packages feed

hspec-core 2.9.7 → 2.10.0

raw patch · 25 files changed

+722/−231 lines, 25 files

Files

hspec-core.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.7.+-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack  name:             hspec-core-version:          2.9.7+version:          2.10.0 license:          MIT license-file:     LICENSE copyright:        (c) 2011-2022 Simon Hengel,@@ -50,18 +50,6 @@     , setenv     , tf-random     , transformers >=0.2.2.0-  if impl(ghc >= 8.2.1)-    build-depends:-        ghc-      , ghc-boot-th-  if impl(ghc >= 8.4.1)-    build-depends:-        stm >=2.2-  else-    other-modules:-        Control.Concurrent.STM.TMVar-    hs-source-dirs:-        vendor/stm-2.5.0.1/   exposed-modules:       Test.Hspec.Core.Spec       Test.Hspec.Core.Hooks@@ -78,6 +66,7 @@       GetOpt.Declarative.Interpret       GetOpt.Declarative.Types       GetOpt.Declarative.Util+      NonEmpty       Test.Hspec.Core.Clock       Test.Hspec.Core.Compat       Test.Hspec.Core.Config@@ -97,6 +86,7 @@       Test.Hspec.Core.QuickCheckUtil       Test.Hspec.Core.Runner.Eval       Test.Hspec.Core.Runner.PrintSlowSpecItems+      Test.Hspec.Core.Runner.Result       Test.Hspec.Core.Shuffle       Test.Hspec.Core.Spec.Monad       Test.Hspec.Core.Timer@@ -105,6 +95,18 @@       Data.Algorithm.Diff       Paths_hspec_core   default-language: Haskell2010+  if impl(ghc >= 8.2.1)+    build-depends:+        ghc+      , ghc-boot-th+  if impl(ghc >= 8.4.1)+    build-depends:+        stm >=2.2+  else+    other-modules:+        Control.Concurrent.STM.TMVar+    hs-source-dirs:+        vendor/stm-2.5.0.1/  test-suite spec   type: exitcode-stdio-1.0@@ -137,18 +139,6 @@     , temporary     , tf-random     , transformers >=0.2.2.0-  if impl(ghc >= 8.2.1)-    build-depends:-        ghc-      , ghc-boot-th-  if impl(ghc >= 8.4.1)-    build-depends:-        stm >=2.2-  else-    other-modules:-        Control.Concurrent.STM.TMVar-    hs-source-dirs:-        vendor/stm-2.5.0.1/   build-tool-depends:       hspec-meta:hspec-meta-discover   other-modules:@@ -157,6 +147,7 @@       GetOpt.Declarative.Interpret       GetOpt.Declarative.Types       GetOpt.Declarative.Util+      NonEmpty       Test.Hspec.Core.Clock       Test.Hspec.Core.Compat       Test.Hspec.Core.Config@@ -183,6 +174,7 @@       Test.Hspec.Core.Runner       Test.Hspec.Core.Runner.Eval       Test.Hspec.Core.Runner.PrintSlowSpecItems+      Test.Hspec.Core.Runner.Result       Test.Hspec.Core.Shuffle       Test.Hspec.Core.Spec       Test.Hspec.Core.Spec.Monad@@ -223,3 +215,15 @@       Test.Hspec.Core.UtilSpec       Paths_hspec_core   default-language: Haskell2010+  if impl(ghc >= 8.2.1)+    build-depends:+        ghc+      , ghc-boot-th+  if impl(ghc >= 8.4.1)+    build-depends:+        stm >=2.2+  else+    other-modules:+        Control.Concurrent.STM.TMVar+    hs-source-dirs:+        vendor/stm-2.5.0.1/
+ src/NonEmpty.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+module NonEmpty (+  NonEmpty(..)+, nonEmpty+, reverse+#ifdef TEST+, fromList+#endif+) where++import           Prelude ()+import           Test.Hspec.Core.Compat hiding (reverse)++import qualified Data.List as List+import qualified Data.Foldable as Foldable++data NonEmpty a = a :| [a]+  deriving (Eq, Show, Functor, Foldable, Traversable)++infixr 5 :|++nonEmpty :: [a] -> Maybe (NonEmpty a)+nonEmpty []     = Nothing+nonEmpty (a:as) = Just (a :| as)++reverse :: NonEmpty a -> NonEmpty a+reverse = lift List.reverse++lift :: Foldable f => ([a] -> [b]) -> f a -> NonEmpty b+lift f = fromList . f . Foldable.toList++fromList :: [a] -> NonEmpty a+fromList (a:as) = a :| as+fromList [] = error "NonEmpty.fromList: empty list"
src/Test/Hspec/Core/Compat.hs view
@@ -68,6 +68,7 @@ import           Text.Read as Imports (readMaybe) import           System.Environment as Imports (lookupEnv) #else+import           Control.Exception import           Text.Read import           System.Environment import qualified Text.ParserCombinators.ReadP as P@@ -87,6 +88,11 @@ #endif  #if !MIN_VERSION_base(4,6,0)+forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId+forkFinally action and_then =+  mask $ \restore ->+    forkIO $ try (restore action) >>= and_then+ -- |Strict version of 'modifyIORef' modifyIORef' :: IORef a -> (a -> a) -> IO () modifyIORef' ref f = do
src/Test/Hspec/Core/Config/Definition.hs view
@@ -22,6 +22,7 @@  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 as V1 import qualified Test.Hspec.Core.Formatters.V2 as V2 import           Test.Hspec.Core.Util@@ -58,11 +59,12 @@ , configQuickCheckMaxDiscardRatio :: Maybe Int , configQuickCheckMaxSize :: Maybe Int , configQuickCheckMaxShrinks :: Maybe Int-, configSmallCheckDepth :: Int+, configSmallCheckDepth :: Maybe Int , configColorMode :: ColorMode , configUnicodeMode :: UnicodeMode , configDiff :: Bool , configPrettyPrint :: Bool+, configPrettyPrintFunction :: Bool -> String -> String -> (String, String) , configTimes :: Bool , configAvailableFormatters :: [(String, FormatConfig -> IO Format)] , configFormat :: Maybe (FormatConfig -> IO Format)@@ -96,6 +98,7 @@ , configUnicodeMode = UnicodeAuto , configDiff = True , configPrettyPrint = True+, configPrettyPrintFunction = pretty2 , configTimes = False , configAvailableFormatters = map (fmap V2.formatterToFormat) [     ("checks", V2.checks)@@ -195,7 +198,7 @@   ]  setDepth :: Int -> Config -> Config-setDepth n c = c {configSmallCheckDepth = n}+setDepth n c = c {configSmallCheckDepth = Just n}  quickCheckOptions :: [Option Config] quickCheckOptions = [
src/Test/Hspec/Core/Example.hs view
@@ -51,13 +51,13 @@  data Params = Params {   paramsQuickCheckArgs  :: QC.Args-, paramsSmallCheckDepth :: Int+, paramsSmallCheckDepth :: Maybe Int } deriving (Show)  defaultParams :: Params defaultParams = Params {   paramsQuickCheckArgs = QC.stdArgs-, paramsSmallCheckDepth = 5+, paramsSmallCheckDepth = Nothing }  type Progress = (Int, Int)
src/Test/Hspec/Core/Format.hs view
@@ -59,13 +59,14 @@ , formatConfigReportProgress :: Bool , formatConfigOutputUnicode :: Bool , formatConfigUseDiff :: Bool-, formatConfigPrettyPrint :: Bool+, formatConfigPrettyPrint :: Bool -- ^ Deprecated: use `formatConfigPrettyPrintFunction` instead+, formatConfigPrettyPrintFunction :: Maybe (String -> String -> (String, String)) , formatConfigPrintTimes :: Bool , formatConfigHtmlOutput :: Bool , formatConfigPrintCpuTime :: Bool , formatConfigUsedSeed :: Integer , formatConfigExpectedTotalCount :: Int-} deriving (Eq, Show)+}  data Signal = Ok | NotOk SomeException
src/Test/Hspec/Core/Formatters/Internal.hs view
@@ -36,6 +36,7 @@  , useDiff , prettyPrint+, prettyPrintFunction , extraChunk , missingChunk @@ -96,9 +97,11 @@     case itemResult item of       Success {} -> increaseSuccessCount       Pending {} -> increasePendingCount-      Failure loc err -> addFailMessage (loc <|> itemLocation item) path err+      Failure loc err -> addFailure $ FailureRecord (loc <|> itemLocation item) path err     formatterItemDone path item   Done _ -> formatterDone+  where+    addFailure r = modify $ \ s -> s { stateFailMessages = r : stateFailMessages s }  -- | Get the number of failed examples encountered so far. getFailCount :: FormatM Int@@ -110,8 +113,16 @@  -- | Return `True` if the user requested pretty diffs, `False` otherwise. prettyPrint :: FormatM Bool-prettyPrint = getConfig formatConfigPrettyPrint+prettyPrint = maybe False (const True) <$> getConfig formatConfigPrettyPrintFunction+{-# DEPRECATED prettyPrint "use `prettyPrintFunction` instead" #-} +-- | Return a function for pretty-printing if the user requested pretty diffs,+-- `Nothing` otherwise.+--+-- @since 2.10.0+prettyPrintFunction :: FormatM (Maybe (String -> String -> (String, String)))+prettyPrintFunction = getConfig formatConfigPrettyPrintFunction+ -- | Return `True` if the user requested unicode output, `False` otherwise. outputUnicode :: FormatM Bool outputUnicode = getConfig formatConfigOutputUnicode@@ -168,9 +179,20 @@ runFormatM config (FormatM action) = withLineBuffering $ do   time <- getMonotonicTime   cpuTime <- if (formatConfigPrintCpuTime config) then Just <$> CPUTime.getCPUTime else pure Nothing-  st <- newIORef (FormatterState 0 0 [] cpuTime time config Nothing)-  evalStateT action st +  let+    progress = formatConfigReportProgress config && not (formatConfigHtmlOutput config)+    state = FormatterState {+      stateSuccessCount = 0+    , statePendingCount = 0+    , stateFailMessages = []+    , stateCpuStartTime = cpuTime+    , stateStartTime = time+    , stateConfig = config { formatConfigReportProgress = progress }+    , stateColor = Nothing+    }+  newIORef state >>= evalStateT action+ withLineBuffering :: IO a -> IO a withLineBuffering action = bracket (IO.hGetBuffering stdout) (IO.hSetBuffering stdout) $ \ _ -> do   IO.hSetBuffering stdout IO.LineBuffering >> action@@ -190,10 +212,6 @@ -- | Get the number of pending examples encountered so far. getPendingCount :: FormatM Int getPendingCount = gets statePendingCount---- | Append to the list of accumulated failure messages.-addFailMessage :: Maybe Location -> Path -> FailureReason -> FormatM ()-addFailMessage loc p m = modify $ \s -> s {stateFailMessages = FailureRecord loc p m : stateFailMessages s}  -- | Get the list of accumulated failure messages. getFailMessages :: FormatM [FailureRecord]
src/Test/Hspec/Core/Formatters/V2.hs view
@@ -59,6 +59,7 @@  , useDiff , prettyPrint+, prettyPrintFunction , extraChunk , missingChunk @@ -126,12 +127,12 @@    , useDiff   , prettyPrint+  , prettyPrintFunction   , extraChunk   , missingChunk   )  import           Test.Hspec.Core.Formatters.Diff-import           Test.Hspec.Core.Formatters.Pretty (pretty2)  silent :: Formatter silent = Formatter {@@ -275,11 +276,11 @@         NoReason -> return ()         Reason err -> withFailColor $ indent err         ExpectedButGot preface expected_ actual_ -> do-          pretty <- prettyPrint+          pretty <- prettyPrintFunction           let-            (expected, actual)-              | pretty = pretty2 unicode expected_ actual_-              | otherwise = (expected_, actual_)+            (expected, actual) = case pretty of+              Just f -> f expected_ actual_+              Nothing -> (expected_, actual_)            mapM_ indent preface @@ -311,7 +312,9 @@               where                 indentation_ = indentation ++ replicate (length pre) ' ' -        Error _ e -> withFailColor . indent $ (("uncaught exception: " ++) . formatException) e+        Error info e -> do+          mapM_ indent info+          withFailColor . indent $ "uncaught exception: " ++ formatException e        writeLine ""
src/Test/Hspec/Core/Hooks.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-}@@ -22,15 +23,18 @@  , mapSubject , ignoreSubject++#ifdef TEST+, decompose+#endif ) where  import           Prelude () import           Test.Hspec.Core.Compat-import           Data.CallStack+import           Data.CallStack (HasCallStack) -import           Control.Exception (SomeException, finally, throwIO, try, catch)-import           Control.Concurrent.MVar-import           Control.Concurrent.Async+import           Control.Exception (SomeException, finally, throwIO, try)+import           Control.Concurrent  import           Test.Hspec.Core.Example import           Test.Hspec.Core.Tree@@ -95,11 +99,11 @@  -- | Run a custom action after the last spec item. afterAll :: HasCallStack => ActionWith a -> SpecWith a -> SpecWith a-afterAll action = mapSpecForest (return . NodeWithCleanup location action)+afterAll action = aroundAllWith (\ hook a -> hook a >> action a)  -- | Run a custom action after the last spec item. afterAll_ :: HasCallStack => IO () -> SpecWith a -> SpecWith a-afterAll_ action = afterAll (\_ -> action)+afterAll_ action = mapSpecForest (return . NodeWithCleanup callSite action)  -- | Run a custom action before and/or after every spec item. around_ :: (IO () -> IO ()) -> SpecWith a -> SpecWith a@@ -107,7 +111,7 @@  -- | Run a custom action before and/or after every spec item. aroundWith :: (ActionWith a -> ActionWith b) -> SpecWith a -> SpecWith b-aroundWith action = mapSpecItem action (modifyAroundAction action)+aroundWith = mapSpecItem_ . modifyAroundAction  modifyAroundAction :: (ActionWith a -> ActionWith b) -> Item a -> Item b modifyAroundAction action item@Item{itemExample = e} =@@ -120,47 +124,62 @@ -- | Wrap an action around the given spec. aroundAll_ :: HasCallStack => (IO () -> IO ()) -> SpecWith a -> SpecWith a aroundAll_ action spec = do-  allSpecItemsDone <- runIO newEmptyMVar-  workerRef <- runIO newEmptyMVar-  let-    acquire :: IO ()-    acquire = do-      resource <- newEmptyMVar-      worker <- async $ do-        action $ do-          signal resource-          waitFor allSpecItemsDone-      putMVar workerRef worker-      unwrapExceptionsFromLinkedThread $ do-        link worker-        waitFor resource-    release :: IO ()-    release = signal allSpecItemsDone >> takeMVar workerRef >>= wait-  beforeAll_ acquire $ afterAll_ release spec+  (acquire, release) <- runIO $ decompose (action .)+  beforeAll_ (acquire ()) $ afterAll_ release spec  -- | Wrap an action around the given spec. Changes the arg type inside. aroundAllWith :: forall a b. HasCallStack => (ActionWith a -> ActionWith b) -> SpecWith a -> SpecWith b aroundAllWith action spec = do-  allSpecItemsDone <- runIO newEmptyMVar-  workerRef <- runIO newEmptyMVar+  (acquire, release) <- runIO $ decompose action+  beforeAllWith acquire $ afterAll_ release spec++data Acquired a = Acquired a | ExceptionDuringAcquire SomeException+data Released   = Released   | ExceptionDuringRelease SomeException++decompose :: forall a b. ((a -> IO ()) -> b -> IO ()) -> IO (b -> IO a, IO ())+decompose action = do+  doCleanupNow <- newEmptyMVar+  acquired <- newEmptyMVar+  released <- newEmptyMVar+   let+    notify :: Either SomeException () -> IO ()+    -- `notify` is guaranteed to run without being interrupted by an async+    -- exception for the following reasons:+    --+    -- 1. `forkFinally` runs the final action within `mask`+    -- 2. `tryPutMVar` is guaranteed not to be interruptible+    -- 3. `putMVar` is guaranteed not to be interruptible on an empty `MVar`+    notify r = case r of+      Left err -> do+        exceptionDuringAcquire <- tryPutMVar acquired (ExceptionDuringAcquire err)+        putMVar released $ if exceptionDuringAcquire then Released else ExceptionDuringRelease err+      Right () -> do+        putMVar released Released++    forkWorker :: b -> IO ()+    forkWorker b = void . flip forkFinally notify $ do+      flip action b $ \ a -> do+        putMVar acquired (Acquired a)+        waitFor doCleanupNow+     acquire :: b -> IO a     acquire b = do-      resource <- newEmptyMVar-      worker <- async $ do-        flip action b $ \ a -> do-          putMVar resource a-          waitFor allSpecItemsDone-      putMVar workerRef worker-      unwrapExceptionsFromLinkedThread $ do-        link worker-        takeMVar resource+      forkWorker b+      r <- readMVar acquired -- This does not work reliably with base < 4.7+      case r of+        Acquired a -> return a+        ExceptionDuringAcquire err -> throwIO err+     release :: IO ()-    release = signal allSpecItemsDone >> takeMVar workerRef >>= wait-  beforeAllWith acquire $ afterAll_ release spec+    release = do+      signal doCleanupNow+      r <- takeMVar released+      case r of+        Released -> return ()+        ExceptionDuringRelease err -> throwIO err -unwrapExceptionsFromLinkedThread :: IO a -> IO a-unwrapExceptionsFromLinkedThread = (`catch` \ (ExceptionInLinkedThread _ e) -> throwIO e)+  return (acquire, release)  type BinarySemaphore = MVar ()
src/Test/Hspec/Core/Runner.hs view
@@ -5,8 +5,34 @@ -- Stability: provisional module Test.Hspec.Core.Runner ( -- * Running a spec+{- |+To run a spec `hspec` performs a sequence of steps:++1. Evaluate a `Spec` to a forest of `SpecTree`s+1. Read config values from the command-line, config files and the process environment+1. Execute each spec item of the forest and report results to `stdout`+1. Exit with `exitFailure` if at least on spec item fails++The four primitives `evalSpec`, `readConfig`, `runSpecForest` and+`evaluateResult` each perform one of these steps respectively.++`hspec` is defined in terms of these primitives:++@+hspec = `evalSpec` `defaultConfig` >=> \\ (config, spec) ->+      `getArgs`+  >>= `readConfig` config+  >>= `withArgs` [] . `runSpecForest` spec+  >>= `evaluateResult`+@++If you need more control over how a spec is run use these primitives individually.++-}   hspec-, runSpec+, evalSpec+, runSpecForest+, evaluateResult  -- * Config , Config (..)@@ -17,17 +43,35 @@ , configAddFilter , readConfig --- * Summary-, Summary (..)-, isSuccess-, evaluateSummary+-- * Result +-- ** Spec Result+, Test.Hspec.Core.Runner.Result.SpecResult+, Test.Hspec.Core.Runner.Result.specResultItems+, Test.Hspec.Core.Runner.Result.specResultSuccess++-- ** Result Item+, Test.Hspec.Core.Runner.Result.ResultItem+, Test.Hspec.Core.Runner.Result.resultItemPath+, Test.Hspec.Core.Runner.Result.resultItemStatus+, Test.Hspec.Core.Runner.Result.resultItemIsFailure++-- ** Result Item Status+, Test.Hspec.Core.Runner.Result.ResultItemStatus(..)+ -- * Legacy--- | The following primitives are deprecated.  Use `runSpec` instead.+-- | The following primitives are deprecated.  Use `runSpecForest` instead. , hspecWith , hspecResult , hspecWithResult+, runSpec +-- ** Summary+, Summary (..)+, toSummary+, isSuccess+, evaluateSummary+ #ifdef TEST , rerunAll , specToEvalForest@@ -40,6 +84,7 @@ import           Test.Hspec.Core.Compat  import           Data.Maybe+import           NonEmpty (nonEmpty) import           System.IO import           System.Environment (getArgs, withArgs) import           System.Exit@@ -66,7 +111,7 @@ import           Test.Hspec.Core.Runner.PrintSlowSpecItems import           Test.Hspec.Core.Runner.Eval hiding (Tree(..)) import qualified Test.Hspec.Core.Runner.Eval as Eval-+import           Test.Hspec.Core.Runner.Result  applyFilterPredicates :: Config -> [Tree c EvalItem] -> [Tree c EvalItem] applyFilterPredicates c = filterForestWithLabels p@@ -97,15 +142,29 @@ -- Exit with `exitFailure` if at least one spec item fails. -- -- /Note/: `hspec` handles command-line options and reads config files.  This--- is not always desired.  Use `runSpec` if you need more control over these--- aspects.+-- is not always desirable.  Use `evalSpec` and `runSpecForest` if you need+-- more control over these aspects. hspec :: Spec -> IO ()-hspec spec =+hspec = evalSpec defaultConfig >=> \ (config, spec) ->       getArgs-  >>= readConfig defaultConfig-  >>= doNotLeakCommandLineArgumentsToExamples . runSpec spec-  >>= evaluateSummary+  >>= readConfig config+  >>= doNotLeakCommandLineArgumentsToExamples . runSpecForest spec+  >>= evaluateResult +-- |+-- Evaluate a `Spec` to a forest of `SpecTree`s.  This does not execute any+-- spec items, but it does run any IO that is used during spec construction+-- time (see `runIO`).+--+-- A `Spec` may modify a `Config` through `modifyConfig`.  These modifications+-- are applied to the given config (the first argument).+--+-- @since 2.10.0+evalSpec :: Config -> SpecWith a -> IO (Config, [SpecTree a])+evalSpec config spec = do+  (Endo f, forest) <- runSpecM spec+  return (f config, forest)+ -- 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@@ -118,7 +177,7 @@ -- | Run given spec with custom options. -- This is similar to `hspec`, but more flexible. hspecWith :: Config -> Spec -> IO ()-hspecWith config spec = getArgs >>= readConfig config >>= doNotLeakCommandLineArgumentsToExamples . runSpec spec >>= evaluateSummary+hspecWith defaults = hspecWithResult defaults >=> evaluateSummary  -- | `True` if the given `Summary` indicates that there were no -- failures, `False` otherwise.@@ -130,13 +189,16 @@ evaluateSummary :: Summary -> IO () evaluateSummary summary = unless (isSuccess summary) exitFailure +evaluateResult :: SpecResult -> IO ()+evaluateResult result = unless (specResultSuccess result) exitFailure+ -- | Run given spec and returns a summary of the test run. -- -- /Note/: `hspecResult` does not exit with `exitFailure` on failing spec -- items.  If you need this, you have to check the `Summary` yourself and act -- accordingly. hspecResult :: Spec -> IO Summary-hspecResult spec = getArgs >>= readConfig defaultConfig >>= doNotLeakCommandLineArgumentsToExamples . runSpec spec+hspecResult = hspecWithResult defaultConfig  -- | Run given spec with custom options and returns a summary of the test run. --@@ -144,24 +206,32 @@ -- items.  If you need this, you have to check the `Summary` yourself and act -- accordingly. hspecWithResult :: Config -> Spec -> IO Summary-hspecWithResult config spec = getArgs >>= readConfig config >>= doNotLeakCommandLineArgumentsToExamples . runSpec spec+hspecWithResult defaults = evalSpec defaults >=> \ (config, spec) ->+      getArgs+  >>= readConfig config+  >>= doNotLeakCommandLineArgumentsToExamples . fmap toSummary . runSpecForest spec  -- |--- `runSpec` is the most basic primitive to run a spec. `hspec` is defined in--- terms of @runSpec@:+-- /Note/: `runSpec` is deprecated. It ignores any modifications applied+-- through `modifyConfig`.  Use `evalSpec` and `runSpecForest` instead.+runSpec :: Spec -> Config -> IO Summary+runSpec spec config = evalSpec defaultConfig spec >>= fmap toSummary . flip runSpecForest config . snd++-- |+-- `runSpecForest` is the most basic primitive to run a spec. `hspec` is+-- defined in terms of @runSpecForest@: -- -- @--- hspec spec =+-- hspec = `evalSpec` `defaultConfig` >=> \\ (config, spec) -> --       `getArgs`---   >>= `readConfig` `defaultConfig`---   >>= `withArgs` [] . runSpec spec---   >>= `evaluateSummary`+--   >>= `readConfig` config+--   >>= `withArgs` [] . runSpecForest spec+--   >>= `evaluateResult` -- @-runSpec :: Spec -> Config -> IO Summary-runSpec spec config = runSpecM spec >>= runSpecForest config--runSpecForest :: Config -> [SpecTree ()] -> IO Summary-runSpecForest c_ spec = do+--+-- @since 2.10.0+runSpecForest :: [SpecTree ()] -> Config -> IO SpecResult+runSpecForest spec c_ = do   oldFailureReport <- readFailureReportOnRerun c_    c <- ensureSeed (applyFailureReport oldFailureReport c_)@@ -180,12 +250,12 @@   where     normalMode c = runSpecForest_ c spec     rerunAllMode c oldFailureReport = do-      summary <- runSpecForest_ c spec-      if rerunAll c oldFailureReport summary-        then runSpecForest c_ spec-        else return summary+      result <- runSpecForest_ c spec+      if rerunAll c oldFailureReport result+        then runSpecForest spec c_+        else return result -runSpecForest_ :: Config -> [SpecTree ()] -> IO Summary+runSpecForest_ :: Config -> [SpecTree ()] -> IO SpecResult runSpecForest_ config spec = runEvalTree config (specToEvalForest config spec)  failFocused :: Item a -> Item a@@ -211,7 +281,7 @@   | configFocusedOnly config = spec   | otherwise = focusForest spec -runEvalTree :: Config -> [EvalTree] -> IO Summary+runEvalTree :: Config -> [EvalTree] -> IO SpecResult runEvalTree config spec = do   let       seed = (fromJust . configQuickCheckSeed) config@@ -225,7 +295,7 @@   (reportProgress, useColor) <- colorOutputSupported (configColorMode config) (hSupportsANSI stdout)   outputUnicode <- unicodeOutputSupported (configUnicodeMode config) stdout -  results <- withHiddenCursor reportProgress stdout $ do+  results <- fmap toSpecResult . withHiddenCursor reportProgress stdout $ do     let       formatConfig = FormatConfig {         formatConfigUseColor = useColor@@ -233,6 +303,7 @@       , formatConfigOutputUnicode = outputUnicode       , formatConfigUseDiff = configDiff config       , formatConfigPrettyPrint = configPrettyPrint config+      , formatConfigPrettyPrintFunction = if configPrettyPrint config then Just (configPrettyPrintFunction config outputUnicode) else Nothing       , formatConfigPrintTimes = configTimes config       , formatConfigHtmlOutput = configHtmlOutput config       , formatConfigPrintCpuTime = configPrintCpuTime config@@ -252,15 +323,22 @@       }     runFormatter evalConfig spec -  let failures = filter resultItemIsFailure results+  let+    failures :: [Path]+    failures = map resultItemPath $ filter resultItemIsFailure $ specResultItems results -  dumpFailureReport config seed qcArgs (map fst failures)+  dumpFailureReport config seed qcArgs failures -  return Summary {-    summaryExamples = length results-  , summaryFailures = length failures-  }+  return results +toSummary :: SpecResult -> Summary+toSummary result = Summary {+  summaryExamples = length items+, summaryFailures = length failures+} where+    items = specResultItems result+    failures = filter resultItemIsFailure items+ specToEvalForest :: Config -> [SpecTree ()] -> [EvalTree] specToEvalForest config =       failFocusedItems config@@ -291,7 +369,7 @@ type EvalItemTree = Tree (IO ()) EvalItem  toEvalItemForest :: Params -> [SpecTree ()] -> [EvalItemTree]-toEvalItemForest params = bimapForest withUnit toEvalItem . filterForest itemIsFocused+toEvalItemForest params = bimapForest id toEvalItem . filterForest itemIsFocused   where     toEvalItem :: Item () -> EvalItem     toEvalItem (Item requirement loc isParallelizable _isFocused e) = EvalItem requirement loc (fromMaybe False isParallelizable) (e params withUnit)@@ -343,18 +421,19 @@   UnicodeNever -> return False   UnicodeAlways -> return True -rerunAll :: Config -> Maybe FailureReport -> Summary -> Bool-rerunAll _ Nothing _ = False-rerunAll config (Just oldFailureReport) summary =-     configRerunAllOnSuccess config-  && configRerun config-  && isSuccess summary-  && (not . null) (failureReportPaths oldFailureReport)+rerunAll :: Config -> Maybe FailureReport -> SpecResult -> Bool+rerunAll config mOldFailureReport result = case mOldFailureReport of+  Nothing -> False+  Just oldFailureReport ->+       configRerunAllOnSuccess config+    && configRerun config+    && specResultSuccess result+    && (not . null) (failureReportPaths oldFailureReport)  -- | Summary of a test run. data Summary = Summary {-  summaryExamples :: Int-, summaryFailures :: Int+  summaryExamples :: !Int+, summaryFailures :: !Int } deriving (Eq, Show)  instance Monoid Summary where
src/Test/Hspec/Core/Runner/Eval.hs view
@@ -14,14 +14,12 @@  module Test.Hspec.Core.Runner.Eval (   EvalConfig(..)-, NonEmpty(..)-, nonEmpty , EvalTree , Tree(..) , EvalItem(..) , runFormatter-, resultItemIsFailure #ifdef TEST+, mergeResults , runSequentially #endif ) where@@ -49,18 +47,12 @@ import           Test.Hspec.Core.Example.Location import           Test.Hspec.Core.Example (safeEvaluateResultStatus) -data NonEmpty a = a :| [a]-  deriving (Eq, Show, Functor, Foldable, Traversable)--infixr 5 :|--nonEmpty :: [a] -> Maybe (NonEmpty a)-nonEmpty []     = Nothing-nonEmpty (a:as) = Just (a :| as)+import qualified NonEmpty+import           NonEmpty (NonEmpty(..))  data Tree c a =     Node String (NonEmpty (Tree c a))-  | NodeWithCleanup (Maybe Location) c (NonEmpty (Tree c a))+  | NodeWithCleanup (Maybe (String, Location)) c (NonEmpty (Tree c a))   | Leaf a   deriving (Eq, Show, Functor, Foldable, Traversable) @@ -144,7 +136,7 @@     withTimer 0.05 $ \ timer -> do        format Format.Started-      runReaderT (run $ map (fmap (fmap (. reportProgress timer) . snd)) runningSpecs) (Env config ref) `E.finally` do+      runReaderT (run . applyCleanup $ map (fmap (fmap (. reportProgress timer) . snd)) runningSpecs) (Env config ref) `E.finally` do         results <- reverse <$> readIORef ref         format (Format.Done results) @@ -166,14 +158,60 @@ data Item a = Item {   _itemDescription :: String , _itemLocation :: Maybe Location-, _itemAction :: a+, itemAction :: a } deriving Functor  type Job m p a = (p -> m ()) -> m a -type RunningItem m = Item (Path -> m (Seconds, Result))-type RunningTree m = Tree (IO ()) (RunningItem m)+type RunningItem = Item (Path -> IO (Seconds, Result))+type RunningTree c = Tree c RunningItem +applyCleanup :: [RunningTree (IO ())] -> [RunningTree ()]+applyCleanup = map go+  where+    go t = case t of+      Leaf a -> Leaf a+      Node label xs -> Node label (go <$> xs)+      NodeWithCleanup loc cleanup xs -> NodeWithCleanup loc () (addCleanupToLastLeaf loc cleanup $ go <$> xs)++addCleanupToLastLeaf :: Maybe (String, Location) -> IO () -> NonEmpty (RunningTree ()) -> NonEmpty (RunningTree ())+addCleanupToLastLeaf loc cleanup = go+  where+    go = NonEmpty.reverse . mapHead goNode . NonEmpty.reverse++    goNode node = case node of+      Leaf item -> Leaf (addCleanupToItem loc cleanup item)+      NodeWithCleanup loc_ () zs -> NodeWithCleanup loc_ () (go zs)+      Node description zs -> Node description (go zs)++mapHead :: (a -> a) -> NonEmpty a -> NonEmpty a+mapHead f xs = case xs of+  y :| ys -> f y :| ys++addCleanupToItem :: Maybe (String, Location) -> IO () -> RunningItem -> RunningItem+addCleanupToItem loc cleanup item = item {+  itemAction = \ path -> do+    (t1, r1) <- itemAction item path+    (t2, r2) <- measure $ safeEvaluateResultStatus (cleanup >> return Success)+    let t = t1 + t2+    return (t, mergeResults loc r1 r2)+}++mergeResults :: Maybe (String, Location) -> Result -> ResultStatus -> Result+mergeResults mCallSite (Result info r1) r2 = Result info $ case (r1, r2) of+  (_, Success) -> r1+  (Failure{}, _) -> r1+  (Pending{}, Pending{}) -> r1+  (Success, Pending{}) -> r2+  (_, Failure mLoc err) -> Failure (mLoc <|> hookLoc) $ case err of+    Error message e -> Error (message <|> hookFailed) e+    _ -> err+  where+    hookLoc = snd <$> mCallSite+    hookFailed = case mCallSite of+      Just (name, _) -> Just $ "in " ++ name ++ "-hook:"+      Nothing -> Nothing+ type RunningItem_ m = (Async (), Item (Job m Progress (Seconds, Result))) type RunningTree_ m = Tree (IO ()) (RunningItem_ m) @@ -228,12 +266,12 @@ replaceMVar :: MVar a -> a -> IO () replaceMVar mvar p = tryTakeMVar mvar >> putMVar mvar p -run :: [RunningTree IO] -> EvalM ()+run :: [RunningTree ()] -> EvalM () run specs = do-  fastFail <- asks (evalConfigFailFast . envConfig)-  sequenceActions fastFail (concatMap foldSpec specs)+  failFast <- asks (evalConfigFailFast . envConfig)+  sequenceActions failFast (concatMap foldSpec specs)   where-    foldSpec :: RunningTree IO -> [EvalM ()]+    foldSpec :: RunningTree () -> [EvalM ()]     foldSpec = foldTree FoldTree {       onGroupStarted = groupStarted     , onGroupDone = groupDone@@ -241,16 +279,10 @@     , onLeafe = evalItem     } -    runCleanup :: Maybe Location -> [String] -> IO () -> EvalM ()-    runCleanup loc groups action = do-      (t, r) <- liftIO $ measure $ safeEvaluateResultStatus (action >> return Success)-      case r of-        Success -> return ()-        _ -> reportItem path loc $ return (t, Result "" r)-      where-        path = (groups, "afterAll-hook")+    runCleanup :: Maybe (String, Location) -> [String] -> () -> EvalM ()+    runCleanup _loc _groups = return -    evalItem :: [String] -> RunningItem IO -> EvalM ()+    evalItem :: [String] -> RunningItem -> EvalM ()     evalItem groups (Item requirement loc action) = do       reportItem path loc $ lift (action path)       where@@ -260,7 +292,7 @@ data FoldTree c a r = FoldTree {   onGroupStarted :: Path -> r , onGroupDone :: Path -> r-, onCleanup :: Maybe Location -> [String] -> c -> r+, onCleanup :: Maybe (String, Location) -> [String] -> c -> r , onLeafe :: [String] -> a -> r } @@ -280,20 +312,21 @@     go rGroups (Leaf a) = [onLeafe (reverse rGroups) a]  sequenceActions :: Bool -> [EvalM ()] -> EvalM ()-sequenceActions fastFail = go+sequenceActions failFast = go   where     go :: [EvalM ()] -> EvalM ()     go [] = return ()     go (action : actions) = do       action-      hasFailures <- any resultItemIsFailure <$> getResults-      let stopNow = fastFail && hasFailures+      stopNow <- case failFast of+        False -> return False+        True -> any itemIsFailure <$> getResults       unless stopNow (go actions) -resultItemIsFailure :: (Path, Format.Item) -> Bool-resultItemIsFailure = isFailure . Format.itemResult . snd-  where-    isFailure r = case r of-      Format.Success{} -> False-      Format.Pending{} -> False-      Format.Failure{} -> True+    itemIsFailure :: (Path, Format.Item) -> Bool+    itemIsFailure = isFailure . Format.itemResult . snd+      where+        isFailure r = case r of+          Format.Success{} -> False+          Format.Pending{} -> False+          Format.Failure{} -> True
+ src/Test/Hspec/Core/Runner/Result.hs view
@@ -0,0 +1,58 @@+module Test.Hspec.Core.Runner.Result (+-- RE-EXPORTED from Test.Hspec.Core.Runner+  SpecResult(SpecResult)+, specResultItems+, specResultSuccess++, ResultItem(ResultItem)+, resultItemPath+, resultItemStatus+, resultItemIsFailure++, ResultItemStatus(..)+-- END RE-EXPORTED from Test.Hspec.Core.Runner++, toSpecResult+) where++import           Prelude ()+import           Test.Hspec.Core.Compat++import           Test.Hspec.Core.Util+import qualified Test.Hspec.Core.Format as Format++data SpecResult = SpecResult {+  specResultItems :: [ResultItem]+, specResultSuccess :: !Bool+} deriving (Eq, Show)++data ResultItem = ResultItem {+  resultItemPath :: Path+, resultItemStatus :: ResultItemStatus+} deriving (Eq, Show)++resultItemIsFailure :: ResultItem -> Bool+resultItemIsFailure item = case resultItemStatus item of+  ResultItemSuccess -> False+  ResultItemPending -> False+  ResultItemFailure -> True++data ResultItemStatus =+    ResultItemSuccess+  | ResultItemPending+  | ResultItemFailure+  deriving (Eq, Show)++toSpecResult :: [(Path, Format.Item)] -> SpecResult+toSpecResult results = SpecResult items success+  where+    items = map toResultItem results+    success = all (not . resultItemIsFailure) items++toResultItem :: (Path, Format.Item) -> ResultItem+toResultItem (path, item) = ResultItem path status+  where+    status = case Format.itemResult item of+      Format.Success{} -> ResultItemSuccess+      Format.Pending{} -> ResultItemPending+      Format.Failure{} -> ResultItemFailure
src/Test/Hspec/Core/Spec.hs view
@@ -29,7 +29,18 @@ , sequential  -- * The @SpecM@ monad-, module Test.Hspec.Core.Spec.Monad+, Test.Hspec.Core.Spec.Monad.Spec+, Test.Hspec.Core.Spec.Monad.SpecWith+, Test.Hspec.Core.Spec.Monad.SpecM(..)+, Test.Hspec.Core.Spec.Monad.runSpecM+, Test.Hspec.Core.Spec.Monad.fromSpecList+, Test.Hspec.Core.Spec.Monad.runIO+, Test.Hspec.Core.Spec.Monad.mapSpecForest+, Test.Hspec.Core.Spec.Monad.mapSpecItem+, Test.Hspec.Core.Spec.Monad.mapSpecItem_+, Test.Hspec.Core.Spec.Monad.modifyParams+, Test.Hspec.Core.Spec.Monad.modifyConfig+, getSpecDescriptionPath  -- * A type class for examples , Test.Hspec.Core.Example.Example (..)@@ -46,7 +57,21 @@ , Test.Hspec.Core.Example.safeEvaluateExample  -- * Internal representation of a spec tree-, module Test.Hspec.Core.Tree+, Test.Hspec.Core.Tree.SpecTree+, Test.Hspec.Core.Tree.Tree (..)+, Test.Hspec.Core.Tree.Item (..)+, Test.Hspec.Core.Tree.specGroup+, Test.Hspec.Core.Tree.specItem+, Test.Hspec.Core.Tree.bimapTree+, Test.Hspec.Core.Tree.bimapForest+, Test.Hspec.Core.Tree.filterTree+, Test.Hspec.Core.Tree.filterForest+, Test.Hspec.Core.Tree.filterTreeWithLabels+, Test.Hspec.Core.Tree.filterForestWithLabels+, Test.Hspec.Core.Tree.pruneTree -- unused+, Test.Hspec.Core.Tree.pruneForest -- unused+, Test.Hspec.Core.Tree.location+ , focusForest ) where @@ -55,6 +80,8 @@  import qualified Control.Exception as E import           Data.CallStack+import           Control.Monad.Trans.Class (lift)+import           Control.Monad.Trans.Reader (asks)  import           Test.Hspec.Expectations (Expectation) @@ -65,7 +92,9 @@  -- | The @describe@ function combines a list of specs into a larger spec. describe :: HasCallStack => String -> SpecWith a -> SpecWith a-describe label = mapSpecForest (return . specGroup label)+describe label = withEnv pushLabel . mapSpecForest (return . specGroup label)+  where+    pushLabel (Env labels) = Env $ label : labels  -- | @context@ is an alias for `describe`. context :: HasCallStack => String -> SpecWith a -> SpecWith a@@ -169,3 +198,19 @@ -- argument that can be used to specify the reason for why the spec item is pending. pendingWith :: HasCallStack => String -> Expectation pendingWith = E.throwIO . Pending location . Just++-- | Get the path of `describe` labels, from the root all the way in to the+-- call-site of this function.+--+-- ==== __Example__+-- >>> :{+-- runSpecM $ do+--   describe "foo" $ do+--     describe "bar" $ do+--       getSpecDescriptionPath >>= runIO . print+-- :}+-- ["foo","bar"]+--+-- @since 2.10.0+getSpecDescriptionPath :: SpecM a [String]+getSpecDescriptionPath = SpecM $ lift $ reverse <$> asks envSpecDescriptionPath
src/Test/Hspec/Core/Spec/Monad.hs view
@@ -1,10 +1,9 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}---- NOTE: re-exported from Test.Hspec.Core.Spec module Test.Hspec.Core.Spec.Monad (+-- RE-EXPORTED from Test.Hspec.Core.Spec   Spec , SpecWith-, SpecM (..)+, SpecM (SpecM) , runSpecM , fromSpecList , runIO@@ -13,33 +12,51 @@ , mapSpecItem , mapSpecItem_ , modifyParams++, modifyConfig+-- END RE-EXPORTED from Test.Hspec.Core.Spec++, Env(..)+, withEnv ) where  import           Prelude () import           Test.Hspec.Core.Compat  import           Control.Arrow-import           Control.Monad.Trans.Writer import           Control.Monad.IO.Class (liftIO)+import           Control.Monad.Trans.Reader+import           Control.Monad.Trans.Writer  import           Test.Hspec.Core.Example import           Test.Hspec.Core.Tree +import           Test.Hspec.Core.Config.Definition (Config)+ type Spec = SpecWith ()  type SpecWith a = SpecM a () +-- |+-- @since 2.10.0+modifyConfig :: (Config -> Config) -> SpecWith a+modifyConfig f = SpecM $ tell (Endo f, mempty)+ -- | A writer monad for `SpecTree` forests-newtype SpecM a r = SpecM (WriterT [SpecTree a] IO r)+newtype SpecM a r = SpecM { unSpecM :: WriterT (Endo Config, [SpecTree a]) (ReaderT Env IO) r }   deriving (Functor, Applicative, Monad)  -- | Convert a `Spec` to a forest of `SpecTree`s.-runSpecM :: SpecWith a -> IO [SpecTree a]-runSpecM (SpecM specs) = execWriterT specs+runSpecM :: SpecWith a -> IO (Endo Config, [SpecTree a])+runSpecM = flip runReaderT (Env []) . execWriterT . unSpecM  -- | Create a `Spec` from a forest of `SpecTree`s.+fromSpecForest :: (Endo Config, [SpecTree a]) -> SpecWith a+fromSpecForest = SpecM . tell++-- | Create a `Spec` from a forest of `SpecTree`s. fromSpecList :: [SpecTree a] -> SpecWith a-fromSpecList = SpecM . tell+fromSpecList = fromSpecForest . (,) mempty  -- | Run an IO action while constructing the spec tree. --@@ -53,13 +70,20 @@ runIO = SpecM . liftIO  mapSpecForest :: ([SpecTree a] -> [SpecTree b]) -> SpecM a r -> SpecM b r-mapSpecForest f (SpecM specs) = SpecM (mapWriterT (fmap (second f)) specs)+mapSpecForest f (SpecM specs) = SpecM (mapWriterT (fmap (fmap (second f))) specs)  mapSpecItem :: (ActionWith a -> ActionWith b) -> (Item a -> Item b) -> SpecWith a -> SpecWith b-mapSpecItem g f = mapSpecForest (bimapForest g f)+mapSpecItem _ = mapSpecItem_ -mapSpecItem_ :: (Item a -> Item a) -> SpecWith a -> SpecWith a-mapSpecItem_ = mapSpecItem id+mapSpecItem_ :: (Item a -> Item b) -> SpecWith a -> SpecWith b+mapSpecItem_ = mapSpecForest . bimapForest id  modifyParams :: (Params -> Params) -> SpecWith a -> SpecWith a modifyParams f = mapSpecItem_ $ \item -> item {itemExample = \p -> (itemExample item) (f p)}++newtype Env = Env {+  envSpecDescriptionPath :: [String]+}++withEnv :: (Env -> Env) -> SpecM a r -> SpecM a r+withEnv f = SpecM . WriterT . local f . runWriterT . unSpecM
src/Test/Hspec/Core/Tree.hs view
@@ -4,8 +4,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} --- NOTE: re-exported from Test.Hspec.Core.Spec module Test.Hspec.Core.Tree (+-- RE-EXPORTED from Test.Hspec.Core.Spec   SpecTree , Tree (..) , Item (..)@@ -20,12 +20,15 @@ , pruneTree -- unused , pruneForest -- unused , location+-- END RE-EXPORTED from Test.Hspec.Core.Spec+, callSite ) where  import           Prelude () import           Test.Hspec.Core.Compat -import           Data.CallStack+import           Data.CallStack (HasCallStack, SrcLoc(..))+import qualified Data.CallStack as CallStack import           Data.Maybe  import           Test.Hspec.Core.Example@@ -33,13 +36,13 @@ -- | Internal tree data structure data Tree c a =     Node String [Tree c a]-  | NodeWithCleanup (Maybe Location) c [Tree c a]+  | NodeWithCleanup (Maybe (String, Location)) c [Tree c a]   | Leaf a   deriving (Eq, Show, Functor, Foldable, Traversable)  -- | A tree is used to represent a spec internally.  The tree is parameterized -- over the type of cleanup actions and the type of the actual spec items.-type SpecTree a = Tree (ActionWith a) (Item a)+type SpecTree a = Tree (IO ()) (Item a)  bimapForest :: (a -> b) -> (c -> d) -> [Tree a c] -> [Tree b d] bimapForest g f = map (bimapTree g f)@@ -132,11 +135,15 @@       | otherwise = s  location :: HasCallStack => Maybe Location-location = case reverse callStack of-  (_, loc) : _ -> Just (Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc))-  _ -> Nothing+location = snd <$> callSite +callSite :: HasCallStack => Maybe (String, Location)+callSite = fmap toLocation <$> CallStack.callSite+ defaultDescription :: HasCallStack => Maybe String-defaultDescription = case reverse callStack of-  (_, loc) : _ -> Just (srcLocModule loc ++ "[" ++ show (srcLocStartLine loc) ++ ":" ++ show (srcLocStartCol loc) ++ "]")-  _ -> Nothing+defaultDescription = case CallStack.callSite of+  Just (_, loc) -> Just (srcLocModule loc ++ "[" ++ show (srcLocStartLine loc) ++ ":" ++ show (srcLocStartCol loc) ++ "]")+  Nothing -> Nothing++toLocation :: SrcLoc -> Location+toLocation loc = Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc)
src/Test/Hspec/Core/Util.hs view
@@ -102,7 +102,7 @@ -- This is different from `show`.  The type of the exception is included, e.g.: -- -- >>> formatException (toException DivideByZero)--- "ArithException (divide by zero)"+-- "ArithException\ndivide by zero" -- -- For `IOException`s the `IOErrorType` is included, as well. formatException :: SomeException -> String
test/Test/Hspec/Core/Config/OptionsSpec.hs view
@@ -88,7 +88,7 @@      context "with --depth" $ do       it "sets depth parameter for SmallCheck" $ do-        configSmallCheckDepth <$> parseOptions [] Nothing [] ["--depth", "23"] `shouldBe` Right 23+        configSmallCheckDepth <$> parseOptions [] Nothing [] ["--depth", "23"] `shouldBe` Right (Just 23)      context "with --jobs" $ do       it "sets number of concurrent jobs" $ do
test/Test/Hspec/Core/Formatters/InternalSpec.hs view
@@ -15,6 +15,7 @@ , formatConfigOutputUnicode = False , formatConfigUseDiff = False , formatConfigPrettyPrint = False+, formatConfigPrettyPrintFunction = Nothing , formatConfigPrintTimes = False , formatConfigHtmlOutput = False , formatConfigPrintCpuTime = False
test/Test/Hspec/Core/Formatters/V2Spec.hs view
@@ -25,15 +25,17 @@ formatConfig = FormatConfig {   formatConfigUseColor = False , formatConfigReportProgress = False-, formatConfigOutputUnicode = True+, formatConfigOutputUnicode = unicode , formatConfigUseDiff = True , formatConfigPrettyPrint = True+, formatConfigPrettyPrintFunction = Just (H.configPrettyPrintFunction H.defaultConfig unicode) , formatConfigPrintTimes = False , formatConfigHtmlOutput = False , formatConfigPrintCpuTime = False , formatConfigUsedSeed = 0 , formatConfigExpectedTotalCount = 0-}+} where+    unicode = True  runSpecWith :: Formatter -> H.Spec -> IO [String] runSpecWith formatter = captureLines . H.hspecWithResult H.defaultConfig {H.configFormat = Just $ formatterToFormat formatter}
test/Test/Hspec/Core/HooksSpec.hs view
@@ -7,6 +7,7 @@ import           Mock  import           Control.Exception+import           Control.Arrow  import qualified Test.Hspec.Core.Runner as H import qualified Test.Hspec.Core.Spec as H@@ -18,8 +19,9 @@ evalSpec_ :: H.Spec -> IO () evalSpec_ = void . evalSpec + evalSpec :: H.Spec -> IO [([String], Item)]-evalSpec = fmap normalize . (fmap (H.specToEvalForest H.defaultConfig) . H.runSpecM >=> runFormatter config)+evalSpec = fmap normalize . (toEvalForest >=> runFormatter config)   where     config = EvalConfig {       evalConfigFormat = \ _ -> return ()@@ -37,6 +39,9 @@     }     pathToList (xs, x) = xs ++ [x] +toEvalForest :: H.SpecWith () -> IO [EvalTree]+toEvalForest = fmap (uncurry H.specToEvalForest . first (($ H.defaultConfig) . appEndo)) . H.runSpecM+ mkAppend :: IO (String -> IO (), IO [String]) mkAppend = do   ref <- newIORef ([] :: [String])@@ -318,7 +323,6 @@         , "foo"         , "before"         , "bar"-        , "before"         , "from before"         ] @@ -332,9 +336,10 @@       it "reports a failure" $ do         evalSpec $ H.before (return "from before") $ H.afterAll (\_ -> throwException) $ do           H.it "foo" $ \a -> a `shouldBe` "from before"+          H.it "bar" $ \a -> a `shouldBe` "from before"         `shouldReturn` [           item ["foo"] Success-        , item ["afterAll-hook"] divideByZero+        , item ["bar"] $ divideByZeroIn "afterAll"         ]    describe "afterAll_" $ do@@ -350,7 +355,6 @@         , "foo"         , "before"         , "bar"-        , "before"         , "afterAll_"         ] @@ -378,9 +382,10 @@         evalSpec $ do           H.afterAll_ H.pending $ do             H.it "foo" True+            H.it "bar" True         `shouldReturn` [           item ["foo"] Success-        , item ["afterAll-hook"] (Pending Nothing Nothing)+        , item ["bar"] (Pending Nothing Nothing)         ]      context "when action throws an exception" $ do@@ -388,13 +393,14 @@         evalSpec $ do           H.afterAll_ throwException $ do             H.it "foo" True+            H.it "bar" True         `shouldReturn` [           item ["foo"] Success-        , item ["afterAll-hook"] divideByZero+        , item ["bar"] $ divideByZeroIn "afterAll_"         ]      context "when action is successful" $ do-      it "does not report anythig" $ do+      it "does not report anything" $ do         evalSpec $ do           H.afterAll_ (return ()) $ do             H.it "foo" True@@ -513,24 +519,26 @@         , "2"         , "3"         ]-      mockCounter mock `shouldReturn` 4+      mockCounter mock `shouldReturn` 3      it "reports exceptions on acquire" $ do       evalSpec $ do         H.aroundAll_ (throwException <*) $ do           H.it "foo" True+          H.it "bar" True       `shouldReturn` [         item ["foo"] divideByZero-      , item ["afterAll-hook"] (Pending Nothing $ exceptionIn "aroundAll_")+      , item ["bar"] (Pending Nothing $ exceptionIn "aroundAll_")       ]      it "reports exceptions on release" $ do       evalSpec $ do         H.aroundAll_ (<* throwException) $ do           H.it "foo" True+          H.it "bar" True       `shouldReturn` [         item ["foo"] Success-      , item ["afterAll-hook"] divideByZero+      , item ["bar"] $ divideByZeroIn "aroundAll_"       ]    describe "aroundAllWith" $ do@@ -547,7 +555,7 @@         , "1"         , "1"         ]-      mockCounter mock `shouldReturn` 4+      mockCounter mock `shouldReturn` 3      it "reports exceptions on acquire" $ do       evalSpec $ do@@ -555,21 +563,51 @@           H.it "foo" H.pending       `shouldReturn` [         item ["foo"] divideByZero-      , item ["afterAll-hook"] (Pending Nothing $ exceptionIn "aroundAllWith")       ]      it "reports exceptions on release" $ do       evalSpec $ do         H.aroundAllWith (\ action () -> action () <* throwException) $ do           H.it "foo" True+          H.it "bar" True       `shouldReturn` [         item ["foo"] Success-      , item ["afterAll-hook"] divideByZero+      , item ["bar"] $ divideByZeroIn "aroundAllWith"       ] +  describe "decompose" $ do+    it "decomposes a with-style action into acquire / release" $ do+      (acquire, release) <- H.decompose $ \ action x -> do+        action (x + 42)+      acquire 23 `shouldReturn` (65 :: Int)+      release++    context "with an exception during resource acquisition" $ do+      it "propagates that exception" $ do+        (acquire, release) <- H.decompose $ \ action () -> do+          throwException_+          action ()+        acquire () `shouldThrow` (== DivideByZero)+        release++    context "with an exception during resource deallocation" $ do+      it "propagates that exception" $ do+        (acquire, release) <- H.decompose $ \ action () -> do+          action ()+          throwException_+        acquire ()+        release `shouldThrow` (== DivideByZero)+   where     divideByZero :: Result     divideByZero = Failure Nothing (Error Nothing $ toException DivideByZero)++    divideByZeroIn :: String -> Result+#if MIN_VERSION_base(4,8,1)+    divideByZeroIn hook = Failure Nothing (Error (Just $ "in " <> hook <> "-hook:") $ toException DivideByZero)+#else+    divideByZeroIn _ = Failure Nothing (Error Nothing $ toException DivideByZero)+#endif      item :: [String] -> Result -> ([String], Item)     item path result = (path, Item Nothing 0 "" result)
test/Test/Hspec/Core/Runner/EvalSpec.hs view
@@ -1,16 +1,70 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} module Test.Hspec.Core.Runner.EvalSpec (spec) where  import           Prelude () import           Helper +import           Control.Exception+import           NonEmpty (fromList)++import           Test.Hspec.Core.Spec (FailureReason(..), Result(..), ResultStatus(..), Location(..))+ import           Test.Hspec.Core.Runner.Eval -fromList :: [a] -> NonEmpty a-fromList (a:as) = a :| as-fromList [] = error "NonEmpty.fromList: empty list"+instance Arbitrary ResultStatus where+  arbitrary = oneof [+      pure Success+    , Pending <$> arbitrary <*> arbitrary+    , failure+    ] +instance Arbitrary FailureReason where+  arbitrary = oneof [+      pure NoReason+    , ExpectedButGot <$> arbitrary <*> (show <$> positive) <*> (show <$> positive)+    , Error <$> arbitrary <*> pure (toException DivideByZero)+    ]++instance Arbitrary Location where+  arbitrary = Location <$> elements ["src/Foo.hs", "src/Bar.hs", "src/Baz.hs"] <*> positive <*> positive++positive :: Gen Int+positive = getPositive <$> arbitrary++failureResult :: Gen Result+failureResult = Result <$> arbitrary <*> failure++pendingResult :: Gen Result+pendingResult = Result <$> arbitrary <*> pending++successResult :: Gen Result+successResult = Result <$> arbitrary <*> pure Success++pending :: Gen ResultStatus+pending = Pending <$> arbitrary <*> arbitrary++failure :: Gen ResultStatus+failure = Failure <$> arbitrary <*> arbitrary+ spec :: Spec spec = do+  describe "mergeResults" $ do+    it "gives failures from items precedence" $ do+      forAll failureResult $ \ item -> \ hook -> do+        mergeResults Nothing item hook `shouldBe` item++    it "gives failures from hooks precedence over succeeding items" $ do+      forAll successResult $ \ item@(Result info _) -> forAll failure $ \ hook -> do+        mergeResults Nothing item hook `shouldBe` Result info hook++    it "gives failures from hooks precedence over pending items" $ do+      forAll pendingResult $ \ item@(Result info _) -> forAll failure $ \ hook -> do+        mergeResults Nothing item hook `shouldBe` Result info hook++    it "gives pending items precedence over pending hooks" $ do+      forAll pendingResult $ \ item -> forAll pending $ \ hook -> do+        mergeResults Nothing item hook `shouldBe` item+   describe "traverse" $ do     context "when used with Tree" $ do       let
test/Test/Hspec/Core/RunnerSpec.hs view
@@ -26,12 +26,15 @@ import qualified Test.Hspec.Expectations as H import qualified Test.Hspec.Core.Spec as H import qualified Test.Hspec.Core.Runner as H+import           Test.Hspec.Core.Runner.Result import qualified Test.Hspec.Core.Formatters.V2 as V2 import qualified Test.Hspec.Core.QuickCheck as H  import qualified Test.QuickCheck as QC import qualified Test.Hspec.Core.Hooks as H +import           Test.Hspec.Core.Formatters.Pretty.ParserSpec (Person(..))+ quickCheckOptions :: [([Char], Args -> Int)] quickCheckOptions = [("--qc-max-success", QC.maxSuccess), ("--qc-max-size", QC.maxSize), ("--qc-max-discard", QC.maxDiscardRatio)] @@ -41,6 +44,9 @@     H.it "foo" $ do       property (/= (23 :: Int)) +person :: Int -> Person+person = Person "Joe"+ spec :: Spec spec = do   describe "hspec" $ do@@ -392,6 +398,46 @@             H.it "example 3" $ mockAction e3         (,,) <$> mockCounter e1 <*> mockCounter e2 <*> mockCounter e3 `shouldReturn` (1, 0, 1) +#if __GLASGOW_HASKELL__ >= 802+    context "with --pretty" $ do+      it "pretty-prints Haskell values" $ do+        r <- capture_ . ignoreExitCode . withArgs ["--pretty"] . H.hspec $ do+          H.it "foo" $ do+            person 23 `H.shouldBe` person 42+        r `shouldContain` unlines [+            "       expected: Person {"+          , "                   personName = \"Joe\","+          , "                   personAge = 42"+          , "                 }"+          , "        but got: Person {"+          , "                   personName = \"Joe\","+          , "                   personAge = 23"+          , "                 }"+          ]+#endif++      it "uses custom pretty-print functions" $ do+        let pretty _ _ _ = ("foo", "bar")++        r <- capture_ . ignoreExitCode . withArgs ["--pretty"] . H.hspec $ do+          H.modifyConfig $ \ c -> c { H.configPrettyPrintFunction = pretty }+          H.it "foo" $ do+            23 `H.shouldBe` (42 :: Int)+        r `shouldContain` unlines [+            "       expected: foo"+          , "        but got: bar"+          ]++    context "with --no-pretty" $ do+      it "does not pretty-prints Haskell values" $ do+        r <- capture_ . ignoreExitCode . withArgs ["--no-pretty"] . H.hspec $ do+          H.it "foo" $ do+            person 23 `H.shouldBe` person 42+        r `shouldContain` unlines [+            "       expected: Person {personName = \"Joe\", personAge = 42}"+          , "        but got: Person {personName = \"Joe\", personAge = 23}"+          ]+     context "with --diff" $ do       it "shows colorized diffs" $ do         r <- capture_ . ignoreExitCode . withArgs ["--diff", "--color"] . H.hspec $ do@@ -629,30 +675,30 @@     let       report = FailureReport 0 0 0 0 [([], "foo")]       config = H.defaultConfig {H.configRerun = True, H.configRerunAllOnSuccess = True}-      summary = H.Summary 1 0+      result = SpecResult [] True     context "with --rerun, --rerun-all-on-success, previous failures, on success" $ do       it "returns True" $ do-        H.rerunAll config (Just report) summary `shouldBe` True+        H.rerunAll config (Just report) result `shouldBe` True      context "without --rerun" $ do       it "returns False" $ do-        H.rerunAll config {H.configRerun = False} (Just report) summary `shouldBe` False+        H.rerunAll config {H.configRerun = False} (Just report) result `shouldBe` False      context "without --rerun-all-on-success" $ do       it "returns False" $ do-        H.rerunAll config {H.configRerunAllOnSuccess = False} (Just report) summary `shouldBe` False+        H.rerunAll config {H.configRerunAllOnSuccess = False} (Just report) result `shouldBe` False      context "without previous failures" $ do       it "returns False" $ do-        H.rerunAll config (Just report {failureReportPaths = []}) summary `shouldBe` False+        H.rerunAll config (Just report {failureReportPaths = []}) result `shouldBe` False      context "without failure report" $ do       it "returns False" $ do-        H.rerunAll config Nothing summary `shouldBe` False+        H.rerunAll config Nothing result `shouldBe` False      context "on failure" $ do       it "returns False" $ do-        H.rerunAll config (Just report) summary {H.summaryFailures = 1} `shouldBe` False+        H.rerunAll config (Just report) result { specResultSuccess = False } `shouldBe` False   where     green  = setSGRCode [SetColor Foreground Dull Green]     red    = setSGRCode [SetColor Foreground Dull Red]
test/Test/Hspec/Core/SpecSpec.hs view
@@ -6,18 +6,31 @@  import           Test.Hspec.Core.Spec (Item(..), Result(..), ResultStatus(..)) import qualified Test.Hspec.Core.Runner as H-import           Test.Hspec.Core.Spec (Tree(..), runSpecM)+import           Test.Hspec.Core.Spec (Tree(..))  import qualified Test.Hspec.Core.Spec as H  extract :: (Item () -> a) -> H.Spec -> IO [Tree () a]-extract f = fmap (H.bimapForest (const ()) f) . runSpecM+extract f = fmap (H.bimapForest (const ()) f) . fmap snd . H.runSpecM  runSpec :: H.Spec -> IO [String] runSpec = captureLines . H.hspecResult  spec :: Spec spec = do+  let runSpecM = fmap snd . H.runSpecM++  describe "getSpecDescriptionPath" $ do+    it "returns the spec path" $ do+      let descriptionPathShouldBe xs =+            H.getSpecDescriptionPath >>= H.runIO . (`shouldBe` xs)+      void . runSpecM $ do+        descriptionPathShouldBe []+        H.describe "foo" $ do+          H.describe "bar" $ do+            descriptionPathShouldBe ["foo", "bar"]+            H.it "baz" True+   describe "describe" $ do     it "can be nested" $ do       [Node foo [Node bar [Leaf _]]] <- runSpecM $ do
test/Test/Hspec/Core/UtilSpec.hs view
@@ -95,7 +95,7 @@     it "creates a sentence from a subject and a requirement" $ do       formatRequirement (["reverse"], "reverses a list") `shouldBe` "reverse reverses a list" -    it "creates a sentence from a subject and a requirement when the subject consits of multiple words" $ do+    it "creates a sentence from a subject and a requirement when the subject consists of multiple words" $ do       formatRequirement (["The reverse function"], "reverses a list") `shouldBe` "The reverse function reverses a list"      it "returns the requirement if no subject is given" $ do
version.yaml view
@@ -1,1 +1,1 @@-&version 2.9.7+&version 2.10.0