From 1f6ed71dbec25257f1bd77b96bb2d95fad038f4e 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] 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 | 65 +++++++++++++++++++---------- quickcheck/tasty-quickcheck.cabal | 1 + quickcheck/tests/test.hs | 44 +++++++++++++++++++ 3 files changed, 88 insertions(+), 22 deletions(-) diff --git a/quickcheck/Test/Tasty/QuickCheck.hs b/quickcheck/Test/Tasty/QuickCheck.hs index 04b45a6d..259bf280 100644 --- a/quickcheck/Test/Tasty/QuickCheck.hs +++ b/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 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..5833e9a5 100644 --- a/quickcheck/tests/test.hs +++ b/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 (/='\"')