{-# 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

  -- * 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.Monad.Catch (MonadCatch(..), catchAll)
import           Control.Monad.IO.Class (MonadIO(..))

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)
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.Queue
import           Hedgehog.Internal.Region
import           Hedgehog.Internal.Report
import           Hedgehog.Internal.Seed (Seed)
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)

      -- | 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
/= :: RunnerConfig -> RunnerConfig -> Bool
$c/= :: RunnerConfig -> RunnerConfig -> Bool
== :: RunnerConfig -> RunnerConfig -> Bool
$c== :: 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
min :: RunnerConfig -> RunnerConfig -> RunnerConfig
$cmin :: RunnerConfig -> RunnerConfig -> RunnerConfig
max :: RunnerConfig -> RunnerConfig -> RunnerConfig
$cmax :: RunnerConfig -> RunnerConfig -> RunnerConfig
>= :: RunnerConfig -> RunnerConfig -> Bool
$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
compare :: RunnerConfig -> RunnerConfig -> Ordering
$ccompare :: RunnerConfig -> RunnerConfig -> Ordering
$cp1Ord :: Eq 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
showList :: [RunnerConfig] -> ShowS
$cshowList :: [RunnerConfig] -> ShowS
show :: RunnerConfig -> String
$cshow :: RunnerConfig -> String
showsPrec :: Int -> RunnerConfig -> ShowS
$cshowsPrec :: Int -> RunnerConfig -> ShowS
Show, RunnerConfig -> Q Exp
RunnerConfig -> Q (TExp RunnerConfig)
(RunnerConfig -> Q Exp)
-> (RunnerConfig -> Q (TExp RunnerConfig)) -> Lift RunnerConfig
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: RunnerConfig -> Q (TExp RunnerConfig)
$cliftTyped :: RunnerConfig -> Q (TExp RunnerConfig)
lift :: RunnerConfig -> Q Exp
$clift :: RunnerConfig -> Q Exp
Lift)

findM :: Monad m => [a] -> b -> (a -> m (Maybe b)) -> m b
findM :: [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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return b
x

isFailure :: NodeT m (Maybe (Either x a, b)) -> Bool
isFailure :: 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 :: 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 :: 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
  NodeT m (Maybe (Either x a, b))
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 ShrinkRetries
n ShrinkRetries -> ShrinkRetries -> Bool
forall a. Ord a => a -> a -> Bool
> ShrinkRetries
0 Bool -> Bool -> Bool
&& NodeT m (Maybe (Either x a, b)) -> Bool
forall (m :: * -> *) x a b. NodeT m (Maybe (Either x a, b)) -> Bool
isSuccess NodeT m (Maybe (Either x a, b))
o then
    ShrinkRetries
-> TreeT m (Maybe (Either x a, b))
-> m (NodeT m (Maybe (Either x a, b)))
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 ShrinkRetries -> ShrinkRetries -> ShrinkRetries
forall a. Num a => a -> a -> a
- ShrinkRetries
1) TreeT m (Maybe (Either x a, b))
m
  else
    NodeT m (Maybe (Either x a, b))
-> m (NodeT m (Maybe (Either x a, b)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeT m (Maybe (Either x a, b))
o

takeSmallest ::
     MonadIO m
  => Size
  -> Seed
  -> ShrinkCount
  -> ShrinkLimit
  -> ShrinkRetries
  -> (Progress -> m ())
  -> NodeT m (Maybe (Either Failure (), Journal))
  -> m Result
takeSmallest :: Size
-> Seed
-> ShrinkCount
-> ShrinkLimit
-> ShrinkRetries
-> (Progress -> m ())
-> NodeT m (Maybe (Either Failure (), Journal))
-> m Result
takeSmallest Size
size Seed
seed ShrinkCount
shrinks ShrinkLimit
slimit ShrinkRetries
retries Progress -> m ()
updateUI = \case
  NodeT Maybe (Either Failure (), Journal)
Nothing [TreeT m (Maybe (Either Failure (), Journal))]
_ ->
    Result -> m Result
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
          failure :: FailureReport
failure =
            Size
-> Seed
-> ShrinkCount
-> Maybe (Coverage CoverCount)
-> Maybe Span
-> String
-> Maybe Diff
-> [Log]
-> FailureReport
mkFailure Size
size Seed
seed ShrinkCount
shrinks 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 (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
          [TreeT m (Maybe (Either Failure (), Journal))]
-> Result
-> (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 [TreeT m (Maybe (Either Failure (), Journal))]
xs (FailureReport -> Result
Failed FailureReport
failure) ((TreeT m (Maybe (Either Failure (), Journal)) -> m (Maybe Result))
 -> m Result)
-> (TreeT m (Maybe (Either Failure (), Journal))
    -> m (Maybe Result))
-> m Result
forall a b. (a -> b) -> a -> b
$ \TreeT m (Maybe (Either Failure (), Journal))
m -> do
            NodeT m (Maybe (Either Failure (), Journal))
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 NodeT m (Maybe (Either Failure (), Journal)) -> Bool
forall (m :: * -> *) x a b. NodeT m (Maybe (Either x a, b)) -> Bool
isFailure NodeT m (Maybe (Either Failure (), Journal))
o then
              Result -> Maybe Result
forall a. a -> Maybe a
Just (Result -> Maybe Result) -> m Result -> m (Maybe Result)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Size
-> Seed
-> ShrinkCount
-> ShrinkLimit
-> ShrinkRetries
-> (Progress -> m ())
-> NodeT m (Maybe (Either Failure (), Journal))
-> m Result
forall (m :: * -> *).
MonadIO m =>
Size
-> Seed
-> ShrinkCount
-> ShrinkLimit
-> ShrinkRetries
-> (Progress -> m ())
-> NodeT m (Maybe (Either Failure (), Journal))
-> m Result
takeSmallest Size
size Seed
seed (ShrinkCount
shrinks ShrinkCount -> ShrinkCount -> ShrinkCount
forall a. Num a => a -> a -> a
+ ShrinkCount
1) ShrinkLimit
slimit ShrinkRetries
retries Progress -> m ()
updateUI NodeT m (Maybe (Either Failure (), Journal))
o
            else
              Maybe Result -> m (Maybe Result)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Result
forall a. Maybe a
Nothing

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

checkReport ::
     forall m.
     MonadIO m
  => MonadCatch m
  => PropertyConfig
  -> Size
  -> Seed
  -> PropertyT m ()
  -> (Report Progress -> m ())
  -> m (Report Result)
checkReport :: 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 =
  let
    test :: PropertyT m ()
test =
      PropertyT m ()
-> (SomeException -> PropertyT m ()) -> PropertyT m ()
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
catchAll PropertyT m ()
test0 (String -> PropertyT m ()
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 :: TerminationCriteria
terminationCriteria =
      PropertyConfig -> TerminationCriteria
propertyTerminationCriteria PropertyConfig
cfg

    (Maybe Confidence
confidence, TestLimit
minTests) =
      case TerminationCriteria
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 -> Coverage CoverCount -> Bool
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 -> Coverage CoverCount -> Bool
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
-> 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
-> Progress
-> Report Progress
forall a.
TestCount -> DiscardCount -> Coverage CoverCount -> a -> Report a
Report TestCount
tests DiscardCount
discards Coverage CoverCount
coverage0 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 -> Result -> Report Result
forall a.
TestCount -> DiscardCount -> Coverage CoverCount -> a -> Report a
Report TestCount
tests DiscardCount
discards Coverage CoverCount
coverage0 Result
OK

        failureReport :: String -> Report Result
failureReport String
message =
          TestCount
-> DiscardCount -> Coverage CoverCount -> Result -> Report Result
forall a.
TestCount -> DiscardCount -> Coverage CoverCount -> a -> Report a
Report TestCount
tests DiscardCount
discards Coverage CoverCount
coverage0 (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
$ Size
-> Seed
-> ShrinkCount
-> Maybe (Coverage CoverCount)
-> Maybe Span
-> String
-> Maybe Diff
-> [Log]
-> FailureReport
mkFailure
            Size
size
            Seed
seed
            ShrinkCount
0
            (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
        Report Result -> m (Report Result)
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 sufficently 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 (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 -> Result -> Report Result
forall a.
TestCount -> DiscardCount -> Coverage CoverCount -> a -> Report a
Report TestCount
tests DiscardCount
discards Coverage CoverCount
coverage0 Result
GaveUp

      else
        case Seed -> (Seed, Seed)
Seed.split Seed
seed of
          (Seed
s0, Seed
s1) -> do
            node :: NodeT m (Maybe (Either Failure (), Journal))
node@(NodeT Maybe (Either Failure (), Journal)
x [TreeT m (Maybe (Either Failure (), Journal))]
_) <-
              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 Maybe (Either Failure (), Journal)
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 -> a -> Report a
forall a.
TestCount -> DiscardCount -> Coverage CoverCount -> a -> Report a
Report (TestCount
tests TestCount -> TestCount -> TestCount
forall a. Num a => a -> a -> a
+ TestCount
1) DiscardCount
discards Coverage CoverCount
coverage0
                in
                  (Result -> Report Result) -> m Result -> m (Report Result)
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
$
                    Size
-> Seed
-> ShrinkCount
-> ShrinkLimit
-> ShrinkRetries
-> (Progress -> m ())
-> NodeT m (Maybe (Either Failure (), Journal))
-> m Result
forall (m :: * -> *).
MonadIO m =>
Size
-> Seed
-> ShrinkCount
-> ShrinkLimit
-> ShrinkRetries
-> (Progress -> m ())
-> NodeT m (Maybe (Either Failure (), Journal))
-> m Result
takeSmallest
                      Size
size
                      Seed
seed
                      ShrinkCount
0
                      (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
  in
    TestCount
-> DiscardCount
-> Size
-> Seed
-> Coverage CoverCount
-> m (Report Result)
loop TestCount
0 DiscardCount
0 Size
size0 Seed
seed0 Coverage CoverCount
forall a. Monoid a => a
mempty

checkRegion ::
     MonadIO m
  => Region
  -> UseColor
  -> Maybe PropertyName
  -> Size
  -> Seed
  -> Property
  -> m (Report Result)
checkRegion :: 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 (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
    Report Result
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
        String
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 Report Progress -> Progress
forall a. Report a -> a
reportStatus Report Progress
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

    String
ppresult <- UseColor -> Maybe PropertyName -> Report Result -> IO String
forall (m :: * -> *).
MonadIO m =>
UseColor -> Maybe PropertyName -> Report Result -> m String
renderResult UseColor
color Maybe PropertyName
name Report Result
result
    case Report Result -> Result
forall a. Report a -> a
reportStatus Report Result
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

    Report Result -> IO (Report Result)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Report Result
result

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

-- | Check a property.
--
check :: MonadIO m => Property -> m Bool
check :: Property -> m Bool
check Property
prop = do
  UseColor
color <- m UseColor
forall (m :: * -> *). MonadIO m => m UseColor
detectColor
  IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool)
-> ((Region -> IO Bool) -> IO Bool)
-> (Region -> IO Bool)
-> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Region -> IO Bool) -> IO Bool
forall (m :: * -> *) a.
(MonadIO m, MonadMask m, LiftRegion m) =>
(Region -> m a) -> m a
displayRegion ((Region -> IO Bool) -> m Bool) -> (Region -> IO Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ \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 -> Property -> IO (Report Result)
forall (m :: * -> *).
MonadIO m =>
Region
-> UseColor -> Maybe PropertyName -> Property -> m (Report Result)
checkNamed Region
region UseColor
color Maybe PropertyName
forall a. Maybe a
Nothing Property
prop

-- | Check a property using a specific size and seed.
--
recheck :: MonadIO m => Size -> Seed -> Property -> m ()
recheck :: Size -> Seed -> Property -> m ()
recheck Size
size Seed
seed Property
prop0 = do
  UseColor
color <- m UseColor
forall (m :: * -> *). MonadIO m => m UseColor
detectColor
  let prop :: Property
prop = TestLimit -> Property -> Property
withTests TestLimit
1 Property
prop0
  Report Result
_ <- IO (Report Result) -> m (Report Result)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Report Result) -> m (Report Result))
-> ((Region -> IO (Report Result)) -> IO (Report Result))
-> (Region -> IO (Report Result))
-> m (Report Result)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Region -> IO (Report Result)) -> IO (Report Result)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m, LiftRegion m) =>
(Region -> m a) -> m a
displayRegion ((Region -> IO (Report Result)) -> m (Report Result))
-> (Region -> IO (Report Result)) -> m (Report Result)
forall a b. (a -> b) -> a -> b
$ \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
  () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Check a group of properties using the specified runner config.
--
checkGroup :: MonadIO m => RunnerConfig -> Group -> m Bool
checkGroup :: RunnerConfig -> Group -> m Bool
checkGroup RunnerConfig
config (Group GroupName
group [(PropertyName, Property)]
props) =
  IO Bool -> m Bool
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
    WorkerCount
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.
    WorkerCount -> IO ()
updateNumCapabilities (WorkerCount
n WorkerCount -> WorkerCount -> WorkerCount
forall a. Num a => a -> a -> a
+ WorkerCount
2)

#if mingw32_HOST_OS
    hSetEncoding stdout utf8
    hSetEncoding stderr utf8
#endif

    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"━━━ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ GroupName -> String
unGroupName GroupName
group String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ━━━"

    Verbosity
verbosity <- Maybe Verbosity -> IO Verbosity
forall (m :: * -> *). MonadIO m => Maybe Verbosity -> m Verbosity
resolveVerbosity (RunnerConfig -> Maybe Verbosity
runnerVerbosity RunnerConfig
config)
    UseColor
color <- Maybe UseColor -> IO UseColor
forall (m :: * -> *). MonadIO m => Maybe UseColor -> m UseColor
resolveColor (RunnerConfig -> Maybe UseColor
runnerColor RunnerConfig
config)
    Summary
summary <- WorkerCount
-> Verbosity
-> UseColor
-> [(PropertyName, Property)]
-> IO Summary
checkGroupWith WorkerCount
n Verbosity
verbosity UseColor
color [(PropertyName, Property)]
props

    Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$
      Summary -> PropertyCount
summaryFailed Summary
summary PropertyCount -> PropertyCount -> Bool
forall a. Eq a => a -> a -> Bool
== PropertyCount
0 Bool -> Bool -> Bool
&&
      Summary -> PropertyCount
summaryGaveUp Summary
summary PropertyCount -> PropertyCount -> Bool
forall a. Eq a => a -> a -> Bool
== PropertyCount
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
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 (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)
  Region -> String -> IO ()
forall (m :: * -> *). LiftRegion m => Region -> String -> m ()
setRegion Region
sregion (String -> IO ()) -> IO String -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< UseColor -> Summary -> IO String
forall (m :: * -> *). MonadIO m => UseColor -> Summary -> m String
renderSummary UseColor
color Summary
summary

checkGroupWith ::
     WorkerCount
  -> Verbosity
  -> UseColor
  -> [(PropertyName, Property)]
  -> IO Summary
checkGroupWith :: WorkerCount
-> Verbosity
-> UseColor
-> [(PropertyName, Property)]
-> IO Summary
checkGroupWith WorkerCount
n Verbosity
verbosity UseColor
color [(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
    TVar Summary
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
summaryWaiting = Int -> PropertyCount
PropertyCount ([(PropertyName, Property)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(PropertyName, Property)]
props) }

    let
      start :: TasksRemaining -> p -> (a, b) -> m (a, b, Region)
start (TasksRemaining Int
tasks) p
_ix (a
name, b
prop) =
        IO (a, b, Region) -> m (a, b, Region)
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
summaryWaiting =
                Int -> PropertyCount
PropertyCount Int
tasks
            , summaryRunning :: PropertyCount
summaryRunning =
                Summary -> PropertyCount
summaryRunning Summary
x PropertyCount -> PropertyCount -> PropertyCount
forall a. Num a => a -> a -> a
+ PropertyCount
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
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

            Region -> STM ()
moveToBottom Region
sregion

            (a, b, Region) -> STM (a, b, Region)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
name, b
prop, Region
region)

      finish :: (a, b, c) -> IO ()
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 :: PropertyCount
summaryRunning =
              Summary -> PropertyCount
summaryRunning Summary
x PropertyCount -> PropertyCount -> PropertyCount
forall a. Num a => a -> a -> a
- PropertyCount
1
          }

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

    Summary
summary <-
      ([Report Result] -> Summary) -> IO [Report Result] -> IO Summary
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Summary] -> Summary
forall a. Monoid a => [a] -> a
mconcat ([Summary] -> Summary)
-> ([Report Result] -> [Summary]) -> [Report Result] -> Summary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Report Result -> Summary) -> [Report Result] -> [Summary]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Result -> Summary
fromResult (Result -> Summary)
-> (Report Result -> Result) -> Report Result -> Summary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Report Result -> Result
forall a. Report a -> a
reportStatus)) (IO [Report Result] -> IO Summary)
-> IO [Report Result] -> IO Summary
forall a b. (a -> b) -> a -> b
$
        WorkerCount
-> [(PropertyName, Property)]
-> (TasksRemaining
    -> TaskIndex
    -> (PropertyName, Property)
    -> IO (PropertyName, Property, Region))
-> ((PropertyName, Property, Region) -> IO ())
-> ((PropertyName, Property, Region) -> IO ())
-> ((PropertyName, Property, Region) -> IO (Report Result))
-> IO [Report Result]
forall a b c.
WorkerCount
-> [a]
-> (TasksRemaining -> TaskIndex -> a -> IO b)
-> (b -> IO ())
-> (b -> IO ())
-> (b -> IO c)
-> IO [c]
runTasks WorkerCount
n [(PropertyName, Property)]
props TasksRemaining
-> TaskIndex
-> (PropertyName, Property)
-> IO (PropertyName, Property, Region)
forall (m :: * -> *) p a b.
MonadIO m =>
TasksRemaining -> p -> (a, b) -> m (a, b, Region)
start (PropertyName, Property, Region) -> IO ()
forall a b c. (a, b, c) -> IO ()
finish (PropertyName, Property, Region) -> IO ()
forall (m :: * -> *) a b. LiftRegion m => (a, b, Region) -> m ()
finalize (((PropertyName, Property, Region) -> IO (Report Result))
 -> IO [Report Result])
-> ((PropertyName, Property, Region) -> IO (Report Result))
-> IO [Report Result]
forall a b. (a -> b) -> a -> b
$ \(PropertyName
name, Property
prop, Region
region) -> do
          Report Result
result <- Region
-> UseColor -> Maybe PropertyName -> Property -> IO (Report Result)
forall (m :: * -> *).
MonadIO m =>
Region
-> UseColor -> Maybe PropertyName -> Property -> m (Report Result)
checkNamed Region
region UseColor
color (PropertyName -> Maybe PropertyName
forall a. a -> Maybe a
Just PropertyName
name) Property
prop
          Region -> TVar Summary -> UseColor -> (Summary -> Summary) -> IO ()
updateSummary Region
sregion TVar Summary
svar UseColor
color
            (Summary -> Summary -> Summary
forall a. Semigroup a => a -> a -> a
<> Result -> Summary
fromResult (Report Result -> Result
forall a. Report a -> a
reportStatus Report Result
result))
          Report Result -> IO (Report Result)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Report Result
result

    Region -> TVar Summary -> UseColor -> (Summary -> Summary) -> IO ()
updateSummary Region
sregion TVar Summary
svar UseColor
color (Summary -> Summary -> Summary
forall a b. a -> b -> a
const Summary
summary)
    Summary -> IO Summary
forall (f :: * -> *) a. Applicative f => a -> f a
pure Summary
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 :: Group -> m Bool
checkSequential =
  RunnerConfig -> Group -> m Bool
forall (m :: * -> *). MonadIO m => RunnerConfig -> Group -> m Bool
checkGroup
    RunnerConfig :: Maybe WorkerCount
-> Maybe UseColor -> Maybe Verbosity -> RunnerConfig
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
      , 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 :: Group -> m Bool
checkParallel =
  RunnerConfig -> Group -> m Bool
forall (m :: * -> *). MonadIO m => RunnerConfig -> Group -> m Bool
checkGroup
    RunnerConfig :: Maybe WorkerCount
-> Maybe UseColor -> Maybe Verbosity -> RunnerConfig
RunnerConfig {
        runnerWorkers :: Maybe WorkerCount
runnerWorkers =
          Maybe WorkerCount
forall a. Maybe a
Nothing
      , runnerColor :: Maybe UseColor
runnerColor =
          Maybe UseColor
forall a. Maybe a
Nothing
      , runnerVerbosity :: Maybe Verbosity
runnerVerbosity =
          Maybe Verbosity
forall a. Maybe a
Nothing
      }