{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

-- | This module defines how to run a test suite
module Test.Syd.Runner.Asynchronous
  ( runSpecForestAsynchronously,
    runSpecForestInterleavedWithOutputAsynchronously,
  )
where

import Control.Concurrent
import Control.Concurrent.Async as Async
import Control.Exception
#if MIN_VERSION_mtl(2,3,0)
import Control.Monad (when)
#endif
import Control.Monad.Reader
import Data.Maybe
import Data.Set (Set)
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Test.QuickCheck.IO ()
import Test.Syd.HList
import Test.Syd.OptParse
import Test.Syd.Output
import Test.Syd.Run
import Test.Syd.Runner.Single
import Test.Syd.SpecDef
import Test.Syd.SpecForest
import Text.Colour

runSpecForestAsynchronously :: Settings -> Word -> TestForest '[] () -> IO ResultForest
runSpecForestAsynchronously :: Settings -> Word -> TestForest '[] () -> IO ResultForest
runSpecForestAsynchronously Settings
settings Word
nbThreads TestForest '[] ()
testForest = do
  HandleForest '[] ()
handleForest <- forall (a :: [*]) b. TestForest a b -> IO (HandleForest a b)
makeHandleForest TestForest '[] ()
testForest
  MVar ()
failFastVar <- forall a. IO (MVar a)
newEmptyMVar
  let runRunner :: IO ()
runRunner = Settings -> Word -> MVar () -> HandleForest '[] () -> IO ()
runner Settings
settings Word
nbThreads MVar ()
failFastVar HandleForest '[] ()
handleForest
      runPrinter :: IO ResultForest
runPrinter = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ MVar () -> HandleForest '[] () -> IO ResultForest
waiter MVar ()
failFastVar HandleForest '[] ()
handleForest
  ((), ResultForest
resultForest) <- forall a b. IO a -> IO b -> IO (a, b)
concurrently IO ()
runRunner IO ResultForest
runPrinter
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ResultForest
resultForest

runSpecForestInterleavedWithOutputAsynchronously :: Settings -> Word -> TestForest '[] () -> IO (Timed ResultForest)
runSpecForestInterleavedWithOutputAsynchronously :: Settings -> Word -> TestForest '[] () -> IO (Timed ResultForest)
runSpecForestInterleavedWithOutputAsynchronously Settings
settings Word
nbThreads TestForest '[] ()
testForest = do
  HandleForest '[] ()
handleForest <- forall (a :: [*]) b. TestForest a b -> IO (HandleForest a b)
makeHandleForest TestForest '[] ()
testForest
  MVar ()
failFastVar <- forall a. IO (MVar a)
newEmptyMVar
  let runRunner :: IO ()
runRunner = Settings -> Word -> MVar () -> HandleForest '[] () -> IO ()
runner Settings
settings Word
nbThreads MVar ()
failFastVar HandleForest '[] ()
handleForest
      runPrinter :: IO (Timed ResultForest)
runPrinter = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Settings
-> MVar () -> HandleForest '[] () -> IO (Timed ResultForest)
printer Settings
settings MVar ()
failFastVar HandleForest '[] ()
handleForest
  ((), Timed ResultForest
resultForest) <- forall a b. IO a -> IO b -> IO (a, b)
concurrently IO ()
runRunner IO (Timed ResultForest)
runPrinter
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Timed ResultForest
resultForest

type HandleForest a b = SpecDefForest a b (MVar (Timed TestRunReport))

type HandleTree a b = SpecDefTree a b (MVar (Timed TestRunReport))

makeHandleForest :: TestForest a b -> IO (HandleForest a b)
makeHandleForest :: forall (a :: [*]) b. TestForest a b -> IO (HandleForest a b)
makeHandleForest = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. (a -> b) -> a -> b
$ \() -> forall a. IO (MVar a)
newEmptyMVar

runner :: Settings -> Word -> MVar () -> HandleForest '[] () -> IO ()
runner :: Settings -> Word -> MVar () -> HandleForest '[] () -> IO ()
runner Settings
settings Word
nbThreads MVar ()
failFastVar HandleForest '[] ()
handleForest = do
  QSemN
sem <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO QSemN
newQSemN forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
nbThreads
  MVar (Set (Async ()))
jobsVar <- forall a. a -> IO (MVar a)
newMVar (forall a. Set a
S.empty :: Set (Async ()))
  -- This is used to make sure that the 'after' part of the resources actually happens after the tests are done, not just when they are started.
  let waitForCurrentlyRunning :: IO ()
      waitForCurrentlyRunning :: IO ()
waitForCurrentlyRunning = do
        forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Set (Async ()))
jobsVar forall a b. (a -> b) -> a -> b
$ \Set (Async ())
jobThreads -> do
          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a. Async a -> IO a
Async.wait Set (Async ())
jobThreads
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Set a
S.empty

  let goForest :: forall a. HandleForest a () -> R a ()
      goForest :: forall (a :: [*]). HandleForest a () -> R a ()
goForest = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (a :: [*]). HandleTree a () -> R a ()
goTree

      goTree :: forall a. HandleTree a () -> R a ()
      goTree :: forall (a :: [*]). HandleTree a () -> R a ()
goTree = \case
        DefSpecifyNode Text
_ TDef
  (ProgressReporter
   -> ((HList a -> () -> IO ()) -> IO ()) -> IO TestRunResult)
td MVar (Timed TestRunReport)
var -> do
          -- If the fail-fast var has been put, This will return 'Just ()', in
          -- which case we must stop.
          Maybe ()
mDoneEarly <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO (Maybe a)
tryReadMVar MVar ()
failFastVar
          case Maybe ()
mDoneEarly of
            Just () -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Maybe ()
Nothing -> do
              Env {Word
HList a
ExpectationMode
FlakinessMode
Parallelism
eExternalResources :: forall (externalResources :: [*]).
Env externalResources -> HList externalResources
eExpectationMode :: forall (externalResources :: [*]).
Env externalResources -> ExpectationMode
eFlakinessMode :: forall (externalResources :: [*]).
Env externalResources -> FlakinessMode
eRetries :: forall (externalResources :: [*]). Env externalResources -> Word
eParallelism :: forall (externalResources :: [*]).
Env externalResources -> Parallelism
eExternalResources :: HList a
eExpectationMode :: ExpectationMode
eFlakinessMode :: FlakinessMode
eRetries :: Word
eParallelism :: Parallelism
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask

              forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
                -- Wait before spawning a thread so that we don't spawn too many threads
                let quantity :: Word
quantity = case Parallelism
eParallelism of
                      -- When the test wants to be executed sequentially, we take n locks because we must make sure that
                      -- 1. no more other tests are still running.
                      -- 2. no other tests are started during execution.
                      Parallelism
Sequential -> Word
nbThreads
                      Parallelism
Parallel -> Word
1
                QSemN -> Int -> IO ()
waitQSemN QSemN
sem forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
quantity

                let runNow :: IO (Timed TestRunReport)
runNow =
                      forall (m :: * -> *) a. MonadIO m => m a -> m (Timed a)
timeItT forall a b. (a -> b) -> a -> b
$
                        forall (externalResources :: [*]) t.
ProgressReporter
-> HList externalResources
-> TDef
     (ProgressReporter
      -> ((HList externalResources -> () -> t) -> t) -> IO TestRunResult)
-> Word
-> FlakinessMode
-> ExpectationMode
-> IO TestRunReport
runSingleTestWithFlakinessMode
                          ProgressReporter
noProgressReporter
                          HList a
eExternalResources
                          TDef
  (ProgressReporter
   -> ((HList a -> () -> IO ()) -> IO ()) -> IO TestRunResult)
td
                          Word
eRetries
                          FlakinessMode
eFlakinessMode
                          ExpectationMode
eExpectationMode
                let job :: IO ()
                    job :: IO ()
job = do
                      -- Start the test
                      Timed TestRunReport
result <- IO (Timed TestRunReport)
runNow

                      -- Put the result in the mvar
                      forall a. MVar a -> a -> IO ()
putMVar MVar (Timed TestRunReport)
var Timed TestRunReport
result

                      -- If we should fail fast, put the fail-fast var and cancel all other jobs.
                      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Settings -> Bool
settingFailFast Settings
settings Bool -> Bool -> Bool
&& Settings -> TestRunReport -> Bool
testRunReportFailed Settings
settings (forall a. Timed a -> a
timedValue Timed TestRunReport
result)) forall a b. (a -> b) -> a -> b
$ do
                        forall a. MVar a -> a -> IO ()
putMVar MVar ()
failFastVar ()
                        forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar (Set (Async ()))
jobsVar forall a b. (a -> b) -> a -> b
$ \Set (Async ())
jobThreads ->
                          forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a. Async a -> IO ()
cancel Set (Async ())
jobThreads
                      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ QSemN -> Int -> IO ()
signalQSemN QSemN
sem forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
quantity

                forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Set (Async ()))
jobsVar forall a b. (a -> b) -> a -> b
$ \Set (Async ())
jobThreads -> do
                  Async ()
jobThread <- forall a. IO a -> IO (Async a)
async IO ()
job
                  forall a. Async a -> IO ()
link Async ()
jobThread
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Ord a => a -> Set a -> Set a
S.insert Async ()
jobThread Set (Async ())
jobThreads)
        DefPendingNode Text
_ Maybe Text
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        DefDescribeNode Text
_ SpecDefForest a () (MVar (Timed TestRunReport))
sdf -> forall (a :: [*]). HandleForest a () -> R a ()
goForest SpecDefForest a () (MVar (Timed TestRunReport))
sdf
        DefWrapNode IO () -> IO ()
func SpecDefForest a () (MVar (Timed TestRunReport))
sdf -> do
          Env a
e <- forall r (m :: * -> *). MonadReader r m => m r
ask
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
            IO () -> IO ()
func forall a b. (a -> b) -> a -> b
$ do
              forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall (a :: [*]). HandleForest a () -> R a ()
goForest SpecDefForest a () (MVar (Timed TestRunReport))
sdf) Env a
e
              IO ()
waitForCurrentlyRunning
        DefBeforeAllNode IO outer
func SpecDefForest (outer : a) () (MVar (Timed TestRunReport))
sdf -> do
          outer
b <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO outer
func
          forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT
            (\Env a
e -> Env a
e {eExternalResources :: HList (outer : a)
eExternalResources = forall e (l :: [*]). e -> HList l -> HList (e : l)
HCons outer
b (forall (externalResources :: [*]).
Env externalResources -> HList externalResources
eExternalResources Env a
e)})
            (forall (a :: [*]). HandleForest a () -> R a ()
goForest SpecDefForest (outer : a) () (MVar (Timed TestRunReport))
sdf)
        DefAroundAllNode (outer -> IO ()) -> IO ()
func SpecDefForest (outer : a) () (MVar (Timed TestRunReport))
sdf -> do
          Env a
e <- forall r (m :: * -> *). MonadReader r m => m r
ask
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
            (outer -> IO ()) -> IO ()
func
              ( \outer
b -> do
                  forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT
                    (forall (a :: [*]). HandleForest a () -> R a ()
goForest SpecDefForest (outer : a) () (MVar (Timed TestRunReport))
sdf)
                    (Env a
e {eExternalResources :: HList (outer : a)
eExternalResources = forall e (l :: [*]). e -> HList l -> HList (e : l)
HCons outer
b (forall (externalResources :: [*]).
Env externalResources -> HList externalResources
eExternalResources Env a
e)})
                  IO ()
waitForCurrentlyRunning
              )
        DefAroundAllWithNode (newOuter -> IO ()) -> oldOuter -> IO ()
func SpecDefForest
  (newOuter : oldOuter : otherOuters) () (MVar (Timed TestRunReport))
sdf -> do
          Env (oldOuter : otherOuters)
e <- forall r (m :: * -> *). MonadReader r m => m r
ask
          let HCons oldOuter
e
x HList l
_ = forall (externalResources :: [*]).
Env externalResources -> HList externalResources
eExternalResources Env (oldOuter : otherOuters)
e
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
            (newOuter -> IO ()) -> oldOuter -> IO ()
func
              ( \newOuter
b -> do
                  forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT
                    (forall (a :: [*]). HandleForest a () -> R a ()
goForest SpecDefForest
  (newOuter : oldOuter : otherOuters) () (MVar (Timed TestRunReport))
sdf)
                    (Env (oldOuter : otherOuters)
e {eExternalResources :: HList (newOuter : oldOuter : otherOuters)
eExternalResources = forall e (l :: [*]). e -> HList l -> HList (e : l)
HCons newOuter
b (forall (externalResources :: [*]).
Env externalResources -> HList externalResources
eExternalResources Env (oldOuter : otherOuters)
e)})
                  IO ()
waitForCurrentlyRunning
              )
              oldOuter
x
        DefAfterAllNode HList a -> IO ()
func SpecDefForest a () (MVar (Timed TestRunReport))
sdf -> do
          Env a
e <- forall r (m :: * -> *). MonadReader r m => m r
ask
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
            forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall (a :: [*]). HandleForest a () -> R a ()
goForest SpecDefForest a () (MVar (Timed TestRunReport))
sdf) Env a
e
              forall a b. IO a -> IO b -> IO a
`finally` ( do
                            IO ()
waitForCurrentlyRunning
                            HList a -> IO ()
func (forall (externalResources :: [*]).
Env externalResources -> HList externalResources
eExternalResources Env a
e)
                        )
        DefParallelismNode Parallelism
p' SpecDefForest a () (MVar (Timed TestRunReport))
sdf ->
          forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT
            (\Env a
e -> Env a
e {eParallelism :: Parallelism
eParallelism = Parallelism
p'})
            (forall (a :: [*]). HandleForest a () -> R a ()
goForest SpecDefForest a () (MVar (Timed TestRunReport))
sdf)
        DefRandomisationNode ExecutionOrderRandomisation
_ SpecDefForest a () (MVar (Timed TestRunReport))
sdf -> forall (a :: [*]). HandleForest a () -> R a ()
goForest SpecDefForest a () (MVar (Timed TestRunReport))
sdf -- Ignore, randomisation has already happened.
        DefRetriesNode Word -> Word
modRetries SpecDefForest a () (MVar (Timed TestRunReport))
sdf ->
          forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT
            (\Env a
e -> Env a
e {eRetries :: Word
eRetries = Word -> Word
modRetries (forall (externalResources :: [*]). Env externalResources -> Word
eRetries Env a
e)})
            (forall (a :: [*]). HandleForest a () -> R a ()
goForest SpecDefForest a () (MVar (Timed TestRunReport))
sdf)
        DefFlakinessNode FlakinessMode
fm SpecDefForest a () (MVar (Timed TestRunReport))
sdf ->
          forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT
            (\Env a
e -> Env a
e {eFlakinessMode :: FlakinessMode
eFlakinessMode = FlakinessMode
fm})
            (forall (a :: [*]). HandleForest a () -> R a ()
goForest SpecDefForest a () (MVar (Timed TestRunReport))
sdf)
        DefExpectationNode ExpectationMode
em SpecDefForest a () (MVar (Timed TestRunReport))
sdf ->
          forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT
            (\Env a
e -> Env a
e {eExpectationMode :: ExpectationMode
eExpectationMode = ExpectationMode
em})
            (forall (a :: [*]). HandleForest a () -> R a ()
goForest SpecDefForest a () (MVar (Timed TestRunReport))
sdf)

  forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT
    (forall (a :: [*]). HandleForest a () -> R a ()
goForest HandleForest '[] ()
handleForest)
    Env
      { eParallelism :: Parallelism
eParallelism = Parallelism
Parallel,
        eRetries :: Word
eRetries = Settings -> Word
settingRetries Settings
settings,
        eFlakinessMode :: FlakinessMode
eFlakinessMode = FlakinessMode
MayNotBeFlaky,
        eExpectationMode :: ExpectationMode
eExpectationMode = ExpectationMode
ExpectPassing,
        eExternalResources :: HList '[]
eExternalResources = HList '[]
HNil
      }

type R a = ReaderT (Env a) IO

-- Not exported, on purpose.
data Env externalResources = Env
  { forall (externalResources :: [*]).
Env externalResources -> Parallelism
eParallelism :: !Parallelism,
    forall (externalResources :: [*]). Env externalResources -> Word
eRetries :: !Word,
    forall (externalResources :: [*]).
Env externalResources -> FlakinessMode
eFlakinessMode :: !FlakinessMode,
    forall (externalResources :: [*]).
Env externalResources -> ExpectationMode
eExpectationMode :: !ExpectationMode,
    forall (externalResources :: [*]).
Env externalResources -> HList externalResources
eExternalResources :: !(HList externalResources)
  }

printer :: Settings -> MVar () -> HandleForest '[] () -> IO (Timed ResultForest)
printer :: Settings
-> MVar () -> HandleForest '[] () -> IO (Timed ResultForest)
printer Settings
settings MVar ()
failFastVar HandleForest '[] ()
handleForest = do
  TerminalCapabilities
tc <- Settings -> IO TerminalCapabilities
deriveTerminalCapababilities Settings
settings

  let outputLine :: [Chunk] -> IO ()
      outputLine :: [Chunk] -> IO ()
outputLine [Chunk]
lineChunks = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        TerminalCapabilities -> [Chunk] -> IO ()
putChunksLocaleWith TerminalCapabilities
tc [Chunk]
lineChunks
        Text -> IO ()
TIO.putStrLn Text
""

      treeWidth :: Int
      treeWidth :: Int
treeWidth = forall (a :: [*]) b c. SpecDefForest a b c -> Int
specForestWidth HandleForest '[] ()
handleForest

  let pad :: Int -> [Chunk] -> [Chunk]
      pad :: Int -> [Chunk] -> [Chunk]
pad Int
level = (Text -> Chunk
chunk (String -> Text
T.pack (forall a. Int -> a -> [a]
replicate (Int
paddingSize forall a. Num a => a -> a -> a
* Int
level) Char
' ')) forall a. a -> [a] -> [a]
:)

  let outputLineP :: [Chunk] -> P ()
      outputLineP :: [Chunk] -> P ()
outputLineP [Chunk]
line = do
        Int
level <- forall r (m :: * -> *). MonadReader r m => m r
ask
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Chunk] -> IO ()
outputLine forall a b. (a -> b) -> a -> b
$ Int -> [Chunk] -> [Chunk]
pad Int
level [Chunk]
line

      outputLinesP :: [[Chunk]] -> P ()
      outputLinesP :: [[Chunk]] -> P ()
outputLinesP = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Chunk] -> P ()
outputLineP

  let goForest :: HandleForest a b -> P (Maybe ResultForest)
      goForest :: forall (a :: [*]) b. HandleForest a b -> P (Maybe ResultForest)
goForest HandleForest a b
hts = do
        ResultForest
rts <- forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (a :: [*]) b. HandleTree a b -> P (Maybe ResultTree)
goTree HandleForest a b
hts
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null ResultForest
rts then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just ResultForest
rts

      goTree :: HandleTree a b -> P (Maybe ResultTree)
      goTree :: forall (a :: [*]) b. HandleTree a b -> P (Maybe ResultTree)
goTree = \case
        DefSpecifyNode Text
t TDef
  (ProgressReporter
   -> ((HList a -> b -> IO ()) -> IO ()) -> IO TestRunResult)
td MVar (Timed TestRunReport)
var -> do
          Either () (Timed TestRunReport)
failFastOrResult <-
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
              forall a b. IO a -> IO b -> IO (Either a b)
race
                (forall a. MVar a -> IO a
readMVar MVar ()
failFastVar)
                (forall a. MVar a -> IO a
takeMVar MVar (Timed TestRunReport)
var)
          case Either () (Timed TestRunReport)
failFastOrResult of
            Left () -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            Right Timed TestRunReport
result -> do
              let td' :: TDef (Timed TestRunReport)
td' = TDef
  (ProgressReporter
   -> ((HList a -> b -> IO ()) -> IO ()) -> IO TestRunResult)
td {testDefVal :: Timed TestRunReport
testDefVal = Timed TestRunReport
result}
              Int
level <- forall r (m :: * -> *). MonadReader r m => m r
ask
              [[Chunk]] -> P ()
outputLinesP forall a b. (a -> b) -> a -> b
$ Settings
-> Int -> Int -> Text -> TDef (Timed TestRunReport) -> [[Chunk]]
outputSpecifyLines Settings
settings Int
level Int
treeWidth Text
t TDef (Timed TestRunReport)
td'
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Text -> a -> SpecTree a
SpecifyNode Text
t TDef (Timed TestRunReport)
td'
        DefPendingNode Text
t Maybe Text
mr -> do
          [[Chunk]] -> P ()
outputLinesP forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> [[Chunk]]
outputPendingLines Text
t Maybe Text
mr
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Text -> Maybe Text -> SpecTree a
PendingNode Text
t Maybe Text
mr
        DefDescribeNode Text
t SpecDefForest a b (MVar (Timed TestRunReport))
sf -> do
          Maybe ()
mDoneEarly <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO (Maybe a)
tryReadMVar MVar ()
failFastVar
          case Maybe ()
mDoneEarly of
            Just () -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            Maybe ()
Nothing -> do
              [Chunk] -> P ()
outputLineP forall a b. (a -> b) -> a -> b
$ Text -> [Chunk]
outputDescribeLine Text
t
              forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Text -> SpecForest a -> SpecTree a
DescribeNode Text
t) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. P a -> P a
addLevel (forall (a :: [*]) b. HandleForest a b -> P (Maybe ResultForest)
goForest SpecDefForest a b (MVar (Timed TestRunReport))
sf)
        DefWrapNode IO () -> IO ()
_ SpecDefForest a b (MVar (Timed TestRunReport))
sdf -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. SpecForest a -> SpecTree a
SubForestNode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: [*]) b. HandleForest a b -> P (Maybe ResultForest)
goForest SpecDefForest a b (MVar (Timed TestRunReport))
sdf
        DefBeforeAllNode IO outer
_ SpecDefForest (outer : a) b (MVar (Timed TestRunReport))
sdf -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. SpecForest a -> SpecTree a
SubForestNode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: [*]) b. HandleForest a b -> P (Maybe ResultForest)
goForest SpecDefForest (outer : a) b (MVar (Timed TestRunReport))
sdf
        DefAroundAllNode (outer -> IO ()) -> IO ()
_ SpecDefForest (outer : a) b (MVar (Timed TestRunReport))
sdf -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. SpecForest a -> SpecTree a
SubForestNode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: [*]) b. HandleForest a b -> P (Maybe ResultForest)
goForest SpecDefForest (outer : a) b (MVar (Timed TestRunReport))
sdf
        DefAroundAllWithNode (newOuter -> IO ()) -> oldOuter -> IO ()
_ SpecDefForest
  (newOuter : oldOuter : otherOuters) b (MVar (Timed TestRunReport))
sdf -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. SpecForest a -> SpecTree a
SubForestNode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: [*]) b. HandleForest a b -> P (Maybe ResultForest)
goForest SpecDefForest
  (newOuter : oldOuter : otherOuters) b (MVar (Timed TestRunReport))
sdf
        DefAfterAllNode HList a -> IO ()
_ SpecDefForest a b (MVar (Timed TestRunReport))
sdf -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. SpecForest a -> SpecTree a
SubForestNode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: [*]) b. HandleForest a b -> P (Maybe ResultForest)
goForest SpecDefForest a b (MVar (Timed TestRunReport))
sdf
        DefParallelismNode Parallelism
_ SpecDefForest a b (MVar (Timed TestRunReport))
sdf -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. SpecForest a -> SpecTree a
SubForestNode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: [*]) b. HandleForest a b -> P (Maybe ResultForest)
goForest SpecDefForest a b (MVar (Timed TestRunReport))
sdf
        DefRandomisationNode ExecutionOrderRandomisation
_ SpecDefForest a b (MVar (Timed TestRunReport))
sdf -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. SpecForest a -> SpecTree a
SubForestNode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: [*]) b. HandleForest a b -> P (Maybe ResultForest)
goForest SpecDefForest a b (MVar (Timed TestRunReport))
sdf
        DefRetriesNode Word -> Word
_ SpecDefForest a b (MVar (Timed TestRunReport))
sdf -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. SpecForest a -> SpecTree a
SubForestNode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: [*]) b. HandleForest a b -> P (Maybe ResultForest)
goForest SpecDefForest a b (MVar (Timed TestRunReport))
sdf
        DefFlakinessNode FlakinessMode
_ SpecDefForest a b (MVar (Timed TestRunReport))
sdf -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. SpecForest a -> SpecTree a
SubForestNode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: [*]) b. HandleForest a b -> P (Maybe ResultForest)
goForest SpecDefForest a b (MVar (Timed TestRunReport))
sdf
        DefExpectationNode ExpectationMode
_ SpecDefForest a b (MVar (Timed TestRunReport))
sdf -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. SpecForest a -> SpecTree a
SubForestNode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: [*]) b. HandleForest a b -> P (Maybe ResultForest)
goForest SpecDefForest a b (MVar (Timed TestRunReport))
sdf
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Chunk] -> IO ()
outputLine [[Chunk]]
outputTestsHeader
  Timed ResultForest
resultForest <- forall (m :: * -> *) a. MonadIO m => m a -> m (Timed a)
timeItT forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe [] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall (a :: [*]) b. HandleForest a b -> P (Maybe ResultForest)
goForest HandleForest '[] ()
handleForest) Int
0
  [Chunk] -> IO ()
outputLine [Text -> Chunk
chunk Text
" "]
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Chunk] -> IO ()
outputLine forall a b. (a -> b) -> a -> b
$ Settings -> ResultForest -> [[Chunk]]
outputFailuresWithHeading Settings
settings (forall a. Timed a -> a
timedValue Timed ResultForest
resultForest)
  [Chunk] -> IO ()
outputLine [Text -> Chunk
chunk Text
" "]
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [Chunk] -> IO ()
outputLine forall a b. (a -> b) -> a -> b
$ Timed TestSuiteStats -> [[Chunk]]
outputStats (Settings -> ResultForest -> TestSuiteStats
computeTestSuiteStats Settings
settings forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Timed ResultForest
resultForest)
  [Chunk] -> IO ()
outputLine [Text -> Chunk
chunk Text
" "]
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Timed ResultForest
resultForest

addLevel :: P a -> P a
addLevel :: forall a. P a -> P a
addLevel = forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT forall a. Enum a => a -> a
succ

type P = ReaderT Int IO

waiter :: MVar () -> HandleForest '[] () -> IO ResultForest
waiter :: MVar () -> HandleForest '[] () -> IO ResultForest
waiter MVar ()
failFastVar HandleForest '[] ()
handleForest = do
  let goForest :: HandleForest a b -> IO (Maybe ResultForest)
      goForest :: forall (a :: [*]) b. HandleForest a b -> IO (Maybe ResultForest)
goForest HandleForest a b
hts = do
        ResultForest
rts <- forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (a :: [*]) b. HandleTree a b -> IO (Maybe ResultTree)
goTree HandleForest a b
hts
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null ResultForest
rts then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just ResultForest
rts

      goTree :: HandleTree a b -> IO (Maybe ResultTree)
      goTree :: forall (a :: [*]) b. HandleTree a b -> IO (Maybe ResultTree)
goTree = \case
        DefSpecifyNode Text
t TDef
  (ProgressReporter
   -> ((HList a -> b -> IO ()) -> IO ()) -> IO TestRunResult)
td MVar (Timed TestRunReport)
var -> do
          Either () (Timed TestRunReport)
failFastOrResult <-
            forall a b. IO a -> IO b -> IO (Either a b)
race
              (forall a. MVar a -> IO a
readMVar MVar ()
failFastVar)
              (forall a. MVar a -> IO a
takeMVar MVar (Timed TestRunReport)
var)
          case Either () (Timed TestRunReport)
failFastOrResult of
            Left () -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            Right Timed TestRunReport
result -> do
              let td' :: TDef (Timed TestRunReport)
td' = TDef
  (ProgressReporter
   -> ((HList a -> b -> IO ()) -> IO ()) -> IO TestRunResult)
td {testDefVal :: Timed TestRunReport
testDefVal = Timed TestRunReport
result}
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Text -> a -> SpecTree a
SpecifyNode Text
t TDef (Timed TestRunReport)
td'
        DefPendingNode Text
t Maybe Text
mr -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Text -> Maybe Text -> SpecTree a
PendingNode Text
t Maybe Text
mr
        DefDescribeNode Text
t SpecDefForest a b (MVar (Timed TestRunReport))
sf -> do
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Text -> SpecForest a -> SpecTree a
DescribeNode Text
t) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: [*]) b. HandleForest a b -> IO (Maybe ResultForest)
goForest SpecDefForest a b (MVar (Timed TestRunReport))
sf
        DefWrapNode IO () -> IO ()
_ SpecDefForest a b (MVar (Timed TestRunReport))
sdf -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. SpecForest a -> SpecTree a
SubForestNode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: [*]) b. HandleForest a b -> IO (Maybe ResultForest)
goForest SpecDefForest a b (MVar (Timed TestRunReport))
sdf
        DefBeforeAllNode IO outer
_ SpecDefForest (outer : a) b (MVar (Timed TestRunReport))
sdf -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. SpecForest a -> SpecTree a
SubForestNode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: [*]) b. HandleForest a b -> IO (Maybe ResultForest)
goForest SpecDefForest (outer : a) b (MVar (Timed TestRunReport))
sdf
        DefAroundAllNode (outer -> IO ()) -> IO ()
_ SpecDefForest (outer : a) b (MVar (Timed TestRunReport))
sdf -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. SpecForest a -> SpecTree a
SubForestNode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: [*]) b. HandleForest a b -> IO (Maybe ResultForest)
goForest SpecDefForest (outer : a) b (MVar (Timed TestRunReport))
sdf
        DefAroundAllWithNode (newOuter -> IO ()) -> oldOuter -> IO ()
_ SpecDefForest
  (newOuter : oldOuter : otherOuters) b (MVar (Timed TestRunReport))
sdf -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. SpecForest a -> SpecTree a
SubForestNode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: [*]) b. HandleForest a b -> IO (Maybe ResultForest)
goForest SpecDefForest
  (newOuter : oldOuter : otherOuters) b (MVar (Timed TestRunReport))
sdf
        DefAfterAllNode HList a -> IO ()
_ SpecDefForest a b (MVar (Timed TestRunReport))
sdf -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. SpecForest a -> SpecTree a
SubForestNode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: [*]) b. HandleForest a b -> IO (Maybe ResultForest)
goForest SpecDefForest a b (MVar (Timed TestRunReport))
sdf
        DefParallelismNode Parallelism
_ SpecDefForest a b (MVar (Timed TestRunReport))
sdf -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. SpecForest a -> SpecTree a
SubForestNode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: [*]) b. HandleForest a b -> IO (Maybe ResultForest)
goForest SpecDefForest a b (MVar (Timed TestRunReport))
sdf
        DefRandomisationNode ExecutionOrderRandomisation
_ SpecDefForest a b (MVar (Timed TestRunReport))
sdf -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. SpecForest a -> SpecTree a
SubForestNode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: [*]) b. HandleForest a b -> IO (Maybe ResultForest)
goForest SpecDefForest a b (MVar (Timed TestRunReport))
sdf
        DefRetriesNode Word -> Word
_ SpecDefForest a b (MVar (Timed TestRunReport))
sdf -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. SpecForest a -> SpecTree a
SubForestNode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: [*]) b. HandleForest a b -> IO (Maybe ResultForest)
goForest SpecDefForest a b (MVar (Timed TestRunReport))
sdf
        DefFlakinessNode FlakinessMode
_ SpecDefForest a b (MVar (Timed TestRunReport))
sdf -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. SpecForest a -> SpecTree a
SubForestNode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: [*]) b. HandleForest a b -> IO (Maybe ResultForest)
goForest SpecDefForest a b (MVar (Timed TestRunReport))
sdf
        DefExpectationNode ExpectationMode
_ SpecDefForest a b (MVar (Timed TestRunReport))
sdf -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. SpecForest a -> SpecTree a
SubForestNode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: [*]) b. HandleForest a b -> IO (Maybe ResultForest)
goForest SpecDefForest a b (MVar (Timed TestRunReport))
sdf
  forall a. a -> Maybe a -> a
fromMaybe [] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: [*]) b. HandleForest a b -> IO (Maybe ResultForest)
goForest HandleForest '[] ()
handleForest