tasty 0.11.3 → 1.5.4
raw patch · 28 files changed
Files
- CHANGELOG.md +355/−3
- Control/Concurrent/Async.hs +293/−0
- README.md +539/−104
- Test/Tasty.hs +51/−6
- Test/Tasty/CmdLine.hs +142/−63
- Test/Tasty/Core.hs +517/−44
- Test/Tasty/Ingredients.hs +28/−7
- Test/Tasty/Ingredients/Basic.hs +5/−2
- Test/Tasty/Ingredients/ConsoleReporter.hs +449/−141
- Test/Tasty/Ingredients/IncludingOptions.hs +3/−1
- Test/Tasty/Ingredients/ListTests.hs +13/−9
- Test/Tasty/Options.hs +93/−20
- Test/Tasty/Options/Core.hs +61/−18
- Test/Tasty/Options/Env.hs +2/−6
- Test/Tasty/Parallel.hs +78/−107
- Test/Tasty/Patterns.hs +64/−138
- Test/Tasty/Patterns/Eval.hs +164/−0
- Test/Tasty/Patterns/Expr.hs +173/−0
- Test/Tasty/Patterns/Parser.hs +194/−0
- Test/Tasty/Patterns/Printer.hs +66/−0
- Test/Tasty/Patterns/Types.hs +40/−0
- Test/Tasty/Providers.hs +20/−12
- Test/Tasty/Providers/ConsoleFormat.hs +87/−0
- Test/Tasty/Run.hs +483/−104
- Test/Tasty/Runners.hs +6/−1
- Test/Tasty/Runners/Reducers.hs +24/−5
- Test/Tasty/Runners/Utils.hs +110/−7
- tasty.cabal +58/−42
CHANGELOG.md view
@@ -1,6 +1,358 @@ 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 -------------- @@ -127,7 +479,7 @@ --------------- Be careful not to export the `Show (a -> b)` instance, see-<https://github.com/feuerbach/tasty/issues/71>+<https://github.com/UnkindPartition/tasty/issues/71> Version 0.8.1.2 ---------------@@ -189,7 +541,7 @@ * Better handling of exceptions that arise during resource creation or disposal * Expose the `AppMonoid` wrapper-* Add `askOption` and `inludingOptions`+* Add `askOption` and `includingOptions` Version 0.5.2.1 ---------------@@ -231,7 +583,7 @@ Version 0.4.0.1 --------------- -Fix a bug ([#25](https://github.com/feuerbach/tasty/issues/25))+Fix a bug ([#25](https://github.com/UnkindPartition/tasty/issues/25)) Version 0.4 -----------
+ Control/Concurrent/Async.hs view
@@ -0,0 +1,293 @@+-- | Operations for running IO operations asynchronously.++-- These are the same as in the 'async' package. We do not use+-- 'async' to avoid its dependencies.++{- License for the 'async' package+Copyright (c) 2012, Simon Marlow++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Simon Marlow nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+-}++{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}++module Control.Concurrent.Async (+ async, withAsync, wait, asyncThreadId, cancel, concurrently+ ) where++import Control.Concurrent.STM+import Control.Exception+ ( BlockedIndefinitelyOnMVar(..)+ , BlockedIndefinitelyOnSTM(..)+ , Exception+ , SomeException+ , asyncExceptionFromException+ , asyncExceptionToException+ , catch+ , fromException+ , onException+ , toException+ , try+ )+import Control.Concurrent+import Control.Monad+import Data.IORef+import GHC.Conc (ThreadId(..))+import GHC.Exts+import GHC.IO hiding (onException)++#if MIN_VERSION_base(4,21,0)+import Control.Exception (ExceptionWithContext, tryWithContext, catchNoPropagate, rethrowIO)+#else+type ExceptionWithContext x = x++catchNoPropagate :: IO a -> (ExceptionWithContext SomeException -> IO a) -> IO a+catchNoPropagate = catchAll++tryWithContext :: IO a -> IO (Either (ExceptionWithContext SomeException) a)+tryWithContext = try++rethrowIO :: ExceptionWithContext SomeException -> IO a+rethrowIO = throwIO+#endif++-- | An asynchronous action spawned by 'async' or 'withAsync'.+-- Asynchronous actions are executed in a separate thread, and+-- operations are provided for waiting for asynchronous actions to+-- complete and obtaining their results (see e.g. 'wait').+--+data Async a = Async+ { asyncThreadId :: {-# UNPACK #-} !ThreadId+ -- ^ Returns the t'ThreadId' of the thread running+ -- the given t'Async'.+ , _asyncWait :: STM (Either (ExceptionWithContext SomeException) a)+ }++-- | Spawn an asynchronous action in a separate thread.+async :: IO a -> IO (Async a)+async = inline asyncUsing rawForkIO++asyncUsing :: (IO () -> IO ThreadId)+ -> IO a -> IO (Async a)+asyncUsing doFork = \action -> do+ var <- newEmptyTMVarIO+ -- t <- forkFinally action (\r -> atomically $ putTMVar var r)+ -- slightly faster:+ t <- mask $ \restore ->+ doFork $ try (restore action) >>= atomically . putTMVar var+ return (Async t (readTMVar var))++-- | Spawn an asynchronous action in a separate thread, and pass its+-- @Async@ handle to the supplied function. When the function returns+-- or throws an exception, 'uninterruptibleCancel' is called on the @Async@.+--+-- > withAsync action inner = mask $ \restore -> do+-- > a <- async (restore action)+-- > restore (inner a) `finally` uninterruptibleCancel a+--+-- This is a useful variant of 'async' that ensures an @Async@ is+-- never left running unintentionally.+--+-- Note: a reference to the child thread is kept alive until the call+-- to `withAsync` returns, so nesting many `withAsync` calls requires+-- linear memory.+--+withAsync :: IO a -> (Async a -> IO b) -> IO b+withAsync = inline withAsyncUsing rawForkIO++withAsyncUsing :: (IO () -> IO ThreadId)+ -> IO a -> (Async a -> IO b) -> IO b+-- The bracket version works, but is slow. We can do better by+-- hand-coding it:+withAsyncUsing doFork = \action inner -> do+ var <- newEmptyTMVarIO+ mask $ \restore -> do+ t <- doFork $ tryWithContext (restore action) >>= atomically . putTMVar var+ let a = Async t (readTMVar var)+ r <- restore (inner a) `catchNoPropagate` \e -> do+ uninterruptibleCancel a+ rethrowIO (e :: ExceptionWithContext SomeException)+ uninterruptibleCancel a+ return r++-- | Wait for an asynchronous action to complete, and return its+-- value. If the asynchronous action threw an exception, then the+-- exception is re-thrown by 'wait'.+--+-- > wait = atomically . waitSTM+--+{-# INLINE wait #-}+wait :: Async a -> IO a+wait = tryAgain . atomically . waitSTM+ where+ -- See: https://github.com/simonmar/async/issues/14+ tryAgain f = f `Control.Exception.catch` \BlockedIndefinitelyOnSTM -> f++-- | Wait for an asynchronous action to complete, and return either+-- @Left e@ if the action raised an exception @e@, or @Right a@ if it+-- returned a value @a@.+--+-- > waitCatch = atomically . waitCatchSTM+--+{-# INLINE waitCatch #-}+waitCatch :: Async a -> IO (Either (ExceptionWithContext SomeException) a)+waitCatch = tryAgain . atomically . waitCatchSTM+ where+ -- See: https://github.com/simonmar/async/issues/14+ tryAgain f = f `Control.Exception.catch` \BlockedIndefinitelyOnSTM -> f++-- | A version of 'wait' that can be used inside an STM transaction.+--+waitSTM :: Async a -> STM a+waitSTM a = do+ r <- waitCatchSTM a+ either throwSTM return r++-- | A version of 'waitCatch' that can be used inside an STM transaction.+--+{-# INLINE waitCatchSTM #-}+waitCatchSTM :: Async a -> STM (Either (ExceptionWithContext SomeException) a)+waitCatchSTM (Async _ w) = w++-- | Cancel an asynchronous action by throwing the @AsyncCancelled@+-- exception to it, and waiting for the t'Async' thread to quit.+-- Has no effect if the t'Async' has already completed.+--+-- > cancel a = throwTo (asyncThreadId a) AsyncCancelled <* waitCatch a+--+-- Note that 'cancel' will not terminate until the thread the t'Async'+-- refers to has terminated. This means that 'cancel' will block for+-- as long said thread blocks when receiving an asynchronous exception.+--+-- For example, it could block if:+--+-- * It's executing a foreign call, and thus cannot receive the asynchronous+-- exception;+-- * It's executing some cleanup handler after having received the exception,+-- and the handler is blocking.+{-# INLINE cancel #-}+cancel :: Async a -> IO ()+cancel a@(Async t _) = throwTo t AsyncCancelled >> void (waitCatch a)++-- | The exception thrown by `cancel` to terminate a thread.+data AsyncCancelled = AsyncCancelled+ deriving (Show, Eq)++instance Exception AsyncCancelled where+ fromException = asyncExceptionFromException+ toException = asyncExceptionToException++-- | Cancel an asynchronous action+--+-- This is a variant of `cancel`, but it is not interruptible.+{-# INLINE uninterruptibleCancel #-}+uninterruptibleCancel :: Async a -> IO ()+uninterruptibleCancel = uninterruptibleMask_ . cancel++-- | Run two @IO@ actions concurrently, and return both results. If+-- either action throws an exception at any time, then the other+-- action is 'cancel'led, and the exception is re-thrown by+-- 'concurrently'.+--+-- > concurrently left right =+-- > withAsync left $ \a ->+-- > withAsync right $ \b ->+-- > waitBoth a b+concurrently :: IO a -> IO b -> IO (a,b)+concurrently left right = concurrently' left right (collect [])+ where+ collect [Left a, Right b] _ = return (a,b)+ collect [Right b, Left a] _ = return (a,b)+ collect xs m = do+ e <- m+ case e of+ Left ex -> throwIO ex+ Right r -> collect (r:xs) m++concurrently' :: IO a -> IO b+ -> (IO (Either SomeException (Either a b)) -> IO r)+ -> IO r+concurrently' left right collect = do+ done <- newEmptyMVar+ mask $ \restore -> do+ -- Note: uninterruptibleMask here is because we must not allow+ -- the putMVar in the exception handler to be interrupted,+ -- otherwise the parent thread will deadlock when it waits for+ -- the thread to terminate.+ lid <- forkIO $ uninterruptibleMask_ $+ restore (left >>= putMVar done . Right . Left)+ `catchAll` (putMVar done . Left)+ rid <- forkIO $ uninterruptibleMask_ $+ restore (right >>= putMVar done . Right . Right)+ `catchAll` (putMVar done . Left)++ count <- newIORef (2 :: Int)+ let takeDone = do+ r <- takeMVar done -- interruptible+ -- Decrement the counter so we know how many takes are left.+ -- Since only the parent thread is calling this, we can+ -- use non-atomic modifications.+ -- NB. do this *after* takeMVar, because takeMVar might be+ -- interrupted.+ modifyIORef count (subtract 1)+ return r++ let tryAgain f = f `Control.Exception.catch` \BlockedIndefinitelyOnMVar -> f++ stop = do+ -- kill right before left, to match the semantics of+ -- the version using withAsync. (#27)+ uninterruptibleMask_ $ do+ count' <- readIORef count+ -- we only need to use killThread if there are still+ -- children alive. Note: forkIO here is because the+ -- child thread could be in an uninterruptible+ -- putMVar.+ when (count' > 0) $+ void $ forkIO $ do+ throwTo rid AsyncCancelled+ throwTo lid AsyncCancelled+ -- ensure the children are really dead+ replicateM_ count' (tryAgain $ takeMVar done)++ r <- collect (tryAgain $ takeDone) `onException` stop+ stop+ return r++catchAll :: IO a -> (SomeException -> IO a) -> IO a+catchAll = Control.Exception.catch++-- A version of forkIO that does not include the outer exception+-- handler: saves a bit of time when we will be installing our own+-- exception handler.+{-# INLINE rawForkIO #-}+rawForkIO :: IO () -> IO ThreadId+rawForkIO action = IO $ \ s ->+ case (fork# (unIO action) s) of (# s1, tid #) -> (# s1, ThreadId tid #)
README.md view
@@ -16,17 +16,9 @@ * Extensibility: add your own test providers and ingredients (runners) above and beyond those provided -[](https://travis-ci.org/feuerbach/tasty)- To find out what's new, read the **[change log][]**. -[change log]: https://github.com/feuerbach/tasty/blob/master/core/CHANGELOG.md--Ask any tasty-related questions on the **[mailing list][]** or IRC channel-**#tasty** at FreeNode ([logs & stats][ircbrowse]).--[mailing list]: https://groups.google.com/forum/#!forum/haskell-tasty-[ircbrowse]: http://ircbrowse.net/tasty+[change log]: https://github.com/UnkindPartition/tasty/blob/master/core/CHANGELOG.md ## Example @@ -83,7 +75,7 @@ And here is the output of the above program: -+ (Note that whether QuickCheck finds a counterexample to the third property is determined by chance.)@@ -93,7 +85,7 @@ [tasty][] is the core package. It contains basic definitions and APIs and a console runner. -[tasty]: http://hackage.haskell.org/package/tasty+[tasty]: https://hackage.haskell.org/package/tasty In order to create a test suite, you also need to install one or more «providers» (see below).@@ -102,21 +94,33 @@ The following providers exist: -* [tasty-hunit](http://hackage.haskell.org/package/tasty-hunit) — for unit tests- (based on [HUnit](http://hackage.haskell.org/package/HUnit))+* [tasty-hunit](https://hackage.haskell.org/package/tasty-hunit) — for unit tests+ (based on [HUnit](https://hackage.haskell.org/package/HUnit)) * [tasty-golden][] — for golden tests, which are unit tests whose results are kept in files-* [tasty-smallcheck](http://hackage.haskell.org/package/tasty-smallcheck) —+* [tasty-smallcheck](https://hackage.haskell.org/package/tasty-smallcheck) — exhaustive property-based testing- (based on [smallcheck](http://hackage.haskell.org/package/smallcheck))-* [tasty-quickcheck](http://hackage.haskell.org/package/tasty-quickcheck) — for randomized+ (based on [smallcheck](https://hackage.haskell.org/package/smallcheck))+* [tasty-quickcheck](https://hackage.haskell.org/package/tasty-quickcheck) — for randomized property-based testing (based on [QuickCheck](http://hackage.haskell.org/package/QuickCheck))-* [tasty-hspec](http://hackage.haskell.org/package/tasty-hspec) — for- [Hspec](http://hspec.github.io/) tests-* [tasty-program](http://hackage.haskell.org/package/tasty-program) — run+* [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]: http://hackage.haskell.org/package/tasty-golden+[tasty-golden]: https://hackage.haskell.org/package/tasty-golden It's easy to create custom providers using the API from `Test.Tasty.Providers`. @@ -132,29 +136,37 @@ Some ingredients that can enhance your test suite are: -* [tasty-ant-xml](http://hackage.haskell.org/package/tasty-ant-xml) adds a+* [tasty-ant-xml](https://hackage.haskell.org/package/tasty-ant-xml) adds a possibility to write the test results in a machine-readable XML format, which is understood by various CI systems and IDEs-* [tasty-rerun](http://hackage.haskell.org/package/tasty-rerun) adds support for+* [tasty-rerun](https://hackage.haskell.org/package/tasty-rerun) adds support for minimal test reruns by recording previous test runs and using this information to filter the test tree. For example, you can use this ingredient to only run failed tests, or only run tests that threw an exception.-* [tasty-html](http://hackage.haskell.org/package/tasty-html) adds the+* [tasty-html](https://hackage.haskell.org/package/tasty-html) adds the possibility to write the test results as a HTML file-* [tasty-stats](http://hackage.haskell.org/package/tasty-stats) adds the+* [tasty-stats](https://hackage.haskell.org/package/tasty-stats) adds the possibility to collect statistics of the test suite in a CSV file. +### Test discovery++`tasty` by itself forces you to explicitly write out the `TestTree` yourself.+The packages listed below allow you to write tests at the top-level, and will+automatically collect them into a single `TestTree`.++* [tasty-th](https://hackage.haskell.org/package/tasty-th)+* [tasty-discover](https://hackage.haskell.org/package/tasty-discover)+* [tasty-autocollect](https://hackage.haskell.org/package/tasty-autocollect)+ ### Other packages -* [tasty-th](http://hackage.haskell.org/package/tasty-th) automatically-discovers tests based on the function names and generate the boilerplate code for-you-* [tasty-hunit-adapter](http://hackage.haskell.org/package/tasty-hunit-adapter)+* [tasty-hunit-adapter](https://hackage.haskell.org/package/tasty-hunit-adapter) converts existing HUnit test suites into tasty test suites-* [tasty-discover](https://github.com/lwm/tasty-discover) automatically discovers-your tests.-* [tasty-expected-failure](https://github.com/nomeata/tasty-expected-failure) provides+* [tasty-expected-failure](https://hackage.haskell.org/package/tasty-expected-failure) provides test markers for when you expect failures or wish to ignore tests.+* [tasty-bench](https://hackage.haskell.org/package/tasty-bench) covers performance+regression testing and extends `tasty` to a benchmark framework+similar to `criterion` and `gauge`. ## Options@@ -181,44 +193,68 @@ % ./test --help Mmm... tasty test suite -Usage: test [-p|--pattern ARG] [-t|--timeout ARG] [-l|--list-tests]- [-j|--num-threads ARG] [-q|--quiet] [--hide-successes] [--color ARG]- [--quickcheck-tests ARG] [--quickcheck-replay ARG]- [--quickcheck-show-replay ARG] [--quickcheck-max-size ARG]- [--quickcheck-max-ratio ARG] [--quickcheck-verbose]- [--smallcheck-depth ARG]+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 ARG Select only tests that match pattern- -t,--timeout ARG Timeout for individual tests (suffixes: ms,s,m,h;+ -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 ARG Number of threads to use for tests execution+ -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- --color ARG When to use colored output. Options are 'never',- 'always' and 'auto' (default: 'auto')- --quickcheck-tests ARG Number of test cases for QuickCheck to generate- --quickcheck-replay ARG Replay token to use for replaying a previous test run- --quickcheck-show-replay ARG- Show a replay token for replaying tests- --quickcheck-max-size ARG+ --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 ARG- Maximum number of discared tests per successful test+ --quickcheck-max-ratio NUMBER+ Maximum number of discarded tests per successful test before giving up --quickcheck-verbose Show the generated test cases- --smallcheck-depth ARG Depth to use for smallcheck tests+ --quickcheck-shrinks NUMBER+ Number of shrinks allowed before QuickCheck will fail+ a test ``` Every option can be passed via environment. To obtain the environment variable 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`. To turn on a switch (such as-`TASTY_HIDE_SUCCESSES`), set the variable to `True`.+`--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. @@ -251,30 +287,300 @@ ### Patterns -It is possible to restrict the set of executed tests using the `--pattern`-option. The syntax of patterns is the same as for test-framework, namely:+It is possible to restrict the set of executed tests using the `-p/--pattern`+option. -- An optional prefixed bang `!` negates the pattern.-- If the pattern ends with a slash, it is removed for the purpose of- the following description, but it would only find a match with a- test group. In other words, `foo/` will match a group called `foo`- and any tests underneath it, but will not match a regular test- `foo`.-- If the pattern does not contain a slash `/`, the framework checks- for a match against any single component of the path.-- Otherwise, the pattern is treated as a glob, where:- - The wildcard `*` matches anything within a single path component- (i.e. `foo` but not `foo/bar`).- - Two wildcards `**` matches anything (i.e. `foo` and `foo/bar`).- - Anything else matches exactly that text in the path (i.e. `foo`- would only match a component of the test path called `foo` (or a- substring of that form).+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. -For example, `group/*1` matches `group/test1` but not-`group/subgroup/test1`, whereas both examples would be matched by-`group/**1`. A leading slash matches the beginning of the test path; for-example, `/test*` matches `test1` but not `group/test1`.+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 < expr</code></p>+<p><code>expr <= expr</code></p>+<p><code>expr != expr</code></p>+<p><code>expr == expr</code></p>+<p><code>expr > expr</code></p>+<p><code>expr >= 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 && 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:@@ -391,55 +697,184 @@ 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. How do I make some tests execute after others?+1. **Q**: When my tests write to stdout/stderr, the output is garbled. Why is that and+ what do I do? - Currently, your only option is to make all tests execute sequentially by- setting the number of tasty threads to 1 ([example](#num_threads_example)).- See [#48](https://github.com/feuerbach/tasty/issues/48) for the discussion.+ **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](http://yannesposito.com/Scratch/en/blog/Holy-Haskell-Starter/)-* [First time testing, also with FP Complete](http://levischuck.com/posts/2013-11-13-first-testing-and-fpcomplete.html)+* [Holy Haskell Project Starter](https://yannesposito.com/Scratch/en/blog/Holy-Haskell-Starter/)+* [First time testing, also with FP Complete](https://levischuck.com/posts/2013-11-13-first-testing-and-fpcomplete.html) (tasty has been added to stackage since then)-* [24 Days of Hackage: tasty](http://ocharles.org.uk/blog/posts/2013-12-03-24-days-of-hackage-tasty.html)-* [Resources in Tasty](http://ro-che.info/articles/2013-12-10-tasty-resources.html)+* [24 Days of Hackage: tasty](https://ocharles.org.uk/blog/posts/2013-12-03-24-days-of-hackage-tasty.html)+* [Resources in Tasty](https://ro-che.info/articles/2013-12-10-tasty-resources) * [Custom options in Tasty][custom-options-article]-* [Resources in Tasty (update)](http://ro-che.info/articles/2013-12-29-tasty-resources-2.html)-* [Announcing tasty-rerun](http://ocharles.org.uk/blog/posts/2014-01-20-announcing-tasty-rerun.html)-* [Code testing in Haskell revisited (with Tasty)](http://lambda.jstolarek.com/2014/01/code-testing-in-haskell-revisited-with-tasty/)--[custom-options-article]: http://ro-che.info/articles/2013-12-20-tasty-custom-options.html--## Background--Tasty is heavily influenced by [test-framework][].--The problems with test-framework are:+* [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] -* Poor code style (some lines of the code wouldn't even fit in a twitter message!)-* Poor architecture — e.g. relying on laziness for IO and control flow. The- whole story with `:~>` and `ImprovingIO` is really obscure.-* Non-extensible options. For example, when I integrated SmallCheck with- test-framework (in the form of the `test-framework-smallcheck` package), I- still had to submit patches to the main package to make SmallCheck depth- customizable by the user.-* The project is effectively unmaintained.+[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 -So I decided to recreate everything that I liked in test-framework from scratch-in this package.+## GHC version support policy -[test-framework]: http://batterseapower.github.io/test-framework/+We only support the GHC/base versions [from the last 5 years](https://wiki.haskell.org/Base_package#Versions). Maintainers ----------- -[Roman Cheplyaka](https://github.com/feuerbach) is the primary maintainer.+[Roman Cheplyaka](https://github.com/UnkindPartition) is the primary maintainer. [Oliver Charles](https://github.com/ocharles) is the backup maintainer. Please get in touch with him if the primary maintainer cannot be reached.
Test/Tasty.hs view
@@ -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@@ -30,6 +60,10 @@ -- a file or a socket. We want to create or grab the resource before -- the tests are run, and destroy or release afterwards. , withResource+ -- * Dependencies+ , DependencyType(..)+ , after+ , after_ ) where @@ -42,12 +76,14 @@ -- | List of the default ingredients. This is what 'defaultMain' uses. -- -- At the moment it consists of 'listingTests' and 'consoleTestReporter'.+--+-- @since 0.4.2 defaultIngredients :: [Ingredient] defaultIngredients = [listingTests, consoleTestReporter] -- | Parse the command line arguments and run the tests. ----- When the tests finish, this function calls 'exitWith' with the exit code+-- When the tests finish, this function calls 'System.Exit.exitWith' with the exit code -- that indicates whether any tests have failed. Most external systems -- (stack, cabal, travis-ci, jenkins etc.) rely on the exit code to detect -- whether the tests pass. If you want to do something else after@@ -67,25 +103,34 @@ -- > then putStrLn "Yea" -- > else putStrLn "Nay" -- > throwIO e)-+--+-- @since 0.1 defaultMain :: TestTree -> IO () defaultMain = defaultMainWithIngredients defaultIngredients --- | Locally adjust the option value for the given test subtree+-- | Locally adjust the option value for the given test subtree.+--+-- @since 0.1 adjustOption :: IsOption v => (v -> v) -> TestTree -> TestTree adjustOption f = PlusTestOptions $ \opts -> setOption (f $ lookupOption opts) opts --- | Locally set the option value for the given test subtree+-- | Locally set the option value for the given test subtree.+--+-- @since 0.1 localOption :: IsOption v => v -> TestTree -> TestTree localOption v = PlusTestOptions (setOption v) --- | Customize the test tree based on the run-time options+-- | Customize the test tree based on the run-time options.+--+-- @since 0.6 askOption :: IsOption v => (v -> TestTree) -> TestTree askOption f = AskOptions $ f . lookupOption -- | Acquire the resource to run this test (sub)tree and release it--- afterwards+-- afterwards.+--+-- @since 0.5 withResource :: IO a -- ^ initialize the resource -> (a -> IO ()) -- ^ free the resource
Test/Tasty/CmdLine.hs view
@@ -1,71 +1,175 @@ -- | Parsing options supplied on the command line-{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable #-} module Test.Tasty.CmdLine ( optionParser , suiteOptions , suiteOptionParser+ , parseOptions , defaultMainWithIngredients ) where -import Options.Applicative-import Data.Monoid+import Control.Arrow+import Data.Maybe import Data.Proxy-import Data.Foldable (foldMap)-import Prelude -- Silence AMP and FTP import warnings+import Data.Typeable (typeRep)+import Options.Applicative+import Options.Applicative.Common (evalParser)+import qualified Options.Applicative.Types as Applicative (Option(..))+import Options.Applicative.Types (Parser(..), OptProperties(..)) import System.Exit import System.IO---- We install handlers only on UNIX (obviously) and on GHC >= 7.6.--- GHC 7.4 lacks mkWeakThreadId (see #181), and this is not important--- enough to look for an alternative implementation, so we just disable it--- there.-#define INSTALL_HANDLERS defined UNIX && MIN_VERSION_base(4,6,0)--#if INSTALL_HANDLERS-import Control.Concurrent (mkWeakThreadId, myThreadId)-import Control.Exception (Exception(..), throwTo)-import Control.Monad (forM_)-import Data.Typeable (Typeable)-import System.Posix.Signals-import System.Mem.Weak (deRefWeak)+#if !MIN_VERSION_base(4,11,0)+import Data.Monoid+import Data.Foldable (foldMap) #endif import Test.Tasty.Core+import Test.Tasty.Runners.Utils import Test.Tasty.Ingredients import Test.Tasty.Options import Test.Tasty.Options.Env import Test.Tasty.Runners.Reducers +-- | Generate a command line parser from a list of option descriptions,+-- alongside any related warning messages.+--+-- @since 1.3+optionParser :: [OptionDescription] -> ([String], Parser OptionSet)+optionParser = second getApp . foldMap toSet where+ toSet :: OptionDescription -> ([String], Ap Parser OptionSet)+ toSet (Option p) = second+ (\parser -> Ap $ (singleOption <$> parser) <|> pure mempty)+ (finalizeCLParser p optionCLParser) --- | Generate a command line parser from a list of option descriptions-optionParser :: [OptionDescription] -> Parser OptionSet-optionParser = getApp . foldMap toSet where- toSet :: OptionDescription -> Ap Parser OptionSet- toSet (Option (Proxy :: Proxy v)) = Ap $- (singleOption <$> (optionCLParser :: Parser v)) <|> pure mempty+-- Do two things:+--+-- 1. Replace an `optionCLParser`'s 'propShowDefault' with 'showDefaultValue'+-- from the 'IsOption' class.+-- 2. Generate warning messages if the 'optionCLParser' does anything+-- suspicious. Currently, the only suspicious things we check for are+-- (a) if the 'Parser' defines multiple options and, (b) if the 'Parser'+-- assigns a default value outside of 'defaultValue'.+finalizeCLParser :: forall proxy v . IsOption v+ => proxy v -> Parser v -> ([String], Parser v)+finalizeCLParser _ p = (warnings, setCLParserShowDefaultValue mbDef p)+ where+ mbDef :: Maybe String+ mbDef = showDefaultValue (defaultValue :: v) --- | The command line parser for the test suite-suiteOptionParser :: [Ingredient] -> TestTree -> Parser OptionSet+ warnings :: [String]+ warnings = catMaybes [multipleOptPsWarning, badDefaultWarning]++ -- Warn if a Parser defines multiple options, as this breaks an assumption+ -- that setCLParserShowDefaultValue relies on.+ multipleOptPsWarning :: Maybe String+ multipleOptPsWarning+ | numOptPs p > 1+ = Just $ unlines+ [ prov+ , "optionCLParser defines multiple options. Consider only defining"+ , "a single option here, as defining multiple options does not play"+ , "well with how tasty displays default values."+ ]+ | otherwise+ = Nothing++ -- Warning if a Parser has a default value (outside of IsOption's+ -- defaultValue method, that is), as this interferes with tasty's ability+ -- to read arguments from environment variables. For more on this point,+ -- see the Haddocks for optionCLParser.+ badDefaultWarning :: Maybe String+ badDefaultWarning+ -- evalParser will only return Just if has a default value declared with+ -- e.g. the Options.Applicative.value function.+ | isJust (evalParser p)+ = Just $ unlines+ [ prov+ , "Using default values (e.g., with Options.Applicative.value) in"+ , "optionCLParser is prohibited, as it interferes with tasty's ability"+ , "to read environment variable options properly. Moreover, assigning"+ , "default values is unnecessary, as their functionality is subsumed"+ , "by the defaultValue method of IsOption."+ ]+ | otherwise+ = Nothing++ prov :: String+ prov = "WARNING (in the IsOption instance for "+ ++ show (typeRep (Proxy :: Proxy v)) ++ "):"++-- Replace an `optionCLParser`'s 'propShowDefault' with 'showDefaultValue' from+-- the 'IsOption' class. It's tempting to try doing this when constructing the+-- 'Parser' itself using 'optionMod', but @optparse-applicative@'s 'mkParser'+-- function always overrides the result of 'optionMod'. Ugh.+setCLParserShowDefaultValue :: Maybe String -> Parser a -> Parser a+setCLParserShowDefaultValue mbDef = go+ where+ go :: Parser a -> Parser a+ -- Note that we /always/ replace the Option's optProps, regardless of+ -- what type it may have. This can produce unexpected results if an+ -- optionCLParser defines multiple options, which is why we emit a warning+ -- (in finalizeCLParser) if a Parser does this.+ go (OptP o) = OptP o{Applicative.optProps =+ modifyDefault (Applicative.optProps o)}+ go p@NilP{} = p+ go (MultP p1 p2) = MultP (go p1) (go p2)+ go (AltP p1 p2) = AltP (go p1) (go p2)+ go (BindP p1 p2) = BindP (go p1) (fmap go p2)++ modifyDefault :: OptProperties -> OptProperties+ modifyDefault op = op{propShowDefault = mbDef}++-- Note: this is a conservative estimate, since we cannot count the number+-- of OptPs in the continuation argument of BindP. But BindP is really only+-- used for ParserM purposes, and since ParserM is an internal+-- optparse-applicative definition, most optionCLParser instances are+-- unlikely to use it in practice.+numOptPs :: Parser a -> Int+numOptPs OptP{} = 1+numOptPs NilP{} = 0+numOptPs (MultP p1 p2) = numOptPs p1 + numOptPs p2+numOptPs (AltP p1 p2) = numOptPs p1 + numOptPs p2+numOptPs (BindP p1 _p2) = numOptPs p1++-- | The command line parser for the test suite, alongside any related+-- warnings.+--+-- @since 1.3+suiteOptionParser :: [Ingredient] -> TestTree -> ([String], Parser OptionSet) suiteOptionParser ins tree = optionParser $ suiteOptions ins tree +-- | Parse the command-line and environment options passed to tasty.+--+-- Useful if you need to get the options before 'Test.Tasty.defaultMain' is called.+--+-- Once within the test tree, 'Test.Tasty.askOption' should be used instead.+--+-- The arguments to this function should be the same as for+-- 'defaultMainWithIngredients'. If you don't use any custom ingredients,+-- pass 'Test.Tasty.defaultIngredients'.+--+-- @since 1.2.2+parseOptions :: [Ingredient] -> TestTree -> IO OptionSet+parseOptions ins tree = do+ let (warnings, parser) = suiteOptionParser ins tree+ mapM_ (hPutStrLn stderr) warnings+ cmdlineOpts <- execParser $+ info (helper <*> parser)+ (header "Mmm... tasty test suite")+ envOpts <- suiteEnvOptions ins tree+ return $ envOpts <> cmdlineOpts+ -- | Parse the command line arguments and run the tests using the provided -- ingredient list. ----- When the tests finish, this function calls 'exitWith' with the exit code--- that indicates whether any tests have failed. See 'defaultMain' for+-- When the tests finish, this function calls 'System.Exit.exitWith' with the exit code+-- that indicates whether any tests have failed. See 'Test.Tasty.defaultMain' for -- details.+--+-- @since 0.4 defaultMainWithIngredients :: [Ingredient] -> TestTree -> IO () defaultMainWithIngredients ins testTree = do installSignalHandlers- cmdlineOpts <- execParser $- info (helper <*> suiteOptionParser ins testTree)- ( fullDesc <>- header "Mmm... tasty test suite"- )-- envOpts <- suiteEnvOptions ins testTree-- let opts = envOpts <> cmdlineOpts+ opts <- parseOptions ins testTree case tryIngredients ins opts testTree of Nothing -> do@@ -75,28 +179,3 @@ Just act -> do ok <- act if ok then exitSuccess else exitFailure---- from https://ro-che.info/articles/2014-07-30-bracket--- Install a signal handler so that e.g. the cursor is restored if the test--- suite is killed by SIGTERM.-installSignalHandlers :: IO ()-installSignalHandlers = do-#if INSTALL_HANDLERS- main_thread_id <- myThreadId- weak_tid <- mkWeakThreadId main_thread_id- forM_ [ sigABRT, sigBUS, sigFPE, sigHUP, sigILL, sigQUIT, sigSEGV,- sigSYS, sigTERM, sigUSR1, sigUSR2, sigXCPU, sigXFSZ ] $ \sig ->- installHandler sig (Catch $ send_exception weak_tid sig) Nothing- where- send_exception weak_tid sig = do- m <- deRefWeak weak_tid- case m of- Nothing -> return ()- Just tid -> throwTo tid (toException $ SignalException sig)--newtype SignalException = SignalException Signal- deriving (Show, Typeable)-instance Exception SignalException-#else- return ()-#endif
Test/Tasty/Core.hs view
@@ -1,22 +1,70 @@ -- | Core types and definitions-{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts,- ExistentialQuantification, RankNTypes, DeriveDataTypeable,- DeriveGeneric #-}-module Test.Tasty.Core where+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}+module Test.Tasty.Core+ ( FailureReason(..)+ , Outcome(..)+ , Time+ , Result(..)+ , resultSuccessful+ , exceptionResult+ , Progress(..)+ , emptyProgress+ , IsTest(..)+ , TestName+ , ResourceSpec(..)+ , ResourceError(..)+ , DependencyType(..)+ , ExecutionMode(..)+ , Parallel(..)+ , TestTree(..)+ , testGroup+ , sequentialTestGroup+ , dependentTestGroup+ , inOrderTestGroup+ , after+ , after_+ , TreeFold(..)+ , trivialFold+ , foldTestTree+ , foldTestTree0+ , treeOptions+ , testFailed+ ) where import Control.Exception-import Test.Tasty.Options-import Test.Tasty.Patterns-import 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 Prelude -- Silence AMP and FTP import warnings+import Options.Applicative (internal)+import Test.Tasty.Options+import Test.Tasty.Patterns+import Test.Tasty.Patterns.Types+import Test.Tasty.Providers.ConsoleFormat import Text.Printf+import Text.Read (readMaybe) --- | If a test failed, 'FailureReason' describes why+#if MIN_VERSION_base(4,21,0) && !MIN_VERSION_base(4,22,0)+import Control.Exception.Context+#endif++-- | If a test failed, 'FailureReason' describes why.+--+-- @since 0.8 data FailureReason = TestFailed -- ^ test provider indicated failure of the code to test, either because@@ -29,21 +77,31 @@ -- 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+-- | A test result.+--+-- @since 0.1 data Result = Result { resultOutcome :: Outcome -- ^ Did the test fail? If so, why?@@ -56,33 +114,90 @@ -- -- For a failed test, 'resultDescription' should typically provide more -- information about the failure.+ --+ -- @since 0.11 , resultShortDescription :: String -- ^ The short description printed in the test run summary, usually @OK@ or -- @FAIL@.+ --+ -- @since 0.10 , resultTime :: Time -- ^ How long it took to run the test, in seconds.+ , resultDetailsPrinter :: ResultDetailsPrinter+ -- ^ An action that prints additional information about a test.+ --+ -- This is similar to 'resultDescription' except it can produce+ -- colorful/formatted output; see "Test.Tasty.Providers.ConsoleFormat".+ --+ -- This can be used instead of or in addition to 'resultDescription'.+ --+ -- Usually this is set to 'noResultDetails', which does nothing.+ --+ -- @since 1.3.1 }+ deriving+ ( Show -- ^ @since 1.2+ ) +{- Note [Skipped tests]+ ~~~~~~~~~~~~~~~~~~~~+ There are two potential ways to represent the tests that are skipped+ because of their failed dependencies:+ 1. With Outcome = Failure, and FailureReason giving the specifics (TestDepFailed)+ 2. With a dedicated Outcome = Skipped++ It seems to me that (1) will lead to fewer bugs (esp. in the extension packages),+ because most of the time skipped tests should be handled in the same way+ as failed tests.+ But sometimes it is not obvious what the right behavior should be. E.g.+ should --hide-successes show or hide the skipped tests?++ Perhaps we should hide them, because they aren't really informative.+ Or perhaps we shouldn't hide them, because we are not sure that they+ will pass, and hiding them will imply a false sense of security+ ("there's at most 2 tests failing", whereas in fact there could be much more).++ So I might change this in the future, but for now treating them as+ failures seems the easiest yet reasonable approach.+-}+ -- | 'True' for a passed test, 'False' for a failed one.+--+-- @since 0.8 resultSuccessful :: Result -> Bool resultSuccessful r = case resultOutcome r of Success -> True Failure {} -> False --- | Shortcut for creating a 'Result' that indicates exception+-- | Shortcut for creating a t'Result' that indicates exception exceptionResult :: SomeException -> Result exceptionResult e = Result { resultOutcome = Failure $ TestThrewException e- , resultDescription = "Exception: " ++ show e+ , resultDescription = "Exception: " ++ displayException' e , resultShortDescription = "FAIL" , resultTime = 0+ , resultDetailsPrinter = noResultDetails } +displayException' :: SomeException -> String+#if MIN_VERSION_base(4,22,0)+displayException' = displayExceptionWithInfo+#elif MIN_VERSION_base(4,21,0)+displayException' (SomeException e) =+ displayException e ++ case displayExceptionContext ?exceptionContext of+ "" -> ""+ dc -> "\n\n" ++ dc+#else+displayException' = displayException+#endif+ -- | Test progress information. -- -- This may be used by a runner to provide some feedback to the user while -- a long-running test is executing.+--+-- @since 0.1 data Progress = Progress { progressText :: String -- ^ textual information about the test's progress@@ -91,33 +206,80 @@ -- 'progressPercent' should be a value between 0 and 1. If it's impossible -- to compute the estimate, use 0. }+ deriving+ ( Show -- ^ @since 1.2+ , Eq -- ^ @since 1.5+ ) +-- | Empty progress+--+-- @since 1.5+emptyProgress :: Progress+emptyProgress = Progress mempty 0.0+ -- | The interface to be implemented by a test provider. -- -- The type @t@ is the concrete representation of the test which is used by -- the provider.+--+-- @since 0.1 class Typeable t => IsTest t where -- | Run the test -- -- This method should cleanly catch any exceptions in the code to test, and- -- return them as part of the 'Result', see 'FailureReason' for an+ -- return them as part of the t'Result', see 'FailureReason' for an -- explanation. It is ok for 'run' to raise an exception if there is a -- problem with the test suite code itself (for example, if a file that -- should contain example data or expected output is not found). 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@@ -125,7 +287,6 @@ = NotRunningTests | UnexpectedState String String | UseOutsideOfTest- deriving Typeable instance Show ResourceError where show NotRunningTests =@@ -138,6 +299,49 @@ instance Exception ResourceError +-- | These are the two ways in which one test may depend on the others.+--+-- This is the same distinction as the+-- <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@@ -148,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@@ -160,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@@ -189,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@@ -211,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@@ -223,21 +589,128 @@ -> TestTree -- ^ the tree to fold -> b-foldTestTree (TreeFold fTest fGroup fResource) opts tree =- let pat = lookupOption opts- in go pat [] opts tree+foldTestTree = foldTestTree0 mempty++-- | Like 'foldTestTree', but with a custom (non-Monoid) empty value. Unlike+-- 'foldTestTree', it is not part of the public API.+foldTestTree0+ :: forall b+ . b+ -- ^ "empty" value+ -> TreeFold b+ -- ^ the algebra (i.e. how to fold a tree)+ -> OptionSet+ -- ^ initial options+ -> TestTree+ -- ^ the tree to fold+ -> b+foldTestTree0 empty (TreeFold fTest fGroup fResource fAfter) opts0 tree0 =+ go (filterByPattern (annotatePath (evaluateOptions opts0 tree0))) where- go pat path opts tree =- case tree of- SingleTest name test- | testPatternMatches pat (path ++ [name])- -> fTest opts name test- | otherwise -> mempty- TestGroup name trees ->- fGroup name $ foldMap (go pat (path ++ [name]) opts) trees- PlusTestOptions f tree -> go pat path (f opts) tree- WithResource res tree -> fResource res $ \res -> go pat path opts (tree res)- AskOptions f -> go pat path opts (f opts)+ go :: AnnTestTree OptionSet -> b+ go = \case+ AnnEmptyTestTree -> empty+ AnnSingleTest opts name test -> fTest opts name test+ AnnTestGroup opts name trees -> fGroup opts name (map go trees)+ AnnWithResource opts res0 tree -> fResource opts res0 $ \res -> go (tree res)+ AnnAfter opts deptype dep tree -> fAfter opts deptype dep (go tree)++-- | 'TestTree' with arbitrary annotations, e. g., evaluated t'OptionSet'.+data AnnTestTree ann+ = AnnEmptyTestTree+ -- ^ Just an empty test tree (e. g., when everything has been filtered out).+ | forall t . IsTest t => AnnSingleTest ann TestName t+ -- ^ Annotated counterpart of 'SingleTest'.+ | AnnTestGroup ann TestName [AnnTestTree ann]+ -- ^ Annotated counterpart of 'TestGroup'.+ | forall a . AnnWithResource ann (ResourceSpec a) (IO a -> AnnTestTree ann)+ -- ^ Annotated counterpart of 'WithResource'.+ | AnnAfter ann DependencyType Expr (AnnTestTree ann)+ -- ^ Annotated counterpart of 'After'.++-- | Annotate 'TestTree' with options, removing 'PlusTestOptions' and 'AskOptions' nodes.+evaluateOptions :: OptionSet -> TestTree -> AnnTestTree OptionSet+evaluateOptions opts = \case+ SingleTest name test ->+ AnnSingleTest opts name test+ TestGroup name trees ->+ AnnTestGroup opts name $ map (evaluateOptions opts) trees+ PlusTestOptions f tree ->+ evaluateOptions (f opts) tree+ WithResource res0 tree ->+ AnnWithResource opts res0 $ \res -> evaluateOptions opts (tree res)+ AskOptions f ->+ evaluateOptions opts (f opts)+ After deptype dep tree ->+ AnnAfter opts deptype dep $ evaluateOptions opts tree++-- | Annotate 'AnnTestTree' with paths.+annotatePath :: AnnTestTree OptionSet -> AnnTestTree (OptionSet, Path)+annotatePath = go mempty+ where+ go :: Seq.Seq TestName -> AnnTestTree OptionSet -> AnnTestTree (OptionSet, Path)+ go path = \case+ AnnEmptyTestTree -> AnnEmptyTestTree+ AnnSingleTest opts name tree ->+ AnnSingleTest (opts, path |> name) name tree+ AnnTestGroup opts name trees ->+ let newPath = path |> name in+ AnnTestGroup (opts, newPath) name (map (go newPath) trees)+ AnnWithResource opts res0 tree ->+ AnnWithResource (opts, path) res0 $ \res -> go path (tree res)+ AnnAfter opts deptype dep tree ->+ AnnAfter (opts, path) deptype dep (go path tree)++-- | Filter test tree by pattern, replacing leafs with 'AnnEmptyTestTree'.+filterByPattern :: AnnTestTree (OptionSet, Path) -> AnnTestTree OptionSet+filterByPattern = snd . go (Any False)+ where+ mkGroup opts name xs = case filter isNonEmpty xs of+ [] -> AnnEmptyTestTree+ ys -> AnnTestGroup opts name ys++ isNonEmpty = \case+ AnnEmptyTestTree -> False+ _ -> True++ go+ :: ForceTestMatch+ -> AnnTestTree (OptionSet, Path)+ -> (TestMatched, AnnTestTree OptionSet)+ go forceMatch = \case+ AnnEmptyTestTree ->+ (Any False, AnnEmptyTestTree)++ AnnSingleTest (opts, path) name tree+ | getAny forceMatch || testPatternMatches (lookupOption opts) path+ -> (Any True, AnnSingleTest opts name tree)+ | otherwise+ -> (Any False, AnnEmptyTestTree)++ AnnTestGroup _ _ [] ->+ (forceMatch, AnnEmptyTestTree)++ AnnTestGroup (opts, _) name trees ->+ case lookupOption opts of+ Dependent _ ->+ second+ (mkGroup opts name)+ (mapAccumR go forceMatch trees)+ Independent _ ->+ bimap+ mconcat+ (mkGroup opts name)+ (unzip (map (go forceMatch) trees))++ AnnWithResource (opts, _) res0 tree ->+ ( fst (go forceMatch (tree (throwIO NotRunningTests)))+ , AnnWithResource opts res0 $ \res -> snd (go forceMatch (tree res))+ )++ AnnAfter (opts, _) deptype dep tree ->+ second+ (AnnAfter opts deptype dep)+ (go forceMatch tree) -- | Get the list of options that are relevant for a given test tree treeOptions :: TestTree -> [OptionDescription]
Test/Tasty/Ingredients.hs view
@@ -2,6 +2,8 @@ -- -- Ingredients themselves are provided by other modules (usually under -- the @Test.Tasty.Ingredients.*@ hierarchy).+--+-- @since 0.8 module Test.Tasty.Ingredients ( Ingredient(..) , tryIngredients@@ -34,7 +36,7 @@ -- which options it cares about, so that those options are presented to -- the user if the ingredient is included in the test suite. ----- An ingredient can choose, typically based on the 'OptionSet', whether to+-- An ingredient can choose, typically based on the t'OptionSet', whether to -- run. That's what the 'Maybe' is for. The first ingredient that agreed to -- run does its work, and the remaining ingredients are ignored. Thus, the -- order in which you arrange the ingredients may matter.@@ -68,23 +70,30 @@ -- what the result should be. When no tests are run, the result should -- probably be 'True'. Sometimes, even if some tests run and fail, it still -- makes sense to return 'True'.+--+-- @since 0.4 data Ingredient = TestReporter [OptionDescription] (OptionSet -> TestTree -> Maybe (StatusMap -> IO (Time -> IO Bool))) -- ^ For the explanation on how the callback works, see the -- documentation for 'launchTestTree'.+ --+ -- @since 0.10 | TestManager [OptionDescription] (OptionSet -> TestTree -> Maybe (IO Bool))+ -- ^ @since 0.4 -- | Try to run an 'Ingredient'. ----- If the ingredient refuses to run (usually based on the 'OptionSet'),+-- If the ingredient refuses to run (usually based on the t'OptionSet'), -- the function returns 'Nothing'. -- -- For a 'TestReporter', this function automatically starts running the -- tests in the background.+--+-- This function is not publicly exposed. tryIngredient :: Ingredient -> OptionSet -> TestTree -> Maybe (IO Bool) tryIngredient (TestReporter _ report) opts testTree = do -- Maybe monad reportFn <- report opts testTree@@ -96,28 +105,38 @@ -- -- If no one accepts the task, return 'Nothing'. This is usually a sign of -- misconfiguration.+--+-- @since 0.4 tryIngredients :: [Ingredient] -> OptionSet -> TestTree -> Maybe (IO Bool)-tryIngredients ins opts tree =+tryIngredients ins opts' tree' = msum $ map (\i -> tryIngredient i opts tree) ins+ where+ (opts, tree) = applyTopLevelPlusTestOptions opts' tree' -- | Return the options which are relevant for the given ingredient. -- -- Note that this isn't the same as simply pattern-matching on -- 'Ingredient'. E.g. options for a 'TestReporter' automatically include--- 'NumThreads'.+-- t'NumThreads'.+--+-- @since 0.4 ingredientOptions :: Ingredient -> [OptionDescription] ingredientOptions (TestReporter opts _) = Option (Proxy :: Proxy NumThreads) : opts ingredientOptions (TestManager opts _) = opts --- | Like 'ingredientOption', but folds over multiple ingredients.+-- | Like 'ingredientOptions', but folds over multiple ingredients.+--+-- @since 0.4 ingredientsOptions :: [Ingredient] -> [OptionDescription]-ingredientsOptions = F.foldMap ingredientOptions+ingredientsOptions = uniqueOptionDescriptions . F.foldMap ingredientOptions -- | All the options relevant for this test suite. This includes the -- options for the test tree and ingredients, and the core options.+--+-- @since 0.4 suiteOptions :: [Ingredient] -> TestTree -> [OptionDescription]-suiteOptions ins tree =+suiteOptions ins tree = uniqueOptionDescriptions $ coreOptions ++ ingredientsOptions ins ++ treeOptions tree@@ -129,6 +148,8 @@ -- -- Be aware that it is not possible to use 'composeReporters' with a 'TestManager', -- it only works for 'TestReporter' ingredients.+--+-- @since 0.11.2 composeReporters :: Ingredient -> Ingredient -> Ingredient composeReporters (TestReporter o1 f1) (TestReporter o2 f2) = TestReporter (o1 ++ o2) $ \o t ->
Test/Tasty/Ingredients/Basic.hs view
@@ -1,14 +1,17 @@--- | This module exports the basic ingredients defined in the 'tasty'+-- | This module exports the basic ingredients defined in the @tasty@ -- packages. ----- Note that if @defaultIngredients@ from "Test.Tasty" suits your needs,+-- Note that if 'Test.Tasty.defaultIngredients' from "Test.Tasty" suits your needs, -- use that instead of importing this module.+--+-- @since 0.8 module Test.Tasty.Ingredients.Basic ( -- ** Console test reporter consoleTestReporter , Quiet(..) , HideSuccesses(..)+ , AnsiTricks(..) -- ** Listing tests , listingTests , ListTests(..)
Test/Tasty/Ingredients/ConsoleReporter.hs view
@@ -1,10 +1,15 @@--- vim:fdm=marker:foldtext=foldtext()-{-# LANGUAGE BangPatterns, ImplicitParams, MultiParamTypeClasses, DeriveDataTypeable, FlexibleContexts #-}--- | Console reporter ingredient+-- vim:fdm=marker+{-# LANGUAGE BangPatterns, ImplicitParams, MultiParamTypeClasses, FlexibleContexts, CApiFFI, NamedFieldPuns #-}+-- | Console reporter ingredient.+--+-- @since 0.11.3 module Test.Tasty.Ingredients.ConsoleReporter ( consoleTestReporter+ , consoleTestReporterWithHook , Quiet(..) , HideSuccesses(..)+ , MinDurationToReport(..)+ , AnsiTricks(..) -- * Internals -- | The following functions and datatypes are internals that are exposed to -- simplify the task of rolling your own custom console reporter UI.@@ -14,38 +19,54 @@ , useColor -- ** Test failure statistics , Statistics(..)+ , computeStatistics , printStatistics+ , printStatisticsNoTime -- ** Outputting results , TestOutput(..) , buildTestOutput , foldTestOutput+ , withConsoleFormat ) where -import Control.Monad.State hiding (fail)-import Control.Monad.Reader hiding (fail,reader)+import Prelude hiding (fail, EQ)+import Control.Monad (join, unless, void, when, (<=<))+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (Reader, runReader, ask)+import Control.Monad.Trans.State (evalState, evalStateT, get, modify, put) import Control.Concurrent.STM import Control.Exception-import Control.Applicative import Test.Tasty.Core+import Test.Tasty.Providers.ConsoleFormat import Test.Tasty.Run import Test.Tasty.Ingredients+import Test.Tasty.Ingredients.ListTests import Test.Tasty.Options import Test.Tasty.Options.Core+import Test.Tasty.Patterns+import Test.Tasty.Patterns.Printer+import Test.Tasty.Patterns.Types import Test.Tasty.Runners.Reducers import Test.Tasty.Runners.Utils import Text.Printf import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet import Data.Char+#ifdef USE_WCWIDTH+import Foreign.C.Types (CInt(..), CWchar(..))+#endif+import Data.List (isInfixOf) import Data.Maybe-import Data.Monoid-import Data.Proxy-import Data.Tagged+import Data.Monoid (Any(..))+import qualified Data.Semigroup as Sem import Data.Typeable-import Data.Foldable hiding (concatMap,elem,sequence_)-import Options.Applicative-import Prelude hiding (fail) -- Silence AMP and FTP import warnings+import Options.Applicative hiding (action, str, Success, Failure) import System.IO import System.Console.ANSI+#if !MIN_VERSION_base(4,11,0)+import Data.Foldable (foldMap)+#endif+import System.IO.Unsafe -------------------------------------------------- -- TestOutput base definitions@@ -55,28 +76,77 @@ -- printing. It lets us have several different printing modes (normal; print -- failures only; quiet). ----- @since 0.11.3+-- @since 0.12 data TestOutput- = PrintTest- {- print test name -} (IO ())- {- print test result -} (Result -> IO ())- -- ^ Action that prints the test name and an action that renders the- -- result of the action.- | PrintHeading (IO ()) TestOutput- -- ^ Action that prints the heading of a test group and the 'TestOutput'- -- for that test group.- | Skip -- ^ Inactive test (e.g. not matching the current pattern)- | Seq TestOutput TestOutput -- ^ Two sets of 'TestOuput' on the same level+ = -- | Printing a test.+ PrintTest+ String+ -- ^ Name of the test.+ (IO ())+ -- ^ Action that prints the test name.+ (Progress -> IO ())+ -- ^ Action that prints the progress of the test. /Since: 1.5/+ (Result -> IO ())+ -- ^ Action that renders the result of the test.+ | -- | Printing a test group.+ PrintHeading+ String+ -- ^ Name of the test group+ (IO ())+ -- ^ Action that prints the heading of a test group.+ TestOutput+ -- ^ The 'TestOutput' for that test group.+ | -- | Inactive test (e.g. not matching the current pattern).+ Skip+ | -- | Two sets of 'TestOutput' on the same level.+ Seq TestOutput TestOutput -- The monoid laws should hold observationally w.r.t. the semantics defined--- in this module+-- in this module.+--+-- @since 0.12.0.1+instance Sem.Semigroup TestOutput where+ (<>) = Seq instance Monoid TestOutput where mempty = Skip- mappend = Seq+#if !MIN_VERSION_base(4,11,0)+ mappend = (Sem.<>)+#endif +applyHook :: ([TestName] -> Result -> IO Result) -> TestOutput -> TestOutput+applyHook hook = go []+ where+ go path (PrintTest name printName printProgress printResult) =+ PrintTest name printName printProgress (printResult <=< hook (name : path))+ go path (PrintHeading name printName printBody) =+ PrintHeading name printName (go (name : path) printBody)+ go path (Seq a b) = Seq (go path a) (go path b)+ go _ Skip = mempty+ type Level = Int --- | Build the 'TestOutput' for a 'TestTree' and 'OptionSet'. The @colors@+-- TODO before the next major release:+-- refactor this as an argument to 'buildTestOutput'+-- to avoid unsafePerformIO.+-- (We cannot add another argument to 'buildTestOutput'+-- in the middle of tasty-1.5 series, because it is exported)+terminalWidth :: Maybe Int+terminalWidth = unsafePerformIO $ do+ isTerminalStdin <- hIsTerminalDevice stdin+ if isTerminalStdin+ then fmap (fmap snd) getTerminalSize+ else pure Nothing+{-# NOINLINE terminalWidth #-}++-- | How wide could 'resultShortDescription' be (in non-extreme scenarios)?+-- Think of something like "OK", "FAIL (12.34s)", "TIMEOUT (100.00s)".+--+-- The field is freeform and test providers can put an arbitrarily long data,+-- so we just settle for a reasonable (over)approximation.+approxMaxResultShortDescriptionWidth :: Int+approxMaxResultShortDescriptionWidth = 20++-- | Build the 'TestOutput' for a 'TestTree' and t'OptionSet'. The @colors@ -- ImplicitParam controls whether the output is colored. -- -- @since 0.11.3@@ -84,8 +154,13 @@ buildTestOutput opts tree = let -- Do not retain the reference to the tree more than necessary- !alignment = computeAlignment opts tree+ !rawAlignment = computeAlignment opts tree+ !alignment = case terminalWidth of+ Nothing -> rawAlignment+ Just width -> min (width - approxMaxResultShortDescriptionWidth) rawAlignment + MinDurationToReport{minDurationMicros} = lookupOption opts+ runSingleTest :: (IsTest t, ?colors :: Bool) => OptionSet -> TestName -> t -> Ap (Reader Level) TestOutput@@ -93,40 +168,78 @@ level <- ask let+ indentedNameWidth = indentSize * level + stringWidth name+ postNamePadding = alignment - indentedNameWidth++ testNamePadded = printf "%s%s: %s"+ (indent level)+ name+ (replicate postNamePadding ' ')+ printTestName = do- printf "%s%s: %s" (indent level) name- (replicate (alignment - indentSize * level - length name) ' ')+ withoutLineWrap $ putStr testNamePadded hFlush stdout + printTestProgress progress+ -- We cannot display progress properly if a terminal+ -- does not support manipulations with cursor position.+ | not getAnsiTricks = pure ()++ | progress == emptyProgress = pure ()++ | otherwise = do+ let+ msg = case (cleanupProgressText $ progressText progress, 100 * progressPercent progress) of+ ("", pct) -> printf "%.0f%% " pct+ (txt, 0.0) -> printf "%s" txt+ (txt, pct) -> printf "%s: %.0f%% " txt pct+ putChar '\r'+ -- A new progress message may be shorter than the previous one+ -- so we must clean whole line and print anew.+ clearLine+ withoutLineWrap $ do+ putStr testNamePadded+ infoOk msg+ hFlush stdout+ printTestResult result = do rDesc <- formatMessage $ resultDescription result -- use an appropriate printing function let printFn =- if resultSuccessful result- then ok- else fail+ 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)- -- print time only if it's significant- when (time >= 0.01) $+ when (floor (time * 1e6) >= minDurationMicros) $ printFn (printf " (%.2fs)" time) printFn "\n" when (not $ null rDesc) $ (if resultSuccessful result then infoOk else infoFail) $ printf "%s%s\n" (indent $ level + 1) (formatDesc (level+1) rDesc)+ case resultDetailsPrinter result of+ ResultDetailsPrinter action -> action level withConsoleFormat - return $ PrintTest printTestName printTestResult+ return $ PrintTest name printTestName printTestProgress printTestResult - runGroup :: TestName -> Ap (Reader Level) TestOutput -> Ap (Reader Level) TestOutput- runGroup name grp = Ap $ do+ runGroup :: OptionSet -> TestName -> [Ap (Reader Level) TestOutput] -> Ap (Reader Level) TestOutput+ runGroup _opts name grp = Ap $ do level <- ask let- printHeading = printf "%s%s\n" (indent level) name- printBody = runReader (getApp grp) (level + 1)- return $ PrintHeading printHeading printBody+ printHeading = withoutLineWrap $ printf "%s%s\n" (indent level) name+ printBody = runReader (getApp (mconcat grp)) (level + 1)+ return $ PrintHeading name printHeading printBody in flip runReader 0 $ getApp $@@ -136,17 +249,36 @@ , 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.11.3+-- @since 0.12 foldTestOutput :: Monoid b- => (IO () -> IO Result -> (Result -> IO ()) -> b)+ => (String -> IO () -> IO Result -> (Result -> IO ()) -> b) -- ^ Eliminator for test cases. The @IO ()@ prints the testname. The- -- @IO Result@ blocks until the test is finished, returning it's 'Result'.+ -- @IO Result@ blocks until the test is finished, returning it's t'Result'. -- The @Result -> IO ()@ function prints the formatted output.- -> (IO () -> b -> b)+ -> (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.@@ -154,17 +286,19 @@ -> b foldTestOutput foldTest foldHeading outputTree smap = flip evalState 0 $ getApp $ go outputTree where- go (PrintTest printName printResult) = Ap $ do++ go (PrintTest name printName printProgress printResult) = Ap $ do ix <- get put $! ix + 1 let statusVar = fromMaybe (error "internal error: index out of bounds") $ IntMap.lookup ix smap- readStatusVar = getResultFromTVar statusVar- return $ foldTest printName readStatusVar printResult- go (PrintHeading printName printBody) = Ap $- foldHeading printName <$> getApp (go printBody)++ return $ foldTest name printName (ppProgressOrResult statusVar printProgress) printResult++ go (PrintHeading name printName printBody) = Ap $+ foldHeading name printName <$> getApp (go printBody) go (Seq a b) = mappend (go a) (go b) go Skip = mempty @@ -173,38 +307,53 @@ -------------------------------------------------- -- TestOutput modes --------------------------------------------------++ppProgressOrResult :: TVar Status -> (Progress -> IO ()) -> IO Result+ppProgressOrResult statusVar ppProgress = go emptyProgress where+ go old_p = either (\p -> ppProgress p *> go p) return =<< (atomically $ do+ status <- readTVar statusVar+ case status of+ Executing p+ | p == old_p -> retry+ | otherwise -> pure $ Left p+ Done r -> pure $ Right r+ _ -> retry+ )+ -- {{{ consoleOutput :: (?colors :: Bool) => TestOutput -> StatusMap -> IO ()-consoleOutput output smap =- getTraversal . fst $ foldTestOutput foldTest foldHeading output smap+consoleOutput toutput smap =+ getTraversal . fst $ foldTestOutput foldTest foldHeading toutput smap where- foldTest printName getResult printResult =+ foldTest _name printName getResult printResult = ( Traversal $ do- printName+ printName :: IO () r <- getResult printResult r , Any True)- foldHeading printHeading (printBody, Any nonempty) =+ foldHeading _name printHeading (printBody, Any nonempty) = ( Traversal $ do- when nonempty $ do printHeading; getTraversal printBody+ when nonempty $ do+ printHeading :: IO ()+ getTraversal printBody , Any nonempty ) consoleOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> IO ()-consoleOutputHidingSuccesses output smap =- void . getApp $ foldTestOutput foldTest foldHeading output smap+consoleOutputHidingSuccesses toutput smap =+ void . getApp $ foldTestOutput foldTest foldHeading toutput smap where- foldTest printName getResult printResult =+ foldTest _name printName getResult printResult = Ap $ do- printName+ printName :: IO () r <- getResult if resultSuccessful r then do clearThisLine; return $ Any False- else do printResult r; return $ Any True+ else do printResult r :: IO (); return $ Any True - foldHeading printHeading printBody =+ foldHeading _name printHeading printBody = Ap $ do- printHeading+ printHeading :: IO () Any failed <- getApp printBody unless failed clearAboveLine return $ Any failed@@ -213,11 +362,11 @@ clearThisLine = do clearLine; setCursorColumn 0 streamOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> IO ()-streamOutputHidingSuccesses output smap =+streamOutputHidingSuccesses toutput smap = void . flip evalStateT [] . getApp $- foldTestOutput foldTest foldHeading output smap+ foldTestOutput foldTest foldHeading toutput smap where- foldTest printName getResult printResult =+ foldTest _name printName getResult printResult = Ap $ do r <- liftIO $ getResult if resultSuccessful r@@ -228,12 +377,12 @@ liftIO $ do sequence_ $ reverse stack- printName- printResult r+ printName :: IO ()+ printResult r :: IO () return $ Any True - foldHeading printHeading printBody =+ foldHeading _name printHeading printBody = Ap $ do modify (printHeading :) Any failed <- getApp printBody@@ -262,15 +411,30 @@ , statFailures :: !Int -- ^ Number of active tests that failed. } +-- | @since 0.12.0.1+instance Sem.Semigroup Statistics where+ Statistics t1 f1 <> Statistics t2 f2 = Statistics (t1 + t2) (f1 + f2) instance Monoid Statistics where- Statistics t1 f1 `mappend` Statistics t2 f2 = Statistics (t1 + t2) (f1 + f2) mempty = Statistics 0 0+#if !MIN_VERSION_base(4,11,0)+ mappend = (Sem.<>)+#endif +-- | @computeStatistics@ computes a summary t'Statistics' for+-- a given state of the 'StatusMap'.+-- Useful in combination with 'printStatistics'.+--+-- @since 1.2.3 computeStatistics :: StatusMap -> IO Statistics computeStatistics = getApp . foldMap (\var -> Ap $ (\r -> Statistics 1 (if resultSuccessful r then 0 else 1)) <$> getResultFromTVar var) +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@@ -280,13 +444,17 @@ printStatistics :: (?colors :: Bool) => Statistics -> Time -> IO () printStatistics st time = do printf "\n"-+ reportStatistics st case statFailures st of- 0 -> do- ok $ printf "All %d tests passed (%.2fs)\n" (statTotal st) time+ 0 -> ok $ printf " (%.2fs)\n" time+ _ -> fail $ printf " (%.2fs)\n" time - fs -> do- fail $ printf "%d out of %d tests failed (%.2fs)\n" fs (statTotal st) 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 --@@ -305,8 +473,8 @@ where f :: Int -> TVar Status- -> (IntMap.IntMap () -> Int -> STM (IO Bool))- -> (IntMap.IntMap () -> Int -> STM (IO Bool))+ -> (IntSet.IntSet -> Int -> STM (IO Bool))+ -> (IntSet.IntSet -> Int -> STM (IO Bool)) -- ok_tests is a set of tests that completed successfully -- lookahead is the number of unfinished tests that we are allowed to -- look at@@ -319,23 +487,23 @@ case this_status of Done r -> if resultSuccessful r- then k (IntMap.insert key () ok_tests) lookahead+ then k (IntSet.insert key ok_tests) lookahead else return $ return False _ -> k ok_tests (lookahead-1) -- next_iter is called when we end the current iteration, -- either because we reached the end of the test tree -- or because we exhausted the lookahead- next_iter :: IntMap.IntMap () -> STM (IO Bool)+ next_iter :: IntSet.IntSet -> STM (IO Bool) next_iter ok_tests = -- If we made no progress at all, wait until at least some tests -- complete. -- Otherwise, reduce the set of tests we are looking at.- if IntMap.null ok_tests+ if IntSet.null ok_tests then retry- else return $ statusMapResult lookahead0 (IntMap.difference smap ok_tests)+ else return $ statusMapResult lookahead0 (IntMap.withoutKeys smap ok_tests) - finish :: IntMap.IntMap () -> Int -> STM (IO Bool)+ finish :: IntSet.IntSet -> Int -> STM (IO Bool) finish ok_tests _ = next_iter ok_tests -- }}}@@ -345,14 +513,61 @@ -------------------------------------------------- -- {{{ --- | A simple console UI+-- | A simple console UI.+--+-- @since 0.4 consoleTestReporter :: Ingredient-consoleTestReporter =- TestReporter- [ Option (Proxy :: Proxy Quiet)- , Option (Proxy :: Proxy HideSuccesses)- , Option (Proxy :: Proxy UseColor)- ] $+consoleTestReporter = TestReporter consoleTestReporterOptions $ \opts tree ->+ let+ TestPattern pattern = lookupOption opts+ tests = testsNames opts tree+ hook = (return .) . appendPatternIfTestFailed tests pattern+ TestReporter _ cb = consoleTestReporterWithHook hook+ in cb opts tree++appendPatternIfTestFailed+ :: [TestName] -- ^ list of (pre-intercalated) test names+ -> Maybe Expr -- ^ current pattern, if any+ -> [TestName] -- ^ name of current test, represented as a list of group names+ -> Result -- ^ vanilla result+ -> Result+appendPatternIfTestFailed [_] _ _ res = res -- if there is only one test, nothing to refine+appendPatternIfTestFailed _ _ [] res = res -- should be impossible+appendPatternIfTestFailed tests currentPattern (name : names) res = case resultOutcome res of+ Success -> res+ Failure{} -> res { resultDescription = resultDescription res ++ msg }+ where+ msg = "\nUse -p '" ++ escapeQuotes (printAwkExpr pattern) ++ "' to rerun this test only."++ escapeQuotes = concatMap $ \c -> if c == '\'' then "'\\''" else [c]++ findPattern [_] pat _ = ERE pat+ findPattern _ pat [] = EQ (Field (IntLit 0)) (StringLit pat)+ findPattern ts pat (n : ns) = let pat' = n ++ '.' : pat in+ findPattern (filter (pat' `isInfixOf`) ts) pat' ns++ individualPattern = findPattern (filter (name `isInfixOf`) tests) name names++ pattern = maybe id And currentPattern individualPattern++consoleTestReporterOptions :: [OptionDescription]+consoleTestReporterOptions =+ [ Option (Proxy :: Proxy Quiet)+ , Option (Proxy :: Proxy HideSuccesses)+ , Option (Proxy :: Proxy MinDurationToReport)+ , Option (Proxy :: Proxy UseColor)+ , Option (Proxy :: Proxy AnsiTricks)+ ]++-- | A simple console UI with a hook to postprocess results,+-- depending on their names and external conditions+-- (e. g., its previous outcome, stored in a file).+-- Names are listed in reverse order:+-- from test's own name to a name of the outermost test group.+--+-- @since 1.4.2+consoleTestReporterWithHook :: ([TestName] -> Result -> IO Result) -> Ingredient+consoleTestReporterWithHook hook = TestReporter consoleTestReporterOptions $ \opts tree -> Just $ \smap -> do let@@ -360,6 +575,7 @@ Quiet quiet = lookupOption opts HideSuccesses hideSuccesses = lookupOption opts NumThreads numThreads = lookupOption opts+ AnsiTricks ansiTricks = lookupOption opts if quiet then do@@ -369,25 +585,32 @@ do isTerm <- hSupportsANSI stdout+ isTermColor <- hSupportsANSIColor stdout (\k -> if isTerm- then (do hideCursor; k) `finally` showCursor+ -- When killing with Ctrl+C 'showCursor' can fail+ -- to restore terminal cursor if not flushed explicitly+ then (do hideCursor; k) `finally` (do showCursor; hFlush stdout) else k) $ do hSetBuffering stdout LineBuffering let- ?colors = useColor whenColor isTerm+ ?colors = useColor whenColor isTermColor let- output = buildTestOutput opts tree+ -- 'buildTestOutput' is a pure function and cannot query 'hSupportsANSI' itself.+ -- We also would rather not pass @isTerm@ as an extra argument,+ -- since it's a breaking change, thus resorting to tweaking @opts@.+ opts' = changeOption (\(AnsiTricks x) -> AnsiTricks (x && isTerm)) opts+ toutput = applyHook hook $ buildTestOutput opts' tree case () of { _- | hideSuccesses && isTerm ->- consoleOutputHidingSuccesses output smap- | hideSuccesses && not isTerm ->- streamOutputHidingSuccesses output smap- | otherwise -> consoleOutput output smap+ | hideSuccesses && isTerm && ansiTricks ->+ consoleOutputHidingSuccesses toutput smap+ | hideSuccesses ->+ streamOutputHidingSuccesses toutput smap+ | otherwise -> consoleOutput toutput smap } return $ \time -> do@@ -395,26 +618,50 @@ printStatistics stats time return $ statFailures stats == 0 --- | Do not print test results (see README for details)+-- | Do not print test results (see README for details).+--+-- @since 0.8 newtype Quiet = Quiet Bool- deriving (Eq, Ord, Typeable)+ deriving (Eq, Ord) instance IsOption Quiet where defaultValue = Quiet False- parseValue = fmap Quiet . safeRead+ 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+-- | Report only failed tests.+--+-- At the moment, this option only works globally. As an argument+-- to 'Test.Tasty.localOption', it does nothing.+--+-- @since 0.8 newtype HideSuccesses = HideSuccesses Bool- deriving (Eq, Ord, Typeable)+ deriving (Eq, Ord) instance IsOption HideSuccesses where defaultValue = HideSuccesses False- parseValue = fmap HideSuccesses . safeRead+ parseValue = fmap HideSuccesses . safeReadBool optionName = return "hide-successes" optionHelp = return "Do not print tests that passed successfully" optionCLParser = 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@@ -422,22 +669,58 @@ = Never | Always | Auto -- ^ Only if stdout is an ANSI color supporting terminal- deriving (Eq, Ord, Typeable)+ deriving (Eq, Ord) -- | Control color output instance IsOption UseColor where defaultValue = Auto parseValue = parseUseColor optionName = return "color"- optionHelp = return "When to use colored output. Options are 'never', 'always' and 'auto' (default: 'auto')"+ optionHelp = return "When to use colored output"+ optionCLParser = mkOptionCLParser $ metavar "never|always|auto"+ showDefaultValue = Just . displayUseColor +-- | By default, when the option @--hide-successes@ is given and the output+-- goes to an ANSI-capable terminal, we employ some ANSI terminal tricks to+-- display the name of the currently running test and then erase it if it+-- succeeds.+--+-- These tricks sometimes fail, however—in particular, when the test names+-- happen to be longer than the width of the terminal window. See+--+-- * <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+useColor when_ isTerm =+ case when_ of Never -> False Always -> True Auto -> isTerm@@ -450,6 +733,13 @@ "auto" -> return Auto _ -> Nothing +displayUseColor :: UseColor -> String+displayUseColor uc =+ case uc of+ Never -> "never"+ Always -> "always"+ Auto -> "auto"+ -- }}} --------------------------------------------------@@ -500,56 +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 +-- | 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.+--+-- (This only works properly on Unix at the moment; on Windows, the function+-- treats every character as width-1 like 'Data.List.length' does.)+stringWidth :: String -> Int+#ifdef USE_WCWIDTH+stringWidth = Prelude.sum . map charWidth+ where charWidth c = case wcwidth (fromIntegral (ord c)) of+ -1 -> 1 -- many chars have "undefined" width; default to 1 for these.+ w -> fromIntegral w+foreign import capi safe "wchar.h wcwidth" wcwidth :: CWchar -> CInt+#else+stringWidth = length+#endif+ -- (Potentially) colorful output-ok, fail, infoOk, infoFail :: (?colors :: Bool) => String -> IO ()-fail = output BoldIntensity Vivid Red-ok = output NormalIntensity Dull Green-infoOk = output NormalIntensity Dull White-infoFail = output NormalIntensity Dull Red+ok, fail, skipped, infoOk, infoFail :: (?colors :: Bool) => String -> IO ()+fail = output failFormat+ok = output okFormat+skipped = output skippedFormat+-- Just default foreground color for 'infoOk'; do not apply 'infoOkFormat',+-- because terminal's background could be white itself. See #298.+infoOk = putStr+infoFail = output infoFailFormat output :: (?colors :: Bool)- => ConsoleIntensity- -> ColorIntensity- -> Color+ => ConsoleFormat -> String -> IO ()-output bold intensity color str+output format = withConsoleFormat format . putStr++-- | Run action with console configured for a specific output format+--+-- This function does not apply any output formats if colors are disabled at command+-- line or console detection.+--+-- Can be used by providers that wish to provider specific result details printing,+-- while reusing the tasty formats and coloring logic.+--+-- @since 1.3.1+withConsoleFormat :: (?colors :: Bool) => ConsoleFormatPrinter+withConsoleFormat format action | ?colors = (do setSGR- [ SetColor Foreground intensity color- , SetConsoleIntensity bold+ [ SetColor Foreground (colorIntensity format) (color format)+ , SetConsoleIntensity (consoleIntensity format) ]- putStr str+ action ) `finally` setSGR []- | otherwise = putStr str+ | otherwise = action -- }}}
Test/Tasty/Ingredients/IncludingOptions.hs view
@@ -7,6 +7,8 @@ -- | This ingredient doesn't do anything apart from registering additional -- options. ----- The option values can be accessed using 'askOption'.+-- The option values can be accessed using 'Test.Tasty.askOption'.+--+-- @since 0.6 includingOptions :: [OptionDescription] -> Ingredient includingOptions opts = TestManager opts (\_ _ -> Nothing)
Test/Tasty/Ingredients/ListTests.hs view
@@ -1,5 +1,5 @@ -- | Ingredient for listing test names-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-}+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} module Test.Tasty.Ingredients.ListTests ( ListTests(..) , testsNames@@ -7,8 +7,6 @@ ) where import Data.Proxy-import Data.Typeable-import Data.Monoid import Options.Applicative import Test.Tasty.Core@@ -16,26 +14,32 @@ 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 = 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@@ -15,29 +17,37 @@ , lookupOption , singleOption , OptionDescription(..)+ , uniqueOptionDescriptions -- * Utilities , flagCLParser , mkFlagCLParser , mkOptionCLParser , safeRead+ , safeReadBool ) where 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 Prelude -- Silence FTP import warnings-+import qualified Data.Semigroup as Sem+import qualified Data.Set as S+import Prelude hiding (mod) -- Silence FTP import warnings import Options.Applicative -- | 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@@ -46,6 +56,14 @@ -- | The option description or help string. This can be an arbitrary -- string. optionHelp :: Tagged v String+ -- | How a 'defaultValue' should be displayed in the help string. 'Nothing'+ -- (the default implementation) will result in nothing being displayed, while+ -- @'Just' def@ will result in @def@ being advertised as the default in the+ -- help string.+ --+ -- @since 1.3+ showDefaultValue :: v -> Maybe String+ showDefaultValue _ = Nothing -- | A command-line option parser. -- -- It has a default implementation in terms of the other methods.@@ -56,11 +74,14 @@ -- Even if you override this, you still should implement all the methods -- above, to allow alternative interfaces. --- -- Do not supply a default value here for this parser!- -- This is because if no value was provided on the command line we may- -- lookup the option e.g. in the environment. But if the parser always- -- succeeds, we have no way to tell whether the user really provided the- -- option on the command line.+ -- Do not supply a default value (e.g., with the 'value' function) here+ -- for this parser! This is because if no value was provided on the command+ -- line we may lookup the option e.g. in the environment. But if the parser+ -- always succeeds, we have no way to tell whether the user really provided+ -- the option on the command line.+ --+ -- Similarly, do not use 'showDefaultWith' here, as it will be ignored. Use+ -- the 'showDefaultValue' method of 'IsOption' instead. -- (If we don't specify a default, the option becomes mandatory. -- So, when we build the complete parser for OptionSet, we turn a@@ -75,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@@ -96,20 +129,39 @@ Just {} -> error "OptionSet: broken invariant (shouldn't happen)" Nothing -> defaultValue --- | Change the option value+-- | Change the option value.+--+-- @since 0.1 changeOption :: forall v . IsOption v => (v -> v) -> OptionSet -> OptionSet changeOption f s = setOption (f $ lookupOption s) s --- | Create a singleton 'OptionSet'+-- | Create a singleton t'OptionSet'.+--+-- @since 0.8 singleOption :: IsOption v => v -> OptionSet singleOption v = setOption v mempty -- | The purpose of this data type is to capture the dictionary -- corresponding to a particular option.+--+-- @since 0.1 data OptionDescription where Option :: IsOption v => Proxy v -> OptionDescription --- | Command-line parser to use with flags+-- | Remove duplicated 'OptionDescription', preserving existing order otherwise.+--+-- @since 1.4.1+uniqueOptionDescriptions :: [OptionDescription] -> [OptionDescription]+uniqueOptionDescriptions = go S.empty+ where+ go _ [] = []+ go acc (Option o : os)+ | typeOf o `S.member` acc = go acc os+ | otherwise = Option o : go (S.insert (typeOf o) acc) os++-- | Command-line parser to use with flags.+--+-- @since 0.8 flagCLParser :: forall v . IsOption v => Maybe Char -- ^ optional short flag@@ -118,6 +170,8 @@ flagCLParser mbShort = mkFlagCLParser (foldMap short mbShort) -- | Command-line flag parser that takes additional option modifiers.+--+-- @since 0.11.1 mkFlagCLParser :: forall v . IsOption v => Mod FlagFields v -- ^ option modifier@@ -130,6 +184,8 @@ ) -- | Command-line option parser that takes additional option modifiers.+--+-- @since 0.11.1 mkOptionCLParser :: forall v . IsOption v => Mod OptionFields v -> Parser v mkOptionCLParser mod = option parse@@ -138,13 +194,30 @@ <> mod ) where+ name :: String name = untag (optionName :: Tagged v String)- parse = str >>=- maybe (readerError $ "Could not parse " ++ name) pure <$> parseValue + parse :: ReadM v+ parse = do+ s <- str+ let err = "Could not parse: " ++ s ++ " is not a valid " ++ name+ maybe (readerError err) pure (parseValue s)+ -- | Safe read function. Defined here for convenience to use for -- 'parseValue'.+--+-- @since 0.1 safeRead :: Read a => String -> Maybe a safeRead s | [(x, "")] <- reads s = Just x | otherwise = Nothing++-- | Parse a 'Bool' case-insensitively.+--+-- @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
@@ -1,23 +1,27 @@ -- | Core options, i.e. the options used by tasty itself-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} -- for (^) module Test.Tasty.Options.Core ( NumThreads(..) , Timeout(..) , mkTimeout+ , HideProgress(..) , coreOptions+ -- * Helpers+ , parseDuration ) where import Control.Monad (mfilter) import Data.Proxy-import Data.Typeable-import Data.Tagged import Data.Fixed-import Data.Monoid-import Options.Applicative+import Options.Applicative hiding (str) import GHC.Conc-import Prelude -- Silence FTP import warnings+#if !MIN_VERSION_base(4,11,0)+import Data.Monoid+#endif+import Control.Concurrent+import System.IO.Unsafe import Test.Tasty.Options import Test.Tasty.Patterns@@ -26,43 +30,62 @@ -- -- Note that this is /not/ included in 'coreOptions'. -- Instead, it's automatically included in the options for any--- 'TestReporter' ingredient by 'ingredientOptions', because the way test+-- 'Test.Tasty.Ingredients.TestReporter' ingredient by+-- 'Test.Tasty.Ingredients.ingredientOptions', because the way test -- reporters are handled already involves parallelism. Other ingredients -- may also choose to include this option.+--+-- @since 0.1 newtype NumThreads = NumThreads { getNumThreads :: Int }- deriving (Eq, Ord, Num, Typeable)+ deriving (Eq, Ord, Num) instance IsOption NumThreads where- defaultValue = NumThreads numCapabilities+ defaultValue = unsafePerformIO $ NumThreads <$>+ if rtsSupportsBoundThreads then getNumProcessors else pure 1 parseValue = mfilter onlyPositive . fmap NumThreads . safeRead optionName = return "num-threads" optionHelp = return "Number of threads to use for tests execution"- optionCLParser = mkOptionCLParser (short 'j')+ optionCLParser = mkOptionCLParser (short 'j' <> metavar "NUMBER")+ showDefaultValue _ = Just "Number of cores when using threaded RTS, 1 for non-threaded" -- | Filtering function to prevent non-positive number of threads onlyPositive :: NumThreads -> Bool onlyPositive (NumThreads x) = x > 0 --- | Timeout to be applied to individual tests+-- | Timeout to be applied to individual tests.+--+-- @since 0.8 data Timeout = Timeout Integer String -- ^ 'String' is the original representation of the timeout (such as -- @\"0.5m\"@), so that we can print it back. 'Integer' is the number of -- microseconds. | NoTimeout- deriving (Show, Typeable)+ deriving+ ( Eq+ -- ^ Auto-derived instance, just to allow storing in a 'Data.Map.Map' and such.+ --+ -- @since 1.5.1+ , Ord+ -- ^ Auto-derived instance, just to allow storing in a 'Data.Map.Map' and such.+ --+ -- @since 1.5.1+ , Show+ ) instance IsOption Timeout where defaultValue = NoTimeout parseValue str = Timeout- <$> parseTimeout str+ <$> parseDuration str <*> pure str optionName = return "timeout" optionHelp = return "Timeout for individual tests (suffixes: ms,s,m,h; default: s)"- optionCLParser = mkOptionCLParser (short 't')+ optionCLParser = mkOptionCLParser (short 't' <> metavar "DURATION") -parseTimeout :: String -> Maybe Integer-parseTimeout str =+-- | Parses a suffixed duration (e.g. "10s") to an Integer representing+-- number of microseconds.+parseDuration :: String -> Maybe Integer+parseDuration str = -- it sucks that there's no more direct way to convert to a number of -- microseconds (round :: Micro -> Integer) . (* 10^6) <$>@@ -77,7 +100,9 @@ _ -> Nothing _ -> Nothing --- | A shortcut for creating 'Timeout' values+-- | A shortcut for creating v'Timeout' values.+--+-- @since 0.8 mkTimeout :: Integer -- ^ microseconds -> Timeout@@ -85,11 +110,29 @@ Timeout n $ showFixed True (fromInteger n / (10^6) :: Micro) ++ "s" +-- | Hide progress information. If progress disabled, the test launcher+-- 'Test.Tasty.Runners.launchTestTree' completely ignores callbacks to update progress.+-- If enabled, it's up to individual 'Test.Tasty.Ingredients.TestReporter's+-- how to execute, some might not be able to render progress anyways.+--+-- @since 1.5+newtype HideProgress = HideProgress { getHideProgress :: Bool }+ deriving (Eq, Ord)+instance IsOption HideProgress where+ defaultValue = HideProgress False+ parseValue = fmap HideProgress . safeReadBool+ optionName = return "hide-progress"+ optionHelp = return "Do not show progress"+ optionCLParser = mkFlagCLParser mempty (HideProgress True)+ -- | The list of all core options, i.e. the options not specific to any -- provider or ingredient, but to tasty itself. Currently contains--- 'TestPattern' and 'Timeout'.+-- t'TestPattern', t'Timeout' and t'HideProgress'.+--+-- @since 0.1 coreOptions :: [OptionDescription] coreOptions = [ Option (Proxy :: Proxy TestPattern) , Option (Proxy :: Proxy Timeout)+ , Option (Proxy :: Proxy HideProgress) ]
Test/Tasty/Options/Env.hs view
@@ -1,5 +1,5 @@ -- | Get options from the environment-{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables #-} module Test.Tasty.Options.Env (getEnvOptions, suiteEnvOptions) where import Test.Tasty.Options@@ -8,14 +8,10 @@ import Test.Tasty.Runners.Reducers import System.Environment-import Data.Foldable import Data.Tagged import Data.Proxy import Data.Char-import Data.Typeable import Control.Exception-import Control.Applicative-import Prelude -- Silence AMP and FTP import warnings import Text.Printf data EnvOptionException@@ -23,7 +19,6 @@ String -- option name String -- variable name String -- value- deriving (Typeable) instance Show EnvOptionException where show (BadOption optName varName value) =@@ -37,6 +32,7 @@ getEnvOptions :: [OptionDescription] -> IO OptionSet getEnvOptions = getApp . foldMap lookupOpt where+ lookupOpt :: OptionDescription -> Ap IO OptionSet lookupOpt (Option (px :: Proxy v)) = do let name = proxy optionName px
Test/Tasty/Parallel.hs view
@@ -1,31 +1,27 @@ -- | A helper module which takes care of parallelism-{-# LANGUAGE DeriveDataTypeable #-}-module Test.Tasty.Parallel (runInParallel) where+module Test.Tasty.Parallel (ActionStatus(..), Action(..), runInParallel) where import Control.Monad import Control.Concurrent+import Control.Concurrent.Async import Control.Concurrent.STM-import Control.Exception import Foreign.StablePtr-import Data.Typeable-import GHC.Conc (labelThread) -data Interrupt = Interrupt- deriving Typeable-instance Show Interrupt where- show Interrupt = "interrupted"-instance Exception Interrupt--data ParThreadKilled = ParThreadKilled SomeException- deriving Typeable-instance Show ParThreadKilled where- show (ParThreadKilled exn) =- "tasty: one of the test running threads was killed by: " ++- show exn-instance Exception ParThreadKilled+-- | What to do about an t'Action'?+data ActionStatus+ = ActionReady+ -- ^ the action is ready to be executed+ | ActionSkip+ -- ^ the action should be skipped+ | ActionWait+ -- ^ not sure what to do yet; wait+ deriving Eq -shutdown :: ThreadId -> IO ()-shutdown = flip throwTo Interrupt+data Action = Action+ { actionStatus :: STM ActionStatus+ , actionRun :: IO ()+ , actionSkip :: STM ()+ } -- | Take a list of actions and execute them in parallel, no more than @n@ -- at the same time.@@ -35,7 +31,8 @@ -- cleans up. runInParallel :: Int -- ^ maximum number of parallel threads- -> [IO ()] -- ^ list of actions to execute+ -> [Action] -- ^ list of actions to execute.+ -- The first action in the pair tells if the second action is ready to run. -> IO (IO ()) -- This implementation tries its best to ensure that exceptions are -- properly propagated to the caller and threads are not left running.@@ -44,101 +41,75 @@ -- actions themselves. Any exceptions that reach this function or its -- threads are by definition unexpected. runInParallel nthreads actions = do+ -- When linked with threaded RTS, ensure we have enough Capabilities+ -- so that all Haskell worker threads can truly run in parallel.+ when rtsSupportsBoundThreads $ do+ ncap <- getNumCapabilities+ when (ncap < nthreads) $ setNumCapabilities nthreads+ callingThread <- myThreadId -- Don't let the main thread be garbage-collected -- Otherwise we may get a "thread blocked indefinitely in an STM -- transaction" exception when a child thread is blocked and GC'd.- -- (See e.g. https://github.com/feuerbach/tasty/issues/15)+ -- (See e.g. https://github.com/UnkindPartition/tasty/issues/15)+ -- FIXME is this still needed? _ <- newStablePtr callingThread - -- A variable containing all ThreadIds of forked threads.- --- -- These are the threads we'll need to kill if something wrong happens.- pidsVar <- atomically $ newTVar []-- -- If an unexpected exception has been thrown and we started killing all- -- the spawned threads, this flag will be set to False, so that any- -- freshly spawned threads will know to terminate, even if their pids- -- didn't make it to the "kill list" yet.- aliveVar <- atomically $ newTVar True-- let- -- Kill all threads.- shutdownAll :: IO ()- shutdownAll = do- pids <- atomically $ do- writeTVar aliveVar False- readTVar pidsVar-- -- be sure not to kill myself!- me <- myThreadId- mapM_ shutdown $ filter (/= me) pids+ actionsVar <- atomically $ newTMVar actions - cleanup :: Either SomeException () -> IO ()- cleanup Right {} = return ()- cleanup (Left exn)- | Just Interrupt <- fromException exn- -- I'm being shut down either by a fellow thread (which caught an- -- exception), or by the main thread which decided to stop running- -- tests. In any case, just end silently.- = return ()- | otherwise = do- -- Wow, I caught an exception (most probably an async one,- -- although it doesn't really matter). Shut down all other- -- threads, and re-throw my exception to the calling thread.- shutdownAll- throwTo callingThread $ ParThreadKilled exn+ pids <- replicateM nthreads (async $ work actionsVar) - forkCarefully :: IO () -> IO ThreadId- forkCarefully action = flip myForkFinally cleanup $ do- -- We cannot check liveness and update the pidsVar in one- -- transaction before forking, because we don't know the new pid yet.- --- -- So we fork and then check/update. If something has happened in- -- the meantime, it's not a big deal — we just cancel. OTOH, if- -- we're alive at the time of the transaction, then we add our pid- -- and will be killed when something happens.- newPid <- myThreadId+ return $ do+ -- Tell worker threads there is no more work after their current task.+ -- 'cancel' below by itself is not sufficient because if an exception+ -- is thrown in the middle of a test, the worker thread simply marks+ -- the test as failed and moves on to their next task. We also need to+ -- make it clear that there are no further tasks.+ _ <- atomically $ swapTMVar actionsVar []+ -- Cancel all the current tasks, waiting for workers to clean up.+ -- The waiting part is important (see #249), that's why we use cancel+ -- instead of killThread.+ mapM_ cancel pids +work :: TMVar [Action] -> IO ()+work actionsVar = go+ where+ go = do join . atomically $ do- alive <- readTVar aliveVar- if alive- then do- modifyTVar pidsVar (newPid :)- return action- else- return (return ())-- capsVar <- atomically $ newTVar nthreads-- let- go a cont = join . atomically $ do- caps <- readTVar capsVar- if caps > 0- then do- writeTVar capsVar $! caps - 1- let- release = atomically $ modifyTVar' capsVar (+1)-- -- Thanks to our exception handling, we won't deadlock even if- -- an exception strikes before we 'release'. Everything will be- -- killed, so why bother.- return $ do- pid <- forkCarefully (do a; release)- labelThread pid "tasty_test_thread"- cont-- else retry-- -- fork here as well, so that we can move to the UI without waiting- -- untill all tests have finished- pid <- forkCarefully $ foldr go (return ()) actions- labelThread pid "tasty_thread_manager"- return shutdownAll+ mb_ready <- findBool =<< takeTMVar actionsVar+ case mb_ready of+ Nothing -> do+ -- Nothing left to do. Put back the TMVar so that other threads+ -- do not block on an empty TMVar (see #249) and return.+ putTMVar actionsVar []+ return $ return ()+ Just (this, rest) -> do+ putTMVar actionsVar rest+ return $ actionRun this >> go --- Copied from base to stay compatible with GHC 7.4.-myForkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId-myForkFinally action and_then =- mask $ \restore ->- forkIO $ try (restore action) >>= and_then+-- | Find a ready-to-run item. Filter out the items that will never be+-- ready to run.+--+-- Return the ready item and the remaining ones.+--+-- This action may block if no items are ready to run just yet.+--+-- Return 'Nothing' if there are no runnable items left.+findBool :: [Action] -> STM (Maybe (Action, [Action]))+findBool = go []+ where+ go [] [] =+ -- nothing to do+ return Nothing+ go _ [] =+ -- nothing ready yet+ retry+ go past (this : rest) = do+ status <- actionStatus this+ case status of+ ActionReady -> return $ Just (this, reverse past ++ rest)+ ActionWait -> go (this : past) rest+ ActionSkip -> do+ actionSkip this+ go past rest
Test/Tasty/Patterns.hs view
@@ -1,161 +1,87 @@--- This code is largely borrowed from test-framework-{--Copyright (c) 2008, Maximilian Bolingbroke-All rights reserved.--Redistribution and use in source and binary forms, with or without modification, are permitted-provided that the following conditions are met:-- * Redistributions of source code must retain the above copyright notice, this list of- conditions and the following disclaimer.- * Redistributions in binary form must reproduce the above copyright notice, this list of- conditions and the following disclaimer in the documentation and/or other materials- provided with the distribution.- * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to- endorse or promote products derived from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR-IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND-FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR-CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER-IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT-OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.--}- -- | Test patterns------ (Most of the code borrowed from the test-framework) -{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP, TypeApplications #-} module Test.Tasty.Patterns- ( TestPattern+ ( TestPattern(..)+ , parseExpr , parseTestPattern , noPattern+ , Path+ , exprMatches , testPatternMatches ) where import Test.Tasty.Options--import Text.Regex.TDFA-import Text.Regex.TDFA.String()--import Data.List-import Data.Typeable-import Data.Tagged+import Test.Tasty.Patterns.Types+import Test.Tasty.Patterns.Parser+import Test.Tasty.Patterns.Eval -import Options.Applicative+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--data Token = SlashToken- | WildcardToken- | DoubleWildcardToken- | LiteralToken Char- deriving (Eq, Show)--tokenize :: String -> [Token]-tokenize ('/':rest) = SlashToken : tokenize rest-tokenize ('*':'*':rest) = DoubleWildcardToken : tokenize rest-tokenize ('*':rest) = WildcardToken : tokenize rest-tokenize (c:rest) = LiteralToken c : tokenize rest-tokenize [] = []---data TestPatternMatchMode = TestMatchMode- | PathMatchMode- deriving Show+#endif --- | A pattern to filter tests. For the syntax description, see--- the README.-data TestPattern = TestPattern {- tp_categories_only :: Bool,- tp_negated :: Bool,- tp_match_mode :: TestPatternMatchMode,- tp_tokens :: [Token]- } | NoPattern- deriving (Typeable, Show)+-- | @since 1.0+newtype TestPattern =+ -- | @since 1.1+ TestPattern+ (Maybe Expr)+ deriving+ ( Show -- ^ @since 1.1+ , Eq -- ^ @since 1.1+ ) --- | A pattern that matches anything.+-- | @since 1.0 noPattern :: TestPattern-noPattern = NoPattern--instance Read TestPattern where- readsPrec _ string = [(parseTestPattern string, "")]+noPattern = TestPattern Nothing +-- | Since tasty-1.5, this option can be specified multiple times on the+-- command line. Only the tests matching all given patterns will be selected. instance IsOption TestPattern where defaultValue = noPattern- parseValue = Just . parseTestPattern+ parseValue = parseTestPattern optionName = return "pattern"- optionHelp = return "Select only tests that match pattern"- optionCLParser = mkOptionCLParser (short 'p')---- | 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 test_pattern =- -- It is important that GHC assigns arity 1 to this function,- -- so that compilation of the regex is shared among the invocations.- -- See #175.- case test_pattern of- NoPattern -> const True- TestPattern {} -> \path ->- let- path_to_consider | tp_categories_only test_pattern = dropLast 1 path- | otherwise = path- 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- in not_maybe . any (match tokens_regex) $ things_to_match- where- not_maybe | tp_negated test_pattern = not- | otherwise = id- tokens_regex :: Regex- tokens_regex = makeRegex $ buildTokenRegex (tp_tokens test_pattern)---buildTokenRegex :: [Token] -> String-buildTokenRegex [] = []-buildTokenRegex (token:tokens) = concat (firstTokenToRegex token : map tokenToRegex tokens)- where- firstTokenToRegex SlashToken = "^"- firstTokenToRegex other = tokenToRegex other+#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,8 +1,11 @@--- | API for test providers+-- | API for test providers.+--+-- @since 0.1 module Test.Tasty.Providers ( IsTest(..) , testPassed , testFailed+ , testFailedDetails , Result , Progress(..) , TestName@@ -12,12 +15,17 @@ where import Test.Tasty.Core+import Test.Tasty.Providers.ConsoleFormat (ResultDetailsPrinter, noResultDetails) --- | Convert a test to a leaf of the 'TestTree'+-- | Convert a test to a leaf of the 'TestTree'.+--+-- @since 0.1 singleTest :: IsTest t => TestName -> t -> TestTree singleTest = SingleTest --- | 'Result' of a passed test+-- | t'Result' of a passed test.+--+-- @since 0.8 testPassed :: String -- ^ description (may be empty) -> Result@@ -26,15 +34,15 @@ , resultDescription = desc , resultShortDescription = "OK" , resultTime = 0+ , resultDetailsPrinter = noResultDetails } --- | 'Result' of a failed test-testFailed- :: String -- ^ description+-- | t'Result' of a failed test with custom details printer+--+-- @since 1.3.1+testFailedDetails+ :: String -- ^ description+ -> ResultDetailsPrinter -- ^ details printer -> Result-testFailed desc = Result- { resultOutcome = Failure TestFailed- , resultDescription = desc- , resultShortDescription = "FAIL"- , resultTime = 0- }+testFailedDetails desc printer = (testFailed desc)+ { resultDetailsPrinter = printer }
+ Test/Tasty/Providers/ConsoleFormat.hs view
@@ -0,0 +1,87 @@+-- | This module can be used by providers to perform colorful/formatted+-- output and possibly reuse tasty's own output formats.+--+-- @since 1.3.1+module Test.Tasty.Providers.ConsoleFormat+ ( ResultDetailsPrinter(..)+ , ConsoleFormat(..)+ , ConsoleFormatPrinter+ , noResultDetails+ , failFormat+ , infoFailFormat+ , infoOkFormat+ , okFormat+ , skippedFormat+ )+where++import System.Console.ANSI++-- | Console output format+--+-- @since 1.3.1+data ConsoleFormat = ConsoleFormat+ { consoleIntensity :: ConsoleIntensity+ , colorIntensity :: ColorIntensity+ , color :: Color+ }++-- | Type of console format printer functions+--+-- @since 1.3.1+type ConsoleFormatPrinter+ = ConsoleFormat -- ^ selected console format+ -> IO () -- ^ action to be executed with active console format+ -> IO ()++-- | Noop result details printer. The default for most providers.+--+-- @since 1.3.1+noResultDetails :: ResultDetailsPrinter+noResultDetails = ResultDetailsPrinter . const . const $ return ()++-- | An action that prints additional information about a test using+-- colors/formatting; see 'Test.Tasty.Providers.testFailedDetails' and+-- 'Test.Tasty.Runners.resultDetailsPrinter'.+--+-- As input, this action is provided with the current indentation level and+-- a 'ConsoleFormatPrinter', which tells it how perform output.+--+-- This is a newtype to allow a 'Show' instance.+--+-- @since 1.3.1+newtype ResultDetailsPrinter = ResultDetailsPrinter+ (Int -> ConsoleFormatPrinter -> IO ())++instance Show ResultDetailsPrinter where+ show _printer = "ResultDetailsPrinter"++-- | Format used to display failures+--+-- @since 1.3.1+failFormat :: ConsoleFormat+failFormat = ConsoleFormat BoldIntensity Vivid Red++-- | Format used to display additional information on failures+--+-- @since 1.3.1+infoFailFormat :: ConsoleFormat+infoFailFormat = ConsoleFormat NormalIntensity Dull Red++-- | Format used to display successes+--+-- @since 1.3.1+okFormat :: ConsoleFormat+okFormat = ConsoleFormat NormalIntensity Dull Green++-- | Format used to display additional information on successes+--+-- @since 1.3.1+infoOkFormat :: ConsoleFormat+infoOkFormat = ConsoleFormat NormalIntensity Dull White++-- | Format used to display skipped tests+--+-- @since 1.3.1+skippedFormat :: ConsoleFormat+skippedFormat = ConsoleFormat NormalIntensity Dull Magenta
Test/Tasty/Run.hs view
@@ -1,36 +1,58 @@ -- | Running tests {-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes,- FlexibleContexts, BangPatterns #-}+ FlexibleContexts, CPP, LambdaCase,+ RecordWildCards, NamedFieldPuns #-} module Test.Tasty.Run ( Status(..) , StatusMap , launchTestTree+ , applyTopLevelPlusTestOptions+ , DependencyException(..) ) where -import qualified Data.IntMap as IntMap+import qualified Data.IntMap.Strict as IntMap import qualified Data.Sequence as Seq import qualified Data.Foldable as F+import Data.Int (Int64) import Data.Maybe-import Control.Monad.State-import Control.Monad.Writer-import Control.Monad.Reader+import Data.List (intercalate)+import Data.Graph (SCC(..), stronglyConnComp)+import Data.Sequence (Seq, (|>), (<|), (><))+import Control.Monad (forever, guard, join, liftM)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (ReaderT(..), local, ask)+import Control.Monad.Trans.Writer (execWriterT, tell)+import Control.Concurrent import Control.Concurrent.STM-import Control.Concurrent.Timeout (timeout) import Control.Concurrent.Async import Control.Exception as E-import Control.Applicative import Control.Arrow+import Data.Monoid (First(..)) import GHC.Conc (labelThread)-import Prelude -- Silence AMP and FTP import warnings-import qualified System.Clock as Clock +#if MIN_VERSION_base(4,18,0)+import Data.Traversable (mapAccumM)+#endif++#ifdef MIN_VERSION_unbounded_delays+import Control.Concurrent.Timeout (timeout)+#else+import System.Timeout (timeout)+#endif+ import Test.Tasty.Core import Test.Tasty.Parallel+import Test.Tasty.Patterns+import Test.Tasty.Patterns.Types import Test.Tasty.Options import Test.Tasty.Options.Core import Test.Tasty.Runners.Reducers+import Test.Tasty.Runners.Utils (timed, forceElements)+import Test.Tasty.Providers.ConsoleFormat (noResultDetails) --- | Current status of a test+-- | Current status of a test.+--+-- @since 0.1 data Status = NotStarted -- ^ test has not started running yet@@ -38,11 +60,16 @@ -- ^ test is being run | Done Result -- ^ test finished with a given result+ deriving+ ( Show -- ^ @since 1.2+ ) -- | Mapping from test numbers (starting from 0) to their status variables. -- -- This is what an ingredient uses to analyse and display progress, and to -- detect when tests finish.+--+-- @since 0.1 type StatusMap = IntMap.IntMap (TVar Status) data Resource r@@ -50,6 +77,7 @@ | BeingCreated | FailedToCreate SomeException | Created r+ | BeingDestroyed | Destroyed instance Show (Resource r) where@@ -58,10 +86,9 @@ BeingCreated -> "BeingCreated" FailedToCreate exn -> "FailedToCreate " ++ show exn Created {} -> "Created"+ BeingDestroyed -> "BeingDestroyed" Destroyed -> "Destroyed" -data ResourceVar = forall r . ResourceVar (TVar (Resource r))- data Initializer = forall res . Initializer (IO res)@@ -79,11 +106,12 @@ -- a parameter -> TVar Status -- ^ variable to write status to -> Timeout -- ^ optional timeout to apply- -> Seq.Seq Initializer -- ^ initializers (to be executed in this order)- -> Seq.Seq Finalizer -- ^ finalizers (to be executed in this order)+ -> HideProgress -- ^ hide progress option+ -> Seq Initializer -- ^ initializers (to be executed in this order)+ -> Seq Finalizer -- ^ finalizers (to be executed in this order) -> IO ()-executeTest action statusVar timeoutOpt inits fins = mask $ \restore -> do- resultOrExn <- try $ restore $ do+executeTest action statusVar timeoutOpt hideProgressOpt inits fins = mask $ \restore -> do+ resultOrExn <- try . restore $ do -- N.B. this can (re-)throw an exception. It's okay. By design, the -- actual test will not be run, then. We still run all the -- finalizers.@@ -93,17 +121,30 @@ -- anyway. initResources + let+ cursorMischiefManaged = do+ atomically $ writeTVar statusVar (Executing emptyProgress)+ action yieldProgress+ -- If all initializers ran successfully, actually run the test. -- We run it in a separate thread, so that the test's exception -- handler doesn't interfere with our timeout.- withAsync (action yieldProgress) $ \asy -> do+ withAsync cursorMischiefManaged $ \asy -> do labelThread (asyncThreadId asy) "tasty_test_execution_thread"- timed $ applyTimeout timeoutOpt $ wait asy+ timed $ applyTimeout timeoutOpt $ do+ r <- wait asy+ -- Not only wait for the result to be returned, but make sure to+ -- evaluate it inside applyTimeout; see #280.+ evaluate $+ resultOutcome r `seq`+ forceElements (resultDescription r) `seq`+ forceElements (resultShortDescription r)+ return r -- no matter what, try to run each finalizer mbExn <- destroyResources restore - atomically . writeTVar statusVar $ Done $+ atomically . writeTVar statusVar . Done $ case resultOrExn <* maybe (Right ()) Left mbExn of Left ex -> exceptionResult ex Right (t,r) -> r { resultTime = t }@@ -129,8 +170,15 @@ BeingCreated -> retry Created {} -> return $ return () FailedToCreate exn -> return $ throwIO exn- _ -> return $ throwIO $- unexpectedState "initResources" resStatus+ -- If the resource is destroyed or being destroyed+ -- while we're starting a test, the test suite is probably+ -- shutting down. We are about to be killed.+ -- (In fact we are probably killed already, so these cases are+ -- unlikely to occur.)+ -- In any case, the most sensible thing to do is to go to+ -- sleep, awaiting our fate.+ Destroyed -> return $ sleepIndefinitely+ BeingDestroyed -> return $ sleepIndefinitely applyTimeout :: Timeout -> IO Result -> IO Result applyTimeout NoTimeout a = a@@ -143,8 +191,11 @@ "Timed out after " ++ tstr , resultShortDescription = "TIMEOUT" , resultTime = fromIntegral t+ , resultDetailsPrinter = noResultDetails }- fromMaybe timeoutResult <$> timeout t a+ -- If compiled with unbounded-delays then t' :: Integer, otherwise t' :: Int+ let t' = fromInteger (min (max 0 t) (toInteger (maxBound :: Int64)))+ fromMaybe timeoutResult <$> timeout t' a -- destroyResources should not be interrupted by an exception -- Here's how we ensure this:@@ -156,7 +207,7 @@ destroyResources restore = do -- remember the first exception that occurred liftM getFirst . execWriterT . getTraversal $- flip F.foldMap fins $ \(Finalizer doRelease initVar finishVar) ->+ flip F.foldMap fins $ \fin@(Finalizer _ _ finishVar) -> Traversal $ do iAmLast <- liftIO $ atomically $ do nUsers <- readTVar finishVar@@ -166,71 +217,321 @@ mbExcn <- liftIO $ if iAmLast- then join $ atomically $ do- resStatus <- readTVar initVar- case resStatus of- Created res -> do- -- Don't worry about double destroy — only one thread- -- receives iAmLast- return $- (either Just (const Nothing)- <$> try (restore $ doRelease res))- <* atomically (writeTVar initVar Destroyed)- FailedToCreate {} -> return $ return Nothing- _ -> return $ return $ Just $- unexpectedState "destroyResources" resStatus+ then destroyResource restore fin else return Nothing tell $ First mbExcn - -- The callback- -- Since this is not used yet anyway, disable for now.- -- I'm not sure whether we should get rid of this altogether. For most- -- providers this is either difficult to implement or doesn't make- -- sense at all.- -- See also https://github.com/feuerbach/tasty/issues/33- yieldProgress _ = return ()+ yieldProgress _newP | getHideProgress hideProgressOpt =+ pure ()+ yieldProgress newP | newP == emptyProgress =+ -- This could be changed to `Maybe Progress` to lets more easily indicate+ -- when progress should try to be printed ?+ pure ()+ yieldProgress newP = liftIO+ . atomically+ . writeTVar statusVar+ $ Executing newP -type InitFinPair = (Seq.Seq Initializer, Seq.Seq Finalizer)+-- | Traversal type used in 'createTestActions'+type Tr = ReaderT (Path, Seq Dependency) IO (TestActionTree UnresolvedAction) +-- | Exceptions related to dependencies between tests.+--+-- @since 1.2+newtype DependencyException+ = DependencyLoop [[Path]]+ -- ^ Test dependencies form cycles. In other words, test A cannot start+ -- until test B finishes, and test B cannot start until test+ -- A finishes. Field lists detected cycles.+ --+ -- @since 1.5++instance Show DependencyException where+ show (DependencyLoop css) = "Test dependencies have cycles:\n" ++ showCycles css+ where+ showCycles = intercalate "\n" . map showCycle+ showPath = intercalate "." . F.toList++ -- For clarity in the error message, the first element is repeated at the end+ showCycle [] = "- <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-createTestActions :: OptionSet -> TestTree -> IO ([(IO (), TVar Status)], [ResourceVar])-createTestActions opts tree = do+-- variables to watch them. Additionally, a collection of finalizers is+-- returned that can be used to clean up resources in case of unexpected+-- events.+createTestActions+ :: OptionSet+ -> TestTree+ -> IO ([TestAction Action], Seq Finalizer)+createTestActions opts0 tree = do+ -- Folding the test tree reduces it to a 'TestActionTree', which is a simplified+ -- version of 'TestTree' that only includes the tests to be run, resources needed+ -- to run them, and meta information needed to watch test progress and calculate+ -- dependencies in 'resolveDeps'.+ unresolvedTestTree :: TestActionTree UnresolvedAction <-+ flip runReaderT (mempty :: (Path, Seq Dependency)) $+ foldTestTree0 (pure (tGroup [])) (TreeFold { .. }) opts0 tree+ let- traversal ::- Traversal (WriterT ([(InitFinPair -> IO (), TVar Status)], [ResourceVar]) IO)- traversal =- foldTestTree- trivialFold- { foldSingle = runSingleTest- , foldResource = addInitAndRelease- }- opts tree- (tests, rvars) <- unwrap traversal- let tests' = map (first ($ (Seq.empty, Seq.empty))) tests- return (tests', rvars)+ finalizers :: Seq Finalizer+ finalizers = collectFinalizers unresolvedTestTree + tests :: [TestAction ResolvedAction]+ tests = collectTests (resolveTestActions unresolvedTestTree)++ case resolveDeps tests of+ Right tests' -> return (tests', finalizers)+ Left cycles -> throwIO (DependencyLoop cycles)+ where- runSingleTest opts _ test = Traversal $ do- statusVar <- liftIO $ atomically $ newTVar NotStarted+ -- * Functions used in 'TreeFold'+ foldSingle :: IsTest t => OptionSet -> TestName -> t -> Tr+ foldSingle opts name test = do+ testStatus <- liftIO $ newTVarIO NotStarted+ (parentPath, testDeps) <- ask let- act (inits, fins) =- executeTest (run opts test) statusVar (lookupOption opts) inits fins- tell ([(act, statusVar)], mempty)- addInitAndRelease (ResourceSpec doInit doRelease) a = wrap $ do- initVar <- atomically $ newTVar NotCreated- (tests, rvars) <- unwrap $ a (getResource initVar)- let ntests = length tests- finishVar <- atomically $ newTVar ntests+ testPath = parentPath |> name+ testAction = executeTest (run opts test) testStatus (lookupOption opts) (lookupOption opts)+ pure $ TAction (TestAction {..})++ foldResource :: OptionSet -> ResourceSpec a -> (IO a -> Tr) -> Tr+ foldResource _opts (ResourceSpec doInit doRelease) a = do+ initVar <- liftIO $ newTVarIO NotCreated+ testTree <- a (getResource initVar)+ finishVar <- liftIO $ newTVarIO (testActionTreeSize testTree) let ini = Initializer doInit initVar fin = Finalizer doRelease initVar finishVar- tests' = map (first $ local $ (Seq.|> ini) *** (fin Seq.<|)) tests- return (tests', ResourceVar initVar : rvars)- wrap = Traversal . WriterT . fmap ((,) ())- unwrap = execWriterT . getTraversal+ pure $ TResource ini fin testTree + foldAfter :: OptionSet -> DependencyType -> Expr -> Tr -> Tr+ foldAfter _opts depType pat = local (second (Dependency depType (PatternDep pat) <|))++ foldGroup :: OptionSet -> TestName -> [Tr] -> Tr+ foldGroup opts name trees =+ fmap tGroup $ local (first (|> name)) $+ case lookupOption opts of+ Independent Parallel -> sequence trees+ Independent NonParallel -> foldSequential AllFinish trees+ Dependent depType -> foldSequential depType trees++ foldSequential :: DependencyType -> [Tr] -> ReaderT (Path, Seq Dependency) IO [TestActionTree UnresolvedAction]+ foldSequential depType =+ fmap snd . mapAccumM (goSeqGroup depType) mempty++ -- * Utility functions+ collectTests :: TestActionTree act -> [TestAction act]+ collectTests = \case+ TResource _ _ t -> collectTests t+ TGroup _ trees -> concatMap collectTests trees+ TAction action -> [action]++ collectFinalizers :: TestActionTree act -> Seq Finalizer+ collectFinalizers = \case+ TResource _ fin t -> collectFinalizers t |> fin+ TGroup _ trees -> mconcat (map collectFinalizers trees)+ TAction _ -> mempty++ goSeqGroup + :: DependencyType+ -> Seq Dependency+ -> Tr+ -> ReaderT (Path, Seq Dependency) IO (Seq Dependency, TestActionTree UnresolvedAction)+ goSeqGroup depType prevDeps treeM = do+ tree0 <- local (second (prevDeps ><)) treeM++ let+ toDep TestAction {..} = Dependency depType (ExactDep testPath testStatus)+ deps0 = Seq.fromList (toDep <$> collectTests tree0)++ -- If this test tree is empty (either due to it being actually empty, or due+ -- to all tests being filtered) we need to propagate the previous dependencies.+ deps1 = if Seq.null deps0 then prevDeps else deps0++ pure (deps1, tree0)++-- | Take care of the dependencies.+--+-- Return 'Left' if there is a dependency cycle, containing the detected cycles.+resolveDeps+ :: [TestAction ResolvedAction]+ -> Either [[Path]] [TestAction Action]+resolveDeps tests = maybeCheckCycles $ do+ TestAction { testAction=run_test, .. } <- tests++ let+ deps' = concatMap findDeps testDeps++ getStatus :: STM ActionStatus+ getStatus = foldr+ (\(deptype, statusvar, _) k -> do+ status <- readTVar statusvar+ case status of+ Done result+ | deptype == AllFinish || resultSuccessful result -> k+ | otherwise -> return ActionSkip+ _ -> return ActionWait+ )+ (return ActionReady)+ deps'+ let+ dep_paths = map (\(_, _, path) -> path) deps'+ action = Action+ { actionStatus = getStatus+ , actionRun = run_test+ , actionSkip = writeTVar testStatus $ Done $ Result+ -- See Note [Skipped tests]+ { resultOutcome = Failure TestDepFailed+ , resultDescription = ""+ , resultShortDescription = "SKIP"+ , resultTime = 0+ , resultDetailsPrinter = noResultDetails+ }+ }+ return (TestAction { testAction = action, .. }, (testPath, dep_paths))+ where+ -- Skip cycle checking if no patterns are used: sequential test groups can't+ -- introduce cycles on their own.+ maybeCheckCycles+ | any (any isPatternDependency . testDeps) tests = checkCycles+ | otherwise = Right . map fst++ findDeps :: Dependency -> [(DependencyType, TVar Status, Seq TestName)]+ findDeps (Dependency depType depSpec) =+ case depSpec of+ ExactDep testPath statusVar ->+ -- A dependency defined using 'TestGroup' has already been pinpointed+ -- to its 'statusVar' in 'createTestActions'.+ [(depType, statusVar, testPath)]+ PatternDep expr -> do+ -- A dependency defined using patterns needs to scan the whole test+ -- tree for matching tests.+ TestAction{testPath, testStatus} <- tests+ guard $ exprMatches expr testPath+ [(depType, testStatus, testPath)]++-- | Check a graph, given as an adjacency list, for cycles. Return 'Left' if the+-- graph contained cycles, or return all nodes in the graph as a 'Right' if it+-- didn't.+checkCycles :: Ord b => [(a, (b, [b]))] -> Either [[b]] [a]+checkCycles tests = do+ let+ result = fst <$> tests+ graph = [ (v, v, vs) | (v, vs) <- snd <$> tests ]+ sccs = stronglyConnComp graph+ cycles =+ flip mapMaybe sccs $ \case+ AcyclicSCC{} -> Nothing+ CyclicSCC vs -> Just vs++ case cycles of+ [] -> Right result+ _ -> Left cycles+ -- | Used to create the IO action which is passed in a WithResource node getResource :: TVar (Resource r) -> IO r getResource var =@@ -241,9 +542,74 @@ Destroyed -> throwSTM UseOutsideOfTest _ -> throwSTM $ unexpectedState "getResource" rState --- | Start running all the tests in a test tree in parallel, without--- blocking the current thread. The number of test running threads is--- determined by the 'NumThreads' option.+-- | Run a resource finalizer.+--+-- 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@@ -261,17 +627,29 @@ -- all resource initializers and finalizers, which is why it is more -- accurate than what could be measured from inside the first callback. -> IO a-launchTestTree opts tree k = do- (testActions, rvars) <- createTestActions opts tree- let NumThreads numTheads = lookupOption opts- (t,k) <- timed $ do- abortTests <- runInParallel numTheads (fst <$> testActions)- (do let smap = IntMap.fromList $ zip [0..] (snd <$> testActions)- k smap)- `finally` do+launchTestTree opts' tree' k0 = do+ -- Normally 'applyTopLevelPlusTestOptions' has been already applied by+ -- 'Test.Tasty.Ingredients.tryIngredients', but 'launchTestTree' is exposed+ -- publicly, so in principle clients could use it outside of 'tryIngredients'.+ -- Thus running 'applyTopLevelPlusTestOptions' again, just to be sure.+ let (opts, tree) = applyTopLevelPlusTestOptions opts' tree'+ (testActions, fins) <- createTestActions opts tree+ let NumThreads 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- waitForResources rvars- k t+ -- 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@@ -279,30 +657,31 @@ BeingCreated -> True FailedToCreate {} -> False Created {} -> True+ BeingDestroyed -> True Destroyed -> False - waitForResources rvars = atomically $- forM_ rvars $ \(ResourceVar rvar) -> do+ waitForResources fins = atomically $+ F.forM_ fins $ \(Finalizer _ rvar _) -> do res <- readTVar rvar check $ not $ alive res unexpectedState :: String -> Resource r -> SomeException unexpectedState where_ r = toException $ UnexpectedState where_ (show r) --- | Measure the time taken by an 'IO' action to run-timed :: IO a -> IO (Time, a)-timed t = do- start <- getTime- !r <- t- end <- getTime- return (end-start, r)+sleepIndefinitely :: IO ()+sleepIndefinitely = forever $ threadDelay (10^(7::Int)) --- | Get monotonic time------ Warning: This is not the system time, but a monotonically increasing time--- that facilitates reliable measurement of time differences.-getTime :: IO Time-getTime = do- t <- Clock.getTime Clock.Monotonic- let ns = realToFrac $ Clock.timeSpecAsNanoSecs t- return $ ns / 10 ^ (9 :: 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@@ -26,6 +28,7 @@ , ListTests(..) , testsNames -- * Command line handling+ , parseOptions , optionParser , suiteOptionParser , defaultMainWithIngredients@@ -36,9 +39,11 @@ , FailureReason(..) , resultSuccessful , Progress(..)+ , emptyProgress , StatusMap , launchTestTree , NumThreads(..)+ , DependencyException(..) -- * Options , suiteOptions , coreOptions
Test/Tasty/Runners/Reducers.hs view
@@ -41,19 +41,38 @@ module Test.Tasty.Runners.Reducers where -import Data.Monoid+import Prelude hiding (Applicative(..)) import Control.Applicative-import Prelude -- Silence AMP import warnings+import qualified Data.Semigroup as Sem --- | Monoid generated by '*>'+-- | Monoid generated by '*>'.+--+-- @since 0.8 newtype Traversal f = Traversal { getTraversal :: f () }++-- | @since 0.12.0.1+instance Applicative f => Sem.Semigroup (Traversal f) where+ Traversal f1 <> Traversal f2 = Traversal $ f1 *> f2 instance Applicative f => Monoid (Traversal f) where mempty = Traversal $ pure ()- Traversal f1 `mappend` Traversal f2 = Traversal $ f1 *> f2+#if !MIN_VERSION_base(4,11,0)+ mappend = (Sem.<>)+#endif -- | Monoid generated by @'liftA2' ('<>')@+--+-- Starting from GHC 8.6, a similar type is available from "Data.Monoid".+-- This type is nevertheless kept for compatibility.+--+-- @since 0.8 newtype Ap f a = Ap { getApp :: f a } deriving (Functor, Applicative, Monad)++-- | @since 0.12.0.1+instance (Applicative f, Monoid a) => Sem.Semigroup (Ap f a) where+ (<>) = liftA2 mappend instance (Applicative f, Monoid a) => Monoid (Ap f a) where mempty = pure mempty- mappend = liftA2 mappend+#if !MIN_VERSION_base(4,11,0)+ mappend = (Sem.<>)+#endif
Test/Tasty/Runners/Utils.hs view
@@ -1,27 +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.DeepSeq-import Control.Applicative-import Prelude -- Silence AMP import warnings+import Control.Concurrent (mkWeakThreadId, myThreadId)+import Control.Monad (forM_) import Text.Printf+import Foreign.C (CInt) +#if MIN_VERSION_base(4,11,0)+import GHC.Clock (getMonotonicTime)+#else+import Data.Time.Clock.POSIX (getPOSIXTime)+#endif++#ifdef VERSION_unix+#include "HsUnixConfig.h"+#ifdef HAVE_SIGNAL_H+#define INSTALL_HANDLERS 1+#else+#define INSTALL_HANDLERS 0+#endif+#else+#define INSTALL_HANDLERS 0+#endif++#if INSTALL_HANDLERS+import System.Posix.Signals+import System.Mem.Weak (deRefWeak)+#endif++import Test.Tasty.Core (Time)+ -- | Catch possible exceptions that may arise when evaluating a string. -- For normal (total) strings, this is a no-op. -- -- This function should be used to display messages generated by the test -- suite (such as test result descriptions). ----- See e.g. <https://github.com/feuerbach/tasty/issues/25>+-- See e.g. <https://github.com/UnkindPartition/tasty/issues/25>.+--+-- @since 0.10.1 formatMessage :: String -> IO String-formatMessage msg = go 3 msg+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 $ force msg+ mbStr <- try $ evaluate $ forceElements msg case mbStr of- Right str -> return str+ 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,8 +1,6 @@--- Initial tasty.cabal generated by cabal init. For further documentation,--- see http://haskell.org/cabal/users-guide/-+cabal-version: >=1.10 name: tasty-version: 0.11.3+version: 1.5.4 synopsis: Modern and extensible testing framework description: Tasty is a modern testing framework for Haskell. It lets you combine your unit tests, golden@@ -12,62 +10,80 @@ license-file: LICENSE author: Roman Cheplyaka <roma@ro-che.info> maintainer: Roman Cheplyaka <roma@ro-che.info>-homepage: https://github.com/feuerbach/tasty-bug-reports: https://github.com/feuerbach/tasty/issues--- copyright: +homepage: https://github.com/UnkindPartition/tasty+bug-reports: https://github.com/UnkindPartition/tasty/issues+-- copyright: category: Testing build-type: Simple extra-source-files: CHANGELOG.md, README.md-cabal-version: >=1.10 Source-repository head type: git- location: git://github.com/feuerbach/tasty.git+ location: https://github.com/UnkindPartition/tasty.git subdir: core +flag unix+ description:+ Depend on the unix package to install signal handlers+ default: True+ library exposed-modules:- Test.Tasty,- Test.Tasty.Options,- Test.Tasty.Providers,+ Test.Tasty+ Test.Tasty.Options+ Test.Tasty.Providers+ Test.Tasty.Providers.ConsoleFormat Test.Tasty.Runners- Test.Tasty.Ingredients,+ Test.Tasty.Ingredients Test.Tasty.Ingredients.Basic Test.Tasty.Ingredients.ConsoleReporter++ -- for testing only+ Test.Tasty.Patterns.Types+ Test.Tasty.Patterns.Parser+ Test.Tasty.Patterns.Printer+ Test.Tasty.Patterns.Eval other-modules:- Test.Tasty.Parallel,- Test.Tasty.Core,- Test.Tasty.Options.Core,- Test.Tasty.Options.Env,- Test.Tasty.Patterns,- Test.Tasty.Run,- Test.Tasty.Runners.Reducers,- Test.Tasty.Runners.Utils,- Test.Tasty.CmdLine,+ Control.Concurrent.Async+ Test.Tasty.Parallel+ Test.Tasty.Core+ Test.Tasty.Options.Core+ Test.Tasty.Options.Env+ Test.Tasty.Patterns+ Test.Tasty.Patterns.Expr+ Test.Tasty.Run+ Test.Tasty.Runners.Reducers+ Test.Tasty.Runners.Utils+ Test.Tasty.CmdLine Test.Tasty.Ingredients.ListTests Test.Tasty.Ingredients.IncludingOptions+ build-depends:- base >= 4.5 && < 5,- stm >= 2.3,- containers,- mtl,- tagged >= 0.5,- regex-tdfa >= 1.1.8.2,- optparse-applicative >= 0.11,- deepseq >= 1.3,- unbounded-delays >= 0.1,- async >= 2.0,- ansi-terminal >= 0.6.2,- clock >= 0.4.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 impl(ghc < 7.6)- -- for GHC.Generics- build-depends: ghc-prim+ -- No reason to depend on unbounded-delays on 64-bit architecture+ if(!arch(x86_64) && !arch(aarch64) && !arch(ppc64le) && !arch(ppc64) && !arch(s390x) && !arch(riscv64) && !arch(loongarch64))+ build-depends:+ unbounded-delays >= 0.1 && < 0.2 - if !os(windows)- build-depends: unix- cpp-options: -DUNIX+ if(!impl(ghc >= 8.4))+ build-depends: time >= 1.4 && < 1.13 - -- hs-source-dirs: + 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