haskell/Env.hs

   1 module Env
   2 ( Env, env_new, null_env, env_bind, env_find, env_get, env_set )
   3 where
   4
   5 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
   6 import Control.Monad.Trans (liftIO)
   7 import Data.List (elemIndex)
   8 import qualified Data.Map  as Map
   9
  10 import Types
  11 import Printer
  12
  13 -- These Env types are defined in Types module to avoid dep cycle
  14 --data EnvData = EnvPair (Maybe Env, (Map.Map String MalVal))
  15 --type Env = IORef EnvData
  16
  17 env_new :: Maybe Env -> IO Env
  18 env_new outer  = newIORef $ EnvPair (outer, (Map.fromList []))
  19
  20 null_env = env_new Nothing
  21
  22 env_bind :: Env -> [MalVal] -> [MalVal] -> IO Env
  23 env_bind envRef binds exprs = do
  24     case (elemIndex (MalSymbol "&") binds) of
  25         Nothing  -> do
  26             -- bind binds to exprs
  27             _ <- mapM (\(b,e) -> env_set envRef b e) $ zip binds exprs
  28             return envRef
  29         Just idx -> do
  30             -- Varargs binding
  31             _ <- mapM (\(b,e) -> env_set envRef b e) $
  32                 zip (take idx binds) (take idx exprs)
  33             _ <- env_set envRef (binds !! (idx + 1))
  34                                 (MalList (drop idx exprs) Nil)
  35             return envRef
  36
  37 env_find :: Env -> MalVal -> IO (Maybe Env)
  38 env_find envRef sym@(MalSymbol key) = do
  39     e <- readIORef envRef
  40     case e of
  41         EnvPair (o, m) -> case Map.lookup key m of
  42                                Nothing  -> case o of
  43                                                 Nothing -> return Nothing
  44                                                 Just o  -> env_find o sym
  45                                Just val -> return $ Just envRef
  46
  47 env_get :: Env -> MalVal -> IOThrows MalVal
  48 env_get envRef sym@(MalSymbol key) = do
  49     e1 <- liftIO $ env_find envRef sym
  50     case e1 of
  51          Nothing   -> throwStr $ "'" ++ key ++ "' not found"
  52          Just eRef -> do
  53             e2 <- liftIO $ readIORef eRef
  54             case e2 of
  55                 EnvPair (o,m) -> case Map.lookup key m of
  56                                       Nothing  -> throwStr $ "env_get error"
  57                                       Just val -> return val
  58
  59
  60 env_set :: Env -> MalVal -> MalVal -> IO MalVal
  61 env_set envRef (MalSymbol key) val = do
  62     e <- readIORef envRef
  63     case e of
  64         EnvPair (o,m) -> writeIORef envRef $ EnvPair (o, (Map.insert key val m))
  65     return val