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

@@ -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 =

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