github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-30 02:14:20 +03:00
Code Issues Projects Releases Wiki Activity

Add a runLoopControl handler.

Browse Source
This commit is contained in:
Rob Rix 2018-05-06 14:09:05 -04:00
parent bef772e398
commit 8b679d0f80
1 changed files with 6 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
src/Control/Abstract/Evaluator.hs
View File

@ -61,6 +61,7 @@ module Control.Abstract.Evaluator
, throwBreak , throwBreak
, throwContinue , throwContinue
, catchLoopControl , catchLoopControl
, runLoopControl
, module Control.Effect , module Control.Effect
, module Control.Monad.Effect.Fail , module Control.Monad.Effect.Fail
, module Control.Monad.Effect.Fresh , module Control.Monad.Effect.Fresh
@ -339,3 +340,8 @@ throwContinue = raise . Eff.send . Continue
catchLoopControl :: Member (LoopControl value) effects => Evaluator location term value effects a -> (forall x . LoopControl value x -> Evaluator location term value effects a) -> Evaluator location term value effects a catchLoopControl :: Member (LoopControl value) effects => Evaluator location term value effects a -> (forall x . LoopControl value x -> Evaluator location term value effects a) -> Evaluator location term value effects a
catchLoopControl action handler = raiseHandler (Eff.interpose pure (\ control _ -> lower (handler control))) action catchLoopControl action handler = raiseHandler (Eff.interpose pure (\ control _ -> lower (handler control))) action
runLoopControl :: Evaluator location term value (LoopControl value ': effects) value -> Evaluator location term value effects value
runLoopControl = raiseHandler (Eff.relay pure (\ eff _ -> case eff of
Break value -> pure value
Continue value -> pure value))