From 6faf4b18d1adb3bb003c032fb21c1476ca28d286 Mon Sep 17 00:00:00 2001 From: Ben Franksen Date: Wed, 19 Apr 2023 09:09:11 +0200 Subject: [PATCH] support quickcheck test case classification When a property test succeeds and QC's classify function has been used, the output now has additional information about the distribution of test cases. Example outputs: [OK, passed 1000 tests (49.6% fully trivial, 76.1 half trivial)] [Arguments exhausted after 53 tests (100% half trivial)] --- .../Test/Framework/Providers/QuickCheck2.hs | 41 +++++++++++++++---- quickcheck2/test-framework-quickcheck2.cabal | 1 + 2 files changed, 33 insertions(+), 9 deletions(-) diff --git a/quickcheck2/Test/Framework/Providers/QuickCheck2.hs b/quickcheck2/Test/Framework/Providers/QuickCheck2.hs index 5c989c6..07a19d8 100644 --- a/quickcheck2/Test/Framework/Providers/QuickCheck2.hs +++ b/quickcheck2/Test/Framework/Providers/QuickCheck2.hs @@ -22,6 +22,14 @@ import Test.QuickCheck.Random (QCGen, mkQCGen) #endif import System.Random +#if MIN_VERSION_QuickCheck(2,12,0) +import qualified Data.Map as M +import Test.QuickCheck.Text (lpercent) +#elif MIN_VERSION_QuickCheck(2,10,0) +import Numeric (showFFloat) +#endif + +import Data.List (intercalate) import Data.Typeable @@ -44,8 +52,8 @@ data PropertyResult = PropertyResult { -- tests previously run if the test times out, hence we need a Maybe here for that case. } -data PropertyStatus = PropertyOK -- ^ The property is true as far as we could check it - | PropertyArgumentsExhausted -- ^ The property may be true, but we ran out of arguments to try it out on +data PropertyStatus = PropertyOK String -- ^ The property is true as far as we could check it (with classification details) + | PropertyArgumentsExhausted String -- ^ The property may be true, but we ran out of arguments to try it out on | PropertyFalsifiable String String -- ^ The property was not true. The strings are the reason and the output. | PropertyNoExpectedFailure -- ^ We expected that a property would fail but it didn't | PropertyTimedOut -- ^ The property timed out during execution @@ -56,8 +64,8 @@ data PropertyStatus = PropertyOK -- ^ The property is tru instance Show PropertyResult where show (PropertyResult { pr_status = status, pr_used_seed = used_seed, pr_tests_run = mb_tests_run }) = case status of - PropertyOK -> "OK, passed " ++ tests_run_str ++ " tests" - PropertyArgumentsExhausted -> "Arguments exhausted after " ++ tests_run_str ++ " tests" + PropertyOK cs -> "OK, passed " ++ tests_run_str ++ " tests" ++ cs + PropertyArgumentsExhausted cs -> "Arguments exhausted after " ++ tests_run_str ++ " tests" ++ cs PropertyFalsifiable _rsn otpt -> otpt ++ "(used seed " ++ show used_seed ++ ")" PropertyNoExpectedFailure -> "No expected failure with seed " ++ show used_seed ++ ", after " ++ tests_run_str ++ " tests" PropertyTimedOut -> "Timed out after " ++ tests_run_str ++ " tests" @@ -69,9 +77,9 @@ instance Show PropertyResult where propertySucceeded :: PropertyResult -> Bool propertySucceeded (PropertyResult { pr_status = status, pr_tests_run = mb_n }) = case status of - PropertyOK -> True - PropertyArgumentsExhausted -> maybe False (/= 0) mb_n - _ -> False + PropertyOK{} -> True + PropertyArgumentsExhausted{} -> maybe False (/= 0) mb_n + _ -> False data Property = forall a. Testable a => Property a @@ -123,10 +131,25 @@ runProperty topts testable = do pr_tests_run = Just (numTests result) } where - toPropertyStatus (Success {}) = PropertyOK - toPropertyStatus (GaveUp {}) = PropertyArgumentsExhausted + toPropertyStatus s@(Success {}) = PropertyOK (classification s) + toPropertyStatus s@(GaveUp {}) = PropertyArgumentsExhausted (classification s) toPropertyStatus (Failure { reason = rsn, output = otpt }) = PropertyFalsifiable rsn otpt toPropertyStatus (NoExpectedFailure {}) = PropertyNoExpectedFailure #if MIN_VERSION_QuickCheck(2,8,0) && !MIN_VERSION_QuickCheck(2,12,0) toPropertyStatus (InsufficientCoverage _ _ _) = PropertyInsufficientCoverage #endif +#if MIN_VERSION_QuickCheck(2,12,0) + classification s = render_classes (numTests s) (M.toList $ classes s) + render_class n (l,k) = lpercent k n ++ " " ++ l +#else + classification s = render_classes (numTests s) (labels s) +#if MIN_VERSION_QuickCheck(2,10,0) + render_class n (l,p) = showFFloat (Just places) p " " ++ l + where + places = ceiling (logBase 10 (fromIntegral n) - 2 :: Double) `max` 0 +#else + render_class _ (l,p) = shows p " " ++ l +#endif +#endif + render_classes _ [] = "" + render_classes n cs = " (" ++ intercalate (", ") (map (render_class n) cs) ++ ")" diff --git a/quickcheck2/test-framework-quickcheck2.cabal b/quickcheck2/test-framework-quickcheck2.cabal index a292c1a..50fe238 100644 --- a/quickcheck2/test-framework-quickcheck2.cabal +++ b/quickcheck2/test-framework-quickcheck2.cabal @@ -46,6 +46,7 @@ Library Build-Depends: test-framework == 0.8.* , QuickCheck >= 2.4 && < 2.15 , base >= 4.3 && < 5 + , containers >= 0.1 && < 0.7 , extensible-exceptions >= 0.1.1 && < 0.2.0 , random >= 1 && < 1.3