git.iko.soy/effectful
on master help sign in
Make the Fail effect interpreted
f267f23Andrzej Rybczak
effectful-core/src/Effectful/Fail.hs+10−1
compare with master
unifiedsplit
@@ -1,6 +1,15 @@
1module Effectful.Fail
1module Effectful.Fail
2− ( Fail
2+ ( Fail(..)
3 , runFail
3 , runFail
4 ) where
4 ) where
5
5
6+import Effectful.Error
7+import Effectful.Handler
6import Effectful.Internal.Monad
8import Effectful.Internal.Monad
9+
10+-- | Run the 'Fail' effect via 'Error'.
11+runFail :: Eff (Fail : es) a -> Eff es (Either String a)
12+runFail = reinterpret eff $ \_ -> \case
13+ Fail msg -> throwError msg
14+ where
15+ eff = fmap (either (Left . snd) Right) . runError
effectful-core/src/Effectful/Handler.hs+1−47
@@ -30,56 +30,13 @@ module Effectful.Handler
30
30
31import Control.Monad.IO.Unlift
31import Control.Monad.IO.Unlift
32import GHC.Stack
32import GHC.Stack
33−import qualified Control.Exception as E
34
33
35import Effectful.Internal.Effect
34import Effectful.Internal.Effect
36import Effectful.Internal.Env
35import Effectful.Internal.Env
37import Effectful.Internal.Monad
36import Effectful.Internal.Monad
38
37
39----------------------------------------
38----------------------------------------
40−-- Handler
39+-- Handling effects
41−
42−-- | Opaque representation of the 'Eff' environment at the point of calling the
43−-- 'send' function, i.e. right before the control is passed to the effect
44−-- handler.
45−newtype LocalEnv es = LocalEnv (Env es)
46−
47−-- | Type signature of the effect handler.
48−type EffectHandler e es
49− = forall a localEs. HasCallStack
50− => LocalEnv localEs
51− -- ^ The environment for handling local 'Eff' operations with functions from
52− -- the 'localUnlift' family when given a higher order effect.
53− -> e (Eff localEs) a
54− -- ^ The effect in the local environment.
55− -> Eff es a
56−
57−data Handler :: Effect -> Type where
58− Handler :: !(Env es) -> !(EffectHandler e es) -> Handler e
59−
60−runHandler :: Handler e -> Eff (e : es) a -> Eff es a
61−runHandler e m = unsafeEff $ \es0 -> do
62− size0 <- sizeEnv es0
63− E.bracket (unsafeConsEnv e relinker es0)
64− (unsafeTailEnv size0)
65− (\es -> unEff m es)
66− where
67− relinker :: Relinker Handler e
68− relinker = Relinker $ \relink (Handler env handle) -> do
69− newEnv <- relink env
70− pure $ Handler newEnv handle
71−
72−----------------------------------------
73−-- Sending operations
74−
75−-- | Send an operation of the given effect to its handler for execution.
76−send :: (HasCallStack, e :> es) => e (Eff es) a -> Eff es a
77−send op = unsafeEff $ \es -> do
78− Handler env handle <- getEnv es
79− unEff (handle (LocalEnv es) op) env
80−
81−----------------------------------------
82−-- Interpretation
83
40
84-- | Interpret an effect.
41-- | Interpret an effect.
85interpret
42interpret
@@ -91,9 +48,6 @@ interpret handler m = unsafeEff $ \es -> do
91 les <- forkEnv es
48 les <- forkEnv es
92 (`unEff` es) $ runHandler (Handler les handler) m
49 (`unEff` es) $ runHandler (Handler les handler) m
93
50
94−----------------------------------------
95−-- Reinterpretation
96−
97-- | Interpret an effect using other effects.
51-- | Interpret an effect using other effects.
98reinterpret
52reinterpret
99 :: (Eff handlerEs a -> Eff es b)
53 :: (Eff handlerEs a -> Eff es b)
effectful-core/src/Effectful/Internal/Monad.hs+87−65
@@ -16,8 +16,7 @@ module Effectful.Internal.Monad
16 , unsafeEff_
16 , unsafeEff_
17
17
18 -- * Fail
18 -- * Fail
19− , Fail
19+ , Fail(..)
20− , runFail
21
20
22 -- * IO
21 -- * IO
23 , IOE
22 , IOE
@@ -40,14 +39,25 @@ module Effectful.Internal.Monad
40 , seqUnliftEff
39 , seqUnliftEff
41 , concUnliftEff
40 , concUnliftEff
42
41
43− -- * Primitive effects
42+ -- * Effects
44
43
44+ -- ** Handler
45+ , EffectHandler
46+ , LocalEnv(..)
47+ , Handler(..)
48+ , runHandler
49+
50+ -- *** Sending operations
51+ , send
52+
53+ -- ** Primitive
54+
45− -- ** Running
55+ -- *** Running
46 , runEffect
56 , runEffect
47 , evalEffect
57 , evalEffect
48 , execEffect
58 , execEffect
49
59
50− -- ** Modification
60+ -- *** Modification
51 , getEffect
61 , getEffect
52 , putEffect
62 , putEffect
53 , stateEffect
63 , stateEffect
@@ -57,19 +67,18 @@ module Effectful.Internal.Monad
57
67
58import Control.Applicative (liftA2)
68import Control.Applicative (liftA2)
59import Control.Concurrent (myThreadId)
69import Control.Concurrent (myThreadId)
60−import Control.Exception
61import Control.Monad.Base
70import Control.Monad.Base
62import Control.Monad.Fix
71import Control.Monad.Fix
63import Control.Monad.IO.Class
72import Control.Monad.IO.Class
64import Control.Monad.IO.Unlift
73import Control.Monad.IO.Unlift
65import Control.Monad.Primitive
74import Control.Monad.Primitive
66import Control.Monad.Trans.Control
75import Control.Monad.Trans.Control
67−import Data.Unique
68import GHC.Exts (oneShot)
76import GHC.Exts (oneShot)
69import GHC.IO (IO(..))
77import GHC.IO (IO(..))
70import GHC.Stack (HasCallStack)
78import GHC.Stack (HasCallStack)
71import System.IO.Unsafe (unsafeDupablePerformIO)
79import System.IO.Unsafe (unsafeDupablePerformIO)
72−import qualified Control.Monad.Catch as E
80+import qualified Control.Exception as E
81+import qualified Control.Monad.Catch as C
73
82
74import Effectful.Internal.Effect
83import Effectful.Internal.Effect
75import Effectful.Internal.Env
84import Effectful.Internal.Env
@@ -218,71 +227,43 @@ instance MonadFix (Eff es) where
218----------------------------------------
227----------------------------------------
219-- Exception
228-- Exception
220
229
221−instance E.MonadThrow (Eff es) where
230+instance C.MonadThrow (Eff es) where
222− throwM = unsafeEff_ . throwIO
231+ throwM = unsafeEff_ . E.throwIO
223
232
224−instance E.MonadCatch (Eff es) where
233+instance C.MonadCatch (Eff es) where
225 catch m handler = unsafeEff $ \es -> do
234 catch m handler = unsafeEff $ \es -> do
226 size <- sizeEnv es
235 size <- sizeEnv es
227− unEff m es `catch` \e -> do
236+ unEff m es `E.catch` \e -> do
228 checkSizeEnv size es
237 checkSizeEnv size es
229 unEff (handler e) es
238 unEff (handler e) es
230
239
231−instance E.MonadMask (Eff es) where
240+instance C.MonadMask (Eff es) where
232− mask k = unsafeEff $ \es -> mask $ \restore ->
241+ mask k = unsafeEff $ \es -> E.mask $ \restore ->
233 unEff (k $ \m -> unsafeEff $ restore . unEff m) es
242 unEff (k $ \m -> unsafeEff $ restore . unEff m) es
234
243
235− uninterruptibleMask k = unsafeEff $ \es -> uninterruptibleMask $ \restore ->
244+ uninterruptibleMask k = unsafeEff $ \es -> E.uninterruptibleMask $ \restore ->
236 unEff (k $ \m -> unsafeEff $ restore . unEff m) es
245 unEff (k $ \m -> unsafeEff $ restore . unEff m) es
237
246
238− generalBracket acquire release use = unsafeEff $ \es -> mask $ \restore -> do
247+ generalBracket acquire release use = unsafeEff $ \es -> E.mask $ \restore -> do
239 size <- sizeEnv es
248 size <- sizeEnv es
240 resource <- unEff acquire es
249 resource <- unEff acquire es
241− b <- restore (unEff (use resource) es) `catch` \e -> do
250+ b <- restore (unEff (use resource) es) `E.catch` \e -> do
242 checkSizeEnv size es
251 checkSizeEnv size es
243− _ <- unEff (release resource $ E.ExitCaseException e) es
252+ _ <- unEff (release resource $ C.ExitCaseException e) es
244− throwIO e
253+ E.throwIO e
245 checkSizeEnv size es
254 checkSizeEnv size es
246− c <- unEff (release resource $ E.ExitCaseSuccess b) es
255+ c <- unEff (release resource $ C.ExitCaseSuccess b) es
247 pure (b, c)
256 pure (b, c)
248
257
249----------------------------------------
258----------------------------------------
250-- Fail
259-- Fail
251
260
261+-- | Provide the ability to use the 'MonadFail' instance of 'Eff'.
252−newtype Fail :: Effect where
262+data Fail :: Effect where
253− Fail :: Unique -> Fail m r
263+ Fail :: String -> Fail m a
254−
255−runFail :: Eff (Fail : es) a -> Eff es (Either String a)
256−runFail m = unsafeEff $ \es0 -> mask $ \release -> do
257− -- A unique tag is picked so that different runFail handlers don't catch each
258− -- other's exceptions.
259− tag <- newUnique
260− size0 <- sizeEnv es0
261− es <- unsafeConsEnv (IdE (Fail tag)) noRelinker es0
262− r <- tryFailIO tag (release $ unEff m es) `onException` unsafeTailEnv size0 es
263− unsafeTailEnv size0 es
264− pure r
265
264
266instance Fail :> es => MonadFail (Eff es) where
265instance Fail :> es => MonadFail (Eff es) where
267− fail msg = do
266+ fail = send . Fail
268− IdE (Fail tag) <- getEffect
269− unsafeEff_ . throwIO $ FailEx tag msg
270−
271−--------------------
272−
273−data FailEx = FailEx !Unique String
274−instance Show FailEx where
275− showsPrec p (FailEx _ msg)
276− = ("Effectful.Internal.Monad.FailEx " ++)
277− . showsPrec p msg
278−instance Exception FailEx
279−
280−tryFailIO :: Unique -> IO a -> IO (Either String a)
281−tryFailIO tag m =
282− (Right <$> m) `catch` \err@(FailEx etag msg) -> do
283− if tag == etag
284− then pure $ Left msg
285− else throwIO err
286
267
287----------------------------------------
268----------------------------------------
288-- IO
269-- IO
@@ -413,29 +394,70 @@ withEffToIO f = unliftStrategy >>= \case
413 ConcUnlift p b -> withUnliftStrategy SeqUnlift $ do
394 ConcUnlift p b -> withUnliftStrategy SeqUnlift $ do
414 unsafeEff $ \es -> concUnliftEff es p b f
395 unsafeEff $ \es -> concUnliftEff es p b f
415
396
397+----------------------------------------
398+-- Handler
399+
400+-- | Opaque representation of the 'Eff' environment at the point of calling the
401+-- 'send' function, i.e. right before the control is passed to the effect
402+-- handler.
403+newtype LocalEnv es = LocalEnv (Env es)
404+
405+-- | Type signature of the effect handler.
406+type EffectHandler e es
407+ = forall a localEs. HasCallStack
408+ => LocalEnv localEs
409+ -- ^ Capture of the local environment for handling local 'Eff' operations when
410+ -- @e@ is a higher order effect.
411+ -> e (Eff localEs) a
412+ -- ^ The effect performed in the local environment.
413+ -> Eff es a
414+
415+-- | An effect handler bundled along with its environment.
416+data Handler :: Effect -> Type where
417+ Handler :: !(Env es) -> !(EffectHandler e es) -> Handler e
418+
419+-- | Run the effect with the given handler.
420+runHandler :: Handler e -> Eff (e : es) a -> Eff es a
421+runHandler e m = unsafeEff $ \es0 -> do
422+ size0 <- sizeEnv es0
423+ E.bracket (unsafeConsEnv e relinker es0)
424+ (unsafeTailEnv size0)
425+ (\es -> unEff m es)
426+ where
427+ relinker :: Relinker Handler e
428+ relinker = Relinker $ \relink (Handler env handle) -> do
429+ newEnv <- relink env
430+ pure $ Handler newEnv handle
431+
432+-- | Send an operation of the given effect to its handler for execution.
433+send :: (HasCallStack, e :> es) => e (Eff es) a -> Eff es a
434+send op = unsafeEff $ \es -> do
435+ Handler env handle <- getEnv es
436+ unEff (handle (LocalEnv es) op) env
437+
416----------------------------------------
438----------------------------------------
417-- Helpers
439-- Helpers
418
440
419runEffect :: handler e -> Eff (e : es) a -> Eff es (a, handler e)
441runEffect :: handler e -> Eff (e : es) a -> Eff es (a, handler e)
420runEffect e0 m = unsafeEff $ \es0 -> do
442runEffect e0 m = unsafeEff $ \es0 -> do
421 size0 <- sizeEnv es0
443 size0 <- sizeEnv es0
422− bracket (unsafeConsEnv e0 noRelinker es0)
444+ E.bracket (unsafeConsEnv e0 noRelinker es0)
423− (unsafeTailEnv size0)
445+ (unsafeTailEnv size0)
424− (\es -> (,) <$> unEff m es <*> getEnv es)
446+ (\es -> (,) <$> unEff m es <*> getEnv es)
425
447
426evalEffect :: handler e -> Eff (e : es) a -> Eff es a
448evalEffect :: handler e -> Eff (e : es) a -> Eff es a
427evalEffect e m = unsafeEff $ \es0 -> do
449evalEffect e m = unsafeEff $ \es0 -> do
428 size0 <- sizeEnv es0
450 size0 <- sizeEnv es0
429− bracket (unsafeConsEnv e noRelinker es0)
451+ E.bracket (unsafeConsEnv e noRelinker es0)
430− (unsafeTailEnv size0)
452+ (unsafeTailEnv size0)
431− (\es -> unEff m es)
453+ (\es -> unEff m es)
432
454
433execEffect :: handler e -> Eff (e : es) a -> Eff es (handler e)
455execEffect :: handler e -> Eff (e : es) a -> Eff es (handler e)
434execEffect e0 m = unsafeEff $ \es0 -> do
456execEffect e0 m = unsafeEff $ \es0 -> do
435 size0 <- sizeEnv es0
457 size0 <- sizeEnv es0
436− bracket (unsafeConsEnv e0 noRelinker es0)
458+ E.bracket (unsafeConsEnv e0 noRelinker es0)
437− (unsafeTailEnv size0)
459+ (unsafeTailEnv size0)
438− (\es -> unEff m es *> getEnv es)
460+ (\es -> unEff m es *> getEnv es)
439
461
440getEffect :: e :> es => Eff es (handler e)
462getEffect :: e :> es => Eff es (handler e)
441getEffect = unsafeEff $ \es -> getEnv es
463getEffect = unsafeEff $ \es -> getEnv es
@@ -447,13 +469,13 @@ stateEffect :: e :> es => (handler e -> (a, handler e)) -> Eff es a
447stateEffect f = unsafeEff $ \es -> stateEnv es f
469stateEffect f = unsafeEff $ \es -> stateEnv es f
448
470
449stateEffectM :: e :> es => (handler e -> Eff es (a, handler e)) -> Eff es a
471stateEffectM :: e :> es => (handler e -> Eff es (a, handler e)) -> Eff es a
450−stateEffectM f = unsafeEff $ \es -> mask $ \release -> do
472+stateEffectM f = unsafeEff $ \es -> E.mask $ \release -> do
451 (a, e) <- (\e -> release $ unEff (f e) es) =<< getEnv es
473 (a, e) <- (\e -> release $ unEff (f e) es) =<< getEnv es
452 putEnv es e
474 putEnv es e
453 pure a
475 pure a
454
476
455localEffect :: e :> es => (handler e -> handler e) -> Eff es a -> Eff es a
477localEffect :: e :> es => (handler e -> handler e) -> Eff es a -> Eff es a
456localEffect f m = unsafeEff $ \es -> do
478localEffect f m = unsafeEff $ \es -> do
457− bracket (stateEnv es $ \e -> (e, f e))
479+ E.bracket (stateEnv es $ \e -> (e, f e))
458− (\e -> putEnv es e)
480+ (\e -> putEnv es e)
459− (\_ -> unEff m es)
481+ (\_ -> unEff m es)