{-# OPTIONS_HADDOCK hide #-}
-- | The main test loop.
{-# LANGUAGE CPP #-}
#ifndef NO_TYPEABLE
{-# LANGUAGE DeriveDataTypeable #-}
#endif
#ifndef NO_SAFE_HASKELL
{-# LANGUAGE Trustworthy #-}
#endif
module Test.QuickCheck.Test where

--------------------------------------------------------------------------
-- imports

import Test.QuickCheck.Gen
import Test.QuickCheck.Property hiding ( Result( reason, theException, labels, classes, tables ), (.&.) )
import qualified Test.QuickCheck.Property as P
import Test.QuickCheck.Text
import Test.QuickCheck.State hiding (labels, classes, tables, requiredCoverage)
import qualified Test.QuickCheck.State as S
import Test.QuickCheck.Exception
import Test.QuickCheck.Random
import System.Random(split)
#if defined(MIN_VERSION_containers)
#if MIN_VERSION_containers(0,5,0)
import qualified Data.Map.Strict as Map
#else
import qualified Data.Map as Map
#endif
#else
import qualified Data.Map as Map
#endif
import qualified Data.Set as Set
import Data.Set(Set)
import Data.Map(Map)

import Data.Char
  ( isSpace
  )

import Data.List
  ( sort
  , sortBy
  , group
  , intersperse
  )

import Data.Maybe(fromMaybe, isNothing, catMaybes)
import Data.Ord(comparing)
import Text.Printf(printf)
import Control.Monad
import Data.Bits

#ifndef NO_TYPEABLE
import Data.Typeable (Typeable)
#endif

--------------------------------------------------------------------------
-- quickCheck

-- * Running tests

-- | Args specifies arguments to the QuickCheck driver
data Args
  = Args
  { Args -> Maybe (QCGen, Int)
replay          :: Maybe (QCGen,Int)
    -- ^ Should we replay a previous test?
    -- Note: saving a seed from one version of QuickCheck and
    -- replaying it in another is not supported.
    -- If you want to store a test case permanently you should save
    -- the test case itself.
  , Args -> Int
maxSuccess      :: Int
    -- ^ Maximum number of successful tests before succeeding. Testing stops
    -- at the first failure. If all tests are passing and you want to run more tests,
    -- increase this number.
  , Args -> Int
maxDiscardRatio :: Int
    -- ^ Maximum number of discarded tests per successful test before giving up
  , Args -> Int
maxSize         :: Int
    -- ^ Size to use for the biggest test cases
  , Args -> Bool
chatty          :: Bool
    -- ^ Whether to print anything
  , Args -> Int
maxShrinks      :: Int
    -- ^ Maximum number of shrinks to before giving up. Setting this to zero
    --   turns shrinking off.
  }
 deriving ( Int -> Args -> ShowS
[Args] -> ShowS
Args -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Args] -> ShowS
$cshowList :: [Args] -> ShowS
show :: Args -> String
$cshow :: Args -> String
showsPrec :: Int -> Args -> ShowS
$cshowsPrec :: Int -> Args -> ShowS
Show, ReadPrec [Args]
ReadPrec Args
Int -> ReadS Args
ReadS [Args]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Args]
$creadListPrec :: ReadPrec [Args]
readPrec :: ReadPrec Args
$creadPrec :: ReadPrec Args
readList :: ReadS [Args]
$creadList :: ReadS [Args]
readsPrec :: Int -> ReadS Args
$creadsPrec :: Int -> ReadS Args
Read
#ifndef NO_TYPEABLE
  , Typeable
#endif
  )

-- | Result represents the test result
data Result
  -- | A successful test run
  = Success
    { Result -> Int
numTests     :: Int
      -- ^ Number of tests performed
    , Result -> Int
numDiscarded :: Int
      -- ^ Number of tests skipped
    , Result -> Map [String] Int
labels       :: !(Map [String] Int)
      -- ^ The number of test cases having each combination of labels (see 'label')
    , Result -> Map String Int
classes      :: !(Map String Int)
      -- ^ The number of test cases having each class (see 'classify')
    , Result -> Map String (Map String Int)
tables       :: !(Map String (Map String Int))
      -- ^ Data collected by 'tabulate'
    , Result -> String
output       :: String
      -- ^ Printed output
    }
  -- | Given up
  | GaveUp
    { numTests     :: Int
    , numDiscarded :: Int
      -- ^ Number of tests skipped
    , labels       :: !(Map [String] Int)
    , classes      :: !(Map String Int)
    , tables       :: !(Map String (Map String Int))
    , output       :: String
    }
  -- | A failed test run
  | Failure
    { numTests        :: Int
    , numDiscarded    :: Int
      -- ^ Number of tests skipped
    , Result -> Int
numShrinks      :: Int
      -- ^ Number of successful shrinking steps performed
    , Result -> Int
numShrinkTries  :: Int
      -- ^ Number of unsuccessful shrinking steps performed
    , Result -> Int
numShrinkFinal  :: Int
      -- ^ Number of unsuccessful shrinking steps performed since last successful shrink
    , Result -> QCGen
usedSeed        :: QCGen
      -- ^ What seed was used
    , Result -> Int
usedSize        :: Int
      -- ^ What was the test size
    , Result -> String
reason          :: String
      -- ^ Why did the property fail
    , Result -> Maybe AnException
theException    :: Maybe AnException
      -- ^ The exception the property threw, if any
    , output          :: String
    , Result -> [String]
failingTestCase :: [String]
      -- ^ The test case which provoked the failure
    , Result -> [String]
failingLabels   :: [String]
      -- ^ The test case's labels (see 'label')
    , Result -> Set String
failingClasses  :: Set String
      -- ^ The test case's classes (see 'classify')
    }
  -- | A property that should have failed did not
  | NoExpectedFailure
    { numTests     :: Int
    , numDiscarded :: Int
      -- ^ Number of tests skipped
    , labels       :: !(Map [String] Int)
    , classes      :: !(Map String Int)
    , tables       :: !(Map String (Map String Int))
    , output       :: String
    }
 deriving ( Int -> Result -> ShowS
[Result] -> ShowS
Result -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Result] -> ShowS
$cshowList :: [Result] -> ShowS
show :: Result -> String
$cshow :: Result -> String
showsPrec :: Int -> Result -> ShowS
$cshowsPrec :: Int -> Result -> ShowS
Show )

-- | Check if the test run result was a success
isSuccess :: Result -> Bool
isSuccess :: Result -> Bool
isSuccess Success{} = Bool
True
isSuccess Result
_         = Bool
False

-- | The default test arguments
stdArgs :: Args
stdArgs :: Args
stdArgs = Args
  { replay :: Maybe (QCGen, Int)
replay          = forall a. Maybe a
Nothing
  , maxSuccess :: Int
maxSuccess      = Int
100
  , maxDiscardRatio :: Int
maxDiscardRatio = Int
10
  , maxSize :: Int
maxSize         = Int
100
  , chatty :: Bool
chatty          = Bool
True
  , maxShrinks :: Int
maxShrinks      = forall a. Bounded a => a
maxBound
  }

-- | Tests a property and prints the results to 'stdout'.
--
-- By default up to 100 tests are performed, which may not be enough
-- to find all bugs. To run more tests, use 'withMaxSuccess'.
--
-- If you want to get the counterexample as a Haskell value,
-- rather than just printing it, try the
-- <http://hackage.haskell.org/package/quickcheck-with-counterexamples quickcheck-with-counterexamples>
-- package.

quickCheck :: Testable prop => prop -> IO ()
quickCheck :: forall prop. Testable prop => prop -> IO ()
quickCheck prop
p = forall prop. Testable prop => Args -> prop -> IO ()
quickCheckWith Args
stdArgs prop
p

-- | Tests a property, using test arguments, and prints the results to 'stdout'.
quickCheckWith :: Testable prop => Args -> prop -> IO ()
quickCheckWith :: forall prop. Testable prop => Args -> prop -> IO ()
quickCheckWith Args
args prop
p = forall prop. Testable prop => Args -> prop -> IO Result
quickCheckWithResult Args
args prop
p forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Tests a property, produces a test result, and prints the results to 'stdout'.
quickCheckResult :: Testable prop => prop -> IO Result
quickCheckResult :: forall prop. Testable prop => prop -> IO Result
quickCheckResult prop
p = forall prop. Testable prop => Args -> prop -> IO Result
quickCheckWithResult Args
stdArgs prop
p

-- | Tests a property, using test arguments, produces a test result, and prints the results to 'stdout'.
quickCheckWithResult :: Testable prop => Args -> prop -> IO Result
quickCheckWithResult :: forall prop. Testable prop => Args -> prop -> IO Result
quickCheckWithResult Args
a prop
p =
  forall a. Args -> (State -> IO a) -> IO a
withState Args
a (\State
s -> State -> Property -> IO Result
test State
s (forall prop. Testable prop => prop -> Property
property prop
p))

withState :: Args -> (State -> IO a) -> IO a
withState :: forall a. Args -> (State -> IO a) -> IO a
withState Args
a State -> IO a
test = (if Args -> Bool
chatty Args
a then forall a. (Terminal -> IO a) -> IO a
withStdioTerminal else forall a. (Terminal -> IO a) -> IO a
withNullTerminal) forall a b. (a -> b) -> a -> b
$ \Terminal
tm -> do
     QCGen
rnd <- case Args -> Maybe (QCGen, Int)
replay Args
a of
              Maybe (QCGen, Int)
Nothing      -> IO QCGen
newQCGen
              Just (QCGen
rnd,Int
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return QCGen
rnd
     State -> IO a
test MkState{ terminal :: Terminal
terminal                  = Terminal
tm
                 , maxSuccessTests :: Int
maxSuccessTests           = Args -> Int
maxSuccess Args
a
                 , coverageConfidence :: Maybe Confidence
coverageConfidence        = forall a. Maybe a
Nothing
                 , maxDiscardedRatio :: Int
maxDiscardedRatio         = Args -> Int
maxDiscardRatio Args
a
                 , computeSize :: Int -> Int -> Int
computeSize               = case Args -> Maybe (QCGen, Int)
replay Args
a of
                                                 Maybe (QCGen, Int)
Nothing    -> Int -> Int -> Int
computeSize'
                                                 Just (QCGen
_,Int
s) -> Int -> Int -> Int
computeSize' forall {t} {t} {p}.
(Eq t, Eq t, Num t, Num t) =>
(t -> t -> p) -> p -> t -> t -> p
`at0` Int
s
                 , numTotMaxShrinks :: Int
numTotMaxShrinks          = Args -> Int
maxShrinks Args
a
                 , numSuccessTests :: Int
numSuccessTests           = Int
0
                 , numDiscardedTests :: Int
numDiscardedTests         = Int
0
                 , numRecentlyDiscardedTests :: Int
numRecentlyDiscardedTests = Int
0
                 , labels :: Map [String] Int
S.labels                  = forall k a. Map k a
Map.empty
                 , classes :: Map String Int
S.classes                 = forall k a. Map k a
Map.empty
                 , tables :: Map String (Map String Int)
S.tables                  = forall k a. Map k a
Map.empty
                 , requiredCoverage :: Map (Maybe String, String) Double
S.requiredCoverage        = forall k a. Map k a
Map.empty
                 , expected :: Bool
expected                  = Bool
True
                 , randomSeed :: QCGen
randomSeed                = QCGen
rnd
                 , numSuccessShrinks :: Int
numSuccessShrinks         = Int
0
                 , numTryShrinks :: Int
numTryShrinks             = Int
0
                 , numTotTryShrinks :: Int
numTotTryShrinks          = Int
0
                 }
  where computeSize' :: Int -> Int -> Int
computeSize' Int
n Int
d
          -- e.g. with maxSuccess = 250, maxSize = 100, goes like this:
          -- 0, 1, 2, ..., 99, 0, 1, 2, ..., 99, 0, 2, 4, ..., 98.
          | Int
n forall {a}. Integral a => a -> a -> a
`roundTo` Args -> Int
maxSize Args
a forall a. Num a => a -> a -> a
+ Args -> Int
maxSize Args
a forall a. Ord a => a -> a -> Bool
<= Args -> Int
maxSuccess Args
a Bool -> Bool -> Bool
||
            Int
n forall a. Ord a => a -> a -> Bool
>= Args -> Int
maxSuccess Args
a Bool -> Bool -> Bool
||
            Args -> Int
maxSuccess Args
a forall {a}. Integral a => a -> a -> a
`mod` Args -> Int
maxSize Args
a forall a. Eq a => a -> a -> Bool
== Int
0 = (Int
n forall {a}. Integral a => a -> a -> a
`mod` Args -> Int
maxSize Args
a forall a. Num a => a -> a -> a
+ Int
d forall {a}. Integral a => a -> a -> a
`div` Int
10) forall a. Ord a => a -> a -> a
`min` Args -> Int
maxSize Args
a
          | Bool
otherwise =
            ((Int
n forall {a}. Integral a => a -> a -> a
`mod` Args -> Int
maxSize Args
a) forall a. Num a => a -> a -> a
* Args -> Int
maxSize Args
a forall {a}. Integral a => a -> a -> a
`div` (Args -> Int
maxSuccess Args
a forall {a}. Integral a => a -> a -> a
`mod` Args -> Int
maxSize Args
a) forall a. Num a => a -> a -> a
+ Int
d forall {a}. Integral a => a -> a -> a
`div` Int
10) forall a. Ord a => a -> a -> a
`min` Args -> Int
maxSize Args
a
        a
n roundTo :: a -> a -> a
`roundTo` a
m = (a
n forall {a}. Integral a => a -> a -> a
`div` a
m) forall a. Num a => a -> a -> a
* a
m
        at0 :: (t -> t -> p) -> p -> t -> t -> p
at0 t -> t -> p
f p
s t
0 t
0 = p
s
        at0 t -> t -> p
f p
s t
n t
d = t -> t -> p
f t
n t
d

-- | Tests a property and prints the results and all test cases generated to 'stdout'.
-- This is just a convenience function that means the same as @'quickCheck' . 'verbose'@.
--
-- Note: for technical reasons, the test case is printed out /after/
-- the property is tested. To debug a property that goes into an
-- infinite loop, use 'within' to add a timeout instead.
verboseCheck :: Testable prop => prop -> IO ()
verboseCheck :: forall prop. Testable prop => prop -> IO ()
verboseCheck prop
p = forall prop. Testable prop => prop -> IO ()
quickCheck (forall prop. Testable prop => prop -> Property
verbose prop
p)

-- | Tests a property, using test arguments, and prints the results and all test cases generated to 'stdout'.
-- This is just a convenience function that combines 'quickCheckWith' and 'verbose'.
--
-- Note: for technical reasons, the test case is printed out /after/
-- the property is tested. To debug a property that goes into an
-- infinite loop, use 'within' to add a timeout instead.
verboseCheckWith :: Testable prop => Args -> prop -> IO ()
verboseCheckWith :: forall prop. Testable prop => Args -> prop -> IO ()
verboseCheckWith Args
args prop
p = forall prop. Testable prop => Args -> prop -> IO ()
quickCheckWith Args
args (forall prop. Testable prop => prop -> Property
verbose prop
p)

-- | Tests a property, produces a test result, and prints the results and all test cases generated to 'stdout'.
-- This is just a convenience function that combines 'quickCheckResult' and 'verbose'.
--
-- Note: for technical reasons, the test case is printed out /after/
-- the property is tested. To debug a property that goes into an
-- infinite loop, use 'within' to add a timeout instead.
verboseCheckResult :: Testable prop => prop -> IO Result
verboseCheckResult :: forall prop. Testable prop => prop -> IO Result
verboseCheckResult prop
p = forall prop. Testable prop => prop -> IO Result
quickCheckResult (forall prop. Testable prop => prop -> Property
verbose prop
p)

-- | Tests a property, using test arguments, produces a test result, and prints the results and all test cases generated to 'stdout'.
-- This is just a convenience function that combines 'quickCheckWithResult' and 'verbose'.
--
-- Note: for technical reasons, the test case is printed out /after/
-- the property is tested. To debug a property that goes into an
-- infinite loop, use 'within' to add a timeout instead.
verboseCheckWithResult :: Testable prop => Args -> prop -> IO Result
verboseCheckWithResult :: forall prop. Testable prop => Args -> prop -> IO Result
verboseCheckWithResult Args
a prop
p = forall prop. Testable prop => Args -> prop -> IO Result
quickCheckWithResult Args
a (forall prop. Testable prop => prop -> Property
verbose prop
p)

--------------------------------------------------------------------------
-- main test loop

test :: State -> Property -> IO Result
test :: State -> Property -> IO Result
test State
st Property
f
  | State -> Int
numSuccessTests State
st   forall a. Ord a => a -> a -> Bool
>= State -> Int
maxSuccessTests State
st Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing (State -> Maybe Confidence
coverageConfidence State
st) =
    State -> Property -> IO Result
doneTesting State
st Property
f
  | State -> Int
numDiscardedTests State
st forall a. Ord a => a -> a -> Bool
>= State -> Int
maxDiscardedRatio State
st forall a. Num a => a -> a -> a
* forall a. Ord a => a -> a -> a
max (State -> Int
numSuccessTests State
st) (State -> Int
maxSuccessTests State
st) =
    State -> Property -> IO Result
giveUp State
st Property
f
  | Bool
otherwise =
    State -> Property -> IO Result
runATest State
st Property
f

doneTesting :: State -> Property -> IO Result
doneTesting :: State -> Property -> IO Result
doneTesting State
st Property
_f
  | State -> Bool
expected State
st forall a. Eq a => a -> a -> Bool
== Bool
False = do
      Terminal -> String -> IO ()
putPart (State -> Terminal
terminal State
st)
        ( ShowS
bold (String
"*** Failed!")
       forall a. [a] -> [a] -> [a]
++ String
" Passed "
       forall a. [a] -> [a] -> [a]
++ State -> String
showTestCount State
st
       forall a. [a] -> [a] -> [a]
++ String
" (expected failure)"
        )
      forall {b}.
(Int
 -> Int
 -> Map [String] Int
 -> Map String Int
 -> Map String (Map String Int)
 -> String
 -> b)
-> IO b
finished Int
-> Int
-> Map [String] Int
-> Map String Int
-> Map String (Map String Int)
-> String
-> Result
NoExpectedFailure
  | Bool
otherwise = do
      Terminal -> String -> IO ()
putPart (State -> Terminal
terminal State
st)
        ( String
"+++ OK, passed "
       forall a. [a] -> [a] -> [a]
++ State -> String
showTestCount State
st
        )
      forall {b}.
(Int
 -> Int
 -> Map [String] Int
 -> Map String Int
 -> Map String (Map String Int)
 -> String
 -> b)
-> IO b
finished Int
-> Int
-> Map [String] Int
-> Map String Int
-> Map String (Map String Int)
-> String
-> Result
Success
  where
    finished :: (Int
 -> Int
 -> Map [String] Int
 -> Map String Int
 -> Map String (Map String Int)
 -> String
 -> b)
-> IO b
finished Int
-> Int
-> Map [String] Int
-> Map String Int
-> Map String (Map String Int)
-> String
-> b
k = do
      State -> IO ()
success State
st
      String
theOutput <- Terminal -> IO String
terminalOutput (State -> Terminal
terminal State
st)
      forall (m :: * -> *) a. Monad m => a -> m a
return (Int
-> Int
-> Map [String] Int
-> Map String Int
-> Map String (Map String Int)
-> String
-> b
k (State -> Int
numSuccessTests State
st) (State -> Int
numDiscardedTests State
st) (State -> Map [String] Int
S.labels State
st) (State -> Map String Int
S.classes State
st) (State -> Map String (Map String Int)
S.tables State
st) String
theOutput)

giveUp :: State -> Property -> IO Result
giveUp :: State -> Property -> IO Result
giveUp State
st Property
_f =
  do -- CALLBACK gave_up?
     Terminal -> String -> IO ()
putPart (State -> Terminal
terminal State
st)
       ( ShowS
bold (String
"*** Gave up!")
      forall a. [a] -> [a] -> [a]
++ String
" Passed only "
      forall a. [a] -> [a] -> [a]
++ State -> String
showTestCount State
st
      forall a. [a] -> [a] -> [a]
++ String
" tests"
       )
     State -> IO ()
success State
st
     String
theOutput <- Terminal -> IO String
terminalOutput (State -> Terminal
terminal State
st)
     forall (m :: * -> *) a. Monad m => a -> m a
return GaveUp{ numTests :: Int
numTests     = State -> Int
numSuccessTests State
st
                  , numDiscarded :: Int
numDiscarded = State -> Int
numDiscardedTests State
st
                  , labels :: Map [String] Int
labels       = State -> Map [String] Int
S.labels State
st
                  , classes :: Map String Int
classes      = State -> Map String Int
S.classes State
st
                  , tables :: Map String (Map String Int)
tables       = State -> Map String (Map String Int)
S.tables State
st
                  , output :: String
output       = String
theOutput
                  }

showTestCount :: State -> String
showTestCount :: State -> String
showTestCount State
st =
     Int -> ShowS
number (State -> Int
numSuccessTests State
st) String
"test"
  forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"; " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (State -> Int
numDiscardedTests State
st) forall a. [a] -> [a] -> [a]
++ String
" discarded"
            | State -> Int
numDiscardedTests State
st forall a. Ord a => a -> a -> Bool
> Int
0
            ]

runATest :: State -> Property -> IO Result
runATest :: State -> Property -> IO Result
runATest State
st Property
f =
  do -- CALLBACK before_test
     Terminal -> String -> IO ()
putTemp (State -> Terminal
terminal State
st)
        ( String
"("
       forall a. [a] -> [a] -> [a]
++ State -> String
showTestCount State
st
       forall a. [a] -> [a] -> [a]
++ String
")"
        )
     let powerOfTwo :: a -> Bool
powerOfTwo a
n = a
n forall a. Bits a => a -> a -> a
.&. (a
n forall a. Num a => a -> a -> a
- a
1) forall a. Eq a => a -> a -> Bool
== a
0
     let f_or_cov :: Property
f_or_cov =
           case State -> Maybe Confidence
coverageConfidence State
st of
             Just Confidence
confidence | (Int
1 forall a. Num a => a -> a -> a
+ State -> Int
numSuccessTests State
st) forall {a}. Integral a => a -> a -> a
`mod` Int
100 forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& forall {a}. (Bits a, Num a) => a -> Bool
powerOfTwo ((Int
1 forall a. Num a => a -> a -> a
+ State -> Int
numSuccessTests State
st) forall {a}. Integral a => a -> a -> a
`div` Int
100) ->
               Confidence -> State -> Property -> Property
addCoverageCheck Confidence
confidence State
st Property
f
             Maybe Confidence
_ -> Property
f
     let size :: Int
size = State -> Int -> Int -> Int
computeSize State
st (State -> Int
numSuccessTests State
st) (State -> Int
numRecentlyDiscardedTests State
st)
     MkRose Result
res [Rose Result]
ts <- IO (Rose Result) -> IO (Rose Result)
protectRose (Rose Result -> IO (Rose Result)
reduceRose (Prop -> Rose Result
unProp (forall a. Gen a -> QCGen -> Int -> a
unGen (Property -> Gen Prop
unProperty Property
f_or_cov) QCGen
rnd1 Int
size)))
     Result
res <- State -> Result -> IO Result
callbackPostTest State
st Result
res

     let continue :: (State -> Property -> IO Result) -> State -> Property -> IO Result
continue State -> Property -> IO Result
break State
st' | Result -> Bool
abort Result
res = State -> Property -> IO Result
break State
st'
                            | Bool
otherwise = State -> Property -> IO Result
test State
st'

     let st' :: State
st' = State
st{ coverageConfidence :: Maybe Confidence
coverageConfidence = Result -> Maybe Confidence
maybeCheckCoverage Result
res forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` State -> Maybe Confidence
coverageConfidence State
st
                 , maxSuccessTests :: Int
maxSuccessTests = forall a. a -> Maybe a -> a
fromMaybe (State -> Int
maxSuccessTests State
st) (Result -> Maybe Int
maybeNumTests Result
res)
                 , labels :: Map [String] Int
S.labels = forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith forall a. Num a => a -> a -> a
(+) (Result -> [String]
P.labels Result
res) Int
1 (State -> Map [String] Int
S.labels State
st)
                 , classes :: Map String Int
S.classes = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Num a => a -> a -> a
(+) (State -> Map String Int
S.classes State
st) (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall a b. [a] -> [b] -> [(a, b)]
zip (Result -> [String]
P.classes Result
res) (forall a. a -> [a]
repeat Int
1)))
                 , tables :: Map String (Map String Int)
S.tables =
                   forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(String
tab, String
x) -> forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Num a => a -> a -> a
(+)) String
tab (forall k a. k -> a -> Map k a
Map.singleton String
x Int
1))
                     (State -> Map String (Map String Int)
S.tables State
st) (Result -> [(String, String)]
P.tables Result
res)
                 , requiredCoverage :: Map (Maybe String, String) Double
S.requiredCoverage =
                   forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Maybe String
key, String
value, Double
p) -> forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith forall a. Ord a => a -> a -> a
max (Maybe String
key, String
value) Double
p)
                     (State -> Map (Maybe String, String) Double
S.requiredCoverage State
st) (Result -> [(Maybe String, String, Double)]
P.requiredCoverage Result
res)
                 , expected :: Bool
expected = Result -> Bool
expect Result
res }

     case Result
res of
       MkResult{ok :: Result -> Maybe Bool
ok = Just Bool
True} -> -- successful test
         do (State -> Property -> IO Result) -> State -> Property -> IO Result
continue State -> Property -> IO Result
doneTesting
              State
st'{ numSuccessTests :: Int
numSuccessTests           = State -> Int
numSuccessTests State
st' forall a. Num a => a -> a -> a
+ Int
1
                 , numRecentlyDiscardedTests :: Int
numRecentlyDiscardedTests = Int
0
                 , randomSeed :: QCGen
randomSeed = QCGen
rnd2
                 } Property
f

       MkResult{ok :: Result -> Maybe Bool
ok = Maybe Bool
Nothing, expect :: Result -> Bool
expect = Bool
expect, maybeNumTests :: Result -> Maybe Int
maybeNumTests = Maybe Int
mnt, maybeCheckCoverage :: Result -> Maybe Confidence
maybeCheckCoverage = Maybe Confidence
mcc} -> -- discarded test
         do (State -> Property -> IO Result) -> State -> Property -> IO Result
continue State -> Property -> IO Result
giveUp
              -- Don't add coverage info from this test
              State
st{ numDiscardedTests :: Int
numDiscardedTests         = State -> Int
numDiscardedTests State
st' forall a. Num a => a -> a -> a
+ Int
1
                , numRecentlyDiscardedTests :: Int
numRecentlyDiscardedTests = State -> Int
numRecentlyDiscardedTests State
st' forall a. Num a => a -> a -> a
+ Int
1
                , randomSeed :: QCGen
randomSeed = QCGen
rnd2
                } Property
f

       MkResult{ok :: Result -> Maybe Bool
ok = Just Bool
False} -> -- failed test
         do (Int
numShrinks, Int
totFailed, Int
lastFailed, Result
res) <- State -> Result -> [Rose Result] -> IO (Int, Int, Int, Result)
foundFailure State
st' Result
res [Rose Result]
ts
            String
theOutput <- Terminal -> IO String
terminalOutput (State -> Terminal
terminal State
st')
            if Bool -> Bool
not (Result -> Bool
expect Result
res) then
              forall (m :: * -> *) a. Monad m => a -> m a
return Success{ labels :: Map [String] Int
labels = State -> Map [String] Int
S.labels State
st',
                              classes :: Map String Int
classes = State -> Map String Int
S.classes State
st',
                              tables :: Map String (Map String Int)
tables = State -> Map String (Map String Int)
S.tables State
st',
                              numTests :: Int
numTests = State -> Int
numSuccessTests State
st'forall a. Num a => a -> a -> a
+Int
1,
                              numDiscarded :: Int
numDiscarded = State -> Int
numDiscardedTests State
st',
                              output :: String
output = String
theOutput }
             else do
              [String]
testCase <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO String
showCounterexample (Result -> [String]
P.testCase Result
res)
              forall (m :: * -> *) a. Monad m => a -> m a
return Failure{ usedSeed :: QCGen
usedSeed        = State -> QCGen
randomSeed State
st' -- correct! (this will be split first)
                            , usedSize :: Int
usedSize        = Int
size
                            , numTests :: Int
numTests        = State -> Int
numSuccessTests State
st'forall a. Num a => a -> a -> a
+Int
1
                            , numDiscarded :: Int
numDiscarded    = State -> Int
numDiscardedTests State
st'
                            , numShrinks :: Int
numShrinks      = Int
numShrinks
                            , numShrinkTries :: Int
numShrinkTries  = Int
totFailed
                            , numShrinkFinal :: Int
numShrinkFinal  = Int
lastFailed
                            , output :: String
output          = String
theOutput
                            , reason :: String
reason          = Result -> String
P.reason Result
res
                            , theException :: Maybe AnException
theException    = Result -> Maybe AnException
P.theException Result
res
                            , failingTestCase :: [String]
failingTestCase = [String]
testCase
                            , failingLabels :: [String]
failingLabels   = Result -> [String]
P.labels Result
res
                            , failingClasses :: Set String
failingClasses  = forall a. Ord a => [a] -> Set a
Set.fromList (Result -> [String]
P.classes Result
res)
                            }
 where
  (QCGen
rnd1,QCGen
rnd2) = forall g. RandomGen g => g -> (g, g)
split (State -> QCGen
randomSeed State
st)

failureSummary :: State -> P.Result -> String
failureSummary :: State -> Result -> String
failureSummary State
st Result
res = forall a b. (a, b) -> a
fst (State -> Result -> (String, [String])
failureSummaryAndReason State
st Result
res)

failureReason :: State -> P.Result -> [String]
failureReason :: State -> Result -> [String]
failureReason State
st Result
res = forall a b. (a, b) -> b
snd (State -> Result -> (String, [String])
failureSummaryAndReason State
st Result
res)

failureSummaryAndReason :: State -> P.Result -> (String, [String])
failureSummaryAndReason :: State -> Result -> (String, [String])
failureSummaryAndReason State
st Result
res = (String
summary, [String]
full)
  where
    summary :: String
summary =
      String
header forall a. [a] -> [a] -> [a]
++
      Int -> ShowS
short Int
26 (ShowS
oneLine String
theReason forall a. [a] -> [a] -> [a]
++ String
" ") forall a. [a] -> [a] -> [a]
++
      Bool -> String
count Bool
True forall a. [a] -> [a] -> [a]
++ String
"..."

    full :: [String]
full =
      (String
header forall a. [a] -> [a] -> [a]
++
       (if String -> Bool
isOneLine String
theReason then String
theReason forall a. [a] -> [a] -> [a]
++ String
" " else String
"") forall a. [a] -> [a] -> [a]
++
       Bool -> String
count Bool
False forall a. [a] -> [a] -> [a]
++ String
":")forall a. a -> [a] -> [a]
:
      if String -> Bool
isOneLine String
theReason then [] else String -> [String]
lines String
theReason

    theReason :: String
theReason = Result -> String
P.reason Result
res

    header :: String
header =
      if Result -> Bool
expect Result
res then
        ShowS
bold String
"*** Failed! "
      else String
"+++ OK, failed as expected. "

    count :: Bool -> String
count Bool
full =
      String
"(after " forall a. [a] -> [a] -> [a]
++ Int -> ShowS
number (State -> Int
numSuccessTests State
stforall a. Num a => a -> a -> a
+Int
1) String
"test" forall a. [a] -> [a] -> [a]
++
      forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
        String
" and " forall a. [a] -> [a] -> [a]
++
        forall a. Show a => a -> String
show (State -> Int
numSuccessShrinks State
st) forall a. [a] -> [a] -> [a]
++
        forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"." forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (State -> Int
numTryShrinks State
st) | Bool
showNumTryShrinks ] forall a. [a] -> [a] -> [a]
++
        String
" shrink" forall a. [a] -> [a] -> [a]
++
        (if State -> Int
numSuccessShrinks State
st forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
showNumTryShrinks then String
"" else String
"s")
        | State -> Int
numSuccessShrinks State
st forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
|| Bool
showNumTryShrinks ] forall a. [a] -> [a] -> [a]
++
      String
")"
      where
        showNumTryShrinks :: Bool
showNumTryShrinks = Bool
full Bool -> Bool -> Bool
&& State -> Int
numTryShrinks State
st forall a. Ord a => a -> a -> Bool
> Int
0

success :: State -> IO ()
success :: State -> IO ()
success State
st = do
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Terminal -> String -> IO ()
putLine forall a b. (a -> b) -> a -> b
$ State -> Terminal
terminal State
st) ([[String]] -> [String]
paragraphs [[String]
short, [String]
long])
  where
    ([String]
short, [String]
long) =
      case State -> ([String], [String])
labelsAndTables State
st of
        ([String
msg], [String]
long) ->
          ([String
" (" forall a. [a] -> [a] -> [a]
++ forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
msg forall a. [a] -> [a] -> [a]
++ String
")."], [String]
long)
        ([], [String]
long) ->
          ([String
"."], [String]
long)
        ([String]
short, [String]
long) ->
          (String
":"forall a. a -> [a] -> [a]
:[String]
short, [String]
long)

labelsAndTables :: State -> ([String], [String])
labelsAndTables :: State -> ([String], [String])
labelsAndTables State
st = ([String]
theLabels, [String]
theTables)
  where
    theLabels :: [String]
    theLabels :: [String]
theLabels =
      [[String]] -> [String]
paragraphs forall a b. (a -> b) -> a -> b
$
        [ Int -> Maybe String -> Map String Int -> [String]
showTable (State -> Int
numSuccessTests State
st) forall a. Maybe a
Nothing Map String Int
m
        | Map String Int
m <- State -> Map String Int
S.classes State
stforall a. a -> [a] -> [a]
:forall k a. Map k a -> [a]
Map.elems Map Int (Map String Int)
numberedLabels ]

    numberedLabels :: Map Int (Map String Int)
    numberedLabels :: Map Int (Map String Int)
numberedLabels =
      forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Num a => a -> a -> a
(+)) forall a b. (a -> b) -> a -> b
$
        [ (Int
i, forall k a. k -> a -> Map k a
Map.singleton String
l Int
n)
        | ([String]
labels, Int
n) <- forall k a. Map k a -> [(k, a)]
Map.toList (State -> Map [String] Int
S.labels State
st),
          (Int
i, String
l) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [String]
labels ]

    theTables :: [String]
    theTables :: [String]
theTables =
      [[String]] -> [String]
paragraphs forall a b. (a -> b) -> a -> b
$
        [ Int -> Maybe String -> Map String Int -> [String]
showTable (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall k a. Map k a -> [a]
Map.elems Map String Int
m)) (forall a. a -> Maybe a
Just String
table) Map String Int
m
        | (String
table, Map String Int
m) <- forall k a. Map k a -> [(k, a)]
Map.toList (State -> Map String (Map String Int)
S.tables State
st) ] forall a. [a] -> [a] -> [a]
++
        [[ (case Maybe String
mtable of Maybe String
Nothing -> String
"Only "; Just String
table -> String
"Table '" forall a. [a] -> [a] -> [a]
++ String
table forall a. [a] -> [a] -> [a]
++ String
"' had only ")
         forall a. [a] -> [a] -> [a]
++ forall a b. (Integral a, Integral b) => a -> b -> String
lpercent Int
n Int
tot forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
label forall a. [a] -> [a] -> [a]
++ String
", but expected " forall a. [a] -> [a] -> [a]
++ forall a. Integral a => Double -> a -> String
lpercentage Double
p Int
tot
         | (Maybe String
mtable, String
label, Int
tot, Int
n, Double
p) <- State -> [(Maybe String, String, Int, Int, Double)]
allCoverage State
st,
           Maybe Integer -> Int -> Int -> Double -> Bool
insufficientlyCovered (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Confidence -> Integer
certainty (State -> Maybe Confidence
coverageConfidence State
st)) Int
tot Int
n Double
p ]]

showTable :: Int -> Maybe String -> Map String Int -> [String]
showTable :: Int -> Maybe String -> Map String Int -> [String]
showTable Int
k Maybe String
mtable Map String Int
m =
  [String
table forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
total forall a. [a] -> [a] -> [a]
++ String
":" | Just String
table <- [Maybe String
mtable]] forall a. [a] -> [a] -> [a]
++
  (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Integral a => (String, a) -> String
format forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   -- Descending order of occurrences
   forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   -- If #occurences the same, sort in increasing order of key
   -- (note: works because sortBy is stable)
   forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map String Int
m)
  where
    format :: (String, a) -> String
format (String
key, a
v) =
      forall a b. (Integral a, Integral b) => a -> b -> String
rpercent a
v Int
k forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
key

    total :: String
total = forall r. PrintfType r => String -> r
printf String
"(%d in total)" Int
k

--------------------------------------------------------------------------
-- main shrinking loop

foundFailure :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int, P.Result)
foundFailure :: State -> Result -> [Rose Result] -> IO (Int, Int, Int, Result)
foundFailure State
st Result
res [Rose Result]
ts =
  do State -> Result -> [Rose Result] -> IO (Int, Int, Int, Result)
localMin State
st{ numTryShrinks :: Int
numTryShrinks = Int
0 } Result
res [Rose Result]
ts

localMin :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int, P.Result)
-- Don't try to shrink for too long
localMin :: State -> Result -> [Rose Result] -> IO (Int, Int, Int, Result)
localMin State
st Result
res [Rose Result]
ts
  | State -> Int
numSuccessShrinks State
st forall a. Num a => a -> a -> a
+ State -> Int
numTotTryShrinks State
st forall a. Ord a => a -> a -> Bool
>= State -> Int
numTotMaxShrinks State
st =
    State -> Result -> IO (Int, Int, Int, Result)
localMinFound State
st Result
res
localMin State
st Result
res [Rose Result]
ts = do
  Either AnException ()
r <- forall a. IO a -> IO (Either AnException a)
tryEvaluateIO forall a b. (a -> b) -> a -> b
$
    Terminal -> String -> IO ()
putTemp (State -> Terminal
terminal State
st) (State -> Result -> String
failureSummary State
st Result
res)
  case Either AnException ()
r of
    Left AnException
err ->
      State -> Result -> IO (Int, Int, Int, Result)
localMinFound State
st (String -> AnException -> Result
exception String
"Exception while printing status message" AnException
err) { callbacks :: [Callback]
callbacks = Result -> [Callback]
callbacks Result
res }
    Right () -> do
      Either AnException [Rose Result]
r <- forall a. a -> IO (Either AnException a)
tryEvaluate [Rose Result]
ts
      case Either AnException [Rose Result]
r of
        Left AnException
err ->
          State -> Result -> IO (Int, Int, Int, Result)
localMinFound State
st
            (String -> AnException -> Result
exception String
"Exception while generating shrink-list" AnException
err) { callbacks :: [Callback]
callbacks = Result -> [Callback]
callbacks Result
res }
        Right [Rose Result]
ts' -> State -> Result -> [Rose Result] -> IO (Int, Int, Int, Result)
localMin' State
st Result
res [Rose Result]
ts'

localMin' :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int, P.Result)
localMin' :: State -> Result -> [Rose Result] -> IO (Int, Int, Int, Result)
localMin' State
st Result
res [] = State -> Result -> IO (Int, Int, Int, Result)
localMinFound State
st Result
res
localMin' State
st Result
res (Rose Result
t:[Rose Result]
ts) =
  do -- CALLBACK before_test
    MkRose Result
res' [Rose Result]
ts' <- IO (Rose Result) -> IO (Rose Result)
protectRose (Rose Result -> IO (Rose Result)
reduceRose Rose Result
t)
    Result
res' <- State -> Result -> IO Result
callbackPostTest State
st Result
res'
    if Result -> Maybe Bool
ok Result
res' forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Bool
False
      then State -> Result -> [Rose Result] -> IO (Int, Int, Int, Result)
localMin State
st{ numSuccessShrinks :: Int
numSuccessShrinks = State -> Int
numSuccessShrinks State
st forall a. Num a => a -> a -> a
+ Int
1,
                        numTryShrinks :: Int
numTryShrinks     = Int
0 } Result
res' [Rose Result]
ts'
      else State -> Result -> [Rose Result] -> IO (Int, Int, Int, Result)
localMin State
st{ numTryShrinks :: Int
numTryShrinks    = State -> Int
numTryShrinks State
st forall a. Num a => a -> a -> a
+ Int
1,
                        numTotTryShrinks :: Int
numTotTryShrinks = State -> Int
numTotTryShrinks State
st forall a. Num a => a -> a -> a
+ Int
1 } Result
res [Rose Result]
ts

localMinFound :: State -> P.Result -> IO (Int, Int, Int, P.Result)
localMinFound :: State -> Result -> IO (Int, Int, Int, Result)
localMinFound State
st Result
res =
  do forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ Terminal -> String -> IO ()
putLine (State -> Terminal
terminal State
st) String
msg | String
msg <- State -> Result -> [String]
failureReason State
st Result
res ]
     State -> Result -> IO ()
callbackPostFinalFailure State
st Result
res
     -- NB no need to check if callbacks threw an exception because
     -- we are about to return to the user anyway
     forall (m :: * -> *) a. Monad m => a -> m a
return (State -> Int
numSuccessShrinks State
st, State -> Int
numTotTryShrinks State
st forall a. Num a => a -> a -> a
- State -> Int
numTryShrinks State
st, State -> Int
numTryShrinks State
st, Result
res)

--------------------------------------------------------------------------
-- callbacks

callbackPostTest :: State -> P.Result -> IO P.Result
callbackPostTest :: State -> Result -> IO Result
callbackPostTest State
st Result
res = forall a. (AnException -> a) -> IO a -> IO a
protect (String -> AnException -> Result
exception String
"Exception running callback") forall a b. (a -> b) -> a -> b
$ do
  forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ State -> Result -> IO ()
f State
st Result
res | PostTest CallbackKind
_ State -> Result -> IO ()
f <- Result -> [Callback]
callbacks Result
res ]
  forall (m :: * -> *) a. Monad m => a -> m a
return Result
res

callbackPostFinalFailure :: State -> P.Result -> IO ()
callbackPostFinalFailure :: State -> Result -> IO ()
callbackPostFinalFailure State
st Result
res = do
  Either AnException ()
x <- forall a. IO a -> IO (Either AnException a)
tryEvaluateIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ State -> Result -> IO ()
f State
st Result
res | PostFinalFailure CallbackKind
_ State -> Result -> IO ()
f <- Result -> [Callback]
callbacks Result
res ]
  case Either AnException ()
x of
    Left AnException
err -> do
      Terminal -> String -> IO ()
putLine (State -> Terminal
terminal State
st) String
"*** Exception running callback: "
      forall a. IO a -> IO (Either AnException a)
tryEvaluateIO forall a b. (a -> b) -> a -> b
$ Terminal -> String -> IO ()
putLine (State -> Terminal
terminal State
st) (forall a. Show a => a -> String
show AnException
err)
      forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Right () -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

----------------------------------------------------------------------
-- computing coverage

sufficientlyCovered :: Confidence -> Int -> Int -> Double -> Bool
sufficientlyCovered :: Confidence -> Int -> Int -> Double -> Bool
sufficientlyCovered Confidence
confidence Int
n Int
k Double
p =
  -- Accept the coverage if, with high confidence, the actual probability is
  -- at least 0.9 times the required one.
  Integer -> Integer -> Double -> Double
wilsonLow (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
k) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) (Double
1 forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
err) forall a. Ord a => a -> a -> Bool
>= Double
tol forall a. Num a => a -> a -> a
* Double
p
  where
    err :: Integer
err = Confidence -> Integer
certainty Confidence
confidence
    tol :: Double
tol = Confidence -> Double
tolerance Confidence
confidence

insufficientlyCovered :: Maybe Integer -> Int -> Int -> Double -> Bool
insufficientlyCovered :: Maybe Integer -> Int -> Int -> Double -> Bool
insufficientlyCovered Maybe Integer
Nothing Int
n Int
k Double
p =
  forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
k forall a. Ord a => a -> a -> Bool
< Double
p forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n
insufficientlyCovered (Just Integer
err) Int
n Int
k Double
p =
  Integer -> Integer -> Double -> Double
wilsonHigh (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
k) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) (Double
1 forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
err) forall a. Ord a => a -> a -> Bool
< Double
p

-- https://en.wikipedia.org/wiki/Binomial_proportion_confidence_interval#Wilson_score_interval
-- Note:
-- https://www.ncss.com/wp-content/themes/ncss/pdf/Procedures/PASS/Confidence_Intervals_for_One_Proportion.pdf
-- suggests we should use a instead of a/2 for a one-sided test. Look
-- into this.
wilson :: Integer -> Integer -> Double -> Double
wilson :: Integer -> Integer -> Double -> Double
wilson Integer
k Integer
n Double
z =
  (Double
p forall a. Num a => a -> a -> a
+ Double
zforall a. Num a => a -> a -> a
*Double
zforall a. Fractional a => a -> a -> a
/(Double
2forall a. Num a => a -> a -> a
*Double
nf) forall a. Num a => a -> a -> a
+ Double
zforall a. Num a => a -> a -> a
*forall a. Floating a => a -> a
sqrt (Double
pforall a. Num a => a -> a -> a
*(Double
1forall a. Num a => a -> a -> a
-Double
p)forall a. Fractional a => a -> a -> a
/Double
nf forall a. Num a => a -> a -> a
+ Double
zforall a. Num a => a -> a -> a
*Double
zforall a. Fractional a => a -> a -> a
/(Double
4forall a. Num a => a -> a -> a
*Double
nfforall a. Num a => a -> a -> a
*Double
nf)))forall a. Fractional a => a -> a -> a
/(Double
1 forall a. Num a => a -> a -> a
+ Double
zforall a. Num a => a -> a -> a
*Double
zforall a. Fractional a => a -> a -> a
/Double
nf)
  where
    nf :: Double
nf = forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n
    p :: Double
p = forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
k forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n

wilsonLow :: Integer -> Integer -> Double -> Double
wilsonLow :: Integer -> Integer -> Double -> Double
wilsonLow Integer
k Integer
n Double
a = Integer -> Integer -> Double -> Double
wilson Integer
k Integer
n (Double -> Double
invnormcdf (Double
aforall a. Fractional a => a -> a -> a
/Double
2))

wilsonHigh :: Integer -> Integer -> Double -> Double
wilsonHigh :: Integer -> Integer -> Double -> Double
wilsonHigh Integer
k Integer
n Double
a = Integer -> Integer -> Double -> Double
wilson Integer
k Integer
n (Double -> Double
invnormcdf (Double
1forall a. Num a => a -> a -> a
-Double
aforall a. Fractional a => a -> a -> a
/Double
2))

-- Algorithm taken from
-- https://web.archive.org/web/20151110174102/http://home.online.no/~pjacklam/notes/invnorm/
-- Accurate to about one part in 10^9.
--
-- The 'erf' package uses the same algorithm, but with an extra step
-- to get a fully accurate result, which we skip because it requires
-- the 'erfc' function.
invnormcdf :: Double -> Double
invnormcdf :: Double -> Double
invnormcdf Double
p
  | Double
p forall a. Ord a => a -> a -> Bool
< Double
0  = Double
0forall a. Fractional a => a -> a -> a
/Double
0
  | Double
p forall a. Ord a => a -> a -> Bool
> Double
1  = Double
0forall a. Fractional a => a -> a -> a
/Double
0
  | Double
p forall a. Eq a => a -> a -> Bool
== Double
0 = -Double
1forall a. Fractional a => a -> a -> a
/Double
0
  | Double
p forall a. Eq a => a -> a -> Bool
== Double
1 = Double
1forall a. Fractional a => a -> a -> a
/Double
0
  | Double
p forall a. Ord a => a -> a -> Bool
< Double
p_low =
    let
      q :: Double
q = forall a. Floating a => a -> a
sqrt(-Double
2forall a. Num a => a -> a -> a
*forall a. Floating a => a -> a
log(Double
p))
    in
      (((((Double
c1forall a. Num a => a -> a -> a
*Double
qforall a. Num a => a -> a -> a
+Double
c2)forall a. Num a => a -> a -> a
*Double
qforall a. Num a => a -> a -> a
+Double
c3)forall a. Num a => a -> a -> a
*Double
qforall a. Num a => a -> a -> a
+Double
c4)forall a. Num a => a -> a -> a
*Double
qforall a. Num a => a -> a -> a
+Double
c5)forall a. Num a => a -> a -> a
*Double
qforall a. Num a => a -> a -> a
+Double
c6) forall a. Fractional a => a -> a -> a
/
      ((((Double
d1forall a. Num a => a -> a -> a
*Double
qforall a. Num a => a -> a -> a
+Double
d2)forall a. Num a => a -> a -> a
*Double
qforall a. Num a => a -> a -> a
+Double
d3)forall a. Num a => a -> a -> a
*Double
qforall a. Num a => a -> a -> a
+Double
d4)forall a. Num a => a -> a -> a
*Double
qforall a. Num a => a -> a -> a
+Double
1)
  | Double
p forall a. Ord a => a -> a -> Bool
<= Double
p_high =
    let
      q :: Double
q = Double
p forall a. Num a => a -> a -> a
- Double
0.5
      r :: Double
r = Double
qforall a. Num a => a -> a -> a
*Double
q
    in
      (((((Double
a1forall a. Num a => a -> a -> a
*Double
rforall a. Num a => a -> a -> a
+Double
a2)forall a. Num a => a -> a -> a
*Double
rforall a. Num a => a -> a -> a
+Double
a3)forall a. Num a => a -> a -> a
*Double
rforall a. Num a => a -> a -> a
+Double
a4)forall a. Num a => a -> a -> a
*Double
rforall a. Num a => a -> a -> a
+Double
a5)forall a. Num a => a -> a -> a
*Double
rforall a. Num a => a -> a -> a
+Double
a6)forall a. Num a => a -> a -> a
*Double
q forall a. Fractional a => a -> a -> a
/
      (((((Double
b1forall a. Num a => a -> a -> a
*Double
rforall a. Num a => a -> a -> a
+Double
b2)forall a. Num a => a -> a -> a
*Double
rforall a. Num a => a -> a -> a
+Double
b3)forall a. Num a => a -> a -> a
*Double
rforall a. Num a => a -> a -> a
+Double
b4)forall a. Num a => a -> a -> a
*Double
rforall a. Num a => a -> a -> a
+Double
b5)forall a. Num a => a -> a -> a
*Double
rforall a. Num a => a -> a -> a
+Double
1)
  | Bool
otherwise =
    let
      q :: Double
q = forall a. Floating a => a -> a
sqrt(-Double
2forall a. Num a => a -> a -> a
*forall a. Floating a => a -> a
log(Double
1forall a. Num a => a -> a -> a
-Double
p))
    in
      -(((((Double
c1forall a. Num a => a -> a -> a
*Double
qforall a. Num a => a -> a -> a
+Double
c2)forall a. Num a => a -> a -> a
*Double
qforall a. Num a => a -> a -> a
+Double
c3)forall a. Num a => a -> a -> a
*Double
qforall a. Num a => a -> a -> a
+Double
c4)forall a. Num a => a -> a -> a
*Double
qforall a. Num a => a -> a -> a
+Double
c5)forall a. Num a => a -> a -> a
*Double
qforall a. Num a => a -> a -> a
+Double
c6) forall a. Fractional a => a -> a -> a
/
       ((((Double
d1forall a. Num a => a -> a -> a
*Double
qforall a. Num a => a -> a -> a
+Double
d2)forall a. Num a => a -> a -> a
*Double
qforall a. Num a => a -> a -> a
+Double
d3)forall a. Num a => a -> a -> a
*Double
qforall a. Num a => a -> a -> a
+Double
d4)forall a. Num a => a -> a -> a
*Double
qforall a. Num a => a -> a -> a
+Double
1)
  where
    a1 :: Double
a1 = -Double
3.969683028665376e+01
    a2 :: Double
a2 =  Double
2.209460984245205e+02
    a3 :: Double
a3 = -Double
2.759285104469687e+02
    a4 :: Double
a4 =  Double
1.383577518672690e+02
    a5 :: Double
a5 = -Double
3.066479806614716e+01
    a6 :: Double
a6 =  Double
2.506628277459239e+00

    b1 :: Double
b1 = -Double
5.447609879822406e+01
    b2 :: Double
b2 =  Double
1.615858368580409e+02
    b3 :: Double
b3 = -Double
1.556989798598866e+02
    b4 :: Double
b4 =  Double
6.680131188771972e+01
    b5 :: Double
b5 = -Double
1.328068155288572e+01

    c1 :: Double
c1 = -Double
7.784894002430293e-03
    c2 :: Double
c2 = -Double
3.223964580411365e-01
    c3 :: Double
c3 = -Double
2.400758277161838e+00
    c4 :: Double
c4 = -Double
2.549732539343734e+00
    c5 :: Double
c5 =  Double
4.374664141464968e+00
    c6 :: Double
c6 =  Double
2.938163982698783e+00

    d1 :: Double
d1 =  Double
7.784695709041462e-03
    d2 :: Double
d2 =  Double
3.224671290700398e-01
    d3 :: Double
d3 =  Double
2.445134137142996e+00
    d4 :: Double
d4 =  Double
3.754408661907416e+00

    p_low :: Double
p_low  = Double
0.02425
    p_high :: Double
p_high = Double
1 forall a. Num a => a -> a -> a
- Double
p_low

addCoverageCheck :: Confidence -> State -> Property -> Property
addCoverageCheck :: Confidence -> State -> Property -> Property
addCoverageCheck Confidence
confidence State
st Property
prop
  | forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ Confidence -> Int -> Int -> Double -> Bool
sufficientlyCovered Confidence
confidence Int
tot Int
n Double
p
        | (Maybe String
_, String
_, Int
tot, Int
n, Double
p) <- State -> [(Maybe String, String, Int, Int, Double)]
allCoverage State
st ] =
    -- Note: run prop once more so that we get labels for this test case run
    forall prop. Testable prop => prop -> Property
once Property
prop
  | forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Maybe Integer -> Int -> Int -> Double -> Bool
insufficientlyCovered (forall a. a -> Maybe a
Just (Confidence -> Integer
certainty Confidence
confidence)) Int
tot Int
n Double
p
       | (Maybe String
_, String
_, Int
tot, Int
n, Double
p) <- State -> [(Maybe String, String, Int, Int, Double)]
allCoverage State
st ] =
    let ([String]
theLabels, [String]
theTables) = State -> ([String], [String])
labelsAndTables State
st in
    forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall prop. Testable prop => String -> prop -> Property
counterexample (forall prop. Testable prop => prop -> Property
property Result
failed{reason :: String
P.reason = String
"Insufficient coverage"})
      ([[String]] -> [String]
paragraphs [[String]
theLabels, [String]
theTables])
  | Bool
otherwise = Property
prop

allCoverage :: State -> [(Maybe String, String, Int, Int, Double)]
allCoverage :: State -> [(Maybe String, String, Int, Int, Double)]
allCoverage State
st =
  [ (Maybe String
key, String
value, Int
tot, Int
n, Double
p)
  | ((Maybe String
key, String
value), Double
p) <- forall k a. Map k a -> [(k, a)]
Map.toList (State -> Map (Maybe String, String) Double
S.requiredCoverage State
st),
    let tot :: Int
tot =
          case Maybe String
key of
            Just String
key -> forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Int
0 String
key Map String Int
totals
            Maybe String
Nothing -> State -> Int
numSuccessTests State
st,
    let n :: Int
n = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Int
0 String
value (forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault forall k a. Map k a
Map.empty Maybe String
key Map (Maybe String) (Map String Int)
combinedCounts) ]
  where
    combinedCounts :: Map (Maybe String) (Map String Int)
    combinedCounts :: Map (Maybe String) (Map String Int)
combinedCounts =
      forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert forall a. Maybe a
Nothing (State -> Map String Int
S.classes State
st)
        (forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys forall a. a -> Maybe a
Just (State -> Map String (Map String Int)
S.tables State
st))

    totals :: Map String Int
    totals :: Map String Int
totals = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems) (State -> Map String (Map String Int)
S.tables State
st)

--------------------------------------------------------------------------
-- the end.