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/hspec-core/src/Test/Hspec/Core/Config.hs b/hspec-core/src/Test/Hspec/Core/Config.hs --- a/hspec-core/src/Test/Hspec/Core/Config.hs +++ b/hspec-core/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/hspec-core/src/Test/Hspec/Core/Config/Definition.hs b/hspec-core/src/Test/Hspec/Core/Config/Definition.hs --- a/hspec-core/src/Test/Hspec/Core/Config/Definition.hs +++ b/hspec-core/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/hspec-core/src/Test/Hspec/Core/Example.hs b/hspec-core/src/Test/Hspec/Core/Example.hs --- a/hspec-core/src/Test/Hspec/Core/Example.hs +++ b/hspec-core/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/hspec-core/src/Test/Hspec/Core/QuickCheck.hs b/hspec-core/src/Test/Hspec/Core/QuickCheck.hs --- a/hspec-core/src/Test/Hspec/Core/QuickCheck.hs +++ b/hspec-core/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/hspec-core/src/Test/Hspec/Core/QuickCheck/Util.hs b/hspec-core/src/Test/Hspec/Core/QuickCheck/Util.hs new file mode 100644 --- /dev/null +++ b/hspec-core/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/hspec-core/src/Test/Hspec/Core/QuickCheckUtil.hs b/hspec-core/src/Test/Hspec/Core/QuickCheckUtil.hs deleted file mode 100644 --- a/hspec-core/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/hspec-core/src/Test/Hspec/Core/Runner.hs b/hspec-core/src/Test/Hspec/Core/Runner.hs --- a/hspec-core/src/Test/Hspec/Core/Runner.hs +++ b/hspec-core/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/hspec-core/src/Test/Hspec/Core/Spec.hs b/hspec-core/src/Test/Hspec/Core/Spec.hs --- a/hspec-core/src/Test/Hspec/Core/Spec.hs +++ b/hspec-core/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/hspec-meta.cabal b/hspec-meta.cabal --- a/hspec-meta.cabal +++ b/hspec-meta.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: hspec-meta -version: 2.11.7 +version: 2.11.8 synopsis: A version of Hspec which is used to test Hspec itself description: A stable version of Hspec which is used to test the in-development version of Hspec. @@ -15,7 +15,7 @@ bug-reports: https://github.com/hspec/hspec/issues author: Simon Hengel maintainer: Simon Hengel -copyright: (c) 2011-2023 Simon Hengel, +copyright: (c) 2011-2024 Simon Hengel, (c) 2011-2012 Trystan Spangler, (c) 2011 Greg Weber license: MIT @@ -67,7 +67,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 @@ -88,7 +88,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 @@ -127,7 +127,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