{-# 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.Monad.Catch (MonadCatch(..), catchAll)
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
/= :: 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
  => ShrinkCount
  -> ShrinkPath
  -> ShrinkLimit
  -> ShrinkRetries
  -> (Progress -> m ())
  -> NodeT m (Maybe (Either Failure (), Journal))
  -> m Result
takeSmallest :: 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 (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 (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
                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
<$> ShrinkCount
-> [Int]
-> NodeT m (Maybe (Either Failure (), Journal))
-> m Result
loop (ShrinkCount
shrinks ShrinkCount -> ShrinkCount -> ShrinkCount
forall a. Num a => a -> a -> a
+ ShrinkCount
1) (Int
n Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
revShrinkPath) 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
  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 :: 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 (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 (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 (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 (f :: * -> *) a. Applicative f => a -> f a
pure Result
GaveUp
          (TreeT m (Maybe (Either Failure (), Journal))
x:[TreeT m (Maybe (Either Failure (), Journal))]
_) -> do
            NodeT m (Maybe (Either Failure (), Journal))
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
            ShrinkCount
-> [Int]
-> NodeT m (Maybe (Either Failure (), Journal))
-> m Result
loop (ShrinkCount
shrinks ShrinkCount -> ShrinkCount -> ShrinkCount
forall a. Num a => a -> a -> a
+ ShrinkCount
1) [Int]
ss NodeT m (Maybe (Either Failure (), Journal))
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 :: 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
skip <- IO Skip -> m Skip
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
    (Maybe TestCount
mSkipToTest, Maybe ShrinkPath
mSkipToShrink) =
      case Skip
skip of
        Skip
SkipNothing ->
          (Maybe TestCount
forall a. Maybe a
Nothing, Maybe ShrinkPath
forall a. Maybe a
Nothing)
        SkipToTest TestCount
t ->
          (TestCount -> Maybe TestCount
forall a. a -> Maybe a
Just TestCount
t, Maybe ShrinkPath
forall a. Maybe a
Nothing)
        SkipToShrink TestCount
t ShrinkPath
s ->
          (TestCount -> Maybe TestCount
forall a. a -> Maybe a
Just TestCount
t, ShrinkPath -> Maybe ShrinkPath
forall a. a -> Maybe a
Just ShrinkPath
s)

    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
-> 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 -> Bool
forall a. Maybe a -> Bool
isJust Maybe TestCount
mSkipToTest then
          Report Result -> m (Report Result)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Report Result
successReport
        else
          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
-> 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
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, 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
            (Just TestCount
_, Just ShrinkPath
shrinkPath) -> do
              NodeT m (Maybe (Either Failure (), Journal))
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 :: 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
              Result -> Report Result
forall a. a -> Report a
mkReport (Result -> Report Result) -> m Result -> m (Report Result)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ShrinkPath
-> (Progress -> m ())
-> NodeT m (Maybe (Either Failure (), Journal))
-> m Result
forall (m :: * -> *).
MonadIO m =>
ShrinkPath
-> (Progress -> m ())
-> NodeT m (Maybe (Either Failure (), Journal))
-> m Result
skipToShrink ShrinkPath
shrinkPath (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
            (Maybe TestCount, Maybe ShrinkPath)
_ -> 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 -> 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 (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

  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
  -> Maybe Seed
  -> Property
  -> m (Report Result)
checkNamed :: 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
seed <- Maybe Seed -> m Seed
forall (m :: * -> *). MonadIO m => Maybe Seed -> m Seed
resolveSeed Maybe Seed
mseed
  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
-> 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 :: 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 ()

recheckAt :: MonadIO m => Seed -> Skip -> Property -> m ()
recheckAt :: Seed -> Skip -> Property -> m ()
recheckAt Seed
seed Skip
skip Property
prop0 = do
  UseColor
color <- m UseColor
forall (m :: * -> *). MonadIO m => m UseColor
detectColor
  let prop :: Property
prop = Skip -> Property -> Property
withSkip Skip
skip 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
0 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
" ━━━"

    Seed
seed <- Maybe Seed -> IO Seed
forall (m :: * -> *). MonadIO m => Maybe Seed -> m Seed
resolveSeed (RunnerConfig -> Maybe Seed
runnerSeed RunnerConfig
config)
    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
-> Seed
-> [(PropertyName, Property)]
-> IO Summary
checkGroupWith WorkerCount
n Verbosity
verbosity UseColor
color Seed
seed [(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
  -> 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
    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
-> 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
          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 Seed -> 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
      , 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 :: Group -> m Bool
checkParallel =
  RunnerConfig -> Group -> m Bool
forall (m :: * -> *). MonadIO m => RunnerConfig -> Group -> m Bool
checkGroup
    RunnerConfig :: Maybe WorkerCount
-> Maybe UseColor -> Maybe Seed -> 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
      , runnerSeed :: Maybe Seed
runnerSeed =
          Maybe Seed
forall a. Maybe a
Nothing
      , runnerVerbosity :: Maybe Verbosity
runnerVerbosity =
          Maybe Verbosity
forall a. Maybe a
Nothing
      }