tasty 1.2.3 → 1.5.4
raw patch · 27 files changed
Files
- CHANGELOG.md +199/−4
- Control/Concurrent/Async.hs +293/−0
- README.md +99/−29
- Test/Tasty.hs +23/−7
- Test/Tasty/CmdLine.hs +127/−23
- Test/Tasty/Core.hs +407/−60
- Test/Tasty/Ingredients.hs +28/−7
- Test/Tasty/Ingredients/Basic.hs +5/−2
- Test/Tasty/Ingredients/ConsoleReporter.hs +347/−125
- Test/Tasty/Ingredients/IncludingOptions.hs +3/−1
- Test/Tasty/Ingredients/ListTests.hs +12/−7
- Test/Tasty/Options.hs +79/−24
- Test/Tasty/Options/Core.hs +55/−12
- Test/Tasty/Options/Env.hs +1/−6
- Test/Tasty/Parallel.hs +8/−3
- Test/Tasty/Patterns.hs +32/−6
- Test/Tasty/Patterns/Eval.hs +16/−9
- Test/Tasty/Patterns/Parser.hs +21/−17
- Test/Tasty/Patterns/Printer.hs +66/−0
- Test/Tasty/Patterns/Types.hs +11/−1
- Test/Tasty/Providers.hs +20/−12
- Test/Tasty/Providers/ConsoleFormat.hs +87/−0
- Test/Tasty/Run.hs +346/−121
- Test/Tasty/Runners.hs +4/−1
- Test/Tasty/Runners/Reducers.hs +19/−16
- Test/Tasty/Runners/Utils.hs +46/−40
- tasty.cabal +48/−47
CHANGELOG.md view
@@ -1,6 +1,201 @@ Changes ======= +Version 1.5.4+--------------++_2025-03-31_++* Fix display of `HasCallStack` backtraces when a test throws an error+ ([#472](https://github.com/UnkindPartition/tasty/pull/472)).+* Introduce `dependentTestGroup` and `inOrderTestGroup`,+ deprecate `sequentialTestGroup`+ ([#448](https://github.com/UnkindPartition/tasty/pull/448)).+* Add `instance IsTest t => IsTest (ContT () IO t)`+ ([#466](https://github.com/UnkindPartition/tasty/pull/466)).+* Limit maximum line length in console reporter+ ([#451](https://github.com/UnkindPartition/tasty/pull/451)).+* Make `-j` to entail `+RTS -N` automatically+ ([#457](https://github.com/UnkindPartition/tasty/pull/457)).+* Do not depend on `unbounded-delays` on `ppc64le` and `loongarch64`+ ([#460](https://github.com/UnkindPartition/tasty/pull/460),+ [#465](https://github.com/UnkindPartition/tasty/pull/465)).++Version 1.5.3+--------------++_2025-01-05_++* Console reporter: disable line wrapping+ ([#433](https://github.com/UnkindPartition/tasty/pull/433)).+* Console reporter: force flushing of stdout after `showCursor`+ ([#436](https://github.com/UnkindPartition/tasty/pull/436)).++Version 1.5.2+--------------++_2024-11-03_++* Partially revert [#393](https://github.com/UnkindPartition/tasty/pull/393)+ to fix progress reporting outside of Emacs.+* Do not depend on `unbounded-delays` on `ppc64`, `s390x` and `riscv64`+ ([#371](https://github.com/UnkindPartition/tasty/pull/371),+ [#422](https://github.com/UnkindPartition/tasty/pull/422),+ [#423](https://github.com/UnkindPartition/tasty/pull/423)).+++Version 1.5.1+--------------++_2024-06-22_++* Performance improvements+ ([#389](https://github.com/UnkindPartition/tasty/pull/389),+ [#390](https://github.com/UnkindPartition/tasty/pull/390)).+* Progress reporting in Emacs: use `\r` instead of ANSI escape sequences+ ([#393](https://github.com/UnkindPartition/tasty/pull/393)).+* Console reporter: fix unintended change to `foldHeading`+ ([#396](https://github.com/UnkindPartition/tasty/pull/396)).+* Prune empty test subtrees from `TestTree`+ ([#403](https://github.com/UnkindPartition/tasty/pull/403)).+* Add `instance Eq Timeout` and `instance Ord Timeout`+ ([#415](https://github.com/UnkindPartition/tasty/pull/415)).+* Add ability to supply options for launchers and reporters at the top-level of test tree+ ([#417](https://github.com/UnkindPartition/tasty/pull/417)).++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+---------------++_2022-12-18_++* Drop `unbounded-delays` dependency on 64-bit machines (#344).+* Drop `clock` dependency, decomission `clock` flag (#345).+* Drop `wcwidth` dependency (#346)+* Tested with GHC 8.0 - 9.4.++Version 1.4.2.3+---------------++_2022-05-10_++* Drop `mtl` dependency+* Warning-free under GHC 8.0 - 9.2++Version 1.4.2.2+---------------++_2022-05-10_++* Fix compilation with `mtl-2.3`+* Tested with GHC 8.0 - 9.2; dropped support for GHC 7.x++Version 1.4.2.1+---------------++Fix warnings under GHC 9.2++Version 1.4.2+-------------++* Add `consoleTestReporterWithHook`+* Suggest pattern to rerun an individual failing test+* Add `Test.Tasty.Patterns.Printer`++Version 1.4.1+-------------++Deduplicate command line options when there is more than one TestReporter.+Expose the function that does that, `uniqueOptionDescriptions`.++Version 1.4.0.3+---------------++Fix CPP warning/error `macro expansion producing 'defined' has undefined behavior`++Version 1.4.0.2+---------------++Automatically disable the dependency on the `clock` package when compiled by ghcjs.++Version 1.4.0.1+---------------++The only point of this release is to introduce compatibility with GHCs back to 7.0+(see https://github.com/UnkindPartition/tasty/pull/287).++Note, however, that these changes are not merged to the master branch, and the+future releases will only support the GHC/base versions from the last 5 years,+as per our usual policy. To test with even older GHCs, you'll have to use this+particular version of tasty (or have the constraint solver pick it for you when+testing with older GHCs).++The source of this release is in the `support-old-ghcs` branch of the tasty+repository.++Version 1.4+-----------++* Change the `TreeFold` data type to give all functions access to `OptionSet`+* Fix a bug where a looping failure message escaped the time out set for the+ test+* Fix a bug where pattern changes inside the `TestTree` weren't respected++Version 1.3.1+-------------++* Add an ability for a test provider to print colorful/formatted output++Version 1.3+-----------++* `IsOption` has a new method `showDefaultValue` for customizing how+ `defaultValue`s are rendered in the `--help` output.+* Drop support for GHCs older than 5 years+* Do not install handlers for the signals that dump core+* Export the `AnsiTricks` type/option+* In addition to a `Parser`, `optionParser` and `suiteOptionParser` now return+ a `[String]` representing warning messages:+ * A warning is emitted if an `IsOption` instance defines multiple options in+ the implementation of `optionCLParser`.+ * An warning is emitted if an `IsOption` instance's `optionCLParser`+ implementation assigns a default value (e.g., with+ `Options.Applicative.value`), as this interferes with `tasty`'s ability to+ read environment variable arguments.+ Version 1.2.3 ------------- @@ -59,7 +254,7 @@ hopefully the breakage won't be too big. I'm sorry about any problems caused by the change. -See <https://github.com/feuerbach/tasty/issues/220> for the discussion.+See <https://github.com/UnkindPartition/tasty/issues/220> for the discussion. * The field separator in patterns is changed from slash (`/`) to period (`.`), and `.` is now allowed in raw patterns.@@ -284,7 +479,7 @@ --------------- Be careful not to export the `Show (a -> b)` instance, see-<https://github.com/feuerbach/tasty/issues/71>+<https://github.com/UnkindPartition/tasty/issues/71> Version 0.8.1.2 ---------------@@ -346,7 +541,7 @@ * Better handling of exceptions that arise during resource creation or disposal * Expose the `AppMonoid` wrapper-* Add `askOption` and `inludingOptions`+* Add `askOption` and `includingOptions` Version 0.5.2.1 ---------------@@ -388,7 +583,7 @@ Version 0.4.0.1 --------------- -Fix a bug ([#25](https://github.com/feuerbach/tasty/issues/25))+Fix a bug ([#25](https://github.com/UnkindPartition/tasty/issues/25)) Version 0.4 -----------
+ Control/Concurrent/Async.hs view
@@ -0,0 +1,293 @@+-- | Operations for running IO operations asynchronously.++-- These are the same as in the 'async' package. We do not use+-- 'async' to avoid its dependencies.++{- License for the 'async' package+Copyright (c) 2012, Simon Marlow++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 Simon Marlow 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.+-}++{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}++module Control.Concurrent.Async (+ async, withAsync, wait, asyncThreadId, cancel, concurrently+ ) where++import Control.Concurrent.STM+import Control.Exception+ ( BlockedIndefinitelyOnMVar(..)+ , BlockedIndefinitelyOnSTM(..)+ , Exception+ , SomeException+ , asyncExceptionFromException+ , asyncExceptionToException+ , catch+ , fromException+ , onException+ , toException+ , try+ )+import Control.Concurrent+import Control.Monad+import Data.IORef+import GHC.Conc (ThreadId(..))+import GHC.Exts+import GHC.IO hiding (onException)++#if MIN_VERSION_base(4,21,0)+import Control.Exception (ExceptionWithContext, tryWithContext, catchNoPropagate, rethrowIO)+#else+type ExceptionWithContext x = x++catchNoPropagate :: IO a -> (ExceptionWithContext SomeException -> IO a) -> IO a+catchNoPropagate = catchAll++tryWithContext :: IO a -> IO (Either (ExceptionWithContext SomeException) a)+tryWithContext = try++rethrowIO :: ExceptionWithContext SomeException -> IO a+rethrowIO = throwIO+#endif++-- | An asynchronous action spawned by 'async' or 'withAsync'.+-- Asynchronous actions are executed in a separate thread, and+-- operations are provided for waiting for asynchronous actions to+-- complete and obtaining their results (see e.g. 'wait').+--+data Async a = Async+ { asyncThreadId :: {-# UNPACK #-} !ThreadId+ -- ^ Returns the t'ThreadId' of the thread running+ -- the given t'Async'.+ , _asyncWait :: STM (Either (ExceptionWithContext SomeException) a)+ }++-- | Spawn an asynchronous action in a separate thread.+async :: IO a -> IO (Async a)+async = inline asyncUsing rawForkIO++asyncUsing :: (IO () -> IO ThreadId)+ -> IO a -> IO (Async a)+asyncUsing doFork = \action -> do+ var <- newEmptyTMVarIO+ -- t <- forkFinally action (\r -> atomically $ putTMVar var r)+ -- slightly faster:+ t <- mask $ \restore ->+ doFork $ try (restore action) >>= atomically . putTMVar var+ return (Async t (readTMVar var))++-- | Spawn an asynchronous action in a separate thread, and pass its+-- @Async@ handle to the supplied function. When the function returns+-- or throws an exception, 'uninterruptibleCancel' is called on the @Async@.+--+-- > withAsync action inner = mask $ \restore -> do+-- > a <- async (restore action)+-- > restore (inner a) `finally` uninterruptibleCancel a+--+-- This is a useful variant of 'async' that ensures an @Async@ is+-- never left running unintentionally.+--+-- Note: a reference to the child thread is kept alive until the call+-- to `withAsync` returns, so nesting many `withAsync` calls requires+-- linear memory.+--+withAsync :: IO a -> (Async a -> IO b) -> IO b+withAsync = inline withAsyncUsing rawForkIO++withAsyncUsing :: (IO () -> IO ThreadId)+ -> IO a -> (Async a -> IO b) -> IO b+-- The bracket version works, but is slow. We can do better by+-- hand-coding it:+withAsyncUsing doFork = \action inner -> do+ var <- newEmptyTMVarIO+ mask $ \restore -> do+ t <- doFork $ tryWithContext (restore action) >>= atomically . putTMVar var+ let a = Async t (readTMVar var)+ r <- restore (inner a) `catchNoPropagate` \e -> do+ uninterruptibleCancel a+ rethrowIO (e :: ExceptionWithContext SomeException)+ uninterruptibleCancel a+ return r++-- | Wait for an asynchronous action to complete, and return its+-- value. If the asynchronous action threw an exception, then the+-- exception is re-thrown by 'wait'.+--+-- > wait = atomically . waitSTM+--+{-# INLINE wait #-}+wait :: Async a -> IO a+wait = tryAgain . atomically . waitSTM+ where+ -- See: https://github.com/simonmar/async/issues/14+ tryAgain f = f `Control.Exception.catch` \BlockedIndefinitelyOnSTM -> f++-- | Wait for an asynchronous action to complete, and return either+-- @Left e@ if the action raised an exception @e@, or @Right a@ if it+-- returned a value @a@.+--+-- > waitCatch = atomically . waitCatchSTM+--+{-# INLINE waitCatch #-}+waitCatch :: Async a -> IO (Either (ExceptionWithContext SomeException) a)+waitCatch = tryAgain . atomically . waitCatchSTM+ where+ -- See: https://github.com/simonmar/async/issues/14+ tryAgain f = f `Control.Exception.catch` \BlockedIndefinitelyOnSTM -> f++-- | A version of 'wait' that can be used inside an STM transaction.+--+waitSTM :: Async a -> STM a+waitSTM a = do+ r <- waitCatchSTM a+ either throwSTM return r++-- | A version of 'waitCatch' that can be used inside an STM transaction.+--+{-# INLINE waitCatchSTM #-}+waitCatchSTM :: Async a -> STM (Either (ExceptionWithContext SomeException) a)+waitCatchSTM (Async _ w) = w++-- | Cancel an asynchronous action by throwing the @AsyncCancelled@+-- exception to it, and waiting for the t'Async' thread to quit.+-- Has no effect if the t'Async' has already completed.+--+-- > cancel a = throwTo (asyncThreadId a) AsyncCancelled <* waitCatch a+--+-- Note that 'cancel' will not terminate until the thread the t'Async'+-- refers to has terminated. This means that 'cancel' will block for+-- as long said thread blocks when receiving an asynchronous exception.+--+-- For example, it could block if:+--+-- * It's executing a foreign call, and thus cannot receive the asynchronous+-- exception;+-- * It's executing some cleanup handler after having received the exception,+-- and the handler is blocking.+{-# INLINE cancel #-}+cancel :: Async a -> IO ()+cancel a@(Async t _) = throwTo t AsyncCancelled >> void (waitCatch a)++-- | The exception thrown by `cancel` to terminate a thread.+data AsyncCancelled = AsyncCancelled+ deriving (Show, Eq)++instance Exception AsyncCancelled where+ fromException = asyncExceptionFromException+ toException = asyncExceptionToException++-- | Cancel an asynchronous action+--+-- This is a variant of `cancel`, but it is not interruptible.+{-# INLINE uninterruptibleCancel #-}+uninterruptibleCancel :: Async a -> IO ()+uninterruptibleCancel = uninterruptibleMask_ . cancel++-- | Run two @IO@ actions concurrently, and return both results. If+-- either action throws an exception at any time, then the other+-- action is 'cancel'led, and the exception is re-thrown by+-- 'concurrently'.+--+-- > concurrently left right =+-- > withAsync left $ \a ->+-- > withAsync right $ \b ->+-- > waitBoth a b+concurrently :: IO a -> IO b -> IO (a,b)+concurrently left right = concurrently' left right (collect [])+ where+ collect [Left a, Right b] _ = return (a,b)+ collect [Right b, Left a] _ = return (a,b)+ collect xs m = do+ e <- m+ case e of+ Left ex -> throwIO ex+ Right r -> collect (r:xs) m++concurrently' :: IO a -> IO b+ -> (IO (Either SomeException (Either a b)) -> IO r)+ -> IO r+concurrently' left right collect = do+ done <- newEmptyMVar+ mask $ \restore -> do+ -- Note: uninterruptibleMask here is because we must not allow+ -- the putMVar in the exception handler to be interrupted,+ -- otherwise the parent thread will deadlock when it waits for+ -- the thread to terminate.+ lid <- forkIO $ uninterruptibleMask_ $+ restore (left >>= putMVar done . Right . Left)+ `catchAll` (putMVar done . Left)+ rid <- forkIO $ uninterruptibleMask_ $+ restore (right >>= putMVar done . Right . Right)+ `catchAll` (putMVar done . Left)++ count <- newIORef (2 :: Int)+ let takeDone = do+ r <- takeMVar done -- interruptible+ -- Decrement the counter so we know how many takes are left.+ -- Since only the parent thread is calling this, we can+ -- use non-atomic modifications.+ -- NB. do this *after* takeMVar, because takeMVar might be+ -- interrupted.+ modifyIORef count (subtract 1)+ return r++ let tryAgain f = f `Control.Exception.catch` \BlockedIndefinitelyOnMVar -> f++ stop = do+ -- kill right before left, to match the semantics of+ -- the version using withAsync. (#27)+ uninterruptibleMask_ $ do+ count' <- readIORef count+ -- we only need to use killThread if there are still+ -- children alive. Note: forkIO here is because the+ -- child thread could be in an uninterruptible+ -- putMVar.+ when (count' > 0) $+ void $ forkIO $ do+ throwTo rid AsyncCancelled+ throwTo lid AsyncCancelled+ -- ensure the children are really dead+ replicateM_ count' (tryAgain $ takeMVar done)++ r <- collect (tryAgain $ takeDone) `onException` stop+ stop+ return r++catchAll :: IO a -> (SomeException -> IO a) -> IO a+catchAll = Control.Exception.catch++-- A version of forkIO that does not include the outer exception+-- handler: saves a bit of time when we will be installing our own+-- exception handler.+{-# INLINE rawForkIO #-}+rawForkIO :: IO () -> IO ThreadId+rawForkIO action = IO $ \ s ->+ case (fork# (unIO action) s) of (# s1, tid #) -> (# s1, ThreadId tid #)
README.md view
@@ -18,7 +18,7 @@ To find out what's new, read the **[change log][]**. -[change log]: https://github.com/feuerbach/tasty/blob/master/core/CHANGELOG.md+[change log]: https://github.com/UnkindPartition/tasty/blob/master/core/CHANGELOG.md ## Example @@ -75,7 +75,7 @@ And here is the output of the above program: -+ (Note that whether QuickCheck finds a counterexample to the third property is determined by chance.)@@ -103,7 +103,7 @@ (based on [smallcheck](https://hackage.haskell.org/package/smallcheck)) * [tasty-quickcheck](https://hackage.haskell.org/package/tasty-quickcheck) — for randomized property-based testing (based on [QuickCheck](http://hackage.haskell.org/package/QuickCheck))-* [tasty-hedgehog](https://github.com/qfpl/tasty-hedgehog) — for randomized+* [tasty-hedgehog](https://hackage.haskell.org/package/tasty-hedgehog) — for randomized property-based testing (based on [Hedgehog](https://hackage.haskell.org/package/hedgehog)) * [tasty-hspec](https://hackage.haskell.org/package/tasty-hspec) — for [Hspec](https://hspec.github.io/) tests@@ -112,7 +112,13 @@ (based on [LeanCheck](https://hackage.haskell.org/package/leancheck)) * [tasty-program](https://hackage.haskell.org/package/tasty-program) — run external program and test whether it terminates successfully-* [tasty-wai](https://hackage.haskell.org/package/tasty-wai) - for testing [wai](https://hackage.haskell.org/wai) endpoints.+* [tasty-wai](https://hackage.haskell.org/package/tasty-wai) —+ for testing [wai](https://hackage.haskell.org/package/wai) endpoints+* [tasty-inspection-testing](https://hackage.haskell.org/package/tasty-inspection-testing) —+ for compile-time testing of code properties+ (based on [inspection-testing](http://hackage.haskell.org/package/inspection-testing))+* [tasty-flaky](https://hackage.haskell.org/package/tasty-flaky) — add delay and+ retry logic to any test that is known to fail intermittently [tasty-golden]: https://hackage.haskell.org/package/tasty-golden @@ -142,17 +148,25 @@ * [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://github.com/lwm/tasty-discover) automatically discovers-your tests.-* [tasty-expected-failure](https://github.com/nomeata/tasty-expected-failure) provides+* [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+regression testing and extends `tasty` to a benchmark framework+similar to `criterion` and `gauge`. ## Options@@ -179,12 +193,14 @@ % ./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] [--quickcheck-tests NUMBER]- [--quickcheck-replay SEED] [--quickcheck-show-replay]- [--quickcheck-max-size NUMBER] [--quickcheck-max-ratio NUMBER]- [--quickcheck-verbose] [--smallcheck-depth NUMBER]+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]+ [--quickcheck-max-ratio NUMBER] [--quickcheck-verbose]+ [--quickcheck-shrinks NUMBER] Available options: -h,--help Show this help text@@ -192,26 +208,40 @@ 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')+ When to use colored output (default: auto)+ --ansi-tricks ARG Enable various ANSI terminal tricks. Can be set to+ 'true' or 'false'. (default: true)+ --smallcheck-depth NUMBER+ Depth to use for smallcheck tests+ --smallcheck-max-count NUMBER+ Maximum smallcheck test count --quickcheck-tests NUMBER- Number of test cases for QuickCheck to generate+ Number of test cases for QuickCheck to generate.+ Underscores accepted: e.g. 10_000_000 --quickcheck-replay SEED Random seed to use for replaying a previous test run (use same --quickcheck-max-size) --quickcheck-show-replay Show a replay token for replaying tests --quickcheck-max-size NUMBER Size of the biggest test cases quickcheck generates --quickcheck-max-ratio NUMBER- Maximum number of discared tests per successful test+ Maximum number of discarded tests per successful test before giving up --quickcheck-verbose Show the generated test cases- --smallcheck-depth NUMBER- Depth to use for smallcheck tests+ --quickcheck-shrinks NUMBER+ Number of shrinks allowed before QuickCheck will fail+ a test ``` Every option can be passed via environment. To obtain the environment variable@@ -673,13 +703,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 `dependentTestGroup` 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.+* `dependentTestGroup 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: @@ -690,6 +723,12 @@ -> TestTree -- ^ the subtree that depends on other tests -> TestTree -- ^ the subtree annotated with dependency information +dependentTestGroup+ :: 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 ``` @@ -726,9 +765,9 @@ ] ``` -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 the may be filtered out+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* filtering. Therefore, if Test A is filtered out, Test B will run unconditionally, and if Test B is filtered out, it simply won't run.@@ -737,7 +776,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)*,@@ -753,7 +792,9 @@ test tree, searching for the next test to execute may also have an overhead quadratic in the number of tests. +Use `dependentTestGroup` to mitigate these problems. + ## FAQ 1. **Q**: When my tests write to stdout/stderr, the output is garbled. Why is that and@@ -761,7 +802,7 @@ **A**: 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+ See [#103](https://github.com/UnkindPartition/tasty/issues/103) for the discussion. Some ideas on how to work around this:@@ -777,8 +818,33 @@ output. A workaround is to disable ANSI tricks: pass `--ansi-tricks=false` on the command line or set `TASTY_ANSI_TRICKS=false` in the environment. - See [issue #152](https://github.com/feuerbach/tasty/issues/152).+ See [issue #152](https://github.com/UnkindPartition/tasty/issues/152). +3. **Q**: Patterns with slashes do not work on Windows. How can I fix it?++ **A**: If you are running Git for Windows terminal, it has a habit of+ converting slashes to backslashes. Set `MSYS_NO_PATHCONV=1` when running the+ Git for Windows terminal and `MSYS2_ARG_CONV_EXCL=*` when running a MinGW+ bash directly to prevent this behaviour, or follow other suggestions from+ [Known+ Issues](https://github.com/git-for-windows/build-extra/blob/main/ReleaseNotes.md#known-issues).++## Migration from `test-framework`++`tasty` architecture is quite similar to `test-framework`, so a few mechanical changes are usually enough to migrate:++* Replace packages in `build-depends`:+ * `test-framework` -> `tasty`,+ * `test-framework-hunit` -> `tasty-hunit`,+ * `test-framework-quickcheck2` -> `tasty-quickcheck`.+* Replace module imports:+ * `Test.Framework` -> `Test.Tasty`,+ * `Test.Framework.Providers.HUnit` -> `Test.Tasty.HUnit`,+ * `Test.Framework.Providers.QuickCheck2` -> `Test.Tasty.QuickCheck`.+* Replace in type signatures:+ * `Test` -> `TestTree`.+* Replace `defaultMain tests` with `defaultMain (testGroup "All" tests)`.+ ## Press Blog posts and other publications related to tasty. If you wrote or just found@@ -792,7 +858,7 @@ * [Custom options in Tasty][custom-options-article] * [Resources in Tasty (update)](https://ro-che.info/articles/2013-12-29-tasty-resources-2) * [Announcing tasty-rerun](https://ocharles.org.uk/blog/posts/2014-01-20-announcing-tasty-rerun.html)-* [Code testing in Haskell revisited (with Tasty)](https://lambda.jstolarek.com/2014/01/code-testing-in-haskell-revisited-with-tasty/)+* [Code testing in Haskell revisited (with Tasty)](https://jstolarek.github.io/posts/2014-01-26-code-testing-in-haskell-revisited-with-tasty.html) * [New patterns in tasty][awk-patterns-article] * [Screencast: Dynamic Test Suites in Haskell using Hspec and Tasty](https://www.youtube.com/watch?v=PGsDvgmZF7A) * [Automatically generated directories for tasty tests][tasty-directories]@@ -801,10 +867,14 @@ [awk-patterns-article]: https://ro-che.info/articles/2018-01-08-tasty-new-patterns [tasty-directories]: https://nmattia.com/posts/2018-04-30-tasty-test-names.html +## GHC version support policy++We only support the GHC/base versions [from the last 5 years](https://wiki.haskell.org/Base_package#Versions).+ Maintainers ----------- -[Roman Cheplyaka](https://github.com/feuerbach) is the primary maintainer.+[Roman Cheplyaka](https://github.com/UnkindPartition) is the primary maintainer. [Oliver Charles](https://github.com/ocharles) is the backup maintainer. Please get in touch with him if the primary maintainer cannot be reached.
Test/Tasty.hs view
@@ -21,9 +21,11 @@ -- > assertBool "Oops, 7 is odd" (even 7) -- > ] ----- Take a look at the <https://github.com/feuerbach/tasty#readme README>:+-- 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,9 @@ TestName , TestTree , testGroup+ , dependentTestGroup+ , sequentialTestGroup+ , inOrderTestGroup -- * Running tests , defaultMain , defaultMainWithIngredients@@ -71,12 +76,14 @@ -- | 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] -- | Parse the command line arguments and run the tests. ----- When the tests finish, this function calls 'exitWith' with the exit code+-- When the tests finish, this function calls 'System.Exit.exitWith' with the exit code -- that indicates whether any tests have failed. Most external systems -- (stack, cabal, travis-ci, jenkins etc.) rely on the exit code to detect -- whether the tests pass. If you want to do something else after@@ -96,25 +103,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
@@ -7,16 +7,19 @@ , defaultMainWithIngredients ) where -import Options.Applicative-import Data.Monoid ((<>))+import Control.Arrow+import Data.Maybe import Data.Proxy-import Data.Foldable (foldMap)-import Prelude -- Silence AMP and FTP import warnings+import Data.Typeable (typeRep)+import Options.Applicative+import Options.Applicative.Common (evalParser)+import qualified Options.Applicative.Types as Applicative (Option(..))+import Options.Applicative.Types (Parser(..), OptProperties(..)) import System.Exit import System.IO--#if !MIN_VERSION_base(4,9,0)+#if !MIN_VERSION_base(4,11,0) import Data.Monoid+import Data.Foldable (foldMap) #endif import Test.Tasty.Core@@ -26,42 +29,143 @@ import Test.Tasty.Options.Env import Test.Tasty.Runners.Reducers --- | Generate a command line parser from a list of option descriptions-optionParser :: [OptionDescription] -> Parser OptionSet-optionParser = getApp . foldMap toSet where- toSet :: OptionDescription -> Ap Parser OptionSet- toSet (Option (Proxy :: Proxy v)) = Ap $- (singleOption <$> (optionCLParser :: Parser v)) <|> pure mempty+-- | Generate a command line parser from a list of option descriptions,+-- alongside any related warning messages.+--+-- @since 1.3+optionParser :: [OptionDescription] -> ([String], Parser OptionSet)+optionParser = second getApp . foldMap toSet where+ toSet :: OptionDescription -> ([String], Ap Parser OptionSet)+ toSet (Option p) = second+ (\parser -> Ap $ (singleOption <$> parser) <|> pure mempty)+ (finalizeCLParser p optionCLParser) --- | The command line parser for the test suite-suiteOptionParser :: [Ingredient] -> TestTree -> Parser OptionSet+-- Do two things:+--+-- 1. Replace an `optionCLParser`'s 'propShowDefault' with 'showDefaultValue'+-- from the 'IsOption' class.+-- 2. Generate warning messages if the 'optionCLParser' does anything+-- suspicious. Currently, the only suspicious things we check for are+-- (a) if the 'Parser' defines multiple options and, (b) if the 'Parser'+-- assigns a default value outside of 'defaultValue'.+finalizeCLParser :: forall proxy v . IsOption v+ => proxy v -> Parser v -> ([String], Parser v)+finalizeCLParser _ p = (warnings, setCLParserShowDefaultValue mbDef p)+ where+ mbDef :: Maybe String+ mbDef = showDefaultValue (defaultValue :: v)++ warnings :: [String]+ warnings = catMaybes [multipleOptPsWarning, badDefaultWarning]++ -- Warn if a Parser defines multiple options, as this breaks an assumption+ -- that setCLParserShowDefaultValue relies on.+ multipleOptPsWarning :: Maybe String+ multipleOptPsWarning+ | numOptPs p > 1+ = Just $ unlines+ [ prov+ , "optionCLParser defines multiple options. Consider only defining"+ , "a single option here, as defining multiple options does not play"+ , "well with how tasty displays default values."+ ]+ | otherwise+ = Nothing++ -- Warning if a Parser has a default value (outside of IsOption's+ -- defaultValue method, that is), as this interferes with tasty's ability+ -- to read arguments from environment variables. For more on this point,+ -- see the Haddocks for optionCLParser.+ badDefaultWarning :: Maybe String+ badDefaultWarning+ -- evalParser will only return Just if has a default value declared with+ -- e.g. the Options.Applicative.value function.+ | isJust (evalParser p)+ = Just $ unlines+ [ prov+ , "Using default values (e.g., with Options.Applicative.value) in"+ , "optionCLParser is prohibited, as it interferes with tasty's ability"+ , "to read environment variable options properly. Moreover, assigning"+ , "default values is unnecessary, as their functionality is subsumed"+ , "by the defaultValue method of IsOption."+ ]+ | otherwise+ = Nothing++ prov :: String+ prov = "WARNING (in the IsOption instance for "+ ++ show (typeRep (Proxy :: Proxy v)) ++ "):"++-- Replace an `optionCLParser`'s 'propShowDefault' with 'showDefaultValue' from+-- the 'IsOption' class. It's tempting to try doing this when constructing the+-- 'Parser' itself using 'optionMod', but @optparse-applicative@'s 'mkParser'+-- function always overrides the result of 'optionMod'. Ugh.+setCLParserShowDefaultValue :: Maybe String -> Parser a -> Parser a+setCLParserShowDefaultValue mbDef = go+ where+ go :: Parser a -> Parser a+ -- Note that we /always/ replace the Option's optProps, regardless of+ -- what type it may have. This can produce unexpected results if an+ -- optionCLParser defines multiple options, which is why we emit a warning+ -- (in finalizeCLParser) if a Parser does this.+ go (OptP o) = OptP o{Applicative.optProps =+ modifyDefault (Applicative.optProps o)}+ go p@NilP{} = p+ go (MultP p1 p2) = MultP (go p1) (go p2)+ go (AltP p1 p2) = AltP (go p1) (go p2)+ go (BindP p1 p2) = BindP (go p1) (fmap go p2)++ modifyDefault :: OptProperties -> OptProperties+ modifyDefault op = op{propShowDefault = mbDef}++-- Note: this is a conservative estimate, since we cannot count the number+-- of OptPs in the continuation argument of BindP. But BindP is really only+-- used for ParserM purposes, and since ParserM is an internal+-- optparse-applicative definition, most optionCLParser instances are+-- unlikely to use it in practice.+numOptPs :: Parser a -> Int+numOptPs OptP{} = 1+numOptPs NilP{} = 0+numOptPs (MultP p1 p2) = numOptPs p1 + numOptPs p2+numOptPs (AltP p1 p2) = numOptPs p1 + numOptPs p2+numOptPs (BindP p1 _p2) = numOptPs p1++-- | The command line parser for the test suite, alongside any related+-- warnings.+--+-- @since 1.3+suiteOptionParser :: [Ingredient] -> TestTree -> ([String], Parser OptionSet) suiteOptionParser ins tree = optionParser $ suiteOptions ins tree -- | Parse the command-line and environment options passed to tasty. ----- Useful if you need to get the options before 'defaultMain' is called.+-- Useful if you need to get the options before 'Test.Tasty.defaultMain' is called. ----- Once within the test tree, 'askOption' should be used instead.+-- Once within the test tree, 'Test.Tasty.askOption' should be used instead. -- -- The arguments to this function should be the same as for -- 'defaultMainWithIngredients'. If you don't use any custom ingredients,--- pass 'defaultIngredients'.+-- pass 'Test.Tasty.defaultIngredients'.+--+-- @since 1.2.2 parseOptions :: [Ingredient] -> TestTree -> IO OptionSet parseOptions ins tree = do+ let (warnings, parser) = suiteOptionParser ins tree+ mapM_ (hPutStrLn stderr) warnings cmdlineOpts <- execParser $- info (helper <*> suiteOptionParser ins tree)- ( fullDesc <>- header "Mmm... tasty test suite"- )+ info (helper <*> parser)+ (header "Mmm... tasty test suite") envOpts <- suiteEnvOptions ins tree return $ envOpts <> cmdlineOpts -- | Parse the command line arguments and run the tests using the provided -- ingredient list. ----- When the tests finish, this function calls 'exitWith' with the exit code--- that indicates whether any tests have failed. See 'defaultMain' for+-- 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,24 +1,70 @@ -- | Core types and definitions-{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts,- ExistentialQuantification, RankNTypes, DeriveDataTypeable,- DeriveGeneric #-}-module Test.Tasty.Core where+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}+module Test.Tasty.Core+ ( FailureReason(..)+ , Outcome(..)+ , Time+ , Result(..)+ , resultSuccessful+ , exceptionResult+ , Progress(..)+ , emptyProgress+ , IsTest(..)+ , TestName+ , ResourceSpec(..)+ , ResourceError(..)+ , DependencyType(..)+ , ExecutionMode(..)+ , Parallel(..)+ , TestTree(..)+ , testGroup+ , sequentialTestGroup+ , dependentTestGroup+ , inOrderTestGroup+ , after+ , after_+ , TreeFold(..)+ , trivialFold+ , foldTestTree+ , foldTestTree0+ , treeOptions+ , testFailed+ ) where import Control.Exception-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 Control.Monad.Trans.Cont (ContT(..))+import Data.Coerce (coerce) import qualified Data.Map as Map+import Data.Bifunctor (Bifunctor(second, bimap))+import Data.IORef (newIORef, readIORef, atomicModifyIORef')+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 MIN_VERSION_base(4,21,0) && !MIN_VERSION_base(4,22,0)+import Control.Exception.Context+#endif++-- | If a test failed, 'FailureReason' describes why.+--+-- @since 0.8 data FailureReason = TestFailed -- ^ test provider indicated failure of the code to test, either because@@ -33,21 +79,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?@@ -60,13 +114,30 @@ -- -- 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+ -- ^ An action that prints additional information about a test.+ --+ -- This is similar to 'resultDescription' except it can produce+ -- colorful/formatted output; see "Test.Tasty.Providers.ConsoleFormat".+ --+ -- This can be used instead of or in addition to 'resultDescription'.+ --+ -- Usually this is set to 'noResultDetails', which does nothing.+ --+ -- @since 1.3.1 }- deriving Show+ deriving+ ( Show -- ^ @since 1.2+ ) {- Note [Skipped tests] ~~~~~~~~~~~~~~~~~~~~@@ -91,25 +162,42 @@ -} -- | 'True' for a passed test, 'False' for a failed one.+--+-- @since 0.8 resultSuccessful :: Result -> Bool resultSuccessful r = case resultOutcome r of Success -> True Failure {} -> False --- | Shortcut for creating a 'Result' that indicates exception+-- | Shortcut for creating a t'Result' that indicates exception exceptionResult :: SomeException -> Result exceptionResult e = Result { resultOutcome = Failure $ TestThrewException e- , resultDescription = "Exception: " ++ show e+ , resultDescription = "Exception: " ++ displayException' e , resultShortDescription = "FAIL" , resultTime = 0+ , resultDetailsPrinter = noResultDetails } +displayException' :: SomeException -> String+#if MIN_VERSION_base(4,22,0)+displayException' = displayExceptionWithInfo+#elif MIN_VERSION_base(4,21,0)+displayException' (SomeException e) =+ displayException e ++ case displayExceptionContext ?exceptionContext of+ "" -> ""+ dc -> "\n\n" ++ dc+#else+displayException' = displayException+#endif+ -- | Test progress information. -- -- 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@@ -118,17 +206,28 @@ -- '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 -- -- This method should cleanly catch any exceptions in the code to test, and- -- return them as part of the 'Result', see 'FailureReason' for an+ -- return them as part of the t'Result', see 'FailureReason' for an -- explanation. It is ok for 'run' to raise an exception if there is a -- problem with the test suite code itself (for example, if a file that -- should contain example data or expected output is not found).@@ -136,19 +235,51 @@ :: 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+-- | @since 1.5.4+instance IsTest t => IsTest (ContT () IO t) where+ testOptions = coerce (testOptions @t)+ run opts (ContT k) yieldProgress = do+ resRef <- newIORef Nothing+ let runInIORef :: t -> IO ()+ runInIORef t = do+ res <- run opts t yieldProgress+ let err = testFailed "Continuation was called multiple times"+ atomicModifyIORef' resRef $ \prev ->+ (Just $ maybe res (const err) prev, ())+ k runInIORef+ maybeRes <- readIORef resRef+ pure $ case maybeRes of+ Nothing -> testFailed "Continuation was not called"+ Just r -> r++-- | t'Result' of a failed test.+--+-- @since 0.8+testFailed+ :: String -- ^ description+ -> Result+testFailed desc = Result+ { resultOutcome = Failure TestFailed+ , resultDescription = desc+ , resultShortDescription = "FAIL"+ , resultTime = 0+ , resultDetailsPrinter = noResultDetails+ }++-- | 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)+-- | t'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@@ -156,7 +287,6 @@ = NotRunningTests | UnexpectedState String String | UseOutsideOfTest- deriving Typeable instance Show ResourceError where show NotRunningTests =@@ -182,8 +312,36 @@ | 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+ = Dependent DependencyType+ -- ^ Test have dependencies+ | Independent Parallel+ -- ^ Test have no dependencies+ deriving (Show, Read)++data Parallel+ = Parallel+ -- ^ Tests can be run in parallel+ | NonParallel+ -- ^ Tests should not be parallelized+ 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 = Independent Parallel+ parseValue = readMaybe+ optionName = Tagged "execution-mode"+ optionHelp = Tagged "Whether tests have dependencies or not"+ optionCLParser = mkOptionCLParser internal+ -- | The main data structure defining a test suite. -- -- It consists of individual test cases and properties, organized in named@@ -194,6 +352,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@@ -206,16 +366,81 @@ -- 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 'dependentTestGroup'.+--+-- @since 0.1 testGroup :: TestName -> [TestTree] -> TestTree testGroup = TestGroup +{-# DEPRECATED sequentialTestGroup "Use dependentTestGroup instead" #-}+-- | Legacy name for 'dependentTestGroup'.+--+-- @since 1.5+sequentialTestGroup :: TestName -> DependencyType -> [TestTree] -> TestTree+sequentialTestGroup = dependentTestGroup++-- | Create a named group of test cases or other groups. Tests are executed in+-- order and each test is considered a dependency of the next one.+-- If filtering by t'TestPattern' (@--pattern@) is in action,+-- any test matching the pattern also shields earlier tests from filtering out,+-- even if they themselves do not match the pattern.+--+-- For parallel execution, see 'testGroup'. For ordered test execution, but+-- with default filtering behavior, see 'inOrderTestGroup'.+--+-- Note that this is will only work when used with the default 'Test.Tasty.Ingredients.TestManager'.+-- If you use another manager, like @tasty-rerun@ for instance, sequentiality+-- might possibly be ignored.+--+-- @since 1.5.4+dependentTestGroup+ :: TestName+ -- ^ name of the group+ -> DependencyType+ -- ^ whether to run subsequent tests even if earlier ones have failed+ -> [TestTree]+ -- ^ tests to execute sequentially+ -> TestTree+dependentTestGroup nm depType = setDependent . TestGroup nm . map setParallel+ where+ setParallel = PlusTestOptions (setOption $ Independent Parallel)+ setDependent = PlusTestOptions (setOption (Dependent depType))+++-- | Create a named group of test cases that will be played sequentially,+-- in the exact order provided. Similarly to 'testGroup'+-- and in contrast to 'dependentTestGroup',+-- filtering by t'TestPattern' is applied uniformly.+--+-- Note that this is will only work when used with the default 'Test.Tasty.Ingredients.TestManager'.+-- If you use another manager, like @tasty-rerun@ for instance, the fact that+-- these tests should be run in the given order might possibly be ignored.+--+-- @since 1.5.4+inOrderTestGroup+ :: TestName+ -- ^ name of the group+ -> [TestTree]+ -- ^ tests to execute sequentially+ -> TestTree+inOrderTestGroup nm = setSequential . TestGroup nm . map setParallel+ where+ setParallel = PlusTestOptions (setOption $ Independent Parallel)+ setSequential = PlusTestOptions (setOption (Independent NonParallel))+ -- | Like 'after', but accepts the pattern as a syntax tree instead -- of a string. Useful for generating a test tree programmatically. --@@ -225,7 +450,7 @@ -- -- @ -- 'after_' 'AllFinish' ('Test.Tasty.Patterns.Types.EQ' ('Field' 'NF') ('StringLit' \"Bar\")) $--- 'testCase' \"A test that depends on Foo.Bar\" $ ...+-- @testCase@ \"A test that depends on Foo.Bar\" $ ... -- @ -- -- @since 1.2@@ -256,12 +481,12 @@ -- -- @ -- 'after' 'AllFinish' \"Foo\" $--- 'testCase' \"A test that depends on Foo.Bar\" $ ...+-- @testCase@ \"A test that depends on Foo.Bar\" $ ... -- @ -- -- Note, however, that our test also happens to contain @Foo@ as part of its name, -- so it also matches the pattern and becomes a dependency of itself. This--- will result in a 'DependencyLoop' exception. To avoid this, either+-- will result in a 'Test.Tasty.DependencyLoop' exception. To avoid this, either -- change the test name so that it doesn't mention @Foo@ or make the -- pattern more specific. --@@ -269,14 +494,14 @@ -- -- @ -- 'after' 'AllFinish' \"$0 == \\\"Tests.Foo.Bar\\\"\" $--- 'testCase' \"A test that depends on Foo.Bar\" $ ...+-- @testCase@ \"A test that depends on Foo.Bar\" $ ... -- @ -- -- Or only specify the dependency's own name, ignoring the group names: -- -- @ -- 'after' 'AllFinish' \"$NF == \\\"Bar\\\"\" $--- 'testCase' \"A test that depends on Foo.Bar\" $ ...+-- @testCase@ \"A test that depends on Foo.Bar\" $ ... -- @ -- -- @since 1.2@@ -294,12 +519,16 @@ -- -- Instead of constructing fresh records, build upon `trivialFold` -- instead. This way your code won't break when new nodes/fields are--- indroduced.+-- introduced.+--+-- @since 0.7 data TreeFold b = TreeFold { foldSingle :: forall t . IsTest t => OptionSet -> TestName -> t -> b- , foldGroup :: TestName -> b -> b- , foldResource :: forall a . ResourceSpec a -> (IO a -> b) -> b- , foldAfter :: DependencyType -> Expr -> 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@@ -313,14 +542,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 = const id- , foldResource = \_ f -> f $ throwIO NotRunningTests- , foldAfter = \_ _ 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 'dependentTestGroup'.+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@@ -336,11 +579,9 @@ -- -- 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- :: Monoid b+ :: forall b . Monoid b => TreeFold b -- ^ the algebra (i.e. how to fold a tree) -> OptionSet@@ -348,22 +589,128 @@ -> TestTree -- ^ the tree to fold -> b-foldTestTree (TreeFold fTest fGroup fResource fAfter) opts0 tree0 =- let pat = lookupOption opts0- in go pat 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 pat path opts tree1 =- case tree1 of- SingleTest name test- | testPatternMatches pat (path Seq.|> name)- -> fTest opts name test- | otherwise -> mempty- TestGroup name 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)- After deptype dep tree -> fAfter deptype dep $ go pat path opts tree+ 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 t'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+ mkGroup opts name xs = case filter isNonEmpty xs of+ [] -> AnnEmptyTestTree+ ys -> AnnTestGroup opts name ys++ isNonEmpty = \case+ AnnEmptyTestTree -> False+ _ -> True++ 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 _ _ [] ->+ (forceMatch, AnnEmptyTestTree)++ AnnTestGroup (opts, _) name trees ->+ case lookupOption opts of+ Dependent _ ->+ second+ (mkGroup opts name)+ (mapAccumR go forceMatch trees)+ Independent _ ->+ bimap+ mconcat+ (mkGroup opts name)+ (unzip (map (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@@ -34,7 +36,7 @@ -- which options it cares about, so that those options are presented to -- the user if the ingredient is included in the test suite. ----- An ingredient can choose, typically based on the 'OptionSet', whether to+-- An ingredient can choose, typically based on the t'OptionSet', whether to -- run. That's what the 'Maybe' is for. The first ingredient that agreed to -- run does its work, and the remaining ingredients are ignored. Thus, the -- order in which you arrange the ingredients may matter.@@ -68,23 +70,30 @@ -- 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'. ----- If the ingredient refuses to run (usually based on the 'OptionSet'),+-- If the ingredient refuses to run (usually based on the t'OptionSet'), -- the function returns 'Nothing'. -- -- For a 'TestReporter', this function automatically starts running the -- tests in the background.+--+-- This function is not publicly exposed. tryIngredient :: Ingredient -> OptionSet -> TestTree -> Maybe (IO Bool) tryIngredient (TestReporter _ report) opts testTree = do -- Maybe monad reportFn <- report opts testTree@@ -96,28 +105,38 @@ -- -- 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 =+tryIngredients ins opts' tree' = msum $ map (\i -> tryIngredient i opts tree) ins+ where+ (opts, tree) = applyTopLevelPlusTestOptions opts' tree' -- | Return the options which are relevant for the given ingredient. -- -- Note that this isn't the same as simply pattern-matching on -- 'Ingredient'. E.g. options for a 'TestReporter' automatically include--- 'NumThreads'.+-- t'NumThreads'.+--+-- @since 0.4 ingredientOptions :: Ingredient -> [OptionDescription] ingredientOptions (TestReporter opts _) = Option (Proxy :: Proxy NumThreads) : opts ingredientOptions (TestManager opts _) = opts --- | Like 'ingredientOption', but folds over multiple ingredients.+-- | Like 'ingredientOptions', but folds over multiple ingredients.+--+-- @since 0.4 ingredientsOptions :: [Ingredient] -> [OptionDescription]-ingredientsOptions = F.foldMap ingredientOptions+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 =+suiteOptions ins tree = uniqueOptionDescriptions $ coreOptions ++ ingredientsOptions ins ++ treeOptions tree@@ -129,6 +148,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
@@ -1,14 +1,17 @@--- | This module exports the basic ingredients defined in the 'tasty'+-- | This module exports the basic ingredients defined in the @tasty@ -- packages. ----- Note that if @defaultIngredients@ from "Test.Tasty" suits your needs,+-- 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 consoleTestReporter , Quiet(..) , HideSuccesses(..)+ , AnsiTricks(..) -- ** Listing tests , listingTests , ListTests(..)
Test/Tasty/Ingredients/ConsoleReporter.hs view
@@ -1,10 +1,14 @@--- vim:fdm=marker:foldtext=foldtext()-{-# LANGUAGE BangPatterns, ImplicitParams, MultiParamTypeClasses, DeriveDataTypeable, FlexibleContexts #-}--- | Console reporter ingredient+-- vim:fdm=marker+{-# LANGUAGE BangPatterns, ImplicitParams, MultiParamTypeClasses, 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@@ -22,42 +26,47 @@ , TestOutput(..) , buildTestOutput , foldTestOutput+ , withConsoleFormat ) where -import Prelude hiding (fail)-import Control.Monad.State hiding (fail)-import Control.Monad.Reader hiding (fail,reader)+import Prelude hiding (fail, EQ)+import Control.Monad (join, unless, void, when, (<=<))+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (Reader, runReader, ask)+import Control.Monad.Trans.State (evalState, evalStateT, get, modify, put) import Control.Concurrent.STM import Control.Exception import Test.Tasty.Core+import Test.Tasty.Providers.ConsoleFormat import Test.Tasty.Run import Test.Tasty.Ingredients+import Test.Tasty.Ingredients.ListTests import Test.Tasty.Options import Test.Tasty.Options.Core+import Test.Tasty.Patterns+import Test.Tasty.Patterns.Printer+import Test.Tasty.Patterns.Types import Test.Tasty.Runners.Reducers import Test.Tasty.Runners.Utils import Text.Printf import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet import Data.Char-#ifdef UNIX-import Data.Char.WCWidth (wcwidth)+#ifdef USE_WCWIDTH+import Foreign.C.Types (CInt(..), CWchar(..)) #endif+import Data.List (isInfixOf) import Data.Maybe import Data.Monoid (Any(..))+import qualified Data.Semigroup as Sem import Data.Typeable-import Options.Applicative hiding (str, Success, Failure)+import Options.Applicative hiding (action, str, Success, Failure) import System.IO import System.Console.ANSI-#if !MIN_VERSION_base(4,8,0)-import Data.Proxy-import Data.Foldable hiding (concatMap,elem,sequence_)-#endif-#if MIN_VERSION_base(4,9,0)-import Data.Semigroup (Semigroup)-import qualified Data.Semigroup (Semigroup((<>)))-#else-import Data.Monoid+#if !MIN_VERSION_base(4,11,0)+import Data.Foldable (foldMap) #endif+import System.IO.Unsafe -------------------------------------------------- -- TestOutput base definitions@@ -69,31 +78,75 @@ -- -- @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 'TestOuput' 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 mempty = Skip- mappend = Seq-#if MIN_VERSION_base(4,9,0)-instance Semigroup TestOutput where- (<>) = mappend+#if !MIN_VERSION_base(4,11,0)+ mappend = (Sem.<>) #endif +applyHook :: ([TestName] -> Result -> IO Result) -> TestOutput -> TestOutput+applyHook hook = go []+ where+ 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)+ go _ Skip = mempty+ type Level = Int --- | Build the 'TestOutput' for a 'TestTree' and 'OptionSet'. The @colors@+-- TODO before the next major release:+-- refactor this as an argument to 'buildTestOutput'+-- to avoid unsafePerformIO.+-- (We cannot add another argument to 'buildTestOutput'+-- in the middle of tasty-1.5 series, because it is exported)+terminalWidth :: Maybe Int+terminalWidth = unsafePerformIO $ do+ isTerminalStdin <- hIsTerminalDevice stdin+ if isTerminalStdin+ then fmap (fmap snd) getTerminalSize+ else pure Nothing+{-# NOINLINE terminalWidth #-}++-- | How wide could 'resultShortDescription' be (in non-extreme scenarios)?+-- Think of something like "OK", "FAIL (12.34s)", "TIMEOUT (100.00s)".+--+-- The field is freeform and test providers can put an arbitrarily long data,+-- so we just settle for a reasonable (over)approximation.+approxMaxResultShortDescriptionWidth :: Int+approxMaxResultShortDescriptionWidth = 20++-- | Build the 'TestOutput' for a 'TestTree' and t'OptionSet'. The @colors@ -- ImplicitParam controls whether the output is colored. -- -- @since 0.11.3@@ -101,8 +154,13 @@ buildTestOutput opts tree = let -- Do not retain the reference to the tree more than necessary- !alignment = computeAlignment opts tree+ !rawAlignment = computeAlignment opts tree+ !alignment = case terminalWidth of+ Nothing -> rawAlignment+ Just width -> min (width - approxMaxResultShortDescriptionWidth) rawAlignment + MinDurationToReport{minDurationMicros} = lookupOption opts+ runSingleTest :: (IsTest t, ?colors :: Bool) => OptionSet -> TestName -> t -> Ap (Reader Level) TestOutput@@ -110,11 +168,40 @@ level <- ask let+ indentedNameWidth = indentSize * level + stringWidth name+ postNamePadding = alignment - indentedNameWidth++ testNamePadded = printf "%s%s: %s"+ (indent level)+ name+ (replicate postNamePadding ' ')+ printTestName = do- printf "%s%s: %s" (indent level) name- (replicate (alignment - indentSize * level - stringWidth name) ' ')+ withoutLineWrap $ 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+ putChar '\r'+ -- A new progress message may be shorter than the previous one+ -- so we must clean whole line and print anew.+ clearLine+ withoutLineWrap $ do+ putStr testNamePadded+ infoOk msg+ hFlush stdout+ printTestResult result = do rDesc <- formatMessage $ resultDescription result @@ -126,24 +213,32 @@ Failure TestDepFailed -> skipped _ -> fail time = resultTime result++ withoutLineWrap $ do+ when getAnsiTricks $ do+ putChar '\r'+ clearLine+ putStr testNamePadded+ 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" when (not $ null rDesc) $ (if resultSuccessful result then infoOk else infoFail) $ printf "%s%s\n" (indent $ level + 1) (formatDesc (level+1) rDesc)+ case resultDetailsPrinter result of+ ResultDetailsPrinter action -> action level withConsoleFormat - return $ PrintTest name printTestName printTestResult+ return $ PrintTest name printTestName printTestProgress printTestResult - runGroup :: TestName -> Ap (Reader Level) TestOutput -> Ap (Reader Level) TestOutput- runGroup name grp = Ap $ do+ 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)+ printHeading = withoutLineWrap $ printf "%s%s\n" (indent level) name+ printBody = runReader (getApp (mconcat grp)) (level + 1) return $ PrintHeading name printHeading printBody in@@ -154,7 +249,26 @@ , foldGroup = runGroup } opts tree+ where+ AnsiTricks{getAnsiTricks} = lookupOption opts+ -- We must ensure these lines don't wrap, otherwise the wrong+ -- line will be cleared later or the test tree printing will+ -- itself wrap.+ withoutLineWrap :: IO () -> IO ()+#if MIN_VERSION_ansi_terminal(1,1,2)+ withoutLineWrap m | getAnsiTricks =+ bracket_ disableLineWrap enableLineWrap m+#endif+ withoutLineWrap m = m ++-- | 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@@ -162,7 +276,7 @@ :: Monoid b => (String -> IO () -> IO Result -> (Result -> IO ()) -> b) -- ^ Eliminator for test cases. The @IO ()@ prints the testname. The- -- @IO Result@ blocks until the test is finished, returning it's 'Result'.+ -- @IO Result@ blocks until the test is finished, returning it's t'Result'. -- The @Result -> IO ()@ function prints the formatted output. -> (String -> IO () -> b -> b) -- ^ Eliminator for test groups. The @IO ()@ prints the test group's name.@@ -172,15 +286,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)@@ -191,6 +307,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 =@@ -204,7 +333,9 @@ , Any True) foldHeading _name printHeading (printBody, Any nonempty) = ( Traversal $ do- when nonempty $ do printHeading :: IO (); getTraversal printBody+ when nonempty $ do+ printHeading :: IO ()+ getTraversal printBody , Any nonempty ) @@ -280,17 +411,20 @@ , 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- Statistics t1 f1 `mappend` Statistics t2 f2 = Statistics (t1 + t2) (f1 + f2) mempty = Statistics 0 0-#if MIN_VERSION_base(4,9,0)-instance Semigroup Statistics where- (<>) = mappend+#if !MIN_VERSION_base(4,11,0)+ mappend = (Sem.<>) #endif --- | @computeStatistics@ computes a summary 'Statistics' for+-- | @computeStatistics@ computes a summary t'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))@@ -339,8 +473,8 @@ where f :: Int -> TVar Status- -> (IntMap.IntMap () -> Int -> STM (IO Bool))- -> (IntMap.IntMap () -> Int -> STM (IO Bool))+ -> (IntSet.IntSet -> Int -> STM (IO Bool))+ -> (IntSet.IntSet -> Int -> STM (IO Bool)) -- ok_tests is a set of tests that completed successfully -- lookahead is the number of unfinished tests that we are allowed to -- look at@@ -353,23 +487,23 @@ case this_status of Done r -> if resultSuccessful r- then k (IntMap.insert key () ok_tests) lookahead+ then k (IntSet.insert key ok_tests) lookahead else return $ return False _ -> k ok_tests (lookahead-1) -- next_iter is called when we end the current iteration, -- either because we reached the end of the test tree -- or because we exhausted the lookahead- next_iter :: IntMap.IntMap () -> STM (IO Bool)+ next_iter :: IntSet.IntSet -> STM (IO Bool) next_iter ok_tests = -- If we made no progress at all, wait until at least some tests -- complete. -- Otherwise, reduce the set of tests we are looking at.- if IntMap.null ok_tests+ if IntSet.null ok_tests then retry- else return $ statusMapResult lookahead0 (IntMap.difference smap ok_tests)+ else return $ statusMapResult lookahead0 (IntMap.withoutKeys smap ok_tests) - finish :: IntMap.IntMap () -> Int -> STM (IO Bool)+ finish :: IntSet.IntSet -> Int -> STM (IO Bool) finish ok_tests _ = next_iter ok_tests -- }}}@@ -379,15 +513,61 @@ -------------------------------------------------- -- {{{ --- | A simple console UI+-- | A simple console UI.+--+-- @since 0.4 consoleTestReporter :: Ingredient-consoleTestReporter =- TestReporter- [ Option (Proxy :: Proxy Quiet)- , Option (Proxy :: Proxy HideSuccesses)- , Option (Proxy :: Proxy UseColor)- , Option (Proxy :: Proxy AnsiTricks)- ] $+consoleTestReporter = TestReporter consoleTestReporterOptions $ \opts tree ->+ let+ TestPattern pattern = lookupOption opts+ tests = testsNames opts tree+ hook = (return .) . appendPatternIfTestFailed tests pattern+ TestReporter _ cb = consoleTestReporterWithHook hook+ in cb opts tree++appendPatternIfTestFailed+ :: [TestName] -- ^ list of (pre-intercalated) test names+ -> Maybe Expr -- ^ current pattern, if any+ -> [TestName] -- ^ name of current test, represented as a list of group names+ -> Result -- ^ vanilla result+ -> Result+appendPatternIfTestFailed [_] _ _ res = res -- if there is only one test, nothing to refine+appendPatternIfTestFailed _ _ [] res = res -- should be impossible+appendPatternIfTestFailed tests currentPattern (name : names) res = case resultOutcome res of+ Success -> res+ Failure{} -> res { resultDescription = resultDescription res ++ msg }+ where+ msg = "\nUse -p '" ++ escapeQuotes (printAwkExpr pattern) ++ "' to rerun this test only."++ escapeQuotes = concatMap $ \c -> if c == '\'' then "'\\''" else [c]++ findPattern [_] pat _ = ERE pat+ findPattern _ pat [] = EQ (Field (IntLit 0)) (StringLit pat)+ findPattern ts pat (n : ns) = let pat' = n ++ '.' : pat in+ findPattern (filter (pat' `isInfixOf`) ts) pat' ns++ individualPattern = findPattern (filter (name `isInfixOf`) tests) name names++ pattern = maybe id And currentPattern individualPattern++consoleTestReporterOptions :: [OptionDescription]+consoleTestReporterOptions =+ [ Option (Proxy :: Proxy Quiet)+ , Option (Proxy :: Proxy HideSuccesses)+ , Option (Proxy :: Proxy MinDurationToReport)+ , Option (Proxy :: Proxy UseColor)+ , Option (Proxy :: Proxy AnsiTricks)+ ]++-- | A simple console UI with a hook to postprocess results,+-- depending on their names and external conditions+-- (e. g., its previous outcome, stored in a file).+-- Names are listed in reverse order:+-- from test's own name to a name of the outermost test group.+--+-- @since 1.4.2+consoleTestReporterWithHook :: ([TestName] -> Result -> IO Result) -> Ingredient+consoleTestReporterWithHook hook = TestReporter consoleTestReporterOptions $ \opts tree -> Just $ \smap -> do let@@ -408,7 +588,9 @@ isTermColor <- hSupportsANSIColor stdout (\k -> if isTerm- then (do hideCursor; k) `finally` showCursor+ -- When killing with Ctrl+C 'showCursor' can fail+ -- to restore terminal cursor if not flushed explicitly+ then (do hideCursor; k) `finally` (do showCursor; hFlush stdout) else k) $ do hSetBuffering stdout LineBuffering@@ -417,7 +599,11 @@ ?colors = useColor whenColor isTermColor let- toutput = 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 ->@@ -432,9 +618,11 @@ 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)+ deriving (Eq, Ord) instance IsOption Quiet where defaultValue = Quiet False parseValue = fmap Quiet . safeReadBool@@ -442,9 +630,14 @@ optionHelp = return "Do not produce any output; indicate success only by the exit code" optionCLParser = mkFlagCLParser (short 'q') (Quiet True) --- | Report only failed tests+-- | Report only failed tests.+--+-- 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)+ deriving (Eq, Ord) instance IsOption HideSuccesses where defaultValue = HideSuccesses False parseValue = fmap HideSuccesses . safeReadBool@@ -452,6 +645,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)+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@@ -459,15 +669,16 @@ = Never | Always | Auto -- ^ Only if stdout is an ANSI color supporting terminal- deriving (Eq, Ord, Typeable)+ deriving (Eq, Ord) -- | Control color output instance IsOption UseColor where defaultValue = Auto parseValue = parseUseColor optionName = return "color"- optionHelp = return "When to use colored output (default: 'auto')"+ optionHelp = return "When to use colored output" optionCLParser = mkOptionCLParser $ metavar "never|always|auto"+ showDefaultValue = Just . displayUseColor -- | By default, when the option @--hide-successes@ is given and the output -- goes to an ANSI-capable terminal, we employ some ANSI terminal tricks to@@ -477,14 +688,15 @@ -- These tricks sometimes fail, however—in particular, when the test names -- happen to be longer than the width of the terminal window. See ----- * <https://github.com/feuerbach/tasty/issues/152>+-- * <https://github.com/UnkindPartition/tasty/issues/152> ----- * <https://github.com/feuerbach/tasty/issues/250>+-- * <https://github.com/UnkindPartition/tasty/issues/250> -- -- 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.-newtype AnsiTricks = AnsiTricks Bool- deriving Typeable+--+-- @since 1.3+newtype AnsiTricks = AnsiTricks { getAnsiTricks :: Bool } instance IsOption AnsiTricks where defaultValue = AnsiTricks True@@ -493,8 +705,15 @@ optionHelp = return $ -- Multiline literals don't work because of -XCPP. "Enable various ANSI terminal tricks. " ++- "Can be set to 'true' (default) or 'false'."+ "Can be set to 'true' or 'false'."+ showDefaultValue = Just . displayBool . getAnsiTricks +displayBool :: Bool -> String+displayBool b =+ case b of+ False -> "false"+ True -> "true"+ -- | @useColor when isTerm@ decides if colors should be used, -- where @isTerm@ indicates whether @stdout@ is a terminal device. --@@ -514,6 +733,13 @@ "auto" -> return Auto _ -> Nothing +displayUseColor :: UseColor -> String+displayUseColor uc =+ case uc of+ Never -> "never"+ Always -> "always"+ Auto -> "auto"+ -- }}} --------------------------------------------------@@ -564,36 +790,19 @@ then paddedDesc else chomped -data Maximum a- = Maximum a- | MinusInfinity--instance Ord a => Monoid (Maximum a) where- mempty = MinusInfinity-- Maximum a `mappend` Maximum b = Maximum (a `max` b)- MinusInfinity `mappend` a = a- a `mappend` MinusInfinity = a-#if MIN_VERSION_base(4,9,0)-instance Ord a => Semigroup (Maximum a) where- (<>) = mappend-#endif- -- | Compute the amount of space needed to align \"OK\"s and \"FAIL\"s computeAlignment :: OptionSet -> TestTree -> Int computeAlignment opts =- fromMonoid .- foldTestTree- trivialFold- { foldSingle = \_ name _ level -> Maximum (stringWidth name + level)- , foldGroup = \_ m -> m . (+ indentSize)+ max 0 .+ foldTestTree0+ minBound+ TreeFold+ { foldSingle = \_ name _ -> stringWidth name+ , foldGroup = \_ _ m -> if null m then minBound else maximum m + indentSize+ , foldResource = \_ _ f -> f $ throwIO NotRunningTests+ , foldAfter = \_ _ _ b -> b } opts- where- fromMonoid m =- case m 0 of- MinusInfinity -> 0- Maximum x -> x -- | Compute the length/width of the string as it would appear in a monospace -- terminal. This takes into account that even in a “mono”space font, not@@ -603,39 +812,52 @@ -- (This only works properly on Unix at the moment; on Windows, the function -- treats every character as width-1 like 'Data.List.length' does.) stringWidth :: String -> Int-#ifdef UNIX+#ifdef USE_WCWIDTH stringWidth = Prelude.sum . map charWidth- where charWidth c = case wcwidth c of+ where charWidth c = case wcwidth (fromIntegral (ord c)) of -1 -> 1 -- many chars have "undefined" width; default to 1 for these.- w -> w+ w -> fromIntegral w+foreign import capi safe "wchar.h wcwidth" wcwidth :: CWchar -> CInt #else stringWidth = length #endif -- (Potentially) colorful output ok, fail, skipped, infoOk, infoFail :: (?colors :: Bool) => String -> IO ()-fail = output BoldIntensity Vivid Red-ok = output NormalIntensity Dull Green-skipped = output NormalIntensity Dull Magenta-infoOk = output NormalIntensity Dull White-infoFail = output NormalIntensity Dull Red+fail = output failFormat+ok = output okFormat+skipped = output skippedFormat+-- 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 :: (?colors :: Bool)- => ConsoleIntensity- -> ColorIntensity- -> Color+ => ConsoleFormat -> String -> IO ()-output bold intensity color str+output format = withConsoleFormat format . putStr++-- | Run action with console configured for a specific output format+--+-- This function does not apply any output formats if colors are disabled at command+-- line or console detection.+--+-- Can be used by providers that wish to provider specific result details printing,+-- while reusing the tasty formats and coloring logic.+--+-- @since 1.3.1+withConsoleFormat :: (?colors :: Bool) => ConsoleFormatPrinter+withConsoleFormat format action | ?colors = (do setSGR- [ SetColor Foreground intensity color- , SetConsoleIntensity bold+ [ SetColor Foreground (colorIntensity format) (color format)+ , SetConsoleIntensity (consoleIntensity format) ]- putStr str+ action ) `finally` setSGR []- | otherwise = putStr str+ | otherwise = action -- }}}
Test/Tasty/Ingredients/IncludingOptions.hs view
@@ -7,6 +7,8 @@ -- | This ingredient doesn't do anything apart from registering additional -- options. ----- The option values can be accessed using 'askOption'.+-- 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
@@ -1,5 +1,5 @@ -- | Ingredient for listing test names-{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, DeriveDataTypeable #-}+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} module Test.Tasty.Ingredients.ListTests ( ListTests(..) , testsNames@@ -7,7 +7,6 @@ ) where import Data.Proxy-import Data.Typeable import Options.Applicative import Test.Tasty.Core@@ -15,9 +14,11 @@ 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)+ deriving (Eq, Ord) instance IsOption ListTests where defaultValue = ListTests False parseValue = fmap ListTests . safeReadBool@@ -25,16 +26,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 = \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
@@ -1,9 +1,11 @@-{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable,+{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, GADTs, FlexibleInstances, UndecidableInstances, 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@@ -15,6 +17,7 @@ , lookupOption , singleOption , OptionDescription(..)+ , uniqueOptionDescriptions -- * Utilities , flagCLParser , mkFlagCLParser@@ -25,20 +28,21 @@ import qualified Data.Map as Map import Data.Map (Map)+import Data.Maybe import Data.Char (toLower) import Data.Tagged import Data.Proxy import Data.Typeable import Data.Monoid import Data.Foldable+import qualified Data.Semigroup as Sem+import qualified Data.Set as S import Prelude hiding (mod) -- Silence FTP import warnings import Options.Applicative-#if MIN_VERSION_base(4,9,0)-import Data.Semigroup (Semigroup)-import qualified Data.Semigroup (Semigroup((<>)))-#endif -- | 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@@ -52,6 +56,14 @@ -- | The option description or help string. This can be an arbitrary -- string. optionHelp :: Tagged v String+ -- | How a 'defaultValue' should be displayed in the help string. 'Nothing'+ -- (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. -- -- It has a default implementation in terms of the other methods.@@ -62,11 +74,14 @@ -- Even if you override this, you still should implement all the methods -- above, to allow alternative interfaces. --- -- Do not supply a default value here for this parser!- -- This is because if no value was provided on the command line we may- -- lookup the option e.g. in the environment. But if the parser always- -- succeeds, we have no way to tell whether the user really provided the- -- option on the command line.+ -- Do not supply a default value (e.g., with the 'value' function) here+ -- for this parser! This is because if no value was provided on the command+ -- line we may lookup the option e.g. in the environment. But if the parser+ -- always succeeds, we have no way to tell whether the user really provided+ -- the option on the command line.+ --+ -- Similarly, do not use 'showDefaultWith' here, as it will be ignored. Use+ -- the 'showDefaultValue' method of 'IsOption' instead. -- (If we don't specify a default, the option becomes mandatory. -- So, when we build the complete parser for OptionSet, we turn a@@ -81,24 +96,32 @@ -- | 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 instance Monoid OptionSet where mempty = OptionSet mempty- OptionSet a `mappend` OptionSet b =- OptionSet $ Map.unionWith (flip const) a b-#if MIN_VERSION_base(4,9,0)-instance Semigroup OptionSet where- (<>) = mappend+#if !MIN_VERSION_base(4,11,0)+ 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@@ -106,20 +129,39 @@ 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 t'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 --- | Command-line parser to use with flags+-- | Remove duplicated 'OptionDescription', preserving existing order otherwise.+--+-- @since 1.4.1+uniqueOptionDescriptions :: [OptionDescription] -> [OptionDescription]+uniqueOptionDescriptions = go S.empty+ where+ go _ [] = []+ go acc (Option o : os)+ | 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.+--+-- @since 0.8 flagCLParser :: forall v . IsOption v => Maybe Char -- ^ optional short flag@@ -128,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@@ -140,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@@ -148,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
@@ -1,23 +1,27 @@ -- | Core options, i.e. the options used by tasty itself-{-# LANGUAGE CPP, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} -- for (^) module Test.Tasty.Options.Core ( NumThreads(..) , Timeout(..) , mkTimeout+ , HideProgress(..) , coreOptions+ -- * Helpers+ , parseDuration ) where import Control.Monad (mfilter) import Data.Proxy-import Data.Typeable import Data.Fixed import Options.Applicative hiding (str) import GHC.Conc #if !MIN_VERSION_base(4,11,0) import Data.Monoid #endif+import Control.Concurrent+import System.IO.Unsafe import Test.Tasty.Options import Test.Tasty.Patterns@@ -26,43 +30,62 @@ -- -- Note that this is /not/ included in 'coreOptions'. -- Instead, it's automatically included in the options for any--- 'TestReporter' ingredient by 'ingredientOptions', because the way test+-- 'Test.Tasty.Ingredients.TestReporter' ingredient by+-- '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)+ deriving (Eq, Ord, Num) instance IsOption NumThreads where- defaultValue = NumThreads numCapabilities+ defaultValue = unsafePerformIO $ NumThreads <$>+ if rtsSupportsBoundThreads then getNumProcessors else pure 1 parseValue = mfilter onlyPositive . fmap NumThreads . safeRead optionName = return "num-threads" optionHelp = return "Number of threads to use for tests execution" optionCLParser = mkOptionCLParser (short 'j' <> metavar "NUMBER")+ showDefaultValue _ = Just "Number of cores when using threaded RTS, 1 for non-threaded" -- | Filtering function to prevent non-positive number of threads 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 -- @\"0.5m\"@), so that we can print it back. 'Integer' is the number of -- microseconds. | NoTimeout- deriving (Show, Typeable)+ deriving+ ( Eq+ -- ^ Auto-derived instance, just to allow storing in a 'Data.Map.Map' and such.+ --+ -- @since 1.5.1+ , Ord+ -- ^ Auto-derived instance, just to allow storing in a 'Data.Map.Map' and such.+ --+ -- @since 1.5.1+ , Show+ ) instance IsOption Timeout where 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) <$>@@ -77,7 +100,9 @@ _ -> Nothing _ -> Nothing --- | A shortcut for creating 'Timeout' values+-- | A shortcut for creating v'Timeout' values.+--+-- @since 0.8 mkTimeout :: Integer -- ^ microseconds -> Timeout@@ -85,11 +110,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)+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'.+-- t'TestPattern', t'Timeout' and t'HideProgress'.+--+-- @since 0.1 coreOptions :: [OptionDescription] coreOptions = [ Option (Proxy :: Proxy TestPattern) , Option (Proxy :: Proxy Timeout)+ , Option (Proxy :: Proxy HideProgress) ]
Test/Tasty/Options/Env.hs view
@@ -1,5 +1,5 @@ -- | Get options from the environment-{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables #-} module Test.Tasty.Options.Env (getEnvOptions, suiteEnvOptions) where import Test.Tasty.Options@@ -8,14 +8,10 @@ import Test.Tasty.Runners.Reducers import System.Environment-import Data.Foldable import Data.Tagged import Data.Proxy import Data.Char-import Data.Typeable import Control.Exception-import Control.Applicative-import Prelude -- Silence AMP and FTP import warnings import Text.Printf data EnvOptionException@@ -23,7 +19,6 @@ String -- option name String -- variable name String -- value- deriving (Typeable) instance Show EnvOptionException where show (BadOption optName varName value) =
Test/Tasty/Parallel.hs view
@@ -1,5 +1,4 @@ -- | A helper module which takes care of parallelism-{-# LANGUAGE DeriveDataTypeable #-} module Test.Tasty.Parallel (ActionStatus(..), Action(..), runInParallel) where import Control.Monad@@ -8,7 +7,7 @@ import Control.Concurrent.STM import Foreign.StablePtr --- | What to do about an 'Action'?+-- | What to do about an t'Action'? data ActionStatus = ActionReady -- ^ the action is ready to be executed@@ -42,12 +41,18 @@ -- actions themselves. Any exceptions that reach this function or its -- threads are by definition unexpected. runInParallel nthreads actions = do+ -- When linked with threaded RTS, ensure we have enough Capabilities+ -- so that all Haskell worker threads can truly run in parallel.+ when rtsSupportsBoundThreads $ do+ ncap <- getNumCapabilities+ when (ncap < nthreads) $ setNumCapabilities nthreads+ callingThread <- myThreadId -- Don't let the main thread be garbage-collected -- Otherwise we may get a "thread blocked indefinitely in an STM -- transaction" exception when a child thread is blocked and GC'd.- -- (See e.g. https://github.com/feuerbach/tasty/issues/15)+ -- (See e.g. https://github.com/UnkindPartition/tasty/issues/15) -- FIXME is this still needed? _ <- newStablePtr callingThread
Test/Tasty/Patterns.hs view
@@ -1,6 +1,6 @@ -- | Test patterns -{-# LANGUAGE CPP, DeriveDataTypeable #-}+{-# LANGUAGE CPP, TypeApplications #-} module Test.Tasty.Patterns ( TestPattern(..)@@ -18,42 +18,68 @@ import Test.Tasty.Patterns.Eval import Data.Char-import Data.Typeable+import Data.Coerce (coerce)+import Data.List.NonEmpty (nonEmpty)+import Data.Maybe (catMaybes) 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+ ( 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")+#if !defined(mingw32_HOST_OS)+ optionHelp = return "Select only tests which satisfy a pattern or awk expression."+#else+ optionHelp = return+ $ unwords [ "Select only tests which satisfy a pattern or awk expression."+ , "Consider using `MSYS_NO_PATHCONV=1` or `MSYS2_ARG_CONV_EXCL=*`"+ , "to prevent pattern mangling."+ ]+#endif+ 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,20 +1,19 @@ {-# LANGUAGE RankNTypes, ViewPatterns #-}+-- | @since 1.0 module Test.Tasty.Patterns.Eval (Path, eval, withFields, asB) where import Prelude hiding (Ordering(..))-import Control.Monad.Reader-import Control.Monad.Error.Class (throwError) -- see #201+import Control.Monad ((<=<))+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask) import qualified Data.Sequence as Seq import Data.Foldable-import Data.List+import Data.List (findIndex, intercalate, isInfixOf, isPrefixOf, tails) 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 +-- | @since 1.2 type Path = Seq.Seq String data Value@@ -27,6 +26,9 @@ type M = ReaderT Path (Either String) +throwError :: String -> M a+throwError s = lift $ Left s+ asS :: Value -> M String asS v = return $ case v of@@ -64,6 +66,7 @@ VS b s -> b && isJust (parseN s) _ -> True +-- | @since 1.0 asB :: Value -> M Bool asB v = return $ case v of@@ -74,7 +77,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@@ -149,9 +154,11 @@ -> Bool match pat str = pat `isInfixOf` str --- | Run the 'M' monad with a given list of fields+-- | 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@@ -23,23 +25,19 @@ type Token = ReadP --- | A separate 'Parser' data type ensures that we don't forget to skip+-- | A separate t'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) -#if !MIN_VERSION_base(4,6,0)-instance Applicative ReadP where- pure = return- (<*>) = ap-instance Alternative ReadP where- empty = mzero- (<|>) = mplus-#endif--+-- | @since 1.0 data ParseResult a = Success a | Invalid | Ambiguous [a]- deriving Show+ deriving+ ( Show+ , Eq -- ^ @since 1.4.2+ ) token :: Token a -> Parser a token a = Parser (a <* skipSpaces)@@ -51,6 +49,8 @@ str = void . token . string -- | Run a parser+--+-- @since 1.0 runParser :: Parser a -> String -- ^ text to parse@@ -120,21 +120,21 @@ -- -- This roughly corresponds to the @unary_expr@ and @non_unary_expr@ -- non-terminals in the awk grammar.--- (Why roughly? See 'expr2'.)+-- (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'.+-- @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+-- because @makeExprParser@ does not allow us to distinguish it from -- -- >1 -4 + 3 --@@ -178,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
@@ -0,0 +1,66 @@+{-# LANGUAGE LambdaCase #-}+-- | @since 1.4.2++module Test.Tasty.Patterns.Printer+ ( printAwkExpr+ )+ where++import Prelude hiding (LT, GT, EQ)+import Test.Tasty.Patterns.Types++-- | @since 1.4.2+printAwkExpr :: Expr -> String+printAwkExpr e = go 0 e ""++go :: Int -> Expr -> ShowS+go p = \case+ NF -> showString "NF"+ IntLit n -> showsPrec p n+ StringLit xs -> showChar '"' . showString (escapeString xs) . showChar '"'+ ERE xs -> showChar '/' . showString (escapeERE xs) . showChar '/'++ Field x -> showParen (p >= 9) $ showChar '$' . go 9 x++ -- Cf. comment for Test.Tasty.Patterns.Parser.expr2 to understand+ -- why we put showParens when precedence is 6 not 8.+ Neg x -> showParen (p >= 6) $ showChar '-' . go 8 x+ Not x -> showParen (p >= 8) $ showChar '!' . go 8 x++ Add x y -> showParen (p >= 7) $ go 7 x . showChar '+' . go 7 y+ Sub x y -> showParen (p >= 7) $ go 7 x . showChar '-' . go 7 y++ Concat x y -> showParen (p >= 6) $ go 6 x . showChar ' ' . go 6 y++ LT x y -> showParen (p >= 5) $ go 5 x . showChar '<' . go 5 y+ LE x y -> showParen (p >= 5) $ go 5 x . showString "<=" . go 5 y+ GT x y -> showParen (p >= 5) $ go 5 x . showChar '>' . go 5 y+ GE x y -> showParen (p >= 5) $ go 5 x . showString ">=" . go 5 y+ EQ x y -> showParen (p >= 5) $ go 5 x . showString "==" . go 5 y+ NE x y -> showParen (p >= 5) $ go 5 x . showString "!=" . go 5 y++ Match x y -> showParen (p >= 4) $ go 4 x . showChar '~' . go 4 (ERE y)+ NoMatch x y -> showParen (p >= 4) $ go 4 x . showString "!~" . go 4 (ERE y)++ And x y -> showParen (p >= 2) $ go 2 x . showString "&&" . go 2 y++ Or x y -> showParen (p >= 1) $ go 1 x . showString "||" . go 1 y++ If c t f -> showParen (p >= 0) $ go 0 c . showChar '?' . go 0 t . showChar ':' . go 0 f++ ToUpperFn x -> showString "toupper(" . go 0 x . showChar ')'+ ToLowerFn x -> showString "tolower(" . go 0 x . showChar ')'++ LengthFn Nothing -> showString "length()"+ LengthFn (Just x) -> showString "length(" . go 0 x . showChar ')'++ SubstrFn x y Nothing -> showString "substr(" . go 0 x . showChar ',' . go 0 y . showChar ')'+ SubstrFn x y (Just z) -> showString "substr(" . go 0 x . showChar ',' . go 0 y . showChar ',' . go 0 z . showChar ')'++ MatchFn x y -> showString "match(" . go 0 x . showChar ',' . go 0 (ERE y) . showChar ')'++escapeString :: String -> String+escapeString = concatMap $ \c -> (if c `elem` "\\\"" then ('\\' :) else id) [c]++escapeERE :: String -> String+escapeERE = concatMap $ \c -> (if c `elem` "\\/" then ('\\' :) else id) [c]
Test/Tasty/Patterns/Types.hs view
@@ -1,5 +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@@ -27,4 +33,8 @@ | LengthFn (Maybe Expr) | MatchFn Expr String | SubstrFn Expr Expr (Maybe Expr)- deriving (Show, Eq)+ deriving+ ( Show+ , Eq -- ^ @since 1.1+ , Generic -- ^ @since 1.4.2+ )
Test/Tasty/Providers.hs view
@@ -1,8 +1,11 @@--- | API for test providers+-- | API for test providers.+--+-- @since 0.1 module Test.Tasty.Providers ( IsTest(..) , testPassed , testFailed+ , testFailedDetails , Result , Progress(..) , TestName@@ -12,12 +15,17 @@ where 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+-- | t'Result' of a passed test.+--+-- @since 0.8 testPassed :: String -- ^ description (may be empty) -> Result@@ -26,15 +34,15 @@ , resultDescription = desc , resultShortDescription = "OK" , resultTime = 0+ , resultDetailsPrinter = noResultDetails } --- | 'Result' of a failed test-testFailed- :: String -- ^ description+-- | t'Result' of a failed test with custom details printer+--+-- @since 1.3.1+testFailedDetails+ :: String -- ^ description+ -> ResultDetailsPrinter -- ^ details printer -> Result-testFailed desc = Result- { resultOutcome = Failure TestFailed- , resultDescription = desc- , resultShortDescription = "FAIL"- , resultTime = 0- }+testFailedDetails desc printer = (testFailed desc)+ { resultDetailsPrinter = printer }
+ Test/Tasty/Providers/ConsoleFormat.hs view
@@ -0,0 +1,87 @@+-- | This module can be used by providers to perform colorful/formatted+-- output and possibly reuse tasty's own output formats.+--+-- @since 1.3.1+module Test.Tasty.Providers.ConsoleFormat+ ( ResultDetailsPrinter(..)+ , ConsoleFormat(..)+ , ConsoleFormatPrinter+ , noResultDetails+ , failFormat+ , infoFailFormat+ , infoOkFormat+ , okFormat+ , skippedFormat+ )+where++import System.Console.ANSI++-- | Console output format+--+-- @since 1.3.1+data ConsoleFormat = ConsoleFormat+ { consoleIntensity :: ConsoleIntensity+ , colorIntensity :: ColorIntensity+ , color :: Color+ }++-- | Type of console format printer functions+--+-- @since 1.3.1+type ConsoleFormatPrinter+ = ConsoleFormat -- ^ selected console format+ -> IO () -- ^ action to be executed with active console format+ -> IO ()++-- | Noop result details printer. The default for most providers.+--+-- @since 1.3.1+noResultDetails :: ResultDetailsPrinter+noResultDetails = ResultDetailsPrinter . const . const $ return ()++-- | An action that prints additional information about a test using+-- colors/formatting; see 'Test.Tasty.Providers.testFailedDetails' and+-- 'Test.Tasty.Runners.resultDetailsPrinter'.+--+-- As input, this action is provided with the current indentation level and+-- a 'ConsoleFormatPrinter', which tells it how perform output.+--+-- This is a newtype to allow a 'Show' instance.+--+-- @since 1.3.1+newtype ResultDetailsPrinter = ResultDetailsPrinter+ (Int -> ConsoleFormatPrinter -> IO ())++instance Show ResultDetailsPrinter where+ show _printer = "ResultDetailsPrinter"++-- | Format used to display failures+--+-- @since 1.3.1+failFormat :: ConsoleFormat+failFormat = ConsoleFormat BoldIntensity Vivid Red++-- | Format used to display additional information on failures+--+-- @since 1.3.1+infoFailFormat :: ConsoleFormat+infoFailFormat = ConsoleFormat NormalIntensity Dull Red++-- | Format used to display successes+--+-- @since 1.3.1+okFormat :: ConsoleFormat+okFormat = ConsoleFormat NormalIntensity Dull Green++-- | Format used to display additional information on successes+--+-- @since 1.3.1+infoOkFormat :: ConsoleFormat+infoOkFormat = ConsoleFormat NormalIntensity Dull White++-- | Format used to display skipped tests+--+-- @since 1.3.1+skippedFormat :: ConsoleFormat+skippedFormat = ConsoleFormat NormalIntensity Dull Magenta
Test/Tasty/Run.hs view
@@ -1,32 +1,45 @@ -- | Running tests {-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes,- FlexibleContexts, BangPatterns, CPP, DeriveDataTypeable #-}+ FlexibleContexts, CPP, LambdaCase,+ RecordWildCards, NamedFieldPuns #-} module Test.Tasty.Run ( Status(..) , StatusMap , launchTestTree+ , applyTopLevelPlusTestOptions , DependencyException(..) ) where -import qualified Data.IntMap as IntMap+import qualified Data.IntMap.Strict as IntMap import qualified Data.Sequence as Seq import qualified Data.Foldable as F+import Data.Int (Int64) import Data.Maybe+import Data.List (intercalate) import Data.Graph (SCC(..), stronglyConnComp)-import Data.Typeable-import Control.Monad.State-import Control.Monad.Writer-import Control.Monad.Reader+import Data.Sequence (Seq, (|>), (<|), (><))+import Control.Monad (forever, guard, join, liftM)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (ReaderT(..), local, ask)+import Control.Monad.Trans.Writer (execWriterT, tell) import Control.Concurrent import Control.Concurrent.STM-import Control.Concurrent.Timeout (timeout) import Control.Concurrent.Async import Control.Exception as E-import Control.Applicative import Control.Arrow+import Data.Monoid (First(..)) 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+import System.Timeout (timeout)+#endif+ import Test.Tasty.Core import Test.Tasty.Parallel import Test.Tasty.Patterns@@ -34,9 +47,12 @@ import Test.Tasty.Options import Test.Tasty.Options.Core import Test.Tasty.Runners.Reducers-import Test.Tasty.Runners.Utils (timed)+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@@ -44,12 +60,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@@ -86,11 +106,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.@@ -100,17 +121,30 @@ -- 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 $ wait asy+ timed $ applyTimeout timeoutOpt $ do+ r <- wait asy+ -- Not only wait for the result to be returned, but make sure to+ -- evaluate it inside applyTimeout; see #280.+ evaluate $+ resultOutcome r `seq`+ forceElements (resultDescription r) `seq`+ forceElements (resultShortDescription r)+ return r -- 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 }@@ -157,8 +191,11 @@ "Timed out after " ++ tstr , resultShortDescription = "TIMEOUT" , resultTime = fromIntegral t+ , resultDetailsPrinter = noResultDetails }- fromMaybe timeoutResult <$> timeout t a+ -- If compiled with unbounded-delays then t' :: Integer, otherwise t' :: Int+ let t' = fromInteger (min (max 0 t) (toInteger (maxBound :: Int64)))+ fromMaybe timeoutResult <$> timeout t' a -- destroyResources should not be interrupted by an exception -- Here's how we ensure this:@@ -185,119 +222,249 @@ 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/feuerbach/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.- deriving (Typeable)+ -- A finishes. Field lists detected cycles.+ --+ -- @since 1.5 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 t'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 accumulator 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 t'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 t'TestAction') and the resources needed to run them (as t'Initializer's and+-- t'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 = \name (Traversal a) ->- Traversal $ local (first (Seq.|> name)) a- , foldAfter = \deptype pat (Traversal a) ->- Traversal $ 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) <- 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 :: ResourceSpec a -> (IO a -> Tr) -> Tr- addInitAndRelease (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 $ local $ (Seq.|> ini) *** (fin Seq.<|)) 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+ Independent Parallel -> sequence trees+ Independent NonParallel -> foldSequential AllFinish trees+ Dependent depType -> foldSequential depType trees++ foldSequential :: DependencyType -> [Tr] -> ReaderT (Path, Seq Dependency) IO [TestActionTree UnresolvedAction]+ foldSequential depType =+ fmap snd . mapAccumM (goSeqGroup depType) mempty++ -- * 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@@ -316,29 +483,55 @@ 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 = "" , resultShortDescription = "SKIP" , resultTime = 0+ , 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 =@@ -383,13 +576,40 @@ FailedToCreate {} -> return $ return Nothing Destroyed -> return $ return Nothing +-- While tasty allows to configure t'OptionSet' at any level of test tree,+-- it often has any effect only on options of test providers (class IsTest).+-- But test runners and reporters typically only look into the OptionSet+-- they were given as an argument. This is not unreasonable: e. g., if an option+-- is a log filename you cannot expect to change it in the middle of the run.+-- It is however too restrictive: there is no way to use 'defaultMain' but hardcode+-- a global option, without passing it via command line.+--+-- 'applyTopLevelPlusTestOptions' allows for a compromise: unwrap top-level+-- 'PlusTestOptions' from the 'TestTree' and apply them to the t'OptionSet'+-- from command line. This way a user can wrap their tests in+-- 'adjustOption' / 'localOption' forcing, for instance, t'NumThreads' to 1.+--+-- This function is not publicly exposed.+applyTopLevelPlusTestOptions+ :: OptionSet+ -- ^ Raw options, typically from the command-line arguments.+ -> TestTree+ -- ^ Raw test tree.+ -> (OptionSet, TestTree)+ -- ^ Extended options and test tree stripped of outer layers of 'PlusTestOptions'.+applyTopLevelPlusTestOptions opts (PlusTestOptions f tree) =+ applyTopLevelPlusTestOptions (f opts) tree+applyTopLevelPlusTestOptions opts tree = (opts, tree)+ -- | Start running the tests (in background, in parallel) and pass control -- to the callback. -- -- Once the callback returns, stop running the tests. ----- The number of test running threads is determined by the 'NumThreads'+-- The number of test running threads is determined by the t'NumThreads' -- option.+--+-- @since 0.10 launchTestTree :: OptionSet -> TestTree@@ -407,12 +627,17 @@ -- all resource initializers and finalizers, which is why it is more -- accurate than what could be measured from inside the first callback. -> IO a-launchTestTree opts tree k0 = do+launchTestTree opts' tree' k0 = do+ -- Normally 'applyTopLevelPlusTestOptions' has been already applied by+ -- 'Test.Tasty.Ingredients.tryIngredients', but 'launchTestTree' is exposed+ -- publicly, so in principle clients could use it outside of 'tryIngredients'.+ -- Thus running 'applyTopLevelPlusTestOptions' again, just to be sure.+ let (opts, tree) = applyTopLevelPlusTestOptions opts' tree' (testActions, fins) <- createTestActions opts tree- let NumThreads numTheads = lookupOption opts+ let NumThreads numThreads = lookupOption opts (t,k1) <- timed $ do- abortTests <- runInParallel numTheads (fst <$> testActions)- (do let smap = IntMap.fromList $ zip [0..] (snd <$> testActions)+ abortTests <- runInParallel numThreads (testAction <$> testActions)+ (do let smap = IntMap.fromDistinctAscList $ 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
@@ -41,35 +41,38 @@ module Test.Tasty.Runners.Reducers where +import Prelude hiding (Applicative(..)) import Control.Applicative-import Prelude -- Silence AMP import warnings-#if MIN_VERSION_base(4,9,0)-import Data.Semigroup (Semigroup)-import qualified Data.Semigroup (Semigroup((<>)))-#else-import Data.Monoid-#endif+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 mempty = Traversal $ pure ()- Traversal f1 `mappend` Traversal f2 = Traversal $ f1 *> f2-#if MIN_VERSION_base(4,9,0)-instance Applicative f => Semigroup (Traversal f) where- (<>) = mappend+#if !MIN_VERSION_base(4,11,0)+ mappend = (Sem.<>) #endif -- | Monoid generated by @'liftA2' ('<>')@ -- -- 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 mempty = pure mempty- mappend = liftA2 mappend-#if MIN_VERSION_base(4,9,0)-instance (Applicative f, Monoid a) => Semigroup (Ap f a) where- (<>) = mappend+#if !MIN_VERSION_base(4,11,0)+ mappend = (Sem.<>) #endif
Test/Tasty/Runners/Utils.hs view
@@ -4,41 +4,44 @@ module Test.Tasty.Runners.Utils where import Control.Exception-import Control.Applicative-#ifndef VERSION_clock-import Data.Time.Clock.POSIX (getPOSIXTime)-#endif-import Data.Typeable (Typeable)-import Prelude -- Silence AMP import warnings+import Control.Concurrent (mkWeakThreadId, myThreadId)+import Control.Monad (forM_) import Text.Printf import Foreign.C (CInt)-#ifdef VERSION_clock-import qualified System.Clock as Clock-#endif -import Test.Tasty.Core (Time)+#if MIN_VERSION_base(4,11,0)+import GHC.Clock (getMonotonicTime)+#else+import Data.Time.Clock.POSIX (getPOSIXTime)+#endif --- We install handlers only on UNIX (obviously) and on GHC >= 7.6.--- GHC 7.4 lacks mkWeakThreadId (see #181), and this is not important--- enough to look for an alternative implementation, so we just disable it--- there.-#define INSTALL_HANDLERS defined __UNIX__ && MIN_VERSION_base(4,6,0)+#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 Control.Concurrent (mkWeakThreadId, myThreadId)-import Control.Exception (Exception(..), throwTo)-import Control.Monad (forM_) import System.Posix.Signals import System.Mem.Weak (deRefWeak) #endif +import Test.Tasty.Core (Time)+ -- | Catch possible exceptions that may arise when evaluating a string. -- For normal (total) strings, this is a no-op. -- -- This function should be used to display messages generated by the test -- suite (such as test result descriptions). ----- See e.g. <https://github.com/feuerbach/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@@ -51,28 +54,31 @@ Right () -> return msg Left e' -> printf "message threw an exception: %s" <$> go (recLimit-1) (show (e' :: SomeException)) --- https://ro-che.info/articles/2015-05-28-force-list+-- | Force elements of a list+-- (<https://ro-che.info/articles/2015-05-28-force-list>).+--+-- @since 1.0.1 forceElements :: [a] -> () forceElements = foldr seq () -- from https://ro-che.info/articles/2014-07-30-bracket -- | Install signal handlers so that e.g. the cursor is restored if the test--- suite is killed by SIGTERM. Upon a signal, a 'SignalException' will be+-- suite is killed by SIGTERM. Upon a signal, a t'SignalException' will be -- thrown to the thread that has executed this action. -- -- This function is called automatically from the @defaultMain*@ family of -- functions. You only need to call it explicitly if you call--- 'tryIngredients' yourself.+-- '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 main_thread_id <- myThreadId weak_tid <- mkWeakThreadId main_thread_id- forM_ [ sigABRT, sigBUS, sigFPE, sigHUP, sigILL, sigQUIT, sigSEGV,- sigSYS, sigTERM, sigUSR1, sigUSR2, sigXCPU, sigXFSZ ] $ \sig ->+ forM_ [ sigHUP, sigTERM, sigUSR1, sigUSR2, sigXCPU, sigXFSZ ] $ \sig -> installHandler sig (Catch $ send_exception weak_tid sig) Nothing where send_exception weak_tid sig = do@@ -90,11 +96,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)+ deriving (Show) 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@@ -102,23 +112,19 @@ end <- getTime return (end-start, r) -#ifdef VERSION_clock--- | Get monotonic time+#if MIN_VERSION_base(4,11,0)+-- | 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 = do- t <- Clock.getTime Clock.Monotonic- let ns = realToFrac $-#if MIN_VERSION_clock(0,7,1)- Clock.toNanoSecs t-#else- Clock.timeSpecAsNanoSecs t-#endif- return $ ns / 10 ^ (9 :: Int)+getTime = getMonotonicTime #else--- | Get system time+-- | Get system time.+--+-- @since 1.2.2 getTime :: IO Time getTime = realToFrac <$> getPOSIXTime #endif
tasty.cabal view
@@ -1,8 +1,6 @@--- Initial tasty.cabal generated by cabal init. For further documentation,--- see http://haskell.org/cabal/users-guide/-+cabal-version: >=1.10 name: tasty-version: 1.2.3+version: 1.5.4 synopsis: Modern and extensible testing framework description: Tasty is a modern testing framework for Haskell. It lets you combine your unit tests, golden@@ -12,77 +10,80 @@ license-file: LICENSE author: Roman Cheplyaka <roma@ro-che.info> maintainer: Roman Cheplyaka <roma@ro-che.info>-homepage: https://github.com/feuerbach/tasty-bug-reports: https://github.com/feuerbach/tasty/issues--- copyright: +homepage: https://github.com/UnkindPartition/tasty+bug-reports: https://github.com/UnkindPartition/tasty/issues+-- copyright: category: Testing build-type: Simple extra-source-files: CHANGELOG.md, README.md-cabal-version: >=1.10 Source-repository head type: git- location: git://github.com/feuerbach/tasty.git+ location: https://github.com/UnkindPartition/tasty.git subdir: core -flag clock+flag unix description:- Depend on the clock package for more accurate time measurement+ Depend on the unix package to install signal handlers default: True library exposed-modules:- Test.Tasty,- Test.Tasty.Options,- Test.Tasty.Providers,+ Test.Tasty+ Test.Tasty.Options+ Test.Tasty.Providers+ Test.Tasty.Providers.ConsoleFormat Test.Tasty.Runners- Test.Tasty.Ingredients,+ 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.Printer 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,- Test.Tasty.CmdLine,+ Control.Concurrent.Async+ 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+ Test.Tasty.CmdLine Test.Tasty.Ingredients.ListTests Test.Tasty.Ingredients.IncludingOptions+ build-depends:- base >= 4.5 && < 5,- stm >= 2.3,- containers,- mtl >= 2.1.3.1,- tagged >= 0.5,- optparse-applicative >= 0.14,- unbounded-delays >= 0.1,- async >= 2.0,- ansi-terminal >= 0.9+ base >= 4.9 && < 5,+ stm >= 2.3 && < 2.6,+ containers >= 0.5.8 && < 0.9,+ transformers >= 0.5 && < 0.7,+ tagged >= 0.5 && < 0.9,+ optparse-applicative >= 0.14 && < 0.20,+ ansi-terminal >= 0.9 && < 1.2 - if flag(clock)- build-depends: clock >= 0.4.4.0- else- build-depends: time >= 1.4+ -- No reason to depend on unbounded-delays on 64-bit architecture+ if(!arch(x86_64) && !arch(aarch64) && !arch(ppc64le) && !arch(ppc64) && !arch(s390x) && !arch(riscv64) && !arch(loongarch64))+ build-depends:+ unbounded-delays >= 0.1 && < 0.2 - if impl(ghc < 7.6)- -- for GHC.Generics- build-depends: ghc-prim+ if(!impl(ghc >= 8.4))+ build-depends: time >= 1.4 && < 1.13 if !os(windows) && !impl(ghcjs)- build-depends: unix,- wcwidth- cpp-options: -D__UNIX__+ cpp-options: -DUSE_WCWIDTH+ if flag(unix)+ build-depends: unix < 2.9 - -- hs-source-dirs: + -- hs-source-dirs: default-language: Haskell2010- default-extensions: CPP, ScopedTypeVariables, DeriveDataTypeable- ghc-options: -Wall+ default-extensions: CPP, ScopedTypeVariables+ ghc-options:+ -Wall+ -Wno-incomplete-uni-patterns+ -Wcompat