Avoid running earlier successes with --quickcheck-replay

quickcheck/CHANGELOG.md

@@ -1,6 +1,26 @@
 Changes
 =======
 
+Next Version
+------------
+
+Version 0.11
+--------------
+
+* Produce seeds that run a single failing tests instead of reproducing
+  all the earlier successes ([#410](https://github.com/UnkindPartition/tasty/pull/410)).
+
+  Seeds are now pairs instead of single integers, e.g.
+  `--quickcheck-replay="(SMGen 2909028190965759779 12330386376379709109,0)"`
+
+  Single integer seeds are still accepted as input, but they do run through
+  earlier successes.
+
+  The `QuickCheckReplay` type used as a tasty option has three data constructors
+  now. `QuickCheckReplayNone` is the default value and provides no seed.
+  `QuickCheckReplayLegacy` takes an integer as before. The `QuickCheckReplay`
+  data constructor takes the new seed form.
+
 Version 0.10.3
 --------------
 

quickcheck/Test/Tasty/QuickCheck.hs

@@ -50,16 +50,16 @@ import Test.QuickCheck hiding -- for re-export
   , verboseCheckAll
   )
 
+import Control.Applicative
 import qualified Data.Char as Char
 import Data.Typeable
 import Data.List
 import Text.Printf
 import Text.Read (readMaybe)
-import Test.QuickCheck.Random (mkQCGen)
+import Test.QuickCheck.Random (QCGen, mkQCGen)
 import Options.Applicative (metavar)
 import System.Random (getStdRandom, randomR)
 #if !MIN_VERSION_base(4,9,0)
-import Control.Applicative
 import Data.Monoid
 #endif
 
@@ -82,7 +82,21 @@ testProperties name = testGroup name . map (uncurry testProperty)
 newtype QuickCheckTests = QuickCheckTests Int
   deriving (Num, Ord, Eq, Real, Enum, Integral, Typeable)
 
-newtype QuickCheckReplay = QuickCheckReplay (Maybe Int)
+-- | Replay seed
+data QuickCheckReplay
+    = -- | No seed
+      --
+      -- @since 0.11
+      QuickCheckReplayNone
+    | -- | Legacy integer seed
+      --
+      -- @since 0.11
+      QuickCheckReplayLegacy Int
+    | -- | @(qcgen, intSize)@ holds both the seed and the size
+      -- to run QuickCheck tests
+      --
+      -- @since 0.11
+      QuickCheckReplay (QCGen, Int)
   deriving (Typeable)
 
 -- | If a test case fails unexpectedly, show the replay token
@@ -118,11 +132,12 @@ instance IsOption QuickCheckTests where
   optionCLParser = mkOptionCLParser $ metavar "NUMBER"
 
 instance IsOption QuickCheckReplay where
-  defaultValue = QuickCheckReplay Nothing
-  -- Reads a replay int seed
-  parseValue v = QuickCheckReplay . Just <$> safeRead v
+  defaultValue = QuickCheckReplayNone
+  -- Reads either a replay Int seed or a (QCGen, Int) seed
+  parseValue v =
+    (QuickCheckReplayLegacy <$> safeRead v) <|> (QuickCheckReplay <$> safeRead v)
   optionName = return "quickcheck-replay"
-  optionHelp = return "Random seed to use for replaying a previous test run (use same --quickcheck-max-size)"
+  optionHelp = return "Random seed to use for replaying a previous test run"
   optionCLParser = mkOptionCLParser $ metavar "SEED"
 
 instance IsOption QuickCheckShowReplay where
@@ -168,30 +183,37 @@ instance IsOption QuickCheckMaxShrinks where
 -- This is a low-level function that was originally added for tasty-hspec
 -- but may be used by others.
 --
+-- The returned Int is kept only for backward compatibility purposes. It
+-- has no use in @tasty-quickcheck@.
+--
 -- @since 0.9.1
 optionSetToArgs :: OptionSet -> IO (Int, QC.Args)
 optionSetToArgs opts = do
-  replaySeed <- case mReplay of
-    Nothing -> getStdRandom (randomR (1,999999))
-    Just seed -> return seed
+  (intSeed, replaySeed) <- case quickCheckReplay of
+    QuickCheckReplayNone -> do
+      intSeed <- getStdRandom (randomR (1,999999))
+      return (intSeed, (mkQCGen intSeed, 0))
+    QuickCheckReplayLegacy intSeed -> return (intSeed, (mkQCGen intSeed, 0))
+    -- The intSeed is not used when the new form of replay seed is used.
+    QuickCheckReplay replaySeed -> return (0, replaySeed)
 
   let args = QC.stdArgs
         { QC.chatty          = False
         , QC.maxSuccess      = nTests
         , QC.maxSize         = maxSize
-        , QC.replay          = Just (mkQCGen replaySeed, 0)
+        , QC.replay          = Just replaySeed
         , QC.maxDiscardRatio = maxRatio
         , QC.maxShrinks      = maxShrinks
         }
 
-  return (replaySeed, args)
+  return (intSeed, args)
 
   where
-    QuickCheckTests      nTests     = lookupOption opts
-    QuickCheckReplay     mReplay    = lookupOption opts
-    QuickCheckMaxSize    maxSize    = lookupOption opts
-    QuickCheckMaxRatio   maxRatio   = lookupOption opts
-    QuickCheckMaxShrinks maxShrinks = lookupOption opts
+    QuickCheckTests        nTests        = lookupOption opts
+    quickCheckReplay                     = lookupOption opts
+    QuickCheckMaxSize      maxSize       = lookupOption opts
+    QuickCheckMaxRatio     maxRatio      = lookupOption opts
+    QuickCheckMaxShrinks   maxShrinks    = lookupOption opts
 
 instance IsTest QC where
   testOptions = return
@@ -205,12 +227,10 @@ instance IsTest QC where
     ]
 
   run opts (QC prop) yieldProgress = do
-    (replaySeed, args) <- optionSetToArgs opts
+    (_, args) <- optionSetToArgs opts
     let
       QuickCheckShowReplay showReplay = lookupOption opts
       QuickCheckVerbose    verbose    = lookupOption opts
-      maxSize = QC.maxSize args
-      replayMsg = makeReplayMsg replaySeed maxSize
 
     -- Quickcheck already catches exceptions, no need to do it here.
     r <- quickCheck yieldProgress
@@ -224,6 +244,8 @@ 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
     return $
       (if testSuccessful then testPassed else testFailed)
       (qcOutputNl ++
@@ -259,9 +281,12 @@ successful r =
     QC.Success {} -> True
     _ -> False
 
-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
+makeReplayMsg :: (QCGen, Int) -> String
+makeReplayMsg seedSz =
+  printf "Use --quickcheck-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

quickcheck/tasty-quickcheck.cabal

@@ -2,7 +2,7 @@
 -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                tasty-quickcheck
-version:             0.10.3
+version:             0.11
 synopsis:            QuickCheck support for the Tasty test framework.
 description:         QuickCheck support for the Tasty test framework.
                      .
@@ -55,6 +55,7 @@ test-suite test
     , tasty-quickcheck
     , tasty-hunit
     , pcre-light
+    , QuickCheck
   ghc-options: -Wall
   if (!impl(ghc >= 8.0) || os(windows))
     buildable: False

quickcheck/tests/test.hs

@@ -6,6 +6,7 @@ import Test.Tasty.Runners as Tasty
 import Test.Tasty.QuickCheck
 import Test.Tasty.HUnit
 import Data.Maybe
+import Test.QuickCheck.Random (QCGen)
 import Text.Regex.PCRE.Light.Char8
 import Text.Printf
 
@@ -67,6 +68,29 @@ main =
           resultDescription =~ "Failed"
           resultDescription =~ "Use .* to reproduce"
 
+      , testCase "Replay unexpected failure" $ do
+          Result{..} <- runMaxSized 3 $ \x -> x /= (2 :: Int)
+          case resultOutcome of
+            Tasty.Failure {} -> return ()
+            _ -> assertFailure $ show resultOutcome
+          resultDescription =~ "Failed"
+          resultDescription =~ "Use --quickcheck-replay=.* to reproduce."
+          let firstResultDescription = resultDescription
+          Just seedSz <- return (parseSeed resultDescription)
+
+          Result{..} <- runReplayWithSeed seedSz $ \x -> x /= (2 :: Int)
+          case resultOutcome of
+            Tasty.Failure {} -> return ()
+            _ -> assertFailure $ show resultOutcome
+
+          resultDescription =~ "Failed"
+          -- Compare the last lines reporting the replay seed.
+          let lastLine = concat . take 1 . reverse . lines
+          lastLine resultDescription =~ "Use --quickcheck-replay=.* to reproduce."
+          lastLine resultDescription @?= lastLine firstResultDescription
+          -- Exactly one test is executed
+          resultDescription =~ "Falsified \\(after 1 test\\)"
+
       , testCase "Gave up" $ do
           Result{..} <- run' $ \x -> x > x ==> x > (x :: Int)
           case resultOutcome of
@@ -98,3 +122,24 @@ runReplay p =
     (singleOption $ QuickCheckShowReplay True)
     (QC $ property p)
     (const $ return ())
+
+runMaxSized :: Testable p => Int -> p -> IO Result
+runMaxSized sz p =
+  run
+    (singleOption $ QuickCheckMaxSize sz)
+    (QC $ property p)
+    (const $ return ())
+
+runReplayWithSeed :: Testable p => (QCGen, Int) -> p -> IO Result
+runReplayWithSeed seedSz p =
+  run
+    (singleOption $ QuickCheckReplay seedSz)
+    (QC $ property p)
+    (const $ return ())
+
+-- | Reads a seed from a message like
+--
+-- > "Use --quickcheck-single-replay=\"(SMGen 2909028190965759779 12330386376379709109,0)\" to reproduce."
+--
+parseSeed :: String -> Maybe (QCGen, Int)
+parseSeed = safeRead . takeWhile (/= '\"') . drop 1 . dropWhile (/='\"')