packages feed

tasty 0.7 → 1.5.4

raw patch · 29 files changed

Files

+ CHANGELOG.md view
@@ -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 <https://github.com/UnkindPartition/tasty/issues/220> for the discussion.++* The field separator in patterns is changed from slash (`/`) to period (`.`),+  and `.` is now allowed in raw patterns.++  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+<https://github.com/UnkindPartition/tasty/issues/71>++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
+ Control/Concurrent/Async.hs view
@@ -0,0 +1,293 @@+-- | Operations for running IO operations asynchronously.++-- These are the same as in the 'async' package. We do not use+-- 'async' to avoid its dependencies.++{- License for the 'async' package+Copyright (c) 2012, Simon Marlow++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Simon Marlow nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+-}++{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}++module Control.Concurrent.Async (+  async, withAsync, wait, asyncThreadId, cancel, concurrently+  ) where++import Control.Concurrent.STM+import Control.Exception+  ( BlockedIndefinitelyOnMVar(..)+  , BlockedIndefinitelyOnSTM(..)+  , Exception+  , SomeException+  , asyncExceptionFromException+  , asyncExceptionToException+  , catch+  , fromException+  , onException+  , toException+  , try+  )+import Control.Concurrent+import Control.Monad+import Data.IORef+import GHC.Conc (ThreadId(..))+import GHC.Exts+import GHC.IO hiding (onException)++#if MIN_VERSION_base(4,21,0)+import Control.Exception (ExceptionWithContext, tryWithContext, catchNoPropagate, rethrowIO)+#else+type ExceptionWithContext x = x++catchNoPropagate :: IO a -> (ExceptionWithContext SomeException -> IO a) -> IO a+catchNoPropagate = catchAll++tryWithContext :: IO a -> IO (Either (ExceptionWithContext SomeException) a)+tryWithContext = try++rethrowIO :: ExceptionWithContext SomeException -> IO a+rethrowIO = throwIO+#endif++-- | An asynchronous action spawned by 'async' or 'withAsync'.+-- Asynchronous actions are executed in a separate thread, and+-- operations are provided for waiting for asynchronous actions to+-- complete and obtaining their results (see e.g. 'wait').+--+data Async a = Async+  { asyncThreadId :: {-# UNPACK #-} !ThreadId+                  -- ^ Returns the t'ThreadId' of the thread running+                  -- the given t'Async'.+  , _asyncWait    :: STM (Either (ExceptionWithContext SomeException) a)+  }++-- | Spawn an asynchronous action in a separate thread.+async :: IO a -> IO (Async a)+async = inline asyncUsing rawForkIO++asyncUsing :: (IO () -> IO ThreadId)+           -> IO a -> IO (Async a)+asyncUsing doFork = \action -> do+   var <- newEmptyTMVarIO+   -- t <- forkFinally action (\r -> atomically $ putTMVar var r)+   -- slightly faster:+   t <- mask $ \restore ->+          doFork $ try (restore action) >>= atomically . putTMVar var+   return (Async t (readTMVar var))++-- | Spawn an asynchronous action in a separate thread, and pass its+-- @Async@ handle to the supplied function.  When the function returns+-- or throws an exception, 'uninterruptibleCancel' is called on the @Async@.+--+-- > withAsync action inner = mask $ \restore -> do+-- >   a <- async (restore action)+-- >   restore (inner a) `finally` uninterruptibleCancel a+--+-- This is a useful variant of 'async' that ensures an @Async@ is+-- never left running unintentionally.+--+-- Note: a reference to the child thread is kept alive until the call+-- to `withAsync` returns, so nesting many `withAsync` calls requires+-- linear memory.+--+withAsync :: IO a -> (Async a -> IO b) -> IO b+withAsync = inline withAsyncUsing rawForkIO++withAsyncUsing :: (IO () -> IO ThreadId)+               -> IO a -> (Async a -> IO b) -> IO b+-- The bracket version works, but is slow.  We can do better by+-- hand-coding it:+withAsyncUsing doFork = \action inner -> do+  var <- newEmptyTMVarIO+  mask $ \restore -> do+    t <- doFork $ tryWithContext (restore action) >>= atomically . putTMVar var+    let a = Async t (readTMVar var)+    r <- restore (inner a) `catchNoPropagate` \e -> do+      uninterruptibleCancel a+      rethrowIO (e :: ExceptionWithContext SomeException)+    uninterruptibleCancel a+    return r++-- | Wait for an asynchronous action to complete, and return its+-- value.  If the asynchronous action threw an exception, then the+-- exception is re-thrown by 'wait'.+--+-- > wait = atomically . waitSTM+--+{-# INLINE wait #-}+wait :: Async a -> IO a+wait = tryAgain . atomically . waitSTM+  where+    -- See: https://github.com/simonmar/async/issues/14+    tryAgain f = f `Control.Exception.catch` \BlockedIndefinitelyOnSTM -> f++-- | Wait for an asynchronous action to complete, and return either+-- @Left e@ if the action raised an exception @e@, or @Right a@ if it+-- returned a value @a@.+--+-- > waitCatch = atomically . waitCatchSTM+--+{-# INLINE waitCatch #-}+waitCatch :: Async a -> IO (Either (ExceptionWithContext SomeException) a)+waitCatch = tryAgain . atomically . waitCatchSTM+  where+    -- See: https://github.com/simonmar/async/issues/14+    tryAgain f = f `Control.Exception.catch` \BlockedIndefinitelyOnSTM -> f++-- | A version of 'wait' that can be used inside an STM transaction.+--+waitSTM :: Async a -> STM a+waitSTM a = do+   r <- waitCatchSTM a+   either throwSTM return r++-- | A version of 'waitCatch' that can be used inside an STM transaction.+--+{-# INLINE waitCatchSTM #-}+waitCatchSTM :: Async a -> STM (Either (ExceptionWithContext SomeException) a)+waitCatchSTM (Async _ w) = w++-- | Cancel an asynchronous action by throwing the @AsyncCancelled@+-- exception to it, and waiting for the t'Async' thread to quit.+-- Has no effect if the t'Async' has already completed.+--+-- > cancel a = throwTo (asyncThreadId a) AsyncCancelled <* waitCatch a+--+-- Note that 'cancel' will not terminate until the thread the t'Async'+-- refers to has terminated. This means that 'cancel' will block for+-- as long said thread blocks when receiving an asynchronous exception.+--+-- For example, it could block if:+--+-- * It's executing a foreign call, and thus cannot receive the asynchronous+-- exception;+-- * It's executing some cleanup handler after having received the exception,+-- and the handler is blocking.+{-# INLINE cancel #-}+cancel :: Async a -> IO ()+cancel a@(Async t _) = throwTo t AsyncCancelled >> void (waitCatch a)++-- | The exception thrown by `cancel` to terminate a thread.+data AsyncCancelled = AsyncCancelled+  deriving (Show, Eq)++instance Exception AsyncCancelled where+  fromException = asyncExceptionFromException+  toException = asyncExceptionToException++-- | Cancel an asynchronous action+--+-- This is a variant of `cancel`, but it is not interruptible.+{-# INLINE uninterruptibleCancel #-}+uninterruptibleCancel :: Async a -> IO ()+uninterruptibleCancel = uninterruptibleMask_ . cancel++-- | Run two @IO@ actions concurrently, and return both results.  If+-- either action throws an exception at any time, then the other+-- action is 'cancel'led, and the exception is re-thrown by+-- 'concurrently'.+--+-- > concurrently left right =+-- >   withAsync left $ \a ->+-- >   withAsync right $ \b ->+-- >   waitBoth a b+concurrently :: IO a -> IO b -> IO (a,b)+concurrently left right = concurrently' left right (collect [])+  where+    collect [Left a, Right b] _ = return (a,b)+    collect [Right b, Left a] _ = return (a,b)+    collect xs m = do+        e <- m+        case e of+            Left ex -> throwIO ex+            Right r -> collect (r:xs) m++concurrently' :: IO a -> IO b+             -> (IO (Either SomeException (Either a b)) -> IO r)+             -> IO r+concurrently' left right collect = do+    done <- newEmptyMVar+    mask $ \restore -> do+        -- Note: uninterruptibleMask here is because we must not allow+        -- the putMVar in the exception handler to be interrupted,+        -- otherwise the parent thread will deadlock when it waits for+        -- the thread to terminate.+        lid <- forkIO $ uninterruptibleMask_ $+          restore (left >>= putMVar done . Right . Left)+            `catchAll` (putMVar done . Left)+        rid <- forkIO $ uninterruptibleMask_ $+          restore (right >>= putMVar done . Right . Right)+            `catchAll` (putMVar done . Left)++        count <- newIORef (2 :: Int)+        let takeDone = do+                r <- takeMVar done      -- interruptible+                -- Decrement the counter so we know how many takes are left.+                -- Since only the parent thread is calling this, we can+                -- use non-atomic modifications.+                -- NB. do this *after* takeMVar, because takeMVar might be+                -- interrupted.+                modifyIORef count (subtract 1)+                return r++        let tryAgain f = f `Control.Exception.catch` \BlockedIndefinitelyOnMVar -> f++            stop = do+                -- kill right before left, to match the semantics of+                -- the version using withAsync. (#27)+                uninterruptibleMask_ $ do+                  count' <- readIORef count+                  -- we only need to use killThread if there are still+                  -- children alive.  Note: forkIO here is because the+                  -- child thread could be in an uninterruptible+                  -- putMVar.+                  when (count' > 0) $+                    void $ forkIO $ do+                      throwTo rid AsyncCancelled+                      throwTo lid AsyncCancelled+                  -- ensure the children are really dead+                  replicateM_ count' (tryAgain $ takeMVar done)++        r <- collect (tryAgain $ takeDone) `onException` stop+        stop+        return r++catchAll :: IO a -> (SomeException -> IO a) -> IO a+catchAll = Control.Exception.catch++-- A version of forkIO that does not include the outer exception+-- handler: saves a bit of time when we will be installing our own+-- exception handler.+{-# INLINE rawForkIO #-}+rawForkIO :: IO () -> IO ThreadId+rawForkIO action = IO $ \ s ->+   case (fork# (unIO action) s) of (# s1, tid #) -> (# s1, ThreadId tid #)
+ README.md view
@@ -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`:++<a id="num_threads_example">++```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):++<center>+<table>+<tr>+<th>+<p><b>Syntax</b></p>+</th>+<th>+<p><b>Name</b></p>+</th>+<th>+<p><b>Type of Result</b></p>+</th>+<th>+<p><b>Associativity</b></p>+</th>+</tr>++<tr>+<td>+<p><code>(expr)</code></p>+</td>+<td>+<p>Grouping</p>+</td>+<td>+<p>Type of <code>expr</code></p>+</td>+<td>+<p>N/A</p>+</td>+</tr>++<tr>+<td>+<p><code>$expr</code></p>+</td>+<td>+<p>Field reference</p>+</td>+<td>+<p>String</p>+</td>+<td>+<p>N/A</p>+</td>+</tr>++<tr>+<td>+<p><code>!expr</code></p>+<p><code>-expr</code></p>+</td>+<td>+<p>Logical not</p>+<p>Unary minus</p>+</td>+<td>+<p>Numeric</p>+<p>Numeric</p>+</td>+<td>+<p>N/A</p>+<p>N/A</p>+</td>+</tr>++<tr>+<td>+<p><code>expr + expr</code></p>+<p><code>expr - expr</code></p>+</td>+<td>+<p>Addition</p>+<p>Subtraction</p>+</td>+<td>+<p>Numeric</p>+<p>Numeric</p>+</td>+<td>+<p>Left</p>+<p>Left</p>+</td>+</tr>+++<tr>+<td>+<p><code>expr expr</code></p>+</td>+<td>+<p>String concatenation</p>+</td>+<td>+<p>String</p>+</td>+<td>+<p>Right</p>+</td>+</tr>++<tr>+<td>+<p><code>expr &lt; expr</code></p>+<p><code>expr &lt;= expr</code></p>+<p><code>expr != expr</code></p>+<p><code>expr == expr</code></p>+<p><code>expr &gt; expr</code></p>+<p><code>expr &gt;= expr</code></p>+</td>+<td>+<p>Less than</p>+<p>Less than or equal to</p>+<p>Not equal to</p>+<p>Equal to</p>+<p>Greater than</p>+<p>Greater than or equal to</p>+</td>+<td>+<p>Numeric</p>+<p>Numeric</p>+<p>Numeric</p>+<p>Numeric</p>+<p>Numeric</p>+<p>Numeric</p>+</td>+<td>+<p>None</p>+<p>None</p>+<p>None</p>+<p>None</p>+<p>None</p>+<p>None</p>+</td>+</tr>+++<tr>+<td>+<p><code>expr ~ pat</code></p>+<p><code>expr !~ pat</code></p>+<p>(<code>pat</code> must be a literal, not an expression, e.g. <code>/foo/</code>)</p>+</td>+<td>+<p>Substring match</p>+<p>No substring match</p>+</td>+<td>+<p>Numeric</p>+<p>Numeric</p>+</td>+<td>+<p>None</p>+<p>None</p>+</td>+</tr>++<tr>+<td>+<p><code>expr &amp;&amp; expr</code></p>+</td>+<td>+<p>Logical AND</p>+</td>+<td>+<p>Numeric</p>+</td>+<td>+<p>Left</p>+</td>+</tr>++<tr>+<td>+<p><code>expr || expr</code></p>+</td>+<td>+<p>Logical OR</p>+</td>+<td>+<p>Numeric</p>+</td>+<td>+<p>Left</p>+</td>+</tr>++<tr>+<td>+<p><code>expr1 ? expr2 : expr3</code></p>+</td>+<td>+<p>Conditional expression</p>+</td>+<td>+<p>Type of selected<br><code>expr2</code> or <code>expr3</code></p>+</td>+<td>+<p>Right</p>+</td>+</tr>++</table>+</center>++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:++<dl>+<dt><code>-q,--quiet</code></dt>+<dd>+  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.+</dd>+<dt><code>--hide-successes</code></dt>+<dd>Report only the tests that has failed. Especially useful when the+number of tests is large.</dd>+<dt><code>-l,--list-tests</code></dt>+<dd>Don't run the tests; only list their names, in the format accepted by+<code>--pattern</code>.</dd>+<dt><code>--color</code></dt>+<dd>Whether to produce colorful output. Accepted values: <code>never</code>,+<code>always</code>, <code>auto</code>. <code>auto</code> means that colors will+only be enabled when output goes to a terminal and is the default value.</dd>+</dl>++### 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.
Test/Tasty.hs view
@@ -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+-- <https://hackage.haskell.org/package/tasty-hunit tasty-hunit> or+-- <https://hackage.haskell.org/package/tasty-quickcheck tasty-quickcheck>.+--+-- 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 <https://github.com/UnkindPartition/tasty#readme README>:+-- it contains a comprehensive list of test providers, a bigger example,+-- and a lot of other information.+--+-- @since 0.1+ module Test.Tasty   (   -- * Organizing tests     TestName   , TestTree   , testGroup+  , dependentTestGroup+  , sequentialTestGroup+  , inOrderTestGroup   -- * Running tests   , defaultMain   , defaultMainWithIngredients@@ -15,47 +45,92 @@   -- | Normally options are specified on the command line. But you can   -- also have different options for different subtrees in the same tree,   -- using the functions below.+  --+  -- Note that /ingredient options/ (number of threads, hide successes+  -- etc.) set in this way will not have any effect. This is for modifying+  -- per-test options, such as timeout, number of generated tests etc.   , adjustOption   , localOption   , askOption+  -- ** Standard options+  , Timeout(..)+  , mkTimeout   -- * Resources   -- | Sometimes several tests need to access the same resource — say,   -- 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  import Test.Tasty.Core import Test.Tasty.Runners import Test.Tasty.Options-import Test.Tasty.Ingredients.IncludingOptions+import Test.Tasty.Options.Core+import Test.Tasty.Ingredients.Basic  -- | 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
Test/Tasty/CmdLine.hs view
@@ -1,59 +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.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.CoreOptions+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 = foldr addOption (pure mempty) where-  addOption :: OptionDescription -> Parser OptionSet -> Parser OptionSet-  addOption (Option (Proxy :: Proxy v)) p =-    setOption <$> (optionCLParser :: Parser v) <*> p+-- | 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) --- suiteOptions doesn't really belong here (since it's not CmdLine--- specific), but I didn't want to create a new module just for it.+-- 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) --- | All the options relevant for this test suite. This includes the--- options for the test tree and ingredients, and the core options.-suiteOptions :: [Ingredient] -> TestTree -> [OptionDescription]-suiteOptions ins tree =-  coreOptions ++-  ingredientsOptions ins ++-  treeOptions tree+    warnings :: [String]+    warnings = catMaybes [multipleOptPsWarning, badDefaultWarning] --- | The command line parser for the test suite-suiteOptionParser :: [Ingredient] -> TestTree -> Parser OptionSet+    -- 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-  opts <- execParser $-    info (helper <*> suiteOptionParser ins testTree)-    ( fullDesc <>-      header "Mmm... tasty test suite"-    )+  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
Test/Tasty/Core.hs view
@@ -1,25 +1,110 @@ -- | Core types and definitions-{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts,-             ExistentialQuantification, RankNTypes, DeriveDataTypeable #-}-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.Applicative 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) --- | A test result+#if MIN_VERSION_base(4,21,0) && !MIN_VERSION_base(4,22,0)+import Control.Exception.Context+#endif++-- | If a test failed, 'FailureReason' describes why.+--+-- @since 0.8+data FailureReason+  = TestFailed+    -- ^ test provider indicated failure of the code to test, either because+    -- the tested code returned wrong results, or raised an exception+  | TestThrewException SomeException+    -- ^ 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)++-- | 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-  { resultSuccessful :: Bool-    -- ^-    -- 'resultSuccessful' should be 'True' for a passed test and 'False' for-    -- a failed one.+  { resultOutcome :: Outcome+    -- ^ Did the test fail? If so, why?   , resultDescription :: String     -- ^     -- 'resultDescription' may contain some details about the test. For@@ -29,12 +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 t'Result' that indicates exception+exceptionResult :: SomeException -> Result+exceptionResult e = Result+  { resultOutcome = Failure $ TestThrewException 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@@ -43,43 +206,142 @@     -- '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 data ResourceError   = NotRunningTests-  | UnexpectedState String-  deriving Typeable+  | UnexpectedState String String+  | UseOutsideOfTest  instance Show ResourceError where   show NotRunningTests =     "Unhandled resource. Probably a bug in the runner you're using."-  show (UnexpectedState state) =-    printf "Unexpected state of the resource (%s). Report as a tasty bug."-      state+  show (UnexpectedState where_ what) =+    printf "Unexpected state of the resource (%s) in %s. Report as a tasty bug."+      what where_+  show UseOutsideOfTest =+    "It looks like you're attempting to use a resource outside of its test. Don't do that!"  instance Exception ResourceError +-- | These are the two ways in which one test may depend on the others.+--+-- This is the same distinction as the+-- <http://testng.org/doc/documentation-main.html#dependent-methods hard vs soft dependencies in TestNG>.+--+-- @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@@ -90,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@@ -102,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@@ -131,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@@ -153,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@@ -165,27 +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) --- | Useful wrapper for use with foldTestTree-newtype AppMonoid f = AppMonoid { getApp :: f () }-instance Applicative f => Monoid (AppMonoid f) where-  mempty = AppMonoid $ pure ()-  AppMonoid f1 `mappend` AppMonoid f2 = AppMonoid $ f1 *> f2+-- | 'TestTree' with arbitrary annotations, e. g., evaluated t'OptionSet'.+data AnnTestTree ann+  = AnnEmptyTestTree+  -- ^ Just an empty test tree (e. g., when everything has been filtered out).+  | forall t . IsTest t => AnnSingleTest ann TestName t+  -- ^ Annotated counterpart of 'SingleTest'.+  | AnnTestGroup ann TestName [AnnTestTree ann]+  -- ^ Annotated counterpart of 'TestGroup'.+  | forall a . AnnWithResource ann (ResourceSpec a) (IO a -> AnnTestTree ann)+  -- ^ Annotated counterpart of 'WithResource'.+  | AnnAfter ann DependencyType Expr (AnnTestTree ann)+  -- ^ Annotated counterpart of 'After'.++-- | Annotate 'TestTree' with options, removing 'PlusTestOptions' and 'AskOptions' nodes.+evaluateOptions :: OptionSet -> TestTree -> AnnTestTree OptionSet+evaluateOptions opts = \case+  SingleTest name test ->+    AnnSingleTest opts name test+  TestGroup name trees ->+    AnnTestGroup opts name $ map (evaluateOptions opts) trees+  PlusTestOptions f tree ->+    evaluateOptions (f opts) tree+  WithResource res0 tree ->+    AnnWithResource opts res0 $ \res -> evaluateOptions opts (tree res)+  AskOptions f ->+    evaluateOptions opts (f opts)+  After deptype dep tree ->+    AnnAfter opts deptype dep $ evaluateOptions opts tree++-- | Annotate 'AnnTestTree' with paths.+annotatePath :: AnnTestTree OptionSet -> AnnTestTree (OptionSet, Path)+annotatePath = go mempty+  where+    go :: Seq.Seq TestName -> AnnTestTree OptionSet -> AnnTestTree (OptionSet, Path)+    go path = \case+      AnnEmptyTestTree -> AnnEmptyTestTree+      AnnSingleTest opts name tree ->+        AnnSingleTest (opts, path |> name) name tree+      AnnTestGroup opts name trees ->+        let newPath = path |> name in+        AnnTestGroup (opts, newPath) name (map (go newPath) trees)+      AnnWithResource opts res0 tree ->+        AnnWithResource (opts, path) res0 $ \res -> go path (tree res)+      AnnAfter opts deptype dep tree ->+        AnnAfter (opts, path) deptype dep (go path tree)++-- | Filter test tree by pattern, replacing leafs with 'AnnEmptyTestTree'.+filterByPattern :: AnnTestTree (OptionSet, Path) -> AnnTestTree OptionSet+filterByPattern = snd . go (Any False)+  where+    mkGroup opts name xs = case filter isNonEmpty xs of+      [] -> AnnEmptyTestTree+      ys -> AnnTestGroup opts name ys++    isNonEmpty = \case+      AnnEmptyTestTree -> False+      _                -> True++    go+      :: ForceTestMatch+      -> AnnTestTree (OptionSet, Path)+      -> (TestMatched, AnnTestTree OptionSet)+    go forceMatch = \case+      AnnEmptyTestTree ->+        (Any False, AnnEmptyTestTree)++      AnnSingleTest (opts, path) name tree+        | getAny forceMatch || testPatternMatches (lookupOption opts) path+        -> (Any True, AnnSingleTest opts name tree)+        | otherwise+        -> (Any False, AnnEmptyTestTree)++      AnnTestGroup _ _ [] ->+        (forceMatch, AnnEmptyTestTree)++      AnnTestGroup (opts, _) name trees ->+        case lookupOption opts of+          Dependent _ ->+            second+              (mkGroup opts name)+              (mapAccumR go forceMatch trees)+          Independent _ ->+            bimap+              mconcat+              (mkGroup opts name)+              (unzip (map (go forceMatch) trees))++      AnnWithResource (opts, _) res0 tree ->+        ( fst (go forceMatch (tree (throwIO NotRunningTests)))+        , AnnWithResource opts res0 $ \res -> snd (go forceMatch (tree res))+        )++      AnnAfter (opts, _) deptype dep tree ->+        second+          (AnnAfter opts deptype dep)+          (go forceMatch tree)  -- | Get the list of options that are relevant for a given test tree treeOptions :: TestTree -> [OptionDescription]
− Test/Tasty/CoreOptions.hs 
@@ -1,35 +0,0 @@--- | Core options, i.e. the options used by tasty itself-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}-module Test.Tasty.CoreOptions-  ( NumThreads(..)-  , coreOptions-  )-  where--import Data.Typeable-import Data.Proxy--import Test.Tasty.Options-import Test.Tasty.Patterns---- | Number of parallel threads to use for running tests.------ 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--- reporters are handled already involves parallelism. Other ingredients--- may also choose to include this option.-newtype NumThreads = NumThreads { getNumThreads :: Int }-  deriving (Eq, Ord, Num, Typeable)-instance IsOption NumThreads where-  defaultValue = 1-  parseValue = fmap NumThreads . safeRead-  optionName = return "num-threads"-  optionHelp = return "Number of threads to use for tests execution"---- | The list of all core options, i.e. the options not specific to any--- provider or ingredient, but to tasty itself. Currently only contains 'TestPattern'.-coreOptions :: [OptionDescription]-coreOptions =-  [ Option (Proxy :: Proxy TestPattern)-  ]
Test/Tasty/Ingredients.hs view
@@ -1,8 +1,16 @@+-- | This module contains the core definitions related to ingredients.+--+-- 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@@ -12,7 +20,8 @@ import Test.Tasty.Core import Test.Tasty.Run import Test.Tasty.Options-import Test.Tasty.CoreOptions+import Test.Tasty.Options.Core+import Control.Concurrent.Async (concurrently)  -- | 'Ingredient's make your test suite tasty. --@@ -27,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.@@ -40,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. --@@ -56,25 +70,34 @@ -- 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-  return $ reportFn =<< launchTestTree opts testTree+  return $ launchTestTree opts testTree $ \smap -> reportFn smap tryIngredient (TestManager _ manage) opts testTree =   manage opts testTree @@ -82,20 +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 = 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"
+ Test/Tasty/Ingredients/Basic.hs view
@@ -0,0 +1,26 @@+-- | This module exports the basic ingredients defined in the @tasty@+-- packages.+--+-- 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(..)+  , testsNames+    -- ** Adding options+  , includingOptions+  )+  where++import Test.Tasty.Ingredients.ConsoleReporter+import Test.Tasty.Ingredients.ListTests+import Test.Tasty.Ingredients.IncludingOptions
Test/Tasty/Ingredients/ConsoleReporter.hs view
@@ -1,38 +1,766 @@-{-# LANGUAGE TupleSections, CPP, ImplicitParams #-}--- | Console reporter ingredient-module Test.Tasty.Ingredients.ConsoleReporter (consoleTestReporter) where+-- 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. -import Prelude hiding (fail)-import Control.Monad.State hiding (fail)+  -- ** Output colouring+  , UseColor(..)+  , useColor+  -- ** Test failure statistics+  , Statistics(..)+  , computeStatistics+  , printStatistics+  , printStatisticsNoTime+  -- ** Outputting results+  , TestOutput(..)+  , buildTestOutput+  , foldTestOutput+  , withConsoleFormat+  ) where++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.Monoid (Any(..))+import qualified Data.Semigroup as Sem+import Data.Typeable+import Options.Applicative hiding (action, str, Success, Failure) import System.IO--#ifdef COLORS import System.Console.ANSI+#if !MIN_VERSION_base(4,11,0)+import Data.Foldable (foldMap) #endif+import System.IO.Unsafe -data RunnerState = RunnerState-  { ix :: !Int-  , nestedLevel :: !Int-  , failures :: !Int+--------------------------------------------------+-- TestOutput base definitions+--------------------------------------------------+-- {{{+-- | '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+  = -- | 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.+--+-- @since 0.12.0.1+instance Sem.Semigroup TestOutput where+  (<>) = Seq+instance Monoid TestOutput where+  mempty = Skip+#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++-- 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+    !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+    runSingleTest _opts name _test = Ap $ do+      level <- ask++      let+        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++          -- 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 name printTestName printTestProgress printTestResult++    runGroup :: OptionSet -> TestName -> [Ap (Reader Level) TestOutput] -> Ap (Reader Level) TestOutput+    runGroup _opts name grp = Ap $ do+      level <- ask+      let+        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 $+      foldTestTree+        trivialFold+          { foldSingle = runSingleTest+          , 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+  :: 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 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++    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++-- }}}++--------------------------------------------------+-- TestOutput modes+--------------------------------------------------++ppProgressOrResult :: TVar Status -> (Progress -> IO ()) -> IO Result+ppProgressOrResult statusVar ppProgress = go emptyProgress where+  go old_p = either (\p -> ppProgress p *> go p) return =<< (atomically $ do+    status <- readTVar statusVar+    case status of+      Executing p+        | p == old_p -> retry+        | otherwise -> pure $ Left p+      Done r      -> pure $ Right r+      _           -> retry+    )++-- {{{+consoleOutput :: (?colors :: Bool) => TestOutput -> StatusMap -> IO ()+consoleOutput toutput smap =+  getTraversal . fst $ foldTestOutput foldTest foldHeading toutput smap+  where+    foldTest _name printName getResult printResult =+      ( Traversal $ do+          printName :: IO ()+          r <- getResult+          printResult r+      , Any True)+    foldHeading _name printHeading (printBody, Any nonempty) =+      ( Traversal $ do+          when nonempty $ do+            printHeading :: IO ()+            getTraversal printBody+      , Any nonempty+      )++consoleOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> IO ()+consoleOutputHidingSuccesses toutput smap =+  void . getApp $ foldTestOutput foldTest foldHeading toutput smap+  where+    foldTest _name printName getResult printResult =+      Ap $ do+          printName :: IO ()+          r <- getResult+          if resultSuccessful r+            then do clearThisLine; return $ Any False+            else do printResult r :: IO (); return $ Any True++    foldHeading _name printHeading printBody =+      Ap $ do+        printHeading :: IO ()+        Any failed <- getApp printBody+        unless failed clearAboveLine+        return $ Any failed++    clearAboveLine = do cursorUpLine 1; clearThisLine+    clearThisLine = do clearLine; setCursorColumn 0++streamOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> IO ()+streamOutputHidingSuccesses toutput smap =+  void . flip evalStateT [] . getApp $+    foldTestOutput foldTest foldHeading toutput smap+  where+    foldTest _name printName getResult printResult =+      Ap $ do+          r <- liftIO $ getResult+          if resultSuccessful r+            then return $ Any False+            else do+              stack <- get+              put []++              liftIO $ do+                sequence_ $ reverse stack+                printName :: IO ()+                printResult r :: IO ()++              return $ Any True++    foldHeading _name printHeading printBody =+      Ap $ do+        modify (printHeading :)+        Any failed <- getApp printBody+        unless failed $+          modify $ \stack ->+            case stack of+              _:rest -> rest+              [] -> [] -- shouldn't happen anyway+        return $ Any failed++-- }}}++--------------------------------------------------+-- Statistics+--------------------------------------------------+-- {{{++-- | 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 -- ^ 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.   } -initialState :: RunnerState-initialState = RunnerState 0 0 0+-- | @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+  mempty = Statistics 0 0+#if !MIN_VERSION_base(4,11,0)+  mappend = (Sem.<>)+#endif -type M = StateT RunnerState IO+-- | @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) +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 -> ok $ printf " (%.2fs)\n" time+    _ -> fail $ printf " (%.2fs)\n" time++-- | @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"++-- | 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)++    -- 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)++    finish :: IntSet.IntSet -> Int -> STM (IO Bool)+    finish ok_tests _ = next_iter ok_tests++-- }}}++--------------------------------------------------+-- Console test reporter+--------------------------------------------------+-- {{{++-- | A simple console UI.+--+-- @since 0.4+consoleTestReporter :: Ingredient+consoleTestReporter = TestReporter consoleTestReporterOptions $ \opts tree ->+  let+    TestPattern pattern = lookupOption opts+    tests = testsNames opts tree+    hook = (return .) . appendPatternIfTestFailed tests pattern+    TestReporter _ cb = consoleTestReporterWithHook hook+  in cb opts tree++appendPatternIfTestFailed+  :: [TestName] -- ^ list of (pre-intercalated) test names+  -> Maybe Expr -- ^ current pattern, if any+  -> [TestName] -- ^ name of current test, represented as a list of group names+  -> Result     -- ^ vanilla result+  -> Result+appendPatternIfTestFailed [_] _ _ res = res -- if there is only one test, nothing to refine+appendPatternIfTestFailed _ _ [] res  = res -- should be impossible+appendPatternIfTestFailed tests currentPattern (name : names) res = case resultOutcome res of+  Success -> res+  Failure{} -> res { resultDescription = resultDescription res ++ msg }+  where+    msg = "\nUse -p '" ++ escapeQuotes (printAwkExpr pattern) ++ "' to rerun this test only."++    escapeQuotes = concatMap $ \c -> if c == '\'' then "'\\''" else [c]++    findPattern [_] pat _ = ERE pat+    findPattern _  pat [] = EQ (Field (IntLit 0)) (StringLit pat)+    findPattern ts pat (n : ns) = let pat' = n ++ '.' : pat in+      findPattern (filter (pat' `isInfixOf`) ts) pat' ns++    individualPattern = findPattern (filter (name `isInfixOf`) tests) name names++    pattern = maybe id And currentPattern individualPattern++consoleTestReporterOptions :: [OptionDescription]+consoleTestReporterOptions =+  [ Option (Proxy :: Proxy Quiet)+  , Option (Proxy :: Proxy HideSuccesses)+  , Option (Proxy :: Proxy MinDurationToReport)+  , Option (Proxy :: Proxy UseColor)+  , Option (Proxy :: Proxy AnsiTricks)+  ]++-- | A simple console UI with a hook to postprocess results,+-- depending on their names and external conditions+-- (e. g., its previous outcome, stored in a file).+-- Names are listed in reverse order:+-- from test's own name to a name of the outermost test group.+--+-- @since 1.4.2+consoleTestReporterWithHook :: ([TestName] -> Result -> IO Result) -> Ingredient+consoleTestReporterWithHook hook = TestReporter consoleTestReporterOptions $+  \opts tree -> Just $ \smap -> do++  let+    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)+instance IsOption Quiet where+  defaultValue = Quiet False+  parseValue = fmap Quiet . safeReadBool+  optionName = return "quiet"+  optionHelp = return "Do not produce any output; indicate success only by the exit code"+  optionCLParser = mkFlagCLParser (short 'q') (Quiet True)++-- | 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)+instance IsOption HideSuccesses where+  defaultValue = HideSuccesses False+  parseValue = fmap HideSuccesses . safeReadBool+  optionName = return "hide-successes"+  optionHelp = return "Do not print tests that passed successfully"+  optionCLParser = mkFlagCLParser mempty (HideSuccesses True)++-- | The minimum amount of time a test can take before tasty+-- prints timing information.+--+-- @since 1.5+newtype MinDurationToReport = MinDurationToReport { minDurationMicros :: Integer }+  deriving (Eq, Ord)+instance IsOption MinDurationToReport where+  defaultValue = MinDurationToReport 10000+  parseValue = fmap MinDurationToReport . parseDuration+  optionName = return "min-duration-to-report"+  optionHelp =+    return . unwords $+      [ "The minimum amount of time a test can take before tasty prints timing information"+      , "(suffixes: ms,s,m,h; default: s)"+      ]+  optionCLParser = mkOptionCLParser (metavar "DURATION")++-- | When to use color on the output+--+-- @since 0.11.3+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+--+-- * <https://github.com/UnkindPartition/tasty/issues/152>+--+-- * <https://github.com/UnkindPartition/tasty/issues/250>+--+-- When that happens, this option can be used to disable the tricks. In+-- that case, the test name will be printed only once the test fails.+--+-- @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"++-- }}}++--------------------------------------------------+-- Various utilities+--------------------------------------------------+-- {{{+getResultFromTVar :: TVar Status -> IO Result+getResultFromTVar var =+  atomically $ do+    status <- readTVar var+    case status of+      Done r -> return r+      _ -> retry++-- }}}++--------------------------------------------------+-- Formatting+--------------------------------------------------+-- {{{+ indentSize :: Int indentSize = 2 @@ -62,167 +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 --- | A simple console UI-consoleTestReporter :: Ingredient--- We fold the test tree using (AppMonoid m, Any) monoid.------ The 'Any' part is needed to know whether a group is empty, in which case--- we shouldn't display it.-consoleTestReporter = TestReporter [] $ \opts tree -> Just $ \smap -> do-  isTerm <- hIsTerminalDevice stdout--  let-    ?colors = isTerm--  let-    alignment = computeAlignment opts tree--    runSingleTest-      :: (IsTest t, ?colors :: Bool)-      => IntMap.IntMap (TVar Status)-      -> OptionSet -> TestName -> t -> (AppMonoid M, Any)-    runSingleTest smap _opts name _test = (, Any True) $ AppMonoid $ do-      st@RunnerState { ix = ix, nestedLevel = level } <- get-      let-        statusVar =-          fromMaybe (error "internal error: index out of bounds") $-          IntMap.lookup ix smap--      -- Print the test name before waiting for the test. This is useful-      -- for long-running tests.-      liftIO $ printf "%s%s: %s" (indent level) name-        (replicate (alignment - indentSize * level - length name) ' ')--      (rOk, rDesc) <--        liftIO $ atomically $ do-          status <- readTVar statusVar-          case status of-            Done r -> return $ (resultSuccessful r, resultDescription r)-            Exception e -> return (False, "Exception: " ++ show e)-            _ -> retry--      rDesc <- liftIO $ formatMessage rDesc--      liftIO $-        if rOk-          then ok "OK\n"-          else fail "FAIL\n"--      when (not $ null rDesc) $-        liftIO $ (if rOk then infoOk else infoFail) $-          printf "%s%s\n" (indent $ level + 1) (formatDesc (level+1) rDesc)-      let-        ix' = ix+1-        updateFailures = if rOk then id else (+1)-      put $! st { ix = ix', failures = updateFailures (failures st) }--    runGroup :: TestName -> (AppMonoid M, Any) -> (AppMonoid M, Any)-    runGroup _ (_, Any False) = mempty-    runGroup name (AppMonoid act, nonEmpty) = (, nonEmpty) $ AppMonoid $ do-      st@RunnerState { nestedLevel = level } <- get-      liftIO $ printf "%s%s\n" (indent level) name-      put $! st { nestedLevel = level + 1 }-      act-      modify $ \st -> st { nestedLevel = level }--  hSetBuffering stdout NoBuffering--  -- Do not retain the reference to the tree more than necessary-  _ <- evaluate alignment--  st <--    flip execStateT initialState $ getApp $ fst $-      foldTestTree-        trivialFold-          { foldSingle = runSingleTest smap-          , foldGroup = runGroup-          }-        opts-        tree--  printf "\n"--  case failures st of-    0 -> do-      ok $ printf "All %d tests passed\n" (ix st)-      return True--    fs -> do-      fail $ printf "%d out of %d tests failed\n" fs (ix st)-      return False----- | 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 ()-#ifdef COLORS-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-#else-ok       = putStr-fail     = putStr-infoOk   = putStr-infoFail = putStr-#endif+  | otherwise = action++-- }}}
Test/Tasty/Ingredients/IncludingOptions.hs view
@@ -1,3 +1,4 @@+-- | Ingredient for registering user-defined options module Test.Tasty.Ingredients.IncludingOptions where  import Test.Tasty.Ingredients@@ -6,6 +7,8 @@ -- | This ingredient doesn't do anything apart from registering additional -- options. ----- The option values can be accessed using 'askOption'.+-- The option values can be accessed using 'Test.Tasty.askOption'.+--+-- @since 0.6 includingOptions :: [OptionDescription] -> Ingredient includingOptions opts = TestManager opts (\_ _ -> Nothing)
Test/Tasty/Ingredients/ListTests.hs view
@@ -1,46 +1,45 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-}+-- | Ingredient for listing test names+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} module Test.Tasty.Ingredients.ListTests   ( ListTests(..)   , testsNames   , listingTests   ) where -import Options.Applicative-import Data.Typeable import Data.Proxy-import Data.Tagged+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 =-    fmap ListTests $-    switch-      (  short 'l'-      <> long (untag (optionName :: Tagged ListTests String))-      <> help (untag (optionHelp :: Tagged ListTests String))-      )+  optionCLParser = mkFlagCLParser (short 'l') (ListTests True) --- | Obtain the list of all tests in the suite+-- | Obtain the list of all tests in the suite.+--+-- @since 0.4 testsNames :: OptionSet -> TestTree -> [TestName] testsNames {- opts -} {- tree -} =   foldTestTree     trivialFold       { foldSingle = \_opts name _test -> [name]-      , foldGroup = \groupName names -> map ((groupName ++ "/") ++) names+      , foldGroup = \_opts groupName names -> map ((groupName ++ ".") ++) (concat names)       } --- | The ingredient that provides the test listing functionality+-- | The ingredient that provides the test listing functionality.+--+-- @since 0.4 listingTests :: Ingredient listingTests = TestManager [Option (Proxy :: Proxy ListTests)] $   \opts tree ->
Test/Tasty/Options.hs view
@@ -1,9 +1,11 @@-{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable,+{-# LANGUAGE ScopedTypeVariables,              ExistentialQuantification, GADTs,-             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@@ -13,26 +15,39 @@   , setOption   , changeOption   , 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@@ -41,28 +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 (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-      <> value defaultValue-      <> 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@@ -70,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@@ -91,18 +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 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 +-- | 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 = 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
+ Test/Tasty/Options/Core.hs view
@@ -0,0 +1,138 @@+-- | Core options, i.e. the options used by tasty itself+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-} -- for (^)+module Test.Tasty.Options.Core+  ( NumThreads(..)+  , Timeout(..)+  , mkTimeout+  , HideProgress(..)+  , coreOptions+  -- * Helpers+  , parseDuration+  )+  where++import Control.Monad (mfilter)+import Data.Proxy+import Data.Fixed+import Options.Applicative hiding (str)+import GHC.Conc+#if !MIN_VERSION_base(4,11,0)+import Data.Monoid+#endif+import Control.Concurrent+import System.IO.Unsafe++import Test.Tasty.Options+import Test.Tasty.Patterns++-- | Number of parallel threads to use for running tests.+--+-- Note that this is /not/ included in 'coreOptions'.+-- Instead, it's automatically included in the options for any+-- '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)+instance IsOption NumThreads where+  defaultValue = unsafePerformIO $ NumThreads <$>+      if rtsSupportsBoundThreads then getNumProcessors else pure 1+  parseValue = mfilter onlyPositive . fmap NumThreads . safeRead+  optionName = return "num-threads"+  optionHelp = return "Number of threads to use for tests execution"+  optionCLParser = mkOptionCLParser (short 'j' <> metavar "NUMBER")+  showDefaultValue _ = Just "Number of cores when using threaded RTS, 1 for non-threaded"++-- | Filtering function to prevent non-positive number of threads+onlyPositive :: NumThreads -> Bool+onlyPositive (NumThreads x) = x > 0++-- | Timeout to be applied to individual tests.+--+-- @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+  ( 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+      <$> parseDuration str+      <*> pure str+  optionName = return "timeout"+  optionHelp = return "Timeout for individual tests (suffixes: ms,s,m,h; default: s)"+  optionCLParser = mkOptionCLParser (short 't' <> metavar "DURATION")++-- | 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) <$>+  case reads str of+    [(n, suffix)] ->+      case suffix of+        "ms" -> Just (n / 10^3)+        "" -> Just n+        "s" -> Just n+        "m" -> Just (n * 60)+        "h" -> Just (n * 60^2)+        _ -> Nothing+    _ -> Nothing++-- | A shortcut for creating v'Timeout' values.+--+-- @since 0.8+mkTimeout+  :: Integer -- ^ microseconds+  -> Timeout+mkTimeout n =+  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+-- t'TestPattern', t'Timeout' and t'HideProgress'.+--+-- @since 0.1+coreOptions :: [OptionDescription]+coreOptions =+  [ Option (Proxy :: Proxy TestPattern)+  , Option (Proxy :: Proxy Timeout)+  , Option (Proxy :: Proxy HideProgress)+  ]
+ Test/Tasty/Options/Env.hs view
@@ -0,0 +1,59 @@+-- | Get options from the environment+{-# LANGUAGE ScopedTypeVariables #-}+module Test.Tasty.Options.Env (getEnvOptions, suiteEnvOptions) where++import Test.Tasty.Options+import Test.Tasty.Core+import Test.Tasty.Ingredients+import Test.Tasty.Runners.Reducers++import System.Environment+import Data.Tagged+import Data.Proxy+import Data.Char+import Control.Exception+import Text.Printf++data EnvOptionException+  = BadOption+      String -- option name+      String -- variable name+      String -- value++instance Show EnvOptionException where+  show (BadOption optName varName value) =+    printf+      "Bad environment variable %s='%s' (parsed as option %s)"+        varName value optName++instance Exception EnvOptionException++-- | Search the environment for given options+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+        envName = ("TASTY_" ++) . flip map name $ \c ->+          if c == '-'+            then '_'+            else toUpper c+      mbValueStr <- Ap $ myLookupEnv envName+      flip foldMap mbValueStr $ \valueStr ->+        let+          mbValue :: Maybe v+          mbValue = parseValue valueStr++          err = throwIO $ BadOption name envName valueStr++        in Ap $ maybe err (return . singleOption) mbValue++-- | Search the environment for all options relevant for this suite+suiteEnvOptions :: [Ingredient] -> TestTree -> IO OptionSet+suiteEnvOptions ins tree = getEnvOptions $ suiteOptions ins tree++-- note: switch to lookupEnv once we no longer support 7.4+myLookupEnv :: String -> IO (Maybe String)+myLookupEnv name = either (const Nothing) Just <$> (try (getEnv name) :: IO (Either IOException String))
Test/Tasty/Parallel.hs view
@@ -1,18 +1,39 @@ -- | A helper module which takes care of parallelism-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 +-- | 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++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+-- at the same time.+--+-- The action itself is asynchronous, ie. it returns immediately and does+-- the work in new threads. It returns an action which aborts tests and+-- cleans up. runInParallel   :: Int -- ^ maximum number of parallel threads-  -> [IO ()] -- ^ list of actions to execute-  -> IO ()+  -> [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. --@@ -20,84 +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.-    killAll :: IO ()-    killAll = do-      pids <- atomically $ do-        writeTVar aliveVar False-        readTVar pidsVar--      -- be sure not to kill myself!-      me <- myThreadId-      mapM_ killThread $ filter (/= me) pids+  actionsVar <- atomically $ newTMVar actions -    cleanup :: Either SomeException () -> IO ()-    cleanup = either (\e -> killAll >> throwTo callingThread e) (const $ return ())+  pids <- replicateM nthreads (async $ work actionsVar) -    forkCarefully :: IO () -> IO ()-    forkCarefully action = void . 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+        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
Test/Tasty/Patterns.hs view
@@ -1,149 +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---data Token = SlashToken-           | WildcardToken-           | DoubleWildcardToken-           | LiteralToken Char-           deriving (Eq)--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+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--- <http://documentup.com/feuerbach/tasty#using-patterns>-data TestPattern = TestPattern {-        tp_categories_only :: Bool,-        tp_negated :: Bool,-        tp_match_mode :: TestPatternMatchMode,-        tp_tokens :: [Token]-    } | NoPattern-    deriving Typeable+-- | @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-    optionName = return "pattern"-    optionHelp = return "Select only tests that match pattern"---- | 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+  defaultValue = noPattern+  parseValue = parseTestPattern+  optionName = return "pattern"+#if !defined(mingw32_HOST_OS)+  optionHelp = return "Select only tests which satisfy a pattern or awk expression."+#else+  optionHelp = return+    $ unwords [ "Select only tests which satisfy a pattern or awk expression."+              , "Consider using `MSYS_NO_PATHCONV=1` or `MSYS2_ARG_CONV_EXCL=*`"+              , "to prevent pattern mangling."+              ]+#endif+  optionCLParser =+    fmap (TestPattern . fmap (foldr1 And) . nonEmpty . catMaybes . coerce @[TestPattern]) . some $+      mkOptionCLParser (short 'p' <> metavar "PATTERN") -    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
+ Test/Tasty/Patterns/Eval.hs view
@@ -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
+ Test/Tasty/Patterns/Expr.hs view
@@ -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)
+ Test/Tasty/Patterns/Parser.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- | See <http://pubs.opengroup.org/onlinepubs/9699919799/utilities/awk.html> for the+-- full awk grammar.+--+-- @since 1.0+module Test.Tasty.Patterns.Parser+  ( Parser+  , runParser+  , 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
+ Test/Tasty/Patterns/Printer.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE LambdaCase #-}+-- | @since 1.4.2++module Test.Tasty.Patterns.Printer+  ( printAwkExpr+  )+  where++import Prelude hiding (LT, GT, EQ)+import Test.Tasty.Patterns.Types++-- | @since 1.4.2+printAwkExpr :: Expr -> String+printAwkExpr e = go 0 e ""++go :: Int -> Expr -> ShowS+go p = \case+  NF -> showString "NF"+  IntLit n -> showsPrec p n+  StringLit xs -> showChar '"' . showString (escapeString xs) . showChar '"'+  ERE xs -> showChar '/' . showString (escapeERE xs) . showChar '/'++  Field x -> showParen (p >= 9) $ showChar '$' . go 9 x++  -- Cf. comment for Test.Tasty.Patterns.Parser.expr2 to understand+  -- why we put showParens when precedence is 6 not 8.+  Neg x -> showParen (p >= 6) $ showChar '-' . go 8 x+  Not x -> showParen (p >= 8) $ showChar '!' . go 8 x++  Add x y -> showParen (p >= 7) $ go 7 x . showChar '+' . go 7 y+  Sub x y -> showParen (p >= 7) $ go 7 x . showChar '-' . go 7 y++  Concat x y -> showParen (p >= 6) $ go 6 x . showChar ' ' . go 6 y++  LT x y -> showParen (p >= 5) $ go 5 x . showChar '<'    . go 5 y+  LE x y -> showParen (p >= 5) $ go 5 x . showString "<=" . go 5 y+  GT x y -> showParen (p >= 5) $ go 5 x . showChar '>'    . go 5 y+  GE x y -> showParen (p >= 5) $ go 5 x . showString ">=" . go 5 y+  EQ x y -> showParen (p >= 5) $ go 5 x . showString "==" . go 5 y+  NE x y -> showParen (p >= 5) $ go 5 x . showString "!=" . go 5 y++  Match x y   -> showParen (p >= 4) $ go 4 x . showChar '~'    . go 4 (ERE y)+  NoMatch x y -> showParen (p >= 4) $ go 4 x . showString "!~" . go 4 (ERE y)++  And x y -> showParen (p >= 2) $ go 2 x . showString "&&" . go 2 y++  Or x y -> showParen (p >= 1) $ go 1 x . showString "||" . go 1 y++  If c t f -> showParen (p >= 0) $ go 0 c . showChar '?' . go 0 t . showChar ':' . go 0 f++  ToUpperFn x -> showString "toupper(" . go 0 x . showChar ')'+  ToLowerFn x -> showString "tolower(" . go 0 x . showChar ')'++  LengthFn Nothing  -> showString "length()"+  LengthFn (Just x) -> showString "length(" . go 0 x . showChar ')'++  SubstrFn x y Nothing  -> showString "substr(" . go 0 x . showChar ',' . go 0 y . showChar ')'+  SubstrFn x y (Just z) -> showString "substr(" . go 0 x . showChar ',' . go 0 y . showChar ',' . go 0 z . showChar ')'++  MatchFn x y -> showString "match(" . go 0 x . showChar ',' . go 0 (ERE y) . showChar ')'++escapeString :: String -> String+escapeString = concatMap $ \c -> (if c `elem` "\\\"" then ('\\' :) else id) [c]++escapeERE :: String -> String+escapeERE = concatMap $ \c -> (if c `elem` "\\/" then ('\\' :) else id) [c]
+ Test/Tasty/Patterns/Types.hs view
@@ -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+  )
Test/Tasty/Providers.hs view
@@ -1,7 +1,12 @@--- | API for test providers+-- | API for test providers.+--+-- @since 0.1 module Test.Tasty.Providers   ( IsTest(..)-  , Result(..)+  , testPassed+  , testFailed+  , testFailedDetails+  , Result   , Progress(..)   , TestName   , TestTree@@ -10,7 +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++-- | 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+  }++-- | t'Result' of a failed test with custom details printer+--+-- @since 1.3.1+testFailedDetails+  :: String               -- ^ description+  -> ResultDetailsPrinter -- ^ details printer+  -> Result+testFailedDetails desc printer = (testFailed desc)+  { resultDetailsPrinter = printer }
+ Test/Tasty/Providers/ConsoleFormat.hs view
@@ -0,0 +1,87 @@+-- | This module can be used by providers to perform colorful/formatted+-- output and possibly reuse tasty's own output formats.+--+-- @since 1.3.1+module Test.Tasty.Providers.ConsoleFormat+  ( ResultDetailsPrinter(..)+  , ConsoleFormat(..)+  , ConsoleFormatPrinter+  , noResultDetails+  , failFormat+  , infoFailFormat+  , infoOkFormat+  , okFormat+  , skippedFormat+  )+where++import System.Console.ANSI++-- | Console output format+--+-- @since 1.3.1+data ConsoleFormat = ConsoleFormat+  { consoleIntensity :: ConsoleIntensity+  , colorIntensity   :: ColorIntensity+  , color            :: Color+  }++-- | Type of console format printer functions+--+-- @since 1.3.1+type ConsoleFormatPrinter+  =  ConsoleFormat -- ^ selected console format+  -> IO ()         -- ^ action to be executed with active console format+  -> IO ()++-- | Noop result details printer. The default for most providers.+--+-- @since 1.3.1+noResultDetails :: ResultDetailsPrinter+noResultDetails = ResultDetailsPrinter . const . const $ return ()++-- | An action that prints additional information about a test using+-- colors/formatting; see 'Test.Tasty.Providers.testFailedDetails' and+-- 'Test.Tasty.Runners.resultDetailsPrinter'.+--+-- As input, this action is provided with the current indentation level and+-- a 'ConsoleFormatPrinter', which tells it how perform output.+--+-- This is a newtype to allow a 'Show' instance.+--+-- @since 1.3.1+newtype ResultDetailsPrinter = ResultDetailsPrinter+  (Int -> ConsoleFormatPrinter -> IO ())++instance Show ResultDetailsPrinter where+  show _printer = "ResultDetailsPrinter"++-- | Format used to display failures+--+-- @since 1.3.1+failFormat :: ConsoleFormat+failFormat = ConsoleFormat BoldIntensity   Vivid Red++-- | Format used to display additional information on failures+--+-- @since 1.3.1+infoFailFormat :: ConsoleFormat+infoFailFormat = ConsoleFormat NormalIntensity Dull  Red++-- | Format used to display successes+--+-- @since 1.3.1+okFormat :: ConsoleFormat+okFormat = ConsoleFormat NormalIntensity Dull  Green++-- | Format used to display additional information on successes+--+-- @since 1.3.1+infoOkFormat :: ConsoleFormat+infoOkFormat = ConsoleFormat NormalIntensity Dull  White++-- | Format used to display skipped tests+--+-- @since 1.3.1+skippedFormat :: ConsoleFormat+skippedFormat = ConsoleFormat NormalIntensity Dull  Magenta
Test/Tasty/Run.hs view
@@ -1,185 +1,687 @@ -- | Running tests-{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification #-}+{-# 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 Control.Monad.State-import Control.Monad.Writer-import Control.Monad.Reader-import Control.Monad.Trans.Either+import Data.Int (Int64)+import Data.Maybe+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.Exception-import Control.Applicative+import Control.Concurrent.Async+import Control.Exception as E 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.CoreOptions+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   | Executing Progress     -- ^ test is being run-  | Exception SomeException-    -- ^ test threw an exception and was aborted   | 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   = NotCreated+  | BeingCreated   | FailedToCreate SomeException   | Created r+  | BeingDestroyed+  | Destroyed +instance Show (Resource r) where+  show r = case r of+    NotCreated -> "NotCreated"+    BeingCreated -> "BeingCreated"+    FailedToCreate exn -> "FailedToCreate " ++ show exn+    Created {} -> "Created"+    BeingDestroyed -> "BeingDestroyed"+    Destroyed -> "Destroyed"+ data Initializer   = forall res . Initializer       (IO res)-      (MVar (Resource res))+      (TVar (Resource res)) data Finalizer   = forall res . Finalizer       (res -> IO ())-      (MVar (Resource res))-      (MVar Int)+      (TVar (Resource res))+      (TVar Int) --- | Start executing a test------ Note: we take the finalizer as an argument because it's important that--- it's run *before* we write the status var and signal to other threads--- that we're finished+-- | Execute a test taking care of resources executeTest   :: ((Progress -> IO ()) -> IO Result)     -- ^ the action to execute the test, which takes a progress callback as     -- a parameter   -> TVar Status -- ^ variable to write status to-  -> Seq.Seq Initializer -- ^ initializers (to be executed in this order)-  -> Seq.Seq Finalizer -- ^ finalizers (to be executed in this order)+  -> Timeout -- ^ optional timeout to apply+  -> 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 inits fins =-  handle (atomically . writeTVar statusVar . Exception) $ do-  -- We don't try to protect against async exceptions here.-  -- This is because we use interruptible modifyMVar and wouldn't be able-  -- to give any guarantees anyway.-  -- So all we do is guard actual acquire/test/release actions using 'try'.-  -- The only thing we guarantee upon catching an async exception is that-  -- we'll write it to the status var, so that the UI won't be waiting-  -- infinitely.-  resultOrExcn <- runEitherT $ do-    F.forM_ inits $ \(Initializer doInit initVar) -> EitherT $-      modifyMVar initVar $ \resStatus  ->-        case resStatus of-          NotCreated -> do-            mbRes <- try doInit-            case mbRes of-              Right res -> return (Created res, Right ())-              Left ex -> return (FailedToCreate ex, Left ex)-          Created {} -> return (resStatus, Right ())-          FailedToCreate ex -> return (resStatus, Left ex)+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.+    --+    -- There's no point to transform these exceptions to something like+    -- EitherT, because an async exception (cancellation) can strike+    -- anyway.+    initResources -    -- if all initializers ran successfully, actually run the test-    EitherT . try $-      -- pass our callback (which updates the status variable) to the test-      -- action-      action yieldProgress+    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 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-  -- remember the first exception that occurred-  mbExcn <- liftM getFirst . execWriterT . getApp $-    flip F.foldMap fins $ \(Finalizer doRelease initVar finishVar) ->-      AppMonoid $ do-        mbExcn <--          liftIO $ modifyMVar finishVar $ \nUsers -> do-            let nUsers' = nUsers - 1-            mbExcn <--              if nUsers' == 0-              then do-                resStatus <- readMVar initVar-                case resStatus of-                  Created res ->-                    either-                      (\ex -> Just ex)-                      (\_ -> Nothing)-                    <$> try (doRelease res)-                  _ -> return Nothing+  mbExn <- destroyResources restore++  atomically . writeTVar statusVar . Done $+    case resultOrExn <* maybe (Right ()) Left mbExn of+      Left ex -> exceptionResult ex+      Right (t,r) -> r { resultTime = t }++  where+    initResources :: IO ()+    initResources =+      F.forM_ inits $ \(Initializer doInit initVar) -> do+        join $ atomically $ do+          resStatus <- readTVar initVar+          case resStatus of+            NotCreated -> do+              -- signal to others that we're taking care of the resource+              -- initialization+              writeTVar initVar BeingCreated+              return $+                (do+                  res <- doInit+                  atomically $ writeTVar initVar $ Created res+                 ) `E.catch` \exn -> do+                  atomically $ writeTVar initVar $ FailedToCreate exn+                  throwIO exn+            BeingCreated -> retry+            Created {} -> return $ return ()+            FailedToCreate exn -> return $ throwIO exn+            -- 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+    applyTimeout (Timeout t tstr) a = do+      let+        timeoutResult =+          Result+            { resultOutcome = Failure $ TestTimedOut t+            , resultDescription =+                "Timed out after " ++ tstr+            , resultShortDescription = "TIMEOUT"+            , resultTime = fromIntegral t+            , resultDetailsPrinter = noResultDetails+            }+      -- 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:+    --+    -- * the finalizer is wrapped in 'try'+    -- * async exceptions are masked by the caller+    -- * we don't use any interruptible operations here (outside of 'try')+    destroyResources :: (forall a . IO a -> IO a) -> IO (Maybe SomeException)+    destroyResources restore = do+      -- remember the first exception that occurred+      liftM getFirst . execWriterT . getTraversal $+        flip F.foldMap fins $ \fin@(Finalizer _ _ finishVar) ->+          Traversal $ do+            iAmLast <- liftIO $ atomically $ do+              nUsers <- readTVar finishVar+              let nUsers' = nUsers - 1+              writeTVar finishVar nUsers'+              return $ nUsers' == 0++            mbExcn <- liftIO $+              if iAmLast+              then destroyResource restore fin               else return Nothing-            return (nUsers', mbExcn) -- end of modifyMVar -        tell $ First mbExcn+            tell $ First mbExcn -  atomically . writeTVar statusVar $-    case resultOrExcn <* maybe (return ()) Left mbExcn of-      Left ex -> Exception ex-      Right r -> Done r+    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 -  where-    -- the callback-    yieldProgress progress =-      atomically $ writeTVar statusVar $ Executing progress+-- | Traversal type used in 'createTestActions'+type Tr = ReaderT (Path, Seq Dependency) IO (TestActionTree UnresolvedAction) -type InitFinPair = (Seq.Seq Initializer, Seq.Seq Finalizer)+-- | 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 --- | Prepare the test tree to be run-createTestActions :: OptionSet -> TestTree -> IO [(IO (), TVar Status)]-createTestActions opts tree =-  liftM (map (first ($ (Seq.empty, Seq.empty)))) $-  execWriterT $ getApp $-  (foldTestTree-    trivialFold-      { foldSingle = runSingleTest-      , foldResource = addInitAndRelease-      }-    opts-    tree-    :: AppMonoid (WriterT [(InitFinPair -> IO (), TVar Status)] IO))+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 []     = "- <empty cycle>"+      showCycle (x:xs) = "- " ++ intercalate ", " (map showPath (x:xs ++ [x]))++instance Exception DependencyException++-- | Specifies how to calculate a dependency+data DependencySpec+  = ExactDep (Seq TestName) (TVar Status)+  -- ^ Dependency specified by 'TestGroup'. Note that the first field is only+  -- there for dependency cycle detection - which can be introduced by using+  -- 'PatternDep'.+  | PatternDep Expr+  -- ^ All tests matching this 'Expr' should be considered dependencies+  deriving (Eq)++instance Show DependencySpec where+  show (PatternDep dep) = "PatternDep (" ++ show dep ++ ")"+  show (ExactDep testName _) = "ExactDep (" ++ show testName ++ ") (<TVar>)"++-- | Dependency of a test. Either it points to an exact path it depends on, or+-- contains a pattern that should be tested against all tests in a 'TestTree'.+data Dependency = Dependency DependencyType DependencySpec+  deriving (Eq, Show)++-- | Is given t'Dependency' a dependency that was introduced with 'After'?+isPatternDependency :: Dependency -> Bool+isPatternDependency (Dependency _ (PatternDep {})) = True+isPatternDependency _ = False++#if !MIN_VERSION_base(4,18,0)+-- The mapAccumM function behaves like a combination of mapM and mapAccumL that+-- traverses the structure while evaluating the actions and passing an accumulating+-- parameter from left to right. It returns a final value of this accumulator+-- together with the new structure. The accumulator is often used for caching the+-- intermediate results of a computation.+mapAccumM :: Monad m => (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])+mapAccumM _ acc [] = return (acc, [])+mapAccumM f acc (x:xs) = do+  (acc', y) <- f acc x+  (acc'', ys) <- mapAccumM f acc' xs+  return (acc'', y:ys)+#endif++-- | An action with meta information+data TestAction act = TestAction+  { testAction :: act+    -- ^ Some action, typically 'UnresolvedAction', 'ResolvedAction', or t'Action'.+  , testPath :: Path+    -- ^ Path pointing to this action (a series of group names + a test name)+  , testDeps :: Seq Dependency+    -- ^ Dependencies introduced by AWK-like patterns+  , testStatus :: TVar Status+    -- ^ Status var that can be used to monitor test progress+  }++-- | A test that still needs to be given its resource initializers and finalizers+type UnresolvedAction = Seq Initializer -> Seq Finalizer -> IO ()++-- | A test that, unlike 'UnresolvedAction', has been given its initializers and+-- finalizers.+type ResolvedAction = IO ()++-- | Number of 'TAction' leafs in a 'TestActionTree'. Used to prevent repeated+-- size calculations.+type Size = Int++-- | Simplified version of 'TestTree' that only includes the tests to be run (as+-- a t'TestAction') and the resources needed to run them (as t'Initializer's and+-- t'Finalizer's).+data TestActionTree act+  = TResource Initializer Finalizer (TestActionTree act)+  | TGroup Size [TestActionTree act]+  -- ^ Note the 'Size' field of this constructor: it stores how many 'TAction's+  -- are present in the tree. Functions using constructing this constructor+  -- should take care, or use 'tGroup' instead. If this constructor is ever+  -- exported, we should probably move it to its own module and expose only a+  -- smart constructor using pattern synonyms. For now, this seems more trouble+  -- than it's worth, given the number of types it needs defined in this module.+  | TAction (TestAction act)++-- | Smart constructor for 'TGroup'. Fills in 'Size' field by summing the size+-- of the given test trees.+tGroup :: [TestActionTree act] -> TestActionTree act+tGroup trees = TGroup (sum (map testActionTreeSize trees)) trees++-- | Size of a 'TestActionTree', i.e. the number of 'TAction's it contains.+testActionTreeSize :: TestActionTree act -> Int+testActionTreeSize = \case+  TResource _ _ tree -> testActionTreeSize tree+  TGroup size _ -> size+  TAction _ -> 1++-- | Collect initializers and finalizers introduced by 'TResource' and apply them+-- to each action.+resolveTestActions :: TestActionTree UnresolvedAction -> TestActionTree ResolvedAction+resolveTestActions = go Seq.empty Seq.empty+ where+  go inits fins = \case+    TResource ini fin tree ->+      TResource ini fin $ go (inits |> ini) (fin <| fins) tree+    TGroup size trees ->+      TGroup size $ map (go inits fins) trees+    TAction (TestAction {..})->+      TAction $ TestAction { testAction = testAction inits fins, .. }++-- | Turn a test tree into a list of actions to run tests coupled with+-- variables to watch them. 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+    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 = AppMonoid $ 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 inits fins-      tell [(act, statusVar)]-    addInitAndRelease (ResourceSpec doInit doRelease) a =-      AppMonoid . WriterT . fmap ((,) ()) $ do-        initVar <- newMVar NotCreated-        tests <- execWriterT $ getApp $ a (getResource initVar)-        let ntests = length tests-        finishVar <- newMVar ntests-        let-          ini = Initializer doInit initVar-          fin = Finalizer doRelease initVar finishVar-        return $ map (first $ local $ (Seq.|> ini) *** (fin Seq.<|)) tests+        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+      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 :: MVar (Resource r) -> IO r+getResource :: TVar (Resource r) -> IO r getResource var =-  readMVar var >>= \rState ->+  atomically $ do+    rState <- readTVar var     case rState of       Created r -> return r-      NotCreated -> throwIO $ UnexpectedState "not created"-      FailedToCreate {} -> throwIO $ UnexpectedState "failed to create"+      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.-launchTestTree :: OptionSet -> TestTree -> IO StatusMap-launchTestTree opts tree = do-  testActions <- createTestActions opts tree-  let NumThreads numTheads = lookupOption opts-  runInParallel numTheads (fst <$> testActions)-  return $ IntMap.fromList $ zip [0..] (snd <$> testActions)+-- 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 (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' 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+      NotCreated -> False+      BeingCreated -> True+      FailedToCreate {} -> False+      Created {} -> True+      BeingDestroyed -> True+      Destroyed -> False++    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
Test/Tasty/Runners.hs view
@@ -1,4 +1,6 @@--- | API for test runners+-- | API for test runners.+--+-- @since 0.1 module Test.Tasty.Runners   (     -- * Working with the test tree@@ -6,14 +8,19 @@   , foldTestTree   , TreeFold(..)   , trivialFold-  , AppMonoid(..)   , ResourceSpec(..)+  , module Test.Tasty.Runners.Reducers     -- * Ingredients   , Ingredient(..)+  , Time   , tryIngredients   , ingredientOptions   , ingredientsOptions     -- * Standard console ingredients+    -- | NOTE: the exports in this section are deprecated and will be+    -- removed in the future. Please import "Test.Tasty.Ingredients.Basic"+    -- if you need them.+     -- ** Console test reporter   , consoleTestReporter     -- ** Tests list@@ -21,29 +28,38 @@   , ListTests(..)   , testsNames     -- * Command line handling+  , parseOptions   , optionParser   , suiteOptionParser   , defaultMainWithIngredients     -- * Running tests   , Status(..)   , Result(..)+  , Outcome(..)+  , FailureReason(..)+  , resultSuccessful   , Progress(..)+  , emptyProgress   , StatusMap   , launchTestTree   , NumThreads(..)+  , DependencyException(..)     -- * Options   , suiteOptions   , coreOptions     -- ** Patterns   , module Test.Tasty.Patterns+    -- * Utilities+  , module Test.Tasty.Runners.Utils   )   where  import Test.Tasty.Core import Test.Tasty.Run import Test.Tasty.Ingredients-import Test.Tasty.CoreOptions+import Test.Tasty.Options.Core import Test.Tasty.Patterns import Test.Tasty.CmdLine-import Test.Tasty.Ingredients.ConsoleReporter-import Test.Tasty.Ingredients.ListTests+import Test.Tasty.Ingredients.Basic+import Test.Tasty.Runners.Reducers+import Test.Tasty.Runners.Utils
+ Test/Tasty/Runners/Reducers.hs view
@@ -0,0 +1,78 @@+-- | Monoidal wrappers for applicative functors. Useful to define tree+-- folds.++-- These are the same as in the 'reducers' package. We do not use+-- 'reducers' to avoid its dependencies.++{- License for the 'reducers' package+Copyright 2008-2011 Edward Kmett++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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 GeneralizedNewtypeDeriving #-}++module Test.Tasty.Runners.Reducers where++import Prelude hiding (Applicative(..))+import Control.Applicative+import qualified Data.Semigroup as Sem++-- | 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 ()+#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+#if !MIN_VERSION_base(4,11,0)+  mappend = (Sem.<>)+#endif
+ Test/Tasty/Runners/Utils.hs view
@@ -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. <https://github.com/UnkindPartition/tasty/issues/25>.+--+-- @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+-- (<https://ro-che.info/articles/2015-05-28-force-list>).+--+-- @since 1.0.1+forceElements :: [a] -> ()+forceElements = foldr seq ()++-- from https://ro-che.info/articles/2014-07-30-bracket+-- | Install signal handlers so that e.g. the cursor is restored if the test+-- suite is killed by SIGTERM. Upon a signal, a 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
tasty.cabal view
@@ -1,59 +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.7+version:             1.5.4 synopsis:            Modern and extensible testing framework-description:         See <http://documentup.com/feuerbach/tasty>+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. license:             MIT license-file:        LICENSE-author:              Roman Cheplyaka-maintainer:          roma@ro-che.info--- copyright:           +author:              Roman Cheplyaka <roma@ro-che.info>+maintainer:          Roman Cheplyaka <roma@ro-che.info>+homepage:            https://github.com/UnkindPartition/tasty+bug-reports:         https://github.com/UnkindPartition/tasty/issues+-- copyright: category:            Testing build-type:          Simple--- extra-source-files:  -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 colors-  description: Enable colorful output+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-  other-modules:-    Test.Tasty.Parallel,-    Test.Tasty.Core,-    Test.Tasty.CoreOptions,-    Test.Tasty.Patterns,-    Test.Tasty.Run,-    Test.Tasty.Ingredients,-    Test.Tasty.CmdLine,+    Test.Tasty.Ingredients+    Test.Tasty.Ingredients.Basic     Test.Tasty.Ingredients.ConsoleReporter++    -- for testing only+    Test.Tasty.Patterns.Types+    Test.Tasty.Patterns.Parser+    Test.Tasty.Patterns.Printer+    Test.Tasty.Patterns.Eval+  other-modules:+    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 >= 1.1.8,-    optparse-applicative >= 0.6,-    deepseq >= 1.3,-    either >= 4.0+    base                 >= 4.9  && < 5,+    stm                  >= 2.3  && < 2.6,+    containers           >= 0.5.8 && < 0.9,+    transformers         >= 0.5  && < 0.7,+    tagged               >= 0.5  && < 0.9,+    optparse-applicative >= 0.14 && < 0.20,+    ansi-terminal        >= 0.9  && < 1.2 -  if flag(colors)-    build-depends: ansi-terminal >= 0.6.1-    cpp-options: -DCOLORS-  -- hs-source-dirs:      +  -- No reason to depend on unbounded-delays on 64-bit architecture+  if(!arch(x86_64) && !arch(aarch64) && !arch(ppc64le) && !arch(ppc64) && !arch(s390x) && !arch(riscv64) && !arch(loongarch64))+    build-depends:+      unbounded-delays >= 0.1 && < 0.2++  if(!impl(ghc >= 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