github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-19 04:41:47 +03:00
Code Issues Projects Releases Wiki Activity

Add a constructor for closure over the environment.

Browse Source
This commit is contained in:
Rob Rix 2018-05-29 21:09:00 -04:00
parent 7c7204eec8
commit b73de43e97
1 changed files with 7 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
src/Control/Abstract/Environment.hs
View File

@ -10,6 +10,7 @@ module Control.Abstract.Environment
, lookupEnv
, bind
, bindAll
, close
, Env(..)
, runEnv
, reinterpretEnv
@ -67,10 +68,14 @@ bind name addr = send (Bind name (unAddress addr))
bindAll :: Member (Env location) effects => Environment location -> Evaluator location value effects ()
bindAll = foldr ((>>) . uncurry bind . second Address) (pure ()) . Env.pairs
close :: Member (Env location) effects => Set Name -> Evaluator location value effects (Environment location)
close = send . Close
data Env location return where
Lookup :: Name -> Env location (Maybe location)
Bind :: Name -> location -> Env location ()
Close :: Set Name -> Env location (Environment location)
Push :: Env location ()
Pop :: Env location ()
@ -79,6 +84,7 @@ runEnv :: Member (State (Environment location)) effects => Environment location
runEnv defaultEnvironment = interpret $ \case
Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv
Bind name addr -> modifyEnv (Env.insert name addr)
Close names -> Env.intersect names <$> getEnv
Push -> modifyEnv Env.push
Pop -> modifyEnv Env.pop
@ -86,6 +92,7 @@ reinterpretEnv :: Environment location -> Evaluator location value (Env location
reinterpretEnv defaultEnvironment = reinterpret $ \case
Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv
Bind name addr -> modifyEnv (Env.insert name addr)
Close names -> Env.intersect names <$> getEnv
Push -> modifyEnv Env.push
Pop -> modifyEnv Env.pop