summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Parser/Statement.hs13
-rw-r--r--src/Run.hs15
-rw-r--r--src/Script/Expr.hs3
-rw-r--r--src/Test.hs2
-rw-r--r--test/asset/run/callstack.et18
-rw-r--r--test/script/run.et22
6 files changed, 63 insertions, 10 deletions
diff --git a/src/Parser/Statement.hs b/src/Parser/Statement.hs
index 9b02770..0e6314b 100644
--- a/src/Parser/Statement.hs
+++ b/src/Parser/Statement.hs
@@ -169,6 +169,12 @@ instance ParamType SourceLine where
parseParam _ = mzero
showParamType _ = "<source line>"
+instance ParamType CallStack where
+ type ParamRep CallStack = Expr CallStack
+ parseParam _ = mzero
+ showParamType _ = "<call stack>"
+ paramExpr = id
+
instance ExprType a => ParamType (TypedVarName a) where
parseParam _ = newVarName
showParamType _ = "<variable>"
@@ -269,6 +275,9 @@ paramOrContext name = fromParamOrContext <$> param name
cmdLine :: CommandDef SourceLine
cmdLine = param ""
+callStack :: CommandDef CallStack
+callStack = param ""
+
newtype InnerBlock a = InnerBlock { fromInnerBlock :: [ a ] -> TestBlock () }
instance ExprType a => ParamType (InnerBlock a) where
@@ -320,6 +329,7 @@ command name (CommandDef types ctor) = do
iparams <- forM params $ \case
(_, SomeParam (p :: Proxy p) Nothing)
| Just (Refl :: p :~: SourceLine) <- eqT -> return $ SomeParam p $ Identity line
+ | Just (Refl :: p :~: CallStack) <- eqT -> return $ SomeParam p $ Identity $ Variable line callStackFqVarName
| SomeNewVariables (vars :: [ TypedVarName a ]) <- definedVariables
, Just (Refl :: p :~: InnerBlock a) <- eqT
@@ -424,7 +434,8 @@ testSpawn = command "spawn" $ Spawn
testExpect :: TestParser (Expr (TestBlock ()))
testExpect = command "expect" $ Expect
- <$> cmdLine
+ <$> callStack
+ <*> cmdLine
<*> (fromExprParam <$> paramOrContext "from")
<*> param ""
<*> (maybe 1 fromExprParam <$> param "timeout")
diff --git a/src/Run.hs b/src/Run.hs
index 436ce6b..45eec46 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -79,7 +79,7 @@ runTest out opts gdefs test = do
}
tstate = TestState
{ tsGlobals = gdefs
- , tsLocals = []
+ , tsLocals = [ ( callStackVarName, someConstValue (CallStack []) ) ]
, tsNodePacketLoss = M.empty
, tsDisconnectedUp = S.empty
, tsDisconnectedBridge = S.empty
@@ -203,8 +203,8 @@ runStep = \case
outProc OutputChildStdin p line
send p line
- Expect line p expr timeout captures inner -> do
- expect line p expr timeout captures $ runStep . inner
+ Expect stack line p expr timeout captures inner -> do
+ expect stack line p expr timeout captures $ runStep . inner
Flush p regex -> do
atomicallyTest $ flushProcessOutput p regex
@@ -319,8 +319,9 @@ exprFailed desc stack pname = do
outLine (OutputMatchFail stack) (Just prompt) $ desc <> " failed"
throwError Failed
-expect :: SourceLine -> Process -> Traced Regex -> Scientific -> [TypedVarName Text] -> ([ Text ] -> TestRun ()) -> TestRun ()
-expect sline p (Traced trace re) etimeout tvars inner = do
+expect :: CallStack -> SourceLine -> Process -> Traced Regex -> Scientific -> [ TypedVarName Text ] -> ([ Text ] -> TestRun ()) -> TestRun ()
+expect (CallStack cs) sline p (Traced trace re) etimeout tvars inner = do
+ let stack = CallStack (( sline, trace ) : cs)
timeout <- (etimeout *) <$> getCurrentTimeout
delay <- liftIO $ registerDelay $ ceiling $ 1000000 * timeout
mbmatch <- atomicallyTest $ (Nothing <$ (check =<< readTVar delay)) <|> do
@@ -335,13 +336,13 @@ expect sline p (Traced trace re) etimeout tvars inner = do
let vars = map (\(TypedVarName n) -> n) tvars
when (length vars /= length capture) $ do
- outProc (OutputMatchFail (CallStack [ ( sline, [] ) ])) p $ T.pack "mismatched number of capture variables on " `T.append` textSourceLine sline
+ outProc (OutputMatchFail stack) p $ T.pack "mismatched number of capture variables"
throwError Failed
outProc OutputMatch p line
inner capture
- Nothing -> exprFailed (T.pack "expect") (CallStack [ ( sline, trace ) ]) (Just $ procName p)
+ Nothing -> exprFailed (T.pack "expect") stack (Just $ procName p)
testStepGuard :: CallStack -> Bool -> TestRun ()
testStepGuard stack x = do
diff --git a/src/Script/Expr.hs b/src/Script/Expr.hs
index bd84a70..1a0f458 100644
--- a/src/Script/Expr.hs
+++ b/src/Script/Expr.hs
@@ -20,6 +20,7 @@ module Script.Expr (
Traced(..), EvalTrace, CallStack(..), VarNameSelectors, gatherVars,
AppAnnotation(..),
+ callStackVarName, callStackFqVarName,
module Script.Var,
@@ -179,7 +180,7 @@ eval = \case
gdefs <- askGlobalDefs
dict <- askDictionary
return $ FunctionType $ \stack _ ->
- runSimpleEval (eval expr) gdefs (( callStackVarName, someConstValue stack ) : dict)
+ runSimpleEval (eval expr) gdefs (( callStackVarName, someConstValue stack ) : filter ((callStackVarName /=) . fst) dict)
FunctionEval sline efun -> do
vars <- gatherVars efun
CallStack cs <- maybe (return $ CallStack []) (fromSomeVarValue (CallStack []) callStackFqVarName) =<< tryLookupVar callStackFqVarName
diff --git a/src/Test.hs b/src/Test.hs
index 5530081..2320d23 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -48,7 +48,7 @@ data TestStep a where
Spawn :: TypedVarName Process -> Either Network Node -> [ Text ] -> (Process -> TestStep a) -> TestStep a
SpawnShell :: Maybe (TypedVarName Process) -> Node -> ShellScript -> (Process -> TestStep a) -> TestStep a
Send :: Process -> Text -> TestStep ()
- Expect :: SourceLine -> Process -> Traced Regex -> Scientific -> [ TypedVarName Text ] -> ([ Text ] -> TestStep a) -> TestStep a
+ Expect :: CallStack -> SourceLine -> Process -> Traced Regex -> Scientific -> [ TypedVarName Text ] -> ([ Text ] -> TestStep a) -> TestStep a
Flush :: Process -> Maybe Regex -> TestStep ()
Guard :: CallStack -> Bool -> TestStep ()
DisconnectNode :: Node -> TestStep a -> TestStep a
diff --git a/test/asset/run/callstack.et b/test/asset/run/callstack.et
index 9e8123b..36eb401 100644
--- a/test/asset/run/callstack.et
+++ b/test/asset/run/callstack.et
@@ -21,3 +21,21 @@ def gg (x):
test CG:
let z = 3
gg (z)
+
+def fe on p:
+ let x = 1
+ expect /$x/ from p timeout 0.0
+
+test BE:
+ spawn as p
+ fe on p
+
+def ge (x) on p:
+ guard (x /= 0)
+ let y = 2
+ expect /$x $y/ from p timeout 0.0
+
+test CE:
+ spawn as p
+ let z = 3
+ ge (z) on p
diff --git a/test/script/run.et b/test/script/run.et
index dfccab5..b2d3ca9 100644
--- a/test/script/run.et
+++ b/test/script/run.et
@@ -151,3 +151,25 @@ test CallStack:
expect /(run-.*)/ capture done
guard (done == "run-failed")
flush
+
+ send "run BE"
+ expect /match-fail expect failed/
+ expect /match-fail-line .*\/callstack.et:27:5: .*/
+ expect /match-fail-var x 1/
+ expect /match-fail-line .*\/callstack.et:31:5: .*/
+ local:
+ expect /(run-.*)/ capture done
+ guard (done == "run-failed")
+ flush
+
+ send "run CE"
+ expect /match-fail expect failed/
+ expect /match-fail-line .*\/callstack.et:36:5: .*/
+ expect /match-fail-var x 3/
+ expect /match-fail-var y 2/
+ expect /match-fail-line .*\/callstack.et:41:5: .*/
+ expect /match-fail-var z 3/
+ local:
+ expect /(run-.*)/ capture done
+ guard (done == "run-failed")
+ flush
generated by cgit v1.2.3 (git 2.25.1) at 2026-01-11 23:24:42 +0000