1 import System
.IO (hFlush, stdout)
2 import System
.Environment
(getArgs)
3 import Control
.Monad
(mapM)
4 import Control
.Monad
.Except
(runExceptT
)
5 import Control
.Monad
.Trans
(liftIO
)
6 import Data
.Foldable
(foldlM
, foldrM
)
8 import Readline
(readline
, load_history
)
10 import Reader
(read_str
)
11 import Printer
(_pr_str
)
12 import Env
(env_new
, env_bind
, env_get
, env_set
)
17 mal_read
:: String -> IOThrows MalVal
22 -- starts-with is replaced with pattern matching.
24 qqIter
:: Env
-> MalVal
-> [MalVal
] -> IOThrows
[MalVal
]
25 qqIter env
(MalSeq _
(Vect
False) [MalSymbol
"splice-unquote", x
]) acc
= do
26 evaluated
<- eval env x
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
33 quasiquote
:: MalVal
-> Env
-> IOThrows MalVal
34 quasiquote
(MalSeq _
(Vect
False) [MalSymbol
"unquote", x
]) env
= eval env x
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
39 quasiquote ast _
= return ast
41 -- is-macro-call is replaced with pattern matching.
43 macroexpand
:: Env
-> MalVal
-> IOThrows MalVal
44 macroexpand env ast
@(MalSeq _
(Vect
False) (MalSymbol a0
: args
)) = do
45 maybeMacro
<- liftIO
$ env_get env a0
47 Just
(MalFunction
{fn
=f
, macro
=True}) -> macroexpand env
=<< f args
49 macroexpand _ ast
= return ast
51 -- eval_ast is replaced with pattern matching.
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
58 let_bind _ _
= throwStr
"invalid let*"
60 unWrapSymbol
:: MalVal
-> IOThrows
String
61 unWrapSymbol
(MalSymbol s
) = return s
62 unWrapSymbol _
= throwStr
"fn* parameter must be symbols"
64 newFunction
:: MalVal
-> Env
-> [String] -> MalVal
65 newFunction a env p
= MalFunction
{f_ast
=a
, f_params
=p
, macro
=False, meta
=Nil
,
67 fn_env
<- liftIO
$ env_new env
68 ok
<- liftIO
$ env_bind fn_env p args
71 False -> throwStr
$ "actual parameters do not match signature " ++ show p
)}
73 apply_ast
:: [MalVal
] -> Env
-> IOThrows MalVal
75 apply_ast
[] _
= return $ toList
[]
77 apply_ast
[MalSymbol
"def!", MalSymbol a1
, a2
] env
= do
79 liftIO
$ env_set env a1 evd
81 apply_ast
(MalSymbol
"def!" : _
) _
= throwStr
"invalid def!"
83 apply_ast
[MalSymbol
"let*", MalSeq _ _ params
, a2
] env
= do
84 let_env
<- liftIO
$ env_new env
85 let_bind let_env params
87 apply_ast
(MalSymbol
"let*" : _
) _
= throwStr
"invalid let*"
89 apply_ast
[MalSymbol
"quote", a1
] _
= return a1
90 apply_ast
(MalSymbol
"quote" : _
) _
= throwStr
"invalid quote"
92 apply_ast
[MalSymbol
"quasiquote", a1
] env
= quasiquote a1 env
93 apply_ast
(MalSymbol
"quasiquote" : _
) _
= throwStr
"invalid quasiquote"
95 apply_ast
[MalSymbol
"defmacro!", MalSymbol a1
, a2
] env
= do
98 MalFunction
{macro
=False} -> do
99 let m
= func
{macro
=True}
100 liftIO
$ env_set env a1 m
102 _
-> throwStr
"defmacro! on non-function"
103 apply_ast
(MalSymbol
"defmacro!" : _
) _
= throwStr
"invalid defmacro!"
105 apply_ast
[MalSymbol
"macroexpand", a1
] env
= macroexpand env a1
106 apply_ast
(MalSymbol
"macroexpand" : _
) _
= throwStr
"invalid macroexpand"
108 apply_ast
(MalSymbol
"do" : args
) env
= foldlM
(const $ eval env
) Nil args
110 apply_ast
[MalSymbol
"if", a1
, a2
, a3
] env
= do
112 eval env
$ case cond
of
114 MalBoolean
False -> a3
116 apply_ast
[MalSymbol
"if", a1
, a2
] env
= do
120 MalBoolean
False -> return Nil
122 apply_ast
(MalSymbol
"if" : _
) _
= throwStr
"invalid if"
124 apply_ast
[MalSymbol
"fn*", MalSeq _ _ params
, ast
] env
= newFunction ast env
<$> mapM unWrapSymbol params
125 apply_ast
(MalSymbol
"fn*" : _
) _
= throwStr
"invalid fn*"
127 apply_ast ast env
= do
128 evd
<- mapM (eval env
) ast
130 MalFunction
{fn
=f
, macro
=False} : args
-> f args
131 _
-> throwStr
$ "invalid apply: " ++ Printer
._pr_str
True (toList ast
)
133 eval
:: Env
-> MalVal
-> IOThrows MalVal
135 newAst
<- macroexpand env ast
138 maybeVal
<- liftIO
$ env_get env sym
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
149 mal_print
:: MalVal
-> String
150 mal_print
= Printer
._pr_str
True
154 rep
:: Env
-> String -> IOThrows
String
155 rep env line
= mal_print
<$> (eval env
=<< mal_read line
)
157 repl_loop
:: Env
-> IO ()
159 line
<- readline
"user> "
162 Just
"" -> repl_loop env
164 res
<- runExceptT
$ rep env str
166 Left mv
-> return $ "Error: " ++ Printer
._pr_str
True mv
167 Right val
-> return val
172 -- Read and evaluate a line. Ignore successful results, but crash in
173 -- case of error. This is intended for the startup procedure.
174 re
:: Env
-> String -> IO ()
175 re repl_env line
= do
176 res
<- runExceptT
$ eval repl_env
=<< mal_read line
178 Left mv
-> error $ "Startup failed: " ++ Printer
._pr_str
True mv
181 defBuiltIn
:: Env
-> (String, Fn
) -> IO ()
182 defBuiltIn env
(sym
, f
) =
183 env_set env sym
$ MalFunction
{fn
=f
, f_ast
=Nil
, f_params
=[], macro
=False, meta
=Nil
}
186 evalFn env
[ast
] = eval env ast
187 evalFn _ _
= throwStr
"illegal call of eval"
194 repl_env
<- env_new
[]
196 -- core.hs: defined using Haskell
197 mapM_ (defBuiltIn repl_env
) Core
.ns
198 defBuiltIn repl_env
("eval", evalFn repl_env
)
200 -- core.mal: defined using the language itself
201 re repl_env
"(def! not (fn* (a) (if a false true)))"
202 re repl_env
"(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))"
203 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)))))))"
204 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))))))))"
207 script
: scriptArgs
-> do
208 env_set repl_env
"*ARGV*" $ toList
$ MalString
<$> scriptArgs
209 re repl_env
$ "(load-file \"" ++ script
++ "\")"
211 env_set repl_env
"*ARGV*" $ toList
[]