tasty 0.12.0.1 → 1.0
raw patch · 14 files changed
+946/−178 lines, 14 filesdep +timedep −regex-tdfadep ~mtldep ~optparse-applicative
Dependencies added: time
Dependencies removed: regex-tdfa
Dependency ranges changed: mtl, optparse-applicative
Files
- CHANGELOG.md +8/−0
- README.md +305/−21
- Test/Tasty.hs +25/−0
- Test/Tasty/Core.hs +8/−4
- Test/Tasty/Ingredients/ConsoleReporter.hs +0/−2
- Test/Tasty/Ingredients/ListTests.hs +0/−3
- Test/Tasty/Options/Core.hs +0/−4
- Test/Tasty/Patterns.hs +28/−139
- Test/Tasty/Patterns/Eval.hs +157/−0
- Test/Tasty/Patterns/Expr.hs +173/−0
- Test/Tasty/Patterns/Parser.hs +182/−0
- Test/Tasty/Patterns/Types.hs +30/−0
- Test/Tasty/Run.hs +12/−1
- tasty.cabal +18/−4
CHANGELOG.md view
@@ -1,6 +1,14 @@ Changes ======= +Version 1.0+-----------++* New pattern language (see the README and/or the [blog post][awk])+* Make the `clock` dependency optional++[awk]: https://ro-che.info/articles/2018-01-08-tasty-new-patterns+ Version 0.12.0.1 ----------------
README.md view
@@ -245,30 +245,300 @@ ### Patterns -It is possible to restrict the set of executed tests using the `--pattern`-option. The syntax of patterns is the same as for test-framework, namely:+It is possible to restrict the set of executed tests using the `-p/--pattern`+option. -- An optional prefixed bang `!` negates the pattern.-- If the pattern ends with a slash, it is removed for the purpose of- the following description, but it would only find a match with a- test group. In other words, `foo/` will match a group called `foo`- and any tests underneath it, but will not match a regular test- `foo`.-- If the pattern does not contain a slash `/`, the framework checks- for a match against any single component of the path.-- Otherwise, the pattern is treated as a glob, where:- - The wildcard `*` matches anything within a single path component- (i.e. `foo` but not `foo/bar`).- - Two wildcards `**` matches anything (i.e. `foo` and `foo/bar`).- - Anything else matches exactly that text in the path (i.e. `foo`- would only match a component of the test path called `foo` (or a- substring of that form).+Tasty patterns are very powerful, but if you just want to quickly run tests containing `foo`+somewhere in their name or in the name of an enclosing test group, you can just+pass `-p foo`. If you need more power, or if that didn't work as expected, read+on. -For example, `group/*1` matches `group/test1` but not-`group/subgroup/test1`, whereas both examples would be matched by-`group/**1`. A leading slash matches the beginning of the test path; for-example, `/test*` matches `test1` but not `group/test1`.+A pattern is an [awk expression][awk]. When the expression is evaluated, the field `$1`+is set to the outermost test group name, `$2` is set to the next test group+name, and so on up to `$NF`, which is set to the test's own name. The field `$0`+is set to all other fields concatenated using `/` as a separator. +[awk]: http://pubs.opengroup.org/onlinepubs/9699919799/utilities/awk.html#tag_20_06_13_02++As an example, consider a test inside two test groups:++```+ testGroup "One" [ testGroup "Two" [ testCase "Three" _ ] ]+```++When a pattern is evaluated for the above test case, the available fields and variables are:++ $0 = "One/Two/Three"+ $1 = "One"+ $2 = "Two"+ $3 = "Three"+ NF = 3++Here are some examples of awk expressions accepted as patterns:++* `$2 == "Two"` — select the subgroup `Two`+* `$2 == "Two" && $3 == "Three"` — select the test or subgroup named `Three` in the subgroup named `Two`+* `$2 == "Two" || $2 == "Twenty-two"` — select two subgroups+* `$0 !~ /skip/` or `! /skip/` — select tests whose full names (including group names) do not contain the word `skip`+* `$NF !~ /skip/` — select tests whose own names (but not group names) do not contain the word `skip`+* `$(NF-1) ~ /QuickCheck/` — select tests whose immediate parent group name+ contains `QuickCheck`++As an extension to the awk expression language, if a pattern `pat` contains only+letters, digits, and characters from the set `[_/ ]`, it is treated like `/pat/`+(and therefore matched against `$0`). This is so that we can use `-p foo` as+a shortcut for `-p /foo/`.++The only deviation from awk that you will likely notice is that Tasty+does not implement regular expression matching.+Instead, `$1 ~ /foo/` means that the string `foo` occurs somewhere in `$1`,+case-sensitively. We want to avoid a heavy dependency of `regex-tdfa` or+similar libraries; however, if there is demand, regular expression support could+be added under a cabal flag.++The following operators are supported (in the order of decreasing precedence):++<center>+<table>+<tr>+<th>+<p><b>Syntax</b></p>+</th>+<th>+<p><b>Name</b></p>+</th>+<th>+<p><b>Type of Result</b></p>+</th>+<th>+<p><b>Associativity</b></p>+</th>+</tr>++<tr>+<td>+<p><code>(expr)</code></p>+</td>+<td>+<p>Grouping</p>+</td>+<td>+<p>Type of <code>expr</code></p>+</td>+<td>+<p>N/A</p>+</td>+</tr>++<tr>+<td>+<p><code>$expr</code></p>+</td>+<td>+<p>Field reference</p>+</td>+<td>+<p>String</p>+</td>+<td>+<p>N/A</p>+</td>+</tr>++<tr>+<td>+<p><code>!expr</code></p>+<p><code>-expr</code></p>+</td>+<td>+<p>Logical not</p>+<p>Unary minus</p>+</td>+<td>+<p>Numeric</p>+<p>Numeric</p>+</td>+<td>+<p>N/A</p>+<p>N/A</p>+</td>+</tr>++<tr>+<td>+<p><code>expr + expr</code></p>+<p><code>expr - expr</code></p>+</td>+<td>+<p>Addition</p>+<p>Subtraction</p>+</td>+<td>+<p>Numeric</p>+<p>Numeric</p>+</td>+<td>+<p>Left</p>+<p>Left</p>+</td>+</tr>+++<tr>+<td>+<p><code>expr expr</code></p>+</td>+<td>+<p>String concatenation</p>+</td>+<td>+<p>String</p>+</td>+<td>+<p>Right</p>+</td>+</tr>++<tr>+<td>+<p><code>expr < expr</code></p>+<p><code>expr <= expr</code></p>+<p><code>expr != expr</code></p>+<p><code>expr == expr</code></p>+<p><code>expr > expr</code></p>+<p><code>expr >= expr</code></p>+</td>+<td>+<p>Less than</p>+<p>Less than or equal to</p>+<p>Not equal to</p>+<p>Equal to</p>+<p>Greater than</p>+<p>Greater than or equal to</p>+</td>+<td>+<p>Numeric</p>+<p>Numeric</p>+<p>Numeric</p>+<p>Numeric</p>+<p>Numeric</p>+<p>Numeric</p>+</td>+<td>+<p>None</p>+<p>None</p>+<p>None</p>+<p>None</p>+<p>None</p>+<p>None</p>+</td>+</tr>+++<tr>+<td>+<p><code>expr ~ pat</code></p>+<p><code>expr !~ pat</code></p>+<p>(<code>pat</code> must be a literal, not an expression, e.g. <code>/foo/</code>)</p>+</td>+<td>+<p>Substring match</p>+<p>No substring match</p>+</td>+<td>+<p>Numeric</p>+<p>Numeric</p>+</td>+<td>+<p>None</p>+<p>None</p>+</td>+</tr>++<tr>+<td>+<p><code>expr && expr</code></p>+</td>+<td>+<p>Logical AND</p>+</td>+<td>+<p>Numeric</p>+</td>+<td>+<p>Left</p>+</td>+</tr>++<tr>+<td>+<p><code>expr || expr</code></p>+</td>+<td>+<p>Logical OR</p>+</td>+<td>+<p>Numeric</p>+</td>+<td>+<p>Left</p>+</td>+</tr>++<tr>+<td>+<p><code>expr1 ? expr2 : expr3</code></p>+</td>+<td>+<p>Conditional expression</p>+</td>+<td>+<p>Type of selected<br><code>expr2</code> or <code>expr3</code></p>+</td>+<td>+<p>Right</p>+</td>+</tr>++</table>+</center>++The following built-in functions are supported:++```+substr(s, m[, n])+```+Return the at most `n`-character substring of `s` that begins at+position `m`, numbering from 1. If `n` is omitted, or if `n` specifies+more characters than are left in the string, the length of the substring+will be limited by the length of the string `s`.++```+tolower(s)+```++Convert the string `s` to lower case.++```+toupper(s)+```++Convert the string `s` to upper case.++```+match(s, pat)+```++Return the position, in characters, numbering from 1, in string `s` where the+pattern `pat` occurs, or zero if it does not occur at all.+`pat` must be a literal, not an expression, e.g. `/foo/`.++```+length([s])+```++Return the length, in characters, of its argument taken as a string, or of the whole record, `$0`, if there is no argument.+ ### Running tests in parallel In order to run tests in parallel, you have to do the following:@@ -392,6 +662,20 @@ Currently, your only option is to make all tests execute sequentially by setting the number of tasty threads to 1 ([example](#num_threads_example)). See [#48](https://github.com/feuerbach/tasty/issues/48) for the discussion.++2. When my tests write to stdout/stderr, the output is garbled. Why is that and+ what do I do?++ It is not recommended that you print anything to the console when using the+ console test reporter (which is the default one).+ See [#103](https://github.com/feuerbach/tasty/issues/103) for the+ discussion.++ Some ideas on how to work around this:++ * Use [testCaseSteps](https://hackage.haskell.org/package/tasty-hunit/docs/Test-Tasty-HUnit.html#v:testCaseSteps) (for tasty-hunit only).+ * Use a test reporter that does not print to the console (like tasty-ant-xml).+ * Write your output to files instead. ## Press
Test/Tasty.hs view
@@ -1,5 +1,30 @@ -- | This module defines the main data types and functions needed to use -- Tasty.+--+-- To create a test suite, you also need one or more test providers, such+-- as+-- <https://hackage.haskell.org/package/tasty-hunit tasty-hunit> or+-- <https://hackage.haskell.org/package/tasty-quickcheck tasty-quickcheck>.+--+-- A simple example (using tasty-hunit) is+--+-- >import Test.Tasty+-- >import Test.Tasty.HUnit+-- >+-- >main = defaultMain tests+-- >+-- >tests :: TestTree+-- >tests = testGroup "Tests"+-- > [ testCase "2+2=4" $+-- > 2+2 @?= 4+-- > , testCase "7 is even" $+-- > assertBool "Oops, 7 is odd" (even 7)+-- > ]+--+-- Take a look at the <https://github.com/feuerbach/tasty#readme README>:+-- it contains a comprehensive list of test providers, a bigger example,+-- and a lot of other information.+ module Test.Tasty ( -- * Organizing tests
Test/Tasty/Core.hs view
@@ -8,6 +8,7 @@ import Test.Tasty.Options import Test.Tasty.Patterns import Data.Foldable+import qualified Data.Sequence as Seq import Data.Monoid import Data.Typeable import qualified Data.Map as Map@@ -107,7 +108,10 @@ run :: OptionSet -- ^ options -> t -- ^ the test to run- -> (Progress -> IO ()) -- ^ a callback to report progress+ -> (Progress -> IO ()) -- ^ a callback to report progress.+ -- Note: the callback is a no-op at the moment+ -- and there are no plans to use it;+ -- feel free to ignore this argument for now. -> IO Result -- | The list of options that affect execution of tests of this type@@ -225,16 +229,16 @@ -> b foldTestTree (TreeFold fTest fGroup fResource) opts0 tree0 = let pat = lookupOption opts0- in go pat [] opts0 tree0+ in go pat mempty opts0 tree0 where go pat path opts tree1 = case tree1 of SingleTest name test- | testPatternMatches pat (path ++ [name])+ | testPatternMatches pat (path Seq.|> name) -> fTest opts name test | otherwise -> mempty TestGroup name trees ->- fGroup name $ foldMap (go pat (path ++ [name]) opts) trees+ fGroup name $ foldMap (go pat (path Seq.|> name) opts) trees PlusTestOptions f tree -> go pat path (f opts) tree WithResource res0 tree -> fResource res0 $ \res -> go pat path opts (tree res) AskOptions f -> go pat path opts (f opts)
Test/Tasty/Ingredients/ConsoleReporter.hs view
@@ -45,9 +45,7 @@ import System.Console.ANSI #if !MIN_VERSION_base(4,8,0) import Data.Proxy-import Data.Tagged import Data.Foldable hiding (concatMap,elem,sequence_)-import Control.Applicative #endif #if MIN_VERSION_base(4,9,0) import Data.Semigroup (Semigroup)
Test/Tasty/Ingredients/ListTests.hs view
@@ -9,9 +9,6 @@ import Data.Proxy import Data.Typeable import Options.Applicative-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid-#endif import Test.Tasty.Core import Test.Tasty.Options
Test/Tasty/Options/Core.hs view
@@ -12,10 +12,6 @@ import Control.Monad (mfilter) import Data.Proxy import Data.Typeable-#if !MIN_VERSION_base(4,8,0)-import Data.Tagged-import Data.Monoid-#endif import Data.Fixed import Options.Applicative hiding (str) import GHC.Conc
Test/Tasty/Patterns.hs view
@@ -1,32 +1,4 @@--- This code is largely borrowed from test-framework-{--Copyright (c) 2008, Maximilian Bolingbroke-All rights reserved.--Redistribution and use in source and binary forms, with or without modification, are permitted-provided that the following conditions are met:-- * Redistributions of source code must retain the above copyright notice, this list of- conditions and the following disclaimer.- * Redistributions in binary form must reproduce the above copyright notice, this list of- conditions and the following disclaimer in the documentation and/or other materials- provided with the distribution.- * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to- endorse or promote products derived from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR-IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND-FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR-CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER-IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT-OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.--}- -- | Test patterns------ (Most of the code borrowed from the test-framework) {-# LANGUAGE CPP, DeriveDataTypeable #-} @@ -38,126 +10,43 @@ ) where import Test.Tasty.Options--import Text.Regex.TDFA-import Text.Regex.TDFA.String()+import Test.Tasty.Patterns.Types+import Test.Tasty.Patterns.Parser+import Test.Tasty.Patterns.Eval -import Data.List+import Data.Char+import qualified Data.Sequence as Seq import Data.Typeable-#if !MIN_VERSION_base(4,8,0)-import Data.Tagged-import Data.Monoid-#endif--import Options.Applicative--data Token = SlashToken- | WildcardToken- | DoubleWildcardToken- | LiteralToken Char- deriving (Eq, Show)--tokenize :: String -> [Token]-tokenize ('/':rest) = SlashToken : tokenize rest-tokenize ('*':'*':rest) = DoubleWildcardToken : tokenize rest-tokenize ('*':rest) = WildcardToken : tokenize rest-tokenize (c:rest) = LiteralToken c : tokenize rest-tokenize [] = []---data TestPatternMatchMode = TestMatchMode- | PathMatchMode- deriving Show+import Options.Applicative hiding (Success) --- | A pattern to filter tests. For the syntax description, see--- the README.-data TestPattern = TestPattern {- tp_categories_only :: Bool,- tp_negated :: Bool,- tp_match_mode :: TestPatternMatchMode,- tp_tokens :: [Token]- } | NoPattern- deriving (Typeable, Show)+newtype TestPattern = TestPattern (Maybe Expr)+ deriving Typeable --- | A pattern that matches anything. noPattern :: TestPattern-noPattern = NoPattern--instance Read TestPattern where- readsPrec _ string = [(parseTestPattern string, "")]+noPattern = TestPattern Nothing instance IsOption TestPattern where defaultValue = noPattern- parseValue = Just . parseTestPattern+ parseValue = parseTestPattern optionName = return "pattern"- optionHelp = return "Select only tests that match pattern"+ optionHelp = return "Select only tests which satisfy a pattern or awk expression" optionCLParser = mkOptionCLParser (short 'p') --- | Parse a pattern-parseTestPattern :: String -> TestPattern-parseTestPattern string = TestPattern {- tp_categories_only = categories_only,- tp_negated = negated,- tp_match_mode = match_mode,- tp_tokens = tokens''- }- where- tokens = tokenize string- (negated, tokens')- | (LiteralToken '!'):rest <- tokens = (True, rest)- | otherwise = (False, tokens)- (categories_only, tokens'')- | (prefix, [SlashToken]) <- splitAt (length tokens' - 1) tokens' = (True, prefix)- | otherwise = (False, tokens')- match_mode- | SlashToken `elem` tokens = PathMatchMode- | otherwise = TestMatchMode----- | Test a path (which is the sequence of group titles, possibly followed--- by the test title) against a pattern-testPatternMatches :: TestPattern -> [String] -> Bool-testPatternMatches test_pattern =- -- It is important that GHC assigns arity 1 to this function,- -- so that compilation of the regex is shared among the invocations.- -- See #175.- case test_pattern of- NoPattern -> const True- TestPattern {} -> \path ->- let- path_to_consider | tp_categories_only test_pattern = dropLast 1 path- | otherwise = path- things_to_match = case tp_match_mode test_pattern of- -- See if the tokens match any single path component- TestMatchMode -> path_to_consider- -- See if the tokens match any prefix of the path- PathMatchMode -> map pathToString $ inits path_to_consider- in not_maybe . any (match tokens_regex) $ things_to_match- where- not_maybe | tp_negated test_pattern = not- | otherwise = id- tokens_regex :: Regex- tokens_regex = makeRegex $ buildTokenRegex (tp_tokens test_pattern)---buildTokenRegex :: [Token] -> String-buildTokenRegex [] = []-buildTokenRegex (token:tokens) = concat (firstTokenToRegex token : map tokenToRegex tokens)- where- firstTokenToRegex SlashToken = "^"- firstTokenToRegex other = tokenToRegex other-- tokenToRegex SlashToken = "/"- tokenToRegex WildcardToken = "[^/]*"- tokenToRegex DoubleWildcardToken = ".*"- tokenToRegex (LiteralToken lit) = regexEscapeChar lit--regexEscapeChar :: Char -> String-regexEscapeChar c | c `elem` "\\*+?|{}[]()^$." = '\\' : [c]- | otherwise = [c]--pathToString :: [String] -> String-pathToString path = concat (intersperse "/" path)+parseTestPattern :: String -> Maybe TestPattern+parseTestPattern s+ | null s = Just noPattern+ | all (\c -> isAlphaNum c || c `elem` "_/ ") s =+ Just . TestPattern . Just $ ERE s+ | otherwise =+ case runParser expr s of+ Success a -> Just . TestPattern . Just $ a+ _ -> Nothing -dropLast :: Int -> [a] -> [a]-dropLast n = reverse . drop n . reverse+testPatternMatches :: TestPattern -> Seq.Seq String -> Bool+testPatternMatches pat fields =+ case pat of+ TestPattern Nothing -> True+ TestPattern (Just e) ->+ case withFields fields $ asB =<< eval e of+ Left msg -> error msg+ Right b -> b
+ Test/Tasty/Patterns/Eval.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE RankNTypes, ViewPatterns #-}+module Test.Tasty.Patterns.Eval (eval, withFields, asB) where++import Prelude hiding (Ordering(..))+import Control.Monad.Reader+import Control.Monad.Except+import qualified Data.Sequence as Seq+import Data.Foldable+import Data.List+import Data.Maybe+import Data.Char+import Test.Tasty.Patterns.Types+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+import Data.Traversable+#endif++data Value+ = VN !Int+ | VS !Bool String+ -- ^ The 'Bool' is 'True' if the source of the string+ -- allows it to be numeric+ | Uninitialized+ deriving Show++type Env = Seq.Seq String++type M = ReaderT Env (Either String)++asS :: Value -> M String+asS v = return $+ case v of+ VN n -> show n+ VS _ s -> s+ Uninitialized -> ""++-- readMaybe was not in base-4.3 yet+parseN :: String -> Maybe Int+parseN s =+ case read s of+ [(n, "")] -> Just n+ _ -> Nothing++asN :: Value -> M Int+asN v =+ case v of+ VN n -> return n+ VS True s ->+ case parseN s of+ Just n -> return n+ Nothing -> throwError $ "Not a number: " ++ show s+ VS False s -> throwError $ "String is not numeric: " ++ show s+ Uninitialized -> return 0++isN :: Value -> Bool+isN v =+ case v of+ VN _ -> True+ _ -> False++isNumeric :: Value -> Bool+isNumeric v =+ case v of+ VS b s -> b && isJust (parseN s)+ _ -> True++asB :: Value -> M Bool+asB v = return $+ case v of+ VN 0 -> False+ VS _ "" -> False+ _ -> True++fromB :: Bool -> Value+fromB = VN . fromEnum++-- | Evaluate an awk expression+eval :: Expr -> M Value+eval e0 =+ case e0 of+ IntLit n -> return $ VN n+ StringLit s -> return $ VS False s+ NF -> VN . subtract 1 . Seq.length <$> ask+ Add e1 e2 -> binNumOp (+) e1 e2+ Sub e1 e2 -> binNumOp (-) e1 e2+ Neg e1 -> VN . negate <$> (asN =<< eval e1)+ Not e1 -> fromB . not <$> (asB =<< eval e1)+ And e1 e2 -> binLglOp (&&) e1 e2+ Or e1 e2 -> binLglOp (||) e1 e2+ LT e1 e2 -> binCmpOp (<) e1 e2+ LE e1 e2 -> binCmpOp (<=) e1 e2+ GT e1 e2 -> binCmpOp (>) e1 e2+ GE e1 e2 -> binCmpOp (>=) e1 e2+ EQ e1 e2 -> binCmpOp (==) e1 e2+ NE e1 e2 -> binCmpOp (/=) e1 e2+ Concat e1 e2 -> VS False <$> ((++) <$> (asS =<< eval e1) <*> (asS =<< eval e2))+ If cond e1 e2 -> do+ condV <- asB =<< eval cond+ if condV then eval e1 else eval e2+ Field e1 -> do+ n <- asN =<< eval e1+ fields <- ask+ return $ if n > Seq.length fields - 1+ then Uninitialized+ else VS True $ Seq.index fields n+ ERE pat -> do+ str <- Seq.index <$> ask <*> pure 0+ return . fromB $ match pat str+ Match e1 pat -> do+ str <- asS =<< eval e1+ return . fromB $ match pat str+ NoMatch e1 pat -> do+ str <- asS =<< eval e1+ return . fromB . not $ match pat str+ ToUpperFn e1 ->+ VS True . map toUpper <$> (asS =<< eval e1)+ ToLowerFn e1 ->+ VS True . map toLower <$> (asS =<< eval e1)+ SubstrFn e1 e2 mb_e3 -> do+ s <- asS =<< eval e1+ m <- asN =<< eval e2+ mb_n <- traverse (asN <=< eval) mb_e3+ return $ VS True $+ maybe id take mb_n . drop (m-1) $ s+ LengthFn (fromMaybe (Field (IntLit 0)) -> e1) ->+ VN . length <$> (asS =<< eval e1)+ MatchFn e1 pat -> do+ s <- asS =<< eval e1+ return . VN . maybe 0 (+1) . findIndex (pat `isPrefixOf`) $ tails s++ where+ binNumOp op e1 e2 = VN <$> (op <$> (asN =<< eval e1) <*> (asN =<< eval e2))+ binLglOp op e1 e2 = fromB <$> (op <$> (asB =<< eval e1) <*> (asB =<< eval e2))+ binCmpOp :: (forall a . Ord a => a -> a -> Bool) -> Expr -> Expr -> M Value+ binCmpOp op e1 e2 = do+ v1 <- eval e1+ v2 <- eval e2+ let+ compareAsNumbers =+ isN v1 && isNumeric v2 ||+ isN v2 && isNumeric v1+ if compareAsNumbers+ then fromB <$> (op <$> asN v1 <*> asN v2)+ else fromB <$> (op <$> asS v1 <*> asS v2)++match+ :: String -- ^ pattern+ -> String -- ^ string+ -> Bool+match pat str = pat `isInfixOf` str++-- | Run the 'M' monad with a given list of fields+--+-- The field list should not include @$0@; it's calculated automatically.+withFields :: Seq.Seq String -> M a -> Either String a+withFields fields a = runReaderT a (whole Seq.<| fields)+ where whole = intercalate "/" $ toList fields
+ Test/Tasty/Patterns/Expr.hs view
@@ -0,0 +1,173 @@+-- |+-- Copyright : © 2015–2018 Megaparsec contributors+-- © 2007 Paolo Martini+-- © 1999–2001 Daan Leijen+--+--+-- Code adapted from from megaparsec under the BSD license.+module Test.Tasty.Patterns.Expr+ ( Operator (..)+ , makeExprParser )+where++import Control.Monad++choice :: MonadPlus m => [m a] -> m a+choice = msum++option :: MonadPlus m => a -> m a -> m a+option x p = p `mplus` return x++-- | This data type specifies operators that work on values of type @a@. An+-- operator is either binary infix or unary prefix or postfix. A binary+-- operator has also an associated associativity.++data Operator m a+ = InfixN (m (a -> a -> a)) -- ^ Non-associative infix+ | InfixL (m (a -> a -> a)) -- ^ Left-associative infix+ | InfixR (m (a -> a -> a)) -- ^ Right-associative infix+ | Prefix (m (a -> a)) -- ^ Prefix+ | Postfix (m (a -> a)) -- ^ Postfix+ | TernR (m (m (a -> a -> a -> a)))+ -- ^ Right-associative ternary. Right-associative means that+ -- @a ? b : d ? e : f@ parsed as+ -- @a ? b : (d ? e : f)@ and not as @(a ? b : d) ? e : f@.++-- | @'makeExprParser' term table@ builds an expression parser for terms+-- @term@ with operators from @table@, taking the associativity and+-- precedence specified in the @table@ into account.+--+-- @table@ is a list of @[Operator m a]@ lists. The list is ordered in+-- descending precedence. All operators in one list have the same precedence+-- (but may have different associativity).+--+-- Prefix and postfix operators of the same precedence associate to the left+-- (i.e. if @++@ is postfix increment, than @-2++@ equals @-1@, not @-3@).+--+-- Unary operators of the same precedence can only occur once (i.e. @--2@ is+-- not allowed if @-@ is prefix negate). If you need to parse several prefix+-- or postfix operators in a row, (like C pointers—@**i@) you can use this+-- approach:+--+-- > manyUnaryOp = foldr1 (.) <$> some singleUnaryOp+--+-- This is not done by default because in some cases allowing repeating+-- prefix or postfix operators is not desirable.+--+-- If you want to have an operator that is a prefix of another operator in+-- the table, use the following (or similar) wrapper instead of plain+-- 'Text.Megaparsec.Char.Lexer.symbol':+--+-- > op n = (lexeme . try) (string n <* notFollowedBy punctuationChar)+--+-- 'makeExprParser' takes care of all the complexity involved in building an+-- expression parser. Here is an example of an expression parser that+-- handles prefix signs, postfix increment and basic arithmetic:+--+-- > expr = makeExprParser term table <?> "expression"+-- >+-- > term = parens expr <|> integer <?> "term"+-- >+-- > table = [ [ prefix "-" negate+-- > , prefix "+" id ]+-- > , [ postfix "++" (+1) ]+-- > , [ binary "*" (*)+-- > , binary "/" div ]+-- > , [ binary "+" (+)+-- > , binary "-" (-) ] ]+-- >+-- > binary name f = InfixL (f <$ symbol name)+-- > prefix name f = Prefix (f <$ symbol name)+-- > postfix name f = Postfix (f <$ symbol name)++makeExprParser :: MonadPlus m+ => m a -- ^ Term parser+ -> [[Operator m a]] -- ^ Operator table, see 'Operator'+ -> m a -- ^ Resulting expression parser+makeExprParser = foldl addPrecLevel+{-# INLINEABLE makeExprParser #-}++-- | @addPrecLevel p ops@ adds the ability to parse operators in table @ops@+-- to parser @p@.++addPrecLevel :: MonadPlus m => m a -> [Operator m a] -> m a+addPrecLevel term ops =+ term' >>= \x -> choice [ras' x, las' x, nas' x, tern' x, return x]+ where (ras, las, nas, prefix, postfix, tern) = foldr splitOp ([],[],[],[],[],[]) ops+ term' = pTerm (choice prefix) term (choice postfix)+ ras' = pInfixR (choice ras) term'+ las' = pInfixL (choice las) term'+ nas' = pInfixN (choice nas) term'+ tern' = pTernR (choice tern) term'++-- | @pTerm prefix term postfix@ parses a @term@ surrounded by optional+-- prefix and postfix unary operators. Parsers @prefix@ and @postfix@ are+-- allowed to fail, in this case 'id' is used.++pTerm :: MonadPlus m => m (a -> a) -> m a -> m (a -> a) -> m a+pTerm prefix term postfix = do+ pre <- option id prefix+ x <- term+ post <- option id postfix+ return . post . pre $ x++-- | @pInfixN op p x@ parses non-associative infix operator @op@, then term+-- with parser @p@, then returns result of the operator application on @x@+-- and the term.++pInfixN :: MonadPlus m => m (a -> a -> a) -> m a -> a -> m a+pInfixN op p x = do+ f <- op+ y <- p+ return $ f x y++-- | @pInfixL op p x@ parses left-associative infix operator @op@, then term+-- with parser @p@, then returns result of the operator application on @x@+-- and the term.++pInfixL :: MonadPlus m => m (a -> a -> a) -> m a -> a -> m a+pInfixL op p x = do+ f <- op+ y <- p+ let r = f x y+ pInfixL op p r `mplus` return r++-- | @pInfixR op p x@ parses right-associative infix operator @op@, then+-- term with parser @p@, then returns result of the operator application on+-- @x@ and the term.++pInfixR :: MonadPlus m => m (a -> a -> a) -> m a -> a -> m a+pInfixR op p x = do+ f <- op+ y <- p >>= \r -> pInfixR op p r `mplus` return r+ return $ f x y++-- | Parse the first separator of a ternary operator++pTernR :: MonadPlus m => m (m (a -> a -> a -> a)) -> m a -> a -> m a+pTernR sep1 p x = do+ sep2 <- sep1+ y <- p >>= \r -> pTernR sep1 p r `mplus` return r+ f <- sep2+ z <- p >>= \r -> pTernR sep1 p r `mplus` return r+ return $ f x y z++type Batch m a =+ ( [m (a -> a -> a)]+ , [m (a -> a -> a)]+ , [m (a -> a -> a)]+ , [m (a -> a)]+ , [m (a -> a)]+ , [m (m (a -> a -> a -> a))]+ )++-- | A helper to separate various operators (binary, unary, and according to+-- associativity) and return them in a tuple.++splitOp :: Operator m a -> Batch m a -> Batch m a+splitOp (InfixR op) (r, l, n, pre, post, tern) = (op:r, l, n, pre, post, tern)+splitOp (InfixL op) (r, l, n, pre, post, tern) = (r, op:l, n, pre, post, tern)+splitOp (InfixN op) (r, l, n, pre, post, tern) = (r, l, op:n, pre, post, tern)+splitOp (Prefix op) (r, l, n, pre, post, tern) = (r, l, n, op:pre, post, tern)+splitOp (Postfix op) (r, l, n, pre, post, tern) = (r, l, n, pre, op:post, tern)+splitOp (TernR op) (r, l, n, pre, post, tern) = (r, l, n, pre, post, op:tern)
+ Test/Tasty/Patterns/Parser.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- | See <http://pubs.opengroup.org/onlinepubs/9699919799/utilities/awk.html> for the+-- full awk grammar.+module Test.Tasty.Patterns.Parser+ ( Parser+ , runParser+ , ParseResult(..)+ , expr+ )+ where++import Prelude hiding (Ordering(..))+import Text.ParserCombinators.ReadP hiding (many, optional)+import Text.ParserCombinators.ReadPrec (readPrec_to_P, minPrec)+import Text.Read (readPrec)+import Data.Functor+import Data.Char+import Control.Applicative+import Control.Monad+import Test.Tasty.Patterns.Types+import Test.Tasty.Patterns.Expr++type Token = ReadP++-- | A separate 'Parser' data type ensures that we don't forget to skip+-- spaces.+newtype Parser a = Parser (ReadP a)+ deriving (Functor, Applicative, Alternative, Monad, MonadPlus)++#if !MIN_VERSION_base(4,6,0)+instance Applicative ReadP where+ pure = return+ (<*>) = ap+instance Alternative ReadP where+ empty = mzero+ (<|>) = mplus+#endif+++data ParseResult a = Success a | Invalid | Ambiguous [a]+ deriving Show++token :: Token a -> Parser a+token a = Parser (a <* skipSpaces)++sym :: Char -> Parser ()+sym = void . token . char++str :: String -> Parser ()+str = void . token . string++-- | Run a parser+runParser+ :: Parser a+ -> String -- ^ text to parse+ -> ParseResult a+runParser (Parser p) s =+ case filter (null . snd) $ readP_to_S (skipSpaces *> p) s of+ [(a, _)] -> Success a+ [] -> Invalid+ as -> Ambiguous (fst <$> as)++intP :: Parser Int+intP = token $+ -- we cannot use the standard Int ReadP parser because it recognizes+ -- negative numbers, making -1 ambiguous+ read <$> munch1 isDigit++strP :: Parser String+strP = token $ readPrec_to_P readPrec minPrec+ -- this deviates somewhat from the awk string literals, by design++-- | An awk ERE token such as @/foo/@. No special characters are recognized+-- at the moment, except @\@ as an escape character for @/@ and itself.+patP :: Parser String+patP = token $ char '/' *> many ch <* char '/'+ where+ ch =+ satisfy (`notElem` "/\\") <|>+ (char '\\' *> satisfy (`elem` "/\\"))++nfP :: Parser ()+nfP = token $ void $ string "NF"++-- | Built-in functions+builtin :: Parser Expr+builtin = msum+ [ fn "length" $ LengthFn <$> optional expr+ -- we don't support length without parentheses at all,+ -- because that makes length($1) ambiguous+ -- (we don't require spaces for concatenation)+ , fn "toupper" $ ToUpperFn <$> expr+ , fn "tolower" $ ToLowerFn <$> expr+ , fn "match" $ MatchFn <$> expr <* sym ',' <*> patP+ , fn "substr" $ SubstrFn <$> expr <* sym ',' <*> expr <*>+ optional (sym ',' *> expr)+ ]+ where+ fn :: String -> Parser a -> Parser a+ fn name args = token (string name) *> sym '(' *> args <* sym ')'++-- | Atomic expressions+expr0 :: Parser Expr+expr0 =+ (sym '(' *> expr <* sym ')') <|>+ (IntLit <$> intP) <|>+ (StringLit <$> strP) <|>+ (ERE <$> patP) <|>+ (NF <$ nfP) <|>+ builtin++-- | Arguments to unary operators: atomic expressions and field+-- expressions+expr1 :: Parser Expr+expr1 = makeExprParser expr0+ [ [ Prefix (Field <$ sym '$') ] ]++-- | Whether a parser is unary or non-unary.+--+-- This roughly corresponds to the @unary_expr@ and @non_unary_expr@+-- non-terminals in the awk grammar.+-- (Why roughly? See 'expr2'.)+data Unary = Unary | NonUnary++-- | Arithmetic expressions.+--+-- Unlike awk, non-unary expressions disallow unary operators everywhere,+-- not just in the leading position, to avoid extra complexity in+-- 'makeExprParser'.+--+-- For example, the expression+--+-- >1 3 + -4+--+-- is valid in awk because @3 + -4@ is non-unary, but we disallow it here+-- because 'makeExprParser' does not allow us to distinguish it from+--+-- >1 -4 + 3+--+-- which is ambiguous.+expr2 :: Unary -> Parser Expr+expr2 unary = makeExprParser expr1+ [ [ Prefix (Not <$ sym '!') ] +++ (case unary of+ Unary -> [ Prefix (Neg <$ sym '-') ]+ NonUnary -> []+ )+ , [ InfixL (Add <$ sym '+')+ , InfixL (Sub <$ sym '-')+ ]+ ]++-- | Expressions that may include string concatenation+expr3 :: Parser Expr+expr3 = concatExpr <|> expr2 Unary+ where+ -- The awk spec mandates that concatenation associates to the left.+ -- But concatenation is associative, so why would we care.+ concatExpr = Concat <$> nonUnary <*> (nonUnary <|> concatExpr)+ nonUnary = expr2 NonUnary++-- | Everything with lower precedence than concatenation+expr4 :: Parser Expr+expr4 = makeExprParser expr3+ [ [ InfixN (LT <$ sym '<')+ , InfixN (GT <$ sym '>')+ , InfixN (LE <$ str "<=")+ , InfixN (GE <$ str ">=")+ , InfixN (EQ <$ str "==")+ , InfixN (NE <$ str "!=")+ ]+ , [ Postfix (flip Match <$ sym '~' <*> patP)+ , Postfix (flip NoMatch <$ str "!~" <*> patP)+ ]+ , [ InfixL (And <$ str "&&") ]+ , [ InfixL (Or <$ str "||") ]+ , [ TernR ((If <$ sym ':') <$ sym '?') ]+ ]++-- | The awk-like expression parser+expr :: Parser Expr+expr = expr4
+ Test/Tasty/Patterns/Types.hs view
@@ -0,0 +1,30 @@+module Test.Tasty.Patterns.Types where++data Expr+ = IntLit !Int+ | NF -- ^ number of fields+ | Add Expr Expr+ | Sub Expr Expr+ | Neg Expr+ | Not Expr+ | And Expr Expr+ | LT Expr Expr+ | GT Expr Expr+ | LE Expr Expr+ | GE Expr Expr+ | EQ Expr Expr+ | NE Expr Expr+ | Or Expr Expr+ | Concat Expr Expr+ | Match Expr String+ | NoMatch Expr String+ | Field Expr -- ^ nth field of the path, where 1 is the outermost group name and 0 is the whole test name, using @/@ as a separator+ | StringLit String+ | If Expr Expr Expr+ | ERE String -- ^ an ERE token by itself, like @/foo/@ but not like @$1 ~ /foo/@+ | ToUpperFn Expr+ | ToLowerFn Expr+ | LengthFn (Maybe Expr)+ | MatchFn Expr String+ | SubstrFn Expr Expr (Maybe Expr)+ deriving Show
Test/Tasty/Run.hs view
@@ -1,6 +1,6 @@ -- | Running tests {-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes,- FlexibleContexts, BangPatterns #-}+ FlexibleContexts, BangPatterns, CPP #-} module Test.Tasty.Run ( Status(..) , StatusMap@@ -11,6 +11,9 @@ import qualified Data.Sequence as Seq import qualified Data.Foldable as F import Data.Maybe+#ifndef VERSION_clock+import Data.Time.Clock.POSIX (getPOSIXTime)+#endif import Control.Monad.State import Control.Monad.Writer import Control.Monad.Reader@@ -22,7 +25,9 @@ import Control.Arrow import GHC.Conc (labelThread) import Prelude -- Silence AMP and FTP import warnings+#ifdef VERSION_clock import qualified System.Clock as Clock+#endif import Test.Tasty.Core import Test.Tasty.Parallel@@ -297,6 +302,7 @@ end <- getTime return (end-start, r) +#ifdef VERSION_clock -- | Get monotonic time -- -- Warning: This is not the system time, but a monotonically increasing time@@ -311,3 +317,8 @@ Clock.timeSpecAsNanoSecs t #endif return $ ns / 10 ^ (9 :: Int)+#else+-- | Get system time+getTime :: IO Time+getTime = realToFrac <$> getPOSIXTime+#endif
tasty.cabal view
@@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: tasty-version: 0.12.0.1+version: 1.0 synopsis: Modern and extensible testing framework description: Tasty is a modern testing framework for Haskell. It lets you combine your unit tests, golden@@ -25,6 +25,11 @@ location: git://github.com/feuerbach/tasty.git subdir: core +flag clock+ description:+ Depend on the clock package for more accurate time measurement+ default: True+ library exposed-modules: Test.Tasty,@@ -34,12 +39,18 @@ Test.Tasty.Ingredients, Test.Tasty.Ingredients.Basic Test.Tasty.Ingredients.ConsoleReporter++ -- for testing only+ Test.Tasty.Patterns.Types+ Test.Tasty.Patterns.Parser+ Test.Tasty.Patterns.Eval other-modules: Test.Tasty.Parallel, Test.Tasty.Core, Test.Tasty.Options.Core, Test.Tasty.Options.Env, Test.Tasty.Patterns,+ Test.Tasty.Patterns.Expr, Test.Tasty.Run, Test.Tasty.Runners.Reducers, Test.Tasty.Runners.Utils,@@ -52,13 +63,16 @@ containers, mtl, tagged >= 0.5,- regex-tdfa >= 1.1.8.2, optparse-applicative >= 0.11, deepseq >= 1.3, unbounded-delays >= 0.1, async >= 2.0,- ansi-terminal >= 0.6.2,- clock >= 0.4.4.0+ ansi-terminal >= 0.6.2++ if flag(clock)+ build-depends: clock >= 0.4.4.0+ else+ build-depends: time >= 1.4 if impl(ghc < 7.6) -- for GHC.Generics