packages feed

hspec-core 2.10.10 → 2.11.0

raw patch · 38 files changed

+828/−544 lines, 38 filesdep −setenvdep ~base

Dependencies removed: setenv

Dependency ranges changed: base

Files

help.txt view
@@ -14,6 +14,7 @@         --[no-]fail-on=ITEMS    empty: fail if all spec items have been filtered                                 focused: fail on focused spec items                                 pending: fail on pending spec items+                                empty-description: fail on empty descriptions         --[no-]strict           same as --fail-on=focused,pending         --[no-]fail-fast        abort on first failure         --[no-]randomize        randomize execution order
hspec-core.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:             hspec-core-version:          2.10.10+version:          2.11.0 license:          MIT license-file:     LICENSE copyright:        (c) 2011-2023 Simon Hengel,@@ -38,7 +38,7 @@     , QuickCheck >=2.13.1     , ansi-terminal >=0.6.2     , array-    , base >=4.5.0.0 && <5+    , base >=4.8.2.0 && <5     , call-stack >=0.2.0     , deepseq     , directory@@ -48,7 +48,6 @@     , process     , quickcheck-io >=0.2.0     , random-    , setenv     , tf-random     , time     , transformers >=0.2.2.0@@ -84,6 +83,7 @@       Test.Hspec.Core.Formatters.Pretty.Parser.Parser       Test.Hspec.Core.Formatters.Pretty.Unicode       Test.Hspec.Core.Formatters.V1.Free+      Test.Hspec.Core.Formatters.V1.Internal       Test.Hspec.Core.Formatters.V1.Monad       Test.Hspec.Core.QuickCheckUtil       Test.Hspec.Core.Runner.Eval@@ -121,7 +121,7 @@     , QuickCheck >=2.14     , ansi-terminal >=0.6.2     , array-    , base >=4.5.0.0 && <5+    , base >=4.8.2.0 && <5     , base-orphans     , call-stack >=0.2.0     , deepseq@@ -133,7 +133,6 @@     , process     , quickcheck-io >=0.2.0     , random-    , setenv     , silently >=1.2.4     , temporary     , tf-random@@ -166,6 +165,7 @@       Test.Hspec.Core.Formatters.Pretty.Unicode       Test.Hspec.Core.Formatters.V1       Test.Hspec.Core.Formatters.V1.Free+      Test.Hspec.Core.Formatters.V1.Internal       Test.Hspec.Core.Formatters.V1.Monad       Test.Hspec.Core.Formatters.V2       Test.Hspec.Core.Hooks@@ -215,6 +215,7 @@       Test.Hspec.Core.ShuffleSpec       Test.Hspec.Core.SpecSpec       Test.Hspec.Core.TimerSpec+      Test.Hspec.Core.TreeSpec       Test.Hspec.Core.UtilSpec       Paths_hspec_core   default-language: Haskell2010
src/GetOpt/Declarative/Interpret.hs view
@@ -12,7 +12,7 @@ import qualified System.Console.GetOpt as GetOpt  import           GetOpt.Declarative.Types-import           GetOpt.Declarative.Util (mkUsageInfo, mapOptDescr)+import           GetOpt.Declarative.Util (mkUsageInfo)  data InvalidArgument = InvalidArgument String String @@ -30,7 +30,7 @@      usage :: String     usage = "Usage: " ++ prog ++ " [OPTION]...\n\n"-      ++ (intercalate "\n" $ map (uncurry mkUsageInfo) documentedOptions)+      ++ intercalate "\n" (map (uncurry mkUsageInfo) documentedOptions)  addHelpFlag :: [(a, [OptDescr a1])] -> [(a, [OptDescr (Maybe a1)])] addHelpFlag opts = case opts of@@ -40,7 +40,7 @@     help = Nothing      noHelp :: [OptDescr a] -> [OptDescr (Maybe a)]-    noHelp = map (mapOptDescr Just)+    noHelp = map (fmap Just)  parseWithHelp :: [OptDescr (Maybe (config -> Either InvalidArgument config))] -> config -> [String] -> Maybe (Either String config) parseWithHelp options config args = case getOpt Permute options args of
src/GetOpt/Declarative/Util.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-module GetOpt.Declarative.Util (mkUsageInfo, mapOptDescr) where+module GetOpt.Declarative.Util (mkUsageInfo) where  import           Prelude () import           Test.Hspec.Core.Compat@@ -31,17 +31,3 @@     Option "" ["[no-]" ++ optionA] arg help : condenseNoOptions ys   x : xs -> x : condenseNoOptions xs   [] -> []--mapOptDescr :: (a -> b) -> OptDescr a -> OptDescr b-#if MIN_VERSION_base(4,7,0)-mapOptDescr = fmap-#else-mapOptDescr f opt = case opt of-  Option short long arg help -> Option short long (mapArgDescr f arg) help--mapArgDescr :: (a -> b) -> ArgDescr a -> ArgDescr b-mapArgDescr f arg = case arg of-  NoArg a -> NoArg (f a)-  ReqArg parse name -> ReqArg (fmap f parse) name-  OptArg parse name -> OptArg (fmap f parse) name-#endif
src/Test/Hspec/Core/Compat.hs view
@@ -25,7 +25,7 @@ import           System.Environment  #if MIN_VERSION_base(4,11,0)-import           Data.Functor as Imports+import           Data.Functor as Imports ((<&>)) #endif  import           Data.Traversable as Imports@@ -39,9 +39,7 @@   , inits   , tails   , sortBy-#if MIN_VERSION_base(4,8,0)   , sortOn-#endif   )  import           Prelude as Imports hiding (@@ -65,14 +63,17 @@   , sequence   , sequence_   , sum-#if !MIN_VERSION_base(4,6,0)-  , catch-#endif   ) -import           Data.Typeable (Typeable, typeOf, typeRepTyCon)+import           Data.Typeable (Typeable, typeOf, typeRepTyCon, tyConModule, tyConName) import           Data.IORef as Imports +#if MIN_VERSION_base(4,12,0)+import           GHC.ResponseFile as Imports (unescapeArgs)+#else+import           Data.Char+#endif+ #if MIN_VERSION_base(4,6,0) import           Text.Read as Imports (readMaybe) import           System.Environment as Imports (lookupEnv)@@ -89,7 +90,6 @@ import           Data.Bool as Imports (bool) #endif -import           Data.Typeable (tyConModule, tyConName) import           Control.Concurrent  #if !MIN_VERSION_base(4,9,0)@@ -168,18 +168,6 @@ guarded :: Alternative m => (a -> Bool) -> a -> m a guarded p a = if p a then pure a else empty -#if !MIN_VERSION_base(4,8,0)-sortOn :: Ord b => (a -> b) -> [a] -> [a]-sortOn f =-  map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x))-#endif--#if !MIN_VERSION_base(4,7,0)-bool :: a -> a -> Bool -> a-bool f _ False = f-bool _ t True  = t-#endif- #if !MIN_VERSION_base(4,11,0) infixl 1 <&> (<&>) :: Functor f => f a -> (a -> b) -> f b@@ -189,16 +177,44 @@ endsWith :: Eq a => [a] -> [a] -> Bool endsWith = flip isSuffixOf -#if MIN_VERSION_base(4,8,0) pass :: Applicative m => m () pass = pure ()-#else-pass :: Monad m => m ()-pass = return ()-#endif  die :: String -> IO a die err = do   name <- getProgName   hPutStrLn stderr $ name <> ": " <> err   exitFailure++#if !MIN_VERSION_base(4,12,0)+unescapeArgs :: String -> [String]+unescapeArgs = filter (not . null) . unescape++data Quoting = NoneQ | SngQ | DblQ++unescape :: String -> [String]+unescape args = reverse . map reverse $ go args NoneQ False [] []+    where+      -- n.b., the order of these cases matters; these are cribbed from gcc+      -- case 1: end of input+      go []     _q    _bs   a as = a:as+      -- case 2: back-slash escape in progress+      go (c:cs) q     True  a as = go cs q     False (c:a) as+      -- case 3: no back-slash escape in progress, but got a back-slash+      go (c:cs) q     False a as+        | '\\' == c              = go cs q     True  a     as+      -- case 4: single-quote escaping in progress+      go (c:cs) SngQ  False a as+        | '\'' == c              = go cs NoneQ False a     as+        | otherwise              = go cs SngQ  False (c:a) as+      -- case 5: double-quote escaping in progress+      go (c:cs) DblQ  False a as+        | '"' == c               = go cs NoneQ False a     as+        | otherwise              = go cs DblQ  False (c:a) as+      -- case 6: no escaping is in progress+      go (c:cs) NoneQ False a as+        | isSpace c              = go cs NoneQ False []    (a:as)+        | '\'' == c              = go cs SngQ  False a     as+        | '"'  == c              = go cs DblQ  False a     as+        | otherwise              = go cs NoneQ False (c:a) as+#endif
src/Test/Hspec/Core/Config.hs view
@@ -163,7 +163,7 @@ readConfigFile :: FilePath -> IO (Maybe ConfigFile) readConfigFile name = do   exists <- doesFileExist name-  if exists then Just . (,) name . words <$> readFile name else return Nothing+  if exists then Just . (,) name . unescapeArgs <$> readFile name else return Nothing  exitWithMessage :: ExitCode -> String -> IO a exitWithMessage err msg = do
src/Test/Hspec/Core/Config/Definition.hs view
@@ -46,6 +46,7 @@ , configFailOnEmpty :: Bool , configFailOnFocused :: Bool , configFailOnPending :: Bool+, configFailOnEmptyDescription :: Bool , configPrintSlowItems :: Maybe Int , configPrintCpuTime :: Bool , configFailFast :: Bool@@ -83,10 +84,11 @@ , configTimes :: Bool , configAvailableFormatters :: [(String, FormatConfig -> IO Format)] -- ^ @since 2.9.0 , configFormat :: Maybe (FormatConfig -> IO Format)-, configFormatter :: Maybe V1.Formatter -- ^ deprecated, use `configFormat` instead+, configFormatter :: Maybe V1.Formatter , configHtmlOutput :: Bool , configConcurrentJobs :: Maybe Int }+{-# DEPRECATED configFormatter "Use [@useFormatter@](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Formatters-V1.html#v:useFormatter) instead." #-}  mkDefaultConfig :: [(String, FormatConfig -> IO Format)] -> Config mkDefaultConfig formatters = Config {@@ -96,6 +98,7 @@ , configFailOnEmpty = False , configFailOnFocused = False , configFailOnPending = False+, configFailOnEmptyDescription = False , configPrintSlowItems = Nothing , configPrintCpuTime = False , configFailFast = False@@ -282,6 +285,7 @@     FailOnEmpty   | FailOnFocused   | FailOnPending+  | FailOnEmptyDescription   deriving (Bounded, Enum)  allFailOnItems :: [FailOn]@@ -292,6 +296,7 @@   FailOnEmpty -> "empty"   FailOnFocused -> "focused"   FailOnPending -> "pending"+  FailOnEmptyDescription -> "empty-description"  readFailOn :: String -> Maybe FailOn readFailOn = (`lookup` items)@@ -342,6 +347,7 @@           FailOnEmpty -> "fail if all spec items have been filtered"           FailOnFocused -> "fail on focused spec items"           FailOnPending -> "fail on pending spec items"+          FailOnEmptyDescription -> "fail on empty descriptions"      setFailOnItems :: Bool -> [FailOn] -> Config -> Config     setFailOnItems value = flip $ foldr (`setItem` value)@@ -350,6 +356,7 @@           FailOnEmpty -> setFailOnEmpty           FailOnFocused -> setFailOnFocused           FailOnPending -> setFailOnPending+          FailOnEmptyDescription -> setFailOnEmptyDescription      readMaxJobs :: String -> Maybe Int     readMaxJobs s = do@@ -377,6 +384,9 @@      setFailOnPending :: Bool -> Config -> Config     setFailOnPending value config = config {configFailOnPending = value}++    setFailOnEmptyDescription :: Bool -> Config -> Config+    setFailOnEmptyDescription value config = config {configFailOnEmptyDescription = value}      setStrict :: Bool -> Config -> Config     setStrict = (`setFailOnItems` strict)
src/Test/Hspec/Core/Config/Options.hs view
@@ -49,14 +49,7 @@       foldM (parseFileOptions prog) config configFiles   >>= maybe return (parseEnvVarOptions prog) envVar   >>= parseEnvironmentOptions env-  >>= traverseTuple (parseCommandLineOptions prog args)--traverseTuple :: Applicative f => (a -> f b) -> (c, a) -> f (c, b)-#if MIN_VERSION_base(4,7,0)-traverseTuple = traverse-#else-traverseTuple f (c, a) = (,) c <$> f a-#endif+  >>= traverse (parseCommandLineOptions prog args)  parseCommandLineOptions :: String -> [String] -> Config -> Either (ExitCode, String) Config parseCommandLineOptions prog args config = case Declarative.parseCommandLineOptions (commandLineOptions formatters) prog args config of
src/Test/Hspec/Core/Example.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-}@@ -33,7 +32,6 @@ import           Data.CallStack (SrcLoc(..))  import           Control.DeepSeq-import           Data.Typeable (Typeable) import qualified Test.QuickCheck as QC import           Test.Hspec.Expectations (Expectation) @@ -71,25 +69,27 @@ data Result = Result {   resultInfo :: String , resultStatus :: ResultStatus-} deriving (Show, Typeable)+} deriving Show  data ResultStatus =     Success   | Pending (Maybe Location) (Maybe String)   | Failure (Maybe Location) FailureReason-  deriving (Show, Typeable)+  deriving Show  data FailureReason =     NoReason   | Reason String+  | ColorizedReason String   | ExpectedButGot (Maybe String) String String   | Error (Maybe String) SomeException-  deriving (Show, Typeable)+  deriving Show  instance NFData FailureReason where   rnf reason = case reason of     NoReason -> ()     Reason r -> r `deepseq` ()+    ColorizedReason r -> r `deepseq` ()     ExpectedButGot p e a  -> p `deepseq` e `deepseq` a `deepseq` ()     Error m e -> m `deepseq` show e `deepseq` ()
src/Test/Hspec/Core/FailureReport.hs view
@@ -9,7 +9,7 @@ import           Test.Hspec.Core.Compat  #ifndef __GHCJS__-import           System.SetEnv (setEnv)+import           System.Environment (setEnv) import           Test.Hspec.Core.Util (safeTry) #endif import           System.IO
src/Test/Hspec/Core/Format.hs view
@@ -1,8 +1,14 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ExistentialQuantification #-} -- |--- Stability: experimental-module Test.Hspec.Core.Format (+-- Stability: unstable+--+-- This is an unstable API.  Use+-- [Test.Hspec.Api.Format.V2](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Format-V2.html)+-- instead.+module Test.Hspec.Core.Format+-- {-# WARNING "Use [Test.Hspec.Api.Format.V2](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Format-V2.html) instead." #-}+(   Format , FormatConfig(..) , Event(..)@@ -60,7 +66,7 @@ , formatConfigUseDiff :: Bool , formatConfigDiffContext :: Maybe Int , formatConfigExternalDiff :: Maybe (String -> String -> IO ())-, formatConfigPrettyPrint :: Bool -- ^ Deprecated: use `formatConfigPrettyPrintFunction` instead+, formatConfigPrettyPrint :: Bool , formatConfigPrettyPrintFunction :: Maybe (String -> String -> (String, String)) , formatConfigPrintTimes :: Bool , formatConfigHtmlOutput :: Bool@@ -68,6 +74,8 @@ , formatConfigUsedSeed :: Integer , formatConfigExpectedTotalCount :: Int }++{-# DEPRECATED formatConfigPrettyPrint "Use `formatConfigPrettyPrintFunction` instead" #-}  data Signal = Ok | NotOk SomeException
src/Test/Hspec/Core/Formatters.hs view
@@ -1,6 +1,5 @@--- |--- Deprecated\: Use "Test.Hspec.Core.Formatters.V1" instead.+{-# OPTIONS_GHC -fno-warn-deprecations #-} module Test.Hspec.Core.Formatters--- {-# DEPRECATED "Use \"Test.Hspec.Core.Formatters.V1\" instead." #-}+{-# DEPRECATED "Use [Test.Hspec.Api.Formatters.V1](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Formatters-V1.html) instead." #-} (module V1) where import           Test.Hspec.Core.Formatters.V1 as V1
src/Test/Hspec/Core/Formatters/Diff.hs view
@@ -109,7 +109,7 @@       | otherwise = (x :)  splitEscape :: String -> Maybe (String, String)-splitEscape xs = splitNumericEscape xs <|> (msum $ map split escapes)+splitEscape xs = splitNumericEscape xs <|> msum (map split escapes)   where     split :: String -> Maybe (String, String)     split escape = (,) escape <$> stripPrefix escape xs
src/Test/Hspec/Core/Formatters/Internal.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-} module Test.Hspec.Core.Formatters.Internal (   Formatter(..) , Item(..)@@ -52,15 +53,14 @@ import           Test.Hspec.Core.Compat  import qualified System.IO as IO-import           System.IO (Handle, stdout)+import           System.IO (stdout) import           System.Console.ANSI-import           Control.Monad.Trans.State hiding (state, gets, modify)+import           Control.Monad.Trans.Reader (ReaderT(..), ask) 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(..)) import           Test.Hspec.Core.Format import           Test.Hspec.Core.Clock @@ -87,8 +87,14 @@ , formatterDone :: FormatM () } +data FailureRecord = FailureRecord {+  failureRecordLocation :: Maybe Location+, failureRecordPath     :: Path+, failureRecordMessage  :: FailureReason+}+ formatterToFormat :: Formatter -> FormatConfig -> IO Format-formatterToFormat Formatter{..} config = monadic (runFormatM config) $ \ event -> case event of+formatterToFormat Formatter{..} config = monadic (runFormatM config) $ \ case   Started -> formatterStarted   GroupStarted path -> formatterGroupStarted path   GroupDone path -> formatterGroupDone path@@ -165,12 +171,12 @@ -- | A lifted version of `Control.Monad.Trans.State.gets` gets :: (FormatterState -> a) -> FormatM a gets f = FormatM $ do-  f <$> (get >>= liftIO . readIORef)+  f <$> (ask >>= liftIO . readIORef)  -- | A lifted version of `Control.Monad.Trans.State.modify` modify :: (FormatterState -> FormatterState) -> FormatM () modify f = FormatM $ do-  get >>= liftIO . (`modifyIORef'` f)+  ask >>= liftIO . (`modifyIORef'` f)  data FormatterState = FormatterState {   stateSuccessCount    :: !Int@@ -185,16 +191,13 @@ getConfig :: (FormatConfig -> a) -> FormatM a getConfig f = gets (f . stateConfig) -getHandle :: FormatM Handle-getHandle = return stdout- -- | The random seed that is used for QuickCheck. usedSeed :: FormatM Integer usedSeed = getConfig formatConfigUsedSeed  -- NOTE: We use an IORef here, so that the state persists when UserInterrupt is -- thrown.-newtype FormatM a = FormatM (StateT (IORef FormatterState) IO a)+newtype FormatM a = FormatM (ReaderT (IORef FormatterState) IO a)   deriving (Functor, Applicative, Monad, MonadIO)  runFormatM :: FormatConfig -> FormatM a -> IO a@@ -213,7 +216,7 @@     , stateConfig = config { formatConfigReportProgress = progress }     , stateColor = Nothing     }-  newIORef state >>= evalStateT action+  newIORef state >>= runReaderT action  withLineBuffering :: IO a -> IO a withLineBuffering action = bracket (IO.hGetBuffering stdout) (IO.hSetBuffering stdout) $ \ _ -> do@@ -250,9 +253,8 @@ writeTransient new = do   reportProgress <- getConfig formatConfigReportProgress   when reportProgress $ do-    h <- getHandle     write new-    liftIO $ IO.hFlush h+    liftIO $ IO.hFlush stdout     write $ "\r" ++ replicate (length new) ' ' ++ "\r"  -- | Append some output to the report.@@ -266,10 +268,9 @@  writeChunk :: String -> FormatM () writeChunk str = do-  h <- getHandle   let-    plainOutput = IO.hPutStr h str-    colorOutput color = bracket_ (hSetSGR h [color]) (hSetSGR h [Reset]) plainOutput+    plainOutput = IO.hPutStr stdout str+    colorOutput color = bracket_ (hSetSGR stdout [color]) (hSetSGR stdout [Reset]) plainOutput   mColor <- gets stateColor   liftIO $ case mColor of     Just (SetColor Foreground _ _) | all isSpace str -> plainOutput
src/Test/Hspec/Core/Formatters/V1.hs view
@@ -1,12 +1,11 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE RecordWildCards #-} -- | -- Stability: deprecated -- -- This module contains formatters that can be used with -- `Test.Hspec.Core.Runner.hspecWith`.-module Test.Hspec.Core.Formatters.V1 (-+module Test.Hspec.Core.Formatters.V1+{-# DEPRECATED "Use [Test.Hspec.Api.Formatters.V1](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Formatters-V1.html) instead." #-}+( -- * Formatters   silent , checks@@ -60,290 +59,4 @@ ) where  import           Prelude ()-import           Test.Hspec.Core.Compat hiding (First)--import           Test.Hspec.Core.Util-import           Test.Hspec.Core.Clock-import           Test.Hspec.Core.Example (Location(..))-import           Text.Printf-import           Control.Monad.IO.Class---- We use an explicit import list for "Test.Hspec.Formatters.Internal", to make--- sure, that we only use the public API to implement formatters.------ Everything imported here has to be re-exported, so that users can implement--- their own formatters.-import Test.Hspec.Core.Formatters.V1.Monad (-    Formatter(..)-  , FailureReason(..)-  , FormatM--  , getSuccessCount-  , getPendingCount-  , getFailCount-  , getTotalCount--  , FailureRecord(..)-  , getFailMessages-  , usedSeed--  , getCPUTime-  , getRealTime--  , write-  , writeLine-  , writeTransient--  , withInfoColor-  , withSuccessColor-  , withPendingColor-  , withFailColor--  , useDiff-  , extraChunk-  , missingChunk-  )--import           Test.Hspec.Core.Format (FormatConfig, Format)--import           Test.Hspec.Core.Formatters.Diff-import qualified Test.Hspec.Core.Formatters.V2 as V2-import           Test.Hspec.Core.Formatters.V1.Monad (Item(..), Result(..), Environment(..), interpretWith)--formatterToFormat :: Formatter -> FormatConfig -> IO Format-formatterToFormat = V2.formatterToFormat . legacyFormatterToFormatter--legacyFormatterToFormatter :: Formatter -> V2.Formatter-legacyFormatterToFormatter Formatter{..} = V2.Formatter {-  V2.formatterStarted = interpret headerFormatter-, V2.formatterGroupStarted = interpret . uncurry exampleGroupStarted-, V2.formatterGroupDone = interpret . const exampleGroupDone-, V2.formatterProgress = \ path -> interpret . exampleProgress path-, V2.formatterItemStarted = interpret . exampleStarted-, V2.formatterItemDone = \ path item -> interpret $ do-    case itemResult item of-      Success -> exampleSucceeded path (itemInfo item)-      Pending _ reason -> examplePending path (itemInfo item) reason-      Failure _ reason -> exampleFailed path (itemInfo item) reason-, V2.formatterDone = interpret $ failedFormatter >> footerFormatter-}--interpret :: FormatM a -> V2.FormatM a-interpret = interpretWith Environment {-  environmentGetSuccessCount = V2.getSuccessCount-, environmentGetPendingCount = V2.getPendingCount-, environmentGetFailMessages = V2.getFailMessages-, environmentUsedSeed = V2.usedSeed-, environmentPrintTimes = V2.printTimes-, environmentGetCPUTime = V2.getCPUTime-, environmentGetRealTime = V2.getRealTime-, environmentWrite = V2.write-, environmentWriteTransient = V2.writeTransient-, environmentWithFailColor = V2.withFailColor-, environmentWithSuccessColor = V2.withSuccessColor-, environmentWithPendingColor = V2.withPendingColor-, environmentWithInfoColor = V2.withInfoColor-, environmentUseDiff = V2.useDiff-, environmentExtraChunk = V2.extraChunk-, environmentMissingChunk = V2.missingChunk-, environmentLiftIO = liftIO-}--silent :: Formatter-silent = Formatter {-  headerFormatter     = pass-, exampleGroupStarted = \_ _ -> pass-, exampleGroupDone    = pass-, exampleStarted      = \_ -> pass-, exampleProgress     = \_ _ -> pass-, exampleSucceeded    = \ _ _ -> pass-, exampleFailed       = \_ _ _ -> pass-, examplePending      = \_ _ _ -> pass-, failedFormatter     = pass-, footerFormatter     = pass-}--checks :: Formatter-checks = specdoc {-  exampleStarted = \(nesting, requirement) -> do-    writeTransient $ indentationFor nesting ++ requirement ++ " [ ]"--, exampleProgress = \(nesting, requirement) p -> do-    writeTransient $ indentationFor nesting ++ requirement ++ " [" ++ (formatProgress p) ++ "]"--, exampleSucceeded = \(nesting, requirement) info -> do-    writeResult nesting requirement info $ withSuccessColor $ write "✔"--, exampleFailed = \(nesting, requirement) info _ -> do-    writeResult nesting requirement info $ withFailColor $ write "✘"--, examplePending = \(nesting, requirement) info reason -> do-    writeResult nesting requirement info $ withPendingColor $ write "‐"--    withPendingColor $ do-      writeLine $ indentationFor ("" : nesting) ++ "# PENDING: " ++ fromMaybe "No reason given" reason-} where-    indentationFor nesting = replicate (length nesting * 2) ' '--    writeResult :: [String] -> String -> String -> FormatM () -> FormatM ()-    writeResult nesting requirement info action = do-      write $ indentationFor nesting ++ requirement ++ " ["-      action-      writeLine "]"-      forM_ (lines info) $ \ s ->-        writeLine $ indentationFor ("" : nesting) ++ s--    formatProgress (current, total)-      | total == 0 = show current-      | otherwise  = show current ++ "/" ++ show total--specdoc :: Formatter-specdoc = silent {--  headerFormatter = do-    writeLine ""--, exampleGroupStarted = \nesting name -> do-    writeLine (indentationFor nesting ++ name)--, exampleProgress = \_ p -> do-    writeTransient (formatProgress p)--, exampleSucceeded = \(nesting, requirement) info -> withSuccessColor $ do-    writeLine $ indentationFor nesting ++ requirement-    forM_ (lines info) $ \ s ->-      writeLine $ indentationFor ("" : nesting) ++ s--, exampleFailed = \(nesting, requirement) info _ -> withFailColor $ do-    n <- getFailCount-    writeLine $ indentationFor nesting ++ requirement ++ " FAILED [" ++ show n ++ "]"-    forM_ (lines info) $ \ s ->-      writeLine $ indentationFor ("" : nesting) ++ s--, examplePending = \(nesting, requirement) info reason -> withPendingColor $ do-    writeLine $ indentationFor nesting ++ requirement-    forM_ (lines info) $ \ s ->-      writeLine $ indentationFor ("" : nesting) ++ s-    writeLine $ indentationFor ("" : nesting) ++ "# PENDING: " ++ fromMaybe "No reason given" reason--, failedFormatter = defaultFailedFormatter--, footerFormatter = defaultFooter-} where-    indentationFor nesting = replicate (length nesting * 2) ' '-    formatProgress (current, total)-      | total == 0 = show current-      | otherwise  = show current ++ "/" ++ show total---progress :: Formatter-progress = silent {-  exampleSucceeded = \_ _ -> withSuccessColor $ write "."-, exampleFailed    = \_ _ _ -> withFailColor    $ write "F"-, examplePending   = \_ _ _ -> withPendingColor $ write "."-, failedFormatter  = defaultFailedFormatter-, footerFormatter  = defaultFooter-}---failed_examples :: Formatter-failed_examples   = silent {-  failedFormatter = defaultFailedFormatter-, footerFormatter = defaultFooter-}--defaultFailedFormatter :: FormatM ()-defaultFailedFormatter = do-  writeLine ""--  failures <- getFailMessages--  unless (null failures) $ do-    writeLine "Failures:"-    writeLine ""--    forM_ (zip [1..] failures) $ \x -> do-      formatFailure x-      writeLine ""--    write "Randomized with seed " >> usedSeed >>= writeLine . show-    writeLine ""-  where-    formatFailure :: (Int, FailureRecord) -> FormatM ()-    formatFailure (n, FailureRecord mLoc path reason) = do-      forM_ mLoc $ \loc -> do-        withInfoColor $ writeLine (formatLoc loc)-      write ("  " ++ show n ++ ") ")-      writeLine (formatRequirement path)-      case reason of-        NoReason -> pass-        Reason err -> withFailColor $ indent err-        ExpectedButGot preface expected actual -> do-          mapM_ indent preface--          b <- useDiff--          let threshold = 2 :: Seconds--          mchunks <- liftIO $ if b-            then timeout threshold (evaluate $ diff Nothing expected actual)-            else return Nothing--          case mchunks of-            Just chunks -> do-              writeDiff chunks extraChunk missingChunk-            Nothing -> do-              writeDiff [First expected, Second actual] write write-          where-            indented output text = case break (== '\n') text of-              (xs, "") -> output xs-              (xs, _ : ys) -> output (xs ++ "\n") >> write (indentation ++ "          ") >> indented output ys--            writeDiff chunks extra missing = do-              withFailColor $ write (indentation ++ "expected: ")-              forM_ chunks $ \ chunk -> case chunk of-                Both a -> indented write a-                First a -> indented extra a-                Second _ -> pass-                Omitted _ -> pass-              writeLine ""--              withFailColor $ write (indentation ++ " but got: ")-              forM_ chunks $ \ chunk -> case chunk of-                Both a -> indented write a-                First _ -> pass-                Second a -> indented missing a-                Omitted _ -> pass-              writeLine ""--        Error _ e -> withFailColor . indent $ (("uncaught exception: " ++) . formatException) e--      writeLine ""-      writeLine ("  To rerun use: --match " ++ show (joinPath path))-      where-        indentation = "       "-        indent message = do-          forM_ (lines message) $ \line -> do-            writeLine (indentation ++ line)-        formatLoc (Location file line column) = "  " ++ file ++ ":" ++ show line ++ ":" ++ show column ++ ": "--defaultFooter :: FormatM ()-defaultFooter = do--  writeLine =<< (++)-    <$> (printf "Finished in %1.4f seconds" <$> getRealTime)-    <*> (maybe "" (printf ", used %1.4f seconds of CPU time") <$> getCPUTime)--  fails   <- getFailCount-  pending <- getPendingCount-  total   <- getTotalCount--  let-    output =-         pluralize total   "example"-      ++ ", " ++ pluralize fails "failure"-      ++ if pending == 0 then "" else ", " ++ show pending ++ " pending"-    c | fails /= 0   = withFailColor-      | pending /= 0 = withPendingColor-      | otherwise    = withSuccessColor-  c $ writeLine output+import           Test.Hspec.Core.Formatters.V1.Internal
+ src/Test/Hspec/Core/Formatters/V1/Internal.hs view
@@ -0,0 +1,359 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE LambdaCase #-}+module Test.Hspec.Core.Formatters.V1.Internal (+-- * Formatters+  silent+, checks+, specdoc+, progress+, failed_examples++-- * Implementing a custom Formatter+-- |+-- A formatter is a set of actions.  Each action is evaluated when a certain+-- situation is encountered during a test run.+--+-- Actions live in the `FormatM` monad.  It provides access to the runner state+-- and primitives for appending to the generated report.+, Formatter (..)+, FailureReason (..)+, FormatM+, formatterToFormat++-- ** Accessing the runner state+, getSuccessCount+, getPendingCount+, getFailCount+, getTotalCount++, FailureRecord (..)+, getFailMessages+, usedSeed++, Seconds(..)+, getCPUTime+, getRealTime++-- ** Appending to the generated report+, write+, writeLine+, writeTransient++-- ** Dealing with colors+, withInfoColor+, withSuccessColor+, withPendingColor+, withFailColor++, useDiff+, extraChunk+, missingChunk++-- ** Helpers+, formatException+) where++import           Prelude ()+import           Test.Hspec.Core.Compat hiding (First)++import           Test.Hspec.Core.Util+import           Test.Hspec.Core.Clock+import           Test.Hspec.Core.Example (Location(..))+import           Text.Printf+import           Control.Monad.IO.Class++-- We use an explicit import list for "Test.Hspec.Formatters.Internal", to make+-- sure, that we only use the public API to implement formatters.+--+-- Everything imported here has to be re-exported, so that users can implement+-- their own formatters.+import Test.Hspec.Core.Formatters.V1.Monad (+    Formatter(..)+  , FailureReason(..)+  , FormatM++  , getSuccessCount+  , getPendingCount+  , getFailCount+  , getTotalCount++  , FailureRecord(..)+  , getFailMessages+  , usedSeed++  , getCPUTime+  , getRealTime++  , write+  , writeLine+  , writeTransient++  , withInfoColor+  , withSuccessColor+  , withPendingColor+  , withFailColor++  , useDiff+  , extraChunk+  , missingChunk+  )++import           Test.Hspec.Core.Format (FormatConfig, Format)++import           Test.Hspec.Core.Formatters.Diff+import qualified Test.Hspec.Core.Formatters.V2 as V2+import           Test.Hspec.Core.Formatters.V1.Monad (Item(..), Result(..), Environment(..), interpretWith)++formatterToFormat :: Formatter -> FormatConfig -> IO Format+formatterToFormat = V2.formatterToFormat . legacyFormatterToFormatter++legacyFormatterToFormatter :: Formatter -> V2.Formatter+legacyFormatterToFormatter Formatter{..} = V2.Formatter {+  V2.formatterStarted = interpret headerFormatter+, V2.formatterGroupStarted = interpret . uncurry exampleGroupStarted+, V2.formatterGroupDone = interpret . const exampleGroupDone+, V2.formatterProgress = \ path -> interpret . exampleProgress path+, V2.formatterItemStarted = interpret . exampleStarted+, V2.formatterItemDone = \ path item -> interpret $ do+    case itemResult item of+      Success -> exampleSucceeded path (itemInfo item)+      Pending _ reason -> examplePending path (itemInfo item) reason+      Failure _ reason -> exampleFailed path (itemInfo item) (unliftFailureReason reason)+, V2.formatterDone = interpret $ failedFormatter >> footerFormatter+}++unliftFailureRecord :: V2.FailureRecord -> FailureRecord+unliftFailureRecord V2.FailureRecord{..} = FailureRecord {+  failureRecordLocation+, failureRecordPath+, failureRecordMessage = unliftFailureReason failureRecordMessage+}++unliftFailureReason :: V2.FailureReason -> FailureReason+unliftFailureReason = \ case+  V2.NoReason -> NoReason+  V2.Reason reason -> Reason reason+  V2.ColorizedReason reason -> Reason (stripAnsi reason)+  V2.ExpectedButGot preface expected actual -> ExpectedButGot preface expected actual+  V2.Error info e -> Error info e++interpret :: FormatM a -> V2.FormatM a+interpret = interpretWith Environment {+  environmentGetSuccessCount = V2.getSuccessCount+, environmentGetPendingCount = V2.getPendingCount+, environmentGetFailMessages = map unliftFailureRecord <$> V2.getFailMessages+, environmentUsedSeed = V2.usedSeed+, environmentPrintTimes = V2.printTimes+, environmentGetCPUTime = V2.getCPUTime+, environmentGetRealTime = V2.getRealTime+, environmentWrite = V2.write+, environmentWriteTransient = V2.writeTransient+, environmentWithFailColor = V2.withFailColor+, environmentWithSuccessColor = V2.withSuccessColor+, environmentWithPendingColor = V2.withPendingColor+, environmentWithInfoColor = V2.withInfoColor+, environmentUseDiff = V2.useDiff+, environmentExtraChunk = V2.extraChunk+, environmentMissingChunk = V2.missingChunk+, environmentLiftIO = liftIO+}++silent :: Formatter+silent = Formatter {+  headerFormatter     = pass+, exampleGroupStarted = \_ _ -> pass+, exampleGroupDone    = pass+, exampleStarted      = \_ -> pass+, exampleProgress     = \_ _ -> pass+, exampleSucceeded    = \ _ _ -> pass+, exampleFailed       = \_ _ _ -> pass+, examplePending      = \_ _ _ -> pass+, failedFormatter     = pass+, footerFormatter     = pass+}++checks :: Formatter+checks = specdoc {+  exampleStarted = \(nesting, requirement) -> do+    writeTransient $ indentationFor nesting ++ requirement ++ " [ ]"++, exampleProgress = \(nesting, requirement) p -> do+    writeTransient $ indentationFor nesting ++ requirement ++ " [" ++ (formatProgress p) ++ "]"++, exampleSucceeded = \(nesting, requirement) info -> do+    writeResult nesting requirement info $ withSuccessColor $ write "✔"++, exampleFailed = \(nesting, requirement) info _ -> do+    writeResult nesting requirement info $ withFailColor $ write "✘"++, examplePending = \(nesting, requirement) info reason -> do+    writeResult nesting requirement info $ withPendingColor $ write "‐"++    withPendingColor $ do+      writeLine $ indentationFor ("" : nesting) ++ "# PENDING: " ++ fromMaybe "No reason given" reason+} where+    indentationFor nesting = replicate (length nesting * 2) ' '++    writeResult :: [String] -> String -> String -> FormatM () -> FormatM ()+    writeResult nesting requirement info action = do+      write $ indentationFor nesting ++ requirement ++ " ["+      action+      writeLine "]"+      forM_ (lines info) $ \ s ->+        writeLine $ indentationFor ("" : nesting) ++ s++    formatProgress (current, total)+      | total == 0 = show current+      | otherwise  = show current ++ "/" ++ show total++specdoc :: Formatter+specdoc = silent {++  headerFormatter = do+    writeLine ""++, exampleGroupStarted = \nesting name -> do+    writeLine (indentationFor nesting ++ name)++, exampleProgress = \_ p -> do+    writeTransient (formatProgress p)++, exampleSucceeded = \(nesting, requirement) info -> withSuccessColor $ do+    writeLine $ indentationFor nesting ++ requirement+    forM_ (lines info) $ \ s ->+      writeLine $ indentationFor ("" : nesting) ++ s++, exampleFailed = \(nesting, requirement) info _ -> withFailColor $ do+    n <- getFailCount+    writeLine $ indentationFor nesting ++ requirement ++ " FAILED [" ++ show n ++ "]"+    forM_ (lines info) $ \ s ->+      writeLine $ indentationFor ("" : nesting) ++ s++, examplePending = \(nesting, requirement) info reason -> withPendingColor $ do+    writeLine $ indentationFor nesting ++ requirement+    forM_ (lines info) $ \ s ->+      writeLine $ indentationFor ("" : nesting) ++ s+    writeLine $ indentationFor ("" : nesting) ++ "# PENDING: " ++ fromMaybe "No reason given" reason++, failedFormatter = defaultFailedFormatter++, footerFormatter = defaultFooter+} where+    indentationFor nesting = replicate (length nesting * 2) ' '+    formatProgress (current, total)+      | total == 0 = show current+      | otherwise  = show current ++ "/" ++ show total+++progress :: Formatter+progress = silent {+  exampleSucceeded = \_ _ -> withSuccessColor $ write "."+, exampleFailed    = \_ _ _ -> withFailColor    $ write "F"+, examplePending   = \_ _ _ -> withPendingColor $ write "."+, failedFormatter  = defaultFailedFormatter+, footerFormatter  = defaultFooter+}+++failed_examples :: Formatter+failed_examples   = silent {+  failedFormatter = defaultFailedFormatter+, footerFormatter = defaultFooter+}++defaultFailedFormatter :: FormatM ()+defaultFailedFormatter = do+  writeLine ""++  failures <- getFailMessages++  unless (null failures) $ do+    writeLine "Failures:"+    writeLine ""++    forM_ (zip [1..] failures) $ \x -> do+      formatFailure x+      writeLine ""++    write "Randomized with seed " >> usedSeed >>= writeLine . show+    writeLine ""+  where+    formatFailure :: (Int, FailureRecord) -> FormatM ()+    formatFailure (n, FailureRecord mLoc path reason) = do+      forM_ mLoc $ \loc -> do+        withInfoColor $ writeLine (formatLoc loc)+      write ("  " ++ show n ++ ") ")+      writeLine (formatRequirement path)+      case reason of+        NoReason -> pass+        Reason err -> withFailColor $ indent err+        ExpectedButGot preface expected actual -> do+          mapM_ indent preface++          b <- useDiff++          let threshold = 2 :: Seconds++          mchunks <- liftIO $ if b+            then timeout threshold (evaluate $ diff Nothing expected actual)+            else return Nothing++          case mchunks of+            Just chunks -> do+              writeDiff chunks extraChunk missingChunk+            Nothing -> do+              writeDiff [First expected, Second actual] write write+          where+            indented output text = case break (== '\n') text of+              (xs, "") -> output xs+              (xs, _ : ys) -> output (xs ++ "\n") >> write (indentation ++ "          ") >> indented output ys++            writeDiff chunks extra missing = do+              withFailColor $ write (indentation ++ "expected: ")+              forM_ chunks $ \ case+                Both a -> indented write a+                First a -> indented extra a+                Second _ -> pass+                Omitted _ -> pass+              writeLine ""++              withFailColor $ write (indentation ++ " but got: ")+              forM_ chunks $ \ case+                Both a -> indented write a+                First _ -> pass+                Second a -> indented missing a+                Omitted _ -> pass+              writeLine ""++        Error _ e -> withFailColor . indent $ (("uncaught exception: " ++) . formatException) e++      writeLine ""+      writeLine ("  To rerun use: --match " ++ show (joinPath path))+      where+        indentation = "       "+        indent message = do+          forM_ (lines message) $ \line -> do+            writeLine (indentation ++ line)+        formatLoc (Location file line column) = "  " ++ file ++ ":" ++ show line ++ ":" ++ show column ++ ": "++defaultFooter :: FormatM ()+defaultFooter = do++  writeLine =<< (++)+    <$> (printf "Finished in %1.4f seconds" <$> getRealTime)+    <*> (maybe "" (printf ", used %1.4f seconds of CPU time") <$> getCPUTime)++  fails   <- getFailCount+  pending <- getPendingCount+  total   <- getTotalCount++  let+    output =+         pluralize total   "example"+      ++ ", " ++ pluralize fails "failure"+      ++ if pending == 0 then "" else ", " ++ show pending ++ " pending"+    c | fails /= 0   = withFailColor+      | pending /= 0 = withPendingColor+      | otherwise    = withSuccessColor+  c $ writeLine output
src/Test/Hspec/Core/Formatters/V1/Monad.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ExistentialQuantification #-} module Test.Hspec.Core.Formatters.V1.Monad (   Formatter(..)@@ -48,7 +47,14 @@  import           Test.Hspec.Core.Formatters.V1.Free import           Test.Hspec.Core.Clock-import           Test.Hspec.Core.Format+import           Test.Hspec.Core.Format hiding (FailureReason)++data FailureReason =+    NoReason+  | Reason String+  | ExpectedButGot (Maybe String) String String+  | Error (Maybe String) SomeException+  deriving Show  data Formatter = Formatter {
src/Test/Hspec/Core/Formatters/V2.hs view
@@ -1,11 +1,14 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} -- |--- Stability: experimental+-- Stability: unstable ----- This module contains formatters that can be used with--- `Test.Hspec.Core.Runner.hspecWith`.-module Test.Hspec.Core.Formatters.V2 (-+-- This is an unstable API.  Use+-- [Test.Hspec.Api.Formatters.V3](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Formatters-V3.html)+-- instead.+module Test.Hspec.Core.Formatters.V2+-- {-# WARNING "Use [Test.Hspec.Api.Formatters.V3](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Formatters-V3.html) instead." #-}+( -- * Formatters   silent , checks@@ -81,6 +84,7 @@  import           Prelude () import           Test.Hspec.Core.Compat hiding (First)+import           System.IO (hFlush, stdout)  import           Data.Char import           Test.Hspec.Core.Util@@ -153,7 +157,7 @@ checks :: Formatter checks = specdoc {   formatterProgress = \(nesting, requirement) p -> do-    writeTransient $ indentationFor nesting ++ requirement ++ " [" ++ (formatProgress p) ++ "]"+    writeTransient $ indentationFor nesting ++ requirement ++ " [" ++ formatProgress p ++ "]"  , formatterItemStarted = \(nesting, requirement) -> do     writeTransient $ indentationFor nesting ++ requirement ++ " [ ]"@@ -242,10 +246,12 @@  progress :: Formatter progress = failed_examples {-  formatterItemDone = \ _ item -> case itemResult item of-    Success{} -> withSuccessColor $ write "."-    Pending{} -> withPendingColor $ write "."-    Failure{} -> withFailColor $ write "F"+  formatterItemDone = \ _ item -> do+    case itemResult item of+      Success{} -> withSuccessColor $ write "."+      Pending{} -> withPendingColor $ write "."+      Failure{} -> withFailColor $ write "F"+    liftIO $ hFlush stdout }  failed_examples :: Formatter@@ -280,6 +286,7 @@       case reason of         NoReason -> pass         Reason err -> withFailColor $ indent err+        ColorizedReason err -> indent err         ExpectedButGot preface expected_ actual_ -> do           pretty <- prettyPrintFunction           let@@ -319,7 +326,7 @@             writeChunks :: String -> [Chunk] -> (String -> FormatM ()) -> FormatM ()             writeChunks pre chunks colorize = do               withFailColor $ write (indentation ++ pre)-              forM_ (indentChunks indentation_ chunks) $ \ chunk -> case chunk of+              forM_ (indentChunks indentation_ chunks) $ \ case                 PlainChunk a -> write a                 ColorChunk a -> colorize a                 Informational a -> withInfoColor $ write a@@ -345,14 +352,14 @@   deriving (Eq, Show)  expectedChunks :: [Diff] -> [Chunk]-expectedChunks = mapMaybe $ \ chunk -> case chunk of+expectedChunks = mapMaybe $ \ case   Both a -> Just $ Original a   First a -> Just $ Modified a   Second _ -> Nothing   Omitted n -> Just $ OmittedLines n  actualChunks :: [Diff] -> [Chunk]-actualChunks = mapMaybe $ \ chunk -> case chunk of+actualChunks = mapMaybe $ \ case   Both a -> Just $ Original a   First _ -> Nothing   Second a -> Just $ Modified a@@ -361,12 +368,34 @@ data ColorChunk = PlainChunk String | ColorChunk String | Informational String   deriving (Eq, Show) +data StartsWith = StartsWithNewline | StartsWithNonNewline+  deriving Eq+ indentChunks :: String -> [Chunk] -> [ColorChunk]-indentChunks indentation = concatMap $ \ chunk -> case chunk of-  Original y -> [indentOriginal indentation y]-  Modified y -> indentModified indentation y-  OmittedLines n -> [Informational $ "@@ " <> show n <> " lines omitted @@\n" <> indentation]+indentChunks indentation = go+  where+    go :: [Chunk] -> [ColorChunk]+    go = \ case+      Original x : xs -> indentOriginal indentation x : go xs+      Modified x : xs -> indentModified (startsWith xs) indentation x ++ go xs+      OmittedLines n : xs -> Informational (formatOmittedLines n) : go xs+      [] -> [] +    startsWith :: [Chunk] -> StartsWith+    startsWith xs+      | all isSpace (takeWhile (/= '\n') $ unChunks xs) = StartsWithNewline+      | otherwise = StartsWithNonNewline++    unChunks :: [Chunk] -> String+    unChunks = \ case+      Original x : xs -> x ++ unChunks xs+      Modified x : xs -> x ++ unChunks xs+      OmittedLines {} : _ -> ""+      [] -> ""++    formatOmittedLines :: Int -> String+    formatOmittedLines n = "@@ " <> show n <> " lines omitted @@\n" <> indentation+ indentOriginal :: String -> String -> ColorChunk indentOriginal indentation = PlainChunk . go   where@@ -374,18 +403,21 @@       (xs, _ : ys) -> xs ++ "\n" ++ indentation ++ go ys       (xs, "") -> xs -indentModified :: String -> String -> [ColorChunk]-indentModified indentation = go+indentModified :: StartsWith -> String -> String -> [ColorChunk]+indentModified nextChunk indentation = go   where-    go text = case text of+    go :: String -> [ColorChunk]+    go = \ case+      "" -> []       "\n" -> [PlainChunk "\n", ColorChunk indentation]       '\n' : ys@('\n' : _) -> PlainChunk "\n" : ColorChunk indentation : go ys-      _ -> case break (== '\n') text of-        (xs, _ : ys) -> segment xs ++ PlainChunk ('\n' : indentation) : go ys-        (xs, "") -> segment xs+      '\n' : xs -> PlainChunk ('\n' : indentation) : go xs+      text -> case break (== '\n') text of+        (xs, "") | nextChunk == StartsWithNonNewline -> [ColorChunk xs]+        (xs, ys) -> segment xs ++ go ys +    segment :: String -> [ColorChunk]     segment xs = case span isSpace $ reverse xs of-      ("", "") -> []       ("", _) -> [ColorChunk xs]       (_, "") -> [ColorChunk xs]       (ys, zs) -> [ColorChunk (reverse zs), ColorChunk (reverse ys)]
src/Test/Hspec/Core/Runner.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-deprecations #-} {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -5,6 +6,17 @@ -- | -- Stability: provisional module Test.Hspec.Core.Runner (+-- * Simple interface+  hspec+, hspecWith+, hspecResult+, hspecWithResult++-- ** Summary+, Summary (..)+, isSuccess+, evaluateSummary+ -- * Running a spec {- | To run a spec `hspec` performs a sequence of steps:@@ -17,7 +29,8 @@ The four primitives `evalSpec`, `readConfig`, `runSpecForest` and `evaluateResult` each perform one of these steps respectively. -`hspec` is defined in terms of these primitives:+`hspec` is defined in terms of these primitives. Loosely speaking, a definition+for @hspec@ is:  @ hspec = `evalSpec` `defaultConfig` >=> \\ (config, spec) ->@@ -27,54 +40,50 @@   >>= `evaluateResult` @ -If you need more control over how a spec is run use these primitives individually.+Loosely speaking in the sense that this definition of @hspec@ ignores+@--rerun-all-on-success@. +Using these primitives individually gives you more control over how a spec is+run.  However, if you need support for @--rerun-all-on-success@ then you should+try hard to solve your use case with one of `hspec`, `hspecWith`, `hspecResult`+or `hspecWithResult`.+ -}-  hspec , evalSpec , runSpecForest , evaluateResult --- * Config-, Config (..)-, ColorMode (..)-, UnicodeMode(..)-, Path-, defaultConfig-, registerFormatter-, registerDefaultFormatter-, configAddFilter-, readConfig---- * Result+-- ** Result --- ** Spec Result+-- *** Spec Result , Test.Hspec.Core.Runner.Result.SpecResult , Test.Hspec.Core.Runner.Result.specResultItems , Test.Hspec.Core.Runner.Result.specResultSuccess+, toSummary --- ** Result Item+-- *** 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+-- *** Result Item Status , Test.Hspec.Core.Runner.Result.ResultItemStatus(..) +-- * Config+, Config (..)+, ColorMode (..)+, UnicodeMode(..)+, Path+, defaultConfig+, registerFormatter+, registerDefaultFormatter+, configAddFilter+, readConfig+ -- * Legacy--- | The following primitives are deprecated.  Use `runSpecForest` instead.-, hspecWith-, hspecResult-, hspecWithResult , runSpec --- ** Summary-, Summary (..)-, toSummary-, isSuccess-, evaluateSummary- -- * Re-exports , Spec , SpecWith@@ -106,6 +115,7 @@ import           Test.Hspec.Core.Util (Path) import           Test.Hspec.Core.Clock import           Test.Hspec.Core.Spec hiding (pruneTree, pruneForest)+import           Test.Hspec.Core.Tree (formatDefaultDescription) import           Test.Hspec.Core.Config import           Test.Hspec.Core.Format (Format, FormatConfig(..)) import qualified Test.Hspec.Core.Formatters.V1 as V1@@ -115,7 +125,7 @@ import           Test.Hspec.Core.Shuffle  import           Test.Hspec.Core.Runner.PrintSlowSpecItems-import           Test.Hspec.Core.Runner.Eval hiding (Tree(..))+import           Test.Hspec.Core.Runner.Eval hiding (ColorMode(..), Tree(..)) import qualified Test.Hspec.Core.Runner.Eval as Eval import           Test.Hspec.Core.Runner.Result @@ -124,6 +134,7 @@ -- -- @since 2.10.5 registerFormatter :: (String, FormatConfig -> IO Format) -> Config -> Config+{-# DEPRECATED registerFormatter "Use [@registerFormatter@](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Format-V2.html#v:registerFormatter) instead." #-} registerFormatter formatter config = config { configAvailableFormatters = formatter : configAvailableFormatters config }  -- |@@ -131,6 +142,7 @@ -- -- @since 2.10.5 registerDefaultFormatter :: (String, FormatConfig -> IO Format) -> Config -> Config+{-# DEPRECATED registerDefaultFormatter "Use [@useFormatter@](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Format-V2.html#v:useFormatter) instead." #-} registerDefaultFormatter formatter@(_, format) config = (registerFormatter formatter config) { configFormat = Just format }  applyFilterPredicates :: Config -> [Tree c EvalItem] -> [Tree c EvalItem]@@ -277,26 +289,48 @@ mapItem :: (Item a -> Item b) -> [SpecTree a] -> [SpecTree b] mapItem f = map (fmap f) +mapItemIf :: (Item a -> Bool) -> (Item a -> Item a) -> [SpecTree a] -> [SpecTree a]+mapItemIf p f = mapItem $ \ item -> if p item then f item else item++addDefaultDescriptions :: [SpecTree a] -> [SpecTree a]+addDefaultDescriptions = mapItem addDefaultDescription+  where+    addDefaultDescription :: Item a -> Item a+    addDefaultDescription item+      | null (itemRequirement item) = item { itemRequirement = defaultRequirement }+      | otherwise = item+      where+        defaultRequirement = maybe "(unspecified behavior)" formatDefaultDescription (itemLocation item)++failItemsWithEmptyDescription :: Config -> [SpecTree a] -> [SpecTree a]+failItemsWithEmptyDescription config+  | configFailOnEmptyDescription config = mapItemIf condition (failWith failure)+  | otherwise = id+  where+    condition = null . itemRequirement+    failure = "item has no description; failing due to --fail-on=empty-description"+ failFocusedItems :: Config -> [SpecTree a] -> [SpecTree a] failFocusedItems config-  | configFailOnFocused config = mapItem failFocused+  | configFailOnFocused config = mapItemIf condition (failWith failure)   | otherwise = id+  where+    condition = itemIsFocused+    failure = "item is focused; failing due to --fail-on=focused" -failFocused :: forall a. Item a -> Item a-failFocused item = item {itemExample = example}+failWith :: forall a. String -> Item a -> Item a+failWith reason item = item {itemExample = example}   where     failure :: ResultStatus-    failure = Failure Nothing (Reason "item is focused; failing due to --fail-on=focused")+    failure = Failure Nothing (Reason reason)      example :: Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result-    example-      | itemIsFocused item = \ params hook p -> do-          Result info status <- itemExample item params hook p-          return $ Result info $ case status of-            Success -> failure-            Pending _ _ -> failure-            Failure{} -> status-      | otherwise = itemExample item+    example params hook p = do+      Result info status <- itemExample item params hook p+      return $ Result info $ case status of+        Success -> failure+        Pending _ _ -> failure+        Failure{} -> status  failPendingItems :: Config -> [SpecTree a] -> [SpecTree a] failPendingItems config@@ -365,6 +399,7 @@         evalConfigFormat = format       , evalConfigConcurrentJobs = concurrentJobs       , evalConfigFailFast = configFailFast config+      , evalConfigColorMode = bool Eval.ColorDisabled Eval.ColorEnabled (shouldUseColor colorMode)       }     runFormatter evalConfig filteredSpec @@ -378,7 +413,9 @@  specToEvalForest :: Config -> [SpecTree ()] -> [EvalTree] specToEvalForest config =-      failFocusedItems config+      failItemsWithEmptyDescription config+  >>> addDefaultDescriptions+  >>> failFocusedItems config   >>> failPendingItems config   >>> focusSpec config   >>> toEvalItemForest params
src/Test/Hspec/Core/Runner/Eval.hs view
@@ -1,11 +1,10 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ConstraintKinds #-} module Test.Hspec.Core.Runner.Eval (   EvalConfig(..)+, ColorMode(..) , EvalTree , Tree(..) , EvalItem(..)@@ -47,8 +46,11 @@   evalConfigFormat :: Format , evalConfigConcurrentJobs :: Int , evalConfigFailFast :: Bool+, evalConfigColorMode :: ColorMode } +data ColorMode = ColorDisabled | ColorEnabled+ data Env = Env {   envConfig :: EvalConfig , envFailed :: IORef Bool@@ -98,12 +100,22 @@  reportResult :: Path -> Maybe Location -> (Seconds, Result) -> EvalM () reportResult path loc (duration, result) = do+  mode <- asks (evalConfigColorMode . envConfig)   case result of     Result info status -> reportItemDone path $ Format.Item loc duration info $ case status of       Success                      -> Format.Success       Pending loc_ reason          -> Format.Pending loc_ reason       Failure loc_ err@(Error _ e) -> Format.Failure (loc_ <|> extractLocation e) err-      Failure loc_ err             -> Format.Failure loc_ err+      Failure loc_ err             -> Format.Failure loc_ $ case mode of+        ColorEnabled -> err+        ColorDisabled -> case err of+          NoReason -> err+          Reason _ -> err+          ExpectedButGot _ _ _ -> err+          ColorizedReason r -> Reason (stripAnsi r)+#if __GLASGOW_HASKELL__ < 900+          Error _ _ -> err+#endif  groupStarted :: Path -> EvalM () groupStarted = formatEvent . Format.GroupStarted@@ -121,7 +133,7 @@ type EvalTree = Tree (IO ()) EvalItem  -- | Evaluate all examples of a given spec and produce a report.-runFormatter :: EvalConfig -> [EvalTree] -> IO ([(Path, Format.Item)])+runFormatter :: EvalConfig -> [EvalTree] -> IO [(Path, Format.Item)] runFormatter config specs = do   withJobQueue (evalConfigConcurrentJobs config) $ \ queue -> do     withTimer 0.05 $ \ timer -> do
src/Test/Hspec/Core/Runner/JobQueue.hs view
@@ -2,11 +2,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ConstraintKinds #-} -#if MIN_VERSION_base(4,6,0) && !MIN_VERSION_base(4,7,0)--- Control.Concurrent.QSem is deprecated in base-4.6.0.*-{-# OPTIONS_GHC -fno-warn-deprecations #-}-#endif- module Test.Hspec.Core.Runner.JobQueue (   MonadIO , Job
src/Test/Hspec/Core/Runner/PrintSlowSpecItems.hs view
@@ -7,6 +7,8 @@ import           Prelude () import           Test.Hspec.Core.Compat +import           System.IO (stderr, hPutStrLn)+ import           Test.Hspec.Core.Util import           Test.Hspec.Core.Format @@ -26,7 +28,7 @@     Done items -> do       let xs = slowItems n $ map toSlowItem items       unless (null xs) $ do-        putStrLn "\nSlow spec items:"+        hPutStrLn stderr "\nSlow spec items:"         mapM_ printSlowSpecItem xs     _ -> pass @@ -38,4 +40,4 @@  printSlowSpecItem :: SlowItem -> IO () printSlowSpecItem SlowItem{..} = do-  putStrLn $ "  " ++ maybe "" formatLocation location ++ joinPath path ++ " (" ++ show duration ++ "ms)"+  hPutStrLn stderr $ "  " ++ maybe "" formatLocation location ++ joinPath path ++ " (" ++ show duration ++ "ms)"
src/Test/Hspec/Core/Tree.hs view
@@ -22,12 +22,15 @@ , location -- END RE-EXPORTED from Test.Hspec.Core.Spec , callSite+, formatDefaultDescription+, toModuleName ) where  import           Prelude () import           Test.Hspec.Core.Compat -import           Data.CallStack (SrcLoc(..))+import           Data.Char+import           System.FilePath import qualified Data.CallStack as CallStack  import           Test.Hspec.Core.Example@@ -121,23 +124,18 @@   where     msg :: HasCallStack => String     msg-      | null s = fromMaybe "(no description given)" defaultDescription+      | null s = maybe "(no description given)" formatDefaultDescription location       | otherwise = s  -- | The @specItem@ function creates a spec item. specItem :: (HasCallStack, Example e) => String -> e -> SpecTree (Arg e) specItem s e = Leaf Item {-    itemRequirement = requirement+    itemRequirement = s   , itemLocation = location   , itemIsParallelizable = Nothing   , itemIsFocused = False   , itemExample = safeEvaluateExample e   }-  where-    requirement :: HasCallStack => String-    requirement-      | null s = fromMaybe "(unspecified behavior)" defaultDescription-      | otherwise = s  location :: HasCallStack => Maybe Location location = snd <$> callSite@@ -145,7 +143,16 @@ callSite :: HasCallStack => Maybe (String, Location) callSite = fmap toLocation <$> CallStack.callSite -defaultDescription :: HasCallStack => Maybe String-defaultDescription = case CallStack.callSite of-  Just (_, loc) -> Just (srcLocModule loc ++ "[" ++ show (srcLocStartLine loc) ++ ":" ++ show (srcLocStartCol loc) ++ "]")-  Nothing -> Nothing+formatDefaultDescription :: Location -> String+formatDefaultDescription loc = toModuleName (locationFile loc) ++ "[" ++ show (locationLine loc) ++ ":" ++ show (locationColumn loc) ++ "]"++toModuleName :: FilePath -> String+toModuleName = intercalate "." . reverse . takeWhile isModuleNameComponent . reverse . splitDirectories . dropExtension++isModuleNameComponent :: String -> Bool+isModuleNameComponent name = case name of+  x : xs -> isUpper x && all isIdChar xs+  _ -> False++isIdChar :: Char -> Bool+isIdChar c = isAlphaNum c || c == '_' || c == '\''
src/Test/Hspec/Core/Util.hs view
@@ -1,9 +1,11 @@+{-# LANGUAGE  ViewPatterns #-} -- | Stability: unstable module Test.Hspec.Core.Util ( -- * String functions   pluralize , strip , lineBreaksAt+, stripAnsi  -- * Working with paths , Path@@ -68,6 +70,18 @@         if length r <= n           then go (r, ys)           else s : go (y, ys)++-- |+-- Remove ANSI color escape sequences.+--+-- @since 2.11.0+stripAnsi :: String -> String+stripAnsi = go+  where+    go input = case input of+      '\ESC' : '[' : (dropWhile (`elem` "0123456789;") -> 'm' : xs) -> go xs+      x : xs -> x : go xs+      [] -> []  -- | -- A `Path` describes the location of a spec item within a spec tree.
test/Helper.hs view
@@ -23,6 +23,7 @@ , throwException_  , withEnvironment+, withTempDirectory , inTempDirectory  , hspecSilent@@ -36,19 +37,23 @@ , workaroundForIssue19236  , replace++, red+, green+, colorize ) where  import           Prelude () import           Test.Hspec.Core.Compat  import           Data.Char-import           System.Environment (withArgs, getEnvironment)+import           System.Environment (withArgs, getEnvironment, setEnv, unsetEnv) import           System.Exit import           System.IO.Silently-import           System.SetEnv import           System.FilePath import           System.Directory-import           System.IO.Temp+import           System.IO.Temp (withSystemTempDirectory)+import           System.Console.ANSI  import           Test.Hspec.Meta hiding (hspec, hspecResult, pending, pendingWith) import           Test.QuickCheck hiding (Result(..))@@ -174,20 +179,28 @@       forM_ env (unsetEnv . fst)       return env +withTempDirectory :: (FilePath -> IO a) -> IO a+withTempDirectory = withSystemTempDirectory "hspec"+ inTempDirectory :: IO a -> IO a-inTempDirectory action = withSystemTempDirectory "mockery" $ \path -> do+inTempDirectory action = withTempDirectory $ \path -> do   bracket getCurrentDirectory setCurrentDirectory $ \_ -> do     setCurrentDirectory path     action  mkLocation :: FilePath -> Int -> Int -> Maybe Location-#if MIN_VERSION_base(4,8,1) mkLocation file line column = Just (Location (workaroundForIssue19236 file) line column)-#else-mkLocation _ _ _ = Nothing-#endif  replace :: Eq a => a -> a -> [a] -> [a] replace x y xs = case break (== x) xs of   (ys, _: zs) -> ys ++ y : zs   _ -> xs++green :: String -> String+green = colorize Foreground Green++red :: String -> String+red = colorize Foreground Red++colorize :: ConsoleLayer -> Color -> String -> String+colorize layer color text = setSGRCode [SetColor layer Dull color] <> text <> setSGRCode [Reset]
test/Test/Hspec/Core/CompatSpec.hs view
@@ -4,7 +4,7 @@ import           Prelude () import           Helper -import           System.SetEnv+import           System.Environment import           Data.Typeable  data SomeType = SomeType
test/Test/Hspec/Core/ConfigSpec.hs view
@@ -23,8 +23,8 @@     it "reads .hspec" $ do       dir <- getCurrentDirectory       let name = dir </> ".hspec"-      writeFile name "--diff"-      readConfigFiles `shouldReturn` [(name, ["--diff"])]+      writeFile name "--diff --foo 'bar baz'"+      readConfigFiles `shouldReturn` [(name, ["--diff", "--foo", "bar baz"])]  #ifndef mingw32_HOST_OS     it "reads ~/.hspec" $ do
test/Test/Hspec/Core/Formatters/InternalSpec.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-deprecations #-} module Test.Hspec.Core.Formatters.InternalSpec (spec) where  import           Prelude ()@@ -25,9 +26,6 @@ , formatConfigExpectedTotalCount = 0 } -green :: String -> String-green text = setSGRCode [SetColor Foreground Dull Green] <> text <> setSGRCode [Reset]- spec :: Spec spec = do   forM_ [@@ -35,25 +33,23 @@     , ("missingChunk", missingChunk, Green)     ] $ \ (name, chunk, color) -> do -    let colorize layer text = setSGRCode [SetColor layer Dull color] <> text <> setSGRCode [Reset]-     describe name $ do       it "colorizes chunks" $ do         capture_ $ runFormatM formatConfig $ do           chunk "foo"-        `shouldReturn` colorize Foreground "foo"+        `shouldReturn` colorize Foreground color "foo"        context "with an all-spaces chunk" $ do         it "colorizes background" $ do           capture_ $ runFormatM formatConfig $ do             chunk "  "-          `shouldReturn` colorize Background "  "+          `shouldReturn` colorize Background color "  "        context "with an all-newlines chunk" $ do         it "colorizes background" $ do           capture_ $ runFormatM formatConfig $ do             chunk "\n\n\n"-          `shouldReturn` colorize Background "\n\n\n"+          `shouldReturn` colorize Background color "\n\n\n"    describe "write" $ do     it "does not span colored output over multiple lines" $ do
test/Test/Hspec/Core/Formatters/V1Spec.hs view
@@ -1,16 +1,17 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-} module Test.Hspec.Core.Formatters.V1Spec (spec) where  import           Prelude ()-import           Helper+import           Helper hiding (colorize) import           Data.String import           Control.Monad.IO.Class import           Control.Monad.Trans.Writer hiding (pass)  import qualified Test.Hspec.Core.Spec as H import qualified Test.Hspec.Core.Runner as H-import qualified Test.Hspec.Core.Formatters.V1 as H+import qualified Test.Hspec.Core.Formatters.V1 as H hiding (FailureReason(..)) import qualified Test.Hspec.Core.Formatters.V1.Monad as H (interpretWith) import           Test.Hspec.Core.Formatters.V1.Monad (FormatM, Environment(..), FailureRecord(..), FailureReason(..))
test/Test/Hspec/Core/Formatters/V2Spec.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-deprecations #-} module Test.Hspec.Core.Formatters.V2Spec (spec) where  import           Prelude ()@@ -59,19 +60,46 @@         indentChunks "  " [Modified "foo"] `shouldBe` [ColorChunk "foo"]        it "indents multi-line input" $ do-        indentChunks "  " [Modified "foo\nbar\nbaz\n"] `shouldBe` [ColorChunk "foo", PlainChunk "\n  ", ColorChunk "bar", PlainChunk "\n  ", ColorChunk "baz", PlainChunk "\n  "]+        indentChunks "  " [Modified "foo\nbar\nbaz\n"] `shouldBe` [ColorChunk "foo", PlainChunk "\n  ", ColorChunk "bar", PlainChunk "\n  ", ColorChunk "baz", PlainChunk "\n", ColorChunk "  "]        it "colorizes whitespace-only input" $ do         indentChunks "  " [Modified "  "] `shouldBe` [ColorChunk "  "]        it "colorizes whitespace-only lines" $ do-        indentChunks "  " [Modified "foo\n  \n"] `shouldBe` [ColorChunk "foo", PlainChunk "\n  ", ColorChunk "  ", PlainChunk "\n  "]+        indentChunks "  " [Modified "foo\n  \n"] `shouldBe` [ColorChunk "foo", PlainChunk "\n  ", ColorChunk "  ", PlainChunk "\n", ColorChunk "  "]        it "colorizes whitespace at the end of the input" $ do         indentChunks "  " [Modified "foo\n  "] `shouldBe` [ColorChunk "foo", PlainChunk "\n  ", ColorChunk "  "]        it "splits off whitespace-only segments at the end of a line so that they get colorized" $ do-        indentChunks "  " [Modified "foo  \n"] `shouldBe` [ColorChunk "foo", ColorChunk "  ", PlainChunk "\n  "]+        indentChunks "  " [Modified "foo  \n"] `shouldBe` [ColorChunk "foo", ColorChunk "  ", PlainChunk "\n", ColorChunk "  "]++      it "splits off whitespace-only segments at the end of the input so that they get colorized" $ do+        indentChunks "  " [Modified "23 "] `shouldBe` [ColorChunk "23", ColorChunk " "]++      context "when next chunk starts with a newline" $ do+        it "splits off whitespace-only segments at the end of a chunk so that they get colorized" $ do+          indentChunks "  " [Modified "23 ", Original "\nbar"] `shouldBe` [ColorChunk "23", ColorChunk " ", PlainChunk "\n  bar"]++      context "when next chunk starts with spaces followed by a newline" $ do+        it "splits off whitespace-only segments at the end of a chunk so that they get colorized" $ do+          indentChunks "  " [Modified "23 ", Original "   \nbar"] `shouldBe` [ColorChunk "23", ColorChunk " ", PlainChunk "   \n  bar"]++      context "when all following chunks only consist of whitespace characters" $ do+        it "splits off whitespace-only segments at the end of a chunk so that they get colorized" $ do+          indentChunks "  " [Modified "23 ", Original "  ", Original "  "] `shouldBe` [ColorChunk "23", ColorChunk " ", PlainChunk "  ", PlainChunk "  "]++      context "when all following chunks only consist of whitespace characters until the next newline is encountered" $ do+        it "splits off whitespace-only segments at the end of a chunk so that they get colorized" $ do+          indentChunks "  " [Modified "23 ", Original " ", Modified " ", Original "\n"] `shouldBe` [ColorChunk "23", ColorChunk " ", PlainChunk " ", ColorChunk " ", PlainChunk "\n  "]++      context "when next chunk starts with a non-whitespace character" $ do+        it "does not split off whitespace-only segments at the end of a chunk" $ do+          indentChunks "  " [Modified "23 ", Original "bar"] `shouldBe` [ColorChunk "23 ", PlainChunk "bar"]++      context "when all following chunks only consist of non-newline characters until the next non-whitespace character is encountered" $ do+        it "does not split off whitespace-only segments at the end of a chunk" $ do+          indentChunks "  " [Modified "23 ", Original "  ", Original " bar"] `shouldBe` [ColorChunk "23 ", PlainChunk "  ", PlainChunk " bar"]        context "with empty lines" $ do         it "colorizes indentation" $ do
test/Test/Hspec/Core/HooksSpec.hs view
@@ -24,6 +24,7 @@       evalConfigFormat = \ _ -> pass     , evalConfigConcurrentJobs = 1     , evalConfigFailFast = False+    , evalConfigColorMode = ColorEnabled     }     normalize = map $ \ (path, item) -> (pathToList path, normalizeItem item)     normalizeItem item = item {@@ -666,17 +667,9 @@     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) -#if MIN_VERSION_base(4,8,1)     exceptionIn name = Just ("exception in " <> name <> "-hook (see previous failure)")-#else-    exceptionIn _ = Just "exception in beforeAll-hook (see previous failure)"-#endif
test/Test/Hspec/Core/Runner/EvalSpec.hs view
@@ -49,7 +49,7 @@ spec = do   describe "mergeResults" $ do     it "gives failures from items precedence" $ do-      forAll failureResult $ \ item -> \ hook -> do+      forAll failureResult $ \ item hook -> do         mergeResults Nothing item hook `shouldBe` item      it "gives failures from hooks precedence over succeeding items" $ do
test/Test/Hspec/Core/Runner/PrintSlowSpecItemsSpec.hs view
@@ -1,9 +1,10 @@-{-# LANGUAGE RecordWildCards #-} module Test.Hspec.Core.Runner.PrintSlowSpecItemsSpec (spec) where  import           Prelude () import           Helper +import           System.IO (stderr)+ import           Test.Hspec.Core.Format import           Test.Hspec.Core.Runner.PrintSlowSpecItems @@ -25,9 +26,12 @@ spec :: Spec spec = do   describe "printSlowSpecItems" $ do-    let format = printSlowSpecItems 2 $ \ _ -> pass+    let+      format = printSlowSpecItems 2 $ \ _ -> pass+      run = hCapture_ [stderr] . format . Done+     it "prints slow spec items" $ do-      capture_ $ format $ Done [+      run [             ((["foo", "bar"], "one"), item {itemDuration = 0.100})           , ((["foo", "bar"], "two"), item {itemDuration = 0.500})           , ((["foo", "bar"], "thr"), item {itemDuration = 0.050})@@ -41,5 +45,5 @@      context "when there are no slow items" $ do       it "prints nothing" $ do-        capture_ $ format $ Done [((["foo", "bar"], "one"), item {itemDuration = 0})]+        run [((["foo", "bar"], "one"), item {itemDuration = 0})]         `shouldReturn` ""
test/Test/Hspec/Core/RunnerSpec.hs view
@@ -1,25 +1,17 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}--#if MIN_VERSION_base(4,6,0) && !MIN_VERSION_base(4,7,0)--- Control.Concurrent.QSem is deprecated in base-4.6.0.*-{-# OPTIONS_GHC -fno-warn-deprecations #-}-#endif- module Test.Hspec.Core.RunnerSpec (spec) where  import           Prelude () import           Helper  import           System.IO-import           System.Environment (withArgs, withProgName, getArgs)+import           System.Environment (withArgs, withProgName, getArgs, setEnv, unsetEnv) import           System.Exit import           Control.Concurrent import           Control.Concurrent.Async import           Mock-import           System.SetEnv-import           System.Console.ANSI  import           Test.Hspec.Core.FailureReport (FailureReport(..)) import qualified Test.Hspec.Expectations as H@@ -332,6 +324,30 @@           , "1 example, 1 failure"           ] +    context "with --fail-on=empty-description" $ do+      let run = captureLines . ignoreExitCode . withArgs ["--fail-on=empty-description", "--seed", "23"] . H.hspec . removeLocations+      it "fails on items with empty requirement" $ do+        r <- run $ do+          H.it "foo" True+          H.it "" True+        normalizeSummary r `shouldBe` [+            ""+          , "foo [✔]"+          , "(unspecified behavior) [✘]"+          , ""+          , "Failures:"+          , ""+          , "  1) (unspecified behavior)"+          , "       item has no description; failing due to --fail-on=empty-description"+          , ""+          , "  To rerun use: --match \"/(unspecified behavior)/\""+          , ""+          , "Randomized with seed 23"+          , ""+          , "Finished in 0.0000 seconds"+          , "2 examples, 1 failure"+          ]+     context "with --fail-on=pending" $ do       let run = captureLines . ignoreExitCode . withArgs ["--fail-on=pending", "--seed", "23"] . H.hspec . removeLocations       it "fails on pending spec items" $ do@@ -516,14 +532,60 @@           , "        but got: Person {personName = \"Joe\", personAge = 23}"           ] +    let+      resultWithColorizedReason :: H.Result+      resultWithColorizedReason = H.Result {+          H.resultInfo = "info"+        , H.resultStatus = H.Failure Nothing . H.ColorizedReason $ "some " <> green "colorized" <> " error message"+        }++    context "with --color" $ do+      it "outputs ColorizedReason" $ do+        r <- capture_ . ignoreExitCode . withArgs ["--seed=0", "--format=failed-examples", "--color"] . H.hspec . removeLocations $ do+          H.it "foo" resultWithColorizedReason+        normalizeSummary (lines r) `shouldBe` [+            "\ESC[?25l"+          , "Failures:"+          , ""+          , "  1) foo"+          , "       some " ++ green "colorized" ++ " error message"+          , ""+          , "  To rerun use: --match \"/foo/\""+          , ""+          , "Randomized with seed 0"+          , ""+          , "Finished in 0.0000 seconds"+          , red "1 example, 1 failure"+          , "\ESC[?25h"+          ]++    context "with --no-color" $ do+      it "strips ANSI sequences from ColorizedReason" $ do+        r <- capture_ . ignoreExitCode . withArgs ["--seed=0", "--format=failed-examples", "--no-color"] . H.hspec . removeLocations $ do+          H.it "foo" resultWithColorizedReason+        normalizeSummary (lines r) `shouldBe` [+            ""+          , "Failures:"+          , ""+          , "  1) foo"+          , "       some colorized error message"+          , ""+          , "  To rerun use: --match \"/foo/\""+          , ""+          , "Randomized with seed 0"+          , ""+          , "Finished in 0.0000 seconds"+          , "1 example, 1 failure"+          ]+     context "with --diff" $ do       it "shows colorized diffs" $ do         r <- capture_ . ignoreExitCode . withArgs ["--diff", "--color"] . H.hspec $ do           H.it "foo" $ do             23 `H.shouldBe` (42 :: Int)         r `shouldContain` unlines [-            red ++ "       expected: " ++ reset ++ red ++ "42" ++ reset-          , red ++ "        but got: " ++ reset ++ green ++ "23" ++ reset+            red "       expected: " ++ red "42"+          , red "        but got: " ++ green "23"           ]      context "with --no-diff" $ do@@ -532,8 +594,8 @@           H.it "foo" $ do             23 `H.shouldBe` (42 :: Int)         r `shouldContain` unlines [-            red ++ "       expected: " ++ reset ++ "42"-          , red ++ "        but got: " ++ reset ++ "23"+            red "       expected: " ++ "42"+          , red "        but got: " ++ "23"           ]      context "with --diff-context" $ do@@ -607,7 +669,7 @@      context "with --print-slow-items" $ do       it "prints slow items" $ do-        r <- captureLines . ignoreExitCode . withArgs ["--print-slow-items"] . H.hspec $ do+        r <- fmap lines . hCapture_ [stdout, stderr] . ignoreExitCode . withArgs ["--print-slow-items"] . H.hspec $ do           H.it "foo" $ threadDelay 2000         normalizeTimes (normalizeSummary r) `shouldBe` [             ""@@ -617,11 +679,7 @@           , "1 example, 0 failures"           , ""           , "Slow spec items:"-#if MIN_VERSION_base(4,8,1)-          , "  test" </> "Test" </> "Hspec" </> "Core" </> "RunnerSpec.hs:" <> show (__LINE__ - 10 :: Int) <> ":11: /foo/ (2ms)"-#else-          , "  /foo/ (2ms)"-#endif+          , "  test" </> "Test" </> "Hspec" </> "Core" </> "RunnerSpec.hs:" <> show (__LINE__ - 9 :: Int) <> ":11: /foo/ (2ms)"           ]      context "with --format" $ do@@ -854,7 +912,3 @@     context "on failure" $ do       it "returns False" $ do         H.rerunAll config (Just report) result { specResultSuccess = False } `shouldBe` False-  where-    green  = setSGRCode [SetColor Foreground Dull Green]-    red    = setSGRCode [SetColor Foreground Dull Red]-    reset  = setSGRCode [Reset]
test/Test/Hspec/Core/SpecSpec.hs view
@@ -47,11 +47,7 @@     context "when no description is given" $ do       it "uses a default description" $ do         [Node d _] <- runSpecM (H.describe "" (pure ()))-#if MIN_VERSION_base(4,8,1)-        d `shouldBe` "Test.Hspec.Core.SpecSpec[" ++ show (__LINE__ - 2 :: Int) ++ ":33]"-#else-        d `shouldBe` "(no description given)"-#endif+        d `shouldBe` "Test.Hspec.Core.SpecSpec[" ++ show (pred __LINE__ :: Int) ++ ":33]"    describe "xdescribe" $ do     it "creates a tree of pending spec items" $ do@@ -71,15 +67,6 @@       [Leaf item] <- runSpecM (H.it "foo" True)       let location = mkLocation __FILE__ (pred __LINE__) 32       itemLocation item `shouldBe` location--    context "when no description is given" $ do-      it "uses a default description" $ do-        [Leaf item] <- runSpecM (H.it "" True)-#if MIN_VERSION_base(4,8,1)-        itemRequirement item `shouldBe` "Test.Hspec.Core.SpecSpec[" ++ show (__LINE__ - 2 :: Int) ++ ":34]"-#else-        itemRequirement item `shouldBe` "(unspecified behavior)"-#endif    describe "xit" $ do     it "creates a pending spec item" $ do
+ test/Test/Hspec/Core/TreeSpec.hs view
@@ -0,0 +1,12 @@+module Test.Hspec.Core.TreeSpec (spec) where++import           Prelude ()+import           Helper++import           Test.Hspec.Core.Tree++spec :: Spec+spec = do+  describe "toModuleName" $ do+    it "derives a module name from a FilePath" $ do+      toModuleName "src/Foo/Bar.hs" `shouldBe` "Foo.Bar"
test/Test/Hspec/Core/UtilSpec.hs view
@@ -51,6 +51,10 @@         , "three"         ] +  describe "stripAnsi" $ do+    it "removes ANSI color sequences" $ do+      stripAnsi ("some " <> green "colorized" <> " text") `shouldBe` "some colorized text"+   describe "safeTry" $ do     it "returns Right on success" $ do       Right e <- safeTry (return 23 :: IO Int)
version.yaml view
@@ -1,1 +1,1 @@-&version 2.10.10+&version 2.11.0