Commit | Line | Data |
---|---|---|
0bac0757 JB |
1 | port module Main exposing (..) |
2 | ||
3 | import Array | |
4 | import Dict exposing (Dict) | |
5 | import IO exposing (..) | |
6 | import Json.Decode exposing (decodeValue) | |
7 | import Platform exposing (programWithFlags) | |
8 | import Types exposing (..) | |
9 | import Reader exposing (readString) | |
10 | import Printer exposing (printString) | |
11 | import Utils exposing (maybeToList, zip, last, justValues) | |
12 | import Env | |
13 | import Core | |
14 | import Eval | |
15 | ||
16 | ||
17 | main : Program Flags Model Msg | |
18 | main = | |
19 | programWithFlags | |
20 | { init = init | |
21 | , update = update | |
22 | , subscriptions = | |
23 | \model -> input (decodeValue decodeIO >> Input) | |
24 | } | |
25 | ||
26 | ||
27 | type alias Flags = | |
28 | { args : List String | |
29 | } | |
30 | ||
31 | ||
32 | type Model | |
33 | = InitIO Env (IO -> Eval MalExpr) | |
34 | | InitError String | |
35 | | ReplActive Env | |
36 | | ReplIO Env (IO -> Eval MalExpr) | |
37 | ||
38 | ||
39 | init : Flags -> ( Model, Cmd Msg ) | |
40 | init { args } = | |
41 | let | |
42 | initEnv = | |
43 | Core.ns | |
44 | ||
45 | evalMalInit = | |
16fbc20a | 46 | malInit |
0bac0757 JB |
47 | |> List.map rep |
48 | |> justValues | |
49 | |> List.foldl | |
50 | (\b a -> a |> Eval.andThen (\_ -> b)) | |
51 | (Eval.succeed MalNil) | |
52 | in | |
53 | runInit initEnv evalMalInit | |
54 | ||
55 | ||
16fbc20a JB |
56 | malInit : List String |
57 | malInit = | |
58 | [ """(def! not | |
59 | (fn* (a) | |
60 | (if a false true)))""" | |
61 | ] | |
62 | ||
63 | ||
0bac0757 JB |
64 | update : Msg -> Model -> ( Model, Cmd Msg ) |
65 | update msg model = | |
66 | case model of | |
67 | InitError _ -> | |
68 | -- ignore all | |
69 | ( model, Cmd.none ) | |
70 | ||
71 | InitIO env cont -> | |
72 | case msg of | |
73 | Input (Ok io) -> | |
74 | runInit env (cont io) | |
75 | ||
76 | Input (Err msg) -> | |
77 | Debug.crash msg | |
78 | ||
79 | ReplActive env -> | |
80 | case msg of | |
81 | Input (Ok (LineRead (Just line))) -> | |
82 | case rep line of | |
83 | Just expr -> | |
84 | run env expr | |
85 | ||
86 | Nothing -> | |
87 | ( model, readLine prompt ) | |
88 | ||
89 | Input (Ok LineWritten) -> | |
90 | ( model, readLine prompt ) | |
91 | ||
92 | Input (Ok (LineRead Nothing)) -> | |
93 | -- Ctrl+D = The End. | |
94 | ( model, Cmd.none ) | |
95 | ||
96 | Input (Ok io) -> | |
97 | Debug.crash "unexpected IO received: " io | |
98 | ||
99 | Input (Err msg) -> | |
100 | Debug.crash msg | |
101 | ||
102 | ReplIO env cont -> | |
103 | case msg of | |
104 | Input (Ok io) -> | |
105 | run env (cont io) | |
106 | ||
107 | Input (Err msg) -> | |
108 | Debug.crash msg ( model, Cmd.none ) | |
109 | ||
110 | ||
111 | runInit : Env -> Eval MalExpr -> ( Model, Cmd Msg ) | |
112 | runInit env expr = | |
113 | case Eval.run env expr of | |
114 | ( env, EvalOk expr ) -> | |
115 | -- Init went okay, start REPL. | |
116 | ( ReplActive env, readLine prompt ) | |
117 | ||
118 | ( env, EvalErr msg ) -> | |
119 | -- Init failed, don't start REPL. | |
120 | ( InitError msg, writeLine ("ERR:" ++ msg) ) | |
121 | ||
122 | ( env, EvalIO cmd cont ) -> | |
123 | -- IO in init. | |
124 | ( InitIO env cont, cmd ) | |
125 | ||
126 | ||
127 | run : Env -> Eval MalExpr -> ( Model, Cmd Msg ) | |
128 | run env expr = | |
129 | case Eval.run env expr of | |
130 | ( env, EvalOk expr ) -> | |
fe50dd7a | 131 | ( ReplActive env, writeLine (print env expr) ) |
0bac0757 JB |
132 | |
133 | ( env, EvalErr msg ) -> | |
134 | ( ReplActive env, writeLine ("ERR:" ++ msg) ) | |
135 | ||
136 | ( env, EvalIO cmd cont ) -> | |
137 | ( ReplIO env cont, cmd ) | |
138 | ||
139 | ||
140 | prompt : String | |
141 | prompt = | |
142 | "user> " | |
143 | ||
144 | ||
145 | {-| read can return three things: | |
146 | ||
147 | Ok (Just expr) -> parsed okay | |
148 | Ok Nothing -> empty string (only whitespace and/or comments) | |
149 | Err msg -> parse error | |
150 | ||
151 | -} | |
152 | read : String -> Result String (Maybe MalExpr) | |
153 | read = | |
154 | readString | |
155 | ||
156 | ||
fe50dd7a JB |
157 | debug : String -> (Env -> a) -> Eval b -> Eval b |
158 | debug msg f e = | |
16586ba5 JB |
159 | Eval.withEnv |
160 | (\env -> | |
fe50dd7a | 161 | Env.debug env msg (f env) |
16586ba5 JB |
162 | |> always e |
163 | ) | |
164 | ||
165 | ||
0bac0757 JB |
166 | eval : MalExpr -> Eval MalExpr |
167 | eval ast = | |
16586ba5 | 168 | let |
16fbc20a | 169 | apply expr env = |
16586ba5 JB |
170 | case expr of |
171 | MalApply app -> | |
172 | Left | |
173 | (debug "evalApply" | |
fe50dd7a | 174 | (\env -> printString env True expr) |
16586ba5 | 175 | (evalApply app) |
0bac0757 | 176 | ) |
16586ba5 JB |
177 | |
178 | _ -> | |
179 | Right expr | |
180 | in | |
181 | evalNoApply ast | |
182 | |> Eval.andThen (Eval.runLoop apply) | |
183 | ||
184 | ||
185 | evalApply : ApplyRec -> Eval MalExpr | |
186 | evalApply { frameId, bound, body } = | |
187 | Eval.withEnv | |
188 | (\env -> | |
189 | Eval.modifyEnv (Env.enter frameId bound) | |
190 | |> Eval.andThen (\_ -> evalNoApply body) | |
191 | |> Eval.andThen | |
192 | (\res -> | |
193 | Eval.modifyEnv (Env.leave env.currentFrameId) | |
194 | |> Eval.map (\_ -> res) | |
195 | ) | |
196 | ) | |
0bac0757 JB |
197 | |
198 | ||
199 | evalNoApply : MalExpr -> Eval MalExpr | |
200 | evalNoApply ast = | |
16586ba5 | 201 | debug "evalNoApply" |
fe50dd7a | 202 | (\env -> printString env True ast) |
16586ba5 JB |
203 | (case ast of |
204 | MalList [] -> | |
205 | Eval.succeed ast | |
0bac0757 | 206 | |
16586ba5 JB |
207 | MalList ((MalSymbol "def!") :: args) -> |
208 | evalDef args | |
0bac0757 | 209 | |
16586ba5 JB |
210 | MalList ((MalSymbol "let*") :: args) -> |
211 | evalLet args | |
0bac0757 | 212 | |
16586ba5 JB |
213 | MalList ((MalSymbol "do") :: args) -> |
214 | evalDo args | |
0bac0757 | 215 | |
16586ba5 JB |
216 | MalList ((MalSymbol "if") :: args) -> |
217 | evalIf args | |
0bac0757 | 218 | |
16586ba5 JB |
219 | MalList ((MalSymbol "fn*") :: args) -> |
220 | evalFn args | |
0bac0757 | 221 | |
16586ba5 JB |
222 | MalList list -> |
223 | evalList list | |
224 | |> Eval.andThen | |
225 | (\newList -> | |
226 | case newList of | |
227 | [] -> | |
228 | Eval.fail "can't happen" | |
0bac0757 | 229 | |
16586ba5 JB |
230 | (MalFunction (CoreFunc fn)) :: args -> |
231 | fn args | |
0bac0757 | 232 | |
fe50dd7a JB |
233 | (MalFunction (UserFunc { lazyFn })) :: args -> |
234 | lazyFn args | |
0bac0757 | 235 | |
16586ba5 | 236 | fn :: _ -> |
fe50dd7a JB |
237 | Eval.withEnv |
238 | (\env -> | |
239 | Eval.fail ((printString env True fn) ++ " is not a function") | |
240 | ) | |
16586ba5 | 241 | ) |
0bac0757 | 242 | |
16586ba5 JB |
243 | _ -> |
244 | evalAst ast | |
245 | ) | |
0bac0757 JB |
246 | |
247 | ||
248 | evalAst : MalExpr -> Eval MalExpr | |
249 | evalAst ast = | |
250 | case ast of | |
251 | MalSymbol sym -> | |
252 | -- Lookup symbol in env and return value or raise error if not found. | |
253 | Eval.withEnv | |
254 | (\env -> | |
255 | case Env.get sym env of | |
256 | Ok val -> | |
257 | Eval.succeed val | |
258 | ||
259 | Err msg -> | |
260 | Eval.fail msg | |
261 | ) | |
262 | ||
263 | MalList list -> | |
264 | -- Return new list that is result of calling eval on each element of list. | |
265 | evalList list | |
266 | |> Eval.map MalList | |
267 | ||
268 | MalVector vec -> | |
269 | evalList (Array.toList vec) | |
270 | |> Eval.map (Array.fromList >> MalVector) | |
271 | ||
272 | MalMap map -> | |
273 | evalList (Dict.values map) | |
274 | |> Eval.map | |
275 | (zip (Dict.keys map) | |
276 | >> Dict.fromList | |
277 | >> MalMap | |
278 | ) | |
279 | ||
280 | _ -> | |
281 | Eval.succeed ast | |
282 | ||
283 | ||
284 | evalList : List MalExpr -> Eval (List MalExpr) | |
285 | evalList list = | |
286 | let | |
287 | go list acc = | |
288 | case list of | |
289 | [] -> | |
290 | Eval.succeed (List.reverse acc) | |
291 | ||
292 | x :: rest -> | |
293 | eval x | |
294 | |> Eval.andThen | |
295 | (\val -> | |
296 | go rest (val :: acc) | |
297 | ) | |
298 | in | |
299 | go list [] | |
300 | ||
301 | ||
302 | evalDef : List MalExpr -> Eval MalExpr | |
303 | evalDef args = | |
304 | case args of | |
305 | [ MalSymbol name, uneValue ] -> | |
306 | eval uneValue | |
307 | |> Eval.andThen | |
308 | (\value -> | |
071ce8a8 | 309 | Eval.modifyEnv (Env.set name value) |
0bac0757 JB |
310 | |> Eval.andThen (\_ -> Eval.succeed value) |
311 | ) | |
312 | ||
313 | _ -> | |
314 | Eval.fail "def! expected two args: name and value" | |
315 | ||
316 | ||
317 | evalLet : List MalExpr -> Eval MalExpr | |
318 | evalLet args = | |
319 | let | |
320 | evalBinds binds = | |
321 | case binds of | |
322 | (MalSymbol name) :: expr :: rest -> | |
323 | eval expr | |
324 | |> Eval.andThen | |
325 | (\value -> | |
326 | Eval.modifyEnv (Env.set name value) | |
327 | |> Eval.andThen | |
328 | (\_ -> | |
329 | if List.isEmpty rest then | |
330 | Eval.succeed () | |
331 | else | |
332 | evalBinds rest | |
333 | ) | |
334 | ) | |
335 | ||
336 | _ -> | |
337 | Eval.fail "let* expected an even number of binds (symbol expr ..)" | |
338 | ||
339 | go binds body = | |
340 | Eval.modifyEnv Env.push | |
341 | |> Eval.andThen (\_ -> evalBinds binds) | |
342 | |> Eval.andThen (\_ -> evalNoApply body) | |
343 | |> Eval.andThen | |
344 | (\res -> | |
345 | Eval.modifyEnv Env.pop | |
346 | |> Eval.map (\_ -> res) | |
347 | ) | |
348 | in | |
349 | case args of | |
350 | [ MalList binds, body ] -> | |
351 | go binds body | |
352 | ||
353 | [ MalVector bindsVec, body ] -> | |
354 | go (Array.toList bindsVec) body | |
355 | ||
356 | _ -> | |
357 | Eval.fail "let* expected two args: binds and a body" | |
358 | ||
359 | ||
360 | evalDo : List MalExpr -> Eval MalExpr | |
361 | evalDo args = | |
362 | case List.reverse args of | |
363 | last :: rest -> | |
364 | evalList (List.reverse rest) | |
365 | |> Eval.andThen (\_ -> evalNoApply last) | |
366 | ||
367 | [] -> | |
368 | Eval.fail "do expected at least one arg" | |
369 | ||
370 | ||
371 | evalIf : List MalExpr -> Eval MalExpr | |
372 | evalIf args = | |
373 | let | |
374 | isThruthy expr = | |
375 | expr /= MalNil && expr /= (MalBool False) | |
376 | ||
377 | go condition trueExpr falseExpr = | |
378 | eval condition | |
379 | |> Eval.map isThruthy | |
380 | |> Eval.andThen | |
381 | (\cond -> | |
382 | evalNoApply | |
383 | (if cond then | |
384 | trueExpr | |
385 | else | |
386 | falseExpr | |
387 | ) | |
388 | ) | |
389 | in | |
390 | case args of | |
391 | [ condition, trueExpr ] -> | |
392 | go condition trueExpr MalNil | |
393 | ||
394 | [ condition, trueExpr, falseExpr ] -> | |
395 | go condition trueExpr falseExpr | |
396 | ||
397 | _ -> | |
398 | Eval.fail "if expected at least two args" | |
399 | ||
400 | ||
401 | evalFn : List MalExpr -> Eval MalExpr | |
402 | evalFn args = | |
403 | let | |
404 | {- Extract symbols from the binds list and verify their uniqueness -} | |
405 | extractSymbols acc list = | |
406 | case list of | |
407 | [] -> | |
408 | Ok (List.reverse acc) | |
409 | ||
410 | (MalSymbol name) :: rest -> | |
411 | if List.member name acc then | |
412 | Err "all binds must have unique names" | |
413 | else | |
414 | extractSymbols (name :: acc) rest | |
415 | ||
416 | _ -> | |
417 | Err "all binds in fn* must be a symbol" | |
418 | ||
419 | parseBinds list = | |
420 | case List.reverse list of | |
421 | var :: "&" :: rest -> | |
422 | Ok <| bindVarArgs (List.reverse rest) var | |
423 | ||
424 | _ -> | |
425 | if List.member "&" list then | |
426 | Err "varargs separator '&' is used incorrectly" | |
427 | else | |
428 | Ok <| bindArgs list | |
429 | ||
430 | extractAndParse = | |
431 | extractSymbols [] >> Result.andThen parseBinds | |
432 | ||
433 | bindArgs binds args = | |
434 | let | |
435 | numBinds = | |
436 | List.length binds | |
437 | in | |
438 | if List.length args /= numBinds then | |
439 | Err <| | |
440 | "function expected " | |
441 | ++ (toString numBinds) | |
442 | ++ " arguments" | |
443 | else | |
444 | Ok <| zip binds args | |
445 | ||
446 | bindVarArgs binds var args = | |
447 | let | |
448 | minArgs = | |
449 | List.length binds | |
450 | ||
451 | varArgs = | |
452 | MalList (List.drop minArgs args) | |
453 | in | |
454 | if List.length args < minArgs then | |
455 | Err <| | |
456 | "function expected at least " | |
457 | ++ (toString minArgs) | |
458 | ++ " arguments" | |
459 | else | |
460 | Ok <| zip binds args ++ [ ( var, varArgs ) ] | |
461 | ||
462 | makeFn frameId binder body = | |
463 | MalFunction <| | |
fe50dd7a JB |
464 | let |
465 | lazyFn args = | |
466 | case binder args of | |
467 | Ok bound -> | |
468 | Eval.succeed <| | |
469 | -- TODO : choice Env.enter prematurely? | |
470 | -- I think it is needed by the garbage collect.. | |
471 | MalApply | |
472 | { frameId = frameId | |
473 | , bound = bound | |
474 | , body = body | |
475 | } | |
476 | ||
477 | Err msg -> | |
478 | Eval.fail msg | |
479 | in | |
480 | UserFunc | |
481 | { frameId = frameId | |
482 | , lazyFn = lazyFn | |
483 | , eagerFn = lazyFn >> Eval.andThen eval | |
16fbc20a | 484 | , isMacro = False |
fe50dd7a | 485 | } |
0bac0757 JB |
486 | |
487 | go bindsList body = | |
488 | case extractAndParse bindsList of | |
489 | Ok binder -> | |
490 | Eval.modifyEnv Env.ref | |
491 | -- reference the current frame. | |
492 | |> Eval.andThen | |
493 | (\_ -> | |
494 | Eval.withEnv | |
495 | (\env -> | |
496 | Eval.succeed | |
497 | (makeFn env.currentFrameId binder body) | |
498 | ) | |
499 | ) | |
500 | ||
501 | Err msg -> | |
502 | Eval.fail msg | |
503 | in | |
504 | case args of | |
505 | [ MalList bindsList, body ] -> | |
506 | go bindsList body | |
507 | ||
508 | [ MalVector bindsVec, body ] -> | |
509 | go (Array.toList bindsVec) body | |
510 | ||
511 | _ -> | |
512 | Eval.fail "fn* expected two args: binds list and body" | |
513 | ||
514 | ||
fe50dd7a JB |
515 | print : Env -> MalExpr -> String |
516 | print env = | |
517 | printString env True | |
0bac0757 JB |
518 | |
519 | ||
520 | {-| Read-Eval-Print. | |
521 | ||
522 | Doesn't actually run the Eval but returns the monad. | |
523 | ||
524 | -} | |
525 | rep : String -> Maybe (Eval MalExpr) | |
526 | rep input = | |
527 | case readString input of | |
528 | Ok Nothing -> | |
529 | Nothing | |
530 | ||
531 | Err msg -> | |
532 | Just (Eval.fail msg) | |
533 | ||
534 | Ok (Just ast) -> | |
535 | eval ast |> Just |