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