diff --git a/CHANGELOG b/CHANGELOG deleted file mode 100644 --- a/CHANGELOG +++ /dev/null @@ -1,1 +0,0 @@ -See https://github.com/feuerbach/tasty/blob/master/CHANGES.md diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,636 @@ +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 +----------- + +Make it possible to declare dependencies between tests (see the README for +details) + +Version 1.1.0.4 +--------------- + +Make tasty work with GHCJS + +Version 1.1.0.3 +--------------- + +Fix compatibility with GHC 8.6 + +Version 1.1.0.2 +--------------- + +Fix a bug where some (mostly Asian) characters would break alignment in the +terminal output + +Version 1.1.0.1 +--------------- + +Fix a bug where `-l` was still using `/` instead of `.` as a field separator + +Version 1.1 +----------- + +**NOTE**: This major release contains some breaking changes to the semantics of patterns. +In the original pattern design I didn't notice the conflict between using `/` as +a field separator and as the AWK syntax for pattern matching `/.../`. + +The new patterns have been around for a relatively short time (5 months), so +hopefully the breakage won't be too big. I'm sorry about any problems caused by +the change. + +See for the discussion. + +* The field separator in patterns is changed from slash (`/`) to period (`.`), + and `.` is now allowed in raw patterns. + + The field separator is used to join the group names and the test + name when comparing to a pattern such as `-p foo` or `-p /foo/`. + + If you used + + -p 'foo/bar' + + or + + -p '/foo\/bar/' + + before, now you should use + + -p 'foo.bar' + or + + -p '/foo.bar/' + + if you meant "test/group `bar` inside group `foo`, or + + -p '/foo\/bar/' + + if you meant "test/group containing `foo/bar` in the name". + + The need for escaping the slash inside the `/.../` pattern was precisely the + motivation for this change. + +* Raw patterns (ones that are not AWK expressions) may no longer contain slashes + (`/`). + + So + + -p 'foo/bar' + + is no longer allowed, and + + -p '/foo/' + + is now parsed as an AWK expression `/foo/`, whereas before it + was treated as a raw pattern and converted to `/\/foo\//`. + + The reason for this change is that `/foo/` is a valid AWK expression + and should be parsed as such. + +* Raw patterns may now contain hyphens, so e.g. `-p type-checking` now works. + + In theory this makes some valid AWK expressions (such as `NF-2`) not to be + parsed as such, but they are either unlikely to be useful or could also be + expressed in other ways (`NF!=2`). + +* Several new exports, mostly for testing/debugging patterns: + + * `TestPattern` now has a `Show` instance; `TestPattern` and `Expr` now have + `Eq` instances. + * The constructors of `TestPattern` are now exported. + * `parseAwkExpr` is introduced and can be used in ghci to see how an AWK + expression is parsed. (For parsing test patterns, which include raw + patterns in addition to AWK expression, use `parseTestPattern`.) + +Version 1.0.1.1 +--------------- + +Fix a bug where a test suite that uses resources would hang if interrupted + +Version 1.0.1 +------------- + +* Add a `safeReadBool` function, for case-insensitive parsing of boolean options +* Convert all tasty's own options to case-insensitive + +Version 1.0.0.1 +--------------- + +Adjust lower bounds for the dependencies (mtl and optparse-applicative) + +Version 1.0 +----------- + +* New pattern language (see the README and/or the [blog post][awk]) +* Make the `clock` dependency optional + +[awk]: https://ro-che.info/articles/2018-01-08-tasty-new-patterns + +Version 0.12.0.1 +---------------- + +Fix compatibility with GHC 8.4 + +Version 0.12 +------------ + +Backward compat breaking revision of `Test.Tasty.Ingredients.ConsoleReporter` +that exposes the name of tests/groups. + +Version 0.11.3 +-------------- + +Expose and document several of the internals of +`Test.Tasty.Ingredients.ConsoleReporter`. + +Version 0.11.2.5 +---------------- + +Fix compatibility with GHC 7.4 + +Version 0.11.2.4 +---------------- + +1. Make the `--quiet` mode more efficient on a large number of tests +2. Fix a bug where a cursor would disappear if the test suite was terminated by + a signal other than SIGINT. + +Version 0.11.2.3 +---------------- + +Make filtering tests (`-p`) work faster + +Version 0.11.2.2 +---------------- + +Fix a critical bug in the quiet mode (`-q`/`--quiet`): +the exit status could be wrong or the test suite could hang. + +Version 0.11.2.1 +---------------- + +Fix compatibility with the latest `unbounded-delays` + +Version 0.11.2 +-------------- + +Add `composeReporters`, a function to run multiple reporter ingredients + +Version 0.11.1 +-------------- + +Introduce `mkOptionCLParser` and `mkFlagCLParser` + +Version 0.11.0.4 +---------------- + +Fix compatibility with `optparse-applicative-0.13` + +Version 0.11.0.3 +---------------- + +Switch from `regex-tdfa-rc` to `regex-tdfa`, which got a new maintainer. + +Version 0.11.0.2 +---------------- + +Clarify `IsTest`’s specification with regard to exceptions + +Version 0.11.0.1 +---------------- + +Use monotonic clock when measuring durations. + +Version 0.11 +------------ + +New field `resultShortDescription` of `Result` + +Version 0.10.1.2 +---------------- + +* Improve the docs +* Fix compatibility with GHC HEAD + +Version 0.10.1.1 +---------------- + +* Prevent parsing non-positive number of threads via program options (#104) +* Buffer output to avoid slowdowns when printing test results (#101) +* Default to using the maximum number of available cores for test execution + +Version 0.10.1 +-------------- + +Export `Test.Tasty.Runners.formatMessage` + +Version 0.10.0.4 +---------------- + +Don't output ANSI codes for the Emacs terminal emulator + +Version 0.10.0.3 +---------------- + +Better handle the situation when there are no ingredients to run + +Version 0.10.0.2 +---------------- + +Split the changelog into per-project changelogs + +Version 0.10.0.1 +---------------- + +Update to optparse-applicative 0.11 + +Version 0.10 +------------ + +* Add the `--color` option +* Timings + * Introduce the `Time` type synonym + * Change the types of `launchTestTree` and `TestReporter` to accept the + total run time + * `consoleTestReporter` now displays the timings + +Version 0.9.0.1 +--------------- + +Upgrade to optparse-applicative-0.10. + +Version 0.8.1.3 +--------------- + +Be careful not to export the `Show (a -> b)` instance, see + + +Version 0.8.1.2 +--------------- + +Hide cursor when running tests + +Version 0.8.1.1 +--------------- + +Fix for GHC 7.9 + +Version 0.8.0.4 +--------------- + +Remove the old 'colors' flag description from the cabal file + +Version 0.8.0.2 +--------------- + +Make ansi-terminal an unconditional dependency + +Version 0.8 +----------- + +* `Test.Tasty.Ingredients` is now exposed +* `Test.Tasty.Ingredients.Basic` is added, which exports the ingredients defined + in the `tasty` package. These exports should now be used instead of ones + exported from `Test.Tasty.Runners` +* The `Result` type is now structured a bit differently. Providers now should + use `testPassed` and `testFailed` functions instead of constructing `Result`s + directly. +* Add «quiet mode» (see README) +* Add «hide successes» mode (see README) +* Add short command-line options: `-j` for `--num-threads`, `-p` for `--pattern` +* Add timeout support +* `AppMonoid` is renamed to `Traversal` for consistency with the 'reducers' + package. Another similar wrapper, `Ap`, is introduced. +* Fix a resources bug (resources were not released if the test suite was + interrupted) +* The type of `launchTestTree` is changed. It now takes a continuation as an + argument. This is necessary to fix the bug mentioned above. +* Add `flagCLParser` to be used as the `optionCLParser` implementation for + boolean options. +* Add the ability to pass options via environment + +Version 0.7 +----------- + +* Use `regex-tdfa` instead of `regex-posix` (which is a native + implementation, and as such is more portable) +* `foldTestTree` now takes the algebra in the form of a record rather than + multiple arguments, to minimize breakage when new nodes are added or + existing ones change +* `withResource` now passes the IO action to get the resource to the inner test tree + +Version 0.6 +----------- + +* Better handling of exceptions that arise during resource creation or + disposal +* Expose the `AppMonoid` wrapper +* Add `askOption` and `includingOptions` + +Version 0.5.2.1 +--------------- + +Depend on ansi-terminal >= 0.6.1. This fixes some issues with colors on Windows. + +Version 0.5.2 +------------- + +* Export `Result` and `Progress` from `Test.Tasty.Runners` +* Make it clear that only GHC 7.4+ is supported + +Version 0.5.1 +------------- + +Export `ResourceSpec` from `Test.Tasty.Runners` + +Version 0.5 +----------- + +Add a capability to acquire and release resources. See the «Resources» section +in the `Test.Tasty` docs. + +For the end users, the API is backwards-compatible. + +Test runners may have to be adjusted — there is a new constructor of `TestTree` +and a new argument of `foldTestTree`. + +Version 0.4.2 +------------- + +Add `defaultIngredients` + +Version 0.4.1.1 +--------------- + +Print the failure description in red + +Version 0.4.0.1 +--------------- + +Fix a bug ([#25](https://github.com/UnkindPartition/tasty/issues/25)) + +Version 0.4 +----------- + +The big change in this release is introduction of ingredients, which is a +replacement for runners. But unless you have a custom runner, this is unlikely +to affect you much. + +The `Ingredient` data type has replaced the `Runner` type. + +The following functions have been renamed and possibly changed their types: + +* `defaultMainWithRunner` → `defaultMainWithIngredients` +* `treeOptionParser` → `suiteOptionParser` +* `getTreeOptions` → `treeOptions` +* `runUI` → `consoleTestReporter` + +Added in this release: + +* `suiteOptions` +* `optionParser` +* functions operating on ingredients +* `testsNames` +* the `listingTests` ingredient and its option, `ListTests` + +`NumThreads` is no longer a core option, but is automatically included in the +test reporting ingredients (see its haddock). + +Version 0.3.1 +------------- + +* Proper reporting of (some) non-terminating tests (#15) +* Upgrade to optparse-applicative 0.6 + +Version 0.3 +----------- + +* Restrict dependency versions +* Fix a bug where non-terminating test would lead to a deadlock (#15) + +Version 0.2 +----------- + +* Add an `execRunner` function +* Make `Runner` return `IO Bool` + +Version 0.1.1 +------------- + +Set lower bound on optparse-applicative dependency version 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 new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,880 @@ +# Tasty + +**Tasty** is a modern testing framework for Haskell. + +It lets you combine your unit tests, golden tests, QuickCheck/SmallCheck +properties, and any other types of tests into a single test suite. + +Features: + +* Run tests in parallel but report results in a deterministic order +* Filter the tests to be run using patterns specified on the command line +* Hierarchical, colored display of test results +* Reporting of test statistics +* Acquire and release resources (sockets, temporary files etc.) that can be + shared among several tests +* Extensibility: add your own test providers and ingredients (runners) above and + beyond those provided + +To find out what's new, read the **[change log][]**. + +[change log]: https://github.com/UnkindPartition/tasty/blob/master/core/CHANGELOG.md + +## Example + +Here's how your `test.hs` might look like: + +```haskell +import Test.Tasty +import Test.Tasty.SmallCheck as SC +import Test.Tasty.QuickCheck as QC +import Test.Tasty.HUnit + +import Data.List +import Data.Ord + +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" [properties, unitTests] + +properties :: TestTree +properties = testGroup "Properties" [scProps, qcProps] + +scProps = testGroup "(checked by SmallCheck)" + [ SC.testProperty "sort == sort . reverse" $ + \list -> sort (list :: [Int]) == sort (reverse list) + , SC.testProperty "Fermat's little theorem" $ + \x -> ((x :: Integer)^7 - x) `mod` 7 == 0 + -- the following property does not hold + , SC.testProperty "Fermat's last theorem" $ + \x y z n -> + (n :: Integer) >= 3 SC.==> x^n + y^n /= (z^n :: Integer) + ] + +qcProps = testGroup "(checked by QuickCheck)" + [ QC.testProperty "sort == sort . reverse" $ + \list -> sort (list :: [Int]) == sort (reverse list) + , QC.testProperty "Fermat's little theorem" $ + \x -> ((x :: Integer)^7 - x) `mod` 7 == 0 + -- the following property does not hold + , QC.testProperty "Fermat's last theorem" $ + \x y z n -> + (n :: Integer) >= 3 QC.==> x^n + y^n /= (z^n :: Integer) + ] + +unitTests = testGroup "Unit tests" + [ testCase "List comparison (different length)" $ + [1, 2, 3] `compare` [1,2] @?= GT + + -- the following test does not hold + , testCase "List comparison (same length)" $ + [1, 2, 3] `compare` [1,2,2] @?= LT + ] +``` + +And here is the output of the above program: + +![](https://raw.github.com/UnkindPartition/tasty/master/screenshot.png) + +(Note that whether QuickCheck finds a counterexample to the third property is +determined by chance.) + +## Packages + +[tasty][] is the core package. It contains basic definitions and APIs and a +console runner. + +[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). + +### Providers + +The following providers exist: + +* [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](https://hackage.haskell.org/package/tasty-smallcheck) — + exhaustive property-based testing + (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://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](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]: https://hackage.haskell.org/package/tasty-golden + +It's easy to create custom providers using the API from `Test.Tasty.Providers`. + +### Ingredients + +Ingredients represent different actions that you can perform on your test suite. +One obvious ingredient that you want to include is one that runs tests and +reports the progress and results. + +Another standard ingredient is one that simply prints the names of all tests. + +It is possible to write custom ingredients using the API from `Test.Tasty.Runners`. + +Some ingredients that can enhance your test suite are: + +* [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](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](https://hackage.haskell.org/package/tasty-html) adds the + possibility to write the test results as a HTML file +* [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-hunit-adapter](https://hackage.haskell.org/package/tasty-hunit-adapter) + converts existing HUnit test suites into tasty test suites +* [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 + +Options allow one to customize the run-time behavior of the test suite, such +as: + +* mode of operation (run tests, list tests, run tests quietly etc.) +* which tests are run (see «Patterns» below) +* parameters of individual providers (like depth of search for SmallCheck) + +### Setting options + +There are two main ways to set options: + +#### Runtime + +When using the standard console runner, the options can be passed on the +command line or via environment variables. To see the available options, run +your test suite with the `--help` flag. The output will look something like this +(depending on which ingredients and providers the test suite uses): + +``` +% ./test --help +Mmm... tasty test suite + +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 + -p,--pattern PATTERN Select only tests which satisfy a pattern or awk + expression + -t,--timeout DURATION Timeout for individual tests (suffixes: ms,s,m,h; + default: s) + --no-progress Do not show progress + -l,--list-tests Do not run the tests; just print their names + -j,--num-threads NUMBER Number of threads to use for tests execution + (default: # of cores/capabilities) + -q,--quiet Do not produce any output; indicate success only by + the exit code + --hide-successes Do not print tests that passed successfully + --min-duration-to-report DURATION + The minimum amount of time a test can take before + tasty prints timing information (suffixes: ms,s,m,h; + default: s) + --color never|always|auto + When to use colored output (default: auto) + --ansi-tricks ARG Enable various ANSI terminal tricks. Can be set to + '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. + 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 discarded tests per successful test + before giving up + --quickcheck-verbose Show the generated test cases + --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 +name from the option name, replace hyphens `-` with underscores `_`, capitalize +all letters, and prepend `TASTY_`. For example, the environment equivalent of +`--smallcheck-depth` is `TASTY_SMALLCHECK_DEPTH`. + +Note on boolean options: by convention, boolean ("on/off") options are specified +using a switch on the command line, for example `--quickcheck-show-replay` +instead of `--quickcheck-show-replay=true`. However, when +passed via the environment, the option value needs to be `True` or `False` +(case-insensitive), e.g. `TASTY_QUICKCHECK_SHOW_REPLAY=true`. + +If you're using a non-console runner, please refer to its documentation to find +out how to configure options during the run time. + +#### Compile-time + +You can also specify options in the test suite itself, using +`localOption`. It can be applied not only to the whole test tree, but also to +individual tests or subgroups, so that different tests can be run with +different options. + +It is possible to combine run-time and compile-time options, too, by using +`adjustOption`. For example, make the overall testing depth configurable +during the run time, but increase or decrease it slightly for individual +tests. + +This method currently doesn't work for ingredient options, such as `--quiet` or +`--num-threads`. You can set them by setting the corresponding environment +variable before calling `defaultMain`: + + + +```haskell +import Test.Tasty +import System.Environment + +main = do + setEnv "TASTY_NUM_THREADS" "1" + defaultMain _ +``` + +### Patterns + +It is possible to restrict the set of executed tests using the `-p/--pattern` +option. + +Tasty patterns are very powerful, but if you just want to quickly run tests containing `foo` +somewhere in their name or in the name of an enclosing test group, you can just +pass `-p foo`. If you need more power, or if that didn't work as expected, read +on. + +A pattern is an [awk expression][awk]. When the expression is evaluated, the field `$1` +is set to the outermost test group name, `$2` is set to the next test group +name, and so on up to `$NF`, which is set to the test's own name. The field `$0` +is set to all other fields concatenated using `.` as a separator. + +[awk]: https://pubs.opengroup.org/onlinepubs/9699919799/utilities/awk.html#tag_20_06_13_02 + +As an example, consider a test inside two test groups: + +``` + testGroup "One" [ testGroup "Two" [ testCase "Three" _ ] ] +``` + +When a pattern is evaluated for the above test case, the available fields and variables are: + + $0 = "One.Two.Three" + $1 = "One" + $2 = "Two" + $3 = "Three" + NF = 3 + +Here are some examples of awk expressions accepted as patterns: + +* `$2 == "Two"` — select the subgroup `Two` +* `$2 == "Two" && $3 == "Three"` — select the test or subgroup named `Three` in the subgroup named `Two` +* `$2 == "Two" || $2 == "Twenty-two"` — select two subgroups +* `$0 !~ /skip/` or `! /skip/` — select tests whose full names (including group names) do not contain the word `skip` +* `$NF !~ /skip/` — select tests whose own names (but not group names) do not contain the word `skip` +* `$(NF-1) ~ /QuickCheck/` — select tests whose immediate parent group name + contains `QuickCheck` + +As an extension to the awk expression language, if a pattern `pat` contains only +letters, digits, and characters from the set `._ -` (period, underscore, space, hyphen), +it is treated like `/pat/` (and therefore matched against `$0`). +This is so that we can use `-p foo` as a shortcut for `-p /foo/`. + +The only deviation from awk that you will likely notice is that Tasty +does not implement regular expression matching. +Instead, `$1 ~ /foo/` means that the string `foo` occurs somewhere in `$1`, +case-sensitively. We want to avoid a heavy dependency of `regex-tdfa` or +similar libraries; however, if there is demand, regular expression support could +be added under a cabal flag. + +The following operators are supported (in the order of decreasing precedence): + +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+

Syntax

+		 +

Name

+		 +

Type of Result

+		 +

Associativity

+
+

(expr)

+		 +

Grouping

+		 +

Type of expr

+		 +

N/A

+
+

$expr

+		 +

Field reference

+		 +

String

+		 +

N/A

+
+

!expr

+

-expr

+		 +

Logical not

+

Unary minus

+		 +

Numeric

+

Numeric

+		 +

N/A

+

N/A

+
+

expr + expr

+

expr - expr

+		 +

Addition

+

Subtraction

+		 +

Numeric

+

Numeric

+		 +

Left

+

Left

+
+

expr expr

+		 +

String concatenation

+		 +

String

+		 +

Right

+
+

expr < expr

+

expr <= expr

+

expr != expr

+

expr == expr

+

expr > expr

+

expr >= expr

+		 +

Less than

+

Less than or equal to

+

Not equal to

+

Equal to

+

Greater than

+

Greater than or equal to

+		 +

Numeric

+

Numeric

+

Numeric

+

Numeric

+

Numeric

+

Numeric

+		 +

None

+

None

+

None

+

None

+

None

+

None

+
+

expr ~ pat

+

expr !~ pat

+

(pat must be a literal, not an expression, e.g. /foo/)

+		 +

Substring match

+

No substring match

+		 +

Numeric

+

Numeric

+		 +

None

+

None

+
+

expr && expr

+		 +

Logical AND

+		 +

Numeric

+		 +

Left

+
+

expr || expr

+		 +

Logical OR

+		 +

Numeric

+		 +

Left

+
+

expr1 ? expr2 : expr3

+		 +

Conditional expression

+		 +

Type of selected
expr2 or expr3

+		 +

Right

+
+
+ +The following built-in functions are supported: + +``` +substr(s, m[, n]) +``` +Return the at most `n`-character substring of `s` that begins at +position `m`, numbering from 1. If `n` is omitted, or if `n` specifies +more characters than are left in the string, the length of the substring +will be limited by the length of the string `s`. + +``` +tolower(s) +``` + +Convert the string `s` to lower case. + +``` +toupper(s) +``` + +Convert the string `s` to upper case. + +``` +match(s, pat) +``` + +Return the position, in characters, numbering from 1, in string `s` where the +pattern `pat` occurs, or zero if it does not occur at all. +`pat` must be a literal, not an expression, e.g. `/foo/`. + +``` +length([s]) +``` + +Return the length, in characters, of its argument taken as a string, or of the whole record, `$0`, if there is no argument. + +### Running tests in parallel + +In order to run tests in parallel, you have to do the following: + +* Compile (or, more precisely, *link*) your test program with the `-threaded` + flag; +* Launch the program with `+RTS -N -RTS`. + +### Timeout + +To apply timeout to individual tests, use the `--timeout` (or `-t`) command-line +option, or set the option in your test suite using the `mkTimeout` function. + +Timeouts can be fractional, and can be optionally followed by a suffix `ms` +(milliseconds), `s` (seconds), `m` (minutes), or `h` (hours). When there's no +suffix, seconds are assumed. + +Example: + + ./test --timeout=0.5m + +sets a 30 seconds timeout for each individual test. + +### Options controlling console output + +The following options control behavior of the standard console interface: + +
+
-q,--quiet
+
+ Run the tests but don't output anything. The result is indicated only by the + exit code, which is 1 if at least one test has failed, and 0 if all tests + have passed. Execution stops when the first failure is detected, so not all + tests are necessarily run. + This may be useful for various batch systems, such as commit hooks. +
+
--hide-successes
+
Report only the tests that has failed. Especially useful when the +number of tests is large.
+
-l,--list-tests
+
Don't run the tests; only list their names, in the format accepted by +--pattern.
+
--color
+
Whether to produce colorful output. Accepted values: never, +always, auto. auto means that colors will +only be enabled when output goes to a terminal and is the default value.
+
+ +### Custom options + +It is possible to add custom options, too. + +To do that, + +1. Define a datatype to represent the option, and make it an instance of + `IsOption` +2. Register the options with the `includingOptions` ingredient +3. To query the option value, use `askOption`. + +See the [Custom options in Tasty][custom-options-article] article for some examples. + +## Project organization and integration with Cabal + +There may be several ways to organize your project. What follows is not +Tasty's requirements but my recommendations. + +### Tests for a library + +Place your test suite sources in a dedicated subdirectory (called `tests` +here) instead of putting them among the main library sources. + +The directory structure will be as follows: + + my-project/ + my-project.cabal + src/ + ... + tests/ + test.hs + Mod1.hs + Mod2.hs + ... + +`test.hs` is where your `main` function is defined. The tests may be +contained in `test.hs` or spread across multiple modules (`Mod1.hs`, `Mod2.hs`, +...) which are then imported by `test.hs`. + +Add the following section to the cabal file (`my-project.cabal`): + + test-suite test + default-language: + Haskell2010 + type: + exitcode-stdio-1.0 + hs-source-dirs: + tests + main-is: + test.hs + build-depends: + base >= 4 && < 5 + , tasty >= 0.7 -- insert the current version here + , my-project -- depend on the library we're testing + , ... + +### Tests for a program + +All the above applies, except you can't depend on the library if there's no +library. You have two options: + +* Re-organize the project into a library and a program, so that both the + program and the test suite depend on this new library. The library can be + declared in the same cabal file. +* Add your program sources directory to the `Hs-source-dirs`. Note that this + will lead to double compilation (once for the program and once for the test + suite). + +## Dependencies + +Tasty executes tests in parallel to make them finish faster. +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` 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: + +``` haskell +after + :: DependencyType -- ^ whether to run the tests even if some of the dependencies fail + -> String -- ^ the pattern + -> 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 +``` + +The pattern follows the same AWK-like syntax and semantics as described in +[Patterns](#patterns). There is also a variant named `after_` that accepts the +AST of the pattern instead of a textual representation. + +Let's consider some typical examples. (A note about terminology: here +by "resource" I mean anything stateful and external to the test: it could be a file, +a database record, or even a value stored in an `IORef` that's shared among +tests. The resource may or may not be managed by `withResource`.) + +1. Two tests, Test A and Test B, access the same shared resource and cannot be + run concurrently. To achieve this, make Test A a dependency of Test B: + + ``` haskell + testGroup "Tests accessing the same resource" + [ testCase "Test A" $ ... + , after AllFinish "Test A" $ + testCase "Test B" $ ... + ] + ``` + +1. Test A creates a resource and Test B uses that resource. Like above, we make + Test A a dependency of Test B, except now we don't want to run Test B if Test + A failed because the resource may not have been set up properly. So we use + `AllSucceed` instead of `AllFinish` + + ``` haskell + testGroup "Tests creating and using a resource" + [ testCase "Test A" $ ... + , after AllSucceed "Test A" $ + testCase "Test B" $ ... + ] + ``` + +Here are some caveats to keep in mind when using patterns to specify dependencies in Tasty: + +1. If Test B depends on Test A, remember that either of them may be filtered out + using the `--pattern` option. Collecting the dependency info happens *after* + 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. +1. Tasty does not currently check whether the pattern in a dependency matches + anything at all, so make sure your patterns are correct and do not contain + 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 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)*, + since each pattern has to be matched against each test name. As a guideline, + if you have up to 1000 tests, the overhead will be negligible, but if you + have thousands of tests or more, then you probably shouldn't have more than a + few dependencies. + + Additionally, it is recommended that the dependencies follow the + natural order of tests, i.e. that the later tests in the test tree depend on + the earlier ones and not vice versa. If the execution order mandated by the + dependencies is sufficiently different from the natural order of tests in the + test tree, searching for the next test to execute may also have an + overhead quadratic in the number of tests. + +Use `dependentTestGroup` to mitigate these problems. + + +## FAQ + +1. **Q**: When my tests write to stdout/stderr, the output is garbled. Why is that and + what do I do? + + **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/UnkindPartition/tasty/issues/103) for the + discussion. + + Some ideas on how to work around this: + + * Use [testCaseSteps](https://hackage.haskell.org/package/tasty-hunit/docs/Test-Tasty-HUnit.html#v:testCaseSteps) (for tasty-hunit only). + * Use a test reporter that does not print to the console (like tasty-ant-xml). + * Write your output to files instead. + +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](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](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](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]: 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/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 @@ -1,11 +1,41 @@ -- | This module defines the main data types and functions needed to use -- Tasty. +-- +-- To create a test suite, you also need one or more test providers, such +-- as +-- or +-- . +-- +-- A simple example (using tasty-hunit) is +-- +-- >import Test.Tasty +-- >import Test.Tasty.HUnit +-- > +-- >main = defaultMain tests +-- > +-- >tests :: TestTree +-- >tests = testGroup "Tests" +-- > [ testCase "2+2=4" $ +-- > 2+2 @?= 4 +-- > , testCase "7 is even" $ +-- > assertBool "Oops, 7 is odd" (even 7) +-- > ] +-- +-- Take a look at the : +-- it contains a comprehensive list of test providers, a bigger example, +-- and a lot of other information. +-- +-- @since 0.1 + module Test.Tasty ( -- * Organizing tests TestName , TestTree , testGroup + , dependentTestGroup + , sequentialTestGroup + , inOrderTestGroup -- * Running tests , defaultMain , defaultMainWithIngredients @@ -30,6 +60,10 @@ -- a file or a socket. We want to create or grab the resource before -- the tests are run, and destroy or release afterwards. , withResource + -- * Dependencies + , DependencyType(..) + , after + , after_ ) where @@ -42,28 +76,61 @@ -- | 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 +-- | Parse the command line arguments and run the tests. +-- +-- 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 +-- `defaultMain` returns, you need to catch the exception and then re-throw +-- it. Example: +-- +-- >import Test.Tasty +-- >import Test.Tasty.HUnit +-- >import System.Exit +-- >import Control.Exception +-- > +-- >test = testCase "Test 1" (2 @?= 3) +-- > +-- >main = defaultMain test +-- > `catch` (\e -> do +-- > if e == ExitSuccess +-- > 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,53 +1,181 @@ -- | Parsing options supplied on the command line -{-# LANGUAGE ScopedTypeVariables #-} 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 +import Data.Typeable (typeRep) +import Options.Applicative +import Options.Applicative.Common (evalParser) +import qualified Options.Applicative.Types as Applicative (Option(..)) +import Options.Applicative.Types (Parser(..), OptProperties(..)) import System.Exit +import System.IO +#if !MIN_VERSION_base(4,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 -optionParser :: [OptionDescription] -> Parser OptionSet -optionParser = getApp . foldMap toSet where - toSet :: OptionDescription -> Ap Parser OptionSet - toSet (Option (Proxy :: Proxy v)) = Ap $ - (singleOption <$> (optionCLParser :: Parser v)) <|> pure mempty +-- | Generate a command line parser from a list of option descriptions, +-- alongside any related warning messages. +-- +-- @since 1.3 +optionParser :: [OptionDescription] -> ([String], Parser OptionSet) +optionParser = second getApp . foldMap toSet where + toSet :: OptionDescription -> ([String], Ap Parser OptionSet) + toSet (Option p) = second + (\parser -> Ap $ (singleOption <$> parser) <|> pure mempty) + (finalizeCLParser p optionCLParser) --- | The command line parser for the test suite -suiteOptionParser :: [Ingredient] -> TestTree -> Parser OptionSet +-- Do two things: +-- +-- 1. Replace an `optionCLParser`'s 'propShowDefault' with 'showDefaultValue' +-- from the 'IsOption' class. +-- 2. Generate warning messages if the 'optionCLParser' does anything +-- suspicious. Currently, the only suspicious things we check for are +-- (a) if the 'Parser' defines multiple options and, (b) if the 'Parser' +-- assigns a default value outside of 'defaultValue'. +finalizeCLParser :: forall proxy v . IsOption v + => proxy v -> Parser v -> ([String], Parser v) +finalizeCLParser _ p = (warnings, setCLParserShowDefaultValue mbDef p) + where + mbDef :: Maybe String + mbDef = showDefaultValue (defaultValue :: v) + + warnings :: [String] + warnings = catMaybes [multipleOptPsWarning, badDefaultWarning] + + -- Warn if a Parser defines multiple options, as this breaks an assumption + -- that setCLParserShowDefaultValue relies on. + multipleOptPsWarning :: Maybe String + multipleOptPsWarning + | numOptPs p > 1 + = Just $ unlines + [ prov + , "optionCLParser defines multiple options. Consider only defining" + , "a single option here, as defining multiple options does not play" + , "well with how tasty displays default values." + ] + | otherwise + = Nothing + + -- Warning if a Parser has a default value (outside of IsOption's + -- defaultValue method, that is), as this interferes with tasty's ability + -- to read arguments from environment variables. For more on this point, + -- see the Haddocks for optionCLParser. + badDefaultWarning :: Maybe String + badDefaultWarning + -- evalParser will only return Just if has a default value declared with + -- e.g. the Options.Applicative.value function. + | isJust (evalParser p) + = Just $ unlines + [ prov + , "Using default values (e.g., with Options.Applicative.value) in" + , "optionCLParser is prohibited, as it interferes with tasty's ability" + , "to read environment variable options properly. Moreover, assigning" + , "default values is unnecessary, as their functionality is subsumed" + , "by the defaultValue method of IsOption." + ] + | otherwise + = Nothing + + prov :: String + prov = "WARNING (in the IsOption instance for " + ++ show (typeRep (Proxy :: Proxy v)) ++ "):" + +-- Replace an `optionCLParser`'s 'propShowDefault' with 'showDefaultValue' from +-- the 'IsOption' class. It's tempting to try doing this when constructing the +-- 'Parser' itself using 'optionMod', but @optparse-applicative@'s 'mkParser' +-- function always overrides the result of 'optionMod'. Ugh. +setCLParserShowDefaultValue :: Maybe String -> Parser a -> Parser a +setCLParserShowDefaultValue mbDef = go + where + go :: Parser a -> Parser a + -- Note that we /always/ replace the Option's optProps, regardless of + -- what type it may have. This can produce unexpected results if an + -- optionCLParser defines multiple options, which is why we emit a warning + -- (in finalizeCLParser) if a Parser does this. + go (OptP o) = OptP o{Applicative.optProps = + modifyDefault (Applicative.optProps o)} + go p@NilP{} = p + go (MultP p1 p2) = MultP (go p1) (go p2) + go (AltP p1 p2) = AltP (go p1) (go p2) + go (BindP p1 p2) = BindP (go p1) (fmap go p2) + + modifyDefault :: OptProperties -> OptProperties + modifyDefault op = op{propShowDefault = mbDef} + +-- Note: this is a conservative estimate, since we cannot count the number +-- of OptPs in the continuation argument of BindP. But BindP is really only +-- used for ParserM purposes, and since ParserM is an internal +-- optparse-applicative definition, most optionCLParser instances are +-- unlikely to use it in practice. +numOptPs :: Parser a -> Int +numOptPs OptP{} = 1 +numOptPs NilP{} = 0 +numOptPs (MultP p1 p2) = numOptPs p1 + numOptPs p2 +numOptPs (AltP p1 p2) = numOptPs p1 + numOptPs p2 +numOptPs (BindP p1 _p2) = numOptPs p1 + +-- | The command line parser for the test suite, alongside any related +-- warnings. +-- +-- @since 1.3 +suiteOptionParser :: [Ingredient] -> TestTree -> ([String], Parser OptionSet) suiteOptionParser ins tree = optionParser $ suiteOptions ins tree +-- | Parse the command-line and environment options passed to tasty. +-- +-- Useful if you need to get the options before '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 +-- ingredient list. +-- +-- 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 - cmdlineOpts <- execParser $ - info (helper <*> suiteOptionParser ins testTree) - ( fullDesc <> - header "Mmm... tasty test suite" - ) - - envOpts <- suiteEnvOptions ins testTree - - let opts = envOpts <> cmdlineOpts + installSignalHandlers + opts <- parseOptions ins testTree case tryIngredients ins opts testTree of - Nothing -> - putStrLn - "This doesn't taste right. Check your ingredients — did you forget a test reporter?" + Nothing -> do + hPutStrLn stderr + "No ingredients agreed to run. Something is wrong either with your ingredient set or the options." + exitFailure Just act -> do ok <- act if ok then exitSuccess else exitFailure diff --git a/Test/Tasty/Core.hs b/Test/Tasty/Core.hs --- a/Test/Tasty/Core.hs +++ b/Test/Tasty/Core.hs @@ -1,43 +1,107 @@ -- | 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 Data.Foldable -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 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 + -- ^ test provider indicated failure of the code to test, either because + -- the tested code returned wrong results, or raised an exception | TestThrewException SomeException - -- ^ test resulted in an exception. Note that some test providers may - -- catch exceptions in order to provide more meaningful errors. In that - -- case, the 'FailureReason' will be 'TestFailed', not - -- 'TestThrewException'. + -- ^ the test code itself raised an exception. Typical cases include missing + -- example input or output files. + -- + -- Usually, providers do not have to implement this, as their 'run' method + -- may simply raise an exception. | TestTimedOut Integer -- ^ 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) --- | A test result +-- | Time in seconds. Used to measure how long the tests took to run. +-- +-- @since 0.10 +type Time = Double + +-- | A test result. +-- +-- @since 0.1 data Result = Result { resultOutcome :: Outcome -- ^ Did the test fail? If so, why? @@ -50,26 +114,90 @@ -- -- 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 -- ^ @since 1.2 + ) +{- Note [Skipped tests] + ~~~~~~~~~~~~~~~~~~~~ + There are two potential ways to represent the tests that are skipped + because of their failed dependencies: + 1. With Outcome = Failure, and FailureReason giving the specifics (TestDepFailed) + 2. With a dedicated Outcome = Skipped + + It seems to me that (1) will lead to fewer bugs (esp. in the extension packages), + because most of the time skipped tests should be handled in the same way + as failed tests. + But sometimes it is not obvious what the right behavior should be. E.g. + should --hide-successes show or hide the skipped tests? + + Perhaps we should hide them, because they aren't really informative. + Or perhaps we shouldn't hide them, because we are not sure that they + will pass, and hiding them will imply a false sense of security + ("there's at most 2 tests failing", whereas in fact there could be much more). + + So I might change this in the future, but for now treating them as + failures seems the easiest yet reasonable approach. +-} + -- | '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 @@ -78,27 +206,80 @@ -- 'progressPercent' should be a value between 0 and 1. If it's impossible -- to compute the estimate, use 0. } + 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 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). run :: OptionSet -- ^ options -> t -- ^ the test to run - -> (Progress -> IO ()) -- ^ a callback to report progress + -> (Progress -> IO ()) -- ^ a callback to report progress. -> 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 @@ -106,7 +287,6 @@ = NotRunningTests | UnexpectedState String String | UseOutsideOfTest - deriving Typeable instance Show ResourceError where show NotRunningTests = @@ -119,6 +299,49 @@ instance Exception ResourceError +-- | These are the two ways in which one test may depend on the others. +-- +-- This is the same distinction as the +-- . +-- +-- @since 1.2 +data DependencyType + = AllSucceed + -- ^ The current test tree will be executed after its dependencies finish, and only + -- if all of the dependencies succeed. + | AllFinish + -- ^ The current test tree will be executed after its dependencies finish, + -- regardless of whether they succeed or not. + 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 @@ -129,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 @@ -141,22 +366,169 @@ -- 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). + -- + -- @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. +-- +-- ==== __Examples__ +-- +-- Only match on the test's own name, ignoring the group names: +-- +-- @ +-- 'after_' 'AllFinish' ('Test.Tasty.Patterns.Types.EQ' ('Field' 'NF') ('StringLit' \"Bar\")) $ +-- @testCase@ \"A test that depends on Foo.Bar\" $ ... +-- @ +-- +-- @since 1.2 +after_ + :: DependencyType -- ^ whether to run the tests even if some of the dependencies fail + -> Expr -- ^ the pattern + -> TestTree -- ^ the subtree that depends on other tests + -> TestTree -- ^ the subtree annotated with dependency information +after_ = After + +-- | The 'after' combinator declares dependencies between tests. +-- +-- If a 'TestTree' is wrapped in 'after', the tests in this tree will not run +-- until certain other tests («dependencies») have finished. These +-- dependencies are specified using an AWK pattern (see the «Patterns» section +-- in the README). +-- +-- Moreover, if the 'DependencyType' argument is set to 'AllSucceed' and +-- at least one dependency has failed, this test tree will not run at all. +-- +-- Tasty does not check that the pattern matches any tests (let alone the +-- correct set of tests), so it is on you to supply the right pattern. +-- +-- ==== __Examples__ +-- +-- The following test will be executed only after all tests that contain +-- @Foo@ anywhere in their path finish. +-- +-- @ +-- 'after' 'AllFinish' \"Foo\" $ +-- @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 '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. +-- +-- You can use AWK patterns, for instance, to specify the full path to the dependency. +-- +-- @ +-- 'after' 'AllFinish' \"$0 == \\\"Tests.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\" $ ... +-- @ +-- +-- @since 1.2 +after + :: DependencyType -- ^ whether to run the tests even if some of the dependencies fail + -> String -- ^ the pattern + -> TestTree -- ^ the subtree that depends on other tests + -> TestTree -- ^ the subtree annotated with dependency information +after deptype s = + case parseExpr s of + Nothing -> error $ "Could not parse pattern " ++ show s + Just e -> after_ deptype e + -- | An algebra for folding a `TestTree`. -- -- 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 + , 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 @@ -170,13 +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 + , 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 @@ -192,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 @@ -204,21 +589,128 @@ -> TestTree -- ^ the tree to fold -> b -foldTestTree (TreeFold fTest fGroup fResource) opts tree = - let pat = lookupOption opts - in go pat [] opts tree +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 tree = - case tree of - SingleTest name test - | testPatternMatches pat (path ++ [name]) - -> fTest opts name test - | otherwise -> mempty - TestGroup name trees -> - fGroup name $ foldMap (go pat (path ++ [name]) opts) trees - PlusTestOptions f tree -> go pat path (f opts) tree - WithResource res tree -> fResource res $ \res -> go pat path opts (tree res) - AskOptions f -> go pat path opts (f opts) + 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,12 +2,15 @@ -- -- Ingredients themselves are provided by other modules (usually under -- the @Test.Tasty.Ingredients.*@ hierarchy). +-- +-- @since 0.8 module Test.Tasty.Ingredients ( Ingredient(..) , tryIngredients , ingredientOptions , ingredientsOptions , suiteOptions + , composeReporters ) where import Control.Monad @@ -18,6 +21,7 @@ import Test.Tasty.Run import Test.Tasty.Options import Test.Tasty.Options.Core +import Control.Concurrent.Async (concurrently) -- | 'Ingredient's make your test suite tasty. -- @@ -32,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. @@ -45,15 +49,20 @@ -- That's all you need to know from an (advanced) user perspective. Read -- on if you want to create a new ingredient. -- --- There are two kinds of ingredients. 'TestReporter', if it agrees to run, --- automatically launches tests execution, and gets the 'StatusMap' which --- it uses to report the progress and results to the user. +-- There are two kinds of ingredients. -- +-- The first kind is 'TestReporter'. If the ingredient that agrees to run +-- is a 'TestReporter', then tasty will automatically launch the tests and +-- pass a 'StatusMap' to the ingredient. All the ingredient needs to do +-- then is to process the test results and probably report them to the user +-- in some way (hence the name). +-- -- 'TestManager' is the second kind of ingredient. It is typically used for -- test management purposes (such as listing the test names), although it -- can also be used for running tests (but, unlike 'TestReporter', it has --- to launch the tests manually). It is therefore more general than --- 'TestReporter'. 'TestReporter' is provided just for convenience. +-- to launch the tests manually if it wants them to be run). It is +-- therefore more general than 'TestReporter'. 'TestReporter' is provided +-- just for convenience. -- -- The function's result should indicate whether all the tests passed. -- @@ -61,21 +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 Bool)) + (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 @@ -87,28 +105,58 @@ -- -- 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 + +-- | Compose two 'TestReporter' ingredients which are then executed +-- in parallel. This can be useful if you want to have two reporters +-- active at the same time, e.g., one which prints to the console and +-- one which writes the test results to a file. +-- +-- 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 -> + case (f1 o t, f2 o t) of + (g, Nothing) -> g + (Nothing, g) -> g + (Just g1, Just g2) -> Just $ \s -> do + (h1, h2) <- concurrently (g1 s) (g2 s) + return $ \x -> fmap (uncurry (&&)) $ concurrently (h1 x) (h2 x) +composeReporters _ _ = error "Only TestReporters can be composed" 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,33 +1,72 @@ --- vim:fdm=marker:foldtext=foldtext() -{-# LANGUAGE BangPatterns, ImplicitParams, MultiParamTypeClasses, DeriveDataTypeable #-} --- | 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. + + -- ** Output colouring + , UseColor(..) + , 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) +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 Control.DeepSeq -import Control.Applicative 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 USE_WCWIDTH +import Foreign.C.Types (CInt(..), CWchar(..)) +#endif +import Data.List (isInfixOf) import Data.Maybe -import Data.Monoid -import Data.Proxy +import Data.Monoid (Any(..)) +import qualified Data.Semigroup as Sem import Data.Typeable -import Data.Foldable (foldMap) +import Options.Applicative hiding (action, str, Success, Failure) import System.IO import System.Console.ANSI +#if !MIN_VERSION_base(4,11,0) +import Data.Foldable (foldMap) +#endif +import System.IO.Unsafe -------------------------------------------------- -- TestOutput base definitions @@ -36,28 +75,92 @@ -- | 'TestOutput' is an intermediary between output formatting and output -- printing. It lets us have several different printing modes (normal; print -- failures only; quiet). +-- +-- @since 0.12 data TestOutput - = PrintTest - {- print test name -} (IO ()) - {- print test result -} (Result -> IO ()) - | PrintHeading (IO ()) TestOutput - | Skip - | Seq TestOutput TestOutput + = -- | 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,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 -produceOutput :: (?colors :: Bool) => OptionSet -> TestTree -> TestOutput -produceOutput opts tree = +-- 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 +buildTestOutput :: (?colors :: Bool) => OptionSet -> TestTree -> TestOutput +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 @@ -65,30 +168,78 @@ level <- ask let - printTestName = - printf "%s%s: %s" (indent level) name - (replicate (alignment - indentSize * level - length name) ' ') + indentedNameWidth = indentSize * level + stringWidth name + postNamePadding = alignment - indentedNameWidth + testNamePadded = printf "%s%s: %s" + (indent level) + name + (replicate postNamePadding ' ') + + printTestName = do + 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 - if resultSuccessful result - then ok "OK\n" - else fail "FAIL\n" + -- use an appropriate printing function + let + printFn = + case resultOutcome result of + Success -> ok + Failure TestDepFailed -> skipped + _ -> fail + time = resultTime result + withoutLineWrap $ do + when getAnsiTricks $ do + putChar '\r' + clearLine + putStr testNamePadded + + printFn (resultShortDescription result) + 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 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) - return $ PrintHeading printHeading printBody + printHeading = withoutLineWrap $ printf "%s%s\n" (indent level) name + printBody = runReader (getApp (mconcat grp)) (level + 1) + return $ PrintHeading name printHeading printBody in flip runReader 0 $ getApp $ @@ -98,25 +249,56 @@ , 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 foldTestOutput - :: (?colors :: Bool, Monoid b) - => (IO () -> IO Result -> (Result -> IO ()) -> b) - -> (IO () -> b -> b) - -> TestOutput -> StatusMap -> b + :: 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 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. + -- The @b@ is the result of folding the test group. + -> TestOutput -- ^ The @TestOutput@ being rendered. + -> StatusMap -- ^ The @StatusMap@ received by the 'TestReporter' + -> b foldTestOutput foldTest foldHeading outputTree smap = flip evalState 0 $ getApp $ go outputTree where - go (PrintTest 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 printName readStatusVar printResult - go (PrintHeading printName printBody) = Ap $ - foldHeading printName <$> getApp (go printBody) + + 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) go Skip = mempty @@ -125,38 +307,53 @@ -------------------------------------------------- -- 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 output smap = - getTraversal . fst $ foldTestOutput foldTest foldHeading output smap +consoleOutput toutput smap = + getTraversal . fst $ foldTestOutput foldTest foldHeading toutput smap where - foldTest printName getResult printResult = + foldTest _name printName getResult printResult = ( Traversal $ do - printName + printName :: IO () r <- getResult printResult r , Any True) - foldHeading printHeading (printBody, Any nonempty) = + foldHeading _name printHeading (printBody, Any nonempty) = ( Traversal $ do - when nonempty $ do printHeading; getTraversal printBody + when nonempty $ do + printHeading :: IO () + getTraversal printBody , Any nonempty ) consoleOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> IO () -consoleOutputHidingSuccesses output smap = - void . getApp $ foldTestOutput foldTest foldHeading output smap +consoleOutputHidingSuccesses toutput smap = + void . getApp $ foldTestOutput foldTest foldHeading toutput smap where - foldTest printName getResult printResult = + foldTest _name printName getResult printResult = Ap $ do - printName + printName :: IO () r <- getResult if resultSuccessful r then do clearThisLine; return $ Any False - else do printResult r; return $ Any True + else do printResult r :: IO (); return $ Any True - foldHeading printHeading printBody = + foldHeading _name printHeading printBody = Ap $ do - printHeading + printHeading :: IO () Any failed <- getApp printBody unless failed clearAboveLine return $ Any failed @@ -165,11 +362,11 @@ clearThisLine = do clearLine; setCursorColumn 0 streamOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> IO () -streamOutputHidingSuccesses output smap = +streamOutputHidingSuccesses toutput smap = void . flip evalStateT [] . getApp $ - foldTestOutput foldTest foldHeading output smap + foldTestOutput foldTest foldHeading toutput smap where - foldTest printName getResult printResult = + foldTest _name printName getResult printResult = Ap $ do r <- liftIO $ getResult if resultSuccessful r @@ -180,12 +377,12 @@ liftIO $ do sequence_ $ reverse stack - printName - printResult r + printName :: IO () + printResult r :: IO () return $ Any True - foldHeading printHeading printBody = + foldHeading _name printHeading printBody = Ap $ do modify (printHeading :) Any failed <- getApp printBody @@ -203,57 +400,111 @@ -------------------------------------------------- -- {{{ +-- | Track the number of tests that were run and failures of a 'TestTree' or +-- sub-tree. +-- +-- @since 0.11.3 data Statistics = Statistics - { statTotal :: !Int - , statFailures :: !Int + { statTotal :: !Int -- ^ Number of active tests (e.g., that match the + -- pattern specified on the commandline), inactive tests + -- are not counted. + , 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,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)) <$> getResultFromTVar var) -printStatistics :: (?colors :: Bool) => Statistics -> IO () -printStatistics st = do - printf "\n" +reportStatistics :: (?colors :: Bool) => Statistics -> IO () +reportStatistics st = case statFailures st of + 0 -> ok $ printf "All %d tests passed" (statTotal st) + fs -> fail $ printf "%d out of %d tests failed" fs (statTotal st) +-- | @printStatistics@ reports test success/failure statistics and time it took +-- to run. The 'Time' results is intended to be filled in by the 'TestReporter' +-- callback. The @colors@ ImplicitParam controls whether coloured output is +-- used. +-- +-- @since 0.11.3 +printStatistics :: (?colors :: Bool) => Statistics -> Time -> IO () +printStatistics st time = do + printf "\n" + reportStatistics st case statFailures st of - 0 -> do - ok $ printf "All %d tests passed\n" (statTotal st) - - fs -> do - fail $ printf "%d out of %d tests failed\n" fs (statTotal st) - -data FailureStatus - = Unknown - | Failed - | OK - -instance Monoid FailureStatus where - mappend Failed _ = Failed - mappend _ Failed = Failed + 0 -> ok $ printf " (%.2fs)\n" time + _ -> fail $ printf " (%.2fs)\n" time - mappend OK OK = OK +-- | @printStatisticsNoTime@ reports test success/failure statistics +-- The @colors@ ImplicitParam controls whether coloured output is used. +-- +-- @since 0.12 +printStatisticsNoTime :: (?colors :: Bool) => Statistics -> IO () +printStatisticsNoTime st = reportStatistics st >> printf "\n" - mappend _ _ = Unknown +-- | Wait until +-- +-- * all tests have finished successfully, and return 'True', or +-- +-- * at least one test has failed, and return 'False' +statusMapResult + :: Int -- ^ lookahead + -> StatusMap + -> IO Bool +statusMapResult lookahead0 smap + | IntMap.null smap = return True + | otherwise = + join . atomically $ + IntMap.foldrWithKey f finish smap mempty lookahead0 + where + f :: Int + -> TVar Status + -> (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 + f key tvar k ok_tests lookahead + | lookahead <= 0 = + -- We looked at too many unfinished tests. + next_iter ok_tests + | otherwise = do + this_status <- readTVar tvar + case this_status of + Done r -> + if resultSuccessful r + then k (IntSet.insert key ok_tests) lookahead + else return $ return False + _ -> k ok_tests (lookahead-1) - mempty = OK + -- 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 :: 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 IntSet.null ok_tests + then retry + else return $ statusMapResult lookahead0 (IntMap.withoutKeys smap ok_tests) -failureStatus :: StatusMap -> IO FailureStatus -failureStatus smap = atomically $ do - fst <- getApp $ flip foldMap smap $ \svar -> Ap $ do - status <- readTVar svar - return $ case status of - Done r -> - if resultSuccessful r then OK else Failed - _ -> Unknown - case fst of - Unknown -> retry - _ -> return fst + finish :: IntSet.IntSet -> Int -> STM (IO Bool) + finish ok_tests _ = next_iter ok_tests -- }}} @@ -262,72 +513,233 @@ -------------------------------------------------- -- {{{ --- | A simple console UI +-- | A simple console UI. +-- +-- @since 0.4 consoleTestReporter :: Ingredient -consoleTestReporter = - TestReporter - [ Option (Proxy :: Proxy Quiet) - , Option (Proxy :: Proxy HideSuccesses) - ] $ - \opts tree -> Just $ \smap -> +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 - do - isTerm <- hIsTerminalDevice stdout +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." - (\k -> if isTerm - then (do hideCursor; k) `finally` showCursor - else k) $ do + escapeQuotes = concatMap $ \c -> if c == '\'' then "'\\''" else [c] - hSetBuffering stdout NoBuffering + 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 - let - ?colors = isTerm - let - Quiet quiet = lookupOption opts - HideSuccesses hideSuccesses = lookupOption opts + individualPattern = findPattern (filter (name `isInfixOf`) tests) name names - output = produceOutput opts tree + pattern = maybe id And currentPattern individualPattern - case () of { _ - | quiet -> return () - | hideSuccesses && isTerm -> - consoleOutputHidingSuccesses output smap - | hideSuccesses && not isTerm -> - streamOutputHidingSuccesses output smap - | otherwise -> consoleOutput output smap - } +consoleTestReporterOptions :: [OptionDescription] +consoleTestReporterOptions = + [ Option (Proxy :: Proxy Quiet) + , Option (Proxy :: Proxy HideSuccesses) + , Option (Proxy :: Proxy MinDurationToReport) + , Option (Proxy :: Proxy UseColor) + , Option (Proxy :: Proxy AnsiTricks) + ] - if quiet - then do - fst <- failureStatus smap - return $ case fst of - OK -> True - _ -> False - else do - stats <- computeStatistics smap - printStatistics stats - return $ statFailures stats == 0 +-- | 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 --- | Do not print test results (see README for details) + let + whenColor = lookupOption opts + Quiet quiet = lookupOption opts + HideSuccesses hideSuccesses = lookupOption opts + NumThreads numThreads = lookupOption opts + AnsiTricks ansiTricks = lookupOption opts + + if quiet + then do + b <- statusMapResult numThreads smap + return $ \_time -> return b + else + + do + isTerm <- hSupportsANSI stdout + isTermColor <- hSupportsANSIColor stdout + + (\k -> if isTerm + -- 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 isTermColor + + let + -- 'buildTestOutput' is a pure function and cannot query 'hSupportsANSI' itself. + -- We also would rather not pass @isTerm@ as an extra argument, + -- since it's a breaking change, thus resorting to tweaking @opts@. + opts' = changeOption (\(AnsiTricks x) -> AnsiTricks (x && isTerm)) opts + toutput = applyHook hook $ buildTestOutput opts' tree + + case () of { _ + | hideSuccesses && isTerm && ansiTricks -> + consoleOutputHidingSuccesses toutput smap + | hideSuccesses -> + streamOutputHidingSuccesses toutput smap + | otherwise -> consoleOutput toutput smap + } + + return $ \time -> do + stats <- computeStatistics smap + printStatistics stats time + return $ statFailures stats == 0 + +-- | 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 . safeRead + parseValue = fmap Quiet . safeReadBool optionName = return "quiet" optionHelp = return "Do not produce any output; indicate success only by the exit code" - optionCLParser = flagCLParser (Just 'q') (Quiet True) + 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 . safeRead + parseValue = fmap HideSuccesses . safeReadBool optionName = return "hide-successes" optionHelp = return "Do not print tests that passed successfully" - optionCLParser = flagCLParser Nothing (HideSuccesses True) + 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 +data UseColor + = Never + | Always + | Auto -- ^ Only if stdout is an ANSI color supporting terminal + deriving (Eq, Ord) + +-- | Control color output +instance IsOption UseColor where + defaultValue = Auto + parseValue = parseUseColor + optionName = return "color" + 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. +-- +-- @since 0.11.3 +useColor :: UseColor -> Bool -> Bool +useColor when_ isTerm = + case when_ of + Never -> False + Always -> True + Auto -> isTerm + +parseUseColor :: String -> Maybe UseColor +parseUseColor s = + case map toLower s of + "never" -> return Never + "always" -> return Always + "auto" -> return Auto + _ -> Nothing + +displayUseColor :: UseColor -> String +displayUseColor uc = + case uc of + Never -> "never" + Always -> "always" + Auto -> "auto" + -- }}} -------------------------------------------------- @@ -378,72 +790,74 @@ 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 - --- | Compute the amount of space needed to align "OK"s and "FAIL"s +-- | 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 (length 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 --- | Printing exceptions or other messages is tricky — in the process we --- can get new exceptions! +-- | 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 +-- all characters actually have the same width, in particular, most CJK +-- characters have twice the same as Western characters. -- --- See e.g. https://github.com/feuerbach/tasty/issues/25 -formatMessage :: String -> IO String -formatMessage msg = go 3 msg - where - -- to avoid infinite recursion, we introduce the recursion limit - go :: Int -> String -> IO String - go 0 _ = return "exceptions keep throwing other exceptions!" - go recLimit msg = do - mbStr <- try $ evaluate $ force msg - case mbStr of - Right str -> return str - Left e' -> printf "message threw an exception: %s" <$> go (recLimit-1) (show (e' :: SomeException)) +-- (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 USE_WCWIDTH +stringWidth = Prelude.sum . map charWidth + where charWidth c = case wcwidth (fromIntegral (ord c)) of + -1 -> 1 -- many chars have "undefined" width; default to 1 for these. + w -> fromIntegral w +foreign import capi safe "wchar.h wcwidth" wcwidth :: CWchar -> CInt +#else +stringWidth = length +#endif -- (Potentially) colorful output -ok, fail, infoOk, infoFail :: (?colors :: Bool) => String -> IO () -fail = output BoldIntensity Vivid Red -ok = output NormalIntensity Dull Green -infoOk = output NormalIntensity Dull White -infoFail = output NormalIntensity Dull Red +ok, fail, skipped, infoOk, infoFail :: (?colors :: Bool) => String -> IO () +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,39 +1,45 @@ -- | Ingredient for listing test names -{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} module Test.Tasty.Ingredients.ListTests ( ListTests(..) , testsNames , listingTests ) where -import Data.Typeable import Data.Proxy +import Options.Applicative import Test.Tasty.Core import Test.Tasty.Options 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 . safeRead + parseValue = fmap ListTests . safeReadBool optionName = return "list-tests" optionHelp = return "Do not run the tests; just print their names" - optionCLParser = flagCLParser (Just 'l') (ListTests True) + 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, - OverlappingInstances, FlexibleInstances, UndecidableInstances, + 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,27 +17,37 @@ , lookupOption , singleOption , OptionDescription(..) + , uniqueOptionDescriptions -- * Utilities , flagCLParser + , mkFlagCLParser + , mkOptionCLParser , safeRead + , safeReadBool ) where -import Data.Typeable 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 -import Options.Applicative.Types -- | 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 - -- | Try to parse an option value from a string + -- | Try to parse an option value from a string. Consider using + -- 'safeReadBool' for boolean options and 'safeRead' for numeric options. parseValue :: String -> Maybe v -- | The option name. It is used to form the command line option name, for -- instance. Therefore, it had better not contain spaces or other fancy @@ -44,38 +56,39 @@ -- | 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. - -- You may want to override it in some cases (e.g. add a short flag). + -- You may want to override it in some cases (e.g. add a short flag) and + -- 'flagCLParser', 'mkFlagCLParser' and 'mkOptionCLParser' might come in + -- handy. -- -- 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 -- failing parser into an always-succeeding one that may return an empty -- OptionSet.) optionCLParser :: Parser v - optionCLParser = - nullOption - ( reader parse - <> long name - <> help helpString - ) - where - name = untag (optionName :: Tagged v String) - helpString = untag (optionHelp :: Tagged v String) - parse = - ReadM . - maybe (Left (ErrorMsg $ "Could not parse " ++ name)) Right . - parseValue + optionCLParser = mkOptionCLParser mempty data OptionValue = forall v . IsOption v => OptionValue v @@ -83,20 +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,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 @@ -104,34 +129,95 @@ 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 -> v -- ^ non-default value (when the flag is supplied) -> Parser v -flagCLParser mbShort v = flag' v - ( foldMap short mbShort - <> long (untag (optionName :: Tagged v String)) +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 + -> v -- ^ non-default value (when the flag is supplied) + -> Parser v +mkFlagCLParser mod v = flag' v + ( long (untag (optionName :: Tagged v String)) <> help (untag (optionHelp :: Tagged v String)) + <> mod ) +-- | 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 + ( long name + <> help (untag (optionHelp :: Tagged v String)) + <> mod + ) + where + name :: String + name = untag (optionName :: Tagged v String) + + 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. +-- +-- @since 1.0.1 +safeReadBool :: String -> Maybe Bool +safeReadBool s = + case (map toLower s) of + "true" -> Just True + "false" -> Just False + _ -> Nothing 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,20 +1,27 @@ -- | Core options, i.e. the options used by tasty itself -{-# LANGUAGE 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 Data.Typeable +import Control.Monad (mfilter) import Data.Proxy -import Data.Tagged import Data.Fixed -import Options.Applicative -import Options.Applicative.Types (ReadM(..)) +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 @@ -23,63 +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 = 1 - parseValue = fmap NumThreads . safeRead + 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 = - nullOption - ( reader parse - <> short 'j' - <> long name - <> help (untag (optionHelp :: Tagged NumThreads String)) - ) - where - name = untag (optionName :: Tagged NumThreads String) - parse = - ReadM . - maybe (Left (ErrorMsg $ "Could not parse " ++ name)) Right . - parseValue + optionCLParser = mkOptionCLParser (short 'j' <> metavar "NUMBER") + showDefaultValue _ = Just "Number of cores when using threaded RTS, 1 for non-threaded" --- | Timeout to be applied to individual tests +-- | Filtering function to prevent non-positive number of threads +onlyPositive :: NumThreads -> Bool +onlyPositive (NumThreads x) = x > 0 + +-- | 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 = - nullOption - ( reader parse - <> short 't' - <> long name - <> help (untag (optionHelp :: Tagged Timeout String)) - ) - where - name = untag (optionName :: Tagged Timeout String) - parse = - ReadM . - maybe (Left (ErrorMsg $ "Could not parse " ++ name)) Right . - parseValue + 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) <$> @@ -94,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 @@ -102,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,13 +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 Text.Printf data EnvOptionException @@ -22,7 +19,6 @@ String -- option name String -- variable name String -- value - deriving (Typeable) instance Show EnvOptionException where show (BadOption optName varName value) = @@ -36,6 +32,7 @@ getEnvOptions :: [OptionDescription] -> IO OptionSet getEnvOptions = getApp . foldMap lookupOpt where + lookupOpt :: OptionDescription -> Ap IO OptionSet lookupOpt (Option (px :: Proxy v)) = do let name = proxy optionName px diff --git a/Test/Tasty/Parallel.hs b/Test/Tasty/Parallel.hs --- a/Test/Tasty/Parallel.hs +++ b/Test/Tasty/Parallel.hs @@ -1,30 +1,27 @@ -- | A helper module which takes care of parallelism -{-# LANGUAGE DeriveDataTypeable #-} -module Test.Tasty.Parallel (runInParallel) where +module Test.Tasty.Parallel (ActionStatus(..), Action(..), runInParallel) where import Control.Monad import Control.Concurrent +import Control.Concurrent.Async import Control.Concurrent.STM -import Control.Exception import Foreign.StablePtr -import Data.Typeable -data Interrupt = Interrupt - deriving Typeable -instance Show Interrupt where - show Interrupt = "interrupted" -instance Exception Interrupt - -data ParThreadKilled = ParThreadKilled SomeException - deriving Typeable -instance Show ParThreadKilled where - show (ParThreadKilled exn) = - "tasty: one of the test running threads was killed by: " ++ - show exn -instance Exception ParThreadKilled +-- | What to do about an t'Action'? +data ActionStatus + = ActionReady + -- ^ the action is ready to be executed + | ActionSkip + -- ^ the action should be skipped + | ActionWait + -- ^ not sure what to do yet; wait + deriving Eq -shutdown :: ThreadId -> IO () -shutdown = flip throwTo Interrupt +data Action = Action + { actionStatus :: STM ActionStatus + , actionRun :: IO () + , actionSkip :: STM () + } -- | Take a list of actions and execute them in parallel, no more than @n@ -- at the same time. @@ -34,7 +31,8 @@ -- cleans up. runInParallel :: Int -- ^ maximum number of parallel threads - -> [IO ()] -- ^ list of actions to execute + -> [Action] -- ^ list of actions to execute. + -- The first action in the pair tells if the second action is ready to run. -> IO (IO ()) -- This implementation tries its best to ensure that exceptions are -- properly propagated to the caller and threads are not left running. @@ -43,97 +41,75 @@ -- 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 - -- A variable containing all ThreadIds of forked threads. - -- - -- These are the threads we'll need to kill if something wrong happens. - pidsVar <- atomically $ newTVar [] - - -- If an unexpected exception has been thrown and we started killing all - -- the spawned threads, this flag will be set to False, so that any - -- freshly spawned threads will know to terminate, even if their pids - -- didn't make it to the "kill list" yet. - aliveVar <- atomically $ newTVar True - - let - -- Kill all threads. - shutdownAll :: IO () - shutdownAll = do - pids <- atomically $ do - writeTVar aliveVar False - readTVar pidsVar - - -- be sure not to kill myself! - me <- myThreadId - mapM_ shutdown $ filter (/= me) pids + actionsVar <- atomically $ newTMVar actions - cleanup :: Either SomeException () -> IO () - cleanup Right {} = return () - cleanup (Left exn) - | Just Interrupt <- fromException exn - -- I'm being shut down either by a fellow thread (which caught an - -- exception), or by the main thread which decided to stop running - -- tests. In any case, just end silently. - = return () - | otherwise = do - -- Wow, I caught an exception (most probably an async one, - -- although it doesn't really matter). Shut down all other - -- threads, and re-throw my exception to the calling thread. - shutdownAll - throwTo callingThread $ ParThreadKilled exn + pids <- replicateM nthreads (async $ work actionsVar) - forkCarefully :: IO () -> IO ThreadId - forkCarefully action = flip myForkFinally cleanup $ do - -- We cannot check liveness and update the pidsVar in one - -- transaction before forking, because we don't know the new pid yet. - -- - -- So we fork and then check/update. If something has happened in - -- the meantime, it's not a big deal — we just cancel. OTOH, if - -- we're alive at the time of the transaction, then we add our pid - -- and will be killed when something happens. - newPid <- myThreadId + 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 + where + go = do join . atomically $ do - alive <- readTVar aliveVar - if alive - then do - modifyTVar pidsVar (newPid :) - return action - else - return (return ()) - - capsVar <- atomically $ newTVar nthreads - - let - go a cont = join . atomically $ do - caps <- readTVar capsVar - if caps > 0 - then do - writeTVar capsVar $! caps - 1 - let - release = atomically $ modifyTVar' capsVar (+1) - - -- Thanks to our exception handling, we won't deadlock even if - -- an exception strikes before we 'release'. Everything will be - -- killed, so why bother. - return $ do forkCarefully (do a; release); cont - - else retry - - -- fork here as well, so that we can move to the UI without waiting - -- untill all tests have finished - forkCarefully $ foldr go (return ()) actions - return shutdownAll + mb_ready <- findBool =<< takeTMVar actionsVar + case mb_ready of + 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 + return $ actionRun this >> go --- Copied from base to stay compatible with GHC 7.4. -myForkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId -myForkFinally action and_then = - mask $ \restore -> - forkIO $ try (restore action) >>= and_then +-- | Find a ready-to-run item. Filter out the items that will never be +-- ready to run. +-- +-- Return the ready item and the remaining ones. +-- +-- This action may block if no items are ready to run just yet. +-- +-- Return 'Nothing' if there are no runnable items left. +findBool :: [Action] -> STM (Maybe (Action, [Action])) +findBool = go [] + where + go [] [] = + -- nothing to do + return Nothing + go _ [] = + -- nothing ready yet + retry + go past (this : rest) = do + status <- actionStatus this + case status of + ActionReady -> return $ Just (this, reverse past ++ rest) + ActionWait -> go (this : past) rest + ActionSkip -> do + actionSkip this + go past rest diff --git a/Test/Tasty/Patterns.hs b/Test/Tasty/Patterns.hs --- a/Test/Tasty/Patterns.hs +++ b/Test/Tasty/Patterns.hs @@ -1,160 +1,87 @@ --- This code is largely borrowed from test-framework -{- -Copyright (c) 2008, Maximilian Bolingbroke -All rights reserved. - -Redistribution and use in source and binary forms, with or without modification, are permitted -provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright notice, this list of - conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above copyright notice, this list of - conditions and the following disclaimer in the documentation and/or other materials - provided with the distribution. - * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to - endorse or promote products derived from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR -IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR -CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER -IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT -OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --} - -- | Test patterns --- --- (Most of the code borrowed from the test-framework) -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE CPP, TypeApplications #-} module Test.Tasty.Patterns - ( TestPattern + ( TestPattern(..) + , parseExpr , parseTestPattern , noPattern + , Path + , exprMatches , testPatternMatches ) where import Test.Tasty.Options - -import Text.Regex.TDFA -import Text.Regex.TDFA.String() - -import Data.List -import Data.Typeable -import Data.Tagged - -import Options.Applicative -import Options.Applicative.Types (ReadM(..)) - -data Token = SlashToken - | WildcardToken - | DoubleWildcardToken - | LiteralToken Char - deriving (Eq, Show) - -tokenize :: String -> [Token] -tokenize ('/':rest) = SlashToken : tokenize rest -tokenize ('*':'*':rest) = DoubleWildcardToken : tokenize rest -tokenize ('*':rest) = WildcardToken : tokenize rest -tokenize (c:rest) = LiteralToken c : tokenize rest -tokenize [] = [] - +import Test.Tasty.Patterns.Types +import Test.Tasty.Patterns.Parser +import Test.Tasty.Patterns.Eval -data TestPatternMatchMode = TestMatchMode - | PathMatchMode - deriving Show +import Data.Char +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 --- | A pattern to filter tests. For the syntax description, see --- -data TestPattern = TestPattern { - tp_categories_only :: Bool, - tp_negated :: Bool, - tp_match_mode :: TestPatternMatchMode, - tp_tokens :: [Token] - } | NoPattern - deriving (Typeable, Show) +-- | @since 1.0 +newtype TestPattern = + -- | @since 1.1 + TestPattern + (Maybe Expr) + deriving + ( Show -- ^ @since 1.1 + , Eq -- ^ @since 1.1 + ) --- | A pattern that matches anything. +-- | @since 1.0 noPattern :: TestPattern -noPattern = NoPattern - -instance Read TestPattern where - readsPrec _ string = [(parseTestPattern string, "")] +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 = Just . parseTestPattern + parseValue = parseTestPattern optionName = return "pattern" - optionHelp = return "Select only tests that match 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 = - nullOption - ( reader (ReadM . Right . parseTestPattern) - <> short 'p' - <> long (untag (optionName :: Tagged TestPattern String)) - <> help (untag (optionHelp :: Tagged TestPattern String)) - ) - --- | Parse a pattern -parseTestPattern :: String -> TestPattern -parseTestPattern string = TestPattern { - tp_categories_only = categories_only, - tp_negated = negated, - tp_match_mode = match_mode, - tp_tokens = tokens'' - } - where - tokens = tokenize string - (negated, tokens') - | (LiteralToken '!'):rest <- tokens = (True, rest) - | otherwise = (False, tokens) - (categories_only, tokens'') - | (prefix, [SlashToken]) <- splitAt (length tokens' - 1) tokens' = (True, prefix) - | otherwise = (False, tokens') - match_mode - | SlashToken `elem` tokens = PathMatchMode - | otherwise = TestMatchMode - - --- | Test a path (which is the sequence of group titles, possibly followed --- by the test title) against a pattern -testPatternMatches :: TestPattern -> [String] -> Bool -testPatternMatches NoPattern _ = True -testPatternMatches test_pattern path = not_maybe $ any (=~ tokens_regex) things_to_match - where - not_maybe | tp_negated test_pattern = not - | otherwise = id - path_to_consider | tp_categories_only test_pattern = dropLast 1 path - | otherwise = path - tokens_regex = buildTokenRegex (tp_tokens test_pattern) - - things_to_match = case tp_match_mode test_pattern of - -- See if the tokens match any single path component - TestMatchMode -> path_to_consider - -- See if the tokens match any prefix of the path - PathMatchMode -> map pathToString $ inits path_to_consider - - -buildTokenRegex :: [Token] -> String -buildTokenRegex [] = [] -buildTokenRegex (token:tokens) = concat (firstTokenToRegex token : map tokenToRegex tokens) - where - firstTokenToRegex SlashToken = "^" - firstTokenToRegex other = tokenToRegex other + fmap (TestPattern . fmap (foldr1 And) . nonEmpty . catMaybes . coerce @[TestPattern]) . some $ + mkOptionCLParser (short 'p' <> metavar "PATTERN") - tokenToRegex SlashToken = "/" - tokenToRegex WildcardToken = "[^/]*" - tokenToRegex DoubleWildcardToken = ".*" - tokenToRegex (LiteralToken lit) = regexEscapeChar lit +-- | @since 1.2 +parseExpr :: String -> Maybe Expr +parseExpr s + | all (\c -> isAlphaNum c || c `elem` "._- ") s = + Just $ ERE s + | otherwise = parseAwkExpr s -regexEscapeChar :: Char -> String -regexEscapeChar c | c `elem` "\\*+?|{}[]()^$." = '\\' : [c] - | otherwise = [c] +-- | @since 1.0 +parseTestPattern :: String -> Maybe TestPattern +parseTestPattern s + | null s = Just noPattern + | otherwise = TestPattern . Just <$> parseExpr s -pathToString :: [String] -> String -pathToString path = concat (intersperse "/" path) +-- | @since 1.2 +exprMatches :: Expr -> Path -> Bool +exprMatches e fields = + case withFields fields $ asB =<< eval e of + Left msg -> error msg + Right b -> b -dropLast :: Int -> [a] -> [a] -dropLast n = reverse . drop n . reverse +-- | @since 1.0 +testPatternMatches :: TestPattern -> Path -> Bool +testPatternMatches pat fields = + case pat of + TestPattern Nothing -> True + TestPattern (Just e) -> exprMatches e fields diff --git a/Test/Tasty/Patterns/Eval.hs b/Test/Tasty/Patterns/Eval.hs new file mode 100644 --- /dev/null +++ b/Test/Tasty/Patterns/Eval.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE RankNTypes, ViewPatterns #-} +-- | @since 1.0 +module Test.Tasty.Patterns.Eval (Path, eval, withFields, asB) where + +import Prelude hiding (Ordering(..)) +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 (findIndex, intercalate, isInfixOf, isPrefixOf, tails) +import Data.Maybe +import Data.Char +import Test.Tasty.Patterns.Types + +-- | @since 1.2 +type Path = Seq.Seq String + +data Value + = VN !Int + | VS !Bool String + -- ^ The 'Bool' is 'True' if the source of the string + -- allows it to be numeric + | Uninitialized + deriving Show + +type M = ReaderT Path (Either String) + +throwError :: String -> M a +throwError s = lift $ Left s + +asS :: Value -> M String +asS v = return $ + case v of + VN n -> show n + VS _ s -> s + Uninitialized -> "" + +-- readMaybe was not in base-4.3 yet +parseN :: String -> Maybe Int +parseN s = + case read s of + [(n, "")] -> Just n + _ -> Nothing + +asN :: Value -> M Int +asN v = + case v of + VN n -> return n + VS True s -> + case parseN s of + Just n -> return n + Nothing -> throwError $ "Not a number: " ++ show s + VS False s -> throwError $ "String is not numeric: " ++ show s + Uninitialized -> return 0 + +isN :: Value -> Bool +isN v = + case v of + VN _ -> True + _ -> False + +isNumeric :: Value -> Bool +isNumeric v = + case v of + VS b s -> b && isJust (parseN s) + _ -> True + +-- | @since 1.0 +asB :: Value -> M Bool +asB v = return $ + case v of + VN 0 -> False + VS _ "" -> False + _ -> True + +fromB :: Bool -> Value +fromB = VN . fromEnum + +-- | Evaluate an awk expression. +-- +-- @since 1.0 +eval :: Expr -> M Value +eval e0 = + case e0 of + IntLit n -> return $ VN n + StringLit s -> return $ VS False s + NF -> VN . subtract 1 . Seq.length <$> ask + Add e1 e2 -> binNumOp (+) e1 e2 + Sub e1 e2 -> binNumOp (-) e1 e2 + Neg e1 -> VN . negate <$> (asN =<< eval e1) + Not e1 -> fromB . not <$> (asB =<< eval e1) + And e1 e2 -> binLglOp (&&) e1 e2 + Or e1 e2 -> binLglOp (||) e1 e2 + LT e1 e2 -> binCmpOp (<) e1 e2 + LE e1 e2 -> binCmpOp (<=) e1 e2 + GT e1 e2 -> binCmpOp (>) e1 e2 + GE e1 e2 -> binCmpOp (>=) e1 e2 + EQ e1 e2 -> binCmpOp (==) e1 e2 + NE e1 e2 -> binCmpOp (/=) e1 e2 + Concat e1 e2 -> VS False <$> ((++) <$> (asS =<< eval e1) <*> (asS =<< eval e2)) + If cond e1 e2 -> do + condV <- asB =<< eval cond + if condV then eval e1 else eval e2 + Field e1 -> do + n <- asN =<< eval e1 + fields <- ask + return $ if n > Seq.length fields - 1 + then Uninitialized + else VS True $ Seq.index fields n + ERE pat -> do + str <- Seq.index <$> ask <*> pure 0 + return . fromB $ match pat str + Match e1 pat -> do + str <- asS =<< eval e1 + return . fromB $ match pat str + NoMatch e1 pat -> do + str <- asS =<< eval e1 + return . fromB . not $ match pat str + ToUpperFn e1 -> + VS True . map toUpper <$> (asS =<< eval e1) + ToLowerFn e1 -> + VS True . map toLower <$> (asS =<< eval e1) + SubstrFn e1 e2 mb_e3 -> do + s <- asS =<< eval e1 + m <- asN =<< eval e2 + mb_n <- traverse (asN <=< eval) mb_e3 + return $ VS True $ + maybe id take mb_n . drop (m-1) $ s + LengthFn (fromMaybe (Field (IntLit 0)) -> e1) -> + VN . length <$> (asS =<< eval e1) + MatchFn e1 pat -> do + s <- asS =<< eval e1 + return . VN . maybe 0 (+1) . findIndex (pat `isPrefixOf`) $ tails s + + where + binNumOp op e1 e2 = VN <$> (op <$> (asN =<< eval e1) <*> (asN =<< eval e2)) + binLglOp op e1 e2 = fromB <$> (op <$> (asB =<< eval e1) <*> (asB =<< eval e2)) + binCmpOp :: (forall a . Ord a => a -> a -> Bool) -> Expr -> Expr -> M Value + binCmpOp op e1 e2 = do + v1 <- eval e1 + v2 <- eval e2 + let + compareAsNumbers = + isN v1 && isNumeric v2 || + isN v2 && isNumeric v1 + if compareAsNumbers + then fromB <$> (op <$> asN v1 <*> asN v2) + else fromB <$> (op <$> asS v1 <*> asS v2) + +match + :: String -- ^ pattern + -> String -- ^ string + -> Bool +match pat str = pat `isInfixOf` str + +-- | Run the @M@ monad with a given list of fields +-- +-- The field list should not include @$0@; it's calculated automatically. +-- +-- @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/Expr.hs b/Test/Tasty/Patterns/Expr.hs new file mode 100644 --- /dev/null +++ b/Test/Tasty/Patterns/Expr.hs @@ -0,0 +1,173 @@ +-- | +-- Copyright : © 2015–2018 Megaparsec contributors +-- © 2007 Paolo Martini +-- © 1999–2001 Daan Leijen +-- +-- +-- Code adapted from from megaparsec under the BSD license. +module Test.Tasty.Patterns.Expr + ( Operator (..) + , makeExprParser ) +where + +import Control.Monad + +choice :: MonadPlus m => [m a] -> m a +choice = msum + +option :: MonadPlus m => a -> m a -> m a +option x p = p `mplus` return x + +-- | This data type specifies operators that work on values of type @a@. An +-- operator is either binary infix or unary prefix or postfix. A binary +-- operator has also an associated associativity. + +data Operator m a + = InfixN (m (a -> a -> a)) -- ^ Non-associative infix + | InfixL (m (a -> a -> a)) -- ^ Left-associative infix + | InfixR (m (a -> a -> a)) -- ^ Right-associative infix + | Prefix (m (a -> a)) -- ^ Prefix + | Postfix (m (a -> a)) -- ^ Postfix + | TernR (m (m (a -> a -> a -> a))) + -- ^ Right-associative ternary. Right-associative means that + -- @a ? b : d ? e : f@ parsed as + -- @a ? b : (d ? e : f)@ and not as @(a ? b : d) ? e : f@. + +-- | @'makeExprParser' term table@ builds an expression parser for terms +-- @term@ with operators from @table@, taking the associativity and +-- precedence specified in the @table@ into account. +-- +-- @table@ is a list of @[Operator m a]@ lists. The list is ordered in +-- descending precedence. All operators in one list have the same precedence +-- (but may have different associativity). +-- +-- Prefix and postfix operators of the same precedence associate to the left +-- (i.e. if @++@ is postfix increment, than @-2++@ equals @-1@, not @-3@). +-- +-- Unary operators of the same precedence can only occur once (i.e. @--2@ is +-- not allowed if @-@ is prefix negate). If you need to parse several prefix +-- or postfix operators in a row, (like C pointers—@**i@) you can use this +-- approach: +-- +-- > manyUnaryOp = foldr1 (.) <$> some singleUnaryOp +-- +-- This is not done by default because in some cases allowing repeating +-- prefix or postfix operators is not desirable. +-- +-- If you want to have an operator that is a prefix of another operator in +-- the table, use the following (or similar) wrapper instead of plain +-- 'Text.Megaparsec.Char.Lexer.symbol': +-- +-- > op n = (lexeme . try) (string n <* notFollowedBy punctuationChar) +-- +-- 'makeExprParser' takes care of all the complexity involved in building an +-- expression parser. Here is an example of an expression parser that +-- handles prefix signs, postfix increment and basic arithmetic: +-- +-- > expr = makeExprParser term table "expression" +-- > +-- > term = parens expr <|> integer "term" +-- > +-- > table = [ [ prefix "-" negate +-- > , prefix "+" id ] +-- > , [ postfix "++" (+1) ] +-- > , [ binary "*" (*) +-- > , binary "/" div ] +-- > , [ binary "+" (+) +-- > , binary "-" (-) ] ] +-- > +-- > binary name f = InfixL (f <$ symbol name) +-- > prefix name f = Prefix (f <$ symbol name) +-- > postfix name f = Postfix (f <$ symbol name) + +makeExprParser :: MonadPlus m + => m a -- ^ Term parser + -> [[Operator m a]] -- ^ Operator table, see 'Operator' + -> m a -- ^ Resulting expression parser +makeExprParser = foldl addPrecLevel +{-# INLINEABLE makeExprParser #-} + +-- | @addPrecLevel p ops@ adds the ability to parse operators in table @ops@ +-- to parser @p@. + +addPrecLevel :: MonadPlus m => m a -> [Operator m a] -> m a +addPrecLevel term ops = + term' >>= \x -> choice [ras' x, las' x, nas' x, tern' x, return x] + where (ras, las, nas, prefix, postfix, tern) = foldr splitOp ([],[],[],[],[],[]) ops + term' = pTerm (choice prefix) term (choice postfix) + ras' = pInfixR (choice ras) term' + las' = pInfixL (choice las) term' + nas' = pInfixN (choice nas) term' + tern' = pTernR (choice tern) term' + +-- | @pTerm prefix term postfix@ parses a @term@ surrounded by optional +-- prefix and postfix unary operators. Parsers @prefix@ and @postfix@ are +-- allowed to fail, in this case 'id' is used. + +pTerm :: MonadPlus m => m (a -> a) -> m a -> m (a -> a) -> m a +pTerm prefix term postfix = do + pre <- option id prefix + x <- term + post <- option id postfix + return . post . pre $ x + +-- | @pInfixN op p x@ parses non-associative infix operator @op@, then term +-- with parser @p@, then returns result of the operator application on @x@ +-- and the term. + +pInfixN :: MonadPlus m => m (a -> a -> a) -> m a -> a -> m a +pInfixN op p x = do + f <- op + y <- p + return $ f x y + +-- | @pInfixL op p x@ parses left-associative infix operator @op@, then term +-- with parser @p@, then returns result of the operator application on @x@ +-- and the term. + +pInfixL :: MonadPlus m => m (a -> a -> a) -> m a -> a -> m a +pInfixL op p x = do + f <- op + y <- p + let r = f x y + pInfixL op p r `mplus` return r + +-- | @pInfixR op p x@ parses right-associative infix operator @op@, then +-- term with parser @p@, then returns result of the operator application on +-- @x@ and the term. + +pInfixR :: MonadPlus m => m (a -> a -> a) -> m a -> a -> m a +pInfixR op p x = do + f <- op + y <- p >>= \r -> pInfixR op p r `mplus` return r + return $ f x y + +-- | Parse the first separator of a ternary operator + +pTernR :: MonadPlus m => m (m (a -> a -> a -> a)) -> m a -> a -> m a +pTernR sep1 p x = do + sep2 <- sep1 + y <- p >>= \r -> pTernR sep1 p r `mplus` return r + f <- sep2 + z <- p >>= \r -> pTernR sep1 p r `mplus` return r + return $ f x y z + +type Batch m a = + ( [m (a -> a -> a)] + , [m (a -> a -> a)] + , [m (a -> a -> a)] + , [m (a -> a)] + , [m (a -> a)] + , [m (m (a -> a -> a -> a))] + ) + +-- | A helper to separate various operators (binary, unary, and according to +-- associativity) and return them in a tuple. + +splitOp :: Operator m a -> Batch m a -> Batch m a +splitOp (InfixR op) (r, l, n, pre, post, tern) = (op:r, l, n, pre, post, tern) +splitOp (InfixL op) (r, l, n, pre, post, tern) = (r, op:l, n, pre, post, tern) +splitOp (InfixN op) (r, l, n, pre, post, tern) = (r, l, op:n, pre, post, tern) +splitOp (Prefix op) (r, l, n, pre, post, tern) = (r, l, n, op:pre, post, tern) +splitOp (Postfix op) (r, l, n, pre, post, tern) = (r, l, n, pre, op:post, tern) +splitOp (TernR op) (r, l, n, pre, post, tern) = (r, l, n, pre, post, op:tern) diff --git a/Test/Tasty/Patterns/Parser.hs b/Test/Tasty/Patterns/Parser.hs new file mode 100644 --- /dev/null +++ b/Test/Tasty/Patterns/Parser.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | See for the +-- full awk grammar. +-- +-- @since 1.0 +module Test.Tasty.Patterns.Parser + ( Parser + , runParser + , ParseResult(..) + , expr + , parseAwkExpr + ) + where + +import Prelude hiding (Ordering(..)) +import Text.ParserCombinators.ReadP hiding (many, optional) +import Text.ParserCombinators.ReadPrec (readPrec_to_P, minPrec) +import Text.Read (readPrec) +import Data.Functor +import Data.Char +import Control.Applicative +import Control.Monad +import Test.Tasty.Patterns.Types +import Test.Tasty.Patterns.Expr + +type Token = ReadP + +-- | A separate 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) + +-- | @since 1.0 +data ParseResult a = Success a | Invalid | Ambiguous [a] + deriving + ( Show + , Eq -- ^ @since 1.4.2 + ) + +token :: Token a -> Parser a +token a = Parser (a <* skipSpaces) + +sym :: Char -> Parser () +sym = void . token . char + +str :: String -> Parser () +str = void . token . string + +-- | Run a parser +-- +-- @since 1.0 +runParser + :: Parser a + -> String -- ^ text to parse + -> ParseResult a +runParser (Parser p) s = + case filter (null . snd) $ readP_to_S (skipSpaces *> p) s of + [(a, _)] -> Success a + [] -> Invalid + as -> Ambiguous (fst <$> as) + +intP :: Parser Int +intP = token $ + -- we cannot use the standard Int ReadP parser because it recognizes + -- negative numbers, making -1 ambiguous + read <$> munch1 isDigit + +strP :: Parser String +strP = token $ readPrec_to_P readPrec minPrec + -- this deviates somewhat from the awk string literals, by design + +-- | An awk ERE token such as @/foo/@. No special characters are recognized +-- at the moment, except @\@ as an escape character for @/@ and itself. +patP :: Parser String +patP = token $ char '/' *> many ch <* char '/' + where + ch = + satisfy (`notElem` "/\\") <|> + (char '\\' *> satisfy (`elem` "/\\")) + +nfP :: Parser () +nfP = token $ void $ string "NF" + +-- | Built-in functions +builtin :: Parser Expr +builtin = msum + [ fn "length" $ LengthFn <$> optional expr + -- we don't support length without parentheses at all, + -- because that makes length($1) ambiguous + -- (we don't require spaces for concatenation) + , fn "toupper" $ ToUpperFn <$> expr + , fn "tolower" $ ToLowerFn <$> expr + , fn "match" $ MatchFn <$> expr <* sym ',' <*> patP + , fn "substr" $ SubstrFn <$> expr <* sym ',' <*> expr <*> + optional (sym ',' *> expr) + ] + where + fn :: String -> Parser a -> Parser a + fn name args = token (string name) *> sym '(' *> args <* sym ')' + +-- | Atomic expressions +expr0 :: Parser Expr +expr0 = + (sym '(' *> expr <* sym ')') <|> + (IntLit <$> intP) <|> + (StringLit <$> strP) <|> + (ERE <$> patP) <|> + (NF <$ nfP) <|> + builtin + +-- | Arguments to unary operators: atomic expressions and field +-- expressions +expr1 :: Parser Expr +expr1 = makeExprParser expr0 + [ [ Prefix (Field <$ sym '$') ] ] + +-- | Whether a parser is unary or non-unary. +-- +-- This roughly corresponds to the @unary_expr@ and @non_unary_expr@ +-- non-terminals in the awk grammar. +-- (Why roughly? See @expr2@.) +data Unary = Unary | NonUnary + +-- | Arithmetic expressions. +-- +-- Unlike awk, non-unary expressions disallow unary operators everywhere, +-- not just in the leading position, to avoid extra complexity in +-- @makeExprParser@. +-- +-- For example, the expression +-- +-- >1 3 + -4 +-- +-- is valid in awk because @3 + -4@ is non-unary, but we disallow it here +-- because @makeExprParser@ does not allow us to distinguish it from +-- +-- >1 -4 + 3 +-- +-- which is ambiguous. +expr2 :: Unary -> Parser Expr +expr2 unary = makeExprParser expr1 + [ [ Prefix (Not <$ sym '!') ] ++ + (case unary of + Unary -> [ Prefix (Neg <$ sym '-') ] + NonUnary -> [] + ) + , [ InfixL (Add <$ sym '+') + , InfixL (Sub <$ sym '-') + ] + ] + +-- | Expressions that may include string concatenation +expr3 :: Parser Expr +expr3 = concatExpr <|> expr2 Unary + where + -- The awk spec mandates that concatenation associates to the left. + -- But concatenation is associative, so why would we care. + concatExpr = Concat <$> nonUnary <*> (nonUnary <|> concatExpr) + nonUnary = expr2 NonUnary + +-- | Everything with lower precedence than concatenation +expr4 :: Parser Expr +expr4 = makeExprParser expr3 + [ [ InfixN (LT <$ sym '<') + , InfixN (GT <$ sym '>') + , InfixN (LE <$ str "<=") + , InfixN (GE <$ str ">=") + , InfixN (EQ <$ str "==") + , InfixN (NE <$ str "!=") + ] + , [ Postfix (flip Match <$ sym '~' <*> patP) + , Postfix (flip NoMatch <$ str "!~" <*> patP) + ] + , [ InfixL (And <$ str "&&") ] + , [ InfixL (Or <$ str "||") ] + , [ TernR ((If <$ sym ':') <$ sym '?') ] + ] + +-- | The awk-like expression parser. +-- +-- @since 1.0 +expr :: Parser Expr +expr = expr4 + +-- | Parse an awk expression. +-- +-- @since 1.1 +parseAwkExpr :: String -> Maybe Expr +parseAwkExpr s = + case runParser expr s of + Success e -> Just e + _ -> Nothing 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 new file mode 100644 --- /dev/null +++ b/Test/Tasty/Patterns/Types.hs @@ -0,0 +1,40 @@ +{-# 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 + | Add Expr Expr + | Sub Expr Expr + | Neg Expr + | Not Expr + | And Expr Expr + | LT Expr Expr + | GT Expr Expr + | LE Expr Expr + | GE Expr Expr + | EQ Expr Expr + | NE Expr Expr + | Or Expr Expr + | Concat Expr Expr + | Match Expr String + | NoMatch Expr String + | Field Expr -- ^ nth field of the path, where 1 is the outermost group name and 0 is the whole test name, using @.@ (dot) as a separator + | StringLit String + | If Expr Expr Expr + | ERE String -- ^ an ERE token by itself, like @/foo/@ but not like @$1 ~ /foo/@ + | ToUpperFn Expr + | ToLowerFn Expr + | LengthFn (Maybe Expr) + | MatchFn Expr String + | SubstrFn Expr Expr (Maybe Expr) + deriving + ( Show + , 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,25 +15,34 @@ 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 testPassed desc = Result { resultOutcome = Success , 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 - } +testFailedDetails desc printer = (testFailed desc) + { resultDetailsPrinter = printer } diff --git a/Test/Tasty/Providers/ConsoleFormat.hs b/Test/Tasty/Providers/ConsoleFormat.hs new file mode 100644 --- /dev/null +++ b/Test/Tasty/Providers/ConsoleFormat.hs @@ -0,0 +1,87 @@ +-- | This module can be used by providers to perform colorful/formatted +-- output and possibly reuse tasty's own output formats. +-- +-- @since 1.3.1 +module Test.Tasty.Providers.ConsoleFormat + ( ResultDetailsPrinter(..) + , ConsoleFormat(..) + , ConsoleFormatPrinter + , noResultDetails + , failFormat + , infoFailFormat + , infoOkFormat + , okFormat + , skippedFormat + ) +where + +import System.Console.ANSI + +-- | Console output format +-- +-- @since 1.3.1 +data ConsoleFormat = ConsoleFormat + { consoleIntensity :: ConsoleIntensity + , colorIntensity :: ColorIntensity + , color :: Color + } + +-- | Type of console format printer functions +-- +-- @since 1.3.1 +type ConsoleFormatPrinter + = ConsoleFormat -- ^ selected console format + -> IO () -- ^ action to be executed with active console format + -> IO () + +-- | Noop result details printer. The default for most providers. +-- +-- @since 1.3.1 +noResultDetails :: ResultDetailsPrinter +noResultDetails = ResultDetailsPrinter . const . const $ return () + +-- | An action that prints additional information about a test using +-- colors/formatting; see 'Test.Tasty.Providers.testFailedDetails' and +-- 'Test.Tasty.Runners.resultDetailsPrinter'. +-- +-- As input, this action is provided with the current indentation level and +-- a 'ConsoleFormatPrinter', which tells it how perform output. +-- +-- This is a newtype to allow a 'Show' instance. +-- +-- @since 1.3.1 +newtype ResultDetailsPrinter = ResultDetailsPrinter + (Int -> ConsoleFormatPrinter -> IO ()) + +instance Show ResultDetailsPrinter where + show _printer = "ResultDetailsPrinter" + +-- | Format used to display failures +-- +-- @since 1.3.1 +failFormat :: ConsoleFormat +failFormat = ConsoleFormat BoldIntensity Vivid Red + +-- | Format used to display additional information on failures +-- +-- @since 1.3.1 +infoFailFormat :: ConsoleFormat +infoFailFormat = ConsoleFormat NormalIntensity Dull Red + +-- | Format used to display successes +-- +-- @since 1.3.1 +okFormat :: ConsoleFormat +okFormat = ConsoleFormat NormalIntensity Dull Green + +-- | Format used to display additional information on successes +-- +-- @since 1.3.1 +infoOkFormat :: ConsoleFormat +infoOkFormat = ConsoleFormat NormalIntensity Dull White + +-- | Format used to display skipped tests +-- +-- @since 1.3.1 +skippedFormat :: ConsoleFormat +skippedFormat = ConsoleFormat NormalIntensity Dull Magenta diff --git a/Test/Tasty/Run.hs b/Test/Tasty/Run.hs --- a/Test/Tasty/Run.hs +++ b/Test/Tasty/Run.hs @@ -1,32 +1,58 @@ -- | Running tests -{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes, FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes, + 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 Control.Monad.State -import Control.Monad.Writer -import Control.Monad.Reader +import Data.List (intercalate) +import Data.Graph (SCC(..), stronglyConnComp) +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 import Control.Concurrent.Async import Control.Exception as E -import Control.Applicative import Control.Arrow +import Data.Monoid (First(..)) +import GHC.Conc (labelThread) +#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 +import Test.Tasty.Patterns.Types 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 @@ -34,11 +60,16 @@ -- ^ test is being run | Done Result -- ^ test finished with a given result + 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 @@ -46,6 +77,7 @@ | BeingCreated | FailedToCreate SomeException | Created r + | BeingDestroyed | Destroyed instance Show (Resource r) where @@ -54,10 +86,9 @@ BeingCreated -> "BeingCreated" FailedToCreate exn -> "FailedToCreate " ++ show exn Created {} -> "Created" + BeingDestroyed -> "BeingDestroyed" Destroyed -> "Destroyed" -data ResourceVar = forall r . ResourceVar (TVar (Resource r)) - data Initializer = forall res . Initializer (IO res) @@ -75,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. @@ -89,19 +121,33 @@ -- 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 -> - applyTimeout timeoutOpt $ wait asy + withAsync cursorMischiefManaged $ \asy -> do + labelThread (asyncThreadId asy) "tasty_test_execution_thread" + 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 r -> r + Right (t,r) -> r { resultTime = t } where initResources :: IO () @@ -124,8 +170,15 @@ BeingCreated -> retry Created {} -> return $ return () FailedToCreate exn -> return $ throwIO exn - _ -> return $ throwIO $ - unexpectedState "initResources" resStatus + -- If the resource is destroyed or being destroyed + -- while we're starting a test, the test suite is probably + -- shutting down. We are about to be killed. + -- (In fact we are probably killed already, so these cases are + -- unlikely to occur.) + -- In any case, the most sensible thing to do is to go to + -- sleep, awaiting our fate. + Destroyed -> return $ sleepIndefinitely + BeingDestroyed -> return $ sleepIndefinitely applyTimeout :: Timeout -> IO Result -> IO Result applyTimeout NoTimeout a = a @@ -136,8 +189,13 @@ { resultOutcome = Failure $ TestTimedOut t , resultDescription = "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: @@ -149,7 +207,7 @@ destroyResources restore = do -- remember the first exception that occurred liftM getFirst . execWriterT . getTraversal $ - flip F.foldMap fins $ \(Finalizer doRelease initVar finishVar) -> + flip F.foldMap fins $ \fin@(Finalizer _ _ finishVar) -> Traversal $ do iAmLast <- liftIO $ atomically $ do nUsers <- readTVar finishVar @@ -159,71 +217,321 @@ mbExcn <- liftIO $ if iAmLast - then join $ atomically $ do - resStatus <- readTVar initVar - case resStatus of - Created res -> do - -- Don't worry about double destroy — only one thread - -- receives iAmLast - return $ - (either Just (const Nothing) - <$> try (restore $ doRelease res)) - <* atomically (writeTVar initVar Destroyed) - FailedToCreate {} -> return $ return Nothing - _ -> return $ return $ Just $ - unexpectedState "destroyResources" resStatus + then destroyResource restore fin else return Nothing 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 () + 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 -type InitFinPair = (Seq.Seq Initializer, Seq.Seq Finalizer) +-- | Traversal type used in 'createTestActions' +type Tr = ReaderT (Path, Seq Dependency) IO (TestActionTree UnresolvedAction) +-- | Exceptions related to dependencies between tests. +-- +-- @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. Field lists detected cycles. + -- + -- @since 1.5 + +instance Show DependencyException where + 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 -createTestActions :: OptionSet -> TestTree -> IO ([(IO (), TVar Status)], [ResourceVar]) -createTestActions opts tree = do +-- 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 ([TestAction Action], Seq Finalizer) +createTestActions opts0 tree = do + -- 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 - traversal :: - Traversal (WriterT ([(InitFinPair -> IO (), TVar Status)], [ResourceVar]) IO) - traversal = - foldTestTree - trivialFold - { foldSingle = runSingleTest - , foldResource = addInitAndRelease - } - opts tree - (tests, rvars) <- unwrap traversal - let tests' = map (first ($ (Seq.empty, Seq.empty))) tests - return (tests', rvars) + 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 opts _ test = Traversal $ do - statusVar <- liftIO $ atomically $ newTVar NotStarted + -- * Functions used in 'TreeFold' + foldSingle :: IsTest t => OptionSet -> TestName -> t -> Tr + foldSingle opts name test = do + testStatus <- liftIO $ newTVarIO NotStarted + (parentPath, testDeps) <- ask let - act (inits, fins) = - executeTest (run opts test) statusVar (lookupOption opts) inits fins - tell ([(act, statusVar)], mempty) - addInitAndRelease (ResourceSpec doInit doRelease) a = wrap $ do - initVar <- atomically $ newTVar NotCreated - (tests, rvars) <- unwrap $ 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', ResourceVar initVar : rvars) - wrap = Traversal . WriterT . fmap ((,) ()) - unwrap = execWriterT . getTraversal + 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 + -> 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 '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 + deps' = concatMap findDeps testDeps + + getStatus :: STM ActionStatus + getStatus = foldr + (\(deptype, statusvar, _) k -> do + status <- readTVar statusvar + case status of + Done result + | deptype == AllFinish || resultSuccessful result -> k + | otherwise -> return ActionSkip + _ -> return ActionWait + ) + (return ActionReady) + deps' + let + dep_paths = map (\(_, _, path) -> path) deps' + action = Action + { actionStatus = getStatus + , actionRun = run_test + , actionSkip = writeTVar testStatus $ Done $ Result + -- See Note [Skipped tests] + { resultOutcome = Failure TestDepFailed + , resultDescription = "" + , resultShortDescription = "SKIP" + , resultTime = 0 + , resultDetailsPrinter = noResultDetails + } + } + 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 + + 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, v, vs) | (v, vs) <- snd <$> tests ] + sccs = stronglyConnComp graph + 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 = @@ -234,25 +542,114 @@ Destroyed -> throwSTM UseOutsideOfTest _ -> throwSTM $ unexpectedState "getResource" rState --- | Start running all the tests in a test tree in parallel. The number of --- threads is determined by the 'NumThreads' option. +-- | Run a resource finalizer. -- --- Return a map from the test number (starting from 0) to its status --- variable. +-- This function is called from two different places: +-- +-- 1. A test thread, which is the last one to use the resource. +-- 2. The main thread, if an exception (e.g. Ctrl-C) is received. +-- +-- Therefore, it is possible that this function is called multiple +-- times concurrently on the same finalizer. +-- +-- This function should be run with async exceptions masked, +-- and the restore function should be passed as an argument. +destroyResource :: (forall a . IO a -> IO a) -> Finalizer -> IO (Maybe SomeException) +destroyResource restore (Finalizer doRelease stateVar _) = join . atomically $ do + rState <- readTVar stateVar + case rState of + Created res -> do + writeTVar stateVar BeingDestroyed + return $ + (either Just (const Nothing) + <$> try (restore $ doRelease res)) + <* atomically (writeTVar stateVar Destroyed) + BeingCreated -> retry + -- If the resource is being destroyed, wait until it is destroyed. + -- This is so that we don't start destroying the next resource out of + -- order. + BeingDestroyed -> retry + NotCreated -> do + -- prevent the resource from being created by a competing thread + writeTVar stateVar Destroyed + return $ return Nothing + 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 t'NumThreads' +-- option. +-- +-- @since 0.10 launchTestTree :: OptionSet -> TestTree - -> (StatusMap -> IO a) + -> (StatusMap -> IO (Time -> IO a)) + -- ^ A callback. First, it receives the 'StatusMap' through which it + -- can observe the execution of tests in real time. Typically (but not + -- necessarily), it waits until all the tests are finished. + -- + -- After this callback returns, the test-running threads (if any) are + -- terminated and all resources acquired by tests are released. + -- + -- The callback must return another callback (of type @'Time' -> 'IO' + -- a@) which additionally can report and/or record the total time + -- taken by the test suite. This time includes the time taken to run + -- 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 k = do - (testActions, rvars) <- createTestActions opts tree - let NumThreads numTheads = lookupOption opts - abortTests <- runInParallel numTheads (fst <$> testActions) - (do let smap = IntMap.fromList $ zip [0..] (snd <$> testActions) - k smap) - `finally` do - abortTests - waitForResources rvars +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 numThreads = lookupOption opts + (t,k1) <- timed $ do + 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. + abortTests + -- Destroy all allocated resources in the case they didn't get + -- destroyed by their tests. (See #75.) + F.mapM_ (destroyResource restore) fins + -- Wait until all resources are destroyed. (Specifically, those + -- that were being destroyed by their tests, not those that were + -- destroyed by destroyResource above.) + restore $ waitForResources fins + k1 t where alive :: Resource r -> Bool alive r = case r of @@ -260,12 +657,31 @@ BeingCreated -> True FailedToCreate {} -> False Created {} -> True + BeingDestroyed -> True Destroyed -> False - waitForResources rvars = atomically $ - forM_ rvars $ \(ResourceVar rvar) -> do + waitForResources fins = atomically $ + F.forM_ fins $ \(Finalizer _ rvar _) -> do res <- readTVar rvar check $ not $ alive res unexpectedState :: String -> Resource r -> SomeException unexpectedState where_ r = toException $ UnexpectedState where_ (show r) + +sleepIndefinitely :: IO () +sleepIndefinitely = forever $ threadDelay (10^(7::Int)) + +-- | Like 'finally' (which also masks its finalizers), but pass the restore +-- action to the finalizer. +finallyRestore + :: IO a + -- ^ computation to run first + -> ((forall c . IO c -> IO c) -> IO b) + -- ^ computation to run afterward (even if an exception was raised) + -> IO a + -- ^ returns the value from the first computation +a `finallyRestore` sequel = + mask $ \restore -> do + r <- restore a `onException` sequel restore + _ <- sequel restore + return r 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 @@ -10,6 +12,7 @@ , module Test.Tasty.Runners.Reducers -- * Ingredients , Ingredient(..) + , Time , tryIngredients , ingredientOptions , ingredientsOptions @@ -25,6 +28,7 @@ , ListTests(..) , testsNames -- * Command line handling + , parseOptions , optionParser , suiteOptionParser , defaultMainWithIngredients @@ -35,14 +39,18 @@ , FailureReason(..) , resultSuccessful , Progress(..) + , emptyProgress , StatusMap , launchTestTree , NumThreads(..) + , DependencyException(..) -- * Options , suiteOptions , coreOptions -- ** Patterns , module Test.Tasty.Patterns + -- * Utilities + , module Test.Tasty.Runners.Utils ) where @@ -54,3 +62,4 @@ import Test.Tasty.CmdLine import Test.Tasty.Ingredients.Basic import Test.Tasty.Runners.Reducers +import Test.Tasty.Runners.Utils 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,18 +41,38 @@ module Test.Tasty.Runners.Reducers where -import Data.Monoid +import Prelude hiding (Applicative(..)) import Control.Applicative +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,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,11,0) + mappend = (Sem.<>) +#endif diff --git a/Test/Tasty/Runners/Utils.hs b/Test/Tasty/Runners/Utils.hs new file mode 100644 --- /dev/null +++ b/Test/Tasty/Runners/Utils.hs @@ -0,0 +1,130 @@ +{-# 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.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. . +-- +-- @since 0.10.1 +formatMessage :: String -> IO String +formatMessage = go 3 + where + -- to avoid infinite recursion, we introduce the recursion limit + go :: Int -> String -> IO String + go 0 _ = return "exceptions keep throwing other exceptions!" + go recLimit msg = do + mbStr <- try $ evaluate $ forceElements msg + case mbStr of + Right () -> return msg + Left e' -> printf "message threw an exception: %s" <$> go (recLimit-1) (show (e' :: SomeException)) + +-- | 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,68 +1,89 @@ --- Initial tasty.cabal generated by cabal init. For further documentation, --- see http://haskell.org/cabal/users-guide/ - +cabal-version: >=1.10 name: tasty -version: 0.8.1.3 +version: 1.5.4 synopsis: Modern and extensible testing framework description: Tasty is a modern testing framework for Haskell. It lets you combine your unit tests, golden tests, QuickCheck/SmallCheck properties, and any other types of tests into a single test suite. - See . license: MIT license-file: LICENSE author: Roman Cheplyaka maintainer: Roman Cheplyaka -homepage: http://documentup.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 -cabal-version: >=1.10 +extra-source-files: CHANGELOG.md, README.md Source-repository head type: git - location: git://github.com/feuerbach/tasty.git + location: https://github.com/UnkindPartition/tasty.git subdir: core +flag unix + description: + 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 - other-modules: - Test.Tasty.Parallel, - Test.Tasty.Core, - Test.Tasty.Options.Core, - Test.Tasty.Options.Env, - Test.Tasty.Patterns, - Test.Tasty.Run, - Test.Tasty.Runners.Reducers, - Test.Tasty.CmdLine, 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: + 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, - tagged >= 0.5, - regex-tdfa-rc >= 1.1.8.2, - optparse-applicative >= 0.6, - deepseq >= 1.3, - unbounded-delays >= 0.1, - async >= 2.0, - ansi-terminal >= 0.6.1 + 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 impl(ghc < 7.6) - -- for GHC.Generics - build-depends: ghc-prim + -- 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 - -- hs-source-dirs: + if(!impl(ghc >= 8.4)) + build-depends: time >= 1.4 && < 1.13 + + if !os(windows) && !impl(ghcjs) + cpp-options: -DUSE_WCWIDTH + if flag(unix) + build-depends: unix < 2.9 + + -- hs-source-dirs: default-language: Haskell2010 - ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing + default-extensions: CPP, ScopedTypeVariables + ghc-options: + -Wall + -Wno-incomplete-uni-patterns + -Wcompat