Commit | Line | Data |
---|---|---|
5400d4bf | 1 | import System.IO (hFlush, stdout) |
c150ec41 | 2 | import System.Environment (getArgs) |
5400d4bf JM |
3 | import Control.Monad (mapM) |
4 | import Control.Monad.Error (runErrorT) | |
5 | import Control.Monad.Trans (liftIO) | |
c150ec41 JM |
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 | |
5400d4bf | 17 | mal_read :: String -> IOThrows MalVal |
c150ec41 JM |
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 | ||
5400d4bf | 41 | is_macro_call :: MalVal -> Env -> IOThrows Bool |
c150ec41 | 42 | is_macro_call (MalList (a0@(MalSymbol _) : rest) _) env = do |
5400d4bf | 43 | e <- liftIO $ env_find env a0 |
c150ec41 JM |
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 | ||
5400d4bf | 53 | macroexpand :: MalVal -> Env -> IOThrows MalVal |
c150ec41 JM |
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 | ||
5400d4bf | 68 | eval_ast :: MalVal -> Env -> IOThrows MalVal |
c150ec41 JM |
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 | ||
5400d4bf | 81 | let_bind :: Env -> [MalVal] -> IOThrows Env |
c150ec41 JM |
82 | let_bind env [] = return env |
83 | let_bind env (b:e:xs) = do | |
84 | evaled <- eval e env | |
5400d4bf | 85 | x <- liftIO $ env_set env b evaled |
c150ec41 JM |
86 | let_bind env xs |
87 | ||
5400d4bf | 88 | apply_ast :: MalVal -> Env -> IOThrows MalVal |
c150ec41 JM |
89 | apply_ast ast@(MalList (MalSymbol "def!" : args) _) env = do |
90 | case args of | |
91 | (a1@(MalSymbol _): a2 : []) -> do | |
92 | evaled <- eval a2 env | |
5400d4bf JM |
93 | liftIO $ env_set env a1 evaled |
94 | _ -> throwStr "invalid def!" | |
c150ec41 JM |
95 | apply_ast ast@(MalList (MalSymbol "let*" : args) _) env = do |
96 | case args of | |
97 | (a1 : a2 : []) -> do | |
98 | params <- (_to_list a1) | |
5400d4bf | 99 | let_env <- liftIO $ env_new $ Just env |
c150ec41 JM |
100 | let_bind let_env params |
101 | eval a2 let_env | |
5400d4bf | 102 | _ -> throwStr "invalid let*" |
c150ec41 JM |
103 | apply_ast ast@(MalList (MalSymbol "quote" : args) _) env = do |
104 | case args of | |
105 | a1 : [] -> return a1 | |
5400d4bf | 106 | _ -> throwStr "invalid quote" |
c150ec41 JM |
107 | apply_ast ast@(MalList (MalSymbol "quasiquote" : args) _) env = do |
108 | case args of | |
109 | a1 : [] -> eval (quasiquote a1) env | |
5400d4bf | 110 | _ -> throwStr "invalid quasiquote" |
c150ec41 JM |
111 | |
112 | apply_ast ast@(MalList (MalSymbol "defmacro!" : args) _) env = do | |
113 | case args of | |
114 | (a1 : a2 : []) -> do | |
115 | func <- eval a2 env | |
116 | case func of | |
117 | MalFunc {fn=f, ast=a, env=e, params=p} -> do | |
118 | let new_func = MalFunc {fn=f, ast=a, env=e, | |
119 | params=p, macro=True, | |
120 | meta=Nil} in | |
5400d4bf JM |
121 | liftIO $ env_set env a1 new_func |
122 | _ -> throwStr "defmacro! on non-function" | |
123 | _ -> throwStr "invalid defmacro!" | |
c150ec41 JM |
124 | apply_ast ast@(MalList (MalSymbol "macroexpand" : args) _) env = do |
125 | case args of | |
126 | (a1 : []) -> macroexpand a1 env | |
5400d4bf JM |
127 | _ -> throwStr "invalid macroexpand" |
128 | apply_ast ast@(MalList (MalSymbol "try*" : args) _) env = do | |
129 | case args of | |
130 | (a1 : []) -> eval a1 env | |
131 | (a1 : (MalList ((MalSymbol "catch*") : a21 : a22 : []) _) : []) -> do | |
132 | res <- liftIO $ runErrorT $ eval a1 env | |
133 | case res of | |
134 | Right val -> return val | |
135 | Left err -> do | |
136 | exc <- case err of | |
137 | (StringError str) -> return $ MalString str | |
138 | (MalValError mv) -> return $ mv | |
139 | try_env <- liftIO $ env_new $ Just env | |
140 | liftIO $ env_set try_env a21 exc | |
141 | eval a22 try_env | |
142 | _ -> throwStr "invalid try*" | |
c150ec41 JM |
143 | apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do |
144 | case args of | |
145 | ([]) -> return Nil | |
146 | _ -> do | |
147 | el <- eval_ast (MalList args Nil) env | |
148 | case el of | |
149 | (MalList lst _) -> return $ last lst | |
150 | ||
151 | apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do | |
152 | case args of | |
153 | (a1 : a2 : a3 : []) -> do | |
154 | cond <- eval a1 env | |
155 | if cond == MalFalse || cond == Nil | |
156 | then eval a3 env | |
157 | else eval a2 env | |
158 | (a1 : a2 : []) -> do | |
159 | cond <- eval a1 env | |
160 | if cond == MalFalse || cond == Nil | |
161 | then return Nil | |
162 | else eval a2 env | |
5400d4bf | 163 | _ -> throwStr "invalid if" |
c150ec41 JM |
164 | apply_ast ast@(MalList (MalSymbol "fn*" : args) _) env = do |
165 | case args of | |
166 | (a1 : a2 : []) -> do | |
167 | params <- (_to_list a1) | |
168 | return $ (_malfunc a2 env (MalList params Nil) | |
169 | (\args -> do | |
5400d4bf JM |
170 | fn_env1 <- liftIO $ env_new $ Just env |
171 | fn_env2 <- liftIO $ env_bind fn_env1 params args | |
c150ec41 | 172 | eval a2 fn_env2)) |
5400d4bf | 173 | _ -> throwStr "invalid fn*" |
c150ec41 JM |
174 | apply_ast ast@(MalList _ _) env = do |
175 | mc <- is_macro_call ast env | |
176 | if mc then do | |
177 | new_ast <- macroexpand ast env | |
178 | eval new_ast env | |
179 | else | |
180 | case ast of | |
181 | MalList _ _ -> do | |
182 | el <- eval_ast ast env | |
183 | case el of | |
184 | (MalList ((Func (Fn f) _) : rest) _) -> | |
185 | f $ rest | |
186 | (MalList ((MalFunc {ast=ast, | |
187 | env=fn_env, | |
188 | params=(MalList params Nil)} : rest)) _) -> do | |
5400d4bf JM |
189 | fn_env1 <- liftIO $ env_new $ Just fn_env |
190 | fn_env2 <- liftIO $ env_bind fn_env1 params rest | |
c150ec41 JM |
191 | eval ast fn_env2 |
192 | el -> | |
5400d4bf | 193 | throwStr $ "invalid apply: " ++ (show el) |
c150ec41 JM |
194 | _ -> return ast |
195 | ||
5400d4bf | 196 | eval :: MalVal -> Env -> IOThrows MalVal |
c150ec41 JM |
197 | eval ast env = do |
198 | case ast of | |
199 | (MalList _ _) -> apply_ast ast env | |
200 | _ -> eval_ast ast env | |
201 | ||
202 | ||
203 | ||
204 | mal_print :: MalVal -> String | |
205 | mal_print exp = show exp | |
206 | ||
207 | -- repl | |
208 | ||
5400d4bf | 209 | rep :: Env -> String -> IOThrows String |
c150ec41 JM |
210 | rep env line = do |
211 | ast <- mal_read line | |
212 | exp <- eval ast env | |
213 | return $ mal_print exp | |
214 | ||
215 | repl_loop :: Env -> IO () | |
216 | repl_loop env = do | |
217 | line <- readline "user> " | |
218 | case line of | |
219 | Nothing -> return () | |
220 | Just "" -> repl_loop env | |
221 | Just str -> do | |
5400d4bf JM |
222 | res <- runErrorT $ rep env str |
223 | out <- case res of | |
224 | Left (StringError str) -> return $ "Error: " ++ str | |
225 | Left (MalValError mv) -> return $ "Error: " ++ (show mv) | |
226 | Right val -> return val | |
c150ec41 | 227 | putStrLn out |
5400d4bf | 228 | hFlush stdout |
c150ec41 JM |
229 | repl_loop env |
230 | ||
231 | main = do | |
232 | args <- getArgs | |
233 | load_history | |
234 | ||
235 | repl_env <- env_new Nothing | |
236 | ||
237 | -- core.hs: defined using Haskell | |
238 | (mapM (\(k,v) -> (env_set repl_env (MalSymbol k) v)) Core.ns) | |
239 | env_set repl_env (MalSymbol "eval") (_func (\[ast] -> eval ast repl_env)) | |
240 | env_set repl_env (MalSymbol "*ARGV*") (MalList [] Nil) | |
241 | ||
242 | -- core.mal: defined using the language itself | |
5400d4bf JM |
243 | runErrorT $ rep repl_env "(def! not (fn* (a) (if a false true)))" |
244 | runErrorT $ rep repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" | |
245 | 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)))))))" | |
246 | 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))))))))" | |
c150ec41 JM |
247 | |
248 | if length args > 0 then do | |
249 | env_set repl_env (MalSymbol "*ARGV*") (MalList (map MalString (drop 1 args)) Nil) | |
5400d4bf | 250 | runErrorT $ rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")" |
c150ec41 JM |
251 | return () |
252 | else | |
253 | repl_loop repl_env |