Prevent internal functions from polluting call stack of effect handlers

effectful-core/src/Effectful/Dispatch/Dynamic.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ImplicitParams #-}
 {-# LANGUAGE UndecidableInstances #-}
 -- | Dynamically dispatched effects.
 module Effectful.Dispatch.Dynamic
@@ -407,7 +408,9 @@ interpret
   -> Eff (e : es) a
   -> Eff      es  a
 interpret handler m = unsafeEff $ \es -> do
-  (`unEff` es) $ runHandler (Handler es handler) m
+  (`unEff` es) $ runHandler (mkHandler es) m
+  where
+    mkHandler es = Handler es (let ?callStack = thawCallStack ?callStack in handler)
 
 -- | Interpret an effect using other, private effects.
 --
@@ -422,7 +425,9 @@ reinterpret
   -> Eff      es  b
 reinterpret runHandlerEs handler m = unsafeEff $ \es -> do
   (`unEff` es) . runHandlerEs . unsafeEff $ \handlerEs -> do
-    (`unEff` es) $ runHandler (Handler handlerEs handler) m
+    (`unEff` es) $ runHandler (mkHandler handlerEs) m
+  where
+    mkHandler es = Handler es (let ?callStack = thawCallStack ?callStack in handler)
 
 -- | Replace the handler of an existing effect with a new one.
 --
@@ -472,9 +477,11 @@ interpose handler m = unsafeEff $ \es -> do
     (\newEs -> do
         -- Replace the original handler with a new one. Note that 'newEs'
         -- will still see the original handler.
-        putEnv es (Handler newEs handler)
+        putEnv es $ mkHandler newEs
         unEff m es
     )
+  where
+    mkHandler es = Handler es (let ?callStack = thawCallStack ?callStack in handler)
 
 -- | Replace the handler of an existing effect with a new one that uses other,
 -- private effects.
@@ -504,9 +511,11 @@ impose runHandlerEs handler m = unsafeEff $ \es -> do
           -- Replace the original handler with a new one. Note that
           -- 'newEs' (and thus 'handlerEs') wil still see the original
           -- handler.
-          putEnv es (Handler handlerEs handler)
+          putEnv es $ mkHandler handlerEs
           unEff m es
     )
+  where
+    mkHandler es = Handler es (let ?callStack = thawCallStack ?callStack in handler)
 
 ----------------------------------------
 -- Unlifts

effectful-core/src/Effectful/Internal/Monad.hs

@@ -508,9 +508,9 @@ data Handler :: Effect -> Type where
 type instance EffectRep Dynamic = Handler
 
 relinkHandler :: Relinker Handler e
-relinkHandler = Relinker $ \relink (Handler handlerEs handle) -> do
+relinkHandler = Relinker $ \relink (Handler handlerEs handler) -> do
   newHandlerEs <- relink handlerEs
-  pure $ Handler newHandlerEs handle
+  pure $ Handler newHandlerEs handler
 
 -- | Run a dynamically dispatched effect with the given handler.
 runHandler :: DispatchOf e ~ Dynamic => Handler e -> Eff (e : es) a -> Eff es a
@@ -527,8 +527,12 @@ send
   -- ^ The operation.
   -> Eff es a
 send op = unsafeEff $ \es -> do
-  Handler handlerEs handle <- getEnv es
-  unEff (handle (LocalEnv es) op) handlerEs
+  Handler handlerEs handler <- getEnv es
+  -- Prevent internal functions that rebind the effect handler from polluting
+  -- its call stack by freezing it. Note that functions 'interpret',
+  -- 'reinterpret', 'interpose' and 'impose' need to thaw it so that useful
+  -- stack frames from inside the effect handler continue to be added.
+  unEff (withFrozenCallStack handler (LocalEnv es) op) handlerEs
 {-# NOINLINE send #-}
 
 ----------------------------------------

effectful-core/src/Effectful/Internal/Utils.hs

@@ -31,6 +31,9 @@ module Effectful.Internal.Utils
     -- * Unique
   , Unique
   , newUnique
+
+  -- * CallStack
+  , thawCallStack
   ) where
 
 import Control.Concurrent.MVar
@@ -39,6 +42,7 @@ import Data.IORef
 import Data.Primitive.ByteArray
 import GHC.Conc.Sync (ThreadId(..))
 import GHC.Exts (Any, RealWorld)
+import GHC.Stack.Types (CallStack(..))
 import Unsafe.Coerce (unsafeCoerce)
 
 #if MIN_VERSION_base(4,19,0)
@@ -177,3 +181,10 @@ instance Eq Unique where
 
 newUnique :: IO Unique
 newUnique = Unique <$> newByteArray 0
+
+----------------------------------------
+
+thawCallStack :: CallStack -> CallStack
+thawCallStack = \case
+  FreezeCallStack cs -> cs
+  cs -> cs