module Language.Scheme.Variables
(
printEnv
, copyEnv
, extendEnv
, findNamespacedEnv
, getVar
, getNamespacedVar
, defineVar
, setVar
, setNamespacedVar
, defineNamespacedVar
, isBound
, isRecBound
, isNamespacedBound
, isNamespacedRecBound
) where
import Language.Scheme.Types
import Control.Monad.Error
import Data.IORef
import qualified Data.Map
printEnv :: Env
-> IO String
printEnv env = do
binds <- liftIO $ readIORef $ bindings env
l <- mapM showVar $ Data.Map.toList binds
return $ unlines l
where
showVar ((_, name), val) = do
v <- liftIO $ readIORef val
return $ name ++ ": " ++ show v
copyEnv :: Env
-> IO Env
copyEnv env = do
binds <- liftIO $ readIORef $ bindings env
bindingListT <- mapM addBinding $ Data.Map.toList binds
bindingList <- newIORef $ Data.Map.fromList bindingListT
return $ Environment (parentEnv env) bindingList
where addBinding ((namespace, name), val) = do
x <- liftIO $ readIORef val
ref <- newIORef x
return ((namespace, name), ref)
extendEnv :: Env
-> [((String, String), LispVal)]
-> IO Env
extendEnv envRef abindings = do bindinglistT <- (mapM addBinding abindings)
bindinglist <- newIORef $ Data.Map.fromList bindinglistT
return $ Environment (Just envRef) bindinglist
where addBinding ((namespace, name), val) = do ref <- newIORef val
return ((namespace, name), ref)
findNamespacedEnv
:: Env
-> String
-> String
-> IO (Maybe Env)
findNamespacedEnv envRef namespace var = do
found <- liftIO $ isNamespacedBound envRef namespace var
if found
then return (Just envRef)
else case parentEnv envRef of
(Just par) -> findNamespacedEnv par namespace var
Nothing -> return Nothing
isBound :: Env
-> String
-> IO Bool
isBound envRef var = isNamespacedBound envRef varNamespace var
isRecBound :: Env
-> String
-> IO Bool
isRecBound envRef var = isNamespacedRecBound envRef varNamespace var
isNamespacedBound
:: Env
-> String
-> String
-> IO Bool
isNamespacedBound envRef namespace var =
(readIORef $ bindings envRef) >>= return . Data.Map.member (namespace, var)
isNamespacedRecBound
:: Env
-> String
-> String
-> IO Bool
isNamespacedRecBound envRef namespace var = do
env <- findNamespacedEnv envRef namespace var
case env of
(Just e) -> isNamespacedBound e namespace var
Nothing -> return False
getVar :: Env
-> String
-> IOThrowsError LispVal
getVar envRef var = getNamespacedVar envRef varNamespace var
getNamespacedVar :: Env
-> String
-> String
-> IOThrowsError LispVal
getNamespacedVar envRef
namespace
var = do binds <- liftIO $ readIORef $ bindings envRef
case Data.Map.lookup (namespace, var) binds of
(Just a) -> liftIO $ readIORef a
Nothing -> case parentEnv envRef of
(Just par) -> getNamespacedVar par namespace var
Nothing -> (throwError $ UnboundVar "Getting an unbound variable" var)
setVar
:: Env
-> String
-> LispVal
-> IOThrowsError LispVal
setVar envRef var value = setNamespacedVar envRef varNamespace var value
defineVar
:: Env
-> String
-> LispVal
-> IOThrowsError LispVal
defineVar envRef var value = defineNamespacedVar envRef varNamespace var value
setNamespacedVar
:: Env
-> String
-> String
-> LispVal
-> IOThrowsError LispVal
setNamespacedVar envRef
namespace
var value = do env <- liftIO $ readIORef $ bindings envRef
case Data.Map.lookup (namespace, var) env of
(Just a) -> do
liftIO $ writeIORef a value
return value
Nothing -> case parentEnv envRef of
(Just par) -> setNamespacedVar par namespace var value
Nothing -> throwError $ UnboundVar "Setting an unbound variable: " var
defineNamespacedVar
:: Env
-> String
-> String
-> LispVal
-> IOThrowsError LispVal
defineNamespacedVar envRef
namespace
var value = do
alreadyDefined <- liftIO $ isNamespacedBound envRef namespace var
if alreadyDefined
then setNamespacedVar envRef namespace var value >> return value
else liftIO $ do
valueRef <- newIORef value
env <- readIORef $ bindings envRef
writeIORef (bindings envRef) (Data.Map.insert (namespace, var) valueRef env)
return value