diff options
author | Akshay <[email protected]> | 2020-10-16 14:24:46 +0100 |
---|---|---|
committer | Akshay <[email protected]> | 2020-10-16 14:24:46 +0100 |
commit | b19a4a35db4cd951c52e179f3340518c9e2dcc1e (patch) | |
tree | 6d3d840a995d0467577ca645f5838a16d78aa3d6 /src/Environment.hs | |
parent | 684e09298b8453ee56571d8a225e11d7c57e3746 (diff) |
add initial support for variable definition
Diffstat (limited to 'src/Environment.hs')
-rw-r--r-- | src/Environment.hs | 69 |
1 files changed, 69 insertions, 0 deletions
diff --git a/src/Environment.hs b/src/Environment.hs new file mode 100644 index 0000000..7b3f365 --- /dev/null +++ b/src/Environment.hs | |||
@@ -0,0 +1,69 @@ | |||
1 | module Environment ( Env | ||
2 | , setVar | ||
3 | , getVar | ||
4 | , defineVar | ||
5 | , manyBindings | ||
6 | , newEnv | ||
7 | , liftLispResult | ||
8 | , IOResult | ||
9 | ) where | ||
10 | |||
11 | import Control.Monad (liftM, mapM) | ||
12 | import Control.Monad.Except | ||
13 | import Data.IORef | ||
14 | import Data.Maybe (isJust) | ||
15 | import Error.Base (LispError (..), LispResult (..), unwrap) | ||
16 | import Parser (Expr (..)) | ||
17 | |||
18 | type Env = IORef [(String, IORef Expr)] | ||
19 | |||
20 | newEnv :: IO Env | ||
21 | newEnv = newIORef [] | ||
22 | |||
23 | type IOResult = ExceptT LispError IO | ||
24 | |||
25 | liftLispResult :: LispResult a -> IOResult a | ||
26 | liftLispResult (Left err) = throwError err | ||
27 | liftLispResult (Right val) = return val | ||
28 | |||
29 | isBound :: Env -> String -> IO Bool | ||
30 | isBound env var = do | ||
31 | ptr <- readIORef env | ||
32 | return $ isJust $ lookup var ptr | ||
33 | |||
34 | -- env modifiers | ||
35 | |||
36 | getVar :: Env -> String -> IOResult Expr | ||
37 | getVar env var = do | ||
38 | ptr <- liftIO $ readIORef env | ||
39 | maybe (throwError $ UnboundVariable var) | ||
40 | (liftIO . readIORef) | ||
41 | $ lookup var ptr | ||
42 | |||
43 | setVar :: Env -> String -> Expr -> IOResult () | ||
44 | setVar env var val = do | ||
45 | ptr <- liftIO $ readIORef env | ||
46 | maybe (throwError $ UnboundVariable var) | ||
47 | (liftIO . (flip writeIORef val)) | ||
48 | $ lookup var ptr | ||
49 | |||
50 | defineVar :: Env -> String -> Expr -> IOResult () | ||
51 | defineVar env var val = do | ||
52 | alreadyBound <- liftIO $ isBound env var | ||
53 | if alreadyBound | ||
54 | then setVar env var val | ||
55 | else liftIO $ do | ||
56 | newRef <- newIORef val | ||
57 | ptr <- readIORef env | ||
58 | writeIORef env $ (var, newRef):ptr | ||
59 | |||
60 | makeBind :: (String, Expr) -> IO (String, IORef Expr) | ||
61 | makeBind (var, val) = do | ||
62 | n <- newIORef val | ||
63 | return (var, n) | ||
64 | |||
65 | manyBindings :: Env -> [(String, Expr)] -> IO Env | ||
66 | manyBindings env binds = do | ||
67 | ptr <- readIORef env | ||
68 | extendedEnv <- liftM (++ ptr) $ mapM makeBind binds | ||
69 | newIORef extendedEnv | ||