-- | Running tests
{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes,
             FlexibleContexts, CPP, DeriveDataTypeable, 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 Data.Typeable
import Control.Monad (forever, guard, join, liftM)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Reader (ReaderT(..), local, ask)
import Control.Monad.Trans.Writer (execWriterT, tell)
import Control.Concurrent
import Control.Concurrent.STM
import Control.Concurrent.Async
import Control.Exception as E
import Control.Applicative
import Control.Arrow
import Data.Monoid (First(..))
import GHC.Conc (labelThread)
import Prelude  -- Silence AMP and FTP import warnings

#if MIN_VERSION_base(4,18,0)
import Data.Traversable (mapAccumM)
#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
  Either SomeException (Time, Result)
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
        Result
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
        -- evalute it inside applyTimeout; see #280.
        () -> IO ()
forall a. a -> IO a
evaluate (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Result -> Outcome
resultOutcome Result
r Outcome -> () -> ()
forall a b. a -> b -> b
`seq`
          String -> ()
forall a. [a] -> ()
forceElements (Result -> String
resultDescription Result
r) () -> () -> ()
forall a b. a -> b -> b
`seq`
          String -> ()
forall a. [a] -> ()
forceElements (Result -> String
resultShortDescription Result
r)
        Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
r

  -- no matter what, try to run each finalizer
  Maybe SomeException
mbExn <- (forall a. IO a -> IO a) -> IO (Maybe SomeException)
destroyResources IO a -> IO a
forall a. IO a -> IO a
restore

  STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> (Result -> STM ()) -> Result -> 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 -> STM ()) -> (Result -> Status) -> Result -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> Status
Done (Result -> IO ()) -> Result -> IO ()
forall a b. (a -> b) -> a -> b
$
    case Either SomeException (Time, Result)
resultOrExn Either SomeException (Time, Result)
-> Either SomeException () -> Either SomeException (Time, Result)
forall a b.
Either SomeException a
-> Either SomeException b -> Either SomeException a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Either SomeException ()
-> (SomeException -> Either SomeException ())
-> Maybe SomeException
-> Either SomeException ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Either SomeException ()
forall a b. b -> Either a b
Right ()) SomeException -> Either SomeException ()
forall a b. a -> Either a b
Left Maybe SomeException
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
          Resource res
resStatus <- TVar (Resource res) -> STM (Resource res)
forall a. TVar a -> STM a
readTVar TVar (Resource res)
initVar
          case Resource res
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
res <- IO res
doInit
                  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
$ res -> Resource res
forall r. r -> Resource r
Created res
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. 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. 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
            Bool
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
              Int
nUsers <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
finishVar
              let nUsers' :: Int
nUsers' = Int
nUsers Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
              TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
finishVar Int
nUsers'
              Bool -> STM Bool
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> STM Bool) -> Bool -> STM Bool
forall a b. (a -> b) -> a -> b
$ Int
nUsers' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0

            Maybe SomeException
mbExcn <- IO (Maybe SomeException)
-> WriterT (First SomeException) IO (Maybe SomeException)
forall a. IO a -> WriterT (First SomeException) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe SomeException)
 -> WriterT (First SomeException) IO (Maybe SomeException))
-> IO (Maybe SomeException)
-> WriterT (First SomeException) IO (Maybe SomeException)
forall a b. (a -> b) -> a -> b
$
              if Bool
iAmLast
              then (forall a. IO a -> IO a) -> Finalizer -> IO (Maybe SomeException)
destroyResource IO a -> IO a
forall a. IO a -> IO a
restore Finalizer
fin
              else 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

            First SomeException -> WriterT (First SomeException) IO ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell (First SomeException -> WriterT (First SomeException) IO ())
-> First SomeException -> WriterT (First SomeException) IO ()
forall a b. (a -> b) -> a -> b
$ Maybe SomeException -> First SomeException
forall a. Maybe a -> First a
First Maybe SomeException
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
  deriving (Typeable)

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 '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 accummulator 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 '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 'TestAction') and the resources needed to run them (as 'Initializer's and
-- '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'.
  TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
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 ()))
foldSingle :: forall t.
IsTest t =>
OptionSet
-> String
-> t
-> 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 ()))
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 ()))
.. }) OptionSet
opts0 TestTree
tree

  let
    finalizers :: Seq Finalizer
    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 :: [TestAction (IO ())]
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 [TestAction (IO ())] -> Either [[Path]] [TestAction Action]
resolveDeps [TestAction (IO ())]
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. 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
      TVar Status
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
      (Path
parentPath, Seq Dependency
testDeps) <- ReaderT (Path, Seq Dependency) IO (Path, Seq Dependency)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
      let
        testPath :: Path
testPath = Path
parentPath Path -> String -> Path
forall a. Seq a -> a -> Seq a
|> String
name
        testAction :: Seq Initializer -> Seq Finalizer -> IO ()
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)
      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 ())
 -> ReaderT
      (Path, Seq Dependency)
      IO
      (TestActionTree (Seq Initializer -> Seq Finalizer -> 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
$ TestAction (Seq Initializer -> Seq Finalizer -> IO ())
-> TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
forall act. TestAction act -> TestActionTree act
TAction (TestAction {TVar Status
Path
Seq Dependency
Seq Initializer -> Seq Finalizer -> IO ()
testAction :: Seq Initializer -> Seq Finalizer -> IO ()
testPath :: Path
testDeps :: Seq Dependency
testStatus :: TVar Status
testStatus :: TVar Status
testDeps :: Seq Dependency
testPath :: Path
testAction :: Seq Initializer -> Seq Finalizer -> IO ()
..})

    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
      TVar (Resource a)
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
      TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
testTree <- IO a
-> ReaderT
     (Path, Seq Dependency)
     IO
     (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
a (TVar (Resource a) -> IO a
forall r. TVar (Resource r) -> IO r
getResource TVar (Resource a)
initVar)
      TVar Int
finishVar <- IO (TVar Int) -> ReaderT (Path, Seq Dependency) IO (TVar Int)
forall a. IO a -> ReaderT (Path, Seq Dependency) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TVar Int) -> ReaderT (Path, Seq Dependency) IO (TVar Int))
-> IO (TVar Int) -> ReaderT (Path, Seq Dependency) IO (TVar Int)
forall a b. (a -> b) -> a -> b
$ Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
newTVarIO (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()) -> Int
forall act. TestActionTree act -> Int
testActionTreeSize TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
testTree)
      let
        ini :: Initializer
ini = IO a -> TVar (Resource a) -> Initializer
forall res. IO res -> TVar (Resource res) -> Initializer
Initializer IO a
doInit TVar (Resource a)
initVar
        fin :: Finalizer
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
      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 ())
 -> ReaderT
      (Path, Seq Dependency)
      IO
      (TestActionTree (Seq Initializer -> Seq Finalizer -> 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
$ Initializer
-> Finalizer
-> TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
-> TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
forall act.
Initializer
-> Finalizer -> TestActionTree act -> TestActionTree act
TResource Initializer
ini Finalizer
fin TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
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
          ExecutionMode
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
          Sequential DependencyType
depType ->
            (Seq Dependency,
 [TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())])
-> [TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())]
forall a b. (a, b) -> b
snd ((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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (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 [ReaderT
   (Path, Seq Dependency)
   IO
   (TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))]
trees

    -- * 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
      TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
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 -> Dependency
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 :: Seq Dependency
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 :: Seq Dependency
deps1 = if Seq Dependency -> Bool
forall a. Seq a -> Bool
Seq.null Seq Dependency
deps0 then Seq Dependency
prevDeps else Seq Dependency
deps0

      (Seq Dependency,
 TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
-> ReaderT
     (Path, Seq Dependency)
     IO
     (Seq Dependency,
      TestActionTree (Seq Initializer -> Seq Finalizer -> IO ()))
forall a. a -> ReaderT (Path, Seq Dependency) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Seq Dependency
deps1, TestActionTree (Seq Initializer -> Seq Finalizer -> IO ())
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 :: forall act. TestAction act -> act
testAction=IO ()
run_test, TVar Status
Path
Seq Dependency
testPath :: forall act. TestAction act -> Path
testDeps :: forall act. TestAction act -> Seq Dependency
testStatus :: forall act. TestAction act -> TVar Status
testPath :: Path
testDeps :: Seq Dependency
testStatus :: TVar Status
.. } <- [TestAction (IO ())]
tests

  let
    deps' :: [(DependencyType, TVar Status, Path)]
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 :: 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
status <- TVar Status -> STM Status
forall a. TVar a -> STM a
readTVar TVar Status
statusvar
        case Status
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 :: [Path]
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
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
          }
      }
  (TestAction Action, (Path, [Path]))
-> [(TestAction Action, (Path, [Path]))]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (TestAction { testAction :: Action
testAction = Action
action, TVar Status
Path
Seq Dependency
testPath :: Path
testDeps :: Seq Dependency
testStatus :: TVar Status
testPath :: Path
testDeps :: Seq Dependency
testStatus :: TVar Status
.. }, (Path
testPath, [Path]
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{Path
testPath :: forall act. TestAction act -> Path
testPath :: Path
testPath, TVar Status
testStatus :: forall act. TestAction act -> TVar Status
testStatus :: TVar Status
testStatus} <- [TestAction (IO ())]
tests
        Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ Expr -> Path -> Bool
exprMatches Expr
expr Path
testPath
        [(DependencyType
depType, TVar Status
testStatus, Path
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
    Resource r
rState <- TVar (Resource r) -> STM (Resource r)
forall a. TVar a -> STM a
readTVar TVar (Resource r)
var
    case Resource r
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
  Resource res
rState <- TVar (Resource res) -> STM (Resource res)
forall a. TVar a -> STM a
readTVar TVar (Resource res)
stateVar
  case Resource res
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 '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 'OptionSet'
-- from command line. This way a user can wrap their tests in
-- 'adjustOption' / 'localOption' forcing, for instance, '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 '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'
  ([TestAction Action]
testActions, Seq Finalizer
fins) <- OptionSet -> TestTree -> IO ([TestAction Action], Seq Finalizer)
createTestActions OptionSet
opts TestTree
tree
  let NumThreads Int
numThreads = OptionSet -> NumThreads
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
  (Time
t,Time -> IO a
k1) <- IO (Time -> IO a) -> IO (Time, Time -> IO a)
forall a. IO a -> IO (Time, a)
timed (IO (Time -> IO a) -> IO (Time, Time -> IO a))
-> IO (Time -> IO a) -> IO (Time, Time -> IO a)
forall a b. (a -> b) -> a -> b
$ do
     IO ()
abortTests <- Int -> [Action] -> IO (IO ())
runInParallel Int
numThreads (TestAction Action -> Action
forall act. TestAction act -> act
testAction (TestAction Action -> Action) -> [TestAction Action] -> [Action]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TestAction Action]
testActions)
     (do let smap :: StatusMap
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)
         StatusMap -> IO (Time -> IO a)
k0 StatusMap
smap)
      IO (Time -> IO a)
-> ((forall a. IO a -> IO a) -> IO ()) -> IO (Time -> IO a)
forall a b. IO a -> ((forall a. IO a -> IO a) -> IO b) -> IO a
`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
  Time -> IO a
k1 Time
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
        Resource res
res <- TVar (Resource res) -> STM (Resource res)
forall a. TVar a -> STM a
readTVar TVar (Resource res)
rvar
        Bool -> STM ()
check (Bool -> STM ()) -> Bool -> STM ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Resource res -> Bool
forall r. Resource r -> Bool
alive Resource res
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
    a
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
    b
_ <- (forall a. IO a -> IO a) -> IO b
sequel IO c -> IO c
forall a. IO a -> IO a
restore
    a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r