module Language.Scheme.Variables
(
printEnv
, recPrintEnv
, recExportsFromEnv
, exportsFromEnv
, copyEnv
, extendEnv
, importEnv
, topmostEnv
, nullEnvWithParent
, findNamespacedEnv
, macroNamespace
, varNamespace
, getVar
, getVar'
, getNamespacedVar
, getNamespacedVar'
, getNamespacedRef
, defineVar
, defineNamespacedVar
, setVar
, setNamespacedVar
, updateObject
, updateNamespacedObject
, isBound
, isRecBound
, isNamespacedRecBound
, derefPtr
, recDerefPtrs
, safeRecDerefPtrs
, recDerefToFnc
) where
import Language.Scheme.Types
import Control.Monad.Error
import Data.Array
import Data.IORef
import qualified Data.Map
macroNamespace :: Char
macroNamespace = 'm'
varNamespace :: Char
varNamespace = 'v'
getVarName :: Char -> String -> String
getVarName namespace name = (namespace : ('_' : name))
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
recPrintEnv :: Env -> IO String
recPrintEnv env = do
envStr <- liftIO $ printEnv env
case parentEnv env of
Just par -> do
parEnvStr <- liftIO $ recPrintEnv par
return $ envStr ++ "\n" ++ parEnvStr
Nothing -> return envStr
recExportsFromEnv :: Env -> IO [LispVal]
recExportsFromEnv env = do
xs <- exportsFromEnv env
case parentEnv env of
Just par -> do
pxs <- liftIO $ recExportsFromEnv par
return $ xs ++ pxs
Nothing -> return xs
exportsFromEnv :: Env
-> IO [LispVal]
exportsFromEnv env = do
binds <- liftIO $ readIORef $ bindings env
return $ getExports [] $ fst $ unzip $ Data.Map.toList binds
where
getExports acc (('m':'_':b) : bs) = getExports (Atom b:acc) bs
getExports acc (('v':'_':b) : bs) = getExports (Atom b:acc) bs
getExports acc (_ : bs) = getExports acc bs
getExports acc [] = acc
copyEnv :: Env
-> IO Env
copyEnv env = do
ptrs <- liftIO $ readIORef $ pointers env
ptrList <- newIORef ptrs
binds <- liftIO $ readIORef $ bindings env
bindingListT <- mapM addBinding $ Data.Map.toList binds
bindingList <- newIORef $ Data.Map.fromList bindingListT
return $ Environment (parentEnv env) bindingList ptrList
where addBinding (name, val) = do
x <- liftIO $ readIORef val
ref <- newIORef x
return (name, ref)
importEnv
:: Env
-> Env
-> IO Env
importEnv dEnv sEnv = do
sPtrs <- liftIO $ readIORef $ pointers sEnv
dPtrs <- liftIO $ readIORef $ pointers dEnv
writeIORef (pointers dEnv) $ Data.Map.union sPtrs dPtrs
sBinds <- liftIO $ readIORef $ bindings sEnv
dBinds <- liftIO $ readIORef $ bindings dEnv
writeIORef (bindings dEnv) $ Data.Map.union sBinds dBinds
case parentEnv sEnv of
Just ps -> importEnv dEnv ps
Nothing -> return dEnv
extendEnv :: Env
-> [((Char, String), LispVal)]
-> IO Env
extendEnv envRef abindings = do
bindinglistT <- (mapM addBinding abindings)
bindinglist <- newIORef $ Data.Map.fromList bindinglistT
nullPointers <- newIORef $ Data.Map.fromList []
return $ Environment (Just envRef) bindinglist nullPointers
where addBinding ((namespace, name), val) = do ref <- newIORef val
return (getVarName namespace name, ref)
topmostEnv :: Env -> IO Env
topmostEnv envRef = do
case parentEnv envRef of
Just p -> topmostEnv p
Nothing -> return envRef
nullEnvWithParent :: Env -> IO Env
nullEnvWithParent p = do
Environment _ binds ptrs <- nullEnv
return $ Environment (Just p) binds ptrs
findNamespacedEnv
:: Env
-> Char
-> 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 = isNamespacedBound envRef varNamespace
isRecBound :: Env
-> String
-> IO Bool
isRecBound envRef = isNamespacedRecBound envRef varNamespace
isNamespacedBound
:: Env
-> Char
-> String
-> IO Bool
isNamespacedBound envRef namespace var =
readIORef (bindings envRef) >>= return . Data.Map.member (getVarName namespace var)
isNamespacedRecBound
:: Env
-> Char
-> 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 = getNamespacedVar envRef varNamespace
getVar' :: Env
-> String
-> IOThrowsError (Maybe LispVal)
getVar' envRef = getNamespacedVar' envRef varNamespace
getNamespacedRef :: Env
-> Char
-> String
-> IOThrowsError (IORef LispVal)
getNamespacedRef envRef
namespace
var = do
v <- getNamespacedObj' envRef namespace var return
case v of
Just a -> return a
Nothing -> (throwError $ UnboundVar "Getting an unbound variable" var)
getNamespacedVar :: Env
-> Char
-> String
-> IOThrowsError LispVal
getNamespacedVar envRef
namespace
var = do
v <- getNamespacedVar' envRef namespace var
case v of
Just a -> return a
Nothing -> (throwError $ UnboundVar "Getting an unbound variable" var)
getNamespacedVar' :: Env
-> Char
-> String
-> IOThrowsError (Maybe LispVal)
getNamespacedVar' envRef
namespace
var = do
getNamespacedObj' envRef namespace var readIORef
getNamespacedObj' :: Env
-> Char
-> String
-> (IORef LispVal -> IO a)
-> IOThrowsError (Maybe a)
getNamespacedObj' envRef
namespace
var
unpackFnc = do
binds <- liftIO $ readIORef $ bindings envRef
case Data.Map.lookup (getVarName namespace var) binds of
(Just a) -> do
v <- liftIO $ unpackFnc a
return $ Just v
Nothing -> case parentEnv envRef of
(Just par) -> getNamespacedObj' par namespace var unpackFnc
Nothing -> return Nothing
setVar
:: Env
-> String
-> LispVal
-> IOThrowsError LispVal
setVar envRef = setNamespacedVar envRef varNamespace
setNamespacedVar
:: Env
-> Char
-> String
-> LispVal
-> IOThrowsError LispVal
setNamespacedVar envRef
namespace
var value = do
case value of
Pointer p _ -> do
if p == var
then return value
else next
_ -> next
where
next = do
_ <- updatePointers envRef namespace var
_setNamespacedVar envRef namespace var value
_setNamespacedVar
:: Env
-> Char
-> String
-> LispVal
-> IOThrowsError LispVal
_setNamespacedVar envRef
namespace
var value = do
valueToStore <- getValueToStore namespace var envRef value
_setNamespacedVarDirect envRef namespace var valueToStore
_setNamespacedVarDirect
:: Env
-> Char
-> String
-> LispVal
-> IOThrowsError LispVal
_setNamespacedVarDirect envRef
namespace
var valueToStore = do
env <- liftIO $ readIORef $ bindings envRef
case Data.Map.lookup (getVarName namespace var) env of
(Just a) -> do
liftIO $ writeIORef a valueToStore
return valueToStore
Nothing -> case parentEnv envRef of
(Just par) -> _setNamespacedVarDirect par namespace var valueToStore
Nothing -> throwError $ UnboundVar "Setting an unbound variable: " var
updatePointers :: Env -> Char -> String -> IOThrowsError LispVal
updatePointers envRef namespace var = do
ptrs <- liftIO $ readIORef $ pointers envRef
case Data.Map.lookup (getVarName namespace var) ptrs of
(Just valIORef) -> do
val <- liftIO $ readIORef valIORef
case val of
(Pointer pVar pEnv : ps) -> do
liftIO $ writeIORef valIORef []
_ <- movePointers pEnv namespace pVar ps
_ <- pointToNewVar pEnv namespace pVar ps
existingValue <- getNamespacedVar envRef namespace var
_setNamespacedVar pEnv namespace pVar existingValue
[] -> return $ Nil ""
_ -> throwError $ InternalError
"non-pointer value found in updatePointers"
Nothing -> return $ Nil ""
where
movePointers :: Env -> Char -> String -> [LispVal] -> IOThrowsError LispVal
movePointers envRef' namespace' var' ptrs = do
env <- liftIO $ readIORef $ pointers envRef'
case Data.Map.lookup (getVarName namespace' var') env of
Just ps' -> do
ps <- liftIO $ readIORef ps'
liftIO $ writeIORef ps' $ ps ++ ptrs
return $ Nil ""
Nothing -> do
valueRef <- liftIO $ newIORef ptrs
liftIO $ writeIORef (pointers envRef') (Data.Map.insert (getVarName namespace var') valueRef env)
return $ Nil ""
pointToNewVar pEnv namespace' pVar' (Pointer v e : ps) = do
_ <- _setNamespacedVarDirect e namespace' v (Pointer pVar' pEnv)
pointToNewVar pEnv namespace' pVar' ps
pointToNewVar _ _ _ [] = return $ Nil ""
pointToNewVar _ _ _ _ = throwError $ InternalError "pointToNewVar"
updateObject :: Env -> String -> LispVal -> IOThrowsError LispVal
updateObject env =
updateNamespacedObject env varNamespace
updateNamespacedObject :: Env
-> Char
-> String
-> LispVal
-> IOThrowsError LispVal
updateNamespacedObject env namespace var value = do
varContents <- getNamespacedVar env namespace var
obj <- findPointerTo varContents
case obj of
Pointer pVar pEnv -> do
_setNamespacedVar pEnv namespace pVar value
_ -> _setNamespacedVar env namespace var value
defineVar
:: Env
-> String
-> LispVal
-> IOThrowsError LispVal
defineVar envRef = defineNamespacedVar envRef varNamespace
defineNamespacedVar
:: Env
-> Char
-> 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 do
valueToStore <- getValueToStore namespace var envRef value
liftIO $ do
valueRef <- newIORef valueToStore
env <- readIORef $ bindings envRef
writeIORef (bindings envRef) (Data.Map.insert (getVarName namespace var) valueRef env)
return valueToStore
getValueToStore :: Char -> String -> Env -> LispVal -> IOThrowsError LispVal
getValueToStore namespace var env (Pointer p pEnv) = do
addReversePointer namespace p pEnv namespace var env
getValueToStore _ _ _ value = return value
addReversePointer :: Char -> String -> Env -> Char -> String -> Env -> IOThrowsError LispVal
addReversePointer namespace var envRef ptrNamespace ptrVar ptrEnvRef = do
env <- liftIO $ readIORef $ bindings envRef
case Data.Map.lookup (getVarName namespace var) env of
(Just a) -> do
v <- liftIO $ readIORef a
if isObject v
then do
ptrs <- liftIO $ readIORef $ pointers envRef
case Data.Map.lookup (getVarName namespace var) ptrs of
(Just valueRef) -> liftIO $ do
value <- readIORef valueRef
writeIORef valueRef (value ++ [Pointer ptrVar ptrEnvRef])
return $ Pointer var envRef
Nothing -> liftIO $ do
valueRef <- newIORef [Pointer ptrVar ptrEnvRef]
writeIORef (pointers envRef) (Data.Map.insert (getVarName namespace var) valueRef ptrs)
return $ Pointer var envRef
else return v
Nothing -> case parentEnv envRef of
(Just par) -> addReversePointer namespace var par ptrNamespace ptrVar ptrEnvRef
Nothing -> throwError $ UnboundVar "Getting an unbound variable: " var
derefPtr :: LispVal -> IOThrowsError LispVal
derefPtr (Pointer p env) = do
result <- getVar env p
derefPtr result
derefPtr v = return v
recDerefPtrs :: LispVal -> IOThrowsError LispVal
recDerefPtrs = safeRecDerefPtrs []
safeRecDerefPtrs :: [LispVal] -> LispVal -> IOThrowsError LispVal
#ifdef UsePointers
safeRecDerefPtrs ps (List l) = do
result <- mapM (safeRecDerefPtrs ps) l
return $ List result
safeRecDerefPtrs ps (DottedList ls l) = do
ds <- mapM (safeRecDerefPtrs ps) ls
d <- safeRecDerefPtrs ps l
return $ DottedList ds d
safeRecDerefPtrs ps (Vector v) = do
let vs = elems v
ds <- mapM (safeRecDerefPtrs ps) vs
return $ Vector $ listArray (0, length vs 1) ds
safeRecDerefPtrs ps (HashTable ht) = do
ks <- mapM (safeRecDerefPtrs ps)$ map (\ (k, _) -> k) $ Data.Map.toList ht
vs <- mapM (safeRecDerefPtrs ps)$ map (\ (_, v) -> v) $ Data.Map.toList ht
return $ HashTable $ Data.Map.fromList $ zip ks vs
#endif
safeRecDerefPtrs ps ptr@(Pointer p env) = do
if containsPtr ps ptr
then return ptr
else do
result <- getVar env p
safeRecDerefPtrs (ptr : ps) result
safeRecDerefPtrs _ v = return v
containsPtr :: [LispVal] -> LispVal -> Bool
containsPtr ((Pointer pa ea):ps) p@(Pointer pb eb) = do
let found = (pa == pb) && ((bindings ea) == (bindings eb))
found || containsPtr ps p
containsPtr _ _ = False
recDerefToFnc :: ([LispVal] -> ThrowsError LispVal) -> [LispVal]
-> IOThrowsError LispVal
recDerefToFnc fnc lvs = do
List result <- recDerefPtrs $ List lvs
liftThrows $ fnc result
isObject :: LispVal -> Bool
isObject (List _) = True
isObject (DottedList _ _) = True
isObject (String _) = True
isObject (Vector _) = True
isObject (HashTable _) = True
isObject (ByteVector _) = True
isObject (Pointer _ _) = True
isObject _ = False
findPointerTo :: LispVal -> IOThrowsError LispVal
findPointerTo ptr@(Pointer p env) = do
result <- getVar env p
case result of
(Pointer _ _) -> findPointerTo result
_ -> return ptr
findPointerTo v = return v