Run Eval in context

This allows the `Vm` to show proper error messages about unused values
as well as sub-programs that don’t return a value when `run` is used to
evaluate code at runtime.

app/elm/Compiler/Ast.elm

@@ -285,6 +285,16 @@ compileBranch controlStructure context children =
             compileNonEmptyBranch context (Nonempty first rest)
 
 
+toInstructionContext : Context -> Instruction.Context
+toInstructionContext context =
+    case context of
+        Statement ->
+            Instruction.Statement
+
+        Expression { caller } ->
+            Instruction.Expression { caller = caller }
+
+
 {-| Compile an AST node to a list of VM instructions.
 
 This function inserts instructions that check at runtime whether or not a
@@ -788,8 +798,12 @@ compile context node =
             ]
 
         Run node_ ->
+            let
+                instructionContext =
+                    toInstructionContext context
+            in
             [ compileInContext (Expression { caller = "run" }) node_
-            , [ Eval ]
+            , [ EvalInContext instructionContext ]
             ]
                 |> List.concat
 

app/elm/Vm/Instruction.elm

@@ -1,4 +1,4 @@
-module Vm.Instruction exposing (Instruction(..))
+module Vm.Instruction exposing (Context(..), Instruction(..))
 
 import Vm.Command as C
 import Vm.Exception exposing (Exception)
@@ -7,6 +7,20 @@ import Vm.Primitive as P
 import Vm.Type as Type
 
 
+{-| Represents the context a Vm instruction can be executed in.
+
+This is relevant for whether or not to raise exceptions about unused or missing
+return values.
+
+If the context is `Statement` the evaluated code is expected to not return a
+value, if it is `Expression` it is expected to return a value.
+
+-}
+type Context
+    = Statement
+    | Expression { caller : String }
+
+
 {-| Represent instructions a `Vm` can execute.
 -}
 type Instruction
@@ -19,7 +33,7 @@ type Instruction
     | Thing
     | Introspect0 I.Introspect0
     | Introspect1 I.Introspect1
-    | Eval
+    | EvalInContext Context
     | Eval1 P.Primitive1
     | Eval2 P.Primitive2
     | Eval3 P.Primitive3

app/elm/Vm/Vm.elm

@@ -16,7 +16,7 @@ machine as well as functions for running it.
 -}
 
 import Array exposing (Array)
-import Compiler.Ast as Ast exposing (CompiledFunction, CompiledProgram, Context(..), Program)
+import Compiler.Ast as Ast exposing (CompiledFunction, CompiledProgram, Program)
 import Compiler.Linker as Linker exposing (LinkedProgram)
 import Compiler.Parser as Parser exposing (Parser)
 import Dict exposing (Dict)
@@ -26,7 +26,7 @@ import Parser.Advanced as Parser
 import Vm.Command as C
 import Vm.Error as Error exposing (Error(..), Internal(..))
 import Vm.Exception as Exception exposing (Exception)
-import Vm.Instruction exposing (Instruction(..))
+import Vm.Instruction exposing (Context(..), Instruction(..))
 import Vm.Introspect as I
 import Vm.Primitive as P
 import Vm.Scope as Scope exposing (Binding(..), Scope)
@@ -39,6 +39,7 @@ import Vm.Type as Type
 type alias Vm =
     { instructions : Array Instruction
     , programCounter : Int
+    , executionHaltedDueToError : Bool
     , stack : Stack
     , scopes : List Scope
     , environment : Environment
@@ -65,6 +66,7 @@ initialize : LinkedProgram -> Vm
 initialize { instructions, functionTable, compiledFunctions, startAddress } =
     { instructions = Array.fromList instructions
     , programCounter = startAddress
+    , executionHaltedDueToError = False
     , stack = []
     , scopes = Scope.empty
     , environment = Environment.empty
@@ -128,8 +130,17 @@ encodeInstruction instruction =
                 Introspect1 { name } ->
                     "Introspect1 " ++ name
 
-                Eval ->
-                    "Eval"
+                EvalInContext context ->
+                    let
+                        name =
+                            case context of
+                                Statement ->
+                                    "Statement"
+
+                                Expression { caller } ->
+                                    "[Expression " ++ caller ++ "]"
+                    in
+                    "EvalInContext " ++ name
 
                 Eval1 { name } ->
                     "Eval1 " ++ name
@@ -485,15 +496,29 @@ popValues n vm =
             |> Result.map (\first -> ( first, { vm | stack = List.drop n vm.stack } ))
 
 
-parseAndCompileProgram : Parser Program -> String -> Result Error CompiledProgram
-parseAndCompileProgram parser =
+toAstContext : Context -> Ast.Context
+toAstContext context =
+    case context of
+        Statement ->
+            Ast.Statement
+
+        Expression { caller } ->
+            Ast.Expression { caller = caller }
+
+
+parseAndCompileProgram : Context -> Parser Program -> String -> Result Error CompiledProgram
+parseAndCompileProgram context parser =
+    let
+        astContext =
+            toAstContext context
+    in
     Parser.run parser
         >> Result.mapError (always <| Internal ParsingFailed)
-        >> Result.map (Ast.compileProgram Statement)
+        >> Result.map (Ast.compileProgram astContext)
 
 
-parseAndEvalInstructions : Vm -> List Type.Value -> Result Error Vm
-parseAndEvalInstructions vm instructions =
+parseAndEvalInstructions : Context -> Vm -> List Type.Value -> Result Error Vm
+parseAndEvalInstructions context vm instructions =
     let
         parser =
             getParser vm
@@ -502,7 +527,7 @@ parseAndEvalInstructions vm instructions =
             instructions
                 |> Type.List
                 |> Type.toString
-                |> parseAndCompileProgram parser
+                |> parseAndCompileProgram context parser
 
         result =
             compiledProgram
@@ -511,30 +536,42 @@ parseAndEvalInstructions vm instructions =
                 |> Result.map (withEnvironment vm.environment)
                 |> Result.map run
     in
-    -- This code does not check yet for context (whether the caller expects a
-    -- value to be returned by `Eval` or not).
     case result of
         Ok (Done subVm) ->
-            case subVm.stack of
-                ((Stack.Value _) as value) :: _ ->
-                    let
-                        newVm =
-                            { vm | environment = subVm.environment, stack = value :: vm.stack }
-                    in
-                    Ok newVm
+            if subVm.executionHaltedDueToError then
+                { vm
+                    | executionHaltedDueToError = True
+                    , environment = subVm.environment
+                }
+                    |> Ok
+
+            else
+                case subVm.stack of
+                    {- To be more strict with respect to which programs to
+                       accept as valid, this could also be changed to just
+                       match a stack with a single value. At this point, I
+                       don’t know what arguments there are against such a
+                       change.
+                    -}
+                    ((Stack.Value _) as value) :: _ ->
+                        let
+                            newVm =
+                                { vm | environment = subVm.environment, stack = value :: vm.stack }
+                        in
+                        Ok newVm
 
-                [] ->
-                    vm |> withEnvironment subVm.environment |> Ok
+                    [] ->
+                        vm |> withEnvironment subVm.environment |> Ok
 
-                _ ->
-                    Err <| Internal EvalFailed
+                    _ ->
+                        Err <| Internal EvalFailed
 
         _ ->
             Err <| Internal EvalFailed
 
 
-eval : Vm -> Result Error Vm
-eval vm =
+evalInContext : Context -> Vm -> Result Error Vm
+evalInContext context vm =
     popValue1 vm
         |> Result.andThen
             (\( first, newVm ) ->
@@ -551,7 +588,7 @@ eval vm =
                                 Err <| Internal InvalidStack
                 in
                 instructions
-                    |> Result.andThen (parseAndEvalInstructions newVm)
+                    |> Result.andThen (parseAndEvalInstructions context newVm)
                     |> Result.map incrementProgramCounter
             )
 
@@ -1097,8 +1134,8 @@ execute instruction vm =
         Introspect1 primitive ->
             introspect1 primitive vm
 
-        Eval ->
-            eval vm
+        EvalInContext context ->
+            evalInContext context vm
 
         Eval1 primitive ->
             eval1 primitive vm
@@ -1223,17 +1260,25 @@ step vm =
         instruction =
             Array.get vm.programCounter vm.instructions
     in
-    case instruction of
-        Just instruction_ ->
-            case execute instruction_ vm of
-                Ok newVm ->
-                    Paused newVm
+    if vm.executionHaltedDueToError then
+        Done vm
 
-                Err error ->
-                    Done { vm | environment = Environment.error (Error.toString error) vm.environment }
+    else
+        case instruction of
+            Just instruction_ ->
+                case execute instruction_ vm of
+                    Ok newVm ->
+                        Paused newVm
+
+                    Err error ->
+                        Done
+                            { vm
+                                | executionHaltedDueToError = True
+                                , environment = Environment.error (Error.toString error) vm.environment
+                            }
 
-        _ ->
-            Done vm
+            _ ->
+                Done vm
 
 
 {-| Run a `Vm` until the program counter points to an invalid instruction.
@@ -1245,21 +1290,30 @@ returns a value or calls itself.
 run : Vm -> State
 run vm =
     let
+        run_ : Result Error Vm -> State
         run_ result =
             case result of
                 Ok newVm ->
                     let
                         instruction =
                             Array.get newVm.programCounter newVm.instructions
                     in
-                    case instruction of
-                        Just instruction_ ->
-                            run_ (execute instruction_ newVm)
+                    if newVm.executionHaltedDueToError then
+                        Done newVm
 
-                        _ ->
-                            Done newVm
+                    else
+                        case instruction of
+                            Just instruction_ ->
+                                run_ (execute instruction_ newVm)
+
+                            _ ->
+                                Done newVm
 
                 Err error ->
-                    Done { vm | environment = Environment.error (Error.toString error) vm.environment }
+                    Done
+                        { vm
+                            | executionHaltedDueToError = True
+                            , environment = Environment.error (Error.toString error) vm.environment
+                        }
     in
     run_ (Ok vm)

tests/Test/Error.elm

@@ -102,6 +102,7 @@ print foo "baz""" "foo did not output to print"
         , printsError "1 > print 3" "print did not output to >"
         , printsError "print ifelse \"true [] []" "ifelse did not output to print"
         , printsError "print ifelse \"false [] []" "ifelse did not output to print"
+        , printsError "print run [print \"a]" "print did not output to print"
         ]
 
 
@@ -136,6 +137,7 @@ foo "baz"""
         , printsError "if 1 = 1 [ minus 1 ]" "You don’t say what to do with -1"
         , printsError "ifelse \"true [ 5 ] [ 6 ]" "You don’t say what to do with 5"
         , printsError "butfirst [ 1 ]" "You don’t say what to do with []"
+        , printsError "run [\"a]" "You don’t say what to do with a"
         ]
 
 

tests/Test/Vm.elm

@@ -8,7 +8,7 @@ import Expect
 import Test exposing (..)
 import Vm.Command as C
 import Vm.Exception as Exception
-import Vm.Instruction exposing (Instruction(..))
+import Vm.Instruction exposing (Context(..), Instruction(..))
 import Vm.Introspect as I
 import Vm.Primitive as P
 import Vm.Scope as Scope
@@ -21,6 +21,7 @@ emptyVm : Vm
 emptyVm =
     { instructions = Array.empty
     , programCounter = 0
+    , executionHaltedDueToError = False
     , stack = []
     , scopes = Scope.empty
     , environment = Environment.empty
@@ -428,7 +429,7 @@ vmWithEvalOnList =
             { emptyVm
                 | instructions =
                     [ PushValue (Type.List [ Type.Word "print", Type.Word "\"word" ])
-                    , Eval
+                    , EvalInContext Statement
                     ]
                         |> Array.fromList
             }
@@ -449,7 +450,7 @@ vmWithEvalOnWord =
                     [ PushValue (Type.Int 90)
                     , Command1 { name = "forward", f = C.forward }
                     , PushValue (Type.Word "home")
-                    , Eval
+                    , EvalInContext Statement
                     , PushValue (Type.Int 90)
                     , Command1 { name = "back", f = C.back }
                     ]