diff options
| -rw-r--r-- | erebos-tester.cabal | 3 | ||||
| -rw-r--r-- | src/Main.hs | 11 | ||||
| -rw-r--r-- | src/Test.hs | 13 | ||||
| -rw-r--r-- | src/Util.hs | 6 |
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 |