1{-# OPTIONS_HADDOCK hide #-} 2-- | The main test loop. 3{-# LANGUAGE CPP #-} 4#ifndef NO_TYPEABLE 5{-# LANGUAGE DeriveDataTypeable #-} 6#endif 7#ifndef NO_SAFE_HASKELL 8{-# LANGUAGE Trustworthy #-} 9#endif 10module Test.QuickCheck.Test where 11 12-------------------------------------------------------------------------- 13-- imports 14 15import Test.QuickCheck.Gen 16import Test.QuickCheck.Property hiding ( Result( reason, theException, labels, classes, tables ), (.&.) ) 17import qualified Test.QuickCheck.Property as P 18import Test.QuickCheck.Text 19import Test.QuickCheck.State hiding (labels, classes, tables, requiredCoverage) 20import qualified Test.QuickCheck.State as S 21import Test.QuickCheck.Exception 22import Test.QuickCheck.Random 23import System.Random(split) 24#if defined(MIN_VERSION_containers) 25#if MIN_VERSION_containers(0,5,0) 26import qualified Data.Map.Strict as Map 27#else 28import qualified Data.Map as Map 29#endif 30#else 31import qualified Data.Map as Map 32#endif 33import qualified Data.Set as Set 34import Data.Set(Set) 35import Data.Map(Map) 36 37import Data.Char 38 ( isSpace 39 ) 40 41import Data.List 42 ( sort 43 , sortBy 44 , group 45 , intersperse 46 ) 47 48import Data.Maybe(fromMaybe, isNothing, catMaybes) 49import Data.Ord(comparing) 50import Text.Printf(printf) 51import Control.Monad 52import Data.Bits 53 54#ifndef NO_TYPEABLE 55import Data.Typeable (Typeable) 56#endif 57 58-------------------------------------------------------------------------- 59-- quickCheck 60 61-- * Running tests 62 63-- | Args specifies arguments to the QuickCheck driver 64data Args 65 = Args 66 { replay :: Maybe (QCGen,Int) 67 -- ^ Should we replay a previous test? 68 -- Note: saving a seed from one version of QuickCheck and 69 -- replaying it in another is not supported. 70 -- If you want to store a test case permanently you should save 71 -- the test case itself. 72 , maxSuccess :: Int 73 -- ^ Maximum number of successful tests before succeeding. Testing stops 74 -- at the first failure. If all tests are passing and you want to run more tests, 75 -- increase this number. 76 , maxDiscardRatio :: Int 77 -- ^ Maximum number of discarded tests per successful test before giving up 78 , maxSize :: Int 79 -- ^ Size to use for the biggest test cases 80 , chatty :: Bool 81 -- ^ Whether to print anything 82 , maxShrinks :: Int 83 -- ^ Maximum number of shrinks to before giving up. Setting this to zero 84 -- turns shrinking off. 85 } 86 deriving ( Show, Read 87#ifndef NO_TYPEABLE 88 , Typeable 89#endif 90 ) 91 92-- | Result represents the test result 93data Result 94 -- | A successful test run 95 = Success 96 { numTests :: Int 97 -- ^ Number of tests performed 98 , numDiscarded :: Int 99 -- ^ Number of tests skipped 100 , labels :: !(Map [String] Int) 101 -- ^ The number of test cases having each combination of labels (see 'label') 102 , classes :: !(Map String Int) 103 -- ^ The number of test cases having each class (see 'classify') 104 , tables :: !(Map String (Map String Int)) 105 -- ^ Data collected by 'tabulate' 106 , output :: String 107 -- ^ Printed output 108 } 109 -- | Given up 110 | GaveUp 111 { numTests :: Int 112 , numDiscarded :: Int 113 -- ^ Number of tests skipped 114 , labels :: !(Map [String] Int) 115 , classes :: !(Map String Int) 116 , tables :: !(Map String (Map String Int)) 117 , output :: String 118 } 119 -- | A failed test run 120 | Failure 121 { numTests :: Int 122 , numDiscarded :: Int 123 -- ^ Number of tests skipped 124 , numShrinks :: Int 125 -- ^ Number of successful shrinking steps performed 126 , numShrinkTries :: Int 127 -- ^ Number of unsuccessful shrinking steps performed 128 , numShrinkFinal :: Int 129 -- ^ Number of unsuccessful shrinking steps performed since last successful shrink 130 , usedSeed :: QCGen 131 -- ^ What seed was used 132 , usedSize :: Int 133 -- ^ What was the test size 134 , reason :: String 135 -- ^ Why did the property fail 136 , theException :: Maybe AnException 137 -- ^ The exception the property threw, if any 138 , output :: String 139 , failingTestCase :: [String] 140 -- ^ The test case which provoked the failure 141 , failingLabels :: [String] 142 -- ^ The test case's labels (see 'label') 143 , failingClasses :: Set String 144 -- ^ The test case's classes (see 'classify') 145 } 146 -- | A property that should have failed did not 147 | NoExpectedFailure 148 { numTests :: Int 149 , numDiscarded :: Int 150 -- ^ Number of tests skipped 151 , labels :: !(Map [String] Int) 152 , classes :: !(Map String Int) 153 , tables :: !(Map String (Map String Int)) 154 , output :: String 155 } 156 deriving ( Show ) 157 158-- | Check if the test run result was a success 159isSuccess :: Result -> Bool 160isSuccess Success{} = True 161isSuccess _ = False 162 163-- | The default test arguments 164stdArgs :: Args 165stdArgs = Args 166 { replay = Nothing 167 , maxSuccess = 100 168 , maxDiscardRatio = 10 169 , maxSize = 100 170 , chatty = True 171 , maxShrinks = maxBound 172 } 173 174-- | Tests a property and prints the results to 'stdout'. 175-- 176-- By default up to 100 tests are performed, which may not be enough 177-- to find all bugs. To run more tests, use 'withMaxSuccess'. 178-- 179-- If you want to get the counterexample as a Haskell value, 180-- rather than just printing it, try the 181-- <http://hackage.haskell.org/package/quickcheck-with-counterexamples quickcheck-with-counterexamples> 182-- package. 183 184quickCheck :: Testable prop => prop -> IO () 185quickCheck p = quickCheckWith stdArgs p 186 187-- | Tests a property, using test arguments, and prints the results to 'stdout'. 188quickCheckWith :: Testable prop => Args -> prop -> IO () 189quickCheckWith args p = quickCheckWithResult args p >> return () 190 191-- | Tests a property, produces a test result, and prints the results to 'stdout'. 192quickCheckResult :: Testable prop => prop -> IO Result 193quickCheckResult p = quickCheckWithResult stdArgs p 194 195-- | Tests a property, using test arguments, produces a test result, and prints the results to 'stdout'. 196quickCheckWithResult :: Testable prop => Args -> prop -> IO Result 197quickCheckWithResult a p = 198 withState a (\s -> test s (property p)) 199 200withState :: Args -> (State -> IO a) -> IO a 201withState a test = (if chatty a then withStdioTerminal else withNullTerminal) $ \tm -> do 202 rnd <- case replay a of 203 Nothing -> newQCGen 204 Just (rnd,_) -> return rnd 205 test MkState{ terminal = tm 206 , maxSuccessTests = maxSuccess a 207 , coverageConfidence = Nothing 208 , maxDiscardedRatio = maxDiscardRatio a 209 , computeSize = case replay a of 210 Nothing -> computeSize' 211 Just (_,s) -> computeSize' `at0` s 212 , numTotMaxShrinks = maxShrinks a 213 , numSuccessTests = 0 214 , numDiscardedTests = 0 215 , numRecentlyDiscardedTests = 0 216 , S.labels = Map.empty 217 , S.classes = Map.empty 218 , S.tables = Map.empty 219 , S.requiredCoverage = Map.empty 220 , expected = True 221 , randomSeed = rnd 222 , numSuccessShrinks = 0 223 , numTryShrinks = 0 224 , numTotTryShrinks = 0 225 } 226 where computeSize' n d 227 -- e.g. with maxSuccess = 250, maxSize = 100, goes like this: 228 -- 0, 1, 2, ..., 99, 0, 1, 2, ..., 99, 0, 2, 4, ..., 98. 229 | n `roundTo` maxSize a + maxSize a <= maxSuccess a || 230 n >= maxSuccess a || 231 maxSuccess a `mod` maxSize a == 0 = (n `mod` maxSize a + d `div` 10) `min` maxSize a 232 | otherwise = 233 ((n `mod` maxSize a) * maxSize a `div` (maxSuccess a `mod` maxSize a) + d `div` 10) `min` maxSize a 234 n `roundTo` m = (n `div` m) * m 235 at0 f s 0 0 = s 236 at0 f s n d = f n d 237 238-- | Tests a property and prints the results and all test cases generated to 'stdout'. 239-- This is just a convenience function that means the same as @'quickCheck' . 'verbose'@. 240-- 241-- Note: for technical reasons, the test case is printed out /after/ 242-- the property is tested. To debug a property that goes into an 243-- infinite loop, use 'within' to add a timeout instead. 244verboseCheck :: Testable prop => prop -> IO () 245verboseCheck p = quickCheck (verbose p) 246 247-- | Tests a property, using test arguments, and prints the results and all test cases generated to 'stdout'. 248-- This is just a convenience function that combines 'quickCheckWith' and 'verbose'. 249-- 250-- Note: for technical reasons, the test case is printed out /after/ 251-- the property is tested. To debug a property that goes into an 252-- infinite loop, use 'within' to add a timeout instead. 253verboseCheckWith :: Testable prop => Args -> prop -> IO () 254verboseCheckWith args p = quickCheckWith args (verbose p) 255 256-- | Tests a property, produces a test result, and prints the results and all test cases generated to 'stdout'. 257-- This is just a convenience function that combines 'quickCheckResult' and 'verbose'. 258-- 259-- Note: for technical reasons, the test case is printed out /after/ 260-- the property is tested. To debug a property that goes into an 261-- infinite loop, use 'within' to add a timeout instead. 262verboseCheckResult :: Testable prop => prop -> IO Result 263verboseCheckResult p = quickCheckResult (verbose p) 264 265-- | Tests a property, using test arguments, produces a test result, and prints the results and all test cases generated to 'stdout'. 266-- This is just a convenience function that combines 'quickCheckWithResult' and 'verbose'. 267-- 268-- Note: for technical reasons, the test case is printed out /after/ 269-- the property is tested. To debug a property that goes into an 270-- infinite loop, use 'within' to add a timeout instead. 271verboseCheckWithResult :: Testable prop => Args -> prop -> IO Result 272verboseCheckWithResult a p = quickCheckWithResult a (verbose p) 273 274-------------------------------------------------------------------------- 275-- main test loop 276 277test :: State -> Property -> IO Result 278test st f 279 | numSuccessTests st >= maxSuccessTests st && isNothing (coverageConfidence st) = 280 doneTesting st f 281 | numDiscardedTests st >= maxDiscardedRatio st * max (numSuccessTests st) (maxSuccessTests st) = 282 giveUp st f 283 | otherwise = 284 runATest st f 285 286doneTesting :: State -> Property -> IO Result 287doneTesting st _f 288 | expected st == False = do 289 putPart (terminal st) 290 ( bold ("*** Failed!") 291 ++ " Passed " 292 ++ showTestCount st 293 ++ " (expected failure)" 294 ) 295 finished NoExpectedFailure 296 | otherwise = do 297 putPart (terminal st) 298 ( "+++ OK, passed " 299 ++ showTestCount st 300 ) 301 finished Success 302 where 303 finished k = do 304 success st 305 theOutput <- terminalOutput (terminal st) 306 return (k (numSuccessTests st) (numDiscardedTests st) (S.labels st) (S.classes st) (S.tables st) theOutput) 307 308giveUp :: State -> Property -> IO Result 309giveUp st _f = 310 do -- CALLBACK gave_up? 311 putPart (terminal st) 312 ( bold ("*** Gave up!") 313 ++ " Passed only " 314 ++ showTestCount st 315 ++ " tests" 316 ) 317 success st 318 theOutput <- terminalOutput (terminal st) 319 return GaveUp{ numTests = numSuccessTests st 320 , numDiscarded = numDiscardedTests st 321 , labels = S.labels st 322 , classes = S.classes st 323 , tables = S.tables st 324 , output = theOutput 325 } 326 327showTestCount :: State -> String 328showTestCount st = 329 number (numSuccessTests st) "test" 330 ++ concat [ "; " ++ show (numDiscardedTests st) ++ " discarded" 331 | numDiscardedTests st > 0 332 ] 333 334runATest :: State -> Property -> IO Result 335runATest st f = 336 do -- CALLBACK before_test 337 putTemp (terminal st) 338 ( "(" 339 ++ showTestCount st 340 ++ ")" 341 ) 342 let powerOfTwo n = n .&. (n - 1) == 0 343 let f_or_cov = 344 case coverageConfidence st of 345 Just confidence | (1 + numSuccessTests st) `mod` 100 == 0 && powerOfTwo ((1 + numSuccessTests st) `div` 100) -> 346 addCoverageCheck confidence st f 347 _ -> f 348 let size = computeSize st (numSuccessTests st) (numRecentlyDiscardedTests st) 349 MkRose res ts <- protectRose (reduceRose (unProp (unGen (unProperty f_or_cov) rnd1 size))) 350 res <- callbackPostTest st res 351 352 let continue break st' | abort res = break st' 353 | otherwise = test st' 354 355 let st' = st{ coverageConfidence = maybeCheckCoverage res `mplus` coverageConfidence st 356 , maxSuccessTests = fromMaybe (maxSuccessTests st) (maybeNumTests res) 357 , S.labels = Map.insertWith (+) (P.labels res) 1 (S.labels st) 358 , S.classes = Map.unionWith (+) (S.classes st) (Map.fromList (zip (P.classes res) (repeat 1))) 359 , S.tables = 360 foldr (\(tab, x) -> Map.insertWith (Map.unionWith (+)) tab (Map.singleton x 1)) 361 (S.tables st) (P.tables res) 362 , S.requiredCoverage = 363 foldr (\(key, value, p) -> Map.insertWith max (key, value) p) 364 (S.requiredCoverage st) (P.requiredCoverage res) 365 , expected = expect res } 366 367 case res of 368 MkResult{ok = Just True} -> -- successful test 369 do continue doneTesting 370 st'{ numSuccessTests = numSuccessTests st' + 1 371 , numRecentlyDiscardedTests = 0 372 , randomSeed = rnd2 373 } f 374 375 MkResult{ok = Nothing, expect = expect, maybeNumTests = mnt, maybeCheckCoverage = mcc} -> -- discarded test 376 do continue giveUp 377 -- Don't add coverage info from this test 378 st{ numDiscardedTests = numDiscardedTests st' + 1 379 , numRecentlyDiscardedTests = numRecentlyDiscardedTests st' + 1 380 , randomSeed = rnd2 381 } f 382 383 MkResult{ok = Just False} -> -- failed test 384 do (numShrinks, totFailed, lastFailed, res) <- foundFailure st' res ts 385 theOutput <- terminalOutput (terminal st') 386 if not (expect res) then 387 return Success{ labels = S.labels st', 388 classes = S.classes st', 389 tables = S.tables st', 390 numTests = numSuccessTests st'+1, 391 numDiscarded = numDiscardedTests st', 392 output = theOutput } 393 else do 394 testCase <- mapM showCounterexample (P.testCase res) 395 return Failure{ usedSeed = randomSeed st' -- correct! (this will be split first) 396 , usedSize = size 397 , numTests = numSuccessTests st'+1 398 , numDiscarded = numDiscardedTests st' 399 , numShrinks = numShrinks 400 , numShrinkTries = totFailed 401 , numShrinkFinal = lastFailed 402 , output = theOutput 403 , reason = P.reason res 404 , theException = P.theException res 405 , failingTestCase = testCase 406 , failingLabels = P.labels res 407 , failingClasses = Set.fromList (P.classes res) 408 } 409 where 410 (rnd1,rnd2) = split (randomSeed st) 411 412failureSummary :: State -> P.Result -> String 413failureSummary st res = fst (failureSummaryAndReason st res) 414 415failureReason :: State -> P.Result -> [String] 416failureReason st res = snd (failureSummaryAndReason st res) 417 418failureSummaryAndReason :: State -> P.Result -> (String, [String]) 419failureSummaryAndReason st res = (summary, full) 420 where 421 summary = 422 header ++ 423 short 26 (oneLine theReason ++ " ") ++ 424 count True ++ "..." 425 426 full = 427 (header ++ 428 (if isOneLine theReason then theReason ++ " " else "") ++ 429 count False ++ ":"): 430 if isOneLine theReason then [] else lines theReason 431 432 theReason = P.reason res 433 434 header = 435 if expect res then 436 bold "*** Failed! " 437 else "+++ OK, failed as expected. " 438 439 count full = 440 "(after " ++ number (numSuccessTests st+1) "test" ++ 441 concat [ 442 " and " ++ 443 show (numSuccessShrinks st) ++ 444 concat [ "." ++ show (numTryShrinks st) | showNumTryShrinks ] ++ 445 " shrink" ++ 446 (if numSuccessShrinks st == 1 && not showNumTryShrinks then "" else "s") 447 | numSuccessShrinks st > 0 || showNumTryShrinks ] ++ 448 ")" 449 where 450 showNumTryShrinks = full && numTryShrinks st > 0 451 452success :: State -> IO () 453success st = do 454 mapM_ (putLine $ terminal st) (paragraphs [short, long]) 455 where 456 (short, long) = 457 case labelsAndTables st of 458 ([msg], long) -> 459 ([" (" ++ dropWhile isSpace msg ++ ")."], long) 460 ([], long) -> 461 (["."], long) 462 (short, long) -> 463 (":":short, long) 464 465labelsAndTables :: State -> ([String], [String]) 466labelsAndTables st = (theLabels, theTables) 467 where 468 theLabels :: [String] 469 theLabels = 470 paragraphs $ 471 [ showTable (numSuccessTests st) Nothing m 472 | m <- S.classes st:Map.elems numberedLabels ] 473 474 numberedLabels :: Map Int (Map String Int) 475 numberedLabels = 476 Map.fromListWith (Map.unionWith (+)) $ 477 [ (i, Map.singleton l n) 478 | (labels, n) <- Map.toList (S.labels st), 479 (i, l) <- zip [0..] labels ] 480 481 theTables :: [String] 482 theTables = 483 paragraphs $ 484 [ showTable (sum (Map.elems m)) (Just table) m 485 | (table, m) <- Map.toList (S.tables st) ] ++ 486 [[ (case mtable of Nothing -> "Only "; Just table -> "Table '" ++ table ++ "' had only ") 487 ++ lpercent n tot ++ " " ++ label ++ ", but expected " ++ lpercentage p tot 488 | (mtable, label, tot, n, p) <- allCoverage st, 489 insufficientlyCovered (fmap certainty (coverageConfidence st)) tot n p ]] 490 491showTable :: Int -> Maybe String -> Map String Int -> [String] 492showTable k mtable m = 493 [table ++ " " ++ total ++ ":" | Just table <- [mtable]] ++ 494 (map format . 495 -- Descending order of occurrences 496 reverse . sortBy (comparing snd) . 497 -- If #occurences the same, sort in increasing order of key 498 -- (note: works because sortBy is stable) 499 reverse . sortBy (comparing fst) $ Map.toList m) 500 where 501 format (key, v) = 502 rpercent v k ++ " " ++ key 503 504 total = printf "(%d in total)" k 505 506-------------------------------------------------------------------------- 507-- main shrinking loop 508 509foundFailure :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int, P.Result) 510foundFailure st res ts = 511 do localMin st{ numTryShrinks = 0 } res ts 512 513localMin :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int, P.Result) 514-- Don't try to shrink for too long 515localMin st res ts 516 | numSuccessShrinks st + numTotTryShrinks st >= numTotMaxShrinks st = 517 localMinFound st res 518localMin st res ts = do 519 r <- tryEvaluateIO $ 520 putTemp (terminal st) (failureSummary st res) 521 case r of 522 Left err -> 523 localMinFound st (exception "Exception while printing status message" err) { callbacks = callbacks res } 524 Right () -> do 525 r <- tryEvaluate ts 526 case r of 527 Left err -> 528 localMinFound st 529 (exception "Exception while generating shrink-list" err) { callbacks = callbacks res } 530 Right ts' -> localMin' st res ts' 531 532localMin' :: State -> P.Result -> [Rose P.Result] -> IO (Int, Int, Int, P.Result) 533localMin' st res [] = localMinFound st res 534localMin' st res (t:ts) = 535 do -- CALLBACK before_test 536 MkRose res' ts' <- protectRose (reduceRose t) 537 res' <- callbackPostTest st res' 538 if ok res' == Just False 539 then localMin st{ numSuccessShrinks = numSuccessShrinks st + 1, 540 numTryShrinks = 0 } res' ts' 541 else localMin st{ numTryShrinks = numTryShrinks st + 1, 542 numTotTryShrinks = numTotTryShrinks st + 1 } res ts 543 544localMinFound :: State -> P.Result -> IO (Int, Int, Int, P.Result) 545localMinFound st res = 546 do sequence_ [ putLine (terminal st) msg | msg <- failureReason st res ] 547 callbackPostFinalFailure st res 548 -- NB no need to check if callbacks threw an exception because 549 -- we are about to return to the user anyway 550 return (numSuccessShrinks st, numTotTryShrinks st - numTryShrinks st, numTryShrinks st, res) 551 552-------------------------------------------------------------------------- 553-- callbacks 554 555callbackPostTest :: State -> P.Result -> IO P.Result 556callbackPostTest st res = protect (exception "Exception running callback") $ do 557 sequence_ [ f st res | PostTest _ f <- callbacks res ] 558 return res 559 560callbackPostFinalFailure :: State -> P.Result -> IO () 561callbackPostFinalFailure st res = do 562 x <- tryEvaluateIO $ sequence_ [ f st res | PostFinalFailure _ f <- callbacks res ] 563 case x of 564 Left err -> do 565 putLine (terminal st) "*** Exception running callback: " 566 tryEvaluateIO $ putLine (terminal st) (show err) 567 return () 568 Right () -> return () 569 570---------------------------------------------------------------------- 571-- computing coverage 572 573sufficientlyCovered :: Confidence -> Int -> Int -> Double -> Bool 574sufficientlyCovered confidence n k p = 575 -- Accept the coverage if, with high confidence, the actual probability is 576 -- at least 0.9 times the required one. 577 wilsonLow (fromIntegral k) (fromIntegral n) (1 / fromIntegral err) >= tol * p 578 where 579 err = certainty confidence 580 tol = tolerance confidence 581 582insufficientlyCovered :: Maybe Integer -> Int -> Int -> Double -> Bool 583insufficientlyCovered Nothing n k p = 584 fromIntegral k < p * fromIntegral n 585insufficientlyCovered (Just err) n k p = 586 wilsonHigh (fromIntegral k) (fromIntegral n) (1 / fromIntegral err) < p 587 588-- https://en.wikipedia.org/wiki/Binomial_proportion_confidence_interval#Wilson_score_interval 589-- Note: 590-- https://www.ncss.com/wp-content/themes/ncss/pdf/Procedures/PASS/Confidence_Intervals_for_One_Proportion.pdf 591-- suggests we should use a instead of a/2 for a one-sided test. Look 592-- into this. 593wilson :: Integer -> Integer -> Double -> Double 594wilson k n z = 595 (p + z*z/(2*nf) + z*sqrt (p*(1-p)/nf + z*z/(4*nf*nf)))/(1 + z*z/nf) 596 where 597 nf = fromIntegral n 598 p = fromIntegral k / fromIntegral n 599 600wilsonLow :: Integer -> Integer -> Double -> Double 601wilsonLow k n a = wilson k n (invnormcdf (a/2)) 602 603wilsonHigh :: Integer -> Integer -> Double -> Double 604wilsonHigh k n a = wilson k n (invnormcdf (1-a/2)) 605 606-- Algorithm taken from 607-- https://web.archive.org/web/20151110174102/http://home.online.no/~pjacklam/notes/invnorm/ 608-- Accurate to about one part in 10^9. 609-- 610-- The 'erf' package uses the same algorithm, but with an extra step 611-- to get a fully accurate result, which we skip because it requires 612-- the 'erfc' function. 613invnormcdf :: Double -> Double 614invnormcdf p 615 | p < 0 = 0/0 616 | p > 1 = 0/0 617 | p == 0 = -1/0 618 | p == 1 = 1/0 619 | p < p_low = 620 let 621 q = sqrt(-2*log(p)) 622 in 623 (((((c1*q+c2)*q+c3)*q+c4)*q+c5)*q+c6) / 624 ((((d1*q+d2)*q+d3)*q+d4)*q+1) 625 | p <= p_high = 626 let 627 q = p - 0.5 628 r = q*q 629 in 630 (((((a1*r+a2)*r+a3)*r+a4)*r+a5)*r+a6)*q / 631 (((((b1*r+b2)*r+b3)*r+b4)*r+b5)*r+1) 632 | otherwise = 633 let 634 q = sqrt(-2*log(1-p)) 635 in 636 -(((((c1*q+c2)*q+c3)*q+c4)*q+c5)*q+c6) / 637 ((((d1*q+d2)*q+d3)*q+d4)*q+1) 638 where 639 a1 = -3.969683028665376e+01 640 a2 = 2.209460984245205e+02 641 a3 = -2.759285104469687e+02 642 a4 = 1.383577518672690e+02 643 a5 = -3.066479806614716e+01 644 a6 = 2.506628277459239e+00 645 646 b1 = -5.447609879822406e+01 647 b2 = 1.615858368580409e+02 648 b3 = -1.556989798598866e+02 649 b4 = 6.680131188771972e+01 650 b5 = -1.328068155288572e+01 651 652 c1 = -7.784894002430293e-03 653 c2 = -3.223964580411365e-01 654 c3 = -2.400758277161838e+00 655 c4 = -2.549732539343734e+00 656 c5 = 4.374664141464968e+00 657 c6 = 2.938163982698783e+00 658 659 d1 = 7.784695709041462e-03 660 d2 = 3.224671290700398e-01 661 d3 = 2.445134137142996e+00 662 d4 = 3.754408661907416e+00 663 664 p_low = 0.02425 665 p_high = 1 - p_low 666 667addCoverageCheck :: Confidence -> State -> Property -> Property 668addCoverageCheck confidence st prop 669 | and [ sufficientlyCovered confidence tot n p 670 | (_, _, tot, n, p) <- allCoverage st ] = 671 -- Note: run prop once more so that we get labels for this test case run 672 once prop 673 | or [ insufficientlyCovered (Just (certainty confidence)) tot n p 674 | (_, _, tot, n, p) <- allCoverage st ] = 675 let (theLabels, theTables) = labelsAndTables st in 676 foldr counterexample (property failed{P.reason = "Insufficient coverage"}) 677 (paragraphs [theLabels, theTables]) 678 | otherwise = prop 679 680allCoverage :: State -> [(Maybe String, String, Int, Int, Double)] 681allCoverage st = 682 [ (key, value, tot, n, p) 683 | ((key, value), p) <- Map.toList (S.requiredCoverage st), 684 let tot = 685 case key of 686 Just key -> Map.findWithDefault 0 key totals 687 Nothing -> numSuccessTests st, 688 let n = Map.findWithDefault 0 value (Map.findWithDefault Map.empty key combinedCounts) ] 689 where 690 combinedCounts :: Map (Maybe String) (Map String Int) 691 combinedCounts = 692 Map.insert Nothing (S.classes st) 693 (Map.mapKeys Just (S.tables st)) 694 695 totals :: Map String Int 696 totals = fmap (sum . Map.elems) (S.tables st) 697 698-------------------------------------------------------------------------- 699-- the end. 700