Add HasCallStack to (un)lifting functions

Now if an unlifting function fails due to insufficient limit, you'll get a nice
call stack that allows to track the origin of the problem easily.

src/Effectful/Handler.hs

@@ -142,27 +142,31 @@ reinterpretM runHandlerEs handler m = unsafeEff $ \es -> do
 -- | Create a local unlifting function with the 'SeqUnlift' strategy. For the
 -- general version see 'localUnlift'.
 localSeqUnlift
-  :: LocalEnv localEs
+  :: HasCallStack
+  => LocalEnv localEs
   -- ^ Local environment.
   -> ((forall r. Eff localEs r -> Eff es r) -> Eff es a)
   -- ^ Continuation with the unlifting function in scope.
   -> Eff es a
-localSeqUnlift env = localUnlift env SeqUnlift
+localSeqUnlift (LocalEnv les) k = unsafeEff $ \es -> do
+  unsafeSeqUnliftEff les $ \unlift -> do
+    (`unEff` es) $ k $ unsafeEff_ . unlift
 
 -- | Create a local unlifting function with the 'SeqUnlift' strategy. For the
 -- general version see 'localUnliftIO'.
 localSeqUnliftIO
-  :: IOE :> es
+  :: (HasCallStack, IOE :> es)
   => LocalEnv localEs
   -- ^ Local environment.
   -> ((forall r. Eff localEs r -> IO r) -> IO a)
   -- ^ Continuation with the unlifting function in scope.
   -> Eff es a
-localSeqUnliftIO env = localUnliftIO env SeqUnlift
+localSeqUnliftIO (LocalEnv les) k = liftIO $ unsafeSeqUnliftEff les k
 
 -- | Create a local unlifting function with the given strategy.
 localUnlift
-  :: LocalEnv localEs
+  :: HasCallStack
+  => LocalEnv localEs
   -- ^ Local environment.
   -> UnliftStrategy
   -> ((forall r. Eff localEs r -> Eff es r) -> Eff es a)
@@ -178,7 +182,7 @@ localUnlift (LocalEnv les) strategy k = case strategy of
 
 -- | Create a local unlifting function with the given strategy.
 localUnliftIO
-  :: IOE :> es
+  :: (HasCallStack, IOE :> es)
   => LocalEnv localEs
   -- ^ Local environment.
   -> UnliftStrategy
@@ -200,13 +204,14 @@ localUnliftIO (LocalEnv les) strategy k = case strategy of
 -- /Note:/ the operation must not run its argument in a separate thread,
 -- attempting to do so will result in a runtime error.
 withLiftMap
-  :: IOE :> es
+  :: (HasCallStack, IOE :> es)
   => ((forall a b localEs. (Eff es a -> Eff es b) -> Eff localEs a -> Eff localEs b) -> Eff es r)
   -- ^ Continuation with the lifting function in scope.
   -> Eff es r
-withLiftMap k = unsafeWithLiftMapIO $ \liftMap -> do
-  unsafeEff $ \es -> (`unEff` es) $ k $ \f -> do
-    liftMap $ (`unEff` es) . f . liftIO
+withLiftMap k = unsafeEff $ \es -> do
+  (`unEff` es) $ k $ \mapIO m -> unsafeEff $ \localEs -> do
+    unsafeSeqUnliftEff localEs $ \unlift -> do
+      (`unEff` es) . mapIO . liftIO $ unlift m
 
 -- | Utility for lifting 'IO' operations of type
 --
@@ -234,11 +239,12 @@ withLiftMap k = unsafeWithLiftMapIO $ \liftMap -> do
 --     forkIOWithUnmask $ \unmask -> unlift $ m $ liftMap unmask
 -- :}
 withLiftMapIO
-  :: IOE :> es
+  :: (HasCallStack, IOE :> es)
   => ((forall a b localEs. (IO a -> IO b) -> Eff localEs a -> Eff localEs b) -> Eff es r)
   -- ^ Continuation with the lifting function in scope.
   -> Eff es r
-withLiftMapIO = unsafeWithLiftMapIO
+withLiftMapIO k = k $ \mapIO m -> unsafeEff $ \es -> do
+  unsafeSeqUnliftEff es $ \unlift -> mapIO $ unlift m
 
 ----------------------------------------
 -- Bidirectional lifts
@@ -251,7 +257,7 @@ withLiftMapIO = unsafeWithLiftMapIO
 -- /Note:/ depending on the operation you're lifting 'localUnlift' along with
 -- 'withLiftMap' might be enough and is more efficient.
 localLiftUnlift
-  :: IOE :> es
+  :: (HasCallStack, IOE :> es)
   => LocalEnv localEs
   -- ^ Local environment.
   -> UnliftStrategy
@@ -277,7 +283,7 @@ localLiftUnlift (LocalEnv les) strategy k = case strategy of
 -- /Note:/ depending on the operation you're lifting 'localUnliftIO' along with
 -- 'withLiftMapIO' might be enough and is more efficient.
 localLiftUnliftIO
-  :: IOE :> es
+  :: (HasCallStack, IOE :> es)
   => LocalEnv localEs
   -- ^ Local environment.
   -> UnliftStrategy

src/Effectful/Internal/Monad.hs

@@ -58,17 +58,18 @@ module Effectful.Internal.Monad
 import Control.Applicative (liftA2)
 import Control.Concurrent (myThreadId)
 import Control.Exception
-import Control.Monad.Base
 import Control.Monad.Fix
 import Control.Monad.IO.Class
-import Control.Monad.IO.Unlift
 import Control.Monad.Primitive
-import Control.Monad.Trans.Control
 import Data.Unique
 import GHC.Exts (oneShot)
 import GHC.IO (IO(..))
+import GHC.Stack (HasCallStack)
 import System.IO.Unsafe (unsafeDupablePerformIO)
+import qualified Control.Monad.Base as M
 import qualified Control.Monad.Catch as E
+import qualified Control.Monad.IO.Unlift as M
+import qualified Control.Monad.Trans.Control as M
 
 import Effectful.Internal.Effect
 import Effectful.Internal.Env
@@ -143,13 +144,18 @@ unsafeEff_ m = unsafeEff $ \_ -> m
 -- /Note:/ the 'IO' operation must not run its argument in a separate thread,
 -- attempting to do so will result in a runtime error.
 unsafeWithLiftMapIO
-  :: ((forall a b localEs. (IO a -> IO b) -> Eff localEs a -> Eff localEs b) -> Eff es r)
+  :: HasCallStack
+  => ((forall a b localEs. (IO a -> IO b) -> Eff localEs a -> Eff localEs b) -> Eff es r)
   -> Eff es r
 unsafeWithLiftMapIO k = k $ \mapIO m -> unsafeEff $ \es -> do
   unsafeSeqUnliftEff es $ \unlift -> mapIO $ unlift m
 
 -- | Lower 'Eff' operations into 'IO' ('SeqUnlift').
-unsafeSeqUnliftEff :: Env es -> ((forall r. Eff es r -> IO r) -> IO a) -> IO a
+unsafeSeqUnliftEff
+  :: HasCallStack
+  => Env es
+  -> ((forall r. Eff es r -> IO r) -> IO a)
+  -> IO a
 unsafeSeqUnliftEff es k = do
   tid0 <- myThreadId
   k $ \m -> do
@@ -162,7 +168,8 @@ unsafeSeqUnliftEff es k = do
 
 -- | Lower 'Eff' operations into 'IO' ('ConcUnlift').
 unsafeConcUnliftEff
-  :: Env es
+  :: HasCallStack
+  => Env es
   -> Persistence
   -> Limit
   -> ((forall r. Eff es r -> IO r) -> IO a)
@@ -283,20 +290,40 @@ runEff m = unEff (evalEffect (IdE (IOE SeqUnlift)) m) =<< emptyEnv
 instance IOE :> es => MonadIO (Eff es) where
   liftIO = unsafeEff_
 
-instance IOE :> es => MonadUnliftIO (Eff es) where
-  withRunInIO = unliftEff
+instance IOE :> es => M.MonadUnliftIO (Eff es) where
+  withRunInIO = withRunInIO
+    where
+      -- A trick to show name of the function in the call stack.
+      withRunInIO
+        :: (HasCallStack, IOE :> es)
+        => ((forall r. Eff es r -> IO r) -> IO a)
+        -> Eff es a
+      withRunInIO f = unliftStrategy >>= \case
+        SeqUnlift -> unsafeEff $ \es -> unsafeSeqUnliftEff es f
+        ConcUnlift p b -> withUnliftStrategy SeqUnlift $ do
+          unsafeEff $ \es -> unsafeConcUnliftEff es p b f
 
 -- | Instance included for compatibility with existing code, usage of 'liftIO'
 -- is preferrable.
-instance IOE :> es => MonadBase IO (Eff es) where
+instance IOE :> es => M.MonadBase IO (Eff es) where
   liftBase = unsafeEff_
 
 -- | Instance included for compatibility with existing code, usage of
 -- 'withRunInIO' is preferrable.
-instance IOE :> es => MonadBaseControl IO (Eff es) where
+instance IOE :> es => M.MonadBaseControl IO (Eff es) where
   type StM (Eff es) a = a
-  liftBaseWith = unliftEff
   restoreM = pure
+  liftBaseWith = liftBaseWith
+    where
+      -- A trick to show name of the function in the call stack.
+      liftBaseWith
+        :: (HasCallStack, IOE :> es)
+        => ((forall r. Eff es r -> IO r) -> IO a)
+        -> Eff es a
+      liftBaseWith f = unliftStrategy >>= \case
+        SeqUnlift -> unsafeEff $ \es -> unsafeSeqUnliftEff es f
+        ConcUnlift p b -> withUnliftStrategy SeqUnlift $ do
+          unsafeEff $ \es -> unsafeConcUnliftEff es p b f
 
 ----------------------------------------
 -- Primitive
@@ -378,13 +405,6 @@ unliftStrategy = readerEffectM $ \(IdE (IOE unlift)) -> pure unlift
 withUnliftStrategy :: IOE :> es => UnliftStrategy -> Eff es a -> Eff es a
 withUnliftStrategy unlift = localEffect $ \_ -> IdE (IOE unlift)
 
--- | Helper for 'MonadBaseControl' and 'MonadUnliftIO' instances.
-unliftEff :: IOE :> es => ((forall r. Eff es r -> IO r) -> IO a) -> Eff es a
-unliftEff f = unliftStrategy >>= \case
-  SeqUnlift -> unsafeEff $ \es -> unsafeSeqUnliftEff es f
-  ConcUnlift p b -> withUnliftStrategy SeqUnlift $ do
-    unsafeEff $ \es -> unsafeConcUnliftEff es p b f
-
 ----------------------------------------
 -- Helpers
 

src/Effectful/Internal/Unlift.hs

@@ -15,6 +15,7 @@ import Control.Monad
 import GHC.Conc.Sync (ThreadId(..))
 import GHC.Exts (mkWeak#, mkWeakNoFinalizer#)
 import GHC.IO (IO(..))
+import GHC.Stack (HasCallStack)
 import GHC.Weak (Weak(..))
 import System.Mem.Weak (deRefWeak)
 import qualified Data.IntMap.Strict as IM
@@ -25,14 +26,15 @@ import Effectful.Internal.Utils
 -- | Concurrent unlift that doesn't preserve the environment between calls to
 -- the unlifting function in threads other than its creator.
 unsafeEphemeralConcUnliftIO
-  :: Int
+  :: HasCallStack
+  => Int
   -> ((forall r. m r -> IO r) -> IO a)
   -> Env es
   -> (forall r. m r -> Env es -> IO r)
   -> IO a
 unsafeEphemeralConcUnliftIO uses k es0 unEff = do
-  when (uses < 0) $ do
-    error $ "ephemeralConcUnliftIO: invalid number of uses: " ++ show uses
+  unless (uses > 0) $ do
+    error $ "Invalid number of uses: " ++ show uses
   tid0 <- myThreadId
   -- Create a copy of the environment as a template for the other threads to
   -- use. This can't be done from inside the callback as the environment might
@@ -57,15 +59,16 @@ unsafeEphemeralConcUnliftIO uses k es0 unEff = do
 -- | Concurrent unlift that preserves the environment between calls to the
 -- unlifting function within a particular thread.
 unsafePersistentConcUnliftIO
-  :: Bool
+  :: HasCallStack
+  => Bool
   -> Int
   -> ((forall r. m r -> IO r) -> IO a)
   -> Env es
   -> (forall r. m r -> Env es -> IO r)
   -> IO a
 unsafePersistentConcUnliftIO cleanUp threads k es0 unEff = do
-  when (threads < 0) $ do
-    error $ "persistentConcUnliftIO: invalid number of threads: " ++ show threads
+  unless (threads > 0) $ do
+    error $ "Invalid number of threads: " ++ show threads
   tid0 <- myThreadId
   -- Create a copy of the environment as a template for the other threads to
   -- use. This can't be done from inside the callback as the environment might