Commit | Line | Data |
---|---|---|
5400d4bf | 1 | import System.IO (hFlush, stdout) |
2988d38e | 2 | import System.Environment (getArgs) |
5400d4bf JM |
3 | import Control.Monad (mapM) |
4 | import Control.Monad.Error (runErrorT) | |
5 | import Control.Monad.Trans (liftIO) | |
2988d38e 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 |
2988d38e JM |
18 | mal_read str = read_str str |
19 | ||
20 | -- eval | |
c150ec41 JM |
21 | is_pair (MalList x _:xs) = True |
22 | is_pair (MalVector x _:xs) = True | |
2988d38e JM |
23 | is_pair _ = False |
24 | ||
25 | quasiquote :: MalVal -> MalVal | |
26 | quasiquote ast = | |
27 | case ast of | |
c150ec41 JM |
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"), | |
2988d38e | 34 | quasiquote a0, |
c150ec41 JM |
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 | |
2988d38e | 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 |
2988d38e 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 | 54 | macroexpand ast@(MalList (a0 : args) _) env = do |
2988d38e JM |
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 |
2988d38e | 69 | eval_ast sym@(MalSymbol _) env = env_get env sym |
c150ec41 | 70 | eval_ast ast@(MalList lst m) env = do |
2988d38e | 71 | new_lst <- mapM (\x -> (eval x env)) lst |
c150ec41 JM |
72 | return $ MalList new_lst m |
73 | eval_ast ast@(MalVector lst m) env = do | |
2988d38e | 74 | new_lst <- mapM (\x -> (eval x env)) lst |
c150ec41 JM |
75 | return $ MalVector new_lst m |
76 | eval_ast ast@(MalHashMap lst m) env = do | |
2988d38e | 77 | new_hm <- DT.mapM (\x -> (eval x env)) lst |
c150ec41 | 78 | return $ MalHashMap new_hm m |
2988d38e JM |
79 | eval_ast ast env = return ast |
80 | ||
5400d4bf | 81 | let_bind :: Env -> [MalVal] -> IOThrows Env |
2988d38e 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 |
2988d38e JM |
86 | let_bind env xs |
87 | ||
5400d4bf | 88 | apply_ast :: MalVal -> Env -> IOThrows MalVal |
c150ec41 | 89 | apply_ast ast@(MalList (MalSymbol "def!" : args) _) env = do |
2988d38e JM |
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 | 95 | apply_ast ast@(MalList (MalSymbol "let*" : args) _) env = do |
2988d38e | 96 | case args of |
c150ec41 JM |
97 | (a1 : a2 : []) -> do |
98 | params <- (_to_list a1) | |
5400d4bf | 99 | let_env <- liftIO $ env_new $ Just env |
c150ec41 | 100 | let_bind let_env params |
2988d38e | 101 | eval a2 let_env |
5400d4bf | 102 | _ -> throwStr "invalid let*" |
c150ec41 | 103 | apply_ast ast@(MalList (MalSymbol "quote" : args) _) env = do |
2988d38e JM |
104 | case args of |
105 | a1 : [] -> return a1 | |
5400d4bf | 106 | _ -> throwStr "invalid quote" |
c150ec41 | 107 | apply_ast ast@(MalList (MalSymbol "quasiquote" : args) _) env = do |
2988d38e JM |
108 | case args of |
109 | a1 : [] -> eval (quasiquote a1) env | |
5400d4bf | 110 | _ -> throwStr "invalid quasiquote" |
2988d38e | 111 | |
c150ec41 | 112 | apply_ast ast@(MalList (MalSymbol "defmacro!" : args) _) env = do |
2988d38e JM |
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, | |
c150ec41 JM |
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 | 124 | apply_ast ast@(MalList (MalSymbol "macroexpand" : args) _) env = do |
2988d38e JM |
125 | case args of |
126 | (a1 : []) -> macroexpand a1 env | |
5400d4bf | 127 | _ -> throwStr "invalid macroexpand" |
c150ec41 | 128 | apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do |
2988d38e JM |
129 | case args of |
130 | ([]) -> return Nil | |
131 | _ -> do | |
c150ec41 | 132 | el <- eval_ast (MalList args Nil) env |
2988d38e | 133 | case el of |
c150ec41 | 134 | (MalList lst _) -> return $ last lst |
2988d38e | 135 | |
c150ec41 | 136 | apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do |
2988d38e JM |
137 | case args of |
138 | (a1 : a2 : a3 : []) -> do | |
139 | cond <- eval a1 env | |
140 | if cond == MalFalse || cond == Nil | |
141 | then eval a3 env | |
142 | else eval a2 env | |
143 | (a1 : a2 : []) -> do | |
144 | cond <- eval a1 env | |
145 | if cond == MalFalse || cond == Nil | |
146 | then return Nil | |
147 | else eval a2 env | |
5400d4bf | 148 | _ -> throwStr "invalid if" |
c150ec41 JM |
149 | apply_ast ast@(MalList (MalSymbol "fn*" : args) _) env = do |
150 | case args of | |
151 | (a1 : a2 : []) -> do | |
152 | params <- (_to_list a1) | |
153 | return $ (_malfunc a2 env (MalList params Nil) | |
154 | (\args -> do | |
5400d4bf JM |
155 | fn_env1 <- liftIO $ env_new $ Just env |
156 | fn_env2 <- liftIO $ env_bind fn_env1 params args | |
c150ec41 | 157 | eval a2 fn_env2)) |
5400d4bf | 158 | _ -> throwStr "invalid fn*" |
c150ec41 | 159 | apply_ast ast@(MalList _ _) env = do |
2988d38e JM |
160 | mc <- is_macro_call ast env |
161 | if mc then do | |
162 | new_ast <- macroexpand ast env | |
163 | eval new_ast env | |
164 | else | |
165 | case ast of | |
c150ec41 | 166 | MalList _ _ -> do |
2988d38e JM |
167 | el <- eval_ast ast env |
168 | case el of | |
c150ec41 | 169 | (MalList ((Func (Fn f) _) : rest) _) -> |
2988d38e | 170 | f $ rest |
c150ec41 JM |
171 | (MalList ((MalFunc {ast=ast, |
172 | env=fn_env, | |
173 | params=(MalList params Nil)} : rest)) _) -> do | |
5400d4bf JM |
174 | fn_env1 <- liftIO $ env_new $ Just fn_env |
175 | fn_env2 <- liftIO $ env_bind fn_env1 params rest | |
2988d38e JM |
176 | eval ast fn_env2 |
177 | el -> | |
5400d4bf | 178 | throwStr $ "invalid apply: " ++ (show el) |
2988d38e JM |
179 | _ -> return ast |
180 | ||
5400d4bf | 181 | eval :: MalVal -> Env -> IOThrows MalVal |
2988d38e JM |
182 | eval ast env = do |
183 | case ast of | |
c150ec41 | 184 | (MalList _ _) -> apply_ast ast env |
2988d38e JM |
185 | _ -> eval_ast ast env |
186 | ||
187 | ||
188 | ||
189 | mal_print :: MalVal -> String | |
190 | mal_print exp = show exp | |
191 | ||
192 | -- repl | |
193 | ||
5400d4bf | 194 | rep :: Env -> String -> IOThrows String |
2988d38e JM |
195 | rep env line = do |
196 | ast <- mal_read line | |
197 | exp <- eval ast env | |
198 | return $ mal_print exp | |
199 | ||
200 | repl_loop :: Env -> IO () | |
201 | repl_loop env = do | |
202 | line <- readline "user> " | |
203 | case line of | |
204 | Nothing -> return () | |
205 | Just "" -> repl_loop env | |
206 | Just str -> do | |
5400d4bf JM |
207 | res <- runErrorT $ rep env str |
208 | out <- case res of | |
209 | Left (StringError str) -> return $ "Error: " ++ str | |
210 | Left (MalValError mv) -> return $ "Error: " ++ (show mv) | |
211 | Right val -> return val | |
2988d38e | 212 | putStrLn out |
5400d4bf | 213 | hFlush stdout |
2988d38e JM |
214 | repl_loop env |
215 | ||
216 | main = do | |
217 | args <- getArgs | |
218 | load_history | |
219 | ||
220 | repl_env <- env_new Nothing | |
221 | ||
222 | -- core.hs: defined using Haskell | |
223 | (mapM (\(k,v) -> (env_set repl_env (MalSymbol k) v)) Core.ns) | |
224 | env_set repl_env (MalSymbol "eval") (_func (\[ast] -> eval ast repl_env)) | |
c150ec41 | 225 | env_set repl_env (MalSymbol "*ARGV*") (MalList [] Nil) |
2988d38e JM |
226 | |
227 | -- core.mal: defined using the language itself | |
5400d4bf JM |
228 | runErrorT $ rep repl_env "(def! not (fn* (a) (if a false true)))" |
229 | runErrorT $ rep repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" | |
230 | 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)))))))" | |
231 | 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))))))))" | |
2988d38e JM |
232 | |
233 | if length args > 0 then do | |
c150ec41 | 234 | env_set repl_env (MalSymbol "*ARGV*") (MalList (map MalString (drop 1 args)) Nil) |
5400d4bf | 235 | runErrorT $ rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")" |
2988d38e JM |
236 | return () |
237 | else | |
238 | repl_loop repl_env |