diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 for the discussion. +See 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 - + 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 ----------- diff --git a/Control/Concurrent/Async.hs b/Control/Concurrent/Async.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/Async.hs @@ -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 #) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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: -![](https://raw.github.com/feuerbach/tasty/master/screenshot.png) +![](https://raw.github.com/UnkindPartition/tasty/master/screenshot.png) (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. diff --git a/Test/Tasty.hs b/Test/Tasty.hs --- a/Test/Tasty.hs +++ b/Test/Tasty.hs @@ -21,9 +21,11 @@ -- > assertBool "Oops, 7 is odd" (even 7) -- > ] -- --- Take a look at the : +-- Take a look at the : -- 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 diff --git a/Test/Tasty/CmdLine.hs b/Test/Tasty/CmdLine.hs --- a/Test/Tasty/CmdLine.hs +++ b/Test/Tasty/CmdLine.hs @@ -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 diff --git a/Test/Tasty/Core.hs b/Test/Tasty/Core.hs --- a/Test/Tasty/Core.hs +++ b/Test/Tasty/Core.hs @@ -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] diff --git a/Test/Tasty/Ingredients.hs b/Test/Tasty/Ingredients.hs --- a/Test/Tasty/Ingredients.hs +++ b/Test/Tasty/Ingredients.hs @@ -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 -> diff --git a/Test/Tasty/Ingredients/Basic.hs b/Test/Tasty/Ingredients/Basic.hs --- a/Test/Tasty/Ingredients/Basic.hs +++ b/Test/Tasty/Ingredients/Basic.hs @@ -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(..) diff --git a/Test/Tasty/Ingredients/ConsoleReporter.hs b/Test/Tasty/Ingredients/ConsoleReporter.hs --- a/Test/Tasty/Ingredients/ConsoleReporter.hs +++ b/Test/Tasty/Ingredients/ConsoleReporter.hs @@ -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 -- --- * +-- * -- --- * +-- * -- -- 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 -- }}} diff --git a/Test/Tasty/Ingredients/IncludingOptions.hs b/Test/Tasty/Ingredients/IncludingOptions.hs --- a/Test/Tasty/Ingredients/IncludingOptions.hs +++ b/Test/Tasty/Ingredients/IncludingOptions.hs @@ -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) diff --git a/Test/Tasty/Ingredients/ListTests.hs b/Test/Tasty/Ingredients/ListTests.hs --- a/Test/Tasty/Ingredients/ListTests.hs +++ b/Test/Tasty/Ingredients/ListTests.hs @@ -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 -> diff --git a/Test/Tasty/Options.hs b/Test/Tasty/Options.hs --- a/Test/Tasty/Options.hs +++ b/Test/Tasty/Options.hs @@ -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 diff --git a/Test/Tasty/Options/Core.hs b/Test/Tasty/Options/Core.hs --- a/Test/Tasty/Options/Core.hs +++ b/Test/Tasty/Options/Core.hs @@ -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) ] diff --git a/Test/Tasty/Options/Env.hs b/Test/Tasty/Options/Env.hs --- a/Test/Tasty/Options/Env.hs +++ b/Test/Tasty/Options/Env.hs @@ -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) = diff --git a/Test/Tasty/Parallel.hs b/Test/Tasty/Parallel.hs --- a/Test/Tasty/Parallel.hs +++ b/Test/Tasty/Parallel.hs @@ -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 diff --git a/Test/Tasty/Patterns.hs b/Test/Tasty/Patterns.hs --- a/Test/Tasty/Patterns.hs +++ b/Test/Tasty/Patterns.hs @@ -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 diff --git a/Test/Tasty/Patterns/Eval.hs b/Test/Tasty/Patterns/Eval.hs --- a/Test/Tasty/Patterns/Eval.hs +++ b/Test/Tasty/Patterns/Eval.hs @@ -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 diff --git a/Test/Tasty/Patterns/Parser.hs b/Test/Tasty/Patterns/Parser.hs --- a/Test/Tasty/Patterns/Parser.hs +++ b/Test/Tasty/Patterns/Parser.hs @@ -1,6 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | See 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 diff --git a/Test/Tasty/Patterns/Printer.hs b/Test/Tasty/Patterns/Printer.hs new file mode 100644 --- /dev/null +++ b/Test/Tasty/Patterns/Printer.hs @@ -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] diff --git a/Test/Tasty/Patterns/Types.hs b/Test/Tasty/Patterns/Types.hs --- a/Test/Tasty/Patterns/Types.hs +++ b/Test/Tasty/Patterns/Types.hs @@ -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 + ) diff --git a/Test/Tasty/Providers.hs b/Test/Tasty/Providers.hs --- a/Test/Tasty/Providers.hs +++ b/Test/Tasty/Providers.hs @@ -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 } diff --git a/Test/Tasty/Providers/ConsoleFormat.hs b/Test/Tasty/Providers/ConsoleFormat.hs new file mode 100644 --- /dev/null +++ b/Test/Tasty/Providers/ConsoleFormat.hs @@ -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 diff --git a/Test/Tasty/Run.hs b/Test/Tasty/Run.hs --- a/Test/Tasty/Run.hs +++ b/Test/Tasty/Run.hs @@ -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 [] = "- " + 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 ++ ") ()" + +-- | 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. diff --git a/Test/Tasty/Runners.hs b/Test/Tasty/Runners.hs --- a/Test/Tasty/Runners.hs +++ b/Test/Tasty/Runners.hs @@ -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(..) diff --git a/Test/Tasty/Runners/Reducers.hs b/Test/Tasty/Runners/Reducers.hs --- a/Test/Tasty/Runners/Reducers.hs +++ b/Test/Tasty/Runners/Reducers.hs @@ -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 diff --git a/Test/Tasty/Runners/Utils.hs b/Test/Tasty/Runners/Utils.hs --- a/Test/Tasty/Runners/Utils.hs +++ b/Test/Tasty/Runners/Utils.hs @@ -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. +-- See e.g. . +-- +-- @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 +-- (). +-- +-- @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 diff --git a/tasty.cabal b/tasty.cabal --- a/tasty.cabal +++ b/tasty.cabal @@ -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 maintainer: Roman Cheplyaka -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