tasty 1.5 → 1.5.4
raw patch · 22 files changed
Files
- CHANGELOG.md +63/−1
- Control/Concurrent/Async.hs +41/−17
- README.md +31/−10
- Test/Tasty.hs +2/−0
- Test/Tasty/CmdLine.hs +1/−5
- Test/Tasty/Core.hs +150/−31
- Test/Tasty/Ingredients.hs +8/−4
- Test/Tasty/Ingredients/ConsoleReporter.hs +82/−57
- Test/Tasty/Ingredients/ListTests.hs +2/−3
- Test/Tasty/Options.hs +2/−2
- Test/Tasty/Options/Core.hs +21/−9
- Test/Tasty/Options/Env.hs +1/−6
- Test/Tasty/Parallel.hs +7/−2
- Test/Tasty/Patterns.hs +11/−5
- Test/Tasty/Patterns/Eval.hs +0/−4
- Test/Tasty/Patterns/Parser.hs +1/−1
- Test/Tasty/Providers.hs +2/−16
- Test/Tasty/Providers/ConsoleFormat.hs +3/−3
- Test/Tasty/Run.hs +51/−21
- Test/Tasty/Runners/Reducers.hs +1/−1
- Test/Tasty/Runners/Utils.hs +2/−5
- tasty.cabal +21/−24
CHANGELOG.md view
@@ -1,6 +1,68 @@ 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 --------------- @@ -479,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 ---------------
Control/Concurrent/Async.hs view
@@ -36,7 +36,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} -{-# LANGUAGE DeriveDataTypeable, MagicHash, UnboxedTuples #-}+{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} module Control.Concurrent.Async ( async, withAsync, wait, asyncThreadId, cancel, concurrently@@ -44,14 +44,40 @@ 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 Data.Typeable-import GHC.Conc+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@@ -59,9 +85,9 @@ -- data Async a = Async { asyncThreadId :: {-# UNPACK #-} !ThreadId- -- ^ Returns the 'ThreadId' of the thread running- -- the given 'Async'.- , _asyncWait :: STM (Either SomeException a)+ -- ^ 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.@@ -103,11 +129,11 @@ withAsyncUsing doFork = \action inner -> do var <- newEmptyTMVarIO mask $ \restore -> do- t <- doFork $ try (restore action) >>= atomically . putTMVar var+ t <- doFork $ tryWithContext (restore action) >>= atomically . putTMVar var let a = Async t (readTMVar var)- r <- restore (inner a) `catchAll` \e -> do+ r <- restore (inner a) `catchNoPropagate` \e -> do uninterruptibleCancel a- throwIO e+ rethrowIO (e :: ExceptionWithContext SomeException) uninterruptibleCancel a return r @@ -131,7 +157,7 @@ -- > waitCatch = atomically . waitCatchSTM -- {-# INLINE waitCatch #-}-waitCatch :: Async a -> IO (Either SomeException a)+waitCatch :: Async a -> IO (Either (ExceptionWithContext SomeException) a) waitCatch = tryAgain . atomically . waitCatchSTM where -- See: https://github.com/simonmar/async/issues/14@@ -147,16 +173,16 @@ -- | A version of 'waitCatch' that can be used inside an STM transaction. -- {-# INLINE waitCatchSTM #-}-waitCatchSTM :: Async a -> STM (Either SomeException a)+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 `Async` thread to quit.--- Has no effect if the 'Async' has already completed.+-- 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 'Async'+-- 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. --@@ -172,13 +198,11 @@ -- | The exception thrown by `cancel` to terminate a thread. data AsyncCancelled = AsyncCancelled- deriving (Show, Eq, Typeable)+ deriving (Show, Eq) instance Exception AsyncCancelled where-#if __GLASGOW_HASKELL__ >= 708 fromException = asyncExceptionFromException toException = asyncExceptionToException-#endif -- | Cancel an asynchronous action --
README.md view
@@ -113,10 +113,12 @@ * [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.+ 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)).+ (based on [inspection-testing](http://hackage.haskell.org/package/inspection-testing))+* [tasty-flaky](https://hackage.haskell.org/package/tasty-flaky) — add delay and+ retry logic to any test that is known to fail intermittently [tasty-golden]: https://hackage.haskell.org/package/tasty-golden @@ -234,7 +236,7 @@ --quickcheck-max-size NUMBER Size of the biggest test cases quickcheck generates --quickcheck-max-ratio NUMBER- Maximum number of discared tests per successful test+ Maximum number of discarded tests per successful test before giving up --quickcheck-verbose Show the generated test cases --quickcheck-shrinks NUMBER@@ -701,14 +703,14 @@ 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 `sequentialTestGroup` combinator:+Dependencies are declared using the `after` or `dependentTestGroup` combinator: * `after AllFinish "pattern" my_tests` will execute the test tree `my_tests` only after all tests that match the pattern finish. * `after AllSucceed "pattern" my_tests` will execute the test tree `my_tests` only after all tests that match the pattern finish **and** only if they all succeed. If at least one dependency fails, then `my_tests` will be skipped.-* `sequentialTestGroup groupName dependencyType [tree1, tree2, ..]` will execute all tests+* `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`. @@ -721,7 +723,7 @@ -> TestTree -- ^ the subtree that depends on other tests -> TestTree -- ^ the subtree annotated with dependency information -sequentialTestGroup+dependentTestGroup :: TestName -- ^ name of the group -> DependencyType -- ^ whether to run the tests even if some of the dependencies fail -> [TestTree] -- ^ trees to execute sequentially@@ -790,7 +792,7 @@ test tree, searching for the next test to execute may also have an overhead quadratic in the number of tests. -Use `sequentialTestGroup` to mitigate these problems.+Use `dependentTestGroup` to mitigate these problems. ## FAQ@@ -820,9 +822,28 @@ 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` 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).+ **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
Test/Tasty.hs view
@@ -33,7 +33,9 @@ TestName , TestTree , testGroup+ , dependentTestGroup , sequentialTestGroup+ , inOrderTestGroup -- * Running tests , defaultMain , defaultMainWithIngredients
Test/Tasty/CmdLine.hs view
@@ -8,7 +8,6 @@ ) where import Control.Arrow-import Control.Monad import Data.Maybe import Data.Proxy import Data.Typeable (typeRep)@@ -16,7 +15,6 @@ import Options.Applicative.Common (evalParser) import qualified Options.Applicative.Types as Applicative (Option(..)) import Options.Applicative.Types (Parser(..), OptProperties(..))-import Prelude -- Silence AMP and FTP import warnings import System.Exit import System.IO #if !MIN_VERSION_base(4,11,0)@@ -156,9 +154,7 @@ mapM_ (hPutStrLn stderr) warnings cmdlineOpts <- execParser $ info (helper <*> parser)- ( fullDesc <>- header "Mmm... tasty test suite"- )+ (header "Mmm... tasty test suite") envOpts <- suiteEnvOptions ins tree return $ envOpts <> cmdlineOpts
Test/Tasty/Core.hs view
@@ -1,8 +1,11 @@ -- | Core types and definitions {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ImplicitParams #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-} module Test.Tasty.Core ( FailureReason(..) , Outcome(..)@@ -18,9 +21,12 @@ , ResourceError(..) , DependencyType(..) , ExecutionMode(..)+ , Parallel(..) , TestTree(..) , testGroup , sequentialTestGroup+ , dependentTestGroup+ , inOrderTestGroup , after , after_ , TreeFold(..)@@ -28,11 +34,15 @@ , foldTestTree , foldTestTree0 , treeOptions+ , testFailed ) where import Control.Exception+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 ((|>))@@ -48,6 +58,10 @@ import Text.Printf import Text.Read (readMaybe) +#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@@ -156,16 +170,28 @@ 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: " ++ displayException 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@@ -201,7 +227,7 @@ -- | 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).@@ -214,12 +240,43 @@ -- | The list of options that affect execution of tests of this type testOptions :: Tagged t [OptionDescription] +-- | @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@@ -230,7 +287,6 @@ = NotRunningTests | UnexpectedState String String | UseOutsideOfTest- deriving Typeable instance Show ResourceError where show NotRunningTests =@@ -264,19 +320,26 @@ -- | Determines mode of execution of a 'TestGroup' data ExecutionMode- = Sequential DependencyType- -- ^ Execute tests one after another- | Parallel- -- ^ Execute tests in parallel+ = 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 = Parallel+ defaultValue = Independent Parallel parseValue = readMaybe optionName = Tagged "execution-mode"- optionHelp = Tagged "Whether to execute tests sequentially or in parallel"+ optionHelp = Tagged "Whether tests have dependencies or not" optionCLParser = mkOptionCLParser internal -- | The main data structure defining a test suite.@@ -316,20 +379,68 @@ -- @since 1.2 -- | Create a named group of test cases or other groups. Tests are executed in--- parallel. For sequential execution, see 'sequentialTestGroup'.+-- parallel. For sequential execution, see 'dependentTestGroup'. -- -- @since 0.1 testGroup :: TestName -> [TestTree] -> TestTree testGroup = TestGroup --- | Create a named group of test cases or other groups. Tests are executed in--- order. For parallel execution, see 'testGroup'.+{-# DEPRECATED sequentialTestGroup "Use dependentTestGroup instead" #-}+-- | Legacy name for 'dependentTestGroup'.+--+-- @since 1.5 sequentialTestGroup :: TestName -> DependencyType -> [TestTree] -> TestTree-sequentialTestGroup nm depType = setSequential . TestGroup nm . map setParallel+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 Parallel)- setSequential = PlusTestOptions (setOption (Sequential depType))+ 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. --@@ -408,7 +519,7 @@ -- -- 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@@ -450,7 +561,7 @@ -- 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 'sequentialTestGroup'.+-- specified using 'dependentTestGroup'. type ForceTestMatch = Any -- | Fold a test tree into a single value.@@ -504,7 +615,7 @@ 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 'OptionSet'.+-- | '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).@@ -540,7 +651,7 @@ go :: Seq.Seq TestName -> AnnTestTree OptionSet -> AnnTestTree (OptionSet, Path) go path = \case AnnEmptyTestTree -> AnnEmptyTestTree- AnnSingleTest opts name tree -> + AnnSingleTest opts name tree -> AnnSingleTest (opts, path |> name) name tree AnnTestGroup opts name trees -> let newPath = path |> name in@@ -554,7 +665,15 @@ filterByPattern :: AnnTestTree (OptionSet, Path) -> AnnTestTree OptionSet filterByPattern = snd . go (Any False) where- go + 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)@@ -565,23 +684,23 @@ AnnSingleTest (opts, path) name tree | getAny forceMatch || testPatternMatches (lookupOption opts) path -> (Any True, AnnSingleTest opts name tree)- | otherwise + | otherwise -> (Any False, AnnEmptyTestTree) - AnnTestGroup (opts, _) name [] ->- (forceMatch, AnnTestGroup opts name [])+ AnnTestGroup _ _ [] ->+ (forceMatch, AnnEmptyTestTree) AnnTestGroup (opts, _) name trees -> case lookupOption opts of- Parallel ->+ Dependent _ ->+ second+ (mkGroup opts name)+ (mapAccumR go forceMatch trees)+ Independent _ -> bimap mconcat- (AnnTestGroup opts name)+ (mkGroup opts name) (unzip (map (go forceMatch) trees))- Sequential _ ->- second- (AnnTestGroup opts name)- (mapAccumR go forceMatch trees) AnnWithResource (opts, _) res0 tree -> ( fst (go forceMatch (tree (throwIO NotRunningTests)))
Test/Tasty/Ingredients.hs view
@@ -36,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.@@ -87,11 +87,13 @@ -- | 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@@ -106,14 +108,16 @@ -- -- @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]
Test/Tasty/Ingredients/ConsoleReporter.hs view
@@ -1,5 +1,5 @@ -- vim:fdm=marker-{-# LANGUAGE BangPatterns, ImplicitParams, MultiParamTypeClasses, DeriveDataTypeable, FlexibleContexts, CApiFFI, NamedFieldPuns #-}+{-# LANGUAGE BangPatterns, ImplicitParams, MultiParamTypeClasses, FlexibleContexts, CApiFFI, NamedFieldPuns #-} -- | Console reporter ingredient. -- -- @since 0.11.3@@ -50,6 +50,7 @@ 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(..))@@ -65,6 +66,7 @@ #if !MIN_VERSION_base(4,11,0) import Data.Foldable (foldMap) #endif+import System.IO.Unsafe -------------------------------------------------- -- TestOutput base definitions@@ -123,7 +125,28 @@ 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@@ -131,10 +154,12 @@ 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- AnsiTricks{getAnsiTricks} = lookupOption opts runSingleTest :: (IsTest t, ?colors :: Bool)@@ -151,10 +176,8 @@ name (replicate postNamePadding ' ') - resultPosition = length testNamePadded- printTestName = do- putStr testNamePadded+ withoutLineWrap $ putStr testNamePadded hFlush stdout printTestProgress progress@@ -170,11 +193,13 @@ ("", pct) -> printf "%.0f%% " pct (txt, 0.0) -> printf "%s" txt (txt, pct) -> printf "%s: %.0f%% " txt pct- setCursorColumn resultPosition- infoOk msg+ putChar '\r' -- A new progress message may be shorter than the previous one- -- so we must clean until the end of the line- clearFromCursorToLineEnd+ -- so we must clean whole line and print anew.+ clearLine+ withoutLineWrap $ do+ putStr testNamePadded+ infoOk msg hFlush stdout printTestResult result = do@@ -189,9 +214,11 @@ _ -> fail time = resultTime result - when getAnsiTricks $ do- setCursorColumn resultPosition- clearFromCursorToLineEnd+ withoutLineWrap $ do+ when getAnsiTricks $ do+ putChar '\r'+ clearLine+ putStr testNamePadded printFn (resultShortDescription result) when (floor (time * 1e6) >= minDurationMicros) $@@ -210,7 +237,7 @@ runGroup _opts name grp = Ap $ do level <- ask let- printHeading = printf "%s%s\n" (indent level) name+ printHeading = withoutLineWrap $ printf "%s%s\n" (indent level) name printBody = runReader (getApp (mconcat grp)) (level + 1) return $ PrintHeading name printHeading printBody @@ -222,7 +249,19 @@ , 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.@@ -237,7 +276,7 @@ :: Monoid b => (String -> IO () -> IO Result -> (Result -> IO ()) -> b) -- ^ Eliminator for test cases. The @IO ()@ prints the testname. The- -- @IO Result@ blocks until the test is finished, returning it's 'Result'.+ -- @IO Result@ blocks until the test is finished, returning it's t'Result'. -- The @Result -> IO ()@ function prints the formatted output. -> (String -> IO () -> b -> b) -- ^ Eliminator for test groups. The @IO ()@ prints the test group's name.@@ -294,8 +333,9 @@ , Any True) foldHeading _name printHeading (printBody, Any nonempty) = ( Traversal $ do- when nonempty $ printHeading- getTraversal printBody+ when nonempty $ do+ printHeading :: IO ()+ getTraversal printBody , Any nonempty ) @@ -380,7 +420,7 @@ mappend = (Sem.<>) #endif --- | @computeStatistics@ computes a summary 'Statistics' for+-- | @computeStatistics@ computes a summary t'Statistics' for -- a given state of the 'StatusMap'. -- Useful in combination with 'printStatistics'. --@@ -433,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@@ -447,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 -- }}}@@ -548,7 +588,9 @@ isTermColor <- hSupportsANSIColor stdout (\k -> if isTerm- then (do hideCursor; k) `finally` showCursor+ -- When killing with Ctrl+C 'showCursor' can fail+ -- to restore terminal cursor if not flushed explicitly+ then (do hideCursor; k) `finally` (do showCursor; hFlush stdout) else k) $ do hSetBuffering stdout LineBuffering@@ -580,7 +622,7 @@ -- -- @since 0.8 newtype Quiet = Quiet Bool- deriving (Eq, Ord, Typeable)+ deriving (Eq, Ord) instance IsOption Quiet where defaultValue = Quiet False parseValue = fmap Quiet . safeReadBool@@ -595,7 +637,7 @@ -- -- @since 0.8 newtype HideSuccesses = HideSuccesses Bool- deriving (Eq, Ord, Typeable)+ deriving (Eq, Ord) instance IsOption HideSuccesses where defaultValue = HideSuccesses False parseValue = fmap HideSuccesses . safeReadBool@@ -608,7 +650,7 @@ -- -- @since 1.5 newtype MinDurationToReport = MinDurationToReport { minDurationMicros :: Integer }- deriving (Eq, Ord, Typeable)+ deriving (Eq, Ord) instance IsOption MinDurationToReport where defaultValue = MinDurationToReport 10000 parseValue = fmap MinDurationToReport . parseDuration@@ -627,7 +669,7 @@ = 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@@ -655,7 +697,6 @@ -- -- @since 1.3 newtype AnsiTricks = AnsiTricks { getAnsiTricks :: Bool }- deriving Typeable instance IsOption AnsiTricks where defaultValue = AnsiTricks True@@ -749,35 +790,19 @@ then paddedDesc else chomped -data Maximum a- = Maximum a- | MinusInfinity--instance Ord a => Sem.Semigroup (Maximum a) where- Maximum a <> Maximum b = Maximum (a `max` b)- MinusInfinity <> a = a- a <> MinusInfinity = a-instance Ord a => Monoid (Maximum a) where- mempty = MinusInfinity-#if !MIN_VERSION_base(4,11,0)- mappend = (Sem.<>)-#endif- -- | Compute the amount of space needed to align \"OK\"s and \"FAIL\"s computeAlignment :: OptionSet -> TestTree -> Int computeAlignment opts =- fromMonoid .- foldTestTree- trivialFold- { foldSingle = \_ name _ level -> Maximum (stringWidth name + level)- , foldGroup = \_opts _ m -> mconcat 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@@ -820,7 +845,7 @@ -- line or console detection. -- -- Can be used by providers that wish to provider specific result details printing,--- while re-using the tasty formats and coloring logic.+-- while reusing the tasty formats and coloring logic. -- -- @since 1.3.1 withConsoleFormat :: (?colors :: Bool) => ConsoleFormatPrinter
Test/Tasty/Ingredients/ListTests.hs view
@@ -1,5 +1,5 @@ -- | Ingredient for listing test names-{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, DeriveDataTypeable #-}+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} module Test.Tasty.Ingredients.ListTests ( ListTests(..) , testsNames@@ -7,7 +7,6 @@ ) where import Data.Proxy-import Data.Typeable import Options.Applicative import Test.Tasty.Core@@ -19,7 +18,7 @@ -- -- @since 0.4 newtype ListTests = ListTests Bool- deriving (Eq, Ord, Typeable)+ deriving (Eq, Ord) instance IsOption ListTests where defaultValue = ListTests False parseValue = fmap ListTests . safeReadBool
Test/Tasty/Options.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable,+{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, GADTs, FlexibleInstances, UndecidableInstances, TypeOperators #-}@@ -135,7 +135,7 @@ 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
Test/Tasty/Options/Core.hs view
@@ -1,5 +1,5 @@ -- | Core options, i.e. the options used by tasty itself-{-# LANGUAGE CPP, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} -- for (^) module Test.Tasty.Options.Core ( NumThreads(..)@@ -14,13 +14,14 @@ import Control.Monad (mfilter) import Data.Proxy-import Data.Typeable import Data.Fixed import Options.Applicative hiding (str) import GHC.Conc #if !MIN_VERSION_base(4,11,0) import Data.Monoid #endif+import Control.Concurrent+import System.IO.Unsafe import Test.Tasty.Options import Test.Tasty.Patterns@@ -36,14 +37,15 @@ -- -- @since 0.1 newtype NumThreads = NumThreads { getNumThreads :: Int }- deriving (Eq, Ord, Num, Typeable)+ deriving (Eq, Ord, Num) instance IsOption NumThreads where- defaultValue = NumThreads numCapabilities+ defaultValue = unsafePerformIO $ NumThreads <$>+ if rtsSupportsBoundThreads then getNumProcessors else pure 1 parseValue = mfilter onlyPositive . fmap NumThreads . safeRead optionName = return "num-threads" optionHelp = return "Number of threads to use for tests execution" optionCLParser = mkOptionCLParser (short 'j' <> metavar "NUMBER")- showDefaultValue _ = Just "# of cores/capabilities"+ 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@@ -58,7 +60,17 @@ -- @\"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@@ -88,7 +100,7 @@ _ -> Nothing _ -> Nothing --- | A shortcut for creating 'Timeout' values.+-- | A shortcut for creating v'Timeout' values. -- -- @since 0.8 mkTimeout@@ -105,7 +117,7 @@ -- -- @since 1.5 newtype HideProgress = HideProgress { getHideProgress :: Bool }- deriving (Eq, Ord, Typeable)+ deriving (Eq, Ord) instance IsOption HideProgress where defaultValue = HideProgress False parseValue = fmap HideProgress . safeReadBool@@ -115,7 +127,7 @@ -- | 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]
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) =
Test/Tasty/Parallel.hs view
@@ -1,5 +1,4 @@ -- | A helper module which takes care of parallelism-{-# LANGUAGE DeriveDataTypeable #-} module Test.Tasty.Parallel (ActionStatus(..), Action(..), runInParallel) where import Control.Monad@@ -8,7 +7,7 @@ import Control.Concurrent.STM import Foreign.StablePtr --- | What to do about an 'Action'?+-- | What to do about an t'Action'? data ActionStatus = ActionReady -- ^ the action is ready to be executed@@ -42,6 +41,12 @@ -- 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
Test/Tasty/Patterns.hs view
@@ -1,6 +1,6 @@ -- | Test patterns -{-# LANGUAGE CPP, DeriveDataTypeable, TypeApplications #-}+{-# LANGUAGE CPP, TypeApplications #-} module Test.Tasty.Patterns ( TestPattern(..)@@ -21,7 +21,6 @@ import Data.Coerce (coerce) import Data.List.NonEmpty (nonEmpty) import Data.Maybe (catMaybes)-import Data.Typeable import Options.Applicative hiding (Success) #if !MIN_VERSION_base(4,11,0) import Data.Monoid@@ -33,8 +32,7 @@ TestPattern (Maybe Expr) deriving- ( Typeable- , Show -- ^ @since 1.1+ ( Show -- ^ @since 1.1 , Eq -- ^ @since 1.1 ) @@ -48,7 +46,15 @@ defaultValue = noPattern parseValue = parseTestPattern optionName = return "pattern"- optionHelp = return "Select only tests which satisfy a pattern or awk expression"+#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")
Test/Tasty/Patterns/Eval.hs view
@@ -12,10 +12,6 @@ import Data.Maybe import Data.Char import Test.Tasty.Patterns.Types-#if !MIN_VERSION_base(4,9,0)-import Control.Applicative-import Data.Traversable-#endif -- | @since 1.2 type Path = Seq.Seq String
Test/Tasty/Patterns/Parser.hs view
@@ -25,7 +25,7 @@ type Token = ReadP --- | A separate 'Parser' data type ensures that we don't forget to skip+-- | A separate t'Parser' data type ensures that we don't forget to skip -- spaces. -- -- @since 1.0
Test/Tasty/Providers.hs view
@@ -23,7 +23,7 @@ singleTest :: IsTest t => TestName -> t -> TestTree singleTest = SingleTest --- | 'Result' of a passed test.+-- | t'Result' of a passed test. -- -- @since 0.8 testPassed@@ -37,21 +37,7 @@ , resultDetailsPrinter = noResultDetails } --- | '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- }---- | 'Result' of a failed test with custom details printer+-- | t'Result' of a failed test with custom details printer -- -- @since 1.3.1 testFailedDetails
Test/Tasty/Providers/ConsoleFormat.hs view
@@ -1,5 +1,5 @@ -- | This module can be used by providers to perform colorful/formatted--- output and possibly re-use tasty's own output formats.+-- output and possibly reuse tasty's own output formats. -- -- @since 1.3.1 module Test.Tasty.Providers.ConsoleFormat@@ -68,13 +68,13 @@ infoFailFormat :: ConsoleFormat infoFailFormat = ConsoleFormat NormalIntensity Dull Red --- | Format used to display sucesses+-- | Format used to display successes -- -- @since 1.3.1 okFormat :: ConsoleFormat okFormat = ConsoleFormat NormalIntensity Dull Green --- | Format used to display additional information on sucesses+-- | Format used to display additional information on successes -- -- @since 1.3.1 infoOkFormat :: ConsoleFormat
Test/Tasty/Run.hs view
@@ -1,15 +1,16 @@ -- | Running tests {-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes,- FlexibleContexts, CPP, DeriveDataTypeable, LambdaCase,+ 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)@@ -17,7 +18,6 @@ import Data.List (intercalate) import Data.Graph (SCC(..), stronglyConnComp) import Data.Sequence (Seq, (|>), (<|), (><))-import Data.Typeable import Control.Monad (forever, guard, join, liftM) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Reader (ReaderT(..), local, ask)@@ -26,11 +26,9 @@ import Control.Concurrent.STM import Control.Concurrent.Async import Control.Exception as E-import Control.Applicative import Control.Arrow import Data.Monoid (First(..)) import GHC.Conc (labelThread)-import Prelude -- Silence AMP and FTP import warnings #if MIN_VERSION_base(4,18,0) import Data.Traversable (mapAccumM)@@ -136,7 +134,7 @@ timed $ applyTimeout timeoutOpt $ do r <- wait asy -- Not only wait for the result to be returned, but make sure to- -- evalute it inside applyTimeout; see #280.+ -- evaluate it inside applyTimeout; see #280. evaluate $ resultOutcome r `seq` forceElements (resultDescription r) `seq`@@ -248,7 +246,6 @@ -- A finishes. Field lists detected cycles. -- -- @since 1.5- deriving (Typeable) instance Show DependencyException where show (DependencyLoop css) = "Test dependencies have cycles:\n" ++ showCycles css@@ -281,7 +278,7 @@ data Dependency = Dependency DependencyType DependencySpec deriving (Eq, Show) --- | Is given 'Dependency' a dependency that was introduced with 'After'?+-- | Is given t'Dependency' a dependency that was introduced with 'After'? isPatternDependency :: Dependency -> Bool isPatternDependency (Dependency _ (PatternDep {})) = True isPatternDependency _ = False@@ -290,7 +287,7 @@ -- 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 accummulator is often used for caching the+-- 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, [])@@ -303,7 +300,7 @@ -- | An action with meta information data TestAction act = TestAction { testAction :: act- -- ^ Some action, typically 'UnresolvedAction', 'ResolvedAction', or 'Action'.+ -- ^ 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@@ -324,8 +321,8 @@ type Size = Int -- | Simplified version of 'TestTree' that only includes the tests to be run (as--- a 'TestAction') and the resources needed to run them (as 'Initializer's and--- 'Finalizer's).+-- 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]@@ -418,11 +415,14 @@ foldGroup opts name trees = fmap tGroup $ local (first (|> name)) $ case lookupOption opts of- Parallel ->- sequence trees- Sequential depType ->- snd <$> mapAccumM (goSeqGroup depType) mempty trees+ 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@@ -576,12 +576,37 @@ FailedToCreate {} -> return $ return Nothing Destroyed -> return $ return Nothing +-- While tasty allows to configure t'OptionSet' at any level of test tree,+-- it often has any effect only on options of test providers (class IsTest).+-- But test runners and reporters typically only look into the OptionSet+-- they were given as an argument. This is not unreasonable: e. g., if an option+-- is a log filename you cannot expect to change it in the middle of the run.+-- It is however too restrictive: there is no way to use 'defaultMain' but hardcode+-- a global option, without passing it via command line.+--+-- 'applyTopLevelPlusTestOptions' allows for a compromise: unwrap top-level+-- 'PlusTestOptions' from the 'TestTree' and apply them to the t'OptionSet'+-- from command line. This way a user can wrap their tests in+-- 'adjustOption' / 'localOption' forcing, for instance, t'NumThreads' to 1.+--+-- This function is not publicly exposed.+applyTopLevelPlusTestOptions+ :: OptionSet+ -- ^ Raw options, typically from the command-line arguments.+ -> TestTree+ -- ^ Raw test tree.+ -> (OptionSet, TestTree)+ -- ^ Extended options and test tree stripped of outer layers of 'PlusTestOptions'.+applyTopLevelPlusTestOptions opts (PlusTestOptions f tree) =+ applyTopLevelPlusTestOptions (f opts) tree+applyTopLevelPlusTestOptions opts tree = (opts, tree)+ -- | Start running the tests (in background, in parallel) and pass control -- to the callback. -- -- Once the callback returns, stop running the tests. ----- The number of test running threads is determined by the 'NumThreads'+-- The number of test running threads is determined by the t'NumThreads' -- option. -- -- @since 0.10@@ -602,12 +627,17 @@ -- all resource initializers and finalizers, which is why it is more -- accurate than what could be measured from inside the first callback. -> IO a-launchTestTree opts tree k0 = do+launchTestTree opts' tree' k0 = do+ -- Normally 'applyTopLevelPlusTestOptions' has been already applied by+ -- 'Test.Tasty.Ingredients.tryIngredients', but 'launchTestTree' is exposed+ -- publicly, so in principle clients could use it outside of 'tryIngredients'.+ -- Thus running 'applyTopLevelPlusTestOptions' again, just to be sure.+ let (opts, tree) = applyTopLevelPlusTestOptions opts' tree' (testActions, fins) <- createTestActions opts tree- let NumThreads numTheads = lookupOption opts+ let NumThreads numThreads = lookupOption opts (t,k1) <- timed $ do- abortTests <- runInParallel numTheads (testAction <$> testActions)- (do let smap = IntMap.fromList $ zip [0..] (testStatus <$> testActions)+ abortTests <- runInParallel numThreads (testAction <$> testActions)+ (do let smap = IntMap.fromDistinctAscList $ zip [0..] (testStatus <$> testActions) k0 smap) `finallyRestore` \restore -> do -- Tell all running tests to wrap up.
Test/Tasty/Runners/Reducers.hs view
@@ -41,8 +41,8 @@ module Test.Tasty.Runners.Reducers where +import Prelude hiding (Applicative(..)) import Control.Applicative-import Prelude -- Silence AMP import warnings import qualified Data.Semigroup as Sem -- | Monoid generated by '*>'.
Test/Tasty/Runners/Utils.hs view
@@ -4,11 +4,8 @@ module Test.Tasty.Runners.Utils where import Control.Exception-import Control.Applicative import Control.Concurrent (mkWeakThreadId, myThreadId) import Control.Monad (forM_)-import Data.Typeable (Typeable)-import Prelude -- Silence AMP import warnings import Text.Printf import Foreign.C (CInt) @@ -66,7 +63,7 @@ -- from https://ro-che.info/articles/2014-07-30-bracket -- | Install signal handlers so that e.g. the cursor is restored if the test--- suite is killed by SIGTERM. Upon a signal, a 'SignalException' will be+-- suite is killed by SIGTERM. Upon a signal, a t'SignalException' will be -- thrown to the thread that has executed this action. -- -- This function is called automatically from the @defaultMain*@ family of@@ -102,7 +99,7 @@ -- -- @since 1.2.1 newtype SignalException = SignalException CInt- deriving (Show, Typeable)+ deriving (Show) instance Exception SignalException -- | Measure the time taken by an 'IO' action to run.
tasty.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: tasty-version: 1.5+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@@ -29,12 +29,12 @@ library exposed-modules:- Test.Tasty,- Test.Tasty.Options,- Test.Tasty.Providers,- Test.Tasty.Providers.ConsoleFormat,+ 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 @@ -45,36 +45,33 @@ Test.Tasty.Patterns.Eval other-modules: Control.Concurrent.Async- Test.Tasty.Parallel,- Test.Tasty.Core,- Test.Tasty.Options.Core,- Test.Tasty.Options.Env,- Test.Tasty.Patterns,- Test.Tasty.Patterns.Expr,- Test.Tasty.Run,- Test.Tasty.Runners.Reducers,- Test.Tasty.Runners.Utils,- Test.Tasty.CmdLine,+ Test.Tasty.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.9 && < 5, stm >= 2.3 && < 2.6,- containers < 0.7,+ containers >= 0.5.8 && < 0.9, transformers >= 0.5 && < 0.7, tagged >= 0.5 && < 0.9,- optparse-applicative >= 0.14 && < 0.19,- ansi-terminal >= 0.9 && < 1.1+ optparse-applicative >= 0.14 && < 0.20,+ ansi-terminal >= 0.9 && < 1.2 -- No reason to depend on unbounded-delays on 64-bit architecture- if(!arch(x86_64) && !arch(aarch64))+ if(!arch(x86_64) && !arch(aarch64) && !arch(ppc64le) && !arch(ppc64) && !arch(s390x) && !arch(riscv64) && !arch(loongarch64)) build-depends: unbounded-delays >= 0.1 && < 0.2 - if(!impl(ghc >= 8.0))- build-depends: semigroups < 0.21- if(!impl(ghc >= 8.4)) build-depends: time >= 1.4 && < 1.13 @@ -85,7 +82,7 @@ -- hs-source-dirs: default-language: Haskell2010- default-extensions: CPP, ScopedTypeVariables, DeriveDataTypeable+ default-extensions: CPP, ScopedTypeVariables ghc-options: -Wall -Wno-incomplete-uni-patterns