summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2022-06-07 21:35:48 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2022-06-07 21:35:48 +0200
commit62251c102c57d4c12da6923dc0ea5747cfb3ef0c (patch)
tree07abceaa52f9bec0e48d9d3eac9b85175753433c
parent202fd8ba096ff5a80102cbec2922eef94061458b (diff)
Source line info for test steps from parsing
-rw-r--r--src/Main.hs15
-rw-r--r--src/Parser.hs32
-rw-r--r--src/Test.hs5
3 files changed, 33 insertions, 19 deletions
diff --git a/src/Main.hs b/src/Main.hs
index e062dee..5e1e7b2 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -267,8 +267,8 @@ tryMatch re (x:xs) | Right (Just (_, _, _, capture)) <- regexec re x = Just ((x,
| otherwise = fmap (x:) <$> tryMatch re xs
tryMatch _ [] = Nothing
-expect :: Process -> Regex -> Text -> [VarName] -> TestRun ()
-expect p re pat vars = do
+expect :: SourceLine -> Process -> Regex -> [VarName] -> TestRun ()
+expect (SourceLine sline) p re vars = do
timeout <- asks $ optTimeout . teOptions
delay <- liftIO $ registerDelay $ ceiling $ 1000000 * timeout
mbmatch <- atomicallyTest $ (Nothing <$ (check =<< readTVar delay)) <|> do
@@ -281,19 +281,19 @@ expect p re pat vars = do
case mbmatch of
Just (line, capture) -> do
when (length vars /= length capture) $ do
- outLine OutputMatchFail (Just $ procName p) $ T.pack "mismatched number of capture variables /" `T.append` pat `T.append` T.pack "/"
+ outLine OutputMatchFail (Just $ procName p) $ T.pack "mismatched number of capture variables on " `T.append` sline
throwError ()
forM_ vars $ \name -> do
cur <- gets (lookup name . tsVars)
when (isJust cur) $ do
- outLine OutputMatchFail (Just $ procName p) $ T.pack "variable already exists: '" `T.append` textVarName name `T.append` T.pack "'"
+ outLine OutputMatchFail (Just $ procName p) $ T.pack "variable '" `T.append` textVarName name `T.append` T.pack "' already exists on " `T.append` sline
throwError ()
modify $ \s -> s { tsVars = zip vars capture ++ tsVars s }
outLine OutputMatch (Just $ procName p) line
Nothing -> do
- outLine OutputMatchFail (Just $ procName p) $ T.pack "expect failed /" `T.append` pat `T.append` T.pack "/"
+ outLine OutputMatchFail (Just $ procName p) $ T.pack "expect failed on " `T.append` sline
throwError ()
allM :: Monad m => [a] -> (a -> m Bool) -> m Bool
@@ -335,11 +335,10 @@ runTest out opts test = do
line <- eval expr
send p line
- Expect pname expr@(Regex ps) captures -> do
+ Expect line pname expr captures -> do
p <- getProcess net pname
regex <- eval expr
- pat <- eval (Concat ps)
- expect p regex pat captures
+ expect line p regex captures
Wait -> do
outPrompt $ T.pack "Waiting..."
diff --git a/src/Parser.hs b/src/Parser.hs
index 6131a78..0608ccd 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -152,16 +152,28 @@ instance (GInit f, GInit h) => GInit (f :*: h) where ginit = ginit :*: ginit
data Param a = forall b. Param String (Lens' a (Maybe b)) (TestParser b)
-command :: (Generic b, GInit (Rep b)) => String -> [Param b] -> (b -> TestParser a) -> TestParser [a]
+getSourceLine :: TestParser SourceLine
+getSourceLine = do
+ pstate <- statePosState <$> getParserState
+ return $ SourceLine $ T.concat
+ [ T.pack $ sourcePosPretty $ pstateSourcePos pstate
+ , T.pack ": "
+ , TL.toStrict $ TL.takeWhile (/='\n') $ pstateInput pstate
+ ]
+
+command :: (Generic b, GInit (Rep b)) => String -> [Param b] -> (SourceLine -> b -> TestParser a) -> TestParser [a]
command name params fin = do
+ origline <- getSourceLine
wsymbol name
- let blockHelper prev cur = L.indentBlock scn $ helper prev cur
- helper prev cur = choice $ concat
+ let blockHelper line prev cur = L.indentBlock scn $ helper line prev cur
+ helper line prev cur = choice $ concat
[[ do void $ eol
- L.IndentNone . (:[]) <$> fin cur
+ L.IndentNone . (:[]) <$> fin line cur
]
,[ do void $ lexeme (char ':')
- return $ L.IndentSome Nothing (return . concat) (blockHelper prev cur)
+ return $ L.IndentSome Nothing (return . concat) $ do
+ line' <- getSourceLine
+ blockHelper line' prev cur
]
, flip map params $ \(Param sym l p) -> do
x <- if null sym
@@ -175,10 +187,10 @@ command name params fin = do
when (any (== sym) prev) $ do
fail $ "multiple '" ++ sym ++ "' parameters"
p
- helper (sym:prev) (l .~ Just x $ cur)
+ helper line (sym:prev) (l .~ Just x $ cur)
]
- blockHelper [] (G.to ginit)
+ blockHelper origline [] (G.to ginit)
data SpawnBuilder = SpawnBuilder
@@ -193,7 +205,7 @@ testSpawn :: TestParser [TestStep]
testSpawn = command "spawn"
[ Param "on" spawnBuilderNode nodeName
, Param "as" spawnBuilderProc procName
- ] $ \b -> Spawn
+ ] $ \_ b -> Spawn
<$> (maybe (fail "missing 'as' <proc>") return $ b ^. spawnBuilderProc)
<*> (maybe (fail "missing 'on' <node>") return $ b ^. spawnBuilderNode)
@@ -210,7 +222,7 @@ testSend :: TestParser [TestStep]
testSend = command "send"
[ Param "to" sendBuilderProc procName
, Param "" sendBuilderLine quotedString
- ] $ \b -> Send
+ ] $ \_ b -> Send
<$> (maybe (fail "missing 'to' <proc>") return $ b ^. sendBuilderProc)
<*> (maybe (fail "missing line to send") return $ b ^. sendBuilderLine)
@@ -229,7 +241,7 @@ testExpect = command "expect"
[ Param "from" expectBuilderProc procName
, Param "" expectBuilderRegex regex
, Param "capture" expectBuilderCaptures (listOf $ VarName . (:[]) <$> identifier)
- ] $ \b -> Expect
+ ] $ \s b -> Expect s
<$> (maybe (fail "missing 'from' <proc>") return $ b ^. expectBuilderProc)
<*> (maybe (fail "missing regex to match") return $ b ^. expectBuilderRegex)
<*> (maybe (return []) return $ b ^. expectBuilderCaptures)
diff --git a/src/Test.hs b/src/Test.hs
index ab97bc7..404d965 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -1,6 +1,7 @@
module Test (
Test(..),
TestStep(..),
+ SourceLine(..),
ProcName(..), textProcName, unpackProcName,
NodeName(..), textNodeName, unpackNodeName,
@@ -29,9 +30,11 @@ data Test = Test
data TestStep = Spawn ProcName NodeName
| Send ProcName (Expr Text)
- | Expect ProcName (Expr Regex) [VarName]
+ | Expect SourceLine ProcName (Expr Regex) [VarName]
| Wait
+newtype SourceLine = SourceLine Text
+
newtype NodeName = NodeName Text
deriving (Eq, Ord)