1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
|
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
|
