summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2022-07-24 20:54:56 +0200
committerRoman Smrž <roman.smrz@seznam.cz>2022-07-24 20:54:56 +0200
commitc90a5abf0eeded8ff8a4aaee5ef35674236ed197 (patch)
treea00c45f0915aa916ccf50872dd32ca5ef0b6fc4f
parent7cefecfc3d491ae668a32cbc89668a055c0268de (diff)
Print relevant variable values after expect failure
-rw-r--r--erebos-tester.cabal3
-rw-r--r--src/Main.hs11
-rw-r--r--src/Test.hs13
-rw-r--r--src/Util.hs6
4 files changed, 28 insertions, 5 deletions
diff --git a/erebos-tester.cabal b/erebos-tester.cabal
index 8b66f13..2ed105a 100644
--- a/erebos-tester.cabal
+++ b/erebos-tester.cabal
@@ -38,6 +38,7 @@ executable erebos-tester-core
Parser
Process
Test
+ Util
other-extensions: TemplateHaskell
default-extensions: DeriveGeneric
ExistentialQuantification
@@ -49,6 +50,8 @@ executable erebos-tester-core
LambdaCase
MultiParamTypeClasses
RankNTypes
+ ScopedTypeVariables
+ TupleSections
TypeFamilies
TypeOperators
build-depends: base >=4.13 && <5,
diff --git a/src/Main.hs b/src/Main.hs
index efab611..dc5ffd4 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -267,8 +267,9 @@ tryMatch re (x:xs) | Right (Just (_, _, _, capture)) <- regexec re x = Just ((x,
| otherwise = fmap (x:) <$> tryMatch re xs
tryMatch _ [] = Nothing
-expect :: SourceLine -> Process -> Regex -> [VarName] -> TestRun ()
-expect (SourceLine sline) p re vars = do
+expect :: SourceLine -> Process -> Expr Regex -> [VarName] -> TestRun ()
+expect (SourceLine sline) p expr vars = do
+ re <- eval expr
timeout <- asks $ optTimeout . teOptions
delay <- liftIO $ registerDelay $ ceiling $ 1000000 * timeout
mbmatch <- atomicallyTest $ (Nothing <$ (check =<< readTVar delay)) <|> do
@@ -294,6 +295,9 @@ expect (SourceLine sline) p re vars = do
outLine OutputMatch (Just $ procName p) line
Nothing -> do
outLine OutputMatchFail (Just $ procName p) $ T.pack "expect failed on " `T.append` sline
+ exprVars <- gatherVars expr
+ forM_ exprVars $ \(name, value) ->
+ outLine OutputMatchFail (Just $ procName p) $ T.concat [T.pack " ", textVarName name, T.pack " = ", T.pack (show value)]
throwError ()
testStepGuard :: SourceLine -> Expr Bool -> TestRun ()
@@ -344,8 +348,7 @@ runTest out opts test = do
Expect line pname expr captures -> do
p <- getProcess net pname
- regex <- eval expr
- expect line p regex captures
+ expect line p expr captures
Guard line expr -> do
testStepGuard line expr
diff --git a/src/Test.hs b/src/Test.hs
index 25f3c09..e7e1255 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -8,7 +8,7 @@ module Test (
MonadEval(..),
VarName(..), textVarName, unpackVarName,
- Expr(..), eval,
+ Expr(..), eval, gatherVars,
Regex,
) where
@@ -23,6 +23,7 @@ import Text.Regex.TDFA
import Text.Regex.TDFA.Text
import Process
+import Util
data Test = Test
{ testName :: Text
@@ -84,3 +85,13 @@ eval (Regex xs) = do
Left err -> fail err
Right re -> return re
eval (BinOp f x y) = f <$> eval x <*> eval y
+
+gatherVars :: forall a m. MonadEval m => Expr a -> m [(VarName, Text)]
+gatherVars = fmap (uniq . sort) . helper
+ where
+ helper :: forall b. Expr b -> m [(VarName, Text)]
+ helper (StringVar var) = (:[]) . (var,) <$> lookupStringVar var
+ helper (StringLit _) = return []
+ helper (Concat es) = concat <$> mapM helper es
+ helper (Regex es) = concat <$> mapM helper es
+ helper (BinOp _ e f) = (++) <$> helper e <*> helper f
diff --git a/src/Util.hs b/src/Util.hs
new file mode 100644
index 0000000..99d51f6
--- /dev/null
+++ b/src/Util.hs
@@ -0,0 +1,6 @@
+module Util where
+
+uniq :: Eq a => [a] -> [a]
+uniq (x:y:xs) | x == y = uniq (x:xs)
+ | otherwise = x : uniq (y:xs)
+uniq xs = xs