diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2011-2023 Simon Hengel +Copyright (c) 2011-2024 Simon Hengel Copyright (c) 2011-2012 Trystan Spangler Copyright (c) 2011-2011 Greg Weber diff --git a/help.txt b/help.txt --- a/help.txt +++ b/help.txt @@ -28,6 +28,8 @@ -j N --jobs=N run at most N parallelizable tests simultaneously (default: number of available processors) + --seed=N used seed for --randomize and QuickCheck + properties FORMATTER OPTIONS -f NAME --format=NAME use a custom formatter; this can be one of @@ -57,7 +59,6 @@ --qc-max-size=N size to use for the biggest test cases --qc-max-shrinks=N maximum number of shrinks to perform before giving up (a value of 0 turns shrinking off) - --seed=N used seed for QuickCheck properties OPTIONS FOR SMALLCHECK --depth=N maximum depth of generated test values for SmallCheck properties diff --git a/hspec-core.cabal b/hspec-core.cabal --- a/hspec-core.cabal +++ b/hspec-core.cabal @@ -5,10 +5,10 @@ -- see: https://github.com/sol/hpack name: hspec-core -version: 2.11.7 +version: 2.11.8 license: MIT license-file: LICENSE -copyright: (c) 2011-2023 Simon Hengel, +copyright: (c) 2011-2024 Simon Hengel, (c) 2011-2012 Trystan Spangler, (c) 2011 Greg Weber maintainer: Simon Hengel @@ -36,7 +36,7 @@ ghc-options: -Wall -fno-warn-incomplete-uni-patterns build-depends: HUnit ==1.6.* - , QuickCheck >=2.13.1 + , QuickCheck >=2.13.1 && <2.16 , ansi-terminal >=0.6.2 , array , base >=4.8.2.0 && <5 @@ -86,7 +86,7 @@ Test.Hspec.Core.Formatters.V1.Free Test.Hspec.Core.Formatters.V1.Internal Test.Hspec.Core.Formatters.V1.Monad - Test.Hspec.Core.QuickCheckUtil + Test.Hspec.Core.QuickCheck.Util Test.Hspec.Core.Runner.Eval Test.Hspec.Core.Runner.JobQueue Test.Hspec.Core.Runner.PrintSlowSpecItems @@ -130,7 +130,7 @@ , filepath , haskell-lexer , hspec-expectations ==0.8.4.* - , hspec-meta ==2.11.7 + , hspec-meta ==2.11.8 , process , quickcheck-io >=0.2.0 , random @@ -171,7 +171,7 @@ Test.Hspec.Core.Formatters.V2 Test.Hspec.Core.Hooks Test.Hspec.Core.QuickCheck - Test.Hspec.Core.QuickCheckUtil + Test.Hspec.Core.QuickCheck.Util Test.Hspec.Core.Runner Test.Hspec.Core.Runner.Eval Test.Hspec.Core.Runner.JobQueue @@ -207,7 +207,7 @@ Test.Hspec.Core.Formatters.V1Spec Test.Hspec.Core.Formatters.V2Spec Test.Hspec.Core.HooksSpec - Test.Hspec.Core.QuickCheckUtilSpec + Test.Hspec.Core.QuickCheck.UtilSpec Test.Hspec.Core.Runner.EvalSpec Test.Hspec.Core.Runner.JobQueueSpec Test.Hspec.Core.Runner.PrintSlowSpecItemsSpec diff --git a/src/Test/Hspec/Core/Config.hs b/src/Test/Hspec/Core/Config.hs --- a/src/Test/Hspec/Core/Config.hs +++ b/src/Test/Hspec/Core/Config.hs @@ -29,9 +29,9 @@ import Test.Hspec.Core.Util import Test.Hspec.Core.Config.Options -import Test.Hspec.Core.Config.Definition (Config(..), ColorMode(..), UnicodeMode(..), mkDefaultConfig, filterOr) +import Test.Hspec.Core.Config.Definition import Test.Hspec.Core.FailureReport -import Test.Hspec.Core.QuickCheckUtil (mkGen) +import Test.Hspec.Core.QuickCheck.Util (mkGen) import Test.Hspec.Core.Example (Params(..), defaultParams) import qualified Test.Hspec.Core.Formatters.V2 as V2 @@ -52,21 +52,21 @@ } applyFailureReport :: Maybe FailureReport -> Config -> Config -applyFailureReport mFailureReport opts = opts { +applyFailureReport mFailureReport config = config { configFilterPredicate = matchFilter `filterOr` rerunFilter - , configQuickCheckSeed = mSeed + , configSeed = mSeed , configQuickCheckMaxSuccess = mMaxSuccess , configQuickCheckMaxDiscardRatio = mMaxDiscardRatio , configQuickCheckMaxSize = mMaxSize } where - mSeed = configQuickCheckSeed opts <|> (failureReportSeed <$> mFailureReport) - mMaxSuccess = configQuickCheckMaxSuccess opts <|> (failureReportMaxSuccess <$> mFailureReport) - mMaxSize = configQuickCheckMaxSize opts <|> (failureReportMaxSize <$> mFailureReport) - mMaxDiscardRatio = configQuickCheckMaxDiscardRatio opts <|> (failureReportMaxDiscardRatio <$> mFailureReport) + mSeed = configSeed config <|> deprecatedQuickCheckSeed config <|> (failureReportSeed <$> mFailureReport) + mMaxSuccess = configQuickCheckMaxSuccess config <|> (failureReportMaxSuccess <$> mFailureReport) + mMaxSize = configQuickCheckMaxSize config <|> (failureReportMaxSize <$> mFailureReport) + mMaxDiscardRatio = configQuickCheckMaxDiscardRatio config <|> (failureReportMaxDiscardRatio <$> mFailureReport) - matchFilter = configFilterPredicate opts + matchFilter = configFilterPredicate config rerunFilter = case failureReportPaths <$> mFailureReport of Just [] -> Nothing @@ -77,7 +77,7 @@ configQuickCheckArgs c = qcArgs where qcArgs = ( - maybe id setSeed (configQuickCheckSeed c) + maybe id setSeed (configSeed c) . maybe id setMaxShrinks (configQuickCheckMaxShrinks c) . maybe id setMaxSize (configQuickCheckMaxSize c) . maybe id setMaxDiscardRatio (configQuickCheckMaxDiscardRatio c) diff --git a/src/Test/Hspec/Core/Config/Definition.hs b/src/Test/Hspec/Core/Config/Definition.hs --- a/src/Test/Hspec/Core/Config/Definition.hs +++ b/src/Test/Hspec/Core/Config/Definition.hs @@ -12,6 +12,8 @@ , quickCheckOptions , runnerOptions +, deprecatedQuickCheckSeed + #ifdef TEST , splitOn #endif @@ -24,7 +26,6 @@ import System.IO (openTempFile, hClose) import System.Process (system) -import Test.Hspec.Core.Example (Params(..), defaultParams) import Test.Hspec.Core.Format (Format, FormatConfig) import Test.Hspec.Core.Formatters.Pretty (pretty2) import qualified Test.Hspec.Core.Formatters.V1.Monad as V1 @@ -51,6 +52,8 @@ , configPrintCpuTime :: Bool , configFailFast :: Bool , configRandomize :: Bool +, configSeed :: Maybe Integer +, configQuickCheckSeed :: Maybe Integer , configFailureReport :: Maybe FilePath , configRerun :: Bool , configRerunAllOnSuccess :: Bool @@ -60,7 +63,6 @@ -- that satisfy the predicate are run. , configFilterPredicate :: Maybe (Path -> Bool) , configSkipPredicate :: Maybe (Path -> Bool) -, configQuickCheckSeed :: Maybe Integer , configQuickCheckMaxSuccess :: Maybe Int , configQuickCheckMaxDiscardRatio :: Maybe Int , configQuickCheckMaxSize :: Maybe Int @@ -91,7 +93,11 @@ , configConcurrentJobs :: Maybe Int } {-# DEPRECATED configFormatter "Use [@useFormatter@](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Formatters-V1.html#v:useFormatter) instead." #-} +{-# DEPRECATED configQuickCheckSeed "Use `configSeed` instead." #-} +deprecatedQuickCheckSeed :: Config -> Maybe Integer +deprecatedQuickCheckSeed = configQuickCheckSeed + mkDefaultConfig :: [(String, FormatConfig -> IO Format)] -> Config mkDefaultConfig formatters = Config { configIgnoreConfigFile = False @@ -105,17 +111,18 @@ , configPrintCpuTime = False , configFailFast = False , configRandomize = False +, configSeed = Nothing +, configQuickCheckSeed = Nothing , configFailureReport = Nothing , configRerun = False , configRerunAllOnSuccess = False , configFilterPredicate = Nothing , configSkipPredicate = Nothing -, configQuickCheckSeed = Nothing , configQuickCheckMaxSuccess = Nothing , configQuickCheckMaxDiscardRatio = Nothing , configQuickCheckMaxSize = Nothing , configQuickCheckMaxShrinks = Nothing -, configSmallCheckDepth = paramsSmallCheckDepth defaultParams +, configSmallCheckDepth = Nothing , configColorMode = ColorAuto , configUnicodeMode = UnicodeAuto , configDiff = True @@ -153,8 +160,8 @@ option :: String -> OptionSetter config -> String -> Option config option name arg help = Option name Nothing arg help True -mkFlag :: String -> (Bool -> Config -> Config) -> String -> Option Config -mkFlag name setter = option name (Flag setter) +flag :: String -> (Bool -> Config -> Config) -> String -> Option Config +flag name setter = option name (Flag setter) mkOptionNoArg :: String -> Maybe Char -> (Config -> Config) -> String -> Option Config mkOptionNoArg name shortcut setter help = Option name shortcut (NoArg setter) help True @@ -171,22 +178,22 @@ formatterOptions :: [(String, FormatConfig -> IO Format)] -> [Option Config] formatterOptions formatters = [ mkOption "format" (Just 'f') (argument "NAME" readFormatter setFormatter) helpForFormat - , mkFlag "color" setColor "colorize the output" - , mkFlag "unicode" setUnicode "output unicode" - , mkFlag "diff" setDiff "show colorized diffs" + , flag "color" setColor "colorize the output" + , flag "unicode" setUnicode "output unicode" + , flag "diff" setDiff "show colorized diffs" , option "diff-context" (argument "N" readDiffContext setDiffContext) $ unlines [ "output N lines of diff context (default: " <> show defaultDiffContext <> ")" , "use a value of 'full' to see the full context" ] , option "diff-command" (argument "CMD" return setDiffCommand) "use an external diff command\nexample: --diff-command=\"git diff\"" - , mkFlag "pretty" setPretty "try to pretty-print diff values" + , flag "pretty" setPretty "try to pretty-print diff values" , mkOptionNoArg "show-exceptions" Nothing setShowException "use `show` when formatting exceptions" , mkOptionNoArg "display-exceptions" Nothing setDisplayException "use `displayException` when formatting exceptions" - , mkFlag "times" setTimes "report times for individual spec items" + , flag "times" setTimes "report times for individual spec items" , mkOptionNoArg "print-cpu-time" Nothing setPrintCpuTime "include used CPU time in summary" , printSlowItemsOption - , mkFlag "expert" setExpertMode "be less verbose" + , flag "expert" setExpertMode "be less verbose" -- undocumented for now, as we probably want to change this to produce a -- standalone HTML report in the future @@ -277,7 +284,6 @@ , option "qc-max-discard" (argument "N" readMaybe setMaxDiscardRatio) "maximum number of discarded tests per successful test before giving up" , option "qc-max-size" (argument "N" readMaybe setMaxSize) "size to use for the biggest test cases" , option "qc-max-shrinks" (argument "N" readMaybe setMaxShrinks) "maximum number of shrinks to perform before giving up (a value of 0 turns shrinking off)" - , option "seed" (argument "N" readMaybe setSeed) "used seed for QuickCheck properties" -- for compatibility with test-framework , undocumented $ option "maximum-generated-tests" (argument "NUMBER" readMaybe setMaxSuccess) "how many automated tests something like QuickCheck should try, by default" @@ -296,7 +302,7 @@ setMaxShrinks n c = c {configQuickCheckMaxShrinks = Just n} setSeed :: Integer -> Config -> Config -setSeed n c = c {configQuickCheckSeed = Just n} +setSeed n c = c {configSeed = Just n} data FailOn = FailOnEmpty @@ -330,22 +336,23 @@ runnerOptions :: [Option Config] runnerOptions = [ - mkFlag "dry-run" setDryRun "pretend that everything passed; don't verify anything" - , mkFlag "focused-only" setFocusedOnly "do not run anything, unless there are focused spec items" + flag "dry-run" setDryRun "pretend that everything passed; don't verify anything" + , flag "focused-only" setFocusedOnly "do not run anything, unless there are focused spec items" - , undocumented $ mkFlag "fail-on-focused" setFailOnFocused "fail on focused spec items" - , undocumented $ mkFlag "fail-on-pending" setFailOnPending "fail on pending spec items" + , undocumented $ flag "fail-on-focused" setFailOnFocused "fail on focused spec items" + , undocumented $ flag "fail-on-pending" setFailOnPending "fail on pending spec items" , mkOption "fail-on" Nothing (argument "ITEMS" readFailOnItems (setFailOnItems True )) helpForFailOn , mkOption "no-fail-on" Nothing (argument "ITEMS" readFailOnItems (setFailOnItems False)) helpForFailOn - , mkFlag "strict" setStrict $ "same as --fail-on=" <> showFailOnItems strict + , flag "strict" setStrict $ "same as --fail-on=" <> showFailOnItems strict - , mkFlag "fail-fast" setFailFast "abort on first failure" - , mkFlag "randomize" setRandomize "randomize execution order" + , flag "fail-fast" setFailFast "abort on first failure" + , flag "randomize" setRandomize "randomize execution order" , mkOptionNoArg "rerun" (Just 'r') setRerun "rerun all examples that failed in the previous test run (only works in combination with --failure-report or in GHCi)" , option "failure-report" (argument "FILE" return setFailureReport) "read/write a failure report for use with --rerun" , mkOptionNoArg "rerun-all-on-success" Nothing setRerunAllOnSuccess "run the whole test suite after a previously failing rerun succeeds for the first time (only works in combination with --rerun)" , mkOption "jobs" (Just 'j') (argument "N" readMaxJobs setMaxJobs) "run at most N parallelizable tests simultaneously (default: number of available processors)" + , option "seed" (argument "N" readMaybe setSeed) "used seed for --randomize and QuickCheck properties" ] where strict = [FailOnFocused, FailOnPending] diff --git a/src/Test/Hspec/Core/Example.hs b/src/Test/Hspec/Core/Example.hs --- a/src/Test/Hspec/Core/Example.hs +++ b/src/Test/Hspec/Core/Example.hs @@ -22,6 +22,7 @@ , safeEvaluateResultStatus , exceptionToResultStatus , toLocation +, hunitFailureToResult ) where import Prelude () @@ -35,11 +36,8 @@ import qualified Test.QuickCheck as QC import Test.Hspec.Expectations (Expectation) -import qualified Test.QuickCheck.State as QC (numSuccessTests, maxSuccessTests) -import qualified Test.QuickCheck.Property as QCP - -import Test.Hspec.Core.QuickCheckUtil import Test.Hspec.Core.Util +import Test.Hspec.Core.QuickCheck.Util (liftHook) import Test.Hspec.Core.Example.Location -- | A type class for examples @@ -183,51 +181,3 @@ instance Example (a -> Expectation) where type Arg (a -> Expectation) = a evaluateExample e _ hook _ = hook e >> return (Result "" Success) - -instance Example QC.Property where - type Arg QC.Property = () - evaluateExample e = evaluateExample (\() -> e) - -instance Example (a -> QC.Property) where - type Arg (a -> QC.Property) = a - evaluateExample p c hook progressCallback = do - let args = paramsQuickCheckArgs c - r <- QC.quickCheckWithResult args {QC.chatty = False} (QCP.callback qcProgressCallback $ aroundProperty hook p) - return $ fromQuickCheckResult args r - where - qcProgressCallback = QCP.PostTest QCP.NotCounterexample $ - \st _ -> progressCallback (QC.numSuccessTests st, QC.maxSuccessTests st) - -fromQuickCheckResult :: QC.Args -> QC.Result -> Result -fromQuickCheckResult args r = case parseQuickCheckResult r of - QuickCheckResult _ info (QuickCheckOtherFailure err) -> Result info $ Failure Nothing (Reason err) - QuickCheckResult _ info QuickCheckSuccess -> Result (if QC.chatty args then info else "") Success - QuickCheckResult n info (QuickCheckFailure QCFailure{..}) -> case quickCheckFailureException of - Just e | Just result <- fromException e -> Result info result - Just e | Just hunit <- fromException e -> Result info $ hunitFailureToResult (Just hunitAssertion) hunit - Just e -> failure (uncaughtException e) - Nothing -> failure falsifiable - where - failure = Result info . Failure Nothing . Reason - - numbers = formatNumbers n quickCheckFailureNumShrinks - - hunitAssertion :: String - hunitAssertion = intercalate "\n" [ - "Falsifiable " ++ numbers ++ ":" - , indent (unlines quickCheckFailureCounterexample) - ] - - uncaughtException e = intercalate "\n" [ - "uncaught exception: " ++ formatException e - , numbers - , indent (unlines quickCheckFailureCounterexample) - ] - - falsifiable = intercalate "\n" [ - quickCheckFailureReason ++ " " ++ numbers ++ ":" - , indent (unlines quickCheckFailureCounterexample) - ] - -indent :: String -> String -indent = intercalate "\n" . map (" " ++) . lines diff --git a/src/Test/Hspec/Core/QuickCheck.hs b/src/Test/Hspec/Core/QuickCheck.hs --- a/src/Test/Hspec/Core/QuickCheck.hs +++ b/src/Test/Hspec/Core/QuickCheck.hs @@ -1,18 +1,29 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} -- | Stability: provisional module Test.Hspec.Core.QuickCheck ( - modifyArgs -, modifyMaxSuccess + modifyMaxSuccess , modifyMaxDiscardRatio , modifyMaxSize , modifyMaxShrinks +, modifyArgs ) where import Prelude () import Test.Hspec.Core.Compat -import Test.QuickCheck -import Test.Hspec.Core.Spec +import Test.QuickCheck (Args(..)) +import qualified Test.QuickCheck as QC +import qualified Test.QuickCheck.State as QC (numSuccessTests, maxSuccessTests) +import qualified Test.QuickCheck.Property as QCP +import Test.Hspec.Core.Util +import Test.Hspec.Core.QuickCheck.Util +import Test.Hspec.Core.Example (Example(..), Params(..), Result(..), ResultStatus(..), FailureReason(..), hunitFailureToResult) +import Test.Hspec.Core.Spec.Monad (SpecWith, modifyParams) + -- | Use a modified `maxSuccess` for given spec. modifyMaxSuccess :: (Int -> Int) -> SpecWith a -> SpecWith a modifyMaxSuccess = modifyArgs . modify @@ -47,3 +58,51 @@ where modify :: (Args -> Args) -> Params -> Params modify f p = p {paramsQuickCheckArgs = f (paramsQuickCheckArgs p)} + +instance Example QC.Property where + type Arg QC.Property = () + evaluateExample e = evaluateExample (\() -> e) + +instance Example (a -> QC.Property) where + type Arg (a -> QC.Property) = a + evaluateExample p params hook progressCallback = do + let args = paramsQuickCheckArgs params + r <- QC.quickCheckWithResult args {QC.chatty = False} (QCP.callback qcProgressCallback $ aroundProperty hook p) + return $ fromQuickCheckResult args r + where + qcProgressCallback = QCP.PostTest QCP.NotCounterexample $ + \st _ -> progressCallback (QC.numSuccessTests st, QC.maxSuccessTests st) + +fromQuickCheckResult :: QC.Args -> QC.Result -> Result +fromQuickCheckResult args r = case parseQuickCheckResult r of + QuickCheckResult _ info (QuickCheckOtherFailure err) -> Result info $ Failure Nothing (Reason err) + QuickCheckResult _ info QuickCheckSuccess -> Result (if QC.chatty args then info else "") Success + QuickCheckResult n info (QuickCheckFailure QCFailure{..}) -> case quickCheckFailureException of + Just e | Just result <- fromException e -> Result info result + Just e | Just hunit <- fromException e -> Result info $ hunitFailureToResult (Just hunitAssertion) hunit + Just e -> failure (uncaughtException e) + Nothing -> failure falsifiable + where + failure = Result info . Failure Nothing . Reason + + numbers = formatNumbers n quickCheckFailureNumShrinks + + hunitAssertion :: String + hunitAssertion = intercalate "\n" [ + "Falsifiable " ++ numbers ++ ":" + , indent (unlines quickCheckFailureCounterexample) + ] + + uncaughtException e = intercalate "\n" [ + "uncaught exception: " ++ formatException e + , numbers + , indent (unlines quickCheckFailureCounterexample) + ] + + falsifiable = intercalate "\n" [ + quickCheckFailureReason ++ " " ++ numbers ++ ":" + , indent (unlines quickCheckFailureCounterexample) + ] + +indent :: String -> String +indent = intercalate "\n" . map (" " ++) . lines diff --git a/src/Test/Hspec/Core/QuickCheck/Util.hs b/src/Test/Hspec/Core/QuickCheck/Util.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/QuickCheck/Util.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} +module Test.Hspec.Core.QuickCheck.Util ( + liftHook +, aroundProperty + +, QuickCheckResult(..) +, Status(..) +, QuickCheckFailure(..) +, parseQuickCheckResult + +, formatNumbers + +, mkGen +, newSeed +#ifdef TEST +, stripSuffix +, splitBy +#endif +) where + +import Prelude () +import Test.Hspec.Core.Compat + +import Data.Int +import System.Random + +import Test.QuickCheck +import Test.QuickCheck.Text (isOneLine) +import qualified Test.QuickCheck.Property as QCP +import Test.QuickCheck.Property hiding (Result(..)) +import Test.QuickCheck.Gen +import Test.QuickCheck.IO () +import Test.QuickCheck.Random +import qualified Test.QuickCheck.Test as QC (showTestCount) +import Test.QuickCheck.State (State(..)) + +import Test.Hspec.Core.Util + +liftHook :: r -> ((a -> IO ()) -> IO ()) -> (a -> IO r) -> IO r +liftHook def hook inner = do + ref <- newIORef def + hook $ inner >=> writeIORef ref + readIORef ref + +aroundProperty :: ((a -> IO ()) -> IO ()) -> (a -> Property) -> Property +aroundProperty hook p = MkProperty . MkGen $ \r n -> aroundProp hook $ \a -> (unGen . unProperty $ p a) r n + +aroundProp :: ((a -> IO ()) -> IO ()) -> (a -> Prop) -> Prop +aroundProp hook p = MkProp $ aroundRose hook (\a -> unProp $ p a) + +aroundRose :: ((a -> IO ()) -> IO ()) -> (a -> Rose QCP.Result) -> Rose QCP.Result +aroundRose hook r = ioRose $ do + liftHook (return QCP.succeeded) hook $ \ a -> reduceRose (r a) + +newSeed :: IO Int +newSeed = fst . randomR (0, fromIntegral (maxBound :: Int32)) <$> + newQCGen + +mkGen :: Int -> QCGen +mkGen = mkQCGen + +formatNumbers :: Int -> Int -> String +formatNumbers n shrinks = "(after " ++ pluralize n "test" ++ shrinks_ ++ ")" + where + shrinks_ + | shrinks > 0 = " and " ++ pluralize shrinks "shrink" + | otherwise = "" + +data QuickCheckResult = QuickCheckResult { + quickCheckResultNumTests :: Int +, quickCheckResultInfo :: String +, quickCheckResultStatus :: Status +} deriving Show + +data Status = + QuickCheckSuccess + | QuickCheckFailure QuickCheckFailure + | QuickCheckOtherFailure String + deriving Show + +data QuickCheckFailure = QCFailure { + quickCheckFailureNumShrinks :: Int +, quickCheckFailureException :: Maybe SomeException +, quickCheckFailureReason :: String +, quickCheckFailureCounterexample :: [String] +} deriving Show + +parseQuickCheckResult :: Result -> QuickCheckResult +parseQuickCheckResult r = case r of + Success {..} -> result output QuickCheckSuccess + + Failure {..} -> + case stripSuffix outputWithoutVerbose output of + Just xs -> result verboseOutput (QuickCheckFailure $ QCFailure numShrinks theException reason failingTestCase) + where + verboseOutput + | xs == "*** Failed! " = "" + | otherwise = maybeStripSuffix "*** Failed!" (strip xs) + Nothing -> couldNotParse output + where + outputWithoutVerbose = reasonAndNumbers ++ unlines failingTestCase + reasonAndNumbers + | isOneLine reason = reason ++ " " ++ numbers ++ colonNewline + | otherwise = numbers ++ colonNewline ++ ensureTrailingNewline reason + numbers = formatNumbers numTests numShrinks + colonNewline = ":\n" + + GaveUp {..} -> + case stripSuffix outputWithoutVerbose output of + Just info -> otherFailure info ("Gave up after " ++ numbers ++ "!") + Nothing -> couldNotParse output + where + numbers = showTestCount numTests numDiscarded + outputWithoutVerbose = "*** Gave up! Passed only " ++ numbers ++ " tests.\n" + + NoExpectedFailure {..} -> case splitBy "*** Failed! " output of + Just (info, err) -> otherFailure info err + Nothing -> couldNotParse output + + where + result = QuickCheckResult (numTests r) . strip + otherFailure info err = result info (QuickCheckOtherFailure $ strip err) + couldNotParse = result "" . QuickCheckOtherFailure + +showTestCount :: Int -> Int -> String +showTestCount success discarded = QC.showTestCount state + where + state = MkState { + terminal = undefined + , maxSuccessTests = undefined + , maxDiscardedRatio = undefined + , coverageConfidence = undefined +#if MIN_VERSION_QuickCheck(2,15,0) + , maxTestSize = 0 + , replayStartSize = undefined +#else + , computeSize = undefined +#endif + , numTotMaxShrinks = 0 + , numSuccessTests = success + , numDiscardedTests = discarded + , numRecentlyDiscardedTests = 0 + , labels = mempty + , classes = mempty + , tables = mempty + , requiredCoverage = mempty + , expected = True + , randomSeed = mkGen 0 + , numSuccessShrinks = 0 + , numTryShrinks = 0 + , numTotTryShrinks = 0 + } + +ensureTrailingNewline :: String -> String +ensureTrailingNewline = unlines . lines + +maybeStripPrefix :: String -> String -> String +maybeStripPrefix prefix m = fromMaybe m (stripPrefix prefix m) + +maybeStripSuffix :: String -> String -> String +maybeStripSuffix suffix = reverse . maybeStripPrefix (reverse suffix) . reverse + +stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] +stripSuffix suffix = fmap reverse . stripPrefix (reverse suffix) . reverse + +splitBy :: String -> String -> Maybe (String, String) +splitBy sep xs = listToMaybe [ + (x, y) | (x, Just y) <- zip (inits xs) (map stripSep $ tails xs) + ] + where + stripSep = stripPrefix sep diff --git a/src/Test/Hspec/Core/QuickCheckUtil.hs b/src/Test/Hspec/Core/QuickCheckUtil.hs deleted file mode 100644 --- a/src/Test/Hspec/Core/QuickCheckUtil.hs +++ /dev/null @@ -1,167 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE CPP #-} -module Test.Hspec.Core.QuickCheckUtil ( - liftHook -, aroundProperty - -, QuickCheckResult(..) -, Status(..) -, QuickCheckFailure(..) -, parseQuickCheckResult - -, formatNumbers - -, mkGen -, newSeed -#ifdef TEST -, stripSuffix -, splitBy -#endif -) where - -import Prelude () -import Test.Hspec.Core.Compat - -import Data.Int -import System.Random - -import Test.QuickCheck -import Test.QuickCheck.Text (isOneLine) -import qualified Test.QuickCheck.Property as QCP -import Test.QuickCheck.Property hiding (Result(..)) -import Test.QuickCheck.Gen -import Test.QuickCheck.IO () -import Test.QuickCheck.Random -import qualified Test.QuickCheck.Test as QC (showTestCount) -import Test.QuickCheck.State (State(..)) - -import Test.Hspec.Core.Util - -liftHook :: r -> ((a -> IO ()) -> IO ()) -> (a -> IO r) -> IO r -liftHook def hook inner = do - ref <- newIORef def - hook $ inner >=> writeIORef ref - readIORef ref - -aroundProperty :: ((a -> IO ()) -> IO ()) -> (a -> Property) -> Property -aroundProperty hook p = MkProperty . MkGen $ \r n -> aroundProp hook $ \a -> (unGen . unProperty $ p a) r n - -aroundProp :: ((a -> IO ()) -> IO ()) -> (a -> Prop) -> Prop -aroundProp hook p = MkProp $ aroundRose hook (\a -> unProp $ p a) - -aroundRose :: ((a -> IO ()) -> IO ()) -> (a -> Rose QCP.Result) -> Rose QCP.Result -aroundRose hook r = ioRose $ do - liftHook (return QCP.succeeded) hook $ \ a -> reduceRose (r a) - -newSeed :: IO Int -newSeed = fst . randomR (0, fromIntegral (maxBound :: Int32)) <$> - newQCGen - -mkGen :: Int -> QCGen -mkGen = mkQCGen - -formatNumbers :: Int -> Int -> String -formatNumbers n shrinks = "(after " ++ pluralize n "test" ++ shrinks_ ++ ")" - where - shrinks_ - | shrinks > 0 = " and " ++ pluralize shrinks "shrink" - | otherwise = "" - -data QuickCheckResult = QuickCheckResult { - quickCheckResultNumTests :: Int -, quickCheckResultInfo :: String -, quickCheckResultStatus :: Status -} deriving Show - -data Status = - QuickCheckSuccess - | QuickCheckFailure QuickCheckFailure - | QuickCheckOtherFailure String - deriving Show - -data QuickCheckFailure = QCFailure { - quickCheckFailureNumShrinks :: Int -, quickCheckFailureException :: Maybe SomeException -, quickCheckFailureReason :: String -, quickCheckFailureCounterexample :: [String] -} deriving Show - -parseQuickCheckResult :: Result -> QuickCheckResult -parseQuickCheckResult r = case r of - Success {..} -> result output QuickCheckSuccess - - Failure {..} -> - case stripSuffix outputWithoutVerbose output of - Just xs -> result verboseOutput (QuickCheckFailure $ QCFailure numShrinks theException reason failingTestCase) - where - verboseOutput - | xs == "*** Failed! " = "" - | otherwise = maybeStripSuffix "*** Failed!" (strip xs) - Nothing -> couldNotParse output - where - outputWithoutVerbose = reasonAndNumbers ++ unlines failingTestCase - reasonAndNumbers - | isOneLine reason = reason ++ " " ++ numbers ++ colonNewline - | otherwise = numbers ++ colonNewline ++ ensureTrailingNewline reason - numbers = formatNumbers numTests numShrinks - colonNewline = ":\n" - - GaveUp {..} -> - case stripSuffix outputWithoutVerbose output of - Just info -> otherFailure info ("Gave up after " ++ numbers ++ "!") - Nothing -> couldNotParse output - where - numbers = showTestCount numTests numDiscarded - outputWithoutVerbose = "*** Gave up! Passed only " ++ numbers ++ " tests.\n" - - NoExpectedFailure {..} -> case splitBy "*** Failed! " output of - Just (info, err) -> otherFailure info err - Nothing -> couldNotParse output - - where - result = QuickCheckResult (numTests r) . strip - otherFailure info err = result info (QuickCheckOtherFailure $ strip err) - couldNotParse = result "" . QuickCheckOtherFailure - -showTestCount :: Int -> Int -> String -showTestCount success discarded = QC.showTestCount state - where - state = MkState { - terminal = undefined - , maxSuccessTests = undefined - , maxDiscardedRatio = undefined - , coverageConfidence = undefined - , computeSize = undefined - , numTotMaxShrinks = 0 - , numSuccessTests = success - , numDiscardedTests = discarded - , numRecentlyDiscardedTests = 0 - , labels = mempty - , classes = mempty - , tables = mempty - , requiredCoverage = mempty - , expected = True - , randomSeed = mkGen 0 - , numSuccessShrinks = 0 - , numTryShrinks = 0 - , numTotTryShrinks = 0 - } - -ensureTrailingNewline :: String -> String -ensureTrailingNewline = unlines . lines - -maybeStripPrefix :: String -> String -> String -maybeStripPrefix prefix m = fromMaybe m (stripPrefix prefix m) - -maybeStripSuffix :: String -> String -> String -maybeStripSuffix suffix = reverse . maybeStripPrefix (reverse suffix) . reverse - -stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] -stripSuffix suffix = fmap reverse . stripPrefix (reverse suffix) . reverse - -splitBy :: String -> String -> Maybe (String, String) -splitBy sep xs = listToMaybe [ - (x, y) | (x, Just y) <- zip (inits xs) (map stripSep $ tails xs) - ] - where - stripSep = stripPrefix sep diff --git a/src/Test/Hspec/Core/Runner.hs b/src/Test/Hspec/Core/Runner.hs --- a/src/Test/Hspec/Core/Runner.hs +++ b/src/Test/Hspec/Core/Runner.hs @@ -121,7 +121,7 @@ import qualified Test.Hspec.Core.Formatters.V1 as V1 import qualified Test.Hspec.Core.Formatters.V2 as V2 import Test.Hspec.Core.FailureReport -import Test.Hspec.Core.QuickCheckUtil +import Test.Hspec.Core.QuickCheck.Util import Test.Hspec.Core.Shuffle import Test.Hspec.Core.Runner.PrintSlowSpecItems @@ -195,12 +195,12 @@ -- Add a seed to given config if there is none. That way the same seed is used -- for all properties. This helps with --seed and --rerun. -ensureSeed :: Config -> IO Config -ensureSeed c = case configQuickCheckSeed c of - Nothing -> do - seed <- newSeed - return c {configQuickCheckSeed = Just (fromIntegral seed)} - _ -> return c +ensureSeed :: Config -> IO (Config, Integer) +ensureSeed config = do + seed <- case configSeed config <|> configQuickCheckSeed config of + Nothing -> toInteger <$> newSeed + Just seed -> return seed + return (config { configSeed = Just seed }, seed) -- | Run given spec with custom options. -- This is similar to `hspec`, but more flexible. @@ -355,14 +355,13 @@ runSpecForest_ :: Maybe FailureReport -> [SpecTree ()] -> Config -> IO SpecResult runSpecForest_ oldFailureReport spec c_ = do - config <- ensureSeed (applyFailureReport oldFailureReport c_) + (config, seed) <- ensureSeed (applyFailureReport oldFailureReport c_) colorMode <- colorOutputSupported (configColorMode config) (hSupportsANSI stdout) outputUnicode <- unicodeOutputSupported (configUnicodeMode config) stdout let - filteredSpec = specToEvalForest config spec - seed = (fromJust . configQuickCheckSeed) config + filteredSpec = specToEvalForest seed config spec qcArgs = configQuickCheckArgs config !numberOfItems = countEvalItems filteredSpec @@ -413,8 +412,8 @@ return results -specToEvalForest :: Config -> [SpecTree ()] -> [EvalTree] -specToEvalForest config = +specToEvalForest :: Integer -> Config -> [SpecTree ()] -> [EvalTree] +specToEvalForest seed config = failItemsWithEmptyDescription config >>> addDefaultDescriptions >>> failFocusedItems config @@ -426,9 +425,6 @@ >>> randomize >>> pruneForest where - seed :: Integer - seed = (fromJust . configQuickCheckSeed) config - params :: Params params = Params (configQuickCheckArgs config) (configSmallCheckDepth config) diff --git a/src/Test/Hspec/Core/Spec.hs b/src/Test/Hspec/Core/Spec.hs --- a/src/Test/Hspec/Core/Spec.hs +++ b/src/Test/Hspec/Core/Spec.hs @@ -91,6 +91,7 @@ import Test.Hspec.Core.Hooks import Test.Hspec.Core.Tree import Test.Hspec.Core.Spec.Monad +import Test.Hspec.Core.QuickCheck () -- | The @describe@ function combines a list of specs into a larger spec. describe :: HasCallStack => String -> SpecWith a -> SpecWith a diff --git a/test/Helper.hs b/test/Helper.hs --- a/test/Helper.hs +++ b/test/Helper.hs @@ -62,7 +62,7 @@ import qualified Test.Hspec.Core.Spec as H import qualified Test.Hspec.Core.Runner as H -import Test.Hspec.Core.QuickCheckUtil (mkGen) +import Test.Hspec.Core.QuickCheck.Util (mkGen) import Test.Hspec.Core.Clock import Test.Hspec.Core.Example (Result(..), ResultStatus(..), FailureReason(..), Location(..)) import Test.Hspec.Core.Example.Location (workaroundForIssue19236) @@ -70,7 +70,7 @@ import qualified Test.Hspec.Core.Format as Format import Test.Hspec.Core.Formatters.V2 (formatterToFormat, silent) -import Data.Orphans() +import Data.Orphans () exceptionEq :: SomeException -> SomeException -> Bool exceptionEq a b diff --git a/test/Test/Hspec/Core/HooksSpec.hs b/test/Test/Hspec/Core/HooksSpec.hs --- a/test/Test/Hspec/Core/HooksSpec.hs +++ b/test/Test/Hspec/Core/HooksSpec.hs @@ -38,7 +38,7 @@ pathToList (xs, x) = xs ++ [x] toEvalForest :: H.SpecWith () -> IO [EvalTree] -toEvalForest = fmap (uncurry H.specToEvalForest . first (($ H.defaultConfig) . appEndo)) . H.runSpecM +toEvalForest = fmap (uncurry (H.specToEvalForest 0) . first (($ H.defaultConfig) . appEndo)) . H.runSpecM mkAppend :: IO (String -> IO (), IO [String]) mkAppend = do diff --git a/test/Test/Hspec/Core/QuickCheck/UtilSpec.hs b/test/Test/Hspec/Core/QuickCheck/UtilSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/QuickCheck/UtilSpec.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} +module Test.Hspec.Core.QuickCheck.UtilSpec (spec) where + +import Prelude () +import Helper + +import qualified Test.QuickCheck.Property as QCP + +import Test.Hspec.Core.QuickCheck.Util + +deriving instance Eq QuickCheckResult +deriving instance Eq Status +deriving instance Eq QuickCheckFailure + +spec :: Spec +spec = do + describe "formatNumbers" $ do + it "includes number of tests" $ do + formatNumbers 1 0 `shouldBe` "(after 1 test)" + + it "pluralizes number of tests" $ do + formatNumbers 3 0 `shouldBe` "(after 3 tests)" + + it "includes number of shrinks" $ do + formatNumbers 3 1 `shouldBe` "(after 3 tests and 1 shrink)" + + it "pluralizes number of shrinks" $ do + formatNumbers 3 3 `shouldBe` "(after 3 tests and 3 shrinks)" + + describe "stripSuffix" $ do + it "drops the given suffix from a list" $ do + stripSuffix "bar" "foobar" `shouldBe` Just "foo" + + describe "splitBy" $ do + it "splits a string by a given infix" $ do + splitBy "bar" "foo bar baz" `shouldBe` Just ("foo ", " baz") + + describe "parseQuickCheckResult" $ do + let + args = stdArgs {chatty = False, replay = Just (mkGen 0, 0)} + qc = quickCheckWithResult args + + context "with Success" $ do + let p :: Int -> Bool + p n = n == n + + it "parses result" $ do + parseQuickCheckResult <$> qc p `shouldReturn` + QuickCheckResult 100 "+++ OK, passed 100 tests." QuickCheckSuccess + + it "includes labels" $ do + parseQuickCheckResult <$> qc (label "unit" p) `shouldReturn` + QuickCheckResult 100 "+++ OK, passed 100 tests (100% unit)." QuickCheckSuccess + + context "with GaveUp" $ do + let p :: Int -> Property + p n = (n == 1234) ==> True + + qc = quickCheckWithResult args {maxSuccess = 2, maxDiscardRatio = 1} + result = QuickCheckResult 0 "" (QuickCheckOtherFailure "Gave up after 0 tests; 2 discarded!") + + it "parses result" $ do + parseQuickCheckResult <$> qc p `shouldReturn` result + + it "includes verbose output" $ do + let + info = intercalate "\n" [ + "Skipped (precondition false):" + , "0" + , "" + , "Skipped (precondition false):" + , "0" + ] + parseQuickCheckResult <$> qc (verbose p) `shouldReturn` result {quickCheckResultInfo = info} + + context "with NoExpectedFailure" $ do + let + p :: Int -> Property + p _ = expectFailure True + + it "parses result" $ do + parseQuickCheckResult <$> qc p `shouldReturn` + QuickCheckResult 100 "" (QuickCheckOtherFailure "Passed 100 tests (expected failure).") + + it "includes verbose output" $ do + let + info = intercalate "\n" [ + "Passed:" + , "0" + , "" + , "Passed:" + , "23" + ] + parseQuickCheckResult <$> quickCheckWithResult args {maxSuccess = 2} (verbose p) `shouldReturn` + QuickCheckResult 2 info (QuickCheckOtherFailure "Passed 2 tests (expected failure).") + + context "with cover" $ do + context "without checkCoverage" $ do + let + p :: Int -> Property + p n = cover 10 (n == 5) "is 5" True + + it "parses result" $ do + parseQuickCheckResult <$> qc p `shouldReturn` + QuickCheckResult 100 "+++ OK, passed 100 tests (1% is 5).\n\nOnly 1% is 5, but expected 10%" QuickCheckSuccess + + it "includes verbose output" $ do + let + info = intercalate "\n" [ + "Passed:" + , "0" + , "" + , "Passed:" + , "23" + , "" +#if MIN_VERSION_QuickCheck(2,15,0) + , "+++ OK, passed 2 tests (0% is 5)." +#else + , "+++ OK, passed 2 tests." +#endif + , "" + , "Only 0% is 5, but expected 10%" + ] + parseQuickCheckResult <$> quickCheckWithResult args {maxSuccess = 2} (verbose p) `shouldReturn` + QuickCheckResult 2 info QuickCheckSuccess + + context "with checkCoverage" $ do + let + p :: Int -> Property + p n = checkCoverage $ cover 10 (n == 23) "is 23" True + + failure :: QuickCheckFailure + failure = QCFailure { + quickCheckFailureNumShrinks = 0 + , quickCheckFailureException = Nothing + , quickCheckFailureReason = "Insufficient coverage" + , quickCheckFailureCounterexample = [ + " 0.9% is 23" + , "" + , "Only 0.9% is 23, but expected 10.0%" + ] + } + + it "parses result" $ do + parseQuickCheckResult <$> qc p `shouldReturn` + QuickCheckResult 800 "" (QuickCheckFailure failure) + + it "includes verbose output" $ do +-- This off-by-one error was fixed in QuickCheck 2.15 +#if MIN_VERSION_QuickCheck(2,15,0) + let info = intercalate "\n\n" (replicate 800 "Passed:") +#else + let info = intercalate "\n\n" (replicate 799 "Passed:") +#endif + parseQuickCheckResult <$> qc (verbose . p) `shouldReturn` + QuickCheckResult 800 info (QuickCheckFailure failure) + + context "with Failure" $ do + context "with single-line failure reason" $ do + let + p :: Int -> Bool + p = (< 1) + + err = "Falsified" + result = QuickCheckResult 4 "" (QuickCheckFailure $ QCFailure 2 Nothing err ["1"]) + + it "parses result" $ do + parseQuickCheckResult <$> qc p `shouldReturn` result + + it "includes verbose output" $ do + let info = intercalate "\n" [ + "Passed:" + , "0" + , "" + , "Passed:" + , "0" + , "" + , "Passed:" + , "-2" + , "" + , "Failed:" + , "3" + , "" + , "Passed:" + , "0" + , "" + , "Failed:" + , "2" + , "" + , "Passed:" + , "0" + , "" + , "Failed:" + , "1" + , "" + , "Passed:" + , "0" + ] + + parseQuickCheckResult <$> qc (verbose p) `shouldReturn` result {quickCheckResultInfo = info} + + context "with multi-line failure reason" $ do + let + p :: Int -> QCP.Result + p n = if n /= 2 then QCP.succeeded else QCP.failed {QCP.reason = err} + + err = "foo\nbar" + result = QuickCheckResult 5 "" (QuickCheckFailure $ QCFailure 0 Nothing err ["2"]) + + it "parses result" $ do + parseQuickCheckResult <$> qc p `shouldReturn` result + + it "includes verbose output" $ do + let info = intercalate "\n" [ + "Passed:" + , "0" + , "" + , "Passed:" + , "0" + , "" + , "Passed:" + , "-2" + , "" + , "Passed:" + , "3" + , "" + , "Failed:" + , "2" + , "" + , "Passed:" + , "0" + , "" + , "Passed:" + , "1" + ] + parseQuickCheckResult <$> qc (verbose p) `shouldReturn` result {quickCheckResultInfo = info} + + context "with HUnit assertion" $ do + let p :: Int -> Int -> Expectation + p m n = do + m `shouldBe` n + + it "includes counterexample" $ do + result <- qc p + let QuickCheckResult _ _ (QuickCheckFailure r) = parseQuickCheckResult result + quickCheckFailureCounterexample r `shouldBe` ["0", "1"] diff --git a/test/Test/Hspec/Core/QuickCheckUtilSpec.hs b/test/Test/Hspec/Core/QuickCheckUtilSpec.hs deleted file mode 100644 --- a/test/Test/Hspec/Core/QuickCheckUtilSpec.hs +++ /dev/null @@ -1,241 +0,0 @@ -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} -module Test.Hspec.Core.QuickCheckUtilSpec (spec) where - -import Prelude () -import Helper - -import qualified Test.QuickCheck.Property as QCP - -import Test.Hspec.Core.QuickCheckUtil - -deriving instance Eq QuickCheckResult -deriving instance Eq Status -deriving instance Eq QuickCheckFailure - -spec :: Spec -spec = do - describe "formatNumbers" $ do - it "includes number of tests" $ do - formatNumbers 1 0 `shouldBe` "(after 1 test)" - - it "pluralizes number of tests" $ do - formatNumbers 3 0 `shouldBe` "(after 3 tests)" - - it "includes number of shrinks" $ do - formatNumbers 3 1 `shouldBe` "(after 3 tests and 1 shrink)" - - it "pluralizes number of shrinks" $ do - formatNumbers 3 3 `shouldBe` "(after 3 tests and 3 shrinks)" - - describe "stripSuffix" $ do - it "drops the given suffix from a list" $ do - stripSuffix "bar" "foobar" `shouldBe` Just "foo" - - describe "splitBy" $ do - it "splits a string by a given infix" $ do - splitBy "bar" "foo bar baz" `shouldBe` Just ("foo ", " baz") - - describe "parseQuickCheckResult" $ do - let - args = stdArgs {chatty = False, replay = Just (mkGen 0, 0)} - qc = quickCheckWithResult args - - context "with Success" $ do - let p :: Int -> Bool - p n = n == n - - it "parses result" $ do - parseQuickCheckResult <$> qc p `shouldReturn` - QuickCheckResult 100 "+++ OK, passed 100 tests." QuickCheckSuccess - - it "includes labels" $ do - parseQuickCheckResult <$> qc (label "unit" p) `shouldReturn` - QuickCheckResult 100 "+++ OK, passed 100 tests (100% unit)." QuickCheckSuccess - - context "with GaveUp" $ do - let p :: Int -> Property - p n = (n == 1234) ==> True - - qc = quickCheckWithResult args {maxSuccess = 2, maxDiscardRatio = 1} - result = QuickCheckResult 0 "" (QuickCheckOtherFailure "Gave up after 0 tests; 2 discarded!") - - it "parses result" $ do - parseQuickCheckResult <$> qc p `shouldReturn` result - - it "includes verbose output" $ do - let - info = intercalate "\n" [ - "Skipped (precondition false):" - , "0" - , "" - , "Skipped (precondition false):" - , "0" - ] - parseQuickCheckResult <$> qc (verbose p) `shouldReturn` result {quickCheckResultInfo = info} - - context "with NoExpectedFailure" $ do - let - p :: Int -> Property - p _ = expectFailure True - - it "parses result" $ do - parseQuickCheckResult <$> qc p `shouldReturn` - QuickCheckResult 100 "" (QuickCheckOtherFailure "Passed 100 tests (expected failure).") - - it "includes verbose output" $ do - let - info = intercalate "\n" [ - "Passed:" - , "0" - , "" - , "Passed:" - , "23" - ] - parseQuickCheckResult <$> quickCheckWithResult args {maxSuccess = 2} (verbose p) `shouldReturn` - QuickCheckResult 2 info (QuickCheckOtherFailure "Passed 2 tests (expected failure).") - - context "with cover" $ do - context "without checkCoverage" $ do - let - p :: Int -> Property - p n = cover 10 (n == 5) "is 5" True - - it "parses result" $ do - parseQuickCheckResult <$> qc p `shouldReturn` - QuickCheckResult 100 "+++ OK, passed 100 tests (1% is 5).\n\nOnly 1% is 5, but expected 10%" QuickCheckSuccess - - it "includes verbose output" $ do - let - info = intercalate "\n" [ - "Passed:" - , "0" - , "" - , "Passed:" - , "23" - , "" - , "+++ OK, passed 2 tests." - , "" - , "Only 0% is 5, but expected 10%" - ] - parseQuickCheckResult <$> quickCheckWithResult args {maxSuccess = 2} (verbose p) `shouldReturn` - QuickCheckResult 2 info QuickCheckSuccess - - context "with checkCoverage" $ do - let - p :: Int -> Property - p n = checkCoverage $ cover 10 (n == 23) "is 23" True - - failure :: QuickCheckFailure - failure = QCFailure { - quickCheckFailureNumShrinks = 0 - , quickCheckFailureException = Nothing - , quickCheckFailureReason = "Insufficient coverage" - , quickCheckFailureCounterexample = [ - " 0.9% is 23" - , "" - , "Only 0.9% is 23, but expected 10.0%" - ] - } - - it "parses result" $ do - parseQuickCheckResult <$> qc p `shouldReturn` - QuickCheckResult 800 "" (QuickCheckFailure failure) - - it "includes verbose output" $ do - let info = intercalate "\n\n" (replicate 799 "Passed:") - parseQuickCheckResult <$> qc (verbose . p) `shouldReturn` - QuickCheckResult 800 info (QuickCheckFailure failure) - - context "with Failure" $ do - context "with single-line failure reason" $ do - let - p :: Int -> Bool - p = (< 1) - - err = "Falsified" - result = QuickCheckResult 4 "" (QuickCheckFailure $ QCFailure 2 Nothing err ["1"]) - - it "parses result" $ do - parseQuickCheckResult <$> qc p `shouldReturn` result - - it "includes verbose output" $ do - let info = intercalate "\n" [ - "Passed:" - , "0" - , "" - , "Passed:" - , "0" - , "" - , "Passed:" - , "-2" - , "" - , "Failed:" - , "3" - , "" - , "Passed:" - , "0" - , "" - , "Failed:" - , "2" - , "" - , "Passed:" - , "0" - , "" - , "Failed:" - , "1" - , "" - , "Passed:" - , "0" - ] - - parseQuickCheckResult <$> qc (verbose p) `shouldReturn` result {quickCheckResultInfo = info} - - context "with multi-line failure reason" $ do - let - p :: Int -> QCP.Result - p n = if n /= 2 then QCP.succeeded else QCP.failed {QCP.reason = err} - - err = "foo\nbar" - result = QuickCheckResult 5 "" (QuickCheckFailure $ QCFailure 0 Nothing err ["2"]) - - it "parses result" $ do - parseQuickCheckResult <$> qc p `shouldReturn` result - - it "includes verbose output" $ do - let info = intercalate "\n" [ - "Passed:" - , "0" - , "" - , "Passed:" - , "0" - , "" - , "Passed:" - , "-2" - , "" - , "Passed:" - , "3" - , "" - , "Failed:" - , "2" - , "" - , "Passed:" - , "0" - , "" - , "Passed:" - , "1" - ] - parseQuickCheckResult <$> qc (verbose p) `shouldReturn` result {quickCheckResultInfo = info} - - context "with HUnit assertion" $ do - let p :: Int -> Int -> Expectation - p m n = do - m `shouldBe` n - - it "includes counterexample" $ do - result <- qc p - let QuickCheckResult _ _ (QuickCheckFailure r) = parseQuickCheckResult result - quickCheckFailureCounterexample r `shouldBe` ["0", "1"] diff --git a/test/Test/Hspec/Core/RunnerSpec.hs b/test/Test/Hspec/Core/RunnerSpec.hs --- a/test/Test/Hspec/Core/RunnerSpec.hs +++ b/test/Test/Hspec/Core/RunnerSpec.hs @@ -1,6 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} module Test.Hspec.Core.RunnerSpec (spec) where import Prelude () @@ -762,31 +764,43 @@ r `shouldContain` "invalid argument `foo' for `--format'" context "with --qc-max-success" $ do + let + run :: HasCallStack => String -> IO () + run option = do + m <- newMock + hspec [option, "23"] $ do + H.it "foo" $ property $ \(_ :: Int) -> do + mockAction m + mockCounter m `shouldReturn` 23 + it "tries QuickCheck properties specified number of times" $ do - m <- newMock - hspec ["--qc-max-success", "23"] $ do - H.it "foo" $ property $ \(_ :: Int) -> do - mockAction m - mockCounter m `shouldReturn` 23 + run "--qc-max-success" + it "accepts --maximum-generated-tests as an alias" $ do + run "--maximum-generated-tests" + context "when run with --rerun" $ do it "takes precedence" $ do ["--qc-max-success", "23"] `shouldUseArgs` (QC.maxSuccess, 23) ["--rerun", "--qc-max-success", "42"] `shouldUseArgs` (QC.maxSuccess, 42) + context "with --qc-max-discard" $ do + it "passes specified maxDiscardRatio to QuickCheck properties" $ do + ["--qc-max-discard", "23"] `shouldUseArgs` (QC.maxDiscardRatio, 23) + context "with --qc-max-size" $ do - it "passes specified size to QuickCheck properties" $ do + it "passes specified maxSize to QuickCheck properties" $ do ["--qc-max-size", "23"] `shouldUseArgs` (QC.maxSize, 23) - context "with --qc-max-discard" $ do - it "uses specified discard ratio to QuickCheck properties" $ do - ["--qc-max-discard", "23"] `shouldUseArgs` (QC.maxDiscardRatio, 23) + context "with --qc-max-shrinks" $ do + it "passes specified maxShrinks to QuickCheck properties" $ do + ["--qc-max-shrinks", "23"] `shouldUseArgs` (QC.maxShrinks, 23) describe "Test.QuickCheck.Args.chatty" $ do let setChatty value args = args { chatty = value } withChatty value = hspecCapture [] . H.modifyArgs (setChatty value) $ do - H.it "foo" $ property True + H.it "foo" $ once $ property True context "when True" $ do it "includes informational output" $ do diff --git a/version.yaml b/version.yaml --- a/version.yaml +++ b/version.yaml @@ -1,4 +1,4 @@ -version: &version 2.11.7 +version: &version 2.11.8 synopsis: A Testing Framework for Haskell author: Simon Hengel maintainer: Simon Hengel