ok

src/Scheme/Env.hs

@@ -0,0 +1,61 @@
+{-# LANGUAGE OverloadedStrings, ExistentialQuantification #-}
+
+module Scheme.Env
+  ( Env
+  , nullEnv
+  , liftThrows
+  , runIOThrows
+  , getVar
+  , setVar
+  , defineVar
+  , isBound )
+  where
+
+type Env = IORef [(String, IORef LispVal)]
+type IOThrowsError = ExceptT LispError IO
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Complex
+import Data.Ratio
+import Control.Monad.Except
+import Data.IORef
+import Control.Applicative
+
+import Scheme.Error
+
+nullEnv :: IO Env
+nullEnv = newIORef []
+
+liftThrows :: ThrowsError a -> IOThrowsError a
+liftThrows (Left err) = throwError err
+liftThrows (Right val) = return val
+
+runIOThrows :: IOThrowsError String -> IO String
+runIOThrows act = runExceptT (trapError act) >>= return . extractValue
+
+isBound :: Env -> String -> IO Bool
+isBound envRef var = readIORef envRef >>= return . maybe False (const True) . lookup var
+
+getVar :: Env -> String -> IOThrowsError LispVal
+getVar envRef var = do env <- liftIO $ readIORef envRef
+                       maybe (throwError $ UnboundVar "Attempting to get unbound variable" var)
+                         (liftIO . readIORef)
+                         (lookup var env)
+
+setVar :: Env -> String -> LispVal -> IOThrowsError LispVal
+setVar envRef var value = do env <- liftIO $ readIORef envRef
+                             maybe (throwError $ UnboundVar "Attempting to get unbound variable" var)
+                               (liftIO . (flip writeIORef value))
+                               (lookup var env)
+                             return value
+
+defineVar :: Env -> String -> LispVal -> IOThrowsError LispVal
+defineVar envRef var value = do
+  alreadyDefined <- liftIO $ isBound envRef var
+  if alreadyDefined
+    then setVar envRef var value >> return value
+    else liftIO $ do valueRef <- newIORef value
+                     env <- readIORef envRef
+                     _ <- writeIORef envRef ((var, valueRef):env)
+                     return value

stack.yaml.lock

@@ -0,0 +1,12 @@
+# This file was autogenerated by Stack.
+# You should not edit this file by hand.
+# For more information, please see the documentation at:
+#   https://docs.haskellstack.org/en/stable/lock_files
+
+packages: []
+snapshots:
+- completed:
+    size: 535256
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/9/3.yaml
+    sha256: 124a1da64177db7c1a46cb127f2ad8ba8e2c5dde0abeafe445fdacc61e723278
+  original: lts-9.3