-- | Core types and definitions
{-# 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 Control.Monad.Trans.Cont (ContT(..))
import Data.Coerce (coerce)
import qualified Data.Map as Map
import Data.Bifunctor (Bifunctor(second, bimap))
import Data.IORef (newIORef, readIORef, atomicModifyIORef')
import Data.List (mapAccumR)
import Data.Monoid (Any (getAny, Any))
import Data.Sequence ((|>))
import qualified Data.Sequence as Seq
import Data.Tagged
import Data.Typeable
import GHC.Generics
import Options.Applicative (internal)
import Test.Tasty.Options
import Test.Tasty.Patterns
import Test.Tasty.Patterns.Types
import Test.Tasty.Providers.ConsoleFormat
import Text.Printf
import Text.Read (readMaybe)

#if MIN_VERSION_base(4,21,0) && !MIN_VERSION_base(4,22,0)
import Control.Exception.Context
#endif

-- | If a test failed, 'FailureReason' describes why.
--
-- @since 0.8
data FailureReason
  = TestFailed
    -- ^ test provider indicated failure of the code to test, either because
    -- the tested code returned wrong results, or raised an exception
  | TestThrewException SomeException
    -- ^ the test code itself raised an exception. Typical cases include missing
    -- example input or output files.
    --
    -- Usually, providers do not have to implement this, as their 'run' method
    -- may simply raise an exception.
  | TestTimedOut Integer
    -- ^ test didn't complete in allotted time
  | TestDepFailed -- See Note [Skipped tests]
    -- ^ a dependency of this test failed, so this test was skipped.
    --
    -- @since 1.2
  deriving Int -> FailureReason -> ShowS
[FailureReason] -> ShowS
FailureReason -> TestName
(Int -> FailureReason -> ShowS)
-> (FailureReason -> TestName)
-> ([FailureReason] -> ShowS)
-> Show FailureReason
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FailureReason -> ShowS
showsPrec :: Int -> FailureReason -> ShowS
$cshow :: FailureReason -> TestName
show :: FailureReason -> TestName
$cshowList :: [FailureReason] -> ShowS
showList :: [FailureReason] -> ShowS
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 (Int -> Outcome -> ShowS
[Outcome] -> ShowS
Outcome -> TestName
(Int -> Outcome -> ShowS)
-> (Outcome -> TestName) -> ([Outcome] -> ShowS) -> Show Outcome
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Outcome -> ShowS
showsPrec :: Int -> Outcome -> ShowS
$cshow :: Outcome -> TestName
show :: Outcome -> TestName
$cshowList :: [Outcome] -> ShowS
showList :: [Outcome] -> ShowS
Show, (forall x. Outcome -> Rep Outcome x)
-> (forall x. Rep Outcome x -> Outcome) -> Generic Outcome
forall x. Rep Outcome x -> Outcome
forall x. Outcome -> Rep Outcome x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Outcome -> Rep Outcome x
from :: forall x. Outcome -> Rep Outcome x
$cto :: forall x. Rep Outcome x -> Outcome
to :: forall x. Rep Outcome x -> Outcome
Generic)

-- | Time in seconds. Used to measure how long the tests took to run.
--
-- @since 0.10
type Time = Double

-- | A test result.
--
-- @since 0.1
data Result = Result
  { Result -> Outcome
resultOutcome :: Outcome
    -- ^ Did the test fail? If so, why?
  , Result -> TestName
resultDescription :: String
    -- ^
    -- 'resultDescription' may contain some details about the test. For
    -- a passed test it's ok to leave it empty. Providers like SmallCheck and
    -- QuickCheck use it to provide information about how many tests were
    -- generated.
    --
    -- For a failed test, 'resultDescription' should typically provide more
    -- information about the failure.
    --
    -- @since 0.11
  , Result -> TestName
resultShortDescription :: String
    -- ^ The short description printed in the test run summary, usually @OK@ or
    -- @FAIL@.
    --
    -- @since 0.10
  , Result -> Time
resultTime :: Time
    -- ^ How long it took to run the test, in seconds.
  , Result -> ResultDetailsPrinter
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
  ( Int -> Result -> ShowS
[Result] -> ShowS
Result -> TestName
(Int -> Result -> ShowS)
-> (Result -> TestName) -> ([Result] -> ShowS) -> Show Result
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Result -> ShowS
showsPrec :: Int -> Result -> ShowS
$cshow :: Result -> TestName
show :: Result -> TestName
$cshowList :: [Result] -> ShowS
showList :: [Result] -> ShowS
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 :: Result -> Bool
resultSuccessful Result
r =
  case Result -> Outcome
resultOutcome Result
r of
    Outcome
Success -> Bool
True
    Failure {} -> Bool
False

-- | Shortcut for creating a t'Result' that indicates exception
exceptionResult :: SomeException -> Result
exceptionResult :: SomeException -> Result
exceptionResult SomeException
e = Result
  { resultOutcome :: Outcome
resultOutcome = FailureReason -> Outcome
Failure (FailureReason -> Outcome) -> FailureReason -> Outcome
forall a b. (a -> b) -> a -> b
$ SomeException -> FailureReason
TestThrewException SomeException
e
  , resultDescription :: TestName
resultDescription = TestName
"Exception: " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> TestName
displayException' SomeException
e
  , resultShortDescription :: TestName
resultShortDescription = TestName
"FAIL"
  , resultTime :: Time
resultTime = Time
0
  , resultDetailsPrinter :: ResultDetailsPrinter
resultDetailsPrinter = ResultDetailsPrinter
noResultDetails
  }

displayException' :: SomeException -> String
#if MIN_VERSION_base(4,22,0)
displayException' = displayExceptionWithInfo
#elif MIN_VERSION_base(4,21,0)
displayException' :: SomeException -> TestName
displayException' (SomeException e
e) =
  e -> TestName
forall e. Exception e => e -> TestName
displayException e
e TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ case ExceptionContext -> TestName
displayExceptionContext HasExceptionContext
ExceptionContext
?exceptionContext of
    TestName
"" -> TestName
""
    TestName
dc -> TestName
"\n\n" TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
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
  { Progress -> TestName
progressText :: String
    -- ^ textual information about the test's progress
  , Progress -> Float
progressPercent :: Float
    -- ^
    -- 'progressPercent' should be a value between 0 and 1. If it's impossible
    -- to compute the estimate, use 0.
  }
  deriving
  ( Int -> Progress -> ShowS
[Progress] -> ShowS
Progress -> TestName
(Int -> Progress -> ShowS)
-> (Progress -> TestName) -> ([Progress] -> ShowS) -> Show Progress
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Progress -> ShowS
showsPrec :: Int -> Progress -> ShowS
$cshow :: Progress -> TestName
show :: Progress -> TestName
$cshowList :: [Progress] -> ShowS
showList :: [Progress] -> ShowS
Show -- ^ @since 1.2
  , Progress -> Progress -> Bool
(Progress -> Progress -> Bool)
-> (Progress -> Progress -> Bool) -> Eq Progress
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Progress -> Progress -> Bool
== :: Progress -> Progress -> Bool
$c/= :: Progress -> Progress -> Bool
/= :: Progress -> Progress -> Bool
Eq   -- ^ @since 1.5
  )

-- | Empty progress
--
-- @since 1.5
emptyProgress :: Progress
emptyProgress :: Progress
emptyProgress = TestName -> Float -> Progress
Progress TestName
forall a. Monoid a => a
mempty Float
0.0

-- | The interface to be implemented by a test provider.
--
-- The type @t@ is the concrete representation of the test which is used by
-- the provider.
--
-- @since 0.1
class Typeable t => IsTest t where
  -- | Run the test
  --
  -- This method should cleanly catch any exceptions in the code to test, and
  -- return them as part of the t'Result', see 'FailureReason' for an
  -- explanation. It is ok for 'run' to raise an exception if there is a
  -- problem with the test suite code itself (for example, if a file that
  -- should contain example data or expected output is not found).
  run
    :: OptionSet -- ^ options
    -> t -- ^ the test to run
    -> (Progress -> IO ()) -- ^ a callback to report progress.
    -> IO Result

  -- | 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 :: Tagged (ContT () IO t) [OptionDescription]
testOptions = Tagged t [OptionDescription]
-> Tagged (ContT () IO t) [OptionDescription]
forall a b. Coercible a b => a -> b
coerce (forall t. IsTest t => Tagged t [OptionDescription]
testOptions @t)
  run :: OptionSet -> ContT () IO t -> (Progress -> IO ()) -> IO Result
run OptionSet
opts (ContT (t -> IO ()) -> IO ()
k) Progress -> IO ()
yieldProgress = do
    resRef <- Maybe Result -> IO (IORef (Maybe Result))
forall a. a -> IO (IORef a)
newIORef Maybe Result
forall a. Maybe a
Nothing
    let runInIORef :: t -> IO ()
        runInIORef t
t = do
          res <- OptionSet -> t -> (Progress -> IO ()) -> IO Result
forall t.
IsTest t =>
OptionSet -> t -> (Progress -> IO ()) -> IO Result
run OptionSet
opts t
t Progress -> IO ()
yieldProgress
          let err = TestName -> Result
testFailed TestName
"Continuation was called multiple times"
          atomicModifyIORef' resRef $ \Maybe Result
prev ->
            (Result -> Maybe Result
forall a. a -> Maybe a
Just (Result -> Maybe Result) -> Result -> Maybe Result
forall a b. (a -> b) -> a -> b
$ Result -> (Result -> Result) -> Maybe Result -> Result
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Result
res (Result -> Result -> Result
forall a b. a -> b -> a
const Result
err) Maybe Result
prev, ())
    k runInIORef
    maybeRes <- readIORef resRef
    pure $ case maybeRes of
      Maybe Result
Nothing -> TestName -> Result
testFailed TestName
"Continuation was not called"
      Just Result
r -> Result
r

-- | t'Result' of a failed test.
--
-- @since 0.8
testFailed
  :: String -- ^ description
  -> Result
testFailed :: TestName -> Result
testFailed TestName
desc = Result
  { resultOutcome :: Outcome
resultOutcome = FailureReason -> Outcome
Failure FailureReason
TestFailed
  , resultDescription :: TestName
resultDescription = TestName
desc
  , resultShortDescription :: TestName
resultShortDescription = TestName
"FAIL"
  , resultTime :: Time
resultTime = Time
0
  , resultDetailsPrinter :: ResultDetailsPrinter
resultDetailsPrinter = ResultDetailsPrinter
noResultDetails
  }

-- | The name of a test or a group of tests.
--
-- @since 0.1
type TestName = String

-- | t'ResourceSpec' describes how to acquire a resource (the first field)
-- and how to release it (the second field).
--
-- @since 0.6
data ResourceSpec a = ResourceSpec (IO a) (a -> IO ())

-- | A resources-related exception
data ResourceError
  = NotRunningTests
  | UnexpectedState String String
  | UseOutsideOfTest

instance Show ResourceError where
  show :: ResourceError -> TestName
show ResourceError
NotRunningTests =
    TestName
"Unhandled resource. Probably a bug in the runner you're using."
  show (UnexpectedState TestName
where_ TestName
what) =
    TestName -> TestName -> ShowS
forall r. PrintfType r => TestName -> r
printf TestName
"Unexpected state of the resource (%s) in %s. Report as a tasty bug."
      TestName
what TestName
where_
  show ResourceError
UseOutsideOfTest =
    TestName
"It looks like you're attempting to use a resource outside of its test. Don't do that!"

instance Exception ResourceError

-- | These are the two ways in which one test may depend on the others.
--
-- This is the same distinction as the
-- <http://testng.org/doc/documentation-main.html#dependent-methods hard vs soft dependencies in TestNG>.
--
-- @since 1.2
data DependencyType
  = AllSucceed
    -- ^ The current test tree will be executed after its dependencies finish, and only
    -- if all of the dependencies succeed.
  | AllFinish
    -- ^ The current test tree will be executed after its dependencies finish,
    -- regardless of whether they succeed or not.
  deriving
    ( DependencyType -> DependencyType -> Bool
(DependencyType -> DependencyType -> Bool)
-> (DependencyType -> DependencyType -> Bool) -> Eq DependencyType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DependencyType -> DependencyType -> Bool
== :: DependencyType -> DependencyType -> Bool
$c/= :: DependencyType -> DependencyType -> Bool
/= :: DependencyType -> DependencyType -> Bool
Eq
    , Int -> DependencyType -> ShowS
[DependencyType] -> ShowS
DependencyType -> TestName
(Int -> DependencyType -> ShowS)
-> (DependencyType -> TestName)
-> ([DependencyType] -> ShowS)
-> Show DependencyType
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DependencyType -> ShowS
showsPrec :: Int -> DependencyType -> ShowS
$cshow :: DependencyType -> TestName
show :: DependencyType -> TestName
$cshowList :: [DependencyType] -> ShowS
showList :: [DependencyType] -> ShowS
Show
    , ReadPrec [DependencyType]
ReadPrec DependencyType
Int -> ReadS DependencyType
ReadS [DependencyType]
(Int -> ReadS DependencyType)
-> ReadS [DependencyType]
-> ReadPrec DependencyType
-> ReadPrec [DependencyType]
-> Read DependencyType
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS DependencyType
readsPrec :: Int -> ReadS DependencyType
$creadList :: ReadS [DependencyType]
readList :: ReadS [DependencyType]
$creadPrec :: ReadPrec DependencyType
readPrec :: ReadPrec DependencyType
$creadListPrec :: ReadPrec [DependencyType]
readListPrec :: ReadPrec [DependencyType]
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 (Int -> ExecutionMode -> ShowS
[ExecutionMode] -> ShowS
ExecutionMode -> TestName
(Int -> ExecutionMode -> ShowS)
-> (ExecutionMode -> TestName)
-> ([ExecutionMode] -> ShowS)
-> Show ExecutionMode
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExecutionMode -> ShowS
showsPrec :: Int -> ExecutionMode -> ShowS
$cshow :: ExecutionMode -> TestName
show :: ExecutionMode -> TestName
$cshowList :: [ExecutionMode] -> ShowS
showList :: [ExecutionMode] -> ShowS
Show, ReadPrec [ExecutionMode]
ReadPrec ExecutionMode
Int -> ReadS ExecutionMode
ReadS [ExecutionMode]
(Int -> ReadS ExecutionMode)
-> ReadS [ExecutionMode]
-> ReadPrec ExecutionMode
-> ReadPrec [ExecutionMode]
-> Read ExecutionMode
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS ExecutionMode
readsPrec :: Int -> ReadS ExecutionMode
$creadList :: ReadS [ExecutionMode]
readList :: ReadS [ExecutionMode]
$creadPrec :: ReadPrec ExecutionMode
readPrec :: ReadPrec ExecutionMode
$creadListPrec :: ReadPrec [ExecutionMode]
readListPrec :: ReadPrec [ExecutionMode]
Read)

data Parallel
  = Parallel
  -- ^ Tests can be run in parallel
  | NonParallel
  -- ^ Tests should not be parallelized
  deriving (Int -> Parallel -> ShowS
[Parallel] -> ShowS
Parallel -> TestName
(Int -> Parallel -> ShowS)
-> (Parallel -> TestName) -> ([Parallel] -> ShowS) -> Show Parallel
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Parallel -> ShowS
showsPrec :: Int -> Parallel -> ShowS
$cshow :: Parallel -> TestName
show :: Parallel -> TestName
$cshowList :: [Parallel] -> ShowS
showList :: [Parallel] -> ShowS
Show, ReadPrec [Parallel]
ReadPrec Parallel
Int -> ReadS Parallel
ReadS [Parallel]
(Int -> ReadS Parallel)
-> ReadS [Parallel]
-> ReadPrec Parallel
-> ReadPrec [Parallel]
-> Read Parallel
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Parallel
readsPrec :: Int -> ReadS Parallel
$creadList :: ReadS [Parallel]
readList :: ReadS [Parallel]
$creadPrec :: ReadPrec Parallel
readPrec :: ReadPrec Parallel
$creadListPrec :: ReadPrec [Parallel]
readListPrec :: ReadPrec [Parallel]
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 :: ExecutionMode
defaultValue = Parallel -> ExecutionMode
Independent Parallel
Parallel
  parseValue :: TestName -> Maybe ExecutionMode
parseValue = TestName -> Maybe ExecutionMode
forall a. Read a => TestName -> Maybe a
readMaybe
  optionName :: Tagged ExecutionMode TestName
optionName = TestName -> Tagged ExecutionMode TestName
forall {k} (s :: k) b. b -> Tagged s b
Tagged TestName
"execution-mode"
  optionHelp :: Tagged ExecutionMode TestName
optionHelp = TestName -> Tagged ExecutionMode TestName
forall {k} (s :: k) b. b -> Tagged s b
Tagged TestName
"Whether tests have dependencies or not"
  optionCLParser :: Parser ExecutionMode
optionCLParser = Mod OptionFields ExecutionMode -> Parser ExecutionMode
forall v. IsOption v => Mod OptionFields v -> Parser v
mkOptionCLParser Mod OptionFields ExecutionMode
forall (f :: * -> *) a. Mod f a
internal

-- | The main data structure defining a test suite.
--
-- It consists of individual test cases and properties, organized in named
-- groups which form a tree-like hierarchy.
--
-- There is no generic way to create a test case. Instead, every test
-- provider (tasty-hunit, tasty-smallcheck etc.) provides a function to
-- 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
  | TestGroup TestName [TestTree]
    -- ^ Assemble a number of tests into a cohesive group
  | PlusTestOptions (OptionSet -> OptionSet) TestTree
    -- ^ Add some options to child tests
  | forall a . WithResource (ResourceSpec a) (IO a -> TestTree)
    -- ^ Acquire the resource before the tests in the inner tree start and
    -- 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.
    --
    -- @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. Tests are executed in
-- parallel. For sequential execution, see 'dependentTestGroup'.
--
-- @since 0.1
testGroup :: TestName -> [TestTree] -> TestTree
testGroup :: TestName -> [TestTree] -> TestTree
testGroup = TestName -> [TestTree] -> TestTree
TestGroup

{-# DEPRECATED sequentialTestGroup "Use dependentTestGroup instead" #-}
-- | Legacy name for 'dependentTestGroup'.
--
-- @since 1.5
sequentialTestGroup :: TestName -> DependencyType -> [TestTree] -> TestTree
sequentialTestGroup :: TestName -> DependencyType -> [TestTree] -> TestTree
sequentialTestGroup = TestName -> DependencyType -> [TestTree] -> TestTree
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 :: TestName -> DependencyType -> [TestTree] -> TestTree
dependentTestGroup TestName
nm DependencyType
depType = TestTree -> TestTree
setDependent (TestTree -> TestTree)
-> ([TestTree] -> TestTree) -> [TestTree] -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> [TestTree] -> TestTree
TestGroup TestName
nm ([TestTree] -> TestTree)
-> ([TestTree] -> [TestTree]) -> [TestTree] -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestTree -> TestTree) -> [TestTree] -> [TestTree]
forall a b. (a -> b) -> [a] -> [b]
map TestTree -> TestTree
setParallel
 where
  setParallel :: TestTree -> TestTree
setParallel = (OptionSet -> OptionSet) -> TestTree -> TestTree
PlusTestOptions (ExecutionMode -> OptionSet -> OptionSet
forall v. IsOption v => v -> OptionSet -> OptionSet
setOption (ExecutionMode -> OptionSet -> OptionSet)
-> ExecutionMode -> OptionSet -> OptionSet
forall a b. (a -> b) -> a -> b
$ Parallel -> ExecutionMode
Independent Parallel
Parallel)
  setDependent :: TestTree -> TestTree
setDependent = (OptionSet -> OptionSet) -> TestTree -> TestTree
PlusTestOptions (ExecutionMode -> OptionSet -> OptionSet
forall v. IsOption v => v -> OptionSet -> OptionSet
setOption (DependencyType -> ExecutionMode
Dependent DependencyType
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 :: TestName -> [TestTree] -> TestTree
inOrderTestGroup TestName
nm = TestTree -> TestTree
setSequential (TestTree -> TestTree)
-> ([TestTree] -> TestTree) -> [TestTree] -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> [TestTree] -> TestTree
TestGroup TestName
nm ([TestTree] -> TestTree)
-> ([TestTree] -> [TestTree]) -> [TestTree] -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestTree -> TestTree) -> [TestTree] -> [TestTree]
forall a b. (a -> b) -> [a] -> [b]
map TestTree -> TestTree
setParallel
 where
  setParallel :: TestTree -> TestTree
setParallel = (OptionSet -> OptionSet) -> TestTree -> TestTree
PlusTestOptions (ExecutionMode -> OptionSet -> OptionSet
forall v. IsOption v => v -> OptionSet -> OptionSet
setOption (ExecutionMode -> OptionSet -> OptionSet)
-> ExecutionMode -> OptionSet -> OptionSet
forall a b. (a -> b) -> a -> b
$ Parallel -> ExecutionMode
Independent Parallel
Parallel)
  setSequential :: TestTree -> TestTree
setSequential = (OptionSet -> OptionSet) -> TestTree -> TestTree
PlusTestOptions (ExecutionMode -> OptionSet -> OptionSet
forall v. IsOption v => v -> OptionSet -> OptionSet
setOption (Parallel -> ExecutionMode
Independent Parallel
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_ :: DependencyType -> Expr -> TestTree -> TestTree
after_ = DependencyType -> Expr -> TestTree -> TestTree
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 :: DependencyType -> TestName -> TestTree -> TestTree
after DependencyType
deptype TestName
s =
  case TestName -> Maybe Expr
parseExpr TestName
s of
    Maybe Expr
Nothing -> TestName -> TestTree -> TestTree
forall a. HasCallStack => TestName -> a
error (TestName -> TestTree -> TestTree)
-> TestName -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$ TestName
"Could not parse pattern " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> TestName
show TestName
s
    Just Expr
e -> DependencyType -> Expr -> TestTree -> TestTree
after_ DependencyType
deptype Expr
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
-- introduced.
--
-- @since 0.7
data TreeFold b = TreeFold
  { forall b.
TreeFold b -> forall t. IsTest t => OptionSet -> TestName -> t -> b
foldSingle :: forall t . IsTest t => OptionSet -> TestName -> t -> b
  , forall b. TreeFold b -> OptionSet -> TestName -> [b] -> b
foldGroup :: OptionSet -> TestName -> [b] -> b
  -- ^ @since 1.4
  , forall b.
TreeFold b
-> forall a. OptionSet -> ResourceSpec a -> (IO a -> b) -> b
foldResource :: forall a . OptionSet -> ResourceSpec a -> (IO a -> b) -> b
  , forall b.
TreeFold b -> OptionSet -> DependencyType -> Expr -> b -> b
foldAfter :: OptionSet -> DependencyType -> Expr -> b -> b
  -- ^ @since 1.2
  }

-- | 'trivialFold' can serve as the basis for custom folds. Just override
-- the fields you need.
--
-- Here's what it does:
--
-- * single tests are mapped to `mempty` (you probably do want to override that)
--
-- * test groups are returned unmodified
--
-- * 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 :: forall b. Monoid b => TreeFold b
trivialFold = TreeFold
  { foldSingle :: forall t. IsTest t => OptionSet -> TestName -> t -> b
foldSingle = \OptionSet
_ TestName
_ t
_ -> b
forall a. Monoid a => a
mempty
  , foldGroup :: OptionSet -> TestName -> [b] -> b
foldGroup = \OptionSet
_ TestName
_ [b]
bs -> [b] -> b
forall a. Monoid a => [a] -> a
mconcat [b]
bs
  , foldResource :: forall a. OptionSet -> ResourceSpec a -> (IO a -> b) -> b
foldResource = \OptionSet
_ ResourceSpec a
_ IO a -> b
f -> IO a -> b
f (IO a -> b) -> IO a -> b
forall a b. (a -> b) -> a -> b
$ ResourceError -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO ResourceError
NotRunningTests
  , foldAfter :: OptionSet -> DependencyType -> Expr -> b -> b
foldAfter = \OptionSet
_ DependencyType
_ Expr
_ b
b -> 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
-- results in a test group. In particular, empty groups get folded into 'mempty'.
--
-- Apart from pure convenience, this function also does the following
-- useful things:
--
-- 1. Keeping track of the current options (which may change due to
-- `PlusTestOptions` nodes)
--
-- 2. Filtering out the tests which do not match the patterns
--
-- Thus, it is preferred to an explicit recursive traversal of the tree.
--
-- @since 0.7
foldTestTree
  :: forall b . Monoid b
  => TreeFold b
     -- ^ the algebra (i.e. how to fold a tree)
  -> OptionSet
     -- ^ initial options
  -> TestTree
     -- ^ the tree to fold
  -> b
foldTestTree :: forall b. Monoid b => TreeFold b -> OptionSet -> TestTree -> b
foldTestTree = b -> TreeFold b -> OptionSet -> TestTree -> b
forall b. b -> TreeFold b -> OptionSet -> TestTree -> b
foldTestTree0 b
forall a. Monoid a => a
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 :: forall b. b -> TreeFold b -> OptionSet -> TestTree -> b
foldTestTree0 b
empty (TreeFold forall t. IsTest t => OptionSet -> TestName -> t -> b
fTest OptionSet -> TestName -> [b] -> b
fGroup forall a. OptionSet -> ResourceSpec a -> (IO a -> b) -> b
fResource OptionSet -> DependencyType -> Expr -> b -> b
fAfter) OptionSet
opts0 TestTree
tree0 =
  AnnTestTree OptionSet -> b
go (AnnTestTree (OptionSet, Seq TestName) -> AnnTestTree OptionSet
filterByPattern (AnnTestTree OptionSet -> AnnTestTree (OptionSet, Seq TestName)
annotatePath (OptionSet -> TestTree -> AnnTestTree OptionSet
evaluateOptions OptionSet
opts0 TestTree
tree0)))
  where
    go :: AnnTestTree OptionSet -> b
    go :: AnnTestTree OptionSet -> b
go = \case
      AnnTestTree OptionSet
AnnEmptyTestTree               -> b
empty
      AnnSingleTest OptionSet
opts TestName
name t
test   -> OptionSet -> TestName -> t -> b
forall t. IsTest t => OptionSet -> TestName -> t -> b
fTest OptionSet
opts TestName
name t
test
      AnnTestGroup OptionSet
opts TestName
name [AnnTestTree OptionSet]
trees   -> OptionSet -> TestName -> [b] -> b
fGroup OptionSet
opts TestName
name ((AnnTestTree OptionSet -> b) -> [AnnTestTree OptionSet] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map AnnTestTree OptionSet -> b
go [AnnTestTree OptionSet]
trees)
      AnnWithResource OptionSet
opts ResourceSpec a
res0 IO a -> AnnTestTree OptionSet
tree -> OptionSet -> ResourceSpec a -> (IO a -> b) -> b
forall a. OptionSet -> ResourceSpec a -> (IO a -> b) -> b
fResource OptionSet
opts ResourceSpec a
res0 ((IO a -> b) -> b) -> (IO a -> b) -> b
forall a b. (a -> b) -> a -> b
$ \IO a
res -> AnnTestTree OptionSet -> b
go (IO a -> AnnTestTree OptionSet
tree IO a
res)
      AnnAfter OptionSet
opts DependencyType
deptype Expr
dep AnnTestTree OptionSet
tree -> OptionSet -> DependencyType -> Expr -> b -> b
fAfter OptionSet
opts DependencyType
deptype Expr
dep (AnnTestTree OptionSet -> b
go AnnTestTree OptionSet
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 :: OptionSet -> TestTree -> AnnTestTree OptionSet
evaluateOptions OptionSet
opts = \case
  SingleTest TestName
name t
test ->
    OptionSet -> TestName -> t -> AnnTestTree OptionSet
forall ann t. IsTest t => ann -> TestName -> t -> AnnTestTree ann
AnnSingleTest OptionSet
opts TestName
name t
test
  TestGroup TestName
name [TestTree]
trees ->
    OptionSet
-> TestName -> [AnnTestTree OptionSet] -> AnnTestTree OptionSet
forall ann. ann -> TestName -> [AnnTestTree ann] -> AnnTestTree ann
AnnTestGroup OptionSet
opts TestName
name ([AnnTestTree OptionSet] -> AnnTestTree OptionSet)
-> [AnnTestTree OptionSet] -> AnnTestTree OptionSet
forall a b. (a -> b) -> a -> b
$ (TestTree -> AnnTestTree OptionSet)
-> [TestTree] -> [AnnTestTree OptionSet]
forall a b. (a -> b) -> [a] -> [b]
map (OptionSet -> TestTree -> AnnTestTree OptionSet
evaluateOptions OptionSet
opts) [TestTree]
trees
  PlusTestOptions OptionSet -> OptionSet
f TestTree
tree ->
    OptionSet -> TestTree -> AnnTestTree OptionSet
evaluateOptions (OptionSet -> OptionSet
f OptionSet
opts) TestTree
tree
  WithResource ResourceSpec a
res0 IO a -> TestTree
tree ->
    OptionSet
-> ResourceSpec a
-> (IO a -> AnnTestTree OptionSet)
-> AnnTestTree OptionSet
forall ann a.
ann
-> ResourceSpec a -> (IO a -> AnnTestTree ann) -> AnnTestTree ann
AnnWithResource OptionSet
opts ResourceSpec a
res0 ((IO a -> AnnTestTree OptionSet) -> AnnTestTree OptionSet)
-> (IO a -> AnnTestTree OptionSet) -> AnnTestTree OptionSet
forall a b. (a -> b) -> a -> b
$ \IO a
res -> OptionSet -> TestTree -> AnnTestTree OptionSet
evaluateOptions OptionSet
opts (IO a -> TestTree
tree IO a
res)
  AskOptions OptionSet -> TestTree
f ->
    OptionSet -> TestTree -> AnnTestTree OptionSet
evaluateOptions OptionSet
opts (OptionSet -> TestTree
f OptionSet
opts)
  After DependencyType
deptype Expr
dep TestTree
tree ->
    OptionSet
-> DependencyType
-> Expr
-> AnnTestTree OptionSet
-> AnnTestTree OptionSet
forall ann.
ann -> DependencyType -> Expr -> AnnTestTree ann -> AnnTestTree ann
AnnAfter OptionSet
opts DependencyType
deptype Expr
dep (AnnTestTree OptionSet -> AnnTestTree OptionSet)
-> AnnTestTree OptionSet -> AnnTestTree OptionSet
forall a b. (a -> b) -> a -> b
$ OptionSet -> TestTree -> AnnTestTree OptionSet
evaluateOptions OptionSet
opts TestTree
tree

-- | Annotate 'AnnTestTree' with paths.
annotatePath :: AnnTestTree OptionSet -> AnnTestTree (OptionSet, Path)
annotatePath :: AnnTestTree OptionSet -> AnnTestTree (OptionSet, Seq TestName)
annotatePath = Seq TestName
-> AnnTestTree OptionSet -> AnnTestTree (OptionSet, Seq TestName)
go Seq TestName
forall a. Monoid a => a
mempty
  where
    go :: Seq.Seq TestName -> AnnTestTree OptionSet -> AnnTestTree (OptionSet, Path)
    go :: Seq TestName
-> AnnTestTree OptionSet -> AnnTestTree (OptionSet, Seq TestName)
go Seq TestName
path = \case
      AnnTestTree OptionSet
AnnEmptyTestTree -> AnnTestTree (OptionSet, Seq TestName)
forall ann. AnnTestTree ann
AnnEmptyTestTree
      AnnSingleTest OptionSet
opts TestName
name t
tree ->
        (OptionSet, Seq TestName)
-> TestName -> t -> AnnTestTree (OptionSet, Seq TestName)
forall ann t. IsTest t => ann -> TestName -> t -> AnnTestTree ann
AnnSingleTest (OptionSet
opts, Seq TestName
path Seq TestName -> TestName -> Seq TestName
forall a. Seq a -> a -> Seq a
|> TestName
name) TestName
name t
tree
      AnnTestGroup OptionSet
opts TestName
name [AnnTestTree OptionSet]
trees ->
        let newPath :: Seq TestName
newPath = Seq TestName
path Seq TestName -> TestName -> Seq TestName
forall a. Seq a -> a -> Seq a
|> TestName
name in
        (OptionSet, Seq TestName)
-> TestName
-> [AnnTestTree (OptionSet, Seq TestName)]
-> AnnTestTree (OptionSet, Seq TestName)
forall ann. ann -> TestName -> [AnnTestTree ann] -> AnnTestTree ann
AnnTestGroup (OptionSet
opts, Seq TestName
newPath) TestName
name ((AnnTestTree OptionSet -> AnnTestTree (OptionSet, Seq TestName))
-> [AnnTestTree OptionSet]
-> [AnnTestTree (OptionSet, Seq TestName)]
forall a b. (a -> b) -> [a] -> [b]
map (Seq TestName
-> AnnTestTree OptionSet -> AnnTestTree (OptionSet, Seq TestName)
go Seq TestName
newPath) [AnnTestTree OptionSet]
trees)
      AnnWithResource OptionSet
opts ResourceSpec a
res0 IO a -> AnnTestTree OptionSet
tree ->
        (OptionSet, Seq TestName)
-> ResourceSpec a
-> (IO a -> AnnTestTree (OptionSet, Seq TestName))
-> AnnTestTree (OptionSet, Seq TestName)
forall ann a.
ann
-> ResourceSpec a -> (IO a -> AnnTestTree ann) -> AnnTestTree ann
AnnWithResource (OptionSet
opts, Seq TestName
path) ResourceSpec a
res0 ((IO a -> AnnTestTree (OptionSet, Seq TestName))
 -> AnnTestTree (OptionSet, Seq TestName))
-> (IO a -> AnnTestTree (OptionSet, Seq TestName))
-> AnnTestTree (OptionSet, Seq TestName)
forall a b. (a -> b) -> a -> b
$ \IO a
res -> Seq TestName
-> AnnTestTree OptionSet -> AnnTestTree (OptionSet, Seq TestName)
go Seq TestName
path (IO a -> AnnTestTree OptionSet
tree IO a
res)
      AnnAfter OptionSet
opts DependencyType
deptype Expr
dep AnnTestTree OptionSet
tree ->
        (OptionSet, Seq TestName)
-> DependencyType
-> Expr
-> AnnTestTree (OptionSet, Seq TestName)
-> AnnTestTree (OptionSet, Seq TestName)
forall ann.
ann -> DependencyType -> Expr -> AnnTestTree ann -> AnnTestTree ann
AnnAfter (OptionSet
opts, Seq TestName
path) DependencyType
deptype Expr
dep (Seq TestName
-> AnnTestTree OptionSet -> AnnTestTree (OptionSet, Seq TestName)
go Seq TestName
path AnnTestTree OptionSet
tree)

-- | Filter test tree by pattern, replacing leafs with 'AnnEmptyTestTree'.
filterByPattern :: AnnTestTree (OptionSet, Path) -> AnnTestTree OptionSet
filterByPattern :: AnnTestTree (OptionSet, Seq TestName) -> AnnTestTree OptionSet
filterByPattern = (TestMatched, AnnTestTree OptionSet) -> AnnTestTree OptionSet
forall a b. (a, b) -> b
snd ((TestMatched, AnnTestTree OptionSet) -> AnnTestTree OptionSet)
-> (AnnTestTree (OptionSet, Seq TestName)
    -> (TestMatched, AnnTestTree OptionSet))
-> AnnTestTree (OptionSet, Seq TestName)
-> AnnTestTree OptionSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestMatched
-> AnnTestTree (OptionSet, Seq TestName)
-> (TestMatched, AnnTestTree OptionSet)
go (Bool -> TestMatched
Any Bool
False)
  where
    mkGroup :: ann -> TestName -> [AnnTestTree ann] -> AnnTestTree ann
mkGroup ann
opts TestName
name [AnnTestTree ann]
xs = case (AnnTestTree ann -> Bool) -> [AnnTestTree ann] -> [AnnTestTree ann]
forall a. (a -> Bool) -> [a] -> [a]
filter AnnTestTree ann -> Bool
forall {ann}. AnnTestTree ann -> Bool
isNonEmpty [AnnTestTree ann]
xs of
      [] -> AnnTestTree ann
forall ann. AnnTestTree ann
AnnEmptyTestTree
      [AnnTestTree ann]
ys -> ann -> TestName -> [AnnTestTree ann] -> AnnTestTree ann
forall ann. ann -> TestName -> [AnnTestTree ann] -> AnnTestTree ann
AnnTestGroup ann
opts TestName
name [AnnTestTree ann]
ys

    isNonEmpty :: AnnTestTree ann -> Bool
isNonEmpty = \case
      AnnTestTree ann
AnnEmptyTestTree -> Bool
False
      AnnTestTree ann
_                -> Bool
True

    go
      :: ForceTestMatch
      -> AnnTestTree (OptionSet, Path)
      -> (TestMatched, AnnTestTree OptionSet)
    go :: TestMatched
-> AnnTestTree (OptionSet, Seq TestName)
-> (TestMatched, AnnTestTree OptionSet)
go TestMatched
forceMatch = \case
      AnnTestTree (OptionSet, Seq TestName)
AnnEmptyTestTree ->
        (Bool -> TestMatched
Any Bool
False, AnnTestTree OptionSet
forall ann. AnnTestTree ann
AnnEmptyTestTree)

      AnnSingleTest (OptionSet
opts, Seq TestName
path) TestName
name t
tree
        | TestMatched -> Bool
getAny TestMatched
forceMatch Bool -> Bool -> Bool
|| TestPattern -> Seq TestName -> Bool
testPatternMatches (OptionSet -> TestPattern
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts) Seq TestName
path
        -> (Bool -> TestMatched
Any Bool
True, OptionSet -> TestName -> t -> AnnTestTree OptionSet
forall ann t. IsTest t => ann -> TestName -> t -> AnnTestTree ann
AnnSingleTest OptionSet
opts TestName
name t
tree)
        | Bool
otherwise
        -> (Bool -> TestMatched
Any Bool
False, AnnTestTree OptionSet
forall ann. AnnTestTree ann
AnnEmptyTestTree)

      AnnTestGroup (OptionSet, Seq TestName)
_ TestName
_ [] ->
        (TestMatched
forceMatch, AnnTestTree OptionSet
forall ann. AnnTestTree ann
AnnEmptyTestTree)

      AnnTestGroup (OptionSet
opts, Seq TestName
_) TestName
name [AnnTestTree (OptionSet, Seq TestName)]
trees ->
        case OptionSet -> ExecutionMode
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts of
          Dependent DependencyType
_ ->
            ([AnnTestTree OptionSet] -> AnnTestTree OptionSet)
-> (TestMatched, [AnnTestTree OptionSet])
-> (TestMatched, AnnTestTree OptionSet)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second
              (OptionSet
-> TestName -> [AnnTestTree OptionSet] -> AnnTestTree OptionSet
forall ann. ann -> TestName -> [AnnTestTree ann] -> AnnTestTree ann
mkGroup OptionSet
opts TestName
name)
              ((TestMatched
 -> AnnTestTree (OptionSet, Seq TestName)
 -> (TestMatched, AnnTestTree OptionSet))
-> TestMatched
-> [AnnTestTree (OptionSet, Seq TestName)]
-> (TestMatched, [AnnTestTree OptionSet])
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumR TestMatched
-> AnnTestTree (OptionSet, Seq TestName)
-> (TestMatched, AnnTestTree OptionSet)
go TestMatched
forceMatch [AnnTestTree (OptionSet, Seq TestName)]
trees)
          Independent Parallel
_ ->
            ([TestMatched] -> TestMatched)
-> ([AnnTestTree OptionSet] -> AnnTestTree OptionSet)
-> ([TestMatched], [AnnTestTree OptionSet])
-> (TestMatched, AnnTestTree OptionSet)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap
              [TestMatched] -> TestMatched
forall a. Monoid a => [a] -> a
mconcat
              (OptionSet
-> TestName -> [AnnTestTree OptionSet] -> AnnTestTree OptionSet
forall ann. ann -> TestName -> [AnnTestTree ann] -> AnnTestTree ann
mkGroup OptionSet
opts TestName
name)
              ([(TestMatched, AnnTestTree OptionSet)]
-> ([TestMatched], [AnnTestTree OptionSet])
forall a b. [(a, b)] -> ([a], [b])
unzip ((AnnTestTree (OptionSet, Seq TestName)
 -> (TestMatched, AnnTestTree OptionSet))
-> [AnnTestTree (OptionSet, Seq TestName)]
-> [(TestMatched, AnnTestTree OptionSet)]
forall a b. (a -> b) -> [a] -> [b]
map (TestMatched
-> AnnTestTree (OptionSet, Seq TestName)
-> (TestMatched, AnnTestTree OptionSet)
go TestMatched
forceMatch) [AnnTestTree (OptionSet, Seq TestName)]
trees))

      AnnWithResource (OptionSet
opts, Seq TestName
_) ResourceSpec a
res0 IO a -> AnnTestTree (OptionSet, Seq TestName)
tree ->
        ( (TestMatched, AnnTestTree OptionSet) -> TestMatched
forall a b. (a, b) -> a
fst (TestMatched
-> AnnTestTree (OptionSet, Seq TestName)
-> (TestMatched, AnnTestTree OptionSet)
go TestMatched
forceMatch (IO a -> AnnTestTree (OptionSet, Seq TestName)
tree (ResourceError -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO ResourceError
NotRunningTests)))
        , OptionSet
-> ResourceSpec a
-> (IO a -> AnnTestTree OptionSet)
-> AnnTestTree OptionSet
forall ann a.
ann
-> ResourceSpec a -> (IO a -> AnnTestTree ann) -> AnnTestTree ann
AnnWithResource OptionSet
opts ResourceSpec a
res0 ((IO a -> AnnTestTree OptionSet) -> AnnTestTree OptionSet)
-> (IO a -> AnnTestTree OptionSet) -> AnnTestTree OptionSet
forall a b. (a -> b) -> a -> b
$ \IO a
res -> (TestMatched, AnnTestTree OptionSet) -> AnnTestTree OptionSet
forall a b. (a, b) -> b
snd (TestMatched
-> AnnTestTree (OptionSet, Seq TestName)
-> (TestMatched, AnnTestTree OptionSet)
go TestMatched
forceMatch (IO a -> AnnTestTree (OptionSet, Seq TestName)
tree IO a
res))
        )

      AnnAfter (OptionSet
opts, Seq TestName
_) DependencyType
deptype Expr
dep AnnTestTree (OptionSet, Seq TestName)
tree ->
        (AnnTestTree OptionSet -> AnnTestTree OptionSet)
-> (TestMatched, AnnTestTree OptionSet)
-> (TestMatched, AnnTestTree OptionSet)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second
          (OptionSet
-> DependencyType
-> Expr
-> AnnTestTree OptionSet
-> AnnTestTree OptionSet
forall ann.
ann -> DependencyType -> Expr -> AnnTestTree ann -> AnnTestTree ann
AnnAfter OptionSet
opts DependencyType
deptype Expr
dep)
          (TestMatched
-> AnnTestTree (OptionSet, Seq TestName)
-> (TestMatched, AnnTestTree OptionSet)
go TestMatched
forceMatch AnnTestTree (OptionSet, Seq TestName)
tree)

-- | Get the list of options that are relevant for a given test tree
treeOptions :: TestTree -> [OptionDescription]
treeOptions :: TestTree -> [OptionDescription]
treeOptions =

  [[OptionDescription]] -> [OptionDescription]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
Prelude.concat ([[OptionDescription]] -> [OptionDescription])
-> (TestTree -> [[OptionDescription]])
-> TestTree
-> [OptionDescription]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Map TypeRep [OptionDescription] -> [[OptionDescription]]
forall k a. Map k a -> [a]
Map.elems (Map TypeRep [OptionDescription] -> [[OptionDescription]])
-> (TestTree -> Map TypeRep [OptionDescription])
-> TestTree
-> [[OptionDescription]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.

  TreeFold (Map TypeRep [OptionDescription])
-> OptionSet -> TestTree -> Map TypeRep [OptionDescription]
forall b. Monoid b => TreeFold b -> OptionSet -> TestTree -> b
foldTestTree
    TreeFold (Map TypeRep [OptionDescription])
forall b. Monoid b => TreeFold b
trivialFold { foldSingle = \OptionSet
_ TestName
_ -> t -> Map TypeRep [OptionDescription]
forall t. IsTest t => t -> Map TypeRep [OptionDescription]
getTestOptions }
    OptionSet
forall a. Monoid a => a
mempty

  where
    getTestOptions
      :: forall t . IsTest t
      => t -> Map.Map TypeRep [OptionDescription]
    getTestOptions :: forall t. IsTest t => t -> Map TypeRep [OptionDescription]
getTestOptions t
t =
      TypeRep -> [OptionDescription] -> Map TypeRep [OptionDescription]
forall k a. k -> a -> Map k a
Map.singleton (t -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf t
t) ([OptionDescription] -> Map TypeRep [OptionDescription])
-> [OptionDescription] -> Map TypeRep [OptionDescription]
forall a b. (a -> b) -> a -> b
$
          Tagged t [OptionDescription] -> t -> [OptionDescription]
forall a b. Tagged a b -> a -> b
witness Tagged t [OptionDescription]
forall t. IsTest t => Tagged t [OptionDescription]
testOptions t
t