From b19a4a35db4cd951c52e179f3340518c9e2dcc1e Mon Sep 17 00:00:00 2001
From: Akshay <nerdy@peppe.rs>
Date: Fri, 16 Oct 2020 18:54:46 +0530
Subject: add initial support for variable definition

---
 src/Environment.hs | 69 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 69 insertions(+)
 create mode 100644 src/Environment.hs

(limited to 'src/Environment.hs')

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 @@
+module Environment ( Env
+                   , setVar
+                   , getVar
+                   , defineVar
+                   , manyBindings
+                   , newEnv
+                   , liftLispResult
+                   , IOResult
+                   ) where
+
+import           Control.Monad        (liftM, mapM)
+import           Control.Monad.Except
+import           Data.IORef
+import           Data.Maybe           (isJust)
+import           Error.Base           (LispError (..), LispResult (..), unwrap)
+import           Parser               (Expr (..))
+
+type Env = IORef [(String, IORef Expr)]
+
+newEnv :: IO Env
+newEnv = newIORef []
+
+type IOResult = ExceptT LispError IO
+
+liftLispResult :: LispResult a -> IOResult a
+liftLispResult (Left err)  = throwError err
+liftLispResult (Right val) = return val
+
+isBound :: Env -> String -> IO Bool
+isBound env var = do
+    ptr <- readIORef env
+    return $ isJust $ lookup var ptr
+
+-- env modifiers
+
+getVar :: Env -> String -> IOResult Expr
+getVar env var = do
+    ptr <- liftIO $ readIORef env
+    maybe (throwError $ UnboundVariable var)
+          (liftIO . readIORef)
+          $ lookup var ptr
+
+setVar :: Env -> String -> Expr -> IOResult ()
+setVar env var val = do
+    ptr <- liftIO $ readIORef env
+    maybe (throwError $ UnboundVariable var)
+          (liftIO . (flip writeIORef val))
+          $ lookup var ptr
+
+defineVar :: Env -> String -> Expr -> IOResult ()
+defineVar env var val = do
+    alreadyBound <- liftIO $ isBound env var
+    if alreadyBound
+       then setVar env var val
+       else liftIO $ do
+           newRef <- newIORef val
+           ptr <- readIORef env
+           writeIORef env $ (var, newRef):ptr
+
+makeBind :: (String, Expr) -> IO (String, IORef Expr)
+makeBind (var, val) = do
+    n <- newIORef val
+    return (var, n)
+
+manyBindings :: Env -> [(String, Expr)] -> IO Env
+manyBindings env binds = do
+    ptr <- readIORef env
+    extendedEnv <- liftM (++ ptr) $ mapM makeBind binds
+    newIORef extendedEnv
-- 
cgit v1.2.3