{- |
Module : Language.Scheme.Variables
Copyright : Justin Ethier
Licence : MIT (see LICENSE in the distribution)
Maintainer : github.com/justinethier
Stability : experimental
Portability : portable
This module contains code for working with Scheme variables.
-}moduleLanguage.Scheme.VariableswhereimportLanguage.Scheme.TypesimportControl.Monad.ErrorimportData.IORefimportqualifiedData.Map-- TODO: convert from storing vars in a list to a more efficient-- data structure using Data.Map{- Experimental code:
-- From: http://rafaelbarreto.com/2011/08/21/comparing-objects-by-memory-location-in-haskell/import Foreign
isMemoryEquivalent :: a -> a -> IO Bool
isMemoryEquivalent obj1 obj2 = do
obj1Ptr <- newStablePtr obj1
obj2Ptr <- newStablePtr obj2
let result = obj1Ptr == obj2Ptr
freeStablePtr obj1Ptr
freeStablePtr obj2Ptr
return result
-- Using above, search an env for a variable definition, but stop if the upperEnv is
-- reached before the variable
isNamespacedRecBoundWUpper :: Env -> Env -> String -> String -> IO Bool
isNamespacedRecBoundWUpper upperEnvRef envRef namespace var = do
areEnvsEqual <- liftIO $ isMemoryEquivalent upperEnvRef envRef
if areEnvsEqual
then return False
else do
found <- liftIO $ isNamespacedBound envRef namespace var
if found
then return True
else case parentEnv envRef of
(Just par) -> isNamespacedRecBoundWUpper upperEnvRef par namespace var
Nothing -> return False -- Var never found
-}-- |Show the contents of an environmentprintEnv::Env->IOStringprintEnvenv=dobinds<-liftIO$readIORef$bindingsenvl<-mapMshowVar$Data.Map.toListbindsreturn$unlineslwhereshowVar((_,name),val)=dov<-liftIO$readIORefvalreturn$name++": "++showv-- |Create a deep copy of an environmentcopyEnv::Env->IOEnvcopyEnvenv=dobinds<-liftIO$readIORef$bindingsenv-- bindingList <- mapM addBinding binds >>= newIORefbindingListT<-mapMaddBinding$Data.Map.toListbinds-- TODO: there is a more elegant way to write this here (and below, too)bindingList<-newIORef$Data.Map.fromListbindingListTreturn$Environment(parentEnvenv)bindingList-- TODO: recursively create a copy of parent also?whereaddBinding((namespace,name),val)=do--ref <- newIORef $ liftIO $ readIORef valx<-liftIO$readIORefvalref<-newIORefxreturn((namespace,name),ref)-- |Extend given environment by binding a series of values to a new environment.-- TODO: should be able to use Data.Map.fromList to ease construction of new EnvextendEnv::Env->[((String,String),LispVal)]->IOEnvextendEnvenvRefabindings=dobindinglistT<-(mapMaddBindingabindings)-- >>= newIORefbindinglist<-newIORef$Data.Map.fromListbindinglistTreturn$Environment(JustenvRef)bindinglistwhereaddBinding((namespace,name),val)=doref<-newIORefvalreturn((namespace,name),ref)-- Recursively search environments to find one that contains varfindNamespacedEnv::Env->String->String->IO(MaybeEnv)findNamespacedEnvenvRefnamespacevar=dofound<-liftIO$isNamespacedBoundenvRefnamespacevariffoundthenreturn(JustenvRef)elsecaseparentEnvenvRefof(Justpar)->findNamespacedEnvparnamespacevarNothing->returnNothing-- |Determine if a variable is bound in the default namespaceisBound::Env->String->IOBoolisBoundenvRefvar=isNamespacedBoundenvRefvarNamespacevar-- |Determine if a variable is bound in the default namespace, in this env or a parentisRecBound::Env->String->IOBoolisRecBoundenvRefvar=isNamespacedRecBoundenvRefvarNamespacevar-- |Determine if a variable is bound in a given namespaceisNamespacedBound::Env->String->String->IOBoolisNamespacedBoundenvRefnamespacevar=(readIORef$bindingsenvRef)>>=return.Data.Map.member(namespace,var)-- TODO: should isNamespacedBound be replaced with this? Probably, but one step at a time...isNamespacedRecBound::Env->String->String->IOBoolisNamespacedRecBoundenvRefnamespacevar=doenv<-findNamespacedEnvenvRefnamespacevarcaseenvof(Juste)->isNamespacedBoundenamespacevarNothing->returnFalse-- |Retrieve the value of a variable defined in the default namespacegetVar::Env->String->IOThrowsErrorLispValgetVarenvRefvar=getNamespacedVarenvRefvarNamespacevar-- |Retrieve the value of a variable defined in a given namespacegetNamespacedVar::Env->String->String->IOThrowsErrorLispValgetNamespacedVarenvRefnamespacevar=dobinds<-liftIO$readIORef$bindingsenvRefcaseData.Map.lookup(namespace,var)bindsof(Justa)->liftIO$readIORefaNothing->caseparentEnvenvRefof(Justpar)->getNamespacedVarparnamespacevarNothing->(throwError$UnboundVar"Getting an unbound variable"var)-- |Set a variable in the default namespacesetVar,defineVar::Env->String->LispVal->IOThrowsErrorLispValsetVarenvRefvarvalue=setNamespacedVarenvRefvarNamespacevarvalue-- ^Bind a variable in the default namespacedefineVarenvRefvarvalue=defineNamespacedVarenvRefvarNamespacevarvalue-- |Set a variable in a given namespacesetNamespacedVar::Env->String->String->LispVal->IOThrowsErrorLispValsetNamespacedVarenvRefnamespacevarvalue=doenv<-liftIO$readIORef$bindingsenvRefcaseData.Map.lookup(namespace,var)envof(Justa)->do-- vprime <- liftIO $ readIORef aliftIO$writeIORefavaluereturnvalueNothing->caseparentEnvenvRefof(Justpar)->setNamespacedVarparnamespacevarvalueNothing->throwError$UnboundVar"Setting an unbound variable: "var-- |Bind a variable in the given namespacedefineNamespacedVar::Env->String->String->LispVal->IOThrowsErrorLispValdefineNamespacedVarenvRefnamespacevarvalue=doalreadyDefined<-liftIO$isNamespacedBoundenvRefnamespacevarifalreadyDefinedthensetNamespacedVarenvRefnamespacevarvalue>>returnvalueelseliftIO$dovalueRef<-newIORefvalueenv<-readIORef$bindingsenvRefwriteIORef(bindingsenvRef)(Data.Map.insert(namespace,var)valueRefenv)-- (((namespace, var), valueRef) : env)returnvalue