haskell/step7_quote.hs

   1 import System.IO (hFlush, stdout)
   2 import System.Environment (getArgs)
   3 import Control.Monad (mapM)
   4 import Control.Monad.Error (runErrorT)
   5 import Control.Monad.Trans (liftIO)
   6 import qualified Data.Map as Map
   7 import qualified Data.Traversable as DT
   8
   9 import Readline (readline, load_history)
  10 import Types
  11 import Reader (read_str)
  12 import Printer (_pr_str)
  13 import Env (Env, env_new, env_bind, env_get, env_set)
  14 import Core as Core
  15
  16 -- read
  17 mal_read :: String -> IOThrows MalVal
  18 mal_read str = read_str str
  19
  20 -- eval
  21 is_pair (MalList x _:xs) = True
  22 is_pair (MalVector x _:xs) = True
  23 is_pair _ = False
  24
  25 quasiquote :: MalVal -> MalVal
  26 quasiquote ast =
  27     case ast of
  28          (MalList (MalSymbol "unquote" : a1 : []) _) -> a1
  29          (MalList (MalList (MalSymbol "splice-unquote" : a01 : []) _ : rest) _) ->
  30             MalList [(MalSymbol "concat"), a01, quasiquote (MalList rest Nil)] Nil
  31          (MalVector (MalList (MalSymbol "splice-unquote" : a01 : []) _ : rest) _) ->
  32             MalList [(MalSymbol "concat"), a01, quasiquote (MalVector rest Nil)] Nil
  33          (MalList (a0 : rest) _) -> MalList [(MalSymbol "cons"),
  34                                              quasiquote a0,
  35                                              quasiquote (MalList rest Nil)] Nil
  36          (MalVector (a0 : rest) _) -> MalList [(MalSymbol "cons"),
  37                                                quasiquote a0,
  38                                                quasiquote (MalVector rest Nil)] Nil
  39          _ -> MalList [(MalSymbol "quote"), ast] Nil
  40
  41
  42 eval_ast :: MalVal -> Env -> IOThrows MalVal
  43 eval_ast sym@(MalSymbol _) env = env_get env sym
  44 eval_ast ast@(MalList lst m) env = do
  45     new_lst <- mapM (\x -> (eval x env)) lst
  46     return $ MalList new_lst m
  47 eval_ast ast@(MalVector lst m) env = do
  48     new_lst <- mapM (\x -> (eval x env)) lst
  49     return $ MalVector new_lst m
  50 eval_ast ast@(MalHashMap lst m) env = do
  51     new_hm <- DT.mapM (\x -> (eval x env)) lst
  52     return $ MalHashMap new_hm m
  53 eval_ast ast env = return ast
  54
  55 let_bind :: Env -> [MalVal] -> IOThrows Env
  56 let_bind env [] = return env
  57 let_bind env (b:e:xs) = do
  58     evaled <- eval e env
  59     x <- liftIO $ env_set env b evaled
  60     let_bind env xs
  61
  62 apply_ast :: MalVal -> Env -> IOThrows MalVal
  63 apply_ast ast@(MalList [] _) env = do
  64     return ast
  65 apply_ast ast@(MalList (MalSymbol "def!" : args) _) env = do
  66     case args of
  67          (a1@(MalSymbol _): a2 : []) -> do
  68             evaled <- eval a2 env
  69             liftIO $ env_set env a1 evaled
  70          _ -> throwStr "invalid def!"
  71 apply_ast ast@(MalList (MalSymbol "let*" : args) _) env = do
  72     case args of
  73          (a1 : a2 : []) -> do
  74             params <- (_to_list a1)
  75             let_env <- liftIO $ env_new $ Just env
  76             let_bind let_env params
  77             eval a2 let_env
  78          _ -> throwStr "invalid let*"
  79 apply_ast ast@(MalList (MalSymbol "quote" : args) _) env = do
  80     case args of
  81          a1 : [] -> return a1
  82          _ -> throwStr "invalid quote"
  83 apply_ast ast@(MalList (MalSymbol "quasiquote" : args) _) env = do
  84     case args of
  85          a1 : [] -> eval (quasiquote a1) env
  86          _ -> throwStr "invalid quasiquote"
  87 apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do
  88     case args of
  89          ([]) -> return Nil
  90          _  -> do
  91             el <- eval_ast (MalList args Nil) env
  92             case el of
  93                  (MalList lst _) -> return $ last lst
  94
  95 apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do
  96     case args of
  97          (a1 : a2 : a3 : []) -> do
  98             cond <- eval a1 env
  99             if cond == MalFalse || cond == Nil
 100                 then eval a3 env
 101                 else eval a2 env
 102          (a1 : a2 : []) -> do
 103             cond <- eval a1 env
 104             if cond == MalFalse || cond == Nil
 105                 then return Nil
 106                 else eval a2 env
 107          _ -> throwStr "invalid if"
 108 apply_ast ast@(MalList (MalSymbol "fn*" : args) _) env = do
 109     case args of
 110          (a1 : a2 : []) -> do
 111             params <- (_to_list a1)
 112             return $ (_malfunc a2 env (MalList params Nil)
 113                       (\args -> do
 114                         fn_env1 <- liftIO $ env_new $ Just env
 115                         fn_env2 <- liftIO $ env_bind fn_env1 params args
 116                         eval a2 fn_env2))
 117          _ -> throwStr "invalid fn*"
 118 apply_ast ast@(MalList _ _) env = do
 119     el <- eval_ast ast env
 120     case el of
 121          (MalList ((Func (Fn f) _) : rest) _) ->
 122             f $ rest
 123          (MalList ((MalFunc {ast=ast, env=fn_env, params=(MalList params Nil)}) : rest) _) -> do
 124             fn_env1 <- liftIO $ env_new $ Just fn_env
 125             fn_env2 <- liftIO $ env_bind fn_env1 params rest
 126             eval ast fn_env2
 127          el ->
 128             throwStr $ "invalid apply: " ++ (show el)
 129
 130 eval :: MalVal -> Env -> IOThrows MalVal
 131 eval ast env = do
 132     case ast of
 133          (MalList _ _) -> apply_ast ast env
 134          _             -> eval_ast ast env
 135
 136
 137 -- print
 138 mal_print :: MalVal -> String
 139 mal_print exp = show exp
 140
 141 -- repl
 142
 143 rep :: Env -> String -> IOThrows String
 144 rep env line = do
 145     ast <- mal_read line
 146     exp <- eval ast env
 147     return $ mal_print exp
 148
 149 repl_loop :: Env -> IO ()
 150 repl_loop env = do
 151     line <- readline "user> "
 152     case line of
 153         Nothing -> return ()
 154         Just "" -> repl_loop env
 155         Just str -> do
 156             res <- runErrorT $ rep env str
 157             out <- case res of
 158                 Left (StringError str) -> return $ "Error: " ++ str
 159                 Left (MalValError mv) -> return $ "Error: " ++ (show mv)
 160                 Right val -> return val
 161             putStrLn out
 162             hFlush stdout
 163             repl_loop env
 164
 165 main = do
 166     args <- getArgs
 167     load_history
 168
 169     repl_env <- env_new Nothing
 170
 171     -- core.hs: defined using Haskell
 172     (mapM (\(k,v) -> (env_set repl_env (MalSymbol k) v)) Core.ns)
 173     env_set repl_env (MalSymbol "eval") (_func (\[ast] -> eval ast repl_env))
 174     env_set repl_env (MalSymbol "*ARGV*") (MalList [] Nil)
 175
 176     -- core.mal: defined using the language itself
 177     runErrorT $ rep repl_env "(def! not (fn* (a) (if a false true)))"
 178     runErrorT $ rep repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))"
 179
 180     if length args > 0 then do
 181         env_set repl_env (MalSymbol "*ARGV*") (MalList (map MalString (drop 1 args)) Nil)
 182         runErrorT $ rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")"
 183         return ()
 184     else
 185         repl_loop repl_env