mal/haskell/Env.hs

module Env
( Env, env_new, null_env, env_bind, env_find, env_get, env_set )
where

import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Control.Monad.Trans (liftIO)
import Data.List (elemIndex)
import qualified Data.Map  as Map

import Types
import Printer

-- These Env types are defined in Types module to avoid dep cycle
--data EnvData = EnvPair (Maybe Env, (Map.Map String MalVal))
--type Env = IORef EnvData

env_new :: Maybe Env -> IO Env
env_new outer  = newIORef $ EnvPair (outer, (Map.fromList []))

null_env = env_new Nothing

env_bind :: Env -> [MalVal] -> [MalVal] -> IO Env
env_bind envRef binds exprs = do
    case (elemIndex (MalSymbol "&") binds) of
        Nothing  -> do
            -- bind binds to exprs
            _ <- mapM (\(b,e) -> env_set envRef b e) $ zip binds exprs
            return envRef
        Just idx -> do
            -- Varargs binding
            _ <- mapM (\(b,e) -> env_set envRef b e) $
                zip (take idx binds) (take idx exprs)
            _ <- env_set envRef (binds !! (idx + 1))
                                (MalList (drop idx exprs) Nil)
            return envRef

env_find :: Env -> MalVal -> IO (Maybe Env)
env_find envRef sym@(MalSymbol key) = do
    e <- readIORef envRef
    case e of
        EnvPair (o, m) -> case Map.lookup key m of
                               Nothing  -> case o of
                                                Nothing -> return Nothing
                                                Just o  -> env_find o sym
                               Just val -> return $ Just envRef

env_get :: Env -> MalVal -> IOThrows MalVal
env_get envRef sym@(MalSymbol key) = do
    e1 <- liftIO $ env_find envRef sym
    case e1 of
         Nothing   -> throwStr $ "'" ++ key ++ "' not found"
         Just eRef -> do
            e2 <- liftIO $ readIORef eRef
            case e2 of
                EnvPair (o,m) -> case Map.lookup key m of
                                      Nothing  -> throwStr $ "env_get error"
                                      Just val -> return val


env_set :: Env -> MalVal -> MalVal -> IO MalVal
env_set envRef (MalSymbol key) val = do
    e <- readIORef envRef
    case e of
        EnvPair (o,m) -> writeIORef envRef $ EnvPair (o, (Map.insert key val m))
    return val