Skip to content

Commit

Permalink
Show both --quickcheck-replay and --quickcheck-single-replay
Browse files Browse the repository at this point in the history
  • Loading branch information
facundominguez committed Mar 19, 2024
1 parent 1f6ed71 commit 747916e
Show file tree
Hide file tree
Showing 2 changed files with 45 additions and 22 deletions.
53 changes: 36 additions & 17 deletions quickcheck/Test/Tasty/QuickCheck.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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 ++
Expand Down Expand Up @@ -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
14 changes: 9 additions & 5 deletions quickcheck/tests/test.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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)

Expand All @@ -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
Expand Down

0 comments on commit 747916e

Please sign in to comment.