github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2025-01-03 04:51:57 +03:00
Code Issues Projects Releases Wiki Activity

Define an interpose effect.

Browse Source
This commit is contained in:
Rob Rix 2018-10-18 08:21:05 -04:00
parent 8e868cc886
commit b3d85f8832
1 changed files with 21 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
src/Data/Abstract/Value/Concrete.hs
View File

@ -144,10 +144,10 @@ instance ( Carrier sig m
-- loop, otherwise under concrete semantics we run the risk of the
-- conditional always being true and getting stuck in an infinite loop.
let body' = interpose @(Resumable (BaseError (UnspecializedError (Value term address))))
(\(Resumable (BaseError _ _ (UnspecializedError _))) -> throwAbort) $
runWhile (raiseEff body) *> continue
(\(Resumable (BaseError _ _ (UnspecializedError _)) k) -> throwAbort) $
runEvaluator (runWhileC body *> continue)
ifthenelse cond' body' (pure unit)
ifthenelse cond' body' (runWhileC (k unit))
where
loop x = catchLoopControl (fix x) (\ control -> case control of
Break value -> deref value
@ -158,6 +158,24 @@ instance ( Carrier sig m
Continue _ -> loop x)
interpose :: (Member eff sig, HFunctor eff, Carrier sig m)
=> (forall v. eff m (m v) -> m v)
-> Eff (InterposeC eff m) a
-> m a
interpose handler = runInterposeC handler . interpret
newtype InterposeC eff m a = InterposeC ((forall x . eff m (m x) -> m x) -> m a)
runInterposeC :: (forall x . eff m (m x) -> m x) -> InterposeC eff m a -> m a
runInterposeC f (InterposeC m) = m f
instance (Member eff sig, HFunctor eff, Carrier sig m) => Carrier sig (InterposeC eff m) where
gen a = InterposeC (const (gen a))
alg op
| Just e <- prj op = InterposeC (\ handler -> handler (handlePure (runInterposeC handler) e))
| otherwise = InterposeC (\ handler -> alg (handlePure (runInterposeC handler) op))
instance AbstractHole (Value term address) where
hole = Hole