@@ -16,8 +16,7 @@ module Effectful.Internal.Monad
1616 , unsafeEff_
1717
1818 -- * Fail
19− , Fail
20− , runFail
19+ , Fail(..)
2120
2221 -- * IO
2322 , IOE
@@ -40,14 +39,25 @@ module Effectful.Internal.Monad
4039 , seqUnliftEff
4140 , concUnliftEff
4241
43− -- * Primitive effects
42+ -- * Effects
4443
45− -- ** Running
44+ -- ** Handler
45+ , EffectHandler
46+ , LocalEnv(..)
47+ , Handler(..)
48+ , runHandler
49+
50+ -- *** Sending operations
51+ , send
52+
53+ -- ** Primitive
54+
55+ -- *** Running
4656 , runEffect
4757 , evalEffect
4858 , execEffect
4959
50− -- ** Modification
60+ -- *** Modification
5161 , getEffect
5262 , putEffect
5363 , stateEffect
@@ -57,19 +67,18 @@ module Effectful.Internal.Monad
5767
5868import Control.Applicative (liftA2)
5969import Control.Concurrent (myThreadId)
60−import Control.Exception
6170import Control.Monad.Base
6271import Control.Monad.Fix
6372import Control.Monad.IO.Class
6473import Control.Monad.IO.Unlift
6574import Control.Monad.Primitive
6675import Control.Monad.Trans.Control
67−import Data.Unique
6876import GHC.Exts (oneShot)
6977import GHC.IO (IO(..))
7078import GHC.Stack (HasCallStack)
7179import 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
7382
7483import Effectful.Internal.Effect
7584import Effectful.Internal.Env
@@ -218,71 +227,43 @@ instance MonadFix (Eff es) where
218227----------------------------------------
219228-- Exception
220229
221−instance E.MonadThrow (Eff es) where
222− throwM = unsafeEff_ . throwIO
230+instance C.MonadThrow (Eff es) where
231+ throwM = unsafeEff_ . E.throwIO
223232
224−instance E.MonadCatch (Eff es) where
233+instance C.MonadCatch (Eff es) where
225234 catch m handler = unsafeEff $ \es -> do
226235 size <- sizeEnv es
227− unEff m es `catch` \e -> do
236+ unEff m es `E.catch` \e -> do
228237 checkSizeEnv size es
229238 unEff (handler e) es
230239
231−instance E.MonadMask (Eff es) where
232− mask k = unsafeEff $ \es -> mask $ \restore ->
240+instance C.MonadMask (Eff es) where
241+ mask k = unsafeEff $ \es -> E.mask $ \restore ->
233242 unEff (k $ \m -> unsafeEff $ restore . unEff m) es
234243
235− uninterruptibleMask k = unsafeEff $ \es -> uninterruptibleMask $ \restore ->
244+ uninterruptibleMask k = unsafeEff $ \es -> E.uninterruptibleMask $ \restore ->
236245 unEff (k $ \m -> unsafeEff $ restore . unEff m) es
237246
238− generalBracket acquire release use = unsafeEff $ \es -> mask $ \restore -> do
247+ generalBracket acquire release use = unsafeEff $ \es -> E.mask $ \restore -> do
239248 size <- sizeEnv es
240249 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
242251 checkSizeEnv size es
243− _ <- unEff (release resource $ E.ExitCaseException e) es
244− throwIO e
252+ _ <- unEff (release resource $ C.ExitCaseException e) es
253+ E.throwIO e
245254 checkSizeEnv size es
246− c <- unEff (release resource $ E.ExitCaseSuccess b) es
255+ c <- unEff (release resource $ C.ExitCaseSuccess b) es
247256 pure (b, c)
248257
249258----------------------------------------
250259-- Fail
251260
252−newtype Fail :: Effect where
253− Fail :: Unique -> Fail m r
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
261+-- | Provide the ability to use the 'MonadFail' instance of 'Eff'.
262+data Fail :: Effect where
263+ Fail :: String -> Fail m a
265264
266265instance Fail :> es => MonadFail (Eff es) where
267− fail msg = do
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
266+ fail = send . Fail
286267
287268----------------------------------------
288269-- IO
@@ -413,29 +394,70 @@ withEffToIO f = unliftStrategy >>= \case
413394 ConcUnlift p b -> withUnliftStrategy SeqUnlift $ do
414395 unsafeEff $ \es -> concUnliftEff es p b f
415396
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+
416438----------------------------------------
417439-- Helpers
418440
419441runEffect :: handler e -> Eff (e : es) a -> Eff es (a, handler e)
420442runEffect e0 m = unsafeEff $ \es0 -> do
421443 size0 <- sizeEnv es0
422− bracket (unsafeConsEnv e0 noRelinker es0)
423− (unsafeTailEnv size0)
424− (\es -> (,) <$> unEff m es <*> getEnv es)
444+ E.bracket (unsafeConsEnv e0 noRelinker es0)
445+ (unsafeTailEnv size0)
446+ (\es -> (,) <$> unEff m es <*> getEnv es)
425447
426448evalEffect :: handler e -> Eff (e : es) a -> Eff es a
427449evalEffect e m = unsafeEff $ \es0 -> do
428450 size0 <- sizeEnv es0
429− bracket (unsafeConsEnv e noRelinker es0)
430− (unsafeTailEnv size0)
431− (\es -> unEff m es)
451+ E.bracket (unsafeConsEnv e noRelinker es0)
452+ (unsafeTailEnv size0)
453+ (\es -> unEff m es)
432454
433455execEffect :: handler e -> Eff (e : es) a -> Eff es (handler e)
434456execEffect e0 m = unsafeEff $ \es0 -> do
435457 size0 <- sizeEnv es0
436− bracket (unsafeConsEnv e0 noRelinker es0)
437− (unsafeTailEnv size0)
438− (\es -> unEff m es *> getEnv es)
458+ E.bracket (unsafeConsEnv e0 noRelinker es0)
459+ (unsafeTailEnv size0)
460+ (\es -> unEff m es *> getEnv es)
439461
440462getEffect :: e :> es => Eff es (handler e)
441463getEffect = unsafeEff $ \es -> getEnv es
@@ -447,13 +469,13 @@ stateEffect :: e :> es => (handler e -> (a, handler e)) -> Eff es a
447469stateEffect f = unsafeEff $ \es -> stateEnv es f
448470
449471stateEffectM :: 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
451473 (a, e) <- (\e -> release $ unEff (f e) es) =<< getEnv es
452474 putEnv es e
453475 pure a
454476
455477localEffect :: e :> es => (handler e -> handler e) -> Eff es a -> Eff es a
456478localEffect f m = unsafeEff $ \es -> do
457− bracket (stateEnv es $ \e -> (e, f e))
458− (\e -> putEnv es e)
459− (\_ -> unEff m es)
479+ E.bracket (stateEnv es $ \e -> (e, f e))
480+ (\e -> putEnv es e)
481+ (\_ -> unEff m es)