haskell/step5_tco.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_bind, env_get, env_set)
  13 import Core as Core
  14
  15 -- read
  16 mal_read :: String -> IOThrows MalVal
  17 mal_read str = read_str str
  18
  19 -- eval
  20 eval_ast :: MalVal -> Env -> IOThrows MalVal
  21 eval_ast sym@(MalSymbol _) env = env_get env sym
  22 eval_ast ast@(MalList lst m) env = do
  23     new_lst <- mapM (\x -> (eval x env)) lst
  24     return $ MalList new_lst m
  25 eval_ast ast@(MalVector lst m) env = do
  26     new_lst <- mapM (\x -> (eval x env)) lst
  27     return $ MalVector new_lst m
  28 eval_ast ast@(MalHashMap lst m) env = do
  29     new_hm <- DT.mapM (\x -> (eval x env)) lst
  30     return $ MalHashMap new_hm m
  31 eval_ast ast env = return ast
  32
  33 let_bind :: Env -> [MalVal] -> IOThrows Env
  34 let_bind env [] = return env
  35 let_bind env (b:e:xs) = do
  36     evaled <- eval e env
  37     x <- liftIO $ env_set env b evaled
  38     let_bind env xs
  39
  40 apply_ast :: MalVal -> Env -> IOThrows MalVal
  41 apply_ast ast@(MalList (MalSymbol "def!" : args) _) env = do
  42     case args of
  43          (a1@(MalSymbol _): a2 : []) -> do
  44             evaled <- eval a2 env
  45             liftIO $ env_set env a1 evaled
  46          _ -> throwStr "invalid def!"
  47 apply_ast ast@(MalList (MalSymbol "let*" : args) _) env = do
  48     case args of
  49          (a1 : a2 : []) -> do
  50             params <- (_to_list a1)
  51             let_env <- liftIO $ env_new $ Just env
  52             let_bind let_env params
  53             eval a2 let_env
  54          _ -> throwStr "invalid let*"
  55 apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do
  56     case args of
  57          ([]) -> return Nil
  58          _  -> do
  59             el <- eval_ast (MalList args Nil) env
  60             case el of
  61                  (MalList lst _) -> return $ last lst
  62
  63 apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do
  64     case args of
  65          (a1 : a2 : a3 : []) -> do
  66             cond <- eval a1 env
  67             if cond == MalFalse || cond == Nil
  68                 then eval a3 env
  69                 else eval a2 env
  70          (a1 : a2 : []) -> do
  71             cond <- eval a1 env
  72             if cond == MalFalse || cond == Nil
  73                 then return Nil
  74                 else eval a2 env
  75          _ -> throwStr "invalid if"
  76 apply_ast ast@(MalList (MalSymbol "fn*" : args) _) env = do
  77     case args of
  78          (a1 : a2 : []) -> do
  79             params <- (_to_list a1)
  80             return $ (_malfunc a2 env (MalList params Nil)
  81                       (\args -> do
  82                         fn_env1 <- liftIO $ env_new $ Just env
  83                         fn_env2 <- liftIO $ env_bind fn_env1 params args
  84                         eval a2 fn_env2))
  85          _ -> throwStr "invalid fn*"
  86 apply_ast ast@(MalList _ _) env = do
  87     el <- eval_ast ast env
  88     case el of
  89          (MalList ((Func (Fn f) _) : rest) _) ->
  90             f $ rest
  91          (MalList ((MalFunc {ast=ast, env=fn_env, params=(MalList params Nil)}) : rest) _) -> do
  92             fn_env1 <- liftIO $ env_new $ Just fn_env
  93             fn_env2 <- liftIO $ env_bind fn_env1 params rest
  94             eval ast fn_env2
  95          el ->
  96             throwStr $ "invalid apply: " ++ (show el)
  97
  98 eval :: MalVal -> Env -> IOThrows MalVal
  99 eval ast env = do
 100     case ast of
 101          (MalList _ _) -> apply_ast ast env
 102          _             -> eval_ast ast env
 103
 104
 105 -- print
 106 mal_print :: MalVal -> String
 107 mal_print exp = show exp
 108
 109 -- repl
 110
 111 rep :: Env -> String -> IOThrows String
 112 rep env line = do
 113     ast <- mal_read line
 114     exp <- eval ast env
 115     return $ mal_print exp
 116
 117 repl_loop :: Env -> IO ()
 118 repl_loop env = do
 119     line <- readline "user> "
 120     case line of
 121         Nothing -> return ()
 122         Just "" -> repl_loop env
 123         Just str -> do
 124             res <- runErrorT $ rep env str
 125             out <- case res of
 126                 Left (StringError str) -> return $ "Error: " ++ str
 127                 Left (MalValError mv) -> return $ "Error: " ++ (show mv)
 128                 Right val -> return val
 129             putStrLn out
 130             hFlush stdout
 131             repl_loop env
 132
 133 main = do
 134     load_history
 135
 136     repl_env <- env_new Nothing
 137
 138     -- core.hs: defined using Haskell
 139     (mapM (\(k,v) -> (env_set repl_env (MalSymbol k) v)) Core.ns)
 140
 141     -- core.mal: defined using the language itself
 142     runErrorT $ rep repl_env "(def! not (fn* (a) (if a false true)))"
 143
 144     repl_loop repl_env