packages feed

hspec-meta 2.9.3 → 2.10.5

raw patch · 29 files changed

+922/−324 lines, 29 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

- Test.Hspec.Meta: type family Arg e
+ Test.Hspec.Meta: type Arg e
- Test.Hspec.Meta: aroundAll :: (ActionWith a -> IO ()) -> SpecWith a -> Spec
+ Test.Hspec.Meta: aroundAll :: HasCallStack => (ActionWith a -> IO ()) -> SpecWith a -> Spec
- Test.Hspec.Meta: aroundAllWith :: forall a b. (ActionWith a -> ActionWith b) -> SpecWith a -> SpecWith b
+ Test.Hspec.Meta: aroundAllWith :: forall a b. HasCallStack => (ActionWith a -> ActionWith b) -> SpecWith a -> SpecWith b
- Test.Hspec.Meta: aroundAll_ :: (IO () -> IO ()) -> SpecWith a -> SpecWith a
+ Test.Hspec.Meta: aroundAll_ :: HasCallStack => (IO () -> IO ()) -> SpecWith a -> SpecWith a
- Test.Hspec.Meta: beforeAll :: IO a -> SpecWith a -> Spec
+ Test.Hspec.Meta: beforeAll :: HasCallStack => IO a -> SpecWith a -> Spec
- Test.Hspec.Meta: beforeAllWith :: (b -> IO a) -> SpecWith a -> SpecWith b
+ Test.Hspec.Meta: beforeAllWith :: HasCallStack => (b -> IO a) -> SpecWith a -> SpecWith b
- Test.Hspec.Meta: beforeAll_ :: IO () -> SpecWith a -> SpecWith a
+ Test.Hspec.Meta: beforeAll_ :: HasCallStack => IO () -> SpecWith a -> SpecWith a

Files

LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2011-2021 Simon Hengel <sol@typeful.net>+Copyright (c) 2011-2022 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/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"
hspec-core/src/Test/Hspec/Core/Clock.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-} module Test.Hspec.Core.Clock (   Seconds(..) , toMilliseconds@@ -13,10 +14,15 @@ import           Test.Hspec.Core.Compat  import           Text.Printf-import           System.Clock import           Control.Concurrent import qualified System.Timeout as System +#if MIN_VERSION_base(4,11,0)+import qualified GHC.Clock as GHC+#else+import           Data.Time.Clock.POSIX+#endif+ newtype Seconds = Seconds Double   deriving (Eq, Show, Ord, Num, Fractional, PrintfArg) @@ -27,9 +33,13 @@ toMicroseconds (Seconds s) = floor (s * 1000000)  getMonotonicTime :: IO Seconds+#if MIN_VERSION_base(4,11,0)+getMonotonicTime = Seconds <$> GHC.getMonotonicTime+#else getMonotonicTime = do-  t <- getTime Monotonic-  return $ Seconds ((fromIntegral . toNanoSecs $ t) / 1000000000)+  t <- getPOSIXTime+  return $ Seconds (realToFrac t)+#endif  measure :: IO a -> IO (Seconds, a) measure action = do
hspec-core/src/Test/Hspec/Core/Compat.hs view
@@ -4,6 +4,7 @@ , module Test.Hspec.Core.Compat ) where +import           Control.Arrow as Imports ((>>>), (&&&), first, second) import           Control.Applicative as Imports import           Control.Monad as Imports hiding (     mapM@@ -68,6 +69,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 +89,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
hspec-core/src/Test/Hspec/Core/Config/Definition.hs view
@@ -13,7 +13,7 @@ , runnerOptions  #ifdef TEST-, formatOrList+, splitOn #endif ) where @@ -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@@ -39,7 +40,9 @@   configIgnoreConfigFile :: Bool , configDryRun :: Bool , configFocusedOnly :: Bool+, configFailOnEmpty :: Bool , configFailOnFocused :: Bool+, configFailOnPending :: Bool , configPrintSlowItems :: Maybe Int , configPrintCpuTime :: Bool , configFailFast :: Bool@@ -58,11 +61,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)@@ -76,7 +80,9 @@   configIgnoreConfigFile = False , configDryRun = False , configFocusedOnly = False+, configFailOnEmpty = False , configFailOnFocused = False+, configFailOnPending = False , configPrintSlowItems = Nothing , configPrintCpuTime = False , configFailFast = False@@ -96,6 +102,7 @@ , configUnicodeMode = UnicodeAuto , configDiff = True , configPrettyPrint = True+, configPrettyPrintFunction = pretty2 , configTimes = False , configAvailableFormatters = map (fmap V2.formatterToFormat) [     ("checks", V2.checks)@@ -195,7 +202,7 @@   ]  setDepth :: Int -> Config -> Config-setDepth n c = c {configSmallCheckDepth = n}+setDepth n c = c {configSmallCheckDepth = Just n}  quickCheckOptions :: [Option Config] quickCheckOptions = [@@ -224,11 +231,46 @@ setSeed :: Integer -> Config -> Config setSeed n c = c {configQuickCheckSeed = Just n} +data FailOn =+    FailOnEmpty+  | FailOnFocused+  | FailOnPending+  deriving (Bounded, Enum)++allFailOnItems :: [FailOn]+allFailOnItems = [minBound .. maxBound]++showFailOn :: FailOn -> String+showFailOn item = case item of+  FailOnEmpty -> "empty"+  FailOnFocused -> "focused"+  FailOnPending -> "pending"++readFailOn :: String -> Maybe FailOn+readFailOn = (`lookup` items)+  where+    items = map (showFailOn &&& id) allFailOnItems++splitOn :: Char -> String -> [String]+splitOn sep = go+  where+    go xs =  case break (== sep) xs of+      ("", "") -> []+      (y, "") -> [y]+      (y, _ : ys) -> y : go ys+ 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"-  , mkFlag "fail-on-focused" setFailOnFocused "fail on 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"++  , 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+   , mkFlag "fail-fast" setFailFast "abort on first failure"   , mkFlag "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)"@@ -237,6 +279,31 @@   , mkOption "jobs" (Just 'j') (argument "N" readMaxJobs setMaxJobs) "run at most N parallelizable tests simultaneously (default: number of available processors)"   ]   where+    strict = allFailOnItems++    readFailOnItems :: String -> Maybe [FailOn]+    readFailOnItems = mapM readFailOn . splitOn ','++    showFailOnItems :: [FailOn] -> String+    showFailOnItems = intercalate "," . map showFailOn++    helpForFailOn :: String+    helpForFailOn = unlines . flip map allFailOnItems $ \ item ->+      showFailOn item <> ": " <> help item+      where+        help item = case item of+          FailOnEmpty -> "fail if no spec items have been run"+          FailOnFocused -> "fail on focused spec items"+          FailOnPending -> "fail on pending spec items"++    setFailOnItems :: Bool -> [FailOn] -> Config -> Config+    setFailOnItems value = flip $ foldr (`setItem` value)+      where+        setItem item = case item of+          FailOnEmpty -> setFailOnEmpty+          FailOnFocused -> setFailOnFocused+          FailOnPending -> setFailOnPending+     readMaxJobs :: String -> Maybe Int     readMaxJobs s = do       n <- readMaybe s@@ -255,8 +322,17 @@     setFocusedOnly :: Bool -> Config -> Config     setFocusedOnly value config = config {configFocusedOnly = value} +    setFailOnEmpty :: Bool -> Config -> Config+    setFailOnEmpty value config = config {configFailOnEmpty = value}+     setFailOnFocused :: Bool -> Config -> Config     setFailOnFocused value config = config {configFailOnFocused = value}++    setFailOnPending :: Bool -> Config -> Config+    setFailOnPending value config = config {configFailOnPending = value}++    setStrict :: Bool -> Config -> Config+    setStrict = (`setFailOnItems` strict)      setFailFast :: Bool -> Config -> Config     setFailFast value config = config {configFailFast = value}
hspec-core/src/Test/Hspec/Core/Example.hs view
@@ -5,8 +5,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} --- NOTE: re-exported from Test.Hspec.Core.Spec module Test.Hspec.Core.Example (+-- RE-EXPORTED from Test.Hspec.Core.Spec   Example (..) , Params (..) , defaultParams@@ -19,6 +19,8 @@ , FailureReason (..) , safeEvaluate , safeEvaluateExample+-- END RE-EXPORTED from Test.Hspec.Core.Spec+, safeEvaluateResultStatus ) where  import           Prelude ()@@ -49,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)@@ -106,12 +108,19 @@  safeEvaluate :: IO Result -> IO Result safeEvaluate action = do-  r <- safeTry $ action+  r <- safeTry action   return $ case r of-    Left e | Just result <- fromException e -> Result "" result-    Left e | Just hunit <- fromException e -> Result "" $ hunitFailureToResult Nothing hunit-    Left e -> Result "" $ Failure Nothing $ Error Nothing e+    Left e -> Result "" (toResultStatus e)     Right result -> result++safeEvaluateResultStatus :: IO ResultStatus -> IO ResultStatus+safeEvaluateResultStatus action = either toResultStatus id <$> safeTry action++toResultStatus :: SomeException -> ResultStatus+toResultStatus e+  | Just result <- fromException e = result+  | Just hunit <- fromException e = hunitFailureToResult Nothing hunit+  | otherwise = Failure Nothing $ Error Nothing e  instance Example Result where   type Arg Result = ()
hspec-core/src/Test/Hspec/Core/Example/Location.hs view
@@ -3,11 +3,14 @@   Location(..) , extractLocation --- for testing+#ifdef TEST , parseAssertionFailed , parseCallStack , parseLocation , parseSourceSpan++, workaroundForIssue19236+#endif ) where  import           Prelude ()@@ -18,6 +21,10 @@ import           Data.Maybe import           GHC.IO.Exception +#ifdef mingw32_HOST_OS+import           System.FilePath+#endif+ -- | @Location@ is used to represent source locations. data Location = Location {   locationFile :: FilePath@@ -96,11 +103,11 @@  parseLocation :: String -> Maybe Location parseLocation input = case fmap breakColon (breakColon input) of-  (file, (line, column)) -> Location file <$> readMaybe line <*> readMaybe column+  (file, (line, column)) -> mkLocation file <$> readMaybe line <*> readMaybe column  parseSourceSpan :: String -> Maybe Location parseSourceSpan input = case breakColon input of-  (file, xs) -> (uncurry $ Location file) <$> (tuple <|> colonSeparated)+  (file, xs) -> (uncurry $ mkLocation file) <$> (tuple <|> colonSeparated)     where       lineAndColumn :: String       lineAndColumn = takeWhile (/= '-') xs@@ -114,3 +121,14 @@  breakColon :: String -> (String, String) breakColon = fmap (drop 1) . break (== ':')++mkLocation :: FilePath -> Int -> Int -> Location+mkLocation file line column = Location (workaroundForIssue19236 file) line column++workaroundForIssue19236 :: FilePath -> FilePath -- https://gitlab.haskell.org/ghc/ghc/-/issues/19236+workaroundForIssue19236 =+#ifdef mingw32_HOST_OS+  joinPath . splitDirectories+#else+  id+#endif
hspec-core/src/Test/Hspec/Core/Format.hs view
@@ -56,15 +56,17 @@  data FormatConfig = FormatConfig {   formatConfigUseColor :: Bool+, 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
hspec-core/src/Test/Hspec/Core/Formatters.hs view
@@ -1,2 +1,6 @@-module Test.Hspec.Core.Formatters (module V1) where+-- |+-- Deprecated\: Use "Test.Hspec.Core.Formatters.V1" instead.+module Test.Hspec.Core.Formatters+-- {-# DEPRECATED "Use \"Test.Hspec.Core.Formatters.V1\" instead." #-}+(module V1) where import           Test.Hspec.Core.Formatters.V1 as V1
hspec-core/src/Test/Hspec/Core/Formatters/Internal.hs view
@@ -36,11 +36,13 @@  , useDiff , prettyPrint+, prettyPrintFunction , extraChunk , missingChunk  #ifdef TEST-, overwriteWith+, runFormatM+, splitLines #endif ) where @@ -49,11 +51,12 @@  import qualified System.IO as IO import           System.IO (Handle, stdout)-import           Control.Exception (bracket_)+import           Control.Exception (bracket_, bracket) import           System.Console.ANSI import           Control.Monad.Trans.State hiding (state, gets, modify) import           Control.Monad.IO.Class import           Data.Char (isSpace)+import           Data.List (groupBy) import qualified System.CPUTime as CPUTime  import           Test.Hspec.Core.Formatters.V1.Monad (FailureRecord(..))@@ -91,13 +94,14 @@   Progress path progress -> formatterProgress path progress   ItemStarted path -> formatterItemStarted path   ItemDone path item -> do-    clearTransientOutput     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@@ -109,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@@ -144,8 +156,8 @@ , stateFailMessages    :: [FailureRecord] , stateCpuStartTime    :: Maybe Integer , stateStartTime       :: Seconds-, stateTransientOutput :: String-, stateConfig :: FormatConfig+, stateConfig          :: FormatConfig+, stateColor           :: Maybe SGR }  getConfig :: (FormatConfig -> a) -> FormatM a@@ -164,12 +176,27 @@   deriving (Functor, Applicative, Monad, MonadIO)  runFormatM :: FormatConfig -> FormatM a -> IO a-runFormatM config (FormatM action) = do+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)-  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+ -- | Increase the counter for successful examples increaseSuccessCount :: FormatM () increaseSuccessCount = modify $ \s -> s {stateSuccessCount = succ $ stateSuccessCount s}@@ -186,10 +213,6 @@ 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] getFailMessages = reverse `fmap` gets stateFailMessages@@ -199,35 +222,35 @@ getExpectedTotalCount :: FormatM Int getExpectedTotalCount = getConfig formatConfigExpectedTotalCount -overwriteWith :: String -> String -> String-overwriteWith old new-  | n == 0 = new-  | otherwise = '\r' : new ++ replicate (n - length new) ' '-  where-    n = length old- writeTransient :: String -> FormatM () writeTransient new = do-  useColor <- getConfig formatConfigUseColor-  when (useColor) $ do-    old <- gets stateTransientOutput-    write $ old `overwriteWith` new-    modify $ \ state -> state {stateTransientOutput = new}+  reportProgress <- getConfig formatConfigReportProgress+  when (reportProgress) $ do     h <- getHandle+    write $ new     liftIO $ IO.hFlush h--clearTransientOutput :: FormatM ()-clearTransientOutput = do-  n <- length <$> gets stateTransientOutput-  unless (n == 0) $ do-    write ("\r" ++ replicate n ' ' ++ "\r")-    modify $ \ state -> state {stateTransientOutput = ""}+    write $ "\r" ++ replicate (length new) ' ' ++ "\r"  -- | Append some output to the report. write :: String -> FormatM ()-write s = do+write = mapM_ writeChunk . splitLines++splitLines :: String -> [String]+splitLines = groupBy (\ a b -> isNewline a == isNewline b)+  where+    isNewline = (== '\n')++writeChunk :: String -> FormatM ()+writeChunk str = do   h <- getHandle-  liftIO $ IO.hPutStr h s+  let+    plainOutput = IO.hPutStr h str+    colorOutput color = bracket_ (hSetSGR h [color]) (hSetSGR h [Reset]) plainOutput+  mColor <- gets stateColor+  liftIO $ case mColor of+    Just (SetColor Foreground _ _) | all isSpace str -> plainOutput+    Just color -> colorOutput color+    Nothing -> plainOutput  -- | Set output color to red, run given action, and finally restore the default -- color.@@ -259,21 +282,15 @@ htmlSpan cls action = write ("<span class=\"" ++ cls ++ "\">") *> action <* write "</span>"  withColor_ :: SGR -> FormatM a -> FormatM a-withColor_ color (FormatM action) = do-  useColor <- getConfig formatConfigUseColor-  h <- getHandle--  FormatM . StateT $ \st -> do-    bracket_--      -- set color-      (when useColor $ hSetSGR h [color])--      -- reset colors-      (when useColor $ hSetSGR h [Reset])+withColor_ color action = do+  oldColor <- gets stateColor+  setColor (Just color) *> action <* setColor oldColor -      -- run action-      (runStateT action st)+setColor :: Maybe SGR -> FormatM ()+setColor color = do+  useColor <- getConfig formatConfigUseColor+  when useColor $ do+    modify (\ state -> state { stateColor = color })  -- | Output given chunk in red. extraChunk :: String -> FormatM ()
hspec-core/src/Test/Hspec/Core/Formatters/Pretty.hs view
@@ -11,7 +11,6 @@ import           Prelude () import           Test.Hspec.Core.Compat hiding (shows, intercalate) -import           Control.Arrow import           Data.Char import           Data.String import           Data.List (intersperse)@@ -99,7 +98,7 @@       Char c -> shows c       String str -> if unicode then Builder $ ushows str else shows str       Integer n -> shows n-      Rational n -> shows n+      Rational n -> fromString n      render :: Expression -> Builder     render expr = case expr of
hspec-core/src/Test/Hspec/Core/Formatters/Pretty/Parser.hs view
@@ -16,8 +16,14 @@ import           Test.Hspec.Core.Compat hiding (fail) import           Test.Hspec.Core.Formatters.Pretty.Parser.Types -#if __GLASGOW_HASKELL__ < 802 || __GLASGOW_HASKELL__ > 902+#ifndef __GHCJS__+#if __GLASGOW_HASKELL__ >= 802 && __GLASGOW_HASKELL__ <= 904+#define PRETTY_PRINTING_SUPPORTED+#endif+#endif +#ifndef PRETTY_PRINTING_SUPPORTED+ parseExpression :: String -> Maybe Expression parseExpression _ = Nothing @@ -29,7 +35,12 @@ import           GHC.Stack import           GHC.Exception (throw, errorCallWithCallStackException) -#if __GLASGOW_HASKELL__ >= 804+#if __GLASGOW_HASKELL__ >= 904+import           GHC.Utils.Error+import           GHC.Utils.Outputable+#endif++#if __GLASGOW_HASKELL__ >= 804 && __GLASGOW_HASKELL__ < 904 import           GHC.LanguageExtensions.Type #endif @@ -46,7 +57,6 @@ import           GHC.Data.StringBuffer import           GHC.Data.FastString import           GHC.Types.SrcLoc-import qualified GHC.Data.EnumSet as EnumSet import           GHC.Types.Name import           GHC.Types.Name.Reader import           GHC.Parser.PostProcess hiding (Tuple)@@ -60,7 +70,12 @@ import           RdrName import           BasicTypes import           Module-#if __GLASGOW_HASKELL__ >= 804+#endif++#if __GLASGOW_HASKELL__ >= 804 && __GLASGOW_HASKELL__ < 904+#if __GLASGOW_HASKELL__ >= 900+import qualified GHC.Data.EnumSet as EnumSet+#else import qualified EnumSet #endif #endif@@ -140,21 +155,30 @@     HsOverLit _x lit -> toExpression lit     HsApp _x f x -> App <$> toExpression f <*> toExpression x     NegApp _x e _ -> toExpression e >>= \ x -> case x of-      Literal (Rational n) -> return $ Literal (Rational $ negate n)+      Literal (Rational n) -> return $ Literal (Rational $ '-' : n)       Literal (Integer n) -> return $ Literal (Integer $ negate n)       _ -> fail "NegApp"-    HsPar _x e -> Parentheses <$> toExpression e++    HsPar _x+#if __GLASGOW_HASKELL__ >= 904+      _ e _ ->+#else+      e ->+#endif+        Parentheses <$> toExpression e     ExplicitTuple _x xs _ -> Tuple <$> mapM toExpression xs     ExplicitList _ _listSynExpr xs -> List <$> mapM toExpression xs     RecCon(name, fields) -> Record (showRdrName name) <$> (recordFields $ rec_flds fields)       where+#if __GLASGOW_HASKELL__ >= 904+        hsRecFieldLbl = hfbLHS+        hsRecFieldArg = hfbRHS+#endif         fieldName = showFieldLabel . unLoc . hsRecFieldLbl         recordFields = mapM (recordField . unLoc)         recordField field = (,) (fieldName field) <$> toExpression (hsRecFieldArg field)      REJECT(HsUnboundVar)-    REJECT(HsConLikeOut)-    REJECT(HsRecFld)     REJECT(HsOverLabel)     REJECT(HsIPVar)     REJECT(HsLam)@@ -172,14 +196,15 @@     REJECT(RecordUpd)     REJECT(ExprWithTySig)     REJECT(ArithSeq)-    REJECT(HsBracket)-    REJECT(HsRnBracketOut)-    REJECT(HsTcBracketOut)     REJECT(HsSpliceE)     REJECT(HsProc)     REJECT(HsStatic)-    REJECT(HsTick)-    REJECT(HsBinTick)++#if __GLASGOW_HASKELL__ >= 904+    REJECT(HsRecSel)+    REJECT(HsTypedBracket)+    REJECT(HsUntypedBracket)+#endif #if __GLASGOW_HASKELL__ >= 902     REJECT(HsGetField)     REJECT(HsProjection)@@ -187,13 +212,23 @@ #if __GLASGOW_HASKELL__ >= 900     REJECT(HsPragE) #endif-#if __GLASGOW_HASKELL__ <= 810++#if __GLASGOW_HASKELL__ < 904+    REJECT(HsConLikeOut)+    REJECT(HsRecFld)+    REJECT(HsBracket)+    REJECT(HsRnBracketOut)+    REJECT(HsTcBracketOut)+    REJECT(HsTick)+    REJECT(HsBinTick)+#endif+#if __GLASGOW_HASKELL__ < 900     REJECT(HsSCC)     REJECT(HsCoreAnn)     REJECT(HsTickPragma)     REJECT(HsWrap) #endif-#if __GLASGOW_HASKELL__ <= 808+#if __GLASGOW_HASKELL__ < 810     REJECT(HsArrApp)     REJECT(HsArrForm)     REJECT(EWildPat)@@ -201,7 +236,7 @@     REJECT(EViewPat)     REJECT(ELazyPat) #endif-#if __GLASGOW_HASKELL__ <= 804+#if __GLASGOW_HASKELL__ < 806     REJECT(HsAppTypeOut)     REJECT(ExplicitPArr)     REJECT(ExprWithTySigOut)@@ -238,12 +273,14 @@     HsIsString _ str -> toExpression str  instance ToExpression FractionalLit where-  toExpression fl = toExpression (fl_value fl)--#if __GLASGOW_HASKELL__ >= 902-fl_value :: FractionalLit -> Rational-fl_value = rationalFromFractionalLit+  toExpression fl = case fl_text fl of+#if __GLASGOW_HASKELL__ > 802+    REJECT(NoSourceText)+    SourceText n+#else+    n #endif+      -> return . Literal $ Rational n  instance ToExpression FastString where   toExpression = return . Literal . String . unpackFS@@ -251,9 +288,6 @@ instance ToExpression Integer where   toExpression = return . Literal . Integer -instance ToExpression Rational where-  toExpression = return . Literal . Rational- instance ToExpression Char where   toExpression = return . Literal . Char @@ -317,14 +351,24 @@     location = mkRealSrcLoc "" 1 1     input = stringToStringBuffer str     parseState = initParserState opts input location-    opts = mkParserOpts warn extensions False False False True+    opts = mkParserOpts warn+#if __GLASGOW_HASKELL__ >= 904+      (DiagOpts mempty mempty False False Nothing defaultSDocContext)+#endif+      extensions False False False True -#if __GLASGOW_HASKELL__ >= 804-    extensions = EnumSet.fromList [TraditionalRecordSyntax]+#if __GLASGOW_HASKELL__ >= 804 && __GLASGOW_HASKELL__ < 904     warn = EnumSet.empty #else-    extensions = mempty     warn = mempty+#endif++#if __GLASGOW_HASKELL__ >= 904+    extensions = ["TraditionalRecordSyntax"]+#elif __GLASGOW_HASKELL__ >= 804+    extensions = EnumSet.fromList [TraditionalRecordSyntax]+#else+    extensions = mempty #endif  #if __GLASGOW_HASKELL__ <= 900
hspec-core/src/Test/Hspec/Core/Formatters/Pretty/Parser/Types.hs view
@@ -17,5 +17,5 @@     Char Char   | String String   | Integer Integer-  | Rational Rational+  | Rational String   deriving (Eq, Show)
hspec-core/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 ""
hspec-core/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@@ -49,19 +53,19 @@ beforeWith action = aroundWith $ \e x -> action x >>= e  -- | Run a custom action before the first spec item.-beforeAll :: IO a -> SpecWith a -> Spec+beforeAll :: HasCallStack => IO a -> SpecWith a -> Spec beforeAll action spec = do   mvar <- runIO (newMVar Empty)   before (memoize mvar action) spec  -- | Run a custom action before the first spec item.-beforeAll_ :: IO () -> SpecWith a -> SpecWith a+beforeAll_ :: HasCallStack => IO () -> SpecWith a -> SpecWith a beforeAll_ action spec = do   mvar <- runIO (newMVar Empty)   before_ (memoize mvar action) spec  -- | Run a custom action with an argument before the first spec item.-beforeAllWith :: (b -> IO a) -> SpecWith a -> SpecWith b+beforeAllWith :: HasCallStack => (b -> IO a) -> SpecWith a -> SpecWith b beforeAllWith action spec = do   mvar <- runIO (newMVar Empty)   beforeWith (memoize mvar . action) spec@@ -71,14 +75,14 @@   | Memoized a   | Failed SomeException -memoize :: MVar (Memoized a) -> IO a -> IO a+memoize :: HasCallStack => MVar (Memoized a) -> IO a -> IO a memoize mvar action = do   result <- modifyMVar mvar $ \ma -> case ma of     Empty -> do       a <- try action       return (either Failed Memoized a, a)     Memoized a -> return (ma, Right a)-    Failed _ -> throwIO (Pending Nothing (Just "exception in beforeAll-hook (see previous failure)"))+    Failed _ -> throwIO (Pending Nothing (Just $ "exception in " <> maybe "beforeAll" fst callSite <> "-hook (see previous failure)"))   either throwIO return result  -- | Run a custom action after every spec item.@@ -95,11 +99,11 @@  -- | Run a custom action after the last spec item. afterAll :: HasCallStack => ActionWith a -> SpecWith a -> SpecWith a-afterAll action spec = runIO (runSpecM spec) >>= fromSpecList . 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,60 +111,77 @@  -- | 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} =   item{ itemExample = \params aroundAction -> e params (aroundAction . action) }  -- | Wrap an action around the given spec.-aroundAll :: (ActionWith a -> IO ()) -> SpecWith a -> Spec+aroundAll :: HasCallStack => (ActionWith a -> IO ()) -> SpecWith a -> Spec aroundAll action = aroundAllWith $ \ e () -> action e  -- | Wrap an action around the given spec.-aroundAll_ :: (IO () -> IO ()) -> SpecWith a -> SpecWith a+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. (ActionWith a -> ActionWith b) -> SpecWith a -> SpecWith b+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+      acquireHasNotBeenCalled <- isEmptyMVar acquired -- NOTE: This can happen if an outer beforeAll fails+      unless acquireHasNotBeenCalled $ 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 ()
hspec-core/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 (..)@@ -14,20 +40,40 @@ , UnicodeMode(..) , Path , defaultConfig+, registerFormatter+, registerDefaultFormatter , 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 +86,7 @@ import           Test.Hspec.Core.Compat  import           Data.Maybe+import           NonEmpty (nonEmpty) import           System.IO import           System.Environment (getArgs, withArgs) import           System.Exit@@ -47,15 +94,14 @@ import           System.Random import           Control.Monad.ST import           Data.STRef-import           System.Console.ANSI (hSupportsANSI) -import           System.Console.ANSI (hHideCursor, hShowCursor)+import           System.Console.ANSI (hSupportsANSI, hHideCursor, hShowCursor) import qualified Test.QuickCheck as QC  import           Test.Hspec.Core.Util (Path)-import           Test.Hspec.Core.Spec+import           Test.Hspec.Core.Spec hiding (pruneTree, pruneForest) import           Test.Hspec.Core.Config-import           Test.Hspec.Core.Format (FormatConfig(..))+import           Test.Hspec.Core.Format (Format, FormatConfig(..)) import qualified Test.Hspec.Core.Formatters.V1 as V1 import qualified Test.Hspec.Core.Formatters.V2 as V2 import           Test.Hspec.Core.FailureReport@@ -63,9 +109,21 @@ import           Test.Hspec.Core.Shuffle  import           Test.Hspec.Core.Runner.PrintSlowSpecItems-import           Test.Hspec.Core.Runner.Eval+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 -> [EvalTree] -> [EvalTree]+-- |+-- Make a formatter available for use with @--format@.+registerFormatter :: (String, FormatConfig -> IO Format) -> Config -> Config+registerFormatter formatter config = config { configAvailableFormatters = formatter : configAvailableFormatters config }++-- |+-- Make a formatter available for use with @--format@ and use it by default.+registerDefaultFormatter :: (String, FormatConfig -> IO Format) -> Config -> Config+registerDefaultFormatter formatter@(_, format) config = (registerFormatter formatter config) { configFormat = Just format }++applyFilterPredicates :: Config -> [Tree c EvalItem] -> [Tree c EvalItem] applyFilterPredicates c = filterForestWithLabels p   where     include :: Path -> Bool@@ -79,7 +137,7 @@       where         path = (groups, evalItemDescription item) -applyDryRun :: Config -> [EvalTree] -> [EvalTree]+applyDryRun :: Config -> [EvalItemTree] -> [EvalItemTree] applyDryRun c   | configDryRun c = bimapForest removeCleanup markSuccess   | otherwise = id@@ -94,15 +152,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@@ -115,7 +187,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.@@ -127,13 +199,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. --@@ -141,21 +216,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 c_ = do+--+-- @since 2.10.0+runSpecForest :: [SpecTree ()] -> Config -> IO SpecResult+runSpecForest spec c_ = do   oldFailureReport <- readFailureReportOnRerun c_    c <- ensureSeed (applyFailureReport oldFailureReport c_)@@ -172,17 +258,28 @@     then rerunAllMode c oldFailureReport     else normalMode c   where-    normalMode c = runSpec_ c spec+    normalMode c = runSpecForest_ c spec     rerunAllMode c oldFailureReport = do-      summary <- runSpec_ c spec-      if rerunAll c oldFailureReport summary-        then runSpec spec c_-        else return summary+      result <- runSpecForest_ c spec+      if rerunAll c oldFailureReport result+        then runSpecForest spec c_+        else return result +runSpecForest_ :: Config -> [SpecTree ()] -> IO SpecResult+runSpecForest_ config spec = runEvalTree config (specToEvalForest config spec)++mapItem :: (Item a -> Item b) -> [SpecTree a] -> [SpecTree b]+mapItem f = map (fmap f)++failFocusedItems :: Config -> [SpecTree a] -> [SpecTree a]+failFocusedItems config+  | configFailOnFocused config = mapItem failFocused+  | otherwise = id+ failFocused :: Item a -> Item a failFocused item = item {itemExample = example}   where-    failure = Failure Nothing (Reason "item is focused; failing due to --fail-on-focused")+    failure = Failure Nothing (Reason "item is focused; failing due to --fail-on=focused")     example       | itemIsFocused item = \ params hook p -> do           Result info status <- itemExample item params hook p@@ -192,38 +289,49 @@             Failure{} -> status       | otherwise = itemExample item -failFocusedItems :: Config -> Spec -> Spec-failFocusedItems config spec-  | configFailOnFocused config = mapSpecItem_ failFocused spec-  | otherwise = spec+failPendingItems :: Config -> [SpecTree a] -> [SpecTree a]+failPendingItems config+  | configFailOnPending config = mapItem failPending+  | otherwise = id -focusSpec :: Config -> Spec -> Spec+failPending :: Item a -> Item a+failPending item = item {itemExample = example}+  where+    example params hook p = do+      Result info status <- itemExample item params hook p+      return $ Result info $ case status of+        Pending loc _ -> Failure loc (Reason "item is pending; failing due to --fail-on=pending")+        _ -> status++focusSpec :: Config -> [SpecTree a] -> [SpecTree a] focusSpec config spec   | configFocusedOnly config = spec-  | otherwise = focus spec+  | otherwise = focusForest spec -runSpec_ :: Config -> Spec -> IO Summary-runSpec_ config spec = do-  filteredSpec <- specToEvalForest config spec+runEvalTree :: Config -> [EvalTree] -> IO SpecResult+runEvalTree config spec = do   let+      failOnEmpty = configFailOnEmpty config       seed = (fromJust . configQuickCheckSeed) config       qcArgs = configQuickCheckArgs config-      !numberOfItems = countSpecItems filteredSpec+      !numberOfItems = countSpecItems spec    concurrentJobs <- case configConcurrentJobs config of     Nothing -> getDefaultConcurrentJobs     Just n -> return n -  useColor <- colorOutputSupported (configColorMode config) (hSupportsANSI stdout)+  (reportProgress, useColor) <- colorOutputSupported (configColorMode config) (hSupportsANSI stdout)   outputUnicode <- unicodeOutputSupported (configUnicodeMode config) stdout -  results <- withHiddenCursor useColor stdout $ do+  results <- fmap (toSpecResult failOnEmpty) . withHiddenCursor reportProgress stdout $ do     let       formatConfig = FormatConfig {         formatConfigUseColor = useColor+      , formatConfigReportProgress = reportProgress       , 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@@ -241,31 +349,57 @@       , evalConfigConcurrentJobs = concurrentJobs       , evalConfigFailFast = configFailFast config       }-    runFormatter evalConfig filteredSpec+    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 -specToEvalForest :: Config -> Spec -> IO [EvalTree]-specToEvalForest config spec = do-  let+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+  >>> failPendingItems config+  >>> focusSpec config+  >>> toEvalItemForest params+  >>> applyDryRun config+  >>> applyFilterPredicates config+  >>> randomize+  >>> pruneForest+  where     seed = (fromJust . configQuickCheckSeed) config-    focusedSpec = focusSpec config (failFocusedItems config spec)     params = Params (configQuickCheckArgs config) (configSmallCheckDepth config)     randomize       | configRandomize config = randomizeForest seed       | otherwise = id-  randomize . pruneForest . applyFilterPredicates config . applyDryRun config . toEvalForest params <$> runSpecM focusedSpec -toEvalForest :: Params -> [SpecTree ()] -> [EvalTree]-toEvalForest params = bimapForest withUnit toEvalItem . filterForest itemIsFocused+pruneForest :: [Tree c a] -> [Eval.Tree c a]+pruneForest = mapMaybe pruneTree++pruneTree :: Tree c a -> Maybe (Eval.Tree c a)+pruneTree node = case node of+  Node group xs -> Eval.Node group <$> prune xs+  NodeWithCleanup loc action xs -> Eval.NodeWithCleanup loc action <$> prune xs+  Leaf item -> Just (Eval.Leaf item)   where+    prune = nonEmpty . pruneForest++type EvalItemTree = Tree (IO ()) EvalItem++toEvalItemForest :: Params -> [SpecTree ()] -> [EvalItemTree]+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) @@ -290,33 +424,45 @@   | useColor  = E.bracket_ (hHideCursor h) (hShowCursor h)   | otherwise = id -colorOutputSupported :: ColorMode -> IO Bool -> IO Bool-colorOutputSupported mode isTerminalDevice = case mode of-  ColorAuto  -> (&&) <$> (not <$> noColor) <*> isTerminalDevice-  ColorNever -> return False-  ColorAlways -> return True+colorOutputSupported :: ColorMode -> IO Bool -> IO (Bool, Bool)+colorOutputSupported mode isTerminalDevice = do+  github <- githubActions+  buildkite <- lookupEnv "BUILDKITE" <&> (== Just "true")+  useColor <- case mode of+    ColorAuto  -> (github ||) <$> colorTerminal+    ColorNever -> return False+    ColorAlways -> return True+  let reportProgress = not github && not buildkite && useColor+  return (reportProgress, useColor)+  where+    githubActions :: IO Bool+    githubActions = lookupEnv "GITHUB_ACTIONS" <&> (== Just "true") +    colorTerminal :: IO Bool+    colorTerminal = (&&) <$> (not <$> noColor) <*> isTerminalDevice++    noColor :: IO Bool+    noColor = lookupEnv "NO_COLOR" <&> (/= Nothing)+ unicodeOutputSupported :: UnicodeMode -> Handle -> IO Bool unicodeOutputSupported mode h = case mode of   UnicodeAuto -> (== Just "UTF-8") . fmap show <$> hGetEncoding h   UnicodeNever -> return False   UnicodeAlways -> return True -noColor :: IO Bool-noColor = lookupEnv "NO_COLOR" <&> (/= Nothing)--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@@ -337,5 +483,5 @@   ref <- newSTRef (mkStdGen $ fromIntegral seed)   shuffleForest ref t -countSpecItems :: [EvalTree] -> Int+countSpecItems :: [Eval.Tree c a] -> Int countSpecItems = getSum . foldMap (foldMap . const $ Sum 1)
hspec-core/src/Test/Hspec/Core/Runner/Eval.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ConstraintKinds #-}@@ -13,10 +15,11 @@ module Test.Hspec.Core.Runner.Eval (   EvalConfig(..) , EvalTree+, Tree(..) , EvalItem(..) , runFormatter-, resultItemIsFailure #ifdef TEST+, mergeResults , runSequentially #endif ) where@@ -36,14 +39,23 @@ import           Control.Monad.Trans.Class  import           Test.Hspec.Core.Util-import           Test.Hspec.Core.Spec (Tree(..), Progress, FailureReason(..), Result(..), ResultStatus(..), ProgressCallback)+import           Test.Hspec.Core.Spec (Progress, FailureReason(..), Result(..), ResultStatus(..), ProgressCallback) import           Test.Hspec.Core.Timer import           Test.Hspec.Core.Format (Format) import qualified Test.Hspec.Core.Format as Format import           Test.Hspec.Core.Clock import           Test.Hspec.Core.Example.Location-import           Test.Hspec.Core.Example (safeEvaluate)+import           Test.Hspec.Core.Example (safeEvaluateResultStatus) +import qualified NonEmpty+import           NonEmpty (NonEmpty(..))++data Tree c a =+    Node String (NonEmpty (Tree c a))+  | NodeWithCleanup (Maybe (String, Location)) c (NonEmpty (Tree c a))+  | Leaf a+  deriving (Eq, Show, Functor, Foldable, Traversable)+ -- for compatibility with GHC < 7.10.1 type Monad m = (Functor m, Applicative m, M.Monad m) type MonadIO m = (Monad m, M.MonadIO m)@@ -124,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) @@ -146,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) @@ -208,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@@ -221,16 +279,10 @@     , onLeafe = evalItem     } -    runCleanup :: Maybe Location -> [String] -> IO () -> EvalM ()-    runCleanup loc groups action = do-      r <- liftIO $ measure $ safeEvaluate (action >> return (Result "" Success))-      case r of-        (_, Result "" Success) -> return ()-        _ -> reportItem path loc (return 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@@ -240,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 } @@ -260,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
+ hspec-core/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 :: Bool -> [(Path, Format.Item)] -> SpecResult+toSpecResult failOnEmpty results = SpecResult items success+  where+    items = map toResultItem results+    success = not (failOnEmpty && null results) && 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
hspec-core/src/Test/Hspec/Core/Spec.hs view
@@ -29,13 +29,50 @@ , 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-, module Test.Hspec.Core.Example+, Test.Hspec.Core.Example.Example (..)+, Test.Hspec.Core.Example.Params (..)+, Test.Hspec.Core.Example.defaultParams+, Test.Hspec.Core.Example.ActionWith+, Test.Hspec.Core.Example.Progress+, Test.Hspec.Core.Example.ProgressCallback+, Test.Hspec.Core.Example.Result(..)+, Test.Hspec.Core.Example.ResultStatus (..)+, Test.Hspec.Core.Example.Location (..)+, Test.Hspec.Core.Example.FailureReason (..)+, Test.Hspec.Core.Example.safeEvaluate+, 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  import           Prelude ()@@ -43,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) @@ -53,7 +92,9 @@  -- | The @describe@ function combines a list of specs into a larger spec. describe :: HasCallStack => String -> SpecWith a -> SpecWith a-describe label spec = runIO (runSpecM spec) >>= fromSpecList . 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@@ -103,14 +144,13 @@ -- -- Applying `focus` to a spec with focused spec items has no effect. focus :: SpecWith a -> SpecWith a-focus spec = do-  xs <- runIO (runSpecM spec)-  let-    ys-      | any (any itemIsFocused) xs = xs-      | otherwise = bimapForest id (\ item -> item {itemIsFocused = True}) xs-  fromSpecList ys+focus = mapSpecForest focusForest +focusForest :: [SpecTree a] -> [SpecTree a]+focusForest xs+  | any (any itemIsFocused) xs = xs+  | otherwise = bimapForest id (\ item -> item {itemIsFocused = True}) xs+ -- | @fit@ is an alias for @fmap focus . it@ fit :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) fit = fmap focus . it@@ -158,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
hspec-core/src/Test/Hspec/Core/Spec/Monad.hs view
@@ -1,44 +1,61 @@ {-# 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 +, mapSpecForest , 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. --@@ -52,13 +69,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
hspec-core/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 (..)@@ -17,15 +17,18 @@ , filterForest , filterTreeWithLabels , filterForestWithLabels-, pruneTree-, pruneForest+, 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 (Show, Eq, Functor, Foldable, Traversable)+  deriving (Eq, Show, Functor, Foldable, Traversable) --- | A tree is used to represent a spec internally.  The tree is parametrize+-- | 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)
hspec-core/src/Test/Hspec/Core/Util.hs view
@@ -50,10 +50,12 @@ -- ensure that lines are not longer than given `n`, insert line breaks at word -- boundaries lineBreaksAt :: Int -> String -> [String]-lineBreaksAt n input = case words input of-  []   -> []-  x:xs -> go (x, xs)+lineBreaksAt n = concatMap f . lines   where+    f input = case words input of+      []   -> []+      x:xs -> go (x, xs)+     go :: (String, [String]) -> [String]     go c = case c of       (s, [])   -> [s]@@ -102,7 +104,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
hspec-discover/src/Test/Hspec/Discover/Config.hs view
@@ -35,9 +35,9 @@ parseConfig :: String -> [String] -> Either String Config parseConfig prog args = case getOpt Permute options args of     (opts, [], []) -> let-        c = (foldl (flip id) defaultConfig opts)+        c = foldl (flip id) defaultConfig opts       in-        if (configNoMain c && isJust (configFormatter c))+        if configNoMain c && isJust (configFormatter c)            then              formatError "option `--formatter=<fmt>' does not make sense with `--no-main'\n"            else
hspec-discover/src/Test/Hspec/Discover/Run.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances, OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | A preprocessor that finds and combines specs. --@@ -61,7 +61,7 @@ mkSpecModule src conf nodes =   ( "{-# LINE 1 " . shows src . " #-}\n"   . showString "{-# LANGUAGE NoImplicitPrelude #-}\n"-  . showString "{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}\n"+  . showString "{-# OPTIONS_GHC -w -Wall -fno-warn-warnings-deprecations #-}\n"   . showString ("module " ++ moduleName src conf ++" where\n")   . importList nodes   . showString "import Test.Hspec.Discover\n"@@ -121,9 +121,7 @@ sequenceS = foldr (.) "" . intersperse " >> "  formatSpecs :: Maybe [Spec] -> ShowS-formatSpecs specs = case specs of-  Nothing -> "return ()"-  Just xs -> fromForest xs+formatSpecs = maybe "return ()" fromForest   where     fromForest :: [Spec] -> ShowS     fromForest = sequenceS . map fromTree
hspec-discover/src/Test/Hspec/Discover/Sort.hs view
@@ -15,7 +15,7 @@ sortNaturallyBy :: (a -> (String, Int)) -> [a] -> [a] sortNaturallyBy f = sortBy (comparing ((\ (k, t) -> (naturalSortKey k, t)) . f)) -data NaturalSortKey = NaturalSortKey [Chunk]+newtype NaturalSortKey = NaturalSortKey [Chunk]   deriving (Eq, Ord)  data Chunk = Numeric Integer Int | Textual [(Char, Char)]
hspec-meta.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.6.+-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack  name:           hspec-meta-version:        2.9.3+version:        2.10.5 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.@@ -14,7 +14,7 @@ homepage:       http://hspec.github.io/ bug-reports:    https://github.com/hspec/hspec/issues maintainer:     Simon Hengel <sol@typeful.net>-copyright:      (c) 2011-2021 Simon Hengel,+copyright:      (c) 2011-2022 Simon Hengel,                 (c) 2011-2012 Trystan Spangler,                 (c) 2011 Greg Weber license:        MIT@@ -41,6 +41,7 @@       GetOpt.Declarative.Interpret       GetOpt.Declarative.Types       GetOpt.Declarative.Util+      NonEmpty       Test.Hspec.Core.Clock       Test.Hspec.Core.Compat       Test.Hspec.Core.Config@@ -67,6 +68,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@@ -106,6 +108,7 @@     , setenv     , time     , transformers >=0.2.2.0+  default-language: Haskell2010   if impl(ghc >= 8.2.1)     build-depends:         ghc@@ -118,7 +121,6 @@         Control.Concurrent.STM.TMVar     hs-source-dirs:         hspec-core/vendor/stm-2.5.0.1/-  default-language: Haskell2010  executable hspec-meta-discover   main-is: hspec-discover.hs@@ -146,8 +148,8 @@     , setenv     , time     , transformers >=0.2.2.0+  default-language: Haskell2010   if impl(ghc >= 8.2.1)     build-depends:         ghc       , ghc-boot-th-  default-language: Haskell2010
src/Test/Hspec/Discover.hs view
@@ -13,7 +13,7 @@  import           Test.Hspec.Core.Spec import           Test.Hspec.Core.Runner-import           Test.Hspec.Formatters+import           Test.Hspec.Core.Formatters.V1  class IsFormatter a where   toFormatter :: a -> IO Formatter
src/Test/Hspec/Formatters.hs view
@@ -1,2 +1,7 @@-module Test.Hspec.Formatters (module Test.Hspec.Core.Formatters) where-import           Test.Hspec.Core.Formatters+-- |+-- Deprecated\: Use "Test.Hspec.Core.Formatters.V1" instead.+module Test.Hspec.Formatters+-- {-# DEPRECATED "Use \"Test.Hspec.Core.Formatters.V1\" instead." #-}+(module Test.Hspec.Core.Formatters.V1)+where+import           Test.Hspec.Core.Formatters.V1
version.yaml view
@@ -1,1 +1,1 @@-&version 2.9.3+&version 2.10.5