Commit | Line | Data |
---|---|---|
5400d4bf | 1 | import System.IO (hFlush, stdout) |
fa9a9758 | 2 | import System.Environment (getArgs) |
87cb47ec | 3 | import Control.Monad ((<=<)) |
53db2d63 | 4 | import Control.Monad.Except (runExceptT) |
5400d4bf | 5 | import Control.Monad.Trans (liftIO) |
6116c2d5 | 6 | import Data.Foldable (foldlM) |
fa9a9758 | 7 | |
219f15b7 | 8 | import Readline (addHistory, readline, load_history) |
fa9a9758 JM |
9 | import Types |
10 | import Reader (read_str) | |
11 | import Printer (_pr_str) | |
52371c3e | 12 | import Env (env_new, env_bind, env_get, env_set) |
6116c2d5 | 13 | import Core (ns) |
fa9a9758 JM |
14 | |
15 | -- read | |
6116c2d5 | 16 | |
5400d4bf | 17 | mal_read :: String -> IOThrows MalVal |
6116c2d5 | 18 | mal_read = read_str |
fa9a9758 JM |
19 | |
20 | -- eval | |
53db2d63 | 21 | |
6116c2d5 | 22 | -- eval_ast is replaced with pattern matching. |
fa9a9758 | 23 | |
6116c2d5 NB |
24 | let_bind :: Env -> [MalVal] -> IOThrows () |
25 | let_bind _ [] = return () | |
26 | let_bind env (MalSymbol b : e : xs) = do | |
27 | liftIO . env_set env b =<< eval env e | |
28 | let_bind env xs | |
29 | let_bind _ _ = throwStr "invalid let*" | |
30 | ||
31 | unWrapSymbol :: MalVal -> IOThrows String | |
32 | unWrapSymbol (MalSymbol s) = return s | |
33 | unWrapSymbol _ = throwStr "fn* parameter must be symbols" | |
34 | ||
35 | newFunction :: MalVal -> Env -> [String] -> MalVal | |
36 | newFunction a env p = MalFunction {f_ast=a, f_params=p, macro=False, meta=Nil, | |
37 | fn=(\args -> do | |
38 | fn_env <- liftIO $ env_new env | |
39 | ok <- liftIO $ env_bind fn_env p args | |
40 | case ok of | |
41 | True -> eval fn_env a | |
42 | False -> throwStr $ "actual parameters do not match signature " ++ show p)} | |
43 | ||
44 | apply_ast :: [MalVal] -> Env -> IOThrows MalVal | |
45 | ||
46 | apply_ast [] _ = return $ toList [] | |
47 | ||
48 | apply_ast [MalSymbol "def!", MalSymbol a1, a2] env = do | |
49 | evd <- eval env a2 | |
50 | liftIO $ env_set env a1 evd | |
51 | return evd | |
52 | apply_ast (MalSymbol "def!" : _) _ = throwStr "invalid def!" | |
53 | ||
54 | apply_ast [MalSymbol "let*", MalSeq _ _ params, a2] env = do | |
55 | let_env <- liftIO $ env_new env | |
56 | let_bind let_env params | |
57 | eval let_env a2 | |
58 | apply_ast (MalSymbol "let*" : _) _ = throwStr "invalid let*" | |
59 | ||
60 | apply_ast (MalSymbol "do" : args) env = foldlM (const $ eval env) Nil args | |
61 | ||
62 | apply_ast [MalSymbol "if", a1, a2, a3] env = do | |
63 | cond <- eval env a1 | |
64 | eval env $ case cond of | |
65 | Nil -> a3 | |
66 | MalBoolean False -> a3 | |
67 | _ -> a2 | |
68 | apply_ast [MalSymbol "if", a1, a2] env = do | |
69 | cond <- eval env a1 | |
70 | case cond of | |
71 | Nil -> return Nil | |
72 | MalBoolean False -> return Nil | |
73 | _ -> eval env a2 | |
74 | apply_ast (MalSymbol "if" : _) _ = throwStr "invalid if" | |
75 | ||
76 | apply_ast [MalSymbol "fn*", MalSeq _ _ params, ast] env = newFunction ast env <$> mapM unWrapSymbol params | |
77 | apply_ast (MalSymbol "fn*" : _) _ = throwStr "invalid fn*" | |
78 | ||
79 | apply_ast ast env = do | |
80 | evd <- mapM (eval env) ast | |
81 | case evd of | |
82 | MalFunction {fn=f} : args -> f args | |
87cb47ec | 83 | _ -> throwStr . (++) "invalid apply: " =<< liftIO (Printer._pr_str True (toList ast)) |
6116c2d5 NB |
84 | |
85 | eval :: Env -> MalVal -> IOThrows MalVal | |
86 | eval env (MalSymbol sym) = do | |
87 | maybeVal <- liftIO $ env_get env sym | |
88 | case maybeVal of | |
89 | Nothing -> throwStr $ "'" ++ sym ++ "' not found" | |
90 | Just val -> return val | |
91 | eval env (MalSeq _ (Vect False) xs) = apply_ast xs env | |
92 | eval env (MalSeq m (Vect True) xs) = MalSeq m (Vect True) <$> mapM (eval env) xs | |
93 | eval env (MalHashMap m xs) = MalHashMap m <$> mapM (eval env) xs | |
94 | eval _ ast = return ast | |
fa9a9758 JM |
95 | |
96 | ||
6116c2d5 | 97 | |
87cb47ec NB |
98 | mal_print :: MalVal -> IOThrows String |
99 | mal_print = liftIO. Printer._pr_str True | |
fa9a9758 JM |
100 | |
101 | -- repl | |
102 | ||
5400d4bf | 103 | rep :: Env -> String -> IOThrows String |
87cb47ec | 104 | rep env = mal_print <=< eval env <=< mal_read |
fa9a9758 JM |
105 | |
106 | repl_loop :: Env -> IO () | |
107 | repl_loop env = do | |
108 | line <- readline "user> " | |
109 | case line of | |
110 | Nothing -> return () | |
111 | Just "" -> repl_loop env | |
112 | Just str -> do | |
219f15b7 | 113 | addHistory str |
53db2d63 | 114 | res <- runExceptT $ rep env str |
5400d4bf | 115 | out <- case res of |
87cb47ec | 116 | Left mv -> (++) "Error: " <$> liftIO (Printer._pr_str True mv) |
5400d4bf | 117 | Right val -> return val |
fa9a9758 | 118 | putStrLn out |
5400d4bf | 119 | hFlush stdout |
fa9a9758 JM |
120 | repl_loop env |
121 | ||
6116c2d5 NB |
122 | -- Read and evaluate a line. Ignore successful results, but crash in |
123 | -- case of error. This is intended for the startup procedure. | |
124 | re :: Env -> String -> IO () | |
125 | re repl_env line = do | |
126 | res <- runExceptT $ eval repl_env =<< mal_read line | |
127 | case res of | |
87cb47ec | 128 | Left mv -> error . (++) "Startup failed: " <$> Printer._pr_str True mv |
6116c2d5 NB |
129 | Right _ -> return () |
130 | ||
131 | defBuiltIn :: Env -> (String, Fn) -> IO () | |
132 | defBuiltIn env (sym, f) = | |
133 | env_set env sym $ MalFunction {fn=f, f_ast=Nil, f_params=[], macro=False, meta=Nil} | |
134 | ||
135 | evalFn :: Env -> Fn | |
136 | evalFn env [ast] = eval env ast | |
137 | evalFn _ _ = throwStr "illegal call of eval" | |
138 | ||
139 | main :: IO () | |
fa9a9758 JM |
140 | main = do |
141 | args <- getArgs | |
142 | load_history | |
143 | ||
6116c2d5 | 144 | repl_env <- env_new [] |
fa9a9758 JM |
145 | |
146 | -- core.hs: defined using Haskell | |
6116c2d5 NB |
147 | mapM_ (defBuiltIn repl_env) Core.ns |
148 | defBuiltIn repl_env ("eval", evalFn repl_env) | |
fa9a9758 JM |
149 | |
150 | -- core.mal: defined using the language itself | |
6116c2d5 | 151 | re repl_env "(def! not (fn* (a) (if a false true)))" |
e6d41de4 | 152 | re repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" |
6116c2d5 NB |
153 | |
154 | case args of | |
155 | script : scriptArgs -> do | |
156 | env_set repl_env "*ARGV*" $ toList $ MalString <$> scriptArgs | |
157 | re repl_env $ "(load-file \"" ++ script ++ "\")" | |
158 | [] -> do | |
159 | env_set repl_env "*ARGV*" $ toList [] | |
160 | repl_loop repl_env |