From 968bfe41f5be97f628e4ad05bf7c7a82e74ed637 Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Fri, 11 Oct 2024 17:01:07 +0200 Subject: [PATCH] Add option for printing the number of QuickCheck tests and shrinks Currently, `tasty` and `tasty-quickcheck` will print a progress percentage, so one can see test progression. However, once a property finds a failure and starts shrinking, then test progression stops. Importantly, it is not clear how the shrinker is progressing, though it would be useful information to show, e.g., to judge whether a test is shrinking too slow, whether the shrinker loops, or whether a shrunk test case hangs. This commit adds a new option to enable printing the number of QuickCheck tests (and shrinks on test failure) in addition to the percentage. --- quickcheck/Test/Tasty/QuickCheck.hs | 55 +++++++++++++++++++++++++---- quickcheck/tests/test.hs | 11 ++++-- 2 files changed, 57 insertions(+), 9 deletions(-) diff --git a/quickcheck/Test/Tasty/QuickCheck.hs b/quickcheck/Test/Tasty/QuickCheck.hs index a3057dda..ab021cae 100644 --- a/quickcheck/Test/Tasty/QuickCheck.hs +++ b/quickcheck/Test/Tasty/QuickCheck.hs @@ -11,6 +11,7 @@ module Test.Tasty.QuickCheck , QuickCheckVerbose(..) , QuickCheckMaxShrinks(..) , QuickCheckTimeout(..) + , QuickCheckVerboseProgress(..) -- * Re-export of Test.QuickCheck , module Test.QuickCheck -- * Internal @@ -125,6 +126,11 @@ newtype QuickCheckMaxShrinks = QuickCheckMaxShrinks Int newtype QuickCheckTimeout = QuickCheckTimeout Timeout deriving (Eq, Ord, Typeable) +-- | Show the number of tests and shrinks. +-- +-- @since ?.?.? +newtype QuickCheckVerboseProgress = QuickCheckVerboseProgress Bool + instance IsOption QuickCheckTests where defaultValue = 100 showDefaultValue (QuickCheckTests n) = Just (show n) @@ -192,6 +198,13 @@ instance IsOption QuickCheckTimeout where optionHelp = return "Timeout for individual tests within a QuickCheck property (suffixes: ms,s,m,h; default: s)" optionCLParser = mkOptionCLParser $ metavar "DURATION" +instance IsOption QuickCheckVerboseProgress where + defaultValue = QuickCheckVerboseProgress False + parseValue = fmap QuickCheckVerboseProgress . safeReadBool + optionName = return "quickcheck-verbose-progress" + optionHelp = return "Show the number of tests and shrinks" + optionCLParser = flagCLParser Nothing (QuickCheckVerboseProgress True) + -- | Convert tasty options into QuickCheck options. -- -- This is a low-level function that was originally added for tasty-hspec @@ -239,21 +252,23 @@ instance IsTest QC where , Option (Proxy :: Proxy QuickCheckVerbose) , Option (Proxy :: Proxy QuickCheckMaxShrinks) , Option (Proxy :: Proxy QuickCheckTimeout) + , Option (Proxy :: Proxy QuickCheckVerboseProgress) ] run opts (QC prop) yieldProgress = do (_, args) <- optionSetToArgs opts let - QuickCheckShowReplay showReplay = lookupOption opts - QuickCheckVerbose verbose = lookupOption opts - QuickCheckTimeout timeout = lookupOption opts + QuickCheckShowReplay showReplay = lookupOption opts + QuickCheckVerbose verbose = lookupOption opts + QuickCheckVerboseProgress verboseProgress = lookupOption opts + QuickCheckTimeout timeout = lookupOption opts applyTimeout = case timeout of Timeout micros _ | micros <= toInteger (maxBound :: Int) -> QC.within (fromInteger micros) _ -> id -- Quickcheck already catches exceptions, no need to do it here. - r <- quickCheck yieldProgress + r <- quickCheck yieldProgress verboseProgress args (applyTimeout $ if verbose then QC.verbose prop else prop) @@ -276,15 +291,41 @@ instance IsTest QC where -- callback. -- quickCheck :: (Progress -> IO ()) + -> Bool -> QC.Args -> QC.Property -> IO QC.Result -quickCheck yieldProgress args +quickCheck yieldProgress verboseProgress args = (.) (QC.quickCheckWithResult args) $ QCP.callback $ QCP.PostTest QCP.NotCounterexample - $ \QC.MkState {QC.maxSuccessTests, QC.numSuccessTests} _ -> - yieldProgress $ emptyProgress {progressPercent = fromIntegral numSuccessTests / fromIntegral maxSuccessTests} + $ \st@QC.MkState {QC.maxSuccessTests, QC.numSuccessTests} _ -> + yieldProgress $ + emptyProgress { + progressText = if verboseProgress then showTestAndShrinkCount st else "" + , progressPercent = fromIntegral numSuccessTests / fromIntegral maxSuccessTests + } + +-- Based on 'QuickCheck.Test.failureSummaryAndReason'. +showTestAndShrinkCount :: QC.State -> String +showTestAndShrinkCount st = count True + where + count :: Bool -> String + count full = + "(" ++ number (QC.numSuccessTests st+1) "test" ++ + concat [ + " and " ++ + show (QC.numSuccessShrinks st) ++ + concat [ "." ++ show (QC.numTryShrinks st) | showNumTryShrinks ] ++ + " shrink" ++ + (if QC.numSuccessShrinks st == 1 && not showNumTryShrinks then "" else "s") + | QC.numSuccessShrinks st > 0 || showNumTryShrinks ] ++ + ")" + where + showNumTryShrinks = full && QC.numTryShrinks st > 0 + + number :: Int -> String -> String + number n s = show n ++ " " ++ s ++ if n == 1 then "" else "s" successful :: QC.Result -> Bool successful r = diff --git a/quickcheck/tests/test.hs b/quickcheck/tests/test.hs index 23ca58b3..af91afa8 100644 --- a/quickcheck/tests/test.hs +++ b/quickcheck/tests/test.hs @@ -110,8 +110,15 @@ main = resultDescription =~ "Use .* to reproduce" -- Run the test suite manually and check that progress does not go beyond 100% - , testProperty "Percent Complete" $ withMaxSuccess 1000 $ \(_ :: Int) -> ioProperty $ threadDelay 10000 - + , testProperty "Percent Complete" $ + withMaxSuccess 1000 $ \(_ :: Int) -> ioProperty $ threadDelay 10000 + , localOption (QuickCheckVerboseProgress True) $ + testProperty "Number of tests" $ + withMaxSuccess 1000 $ \(_ :: Int) -> ioProperty $ threadDelay 10000 + , localOption (QuickCheckVerboseProgress True) $ + testProperty "Number of shrinks" $ + expectFailure $ withMaxSize 1000 $ \(Large (x :: Int)) -> + ioProperty $ threadDelay 100000 >> pure (x <= 100) ] run' :: Testable p => p -> IO Result