{-# LANGUAGE CPP #-}

{- |
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,
and the environments that contain them.

-}

module Language.Scheme.Variables 
    (
    -- * Environments
      printEnv
    , recPrintEnv
    , recExportsFromEnv 
    , exportsFromEnv 
    , copyEnv
    , extendEnv
    , importEnv
    , topmostEnv
    , nullEnvWithParent
    , findNamespacedEnv
    , macroNamespace
    , varNamespace 
    -- * Getters
    , getVar
    , getVar'
    , getNamespacedVar 
    , getNamespacedVar' 
    , getNamespacedRef 
    -- * Setters
    , defineVar
    , defineNamespacedVar
    , setVar
    , setNamespacedVar
    , updateObject 
    , updateNamespacedObject 
    -- * Predicates
    , isBound
    , isRecBound
    , isNamespacedRecBound 
    -- * Pointers
    , derefPtr
--    , derefPtrs
    , recDerefPtrs
    , safeRecDerefPtrs
    , recDerefToFnc
    ) where
import Language.Scheme.Types
import Control.Monad.Except
import Data.Array
import Data.IORef
import qualified Data.Map
-- import Debug.Trace

-- |Internal namespace for macros
macroNamespace :: Char
macroNamespace :: Char
macroNamespace = Char
'm'

-- |Internal namespace for variables
varNamespace :: Char
varNamespace :: Char
varNamespace = Char
'v'

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

-- |Create a variable's name in an environment using given arguments
getVarName :: Char -> String -> String
getVarName :: Char -> String -> String
getVarName Char
namespace String
name = (Char
namespace Char -> String -> String
forall a. a -> [a] -> [a]
: (Char
'_' Char -> String -> String
forall a. a -> [a] -> [a]
: String
name))

-- |Show the contents of an environment
printEnv :: Env         -- ^Environment
         -> IO String   -- ^Contents of the env as a string
printEnv :: Env -> IO String
printEnv Env
env = do
  Map String (IORef LispVal)
binds <- IO (Map String (IORef LispVal)) -> IO (Map String (IORef LispVal))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map String (IORef LispVal))
 -> IO (Map String (IORef LispVal)))
-> IO (Map String (IORef LispVal))
-> IO (Map String (IORef LispVal))
forall a b. (a -> b) -> a -> b
$ IORef (Map String (IORef LispVal))
-> IO (Map String (IORef LispVal))
forall a. IORef a -> IO a
readIORef (IORef (Map String (IORef LispVal))
 -> IO (Map String (IORef LispVal)))
-> IORef (Map String (IORef LispVal))
-> IO (Map String (IORef LispVal))
forall a b. (a -> b) -> a -> b
$ Env -> IORef (Map String (IORef LispVal))
bindings Env
env
  [String]
l <- ((String, IORef LispVal) -> IO String)
-> [(String, IORef LispVal)] -> IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String, IORef LispVal) -> IO String
forall (m :: * -> *) a.
(MonadIO m, Show a) =>
(String, IORef a) -> m String
showVar ([(String, IORef LispVal)] -> IO [String])
-> [(String, IORef LispVal)] -> IO [String]
forall a b. (a -> b) -> a -> b
$ Map String (IORef LispVal) -> [(String, IORef LispVal)]
forall k a. Map k a -> [(k, a)]
Data.Map.toList Map String (IORef LispVal)
binds 
  String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
l
 where 
  showVar :: (String, IORef a) -> m String
showVar (String
name, IORef a
val) = do
    a
v <- IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
val
    String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
v

-- |Recursively print an environment to string
recPrintEnv :: Env -> IO String
recPrintEnv :: Env -> IO String
recPrintEnv Env
env = do
  String
envStr <- IO String -> IO String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> IO String) -> IO String -> IO String
forall a b. (a -> b) -> a -> b
$ Env -> IO String
printEnv Env
env

  case Env -> Maybe Env
parentEnv Env
env of
    Just Env
par -> do
        String
parEnvStr <- IO String -> IO String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> IO String) -> IO String -> IO String
forall a b. (a -> b) -> a -> b
$ Env -> IO String
recPrintEnv Env
par
        String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
envStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
parEnvStr
    Maybe Env
Nothing -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
envStr

-- |Recursively find all exports from the given environment
recExportsFromEnv :: Env -> IO [LispVal]
recExportsFromEnv :: Env -> IO [LispVal]
recExportsFromEnv Env
env = do
  [LispVal]
xs <- Env -> IO [LispVal]
exportsFromEnv Env
env

  case Env -> Maybe Env
parentEnv Env
env of
    Just Env
par -> do
        [LispVal]
pxs <- IO [LispVal] -> IO [LispVal]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [LispVal] -> IO [LispVal]) -> IO [LispVal] -> IO [LispVal]
forall a b. (a -> b) -> a -> b
$ Env -> IO [LispVal]
recExportsFromEnv Env
par
        [LispVal] -> IO [LispVal]
forall (m :: * -> *) a. Monad m => a -> m a
return ([LispVal] -> IO [LispVal]) -> [LispVal] -> IO [LispVal]
forall a b. (a -> b) -> a -> b
$ [LispVal]
xs [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal]
pxs
    Maybe Env
Nothing -> [LispVal] -> IO [LispVal]
forall (m :: * -> *) a. Monad m => a -> m a
return [LispVal]
xs

-- |Return a list of symbols exported from an environment
exportsFromEnv :: Env 
               -> IO [LispVal]
exportsFromEnv :: Env -> IO [LispVal]
exportsFromEnv Env
env = do
  Map String (IORef LispVal)
binds <- IO (Map String (IORef LispVal)) -> IO (Map String (IORef LispVal))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map String (IORef LispVal))
 -> IO (Map String (IORef LispVal)))
-> IO (Map String (IORef LispVal))
-> IO (Map String (IORef LispVal))
forall a b. (a -> b) -> a -> b
$ IORef (Map String (IORef LispVal))
-> IO (Map String (IORef LispVal))
forall a. IORef a -> IO a
readIORef (IORef (Map String (IORef LispVal))
 -> IO (Map String (IORef LispVal)))
-> IORef (Map String (IORef LispVal))
-> IO (Map String (IORef LispVal))
forall a b. (a -> b) -> a -> b
$ Env -> IORef (Map String (IORef LispVal))
bindings Env
env
  [LispVal] -> IO [LispVal]
forall (m :: * -> *) a. Monad m => a -> m a
return ([LispVal] -> IO [LispVal]) -> [LispVal] -> IO [LispVal]
forall a b. (a -> b) -> a -> b
$ [LispVal] -> [String] -> [LispVal]
getExports [] ([String] -> [LispVal]) -> [String] -> [LispVal]
forall a b. (a -> b) -> a -> b
$ ([String], [IORef LispVal]) -> [String]
forall a b. (a, b) -> a
fst (([String], [IORef LispVal]) -> [String])
-> ([String], [IORef LispVal]) -> [String]
forall a b. (a -> b) -> a -> b
$ [(String, IORef LispVal)] -> ([String], [IORef LispVal])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(String, IORef LispVal)] -> ([String], [IORef LispVal]))
-> [(String, IORef LispVal)] -> ([String], [IORef LispVal])
forall a b. (a -> b) -> a -> b
$ Map String (IORef LispVal) -> [(String, IORef LispVal)]
forall k a. Map k a -> [(k, a)]
Data.Map.toList Map String (IORef LispVal)
binds 
 where 
  getExports :: [LispVal] -> [String] -> [LispVal]
getExports [LispVal]
acc ((Char
'm':Char
'_':String
b) : [String]
bs) = [LispVal] -> [String] -> [LispVal]
getExports (String -> LispVal
Atom String
bLispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
:[LispVal]
acc) [String]
bs
  getExports [LispVal]
acc ((Char
'v':Char
'_':String
b) : [String]
bs) = [LispVal] -> [String] -> [LispVal]
getExports (String -> LispVal
Atom String
bLispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
:[LispVal]
acc) [String]
bs
  getExports [LispVal]
acc (String
_ : [String]
bs) = [LispVal] -> [String] -> [LispVal]
getExports [LispVal]
acc [String]
bs
  getExports [LispVal]
acc [] = [LispVal]
acc

-- |Create a deep copy of an environment
copyEnv :: Env      -- ^ Source environment
        -> IO Env   -- ^ A copy of the source environment
copyEnv :: Env -> IO Env
copyEnv Env
env = do
  Map String (IORef [LispVal])
ptrs <- IO (Map String (IORef [LispVal]))
-> IO (Map String (IORef [LispVal]))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map String (IORef [LispVal]))
 -> IO (Map String (IORef [LispVal])))
-> IO (Map String (IORef [LispVal]))
-> IO (Map String (IORef [LispVal]))
forall a b. (a -> b) -> a -> b
$ IORef (Map String (IORef [LispVal]))
-> IO (Map String (IORef [LispVal]))
forall a. IORef a -> IO a
readIORef (IORef (Map String (IORef [LispVal]))
 -> IO (Map String (IORef [LispVal])))
-> IORef (Map String (IORef [LispVal]))
-> IO (Map String (IORef [LispVal]))
forall a b. (a -> b) -> a -> b
$ Env -> IORef (Map String (IORef [LispVal]))
pointers Env
env
  IORef (Map String (IORef [LispVal]))
ptrList <- Map String (IORef [LispVal])
-> IO (IORef (Map String (IORef [LispVal])))
forall a. a -> IO (IORef a)
newIORef Map String (IORef [LispVal])
ptrs

  Map String (IORef LispVal)
binds <- IO (Map String (IORef LispVal)) -> IO (Map String (IORef LispVal))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map String (IORef LispVal))
 -> IO (Map String (IORef LispVal)))
-> IO (Map String (IORef LispVal))
-> IO (Map String (IORef LispVal))
forall a b. (a -> b) -> a -> b
$ IORef (Map String (IORef LispVal))
-> IO (Map String (IORef LispVal))
forall a. IORef a -> IO a
readIORef (IORef (Map String (IORef LispVal))
 -> IO (Map String (IORef LispVal)))
-> IORef (Map String (IORef LispVal))
-> IO (Map String (IORef LispVal))
forall a b. (a -> b) -> a -> b
$ Env -> IORef (Map String (IORef LispVal))
bindings Env
env
  [(String, IORef LispVal)]
bindingListT <- ((String, IORef LispVal) -> IO (String, IORef LispVal))
-> [(String, IORef LispVal)] -> IO [(String, IORef LispVal)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String, IORef LispVal) -> IO (String, IORef LispVal)
forall a a. (a, IORef a) -> IO (a, IORef a)
addBinding ([(String, IORef LispVal)] -> IO [(String, IORef LispVal)])
-> [(String, IORef LispVal)] -> IO [(String, IORef LispVal)]
forall a b. (a -> b) -> a -> b
$ Map String (IORef LispVal) -> [(String, IORef LispVal)]
forall k a. Map k a -> [(k, a)]
Data.Map.toList Map String (IORef LispVal)
binds 
  IORef (Map String (IORef LispVal))
bindingList <- Map String (IORef LispVal)
-> IO (IORef (Map String (IORef LispVal)))
forall a. a -> IO (IORef a)
newIORef (Map String (IORef LispVal)
 -> IO (IORef (Map String (IORef LispVal))))
-> Map String (IORef LispVal)
-> IO (IORef (Map String (IORef LispVal)))
forall a b. (a -> b) -> a -> b
$ [(String, IORef LispVal)] -> Map String (IORef LispVal)
forall k a. Ord k => [(k, a)] -> Map k a
Data.Map.fromList [(String, IORef LispVal)]
bindingListT
  Env -> IO Env
forall (m :: * -> *) a. Monad m => a -> m a
return (Env -> IO Env) -> Env -> IO Env
forall a b. (a -> b) -> a -> b
$ Maybe Env
-> IORef (Map String (IORef LispVal))
-> IORef (Map String (IORef [LispVal]))
-> Env
Environment (Env -> Maybe Env
parentEnv Env
env) IORef (Map String (IORef LispVal))
bindingList IORef (Map String (IORef [LispVal]))
ptrList
 where addBinding :: (a, IORef a) -> IO (a, IORef a)
addBinding (a
name, IORef a
val) = do 
         a
x <- IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
val
         IORef a
ref <- a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef a
x
         (a, IORef a) -> IO (a, IORef a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
name, IORef a
ref)

-- |Perform a deep copy of an environment's contents into
--  another environment.
--
--  The destination environment is modified!
--
importEnv 
  :: Env -- ^ Destination environment
  -> Env -- ^ Source environment
  -> IO Env
importEnv :: Env -> Env -> IO Env
importEnv Env
dEnv Env
sEnv = do
  Map String (IORef [LispVal])
sPtrs <- IO (Map String (IORef [LispVal]))
-> IO (Map String (IORef [LispVal]))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map String (IORef [LispVal]))
 -> IO (Map String (IORef [LispVal])))
-> IO (Map String (IORef [LispVal]))
-> IO (Map String (IORef [LispVal]))
forall a b. (a -> b) -> a -> b
$ IORef (Map String (IORef [LispVal]))
-> IO (Map String (IORef [LispVal]))
forall a. IORef a -> IO a
readIORef (IORef (Map String (IORef [LispVal]))
 -> IO (Map String (IORef [LispVal])))
-> IORef (Map String (IORef [LispVal]))
-> IO (Map String (IORef [LispVal]))
forall a b. (a -> b) -> a -> b
$ Env -> IORef (Map String (IORef [LispVal]))
pointers Env
sEnv
  Map String (IORef [LispVal])
dPtrs <- IO (Map String (IORef [LispVal]))
-> IO (Map String (IORef [LispVal]))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map String (IORef [LispVal]))
 -> IO (Map String (IORef [LispVal])))
-> IO (Map String (IORef [LispVal]))
-> IO (Map String (IORef [LispVal]))
forall a b. (a -> b) -> a -> b
$ IORef (Map String (IORef [LispVal]))
-> IO (Map String (IORef [LispVal]))
forall a. IORef a -> IO a
readIORef (IORef (Map String (IORef [LispVal]))
 -> IO (Map String (IORef [LispVal])))
-> IORef (Map String (IORef [LispVal]))
-> IO (Map String (IORef [LispVal]))
forall a b. (a -> b) -> a -> b
$ Env -> IORef (Map String (IORef [LispVal]))
pointers Env
dEnv
  IORef (Map String (IORef [LispVal]))
-> Map String (IORef [LispVal]) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Env -> IORef (Map String (IORef [LispVal]))
pointers Env
dEnv) (Map String (IORef [LispVal]) -> IO ())
-> Map String (IORef [LispVal]) -> IO ()
forall a b. (a -> b) -> a -> b
$ Map String (IORef [LispVal])
-> Map String (IORef [LispVal]) -> Map String (IORef [LispVal])
forall k a. Ord k => Map k a -> Map k a -> Map k a
Data.Map.union Map String (IORef [LispVal])
sPtrs Map String (IORef [LispVal])
dPtrs

  Map String (IORef LispVal)
sBinds <- IO (Map String (IORef LispVal)) -> IO (Map String (IORef LispVal))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map String (IORef LispVal))
 -> IO (Map String (IORef LispVal)))
-> IO (Map String (IORef LispVal))
-> IO (Map String (IORef LispVal))
forall a b. (a -> b) -> a -> b
$ IORef (Map String (IORef LispVal))
-> IO (Map String (IORef LispVal))
forall a. IORef a -> IO a
readIORef (IORef (Map String (IORef LispVal))
 -> IO (Map String (IORef LispVal)))
-> IORef (Map String (IORef LispVal))
-> IO (Map String (IORef LispVal))
forall a b. (a -> b) -> a -> b
$ Env -> IORef (Map String (IORef LispVal))
bindings Env
sEnv
  Map String (IORef LispVal)
dBinds <- IO (Map String (IORef LispVal)) -> IO (Map String (IORef LispVal))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map String (IORef LispVal))
 -> IO (Map String (IORef LispVal)))
-> IO (Map String (IORef LispVal))
-> IO (Map String (IORef LispVal))
forall a b. (a -> b) -> a -> b
$ IORef (Map String (IORef LispVal))
-> IO (Map String (IORef LispVal))
forall a. IORef a -> IO a
readIORef (IORef (Map String (IORef LispVal))
 -> IO (Map String (IORef LispVal)))
-> IORef (Map String (IORef LispVal))
-> IO (Map String (IORef LispVal))
forall a b. (a -> b) -> a -> b
$ Env -> IORef (Map String (IORef LispVal))
bindings Env
dEnv
  IORef (Map String (IORef LispVal))
-> Map String (IORef LispVal) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Env -> IORef (Map String (IORef LispVal))
bindings Env
dEnv)  (Map String (IORef LispVal) -> IO ())
-> Map String (IORef LispVal) -> IO ()
forall a b. (a -> b) -> a -> b
$ Map String (IORef LispVal)
-> Map String (IORef LispVal) -> Map String (IORef LispVal)
forall k a. Ord k => Map k a -> Map k a -> Map k a
Data.Map.union Map String (IORef LispVal)
sBinds Map String (IORef LispVal)
dBinds

  case Env -> Maybe Env
parentEnv Env
sEnv of
    Just Env
ps -> Env -> Env -> IO Env
importEnv Env
dEnv Env
ps 
    Maybe Env
Nothing -> Env -> IO Env
forall (m :: * -> *) a. Monad m => a -> m a
return Env
dEnv 

-- |Extend given environment by binding a series of values to a new environment.
extendEnv :: Env -- ^ Environment 
          -> [((Char, String), LispVal)] -- ^ Extensions to the environment
          -> IO Env -- ^ Extended environment
extendEnv :: Env -> [((Char, String), LispVal)] -> IO Env
extendEnv Env
envRef [((Char, String), LispVal)]
abindings = do 
  [(String, IORef LispVal)]
bindinglistT <- ((((Char, String), LispVal) -> IO (String, IORef LispVal))
-> [((Char, String), LispVal)] -> IO [(String, IORef LispVal)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Char, String), LispVal) -> IO (String, IORef LispVal)
forall a. ((Char, String), a) -> IO (String, IORef a)
addBinding [((Char, String), LispVal)]
abindings) -- >>= newIORef
  IORef (Map String (IORef LispVal))
bindinglist <- Map String (IORef LispVal)
-> IO (IORef (Map String (IORef LispVal)))
forall a. a -> IO (IORef a)
newIORef (Map String (IORef LispVal)
 -> IO (IORef (Map String (IORef LispVal))))
-> Map String (IORef LispVal)
-> IO (IORef (Map String (IORef LispVal)))
forall a b. (a -> b) -> a -> b
$ [(String, IORef LispVal)] -> Map String (IORef LispVal)
forall k a. Ord k => [(k, a)] -> Map k a
Data.Map.fromList [(String, IORef LispVal)]
bindinglistT
  IORef (Map String (IORef [LispVal]))
nullPointers <- Map String (IORef [LispVal])
-> IO (IORef (Map String (IORef [LispVal])))
forall a. a -> IO (IORef a)
newIORef (Map String (IORef [LispVal])
 -> IO (IORef (Map String (IORef [LispVal]))))
-> Map String (IORef [LispVal])
-> IO (IORef (Map String (IORef [LispVal])))
forall a b. (a -> b) -> a -> b
$ [(String, IORef [LispVal])] -> Map String (IORef [LispVal])
forall k a. Ord k => [(k, a)] -> Map k a
Data.Map.fromList []
  Env -> IO Env
forall (m :: * -> *) a. Monad m => a -> m a
return (Env -> IO Env) -> Env -> IO Env
forall a b. (a -> b) -> a -> b
$ Maybe Env
-> IORef (Map String (IORef LispVal))
-> IORef (Map String (IORef [LispVal]))
-> Env
Environment (Env -> Maybe Env
forall a. a -> Maybe a
Just Env
envRef) IORef (Map String (IORef LispVal))
bindinglist IORef (Map String (IORef [LispVal]))
nullPointers
 where addBinding :: ((Char, String), a) -> IO (String, IORef a)
addBinding ((Char
namespace, String
name), a
val) = do IORef a
ref <- a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef a
val
                                                (String, IORef a) -> IO (String, IORef a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char -> String -> String
getVarName Char
namespace String
name, IORef a
ref)

-- |Find the top-most environment
topmostEnv :: Env -> IO Env
topmostEnv :: Env -> IO Env
topmostEnv Env
envRef = do
    case Env -> Maybe Env
parentEnv Env
envRef of
        Just Env
p -> Env -> IO Env
topmostEnv Env
p
        Maybe Env
Nothing -> Env -> IO Env
forall (m :: * -> *) a. Monad m => a -> m a
return Env
envRef

-- |Create a null environment with the given environment as its parent.
nullEnvWithParent :: Env -> IO Env 
nullEnvWithParent :: Env -> IO Env
nullEnvWithParent Env
p = do
  Environment Maybe Env
_ IORef (Map String (IORef LispVal))
binds IORef (Map String (IORef [LispVal]))
ptrs <- IO Env
nullEnv
  Env -> IO Env
forall (m :: * -> *) a. Monad m => a -> m a
return (Env -> IO Env) -> Env -> IO Env
forall a b. (a -> b) -> a -> b
$ Maybe Env
-> IORef (Map String (IORef LispVal))
-> IORef (Map String (IORef [LispVal]))
-> Env
Environment (Env -> Maybe Env
forall a. a -> Maybe a
Just Env
p) IORef (Map String (IORef LispVal))
binds IORef (Map String (IORef [LispVal]))
ptrs

-- |Recursively search environments to find one that contains the given variable.
findNamespacedEnv 
    :: Env      -- ^Environment to begin the search; 
                --  parent env's will be searched as well.
    -> Char     -- ^Namespace
    -> String   -- ^Variable
    -> IO (Maybe Env) -- ^Environment, or Nothing if there was no match.
findNamespacedEnv :: Env -> Char -> String -> IO (Maybe Env)
findNamespacedEnv Env
envRef Char
namespace String
var = do
  Bool
found <- IO Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> Char -> String -> IO Bool
isNamespacedBound Env
envRef Char
namespace String
var
  if Bool
found
     then Maybe Env -> IO (Maybe Env)
forall (m :: * -> *) a. Monad m => a -> m a
return (Env -> Maybe Env
forall a. a -> Maybe a
Just Env
envRef)
     else case Env -> Maybe Env
parentEnv Env
envRef of
               (Just Env
par) -> Env -> Char -> String -> IO (Maybe Env)
findNamespacedEnv Env
par Char
namespace String
var
               Maybe Env
Nothing -> Maybe Env -> IO (Maybe Env)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Env
forall a. Maybe a
Nothing

-- |Determine if a variable is bound in the default namespace
isBound :: Env      -- ^ Environment
        -> String   -- ^ Variable
        -> IO Bool  -- ^ True if the variable is bound
isBound :: Env -> String -> IO Bool
isBound Env
envRef = Env -> Char -> String -> IO Bool
isNamespacedBound Env
envRef Char
varNamespace

-- |Determine if a variable is bound in the default namespace, 
--  in this environment or one of its parents.
isRecBound :: Env      -- ^ Environment
           -> String   -- ^ Variable
           -> IO Bool  -- ^ True if the variable is bound
isRecBound :: Env -> String -> IO Bool
isRecBound Env
envRef = Env -> Char -> String -> IO Bool
isNamespacedRecBound Env
envRef Char
varNamespace

-- |Determine if a variable is bound in a given namespace
isNamespacedBound 
    :: Env      -- ^ Environment
    -> Char     -- ^ Namespace
    -> String   -- ^ Variable
    -> IO Bool  -- ^ True if the variable is bound
isNamespacedBound :: Env -> Char -> String -> IO Bool
isNamespacedBound Env
envRef Char
namespace String
var = 
    IORef (Map String (IORef LispVal))
-> IO (Map String (IORef LispVal))
forall a. IORef a -> IO a
readIORef (Env -> IORef (Map String (IORef LispVal))
bindings Env
envRef) IO (Map String (IORef LispVal))
-> (Map String (IORef LispVal) -> IO Bool) -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool)
-> (Map String (IORef LispVal) -> Bool)
-> Map String (IORef LispVal)
-> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Map String (IORef LispVal) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Data.Map.member (Char -> String -> String
getVarName Char
namespace String
var)

-- |Determine if a variable is bound in a given namespace
--  or a parent of the given environment.
isNamespacedRecBound 
    :: Env      -- ^ Environment
    -> Char     -- ^ Namespace
    -> String   -- ^ Variable
    -> IO Bool  -- ^ True if the variable is bound
isNamespacedRecBound :: Env -> Char -> String -> IO Bool
isNamespacedRecBound Env
envRef Char
namespace String
var = do
  Maybe Env
env <- Env -> Char -> String -> IO (Maybe Env)
findNamespacedEnv Env
envRef Char
namespace String
var
  case Maybe Env
env of
    (Just Env
e) -> Env -> Char -> String -> IO Bool
isNamespacedBound Env
e Char
namespace String
var
    Maybe Env
Nothing -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- |Retrieve the value of a variable defined in the default namespace
getVar :: Env       -- ^ Environment
       -> String    -- ^ Variable
       -> IOThrowsError LispVal -- ^ Contents of the variable
getVar :: Env -> String -> IOThrowsError LispVal
getVar Env
envRef = Env -> Char -> String -> IOThrowsError LispVal
getNamespacedVar Env
envRef Char
varNamespace

-- |Retrieve the value of a variable defined in the default namespace,
--  or Nothing if it is not defined
getVar' :: Env       -- ^ Environment
        -> String    -- ^ Variable
        -> IOThrowsError (Maybe LispVal) -- ^ Contents of the variable
getVar' :: Env -> String -> IOThrowsError (Maybe LispVal)
getVar' Env
envRef = Env -> Char -> String -> IOThrowsError (Maybe LispVal)
getNamespacedVar' Env
envRef Char
varNamespace

-- |Retrieve an ioRef defined in a given namespace
getNamespacedRef :: Env     -- ^ Environment
                 -> Char    -- ^ Namespace
                 -> String  -- ^ Variable
                 -> IOThrowsError (IORef LispVal)
getNamespacedRef :: Env -> Char -> String -> IOThrowsError (IORef LispVal)
getNamespacedRef Env
envRef
                 Char
namespace
                 String
var = do
  Maybe (IORef LispVal)
v <- Env
-> Char
-> String
-> (IORef LispVal -> IO (IORef LispVal))
-> IOThrowsError (Maybe (IORef LispVal))
forall a.
Env
-> Char
-> String
-> (IORef LispVal -> IO a)
-> IOThrowsError (Maybe a)
getNamespacedObj' Env
envRef Char
namespace String
var IORef LispVal -> IO (IORef LispVal)
forall (m :: * -> *) a. Monad m => a -> m a
return
  case Maybe (IORef LispVal)
v of
    Just IORef LispVal
a -> IORef LispVal -> IOThrowsError (IORef LispVal)
forall (m :: * -> *) a. Monad m => a -> m a
return IORef LispVal
a
    Maybe (IORef LispVal)
Nothing -> (LispError -> IOThrowsError (IORef LispVal)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError (IORef LispVal))
-> LispError -> IOThrowsError (IORef LispVal)
forall a b. (a -> b) -> a -> b
$ String -> String -> LispError
UnboundVar String
"Getting an unbound variable" String
var)

-- |Retrieve the value of a variable defined in a given namespace
getNamespacedVar :: Env     -- ^ Environment
                 -> Char    -- ^ Namespace
                 -> String  -- ^ Variable
                 -> IOThrowsError LispVal -- ^ Contents of the variable
getNamespacedVar :: Env -> Char -> String -> IOThrowsError LispVal
getNamespacedVar Env
envRef
                 Char
namespace
                 String
var = do
  Maybe LispVal
v <- Env -> Char -> String -> IOThrowsError (Maybe LispVal)
getNamespacedVar' Env
envRef Char
namespace String
var
  case Maybe LispVal
v of
    Just LispVal
a -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
a
    Maybe LispVal
Nothing -> (LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> String -> LispError
UnboundVar String
"Getting an unbound variable" String
var)

-- |Retrieve the value of a variable defined in a given namespace,
--  or Nothing if it is not defined
getNamespacedVar' :: Env     -- ^ Environment
                 -> Char    -- ^ Namespace
                 -> String  -- ^ Variable
                 -> IOThrowsError (Maybe LispVal) -- ^ Contents of the variable, if found
getNamespacedVar' :: Env -> Char -> String -> IOThrowsError (Maybe LispVal)
getNamespacedVar' Env
envRef
                 Char
namespace
                 String
var = do 
    Env
-> Char
-> String
-> (IORef LispVal -> IO LispVal)
-> IOThrowsError (Maybe LispVal)
forall a.
Env
-> Char
-> String
-> (IORef LispVal -> IO a)
-> IOThrowsError (Maybe a)
getNamespacedObj' Env
envRef Char
namespace String
var IORef LispVal -> IO LispVal
forall a. IORef a -> IO a
readIORef

getNamespacedObj' :: Env     -- ^ Environment
                 -> Char    -- ^ Namespace
                 -> String  -- ^ Variable
                 -> (IORef LispVal -> IO a)
                 -> IOThrowsError (Maybe a) -- ^ Contents of the variable, if found
getNamespacedObj' :: Env
-> Char
-> String
-> (IORef LispVal -> IO a)
-> IOThrowsError (Maybe a)
getNamespacedObj' Env
envRef
                 Char
namespace
                 String
var 
                 IORef LispVal -> IO a
unpackFnc = do 
    Map String (IORef LispVal)
binds <- IO (Map String (IORef LispVal))
-> ExceptT LispError IO (Map String (IORef LispVal))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map String (IORef LispVal))
 -> ExceptT LispError IO (Map String (IORef LispVal)))
-> IO (Map String (IORef LispVal))
-> ExceptT LispError IO (Map String (IORef LispVal))
forall a b. (a -> b) -> a -> b
$ IORef (Map String (IORef LispVal))
-> IO (Map String (IORef LispVal))
forall a. IORef a -> IO a
readIORef (IORef (Map String (IORef LispVal))
 -> IO (Map String (IORef LispVal)))
-> IORef (Map String (IORef LispVal))
-> IO (Map String (IORef LispVal))
forall a b. (a -> b) -> a -> b
$ Env -> IORef (Map String (IORef LispVal))
bindings Env
envRef
    case String -> Map String (IORef LispVal) -> Maybe (IORef LispVal)
forall k a. Ord k => k -> Map k a -> Maybe a
Data.Map.lookup (Char -> String -> String
getVarName Char
namespace String
var) Map String (IORef LispVal)
binds of
      (Just IORef LispVal
a) -> do
          a
v <- IO a -> ExceptT LispError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> ExceptT LispError IO a) -> IO a -> ExceptT LispError IO a
forall a b. (a -> b) -> a -> b
$ IORef LispVal -> IO a
unpackFnc IORef LispVal
a
          Maybe a -> IOThrowsError (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> IOThrowsError (Maybe a))
-> Maybe a -> IOThrowsError (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
v
      Maybe (IORef LispVal)
Nothing -> case Env -> Maybe Env
parentEnv Env
envRef of
                   (Just Env
par) -> Env
-> Char
-> String
-> (IORef LispVal -> IO a)
-> IOThrowsError (Maybe a)
forall a.
Env
-> Char
-> String
-> (IORef LispVal -> IO a)
-> IOThrowsError (Maybe a)
getNamespacedObj' Env
par Char
namespace String
var IORef LispVal -> IO a
unpackFnc
                   Maybe Env
Nothing -> Maybe a -> IOThrowsError (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

-- |Set a variable in the default namespace
setVar
    :: Env      -- ^ Environment
    -> String   -- ^ Variable
    -> LispVal  -- ^ Value
    -> IOThrowsError LispVal -- ^ Value
setVar :: Env -> String -> LispVal -> IOThrowsError LispVal
setVar Env
envRef = Env -> Char -> String -> LispVal -> IOThrowsError LispVal
setNamespacedVar Env
envRef Char
varNamespace

-- |Set a variable in a given namespace
setNamespacedVar 
    :: Env      -- ^ Environment 
    -> Char     -- ^ Namespace
    -> String   -- ^ Variable
    -> LispVal  -- ^ Value
    -> IOThrowsError LispVal   -- ^ Value
setNamespacedVar :: Env -> Char -> String -> LispVal -> IOThrowsError LispVal
setNamespacedVar Env
envRef
                 Char
namespace
                 String
var LispVal
value = do 
  -- Issue #98 - Need to detect circular references
  --
  -- TODO:
  -- Note this implementation is rather simplistic since
  -- it does not take environments into account. The same
  -- variable name could refer to 2 different variables in
  -- different environments.
  case LispVal
value of
    Pointer String
p Env
_ -> do
      if String
p String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
var 
          then LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
value
          else IOThrowsError LispVal
next
    LispVal
_ -> IOThrowsError LispVal
next

  where 
    next :: IOThrowsError LispVal
next = do
      LispVal
_ <- Env -> Char -> String -> IOThrowsError LispVal
updatePointers Env
envRef Char
namespace String
var 
      Env -> Char -> String -> LispVal -> IOThrowsError LispVal
_setNamespacedVar Env
envRef Char
namespace String
var LispVal
value

-- |An internal function that does the actual setting of a 
--  variable, without all the extra code that keeps pointers
--  in sync when a variable is re-binded
--
--  Note this function still binds reverse pointers
--  for purposes of book-keeping.
_setNamespacedVar 
    :: Env      -- ^ Environment 
    -> Char     -- ^ Namespace
    -> String   -- ^ Variable
    -> LispVal  -- ^ Value
    -> IOThrowsError LispVal   -- ^ Value
_setNamespacedVar :: Env -> Char -> String -> LispVal -> IOThrowsError LispVal
_setNamespacedVar Env
envRef
                 Char
namespace
                 String
var LispVal
value = do 
  -- Set the variable to its new value
  LispVal
valueToStore <- Char -> String -> Env -> LispVal -> IOThrowsError LispVal
getValueToStore Char
namespace String
var Env
envRef LispVal
value
  Env -> Char -> String -> LispVal -> IOThrowsError LispVal
_setNamespacedVarDirect Env
envRef Char
namespace String
var LispVal
valueToStore

-- |Do the actual /set/ operation, with NO pointer operations.
--  Only call this if you know what you are doing!
_setNamespacedVarDirect
    :: Env      -- ^ Environment 
    -> Char     -- ^ Namespace
    -> String   -- ^ Variable
    -> LispVal  -- ^ Value
    -> IOThrowsError LispVal   -- ^ Value
_setNamespacedVarDirect :: Env -> Char -> String -> LispVal -> IOThrowsError LispVal
_setNamespacedVarDirect Env
envRef
                 Char
namespace
                 String
var LispVal
valueToStore = do 
  Map String (IORef LispVal)
env <- IO (Map String (IORef LispVal))
-> ExceptT LispError IO (Map String (IORef LispVal))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map String (IORef LispVal))
 -> ExceptT LispError IO (Map String (IORef LispVal)))
-> IO (Map String (IORef LispVal))
-> ExceptT LispError IO (Map String (IORef LispVal))
forall a b. (a -> b) -> a -> b
$ IORef (Map String (IORef LispVal))
-> IO (Map String (IORef LispVal))
forall a. IORef a -> IO a
readIORef (IORef (Map String (IORef LispVal))
 -> IO (Map String (IORef LispVal)))
-> IORef (Map String (IORef LispVal))
-> IO (Map String (IORef LispVal))
forall a b. (a -> b) -> a -> b
$ Env -> IORef (Map String (IORef LispVal))
bindings Env
envRef
  case String -> Map String (IORef LispVal) -> Maybe (IORef LispVal)
forall k a. Ord k => k -> Map k a -> Maybe a
Data.Map.lookup (Char -> String -> String
getVarName Char
namespace String
var) Map String (IORef LispVal)
env of
    (Just IORef LispVal
a) -> do
      IO () -> ExceptT LispError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT LispError IO ())
-> IO () -> ExceptT LispError IO ()
forall a b. (a -> b) -> a -> b
$ IORef LispVal -> LispVal -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef LispVal
a LispVal
valueToStore
      LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
valueToStore
    Maybe (IORef LispVal)
Nothing -> case Env -> Maybe Env
parentEnv Env
envRef of
      (Just Env
par) -> Env -> Char -> String -> LispVal -> IOThrowsError LispVal
_setNamespacedVarDirect Env
par Char
namespace String
var LispVal
valueToStore
      Maybe Env
Nothing -> LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> String -> LispError
UnboundVar String
"Setting an unbound variable: " String
var

-- |This helper function is used to keep pointers in sync when
--  a variable is bound to a different value.
updatePointers :: Env -> Char -> String -> IOThrowsError LispVal
updatePointers :: Env -> Char -> String -> IOThrowsError LispVal
updatePointers Env
envRef Char
namespace String
var = do
  Map String (IORef [LispVal])
ptrs <- IO (Map String (IORef [LispVal]))
-> ExceptT LispError IO (Map String (IORef [LispVal]))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map String (IORef [LispVal]))
 -> ExceptT LispError IO (Map String (IORef [LispVal])))
-> IO (Map String (IORef [LispVal]))
-> ExceptT LispError IO (Map String (IORef [LispVal]))
forall a b. (a -> b) -> a -> b
$ IORef (Map String (IORef [LispVal]))
-> IO (Map String (IORef [LispVal]))
forall a. IORef a -> IO a
readIORef (IORef (Map String (IORef [LispVal]))
 -> IO (Map String (IORef [LispVal])))
-> IORef (Map String (IORef [LispVal]))
-> IO (Map String (IORef [LispVal]))
forall a b. (a -> b) -> a -> b
$ Env -> IORef (Map String (IORef [LispVal]))
pointers Env
envRef
  case String -> Map String (IORef [LispVal]) -> Maybe (IORef [LispVal])
forall k a. Ord k => k -> Map k a -> Maybe a
Data.Map.lookup (Char -> String -> String
getVarName Char
namespace String
var) Map String (IORef [LispVal])
ptrs of
    (Just IORef [LispVal]
valIORef) -> do
      [LispVal]
val <- IO [LispVal] -> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [LispVal] -> ExceptT LispError IO [LispVal])
-> IO [LispVal] -> ExceptT LispError IO [LispVal]
forall a b. (a -> b) -> a -> b
$ IORef [LispVal] -> IO [LispVal]
forall a. IORef a -> IO a
readIORef IORef [LispVal]
valIORef
      case [LispVal]
val of 
        -- If var has any pointers, then we need to 
        -- assign the first pointer to the old value
        -- of x, and the rest need to be updated to 
        -- point to that first var

        -- This is the first pointer to (the old) var
        (Pointer String
pVar Env
pEnv : [LispVal]
ps) -> do
          -- Since var is now fresh, reset its pointers list
          IO () -> ExceptT LispError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT LispError IO ())
-> IO () -> ExceptT LispError IO ()
forall a b. (a -> b) -> a -> b
$ IORef [LispVal] -> [LispVal] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [LispVal]
valIORef []

          -- The first pointer now becomes the old var,
          -- so its pointers list should become ps
          LispVal
_ <- Env -> Char -> String -> [LispVal] -> IOThrowsError LispVal
movePointers Env
pEnv Char
namespace String
pVar [LispVal]
ps

          -- Each ps needs to be updated to point to pVar
          -- instead of var
          LispVal
_ <- Env -> Char -> String -> [LispVal] -> IOThrowsError LispVal
pointToNewVar Env
pEnv Char
namespace String
pVar [LispVal]
ps

          -- Set first pointer to existing value of var
          LispVal
existingValue <- Env -> Char -> String -> IOThrowsError LispVal
getNamespacedVar Env
envRef Char
namespace String
var
          Env -> Char -> String -> LispVal -> IOThrowsError LispVal
_setNamespacedVar Env
pEnv Char
namespace String
pVar LispVal
existingValue

        -- No pointers, so nothing to do
        [] -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Nil String
""
        [LispVal]
_ -> LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispError
InternalError
               String
"non-pointer value found in updatePointers"
    Maybe (IORef [LispVal])
Nothing -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Nil String
""
 where
  -- |Move the given pointers (ptr) to the list of
  --  pointers for variable (var)
  movePointers :: Env -> Char -> String -> [LispVal] -> IOThrowsError LispVal
  movePointers :: Env -> Char -> String -> [LispVal] -> IOThrowsError LispVal
movePointers Env
envRef' Char
namespace' String
var' [LispVal]
ptrs = do
    Map String (IORef [LispVal])
env <- IO (Map String (IORef [LispVal]))
-> ExceptT LispError IO (Map String (IORef [LispVal]))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map String (IORef [LispVal]))
 -> ExceptT LispError IO (Map String (IORef [LispVal])))
-> IO (Map String (IORef [LispVal]))
-> ExceptT LispError IO (Map String (IORef [LispVal]))
forall a b. (a -> b) -> a -> b
$ IORef (Map String (IORef [LispVal]))
-> IO (Map String (IORef [LispVal]))
forall a. IORef a -> IO a
readIORef (IORef (Map String (IORef [LispVal]))
 -> IO (Map String (IORef [LispVal])))
-> IORef (Map String (IORef [LispVal]))
-> IO (Map String (IORef [LispVal]))
forall a b. (a -> b) -> a -> b
$ Env -> IORef (Map String (IORef [LispVal]))
pointers Env
envRef'
    case String -> Map String (IORef [LispVal]) -> Maybe (IORef [LispVal])
forall k a. Ord k => k -> Map k a -> Maybe a
Data.Map.lookup (Char -> String -> String
getVarName Char
namespace' String
var') Map String (IORef [LispVal])
env of
      Just IORef [LispVal]
ps' -> do
        -- Append ptrs to existing list of pointers to var
        [LispVal]
ps <- IO [LispVal] -> ExceptT LispError IO [LispVal]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [LispVal] -> ExceptT LispError IO [LispVal])
-> IO [LispVal] -> ExceptT LispError IO [LispVal]
forall a b. (a -> b) -> a -> b
$ IORef [LispVal] -> IO [LispVal]
forall a. IORef a -> IO a
readIORef IORef [LispVal]
ps'
        IO () -> ExceptT LispError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT LispError IO ())
-> IO () -> ExceptT LispError IO ()
forall a b. (a -> b) -> a -> b
$ IORef [LispVal] -> [LispVal] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [LispVal]
ps' ([LispVal] -> IO ()) -> [LispVal] -> IO ()
forall a b. (a -> b) -> a -> b
$ [LispVal]
ps [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [LispVal]
ptrs
        LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Nil String
""
      Maybe (IORef [LispVal])
Nothing -> do
        -- var does not have any pointers; create new list
        IORef [LispVal]
valueRef <- IO (IORef [LispVal]) -> ExceptT LispError IO (IORef [LispVal])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef [LispVal]) -> ExceptT LispError IO (IORef [LispVal]))
-> IO (IORef [LispVal]) -> ExceptT LispError IO (IORef [LispVal])
forall a b. (a -> b) -> a -> b
$ [LispVal] -> IO (IORef [LispVal])
forall a. a -> IO (IORef a)
newIORef [LispVal]
ptrs
        IO () -> ExceptT LispError IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT LispError IO ())
-> IO () -> ExceptT LispError IO ()
forall a b. (a -> b) -> a -> b
$ IORef (Map String (IORef [LispVal]))
-> Map String (IORef [LispVal]) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Env -> IORef (Map String (IORef [LispVal]))
pointers Env
envRef') (String
-> IORef [LispVal]
-> Map String (IORef [LispVal])
-> Map String (IORef [LispVal])
forall k a. Ord k => k -> a -> Map k a -> Map k a
Data.Map.insert (Char -> String -> String
getVarName Char
namespace String
var') IORef [LispVal]
valueRef Map String (IORef [LispVal])
env)
        LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Nil String
""

  -- |Update each pointer's source to point to pVar
  pointToNewVar :: Env -> Char -> String -> [LispVal] -> IOThrowsError LispVal
pointToNewVar Env
pEnv Char
namespace' String
pVar' (Pointer String
v Env
e : [LispVal]
ps) = do
    LispVal
_ <- Env -> Char -> String -> LispVal -> IOThrowsError LispVal
_setNamespacedVarDirect Env
e Char
namespace' String
v (String -> Env -> LispVal
Pointer String
pVar' Env
pEnv)
    Env -> Char -> String -> [LispVal] -> IOThrowsError LispVal
pointToNewVar Env
pEnv Char
namespace' String
pVar' [LispVal]
ps
  pointToNewVar Env
_ Char
_ String
_ [] = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispVal
Nil String
""
  pointToNewVar Env
_ Char
_ String
_ [LispVal]
_ = LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> LispError
InternalError String
"pointToNewVar"

-- |A wrapper for updateNamespaceObject that uses the variable namespace.
updateObject :: Env -> String -> LispVal -> IOThrowsError LispVal
updateObject :: Env -> String -> LispVal -> IOThrowsError LispVal
updateObject Env
env = 
  Env -> Char -> String -> LispVal -> IOThrowsError LispVal
updateNamespacedObject Env
env Char
varNamespace

-- |This function updates the object that the variable refers to. If it is
--  a pointer, that means this function will update that pointer (or the last
--  pointer in the chain) to point to the given /value/ object. If the variable
--  is not a pointer, the result is the same as a setVar (but without updating
--  any pointer references, see below).
--
--  Note this function only updates the object, it does not
--  update any associated pointers. So it should probably only be
--  used internally by husk, unless you really know what you are
--  doing!
updateNamespacedObject :: Env                   -- ^ Environment
                       -> Char                  -- ^ Namespace
                       -> String                -- ^ Variable
                       -> LispVal               -- ^ Value
                       -> IOThrowsError LispVal -- ^ Value
updateNamespacedObject :: Env -> Char -> String -> LispVal -> IOThrowsError LispVal
updateNamespacedObject Env
env Char
namespace String
var LispVal
value = do
  LispVal
varContents <- Env -> Char -> String -> IOThrowsError LispVal
getNamespacedVar Env
env Char
namespace String
var
  LispVal
obj <- LispVal -> IOThrowsError LispVal
findPointerTo LispVal
varContents
  case LispVal
obj of
    Pointer String
pVar Env
pEnv -> do
      Env -> Char -> String -> LispVal -> IOThrowsError LispVal
_setNamespacedVar Env
pEnv Char
namespace String
pVar LispVal
value
    LispVal
_ -> Env -> Char -> String -> LispVal -> IOThrowsError LispVal
_setNamespacedVar Env
env Char
namespace String
var LispVal
value

-- |Bind a variable in the default namespace
defineVar
    :: Env      -- ^ Environment
    -> String   -- ^ Variable
    -> LispVal  -- ^ Value
    -> IOThrowsError LispVal -- ^ Value
defineVar :: Env -> String -> LispVal -> IOThrowsError LispVal
defineVar Env
envRef = Env -> Char -> String -> LispVal -> IOThrowsError LispVal
defineNamespacedVar Env
envRef Char
varNamespace 

-- |Bind a variable in the given namespace
defineNamespacedVar
    :: Env      -- ^ Environment 
    -> Char     -- ^ Namespace
    -> String   -- ^ Variable
    -> LispVal  -- ^ Value
    -> IOThrowsError LispVal   -- ^ Value
defineNamespacedVar :: Env -> Char -> String -> LispVal -> IOThrowsError LispVal
defineNamespacedVar Env
envRef
                    Char
namespace
                    String
var LispVal
value = do
  Bool
alreadyDefined <- IO Bool -> ExceptT LispError IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ExceptT LispError IO Bool)
-> IO Bool -> ExceptT LispError IO Bool
forall a b. (a -> b) -> a -> b
$ Env -> Char -> String -> IO Bool
isNamespacedBound Env
envRef Char
namespace String
var
  if Bool
alreadyDefined
    then Env -> Char -> String -> LispVal -> IOThrowsError LispVal
setNamespacedVar Env
envRef Char
namespace String
var LispVal
value IOThrowsError LispVal
-> IOThrowsError LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
value
    else do
      --
      -- Future optimization:
      -- don't change anything if (define) is to existing pointer
      -- (IE, it does not really change anything)
      --


      -- If we are assigning to a pointer, we need a reverse lookup to 
      -- note that the pointer @value@ points to @var@
      -- 
      -- So run through this logic to figure out what exactly to store,
      -- both for bindings and for rev-lookup pointers
      LispVal
valueToStore <- Char -> String -> Env -> LispVal -> IOThrowsError LispVal
getValueToStore Char
namespace String
var Env
envRef LispVal
value
      IO LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LispVal -> IOThrowsError LispVal)
-> IO LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ do
        -- Write new value binding
        IORef LispVal
valueRef <- LispVal -> IO (IORef LispVal)
forall a. a -> IO (IORef a)
newIORef LispVal
valueToStore
        Map String (IORef LispVal)
env <- IORef (Map String (IORef LispVal))
-> IO (Map String (IORef LispVal))
forall a. IORef a -> IO a
readIORef (IORef (Map String (IORef LispVal))
 -> IO (Map String (IORef LispVal)))
-> IORef (Map String (IORef LispVal))
-> IO (Map String (IORef LispVal))
forall a b. (a -> b) -> a -> b
$ Env -> IORef (Map String (IORef LispVal))
bindings Env
envRef
        IORef (Map String (IORef LispVal))
-> Map String (IORef LispVal) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Env -> IORef (Map String (IORef LispVal))
bindings Env
envRef) (String
-> IORef LispVal
-> Map String (IORef LispVal)
-> Map String (IORef LispVal)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Data.Map.insert (Char -> String -> String
getVarName Char
namespace String
var) IORef LispVal
valueRef Map String (IORef LispVal)
env)
        LispVal -> IO LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
valueToStore

-- |An internal helper function to get the value to save to an env
--  based on the value passed to the define/set function. Normally this
--  is straightforward, but there is book-keeping involved if a
--  pointer is passed, depending on if the pointer resolves to an object.
getValueToStore :: Char -> String -> Env -> LispVal -> IOThrowsError LispVal
getValueToStore :: Char -> String -> Env -> LispVal -> IOThrowsError LispVal
getValueToStore Char
namespace String
var Env
env (Pointer String
p Env
pEnv) = do
  Char
-> String -> Env -> Char -> String -> Env -> IOThrowsError LispVal
addReversePointer Char
namespace String
p Env
pEnv Char
namespace String
var Env
env
getValueToStore Char
_ String
_ Env
_ LispVal
value = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
value

-- |Accept input for a pointer (ptrVar) and a variable that the pointer is going
--  to be assigned to. If that variable is an object then we setup a reverse lookup
--  for future book-keeping. Otherwise, we just look it up and return it directly, 
--  no booking-keeping required.
addReversePointer :: Char -> String -> Env -> Char -> String -> Env -> IOThrowsError LispVal
addReversePointer :: Char
-> String -> Env -> Char -> String -> Env -> IOThrowsError LispVal
addReversePointer Char
namespace String
var Env
envRef Char
ptrNamespace String
ptrVar Env
ptrEnvRef = do
   Map String (IORef LispVal)
env <- IO (Map String (IORef LispVal))
-> ExceptT LispError IO (Map String (IORef LispVal))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map String (IORef LispVal))
 -> ExceptT LispError IO (Map String (IORef LispVal)))
-> IO (Map String (IORef LispVal))
-> ExceptT LispError IO (Map String (IORef LispVal))
forall a b. (a -> b) -> a -> b
$ IORef (Map String (IORef LispVal))
-> IO (Map String (IORef LispVal))
forall a. IORef a -> IO a
readIORef (IORef (Map String (IORef LispVal))
 -> IO (Map String (IORef LispVal)))
-> IORef (Map String (IORef LispVal))
-> IO (Map String (IORef LispVal))
forall a b. (a -> b) -> a -> b
$ Env -> IORef (Map String (IORef LispVal))
bindings Env
envRef
   case String -> Map String (IORef LispVal) -> Maybe (IORef LispVal)
forall k a. Ord k => k -> Map k a -> Maybe a
Data.Map.lookup (Char -> String -> String
getVarName Char
namespace String
var) Map String (IORef LispVal)
env of
     (Just IORef LispVal
a) -> do
       LispVal
v <- IO LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LispVal -> IOThrowsError LispVal)
-> IO LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ IORef LispVal -> IO LispVal
forall a. IORef a -> IO a
readIORef IORef LispVal
a
       if LispVal -> Bool
isObject LispVal
v
          then do
            -- Store a reverse pointer for book keeping
            Map String (IORef [LispVal])
ptrs <- IO (Map String (IORef [LispVal]))
-> ExceptT LispError IO (Map String (IORef [LispVal]))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map String (IORef [LispVal]))
 -> ExceptT LispError IO (Map String (IORef [LispVal])))
-> IO (Map String (IORef [LispVal]))
-> ExceptT LispError IO (Map String (IORef [LispVal]))
forall a b. (a -> b) -> a -> b
$ IORef (Map String (IORef [LispVal]))
-> IO (Map String (IORef [LispVal]))
forall a. IORef a -> IO a
readIORef (IORef (Map String (IORef [LispVal]))
 -> IO (Map String (IORef [LispVal])))
-> IORef (Map String (IORef [LispVal]))
-> IO (Map String (IORef [LispVal]))
forall a b. (a -> b) -> a -> b
$ Env -> IORef (Map String (IORef [LispVal]))
pointers Env
envRef
            
            -- Lookup ptr for var
            case String -> Map String (IORef [LispVal]) -> Maybe (IORef [LispVal])
forall k a. Ord k => k -> Map k a -> Maybe a
Data.Map.lookup (Char -> String -> String
getVarName Char
namespace String
var) Map String (IORef [LispVal])
ptrs of
              -- Append another reverse ptr to this var
              -- FUTURE: make sure ptr is not already there, 
              --         before adding it to the list again?
              (Just IORef [LispVal]
valueRef) -> IO LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LispVal -> IOThrowsError LispVal)
-> IO LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ do
                [LispVal]
value <- IORef [LispVal] -> IO [LispVal]
forall a. IORef a -> IO a
readIORef IORef [LispVal]
valueRef
                IORef [LispVal] -> [LispVal] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [LispVal]
valueRef ([LispVal]
value [LispVal] -> [LispVal] -> [LispVal]
forall a. [a] -> [a] -> [a]
++ [String -> Env -> LispVal
Pointer String
ptrVar Env
ptrEnvRef])
                LispVal -> IO LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IO LispVal) -> LispVal -> IO LispVal
forall a b. (a -> b) -> a -> b
$ String -> Env -> LispVal
Pointer String
var Env
envRef 

              -- No mapping, add the first reverse pointer
              Maybe (IORef [LispVal])
Nothing -> IO LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO LispVal -> IOThrowsError LispVal)
-> IO LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ do
                IORef [LispVal]
valueRef <- [LispVal] -> IO (IORef [LispVal])
forall a. a -> IO (IORef a)
newIORef [String -> Env -> LispVal
Pointer String
ptrVar Env
ptrEnvRef]
                IORef (Map String (IORef [LispVal]))
-> Map String (IORef [LispVal]) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Env -> IORef (Map String (IORef [LispVal]))
pointers Env
envRef) (String
-> IORef [LispVal]
-> Map String (IORef [LispVal])
-> Map String (IORef [LispVal])
forall k a. Ord k => k -> a -> Map k a -> Map k a
Data.Map.insert (Char -> String -> String
getVarName Char
namespace String
var) IORef [LispVal]
valueRef Map String (IORef [LispVal])
ptrs)
                LispVal -> IO LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IO LispVal) -> LispVal -> IO LispVal
forall a b. (a -> b) -> a -> b
$ String -> Env -> LispVal
Pointer String
var Env
envRef -- Return non-reverse ptr to caller
          else LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
v -- Not an object, return value directly
     Maybe (IORef LispVal)
Nothing -> case Env -> Maybe Env
parentEnv Env
envRef of
       (Just Env
par) -> Char
-> String -> Env -> Char -> String -> Env -> IOThrowsError LispVal
addReversePointer Char
namespace String
var Env
par Char
ptrNamespace String
ptrVar Env
ptrEnvRef
       Maybe Env
Nothing -> LispError -> IOThrowsError LispVal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (LispError -> IOThrowsError LispVal)
-> LispError -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ String -> String -> LispError
UnboundVar String
"Getting an unbound variable: " String
var

-- |Return a value with a pointer dereferenced, if necessary
derefPtr :: LispVal -> IOThrowsError LispVal
-- Try dereferencing again if a ptr is found
--
-- Not sure if this is the best solution; it would be 
-- nice if we did not have to worry about multiple levels
-- of ptrs, especially since I believe husk only needs to 
-- have one level. but for now we will go with this to
-- move forward.
--
derefPtr :: LispVal -> IOThrowsError LispVal
derefPtr (Pointer String
p Env
env) = do
    LispVal
result <- Env -> String -> IOThrowsError LispVal
getVar Env
env String
p
    LispVal -> IOThrowsError LispVal
derefPtr LispVal
result
derefPtr LispVal
v = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
v

-- -- |Return the given list of values, but if any of the
-- --  original values is a pointer it will be dereferenced
-- derefPtrs :: [LispVal] -> IOThrowsError LispVal
-- derefPtrs lvs = mapM (liftThrows $ derefPtr) lvs

-- |Recursively process the given data structure, dereferencing
--  any pointers found along the way. 
-- 
--  This could potentially be expensive on large data structures 
--  since it must walk the entire object.
recDerefPtrs :: LispVal -> IOThrowsError LispVal
recDerefPtrs :: LispVal -> IOThrowsError LispVal
recDerefPtrs = [LispVal] -> LispVal -> IOThrowsError LispVal
safeRecDerefPtrs []

-- |Attempt to dereference pointers safely, without being caught in a cycle
safeRecDerefPtrs :: [LispVal] -> LispVal -> IOThrowsError LispVal
#ifdef UsePointers
safeRecDerefPtrs :: [LispVal] -> LispVal -> IOThrowsError LispVal
safeRecDerefPtrs [LispVal]
ps (List [LispVal]
l) = do
    [LispVal]
result <- (LispVal -> IOThrowsError LispVal)
-> [LispVal] -> ExceptT LispError IO [LispVal]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([LispVal] -> LispVal -> IOThrowsError LispVal
safeRecDerefPtrs [LispVal]
ps) [LispVal]
l
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal]
result
safeRecDerefPtrs [LispVal]
ps (DottedList [LispVal]
ls LispVal
l) = do
    [LispVal]
ds <- (LispVal -> IOThrowsError LispVal)
-> [LispVal] -> ExceptT LispError IO [LispVal]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([LispVal] -> LispVal -> IOThrowsError LispVal
safeRecDerefPtrs [LispVal]
ps) [LispVal]
ls
    LispVal
d <- [LispVal] -> LispVal -> IOThrowsError LispVal
safeRecDerefPtrs [LispVal]
ps LispVal
l
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal -> LispVal
DottedList [LispVal]
ds LispVal
d
safeRecDerefPtrs [LispVal]
ps (Vector Array Int LispVal
v) = do
   let vs :: [LispVal]
vs = Array Int LispVal -> [LispVal]
forall i e. Array i e -> [e]
elems Array Int LispVal
v
   [LispVal]
ds <- (LispVal -> IOThrowsError LispVal)
-> [LispVal] -> ExceptT LispError IO [LispVal]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([LispVal] -> LispVal -> IOThrowsError LispVal
safeRecDerefPtrs [LispVal]
ps) [LispVal]
vs
   LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Array Int LispVal -> LispVal
Vector (Array Int LispVal -> LispVal) -> Array Int LispVal -> LispVal
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> [LispVal] -> Array Int LispVal
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, [LispVal] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LispVal]
vs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [LispVal]
ds
safeRecDerefPtrs [LispVal]
ps (HashTable Map LispVal LispVal
ht) = do
    [LispVal]
ks <- (LispVal -> IOThrowsError LispVal)
-> [LispVal] -> ExceptT LispError IO [LispVal]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([LispVal] -> LispVal -> IOThrowsError LispVal
safeRecDerefPtrs [LispVal]
ps)([LispVal] -> ExceptT LispError IO [LispVal])
-> [LispVal] -> ExceptT LispError IO [LispVal]
forall a b. (a -> b) -> a -> b
$ ((LispVal, LispVal) -> LispVal)
-> [(LispVal, LispVal)] -> [LispVal]
forall a b. (a -> b) -> [a] -> [b]
map (\ (LispVal
k, LispVal
_) -> LispVal
k) ([(LispVal, LispVal)] -> [LispVal])
-> [(LispVal, LispVal)] -> [LispVal]
forall a b. (a -> b) -> a -> b
$ Map LispVal LispVal -> [(LispVal, LispVal)]
forall k a. Map k a -> [(k, a)]
Data.Map.toList Map LispVal LispVal
ht
    [LispVal]
vs <- (LispVal -> IOThrowsError LispVal)
-> [LispVal] -> ExceptT LispError IO [LispVal]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([LispVal] -> LispVal -> IOThrowsError LispVal
safeRecDerefPtrs [LispVal]
ps)([LispVal] -> ExceptT LispError IO [LispVal])
-> [LispVal] -> ExceptT LispError IO [LispVal]
forall a b. (a -> b) -> a -> b
$ ((LispVal, LispVal) -> LispVal)
-> [(LispVal, LispVal)] -> [LispVal]
forall a b. (a -> b) -> [a] -> [b]
map (\ (LispVal
_, LispVal
v) -> LispVal
v) ([(LispVal, LispVal)] -> [LispVal])
-> [(LispVal, LispVal)] -> [LispVal]
forall a b. (a -> b) -> a -> b
$ Map LispVal LispVal -> [(LispVal, LispVal)]
forall k a. Map k a -> [(k, a)]
Data.Map.toList Map LispVal LispVal
ht
    LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ Map LispVal LispVal -> LispVal
HashTable (Map LispVal LispVal -> LispVal) -> Map LispVal LispVal -> LispVal
forall a b. (a -> b) -> a -> b
$ [(LispVal, LispVal)] -> Map LispVal LispVal
forall k a. Ord k => [(k, a)] -> Map k a
Data.Map.fromList ([(LispVal, LispVal)] -> Map LispVal LispVal)
-> [(LispVal, LispVal)] -> Map LispVal LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> [LispVal] -> [(LispVal, LispVal)]
forall a b. [a] -> [b] -> [(a, b)]
zip [LispVal]
ks [LispVal]
vs
#endif
safeRecDerefPtrs [LispVal]
ps ptr :: LispVal
ptr@(Pointer String
p Env
env) = do
    if [LispVal] -> LispVal -> Bool
containsPtr [LispVal]
ps LispVal
ptr
       then LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
ptr -- Avoid cycle
       else do
            LispVal
result <- Env -> String -> IOThrowsError LispVal
getVar Env
env String
p
            [LispVal] -> LispVal -> IOThrowsError LispVal
safeRecDerefPtrs (LispVal
ptr LispVal -> [LispVal] -> [LispVal]
forall a. a -> [a] -> [a]
: [LispVal]
ps) LispVal
result 
safeRecDerefPtrs [LispVal]
_ LispVal
v = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
v

containsPtr :: [LispVal] -> LispVal -> Bool
containsPtr :: [LispVal] -> LispVal -> Bool
containsPtr ((Pointer String
pa Env
ea):[LispVal]
ps) p :: LispVal
p@(Pointer String
pb Env
eb) = do
    let found :: Bool
found = (String
pa String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
pb) Bool -> Bool -> Bool
&& ((Env -> IORef (Map String (IORef LispVal))
bindings Env
ea) IORef (Map String (IORef LispVal))
-> IORef (Map String (IORef LispVal)) -> Bool
forall a. Eq a => a -> a -> Bool
== (Env -> IORef (Map String (IORef LispVal))
bindings Env
eb))
    Bool
found Bool -> Bool -> Bool
|| [LispVal] -> LispVal -> Bool
containsPtr [LispVal]
ps LispVal
p
containsPtr [LispVal]
_ LispVal
_ = Bool
False

-- |A helper to recursively dereference all pointers and
--  pass results to a function
recDerefToFnc :: ([LispVal] -> ThrowsError LispVal) -> [LispVal] 
            -> IOThrowsError LispVal
recDerefToFnc :: ([LispVal] -> ThrowsError LispVal)
-> [LispVal] -> IOThrowsError LispVal
recDerefToFnc [LispVal] -> ThrowsError LispVal
fnc [LispVal]
lvs = do
    List [LispVal]
result <- LispVal -> IOThrowsError LispVal
recDerefPtrs (LispVal -> IOThrowsError LispVal)
-> LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> LispVal
List [LispVal]
lvs 
    ThrowsError LispVal -> IOThrowsError LispVal
forall a. ThrowsError a -> IOThrowsError a
liftThrows (ThrowsError LispVal -> IOThrowsError LispVal)
-> ThrowsError LispVal -> IOThrowsError LispVal
forall a b. (a -> b) -> a -> b
$ [LispVal] -> ThrowsError LispVal
fnc [LispVal]
result

-- |A predicate to determine if the given lisp value 
--  is an /object/ that can be pointed to.
isObject :: LispVal -> Bool
isObject :: LispVal -> Bool
isObject (List [LispVal]
_) = Bool
True
isObject (DottedList [LispVal]
_ LispVal
_) = Bool
True
isObject (String String
_) = Bool
True
isObject (Vector Array Int LispVal
_) = Bool
True
isObject (HashTable Map LispVal LispVal
_) = Bool
True
isObject (ByteVector ByteString
_) = Bool
True
isObject (Pointer String
_ Env
_) = Bool
True
isObject LispVal
_ = Bool
False

-- |Same as dereferencing a pointer, except we want the
--  last pointer to an object (if there is one) instead
--  of the object itself
findPointerTo :: LispVal -> IOThrowsError LispVal
findPointerTo :: LispVal -> IOThrowsError LispVal
findPointerTo ptr :: LispVal
ptr@(Pointer String
p Env
env) = do
    LispVal
result <- Env -> String -> IOThrowsError LispVal
getVar Env
env String
p
    case LispVal
result of
      (Pointer String
_ Env
_) -> LispVal -> IOThrowsError LispVal
findPointerTo LispVal
result
      LispVal
_ -> LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
ptr
findPointerTo LispVal
v = LispVal -> IOThrowsError LispVal
forall (m :: * -> *) a. Monad m => a -> m a
return LispVal
v