-- | Running tests
{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes,
             FlexibleContexts, CPP, LambdaCase,
             RecordWildCards, NamedFieldPuns #-}
module Test.Tasty.Run
  ( Status(..)
  , StatusMap
  , launchTestTree
  , applyTopLevelPlusTestOptions
  , DependencyException(..)
  ) where

import qualified Data.IntMap.Strict as IntMap
import qualified Data.Sequence as Seq
import qualified Data.Foldable as F
import Data.Int (Int64)
import Data.Maybe
import Data.List (intercalate)
import Data.Graph (SCC(..), stronglyConnComp)
import Data.Sequence (Seq, (|>), (<|), (><))
import Control.Monad (forever, guard, join, liftM)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Reader (ReaderT(..), local, ask)
import Control.Monad.Trans.Writer (execWriterT, tell)
import Control.Concurrent (threadDelay)
import Control.Concurrent.STM (TVar, STM, check, readTVar, writeTVar, atomically, retry, throwSTM, newTVarIO)
import Control.Concurrent.Async (wait, asyncThreadId, withAsync)
import Control.Exception as E
import Control.Arrow
import Data.Monoid (First(..))
import GHC.Conc (labelThread)

#if MIN_VERSION_base(4,18,0)
import Data.Traversable (mapAccumM)
#endif

#ifdef MIN_VERSION_unbounded_delays
import Control.Concurrent.Timeout (timeout)
#else
import System.Timeout (timeout)
#endif

import Test.Tasty.Core
import Test.Tasty.Parallel
import Test.Tasty.Patterns
import Test.Tasty.Patterns.Types
import Test.Tasty.Options
import Test.Tasty.Options.Core
import Test.Tasty.Runners.Reducers
import Test.Tasty.Runners.Utils (timed, forceElements)
import Test.Tasty.Providers.ConsoleFormat (noResultDetails)

-- | Current status of a test.
--
-- @since 0.1
data Status
  = NotStarted
    -- ^ test has not started running yet
  | Executing Progress
    -- ^ test is being run
  | Done Result
    -- ^ test finished with a given result
  deriving
  ( Int -> Status -> ShowS
[Status] -> ShowS
Status -> String
(Int -> Status -> ShowS)
-> (Status -> String) -> ([Status] -> ShowS) -> Show Status
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Status -> ShowS
showsPrec :: Int -> Status -> ShowS
$cshow :: Status -> String
show :: Status -> String
$cshowList :: [Status] -> ShowS
showList :: [Status] -> ShowS
Show -- ^ @since 1.2
  )

-- | Mapping from test numbers (starting from 0) to their status variables.
--
-- This is what an ingredient uses to analyse and display progress, and to
-- detect when tests finish.
--
-- @since 0.1
type StatusMap = IntMap.IntMap (TVar Status)

data Resource r
  = NotCreated
  | BeingCreated
  | FailedToCreate SomeException
  | Created r
  | BeingDestroyed
  | Destroyed

instance Show (Resource r) where
  show :: Resource r -> String
show Resource r
r = case Resource r
r of
    Resource r
NotCreated -> String
"NotCreated"
    Resource r
BeingCreated -> String
"BeingCreated"
    FailedToCreate SomeException
exn -> String
"FailedToCreate " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
exn
    Created {} -> String
"Created"
    Resource r
BeingDestroyed -> String
"BeingDestroyed"
    Resource r
Destroyed -> String
"Destroyed"

data Initializer
  = forall res . Initializer
      (IO res)
      (TVar (Resource res))
data Finalizer
  = forall res . Finalizer
      (res -> IO ())
      (TVar (Resource res))
      (TVar Int)

-- | Execute a test taking care of resources
executeTest
  :: ((Progress -> IO ()) -> IO Result)
    -- ^ the action to execute the test, which takes a progress callback as
    -- a parameter
  -> TVar Status -- ^ variable to write status to
  -> Timeout -- ^ optional timeout to apply
  -> HideProgress -- ^ hide progress option
  -> Seq Initializer -- ^ initializers (to be executed in this order)
  -> Seq Finalizer -- ^ finalizers (to be executed in this order)
  -> IO ()
executeTest :: ((Progress -> IO ()) -> IO Result)
-> TVar Status
-> Timeout
-> HideProgress
-> Seq Initializer
-> Seq Finalizer
-> IO ()
executeTest (Progress -> IO ()) -> IO Result
action TVar Status
statusVar Timeout
timeoutOpt HideProgress
hideProgressOpt Seq Initializer
inits Seq Finalizer
fins = ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO ()) -> IO ())
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
  resultOrExn <- IO (Time, Result) -> IO (Either SomeException (Time, Result))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (Time, Result) -> IO (Either SomeException (Time, Result)))
-> (IO (Time, Result) -> IO (Time, Result))
-> IO (Time, Result)
-> IO (Either SomeException (Time, Result))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Time, Result) -> IO (Time, Result)
forall a. IO a -> IO a
restore (IO (Time, Result) -> IO (Either SomeException (Time, Result)))
-> IO (Time, Result) -> IO (Either SomeException (Time, Result))
forall a b. (a -> b) -> a -> b
$ do
    -- N.B. this can (re-)throw an exception. It's okay. By design, the
    -- actual test will not be run, then. We still run all the
    -- finalizers.
    --
    -- There's no point to transform these exceptions to something like
    -- EitherT, because an async exception (cancellation) can strike
    -- anyway.
    IO ()
initResources

    let
      cursorMischiefManaged :: IO Result
cursorMischiefManaged = do
        STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Status -> Status -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Status
statusVar (Progress -> Status
Executing Progress
emptyProgress)
        (Progress -> IO ()) -> IO Result
action Progress -> IO ()
forall {f :: * -> *}. MonadIO f => Progress -> f ()
yieldProgress

    -- If all initializers ran successfully, actually run the test.
    -- We run it in a separate thread, so that the test's exception
    -- handler doesn't interfere with our timeout.
    IO Result
-> (Async Result -> IO (Time, Result)) -> IO (Time, Result)
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync IO Result
cursorMischiefManaged ((Async Result -> IO (Time, Result)) -> IO (Time, Result))
-> (Async Result -> IO (Time, Result)) -> IO (Time, Result)
forall a b. (a -> b) -> a -> b
$ \Async Result
asy -> do
      ThreadId -> String -> IO ()
labelThread (Async Result -> ThreadId
forall a. Async a -> ThreadId
asyncThreadId Async Result
asy) String
"tasty_test_execution_thread"
      IO Result -> IO (Time, Result)
forall a. IO a -> IO (Time, a)
timed (IO Result -> IO (Time, Result)) -> IO Result -> IO (Time, Result)
forall a b. (a -> b) -> a -> b
$ Timeout -> IO Result -> IO Result
applyTimeout Timeout
timeoutOpt (IO Result -> IO Result) -> IO Result -> IO Result
forall a b. (a -> b) -> a -> b
$ do
        r <- Async Result -> IO Result
forall a. Async a -> IO a
wait Async Result
asy
        -- Not only wait for the result to be returned, but make sure to
        -- evaluate it inside applyTimeout; see #280.
        evaluate $
          resultOutcome r `seq`
          forceElements (resultDescription r) `seq`
          forceElements (resultShortDescription r)
        return r

  -- no matter what, try to run each finalizer
  mbExn <- destroyResources restore

  atomically . writeTVar statusVar . Done $
    case resultOrExn <* maybe (Right ()) Left mbExn of
      Left SomeException
ex -> SomeException -> Result
exceptionResult SomeException
ex
      Right (Time
t,Result
r) -> Result
r { resultTime = t }

  where
    initResources :: IO ()
    initResources :: IO ()
initResources =
      Seq Initializer -> (Initializer -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
F.forM_ Seq Initializer
inits ((Initializer -> IO ()) -> IO ())
-> (Initializer -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Initializer IO res
doInit TVar (Resource res)
initVar) -> do
        IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ do
          resStatus <- TVar (Resource res) -> STM (Resource res)
forall a. TVar a -> STM a
readTVar TVar (Resource res)
initVar
          case resStatus of
            Resource res
NotCreated -> do
              -- signal to others that we're taking care of the resource
              -- initialization
              TVar (Resource res) -> Resource res -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Resource res)
initVar Resource res
forall r. Resource r
BeingCreated
              IO () -> STM (IO ())
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$
                (do
                  res <- IO res
doInit
                  atomically $ writeTVar initVar $ Created res
                 ) IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` \SomeException
exn -> do
                  STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Resource res) -> Resource res -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Resource res)
initVar (Resource res -> STM ()) -> Resource res -> STM ()
forall a b. (a -> b) -> a -> b
$ SomeException -> Resource res
forall r. SomeException -> Resource r
FailedToCreate SomeException
exn
                  SomeException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
exn
            Resource res
BeingCreated -> STM (IO ())
forall a. STM a
retry
            Created {} -> IO () -> STM (IO ())
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            FailedToCreate SomeException
exn -> IO () -> STM (IO ())
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ SomeException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO SomeException
exn
            -- If the resource is destroyed or being destroyed
            -- while we're starting a test, the test suite is probably
            -- shutting down. We are about to be killed.
            -- (In fact we are probably killed already, so these cases are
            -- unlikely to occur.)
            -- In any case, the most sensible thing to do is to go to
            -- sleep, awaiting our fate.
            Resource res
Destroyed      -> IO () -> STM (IO ())
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ IO ()
sleepIndefinitely
            Resource res
BeingDestroyed -> IO () -> STM (IO ())
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> STM (IO ())) -> IO () -> STM (IO ())
forall a b. (a -> b) -> a -> b
$ IO ()
sleepIndefinitely

    applyTimeout :: Timeout -> IO Result -> IO Result
    applyTimeout :: Timeout -> IO Result -> IO Result
applyTimeout Timeout
NoTimeout IO Result
a = IO Result
a
    applyTimeout (Timeout Integer
t String
tstr) IO Result
a = do
      let
        timeoutResult :: Result
timeoutResult =
          Result
            { resultOutcome :: Outcome
resultOutcome = FailureReason -> Outcome
Failure (FailureReason -> Outcome) -> FailureReason -> Outcome
forall a b. (a -> b) -> a -> b
$ Integer -> FailureReason
TestTimedOut Integer
t
            , resultDescription :: String
resultDescription =
                String
"Timed out after " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
tstr
            , resultShortDescription :: String
resultShortDescription = String
"TIMEOUT"
            , resultTime :: Time
resultTime = Integer -> Time
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
t
            , resultDetailsPrinter :: ResultDetailsPrinter
resultDetailsPrinter = ResultDetailsPrinter
noResultDetails
            }
      -- If compiled with unbounded-delays then t' :: Integer, otherwise t' :: Int
      let t' :: Int
t' = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
min (Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
0 Integer
t) (Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Int64
forall a. Bounded a => a
maxBound :: Int64)))
      Result -> Maybe Result -> Result
forall a. a -> Maybe a -> a
fromMaybe Result
timeoutResult (Maybe Result -> Result) -> IO (Maybe Result) -> IO Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IO Result -> IO (Maybe Result)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
t' IO Result
a

    -- destroyResources should not be interrupted by an exception
    -- Here's how we ensure this:
    --
    -- * the finalizer is wrapped in 'try'
    -- * async exceptions are masked by the caller
    -- * we don't use any interruptible operations here (outside of 'try')
    destroyResources :: (forall a . IO a -> IO a) -> IO (Maybe SomeException)
    destroyResources :: (forall a. IO a -> IO a) -> IO (Maybe SomeException)
destroyResources forall a. IO a -> IO a
restore = do
      -- remember the first exception that occurred
      (First SomeException -> Maybe SomeException)
-> IO (First SomeException) -> IO (Maybe SomeException)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM First SomeException -> Maybe SomeException
forall a. First a -> Maybe a
getFirst (IO (First SomeException) -> IO (Maybe SomeException))
-> (Traversal (WriterT (First SomeException) IO)
    -> IO (First SomeException))
-> Traversal (WriterT (First SomeException) IO)
-> IO (Maybe SomeException)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT (First SomeException) IO () -> IO (First SomeException)
forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT (WriterT (First SomeException) IO () -> IO (First SomeException))
-> (Traversal (WriterT (First SomeException) IO)
    -> WriterT (First SomeException) IO ())
-> Traversal (WriterT (First SomeException) IO)
-> IO (First SomeException)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Traversal (WriterT (First SomeException) IO)
-> WriterT (First SomeException) IO ()
forall (f :: * -> *). Traversal f -> f ()
getTraversal (Traversal (WriterT (First SomeException) IO)
 -> IO (Maybe SomeException))
-> Traversal (WriterT (First SomeException) IO)
-> IO (Maybe SomeException)
forall a b. (a -> b) -> a -> b
$
        ((Finalizer -> Traversal (WriterT (First SomeException) IO))
 -> Seq Finalizer -> Traversal (WriterT (First SomeException) IO))
-> Seq Finalizer
-> (Finalizer -> Traversal (WriterT (First SomeException) IO))
-> Traversal (WriterT (First SomeException) IO)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Finalizer -> Traversal (WriterT (First SomeException) IO))
-> Seq Finalizer -> Traversal (WriterT (First SomeException) IO)
forall m a. Monoid m => (a -> m) -> Seq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
F.foldMap Seq Finalizer
fins ((Finalizer -> Traversal (WriterT (First SomeException) IO))
 -> Traversal (WriterT (First SomeException) IO))
-> (Finalizer -> Traversal (WriterT (First SomeException) IO))
-> Traversal (WriterT (First SomeException) IO)
forall a b. (a -> b) -> a -> b
$ \fin :: Finalizer
fin@(Finalizer res -> IO ()
_ TVar (Resource res)
_ TVar Int
finishVar) ->
          WriterT (First SomeException) IO ()
-> Traversal (WriterT (First SomeException) IO)
forall (f :: * -> *). f () -> Traversal f
Traversal (WriterT (First SomeException) IO ()
 -> Traversal (WriterT (First SomeException) IO))
-> WriterT (First SomeException) IO ()
-> Traversal (WriterT (First SomeException) IO)
forall a b. (a -> b) -> a -> b
$ do
            iAmLast <- IO Bool -> WriterT (First SomeException) IO Bool
forall a. IO a -> WriterT (First SomeException) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> WriterT (First SomeException) IO Bool)
-> IO Bool -> WriterT (First SomeException) IO Bool
forall a b. (a -> b) -> a -> b
$ STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
              nUsers <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
finishVar
              let nUsers' = Int
nUsers Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
              writeTVar finishVar nUsers'
              return $ nUsers' == 0

            mbExcn <- liftIO $
              if iAmLast
              then destroyResource restore fin
              else return Nothing

            tell $ First mbExcn

    yieldProgress :: Progress -> f ()
yieldProgress Progress
_newP | HideProgress -> Bool
getHideProgress HideProgress
hideProgressOpt =
      () -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    yieldProgress Progress
newP | Progress
newP Progress -> Progress -> Bool
forall a. Eq a => a -> a -> Bool
== Progress
emptyProgress =
      -- This could be changed to `Maybe Progress` to lets more easily indicate
      -- when progress should try to be printed ?
      () -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    yieldProgress Progress
newP = IO () -> f ()
forall a. IO a -> f a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
      (IO () -> f ()) -> (Status -> IO ()) -> Status -> f ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM () -> IO ()
forall a. STM a -> IO a
atomically
      (STM () -> IO ()) -> (Status -> STM ()) -> Status -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar Status -> Status -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Status
statusVar
      (Status -> f ()) -> Status -> f ()
forall a b. (a -> b) -> a -> b
$ Progress -> Status
Executing Progress
newP

-- | Traversal type used in 'createTestActions'
type Tr = ReaderT (Path, Seq Dependency) IO (TestActionTree UnresolvedAction)

-- | Exceptions related to dependencies between tests.
--
-- @since 1.2
newtype DependencyException
  = DependencyLoop [[Path]]
    -- ^ Test dependencies form cycles. In other words, test A cannot start
    -- until test B finishes, and test B cannot start until test
    -- A finishes. Field lists detected cycles.
    --
    -- @since 1.5

instance Show DependencyException where
  show :: DependencyException -> String
show (DependencyLoop [[Path]]
css) = String
"Test dependencies have cycles:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [[Path]] -> String
showCycles [[Path]]
css
    where
      showCycles :: [[Path]] -> String
showCycles = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String)
-> ([[Path]] -> [String]) -> [[Path]] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Path] -> String) -> [[Path]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map [Path] -> String
showCycle
      showPath :: Path -> String
showPath = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." ([String] -> String) -> (Path -> [String]) -> Path -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> [String]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList

      -- For clarity in the error message, the first element is repeated at the end
      showCycle :: [Path] -> String
showCycle []     = String
"- <empty cycle>"
      showCycle (Path
x:[Path]
xs) = String
"- " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Path -> String) -> [Path] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Path -> String
showPath (Path
xPath -> [Path] -> [Path]
forall a. a -> [a] -> [a]
:[Path]
xs [Path] -> [Path] -> [Path]
forall a. [a] -> [a] -> [a]
++ [Path
x]))

instance Exception DependencyException

-- | Specifies how to calculate a dependency
data DependencySpec
  = ExactDep (Seq TestName) (TVar Status)
  -- ^ Dependency specified by 'TestGroup'. Note that the first field is only
  -- there for dependency cycle detection - which can be introduced by using
  -- 'PatternDep'.
  | PatternDep Expr
  -- ^ All tests matching this 'Expr' should be considered dependencies
  deriving (DependencySpec -> DependencySpec -> Bool
(DependencySpec -> DependencySpec -> Bool)
-> (DependencySpec -> DependencySpec -> Bool) -> Eq DependencySpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DependencySpec -> DependencySpec -> Bool
== :: DependencySpec -> DependencySpec -> Bool
$c/= :: DependencySpec -> DependencySpec -> Bool
/= :: DependencySpec -> DependencySpec -> Bool
Eq)

instance Show DependencySpec where
  show :: DependencySpec -> String
show (PatternDep Expr
dep) = String
"PatternDep (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Expr -> String
forall a. Show a => a -> String
show Expr
dep String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
  show (ExactDep Path
testName TVar Status
_) = String
"ExactDep (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Path -> String
forall a. Show a => a -> String
show Path
testName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") (<TVar>)"

-- | Dependency of a test. Either it points to an exact path it depends on, or
-- contains a pattern that should be tested against all tests in a 'TestTree'.
data Dependency = Dependency DependencyType DependencySpec
  deriving (Dependency -> Dependency -> Bool
(Dependency -> Dependency -> Bool)
-> (Dependency -> Dependency -> Bool) -> Eq Dependency
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Dependency -> Dependency -> Bool
== :: Dependency -> Dependency -> Bool
$c/= :: Dependency -> Dependency -> Bool
/= :: Dependency -> Dependency -> Bool
Eq, Int -> Dependency -> ShowS
[Dependency] -> ShowS
Dependency -> String
(Int -> Dependency -> ShowS)
-> (Dependency -> String)
-> ([Dependency] -> ShowS)
-> Show Dependency
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Dependency -> ShowS
showsPrec :: Int -> Dependency -> ShowS
$cshow :: Dependency -> String
show :: Dependency -> String
$cshowList :: [Dependency] -> ShowS
showList :: [Dependency] -> ShowS
Show)

-- | Is given t'Dependency' a dependency that was introduced with 'After'?
isPatternDependency :: Dependency -> Bool
isPatternDependency :: Dependency -> Bool
isPatternDependency (Dependency DependencyType
_ (PatternDep {})) = Bool
True
isPatternDependency Dependency
_ = Bool
False

#if !MIN_VERSION_base(4,18,0)
-- The mapAccumM function behaves like a combination of mapM and mapAccumL that
-- traverses the structure while evaluating the actions and passing an accumulating
-- parameter from left to right. It returns a final value of this accumulator
-- together with the new structure. The accumulator is often used for caching the
-- intermediate results of a computation.
mapAccumM :: Monad m => (acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumM _ acc [] = return (acc, [])
mapAccumM f acc (x:xs) = do
  (acc', y) <- f acc x
  (acc'', ys) <- mapAccumM f acc' xs
  return (acc'', y:ys)
#endif

-- | An action with meta information
data TestAction act = TestAction
  { forall act. TestAction act -> act
testAction :: act
    -- ^ Some action, typically 'UnresolvedAction', 'ResolvedAction', or t'Action'.
  , forall act. TestAction act -> Path
testPath :: Path
    -- ^ Path pointing to this action (a series of group names + a test name)
  , forall act. TestAction act -> Seq Dependency
testDeps :: Seq Dependency
    -- ^ Dependencies introduced by AWK-like patterns
  , forall act. TestAction act -> TVar Status
testStatus :: TVar Status
    -- ^ Status var that can be used to monitor test progress
  }

-- | A test that still needs to be given its resource initializers and finalizers
type UnresolvedAction = Seq Initializer -> Seq Finalizer -> IO ()

-- | A test that, unlike 'UnresolvedAction', has been given its initializers and
-- finalizers.
type ResolvedAction = IO ()

-- | Number of 'TAction' leafs in a 'TestActionTree'. Used to prevent repeated
-- size calculations.
type Size = Int

-- | Simplified version of 'TestTree' that only includes the tests to be run (as
-- a t'TestAction') and the resources needed to run them (as t'Initializer's and
-- t'Finalizer's).
data TestActionTree act
  = TResource Initializer Finalizer (TestActionTree act)
  | TGroup Size [TestActionTree act]
  -- ^ Note the 'Size' field of this constructor: it stores how many 'TAction's
  -- are present in the tree. Functions using constructing this constructor
  -- should take care, or use 'tGroup' instead. If this constructor is ever
  -- exported, we should probably move it to its own module and expose only a
  -- smart constructor using pattern synonyms. For now, this seems more trouble
  -- than it's worth, given the number of types it needs defined in this module.
  | TAction (TestAction act)

-- | Smart constructor for 'TGroup'. Fills in 'Size' field by summing the size
-- of the given test trees.
tGroup :: [TestActionTree act] -> TestActionTree act
tGroup :: forall act. [TestActionTree act] -> TestActionTree act
tGroup [TestActionTree act]
trees = Int -> [TestActionTree act] -> TestActionTree act
forall act. Int -> [TestActionTree act] -> TestActionTree act
TGroup ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((TestActionTree act -> Int) -> [TestActionTree act] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map TestActionTree act -> Int
forall act. TestActionTree act -> Int
testActionTreeSize [TestActionTree act]
trees)) [TestActionTree act]
trees

-- | Size of a 'TestActionTree', i.e. the number of 'TAction's it contains.
testActionTreeSize :: TestActionTree act -> Int
testActionTreeSize :: forall act. TestActionTree act -> Int
testActionTreeSize = \case
  TResource Initializer
_ Finalizer
_ TestActionTree act
tree -> TestActionTree act -> Int
forall act. TestActionTree act -> Int
testActionTreeSize TestActionTree act
tree
  TGroup Int
size [TestActionTree act]
_ -> Int
size
  TAction TestAction act
_ -> Int
1

-- | Collect initializers and finalizers introduced by 'TResource' and apply them
-- to each action.
resolveTestActions :: TestActionTree UnresolvedAction -> TestActionTree ResolvedAction
resolveTestActions :: TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
-> TestActionTree (IO ())
resolveTestActions = Seq Initializer
-> Seq Finalizer
-> TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
-> TestActionTree (IO ())
forall {act}.
Seq Initializer
-> Seq Finalizer
-> TestActionTree (Seq Initializer -> Seq Finalizer -> act)
-> TestActionTree act
go Seq Initializer
forall a. Seq a
Seq.empty Seq Finalizer
forall a. Seq a
Seq.empty
 where
  go :: Seq Initializer
-> Seq Finalizer
-> TestActionTree (Seq Initializer -> Seq Finalizer -> act)
-> TestActionTree act
go Seq Initializer
inits Seq Finalizer
fins = \case
    TResource Initializer
ini Finalizer
fin TestActionTree (Seq Initializer -> Seq Finalizer -> act)
tree ->
      Initializer
-> Finalizer -> TestActionTree act -> TestActionTree act
forall act.
Initializer
-> Finalizer -> TestActionTree act -> TestActionTree act
TResource Initializer
ini Finalizer
fin (TestActionTree act -> TestActionTree act)
-> TestActionTree act -> TestActionTree act
forall a b. (a -> b) -> a -> b
$ Seq Initializer
-> Seq Finalizer
-> TestActionTree (Seq Initializer -> Seq Finalizer -> act)
-> TestActionTree act
go (Seq Initializer
inits Seq Initializer -> Initializer -> Seq Initializer
forall a. Seq a -> a -> Seq a
|> Initializer
ini) (Finalizer
fin Finalizer -> Seq Finalizer -> Seq Finalizer
forall a. a -> Seq a -> Seq a
<| Seq Finalizer
fins) TestActionTree (Seq Initializer -> Seq Finalizer -> act)
tree
    TGroup Int
size [TestActionTree (Seq Initializer -> Seq Finalizer -> act)]
trees ->
      Int -> [TestActionTree act] -> TestActionTree act
forall act. Int -> [TestActionTree act] -> TestActionTree act
TGroup Int
size ([TestActionTree act] -> TestActionTree act)
-> [TestActionTree act] -> TestActionTree act
forall a b. (a -> b) -> a -> b
$ (TestActionTree (Seq Initializer -> Seq Finalizer -> act)
 -> TestActionTree act)
-> [TestActionTree (Seq Initializer -> Seq Finalizer -> act)]
-> [TestActionTree act]
forall a b. (a -> b) -> [a] -> [b]
map (Seq Initializer
-> Seq Finalizer
-> TestActionTree (Seq Initializer -> Seq Finalizer -> act)
-> TestActionTree act
go Seq Initializer
inits Seq Finalizer
fins) [TestActionTree (Seq Initializer -> Seq Finalizer -> act)]
trees
    TAction (TestAction {TVar Status
Path
Seq Dependency
Seq Initializer -> Seq Finalizer -> act
testAction :: forall act. TestAction act -> act
testPath :: forall act. TestAction act -> Path
testDeps :: forall act. TestAction act -> Seq Dependency
testStatus :: forall act. TestAction act -> TVar Status
testAction :: Seq Initializer -> Seq Finalizer -> act
testPath :: Path
testDeps :: Seq Dependency
testStatus :: TVar Status
..})->
      TestAction act -> TestActionTree act
forall act. TestAction act -> TestActionTree act
TAction (TestAction act -> TestActionTree act)
-> TestAction act -> TestActionTree act
forall a b. (a -> b) -> a -> b
$ TestAction { testAction :: act
testAction = Seq Initializer -> Seq Finalizer -> act
testAction Seq Initializer
inits Seq Finalizer
fins, TVar Status
Path
Seq Dependency
testPath :: Path
testDeps :: Seq Dependency
testStatus :: TVar Status
testPath :: Path
testDeps :: Seq Dependency
testStatus :: TVar Status
.. }

-- | Turn a test tree into a list of actions to run tests coupled with
-- variables to watch them. Additionally, a collection of finalizers is
-- returned that can be used to clean up resources in case of unexpected
-- events.
createTestActions
  :: OptionSet
  -> TestTree
  -> IO ([TestAction Action], Seq Finalizer)
createTestActions :: OptionSet -> TestTree -> IO ([TestAction Action], Seq Finalizer)
createTestActions OptionSet
opts0 TestTree
tree = do
  -- Folding the test tree reduces it to a 'TestActionTree', which is a simplified
  -- version of 'TestTree' that only includes the tests to be run, resources needed
  -- to run them, and meta information needed to watch test progress and calculate
  -- dependencies in 'resolveDeps'.
  unresolvedTestTree :: TestActionTree UnresolvedAction <-
    (ReaderT
   (Path, Seq Dependency)
   IO
   (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
 -> (Path, Seq Dependency)
 -> IO (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())))
-> (Path, Seq Dependency)
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
-> IO (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT
  (Path, Seq Dependency)
  IO
  (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
-> (Path, Seq Dependency)
-> IO (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ((Path, Seq Dependency)
forall a. Monoid a => a
mempty :: (Path, Seq Dependency)) (ReaderT
   (Path, Seq Dependency)
   IO
   (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
 -> IO (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())))
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
-> IO (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
forall a b. (a -> b) -> a -> b
$
      ReaderT
  (Path, Seq Dependency)
  IO
  (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
-> TreeFold
     (ReaderT
        (Path, Seq Dependency)
        IO
        (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())))
-> OptionSet
-> TestTree
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
forall b. b -> TreeFold b -> OptionSet -> TestTree -> b
foldTestTree0 (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
forall a. a -> ReaderT (Path, Seq Dependency) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())]
-> TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
forall act. [TestActionTree act] -> TestActionTree act
tGroup [])) (TreeFold { OptionSet
-> String
-> t
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
OptionSet
-> String
-> [ReaderT
      (Path, Seq Dependency)
      IO
      (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))]
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
OptionSet
-> DependencyType
-> Expr
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
OptionSet
-> ResourceSpec a
-> (IO a
    -> ReaderT
         (Path, Seq Dependency)
         IO
         (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())))
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
forall a.
OptionSet
-> ResourceSpec a
-> (IO a
    -> ReaderT
         (Path, Seq Dependency)
         IO
         (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())))
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
forall t.
IsTest t =>
OptionSet
-> String
-> t
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
foldSingle :: forall t.
IsTest t =>
OptionSet
-> String
-> t
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
foldResource :: forall a.
OptionSet
-> ResourceSpec a
-> (IO a
    -> ReaderT
         (Path, Seq Dependency)
         IO
         (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())))
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
foldAfter :: OptionSet
-> DependencyType
-> Expr
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
foldGroup :: OptionSet
-> String
-> [ReaderT
      (Path, Seq Dependency)
      IO
      (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))]
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
foldAfter :: OptionSet
-> DependencyType
-> Expr
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
foldGroup :: OptionSet
-> String
-> [ReaderT
      (Path, Seq Dependency)
      IO
      (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))]
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
foldResource :: forall a.
OptionSet
-> ResourceSpec a
-> (IO a
    -> ReaderT
         (Path, Seq Dependency)
         IO
         (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())))
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
foldSingle :: forall t.
IsTest t =>
OptionSet
-> String
-> t
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
.. }) OptionSet
opts0 TestTree
tree

  let
    finalizers :: Seq Finalizer
    finalizers = TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
-> Seq Finalizer
forall act. TestActionTree act -> Seq Finalizer
collectFinalizers TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
unresolvedTestTree

    tests :: [TestAction ResolvedAction]
    tests = TestActionTree (IO ()) -> [TestAction (IO ())]
forall act. TestActionTree act -> [TestAction act]
collectTests (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
-> TestActionTree (IO ())
resolveTestActions TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
unresolvedTestTree)

  case resolveDeps tests of
    Right [TestAction Action]
tests' -> ([TestAction Action], Seq Finalizer)
-> IO ([TestAction Action], Seq Finalizer)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TestAction Action]
tests', Seq Finalizer
finalizers)
    Left [[Path]]
cycles  -> DependencyException -> IO ([TestAction Action], Seq Finalizer)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO ([[Path]] -> DependencyException
DependencyLoop [[Path]]
cycles)

  where
    -- * Functions used in 'TreeFold'
    foldSingle :: IsTest t => OptionSet -> TestName -> t -> Tr
    foldSingle :: forall t.
IsTest t =>
OptionSet
-> String
-> t
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
foldSingle OptionSet
opts String
name t
test = do
      testStatus <- IO (TVar Status) -> ReaderT (Path, Seq Dependency) IO (TVar Status)
forall a. IO a -> ReaderT (Path, Seq Dependency) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TVar Status)
 -> ReaderT (Path, Seq Dependency) IO (TVar Status))
-> IO (TVar Status)
-> ReaderT (Path, Seq Dependency) IO (TVar Status)
forall a b. (a -> b) -> a -> b
$ Status -> IO (TVar Status)
forall a. a -> IO (TVar a)
newTVarIO Status
NotStarted
      (parentPath, testDeps) <- ask
      let
        testPath = Path
parentPath Path -> String -> Path
forall a. Seq a -> a -> Seq a
|> String
name
        testAction = ((Progress -> IO ()) -> IO Result)
-> TVar Status
-> Timeout
-> HideProgress
-> Seq Initializer
-> Seq Finalizer
-> IO ()
executeTest (OptionSet -> t -> (Progress -> IO ()) -> IO Result
forall t.
IsTest t =>
OptionSet -> t -> (Progress -> IO ()) -> IO Result
run OptionSet
opts t
test) TVar Status
testStatus (OptionSet -> Timeout
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts) (OptionSet -> HideProgress
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts)
      pure $ TAction (TestAction {..})

    foldResource :: OptionSet -> ResourceSpec a -> (IO a -> Tr) -> Tr
    foldResource :: forall a.
OptionSet
-> ResourceSpec a
-> (IO a
    -> ReaderT
         (Path, Seq Dependency)
         IO
         (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())))
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
foldResource OptionSet
_opts (ResourceSpec IO a
doInit a -> IO ()
doRelease) IO a
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
a = do
      initVar <- IO (TVar (Resource a))
-> ReaderT (Path, Seq Dependency) IO (TVar (Resource a))
forall a. IO a -> ReaderT (Path, Seq Dependency) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TVar (Resource a))
 -> ReaderT (Path, Seq Dependency) IO (TVar (Resource a)))
-> IO (TVar (Resource a))
-> ReaderT (Path, Seq Dependency) IO (TVar (Resource a))
forall a b. (a -> b) -> a -> b
$ Resource a -> IO (TVar (Resource a))
forall a. a -> IO (TVar a)
newTVarIO Resource a
forall r. Resource r
NotCreated
      testTree <- a (getResource initVar)
      finishVar <- liftIO $ newTVarIO (testActionTreeSize testTree)
      let
        ini = IO a -> TVar (Resource a) -> Initializer
forall res. IO res -> TVar (Resource res) -> Initializer
Initializer IO a
doInit TVar (Resource a)
initVar
        fin = (a -> IO ()) -> TVar (Resource a) -> TVar Int -> Finalizer
forall res.
(res -> IO ()) -> TVar (Resource res) -> TVar Int -> Finalizer
Finalizer a -> IO ()
doRelease TVar (Resource a)
initVar TVar Int
finishVar
      pure $ TResource ini fin testTree

    foldAfter :: OptionSet -> DependencyType -> Expr -> Tr -> Tr
    foldAfter :: OptionSet
-> DependencyType
-> Expr
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
foldAfter OptionSet
_opts DependencyType
depType Expr
pat = ((Path, Seq Dependency) -> (Path, Seq Dependency))
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local ((Seq Dependency -> Seq Dependency)
-> (Path, Seq Dependency) -> (Path, Seq Dependency)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (DependencyType -> DependencySpec -> Dependency
Dependency DependencyType
depType (Expr -> DependencySpec
PatternDep Expr
pat) Dependency -> Seq Dependency -> Seq Dependency
forall a. a -> Seq a -> Seq a
<|))

    foldGroup :: OptionSet -> TestName -> [Tr] -> Tr
    foldGroup :: OptionSet
-> String
-> [ReaderT
      (Path, Seq Dependency)
      IO
      (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))]
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
foldGroup OptionSet
opts String
name [ReaderT
   (Path, Seq Dependency)
   IO
   (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))]
trees =
      ([TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())]
 -> TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
-> ReaderT
     (Path, Seq Dependency)
     IO
     [TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())]
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
forall a b.
(a -> b)
-> ReaderT (Path, Seq Dependency) IO a
-> ReaderT (Path, Seq Dependency) IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())]
-> TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
forall act. [TestActionTree act] -> TestActionTree act
tGroup (ReaderT
   (Path, Seq Dependency)
   IO
   [TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())]
 -> ReaderT
      (Path, Seq Dependency)
      IO
      (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())))
-> ReaderT
     (Path, Seq Dependency)
     IO
     [TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())]
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
forall a b. (a -> b) -> a -> b
$ ((Path, Seq Dependency) -> (Path, Seq Dependency))
-> ReaderT
     (Path, Seq Dependency)
     IO
     [TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())]
-> ReaderT
     (Path, Seq Dependency)
     IO
     [TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())]
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local ((Path -> Path) -> (Path, Seq Dependency) -> (Path, Seq Dependency)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Path -> String -> Path
forall a. Seq a -> a -> Seq a
|> String
name)) (ReaderT
   (Path, Seq Dependency)
   IO
   [TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())]
 -> ReaderT
      (Path, Seq Dependency)
      IO
      [TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())])
-> ReaderT
     (Path, Seq Dependency)
     IO
     [TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())]
-> ReaderT
     (Path, Seq Dependency)
     IO
     [TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())]
forall a b. (a -> b) -> a -> b
$
        case OptionSet -> ExecutionMode
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts of
          Independent Parallel
Parallel -> [ReaderT
   (Path, Seq Dependency)
   IO
   (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))]
-> ReaderT
     (Path, Seq Dependency)
     IO
     [TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ReaderT
   (Path, Seq Dependency)
   IO
   (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))]
trees
          Independent Parallel
NonParallel -> DependencyType
-> [ReaderT
      (Path, Seq Dependency)
      IO
      (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))]
-> ReaderT
     (Path, Seq Dependency)
     IO
     [TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())]
foldSequential DependencyType
AllFinish [ReaderT
   (Path, Seq Dependency)
   IO
   (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))]
trees
          Dependent DependencyType
depType -> DependencyType
-> [ReaderT
      (Path, Seq Dependency)
      IO
      (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))]
-> ReaderT
     (Path, Seq Dependency)
     IO
     [TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())]
foldSequential DependencyType
depType [ReaderT
   (Path, Seq Dependency)
   IO
   (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))]
trees

    foldSequential :: DependencyType -> [Tr] -> ReaderT (Path, Seq Dependency) IO [TestActionTree UnresolvedAction]
    foldSequential :: DependencyType
-> [ReaderT
      (Path, Seq Dependency)
      IO
      (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))]
-> ReaderT
     (Path, Seq Dependency)
     IO
     [TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())]
foldSequential DependencyType
depType =
      ((Seq Dependency,
  [TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())])
 -> [TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())])
-> ReaderT
     (Path, Seq Dependency)
     IO
     (Seq Dependency,
      [TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())])
-> ReaderT
     (Path, Seq Dependency)
     IO
     [TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())]
forall a b.
(a -> b)
-> ReaderT (Path, Seq Dependency) IO a
-> ReaderT (Path, Seq Dependency) IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Seq Dependency,
 [TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())])
-> [TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())]
forall a b. (a, b) -> b
snd (ReaderT
   (Path, Seq Dependency)
   IO
   (Seq Dependency,
    [TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())])
 -> ReaderT
      (Path, Seq Dependency)
      IO
      [TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())])
-> ([ReaderT
       (Path, Seq Dependency)
       IO
       (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))]
    -> ReaderT
         (Path, Seq Dependency)
         IO
         (Seq Dependency,
          [TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())]))
-> [ReaderT
      (Path, Seq Dependency)
      IO
      (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))]
-> ReaderT
     (Path, Seq Dependency)
     IO
     [TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Seq Dependency
 -> ReaderT
      (Path, Seq Dependency)
      IO
      (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
 -> ReaderT
      (Path, Seq Dependency)
      IO
      (Seq Dependency,
       TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())))
-> Seq Dependency
-> [ReaderT
      (Path, Seq Dependency)
      IO
      (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))]
-> ReaderT
     (Path, Seq Dependency)
     IO
     (Seq Dependency,
      [TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())])
forall (m :: * -> *) (t :: * -> *) s a b.
(Monad m, Traversable t) =>
(s -> a -> m (s, b)) -> s -> t a -> m (s, t b)
mapAccumM (DependencyType
-> Seq Dependency
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
-> ReaderT
     (Path, Seq Dependency)
     IO
     (Seq Dependency,
      TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
goSeqGroup DependencyType
depType) Seq Dependency
forall a. Monoid a => a
mempty

    -- * Utility functions
    collectTests :: TestActionTree act -> [TestAction act]
    collectTests :: forall act. TestActionTree act -> [TestAction act]
collectTests = \case
      TResource Initializer
_ Finalizer
_ TestActionTree act
t -> TestActionTree act -> [TestAction act]
forall act. TestActionTree act -> [TestAction act]
collectTests TestActionTree act
t
      TGroup Int
_ [TestActionTree act]
trees  -> (TestActionTree act -> [TestAction act])
-> [TestActionTree act] -> [TestAction act]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TestActionTree act -> [TestAction act]
forall act. TestActionTree act -> [TestAction act]
collectTests [TestActionTree act]
trees
      TAction TestAction act
action  -> [TestAction act
action]

    collectFinalizers :: TestActionTree act -> Seq Finalizer
    collectFinalizers :: forall act. TestActionTree act -> Seq Finalizer
collectFinalizers = \case
      TResource Initializer
_ Finalizer
fin TestActionTree act
t -> TestActionTree act -> Seq Finalizer
forall act. TestActionTree act -> Seq Finalizer
collectFinalizers TestActionTree act
t Seq Finalizer -> Finalizer -> Seq Finalizer
forall a. Seq a -> a -> Seq a
|> Finalizer
fin
      TGroup Int
_ [TestActionTree act]
trees    -> [Seq Finalizer] -> Seq Finalizer
forall a. Monoid a => [a] -> a
mconcat ((TestActionTree act -> Seq Finalizer)
-> [TestActionTree act] -> [Seq Finalizer]
forall a b. (a -> b) -> [a] -> [b]
map TestActionTree act -> Seq Finalizer
forall act. TestActionTree act -> Seq Finalizer
collectFinalizers [TestActionTree act]
trees)
      TAction TestAction act
_         -> Seq Finalizer
forall a. Monoid a => a
mempty

    goSeqGroup
      :: DependencyType
      -> Seq Dependency
      -> Tr
      -> ReaderT (Path, Seq Dependency) IO (Seq Dependency, TestActionTree UnresolvedAction)
    goSeqGroup :: DependencyType
-> Seq Dependency
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
-> ReaderT
     (Path, Seq Dependency)
     IO
     (Seq Dependency,
      TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
goSeqGroup DependencyType
depType Seq Dependency
prevDeps ReaderT
  (Path, Seq Dependency)
  IO
  (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
treeM = do
      tree0 <- ((Path, Seq Dependency) -> (Path, Seq Dependency))
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local ((Seq Dependency -> Seq Dependency)
-> (Path, Seq Dependency) -> (Path, Seq Dependency)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Seq Dependency
prevDeps Seq Dependency -> Seq Dependency -> Seq Dependency
forall a. Seq a -> Seq a -> Seq a
><)) ReaderT
  (Path, Seq Dependency)
  IO
  (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
treeM

      let
        toDep TestAction {act
TVar Status
Path
Seq Dependency
testAction :: forall act. TestAction act -> act
testPath :: forall act. TestAction act -> Path
testDeps :: forall act. TestAction act -> Seq Dependency
testStatus :: forall act. TestAction act -> TVar Status
testAction :: act
testPath :: Path
testDeps :: Seq Dependency
testStatus :: TVar Status
..} = DependencyType -> DependencySpec -> Dependency
Dependency DependencyType
depType (Path -> TVar Status -> DependencySpec
ExactDep Path
testPath TVar Status
testStatus)
        deps0 = [Dependency] -> Seq Dependency
forall a. [a] -> Seq a
Seq.fromList (TestAction (Seq Initializer -> Seq Finalizer -> IO ())
-> Dependency
forall {act}. TestAction act -> Dependency
toDep (TestAction (Seq Initializer -> Seq Finalizer -> IO ())
 -> Dependency)
-> [TestAction (Seq Initializer -> Seq Finalizer -> IO ())]
-> [Dependency]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
-> [TestAction (Seq Initializer -> Seq Finalizer -> IO ())]
forall act. TestActionTree act -> [TestAction act]
collectTests TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
tree0)

        -- If this test tree is empty (either due to it being actually empty, or due
        -- to all tests being filtered) we need to propagate the previous dependencies.
        deps1 = if Seq Dependency -> Bool
forall a. Seq a -> Bool
Seq.null Seq Dependency
deps0 then Seq Dependency
prevDeps else Seq Dependency
deps0

      pure (deps1, tree0)

-- | Take care of the dependencies.
--
-- Return 'Left' if there is a dependency cycle, containing the detected cycles.
resolveDeps
  :: [TestAction ResolvedAction]
  -> Either [[Path]] [TestAction Action]
resolveDeps :: [TestAction (IO ())] -> Either [[Path]] [TestAction Action]
resolveDeps [TestAction (IO ())]
tests = [(TestAction Action, (Path, [Path]))]
-> Either [[Path]] [TestAction Action]
forall {a}. [(a, (Path, [Path]))] -> Either [[Path]] [a]
maybeCheckCycles ([(TestAction Action, (Path, [Path]))]
 -> Either [[Path]] [TestAction Action])
-> [(TestAction Action, (Path, [Path]))]
-> Either [[Path]] [TestAction Action]
forall a b. (a -> b) -> a -> b
$ do
  TestAction { testAction=run_test, .. } <- [TestAction (IO ())]
tests

  let
    deps' = (Dependency -> [(DependencyType, TVar Status, Path)])
-> Seq Dependency -> [(DependencyType, TVar Status, Path)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Dependency -> [(DependencyType, TVar Status, Path)]
findDeps Seq Dependency
testDeps

    getStatus :: STM ActionStatus
    getStatus = ((DependencyType, TVar Status, Path)
 -> STM ActionStatus -> STM ActionStatus)
-> STM ActionStatus
-> [(DependencyType, TVar Status, Path)]
-> STM ActionStatus
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
      (\(DependencyType
deptype, TVar Status
statusvar, Path
_) STM ActionStatus
k -> do
        status <- TVar Status -> STM Status
forall a. TVar a -> STM a
readTVar TVar Status
statusvar
        case status of
          Done Result
result
            | DependencyType
deptype DependencyType -> DependencyType -> Bool
forall a. Eq a => a -> a -> Bool
== DependencyType
AllFinish Bool -> Bool -> Bool
|| Result -> Bool
resultSuccessful Result
result -> STM ActionStatus
k
            | Bool
otherwise -> ActionStatus -> STM ActionStatus
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ActionStatus
ActionSkip
          Status
_ -> ActionStatus -> STM ActionStatus
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ActionStatus
ActionWait
      )
      (ActionStatus -> STM ActionStatus
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ActionStatus
ActionReady)
      [(DependencyType, TVar Status, Path)]
deps'
  let
    dep_paths = ((DependencyType, TVar Status, Path) -> Path)
-> [(DependencyType, TVar Status, Path)] -> [Path]
forall a b. (a -> b) -> [a] -> [b]
map (\(DependencyType
_, TVar Status
_, Path
path) -> Path
path) [(DependencyType, TVar Status, Path)]
deps'
    action = Action
      { actionStatus :: STM ActionStatus
actionStatus = STM ActionStatus
getStatus
      , actionRun :: IO ()
actionRun = IO ()
run_test
      , actionSkip :: STM ()
actionSkip = TVar Status -> Status -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Status
testStatus (Status -> STM ()) -> Status -> STM ()
forall a b. (a -> b) -> a -> b
$ Result -> Status
Done (Result -> Status) -> Result -> Status
forall a b. (a -> b) -> a -> b
$ Result
          -- See Note [Skipped tests]
          { resultOutcome :: Outcome
resultOutcome = FailureReason -> Outcome
Failure FailureReason
TestDepFailed
          , resultDescription :: String
resultDescription = String
""
          , resultShortDescription :: String
resultShortDescription = String
"SKIP"
          , resultTime :: Time
resultTime = Time
0
          , resultDetailsPrinter :: ResultDetailsPrinter
resultDetailsPrinter = ResultDetailsPrinter
noResultDetails
          }
      }
  return (TestAction { testAction = action, .. }, (testPath, dep_paths))
 where
  -- Skip cycle checking if no patterns are used: sequential test groups can't
  -- introduce cycles on their own.
  maybeCheckCycles :: [(a, (Path, [Path]))] -> Either [[Path]] [a]
maybeCheckCycles
    | (TestAction (IO ()) -> Bool) -> [TestAction (IO ())] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Dependency -> Bool) -> Seq Dependency -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Dependency -> Bool
isPatternDependency (Seq Dependency -> Bool)
-> (TestAction (IO ()) -> Seq Dependency)
-> TestAction (IO ())
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestAction (IO ()) -> Seq Dependency
forall act. TestAction act -> Seq Dependency
testDeps) [TestAction (IO ())]
tests = [(a, (Path, [Path]))] -> Either [[Path]] [a]
forall b a. Ord b => [(a, (b, [b]))] -> Either [[b]] [a]
checkCycles
    | Bool
otherwise = [a] -> Either [[Path]] [a]
forall a b. b -> Either a b
Right ([a] -> Either [[Path]] [a])
-> ([(a, (Path, [Path]))] -> [a])
-> [(a, (Path, [Path]))]
-> Either [[Path]] [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, (Path, [Path])) -> a) -> [(a, (Path, [Path]))] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, (Path, [Path])) -> a
forall a b. (a, b) -> a
fst

  findDeps :: Dependency -> [(DependencyType, TVar Status, Seq TestName)]
  findDeps :: Dependency -> [(DependencyType, TVar Status, Path)]
findDeps (Dependency DependencyType
depType DependencySpec
depSpec) =
    case DependencySpec
depSpec of
      ExactDep Path
testPath TVar Status
statusVar ->
        -- A dependency defined using 'TestGroup' has already been pinpointed
        -- to its 'statusVar' in 'createTestActions'.
        [(DependencyType
depType, TVar Status
statusVar, Path
testPath)]
      PatternDep Expr
expr -> do
        -- A dependency defined using patterns needs to scan the whole test
        -- tree for matching tests.
        TestAction{testPath, testStatus} <- [TestAction (IO ())]
tests
        guard $ exprMatches expr testPath
        [(depType, testStatus, testPath)]

-- | Check a graph, given as an adjacency list, for cycles. Return 'Left' if the
-- graph contained cycles, or return all nodes in the graph as a 'Right' if it
-- didn't.
checkCycles :: Ord b => [(a, (b, [b]))] -> Either [[b]] [a]
checkCycles :: forall b a. Ord b => [(a, (b, [b]))] -> Either [[b]] [a]
checkCycles [(a, (b, [b]))]
tests = do
  let
    result :: [a]
result = (a, (b, [b])) -> a
forall a b. (a, b) -> a
fst ((a, (b, [b])) -> a) -> [(a, (b, [b]))] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, (b, [b]))]
tests
    graph :: [(b, b, [b])]
graph = [ (b
v, b
v, [b]
vs) | (b
v, [b]
vs) <- (a, (b, [b])) -> (b, [b])
forall a b. (a, b) -> b
snd ((a, (b, [b])) -> (b, [b])) -> [(a, (b, [b]))] -> [(b, [b])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, (b, [b]))]
tests ]
    sccs :: [SCC b]
sccs = [(b, b, [b])] -> [SCC b]
forall key node. Ord key => [(node, key, [key])] -> [SCC node]
stronglyConnComp [(b, b, [b])]
graph
    cycles :: [[b]]
cycles =
      ((SCC b -> Maybe [b]) -> [SCC b] -> [[b]])
-> [SCC b] -> (SCC b -> Maybe [b]) -> [[b]]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SCC b -> Maybe [b]) -> [SCC b] -> [[b]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [SCC b]
sccs ((SCC b -> Maybe [b]) -> [[b]]) -> (SCC b -> Maybe [b]) -> [[b]]
forall a b. (a -> b) -> a -> b
$ \case
        AcyclicSCC{} -> Maybe [b]
forall a. Maybe a
Nothing
        CyclicSCC [b]
vs -> [b] -> Maybe [b]
forall a. a -> Maybe a
Just [b]
vs

  case [[b]]
cycles of
    [] -> [a] -> Either [[b]] [a]
forall a b. b -> Either a b
Right [a]
result
    [[b]]
_  -> [[b]] -> Either [[b]] [a]
forall a b. a -> Either a b
Left [[b]]
cycles

-- | Used to create the IO action which is passed in a WithResource node
getResource :: TVar (Resource r) -> IO r
getResource :: forall r. TVar (Resource r) -> IO r
getResource TVar (Resource r)
var =
  STM r -> IO r
forall a. STM a -> IO a
atomically (STM r -> IO r) -> STM r -> IO r
forall a b. (a -> b) -> a -> b
$ do
    rState <- TVar (Resource r) -> STM (Resource r)
forall a. TVar a -> STM a
readTVar TVar (Resource r)
var
    case rState of
      Created r
r -> r -> STM r
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return r
r
      Resource r
Destroyed -> ResourceError -> STM r
forall e a. Exception e => e -> STM a
throwSTM ResourceError
UseOutsideOfTest
      Resource r
_ -> SomeException -> STM r
forall e a. Exception e => e -> STM a
throwSTM (SomeException -> STM r) -> SomeException -> STM r
forall a b. (a -> b) -> a -> b
$ String -> Resource r -> SomeException
forall r. String -> Resource r -> SomeException
unexpectedState String
"getResource" Resource r
rState

-- | Run a resource finalizer.
--
-- This function is called from two different places:
--
-- 1. A test thread, which is the last one to use the resource.
-- 2. The main thread, if an exception (e.g. Ctrl-C) is received.
--
-- Therefore, it is possible that this function is called multiple
-- times concurrently on the same finalizer.
--
-- This function should be run with async exceptions masked,
-- and the restore function should be passed as an argument.
destroyResource :: (forall a . IO a -> IO a) -> Finalizer -> IO (Maybe SomeException)
destroyResource :: (forall a. IO a -> IO a) -> Finalizer -> IO (Maybe SomeException)
destroyResource forall a. IO a -> IO a
restore (Finalizer res -> IO ()
doRelease TVar (Resource res)
stateVar TVar Int
_) = IO (IO (Maybe SomeException)) -> IO (Maybe SomeException)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO (Maybe SomeException)) -> IO (Maybe SomeException))
-> (STM (IO (Maybe SomeException))
    -> IO (IO (Maybe SomeException)))
-> STM (IO (Maybe SomeException))
-> IO (Maybe SomeException)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (IO (Maybe SomeException)) -> IO (IO (Maybe SomeException))
forall a. STM a -> IO a
atomically (STM (IO (Maybe SomeException)) -> IO (Maybe SomeException))
-> STM (IO (Maybe SomeException)) -> IO (Maybe SomeException)
forall a b. (a -> b) -> a -> b
$ do
  rState <- TVar (Resource res) -> STM (Resource res)
forall a. TVar a -> STM a
readTVar TVar (Resource res)
stateVar
  case rState of
    Created res
res -> do
      TVar (Resource res) -> Resource res -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Resource res)
stateVar Resource res
forall r. Resource r
BeingDestroyed
      IO (Maybe SomeException) -> STM (IO (Maybe SomeException))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (Maybe SomeException) -> STM (IO (Maybe SomeException)))
-> IO (Maybe SomeException) -> STM (IO (Maybe SomeException))
forall a b. (a -> b) -> a -> b
$
        ((SomeException -> Maybe SomeException)
-> (() -> Maybe SomeException)
-> Either SomeException ()
-> Maybe SomeException
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just (Maybe SomeException -> () -> Maybe SomeException
forall a b. a -> b -> a
const Maybe SomeException
forall a. Maybe a
Nothing)
          (Either SomeException () -> Maybe SomeException)
-> IO (Either SomeException ()) -> IO (Maybe SomeException)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (IO () -> IO ()
forall a. IO a -> IO a
restore (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ res -> IO ()
doRelease res
res))
          IO (Maybe SomeException) -> IO () -> IO (Maybe SomeException)
forall a b. IO a -> IO b -> IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* STM () -> IO ()
forall a. STM a -> IO a
atomically (TVar (Resource res) -> Resource res -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Resource res)
stateVar Resource res
forall r. Resource r
Destroyed)
    Resource res
BeingCreated   -> STM (IO (Maybe SomeException))
forall a. STM a
retry
    -- If the resource is being destroyed, wait until it is destroyed.
    -- This is so that we don't start destroying the next resource out of
    -- order.
    Resource res
BeingDestroyed -> STM (IO (Maybe SomeException))
forall a. STM a
retry
    Resource res
NotCreated -> do
      -- prevent the resource from being created by a competing thread
      TVar (Resource res) -> Resource res -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Resource res)
stateVar Resource res
forall r. Resource r
Destroyed
      IO (Maybe SomeException) -> STM (IO (Maybe SomeException))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (Maybe SomeException) -> STM (IO (Maybe SomeException)))
-> IO (Maybe SomeException) -> STM (IO (Maybe SomeException))
forall a b. (a -> b) -> a -> b
$ Maybe SomeException -> IO (Maybe SomeException)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SomeException
forall a. Maybe a
Nothing
    FailedToCreate {} -> IO (Maybe SomeException) -> STM (IO (Maybe SomeException))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (Maybe SomeException) -> STM (IO (Maybe SomeException)))
-> IO (Maybe SomeException) -> STM (IO (Maybe SomeException))
forall a b. (a -> b) -> a -> b
$ Maybe SomeException -> IO (Maybe SomeException)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SomeException
forall a. Maybe a
Nothing
    Resource res
Destroyed         -> IO (Maybe SomeException) -> STM (IO (Maybe SomeException))
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (Maybe SomeException) -> STM (IO (Maybe SomeException)))
-> IO (Maybe SomeException) -> STM (IO (Maybe SomeException))
forall a b. (a -> b) -> a -> b
$ Maybe SomeException -> IO (Maybe SomeException)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SomeException
forall a. Maybe a
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 :: OptionSet -> TestTree -> (OptionSet, TestTree)
applyTopLevelPlusTestOptions OptionSet
opts (PlusTestOptions OptionSet -> OptionSet
f TestTree
tree) =
  OptionSet -> TestTree -> (OptionSet, TestTree)
applyTopLevelPlusTestOptions (OptionSet -> OptionSet
f OptionSet
opts) TestTree
tree
applyTopLevelPlusTestOptions OptionSet
opts TestTree
tree = (OptionSet
opts, TestTree
tree)

-- | Start running the tests (in background, in parallel) and pass control
-- to the callback.
--
-- Once the callback returns, stop running the tests.
--
-- The number of test running threads is determined by the t'NumThreads'
-- option.
--
-- @since 0.10
launchTestTree
  :: OptionSet
  -> TestTree
  -> (StatusMap -> IO (Time -> IO a))
    -- ^ A callback. First, it receives the 'StatusMap' through which it
    -- can observe the execution of tests in real time. Typically (but not
    -- necessarily), it waits until all the tests are finished.
    --
    -- After this callback returns, the test-running threads (if any) are
    -- terminated and all resources acquired by tests are released.
    --
    -- The callback must return another callback (of type @'Time' -> 'IO'
    -- a@) which additionally can report and/or record the total time
    -- taken by the test suite. This time includes the time taken to run
    -- all resource initializers and finalizers, which is why it is more
    -- accurate than what could be measured from inside the first callback.
  -> IO a
launchTestTree :: forall a.
OptionSet -> TestTree -> (StatusMap -> IO (Time -> IO a)) -> IO a
launchTestTree OptionSet
opts' TestTree
tree' StatusMap -> IO (Time -> IO a)
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 (OptionSet
opts, TestTree
tree) = OptionSet -> TestTree -> (OptionSet, TestTree)
applyTopLevelPlusTestOptions OptionSet
opts' TestTree
tree'
  (testActions, fins) <- OptionSet -> TestTree -> IO ([TestAction Action], Seq Finalizer)
createTestActions OptionSet
opts TestTree
tree
  let NumThreads numThreads = lookupOption opts
  (t,k1) <- timed $ do
     abortTests <- runInParallel numThreads (testAction <$> testActions)
     (do let smap = [(Int, TVar Status)] -> StatusMap
forall a. [(Int, a)] -> IntMap a
IntMap.fromDistinctAscList ([(Int, TVar Status)] -> StatusMap)
-> [(Int, TVar Status)] -> StatusMap
forall a b. (a -> b) -> a -> b
$ [Int] -> [TVar Status] -> [(Int, TVar Status)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] (TestAction Action -> TVar Status
forall act. TestAction act -> TVar Status
testStatus (TestAction Action -> TVar Status)
-> [TestAction Action] -> [TVar Status]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TestAction Action]
testActions)
         k0 smap)
      `finallyRestore` \forall a. IO a -> IO a
restore -> do
         -- Tell all running tests to wrap up.
         IO ()
abortTests
         -- Destroy all allocated resources in the case they didn't get
         -- destroyed by their tests. (See #75.)
         (Finalizer -> IO (Maybe SomeException)) -> Seq Finalizer -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
F.mapM_ ((forall a. IO a -> IO a) -> Finalizer -> IO (Maybe SomeException)
destroyResource IO a -> IO a
forall a. IO a -> IO a
restore) Seq Finalizer
fins
         -- Wait until all resources are destroyed. (Specifically, those
         -- that were being destroyed by their tests, not those that were
         -- destroyed by destroyResource above.)
         IO () -> IO ()
forall a. IO a -> IO a
restore (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Seq Finalizer -> IO ()
forall {t :: * -> *}. Foldable t => t Finalizer -> IO ()
waitForResources Seq Finalizer
fins
  k1 t
  where
    alive :: Resource r -> Bool
    alive :: forall r. Resource r -> Bool
alive Resource r
r = case Resource r
r of
      Resource r
NotCreated -> Bool
False
      Resource r
BeingCreated -> Bool
True
      FailedToCreate {} -> Bool
False
      Created {} -> Bool
True
      Resource r
BeingDestroyed -> Bool
True
      Resource r
Destroyed -> Bool
False

    waitForResources :: t Finalizer -> IO ()
waitForResources t Finalizer
fins = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
      t Finalizer -> (Finalizer -> STM ()) -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
F.forM_ t Finalizer
fins ((Finalizer -> STM ()) -> STM ())
-> (Finalizer -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \(Finalizer res -> IO ()
_ TVar (Resource res)
rvar TVar Int
_) -> do
        res <- TVar (Resource res) -> STM (Resource res)
forall a. TVar a -> STM a
readTVar TVar (Resource res)
rvar
        check $ not $ alive res

unexpectedState :: String -> Resource r -> SomeException
unexpectedState :: forall r. String -> Resource r -> SomeException
unexpectedState String
where_ Resource r
r = ResourceError -> SomeException
forall e. Exception e => e -> SomeException
toException (ResourceError -> SomeException) -> ResourceError -> SomeException
forall a b. (a -> b) -> a -> b
$ String -> String -> ResourceError
UnexpectedState String
where_ (Resource r -> String
forall a. Show a => a -> String
show Resource r
r)

sleepIndefinitely :: IO ()
sleepIndefinitely :: IO ()
sleepIndefinitely = IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay (Int
10Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
7::Int))

-- | Like 'finally' (which also masks its finalizers), but pass the restore
-- action to the finalizer.
finallyRestore
  :: IO a
    -- ^ computation to run first
  -> ((forall c . IO c -> IO c) -> IO b)
    -- ^ computation to run afterward (even if an exception was raised)
  -> IO a
    -- ^ returns the value from the first computation
IO a
a finallyRestore :: forall a b. IO a -> ((forall a. IO a -> IO a) -> IO b) -> IO a
`finallyRestore` (forall a. IO a -> IO a) -> IO b
sequel =
  ((forall a. IO a -> IO a) -> IO a) -> IO a
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO a) -> IO a)
-> ((forall a. IO a -> IO a) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
    r <- IO a -> IO a
forall a. IO a -> IO a
restore IO a
a IO a -> IO b -> IO a
forall a b. IO a -> IO b -> IO a
`onException` (forall a. IO a -> IO a) -> IO b
sequel IO c -> IO c
forall a. IO a -> IO a
restore
    _ <- sequel restore
    return r