github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-01 00:33:59 +03:00
Code Issues Projects Releases Wiki Activity

Add a helper lifting handlers over subterm algebras.

Browse Source
This commit is contained in:
Rob Rix 2018-05-04 16:18:44 -04:00
parent 40af10cf39
commit bc7b639b11
1 changed files with 11 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
src/Control/Effect.hs
View File

@ -9,14 +9,16 @@ module Control.Effect
, State
-- * Handlers
, raiseHandler
, liftHandlerOverSubtermAlgebra
, handleReader
, handleState
) where
import Control.Monad.Effect as Effect
import Control.Monad.Effect.Internal
import Control.Monad.Effect.Reader
import Control.Monad.Effect.Resumable as Resumable
import Control.Monad.Effect.State
import Prologue hiding (throwError)
throwResumable :: (Member (Resumable exc) effects, Effectful m) => exc v -> m effects v
throwResumable = raise . throwError
@ -41,14 +43,14 @@ instance Effectful Eff where
-- | Interpreters determine and interpret a list of effects, optionally taking extra arguments.
--
-- Instances will generally be defined recursively in terms of underlying interpreters, bottoming out with the instance for 'Eff' which uses 'Effect.run' to produce a final value.
-- Instances will generally be defined recursively in terms of underlying interpreters, bottoming out with the instance for 'Eff' which uses 'run' to produce a final value.
class Effectful m => Interpreter m effects | m -> effects where
type Result m effects result
type instance Result m effects result = result
interpret :: m effects result -> Result m effects result
instance Interpreter Eff '[] where
interpret = Effect.run
interpret = run
-- Handlers
@ -57,6 +59,12 @@ instance Interpreter Eff '[] where
raiseHandler :: Effectful m => (Eff effectsA a -> Eff effectsB b) -> m effectsA a -> m effectsB b
raiseHandler handler = raise . handler . lower
liftHandlerOverSubtermAlgebra :: (Effectful m, Functor base) => (m (effect ': effects) a -> m effects a) -> SubtermAlgebra base term (m (effect ': effects) a) -> SubtermAlgebra base term (m effects a)
liftHandlerOverSubtermAlgebra handler recur = handler . recur . fmap (second (raiseHandler weakenEff))
where weakenEff m = case m of
Val a -> Val a
E u q -> E (weaken u) (tsingleton (q >>> weakenEff))
-- | Run a 'Reader' effect in an 'Effectful' context.
handleReader :: Effectful m => info -> m (Reader info ': effects) a -> m effects a
handleReader = raiseHandler . flip runReader