{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}

module Hedgehog.Internal.Runner (
  -- * Running Individual Properties
    check
  , recheck
  , recheckAt

  -- * Running Groups of Properties
  , RunnerConfig(..)
  , checkParallel
  , checkSequential
  , checkGroup

  -- * Internal
  , checkReport
  , checkRegion
  , checkNamed
  ) where

import           Control.Concurrent.STM (TVar, atomically)
import qualified Control.Concurrent.STM.TVar as TVar
import           Control.Exception.Safe (MonadCatch, catchAny)
import           Control.Monad.IO.Class (MonadIO(..))
import           Data.Maybe (isJust)

import           Hedgehog.Internal.Config
import           Hedgehog.Internal.Gen (evalGenT)
import           Hedgehog.Internal.Prelude
import           Hedgehog.Internal.Property (DiscardCount(..), ShrinkCount(..))
import           Hedgehog.Internal.Property (Group(..), GroupName(..))
import           Hedgehog.Internal.Property (Journal(..), Coverage(..), CoverCount(..))
import           Hedgehog.Internal.Property (Property(..), PropertyConfig(..), PropertyName(..))
import           Hedgehog.Internal.Property (PropertyT(..), Failure(..), runTestT)
import           Hedgehog.Internal.Property (ShrinkLimit, ShrinkRetries, withTests, withSkip)
import           Hedgehog.Internal.Property (TerminationCriteria(..))
import           Hedgehog.Internal.Property (TestCount(..), PropertyCount(..))
import           Hedgehog.Internal.Property (confidenceSuccess, confidenceFailure)
import           Hedgehog.Internal.Property (coverageSuccess, journalCoverage)
import           Hedgehog.Internal.Property (defaultMinTests)
import           Hedgehog.Internal.Property (ShrinkPath(..))
import           Hedgehog.Internal.Queue
import           Hedgehog.Internal.Region
import           Hedgehog.Internal.Report
import qualified Hedgehog.Internal.Seed as Seed
import           Hedgehog.Internal.Tree (TreeT(..), NodeT(..))
import           Hedgehog.Range (Size)

import           Language.Haskell.TH.Syntax (Lift)

#if mingw32_HOST_OS
import           System.IO (hSetEncoding, stdout, stderr, utf8)
#endif

-- | Configuration for a property test run.
--
data RunnerConfig =
  RunnerConfig {
      -- | The number of property tests to run concurrently. 'Nothing' means
      --   use one worker per processor.
      RunnerConfig -> Maybe WorkerCount
runnerWorkers :: !(Maybe WorkerCount)

      -- | Whether to use colored output or not. 'Nothing' means detect from
      --   the environment.
    , RunnerConfig -> Maybe UseColor
runnerColor :: !(Maybe UseColor)

      -- | The seed to use. 'Nothing' means detect from the environment.
    , RunnerConfig -> Maybe Seed
runnerSeed :: !(Maybe Seed)

      -- | How verbose to be in the runner output. 'Nothing' means detect from
      --   the environment.
    , RunnerConfig -> Maybe Verbosity
runnerVerbosity :: !(Maybe Verbosity)
    } deriving (RunnerConfig -> RunnerConfig -> Bool
(RunnerConfig -> RunnerConfig -> Bool)
-> (RunnerConfig -> RunnerConfig -> Bool) -> Eq RunnerConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RunnerConfig -> RunnerConfig -> Bool
== :: RunnerConfig -> RunnerConfig -> Bool
$c/= :: RunnerConfig -> RunnerConfig -> Bool
/= :: RunnerConfig -> RunnerConfig -> Bool
Eq, Eq RunnerConfig
Eq RunnerConfig =>
(RunnerConfig -> RunnerConfig -> Ordering)
-> (RunnerConfig -> RunnerConfig -> Bool)
-> (RunnerConfig -> RunnerConfig -> Bool)
-> (RunnerConfig -> RunnerConfig -> Bool)
-> (RunnerConfig -> RunnerConfig -> Bool)
-> (RunnerConfig -> RunnerConfig -> RunnerConfig)
-> (RunnerConfig -> RunnerConfig -> RunnerConfig)
-> Ord RunnerConfig
RunnerConfig -> RunnerConfig -> Bool
RunnerConfig -> RunnerConfig -> Ordering
RunnerConfig -> RunnerConfig -> RunnerConfig
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: RunnerConfig -> RunnerConfig -> Ordering
compare :: RunnerConfig -> RunnerConfig -> Ordering
$c< :: RunnerConfig -> RunnerConfig -> Bool
< :: RunnerConfig -> RunnerConfig -> Bool
$c<= :: RunnerConfig -> RunnerConfig -> Bool
<= :: RunnerConfig -> RunnerConfig -> Bool
$c> :: RunnerConfig -> RunnerConfig -> Bool
> :: RunnerConfig -> RunnerConfig -> Bool
$c>= :: RunnerConfig -> RunnerConfig -> Bool
>= :: RunnerConfig -> RunnerConfig -> Bool
$cmax :: RunnerConfig -> RunnerConfig -> RunnerConfig
max :: RunnerConfig -> RunnerConfig -> RunnerConfig
$cmin :: RunnerConfig -> RunnerConfig -> RunnerConfig
min :: RunnerConfig -> RunnerConfig -> RunnerConfig
Ord, Int -> RunnerConfig -> ShowS
[RunnerConfig] -> ShowS
RunnerConfig -> String
(Int -> RunnerConfig -> ShowS)
-> (RunnerConfig -> String)
-> ([RunnerConfig] -> ShowS)
-> Show RunnerConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RunnerConfig -> ShowS
showsPrec :: Int -> RunnerConfig -> ShowS
$cshow :: RunnerConfig -> String
show :: RunnerConfig -> String
$cshowList :: [RunnerConfig] -> ShowS
showList :: [RunnerConfig] -> ShowS
Show, (forall (m :: * -> *). Quote m => RunnerConfig -> m Exp)
-> (forall (m :: * -> *).
    Quote m =>
    RunnerConfig -> Code m RunnerConfig)
-> Lift RunnerConfig
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => RunnerConfig -> m Exp
forall (m :: * -> *).
Quote m =>
RunnerConfig -> Code m RunnerConfig
$clift :: forall (m :: * -> *). Quote m => RunnerConfig -> m Exp
lift :: forall (m :: * -> *). Quote m => RunnerConfig -> m Exp
$cliftTyped :: forall (m :: * -> *).
Quote m =>
RunnerConfig -> Code m RunnerConfig
liftTyped :: forall (m :: * -> *).
Quote m =>
RunnerConfig -> Code m RunnerConfig
Lift)

findM :: Monad m => [a] -> b -> (a -> m (Maybe b)) -> m b
findM :: forall (m :: * -> *) a b.
Monad m =>
[a] -> b -> (a -> m (Maybe b)) -> m b
findM [a]
xs0 b
def a -> m (Maybe b)
p =
  case [a]
xs0 of
    [] ->
      b -> m b
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return b
def
    a
x0 : [a]
xs ->
      a -> m (Maybe b)
p a
x0 m (Maybe b) -> (Maybe b -> m b) -> m b
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe b
m ->
        case Maybe b
m of
          Maybe b
Nothing ->
            [a] -> b -> (a -> m (Maybe b)) -> m b
forall (m :: * -> *) a b.
Monad m =>
[a] -> b -> (a -> m (Maybe b)) -> m b
findM [a]
xs b
def a -> m (Maybe b)
p
          Just b
x ->
            b -> m b
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return b
x

isFailure :: NodeT m (Maybe (Either x a, b)) -> Bool
isFailure :: forall (m :: * -> *) x a b. NodeT m (Maybe (Either x a, b)) -> Bool
isFailure = \case
  NodeT (Just (Left x
_, b
_)) [TreeT m (Maybe (Either x a, b))]
_ ->
    Bool
True
  NodeT m (Maybe (Either x a, b))
_ ->
    Bool
False

isSuccess :: NodeT m (Maybe (Either x a, b)) -> Bool
isSuccess :: forall (m :: * -> *) x a b. NodeT m (Maybe (Either x a, b)) -> Bool
isSuccess =
  Bool -> Bool
not (Bool -> Bool)
-> (NodeT m (Maybe (Either x a, b)) -> Bool)
-> NodeT m (Maybe (Either x a, b))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeT m (Maybe (Either x a, b)) -> Bool
forall (m :: * -> *) x a b. NodeT m (Maybe (Either x a, b)) -> Bool
isFailure

runTreeN ::
     Monad m
  => ShrinkRetries
  -> TreeT m (Maybe (Either x a, b))
  -> m (NodeT m (Maybe (Either x a, b)))
runTreeN :: forall (m :: * -> *) x a b.
Monad m =>
ShrinkRetries
-> TreeT m (Maybe (Either x a, b))
-> m (NodeT m (Maybe (Either x a, b)))
runTreeN ShrinkRetries
n TreeT m (Maybe (Either x a, b))
m = do
  o <- TreeT m (Maybe (Either x a, b))
-> m (NodeT m (Maybe (Either x a, b)))
forall (m :: * -> *) a. TreeT m a -> m (NodeT m a)
runTreeT TreeT m (Maybe (Either x a, b))
m
  if n > 0 && isSuccess o then
    runTreeN (n - 1) m
  else
    pure o

takeSmallest ::
     MonadIO m
  => ShrinkCount
  -> ShrinkPath
  -> ShrinkLimit
  -> ShrinkRetries
  -> (Progress -> m ())
  -> NodeT m (Maybe (Either Failure (), Journal))
  -> m Result
takeSmallest :: forall (m :: * -> *).
MonadIO m =>
ShrinkCount
-> ShrinkPath
-> ShrinkLimit
-> ShrinkRetries
-> (Progress -> m ())
-> NodeT m (Maybe (Either Failure (), Journal))
-> m Result
takeSmallest ShrinkCount
shrinks0 (ShrinkPath [Int]
shrinkPath0) ShrinkLimit
slimit ShrinkRetries
retries Progress -> m ()
updateUI =
  let
    loop :: ShrinkCount
-> [Int]
-> NodeT m (Maybe (Either Failure (), Journal))
-> m Result
loop ShrinkCount
shrinks [Int]
revShrinkPath = \case
      NodeT Maybe (Either Failure (), Journal)
Nothing [TreeT m (Maybe (Either Failure (), Journal))]
_ ->
        Result -> m Result
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
GaveUp

      NodeT (Just (Either Failure ()
x, (Journal [Log]
logs))) [TreeT m (Maybe (Either Failure (), Journal))]
xs ->
        case Either Failure ()
x of
          Left (Failure Maybe Span
loc String
err Maybe Diff
mdiff) -> do
            let
              shrinkPath :: ShrinkPath
shrinkPath =
                [Int] -> ShrinkPath
ShrinkPath ([Int] -> ShrinkPath) -> [Int] -> ShrinkPath
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
revShrinkPath
              failure :: FailureReport
failure =
                ShrinkCount
-> ShrinkPath
-> Maybe (Coverage CoverCount)
-> Maybe Span
-> String
-> Maybe Diff
-> [Log]
-> FailureReport
mkFailure ShrinkCount
shrinks ShrinkPath
shrinkPath Maybe (Coverage CoverCount)
forall a. Maybe a
Nothing Maybe Span
loc String
err Maybe Diff
mdiff ([Log] -> [Log]
forall a. [a] -> [a]
reverse [Log]
logs)

            Progress -> m ()
updateUI (Progress -> m ()) -> Progress -> m ()
forall a b. (a -> b) -> a -> b
$ FailureReport -> Progress
Shrinking FailureReport
failure

            if ShrinkCount
shrinks ShrinkCount -> ShrinkCount -> Bool
forall a. Ord a => a -> a -> Bool
>= ShrinkLimit -> ShrinkCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral ShrinkLimit
slimit then
              -- if we've hit the shrink limit, don't shrink any further
              Result -> m Result
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> m Result) -> Result -> m Result
forall a b. (a -> b) -> a -> b
$ FailureReport -> Result
Failed FailureReport
failure
            else
              [(Int, TreeT m (Maybe (Either Failure (), Journal)))]
-> Result
-> ((Int, TreeT m (Maybe (Either Failure (), Journal)))
    -> m (Maybe Result))
-> m Result
forall (m :: * -> *) a b.
Monad m =>
[a] -> b -> (a -> m (Maybe b)) -> m b
findM ([Int]
-> [TreeT m (Maybe (Either Failure (), Journal))]
-> [(Int, TreeT m (Maybe (Either Failure (), Journal)))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [TreeT m (Maybe (Either Failure (), Journal))]
xs) (FailureReport -> Result
Failed FailureReport
failure) (((Int, TreeT m (Maybe (Either Failure (), Journal)))
  -> m (Maybe Result))
 -> m Result)
-> ((Int, TreeT m (Maybe (Either Failure (), Journal)))
    -> m (Maybe Result))
-> m Result
forall a b. (a -> b) -> a -> b
$ \(Int
n, TreeT m (Maybe (Either Failure (), Journal))
m) -> do
                o <- ShrinkRetries
-> TreeT m (Maybe (Either Failure (), Journal))
-> m (NodeT m (Maybe (Either Failure (), Journal)))
forall (m :: * -> *) x a b.
Monad m =>
ShrinkRetries
-> TreeT m (Maybe (Either x a, b))
-> m (NodeT m (Maybe (Either x a, b)))
runTreeN ShrinkRetries
retries TreeT m (Maybe (Either Failure (), Journal))
m
                if isFailure o then
                  Just <$> loop (shrinks + 1) (n : revShrinkPath) o
                else
                  return Nothing

          Right () ->
            Result -> m Result
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
OK
  in
    ShrinkCount
-> [Int]
-> NodeT m (Maybe (Either Failure (), Journal))
-> m Result
loop ShrinkCount
shrinks0 ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
shrinkPath0)

-- | Follow a given shrink path, instead of searching exhaustively. Assume that
-- the end of the path is minimal, and don't try to shrink any further than
-- that.
--
-- This evaluates the test for all the shrinks on the path, but not ones
-- off-path. Because the generator is mixed with the test code, it's probably
-- not possible to avoid this.
skipToShrink ::
     MonadIO m
  => ShrinkPath
  -> (Progress -> m ())
  -> NodeT m (Maybe (Either Failure (), Journal))
  -> m Result
skipToShrink :: forall (m :: * -> *).
MonadIO m =>
ShrinkPath
-> (Progress -> m ())
-> NodeT m (Maybe (Either Failure (), Journal))
-> m Result
skipToShrink (ShrinkPath [Int]
shrinkPath) Progress -> m ()
updateUI =
  let
    loop :: ShrinkCount
-> [Int]
-> NodeT m (Maybe (Either Failure (), Journal))
-> m Result
loop ShrinkCount
shrinks [] = \case
      NodeT Maybe (Either Failure (), Journal)
Nothing [TreeT m (Maybe (Either Failure (), Journal))]
_ ->
        Result -> m Result
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
GaveUp

      NodeT (Just (Either Failure ()
x, (Journal [Log]
logs))) [TreeT m (Maybe (Either Failure (), Journal))]
_ ->
        case Either Failure ()
x of
          Left (Failure Maybe Span
loc String
err Maybe Diff
mdiff) -> do
            let
              failure :: FailureReport
failure =
                ShrinkCount
-> ShrinkPath
-> Maybe (Coverage CoverCount)
-> Maybe Span
-> String
-> Maybe Diff
-> [Log]
-> FailureReport
mkFailure ShrinkCount
shrinks ([Int] -> ShrinkPath
ShrinkPath [Int]
shrinkPath) Maybe (Coverage CoverCount)
forall a. Maybe a
Nothing Maybe Span
loc String
err Maybe Diff
mdiff ([Log] -> [Log]
forall a. [a] -> [a]
reverse [Log]
logs)

            Progress -> m ()
updateUI (Progress -> m ()) -> Progress -> m ()
forall a b. (a -> b) -> a -> b
$ FailureReport -> Progress
Shrinking FailureReport
failure
            Result -> m Result
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> m Result) -> Result -> m Result
forall a b. (a -> b) -> a -> b
$ FailureReport -> Result
Failed FailureReport
failure

          Right () ->
            Result -> m Result
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
OK

    loop ShrinkCount
shrinks (Int
s0:[Int]
ss) = \case
      NodeT Maybe (Either Failure (), Journal)
_ [TreeT m (Maybe (Either Failure (), Journal))]
xs ->
        case Int
-> [TreeT m (Maybe (Either Failure (), Journal))]
-> [TreeT m (Maybe (Either Failure (), Journal))]
forall a. Int -> [a] -> [a]
drop Int
s0 [TreeT m (Maybe (Either Failure (), Journal))]
xs of
          [] ->
            Result -> m Result
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
GaveUp
          (TreeT m (Maybe (Either Failure (), Journal))
x:[TreeT m (Maybe (Either Failure (), Journal))]
_) -> do
            o <- TreeT m (Maybe (Either Failure (), Journal))
-> m (NodeT m (Maybe (Either Failure (), Journal)))
forall (m :: * -> *) a. TreeT m a -> m (NodeT m a)
runTreeT TreeT m (Maybe (Either Failure (), Journal))
x
            loop (shrinks + 1) ss o
  in
    ShrinkCount
-> [Int]
-> NodeT m (Maybe (Either Failure (), Journal))
-> m Result
loop ShrinkCount
0 [Int]
shrinkPath

checkReport ::
     forall m.
     MonadIO m
  => MonadCatch m
  => PropertyConfig
  -> Size
  -> Seed
  -> PropertyT m ()
  -> (Report Progress -> m ())
  -> m (Report Result)
checkReport :: forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
PropertyConfig
-> Size
-> Seed
-> PropertyT m ()
-> (Report Progress -> m ())
-> m (Report Result)
checkReport PropertyConfig
cfg Size
size0 Seed
seed0 PropertyT m ()
test0 Report Progress -> m ()
updateUI = do
  skip <- IO Skip -> m Skip
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Skip -> m Skip) -> IO Skip -> m Skip
forall a b. (a -> b) -> a -> b
$ Maybe Skip -> IO Skip
forall (m :: * -> *). MonadIO m => Maybe Skip -> m Skip
resolveSkip (Maybe Skip -> IO Skip) -> Maybe Skip -> IO Skip
forall a b. (a -> b) -> a -> b
$ PropertyConfig -> Maybe Skip
propertySkip PropertyConfig
cfg

  let
    (mSkipToTest, mSkipToShrink) =
      case skip of
        Skip
SkipNothing ->
          (Maybe (TestCount, DiscardCount)
forall a. Maybe a
Nothing, Maybe ShrinkPath
forall a. Maybe a
Nothing)
        SkipToTest TestCount
t DiscardCount
d ->
          ((TestCount, DiscardCount) -> Maybe (TestCount, DiscardCount)
forall a. a -> Maybe a
Just (TestCount
t, DiscardCount
d), Maybe ShrinkPath
forall a. Maybe a
Nothing)
        SkipToShrink TestCount
t DiscardCount
d ShrinkPath
s ->
          ((TestCount, DiscardCount) -> Maybe (TestCount, DiscardCount)
forall a. a -> Maybe a
Just (TestCount
t, DiscardCount
d), ShrinkPath -> Maybe ShrinkPath
forall a. a -> Maybe a
Just ShrinkPath
s)

    test =
      PropertyT m ()
-> (SomeException -> PropertyT m ()) -> PropertyT m ()
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
catchAny PropertyT m ()
test0 (String -> PropertyT m ()
forall a. String -> PropertyT m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> PropertyT m ())
-> (SomeException -> String) -> SomeException -> PropertyT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> String
forall a. Show a => a -> String
show)

    terminationCriteria =
      PropertyConfig -> TerminationCriteria
propertyTerminationCriteria PropertyConfig
cfg

    (confidence, minTests) =
      case terminationCriteria of
        EarlyTermination Confidence
c TestLimit
t -> (Confidence -> Maybe Confidence
forall a. a -> Maybe a
Just Confidence
c, TestLimit
t)
        NoEarlyTermination Confidence
c TestLimit
t -> (Confidence -> Maybe Confidence
forall a. a -> Maybe a
Just Confidence
c, TestLimit
t)
        NoConfidenceTermination TestLimit
t -> (Maybe Confidence
forall a. Maybe a
Nothing, TestLimit
t)

    successVerified TestCount
count Coverage CoverCount
coverage =
      TestCount
count TestCount -> TestCount -> TestCount
forall a. Integral a => a -> a -> a
`mod` TestCount
100 TestCount -> TestCount -> Bool
forall a. Eq a => a -> a -> Bool
== TestCount
0 Bool -> Bool -> Bool
&&
      -- If the user wants a statistically significant result, this function
      -- will run a confidence check. Otherwise, it will default to checking
      -- the percentage of encountered labels
      Bool -> (Confidence -> Bool) -> Maybe Confidence -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\Confidence
c -> TestCount -> Confidence -> Coverage CoverCount -> Bool
confidenceSuccess TestCount
count Confidence
c Coverage CoverCount
coverage) Maybe Confidence
confidence

    failureVerified TestCount
count Coverage CoverCount
coverage =
      -- Will be true if we can statistically verify that our coverage was
      -- inadequate.
      -- Testing only on 100s to minimise repeated measurement statistical
      -- errors.
      TestCount
count TestCount -> TestCount -> TestCount
forall a. Integral a => a -> a -> a
`mod` TestCount
100 TestCount -> TestCount -> Bool
forall a. Eq a => a -> a -> Bool
== TestCount
0 Bool -> Bool -> Bool
&&
      Bool -> (Confidence -> Bool) -> Maybe Confidence -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\Confidence
c -> TestCount -> Confidence -> Coverage CoverCount -> Bool
confidenceFailure TestCount
count Confidence
c Coverage CoverCount
coverage) Maybe Confidence
confidence

    loop ::
         TestCount
      -> DiscardCount
      -> Size
      -> Seed
      -> Coverage CoverCount
      -> m (Report Result)
    loop !TestCount
tests !DiscardCount
discards !Size
size !Seed
seed !Coverage CoverCount
coverage0 = do
      Report Progress -> m ()
updateUI (Report Progress -> m ()) -> Report Progress -> m ()
forall a b. (a -> b) -> a -> b
$ TestCount
-> DiscardCount
-> Coverage CoverCount
-> Seed
-> Progress
-> Report Progress
forall a.
TestCount
-> DiscardCount -> Coverage CoverCount -> Seed -> a -> Report a
Report TestCount
tests DiscardCount
discards Coverage CoverCount
coverage0 Seed
seed0 Progress
Running

      let
        coverageReached :: Bool
coverageReached =
          TestCount -> Coverage CoverCount -> Bool
successVerified TestCount
tests Coverage CoverCount
coverage0

        coverageUnreachable :: Bool
coverageUnreachable =
          TestCount -> Coverage CoverCount -> Bool
failureVerified TestCount
tests Coverage CoverCount
coverage0

        enoughTestsRun :: Bool
enoughTestsRun =
          case TerminationCriteria
terminationCriteria of
            EarlyTermination Confidence
_ TestLimit
_ ->
              TestCount
tests TestCount -> TestCount -> Bool
forall a. Ord a => a -> a -> Bool
>= TestLimit -> TestCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral TestLimit
defaultMinTests Bool -> Bool -> Bool
&&
                (Bool
coverageReached Bool -> Bool -> Bool
|| Bool
coverageUnreachable)
            NoEarlyTermination Confidence
_ TestLimit
_ ->
              TestCount
tests TestCount -> TestCount -> Bool
forall a. Ord a => a -> a -> Bool
>= TestLimit -> TestCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral TestLimit
minTests
            NoConfidenceTermination TestLimit
_ ->
              TestCount
tests TestCount -> TestCount -> Bool
forall a. Ord a => a -> a -> Bool
>= TestLimit -> TestCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral TestLimit
minTests

        labelsCovered :: Bool
labelsCovered =
          TestCount -> Coverage CoverCount -> Bool
coverageSuccess TestCount
tests Coverage CoverCount
coverage0

        successReport :: Report Result
successReport =
          TestCount
-> DiscardCount
-> Coverage CoverCount
-> Seed
-> Result
-> Report Result
forall a.
TestCount
-> DiscardCount -> Coverage CoverCount -> Seed -> a -> Report a
Report TestCount
tests DiscardCount
discards Coverage CoverCount
coverage0 Seed
seed0 Result
OK

        failureReport :: String -> Report Result
failureReport String
message =
          TestCount
-> DiscardCount
-> Coverage CoverCount
-> Seed
-> Result
-> Report Result
forall a.
TestCount
-> DiscardCount -> Coverage CoverCount -> Seed -> a -> Report a
Report TestCount
tests DiscardCount
discards Coverage CoverCount
coverage0 Seed
seed0 (Result -> Report Result)
-> (FailureReport -> Result) -> FailureReport -> Report Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FailureReport -> Result
Failed (FailureReport -> Report Result) -> FailureReport -> Report Result
forall a b. (a -> b) -> a -> b
$ ShrinkCount
-> ShrinkPath
-> Maybe (Coverage CoverCount)
-> Maybe Span
-> String
-> Maybe Diff
-> [Log]
-> FailureReport
mkFailure
            ShrinkCount
0
            ([Int] -> ShrinkPath
ShrinkPath [])
            (Coverage CoverCount -> Maybe (Coverage CoverCount)
forall a. a -> Maybe a
Just Coverage CoverCount
coverage0)
            Maybe Span
forall a. Maybe a
Nothing
            String
message
            Maybe Diff
forall a. Maybe a
Nothing
            []

        confidenceReport :: Report Result
confidenceReport =
          if Bool
coverageReached Bool -> Bool -> Bool
&& Bool
labelsCovered then
            Report Result
successReport
          else
            String -> Report Result
failureReport (String -> Report Result) -> String -> Report Result
forall a b. (a -> b) -> a -> b
$
              String
"Test coverage cannot be reached after " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TestCount -> String
forall a. Show a => a -> String
show TestCount
tests String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" tests"

      if Size
size Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
> Size
99 then
        -- size has reached limit, reset to 0
        TestCount
-> DiscardCount
-> Size
-> Seed
-> Coverage CoverCount
-> m (Report Result)
loop TestCount
tests DiscardCount
discards Size
0 Seed
seed Coverage CoverCount
coverage0

      else if Bool
enoughTestsRun then
        -- at this point, we know that enough tests have been run in order to
        -- make a decision on if this was a successful run or not
        --
        -- If we have early termination, then we need to check coverageReached /
        -- coverageUnreachable. If we skip tests, we ignore coverage.
        if Maybe (TestCount, DiscardCount) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (TestCount, DiscardCount)
mSkipToTest then
          Report Result -> m (Report Result)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Report Result
successReport
        else
          Report Result -> m (Report Result)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Report Result -> m (Report Result))
-> Report Result -> m (Report Result)
forall a b. (a -> b) -> a -> b
$ case TerminationCriteria
terminationCriteria of
            EarlyTermination Confidence
_ TestLimit
_ -> Report Result
confidenceReport
            NoEarlyTermination Confidence
_ TestLimit
_ -> Report Result
confidenceReport
            NoConfidenceTermination TestLimit
_ ->
              if Bool
labelsCovered then
                Report Result
successReport
              else
                String -> Report Result
failureReport (String -> Report Result) -> String -> Report Result
forall a b. (a -> b) -> a -> b
$
                  String
"Labels not sufficiently covered after " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> TestCount -> String
forall a. Show a => a -> String
show TestCount
tests String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" tests"

      else if DiscardCount
discards DiscardCount -> DiscardCount -> Bool
forall a. Ord a => a -> a -> Bool
>= DiscardLimit -> DiscardCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PropertyConfig -> DiscardLimit
propertyDiscardLimit PropertyConfig
cfg) then
        -- we've hit the discard limit, give up
        Report Result -> m (Report Result)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Report Result -> m (Report Result))
-> Report Result -> m (Report Result)
forall a b. (a -> b) -> a -> b
$ TestCount
-> DiscardCount
-> Coverage CoverCount
-> Seed
-> Result
-> Report Result
forall a.
TestCount
-> DiscardCount -> Coverage CoverCount -> Seed -> a -> Report a
Report TestCount
tests DiscardCount
discards Coverage CoverCount
coverage0 Seed
seed0 Result
GaveUp

      else
        case Seed -> (Seed, Seed)
Seed.split Seed
seed of
          (Seed
s0, Seed
s1) -> case (Maybe (TestCount, DiscardCount)
mSkipToTest, Maybe ShrinkPath
mSkipToShrink) of
            -- If the report says failed "after 32 tests", the test number that
            -- failed was 31, but we want the user to be able to skip to 32 and
            -- start with the one that failed.
            (Just (TestCount
n, DiscardCount
d), Maybe ShrinkPath
_)
              | TestCount
n TestCount -> TestCount -> Bool
forall a. Ord a => a -> a -> Bool
> TestCount
tests TestCount -> TestCount -> TestCount
forall a. Num a => a -> a -> a
+ TestCount
1 ->
                TestCount
-> DiscardCount
-> Size
-> Seed
-> Coverage CoverCount
-> m (Report Result)
loop (TestCount
tests TestCount -> TestCount -> TestCount
forall a. Num a => a -> a -> a
+ TestCount
1) DiscardCount
discards (Size
size Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1) Seed
s1 Coverage CoverCount
coverage0
              | DiscardCount
d DiscardCount -> DiscardCount -> Bool
forall a. Ord a => a -> a -> Bool
> DiscardCount
discards ->
                TestCount
-> DiscardCount
-> Size
-> Seed
-> Coverage CoverCount
-> m (Report Result)
loop TestCount
tests (DiscardCount
discards DiscardCount -> DiscardCount -> DiscardCount
forall a. Num a => a -> a -> a
+ DiscardCount
1) (Size
size Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1) Seed
s1 Coverage CoverCount
coverage0
            (Just (TestCount, DiscardCount)
_, Just ShrinkPath
shrinkPath) -> do
              node <-
                TreeT m (Maybe (Either Failure (), Journal))
-> m (NodeT m (Maybe (Either Failure (), Journal)))
forall (m :: * -> *) a. TreeT m a -> m (NodeT m a)
runTreeT (TreeT m (Maybe (Either Failure (), Journal))
 -> m (NodeT m (Maybe (Either Failure (), Journal))))
-> (TestT (GenT m) ()
    -> TreeT m (Maybe (Either Failure (), Journal)))
-> TestT (GenT m) ()
-> m (NodeT m (Maybe (Either Failure (), Journal)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Size
-> Seed
-> GenT m (Either Failure (), Journal)
-> TreeT m (Maybe (Either Failure (), Journal))
forall (m :: * -> *) a.
Monad m =>
Size -> Seed -> GenT m a -> TreeT m (Maybe a)
evalGenT Size
size Seed
s0 (GenT m (Either Failure (), Journal)
 -> TreeT m (Maybe (Either Failure (), Journal)))
-> (TestT (GenT m) () -> GenT m (Either Failure (), Journal))
-> TestT (GenT m) ()
-> TreeT m (Maybe (Either Failure (), Journal))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestT (GenT m) () -> GenT m (Either Failure (), Journal)
forall (m :: * -> *) a. TestT m a -> m (Either Failure a, Journal)
runTestT (TestT (GenT m) ()
 -> m (NodeT m (Maybe (Either Failure (), Journal))))
-> TestT (GenT m) ()
-> m (NodeT m (Maybe (Either Failure (), Journal)))
forall a b. (a -> b) -> a -> b
$ PropertyT m () -> TestT (GenT m) ()
forall (m :: * -> *) a. PropertyT m a -> TestT (GenT m) a
unPropertyT PropertyT m ()
test
              let
                mkReport =
                  TestCount
-> DiscardCount -> Coverage CoverCount -> Seed -> a -> Report a
forall a.
TestCount
-> DiscardCount -> Coverage CoverCount -> Seed -> a -> Report a
Report (TestCount
tests TestCount -> TestCount -> TestCount
forall a. Num a => a -> a -> a
+ TestCount
1) DiscardCount
discards Coverage CoverCount
coverage0 Seed
seed0
              mkReport <$> skipToShrink shrinkPath (updateUI . mkReport) node
            (Maybe (TestCount, DiscardCount), Maybe ShrinkPath)
_ -> do
              node@(NodeT x _) <-
                TreeT m (Maybe (Either Failure (), Journal))
-> m (NodeT m (Maybe (Either Failure (), Journal)))
forall (m :: * -> *) a. TreeT m a -> m (NodeT m a)
runTreeT (TreeT m (Maybe (Either Failure (), Journal))
 -> m (NodeT m (Maybe (Either Failure (), Journal))))
-> (TestT (GenT m) ()
    -> TreeT m (Maybe (Either Failure (), Journal)))
-> TestT (GenT m) ()
-> m (NodeT m (Maybe (Either Failure (), Journal)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Size
-> Seed
-> GenT m (Either Failure (), Journal)
-> TreeT m (Maybe (Either Failure (), Journal))
forall (m :: * -> *) a.
Monad m =>
Size -> Seed -> GenT m a -> TreeT m (Maybe a)
evalGenT Size
size Seed
s0 (GenT m (Either Failure (), Journal)
 -> TreeT m (Maybe (Either Failure (), Journal)))
-> (TestT (GenT m) () -> GenT m (Either Failure (), Journal))
-> TestT (GenT m) ()
-> TreeT m (Maybe (Either Failure (), Journal))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestT (GenT m) () -> GenT m (Either Failure (), Journal)
forall (m :: * -> *) a. TestT m a -> m (Either Failure a, Journal)
runTestT (TestT (GenT m) ()
 -> m (NodeT m (Maybe (Either Failure (), Journal))))
-> TestT (GenT m) ()
-> m (NodeT m (Maybe (Either Failure (), Journal)))
forall a b. (a -> b) -> a -> b
$ PropertyT m () -> TestT (GenT m) ()
forall (m :: * -> *) a. PropertyT m a -> TestT (GenT m) a
unPropertyT PropertyT m ()
test
              case x of
                Maybe (Either Failure (), Journal)
Nothing ->
                  TestCount
-> DiscardCount
-> Size
-> Seed
-> Coverage CoverCount
-> m (Report Result)
loop TestCount
tests (DiscardCount
discards DiscardCount -> DiscardCount -> DiscardCount
forall a. Num a => a -> a -> a
+ DiscardCount
1) (Size
size Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1) Seed
s1 Coverage CoverCount
coverage0

                Just (Left Failure
_, Journal
_) ->
                  let
                    mkReport :: a -> Report a
mkReport =
                      TestCount
-> DiscardCount -> Coverage CoverCount -> Seed -> a -> Report a
forall a.
TestCount
-> DiscardCount -> Coverage CoverCount -> Seed -> a -> Report a
Report (TestCount
tests TestCount -> TestCount -> TestCount
forall a. Num a => a -> a -> a
+ TestCount
1) DiscardCount
discards Coverage CoverCount
coverage0 Seed
seed0
                  in
                    (Result -> Report Result) -> m Result -> m (Report Result)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Result -> Report Result
forall {a}. a -> Report a
mkReport (m Result -> m (Report Result)) -> m Result -> m (Report Result)
forall a b. (a -> b) -> a -> b
$
                      ShrinkCount
-> ShrinkPath
-> ShrinkLimit
-> ShrinkRetries
-> (Progress -> m ())
-> NodeT m (Maybe (Either Failure (), Journal))
-> m Result
forall (m :: * -> *).
MonadIO m =>
ShrinkCount
-> ShrinkPath
-> ShrinkLimit
-> ShrinkRetries
-> (Progress -> m ())
-> NodeT m (Maybe (Either Failure (), Journal))
-> m Result
takeSmallest
                        ShrinkCount
0
                        ([Int] -> ShrinkPath
ShrinkPath [])
                        (PropertyConfig -> ShrinkLimit
propertyShrinkLimit PropertyConfig
cfg)
                        (PropertyConfig -> ShrinkRetries
propertyShrinkRetries PropertyConfig
cfg)
                        (Report Progress -> m ()
updateUI (Report Progress -> m ())
-> (Progress -> Report Progress) -> Progress -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Progress -> Report Progress
forall {a}. a -> Report a
mkReport)
                        NodeT m (Maybe (Either Failure (), Journal))
node

                Just (Right (), Journal
journal) ->
                  let
                    coverage :: Coverage CoverCount
coverage =
                      Journal -> Coverage CoverCount
journalCoverage Journal
journal Coverage CoverCount -> Coverage CoverCount -> Coverage CoverCount
forall a. Semigroup a => a -> a -> a
<> Coverage CoverCount
coverage0
                  in
                    TestCount
-> DiscardCount
-> Size
-> Seed
-> Coverage CoverCount
-> m (Report Result)
loop (TestCount
tests TestCount -> TestCount -> TestCount
forall a. Num a => a -> a -> a
+ TestCount
1) DiscardCount
discards (Size
size Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Size
1) Seed
s1 Coverage CoverCount
coverage

  loop 0 0 size0 seed0 mempty

checkRegion ::
     MonadIO m
  => Region
  -> UseColor
  -> Maybe PropertyName
  -> Size
  -> Seed
  -> Property
  -> m (Report Result)
checkRegion :: forall (m :: * -> *).
MonadIO m =>
Region
-> UseColor
-> Maybe PropertyName
-> Size
-> Seed
-> Property
-> m (Report Result)
checkRegion Region
region UseColor
color Maybe PropertyName
name Size
size Seed
seed Property
prop =
  IO (Report Result) -> m (Report Result)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Report Result) -> m (Report Result))
-> IO (Report Result) -> m (Report Result)
forall a b. (a -> b) -> a -> b
$ do
    result <-
      PropertyConfig
-> Size
-> Seed
-> PropertyT IO ()
-> (Report Progress -> IO ())
-> IO (Report Result)
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
PropertyConfig
-> Size
-> Seed
-> PropertyT m ()
-> (Report Progress -> m ())
-> m (Report Result)
checkReport (Property -> PropertyConfig
propertyConfig Property
prop) Size
size Seed
seed (Property -> PropertyT IO ()
propertyTest Property
prop) ((Report Progress -> IO ()) -> IO (Report Result))
-> (Report Progress -> IO ()) -> IO (Report Result)
forall a b. (a -> b) -> a -> b
$ \Report Progress
progress -> do
        ppprogress <- UseColor -> Maybe PropertyName -> Report Progress -> IO String
forall (m :: * -> *).
MonadIO m =>
UseColor -> Maybe PropertyName -> Report Progress -> m String
renderProgress UseColor
color Maybe PropertyName
name Report Progress
progress
        case reportStatus progress of
          Progress
Running ->
            Region -> String -> IO ()
forall (m :: * -> *). LiftRegion m => Region -> String -> m ()
setRegion Region
region String
ppprogress
          Shrinking FailureReport
_ ->
            Region -> String -> IO ()
forall (m :: * -> *). LiftRegion m => Region -> String -> m ()
openRegion Region
region String
ppprogress

    ppresult <- renderResult color name result
    case reportStatus result of
      Failed FailureReport
_ ->
        Region -> String -> IO ()
forall (m :: * -> *). LiftRegion m => Region -> String -> m ()
openRegion Region
region String
ppresult
      Result
GaveUp ->
        Region -> String -> IO ()
forall (m :: * -> *). LiftRegion m => Region -> String -> m ()
openRegion Region
region String
ppresult
      Result
OK ->
        Region -> String -> IO ()
forall (m :: * -> *). LiftRegion m => Region -> String -> m ()
setRegion Region
region String
ppresult

    pure result

checkNamed ::
     MonadIO m
  => Region
  -> UseColor
  -> Maybe PropertyName
  -> Maybe Seed
  -> Property
  -> m (Report Result)
checkNamed :: forall (m :: * -> *).
MonadIO m =>
Region
-> UseColor
-> Maybe PropertyName
-> Maybe Seed
-> Property
-> m (Report Result)
checkNamed Region
region UseColor
color Maybe PropertyName
name Maybe Seed
mseed Property
prop = do
  seed <- Maybe Seed -> m Seed
forall (m :: * -> *). MonadIO m => Maybe Seed -> m Seed
resolveSeed Maybe Seed
mseed
  checkRegion region color name 0 seed prop

-- | Check a property.
--
check :: MonadIO m => Property -> m Bool
check :: forall (m :: * -> *). MonadIO m => Property -> m Bool
check Property
prop = do
  color <- m UseColor
forall (m :: * -> *). MonadIO m => m UseColor
detectColor
  liftIO . displayRegion $ \Region
region ->
    (Result -> Result -> Bool
forall a. Eq a => a -> a -> Bool
== Result
OK) (Result -> Bool)
-> (Report Result -> Result) -> Report Result -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Report Result -> Result
forall a. Report a -> a
reportStatus (Report Result -> Bool) -> IO (Report Result) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Region
-> UseColor
-> Maybe PropertyName
-> Maybe Seed
-> Property
-> IO (Report Result)
forall (m :: * -> *).
MonadIO m =>
Region
-> UseColor
-> Maybe PropertyName
-> Maybe Seed
-> Property
-> m (Report Result)
checkNamed Region
region UseColor
color Maybe PropertyName
forall a. Maybe a
Nothing Maybe Seed
forall a. Maybe a
Nothing Property
prop

-- | Check a property using a specific size and seed.
--
recheck :: MonadIO m => Size -> Seed -> Property -> m ()
recheck :: forall (m :: * -> *). MonadIO m => Size -> Seed -> Property -> m ()
recheck Size
size Seed
seed Property
prop0 = do
  color <- m UseColor
forall (m :: * -> *). MonadIO m => m UseColor
detectColor
  let prop = TestLimit -> Property -> Property
withTests TestLimit
1 Property
prop0
  _ <- liftIO . displayRegion $ \Region
region ->
    Region
-> UseColor
-> Maybe PropertyName
-> Size
-> Seed
-> Property
-> IO (Report Result)
forall (m :: * -> *).
MonadIO m =>
Region
-> UseColor
-> Maybe PropertyName
-> Size
-> Seed
-> Property
-> m (Report Result)
checkRegion Region
region UseColor
color Maybe PropertyName
forall a. Maybe a
Nothing Size
size Seed
seed Property
prop
  pure ()

recheckAt :: MonadIO m => Seed -> Skip -> Property -> m ()
recheckAt :: forall (m :: * -> *). MonadIO m => Seed -> Skip -> Property -> m ()
recheckAt Seed
seed Skip
skip Property
prop0 = do
  color <- m UseColor
forall (m :: * -> *). MonadIO m => m UseColor
detectColor
  let prop = Skip -> Property -> Property
withSkip Skip
skip Property
prop0
  _ <- liftIO . displayRegion $ \Region
region ->
    Region
-> UseColor
-> Maybe PropertyName
-> Size
-> Seed
-> Property
-> IO (Report Result)
forall (m :: * -> *).
MonadIO m =>
Region
-> UseColor
-> Maybe PropertyName
-> Size
-> Seed
-> Property
-> m (Report Result)
checkRegion Region
region UseColor
color Maybe PropertyName
forall a. Maybe a
Nothing Size
0 Seed
seed Property
prop
  pure ()

-- | Check a group of properties using the specified runner config.
--
checkGroup :: MonadIO m => RunnerConfig -> Group -> m Bool
checkGroup :: forall (m :: * -> *). MonadIO m => RunnerConfig -> Group -> m Bool
checkGroup RunnerConfig
config (Group GroupName
group [(PropertyName, Property)]
props) =
  IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
    n <- Maybe WorkerCount -> IO WorkerCount
forall (m :: * -> *).
MonadIO m =>
Maybe WorkerCount -> m WorkerCount
resolveWorkers (RunnerConfig -> Maybe WorkerCount
runnerWorkers RunnerConfig
config)

    -- ensure few spare capabilities for concurrent-output, it's likely that
    -- our tests will saturate all the capabilities they're given.
    updateNumCapabilities (n + 2)

#if mingw32_HOST_OS
    hSetEncoding stdout utf8
    hSetEncoding stderr utf8
#endif

    putStrLn $ "━━━ " ++ unGroupName group ++ " ━━━"

    seed <- resolveSeed (runnerSeed config)
    verbosity <- resolveVerbosity (runnerVerbosity config)
    color <- resolveColor (runnerColor config)
    summary <- checkGroupWith n verbosity color seed props

    pure $
      summaryFailed summary == 0 &&
      summaryGaveUp summary == 0

updateSummary :: Region -> TVar Summary -> UseColor -> (Summary -> Summary) -> IO ()
updateSummary :: Region -> TVar Summary -> UseColor -> (Summary -> Summary) -> IO ()
updateSummary Region
sregion TVar Summary
svar UseColor
color Summary -> Summary
f = do
  summary <- STM Summary -> IO Summary
forall a. STM a -> IO a
atomically (TVar Summary -> (Summary -> Summary) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
TVar.modifyTVar' TVar Summary
svar Summary -> Summary
f STM () -> STM Summary -> STM Summary
forall a b. STM a -> STM b -> STM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TVar Summary -> STM Summary
forall a. TVar a -> STM a
TVar.readTVar TVar Summary
svar)
  setRegion sregion =<< renderSummary color summary

checkGroupWith ::
     WorkerCount
  -> Verbosity
  -> UseColor
  -> Seed
  -> [(PropertyName, Property)]
  -> IO Summary
checkGroupWith :: WorkerCount
-> Verbosity
-> UseColor
-> Seed
-> [(PropertyName, Property)]
-> IO Summary
checkGroupWith WorkerCount
n Verbosity
verbosity UseColor
color Seed
seed [(PropertyName, Property)]
props =
  (Region -> IO Summary) -> IO Summary
forall (m :: * -> *) a.
(MonadIO m, MonadMask m, LiftRegion m) =>
(Region -> m a) -> m a
displayRegion ((Region -> IO Summary) -> IO Summary)
-> (Region -> IO Summary) -> IO Summary
forall a b. (a -> b) -> a -> b
$ \Region
sregion -> do
    svar <- STM (TVar Summary) -> IO (TVar Summary)
forall a. STM a -> IO a
atomically (STM (TVar Summary) -> IO (TVar Summary))
-> (Summary -> STM (TVar Summary)) -> Summary -> IO (TVar Summary)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Summary -> STM (TVar Summary)
forall a. a -> STM (TVar a)
TVar.newTVar (Summary -> IO (TVar Summary)) -> Summary -> IO (TVar Summary)
forall a b. (a -> b) -> a -> b
$ Summary
forall a. Monoid a => a
mempty { summaryWaiting = PropertyCount (length props) }

    let
      start (TasksRemaining Int
tasks) p
_ix (a
name, b
prop) =
        IO (a, b, Region) -> m (a, b, Region)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (a, b, Region) -> m (a, b, Region))
-> IO (a, b, Region) -> m (a, b, Region)
forall a b. (a -> b) -> a -> b
$ do
          Region -> TVar Summary -> UseColor -> (Summary -> Summary) -> IO ()
updateSummary Region
sregion TVar Summary
svar UseColor
color ((Summary -> Summary) -> IO ()) -> (Summary -> Summary) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Summary
x -> Summary
x {
              summaryWaiting =
                PropertyCount tasks
            , summaryRunning =
                summaryRunning x + 1
            }

          STM (a, b, Region) -> IO (a, b, Region)
forall a. STM a -> IO a
atomically (STM (a, b, Region) -> IO (a, b, Region))
-> STM (a, b, Region) -> IO (a, b, Region)
forall a b. (a -> b) -> a -> b
$ do
            region <-
              case Verbosity
verbosity of
                Verbosity
Quiet ->
                  STM Region
forall (m :: * -> *). LiftRegion m => m Region
newEmptyRegion
                Verbosity
Normal ->
                  STM Region
forall (m :: * -> *). LiftRegion m => m Region
newOpenRegion

            moveToBottom sregion

            pure (name, prop, region)

      finish (a
_name, b
_prop, c
_region) =
        Region -> TVar Summary -> UseColor -> (Summary -> Summary) -> IO ()
updateSummary Region
sregion TVar Summary
svar UseColor
color ((Summary -> Summary) -> IO ()) -> (Summary -> Summary) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Summary
x -> Summary
x {
            summaryRunning =
              summaryRunning x - 1
          }

      finalize (a
_name, b
_prop, Region
region) =
        Region -> m ()
forall (m :: * -> *). LiftRegion m => Region -> m ()
finishRegion Region
region

    summary <-
      fmap (mconcat . fmap (fromResult . reportStatus)) $
        runTasks n props start finish finalize $ \(PropertyName
name, Property
prop, Region
region) -> do
          result <- Region
-> UseColor
-> Maybe PropertyName
-> Maybe Seed
-> Property
-> IO (Report Result)
forall (m :: * -> *).
MonadIO m =>
Region
-> UseColor
-> Maybe PropertyName
-> Maybe Seed
-> Property
-> m (Report Result)
checkNamed Region
region UseColor
color (PropertyName -> Maybe PropertyName
forall a. a -> Maybe a
Just PropertyName
name) (Seed -> Maybe Seed
forall a. a -> Maybe a
Just Seed
seed) Property
prop
          updateSummary sregion svar color
            (<> fromResult (reportStatus result))
          pure result

    updateSummary sregion svar color (const summary)
    pure summary

-- | Check a group of properties sequentially.
--
--   Using Template Haskell for property discovery:
--
-- > tests :: IO Bool
-- > tests =
-- >   checkSequential $$(discover)
--
--   With manually specified properties:
--
-- > tests :: IO Bool
-- > tests =
-- >   checkSequential $ Group "Test.Example" [
-- >       ("prop_reverse", prop_reverse)
-- >     ]
--
--
checkSequential :: MonadIO m => Group -> m Bool
checkSequential :: forall (m :: * -> *). MonadIO m => Group -> m Bool
checkSequential =
  RunnerConfig -> Group -> m Bool
forall (m :: * -> *). MonadIO m => RunnerConfig -> Group -> m Bool
checkGroup
    RunnerConfig {
        runnerWorkers :: Maybe WorkerCount
runnerWorkers =
          WorkerCount -> Maybe WorkerCount
forall a. a -> Maybe a
Just WorkerCount
1
      , runnerColor :: Maybe UseColor
runnerColor =
          Maybe UseColor
forall a. Maybe a
Nothing
      , runnerSeed :: Maybe Seed
runnerSeed =
          Maybe Seed
forall a. Maybe a
Nothing
      , runnerVerbosity :: Maybe Verbosity
runnerVerbosity =
          Maybe Verbosity
forall a. Maybe a
Nothing
      }

-- | Check a group of properties in parallel.
--
--   /Warning: although this check function runs tests faster than/
--   /'checkSequential', it should be noted that it may cause problems with/
--   /properties that are not self-contained. For example, if you have a group/
--   /of tests which all use the same database table, you may find that they/
--   /interfere with each other when being run in parallel./
--
--   Using Template Haskell for property discovery:
--
-- > tests :: IO Bool
-- > tests =
-- >   checkParallel $$(discover)
--
--   With manually specified properties:
--
-- > tests :: IO Bool
-- > tests =
-- >   checkParallel $ Group "Test.Example" [
-- >       ("prop_reverse", prop_reverse)
-- >     ]
--
checkParallel :: MonadIO m => Group -> m Bool
checkParallel :: forall (m :: * -> *). MonadIO m => Group -> m Bool
checkParallel =
  RunnerConfig -> Group -> m Bool
forall (m :: * -> *). MonadIO m => RunnerConfig -> Group -> m Bool
checkGroup
    RunnerConfig {
        runnerWorkers :: Maybe WorkerCount
runnerWorkers =
          Maybe WorkerCount
forall a. Maybe a
Nothing
      , runnerColor :: Maybe UseColor
runnerColor =
          Maybe UseColor
forall a. Maybe a
Nothing
      , runnerSeed :: Maybe Seed
runnerSeed =
          Maybe Seed
forall a. Maybe a
Nothing
      , runnerVerbosity :: Maybe Verbosity
runnerVerbosity =
          Maybe Verbosity
forall a. Maybe a
Nothing
      }