git.iko.soy/effectful
on master help sign in
Add HasCallStack to (un)lifting functions
f9bc460Andrzej Rybczak
src/Effectful/Handler.hs+20−14
compare with master
unifiedsplit
@@ -142,27 +142,31 @@ reinterpretM runHandlerEs handler m = unsafeEff $ \es -> do
142-- | Create a local unlifting function with the 'SeqUnlift' strategy. For the
142-- | Create a local unlifting function with the 'SeqUnlift' strategy. For the
143-- general version see 'localUnlift'.
143-- general version see 'localUnlift'.
144localSeqUnlift
144localSeqUnlift
145+ :: HasCallStack
145− :: LocalEnv localEs
146+ => LocalEnv localEs
146 -- ^ Local environment.
147 -- ^ Local environment.
147 -> ((forall r. Eff localEs r -> Eff es r) -> Eff es a)
148 -> ((forall r. Eff localEs r -> Eff es r) -> Eff es a)
148 -- ^ Continuation with the unlifting function in scope.
149 -- ^ Continuation with the unlifting function in scope.
149 -> Eff es a
150 -> 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
151
154
152-- | Create a local unlifting function with the 'SeqUnlift' strategy. For the
155-- | Create a local unlifting function with the 'SeqUnlift' strategy. For the
153-- general version see 'localUnliftIO'.
156-- general version see 'localUnliftIO'.
154localSeqUnliftIO
157localSeqUnliftIO
155− :: IOE :> es
158+ :: (HasCallStack, IOE :> es)
156 => LocalEnv localEs
159 => LocalEnv localEs
157 -- ^ Local environment.
160 -- ^ Local environment.
158 -> ((forall r. Eff localEs r -> IO r) -> IO a)
161 -> ((forall r. Eff localEs r -> IO r) -> IO a)
159 -- ^ Continuation with the unlifting function in scope.
162 -- ^ Continuation with the unlifting function in scope.
160 -> Eff es a
163 -> Eff es a
161−localSeqUnliftIO env = localUnliftIO env SeqUnlift
164+localSeqUnliftIO (LocalEnv les) k = liftIO $ unsafeSeqUnliftEff les k
162
165
163-- | Create a local unlifting function with the given strategy.
166-- | Create a local unlifting function with the given strategy.
164localUnlift
167localUnlift
168+ :: HasCallStack
165− :: LocalEnv localEs
169+ => LocalEnv localEs
166 -- ^ Local environment.
170 -- ^ Local environment.
167 -> UnliftStrategy
171 -> UnliftStrategy
168 -> ((forall r. Eff localEs r -> Eff es r) -> Eff es a)
172 -> ((forall r. Eff localEs r -> Eff es r) -> Eff es a)
@@ -178,7 +182,7 @@ localUnlift (LocalEnv les) strategy k = case strategy of
178
182
179-- | Create a local unlifting function with the given strategy.
183-- | Create a local unlifting function with the given strategy.
180localUnliftIO
184localUnliftIO
181− :: IOE :> es
185+ :: (HasCallStack, IOE :> es)
182 => LocalEnv localEs
186 => LocalEnv localEs
183 -- ^ Local environment.
187 -- ^ Local environment.
184 -> UnliftStrategy
188 -> UnliftStrategy
@@ -200,13 +204,14 @@ localUnliftIO (LocalEnv les) strategy k = case strategy of
200-- /Note:/ the operation must not run its argument in a separate thread,
204-- /Note:/ the operation must not run its argument in a separate thread,
201-- attempting to do so will result in a runtime error.
205-- attempting to do so will result in a runtime error.
202withLiftMap
206withLiftMap
203− :: IOE :> es
207+ :: (HasCallStack, IOE :> es)
204 => ((forall a b localEs. (Eff es a -> Eff es b) -> Eff localEs a -> Eff localEs b) -> Eff es r)
208 => ((forall a b localEs. (Eff es a -> Eff es b) -> Eff localEs a -> Eff localEs b) -> Eff es r)
205 -- ^ Continuation with the lifting function in scope.
209 -- ^ Continuation with the lifting function in scope.
206 -> Eff es r
210 -> Eff es r
207−withLiftMap k = unsafeWithLiftMapIO $ \liftMap -> do
211+withLiftMap k = unsafeEff $ \es -> do
208− unsafeEff $ \es -> (`unEff` es) $ k $ \f -> do
212+ (`unEff` es) $ k $ \mapIO m -> unsafeEff $ \localEs -> do
213+ unsafeSeqUnliftEff localEs $ \unlift -> do
209− liftMap $ (`unEff` es) . f . liftIO
214+ (`unEff` es) . mapIO . liftIO $ unlift m
210
215
211-- | Utility for lifting 'IO' operations of type
216-- | Utility for lifting 'IO' operations of type
212--
217--
@@ -234,11 +239,12 @@ withLiftMap k = unsafeWithLiftMapIO $ \liftMap -> do
234-- forkIOWithUnmask $ \unmask -> unlift $ m $ liftMap unmask
239-- forkIOWithUnmask $ \unmask -> unlift $ m $ liftMap unmask
235-- :}
240-- :}
236withLiftMapIO
241withLiftMapIO
237− :: IOE :> es
242+ :: (HasCallStack, IOE :> es)
238 => ((forall a b localEs. (IO a -> IO b) -> Eff localEs a -> Eff localEs b) -> Eff es r)
243 => ((forall a b localEs. (IO a -> IO b) -> Eff localEs a -> Eff localEs b) -> Eff es r)
239 -- ^ Continuation with the lifting function in scope.
244 -- ^ Continuation with the lifting function in scope.
240 -> Eff es r
245 -> Eff es r
241−withLiftMapIO = unsafeWithLiftMapIO
246+withLiftMapIO k = k $ \mapIO m -> unsafeEff $ \es -> do
247+ unsafeSeqUnliftEff es $ \unlift -> mapIO $ unlift m
242
248
243----------------------------------------
249----------------------------------------
244-- Bidirectional lifts
250-- Bidirectional lifts
@@ -251,7 +257,7 @@ withLiftMapIO = unsafeWithLiftMapIO
251-- /Note:/ depending on the operation you're lifting 'localUnlift' along with
257-- /Note:/ depending on the operation you're lifting 'localUnlift' along with
252-- 'withLiftMap' might be enough and is more efficient.
258-- 'withLiftMap' might be enough and is more efficient.
253localLiftUnlift
259localLiftUnlift
254− :: IOE :> es
260+ :: (HasCallStack, IOE :> es)
255 => LocalEnv localEs
261 => LocalEnv localEs
256 -- ^ Local environment.
262 -- ^ Local environment.
257 -> UnliftStrategy
263 -> UnliftStrategy
@@ -277,7 +283,7 @@ localLiftUnlift (LocalEnv les) strategy k = case strategy of
277-- /Note:/ depending on the operation you're lifting 'localUnliftIO' along with
283-- /Note:/ depending on the operation you're lifting 'localUnliftIO' along with
278-- 'withLiftMapIO' might be enough and is more efficient.
284-- 'withLiftMapIO' might be enough and is more efficient.
279localLiftUnliftIO
285localLiftUnliftIO
280− :: IOE :> es
286+ :: (HasCallStack, IOE :> es)
281 => LocalEnv localEs
287 => LocalEnv localEs
282 -- ^ Local environment.
288 -- ^ Local environment.
283 -> UnliftStrategy
289 -> UnliftStrategy
src/Effectful/Internal/Monad.hs+38−18
@@ -58,17 +58,18 @@ module Effectful.Internal.Monad
58import Control.Applicative (liftA2)
58import Control.Applicative (liftA2)
59import Control.Concurrent (myThreadId)
59import Control.Concurrent (myThreadId)
60import Control.Exception
60import Control.Exception
61−import Control.Monad.Base
62import Control.Monad.Fix
61import Control.Monad.Fix
63import Control.Monad.IO.Class
62import Control.Monad.IO.Class
64−import Control.Monad.IO.Unlift
65import Control.Monad.Primitive
63import Control.Monad.Primitive
66−import Control.Monad.Trans.Control
67import Data.Unique
64import Data.Unique
68import GHC.Exts (oneShot)
65import GHC.Exts (oneShot)
69import GHC.IO (IO(..))
66import GHC.IO (IO(..))
67+import GHC.Stack (HasCallStack)
70import System.IO.Unsafe (unsafeDupablePerformIO)
68import System.IO.Unsafe (unsafeDupablePerformIO)
69+import qualified Control.Monad.Base as M
71import qualified Control.Monad.Catch as E
70import qualified Control.Monad.Catch as E
71+import qualified Control.Monad.IO.Unlift as M
72+import qualified Control.Monad.Trans.Control as M
72
73
73import Effectful.Internal.Effect
74import Effectful.Internal.Effect
74import Effectful.Internal.Env
75import Effectful.Internal.Env
@@ -143,13 +144,18 @@ unsafeEff_ m = unsafeEff $ \_ -> m
143-- /Note:/ the 'IO' operation must not run its argument in a separate thread,
144-- /Note:/ the 'IO' operation must not run its argument in a separate thread,
144-- attempting to do so will result in a runtime error.
145-- attempting to do so will result in a runtime error.
145unsafeWithLiftMapIO
146unsafeWithLiftMapIO
147+ :: HasCallStack
146− :: ((forall a b localEs. (IO a -> IO b) -> Eff localEs a -> Eff localEs b) -> Eff es r)
148+ => ((forall a b localEs. (IO a -> IO b) -> Eff localEs a -> Eff localEs b) -> Eff es r)
147 -> Eff es r
149 -> Eff es r
148unsafeWithLiftMapIO k = k $ \mapIO m -> unsafeEff $ \es -> do
150unsafeWithLiftMapIO k = k $ \mapIO m -> unsafeEff $ \es -> do
149 unsafeSeqUnliftEff es $ \unlift -> mapIO $ unlift m
151 unsafeSeqUnliftEff es $ \unlift -> mapIO $ unlift m
150
152
151-- | Lower 'Eff' operations into 'IO' ('SeqUnlift').
153-- | Lower 'Eff' operations into 'IO' ('SeqUnlift').
154+unsafeSeqUnliftEff
155+ :: HasCallStack
156+ => Env es
152−unsafeSeqUnliftEff :: Env es -> ((forall r. Eff es r -> IO r) -> IO a) -> IO a
157+ -> ((forall r. Eff es r -> IO r) -> IO a)
158+ -> IO a
153unsafeSeqUnliftEff es k = do
159unsafeSeqUnliftEff es k = do
154 tid0 <- myThreadId
160 tid0 <- myThreadId
155 k $ \m -> do
161 k $ \m -> do
@@ -162,7 +168,8 @@ unsafeSeqUnliftEff es k = do
162
168
163-- | Lower 'Eff' operations into 'IO' ('ConcUnlift').
169-- | Lower 'Eff' operations into 'IO' ('ConcUnlift').
164unsafeConcUnliftEff
170unsafeConcUnliftEff
171+ :: HasCallStack
165− :: Env es
172+ => Env es
166 -> Persistence
173 -> Persistence
167 -> Limit
174 -> Limit
168 -> ((forall r. Eff es r -> IO r) -> IO a)
175 -> ((forall r. Eff es r -> IO r) -> IO a)
@@ -283,20 +290,40 @@ runEff m = unEff (evalEffect (IdE (IOE SeqUnlift)) m) =<< emptyEnv
283instance IOE :> es => MonadIO (Eff es) where
290instance IOE :> es => MonadIO (Eff es) where
284 liftIO = unsafeEff_
291 liftIO = unsafeEff_
285
292
286−instance IOE :> es => MonadUnliftIO (Eff es) where
293+instance IOE :> es => M.MonadUnliftIO (Eff es) where
287− withRunInIO = unliftEff
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
288
305
289-- | Instance included for compatibility with existing code, usage of 'liftIO'
306-- | Instance included for compatibility with existing code, usage of 'liftIO'
290-- is preferrable.
307-- is preferrable.
291−instance IOE :> es => MonadBase IO (Eff es) where
308+instance IOE :> es => M.MonadBase IO (Eff es) where
292 liftBase = unsafeEff_
309 liftBase = unsafeEff_
293
310
294-- | Instance included for compatibility with existing code, usage of
311-- | Instance included for compatibility with existing code, usage of
295-- 'withRunInIO' is preferrable.
312-- 'withRunInIO' is preferrable.
296−instance IOE :> es => MonadBaseControl IO (Eff es) where
313+instance IOE :> es => M.MonadBaseControl IO (Eff es) where
297 type StM (Eff es) a = a
314 type StM (Eff es) a = a
298− liftBaseWith = unliftEff
299 restoreM = pure
315 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
300
327
301----------------------------------------
328----------------------------------------
302-- Primitive
329-- Primitive
@@ -378,13 +405,6 @@ unliftStrategy = readerEffectM $ \(IdE (IOE unlift)) -> pure unlift
378withUnliftStrategy :: IOE :> es => UnliftStrategy -> Eff es a -> Eff es a
405withUnliftStrategy :: IOE :> es => UnliftStrategy -> Eff es a -> Eff es a
379withUnliftStrategy unlift = localEffect $ \_ -> IdE (IOE unlift)
406withUnliftStrategy unlift = localEffect $ \_ -> IdE (IOE unlift)
380
407
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−
388----------------------------------------
408----------------------------------------
389-- Helpers
409-- Helpers
390
410
src/Effectful/Internal/Unlift.hs+9−6
@@ -15,6 +15,7 @@ import Control.Monad
15import GHC.Conc.Sync (ThreadId(..))
15import GHC.Conc.Sync (ThreadId(..))
16import GHC.Exts (mkWeak#, mkWeakNoFinalizer#)
16import GHC.Exts (mkWeak#, mkWeakNoFinalizer#)
17import GHC.IO (IO(..))
17import GHC.IO (IO(..))
18+import GHC.Stack (HasCallStack)
18import GHC.Weak (Weak(..))
19import GHC.Weak (Weak(..))
19import System.Mem.Weak (deRefWeak)
20import System.Mem.Weak (deRefWeak)
20import qualified Data.IntMap.Strict as IM
21import qualified Data.IntMap.Strict as IM
@@ -25,14 +26,15 @@ import Effectful.Internal.Utils
25-- | Concurrent unlift that doesn't preserve the environment between calls to
26-- | Concurrent unlift that doesn't preserve the environment between calls to
26-- the unlifting function in threads other than its creator.
27-- the unlifting function in threads other than its creator.
27unsafeEphemeralConcUnliftIO
28unsafeEphemeralConcUnliftIO
29+ :: HasCallStack
28− :: Int
30+ => Int
29 -> ((forall r. m r -> IO r) -> IO a)
31 -> ((forall r. m r -> IO r) -> IO a)
30 -> Env es
32 -> Env es
31 -> (forall r. m r -> Env es -> IO r)
33 -> (forall r. m r -> Env es -> IO r)
32 -> IO a
34 -> IO a
33unsafeEphemeralConcUnliftIO uses k es0 unEff = do
35unsafeEphemeralConcUnliftIO uses k es0 unEff = do
34− when (uses < 0) $ do
36+ unless (uses > 0) $ do
35− error $ "ephemeralConcUnliftIO: invalid number of uses: " ++ show uses
37+ error $ "Invalid number of uses: " ++ show uses
36 tid0 <- myThreadId
38 tid0 <- myThreadId
37 -- Create a copy of the environment as a template for the other threads to
39 -- Create a copy of the environment as a template for the other threads to
38 -- use. This can't be done from inside the callback as the environment might
40 -- use. This can't be done from inside the callback as the environment might
@@ -57,15 +59,16 @@ unsafeEphemeralConcUnliftIO uses k es0 unEff = do
57-- | Concurrent unlift that preserves the environment between calls to the
59-- | Concurrent unlift that preserves the environment between calls to the
58-- unlifting function within a particular thread.
60-- unlifting function within a particular thread.
59unsafePersistentConcUnliftIO
61unsafePersistentConcUnliftIO
62+ :: HasCallStack
60− :: Bool
63+ => Bool
61 -> Int
64 -> Int
62 -> ((forall r. m r -> IO r) -> IO a)
65 -> ((forall r. m r -> IO r) -> IO a)
63 -> Env es
66 -> Env es
64 -> (forall r. m r -> Env es -> IO r)
67 -> (forall r. m r -> Env es -> IO r)
65 -> IO a
68 -> IO a
66unsafePersistentConcUnliftIO cleanUp threads k es0 unEff = do
69unsafePersistentConcUnliftIO cleanUp threads k es0 unEff = do
67− when (threads < 0) $ do
70+ unless (threads > 0) $ do
68− error $ "persistentConcUnliftIO: invalid number of threads: " ++ show threads
71+ error $ "Invalid number of threads: " ++ show threads
69 tid0 <- myThreadId
72 tid0 <- myThreadId
70 -- Create a copy of the environment as a template for the other threads to
73 -- Create a copy of the environment as a template for the other threads to
71 -- use. This can't be done from inside the callback as the environment might
74 -- use. This can't be done from inside the callback as the environment might