From 56878ad193071539a1fd83298c4509fe21b880fd Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Fri, 29 Nov 2024 20:52:20 +0100
Subject: Special "builtin" value for SourceLine
---
src/Run.hs | 22 +++++++++++-----------
src/Test.hs | 10 ++++++++--
src/Test/Builtins.hs | 2 +-
3 files changed, 20 insertions(+), 14 deletions(-)
diff --git a/src/Run.hs b/src/Run.hs
index f94c47d..fd02af3 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -111,18 +111,18 @@ runTest out opts test variables = do
evalBlock :: TestBlock -> TestRun ()
evalBlock (TestBlock steps) = forM_ steps $ \case
- Let (SourceLine sline) (TypedVarName name) expr inner -> do
+ Let sline (TypedVarName name) expr inner -> do
cur <- asks (lookup name . tsVars . snd)
when (isJust cur) $ do
- outLine OutputError Nothing $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline
+ outLine OutputError Nothing $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` textSourceLine sline
throwError Failed
value <- eval expr
withVar name value $ evalBlock =<< eval inner
- For (SourceLine sline) (TypedVarName name) expr inner -> do
+ For sline (TypedVarName name) expr inner -> do
cur <- asks (lookup name . tsVars . snd)
when (isJust cur) $ do
- outLine OutputError Nothing $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline
+ outLine OutputError Nothing $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` textSourceLine sline
throwError Failed
value <- eval expr
forM_ value $ \i -> do
@@ -263,18 +263,18 @@ tryMatch re (x:xs) | Right (Just (_, _, _, capture)) <- regexMatch re x = Just (
tryMatch _ [] = Nothing
exprFailed :: Text -> SourceLine -> Maybe ProcName -> EvalTrace -> TestRun ()
-exprFailed desc (SourceLine sline) pname exprVars = do
+exprFailed desc sline pname exprVars = do
let prompt = maybe T.empty textProcName pname
- outLine OutputMatchFail (Just prompt) $ T.concat [desc, T.pack " failed on ", sline]
+ outLine OutputMatchFail (Just prompt) $ T.concat [desc, T.pack " failed on ", textSourceLine sline]
forM_ exprVars $ \((name, sel), value) ->
outLine OutputMatchFail (Just prompt) $ T.concat
[ " ", textVarName name, T.concat (map ("."<>) sel)
- , " = ", textSomeVarValue (SourceLine sline) value
+ , " = ", textSomeVarValue sline value
]
throwError Failed
expect :: SourceLine -> Process -> Expr Regex -> [TypedVarName Text] -> TestRun () -> TestRun ()
-expect (SourceLine sline) p expr tvars inner = do
+expect sline p expr tvars inner = do
re <- eval expr
timeout <- asks $ optTimeout . teOptions . fst
delay <- liftIO $ registerDelay $ ceiling $ 1000000 * timeout
@@ -290,19 +290,19 @@ expect (SourceLine sline) p expr tvars inner = do
let vars = map (\(TypedVarName n) -> n) tvars
when (length vars /= length capture) $ do
- outProc OutputMatchFail p $ T.pack "mismatched number of capture variables on " `T.append` sline
+ outProc OutputMatchFail p $ T.pack "mismatched number of capture variables on " `T.append` textSourceLine sline
throwError Failed
forM_ vars $ \name -> do
cur <- asks (lookup name . tsVars . snd)
when (isJust cur) $ do
- outProc OutputError p $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline
+ outProc OutputError p $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` textSourceLine sline
throwError Failed
outProc OutputMatch p line
local (fmap $ \s -> s { tsVars = zip vars (map someConstValue capture) ++ tsVars s }) inner
- Nothing -> exprFailed (T.pack "expect") (SourceLine sline) (Just $ procName p) =<< gatherVars expr
+ Nothing -> exprFailed (T.pack "expect") sline (Just $ procName p) =<< gatherVars expr
flush :: Process -> Maybe Regex -> TestRun ()
flush p mbre = do
diff --git a/src/Test.hs b/src/Test.hs
index 836489c..d0f1e45 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -3,7 +3,7 @@ module Test (
Test(..),
TestStep(..),
TestBlock(..),
- SourceLine(..),
+ SourceLine(..), textSourceLine,
MonadEval(..),
VarName(..), TypedVarName(..), textVarName, unpackVarName,
@@ -79,7 +79,13 @@ data TestStep
| PacketLoss Scientific Node TestBlock
| Wait
-newtype SourceLine = SourceLine Text
+data SourceLine
+ = SourceLine Text
+ | SourceLineBuiltin
+
+textSourceLine :: SourceLine -> Text
+textSourceLine (SourceLine text) = text
+textSourceLine SourceLineBuiltin = "<builtin>"
class MonadFail m => MonadEval m where
diff --git a/src/Test/Builtins.hs b/src/Test/Builtins.hs
index a36505a..a676a35 100644
--- a/src/Test/Builtins.hs
+++ b/src/Test/Builtins.hs
@@ -22,7 +22,7 @@ getArg args = fromMaybe (error "parameter mismatch") . getArgMb args
getArgMb :: ExprType a => FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> Maybe a
getArgMb (FunctionArguments args) kw = do
- fromSomeVarValue (SourceLine "") (VarName "") =<< M.lookup kw args
+ fromSomeVarValue SourceLineBuiltin (VarName "") =<< M.lookup kw args
getArgVars :: FunctionArguments SomeVarValue -> Maybe ArgumentKeyword -> [ (( VarName, [ Text ] ), SomeVarValue ) ]
getArgVars (FunctionArguments args) kw = do
--
cgit v1.2.3