Implement --quickcheck-single-replay for tasty-quickcheck

... to replay a test without running earlier successes.

On failure, tasty-quickcheck now suggests --quickcheck-single-replay instead
of --quickcheck-replay. Both options are still accepted with
--quickcheck-single-replay taking precedence over --quickcheck-replay

quickcheck/Test/Tasty/QuickCheck.hs

@@ -5,6 +5,7 @@ module Test.Tasty.QuickCheck
   , testProperties
   , QuickCheckTests(..)
   , QuickCheckReplay(..)
+  , QuickCheckSingleReplay(..)
   , QuickCheckShowReplay(..)
   , QuickCheckMaxSize(..)
   , QuickCheckMaxRatio(..)
@@ -50,16 +51,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
 
@@ -85,6 +86,9 @@ newtype QuickCheckTests = QuickCheckTests Int
 newtype QuickCheckReplay = QuickCheckReplay (Maybe Int)
   deriving (Typeable)
 
+newtype QuickCheckSingleReplay = QuickCheckSingleReplay (Maybe (QCGen, Int))
+  deriving (Typeable)
+
 -- | If a test case fails unexpectedly, show the replay token
 newtype QuickCheckShowReplay = QuickCheckShowReplay Bool
   deriving (Typeable)
@@ -125,6 +129,13 @@ instance IsOption QuickCheckReplay where
   optionHelp = return "Random seed to use for replaying a previous test run (use same --quickcheck-max-size)"
   optionCLParser = mkOptionCLParser $ metavar "SEED"
 
+instance IsOption QuickCheckSingleReplay where
+  defaultValue = QuickCheckSingleReplay Nothing
+  parseValue v = QuickCheckSingleReplay . Just <$> safeRead v
+  optionName = return "quickcheck-single-replay"
+  optionHelp = return "Random seed to use for replaying a single previous test"
+  optionCLParser = mkOptionCLParser $ metavar "SEED"
+
 instance IsOption QuickCheckShowReplay where
   defaultValue = QuickCheckShowReplay False
   parseValue = fmap QuickCheckShowReplay . safeReadBool
@@ -169,34 +180,41 @@ instance IsOption QuickCheckMaxShrinks where
 -- but may be used by others.
 --
 -- @since 0.9.1
-optionSetToArgs :: OptionSet -> IO (Int, QC.Args)
+optionSetToArgs :: OptionSet -> IO QC.Args
 optionSetToArgs opts = do
-  replaySeed <- case mReplay of
-    Nothing -> getStdRandom (randomR (1,999999))
-    Just seed -> return seed
+  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
 
   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 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       mReplay       = lookupOption opts
+    QuickCheckSingleReplay mSingleReplay = lookupOption opts
+    QuickCheckMaxSize      maxSize       = lookupOption opts
+    QuickCheckMaxRatio     maxRatio      = lookupOption opts
+    QuickCheckMaxShrinks   maxShrinks    = lookupOption opts
 
 instance IsTest QC where
   testOptions = return
     [ Option (Proxy :: Proxy QuickCheckTests)
     , Option (Proxy :: Proxy QuickCheckReplay)
+    , Option (Proxy :: Proxy QuickCheckSingleReplay)
     , Option (Proxy :: Proxy QuickCheckShowReplay)
     , Option (Proxy :: Proxy QuickCheckMaxSize)
     , Option (Proxy :: Proxy QuickCheckMaxRatio)
@@ -205,12 +223,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 +240,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 +277,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-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

quickcheck/tasty-quickcheck.cabal

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

@@ -1,4 +1,5 @@
 {-# LANGUAGE RecordWildCards #-}
+import Test.QuickCheck.Random
 import Test.Tasty
 import Test.Tasty.Options
 import Test.Tasty.Providers as Tasty
@@ -67,6 +68,28 @@ 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 .* 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"
+          -- drop the prefix "*** Failed! Falsified (after 1 test):" from the descriptions
+          dropWhile (/=':') resultDescription
+            @?= dropWhile (/=':') firstResultDescription
+          -- exactly one test is executed
+          takeWhile (/=':') resultDescription @?= "*** Failed! Falsified (after 1 test)"
+
       , testCase "Gave up" $ do
           Result{..} <- run' $ \x -> x > x ==> x > (x :: Int)
           case resultOutcome of
@@ -98,3 +121,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 $ QuickCheckSingleReplay (Just 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 (/='\"')