tasty 1.4.3 → 1.5
raw patch · 24 files changed
+1005/−263 lines, 24 filesdep ~ansi-terminaldep ~containersdep ~optparse-applicative
Dependency ranges changed: ansi-terminal, containers, optparse-applicative, semigroups, stm, tagged, time, transformers, unbounded-delays, unix
Files
- CHANGELOG.md +34/−0
- README.md +32/−11
- Test/Tasty.hs +19/−5
- Test/Tasty/CmdLine.hs +4/−0
- Test/Tasty/Core.hs +261/−48
- Test/Tasty/Ingredients.hs +17/−0
- Test/Tasty/Ingredients/Basic.hs +2/−0
- Test/Tasty/Ingredients/ConsoleReporter.hs +143/−33
- Test/Tasty/Ingredients/IncludingOptions.hs +2/−0
- Test/Tasty/Ingredients/ListTests.hs +10/−4
- Test/Tasty/Options.hs +45/−12
- Test/Tasty/Options/Core.hs +34/−5
- Test/Tasty/Patterns.hs +24/−4
- Test/Tasty/Patterns/Eval.hs +8/−1
- Test/Tasty/Patterns/Parser.hs +17/−3
- Test/Tasty/Patterns/Printer.hs +1/−0
- Test/Tasty/Patterns/Types.hs +7/−1
- Test/Tasty/Providers.hs +12/−4
- Test/Tasty/Providers/ConsoleFormat.hs +1/−1
- Test/Tasty/Run.hs +281/−108
- Test/Tasty/Runners.hs +4/−1
- Test/Tasty/Runners/Reducers.hs +9/−1
- Test/Tasty/Runners/Utils.hs +25/−8
- tasty.cabal +13/−13
CHANGELOG.md view
@@ -1,6 +1,40 @@ Changes ======= +Version 1.5+---------------++_2023-09-10_++* Progress reporting is no longer ignored.+ `PrintTest` constructor of `TestOutput` now has an extra field used to report progress.+ Supply `const (pure ())` as this extra field value if you want to skip progress reporting+ ([#311](https://github.com/UnkindPartition/tasty/pull/311)).+* `foldGroup` now takes `[b]` instead of `b` as its last argument to allow+ for custom fold strategies. This is a backwards incompatible change,+ but you can get the old behavior by applying `mconcat`+ ([#364](https://github.com/UnkindPartition/tasty/issues/364)).+* Dependency loop error now lists all test cases that formed a cycle+ ([#340](https://github.com/UnkindPartition/tasty/issues/340)).+* Dependencies can now be defined pattern-free with `sequentialTestGroup`+ ([#343](https://github.com/UnkindPartition/tasty/issues/343)).+* Added `--min-duration-to-report` flag that specifies the time a test+ must take before `tasty` outputs timing information+ ([#341](https://github.com/UnkindPartition/tasty/issues/341)).+* When a test failed with an exception, print it using `displayException`+ instead of `show`+ ([#330](https://github.com/UnkindPartition/tasty/issues/330)).+* The `-p` / `--pattern` option can be specified multiple times;+ only tests that match all patterns are run+ ([#380](https://github.com/UnkindPartition/tasty/pull/380)).+* Fix color scheme to make info messages visible in terminals with white background+ ([#369](https://github.com/UnkindPartition/tasty/pull/369)).+* When parsing of a command-line option failed, report received option+ ([#368](https://github.com/UnkindPartition/tasty/pull/368)).+* Support WASM+ ([#365](https://github.com/UnkindPartition/tasty/pull/365)).+* Tested with GHC 8.0 - 9.8.+ Version 1.4.3 ---------------
README.md view
@@ -146,15 +146,20 @@ * [tasty-stats](https://hackage.haskell.org/package/tasty-stats) adds the possibility to collect statistics of the test suite in a CSV file. +### Test discovery++`tasty` by itself forces you to explicitly write out the `TestTree` yourself.+The packages listed below allow you to write tests at the top-level, and will+automatically collect them into a single `TestTree`.++* [tasty-th](https://hackage.haskell.org/package/tasty-th)+* [tasty-discover](https://hackage.haskell.org/package/tasty-discover)+* [tasty-autocollect](https://hackage.haskell.org/package/tasty-autocollect)+ ### Other packages -* [tasty-th](https://hackage.haskell.org/package/tasty-th) automatically-discovers tests based on the function names and generate the boilerplate code for-you * [tasty-hunit-adapter](https://hackage.haskell.org/package/tasty-hunit-adapter) converts existing HUnit test suites into tasty test suites-* [tasty-discover](https://hackage.haskell.org/package/tasty-discover) automatically discovers-your tests. * [tasty-expected-failure](https://hackage.haskell.org/package/tasty-expected-failure) provides test markers for when you expect failures or wish to ignore tests. * [tasty-bench](https://hackage.haskell.org/package/tasty-bench) covers performance@@ -186,9 +191,9 @@ % ./test --help Mmm... tasty test suite -Usage: test [-p|--pattern PATTERN] [-t|--timeout DURATION] [-l|--list-tests]- [-j|--num-threads NUMBER] [-q|--quiet] [--hide-successes]- [--color never|always|auto] [--ansi-tricks ARG]+Usage: test [-p|--pattern PATTERN] [-t|--timeout DURATION] [--no-progress]+ [-l|--list-tests] [-j|--num-threads NUMBER] [-q|--quiet]+ [--hide-successes] [--color never|always|auto] [--ansi-tricks ARG] [--smallcheck-depth NUMBER] [--smallcheck-max-count NUMBER] [--quickcheck-tests NUMBER] [--quickcheck-replay SEED] [--quickcheck-show-replay] [--quickcheck-max-size NUMBER]@@ -201,12 +206,17 @@ expression -t,--timeout DURATION Timeout for individual tests (suffixes: ms,s,m,h; default: s)+ --no-progress Do not show progress -l,--list-tests Do not run the tests; just print their names -j,--num-threads NUMBER Number of threads to use for tests execution (default: # of cores/capabilities) -q,--quiet Do not produce any output; indicate success only by the exit code --hide-successes Do not print tests that passed successfully+ --min-duration-to-report DURATION+ The minimum amount of time a test can take before+ tasty prints timing information (suffixes: ms,s,m,h;+ default: s) --color never|always|auto When to use colored output (default: auto) --ansi-tricks ARG Enable various ANSI terminal tricks. Can be set to@@ -691,13 +701,16 @@ If this parallelism is not desirable, you can declare *dependencies* between tests, so that one test will not start until certain other tests finish. -Dependencies are declared using the `after` combinator:+Dependencies are declared using the `after` or `sequentialTestGroup` combinator: * `after AllFinish "pattern" my_tests` will execute the test tree `my_tests` only after all tests that match the pattern finish. * `after AllSucceed "pattern" my_tests` will execute the test tree `my_tests` only after all tests that match the pattern finish **and** only if they all succeed. If at least one dependency fails, then `my_tests` will be skipped.+* `sequentialTestGroup groupName dependencyType [tree1, tree2, ..]` will execute all tests+ in `tree1` first, after which it will execute all tests in `tree2`, and so forth. Like+ `after`, `dependencyType` can either be set to `AllFinish` or `AllSucceed`. The relevant types are: @@ -708,6 +721,12 @@ -> TestTree -- ^ the subtree that depends on other tests -> TestTree -- ^ the subtree annotated with dependency information +sequentialTestGroup+ :: TestName -- ^ name of the group+ -> DependencyType -- ^ whether to run the tests even if some of the dependencies fail+ -> [TestTree] -- ^ trees to execute sequentially+ -> TestTree+ data DependencyType = AllSucceed | AllFinish ``` @@ -744,7 +763,7 @@ ] ``` -Here are some caveats to keep in mind regarding dependencies in Tasty:+Here are some caveats to keep in mind when using patterns to specify dependencies in Tasty: 1. If Test B depends on Test A, remember that either of them may be filtered out using the `--pattern` option. Collecting the dependency info happens *after*@@ -755,7 +774,7 @@ typos. Fortunately, misspecified dependencies usually lead to test failures and so can be detected that way. 1. Dependencies shouldn't form a cycle, otherwise Tasty with fail with the- message "Test dependencies form a loop." A common cause of this is a test+ message "Test dependencies have cycles." A common cause of this is a test matching its own dependency pattern. 1. Using dependencies may introduce quadratic complexity. Specifically, resolving dependencies is *O(number_of_tests × number_of_dependencies)*,@@ -770,6 +789,8 @@ dependencies is sufficiently different from the natural order of tests in the test tree, searching for the next test to execute may also have an overhead quadratic in the number of tests.++Use `sequentialTestGroup` to mitigate these problems. ## FAQ
Test/Tasty.hs view
@@ -24,6 +24,8 @@ -- Take a look at the <https://github.com/UnkindPartition/tasty#readme README>: -- it contains a comprehensive list of test providers, a bigger example, -- and a lot of other information.+--+-- @since 0.1 module Test.Tasty (@@ -31,6 +33,7 @@ TestName , TestTree , testGroup+ , sequentialTestGroup -- * Running tests , defaultMain , defaultMainWithIngredients@@ -71,6 +74,8 @@ -- | List of the default ingredients. This is what 'defaultMain' uses. -- -- At the moment it consists of 'listingTests' and 'consoleTestReporter'.+--+-- @since 0.4.2 defaultIngredients :: [Ingredient] defaultIngredients = [listingTests, consoleTestReporter] @@ -96,25 +101,34 @@ -- > then putStrLn "Yea" -- > else putStrLn "Nay" -- > throwIO e)-+--+-- @since 0.1 defaultMain :: TestTree -> IO () defaultMain = defaultMainWithIngredients defaultIngredients --- | Locally adjust the option value for the given test subtree+-- | Locally adjust the option value for the given test subtree.+--+-- @since 0.1 adjustOption :: IsOption v => (v -> v) -> TestTree -> TestTree adjustOption f = PlusTestOptions $ \opts -> setOption (f $ lookupOption opts) opts --- | Locally set the option value for the given test subtree+-- | Locally set the option value for the given test subtree.+--+-- @since 0.1 localOption :: IsOption v => v -> TestTree -> TestTree localOption v = PlusTestOptions (setOption v) --- | Customize the test tree based on the run-time options+-- | Customize the test tree based on the run-time options.+--+-- @since 0.6 askOption :: IsOption v => (v -> TestTree) -> TestTree askOption f = AskOptions $ f . lookupOption -- | Acquire the resource to run this test (sub)tree and release it--- afterwards+-- afterwards.+--+-- @since 0.5 withResource :: IO a -- ^ initialize the resource -> (a -> IO ()) -- ^ free the resource
Test/Tasty/CmdLine.hs view
@@ -148,6 +148,8 @@ -- The arguments to this function should be the same as for -- 'defaultMainWithIngredients'. If you don't use any custom ingredients, -- pass 'Test.Tasty.defaultIngredients'.+--+-- @since 1.2.2 parseOptions :: [Ingredient] -> TestTree -> IO OptionSet parseOptions ins tree = do let (warnings, parser) = suiteOptionParser ins tree@@ -166,6 +168,8 @@ -- When the tests finish, this function calls 'System.Exit.exitWith' with the exit code -- that indicates whether any tests have failed. See 'Test.Tasty.defaultMain' for -- details.+--+-- @since 0.4 defaultMainWithIngredients :: [Ingredient] -> TestTree -> IO () defaultMainWithIngredients ins testTree = do installSignalHandlers
Test/Tasty/Core.hs view
@@ -1,25 +1,56 @@ -- | Core types and definitions-{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts,- ExistentialQuantification, RankNTypes, DeriveDataTypeable, NoMonomorphismRestriction,- DeriveGeneric #-}-module Test.Tasty.Core where+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+module Test.Tasty.Core+ ( FailureReason(..)+ , Outcome(..)+ , Time+ , Result(..)+ , resultSuccessful+ , exceptionResult+ , Progress(..)+ , emptyProgress+ , IsTest(..)+ , TestName+ , ResourceSpec(..)+ , ResourceError(..)+ , DependencyType(..)+ , ExecutionMode(..)+ , TestTree(..)+ , testGroup+ , sequentialTestGroup+ , after+ , after_+ , TreeFold(..)+ , trivialFold+ , foldTestTree+ , foldTestTree0+ , treeOptions+ ) where import Control.Exception-import Test.Tasty.Providers.ConsoleFormat-import Test.Tasty.Options-import Test.Tasty.Patterns-import Test.Tasty.Patterns.Types-import Data.Foldable-import qualified Data.Sequence as Seq-import Data.Monoid-import Data.Typeable import qualified Data.Map as Map+import Data.Bifunctor (Bifunctor(second, bimap))+import Data.List (mapAccumR)+import Data.Monoid (Any (getAny, Any))+import Data.Sequence ((|>))+import qualified Data.Sequence as Seq import Data.Tagged+import Data.Typeable import GHC.Generics-import Prelude -- Silence AMP and FTP import warnings+import Options.Applicative (internal)+import Test.Tasty.Options+import Test.Tasty.Patterns+import Test.Tasty.Patterns.Types+import Test.Tasty.Providers.ConsoleFormat import Text.Printf+import Text.Read (readMaybe) --- | If a test failed, 'FailureReason' describes why+-- | If a test failed, 'FailureReason' describes why.+--+-- @since 0.8 data FailureReason = TestFailed -- ^ test provider indicated failure of the code to test, either because@@ -34,21 +65,29 @@ -- ^ test didn't complete in allotted time | TestDepFailed -- See Note [Skipped tests] -- ^ a dependency of this test failed, so this test was skipped.+ --+ -- @since 1.2 deriving Show -- | Outcome of a test run -- -- Note: this is isomorphic to @'Maybe' 'FailureReason'@. You can use the -- @generic-maybe@ package to exploit that.+--+-- @since 0.8 data Outcome = Success -- ^ test succeeded | Failure FailureReason -- ^ test failed because of the 'FailureReason' deriving (Show, Generic) -- | Time in seconds. Used to measure how long the tests took to run.+--+-- @since 0.10 type Time = Double --- | A test result+-- | A test result.+--+-- @since 0.1 data Result = Result { resultOutcome :: Outcome -- ^ Did the test fail? If so, why?@@ -61,9 +100,13 @@ -- -- For a failed test, 'resultDescription' should typically provide more -- information about the failure.+ --+ -- @since 0.11 , resultShortDescription :: String -- ^ The short description printed in the test run summary, usually @OK@ or -- @FAIL@.+ --+ -- @since 0.10 , resultTime :: Time -- ^ How long it took to run the test, in seconds. , resultDetailsPrinter :: ResultDetailsPrinter@@ -78,7 +121,9 @@ -- -- @since 1.3.1 }- deriving Show+ deriving+ ( Show -- ^ @since 1.2+ ) {- Note [Skipped tests] ~~~~~~~~~~~~~~~~~~~~@@ -103,6 +148,8 @@ -} -- | 'True' for a passed test, 'False' for a failed one.+--+-- @since 0.8 resultSuccessful :: Result -> Bool resultSuccessful r = case resultOutcome r of@@ -113,7 +160,7 @@ exceptionResult :: SomeException -> Result exceptionResult e = Result { resultOutcome = Failure $ TestThrewException e- , resultDescription = "Exception: " ++ show e+ , resultDescription = "Exception: " ++ displayException e , resultShortDescription = "FAIL" , resultTime = 0 , resultDetailsPrinter = noResultDetails@@ -123,6 +170,8 @@ -- -- This may be used by a runner to provide some feedback to the user while -- a long-running test is executing.+--+-- @since 0.1 data Progress = Progress { progressText :: String -- ^ textual information about the test's progress@@ -131,12 +180,23 @@ -- 'progressPercent' should be a value between 0 and 1. If it's impossible -- to compute the estimate, use 0. }- deriving Show+ deriving+ ( Show -- ^ @since 1.2+ , Eq -- ^ @since 1.5+ ) +-- | Empty progress+--+-- @since 1.5+emptyProgress :: Progress+emptyProgress = Progress mempty 0.0+ -- | The interface to be implemented by a test provider. -- -- The type @t@ is the concrete representation of the test which is used by -- the provider.+--+-- @since 0.1 class Typeable t => IsTest t where -- | Run the test --@@ -149,19 +209,20 @@ :: OptionSet -- ^ options -> t -- ^ the test to run -> (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 testOptions :: Tagged t [OptionDescription] --- | The name of a test or a group of tests+-- | The name of a test or a group of tests.+--+-- @since 0.1 type TestName = String -- | 'ResourceSpec' describes how to acquire a resource (the first field) -- and how to release it (the second field).+--+-- @since 0.6 data ResourceSpec a = ResourceSpec (IO a) (a -> IO ()) -- | A resources-related exception@@ -195,8 +256,29 @@ | AllFinish -- ^ The current test tree will be executed after its dependencies finish, -- regardless of whether they succeed or not.- deriving (Eq, Show)+ deriving+ ( Eq+ , Show+ , Read -- ^ @since 1.5+ ) +-- | Determines mode of execution of a 'TestGroup'+data ExecutionMode+ = Sequential DependencyType+ -- ^ Execute tests one after another+ | Parallel+ -- ^ Execute tests in parallel+ deriving (Show, Read)++-- | Determines mode of execution of a 'TestGroup'. Note that this option is+-- not exposed as a command line argument.+instance IsOption ExecutionMode where+ defaultValue = Parallel+ parseValue = readMaybe+ optionName = Tagged "execution-mode"+ optionHelp = Tagged "Whether to execute tests sequentially or in parallel"+ optionCLParser = mkOptionCLParser internal+ -- | The main data structure defining a test suite. -- -- It consists of individual test cases and properties, organized in named@@ -207,6 +289,8 @@ -- turn a test case into a 'TestTree'. -- -- Groups can be created using 'testGroup'.+--+-- @since 0.1 data TestTree = forall t . IsTest t => SingleTest TestName t -- ^ A single test of some particular type@@ -219,16 +303,33 @@ -- release it after they finish. The tree gets an `IO` action which -- yields the resource, although the resource is shared across all the -- tests.+ --+ -- @since 0.5 | AskOptions (OptionSet -> TestTree)- -- ^ Ask for the options and customize the tests based on them+ -- ^ Ask for the options and customize the tests based on them.+ --+ -- @since 0.6 | After DependencyType Expr TestTree -- ^ Only run after all tests that match a given pattern finish- -- (and, depending on the 'DependencyType', succeed)+ -- (and, depending on the 'DependencyType', succeed).+ --+ -- @since 1.2 --- | Create a named group of test cases or other groups+-- | Create a named group of test cases or other groups. Tests are executed in+-- parallel. For sequential execution, see 'sequentialTestGroup'.+--+-- @since 0.1 testGroup :: TestName -> [TestTree] -> TestTree testGroup = TestGroup +-- | Create a named group of test cases or other groups. Tests are executed in+-- order. For parallel execution, see 'testGroup'.+sequentialTestGroup :: TestName -> DependencyType -> [TestTree] -> TestTree+sequentialTestGroup nm depType = setSequential . TestGroup nm . map setParallel+ where+ setParallel = PlusTestOptions (setOption Parallel)+ setSequential = PlusTestOptions (setOption (Sequential depType))+ -- | Like 'after', but accepts the pattern as a syntax tree instead -- of a string. Useful for generating a test tree programmatically. --@@ -308,11 +409,15 @@ -- Instead of constructing fresh records, build upon `trivialFold` -- instead. This way your code won't break when new nodes/fields are -- indroduced.+--+-- @since 0.7 data TreeFold b = TreeFold { foldSingle :: forall t . IsTest t => OptionSet -> TestName -> t -> b- , foldGroup :: OptionSet -> TestName -> b -> b+ , foldGroup :: OptionSet -> TestName -> [b] -> b+ -- ^ @since 1.4 , foldResource :: forall a . OptionSet -> ResourceSpec a -> (IO a -> b) -> b , foldAfter :: OptionSet -> DependencyType -> Expr -> b -> b+ -- ^ @since 1.2 } -- | 'trivialFold' can serve as the basis for custom folds. Just override@@ -326,14 +431,28 @@ -- -- * for a resource, an IO action that throws an exception is passed (you -- want to override this for runners/ingredients that execute tests)+--+-- @since 0.7 trivialFold :: Monoid b => TreeFold b trivialFold = TreeFold { foldSingle = \_ _ _ -> mempty- , foldGroup = \_ _ b -> b+ , foldGroup = \_ _ bs -> mconcat bs , foldResource = \_ _ f -> f $ throwIO NotRunningTests , foldAfter = \_ _ _ b -> b } ++-- | Indicates whether a test matched in an evaluated subtree. If no filter was+-- used, tests always match.+type TestMatched = Any++-- | Used to force tests to be included, even if they would be filtered out by+-- a user's filter. This is used to force dependencies of a test to run. For+-- example, if test @A@ depends on test @B@ and test @A@ is selected to run, test+-- @B@ will be forced to match. Note that this only applies to dependencies+-- specified using 'sequentialTestGroup'.+type ForceTestMatch = Any+ -- | Fold a test tree into a single value. -- -- The fold result type should be a monoid. This is used to fold multiple@@ -349,9 +468,7 @@ -- -- Thus, it is preferred to an explicit recursive traversal of the tree. ----- Note: right now, the patterns are looked up only once, and won't be--- affected by the subsequent option changes. This shouldn't be a problem--- in practice; OTOH, this behaviour may be changed later.+-- @since 0.7 foldTestTree :: forall b . Monoid b => TreeFold b@@ -361,24 +478,120 @@ -> TestTree -- ^ the tree to fold -> b-foldTestTree (TreeFold fTest fGroup fResource fAfter) opts0 tree0 =- go mempty opts0 tree0+foldTestTree = foldTestTree0 mempty++-- | Like 'foldTestTree', but with a custom (non-Monoid) empty value. Unlike+-- 'foldTestTree', it is not part of the public API.+foldTestTree0+ :: forall b+ . b+ -- ^ "empty" value+ -> TreeFold b+ -- ^ the algebra (i.e. how to fold a tree)+ -> OptionSet+ -- ^ initial options+ -> TestTree+ -- ^ the tree to fold+ -> b+foldTestTree0 empty (TreeFold fTest fGroup fResource fAfter) opts0 tree0 =+ go (filterByPattern (annotatePath (evaluateOptions opts0 tree0))) where- go :: (Seq.Seq TestName -> OptionSet -> TestTree -> b)- go path opts tree1 =- case tree1 of- SingleTest name test- | testPatternMatches pat (path Seq.|> name)- -> fTest opts name test- | otherwise -> mempty- TestGroup name trees ->- fGroup opts name $ foldMap (go (path Seq.|> name) opts) trees- PlusTestOptions f tree -> go path (f opts) tree- WithResource res0 tree -> fResource opts res0 $ \res -> go path opts (tree res)- AskOptions f -> go path opts (f opts)- After deptype dep tree -> fAfter opts deptype dep $ go path opts tree- where- pat = lookupOption opts :: TestPattern+ go :: AnnTestTree OptionSet -> b+ go = \case+ AnnEmptyTestTree -> empty+ AnnSingleTest opts name test -> fTest opts name test+ AnnTestGroup opts name trees -> fGroup opts name (map go trees)+ AnnWithResource opts res0 tree -> fResource opts res0 $ \res -> go (tree res)+ AnnAfter opts deptype dep tree -> fAfter opts deptype dep (go tree)++-- | 'TestTree' with arbitrary annotations, e. g., evaluated 'OptionSet'.+data AnnTestTree ann+ = AnnEmptyTestTree+ -- ^ Just an empty test tree (e. g., when everything has been filtered out).+ | forall t . IsTest t => AnnSingleTest ann TestName t+ -- ^ Annotated counterpart of 'SingleTest'.+ | AnnTestGroup ann TestName [AnnTestTree ann]+ -- ^ Annotated counterpart of 'TestGroup'.+ | forall a . AnnWithResource ann (ResourceSpec a) (IO a -> AnnTestTree ann)+ -- ^ Annotated counterpart of 'WithResource'.+ | AnnAfter ann DependencyType Expr (AnnTestTree ann)+ -- ^ Annotated counterpart of 'After'.++-- | Annotate 'TestTree' with options, removing 'PlusTestOptions' and 'AskOptions' nodes.+evaluateOptions :: OptionSet -> TestTree -> AnnTestTree OptionSet+evaluateOptions opts = \case+ SingleTest name test ->+ AnnSingleTest opts name test+ TestGroup name trees ->+ AnnTestGroup opts name $ map (evaluateOptions opts) trees+ PlusTestOptions f tree ->+ evaluateOptions (f opts) tree+ WithResource res0 tree ->+ AnnWithResource opts res0 $ \res -> evaluateOptions opts (tree res)+ AskOptions f ->+ evaluateOptions opts (f opts)+ After deptype dep tree ->+ AnnAfter opts deptype dep $ evaluateOptions opts tree++-- | Annotate 'AnnTestTree' with paths.+annotatePath :: AnnTestTree OptionSet -> AnnTestTree (OptionSet, Path)+annotatePath = go mempty+ where+ go :: Seq.Seq TestName -> AnnTestTree OptionSet -> AnnTestTree (OptionSet, Path)+ go path = \case+ AnnEmptyTestTree -> AnnEmptyTestTree+ AnnSingleTest opts name tree -> + AnnSingleTest (opts, path |> name) name tree+ AnnTestGroup opts name trees ->+ let newPath = path |> name in+ AnnTestGroup (opts, newPath) name (map (go newPath) trees)+ AnnWithResource opts res0 tree ->+ AnnWithResource (opts, path) res0 $ \res -> go path (tree res)+ AnnAfter opts deptype dep tree ->+ AnnAfter (opts, path) deptype dep (go path tree)++-- | Filter test tree by pattern, replacing leafs with 'AnnEmptyTestTree'.+filterByPattern :: AnnTestTree (OptionSet, Path) -> AnnTestTree OptionSet+filterByPattern = snd . go (Any False)+ where+ go + :: ForceTestMatch+ -> AnnTestTree (OptionSet, Path)+ -> (TestMatched, AnnTestTree OptionSet)+ go forceMatch = \case+ AnnEmptyTestTree ->+ (Any False, AnnEmptyTestTree)++ AnnSingleTest (opts, path) name tree+ | getAny forceMatch || testPatternMatches (lookupOption opts) path+ -> (Any True, AnnSingleTest opts name tree)+ | otherwise + -> (Any False, AnnEmptyTestTree)++ AnnTestGroup (opts, _) name [] ->+ (forceMatch, AnnTestGroup opts name [])++ AnnTestGroup (opts, _) name trees ->+ case lookupOption opts of+ Parallel ->+ bimap+ mconcat+ (AnnTestGroup opts name)+ (unzip (map (go forceMatch) trees))+ Sequential _ ->+ second+ (AnnTestGroup opts name)+ (mapAccumR go forceMatch trees)++ AnnWithResource (opts, _) res0 tree ->+ ( fst (go forceMatch (tree (throwIO NotRunningTests)))+ , AnnWithResource opts res0 $ \res -> snd (go forceMatch (tree res))+ )++ AnnAfter (opts, _) deptype dep tree ->+ second+ (AnnAfter opts deptype dep)+ (go forceMatch tree) -- | Get the list of options that are relevant for a given test tree treeOptions :: TestTree -> [OptionDescription]
Test/Tasty/Ingredients.hs view
@@ -2,6 +2,8 @@ -- -- Ingredients themselves are provided by other modules (usually under -- the @Test.Tasty.Ingredients.*@ hierarchy).+--+-- @since 0.8 module Test.Tasty.Ingredients ( Ingredient(..) , tryIngredients@@ -68,15 +70,20 @@ -- what the result should be. When no tests are run, the result should -- probably be 'True'. Sometimes, even if some tests run and fail, it still -- makes sense to return 'True'.+--+-- @since 0.4 data Ingredient = TestReporter [OptionDescription] (OptionSet -> TestTree -> Maybe (StatusMap -> IO (Time -> IO Bool))) -- ^ For the explanation on how the callback works, see the -- documentation for 'launchTestTree'.+ --+ -- @since 0.10 | TestManager [OptionDescription] (OptionSet -> TestTree -> Maybe (IO Bool))+ -- ^ @since 0.4 -- | Try to run an 'Ingredient'. --@@ -96,6 +103,8 @@ -- -- If no one accepts the task, return 'Nothing'. This is usually a sign of -- misconfiguration.+--+-- @since 0.4 tryIngredients :: [Ingredient] -> OptionSet -> TestTree -> Maybe (IO Bool) tryIngredients ins opts tree = msum $ map (\i -> tryIngredient i opts tree) ins@@ -105,17 +114,23 @@ -- Note that this isn't the same as simply pattern-matching on -- 'Ingredient'. E.g. options for a 'TestReporter' automatically include -- 'NumThreads'.+--+-- @since 0.4 ingredientOptions :: Ingredient -> [OptionDescription] ingredientOptions (TestReporter opts _) = Option (Proxy :: Proxy NumThreads) : opts ingredientOptions (TestManager opts _) = opts -- | Like 'ingredientOptions', but folds over multiple ingredients.+--+-- @since 0.4 ingredientsOptions :: [Ingredient] -> [OptionDescription] ingredientsOptions = uniqueOptionDescriptions . F.foldMap ingredientOptions -- | All the options relevant for this test suite. This includes the -- options for the test tree and ingredients, and the core options.+--+-- @since 0.4 suiteOptions :: [Ingredient] -> TestTree -> [OptionDescription] suiteOptions ins tree = uniqueOptionDescriptions $ coreOptions ++@@ -129,6 +144,8 @@ -- -- Be aware that it is not possible to use 'composeReporters' with a 'TestManager', -- it only works for 'TestReporter' ingredients.+--+-- @since 0.11.2 composeReporters :: Ingredient -> Ingredient -> Ingredient composeReporters (TestReporter o1 f1) (TestReporter o2 f2) = TestReporter (o1 ++ o2) $ \o t ->
Test/Tasty/Ingredients/Basic.hs view
@@ -3,6 +3,8 @@ -- -- Note that if 'Test.Tasty.defaultIngredients' from "Test.Tasty" suits your needs, -- use that instead of importing this module.+--+-- @since 0.8 module Test.Tasty.Ingredients.Basic ( -- ** Console test reporter
Test/Tasty/Ingredients/ConsoleReporter.hs view
@@ -1,11 +1,14 @@ -- vim:fdm=marker-{-# LANGUAGE BangPatterns, ImplicitParams, MultiParamTypeClasses, DeriveDataTypeable, FlexibleContexts, CApiFFI #-}--- | Console reporter ingredient+{-# LANGUAGE BangPatterns, ImplicitParams, MultiParamTypeClasses, DeriveDataTypeable, FlexibleContexts, CApiFFI, NamedFieldPuns #-}+-- | Console reporter ingredient.+--+-- @since 0.11.3 module Test.Tasty.Ingredients.ConsoleReporter ( consoleTestReporter , consoleTestReporterWithHook , Quiet(..) , HideSuccesses(..)+ , MinDurationToReport(..) , AnsiTricks(..) -- * Internals -- | The following functions and datatypes are internals that are exposed to@@ -73,20 +76,33 @@ -- -- @since 0.12 data TestOutput- = PrintTest- {- test name -} String- {- print test name -} (IO ())- {- print test result -} (Result -> IO ())- -- ^ Name of a test, an action that prints the test name, and an action- -- that renders the result of the action.- | PrintHeading String (IO ()) TestOutput- -- ^ Name of a test group, an action that prints the heading of a test- -- group and the 'TestOutput' for that test group.- | Skip -- ^ Inactive test (e.g. not matching the current pattern)- | Seq TestOutput TestOutput -- ^ Two sets of 'TestOutput' on the same level+ = -- | Printing a test.+ PrintTest+ String+ -- ^ Name of the test.+ (IO ())+ -- ^ Action that prints the test name.+ (Progress -> IO ())+ -- ^ Action that prints the progress of the test. /Since: 1.5/+ (Result -> IO ())+ -- ^ Action that renders the result of the test.+ | -- | Printing a test group.+ PrintHeading+ String+ -- ^ Name of the test group+ (IO ())+ -- ^ Action that prints the heading of a test group.+ TestOutput+ -- ^ The 'TestOutput' for that test group.+ | -- | Inactive test (e.g. not matching the current pattern).+ Skip+ | -- | Two sets of 'TestOutput' on the same level.+ Seq TestOutput TestOutput -- The monoid laws should hold observationally w.r.t. the semantics defined--- in this module+-- in this module.+--+-- @since 0.12.0.1 instance Sem.Semigroup TestOutput where (<>) = Seq instance Monoid TestOutput where@@ -98,8 +114,8 @@ applyHook :: ([TestName] -> Result -> IO Result) -> TestOutput -> TestOutput applyHook hook = go [] where- go path (PrintTest name printName printResult) =- PrintTest name printName (printResult <=< hook (name : path))+ go path (PrintTest name printName printProgress printResult) =+ PrintTest name printName printProgress (printResult <=< hook (name : path)) go path (PrintHeading name printName printBody) = PrintHeading name printName (go (name : path) printBody) go path (Seq a b) = Seq (go path a) (go path b)@@ -117,6 +133,9 @@ -- Do not retain the reference to the tree more than necessary !alignment = computeAlignment opts tree + MinDurationToReport{minDurationMicros} = lookupOption opts+ AnsiTricks{getAnsiTricks} = lookupOption opts+ runSingleTest :: (IsTest t, ?colors :: Bool) => OptionSet -> TestName -> t -> Ap (Reader Level) TestOutput@@ -124,11 +143,40 @@ level <- ask let+ indentedNameWidth = indentSize * level + stringWidth name+ postNamePadding = alignment - indentedNameWidth++ testNamePadded = printf "%s%s: %s"+ (indent level)+ name+ (replicate postNamePadding ' ')++ resultPosition = length testNamePadded+ printTestName = do- printf "%s%s: %s" (indent level) name- (replicate (alignment - indentSize * level - stringWidth name) ' ')+ putStr testNamePadded hFlush stdout + printTestProgress progress+ -- We cannot display progress properly if a terminal+ -- does not support manipulations with cursor position.+ | not getAnsiTricks = pure ()++ | progress == emptyProgress = pure ()++ | otherwise = do+ let+ msg = case (cleanupProgressText $ progressText progress, 100 * progressPercent progress) of+ ("", pct) -> printf "%.0f%% " pct+ (txt, 0.0) -> printf "%s" txt+ (txt, pct) -> printf "%s: %.0f%% " txt pct+ setCursorColumn resultPosition+ infoOk msg+ -- A new progress message may be shorter than the previous one+ -- so we must clean until the end of the line+ clearFromCursorToLineEnd+ hFlush stdout+ printTestResult result = do rDesc <- formatMessage $ resultDescription result @@ -140,9 +188,13 @@ Failure TestDepFailed -> skipped _ -> fail time = resultTime result++ when getAnsiTricks $ do+ setCursorColumn resultPosition+ clearFromCursorToLineEnd+ printFn (resultShortDescription result)- -- print time only if it's significant- when (time >= 0.01) $+ when (floor (time * 1e6) >= minDurationMicros) $ printFn (printf " (%.2fs)" time) printFn "\n" @@ -152,14 +204,14 @@ case resultDetailsPrinter result of ResultDetailsPrinter action -> action level withConsoleFormat - return $ PrintTest name printTestName printTestResult+ return $ PrintTest name printTestName printTestProgress printTestResult - runGroup :: OptionSet -> TestName -> Ap (Reader Level) TestOutput -> Ap (Reader Level) TestOutput+ runGroup :: OptionSet -> TestName -> [Ap (Reader Level) TestOutput] -> Ap (Reader Level) TestOutput runGroup _opts name grp = Ap $ do level <- ask let printHeading = printf "%s%s\n" (indent level) name- printBody = runReader (getApp grp) (level + 1)+ printBody = runReader (getApp (mconcat grp)) (level + 1) return $ PrintHeading name printHeading printBody in@@ -171,6 +223,13 @@ } opts tree +-- | Make sure the progress text does not contain any newlines or line feeds,+-- lest our ANSI magic breaks. Since the progress text is expected to be short,+-- we simply drop anything after a newline.+cleanupProgressText :: String -> String+cleanupProgressText = map (\c -> if isSpace c then ' ' else c)+ . takeWhile (\c -> c /= '\n' && c /= '\r' && c /= '\t')+ -- | Fold function for the 'TestOutput' tree into a 'Monoid'. -- -- @since 0.12@@ -188,15 +247,17 @@ -> b foldTestOutput foldTest foldHeading outputTree smap = flip evalState 0 $ getApp $ go outputTree where- go (PrintTest name printName printResult) = Ap $ do++ go (PrintTest name printName printProgress printResult) = Ap $ do ix <- get put $! ix + 1 let statusVar = fromMaybe (error "internal error: index out of bounds") $ IntMap.lookup ix smap- readStatusVar = getResultFromTVar statusVar- return $ foldTest name printName readStatusVar printResult++ return $ foldTest name printName (ppProgressOrResult statusVar printProgress) printResult+ go (PrintHeading name printName printBody) = Ap $ foldHeading name printName <$> getApp (go printBody) go (Seq a b) = mappend (go a) (go b)@@ -207,6 +268,19 @@ -------------------------------------------------- -- TestOutput modes --------------------------------------------------++ppProgressOrResult :: TVar Status -> (Progress -> IO ()) -> IO Result+ppProgressOrResult statusVar ppProgress = go emptyProgress where+ go old_p = either (\p -> ppProgress p *> go p) return =<< (atomically $ do+ status <- readTVar statusVar+ case status of+ Executing p+ | p == old_p -> retry+ | otherwise -> pure $ Left p+ Done r -> pure $ Right r+ _ -> retry+ )+ -- {{{ consoleOutput :: (?colors :: Bool) => TestOutput -> StatusMap -> IO () consoleOutput toutput smap =@@ -220,7 +294,8 @@ , Any True) foldHeading _name printHeading (printBody, Any nonempty) = ( Traversal $ do- when nonempty $ do printHeading :: IO (); getTraversal printBody+ when nonempty $ printHeading+ getTraversal printBody , Any nonempty ) @@ -296,6 +371,7 @@ , statFailures :: !Int -- ^ Number of active tests that failed. } +-- | @since 0.12.0.1 instance Sem.Semigroup Statistics where Statistics t1 f1 <> Statistics t2 f2 = Statistics (t1 + t2) (f1 + f2) instance Monoid Statistics where@@ -306,7 +382,9 @@ -- | @computeStatistics@ computes a summary 'Statistics' for -- a given state of the 'StatusMap'.--- Useful in combination with @printStatistics@+-- Useful in combination with 'printStatistics'.+--+-- @since 1.2.3 computeStatistics :: StatusMap -> IO Statistics computeStatistics = getApp . foldMap (\var -> Ap $ (\r -> Statistics 1 (if resultSuccessful r then 0 else 1))@@ -395,7 +473,9 @@ -------------------------------------------------- -- {{{ --- | A simple console UI+-- | A simple console UI.+--+-- @since 0.4 consoleTestReporter :: Ingredient consoleTestReporter = TestReporter consoleTestReporterOptions $ \opts tree -> let@@ -434,6 +514,7 @@ consoleTestReporterOptions = [ Option (Proxy :: Proxy Quiet) , Option (Proxy :: Proxy HideSuccesses)+ , Option (Proxy :: Proxy MinDurationToReport) , Option (Proxy :: Proxy UseColor) , Option (Proxy :: Proxy AnsiTricks) ]@@ -476,7 +557,11 @@ ?colors = useColor whenColor isTermColor let- toutput = applyHook hook $ buildTestOutput opts tree+ -- 'buildTestOutput' is a pure function and cannot query 'hSupportsANSI' itself.+ -- We also would rather not pass @isTerm@ as an extra argument,+ -- since it's a breaking change, thus resorting to tweaking @opts@.+ opts' = changeOption (\(AnsiTricks x) -> AnsiTricks (x && isTerm)) opts+ toutput = applyHook hook $ buildTestOutput opts' tree case () of { _ | hideSuccesses && isTerm && ansiTricks ->@@ -491,7 +576,9 @@ printStatistics stats time return $ statFailures stats == 0 --- | Do not print test results (see README for details)+-- | Do not print test results (see README for details).+--+-- @since 0.8 newtype Quiet = Quiet Bool deriving (Eq, Ord, Typeable) instance IsOption Quiet where@@ -505,6 +592,8 @@ -- -- At the moment, this option only works globally. As an argument -- to 'Test.Tasty.localOption', it does nothing.+--+-- @since 0.8 newtype HideSuccesses = HideSuccesses Bool deriving (Eq, Ord, Typeable) instance IsOption HideSuccesses where@@ -514,6 +603,23 @@ optionHelp = return "Do not print tests that passed successfully" optionCLParser = mkFlagCLParser mempty (HideSuccesses True) +-- | The minimum amount of time a test can take before tasty+-- prints timing information.+--+-- @since 1.5+newtype MinDurationToReport = MinDurationToReport { minDurationMicros :: Integer }+ deriving (Eq, Ord, Typeable)+instance IsOption MinDurationToReport where+ defaultValue = MinDurationToReport 10000+ parseValue = fmap MinDurationToReport . parseDuration+ optionName = return "min-duration-to-report"+ optionHelp =+ return . unwords $+ [ "The minimum amount of time a test can take before tasty prints timing information"+ , "(suffixes: ms,s,m,h; default: s)"+ ]+ optionCLParser = mkOptionCLParser (metavar "DURATION")+ -- | When to use color on the output -- -- @since 0.11.3@@ -546,6 +652,8 @@ -- -- When that happens, this option can be used to disable the tricks. In -- that case, the test name will be printed only once the test fails.+--+-- @since 1.3 newtype AnsiTricks = AnsiTricks { getAnsiTricks :: Bool } deriving Typeable @@ -662,7 +770,7 @@ foldTestTree trivialFold { foldSingle = \_ name _ level -> Maximum (stringWidth name + level)- , foldGroup = \_opts _ m -> m . (+ indentSize)+ , foldGroup = \_opts _ m -> mconcat m . (+ indentSize) } opts where@@ -694,7 +802,9 @@ fail = output failFormat ok = output okFormat skipped = output skippedFormat-infoOk = output infoOkFormat+-- Just default foreground color for 'infoOk'; do not apply 'infoOkFormat',+-- because terminal's background could be white itself. See #298.+infoOk = putStr infoFail = output infoFailFormat output
Test/Tasty/Ingredients/IncludingOptions.hs view
@@ -8,5 +8,7 @@ -- options. -- -- The option values can be accessed using 'Test.Tasty.askOption'.+--+-- @since 0.6 includingOptions :: [OptionDescription] -> Ingredient includingOptions opts = TestManager opts (\_ _ -> Nothing)
Test/Tasty/Ingredients/ListTests.hs view
@@ -15,7 +15,9 @@ import Test.Tasty.Ingredients -- | This option, when set to 'True', specifies that we should run in the--- «list tests» mode+-- «list tests» mode.+--+-- @since 0.4 newtype ListTests = ListTests Bool deriving (Eq, Ord, Typeable) instance IsOption ListTests where@@ -25,16 +27,20 @@ optionHelp = return "Do not run the tests; just print their names" optionCLParser = mkFlagCLParser (short 'l') (ListTests True) --- | Obtain the list of all tests in the suite+-- | Obtain the list of all tests in the suite.+--+-- @since 0.4 testsNames :: OptionSet -> TestTree -> [TestName] testsNames {- opts -} {- tree -} = foldTestTree trivialFold { foldSingle = \_opts name _test -> [name]- , foldGroup = \_opts groupName names -> map ((groupName ++ ".") ++) names+ , foldGroup = \_opts groupName names -> map ((groupName ++ ".") ++) (concat names) } --- | The ingredient that provides the test listing functionality+-- | The ingredient that provides the test listing functionality.+--+-- @since 0.4 listingTests :: Ingredient listingTests = TestManager [Option (Proxy :: Proxy ListTests)] $ \opts tree ->
Test/Tasty/Options.hs view
@@ -4,6 +4,8 @@ TypeOperators #-} -- | Extensible options. They are used for provider-specific settings, -- ingredient-specific settings and core settings (such as the test name pattern).+--+-- @since 0.1 module Test.Tasty.Options ( -- * IsOption class@@ -39,6 +41,8 @@ import Options.Applicative -- | An option is a data type that inhabits the `IsOption` type class.+--+-- @since 0.1 class Typeable v => IsOption v where -- | The value to use if the option was not supplied explicitly defaultValue :: v@@ -56,6 +60,8 @@ -- (the default implementation) will result in nothing being displayed, while -- @'Just' def@ will result in @def@ being advertised as the default in the -- help string.+ --+ -- @since 1.3 showDefaultValue :: v -> Maybe String showDefaultValue _ = Nothing -- | A command-line option parser.@@ -81,8 +87,6 @@ -- So, when we build the complete parser for OptionSet, we turn a -- failing parser into an always-succeeding one that may return an empty -- OptionSet.)- --- -- @since 1.3 optionCLParser :: Parser v optionCLParser = mkOptionCLParser mempty @@ -92,9 +96,13 @@ -- | A set of options. Only one option of each type can be kept. -- -- If some option has not been explicitly set, the default value is used.+--+-- @since 0.1 newtype OptionSet = OptionSet (Map TypeRep OptionValue) --- | Later options override earlier ones+-- | Later options override earlier ones.+--+-- @since 0.12.0.1 instance Sem.Semigroup OptionSet where OptionSet a <> OptionSet b = OptionSet $ Map.unionWith (flip const) a b@@ -104,12 +112,16 @@ mappend = (Sem.<>) #endif --- | Set the option value+-- | Set the option value.+--+-- @since 0.1 setOption :: IsOption v => v -> OptionSet -> OptionSet setOption v (OptionSet s) = OptionSet $ Map.insert (typeOf v) (OptionValue v) s --- | Query the option value+-- | Query the option value.+--+-- @since 0.1 lookupOption :: forall v . IsOption v => OptionSet -> v lookupOption (OptionSet s) = case Map.lookup (typeOf (undefined :: v)) s of@@ -117,20 +129,26 @@ Just {} -> error "OptionSet: broken invariant (shouldn't happen)" Nothing -> defaultValue --- | Change the option value+-- | Change the option value.+--+-- @since 0.1 changeOption :: forall v . IsOption v => (v -> v) -> OptionSet -> OptionSet changeOption f s = setOption (f $ lookupOption s) s --- | Create a singleton 'OptionSet'+-- | Create a singleton 'OptionSet'.+--+-- @since 0.8 singleOption :: IsOption v => v -> OptionSet singleOption v = setOption v mempty -- | The purpose of this data type is to capture the dictionary -- corresponding to a particular option.+--+-- @since 0.1 data OptionDescription where Option :: IsOption v => Proxy v -> OptionDescription --- | Remove duplicated 'OptionDescription', preserving existing order otherwise+-- | Remove duplicated 'OptionDescription', preserving existing order otherwise. -- -- @since 1.4.1 uniqueOptionDescriptions :: [OptionDescription] -> [OptionDescription]@@ -141,7 +159,9 @@ | typeOf o `S.member` acc = go acc os | otherwise = Option o : go (S.insert (typeOf o) acc) os --- | Command-line parser to use with flags+-- | Command-line parser to use with flags.+--+-- @since 0.8 flagCLParser :: forall v . IsOption v => Maybe Char -- ^ optional short flag@@ -150,6 +170,8 @@ flagCLParser mbShort = mkFlagCLParser (foldMap short mbShort) -- | Command-line flag parser that takes additional option modifiers.+--+-- @since 0.11.1 mkFlagCLParser :: forall v . IsOption v => Mod FlagFields v -- ^ option modifier@@ -162,6 +184,8 @@ ) -- | Command-line option parser that takes additional option modifiers.+--+-- @since 0.11.1 mkOptionCLParser :: forall v . IsOption v => Mod OptionFields v -> Parser v mkOptionCLParser mod = option parse@@ -170,18 +194,27 @@ <> mod ) where+ name :: String name = untag (optionName :: Tagged v String)- parse = str >>=- maybe (readerError $ "Could not parse " ++ name) pure <$> parseValue + parse :: ReadM v+ parse = do+ s <- str+ let err = "Could not parse: " ++ s ++ " is not a valid " ++ name+ maybe (readerError err) pure (parseValue s)+ -- | Safe read function. Defined here for convenience to use for -- 'parseValue'.+--+-- @since 0.1 safeRead :: Read a => String -> Maybe a safeRead s | [(x, "")] <- reads s = Just x | otherwise = Nothing --- | Parse a 'Bool' case-insensitively+-- | Parse a 'Bool' case-insensitively.+--+-- @since 1.0.1 safeReadBool :: String -> Maybe Bool safeReadBool s = case (map toLower s) of
Test/Tasty/Options/Core.hs view
@@ -5,7 +5,10 @@ ( NumThreads(..) , Timeout(..) , mkTimeout+ , HideProgress(..) , coreOptions+ -- * Helpers+ , parseDuration ) where @@ -30,6 +33,8 @@ -- 'Test.Tasty.Ingredients.ingredientOptions', because the way test -- reporters are handled already involves parallelism. Other ingredients -- may also choose to include this option.+--+-- @since 0.1 newtype NumThreads = NumThreads { getNumThreads :: Int } deriving (Eq, Ord, Num, Typeable) instance IsOption NumThreads where@@ -44,7 +49,9 @@ onlyPositive :: NumThreads -> Bool onlyPositive (NumThreads x) = x > 0 --- | Timeout to be applied to individual tests+-- | Timeout to be applied to individual tests.+--+-- @since 0.8 data Timeout = Timeout Integer String -- ^ 'String' is the original representation of the timeout (such as@@ -57,14 +64,16 @@ defaultValue = NoTimeout parseValue str = Timeout- <$> parseTimeout str+ <$> parseDuration str <*> pure str optionName = return "timeout" optionHelp = return "Timeout for individual tests (suffixes: ms,s,m,h; default: s)" optionCLParser = mkOptionCLParser (short 't' <> metavar "DURATION") -parseTimeout :: String -> Maybe Integer-parseTimeout str =+-- | Parses a suffixed duration (e.g. "10s") to an Integer representing+-- number of microseconds.+parseDuration :: String -> Maybe Integer+parseDuration str = -- it sucks that there's no more direct way to convert to a number of -- microseconds (round :: Micro -> Integer) . (* 10^6) <$>@@ -79,7 +88,9 @@ _ -> Nothing _ -> Nothing --- | A shortcut for creating 'Timeout' values+-- | A shortcut for creating 'Timeout' values.+--+-- @since 0.8 mkTimeout :: Integer -- ^ microseconds -> Timeout@@ -87,11 +98,29 @@ Timeout n $ showFixed True (fromInteger n / (10^6) :: Micro) ++ "s" +-- | Hide progress information. If progress disabled, the test launcher+-- 'Test.Tasty.Runners.launchTestTree' completely ignores callbacks to update progress.+-- If enabled, it's up to individual 'Test.Tasty.Ingredients.TestReporter's+-- how to execute, some might not be able to render progress anyways.+--+-- @since 1.5+newtype HideProgress = HideProgress { getHideProgress :: Bool }+ deriving (Eq, Ord, Typeable)+instance IsOption HideProgress where+ defaultValue = HideProgress False+ parseValue = fmap HideProgress . safeReadBool+ optionName = return "hide-progress"+ optionHelp = return "Do not show progress"+ optionCLParser = mkFlagCLParser mempty (HideProgress True)+ -- | The list of all core options, i.e. the options not specific to any -- provider or ingredient, but to tasty itself. Currently contains -- 'TestPattern' and 'Timeout'.+--+-- @since 0.1 coreOptions :: [OptionDescription] coreOptions = [ Option (Proxy :: Proxy TestPattern) , Option (Proxy :: Proxy Timeout)+ , Option (Proxy :: Proxy HideProgress) ]
Test/Tasty/Patterns.hs view
@@ -1,6 +1,6 @@ -- | Test patterns -{-# LANGUAGE CPP, DeriveDataTypeable #-}+{-# LANGUAGE CPP, DeriveDataTypeable, TypeApplications #-} module Test.Tasty.Patterns ( TestPattern(..)@@ -18,42 +18,62 @@ import Test.Tasty.Patterns.Eval import Data.Char+import Data.Coerce (coerce)+import Data.List.NonEmpty (nonEmpty)+import Data.Maybe (catMaybes) import Data.Typeable import Options.Applicative hiding (Success) #if !MIN_VERSION_base(4,11,0) import Data.Monoid #endif -newtype TestPattern = TestPattern (Maybe Expr)- deriving (Typeable, Show, Eq)+-- | @since 1.0+newtype TestPattern =+ -- | @since 1.1+ TestPattern+ (Maybe Expr)+ deriving+ ( Typeable+ , Show -- ^ @since 1.1+ , Eq -- ^ @since 1.1+ ) +-- | @since 1.0 noPattern :: TestPattern noPattern = TestPattern Nothing +-- | Since tasty-1.5, this option can be specified multiple times on the+-- command line. Only the tests matching all given patterns will be selected. instance IsOption TestPattern where defaultValue = noPattern parseValue = parseTestPattern optionName = return "pattern" optionHelp = return "Select only tests which satisfy a pattern or awk expression"- optionCLParser = mkOptionCLParser (short 'p' <> metavar "PATTERN")+ optionCLParser =+ fmap (TestPattern . fmap (foldr1 And) . nonEmpty . catMaybes . coerce @[TestPattern]) . some $+ mkOptionCLParser (short 'p' <> metavar "PATTERN") +-- | @since 1.2 parseExpr :: String -> Maybe Expr parseExpr s | all (\c -> isAlphaNum c || c `elem` "._- ") s = Just $ ERE s | otherwise = parseAwkExpr s +-- | @since 1.0 parseTestPattern :: String -> Maybe TestPattern parseTestPattern s | null s = Just noPattern | otherwise = TestPattern . Just <$> parseExpr s +-- | @since 1.2 exprMatches :: Expr -> Path -> Bool exprMatches e fields = case withFields fields $ asB =<< eval e of Left msg -> error msg Right b -> b +-- | @since 1.0 testPatternMatches :: TestPattern -> Path -> Bool testPatternMatches pat fields = case pat of
Test/Tasty/Patterns/Eval.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE RankNTypes, ViewPatterns #-}+-- | @since 1.0 module Test.Tasty.Patterns.Eval (Path, eval, withFields, asB) where import Prelude hiding (Ordering(..))@@ -16,6 +17,7 @@ import Data.Traversable #endif +-- | @since 1.2 type Path = Seq.Seq String data Value@@ -68,6 +70,7 @@ VS b s -> b && isJust (parseN s) _ -> True +-- | @since 1.0 asB :: Value -> M Bool asB v = return $ case v of@@ -78,7 +81,9 @@ fromB :: Bool -> Value fromB = VN . fromEnum --- | Evaluate an awk expression+-- | Evaluate an awk expression.+--+-- @since 1.0 eval :: Expr -> M Value eval e0 = case e0 of@@ -156,6 +161,8 @@ -- | Run the @M@ monad with a given list of fields -- -- The field list should not include @$0@; it's calculated automatically.+--+-- @since 1.0 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/Parser.hs view
@@ -1,6 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | See <http://pubs.opengroup.org/onlinepubs/9699919799/utilities/awk.html> for the -- full awk grammar.+--+-- @since 1.0 module Test.Tasty.Patterns.Parser ( Parser , runParser@@ -25,11 +27,17 @@ -- | A separate 'Parser' data type ensures that we don't forget to skip -- spaces.+--+-- @since 1.0 newtype Parser a = Parser (ReadP a) deriving (Functor, Applicative, Alternative, Monad, MonadPlus) +-- | @since 1.0 data ParseResult a = Success a | Invalid | Ambiguous [a]- deriving (Eq, Show)+ deriving+ ( Show+ , Eq -- ^ @since 1.4.2+ ) token :: Token a -> Parser a token a = Parser (a <* skipSpaces)@@ -41,6 +49,8 @@ str = void . token . string -- | Run a parser+--+-- @since 1.0 runParser :: Parser a -> String -- ^ text to parse@@ -168,11 +178,15 @@ , [ TernR ((If <$ sym ':') <$ sym '?') ] ] --- | The awk-like expression parser+-- | The awk-like expression parser.+--+-- @since 1.0 expr :: Parser Expr expr = expr4 --- | Parse an awk expression+-- | Parse an awk expression.+--+-- @since 1.1 parseAwkExpr :: String -> Maybe Expr parseAwkExpr s = case runParser expr s of
Test/Tasty/Patterns/Printer.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-}+-- | @since 1.4.2 module Test.Tasty.Patterns.Printer ( printAwkExpr
Test/Tasty/Patterns/Types.hs view
@@ -1,9 +1,11 @@ {-# LANGUAGE DeriveGeneric #-}+-- | @since 1.0 module Test.Tasty.Patterns.Types where import GHC.Generics +-- | @since 1.0 data Expr = IntLit !Int | NF -- ^ number of fields@@ -31,4 +33,8 @@ | LengthFn (Maybe Expr) | MatchFn Expr String | SubstrFn Expr Expr (Maybe Expr)- deriving (Show, Eq, Generic)+ deriving+ ( Show+ , Eq -- ^ @since 1.1+ , Generic -- ^ @since 1.4.2+ )
Test/Tasty/Providers.hs view
@@ -1,4 +1,6 @@--- | API for test providers+-- | API for test providers.+--+-- @since 0.1 module Test.Tasty.Providers ( IsTest(..) , testPassed@@ -15,11 +17,15 @@ import Test.Tasty.Core import Test.Tasty.Providers.ConsoleFormat (ResultDetailsPrinter, noResultDetails) --- | Convert a test to a leaf of the 'TestTree'+-- | Convert a test to a leaf of the 'TestTree'.+--+-- @since 0.1 singleTest :: IsTest t => TestName -> t -> TestTree singleTest = SingleTest --- | 'Result' of a passed test+-- | 'Result' of a passed test.+--+-- @since 0.8 testPassed :: String -- ^ description (may be empty) -> Result@@ -31,7 +37,9 @@ , resultDetailsPrinter = noResultDetails } --- | 'Result' of a failed test+-- | 'Result' of a failed test.+--+-- @since 0.8 testFailed :: String -- ^ description -> Result
Test/Tasty/Providers/ConsoleFormat.hs view
@@ -63,9 +63,9 @@ failFormat = ConsoleFormat BoldIntensity Vivid Red -- | Format used to display additional information on failures-infoFailFormat :: ConsoleFormat -- -- @since 1.3.1+infoFailFormat :: ConsoleFormat infoFailFormat = ConsoleFormat NormalIntensity Dull Red -- | Format used to display sucesses
Test/Tasty/Run.hs view
@@ -1,6 +1,7 @@ -- | Running tests {-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes,- FlexibleContexts, BangPatterns, CPP, DeriveDataTypeable #-}+ FlexibleContexts, CPP, DeriveDataTypeable, LambdaCase,+ RecordWildCards, NamedFieldPuns #-} module Test.Tasty.Run ( Status(..) , StatusMap@@ -13,13 +14,14 @@ import qualified Data.Foldable as F import Data.Int (Int64) import Data.Maybe+import Data.List (intercalate) import Data.Graph (SCC(..), stronglyConnComp)+import Data.Sequence (Seq, (|>), (<|), (><)) import Data.Typeable import Control.Monad (forever, guard, join, liftM) import Control.Monad.IO.Class (liftIO)-import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Reader (ReaderT(..), local, ask)-import Control.Monad.Trans.Writer (WriterT(..), execWriterT, mapWriterT, tell)+import Control.Monad.Trans.Writer (execWriterT, tell) import Control.Concurrent import Control.Concurrent.STM import Control.Concurrent.Async@@ -30,6 +32,10 @@ import GHC.Conc (labelThread) import Prelude -- Silence AMP and FTP import warnings +#if MIN_VERSION_base(4,18,0)+import Data.Traversable (mapAccumM)+#endif+ #ifdef MIN_VERSION_unbounded_delays import Control.Concurrent.Timeout (timeout) #else@@ -46,7 +52,9 @@ import Test.Tasty.Runners.Utils (timed, forceElements) import Test.Tasty.Providers.ConsoleFormat (noResultDetails) --- | Current status of a test+-- | Current status of a test.+--+-- @since 0.1 data Status = NotStarted -- ^ test has not started running yet@@ -54,12 +62,16 @@ -- ^ test is being run | Done Result -- ^ test finished with a given result- deriving Show+ deriving+ ( Show -- ^ @since 1.2+ ) -- | Mapping from test numbers (starting from 0) to their status variables. -- -- This is what an ingredient uses to analyse and display progress, and to -- detect when tests finish.+--+-- @since 0.1 type StatusMap = IntMap.IntMap (TVar Status) data Resource r@@ -96,11 +108,12 @@ -- a parameter -> TVar Status -- ^ variable to write status to -> Timeout -- ^ optional timeout to apply- -> Seq.Seq Initializer -- ^ initializers (to be executed in this order)- -> Seq.Seq Finalizer -- ^ finalizers (to be executed in this order)+ -> HideProgress -- ^ hide progress option+ -> Seq Initializer -- ^ initializers (to be executed in this order)+ -> Seq Finalizer -- ^ finalizers (to be executed in this order) -> IO ()-executeTest action statusVar timeoutOpt inits fins = mask $ \restore -> do- resultOrExn <- try $ restore $ do+executeTest action statusVar timeoutOpt hideProgressOpt inits fins = mask $ \restore -> do+ resultOrExn <- try . restore $ do -- N.B. this can (re-)throw an exception. It's okay. By design, the -- actual test will not be run, then. We still run all the -- finalizers.@@ -110,10 +123,15 @@ -- anyway. initResources + let+ cursorMischiefManaged = do+ atomically $ writeTVar statusVar (Executing emptyProgress)+ action yieldProgress+ -- If all initializers ran successfully, actually run the test. -- We run it in a separate thread, so that the test's exception -- handler doesn't interfere with our timeout.- withAsync (action yieldProgress) $ \asy -> do+ withAsync cursorMischiefManaged $ \asy -> do labelThread (asyncThreadId asy) "tasty_test_execution_thread" timed $ applyTimeout timeoutOpt $ do r <- wait asy@@ -128,7 +146,7 @@ -- no matter what, try to run each finalizer mbExn <- destroyResources restore - atomically . writeTVar statusVar $ Done $+ atomically . writeTVar statusVar . Done $ case resultOrExn <* maybe (Right ()) Left mbExn of Left ex -> exceptionResult ex Right (t,r) -> r { resultTime = t }@@ -206,119 +224,247 @@ tell $ First mbExcn - -- The callback- -- Since this is not used yet anyway, disable for now.- -- I'm not sure whether we should get rid of this altogether. For most- -- providers this is either difficult to implement or doesn't make- -- sense at all.- -- See also https://github.com/UnkindPartition/tasty/issues/33- yieldProgress _ = return ()--type InitFinPair = (Seq.Seq Initializer, Seq.Seq Finalizer)---- | Dependencies of a test-type Deps = [(DependencyType, Expr)]+ yieldProgress _newP | getHideProgress hideProgressOpt =+ pure ()+ yieldProgress newP | newP == emptyProgress =+ -- This could be changed to `Maybe Progress` to lets more easily indicate+ -- when progress should try to be printed ?+ pure ()+ yieldProgress newP = liftIO+ . atomically+ . writeTVar statusVar+ $ Executing newP -- | Traversal type used in 'createTestActions'-type Tr = Traversal- (WriterT ([(InitFinPair -> IO (), (TVar Status, Path, Deps))], Seq.Seq Finalizer)- (ReaderT (Path, Deps)- IO))+type Tr = ReaderT (Path, Seq Dependency) IO (TestActionTree UnresolvedAction) -- | Exceptions related to dependencies between tests.-data DependencyException- = DependencyLoop- -- ^ Test dependencies form a loop. In other words, test A cannot start+--+-- @since 1.2+newtype DependencyException+ = DependencyLoop [[Path]]+ -- ^ Test dependencies form cycles. In other words, test A cannot start -- until test B finishes, and test B cannot start until test- -- A finishes.+ -- A finishes. Field lists detected cycles.+ --+ -- @since 1.5 deriving (Typeable) instance Show DependencyException where- show DependencyLoop = "Test dependencies form a loop."+ show (DependencyLoop css) = "Test dependencies have cycles:\n" ++ showCycles css+ where+ showCycles = intercalate "\n" . map showCycle+ showPath = intercalate "." . F.toList + -- For clarity in the error message, the first element is repeated at the end+ showCycle [] = "- <empty cycle>"+ showCycle (x:xs) = "- " ++ intercalate ", " (map showPath (x:xs ++ [x]))+ instance Exception DependencyException +-- | Specifies how to calculate a dependency+data DependencySpec+ = ExactDep (Seq TestName) (TVar Status)+ -- ^ Dependency specified by 'TestGroup'. Note that the first field is only+ -- there for dependency cycle detection - which can be introduced by using+ -- 'PatternDep'.+ | PatternDep Expr+ -- ^ All tests matching this 'Expr' should be considered dependencies+ deriving (Eq)++instance Show DependencySpec where+ show (PatternDep dep) = "PatternDep (" ++ show dep ++ ")"+ show (ExactDep testName _) = "ExactDep (" ++ show testName ++ ") (<TVar>)"++-- | Dependency of a test. Either it points to an exact path it depends on, or+-- contains a pattern that should be tested against all tests in a 'TestTree'.+data Dependency = Dependency DependencyType DependencySpec+ deriving (Eq, Show)++-- | Is given 'Dependency' a dependency that was introduced with 'After'?+isPatternDependency :: Dependency -> Bool+isPatternDependency (Dependency _ (PatternDep {})) = True+isPatternDependency _ = False++#if !MIN_VERSION_base(4,18,0)+-- The mapAccumM function behaves like a combination of mapM and mapAccumL that+-- traverses the structure while evaluating the actions and passing an accumulating+-- parameter from left to right. It returns a final value of this accumulator+-- together with the new structure. The accummulator is often used for caching the+-- intermediate results of a computation.+mapAccumM :: Monad m => (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])+mapAccumM _ acc [] = return (acc, [])+mapAccumM f acc (x:xs) = do+ (acc', y) <- f acc x+ (acc'', ys) <- mapAccumM f acc' xs+ return (acc'', y:ys)+#endif++-- | An action with meta information+data TestAction act = TestAction+ { testAction :: act+ -- ^ Some action, typically 'UnresolvedAction', 'ResolvedAction', or 'Action'.+ , testPath :: Path+ -- ^ Path pointing to this action (a series of group names + a test name)+ , testDeps :: Seq Dependency+ -- ^ Dependencies introduced by AWK-like patterns+ , testStatus :: TVar Status+ -- ^ Status var that can be used to monitor test progress+ }++-- | A test that still needs to be given its resource initializers and finalizers+type UnresolvedAction = Seq Initializer -> Seq Finalizer -> IO ()++-- | A test that, unlike 'UnresolvedAction', has been given its initializers and+-- finalizers.+type ResolvedAction = IO ()++-- | Number of 'TAction' leafs in a 'TestActionTree'. Used to prevent repeated+-- size calculations.+type Size = Int++-- | Simplified version of 'TestTree' that only includes the tests to be run (as+-- a 'TestAction') and the resources needed to run them (as 'Initializer's and+-- 'Finalizer's).+data TestActionTree act+ = TResource Initializer Finalizer (TestActionTree act)+ | TGroup Size [TestActionTree act]+ -- ^ Note the 'Size' field of this constructor: it stores how many 'TAction's+ -- are present in the tree. Functions using constructing this constructor+ -- should take care, or use 'tGroup' instead. If this constructor is ever+ -- exported, we should probably move it to its own module and expose only a+ -- smart constructor using pattern synonyms. For now, this seems more trouble+ -- than it's worth, given the number of types it needs defined in this module.+ | TAction (TestAction act)++-- | Smart constructor for 'TGroup'. Fills in 'Size' field by summing the size+-- of the given test trees.+tGroup :: [TestActionTree act] -> TestActionTree act+tGroup trees = TGroup (sum (map testActionTreeSize trees)) trees++-- | Size of a 'TestActionTree', i.e. the number of 'TAction's it contains.+testActionTreeSize :: TestActionTree act -> Int+testActionTreeSize = \case+ TResource _ _ tree -> testActionTreeSize tree+ TGroup size _ -> size+ TAction _ -> 1++-- | Collect initializers and finalizers introduced by 'TResource' and apply them+-- to each action.+resolveTestActions :: TestActionTree UnresolvedAction -> TestActionTree ResolvedAction+resolveTestActions = go Seq.empty Seq.empty+ where+ go inits fins = \case+ TResource ini fin tree ->+ TResource ini fin $ go (inits |> ini) (fin <| fins) tree+ TGroup size trees ->+ TGroup size $ map (go inits fins) trees+ TAction (TestAction {..})->+ TAction $ TestAction { testAction = testAction inits fins, .. }+ -- | Turn a test tree into a list of actions to run tests coupled with--- variables to watch them.+-- variables to watch them. Additionally, a collection of finalizers is+-- returned that can be used to clean up resources in case of unexpected+-- events. createTestActions :: OptionSet -> TestTree- -> IO ([(Action, TVar Status)], Seq.Seq Finalizer)+ -> IO ([TestAction Action], Seq Finalizer) createTestActions opts0 tree = do- let- traversal :: Tr- traversal =- foldTestTree- (trivialFold :: TreeFold Tr)- { foldSingle = runSingleTest- , foldResource = addInitAndRelease- , foldGroup = \_opts name (Traversal a) ->- Traversal $ mapWriterT (local (first (Seq.|> name))) a- , foldAfter = \_opts deptype pat (Traversal a) ->- Traversal $ mapWriterT (local (second ((deptype, pat) :))) a- }- opts0 tree- (tests, fins) <- unwrap (mempty :: Path) (mempty :: Deps) traversal+ -- Folding the test tree reduces it to a 'TestActionTree', which is a simplified+ -- version of 'TestTree' that only includes the tests to be run, resources needed+ -- to run them, and meta information needed to watch test progress and calculate+ -- dependencies in 'resolveDeps'.+ unresolvedTestTree :: TestActionTree UnresolvedAction <-+ flip runReaderT (mempty :: (Path, Seq Dependency)) $+ foldTestTree0 (pure (tGroup [])) (TreeFold { .. }) opts0 tree+ let- mb_tests :: Maybe [(Action, TVar Status)]- mb_tests = resolveDeps $ map- (\(act, testInfo) ->- (act (Seq.empty, Seq.empty), testInfo))- tests- case mb_tests of- Just tests' -> return (tests', fins)- Nothing -> throwIO DependencyLoop+ finalizers :: Seq Finalizer+ finalizers = collectFinalizers unresolvedTestTree + tests :: [TestAction ResolvedAction]+ tests = collectTests (resolveTestActions unresolvedTestTree)++ case resolveDeps tests of+ Right tests' -> return (tests', finalizers)+ Left cycles -> throwIO (DependencyLoop cycles)+ where- runSingleTest :: IsTest t => OptionSet -> TestName -> t -> Tr- runSingleTest opts name test = Traversal $ do- statusVar <- liftIO $ atomically $ newTVar NotStarted- (parentPath, deps) <- lift ask+ -- * Functions used in 'TreeFold'+ foldSingle :: IsTest t => OptionSet -> TestName -> t -> Tr+ foldSingle opts name test = do+ testStatus <- liftIO $ newTVarIO NotStarted+ (parentPath, testDeps) <- ask let- path = parentPath Seq.|> name- act (inits, fins) =- executeTest (run opts test) statusVar (lookupOption opts) inits fins- tell ([(act, (statusVar, path, deps))], mempty)- addInitAndRelease :: OptionSet -> ResourceSpec a -> (IO a -> Tr) -> Tr- addInitAndRelease _opts (ResourceSpec doInit doRelease) a = wrap $ \path deps -> do- initVar <- atomically $ newTVar NotCreated- (tests, fins) <- unwrap path deps $ a (getResource initVar)- let ntests = length tests- finishVar <- atomically $ newTVar ntests+ testPath = parentPath |> name+ testAction = executeTest (run opts test) testStatus (lookupOption opts) (lookupOption opts)+ pure $ TAction (TestAction {..})++ foldResource :: OptionSet -> ResourceSpec a -> (IO a -> Tr) -> Tr+ foldResource _opts (ResourceSpec doInit doRelease) a = do+ initVar <- liftIO $ newTVarIO NotCreated+ testTree <- a (getResource initVar)+ finishVar <- liftIO $ newTVarIO (testActionTreeSize testTree) let ini = Initializer doInit initVar fin = Finalizer doRelease initVar finishVar- tests' = map (first (\f (x, y) -> f (x Seq.|> ini, fin Seq.<| y))) tests- return (tests', fins Seq.|> fin)- wrap- :: (Path ->- Deps ->- IO ([(InitFinPair -> IO (), (TVar Status, Path, Deps))], Seq.Seq Finalizer))- -> Tr- wrap = Traversal . WriterT . fmap ((,) ()) . ReaderT . uncurry- unwrap- :: Path- -> Deps+ pure $ TResource ini fin testTree++ foldAfter :: OptionSet -> DependencyType -> Expr -> Tr -> Tr+ foldAfter _opts depType pat = local (second (Dependency depType (PatternDep pat) <|))++ foldGroup :: OptionSet -> TestName -> [Tr] -> Tr+ foldGroup opts name trees =+ fmap tGroup $ local (first (|> name)) $+ case lookupOption opts of+ Parallel ->+ sequence trees+ Sequential depType ->+ snd <$> mapAccumM (goSeqGroup depType) mempty trees++ -- * Utility functions+ collectTests :: TestActionTree act -> [TestAction act]+ collectTests = \case+ TResource _ _ t -> collectTests t+ TGroup _ trees -> concatMap collectTests trees+ TAction action -> [action]++ collectFinalizers :: TestActionTree act -> Seq Finalizer+ collectFinalizers = \case+ TResource _ fin t -> collectFinalizers t |> fin+ TGroup _ trees -> mconcat (map collectFinalizers trees)+ TAction _ -> mempty++ goSeqGroup + :: DependencyType+ -> Seq Dependency -> Tr- -> IO ([(InitFinPair -> IO (), (TVar Status, Path, Deps))], Seq.Seq Finalizer)- unwrap path deps = flip runReaderT (path, deps) . execWriterT . getTraversal+ -> ReaderT (Path, Seq Dependency) IO (Seq Dependency, TestActionTree UnresolvedAction)+ goSeqGroup depType prevDeps treeM = do+ tree0 <- local (second (prevDeps ><)) treeM + let+ toDep TestAction {..} = Dependency depType (ExactDep testPath testStatus)+ deps0 = Seq.fromList (toDep <$> collectTests tree0)++ -- If this test tree is empty (either due to it being actually empty, or due+ -- to all tests being filtered) we need to propagate the previous dependencies.+ deps1 = if Seq.null deps0 then prevDeps else deps0++ pure (deps1, tree0)+ -- | Take care of the dependencies. ----- Return 'Nothing' if there is a dependency cycle.-resolveDeps :: [(IO (), (TVar Status, Path, Deps))] -> Maybe [(Action, TVar Status)]-resolveDeps tests = checkCycles $ do- (run_test, (statusVar, path0, deps)) <- tests+-- Return 'Left' if there is a dependency cycle, containing the detected cycles.+resolveDeps+ :: [TestAction ResolvedAction]+ -> Either [[Path]] [TestAction Action]+resolveDeps tests = maybeCheckCycles $ do+ TestAction { testAction=run_test, .. } <- tests+ let- -- Note: Duplicate dependencies may arise if the same test name matches- -- multiple patterns. It's not clear that removing them is worth the- -- trouble; might consider this in the future.- deps' :: [(DependencyType, TVar Status, Path)]- deps' = do- (deptype, depexpr) <- deps- (_, (statusVar1, path, _)) <- tests- guard $ exprMatches depexpr path- return (deptype, statusVar1, path)+ deps' = concatMap findDeps testDeps getStatus :: STM ActionStatus getStatus = foldr@@ -337,7 +483,7 @@ action = Action { actionStatus = getStatus , actionRun = run_test- , actionSkip = writeTVar statusVar $ Done $ Result+ , actionSkip = writeTVar testStatus $ Done $ Result -- See Note [Skipped tests] { resultOutcome = Failure TestDepFailed , resultDescription = ""@@ -346,21 +492,46 @@ , resultDetailsPrinter = noResultDetails } }- return ((action, statusVar), (path0, dep_paths))+ return (TestAction { testAction = action, .. }, (testPath, dep_paths))+ where+ -- Skip cycle checking if no patterns are used: sequential test groups can't+ -- introduce cycles on their own.+ maybeCheckCycles+ | any (any isPatternDependency . testDeps) tests = checkCycles+ | otherwise = Right . map fst -checkCycles :: Ord b => [(a, (b, [b]))] -> Maybe [a]+ findDeps :: Dependency -> [(DependencyType, TVar Status, Seq TestName)]+ findDeps (Dependency depType depSpec) =+ case depSpec of+ ExactDep testPath statusVar ->+ -- A dependency defined using 'TestGroup' has already been pinpointed+ -- to its 'statusVar' in 'createTestActions'.+ [(depType, statusVar, testPath)]+ PatternDep expr -> do+ -- A dependency defined using patterns needs to scan the whole test+ -- tree for matching tests.+ TestAction{testPath, testStatus} <- tests+ guard $ exprMatches expr testPath+ [(depType, testStatus, testPath)]++-- | Check a graph, given as an adjacency list, for cycles. Return 'Left' if the+-- graph contained cycles, or return all nodes in the graph as a 'Right' if it+-- didn't.+checkCycles :: Ord b => [(a, (b, [b]))] -> Either [[b]] [a] checkCycles tests = do let result = fst <$> tests- graph = [ ((), v, vs) | (v, vs) <- snd <$> tests ]+ graph = [ (v, v, vs) | (v, vs) <- snd <$> tests ] sccs = stronglyConnComp graph- not_cyclic = all (\scc -> case scc of- AcyclicSCC{} -> True- CyclicSCC{} -> False)- sccs- guard not_cyclic- return result+ cycles =+ flip mapMaybe sccs $ \case+ AcyclicSCC{} -> Nothing+ CyclicSCC vs -> Just vs + case cycles of+ [] -> Right result+ _ -> Left cycles+ -- | Used to create the IO action which is passed in a WithResource node getResource :: TVar (Resource r) -> IO r getResource var =@@ -412,6 +583,8 @@ -- -- The number of test running threads is determined by the 'NumThreads' -- option.+--+-- @since 0.10 launchTestTree :: OptionSet -> TestTree@@ -433,8 +606,8 @@ (testActions, fins) <- createTestActions opts tree let NumThreads numTheads = lookupOption opts (t,k1) <- timed $ do- abortTests <- runInParallel numTheads (fst <$> testActions)- (do let smap = IntMap.fromList $ zip [0..] (snd <$> testActions)+ abortTests <- runInParallel numTheads (testAction <$> testActions)+ (do let smap = IntMap.fromList $ zip [0..] (testStatus <$> testActions) k0 smap) `finallyRestore` \restore -> do -- Tell all running tests to wrap up.
Test/Tasty/Runners.hs view
@@ -1,4 +1,6 @@--- | API for test runners+-- | API for test runners.+--+-- @since 0.1 module Test.Tasty.Runners ( -- * Working with the test tree@@ -37,6 +39,7 @@ , FailureReason(..) , resultSuccessful , Progress(..)+ , emptyProgress , StatusMap , launchTestTree , NumThreads(..)
Test/Tasty/Runners/Reducers.hs view
@@ -45,8 +45,12 @@ import Prelude -- Silence AMP import warnings import qualified Data.Semigroup as Sem --- | Monoid generated by '*>'+-- | Monoid generated by '*>'.+--+-- @since 0.8 newtype Traversal f = Traversal { getTraversal :: f () }++-- | @since 0.12.0.1 instance Applicative f => Sem.Semigroup (Traversal f) where Traversal f1 <> Traversal f2 = Traversal $ f1 *> f2 instance Applicative f => Monoid (Traversal f) where@@ -59,8 +63,12 @@ -- -- Starting from GHC 8.6, a similar type is available from "Data.Monoid". -- This type is nevertheless kept for compatibility.+--+-- @since 0.8 newtype Ap f a = Ap { getApp :: f a } deriving (Functor, Applicative, Monad)++-- | @since 0.12.0.1 instance (Applicative f, Monoid a) => Sem.Semigroup (Ap f a) where (<>) = liftA2 mappend instance (Applicative f, Monoid a) => Monoid (Ap f a) where
Test/Tasty/Runners/Utils.hs view
@@ -18,12 +18,16 @@ import Data.Time.Clock.POSIX (getPOSIXTime) #endif --- Install handlers only on UNIX #ifdef VERSION_unix+#include "HsUnixConfig.h"+#ifdef HAVE_SIGNAL_H #define INSTALL_HANDLERS 1 #else #define INSTALL_HANDLERS 0 #endif+#else+#define INSTALL_HANDLERS 0+#endif #if INSTALL_HANDLERS import System.Posix.Signals@@ -38,7 +42,9 @@ -- This function should be used to display messages generated by the test -- suite (such as test result descriptions). ----- See e.g. <https://github.com/UnkindPartition/tasty/issues/25>+-- See e.g. <https://github.com/UnkindPartition/tasty/issues/25>.+--+-- @since 0.10.1 formatMessage :: String -> IO String formatMessage = go 3 where@@ -52,7 +58,9 @@ Left e' -> printf "message threw an exception: %s" <$> go (recLimit-1) (show (e' :: SomeException)) -- | Force elements of a list--- (<https://ro-che.info/articles/2015-05-28-force-list>)+-- (<https://ro-che.info/articles/2015-05-28-force-list>).+--+-- @since 1.0.1 forceElements :: [a] -> () forceElements = foldr seq () @@ -65,8 +73,9 @@ -- functions. You only need to call it explicitly if you call -- 'Test.Tasty.Runners.tryIngredients' yourself. ----- This function does nothing on non-UNIX systems or when compiled with GHC--- older than 7.6.+-- This function does nothing when POSIX signals are not supported.+--+-- @since 1.2.1 installSignalHandlers :: IO () installSignalHandlers = do #if INSTALL_HANDLERS@@ -90,11 +99,15 @@ -- The 'CInt' field contains the signal number, as in -- 'System.Posix.Signals.Signal'. We don't use that type synonym, however, -- because it's not available on non-UNIXes.+--+-- @since 1.2.1 newtype SignalException = SignalException CInt deriving (Show, Typeable) instance Exception SignalException --- | Measure the time taken by an 'IO' action to run+-- | Measure the time taken by an 'IO' action to run.+--+-- @since 1.2.2 timed :: IO a -> IO (Time, a) timed t = do start <- getTime@@ -103,14 +116,18 @@ return (end-start, r) #if MIN_VERSION_base(4,11,0)--- | Get monotonic time+-- | Get monotonic time. -- -- Warning: This is not the system time, but a monotonically increasing time -- that facilitates reliable measurement of time differences.+--+-- @since 1.2.2 getTime :: IO Time getTime = getMonotonicTime #else--- | Get system time+-- | Get system time.+--+-- @since 1.2.2 getTime :: IO Time getTime = realToFrac <$> getPOSIXTime #endif
tasty.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: tasty-version: 1.4.3+version: 1.5 synopsis: Modern and extensible testing framework description: Tasty is a modern testing framework for Haskell. It lets you combine your unit tests, golden@@ -19,7 +19,7 @@ Source-repository head type: git- location: git://github.com/UnkindPartition/tasty.git+ location: https://github.com/UnkindPartition/tasty.git subdir: core flag unix@@ -59,29 +59,29 @@ Test.Tasty.Ingredients.IncludingOptions build-depends:- base >= 4.9 && < 5,- stm >= 2.3,- containers,- transformers >= 0.5,- tagged >= 0.5,- optparse-applicative >= 0.14,- ansi-terminal >= 0.9+ base >= 4.9 && < 5,+ stm >= 2.3 && < 2.6,+ containers < 0.7,+ transformers >= 0.5 && < 0.7,+ tagged >= 0.5 && < 0.9,+ optparse-applicative >= 0.14 && < 0.19,+ ansi-terminal >= 0.9 && < 1.1 -- No reason to depend on unbounded-delays on 64-bit architecture if(!arch(x86_64) && !arch(aarch64)) build-depends:- unbounded-delays >= 0.1+ unbounded-delays >= 0.1 && < 0.2 if(!impl(ghc >= 8.0))- build-depends: semigroups+ build-depends: semigroups < 0.21 if(!impl(ghc >= 8.4))- build-depends: time >= 1.4+ build-depends: time >= 1.4 && < 1.13 if !os(windows) && !impl(ghcjs) cpp-options: -DUSE_WCWIDTH if flag(unix)- build-depends: unix+ build-depends: unix < 2.9 -- hs-source-dirs: default-language: Haskell2010