haskell/step3_env.hs

   1 import System.IO (hGetLine, hFlush, hIsEOF, stdin, stdout)
   2 import Control.Monad (when, mapM)
   3 import Control.Monad.Error (throwError)
   4 import qualified Data.Map as Map
   5 import qualified Data.Traversable as DT
   6
   7 import Types
   8 import Reader (read_str)
   9 import Printer (_pr_str)
  10 import Env (Env, env_new, env_get, env_set)
  11
  12 -- read
  13 mal_read :: String -> IO MalVal
  14 mal_read str = read_str str
  15
  16 -- eval
  17 eval_ast :: MalVal -> Env -> IO MalVal
  18 eval_ast sym@(MalSymbol _) env = env_get env sym
  19 eval_ast ast@(MalList lst) env = do
  20     new_lst <- mapM (\x -> (eval x env)) lst
  21     return $ MalList new_lst
  22 eval_ast ast@(MalVector lst) env = do
  23     new_lst <- mapM (\x -> (eval x env)) lst
  24     return $ MalVector new_lst
  25 eval_ast ast@(MalHashMap lst) env = do
  26     new_hm <- DT.mapM (\x -> (eval x env)) lst
  27     return $ MalHashMap new_hm
  28 eval_ast ast env = return ast
  29
  30 let_bind :: Env -> [MalVal] -> IO Env
  31 let_bind env [] = return env
  32 let_bind env (b:e:xs) = do
  33     evaled <- eval e env
  34     x <- env_set env b evaled
  35     let_bind env xs
  36
  37 apply_ast :: MalVal -> Env -> IO MalVal
  38 apply_ast ast@(MalList (MalSymbol "def!" : args)) env = do
  39     case args of
  40          (a1@(MalSymbol _): a2 : []) -> do
  41             evaled <- eval a2 env
  42             env_set env a1 evaled
  43          _ -> error $ "invalid def!"
  44 apply_ast ast@(MalList (MalSymbol "let*" : args)) env = do
  45     case args of
  46          (MalList a1   : a2 : []) -> do
  47             let_env <- env_new $ Just env
  48             let_bind let_env a1
  49             eval a2 let_env
  50          (MalVector a1 : a2 : []) -> do
  51             let_env <- env_new $ Just env
  52             let_bind let_env a1
  53             eval a2 let_env
  54          _ -> error $ "invalid let*"
  55 apply_ast ast@(MalList _) env = do
  56     el <- eval_ast ast env
  57     case el of
  58          (MalList (MalFunc (FuncT f) : rest)) ->
  59             return $ f $ MalList rest
  60          el ->
  61             error $ "invalid apply: " ++ (show el)
  62
  63 eval :: MalVal -> Env -> IO MalVal
  64 eval ast env = do
  65     case ast of
  66          (MalList lst) -> apply_ast ast env
  67          _             -> eval_ast ast env
  68
  69
  70 -- print
  71 mal_print :: MalVal -> String
  72 mal_print exp = show exp
  73
  74 -- repl
  75 add args = case args of
  76     (MalList [MalNumber a, MalNumber b]) -> MalNumber $ a + b
  77     _ -> error $ "illegal arguments to +"
  78 sub args = case args of
  79     (MalList [MalNumber a, MalNumber b]) -> MalNumber $ a - b
  80     _ -> error $ "illegal arguments to -"
  81 mult args = case args of
  82     (MalList [MalNumber a, MalNumber b]) -> MalNumber $ a * b
  83     _ -> error $ "illegal arguments to *"
  84 divd args = case args of
  85     (MalList [MalNumber a, MalNumber b]) -> MalNumber $ a `div` b
  86     _ -> error $ "illegal arguments to /"
  87
  88 rep :: Env -> String -> IO String
  89 rep env line = do
  90     ast <- mal_read line
  91     exp <- eval ast env
  92     return $ mal_print exp
  93
  94 repl_loop :: Env -> IO ()
  95 repl_loop env = do
  96     putStr "user> "
  97     hFlush stdout
  98     ineof <- hIsEOF stdin
  99     when (not ineof) $ do
 100         line <- hGetLine stdin
 101         if null line
 102             then repl_loop env
 103             else do
 104                 out <- catchAny (rep env line) $ \e -> do
 105                     return $ "Error: " ++ (show e)
 106                 putStrLn out
 107                 repl_loop env
 108
 109 main = do
 110     repl_env <- env_new Nothing
 111     env_set repl_env (MalSymbol "+") $ _malfunc add
 112     env_set repl_env (MalSymbol "-") $ _malfunc sub
 113     env_set repl_env (MalSymbol "*") $ _malfunc mult
 114     env_set repl_env (MalSymbol "/") $ _malfunc divd
 115     repl_loop repl_env