diff options
| -rw-r--r-- | src/Script/Expr.hs | 22 | ||||
| -rw-r--r-- | test/asset/run/callstack.et | 15 | ||||
| -rw-r--r-- | test/script/run.et | 22 |
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 |