Pass call stack info through function application

Changelog: Show call stack in error messages

3 files changed, 55 insertions, 4 deletions

diff --git a/src/Script/Expr.hs b/src/Script/Expr.hs
index 4e99a26..7a446c5 100644
--- a/src/Script/Expr.hs
+++ b/src/Script/Expr.hs
@@ -146,6 +146,12 @@ instance MonadEval SimpleEval where
     askDictionary = SimpleEval (asks snd)
     withDictionary f (SimpleEval inner) = SimpleEval (local (fmap f) inner)
 
+callStackVarName :: VarName
+callStackVarName = VarName "$STACK"
+
+callStackFqVarName :: FqVarName
+callStackFqVarName = LocalVarName callStackVarName
+
 eval :: forall m a. MonadEval m => Expr a -> m a
 eval = \case
     Let _ (TypedVarName name) valExpr expr -> do
@@ -166,12 +172,16 @@ eval = \case
         args <- mapM evalSome eargs
         return $ FunctionType $ \stack args' -> fun stack (args <> args')
     FunctionAbstraction expr -> do
-        val <- eval expr
-        return $ FunctionType $ const $ const val
+        gdefs <- askGlobalDefs
+        dict <- askDictionary
+        return $ FunctionType $ \stack _ ->
+            runSimpleEval (eval expr) gdefs (( callStackVarName, someConstValue stack ) : dict)
     FunctionEval sline efun -> do
-        FunctionType fun <- eval efun
         vars <- gatherVars efun
-        return $ fun (CallStack [ ( sline, vars ) ]) mempty
+        CallStack cs <- maybe (return $ CallStack []) (fromSomeVarValue (CallStack []) callStackFqVarName) =<< tryLookupVar callStackFqVarName
+        let cs' = CallStack (( sline, vars ) : cs)
+        FunctionType fun <- withVar callStackVarName cs' $ eval efun
+        return $ fun cs' mempty
     LambdaAbstraction (TypedVarName name) expr -> do
         gdefs <- askGlobalDefs
         dict <- askDictionary
@@ -374,6 +384,10 @@ type VarNameSelectors = ( FqVarName, [ Text ] )
 type EvalTrace = [ ( VarNameSelectors, SomeVarValue ) ]
 newtype CallStack = CallStack [ ( SourceLine, EvalTrace ) ]
 
+instance ExprType CallStack where
+    textExprType _ = T.pack "callstack"
+    textExprValue _ = T.pack "<callstack>"
+
 gatherVars :: forall a m. MonadEval m => Expr a -> m EvalTrace
 gatherVars = fmap (uniqOn fst . sortOn fst) . helper
   where
diff --git a/test/asset/run/callstack.et b/test/asset/run/callstack.et
index f500fb6..9e8123b 100644
--- a/test/asset/run/callstack.et
+++ b/test/asset/run/callstack.et
@@ -6,3 +6,18 @@ test AE:
     spawn as p
     let x = 2
     expect /$x/ from p timeout 0.0
+
+def fg:
+    let x = 1
+    guard (x == 0)
+
+test BG:
+    fg
+
+def gg (x):
+    let y = 2
+    guard (x == y)
+
+test CG:
+    let z = 3
+    gg (z)
diff --git a/test/script/run.et b/test/script/run.et
index f7e4f69..392c44e 100644
--- a/test/script/run.et
+++ b/test/script/run.et
@@ -128,3 +128,25 @@ test CallStack:
             expect /(run-.*)/ capture done
             guard (done == "run-failed")
         flush
+
+        send "run BG"
+        expect /match-fail guard failed/
+        expect /match-fail-line .*\/callstack.et:12:5: .*/
+        expect /match-fail-var x 1/
+        expect /match-fail-line .*\/callstack.et:15:5: .*/
+        local:
+            expect /(run-.*)/ capture done
+            guard (done == "run-failed")
+        flush
+
+        send "run CG"
+        expect /match-fail guard failed/
+        expect /match-fail-line .*\/callstack.et:19:5: .*/
+        expect /match-fail-var x 3/
+        expect /match-fail-var y 2/
+        expect /match-fail-line .*\/callstack.et:23:5: .*/
+        expect /match-fail-var z 3/
+        local:
+            expect /(run-.*)/ capture done
+            guard (done == "run-failed")
+        flush