diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,221 @@ 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 +------------- + +* Expose `computeStatistics` from `Test.Tasty.Ingredients.ConsoleReporter`. +* Ensure that `finally` and `bracket` work as expected inside tests + when the test suite is interrupted by Ctrl-C. + +Version 1.2.2 +------------- + +* Expose timed and getTime +* Add parseOptions +* Allow to disable ANSI tricks with --ansi-tricks=false + +Version 1.2.1 +------------- + +* Document and expose installSignalHandlers +* Enable colors in Emacs and other almost-ANSI-capable terminals + Version 1.2 ----------- @@ -39,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. @@ -264,7 +479,7 @@ --------------- Be careful not to export the `Show (a -> b)` instance, see - + Version 0.8.1.2 --------------- @@ -326,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 --------------- @@ -368,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.) @@ -85,7 +85,7 @@ [tasty][] is the core package. It contains basic definitions and APIs and a console runner. -[tasty]: http://hackage.haskell.org/package/tasty +[tasty]: https://hackage.haskell.org/package/tasty In order to create a test suite, you also need to install one or more «providers» (see below). @@ -94,26 +94,33 @@ The following providers exist: -* [tasty-hunit](http://hackage.haskell.org/package/tasty-hunit) — for unit tests - (based on [HUnit](http://hackage.haskell.org/package/HUnit)) +* [tasty-hunit](https://hackage.haskell.org/package/tasty-hunit) — for unit tests + (based on [HUnit](https://hackage.haskell.org/package/HUnit)) * [tasty-golden][] — for golden tests, which are unit tests whose results are kept in files -* [tasty-smallcheck](http://hackage.haskell.org/package/tasty-smallcheck) — +* [tasty-smallcheck](https://hackage.haskell.org/package/tasty-smallcheck) — exhaustive property-based testing - (based on [smallcheck](http://hackage.haskell.org/package/smallcheck)) -* [tasty-quickcheck](http://hackage.haskell.org/package/tasty-quickcheck) — for randomized + (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 - property-based testing (based on [Hedgehog](http://hackage.haskell.org/package/hedgehog)) -* [tasty-hspec](http://hackage.haskell.org/package/tasty-hspec) — for - [Hspec](http://hspec.github.io/) tests -* [tasty-leancheck](http://hackage.haskell.org/package/tasty-leancheck) — for +* [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 +* [tasty-leancheck](https://hackage.haskell.org/package/tasty-leancheck) — for enumerative property-based testing - (based on [LeanCheck](http://hackage.haskell.org/package/leancheck)) -* [tasty-program](http://hackage.haskell.org/package/tasty-program) — run + (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/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]: http://hackage.haskell.org/package/tasty-golden +[tasty-golden]: https://hackage.haskell.org/package/tasty-golden It's easy to create custom providers using the API from `Test.Tasty.Providers`. @@ -129,29 +136,37 @@ Some ingredients that can enhance your test suite are: -* [tasty-ant-xml](http://hackage.haskell.org/package/tasty-ant-xml) adds a +* [tasty-ant-xml](https://hackage.haskell.org/package/tasty-ant-xml) adds a possibility to write the test results in a machine-readable XML format, which is understood by various CI systems and IDEs -* [tasty-rerun](http://hackage.haskell.org/package/tasty-rerun) adds support for +* [tasty-rerun](https://hackage.haskell.org/package/tasty-rerun) adds support for minimal test reruns by recording previous test runs and using this information to filter the test tree. For example, you can use this ingredient to only run failed tests, or only run tests that threw an exception. -* [tasty-html](http://hackage.haskell.org/package/tasty-html) adds the +* [tasty-html](https://hackage.haskell.org/package/tasty-html) adds the possibility to write the test results as a HTML file -* [tasty-stats](http://hackage.haskell.org/package/tasty-stats) adds the +* [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](http://hackage.haskell.org/package/tasty-th) automatically -discovers tests based on the function names and generate the boilerplate code for -you -* [tasty-hunit-adapter](http://hackage.haskell.org/package/tasty-hunit-adapter) +* [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 @@ -178,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 @@ -191,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 @@ -269,7 +300,7 @@ name, and so on up to `$NF`, which is set to the test's own name. The field `$0` is set to all other fields concatenated using `.` as a separator. -[awk]: http://pubs.opengroup.org/onlinepubs/9699919799/utilities/awk.html#tag_20_06_13_02 +[awk]: https://pubs.opengroup.org/onlinepubs/9699919799/utilities/awk.html#tag_20_06_13_02 As an example, consider a test inside two test groups: @@ -672,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: @@ -689,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 ``` @@ -725,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. @@ -736,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)*, @@ -752,15 +792,17 @@ 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. When my tests write to stdout/stderr, the output is garbled. Why is that and +1. **Q**: When my tests write to stdout/stderr, the output is garbled. Why is that and what do I do? - It is not recommended that you print anything to the console when using the + **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: @@ -769,32 +811,70 @@ * Use a test reporter that does not print to the console (like tasty-ant-xml). * Write your output to files instead. +2. **Q**: Why doesn't the `--hide-successes` option work properly? The test headings + show up and/or the output appears garbled. + + **A**: This can happen sometimes when the terminal is narrower than the + 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/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 something not mentioned here, send a pull request! -* [Holy Haskell Project Starter](http://yannesposito.com/Scratch/en/blog/Holy-Haskell-Starter/) -* [First time testing, also with FP Complete](http://levischuck.com/posts/2013-11-13-first-testing-and-fpcomplete.html) +* [Holy Haskell Project Starter](https://yannesposito.com/Scratch/en/blog/Holy-Haskell-Starter/) +* [First time testing, also with FP Complete](https://levischuck.com/posts/2013-11-13-first-testing-and-fpcomplete.html) (tasty has been added to stackage since then) -* [24 Days of Hackage: tasty](http://ocharles.org.uk/blog/posts/2013-12-03-24-days-of-hackage-tasty.html) +* [24 Days of Hackage: tasty](https://ocharles.org.uk/blog/posts/2013-12-03-24-days-of-hackage-tasty.html) * [Resources in Tasty](https://ro-che.info/articles/2013-12-10-tasty-resources) * [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](http://ocharles.org.uk/blog/posts/2014-01-20-announcing-tasty-rerun.html) -* [Code testing in Haskell revisited (with Tasty)](http://lambda.jstolarek.com/2014/01/code-testing-in-haskell-revisited-with-tasty/) +* [Announcing tasty-rerun](https://ocharles.org.uk/blog/posts/2014-01-20-announcing-tasty-rerun.html) +* [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] [custom-options-article]: https://ro-che.info/articles/2013-12-20-tasty-custom-options.html [awk-patterns-article]: https://ro-che.info/articles/2018-01-08-tasty-new-patterns -[tasty-directories]: http://nmattia.com/posts/2018-04-30-tasty-test-names.html +[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 @@ -1,74 +1,175 @@ -- | Parsing options supplied on the command line -{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable #-} module Test.Tasty.CmdLine ( optionParser , suiteOptions , suiteOptionParser + , parseOptions , 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 - --- 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) - -#if INSTALL_HANDLERS -import Control.Concurrent (mkWeakThreadId, myThreadId) -import Control.Exception (Exception(..), throwTo) -import Control.Monad (forM_) -import Data.Typeable (Typeable) -import System.Posix.Signals -import System.Mem.Weak (deRefWeak) -#endif -#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 +import Test.Tasty.Runners.Utils import Test.Tasty.Ingredients import Test.Tasty.Options import Test.Tasty.Options.Env import Test.Tasty.Runners.Reducers +-- | 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) --- | 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 +-- 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) --- | The command line parser for the test suite -suiteOptionParser :: [Ingredient] -> TestTree -> Parser OptionSet + 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 'Test.Tasty.defaultMain' is called. +-- +-- 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 '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 <*> 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 - cmdlineOpts <- execParser $ - info (helper <*> suiteOptionParser ins testTree) - ( fullDesc <> - header "Mmm... tasty test suite" - ) - - envOpts <- suiteEnvOptions ins testTree - - let opts = envOpts <> cmdlineOpts + opts <- parseOptions ins testTree case tryIngredients ins opts testTree of Nothing -> do @@ -78,28 +179,3 @@ Just act -> do ok <- act if ok then exitSuccess else exitFailure - --- from https://ro-che.info/articles/2014-07-30-bracket --- Install a signal handler so that e.g. the cursor is restored if the test --- suite is killed by SIGTERM. -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 -> - installHandler sig (Catch $ send_exception weak_tid sig) Nothing - where - send_exception weak_tid sig = do - m <- deRefWeak weak_tid - case m of - Nothing -> return () - Just tid -> throwTo tid (toException $ SignalException sig) - -newtype SignalException = SignalException Signal - deriving (Show, Typeable) -instance Exception SignalException -#else - return () -#endif 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,15 @@ --- 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 -- simplify the task of rolling your own custom console reporter UI. @@ -14,48 +19,54 @@ , useColor -- ** Test failure statistics , Statistics(..) + , computeStatistics , printStatistics , printStatisticsNoTime -- ** Outputting results , 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 @@ -67,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 @@ -99,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 @@ -108,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 @@ -124,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 @@ -152,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 @@ -160,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. @@ -170,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) @@ -189,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 = @@ -202,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 ) @@ -278,14 +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 t'Statistics' for +-- a given state of the 'StatusMap'. +-- 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)) @@ -334,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 @@ -348,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 -- }}} @@ -374,14 +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) - ] $ +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 @@ -389,6 +575,7 @@ Quiet quiet = lookupOption opts HideSuccesses hideSuccesses = lookupOption opts NumThreads numThreads = lookupOption opts + AnsiTricks ansiTricks = lookupOption opts if quiet then do @@ -398,23 +585,30 @@ do isTerm <- hSupportsANSI stdout + 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 let - ?colors = useColor whenColor isTerm + ?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 -> + | hideSuccesses && isTerm && ansiTricks -> consoleOutputHidingSuccesses toutput smap - | hideSuccesses && not isTerm -> + | hideSuccesses -> streamOutputHidingSuccesses toutput smap | otherwise -> consoleOutput toutput smap } @@ -424,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 @@ -434,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 @@ -444,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 @@ -451,16 +669,51 @@ = 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 +-- display the name of the currently running test and then erase it if it +-- succeeds. +-- +-- 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. +-- +-- @since 1.3 +newtype AnsiTricks = AnsiTricks { getAnsiTricks :: Bool } + +instance IsOption AnsiTricks where + defaultValue = AnsiTricks True + parseValue = fmap AnsiTricks . safeReadBool + optionName = return "ansi-tricks" + optionHelp = return $ + -- Multiline literals don't work because of -XCPP. + "Enable various ANSI terminal tricks. " ++ + "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. -- @@ -480,6 +733,13 @@ "auto" -> return Auto _ -> Nothing +displayUseColor :: UseColor -> String +displayUseColor uc = + case uc of + Never -> "never" + Always -> "always" + Auto -> "auto" + -- }}} -------------------------------------------------- @@ -530,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 @@ -569,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,13 +1,13 @@ -- | A helper module which takes care of parallelism -{-# LANGUAGE DeriveDataTypeable #-} module Test.Tasty.Parallel (ActionStatus(..), Action(..), runInParallel) where import Control.Monad import Control.Concurrent +import Control.Concurrent.Async 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 @@ -41,20 +41,36 @@ -- 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 actionsVar <- atomically $ newTMVar actions - pids <- replicateM nthreads (forkIO $ work actionsVar) + pids <- replicateM nthreads (async $ work actionsVar) - return $ mapM_ killThread pids + return $ do + -- Tell worker threads there is no more work after their current task. + -- 'cancel' below by itself is not sufficient because if an exception + -- is thrown in the middle of a test, the worker thread simply marks + -- the test as failed and moves on to their next task. We also need to + -- make it clear that there are no further tasks. + _ <- atomically $ swapTMVar actionsVar [] + -- Cancel all the current tasks, waiting for workers to clean up. + -- The waiting part is important (see #249), that's why we use cancel + -- instead of killThread. + mapM_ cancel pids work :: TMVar [Action] -> IO () work actionsVar = go @@ -63,8 +79,10 @@ join . atomically $ do mb_ready <- findBool =<< takeTMVar actionsVar case mb_ready of - Nothing -> - -- nothing left to do; return + Nothing -> do + -- Nothing left to do. Put back the TMVar so that other threads + -- do not block on an empty TMVar (see #249) and return. + putTMVar actionsVar [] return $ return () Just (this, rest) -> do putTMVar actionsVar rest 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,38 +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 -#ifndef VERSION_clock -import Data.Time.Clock.POSIX (getPOSIXTime) -#endif -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 -#ifdef VERSION_clock -import qualified System.Clock as Clock + +#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 @@ -40,8 +47,12 @@ import Test.Tasty.Options import Test.Tasty.Options.Core import Test.Tasty.Runners.Reducers +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 @@ -49,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 @@ -91,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. @@ -105,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 } @@ -162,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: @@ -190,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 @@ -321,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 = @@ -388,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 @@ -412,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. @@ -465,32 +685,3 @@ r <- restore a `onException` sequel restore _ <- sequel restore return r - --- | Measure the time taken by an 'IO' action to run -timed :: IO a -> IO (Time, a) -timed t = do - start <- getTime - !r <- t - end <- getTime - return (end-start, r) - -#ifdef VERSION_clock --- | Get monotonic time --- --- Warning: This is not the system time, but a monotonically increasing time --- that facilitates reliable measurement of time differences. -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) -#else --- | Get system time -getTime :: IO Time -getTime = realToFrac <$> getPOSIXTime -#endif 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 @@ -26,6 +28,7 @@ , ListTests(..) , testsNames -- * Command line handling + , parseOptions , optionParser , suiteOptionParser , defaultMainWithIngredients @@ -36,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 @@ -1,18 +1,47 @@ +{-# LANGUAGE BangPatterns #-} + -- | Note: this module is re-exported as a whole from "Test.Tasty.Runners" module Test.Tasty.Runners.Utils where import Control.Exception -import Control.Applicative -import Prelude -- Silence AMP import warnings +import Control.Concurrent (mkWeakThreadId, myThreadId) +import Control.Monad (forM_) import Text.Printf +import Foreign.C (CInt) +#if MIN_VERSION_base(4,11,0) +import GHC.Clock (getMonotonicTime) +#else +import Data.Time.Clock.POSIX (getPOSIXTime) +#endif + +#ifdef VERSION_unix +#include "HsUnixConfig.h" +#ifdef HAVE_SIGNAL_H +#define INSTALL_HANDLERS 1 +#else +#define INSTALL_HANDLERS 0 +#endif +#else +#define INSTALL_HANDLERS 0 +#endif + +#if INSTALL_HANDLERS +import System.Posix.Signals +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 @@ -25,6 +54,77 @@ 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 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 +-- 'Test.Tasty.Runners.tryIngredients' yourself. +-- +-- 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_ [ sigHUP, sigTERM, sigUSR1, sigUSR2, sigXCPU, sigXFSZ ] $ \sig -> + installHandler sig (Catch $ send_exception weak_tid sig) Nothing + where + send_exception weak_tid sig = do + m <- deRefWeak weak_tid + case m of + Nothing -> return () + Just tid -> throwTo tid (toException $ SignalException sig) +#else + return () +#endif + +-- | This exception is thrown when the program receives a signal, assuming +-- 'installSignalHandlers' was called. +-- +-- 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) +instance Exception SignalException + +-- | 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 + !r <- t + end <- getTime + return (end-start, r) + +#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 = getMonotonicTime +#else +-- | 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 +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.6.2 + 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: -DUNIX + cpp-options: -DUSE_WCWIDTH + if flag(unix) + build-depends: unix < 2.9 - -- hs-source-dirs: + -- hs-source-dirs: default-language: Haskell2010 - default-extensions: CPP - ghc-options: -Wall + default-extensions: CPP, ScopedTypeVariables + ghc-options: + -Wall + -Wno-incomplete-uni-patterns + -Wcompat