From cc442ffd338609056a4a201da3877bdc041d0734 Mon Sep 17 00:00:00 2001
From: Joris Dral <joris@well-typed.com>
Date: Mon, 4 Nov 2024 10:12:15 +0100
Subject: [PATCH] Print the number of QuickCheck shrinks in the progress bar

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 changes the progress bar to
print the number of shrinks in case of test failures. Succesful tests will still
print the progress percentage.
---
 quickcheck/Test/Tasty/QuickCheck.hs | 27 +++++++++++++++++++++++++--
 quickcheck/tests/test.hs            |  7 +++++--
 2 files changed, 30 insertions(+), 4 deletions(-)

diff --git a/quickcheck/Test/Tasty/QuickCheck.hs b/quickcheck/Test/Tasty/QuickCheck.hs
index a3057dda..37625b3e 100644
--- a/quickcheck/Test/Tasty/QuickCheck.hs
+++ b/quickcheck/Test/Tasty/QuickCheck.hs
@@ -283,8 +283,31 @@ quickCheck yieldProgress 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 $
+      if QC.numTotTryShrinks st > 0 then
+        emptyProgress {
+            progressText = showShrinkCount st True
+          }
+      else
+        emptyProgress {
+            progressPercent = fromIntegral numSuccessTests / fromIntegral maxSuccessTests
+          }
+
+-- Based on 'QuickCheck.Test.failureSummaryAndReason'.
+showShrinkCount :: QC.State -> Bool -> String
+showShrinkCount st full = count
+  where
+    count :: String
+    count =
+      concat [
+        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
 
 successful :: QC.Result -> Bool
 successful r =
diff --git a/quickcheck/tests/test.hs b/quickcheck/tests/test.hs
index 23ca58b3..c2562cc7 100644
--- a/quickcheck/tests/test.hs
+++ b/quickcheck/tests/test.hs
@@ -110,8 +110,11 @@ 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
+      , testProperty "Number of shrinks" $
+          expectFailure $ withMaxSize 1000 $ \(Large (x :: Int)) ->
+            ioProperty $ threadDelay 100000 >> pure (x <= 100)
       ]
 
 run' :: Testable p => p -> IO Result