From 363da1a4931ac28e137f82933887ae5f05259de8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= Date: Mon, 18 Mar 2024 17:39:45 +0000 Subject: [PATCH] Avoid running earlier successes with --quickcheck-replay On failure, tasty-quickcheck now suggests string seeds (no integer seeds anymore). Integer seeds are still accepted as input though. --- quickcheck/CHANGELOG.md | 12 ++++++ quickcheck/Test/Tasty/QuickCheck.hs | 65 ++++++++++++++++++----------- quickcheck/tasty-quickcheck.cabal | 1 + quickcheck/tests/test.hs | 45 ++++++++++++++++++++ 4 files changed, 98 insertions(+), 25 deletions(-) diff --git a/quickcheck/CHANGELOG.md b/quickcheck/CHANGELOG.md index 119d60aa..7756335c 100644 --- a/quickcheck/CHANGELOG.md +++ b/quickcheck/CHANGELOG.md @@ -1,6 +1,18 @@ Changes ======= +Next Version +------------ + +* 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 strings, 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. + Version 0.10.3 -------------- diff --git a/quickcheck/Test/Tasty/QuickCheck.hs b/quickcheck/Test/Tasty/QuickCheck.hs index 04b45a6d..e34b049c 100644 --- a/quickcheck/Test/Tasty/QuickCheck.hs +++ b/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,10 @@ 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. The @Left int@ form is kept for legacy purposes. +-- The form @Right (qcgen, intSize)@ holds both the seed and the size +-- to run QuickCheck tests. +newtype QuickCheckReplay = QuickCheckReplay (Maybe (Either Int (QCGen, Int))) deriving (Typeable) -- | If a test case fails unexpectedly, show the replay token @@ -119,10 +122,12 @@ instance IsOption QuickCheckTests where instance IsOption QuickCheckReplay where defaultValue = QuickCheckReplay Nothing - -- Reads a replay int seed - parseValue v = QuickCheckReplay . Just <$> safeRead v + -- Reads either a replay Int seed or a (QCGen, Int) seed + parseValue v = do + QuickCheckReplay . Just <$> + ((Left <$> safeRead v) <|> (Right <$> 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 +173,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 tast-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 mReplay of + Nothing -> do + intSeed <- getStdRandom (randomR (1,999999)) + return (intSeed, (mkQCGen intSeed, 0)) + Just (Left intSeed) -> return (intSeed, (mkQCGen intSeed, 0)) + -- The intSeed is not used when the new form of replay seed is used. + Just (Right 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 mReplay = lookupOption opts + QuickCheckMaxSize maxSize = lookupOption opts + QuickCheckMaxRatio maxRatio = lookupOption opts + QuickCheckMaxShrinks maxShrinks = lookupOption opts instance IsTest QC where testOptions = return @@ -205,12 +217,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 +234,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 +271,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 diff --git a/quickcheck/tasty-quickcheck.cabal b/quickcheck/tasty-quickcheck.cabal index a5f16fd8..c443ab6f 100644 --- a/quickcheck/tasty-quickcheck.cabal +++ b/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 diff --git a/quickcheck/tests/test.hs b/quickcheck/tests/test.hs index 2c61bdac..ec17b3f4 100644 --- a/quickcheck/tests/test.hs +++ b/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 $ Just (Right 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 (/='\"')