{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-}
module Test.Tasty.QuickCheck
( testProperty
, testProperties
, QuickCheckTests(..)
, QuickCheckReplay(..)
, QuickCheckShowReplay(..)
, QuickCheckMaxSize(..)
, QuickCheckMaxRatio(..)
, QuickCheckVerbose(..)
, module Test.QuickCheck
, QC(..)
, optionSetToArgs
) where
import Test.Tasty ( testGroup )
import Test.Tasty.Providers
import Test.Tasty.Options
import qualified Test.QuickCheck as QC
import Test.Tasty.Runners (formatMessage)
import Test.QuickCheck hiding
( quickCheck
, Args(..)
, Result
, stdArgs
, quickCheckWith
, quickCheckWithResult
, quickCheckResult
, verboseCheck
, verboseCheckWith
, verboseCheckWithResult
, verboseCheckResult
, verbose
#if MIN_VERSION_QuickCheck(2,11,0)
, allProperties
#endif
, forAllProperties
, quickCheckAll
, verboseCheckAll
)
import Data.Typeable
import Data.List
import Text.Printf
import Test.QuickCheck.Random (mkQCGen)
import Options.Applicative (metavar)
import System.Random (getStdRandom, randomR)
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
import Data.Monoid
import Data.Proxy
#endif
newtype QC = QC QC.Property
deriving Typeable
testProperty :: QC.Testable a => TestName -> a -> TestTree
testProperty name prop = singleTest name $ QC $ QC.property prop
testProperties :: TestName -> [(String, Property)] -> TestTree
testProperties name = testGroup name . map (uncurry testProperty)
newtype QuickCheckTests = QuickCheckTests Int
deriving (Num, Ord, Eq, Real, Enum, Integral, Typeable)
newtype QuickCheckReplay = QuickCheckReplay (Maybe Int)
deriving (Typeable)
newtype QuickCheckShowReplay = QuickCheckShowReplay Bool
deriving (Typeable)
newtype QuickCheckMaxSize = QuickCheckMaxSize Int
deriving (Num, Ord, Eq, Real, Enum, Integral, Typeable)
newtype QuickCheckMaxRatio = QuickCheckMaxRatio Int
deriving (Num, Ord, Eq, Real, Enum, Integral, Typeable)
newtype QuickCheckVerbose = QuickCheckVerbose Bool
deriving (Typeable)
newtype QuickCheckMaxShrinks = QuickCheckMaxShrinks Int
deriving (Num, Ord, Eq, Real, Enum, Integral, Typeable)
instance IsOption QuickCheckTests where
defaultValue = 100
parseValue =
fmap QuickCheckTests . safeRead . filter (/= '_')
optionName = return "quickcheck-tests"
optionHelp = return "Number of test cases for QuickCheck to generate. Underscores accepted: e.g. 10_000_000"
optionCLParser = mkOptionCLParser $ metavar "NUMBER"
instance IsOption QuickCheckReplay where
defaultValue = QuickCheckReplay Nothing
parseValue v = QuickCheckReplay . Just <$> safeRead v
optionName = return "quickcheck-replay"
optionHelp = return "Random seed to use for replaying a previous test run (use same --quickcheck-max-size)"
optionCLParser = mkOptionCLParser $ metavar "SEED"
instance IsOption QuickCheckShowReplay where
defaultValue = QuickCheckShowReplay False
parseValue = fmap QuickCheckShowReplay . safeReadBool
optionName = return "quickcheck-show-replay"
optionHelp = return "Show a replay token for replaying tests"
optionCLParser = flagCLParser Nothing (QuickCheckShowReplay True)
defaultMaxSize :: Int
defaultMaxSize = QC.maxSize QC.stdArgs
instance IsOption QuickCheckMaxSize where
defaultValue = fromIntegral defaultMaxSize
parseValue = fmap QuickCheckMaxSize . safeRead
optionName = return "quickcheck-max-size"
optionHelp = return "Size of the biggest test cases quickcheck generates"
optionCLParser = mkOptionCLParser $ metavar "NUMBER"
instance IsOption QuickCheckMaxRatio where
defaultValue = fromIntegral $ QC.maxDiscardRatio QC.stdArgs
parseValue = fmap QuickCheckMaxRatio . safeRead
optionName = return "quickcheck-max-ratio"
optionHelp = return "Maximum number of discared tests per successful test before giving up"
optionCLParser = mkOptionCLParser $ metavar "NUMBER"
instance IsOption QuickCheckVerbose where
defaultValue = QuickCheckVerbose False
parseValue = fmap QuickCheckVerbose . safeReadBool
optionName = return "quickcheck-verbose"
optionHelp = return "Show the generated test cases"
optionCLParser = mkFlagCLParser mempty (QuickCheckVerbose True)
instance IsOption QuickCheckMaxShrinks where
defaultValue = QuickCheckMaxShrinks (QC.maxShrinks QC.stdArgs)
parseValue = fmap QuickCheckMaxShrinks . safeRead
optionName = return "quickcheck-shrinks"
optionHelp = return "Number of shrinks allowed before QuickCheck will fail a test"
optionCLParser = mkOptionCLParser $ metavar "NUMBER"
optionSetToArgs :: OptionSet -> IO (Int, QC.Args)
optionSetToArgs opts = do
replaySeed <- case mReplay of
Nothing -> getStdRandom (randomR (1,999999))
Just seed -> return seed
let args = QC.stdArgs
{ QC.chatty = False
, QC.maxSuccess = nTests
, QC.maxSize = maxSize
, QC.replay = Just (mkQCGen replaySeed, 0)
, QC.maxDiscardRatio = maxRatio
, QC.maxShrinks = maxShrinks
}
return (replaySeed, args)
where
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
[ Option (Proxy :: Proxy QuickCheckTests)
, Option (Proxy :: Proxy QuickCheckReplay)
, Option (Proxy :: Proxy QuickCheckShowReplay)
, Option (Proxy :: Proxy QuickCheckMaxSize)
, Option (Proxy :: Proxy QuickCheckMaxRatio)
, Option (Proxy :: Proxy QuickCheckVerbose)
, Option (Proxy :: Proxy QuickCheckMaxShrinks)
]
run opts (QC prop) _yieldProgress = do
(replaySeed, args) <- optionSetToArgs opts
let
QuickCheckShowReplay showReplay = lookupOption opts
QuickCheckVerbose verbose = lookupOption opts
maxSize = QC.maxSize args
testRunner = if verbose
then QC.verboseCheckWithResult
else QC.quickCheckWithResult
replayMsg = makeReplayMsg replaySeed maxSize
r <- testRunner args prop
qcOutput <- formatMessage $ QC.output r
let qcOutputNl =
if "\n" `isSuffixOf` qcOutput
then qcOutput
else qcOutput ++ "\n"
testSuccessful = successful r
putReplayInDesc = (not testSuccessful) || showReplay
return $
(if testSuccessful then testPassed else testFailed)
(qcOutputNl ++
(if putReplayInDesc then replayMsg else ""))
successful :: QC.Result -> Bool
successful r =
case r of
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