From 747916e07a5291acc5ac225755d9be925f3bf410 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= <facundo.dominguez@tweag.io>
Date: Tue, 19 Mar 2024 00:07:40 +0000
Subject: [PATCH] Show both --quickcheck-replay and --quickcheck-single-replay

---
 quickcheck/Test/Tasty/QuickCheck.hs | 53 ++++++++++++++++++++---------
 quickcheck/tests/test.hs            | 14 +++++---
 2 files changed, 45 insertions(+), 22 deletions(-)

diff --git a/quickcheck/Test/Tasty/QuickCheck.hs b/quickcheck/Test/Tasty/QuickCheck.hs
index 259bf280..98ccd138 100644
--- a/quickcheck/Test/Tasty/QuickCheck.hs
+++ b/quickcheck/Test/Tasty/QuickCheck.hs
@@ -53,6 +53,7 @@ import Test.QuickCheck hiding -- for re-export
 
 import Control.Applicative
 import qualified Data.Char as Char
+import Data.Maybe (fromMaybe)
 import Data.Typeable
 import Data.List
 import Text.Printf
@@ -180,27 +181,25 @@ instance IsOption QuickCheckMaxShrinks where
 -- but may be used by others.
 --
 -- @since 0.9.1
-optionSetToArgs :: OptionSet -> IO QC.Args
+optionSetToArgs :: OptionSet -> IO (Int, QC.Args)
 optionSetToArgs opts = do
-  replaySeed <- case mSingleReplay of
-      Nothing -> do
-        seed <- case mReplay of
-          Nothing -> getStdRandom (randomR (1,999999))
-          Just seed -> return seed
-        return (mkQCGen seed, 0)
-
-      Just seedSz -> return seedSz
+  replaySeed <- case mReplay of
+    Nothing -> getStdRandom (randomR (1,999999))
+    Just seed -> return seed
+  replaySingleSeed <- case mSingleReplay of
+    Nothing -> return (mkQCGen replaySeed, 0)
+    Just seedSz -> return seedSz
 
   let args = QC.stdArgs
         { QC.chatty          = False
         , QC.maxSuccess      = nTests
         , QC.maxSize         = maxSize
-        , QC.replay          = Just replaySeed
+        , QC.replay          = Just replaySingleSeed
         , QC.maxDiscardRatio = maxRatio
         , QC.maxShrinks      = maxShrinks
         }
 
-  return args
+  return (replaySeed, args)
 
   where
     QuickCheckTests        nTests        = lookupOption opts
@@ -223,7 +222,7 @@ instance IsTest QC where
     ]
 
   run opts (QC prop) yieldProgress = do
-    args <- optionSetToArgs opts
+    (replaySeed, args) <- optionSetToArgs opts
     let
       QuickCheckShowReplay showReplay = lookupOption opts
       QuickCheckVerbose    verbose    = lookupOption opts
@@ -240,8 +239,7 @@ instance IsTest QC where
             else qcOutput ++ "\n"
         testSuccessful = successful r
         putReplayInDesc = (not testSuccessful) || showReplay
-    Just seedSz <- return $ replayFromResult r <|> QC.replay args
-    let replayMsg = makeReplayMsg seedSz
+        replayMsg = makeFullReplayMsg replaySeed opts r args
     return $
       (if testSuccessful then testPassed else testFailed)
       (qcOutputNl ++
@@ -277,12 +275,33 @@ successful r =
     QC.Success {} -> True
     _ -> False
 
-makeReplayMsg :: (QCGen, Int) -> String
-makeReplayMsg seedSz =
-  printf "Use --quickcheck-single-replay=\"%s\" to reproduce." (show seedSz)
+makeReplayMsg :: Int -> Int -> String
+makeReplayMsg seed size = let
+    sizeStr = if (size /= defaultMaxSize)
+                 then printf " --quickcheck-max-size=%d" size
+                 else ""
+  in printf "Use --quickcheck-replay=%d%s to reproduce." seed sizeStr
+
+makeSingleReplayMsg :: (QCGen, Int) -> String
+makeSingleReplayMsg seedSz =
+  printf "--quickcheck-single-replay=\"%s\" to reproduce." (show seedSz)
 
 replayFromResult :: QC.Result -> Maybe (QCGen, Int)
 replayFromResult r =
   case r of
     Failure{} -> Just (QC.usedSeed r, QC.usedSize r)
     _ -> Nothing
+
+makeFullReplayMsg :: Int -> OptionSet -> QC.Result -> QC.Args -> String
+makeFullReplayMsg replaySeed opts r args = let
+    seedSz = fromMaybe (error "unexpected Nothing") $
+               replayFromResult r <|> QC.replay args
+    QuickCheckSingleReplay mSingleReplay = lookupOption opts
+    replayMsg = makeReplayMsg replaySeed (QC.maxSize args)
+    singleReplayMsg = makeSingleReplayMsg seedSz
+  in -- There is no point in showing --quickcheck-replay if
+     -- --quickcheck-single-replay was set, because the value of
+     -- --quickcheck-reply is overriden in such a case.
+     case mSingleReplay of
+       Just _ -> "Use " ++ singleReplayMsg
+       Nothing -> replayMsg ++ "\nOr use " ++ singleReplayMsg
diff --git a/quickcheck/tests/test.hs b/quickcheck/tests/test.hs
index 5833e9a5..8294ea49 100644
--- a/quickcheck/tests/test.hs
+++ b/quickcheck/tests/test.hs
@@ -74,7 +74,10 @@ main =
             Tasty.Failure {} -> return ()
             _ -> assertFailure $ show resultOutcome
           resultDescription =~ "Failed"
-          resultDescription =~ "Use .* to reproduce"
+          resultDescription =~ concat
+            [ "Use --quickcheck-replay=.* to reproduce.\n"
+            , "Or use --quickcheck-single-replay=\".*\" to reproduce."
+            ]
           let firstResultDescription = resultDescription
           Just seedSz <- return (parseSeed resultDescription)
 
@@ -84,10 +87,11 @@ main =
             _ -> assertFailure $ show resultOutcome
 
           resultDescription =~ "Failed"
-          -- drop the prefix "*** Failed! Falsified (after 1 test):" from the descriptions
-          dropWhile (/=':') resultDescription
-            @?= dropWhile (/=':') firstResultDescription
-          -- exactly one test is executed
+          -- Compare the last lines reporting the single-replay seed.
+          -- Remove the start of the lines: "Or use" vs "Use".
+          drop 1 (words (last (lines resultDescription))) @?=
+            drop 2 (words (last (lines firstResultDescription)))
+          -- Exactly one test is executed
           takeWhile (/=':') resultDescription @?= "*** Failed! Falsified (after 1 test)"
 
       , testCase "Gave up" $ do