Merge pull request #383 from asarhaddon/ada2tco-do

[jackhill/mal.git] / elm / step5_tco.elm

diff --git a/elm/step5_tco.elm b/elm/step5_tco.elm
index d48c50e..d9fb3c0 100644 (file)
--- a/elm/step5_tco.elm
+++ b/elm/step5_tco.elm
@@ -31,7 +31,7 @@ type alias Flags =
 
 type Model
     = InitIO Env (IO -> Eval MalExpr)
-    | InitError String
+    | InitError
     | ReplActive Env
     | ReplIO Env (IO -> Eval MalExpr)
 
@@ -43,7 +43,7 @@ init { args } =
             Core.ns
 
         evalMalInit =
-            Core.malInit
+            malInit
                 |> List.map rep
                 |> justValues
                 |> List.foldl
@@ -53,10 +53,18 @@ init { args } =
         runInit initEnv evalMalInit
 
 
+malInit : List String
+malInit =
+    [ """(def! not
+            (fn* (a)
+                (if a false true)))"""
+    ]
+
+
 update : Msg -> Model -> ( Model, Cmd Msg )
 update msg model =
     case model of
-        InitError _ ->
+        InitError ->
             -- ignore all
             ( model, Cmd.none )
 
@@ -109,7 +117,7 @@ runInit env expr =
 
         ( env, EvalErr msg ) ->
             -- Init failed, don't start REPL.
-            ( InitError msg, writeLine ("ERR:" ++ msg) )
+            ( InitError, writeLine (printError env msg) )
 
         ( env, EvalIO cmd cont ) ->
             -- IO in init.
@@ -120,10 +128,10 @@ run : Env -> Eval MalExpr -> ( Model, Cmd Msg )
 run env expr =
     case Eval.run env expr of
         ( env, EvalOk expr ) ->
-            ( ReplActive env, writeLine (print expr) )
+            ( ReplActive env, writeLine (print env expr) )
 
         ( env, EvalErr msg ) ->
-            ( ReplActive env, writeLine ("ERR:" ++ msg) )
+            ( ReplActive env, writeLine (printError env msg) )
 
         ( env, EvalIO cmd cont ) ->
             ( ReplIO env cont, cmd )
@@ -146,77 +154,92 @@ read =
     readString
 
 
+debug : String -> (Env -> a) -> Eval b -> Eval b
+debug msg f e =
+    Eval.withEnv
+        (\env ->
+            Env.debug env msg (f env)
+                |> always e
+        )
+
+
 eval : MalExpr -> Eval MalExpr
 eval ast =
-    Debug.log "eval " (printString True ast)
-        |> (\_ ->
-                evalNoApply ast
-                    |> Eval.andThen
-                        (\ast ->
-                            case ast of
-                                MalApply { frameId, bound, body } ->
-                                    Eval.withEnv
-                                        (\env ->
-                                            Eval.modifyEnv (Env.enter frameId bound)
-                                                |> Eval.andThen (\_ -> evalNoApply body)
-                                                |> Eval.andThen
-                                                    (\res ->
-                                                        Eval.modifyEnv (Env.leave env.currentFrameId)
-                                                            |> Eval.map (\_ -> res)
-                                                    )
-                                        )
-                                        |> Eval.andThen eval
-
-                                _ ->
-                                    Eval.succeed ast
+    let
+        apply expr env =
+            case expr of
+                MalApply app ->
+                    Left
+                        (debug "evalApply"
+                            (\env -> printString env True expr)
+                            (evalApply app)
                         )
-           )
+
+                _ ->
+                    Right expr
+    in
+        evalNoApply ast
+            |> Eval.andThen (Eval.runLoop apply)
+
+
+evalApply : ApplyRec -> Eval MalExpr
+evalApply { frameId, bound, body } =
+    Eval.withEnv
+        (\env ->
+            Eval.modifyEnv (Env.enter frameId bound)
+                |> Eval.andThen (\_ -> evalNoApply body)
+                |> Eval.finally Env.leave
+                |> Eval.gcPass
+        )
 
 
 evalNoApply : MalExpr -> Eval MalExpr
 evalNoApply ast =
-    Debug.log "evalNoApply " (printString True ast)
-        |> (\_ ->
-                case ast of
-                    MalList [] ->
-                        Eval.succeed ast
+    debug "evalNoApply"
+        (\env -> printString env True ast)
+        (case ast of
+            MalList [] ->
+                Eval.succeed ast
 
-                    MalList ((MalSymbol "def!") :: args) ->
-                        evalDef args
+            MalList ((MalSymbol "def!") :: args) ->
+                evalDef args
 
-                    MalList ((MalSymbol "let*") :: args) ->
-                        evalLet args
+            MalList ((MalSymbol "let*") :: args) ->
+                evalLet args
 
-                    MalList ((MalSymbol "do") :: args) ->
-                        evalDo args
+            MalList ((MalSymbol "do") :: args) ->
+                evalDo args
 
-                    MalList ((MalSymbol "if") :: args) ->
-                        evalIf args
+            MalList ((MalSymbol "if") :: args) ->
+                evalIf args
 
-                    MalList ((MalSymbol "fn*") :: args) ->
-                        evalFn args
+            MalList ((MalSymbol "fn*") :: args) ->
+                evalFn args
 
-                    MalList list ->
-                        evalList list
-                            |> Eval.andThen
-                                (\newList ->
-                                    case newList of
-                                        [] ->
-                                            Eval.fail "can't happen"
+            MalList list ->
+                evalList list
+                    |> Eval.andThen
+                        (\newList ->
+                            case newList of
+                                [] ->
+                                    Eval.fail "can't happen"
 
-                                        (MalFunction (CoreFunc fn)) :: args ->
-                                            fn args
+                                (MalFunction (CoreFunc fn)) :: args ->
+                                    fn args
 
-                                        (MalFunction (UserFunc { fn })) :: args ->
-                                            fn args
+                                (MalFunction (UserFunc { lazyFn })) :: args ->
+                                    lazyFn args
 
-                                        fn :: _ ->
-                                            Eval.fail ((printString True fn) ++ " is not a function")
-                                )
+                                fn :: _ ->
+                                    Eval.withEnv
+                                        (\env ->
+                                            Eval.fail ((printString env True fn) ++ " is not a function")
+                                        )
+                        )
 
-                    _ ->
-                        evalAst ast
-           )
+            _ ->
+                evalAst ast
+        )
 
 
 evalAst : MalExpr -> Eval MalExpr
@@ -435,24 +458,27 @@ evalFn args =
 
         makeFn frameId binder body =
             MalFunction <|
-                UserFunc
-                    { frameId = frameId
-                    , fn =
-                        \args ->
-                            case binder args of
-                                Ok bound ->
-                                    Eval.succeed <|
-                                        -- TODO : choice Env.enter prematurely?
-                                        -- I think it is needed by the garbage collect..
-                                        MalApply
-                                            { frameId = frameId
-                                            , bound = bound
-                                            , body = body
-                                            }
-
-                                Err msg ->
-                                    Eval.fail msg
-                    }
+                let
+                    lazyFn args =
+                        case binder args of
+                            Ok bound ->
+                                Eval.succeed <|
+                                    MalApply
+                                        { frameId = frameId
+                                        , bound = bound
+                                        , body = body
+                                        }
+
+                            Err msg ->
+                                Eval.fail msg
+                in
+                    UserFunc
+                        { frameId = frameId
+                        , lazyFn = lazyFn
+                        , eagerFn = lazyFn >> Eval.andThen eval
+                        , isMacro = False
+                        , meta = Nothing
+                        }
 
         go bindsList body =
             case extractAndParse bindsList of
@@ -482,9 +508,14 @@ evalFn args =
                 Eval.fail "fn* expected two args: binds list and body"
 
 
-print : MalExpr -> String
-print =
-    printString True
+print : Env -> MalExpr -> String
+print env =
+    printString env True
+
+
+printError : Env -> MalExpr -> String
+printError env expr =
+    "Error: " ++ (printString env False expr)
 
 
 {-| Read-Eval-Print.