Commit | Line | Data |
---|---|---|
5400d4bf | 1 | import System.IO (hFlush, stdout) |
c150ec41 | 2 | import System.Environment (getArgs) |
5400d4bf | 3 | import Control.Monad (mapM) |
53db2d63 | 4 | import Control.Monad.Except (runExceptT) |
5400d4bf | 5 | import Control.Monad.Trans (liftIO) |
6116c2d5 | 6 | import Data.Foldable (foldlM, foldrM) |
c150ec41 JM |
7 | |
8 | import Readline (readline, load_history) | |
9 | import Types | |
10 | import Reader (read_str) | |
11 | import Printer (_pr_str) | |
6116c2d5 NB |
12 | import Env (Env, env_new, env_bind, env_get, env_set) |
13 | import Core (ns) | |
c150ec41 JM |
14 | |
15 | -- read | |
6116c2d5 | 16 | |
5400d4bf | 17 | mal_read :: String -> IOThrows MalVal |
6116c2d5 | 18 | mal_read = read_str |
c150ec41 JM |
19 | |
20 | -- eval | |
c150ec41 | 21 | |
6116c2d5 NB |
22 | -- starts-with is replaced with pattern matching. |
23 | ||
24 | qqIter :: Env -> MalVal -> [MalVal] -> IOThrows [MalVal] | |
25 | qqIter env (MalSeq _ (Vect False) [MalSymbol "splice-unquote", x]) acc = do | |
26 | evaluated <- eval env x | |
27 | case evaluated of | |
28 | MalSeq _ (Vect False) xs -> return $ xs ++ acc | |
29 | _ -> throwStr "invalid splice-unquote argument" | |
30 | qqIter _ (MalSeq _ (Vect False) (MalSymbol "splice-unquote" : _)) _ = throwStr "invalid splice-unquote" | |
31 | qqIter env x acc = (: acc) <$> quasiquote x env | |
32 | ||
33 | quasiquote :: MalVal -> Env -> IOThrows MalVal | |
34 | quasiquote (MalSeq _ (Vect False) [MalSymbol "unquote", x]) env = eval env x | |
35 | quasiquote (MalSeq m v ys) env = MalSeq m v <$> foldrM (qqIter env) [] ys | |
36 | quasiquote ast _ = return ast | |
37 | ||
38 | -- is-macro-call is replaced with pattern matching. | |
39 | ||
40 | macroexpand :: Env -> MalVal -> IOThrows MalVal | |
41 | macroexpand env ast@(MalSeq _ (Vect False) (MalSymbol a0 : args)) = do | |
42 | maybeMacro <- liftIO $ env_get env a0 | |
43 | case maybeMacro of | |
44 | Just (MalFunction {fn=f, macro=True}) -> macroexpand env =<< f args | |
45 | _ -> return ast | |
46 | macroexpand _ ast = return ast | |
47 | ||
48 | -- eval_ast is replaced with pattern matching. | |
49 | ||
50 | let_bind :: Env -> [MalVal] -> IOThrows () | |
51 | let_bind _ [] = return () | |
52 | let_bind env (MalSymbol b : e : xs) = do | |
53 | liftIO . env_set env b =<< eval env e | |
54 | let_bind env xs | |
55 | let_bind _ _ = throwStr "invalid let*" | |
56 | ||
57 | unWrapSymbol :: MalVal -> IOThrows String | |
58 | unWrapSymbol (MalSymbol s) = return s | |
59 | unWrapSymbol _ = throwStr "fn* parameter must be symbols" | |
60 | ||
61 | newFunction :: MalVal -> Env -> [String] -> MalVal | |
62 | newFunction a env p = MalFunction {f_ast=a, f_params=p, macro=False, meta=Nil, | |
63 | fn=(\args -> do | |
64 | fn_env <- liftIO $ env_new env | |
65 | ok <- liftIO $ env_bind fn_env p args | |
66 | case ok of | |
67 | True -> eval fn_env a | |
68 | False -> throwStr $ "actual parameters do not match signature " ++ show p)} | |
69 | ||
70 | apply_ast :: [MalVal] -> Env -> IOThrows MalVal | |
71 | ||
72 | apply_ast [] _ = return $ toList [] | |
73 | ||
74 | apply_ast [MalSymbol "def!", MalSymbol a1, a2] env = do | |
75 | evd <- eval env a2 | |
76 | liftIO $ env_set env a1 evd | |
77 | return evd | |
78 | apply_ast (MalSymbol "def!" : _) _ = throwStr "invalid def!" | |
79 | ||
80 | apply_ast [MalSymbol "let*", MalSeq _ _ params, a2] env = do | |
81 | let_env <- liftIO $ env_new env | |
82 | let_bind let_env params | |
83 | eval let_env a2 | |
84 | apply_ast (MalSymbol "let*" : _) _ = throwStr "invalid let*" | |
85 | ||
86 | apply_ast [MalSymbol "quote", a1] _ = return a1 | |
87 | apply_ast (MalSymbol "quote" : _) _ = throwStr "invalid quote" | |
88 | ||
89 | apply_ast [MalSymbol "quasiquote", a1] env = quasiquote a1 env | |
90 | apply_ast (MalSymbol "quasiquote" : _) _ = throwStr "invalid quasiquote" | |
91 | ||
92 | apply_ast [MalSymbol "defmacro!", MalSymbol a1, a2] env = do | |
93 | func <- eval env a2 | |
94 | case func of | |
95 | MalFunction {macro=False} -> do | |
96 | let m = func {macro=True} | |
97 | liftIO $ env_set env a1 m | |
98 | return m | |
99 | _ -> throwStr "defmacro! on non-function" | |
100 | apply_ast (MalSymbol "defmacro!" : _) _ = throwStr "invalid defmacro!" | |
101 | ||
102 | apply_ast [MalSymbol "macroexpand", a1] env = macroexpand env a1 | |
103 | apply_ast (MalSymbol "macroexpand" : _) _ = throwStr "invalid macroexpand" | |
104 | ||
105 | apply_ast [MalSymbol "try*", a1] env = eval env a1 | |
106 | apply_ast [MalSymbol "try*", a1, MalSeq _ (Vect False) [MalSymbol "catch*", MalSymbol a21, a22]] env = do | |
107 | res <- liftIO $ runExceptT $ eval env a1 | |
108 | case res of | |
109 | Right val -> return val | |
110 | Left exc -> do | |
111 | try_env <- liftIO $ env_new env | |
112 | liftIO $ env_set try_env a21 exc | |
113 | eval try_env a22 | |
114 | apply_ast (MalSymbol "try*" : _) _ = throwStr "invalid try*" | |
115 | ||
116 | apply_ast (MalSymbol "do" : args) env = foldlM (const $ eval env) Nil args | |
117 | ||
118 | apply_ast [MalSymbol "if", a1, a2, a3] env = do | |
119 | cond <- eval env a1 | |
120 | eval env $ case cond of | |
121 | Nil -> a3 | |
122 | MalBoolean False -> a3 | |
123 | _ -> a2 | |
124 | apply_ast [MalSymbol "if", a1, a2] env = do | |
125 | cond <- eval env a1 | |
126 | case cond of | |
127 | Nil -> return Nil | |
128 | MalBoolean False -> return Nil | |
129 | _ -> eval env a2 | |
130 | apply_ast (MalSymbol "if" : _) _ = throwStr "invalid if" | |
131 | ||
132 | apply_ast [MalSymbol "fn*", MalSeq _ _ params, ast] env = newFunction ast env <$> mapM unWrapSymbol params | |
133 | apply_ast (MalSymbol "fn*" : _) _ = throwStr "invalid fn*" | |
134 | ||
135 | apply_ast ast env = do | |
136 | evd <- mapM (eval env) ast | |
137 | case evd of | |
138 | MalFunction {fn=f, macro=False} : args -> f args | |
139 | _ -> throwStr $ "invalid apply: " ++ Printer._pr_str True (toList ast) | |
140 | ||
141 | eval :: Env -> MalVal -> IOThrows MalVal | |
142 | eval env ast = do | |
143 | newAst <- macroexpand env ast | |
144 | case newAst of | |
145 | MalSymbol sym -> do | |
146 | maybeVal <- liftIO $ env_get env sym | |
147 | case maybeVal of | |
148 | Nothing -> throwStr $ "'" ++ sym ++ "' not found" | |
149 | Just val -> return val | |
150 | MalSeq _ (Vect False) xs -> apply_ast xs env | |
151 | MalSeq m (Vect True) xs -> MalSeq m (Vect True) <$> mapM (eval env) xs | |
152 | MalHashMap m xs -> MalHashMap m <$> mapM (eval env) xs | |
153 | _ -> return newAst | |
c150ec41 JM |
154 | |
155 | ||
6116c2d5 | 156 | |
c150ec41 | 157 | mal_print :: MalVal -> String |
6116c2d5 | 158 | mal_print = Printer._pr_str True |
c150ec41 JM |
159 | |
160 | -- repl | |
161 | ||
5400d4bf | 162 | rep :: Env -> String -> IOThrows String |
6116c2d5 | 163 | rep env line = mal_print <$> (eval env =<< mal_read line) |
c150ec41 JM |
164 | |
165 | repl_loop :: Env -> IO () | |
166 | repl_loop env = do | |
167 | line <- readline "user> " | |
168 | case line of | |
169 | Nothing -> return () | |
170 | Just "" -> repl_loop env | |
171 | Just str -> do | |
53db2d63 | 172 | res <- runExceptT $ rep env str |
5400d4bf | 173 | out <- case res of |
6116c2d5 | 174 | Left mv -> return $ "Error: " ++ Printer._pr_str True mv |
5400d4bf | 175 | Right val -> return val |
c150ec41 | 176 | putStrLn out |
5400d4bf | 177 | hFlush stdout |
c150ec41 JM |
178 | repl_loop env |
179 | ||
6116c2d5 NB |
180 | -- Read and evaluate a line. Ignore successful results, but crash in |
181 | -- case of error. This is intended for the startup procedure. | |
182 | re :: Env -> String -> IO () | |
183 | re repl_env line = do | |
184 | res <- runExceptT $ eval repl_env =<< mal_read line | |
185 | case res of | |
186 | Left mv -> error $ "Startup failed: " ++ Printer._pr_str True mv | |
187 | Right _ -> return () | |
188 | ||
189 | defBuiltIn :: Env -> (String, Fn) -> IO () | |
190 | defBuiltIn env (sym, f) = | |
191 | env_set env sym $ MalFunction {fn=f, f_ast=Nil, f_params=[], macro=False, meta=Nil} | |
192 | ||
193 | evalFn :: Env -> Fn | |
194 | evalFn env [ast] = eval env ast | |
195 | evalFn _ _ = throwStr "illegal call of eval" | |
196 | ||
197 | main :: IO () | |
c150ec41 JM |
198 | main = do |
199 | args <- getArgs | |
200 | load_history | |
201 | ||
6116c2d5 | 202 | repl_env <- env_new [] |
c150ec41 JM |
203 | |
204 | -- core.hs: defined using Haskell | |
6116c2d5 NB |
205 | mapM_ (defBuiltIn repl_env) Core.ns |
206 | defBuiltIn repl_env ("eval", evalFn repl_env) | |
c150ec41 JM |
207 | |
208 | -- core.mal: defined using the language itself | |
6116c2d5 NB |
209 | re repl_env "(def! not (fn* (a) (if a false true)))" |
210 | re repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" | |
211 | re 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)))))))" | |
212 | re 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))))))))" | |
213 | ||
214 | case args of | |
215 | script : scriptArgs -> do | |
216 | env_set repl_env "*ARGV*" $ toList $ MalString <$> scriptArgs | |
217 | re repl_env $ "(load-file \"" ++ script ++ "\")" | |
218 | [] -> do | |
219 | env_set repl_env "*ARGV*" $ toList [] | |
220 | repl_loop repl_env |