1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
|
import System.IO (hFlush, stdout)
import System.Environment (getArgs)
import Control.Monad (mapM)
import Control.Monad.Error (runErrorT)
import Control.Monad.Trans (liftIO)
import qualified Data.Map as Map
import qualified Data.Traversable as DT
import Readline (readline, load_history)
import Types
import Reader (read_str)
import Printer (_pr_str)
import Env (Env, env_new, env_bind, env_find, env_get, env_set)
import Core as Core
-- read
mal_read :: String -> IOThrows MalVal
mal_read str = read_str str
-- eval
is_pair (MalList x _:xs) = True
is_pair (MalVector x _:xs) = True
is_pair _ = False
quasiquote :: MalVal -> MalVal
quasiquote ast =
case ast of
(MalList (MalSymbol "unquote" : a1 : []) _) -> a1
(MalList (MalList (MalSymbol "splice-unquote" : a01 : []) _ : rest) _) ->
MalList [(MalSymbol "concat"), a01, quasiquote (MalList rest Nil)] Nil
(MalVector (MalList (MalSymbol "splice-unquote" : a01 : []) _ : rest) _) ->
MalList [(MalSymbol "concat"), a01, quasiquote (MalVector rest Nil)] Nil
(MalList (a0 : rest) _) -> MalList [(MalSymbol "cons"),
quasiquote a0,
quasiquote (MalList rest Nil)] Nil
(MalVector (a0 : rest) _) -> MalList [(MalSymbol "cons"),
quasiquote a0,
quasiquote (MalVector rest Nil)] Nil
_ -> MalList [(MalSymbol "quote"), ast] Nil
is_macro_call :: MalVal -> Env -> IOThrows Bool
is_macro_call (MalList (a0@(MalSymbol _) : rest) _) env = do
e <- liftIO $ env_find env a0
case e of
Just e -> do
f <- env_get e a0
case f of
MalFunc {macro=True} -> return True
_ -> return False
Nothing -> return False
is_macro_call _ _ = return False
macroexpand :: MalVal -> Env -> IOThrows MalVal
macroexpand ast@(MalList (a0 : args) _) env = do
mc <- is_macro_call ast env
if mc then do
mac <- env_get env a0
case mac of
MalFunc {fn=(Fn f)} -> do
new_ast <- f args
macroexpand new_ast env
_ ->
return ast
else
return ast
macroexpand ast _ = return ast
eval_ast :: MalVal -> Env -> IOThrows MalVal
eval_ast sym@(MalSymbol _) env = env_get env sym
eval_ast ast@(MalList lst m) env = do
new_lst <- mapM (\x -> (eval x env)) lst
return $ MalList new_lst m
eval_ast ast@(MalVector lst m) env = do
new_lst <- mapM (\x -> (eval x env)) lst
return $ MalVector new_lst m
eval_ast ast@(MalHashMap lst m) env = do
new_hm <- DT.mapM (\x -> (eval x env)) lst
return $ MalHashMap new_hm m
eval_ast ast env = return ast
let_bind :: Env -> [MalVal] -> IOThrows Env
let_bind env [] = return env
let_bind env (b:e:xs) = do
evaled <- eval e env
x <- liftIO $ env_set env b evaled
let_bind env xs
apply_ast :: MalVal -> Env -> IOThrows MalVal
apply_ast ast@(MalList (MalSymbol "def!" : args) _) env = do
case args of
(a1@(MalSymbol _): a2 : []) -> do
evaled <- eval a2 env
liftIO $ env_set env a1 evaled
_ -> throwStr "invalid def!"
apply_ast ast@(MalList (MalSymbol "let*" : args) _) env = do
case args of
(a1 : a2 : []) -> do
params <- (_to_list a1)
let_env <- liftIO $ env_new $ Just env
let_bind let_env params
eval a2 let_env
_ -> throwStr "invalid let*"
apply_ast ast@(MalList (MalSymbol "quote" : args) _) env = do
case args of
a1 : [] -> return a1
_ -> throwStr "invalid quote"
apply_ast ast@(MalList (MalSymbol "quasiquote" : args) _) env = do
case args of
a1 : [] -> eval (quasiquote a1) env
_ -> throwStr "invalid quasiquote"
apply_ast ast@(MalList (MalSymbol "defmacro!" : args) _) env = do
case args of
(a1 : a2 : []) -> do
func <- eval a2 env
case func of
MalFunc {fn=f, ast=a, env=e, params=p} -> do
let new_func = MalFunc {fn=f, ast=a, env=e,
params=p, macro=True,
meta=Nil} in
liftIO $ env_set env a1 new_func
_ -> throwStr "defmacro! on non-function"
_ -> throwStr "invalid defmacro!"
apply_ast ast@(MalList (MalSymbol "macroexpand" : args) _) env = do
case args of
(a1 : []) -> macroexpand a1 env
_ -> throwStr "invalid macroexpand"
apply_ast ast@(MalList (MalSymbol "try*" : args) _) env = do
case args of
(a1 : []) -> eval a1 env
(a1 : (MalList ((MalSymbol "catch*") : a21 : a22 : []) _) : []) -> do
res <- liftIO $ runErrorT $ eval a1 env
case res of
Right val -> return val
Left err -> do
exc <- case err of
(StringError str) -> return $ MalString str
(MalValError mv) -> return $ mv
try_env <- liftIO $ env_new $ Just env
liftIO $ env_set try_env a21 exc
eval a22 try_env
_ -> throwStr "invalid try*"
apply_ast ast@(MalList (MalSymbol "do" : args) _) env = do
case args of
([]) -> return Nil
_ -> do
el <- eval_ast (MalList args Nil) env
case el of
(MalList lst _) -> return $ last lst
apply_ast ast@(MalList (MalSymbol "if" : args) _) env = do
case args of
(a1 : a2 : a3 : []) -> do
cond <- eval a1 env
if cond == MalFalse || cond == Nil
then eval a3 env
else eval a2 env
(a1 : a2 : []) -> do
cond <- eval a1 env
if cond == MalFalse || cond == Nil
then return Nil
else eval a2 env
_ -> throwStr "invalid if"
apply_ast ast@(MalList (MalSymbol "fn*" : args) _) env = do
case args of
(a1 : a2 : []) -> do
params <- (_to_list a1)
return $ (_malfunc a2 env (MalList params Nil)
(\args -> do
fn_env1 <- liftIO $ env_new $ Just env
fn_env2 <- liftIO $ env_bind fn_env1 params args
eval a2 fn_env2))
_ -> throwStr "invalid fn*"
apply_ast ast@(MalList _ _) env = do
mc <- is_macro_call ast env
if mc then do
new_ast <- macroexpand ast env
eval new_ast env
else
case ast of
MalList _ _ -> do
el <- eval_ast ast env
case el of
(MalList ((Func (Fn f) _) : rest) _) ->
f $ rest
(MalList ((MalFunc {ast=ast,
env=fn_env,
params=(MalList params Nil)} : rest)) _) -> do
fn_env1 <- liftIO $ env_new $ Just fn_env
fn_env2 <- liftIO $ env_bind fn_env1 params rest
eval ast fn_env2
el ->
throwStr $ "invalid apply: " ++ (show el)
_ -> return ast
eval :: MalVal -> Env -> IOThrows MalVal
eval ast env = do
case ast of
(MalList _ _) -> apply_ast ast env
_ -> eval_ast ast env
-- print
mal_print :: MalVal -> String
mal_print exp = show exp
-- repl
rep :: Env -> String -> IOThrows String
rep env line = do
ast <- mal_read line
exp <- eval ast env
return $ mal_print exp
repl_loop :: Env -> IO ()
repl_loop env = do
line <- readline "user> "
case line of
Nothing -> return ()
Just "" -> repl_loop env
Just str -> do
res <- runErrorT $ rep env str
out <- case res of
Left (StringError str) -> return $ "Error: " ++ str
Left (MalValError mv) -> return $ "Error: " ++ (show mv)
Right val -> return val
putStrLn out
hFlush stdout
repl_loop env
main = do
args <- getArgs
load_history
repl_env <- env_new Nothing
-- core.hs: defined using Haskell
(mapM (\(k,v) -> (env_set repl_env (MalSymbol k) v)) Core.ns)
env_set repl_env (MalSymbol "eval") (_func (\[ast] -> eval ast repl_env))
env_set repl_env (MalSymbol "*ARGV*") (MalList [] Nil)
-- core.mal: defined using the language itself
runErrorT $ rep repl_env "(def! not (fn* (a) (if a false true)))"
runErrorT $ rep repl_env "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))"
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)))))))"
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))))))))"
if length args > 0 then do
env_set repl_env (MalSymbol "*ARGV*") (MalList (map MalString (drop 1 args)) Nil)
runErrorT $ rep repl_env $ "(load-file \"" ++ (args !! 0) ++ "\")"
return ()
else
repl_loop repl_env
|
