haskell/step9_try.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_find, 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 is_macro_call :: MalVal -> Env -> IOThrows Bool
  42 is_macro_call (MalList (a0@(MalSymbol _) : rest) _) env = do
  43     e <- liftIO $ env_find env a0
  44     case e of
  45          Just e -> do
  46             f <- env_get e a0
  47             case f of
  48                  MalFunc {macro=True} -> return True
  49                  _                    -> return False
  50          Nothing -> return False
  51 is_macro_call _ _ = return False
  52
  53 macroexpand :: MalVal -> Env -> IOThrows MalVal
  54 macroexpand ast@(MalList (a0 : args) _) env = do
  55     mc <- is_macro_call ast env
  56     if mc then do
  57         mac <- env_get env a0
  58         case mac of
  59              MalFunc {fn=(Fn f)} -> do
  60                 new_ast <- f args
  61                 macroexpand new_ast env
  62              _ ->
  63                 return ast
  64     else
  65         return ast
  66 macroexpand ast _ = return ast
  67
  68 eval_ast :: MalVal -> Env -> IOThrows MalVal
  69 eval_ast sym@(MalSymbol _) env = env_get env sym
  70 eval_ast ast@(MalList lst m) env = do
  71     new_lst <- mapM (\x -> (eval x env)) lst
  72     return $ MalList new_lst m
  73 eval_ast ast@(MalVector lst m) env = do
  74     new_lst <- mapM (\x -> (eval x env)) lst
  75     return $ MalVector new_lst m
  76 eval_ast ast@(MalHashMap lst m) env = do
  77     new_hm <- DT.mapM (\x -> (eval x env)) lst
  78     return $ MalHashMap new_hm m
  79 eval_ast ast env = return ast
  80
  81 let_bind :: Env -> [MalVal] -> IOThrows Env
  82 let_bind env [] = return env
  83 let_bind env (b:e:xs) = do
  84     evaled <- eval e env
  85     x <- liftIO $ env_set env b evaled
  86     let_bind env xs
  87
  88 apply_ast :: MalVal -> Env -> IOThrows MalVal
  89 apply_ast ast@(MalList [] _) env = do
  90     return ast
  91 apply_ast ast@(MalList (MalSymbol "def!" : args) _) env = do
  92     case args of
  93          (a1@(MalSymbol _): a2 : []) -> do
  94             evaled <- eval a2 env
  95             liftIO $ env_set env a1 evaled
  96          _ -> throwStr "invalid def!"
  97 apply_ast ast@(MalList (MalSymbol "let*" : args) _) env = do
  98     case args of
  99          (a1 : a2 : []) -> do
 100             params <- (_to_list a1)
 101             let_env <- liftIO $ env_new $ Just env
 102             let_bind let_env params
 103             eval a2 let_env
 104          _ -> throwStr "invalid let*"
 105 apply_ast ast@(MalList (MalSymbol "quote" : args) _) env = do
 106     case args of
 107          a1 : [] -> return a1
 108          _ -> throwStr "invalid quote"
 109 apply_ast ast@(MalList (MalSymbol "quasiquote" : args) _) env = do
 110     case args of
 111          a1 : [] -> eval (quasiquote a1) env
 112          _ -> throwStr "invalid quasiquote"
 113
 114 apply_ast ast@(MalList (MalSymbol "defmacro!" : args) _) env = do
 115     case args of
 116          (a1 : a2 : []) -> do
 117             func <- eval a2 env
 118             case func of
 119                 MalFunc {fn=f, ast=a, env=e, params=p} -> do
 120                     let new_func = MalFunc {fn=f, ast=a, env=e,
 121                                             params=p, macro=True,
 122                                             meta=Nil} in
 123                         liftIO $ env_set env a1 new_func
 124                 _ -> throwStr "defmacro! on non-function"
 125          _ -> throwStr "invalid defmacro!"
 126 apply_ast ast@(MalList (MalSymbol "macroexpand" : args) _) env = do
 127     case args of
 128          (a1 : []) -> macroexpand a1 env
 129          _ -> throwStr "invalid macroexpand"
 130 apply_ast ast@(MalList (MalSymbol "try*" : args) _) env = do
 131     case args of
 132          (a1 : []) -> eval a1 env
 133          (a1 : (MalList ((MalSymbol "catch*") : a21 : a22 : []) _) : []) -> do
 134             res <- liftIO $ runErrorT $ eval a1 env
 135             case res of
 136                 Right val -> return val
 137                 Left err -> do
 138                     exc <- case err of
 139                         (StringError str) -> return $ MalString str
 140                         (MalValError mv) -> return $ mv
 141                     try_env <- liftIO $ env_new $ Just env
 142                     liftIO $ env_set try_env a21 exc
 143                     eval a22 try_env
 144          _ -> throwStr "invalid try*"
 145 apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do
 146     case args of
 147          ([]) -> return Nil
 148          _  -> do
 149             el <- eval_ast (MalList args Nil) env
 150             case el of
 151                  (MalList lst _) -> return $ last lst
 152
 153 apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do
 154     case args of
 155          (a1 : a2 : a3 : []) -> do
 156             cond <- eval a1 env
 157             if cond == MalFalse || cond == Nil
 158                 then eval a3 env
 159                 else eval a2 env
 160          (a1 : a2 : []) -> do
 161             cond <- eval a1 env
 162             if cond == MalFalse || cond == Nil
 163                 then return Nil
 164                 else eval a2 env
 165          _ -> throwStr "invalid if"
 166 apply_ast ast@(MalList (MalSymbol "fn*" : args) _) env = do
 167     case args of
 168          (a1 : a2 : []) -> do
 169             params <- (_to_list a1)
 170             return $ (_malfunc a2 env (MalList params Nil)
 171                       (\args -> do
 172                         fn_env1 <- liftIO $ env_new $ Just env
 173                         fn_env2 <- liftIO $ env_bind fn_env1 params args
 174                         eval a2 fn_env2))
 175          _ -> throwStr "invalid fn*"
 176 apply_ast ast@(MalList _ _) env = do
 177     mc <- is_macro_call ast env
 178     if mc then do
 179         new_ast <- macroexpand ast env
 180         eval new_ast env
 181     else
 182         case ast of
 183             MalList _ _ -> do
 184                 el <- eval_ast ast env
 185                 case el of
 186                     (MalList ((Func (Fn f) _) : rest) _) ->
 187                         f $ rest
 188                     (MalList ((MalFunc {ast=ast,
 189                                         env=fn_env,
 190                                         params=(MalList params Nil)} : rest)) _) -> do
 191                         fn_env1 <- liftIO $ env_new $ Just fn_env
 192                         fn_env2 <- liftIO $ env_bind fn_env1 params rest
 193                         eval ast fn_env2
 194                     el ->
 195                         throwStr $ "invalid apply: " ++ (show el)
 196             _ -> return ast
 197
 198 eval :: MalVal -> Env -> IOThrows MalVal
 199 eval ast env = do
 200     case ast of
 201          (MalList _ _) -> apply_ast ast env
 202          _             -> eval_ast ast env
 203
 204
 205 -- print
 206 mal_print :: MalVal -> String
 207 mal_print exp = show exp
 208
 209 -- repl
 210
 211 rep :: Env -> String -> IOThrows String
 212 rep env line = do
 213     ast <- mal_read line
 214     exp <- eval ast env
 215     return $ mal_print exp
 216
 217 repl_loop :: Env -> IO ()
 218 repl_loop env = do
 219     line <- readline "user> "
 220     case line of
 221         Nothing -> return ()
 222         Just "" -> repl_loop env
 223         Just str -> do
 224             res <- runErrorT $ rep env str
 225             out <- case res of
 226                 Left (StringError str) -> return $ "Error: " ++ str
 227                 Left (MalValError mv) -> return $ "Error: " ++ (show mv)
 228                 Right val -> return val
 229             putStrLn out
 230             hFlush stdout
 231             repl_loop env
 232
 233 main = do
 234     args <- getArgs
 235     load_history
 236
 237     repl_env <- env_new Nothing
 238
 239     -- core.hs: defined using Haskell
 240     (mapM (\(k,v) -> (env_set repl_env (MalSymbol k) v)) Core.ns)
 241     env_set repl_env (MalSymbol "eval") (_func (\[ast] -> eval ast repl_env))
 242     env_set repl_env (MalSymbol "*ARGV*") (MalList [] Nil)
 243
 244     -- core.mal: defined using the language itself
 245     runErrorT $ rep repl_env "(def! not (fn* (a) (if a false true)))"
 246     runErrorT $ rep repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))"
 247     runErrorT $ rep repl_env "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))"
 248     runErrorT $ rep repl_env "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))"
 249
 250     if length args > 0 then do
 251         env_set repl_env (MalSymbol "*ARGV*") (MalList (map MalString (drop 1 args)) Nil)
 252         runErrorT $ rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")"
 253         return ()
 254     else
 255         repl_loop repl_env