git.iko.soy/effectful
on master help sign in
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.

commitf9bc460236321ababb22aa0c21d759195a9899ad authorAndrzej Rybczak <andrzej@rybczak.net> dateWed 14 Jul 2021, 14:42 (5 years ago) parent69350a4
3 files changed+67−38
compare with master
unifiedsplit
src/Effectful/Handler.hs+20−14 src/Effectful/Internal/Monad.hs+38−18 src/Effectful/Internal/Unlift.hs+9−6
src/Effectful/Handler.hs+20−14
@@ -142,27 +142,31 @@ reinterpretM runHandlerEs handler m = unsafeEff $ \es -> do
142142-- | Create a local unlifting function with the 'SeqUnlift' strategy. For the
143143-- general version see 'localUnlift'.
144144localSeqUnlift
145− :: LocalEnv localEs
145+ :: HasCallStack
146+ => LocalEnv localEs
146147 -- ^ Local environment.
147148 -> ((forall r. Eff localEs r -> Eff es r) -> Eff es a)
148149 -- ^ Continuation with the unlifting function in scope.
149150 -> Eff es a
150−localSeqUnlift env = localUnlift env SeqUnlift
151+localSeqUnlift (LocalEnv les) k = unsafeEff $ \es -> do
152+ unsafeSeqUnliftEff les $ \unlift -> do
153+ (`unEff` es) $ k $ unsafeEff_ . unlift
151154
152155-- | Create a local unlifting function with the 'SeqUnlift' strategy. For the
153156-- general version see 'localUnliftIO'.
154157localSeqUnliftIO
155− :: IOE :> es
158+ :: (HasCallStack, IOE :> es)
156159 => LocalEnv localEs
157160 -- ^ Local environment.
158161 -> ((forall r. Eff localEs r -> IO r) -> IO a)
159162 -- ^ Continuation with the unlifting function in scope.
160163 -> Eff es a
161−localSeqUnliftIO env = localUnliftIO env SeqUnlift
164+localSeqUnliftIO (LocalEnv les) k = liftIO $ unsafeSeqUnliftEff les k
162165
163166-- | Create a local unlifting function with the given strategy.
164167localUnlift
165− :: LocalEnv localEs
168+ :: HasCallStack
169+ => LocalEnv localEs
166170 -- ^ Local environment.
167171 -> UnliftStrategy
168172 -> ((forall r. Eff localEs r -> Eff es r) -> Eff es a)
@@ -178,7 +182,7 @@ localUnlift (LocalEnv les) strategy k = case strategy of
178182
179183-- | Create a local unlifting function with the given strategy.
180184localUnliftIO
181− :: IOE :> es
185+ :: (HasCallStack, IOE :> es)
182186 => LocalEnv localEs
183187 -- ^ Local environment.
184188 -> UnliftStrategy
@@ -200,13 +204,14 @@ localUnliftIO (LocalEnv les) strategy k = case strategy of
200204-- /Note:/ the operation must not run its argument in a separate thread,
201205-- attempting to do so will result in a runtime error.
202206withLiftMap
203− :: IOE :> es
207+ :: (HasCallStack, IOE :> es)
204208 => ((forall a b localEs. (Eff es a -> Eff es b) -> Eff localEs a -> Eff localEs b) -> Eff es r)
205209 -- ^ Continuation with the lifting function in scope.
206210 -> Eff es r
207−withLiftMap k = unsafeWithLiftMapIO $ \liftMap -> do
208− unsafeEff $ \es -> (`unEff` es) $ k $ \f -> do
209− liftMap $ (`unEff` es) . f . liftIO
211+withLiftMap k = unsafeEff $ \es -> do
212+ (`unEff` es) $ k $ \mapIO m -> unsafeEff $ \localEs -> do
213+ unsafeSeqUnliftEff localEs $ \unlift -> do
214+ (`unEff` es) . mapIO . liftIO $ unlift m
210215
211216-- | Utility for lifting 'IO' operations of type
212217--
@@ -234,11 +239,12 @@ withLiftMap k = unsafeWithLiftMapIO $ \liftMap -> do
234239-- forkIOWithUnmask $ \unmask -> unlift $ m $ liftMap unmask
235240-- :}
236241withLiftMapIO
237− :: IOE :> es
242+ :: (HasCallStack, IOE :> es)
238243 => ((forall a b localEs. (IO a -> IO b) -> Eff localEs a -> Eff localEs b) -> Eff es r)
239244 -- ^ Continuation with the lifting function in scope.
240245 -> Eff es r
241−withLiftMapIO = unsafeWithLiftMapIO
246+withLiftMapIO k = k $ \mapIO m -> unsafeEff $ \es -> do
247+ unsafeSeqUnliftEff es $ \unlift -> mapIO $ unlift m
242248
243249----------------------------------------
244250-- Bidirectional lifts
@@ -251,7 +257,7 @@ withLiftMapIO = unsafeWithLiftMapIO
251257-- /Note:/ depending on the operation you're lifting 'localUnlift' along with
252258-- 'withLiftMap' might be enough and is more efficient.
253259localLiftUnlift
254− :: IOE :> es
260+ :: (HasCallStack, IOE :> es)
255261 => LocalEnv localEs
256262 -- ^ Local environment.
257263 -> UnliftStrategy
@@ -277,7 +283,7 @@ localLiftUnlift (LocalEnv les) strategy k = case strategy of
277283-- /Note:/ depending on the operation you're lifting 'localUnliftIO' along with
278284-- 'withLiftMapIO' might be enough and is more efficient.
279285localLiftUnliftIO
280− :: IOE :> es
286+ :: (HasCallStack, IOE :> es)
281287 => LocalEnv localEs
282288 -- ^ Local environment.
283289 -> UnliftStrategy
src/Effectful/Internal/Monad.hs+38−18
@@ -58,17 +58,18 @@ module Effectful.Internal.Monad
5858import Control.Applicative (liftA2)
5959import Control.Concurrent (myThreadId)
6060import Control.Exception
61−import Control.Monad.Base
6261import Control.Monad.Fix
6362import Control.Monad.IO.Class
64−import Control.Monad.IO.Unlift
6563import Control.Monad.Primitive
66−import Control.Monad.Trans.Control
6764import Data.Unique
6865import GHC.Exts (oneShot)
6966import GHC.IO (IO(..))
67+import GHC.Stack (HasCallStack)
7068import System.IO.Unsafe (unsafeDupablePerformIO)
69+import qualified Control.Monad.Base as M
7170import qualified Control.Monad.Catch as E
71+import qualified Control.Monad.IO.Unlift as M
72+import qualified Control.Monad.Trans.Control as M
7273
7374import Effectful.Internal.Effect
7475import Effectful.Internal.Env
@@ -143,13 +144,18 @@ unsafeEff_ m = unsafeEff $ \_ -> m
143144-- /Note:/ the 'IO' operation must not run its argument in a separate thread,
144145-- attempting to do so will result in a runtime error.
145146unsafeWithLiftMapIO
146− :: ((forall a b localEs. (IO a -> IO b) -> Eff localEs a -> Eff localEs b) -> Eff es r)
147+ :: HasCallStack
148+ => ((forall a b localEs. (IO a -> IO b) -> Eff localEs a -> Eff localEs b) -> Eff es r)
147149 -> Eff es r
148150unsafeWithLiftMapIO k = k $ \mapIO m -> unsafeEff $ \es -> do
149151 unsafeSeqUnliftEff es $ \unlift -> mapIO $ unlift m
150152
151153-- | Lower 'Eff' operations into 'IO' ('SeqUnlift').
152−unsafeSeqUnliftEff :: Env es -> ((forall r. Eff es r -> IO r) -> IO a) -> IO a
154+unsafeSeqUnliftEff
155+ :: HasCallStack
156+ => Env es
157+ -> ((forall r. Eff es r -> IO r) -> IO a)
158+ -> IO a
153159unsafeSeqUnliftEff es k = do
154160 tid0 <- myThreadId
155161 k $ \m -> do
@@ -162,7 +168,8 @@ unsafeSeqUnliftEff es k = do
162168
163169-- | Lower 'Eff' operations into 'IO' ('ConcUnlift').
164170unsafeConcUnliftEff
165− :: Env es
171+ :: HasCallStack
172+ => Env es
166173 -> Persistence
167174 -> Limit
168175 -> ((forall r. Eff es r -> IO r) -> IO a)
@@ -283,20 +290,40 @@ runEff m = unEff (evalEffect (IdE (IOE SeqUnlift)) m) =<< emptyEnv
283290instance IOE :> es => MonadIO (Eff es) where
284291 liftIO = unsafeEff_
285292
286−instance IOE :> es => MonadUnliftIO (Eff es) where
287− withRunInIO = unliftEff
293+instance IOE :> es => M.MonadUnliftIO (Eff es) where
294+ withRunInIO = withRunInIO
295+ where
296+ -- A trick to show name of the function in the call stack.
297+ withRunInIO
298+ :: (HasCallStack, IOE :> es)
299+ => ((forall r. Eff es r -> IO r) -> IO a)
300+ -> Eff es a
301+ withRunInIO f = unliftStrategy >>= \case
302+ SeqUnlift -> unsafeEff $ \es -> unsafeSeqUnliftEff es f
303+ ConcUnlift p b -> withUnliftStrategy SeqUnlift $ do
304+ unsafeEff $ \es -> unsafeConcUnliftEff es p b f
288305
289306-- | Instance included for compatibility with existing code, usage of 'liftIO'
290307-- is preferrable.
291−instance IOE :> es => MonadBase IO (Eff es) where
308+instance IOE :> es => M.MonadBase IO (Eff es) where
292309 liftBase = unsafeEff_
293310
294311-- | Instance included for compatibility with existing code, usage of
295312-- 'withRunInIO' is preferrable.
296−instance IOE :> es => MonadBaseControl IO (Eff es) where
313+instance IOE :> es => M.MonadBaseControl IO (Eff es) where
297314 type StM (Eff es) a = a
298− liftBaseWith = unliftEff
299315 restoreM = pure
316+ liftBaseWith = liftBaseWith
317+ where
318+ -- A trick to show name of the function in the call stack.
319+ liftBaseWith
320+ :: (HasCallStack, IOE :> es)
321+ => ((forall r. Eff es r -> IO r) -> IO a)
322+ -> Eff es a
323+ liftBaseWith f = unliftStrategy >>= \case
324+ SeqUnlift -> unsafeEff $ \es -> unsafeSeqUnliftEff es f
325+ ConcUnlift p b -> withUnliftStrategy SeqUnlift $ do
326+ unsafeEff $ \es -> unsafeConcUnliftEff es p b f
300327
301328----------------------------------------
302329-- Primitive
@@ -378,13 +405,6 @@ unliftStrategy = readerEffectM $ \(IdE (IOE unlift)) -> pure unlift
378405withUnliftStrategy :: IOE :> es => UnliftStrategy -> Eff es a -> Eff es a
379406withUnliftStrategy unlift = localEffect $ \_ -> IdE (IOE unlift)
380407
381−-- | Helper for 'MonadBaseControl' and 'MonadUnliftIO' instances.
382−unliftEff :: IOE :> es => ((forall r. Eff es r -> IO r) -> IO a) -> Eff es a
383−unliftEff f = unliftStrategy >>= \case
384− SeqUnlift -> unsafeEff $ \es -> unsafeSeqUnliftEff es f
385− ConcUnlift p b -> withUnliftStrategy SeqUnlift $ do
386− unsafeEff $ \es -> unsafeConcUnliftEff es p b f
387−
388408----------------------------------------
389409-- Helpers
390410
src/Effectful/Internal/Unlift.hs+9−6
@@ -15,6 +15,7 @@ import Control.Monad
1515import GHC.Conc.Sync (ThreadId(..))
1616import GHC.Exts (mkWeak#, mkWeakNoFinalizer#)
1717import GHC.IO (IO(..))
18+import GHC.Stack (HasCallStack)
1819import GHC.Weak (Weak(..))
1920import System.Mem.Weak (deRefWeak)
2021import qualified Data.IntMap.Strict as IM
@@ -25,14 +26,15 @@ import Effectful.Internal.Utils
2526-- | Concurrent unlift that doesn't preserve the environment between calls to
2627-- the unlifting function in threads other than its creator.
2728unsafeEphemeralConcUnliftIO
28− :: Int
29+ :: HasCallStack
30+ => Int
2931 -> ((forall r. m r -> IO r) -> IO a)
3032 -> Env es
3133 -> (forall r. m r -> Env es -> IO r)
3234 -> IO a
3335unsafeEphemeralConcUnliftIO uses k es0 unEff = do
34− when (uses < 0) $ do
35− error $ "ephemeralConcUnliftIO: invalid number of uses: " ++ show uses
36+ unless (uses > 0) $ do
37+ error $ "Invalid number of uses: " ++ show uses
3638 tid0 <- myThreadId
3739 -- Create a copy of the environment as a template for the other threads to
3840 -- use. This can't be done from inside the callback as the environment might
@@ -57,15 +59,16 @@ unsafeEphemeralConcUnliftIO uses k es0 unEff = do
5759-- | Concurrent unlift that preserves the environment between calls to the
5860-- unlifting function within a particular thread.
5961unsafePersistentConcUnliftIO
60− :: Bool
62+ :: HasCallStack
63+ => Bool
6164 -> Int
6265 -> ((forall r. m r -> IO r) -> IO a)
6366 -> Env es
6467 -> (forall r. m r -> Env es -> IO r)
6568 -> IO a
6669unsafePersistentConcUnliftIO cleanUp threads k es0 unEff = do
67− when (threads < 0) $ do
68− error $ "persistentConcUnliftIO: invalid number of threads: " ++ show threads
70+ unless (threads > 0) $ do
71+ error $ "Invalid number of threads: " ++ show threads
6972 tid0 <- myThreadId
7073 -- Create a copy of the environment as a template for the other threads to
7174 -- use. This can't be done from inside the callback as the environment might