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

Add a constructor to bind names.

Browse Source
This commit is contained in:
Rob Rix 2018-05-29 18:43:10 -04:00
parent a1d05dcd3d
commit 6b4d7db192
1 changed files with 9 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,4 +1,4 @@
{-# LANGUAGE GADTs, RankNTypes, TypeOperators #-}
{-# LANGUAGE GADTs, LambdaCase, RankNTypes, TypeOperators #-}
module Control.Abstract.Environment
( Environment
, getEnv
@ -52,14 +52,19 @@ lookupEnv name = fmap Address <$> send (Lookup name)
data Env location return where
Lookup :: Name -> Env location (Maybe location)
Lookup :: Name -> Env location (Maybe location)
Bind :: Name -> location -> Env location ()
runEnv :: Member (State (Environment location)) effects => Environment location -> Evaluator location value (Env location ': effects) a -> Evaluator location value effects a
runEnv defaultEnvironment = interpret (\ (Lookup name) -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv)
runEnv defaultEnvironment = interpret $ \case
Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv
Bind name addr -> modifyEnv (Env.insert name addr)
reinterpretEnv :: Environment location -> Evaluator location value (Env location ': effects) a -> Evaluator location value (State (Environment location) ': effects) a
reinterpretEnv defaultEnvironment = reinterpret (\ (Lookup name) -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv)
reinterpretEnv defaultEnvironment = reinterpret $ \case
Lookup name -> maybe (Env.lookup name defaultEnvironment) Just . Env.lookup name <$> getEnv
Bind name addr -> modifyEnv (Env.insert name addr)
-- | Errors involving the environment.