|
|
@ -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 |