packages feed

hspec-meta 2.11.7 → 2.11.8

raw patch · 10 files changed

+293/−275 lines, 10 filesdep ~QuickCheckPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: QuickCheck

API changes (from Hackage documentation)

Files

LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2011-2023 Simon Hengel <sol@typeful.net>+Copyright (c) 2011-2024 Simon Hengel <sol@typeful.net> Copyright (c) 2011-2012 Trystan Spangler <trystan.s@comcast.net> Copyright (c) 2011-2011 Greg Weber <greg@gregweber.info>
hspec-core/src/Test/Hspec/Core/Config.hs view
@@ -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)
hspec-core/src/Test/Hspec/Core/Config/Definition.hs view
@@ -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]
hspec-core/src/Test/Hspec/Core/Example.hs view
@@ -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
hspec-core/src/Test/Hspec/Core/QuickCheck.hs view
@@ -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
+ hspec-core/src/Test/Hspec/Core/QuickCheck/Util.hs view
@@ -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
− hspec-core/src/Test/Hspec/Core/QuickCheckUtil.hs 
@@ -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
hspec-core/src/Test/Hspec/Core/Runner.hs view
@@ -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)
hspec-core/src/Test/Hspec/Core/Spec.hs view
@@ -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
hspec-meta.cabal view
@@ -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 <sol@typeful.net> maintainer:     Simon Hengel <sol@typeful.net>-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