haskell/step3_env.hs

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