hspec-core 2.7.10 → 2.8.0
raw patch · 47 files changed
+1887/−953 lines, 47 files
Files
- hspec-core.cabal +11/−3
- src/Test/Hspec/Core/Clock.hs +8/−1
- src/Test/Hspec/Core/Compat.hs +23/−17
- src/Test/Hspec/Core/Config.hs +7/−3
- src/Test/Hspec/Core/Config/Options.hs +45/−26
- src/Test/Hspec/Core/Config/Util.hs +3/−0
- src/Test/Hspec/Core/Example.hs +3/−1
- src/Test/Hspec/Core/Example/Location.hs +0/−1
- src/Test/Hspec/Core/Format.hs +73/−12
- src/Test/Hspec/Core/Formatters.hs +2/−314
- src/Test/Hspec/Core/Formatters/Diff.hs +0/−1
- src/Test/Hspec/Core/Formatters/Internal.hs +27/−59
- src/Test/Hspec/Core/Formatters/Monad.hs +35/−23
- src/Test/Hspec/Core/Formatters/V1.hs +356/−0
- src/Test/Hspec/Core/Formatters/V2.hs +325/−0
- src/Test/Hspec/Core/Hooks.hs +6/−3
- src/Test/Hspec/Core/QuickCheck.hs +3/−0
- src/Test/Hspec/Core/QuickCheckUtil.hs +0/−1
- src/Test/Hspec/Core/Runner.hs +53/−41
- src/Test/Hspec/Core/Runner/Eval.hs +63/−61
- src/Test/Hspec/Core/Runner/PrintSlowSpecItems.hs +41/−0
- src/Test/Hspec/Core/Shuffle.hs +1/−1
- src/Test/Hspec/Core/Tree.hs +4/−4
- src/Test/Hspec/Core/Util.hs +3/−3
- test/All.hs +1/−0
- test/Helper.hs +9/−1
- test/Spec.hs +3/−0
- test/Test/Hspec/Core/ClockSpec.hs +5/−0
- test/Test/Hspec/Core/CompatSpec.hs +2/−0
- test/Test/Hspec/Core/Config/OptionsSpec.hs +27/−8
- test/Test/Hspec/Core/Config/UtilSpec.hs +1/−0
- test/Test/Hspec/Core/ConfigSpec.hs +2/−0
- test/Test/Hspec/Core/Example/LocationSpec.hs +3/−1
- test/Test/Hspec/Core/ExampleSpec.hs +2/−0
- test/Test/Hspec/Core/FailureReportSpec.hs +1/−0
- test/Test/Hspec/Core/Formatters/V1Spec.hs +308/−0
- test/Test/Hspec/Core/Formatters/V2Spec.hs +340/−0
- test/Test/Hspec/Core/FormattersSpec.hs +0/−314
- test/Test/Hspec/Core/HooksSpec.hs +15/−16
- test/Test/Hspec/Core/QuickCheckUtilSpec.hs +1/−0
- test/Test/Hspec/Core/Runner/PrintSlowSpecItemsSpec.hs +45/−0
- test/Test/Hspec/Core/RunnerSpec.hs +23/−34
- test/Test/Hspec/Core/ShuffleSpec.hs +2/−2
- test/Test/Hspec/Core/TimerSpec.hs +1/−0
- test/Test/Hspec/Core/UtilSpec.hs +2/−0
- vendor/Control/Concurrent/Async.hs +1/−1
- version.yaml +1/−1
hspec-core.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: hspec-core-version: 2.7.10+version: 2.8.0 license: MIT license-file: LICENSE copyright: (c) 2011-2021 Simon Hengel,@@ -54,7 +54,10 @@ Test.Hspec.Core.Spec Test.Hspec.Core.Hooks Test.Hspec.Core.Runner+ Test.Hspec.Core.Format Test.Hspec.Core.Formatters+ Test.Hspec.Core.Formatters.V1+ Test.Hspec.Core.Formatters.V2 Test.Hspec.Core.QuickCheck Test.Hspec.Core.Util other-modules:@@ -66,13 +69,13 @@ Test.Hspec.Core.Example Test.Hspec.Core.Example.Location Test.Hspec.Core.FailureReport- Test.Hspec.Core.Format Test.Hspec.Core.Formatters.Diff Test.Hspec.Core.Formatters.Free Test.Hspec.Core.Formatters.Internal Test.Hspec.Core.Formatters.Monad Test.Hspec.Core.QuickCheckUtil Test.Hspec.Core.Runner.Eval+ Test.Hspec.Core.Runner.PrintSlowSpecItems Test.Hspec.Core.Shuffle Test.Hspec.Core.Spec.Monad Test.Hspec.Core.Timer@@ -130,11 +133,14 @@ Test.Hspec.Core.Formatters.Free Test.Hspec.Core.Formatters.Internal Test.Hspec.Core.Formatters.Monad+ Test.Hspec.Core.Formatters.V1+ Test.Hspec.Core.Formatters.V2 Test.Hspec.Core.Hooks Test.Hspec.Core.QuickCheck Test.Hspec.Core.QuickCheckUtil Test.Hspec.Core.Runner Test.Hspec.Core.Runner.Eval+ Test.Hspec.Core.Runner.PrintSlowSpecItems Test.Hspec.Core.Shuffle Test.Hspec.Core.Spec Test.Hspec.Core.Spec.Monad@@ -156,10 +162,12 @@ Test.Hspec.Core.FailureReportSpec Test.Hspec.Core.Formatters.DiffSpec Test.Hspec.Core.Formatters.InternalSpec- Test.Hspec.Core.FormattersSpec+ Test.Hspec.Core.Formatters.V1Spec+ Test.Hspec.Core.Formatters.V2Spec Test.Hspec.Core.HooksSpec Test.Hspec.Core.QuickCheckUtilSpec Test.Hspec.Core.Runner.EvalSpec+ Test.Hspec.Core.Runner.PrintSlowSpecItemsSpec Test.Hspec.Core.RunnerSpec Test.Hspec.Core.ShuffleSpec Test.Hspec.Core.SpecSpec
src/Test/Hspec/Core/Clock.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Test.Hspec.Core.Clock ( Seconds(..)+, toMilliseconds , toMicroseconds , getMonotonicTime , measure@@ -8,13 +9,19 @@ , timeout ) where +import Prelude ()+import Test.Hspec.Core.Compat+ import Text.Printf import System.Clock import Control.Concurrent import qualified System.Timeout as System newtype Seconds = Seconds Double- deriving (Eq, Show, Num, Fractional, PrintfArg)+ deriving (Eq, Show, Ord, Num, Fractional, PrintfArg)++toMilliseconds :: Seconds -> Int+toMilliseconds (Seconds s) = floor (s * 1000) toMicroseconds :: Seconds -> Int toMicroseconds (Seconds s) = floor (s * 1000000)
src/Test/Hspec/Core/Compat.hs view
@@ -5,15 +5,7 @@ , showFullType , readMaybe , lookupEnv-, module Data.IORef--, module Prelude-, module Control.Applicative-, module Control.Monad-, module Data.Foldable-, module Data.Traversable-, module Data.Monoid-, module Data.List+, module Imports #if !MIN_VERSION_base(4,6,0) , modifyIORef'@@ -22,10 +14,11 @@ , interruptible , guarded+, sortOn ) where -import Control.Applicative-import Control.Monad hiding (+import Control.Applicative as Imports+import Control.Monad as Imports hiding ( mapM , mapM_ , forM@@ -34,12 +27,15 @@ , sequence , sequence_ )-import Data.Foldable-import Data.Traversable-import Data.Monoid-import Data.List (intercalate)+import Data.Foldable as Imports+import Data.Traversable as Imports+import Data.Monoid as Imports+import Data.List as Imports (stripPrefix, isPrefixOf, isInfixOf, intercalate, inits, tails, sortBy)+#if MIN_VERSION_base(4,8,0)+import Data.List (sortOn)+#endif -import Prelude hiding (+import Prelude as Imports hiding ( all , and , any@@ -67,9 +63,13 @@ import Data.Typeable (Typeable, typeOf, typeRepTyCon) import Text.Read-import Data.IORef+import Data.IORef as Imports import System.Environment +#if !MIN_VERSION_base(4,8,0)+import Data.Ord (comparing)+#endif+ import Data.Typeable (tyConModule, tyConName) import Control.Concurrent @@ -147,3 +147,9 @@ 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
src/Test/Hspec/Core/Config.hs view
@@ -67,18 +67,22 @@ where qcArgs = ( maybe id setSeed (configQuickCheckSeed c)- . maybe id setMaxDiscardRatio (configQuickCheckMaxDiscardRatio c)+ . maybe id setMaxShrinks (configQuickCheckMaxShrinks c) . maybe id setMaxSize (configQuickCheckMaxSize c)+ . maybe id setMaxDiscardRatio (configQuickCheckMaxDiscardRatio c) . maybe id setMaxSuccess (configQuickCheckMaxSuccess c)) (paramsQuickCheckArgs defaultParams) setMaxSuccess :: Int -> QC.Args -> QC.Args setMaxSuccess n args = args {QC.maxSuccess = n} + setMaxDiscardRatio :: Int -> QC.Args -> QC.Args+ setMaxDiscardRatio n args = args {QC.maxDiscardRatio = n}+ setMaxSize :: Int -> QC.Args -> QC.Args setMaxSize n args = args {QC.maxSize = n} - setMaxDiscardRatio :: Int -> QC.Args -> QC.Args- setMaxDiscardRatio n args = args {QC.maxDiscardRatio = n}+ setMaxShrinks :: Int -> QC.Args -> QC.Args+ setMaxShrinks n args = args {QC.maxShrinks = n} setSeed :: Integer -> QC.Args -> QC.Args setSeed n args = args {QC.replay = Just (mkGen (fromIntegral n), 0)}
src/Test/Hspec/Core/Config/Options.hs view
@@ -12,11 +12,12 @@ import Prelude () import Test.Hspec.Core.Compat -import System.IO import System.Exit import System.Console.GetOpt -import Test.Hspec.Core.Formatters+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.Config.Util import Test.Hspec.Core.Util import Test.Hspec.Core.Example (Params(..), defaultParams)@@ -35,6 +36,7 @@ , configDryRun :: Bool , configFocusedOnly :: Bool , configFailOnFocused :: Bool+, configPrintSlowItems :: Maybe Int , configPrintCpuTime :: Bool , configFastFail :: Bool , configRandomize :: Bool@@ -51,12 +53,14 @@ , configQuickCheckMaxSuccess :: Maybe Int , configQuickCheckMaxDiscardRatio :: Maybe Int , configQuickCheckMaxSize :: Maybe Int+, configQuickCheckMaxShrinks :: Maybe Int , configSmallCheckDepth :: Int , configColorMode :: ColorMode , configDiff :: Bool-, configFormatter :: Maybe Formatter+, configTimes :: Bool+, configFormat :: Maybe (FormatConfig -> IO Format)+, configFormatter :: Maybe V1.Formatter -- ^ deprecated, use `configFormat` instead , configHtmlOutput :: Bool-, configOutputFile :: Either Handle FilePath , configConcurrentJobs :: Maybe Int } @@ -66,6 +70,7 @@ , configDryRun = False , configFocusedOnly = False , configFailOnFocused = False+, configPrintSlowItems = Nothing , configPrintCpuTime = False , configFastFail = False , configRandomize = False@@ -78,12 +83,14 @@ , configQuickCheckMaxSuccess = Nothing , configQuickCheckMaxDiscardRatio = Nothing , configQuickCheckMaxSize = Nothing+, configQuickCheckMaxShrinks = Nothing , configSmallCheckDepth = paramsSmallCheckDepth defaultParams , configColorMode = ColorAuto , configDiff = True+, configTimes = False+, configFormat = Nothing , configFormatter = Nothing , configHtmlOutput = False-, configOutputFile = Left stdout , configConcurrentJobs = Nothing } @@ -104,11 +111,14 @@ setMaxSuccess :: Int -> Config -> Config setMaxSuccess n c = c {configQuickCheckMaxSuccess = Just n} +setMaxDiscardRatio :: Int -> Config -> Config+setMaxDiscardRatio n c = c {configQuickCheckMaxDiscardRatio = Just n}+ setMaxSize :: Int -> Config -> Config setMaxSize n c = c {configQuickCheckMaxSize = Just n} -setMaxDiscardRatio :: Int -> Config -> Config-setMaxDiscardRatio n c = c {configQuickCheckMaxDiscardRatio = Just n}+setMaxShrinks :: Int -> Config -> Config+setMaxShrinks n c = c {configQuickCheckMaxShrinks = Just n} setSeed :: Integer -> Config -> Config setSeed n c = c {configQuickCheckSeed = Just n}@@ -133,6 +143,17 @@ Just n -> Right (setter n `liftM` c) Nothing -> Left (InvalidArgument name input) +printSlowItemsOption :: Monad m => OptDescr (Result m -> Result m)+printSlowItemsOption = Option "p" [name] (OptArg arg "N") "print the N slowest spec items (default: 10)"+ where+ name = "print-slow-items"+ setter v c = c {configPrintSlowItems = v}+ arg = maybe (set (setter $ Just 10)) parseArg+ parseArg input x = x >>= \ c -> case readMaybe input of+ Just 0 -> Right (setter Nothing `liftM` c)+ Just n -> Right (setter (Just n) `liftM` c)+ Nothing -> Left (InvalidArgument name input)+ mkFlag :: Monad m => String -> (Bool -> Config -> Config) -> String -> [OptDescr (Result m -> Result m)] mkFlag name setter help = [ Option [] [name] (NoArg $ set $ setter True) help@@ -154,26 +175,28 @@ [mkOption "f" "format" (Arg "FORMATTER" readFormatter setFormatter) helpForFormat] , mkFlag "color" setColor "colorize the output" , mkFlag "diff" setDiff "show colorized diffs"+ , mkFlag "times" setTimes "report times for individual spec items" , [Option [] ["print-cpu-time"] (NoArg setPrintCpuTime) "include used CPU time in summary"]+ , [printSlowItemsOption] ] where- formatters :: [(String, Formatter)]- formatters = [- ("checks", checks)- , ("specdoc", specdoc)- , ("progress", progress)- , ("failed-examples", failed_examples)- , ("silent", silent)+ formatters :: [(String, FormatConfig -> IO Format)]+ formatters = map (fmap V2.formatterToFormat) [+ ("checks", V2.checks)+ , ("specdoc", V2.specdoc)+ , ("progress", V2.progress)+ , ("failed-examples", V2.failed_examples)+ , ("silent", V2.silent) ] helpForFormat :: String helpForFormat = "use a custom formatter; this can be one of " ++ (formatOrList $ map fst formatters) - readFormatter :: String -> Maybe Formatter+ readFormatter :: String -> Maybe (FormatConfig -> IO Format) readFormatter = (`lookup` formatters) - setFormatter :: Formatter -> Config -> Config- setFormatter f c = c {configFormatter = Just f}+ setFormatter :: (FormatConfig -> IO Format) -> Config -> Config+ setFormatter f c = c {configFormat = Just f} setColor :: Bool -> Config -> Config setColor v config = config {configColorMode = if v then ColorAlways else ColorNever}@@ -181,6 +204,9 @@ setDiff :: Bool -> Config -> Config setDiff v config = config {configDiff = v} + setTimes :: Bool -> Config -> Config+ setTimes v config = config {configTimes = v}+ setPrintCpuTime = set $ \config -> config {configPrintCpuTime = True} smallCheckOptions :: Monad m => [OptDescr (Result m -> Result m)]@@ -191,8 +217,9 @@ quickCheckOptions :: Monad m => [OptDescr (Result m -> Result m)] quickCheckOptions = [ mkOption "a" "qc-max-success" (Arg "N" readMaybe setMaxSuccess) "maximum number of successful tests before a QuickCheck property succeeds"- , mkOption "" "qc-max-size" (Arg "N" readMaybe setMaxSize) "size to use for the biggest test cases" , mkOption "" "qc-max-discard" (Arg "N" readMaybe setMaxDiscardRatio) "maximum number of discarded tests per successful test before giving up"+ , mkOption "" "qc-max-size" (Arg "N" readMaybe setMaxSize) "size to use for the biggest test cases"+ , mkOption "" "qc-max-shrinks" (Arg "N" readMaybe setMaxShrinks) "maximum number of shrinks to perform before giving up (a value of 0 turns shrinking off)" , mkOption [] "seed" (Arg "N" readMaybe setSeed) "used seed for QuickCheck properties" ] @@ -267,17 +294,9 @@ -- undocumented for now, as we probably want to change this to produce a -- standalone HTML report in the future , Option [] ["html"] (NoArg setHtml) "produce HTML output"-- , mkOption "o" "out" (Arg "FILE" return setOutputFile) "write output to a file instead of STDOUT"-- -- now a noop- , Option "v" ["verbose"] (NoArg id) "do not suppress output to stdout when evaluating examples" ] where setHtml = set $ \config -> config {configHtmlOutput = True}-- setOutputFile :: String -> Config -> Config- setOutputFile file c = c {configOutputFile = Right file} recognizedOptions :: [OptDescr (Result Maybe -> Result Maybe)] recognizedOptions = commandLineOptions ++ configFileOptions ++ undocumentedOptions
src/Test/Hspec/Core/Config/Util.hs view
@@ -1,5 +1,8 @@ module Test.Hspec.Core.Config.Util where +import Prelude ()+import Test.Hspec.Core.Compat+ import System.Console.GetOpt import Test.Hspec.Core.Util
src/Test/Hspec/Core/Example.hs view
@@ -21,6 +21,9 @@ , safeEvaluateExample ) where +import Prelude ()+import Test.Hspec.Core.Compat+ import qualified Test.HUnit.Lang as HUnit import Data.CallStack@@ -36,7 +39,6 @@ import Test.Hspec.Core.QuickCheckUtil import Test.Hspec.Core.Util-import Test.Hspec.Core.Compat import Test.Hspec.Core.Example.Location -- | A type class for examples
src/Test/Hspec/Core/Example/Location.hs view
@@ -14,7 +14,6 @@ import Test.Hspec.Core.Compat import Control.Exception-import Data.List import Data.Char import Data.Maybe import GHC.IO.Exception
src/Test/Hspec/Core/Format.hs view
@@ -1,6 +1,11 @@ {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ExistentialQuantification #-}+-- |+-- Stability: experimental module Test.Hspec.Core.Format (- Format(..)+ Format+, FormatConfig(..)+, Event(..) , Progress , Path , Location(..)@@ -8,13 +13,23 @@ , Item(..) , Result(..) , FailureReason(..)+, monadic ) where +import Prelude ()+import Test.Hspec.Core.Compat++import Control.Concurrent+import Control.Concurrent.Async (async)+import Control.Monad.IO.Class+ import Test.Hspec.Core.Spec (Progress, Location(..)) import Test.Hspec.Core.Example (FailureReason(..)) import Test.Hspec.Core.Util (Path)-import Test.Hspec.Core.Clock+import Test.Hspec.Core.Clock (Seconds(..)) +type Format = Event -> IO ()+ data Item = Item { itemLocation :: Maybe Location , itemDuration :: Seconds@@ -24,15 +39,61 @@ data Result = Success- | Pending (Maybe String)- | Failure FailureReason+ | Pending (Maybe Location) (Maybe String)+ | Failure (Maybe Location) FailureReason deriving Show -data Format m = Format {- formatRun :: forall a. m a -> IO a-, formatGroupStarted :: Path -> m ()-, formatGroupDone :: Path -> m ()-, formatProgress :: Path -> Progress -> m ()-, formatItemStarted :: Path -> m ()-, formatItemDone :: Path -> Item -> m ()-}+data Event =+ Started+ | GroupStarted Path+ | GroupDone Path+ | Progress Path Progress+ | ItemStarted Path+ | ItemDone Path Item+ | Done [(Path, Item)]+ deriving Show++data FormatConfig = FormatConfig {+ formatConfigUseColor :: Bool+, formatConfigUseDiff :: Bool+, formatConfigPrintTimes :: Bool+, formatConfigHtmlOutput :: Bool+, formatConfigPrintCpuTime :: Bool+, formatConfigUsedSeed :: Integer+, formatConfigItemCount :: Int+} deriving (Eq, Show)++monadic :: MonadIO m => (m () -> IO ()) -> (Event -> m ()) -> IO Format+monadic run format = do+ mvar <- newEmptyMVar+ done <- newEmptyMVar++ let+ putEvent :: Event -> IO ()+ putEvent = putMVar mvar++ takeEvent :: MonadIO m => m Event+ takeEvent = liftIO $ takeMVar mvar++ signal :: MonadIO m => m ()+ signal = liftIO $ putMVar done ()++ wait :: IO ()+ wait = takeMVar done++ go = do+ event <- takeEvent+ format event+ case event of+ Done {} -> return ()+ _ -> do+ signal+ go++ _ <- async $ do+ run go+ signal++ return $ \ event -> do+ putEvent event+ wait
src/Test/Hspec/Core/Formatters.hs view
@@ -1,314 +1,2 @@-{-# LANGUAGE CPP #-}--- |--- Stability: experimental------ This module contains formatters that can be used with--- `Test.Hspec.Core.Runner.hspecWith`.-module Test.Hspec.Core.Formatters (---- * 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---- ** 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 Data.Maybe-import Test.Hspec.Core.Util-import Test.Hspec.Core.Clock-import Test.Hspec.Core.Spec (Location(..))-import Text.Printf-import Control.Monad.IO.Class-import Control.Exception---- 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.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.Formatters.Diff--silent :: Formatter-silent = Formatter {- headerFormatter = return ()-, exampleGroupStarted = \_ _ -> return ()-, exampleGroupDone = return ()-, exampleStarted = \_ -> return ()-, exampleProgress = \_ _ -> return ()-, exampleSucceeded = \ _ _ -> return ()-, exampleFailed = \_ _ _ -> return ()-, examplePending = \_ _ _ -> return ()-, failedFormatter = return ()-, footerFormatter = return ()-}--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 ""--#if __GLASGOW_HASKELL__ == 800- withFailColor $ do- writeLine "WARNING:"- writeLine " Your version of GHC is affected by https://ghc.haskell.org/trac/ghc/ticket/13285."- writeLine " Source locations may not work as expected."- writeLine ""- writeLine " Please consider upgrading GHC!"- writeLine ""-#endif-- 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 -> return ()- 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 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 _ -> return ()- writeLine ""-- withFailColor $ write (indentation ++ " but got: ")- forM_ chunks $ \ chunk -> case chunk of- Both a _ -> indented write a- First _ -> return ()- Second a -> indented missing a- 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+module Test.Hspec.Core.Formatters (module V1) where+import Test.Hspec.Core.Formatters.V1 as V1
src/Test/Hspec/Core/Formatters/Diff.hs view
@@ -13,7 +13,6 @@ import Test.Hspec.Core.Compat import Data.Char-import Data.List (stripPrefix) import Data.Algorithm.Diff diff :: String -> String -> [Diff String]
src/Test/Hspec/Core/Formatters/Internal.hs view
@@ -1,13 +1,13 @@-{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-} module Test.Hspec.Core.Formatters.Internal ( FormatM-, FormatConfig(..) , runFormatM , interpret , increaseSuccessCount , increasePendingCount , addFailMessage-, finally_ , formatterToFormat #ifdef TEST , overwriteWith@@ -18,8 +18,8 @@ import Test.Hspec.Core.Compat import qualified System.IO as IO-import System.IO (Handle)-import Control.Exception (AsyncException(..), bracket_, try, throwIO)+import System.IO (Handle, stdout)+import Control.Exception (bracket_) import System.Console.ANSI import Control.Monad.Trans.State hiding (state, gets, modify) import Control.Monad.IO.Class@@ -31,42 +31,30 @@ import Test.Hspec.Core.Format import Test.Hspec.Core.Clock -formatterToFormat :: M.Formatter -> FormatConfig -> Format FormatM-formatterToFormat formatter config = Format {- formatRun = \action -> runFormatM config $ do- interpret (M.headerFormatter formatter)- a <- action `finally_` interpret (M.failedFormatter formatter)- interpret (M.footerFormatter formatter)- return a-, formatGroupStarted = \ (nesting, name) -> interpret $ M.exampleGroupStarted formatter nesting name-, formatGroupDone = \ _ -> interpret (M.exampleGroupDone formatter)--, formatProgress = \ path progress -> do- interpret $ M.exampleProgress formatter path progress--, formatItemStarted = \ path -> do- interpret $ M.exampleStarted formatter path--, formatItemDone = \ path (Item loc _duration info result) -> do+formatterToFormat :: M.Formatter -> FormatConfig -> IO Format+formatterToFormat M.Formatter{..} config = monadic (runFormatM config) $ \ event -> case event of+ Started -> interpret formatterStarted+ GroupStarted path -> interpret $ formatterGroupStarted path+ GroupDone path -> interpret $ formatterGroupDone path+ Progress path progress -> interpret $ formatterProgress path progress+ ItemStarted path -> interpret $ formatterItemStarted path+ ItemDone path item -> do clearTransientOutput- case result of- Success -> do- increaseSuccessCount- interpret $ M.exampleSucceeded formatter path info- Pending reason -> do- increasePendingCount- interpret $ M.examplePending formatter path info reason- Failure err -> do- addFailMessage loc path err- interpret $ M.exampleFailed formatter path info err-}+ case itemResult item of+ Success {} -> increaseSuccessCount+ Pending {} -> increasePendingCount+ Failure loc err -> addFailMessage (loc <|> itemLocation item) path err+ interpret $ formatterItemDone path item+ Done _ -> interpret formatterDone interpret :: M.FormatM a -> FormatM a interpret = interpretWith Environment { environmentGetSuccessCount = getSuccessCount , environmentGetPendingCount = getPendingCount , environmentGetFailMessages = getFailMessages+, environmentGetFinalCount = getItemCount , environmentUsedSeed = usedSeed+, environmentPrintTimes = gets (formatConfigPrintTimes . stateConfig) , environmentGetCPUTime = getCPUTime , environmentGetRealTime = getRealTime , environmentWrite = write@@ -91,15 +79,6 @@ modify f = FormatM $ do get >>= liftIO . (`modifyIORef'` f) -data FormatConfig = FormatConfig {- formatConfigHandle :: Handle-, formatConfigUseColor :: Bool-, formatConfigUseDiff :: Bool-, formatConfigHtmlOutput :: Bool-, formatConfigPrintCpuTime :: Bool-, formatConfigUsedSeed :: Integer-} deriving (Eq, Show)- data FormatterState = FormatterState { stateSuccessCount :: !Int , statePendingCount :: !Int@@ -114,7 +93,7 @@ getConfig f = gets (f . stateConfig) getHandle :: FormatM Handle-getHandle = getConfig formatConfigHandle+getHandle = return stdout -- | The random seed that is used for QuickCheck. usedSeed :: FormatM Integer@@ -156,6 +135,11 @@ getFailMessages :: FormatM [FailureRecord] getFailMessages = reverse `fmap` gets stateFailMessages +-- | Get the number of spec items that will have been encountered when this run+-- completes (if it is not terminated early).+getItemCount :: FormatM Int+getItemCount = getConfig formatConfigItemCount+ overwriteWith :: String -> String -> String overwriteWith old new | n == 0 = new@@ -261,22 +245,6 @@ layer | all isSpace s = Background | otherwise = Foreground---- |--- @finally_ actionA actionB@ runs @actionA@ and then @actionB@. @actionB@ is--- run even when a `UserInterrupt` occurs during @actionA@.-finally_ :: FormatM a -> FormatM () -> FormatM a-finally_ (FormatM actionA) (FormatM actionB) = FormatM . StateT $ \st -> do- r <- try (runStateT actionA st)- case r of- Left e -> do- when (e == UserInterrupt) $- runStateT actionB st >> return ()- throwIO e- Right (a, st_) -> do- runStateT actionB st_ >>= return . replaceValue a- where- replaceValue a (_, st) = (a, st) -- | Get the used CPU time since the test run has been started. getCPUTime :: FormatM (Maybe Seconds)
src/Test/Hspec/Core/Formatters/Monad.hs view
@@ -6,6 +6,8 @@ {-# LANGUAGE ExistentialQuantification #-} module Test.Hspec.Core.Formatters.Monad ( Formatter (..)+, Item(..)+, Result(..) , FailureReason (..) , FormatM @@ -13,11 +15,13 @@ , getPendingCount , getFailCount , getTotalCount+, getFinalCount , FailureRecord (..) , getFailMessages , usedSeed +, printTimes , getCPUTime , getRealTime @@ -44,41 +48,31 @@ import Control.Monad.IO.Class import Test.Hspec.Core.Formatters.Free-import Test.Hspec.Core.Example (FailureReason(..))-import Test.Hspec.Core.Util (Path)-import Test.Hspec.Core.Spec (Progress, Location) import Test.Hspec.Core.Clock+import Test.Hspec.Core.Format data Formatter = Formatter { - headerFormatter :: FormatM ()---- | evaluated before each test group-, exampleGroupStarted :: [String] -> String -> FormatM ()+-- | evaluated before a test run+ formatterStarted :: FormatM () --- | evaluated after each test group-, exampleGroupDone :: FormatM ()+-- | evaluated before each spec group+, formatterGroupStarted :: Path -> FormatM () --- | evaluated before each example-, exampleStarted :: Path -> FormatM ()+-- | evaluated after each spec group+, formatterGroupDone :: Path -> FormatM () -- | used to notify the progress of the currently evaluated example-, exampleProgress :: Path -> Progress -> FormatM ()---- | evaluated after each successful example-, exampleSucceeded :: Path -> String -> FormatM ()+, formatterProgress :: Path -> Progress -> FormatM () --- | evaluated after each failed example-, exampleFailed :: Path -> String -> FailureReason -> FormatM ()+-- | evaluated before each spec item+, formatterItemStarted :: Path -> FormatM () --- | evaluated after each pending example-, examplePending :: Path -> String -> Maybe String -> FormatM ()+-- | evaluated after each spec item+, formatterItemDone :: Path -> Item -> FormatM () -- | evaluated after a test run-, failedFormatter :: FormatM ()---- | evaluated after `failuresFormatter`-, footerFormatter :: FormatM ()+, formatterDone :: FormatM () } data FailureRecord = FailureRecord {@@ -91,7 +85,9 @@ GetSuccessCount (Int -> next) | GetPendingCount (Int -> next) | GetFailMessages ([FailureRecord] -> next)+ | GetFinalCount (Int -> next) | UsedSeed (Integer -> next)+ | PrintTimes (Bool -> next) | GetCPUTime (Maybe Seconds -> next) | GetRealTime (Seconds -> next) | Write String next@@ -110,7 +106,9 @@ GetSuccessCount next -> GetSuccessCount (fmap f next) GetPendingCount next -> GetPendingCount (fmap f next) GetFailMessages next -> GetFailMessages (fmap f next)+ GetFinalCount next -> GetFinalCount (fmap f next) UsedSeed next -> UsedSeed (fmap f next)+ PrintTimes next -> PrintTimes (fmap f next) GetCPUTime next -> GetCPUTime (fmap f next) GetRealTime next -> GetRealTime (fmap f next) Write s next -> Write s (f next)@@ -133,7 +131,9 @@ environmentGetSuccessCount :: m Int , environmentGetPendingCount :: m Int , environmentGetFailMessages :: m [FailureRecord]+, environmentGetFinalCount :: m Int , environmentUsedSeed :: m Integer+, environmentPrintTimes :: m Bool , environmentGetCPUTime :: m (Maybe Seconds) , environmentGetRealTime :: m Seconds , environmentWrite :: String -> m ()@@ -158,7 +158,9 @@ GetSuccessCount next -> environmentGetSuccessCount >>= go . next GetPendingCount next -> environmentGetPendingCount >>= go . next GetFailMessages next -> environmentGetFailMessages >>= go . next+ GetFinalCount next -> environmentGetFinalCount >>= go . next UsedSeed next -> environmentUsedSeed >>= go . next+ PrintTimes next -> environmentPrintTimes >>= go . next GetCPUTime next -> environmentGetCPUTime >>= go . next GetRealTime next -> environmentGetRealTime >>= go . next Write s next -> environmentWrite s >> go next@@ -188,6 +190,11 @@ getTotalCount :: FormatM Int getTotalCount = sum <$> sequence [getSuccessCount, getFailCount, getPendingCount] +-- | Get the number of spec items that will have been encountered when this run+-- completes (if it is not terminated early).+getFinalCount :: FormatM Int+getFinalCount = liftF (GetFinalCount id)+ -- | Get the list of accumulated failure messages. getFailMessages :: FormatM [FailureRecord] getFailMessages = liftF (GetFailMessages id)@@ -195,6 +202,11 @@ -- | The random seed that is used for QuickCheck. usedSeed :: FormatM Integer usedSeed = liftF (UsedSeed id)++-- | Return `True` if the user requested time reporting for individual spec+-- items, `False` otherwise.+printTimes :: FormatM Bool+printTimes = liftF (PrintTimes id) -- | Get the used CPU time since the test run has been started. getCPUTime :: FormatM (Maybe Seconds)
+ src/Test/Hspec/Core/Formatters/V1.hs view
@@ -0,0 +1,356 @@+{-# 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 (++-- * 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 Data.Maybe+import Test.Hspec.Core.Util+import Test.Hspec.Core.Clock+import Test.Hspec.Core.Spec (Location(..))+import Text.Printf+import Control.Monad.IO.Class+import Control.Exception++-- 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.Monad (+ 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.Spec (Progress)+import Test.Hspec.Core.Format (FormatConfig, Format, Item(..), Result(..))+import qualified Test.Hspec.Core.Formatters.V2 as V2++import Test.Hspec.Core.Formatters.Diff++formatterToFormat :: Formatter -> FormatConfig -> IO Format+formatterToFormat Formatter{..} = V2.formatterToFormat V2.Formatter {+ V2.formatterStarted = headerFormatter+, V2.formatterGroupStarted = uncurry exampleGroupStarted+, V2.formatterGroupDone = \ _ -> exampleGroupDone+, V2.formatterProgress = exampleProgress+, V2.formatterItemStarted = exampleStarted+, V2.formatterItemDone = \ path item -> 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 = failedFormatter >> footerFormatter+}++data Formatter = Formatter {++ headerFormatter :: FormatM ()++-- | evaluated before each test group+, exampleGroupStarted :: [String] -> String -> FormatM ()++-- | evaluated after each test group+, exampleGroupDone :: FormatM ()++-- | evaluated before each example+, exampleStarted :: Path -> FormatM ()++-- | used to notify the progress of the currently evaluated example+, exampleProgress :: Path -> Progress -> FormatM ()++-- | evaluated after each successful example+, exampleSucceeded :: Path -> String -> FormatM ()++-- | evaluated after each failed example+, exampleFailed :: Path -> String -> FailureReason -> FormatM ()++-- | evaluated after each pending example+, examplePending :: Path -> String -> Maybe String -> FormatM ()++-- | evaluated after a test run+, failedFormatter :: FormatM ()++-- | evaluated after `failedFormatter`+, footerFormatter :: FormatM ()+}++silent :: Formatter+silent = Formatter {+ headerFormatter = return ()+, exampleGroupStarted = \_ _ -> return ()+, exampleGroupDone = return ()+, exampleStarted = \_ -> return ()+, exampleProgress = \_ _ -> return ()+, exampleSucceeded = \ _ _ -> return ()+, exampleFailed = \_ _ _ -> return ()+, examplePending = \_ _ _ -> return ()+, failedFormatter = return ()+, footerFormatter = return ()+}++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 -> return ()+ 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 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 _ -> return ()+ writeLine ""++ withFailColor $ write (indentation ++ " but got: ")+ forM_ chunks $ \ chunk -> case chunk of+ Both a _ -> indented write a+ First _ -> return ()+ Second a -> indented missing a+ 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/V2.hs view
@@ -0,0 +1,325 @@+{-# LANGUAGE CPP #-}+-- |+-- Stability: experimental+--+-- This module contains formatters that can be used with+-- `Test.Hspec.Core.Runner.hspecWith`.+module Test.Hspec.Core.Formatters.V2 (++-- * 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 (..)+, Item(..)+, Result(..)+, FailureReason (..)+, FormatM+, formatterToFormat++-- ** Accessing the runner state+, getSuccessCount+, getPendingCount+, getFailCount+, getTotalCount++, FailureRecord (..)+, getFailMessages+, usedSeed++, printTimes++, Seconds(..)+, getCPUTime+, getRealTime++-- ** Appending to the generated report+, write+, writeLine+, writeTransient++-- ** Dealing with colors+, withInfoColor+, withSuccessColor+, withPendingColor+, withFailColor++, useDiff+, extraChunk+, missingChunk++-- ** Helpers+, formatLocation+, formatException+) where++import Prelude ()+import Test.Hspec.Core.Compat hiding (First)++import Data.Maybe+import Test.Hspec.Core.Util+import Test.Hspec.Core.Clock+import Test.Hspec.Core.Spec (Location(..))+import Text.Printf+import Control.Monad.IO.Class+import Control.Exception++-- We use an explicit import list for "Test.Hspec.Formatters.Monad", 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.Monad (+ Formatter (..)+ , Item(..)+ , Result(..)+ , FailureReason (..)+ , FormatM++ , getSuccessCount+ , getPendingCount+ , getFailCount+ , getTotalCount++ , FailureRecord (..)+ , getFailMessages+ , usedSeed++ , printTimes+ , getCPUTime+ , getRealTime++ , write+ , writeLine+ , writeTransient++ , withInfoColor+ , withSuccessColor+ , withPendingColor+ , withFailColor++ , useDiff+ , extraChunk+ , missingChunk+ )++import Test.Hspec.Core.Formatters.Internal (formatterToFormat)+import Test.Hspec.Core.Formatters.Diff++silent :: Formatter+silent = Formatter {+ formatterStarted = return ()+, formatterGroupStarted = \ _ -> return ()+, formatterGroupDone = \ _ -> return ()+, formatterProgress = \ _ _ -> return ()+, formatterItemStarted = \ _ -> return ()+, formatterItemDone = \ _ _ -> return ()+, formatterDone = return ()+}++checks :: Formatter+checks = specdoc {+ formatterProgress = \(nesting, requirement) p -> do+ writeTransient $ indentationFor nesting ++ requirement ++ " [" ++ (formatProgress p) ++ "]"++, formatterItemStarted = \(nesting, requirement) -> do+ writeTransient $ indentationFor nesting ++ requirement ++ " [ ]"++, formatterItemDone = \ (nesting, requirement) item -> do+ uncurry (writeResult nesting requirement (itemDuration item) (itemInfo item)) $ case itemResult item of+ Success {} -> (withSuccessColor, "✔")+ Pending {} -> (withPendingColor, "‐")+ Failure {} -> (withFailColor, "✘")+ case itemResult item of+ Success {} -> return ()+ Failure {} -> return ()+ Pending _ reason -> withPendingColor $ do+ writeLine $ indentationFor ("" : nesting) ++ "# PENDING: " ++ fromMaybe "No reason given" reason+} where+ indentationFor nesting = replicate (length nesting * 2) ' '++ writeResult :: [String] -> String -> Seconds -> String -> (FormatM () -> FormatM ()) -> String -> FormatM ()+ writeResult nesting requirement duration info withColor symbol = do+ shouldPrintTimes <- printTimes+ write $ indentationFor nesting ++ requirement ++ " ["+ withColor $ write symbol+ writeLine $ "]" ++ if shouldPrintTimes then times else ""+ forM_ (lines info) $ \ s ->+ writeLine $ indentationFor ("" : nesting) ++ s+ where+ dt :: Int+ dt = toMilliseconds duration++ times+ | dt == 0 = ""+ | otherwise = " (" ++ show dt ++ "ms)"++ formatProgress (current, total)+ | total == 0 = show current+ | otherwise = show current ++ "/" ++ show total++specdoc :: Formatter+specdoc = silent {++ formatterStarted = do+ writeLine ""++, formatterGroupStarted = \ (nesting, name) -> do+ writeLine (indentationFor nesting ++ name)++, formatterProgress = \_ p -> do+ writeTransient (formatProgress p)++, formatterItemDone = \(nesting, requirement) item -> do+ let duration = itemDuration item+ info = itemInfo item++ case itemResult item of+ Success -> withSuccessColor $ do+ writeResult nesting requirement duration info+ Pending _ reason -> withPendingColor $ do+ writeResult nesting requirement duration info+ writeLine $ indentationFor ("" : nesting) ++ "# PENDING: " ++ fromMaybe "No reason given" reason+ Failure {} -> withFailColor $ do+ n <- getFailCount+ writeResult nesting (requirement ++ " FAILED [" ++ show n ++ "]") duration info++, formatterDone = defaultFailedFormatter >> defaultFooter+} where+ indentationFor nesting = replicate (length nesting * 2) ' '++ writeResult nesting requirement (Seconds duration) info = do+ shouldPrintTimes <- printTimes+ writeLine $ indentationFor nesting ++ requirement ++ if shouldPrintTimes then times else ""+ forM_ (lines info) $ \ s ->+ writeLine $ indentationFor ("" : nesting) ++ s+ where+ dt :: Int+ dt = floor (duration * 1000)++ times+ | dt == 0 = ""+ | otherwise = " (" ++ show dt ++ "ms)"++ formatProgress (current, total)+ | total == 0 = show current+ | otherwise = show current ++ "/" ++ show total++progress :: Formatter+progress = failed_examples {+ formatterItemDone = \ _ item -> case itemResult item of+ Success{} -> withSuccessColor $ write "."+ Pending{} -> withPendingColor $ write "."+ Failure{} -> withFailColor $ write "F"+}++failed_examples :: Formatter+failed_examples = silent {+ formatterDone = defaultFailedFormatter >> 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 (" " ++ formatLocation loc)+ write (" " ++ show n ++ ") ")+ writeLine (formatRequirement path)+ case reason of+ NoReason -> return ()+ 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 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 _ -> return ()+ writeLine ""++ withFailColor $ write (indentation ++ " but got: ")+ forM_ chunks $ \ chunk -> case chunk of+ Both a _ -> indented write a+ First _ -> return ()+ Second a -> indented missing a+ 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)++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++formatLocation :: Location -> String+formatLocation (Location file line column) = file ++ ":" ++ show line ++ ":" ++ show column ++ ": "
src/Test/Hspec/Core/Hooks.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-} -- | Stability: provisional module Test.Hspec.Core.Hooks ( before@@ -21,6 +23,7 @@ import Prelude () import Test.Hspec.Core.Compat+import Data.CallStack import Control.Exception (SomeException, finally, throwIO, try, catch) import Control.Concurrent.MVar@@ -88,11 +91,11 @@ around action = aroundWith $ \e () -> action e -- | Run a custom action after the last spec item.-afterAll :: ActionWith a -> SpecWith a -> SpecWith a-afterAll action spec = runIO (runSpecM spec) >>= fromSpecList . return . NodeWithCleanup action+afterAll :: HasCallStack => ActionWith a -> SpecWith a -> SpecWith a+afterAll action spec = runIO (runSpecM spec) >>= fromSpecList . return . NodeWithCleanup location action -- | Run a custom action after the last spec item.-afterAll_ :: IO () -> SpecWith a -> SpecWith a+afterAll_ :: HasCallStack => IO () -> SpecWith a -> SpecWith a afterAll_ action = afterAll (\_ -> action) -- | Run a custom action before and/or after every spec item.
src/Test/Hspec/Core/QuickCheck.hs view
@@ -7,6 +7,9 @@ , modifyMaxShrinks ) where +import Prelude ()+import Test.Hspec.Core.Compat+ import Test.QuickCheck import Test.Hspec.Core.Spec
src/Test/Hspec/Core/QuickCheckUtil.hs view
@@ -5,7 +5,6 @@ import Test.Hspec.Core.Compat import Control.Exception-import Data.List import Data.Maybe import Data.Int import System.Random
src/Test/Hspec/Core/Runner.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-} -- | -- Stability: provisional@@ -50,12 +51,14 @@ import Test.Hspec.Core.Util (Path) import Test.Hspec.Core.Spec import Test.Hspec.Core.Config-import Test.Hspec.Core.Formatters-import Test.Hspec.Core.Formatters.Internal+import Test.Hspec.Core.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 import Test.Hspec.Core.QuickCheckUtil import Test.Hspec.Core.Shuffle +import Test.Hspec.Core.Runner.PrintSlowSpecItems import Test.Hspec.Core.Runner.Eval applyFilterPredicates :: Config -> [EvalTree] -> [EvalTree]@@ -198,43 +201,50 @@ runSpec_ :: Config -> Spec -> IO Summary runSpec_ config spec = do filteredSpec <- specToEvalForest config spec- withHandle config $ \h -> do- let formatter = fromMaybe specdoc (configFormatter config)- seed = (fromJust . configQuickCheckSeed) config- qcArgs = configQuickCheckArgs config+ let+ seed = (fromJust . configQuickCheckSeed) config+ qcArgs = configQuickCheckArgs config+ !numberOfItems = countSpecItems filteredSpec - concurrentJobs <- case configConcurrentJobs config of- Nothing -> getDefaultConcurrentJobs- Just n -> return n+ concurrentJobs <- case configConcurrentJobs config of+ Nothing -> getDefaultConcurrentJobs+ Just n -> return n - useColor <- doesUseColor h config+ useColor <- doesUseColor stdout config - results <- withHiddenCursor useColor h $ do- let- formatConfig = FormatConfig {- formatConfigHandle = h- , formatConfigUseColor = useColor- , formatConfigUseDiff = configDiff config- , formatConfigHtmlOutput = configHtmlOutput config- , formatConfigPrintCpuTime = configPrintCpuTime config- , formatConfigUsedSeed = seed- }- evalConfig = EvalConfig {- evalConfigFormat = formatterToFormat formatter formatConfig- , evalConfigConcurrentJobs = concurrentJobs- , evalConfigFastFail = configFastFail config- }- runFormatter evalConfig filteredSpec+ results <- withHiddenCursor useColor stdout $ do+ let+ formatConfig = FormatConfig {+ formatConfigUseColor = useColor+ , formatConfigUseDiff = configDiff config+ , formatConfigPrintTimes = configTimes config+ , formatConfigHtmlOutput = configHtmlOutput config+ , formatConfigPrintCpuTime = configPrintCpuTime config+ , formatConfigUsedSeed = seed+ , formatConfigItemCount = numberOfItems+ } - let failures = filter resultItemIsFailure results+ formatter = fromMaybe (V2.formatterToFormat V2.specdoc) (configFormat config <|> V1.formatterToFormat <$> configFormatter config) - dumpFailureReport config seed qcArgs (map fst failures)+ format <- maybe id printSlowSpecItems (configPrintSlowItems config) <$> formatter formatConfig - return Summary {- summaryExamples = length results- , summaryFailures = length failures- }+ let+ evalConfig = EvalConfig {+ evalConfigFormat = format+ , evalConfigConcurrentJobs = concurrentJobs+ , evalConfigFastFail = configFastFail config+ }+ runFormatter evalConfig filteredSpec + let failures = filter resultItemIsFailure results++ dumpFailureReport config seed qcArgs (map fst failures)++ return Summary {+ summaryExamples = length results+ , summaryFailures = length failures+ }+ specToEvalForest :: Config -> Spec -> IO [EvalTree] specToEvalForest config spec = do let@@ -279,11 +289,6 @@ ColorNever -> return False ColorAlways -> return True -withHandle :: Config -> (Handle -> IO a) -> IO a-withHandle c action = case configOutputFile c of- Left h -> action h- Right path -> withFile path WriteMode action- rerunAll :: Config -> Maybe FailureReport -> Summary -> Bool rerunAll _ Nothing _ = False rerunAll config (Just oldFailureReport) summary =@@ -303,14 +308,21 @@ instance Monoid Summary where mempty = Summary 0 0-#if !MIN_VERSION_base(4,11,0)- (Summary x1 x2) `mappend` (Summary y1 y2) = Summary (x1 + y1) (x2 + y2)-#else+#if MIN_VERSION_base(4,11,0) instance Semigroup Summary where- (Summary x1 x2) <> (Summary y1 y2) = Summary (x1 + y1) (x2 + y2) #endif+ (Summary x1 x2)+#if MIN_VERSION_base(4,11,0)+ <>+#else+ `mappend`+#endif+ (Summary y1 y2) = Summary (x1 + y1) (x2 + y2) randomizeForest :: Integer -> [Tree c a] -> [Tree c a] randomizeForest seed t = runST $ do ref <- newSTRef (mkStdGen $ fromIntegral seed) shuffleForest ref t++countSpecItems :: [EvalTree] -> Int+countSpecItems = getSum . foldMap (foldMap . const $ Sum 1)
src/Test/Hspec/Core/Runner/Eval.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE RankNTypes #-} #if MIN_VERSION_base(4,6,0) && !MIN_VERSION_base(4,7,0) -- Control.Concurrent.QSem is deprecated in base-4.6.0.*@@ -31,13 +32,13 @@ import Control.Monad.IO.Class (liftIO) import qualified Control.Monad.IO.Class as M -import Control.Monad.Trans.State hiding (State, state)+import Control.Monad.Trans.Reader 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.Timer-import Test.Hspec.Core.Format (Format(..))+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@@ -47,62 +48,59 @@ type Monad m = (Functor m, Applicative m, M.Monad m) type MonadIO m = (Monad m, M.MonadIO m) -data EvalConfig m = EvalConfig {- evalConfigFormat :: Format m+data EvalConfig = EvalConfig {+ evalConfigFormat :: Format , evalConfigConcurrentJobs :: Int , evalConfigFastFail :: Bool } -data State m = State {- stateConfig :: EvalConfig m-, stateResults :: [(Path, Format.Item)]+data Env = Env {+ envConfig :: EvalConfig+, envResults :: IORef [(Path, Format.Item)] } -type EvalM m = StateT (State m) m+formatEvent :: Format.Event -> EvalM ()+formatEvent event = do+ format <- asks $ evalConfigFormat . envConfig+ liftIO $ format event -addResult :: Monad m => Path -> Format.Item -> EvalM m ()-addResult path item = modify $ \ state -> state {stateResults = (path, item) : stateResults state}+type EvalM = ReaderT Env IO -getFormat :: Monad m => (Format m -> a) -> EvalM m a-getFormat format = gets (format . evalConfigFormat . stateConfig)+addResult :: Path -> Format.Item -> EvalM ()+addResult path item = do+ ref <- asks envResults+ liftIO $ modifyIORef ref ((path, item) :) -reportItem :: Monad m => Path -> Maybe Location -> EvalM m (Seconds, Result) -> EvalM m ()+getResults :: EvalM [(Path, Format.Item)]+getResults = reverse <$> (asks envResults >>= liftIO . readIORef)++reportItem :: Path -> Maybe Location -> EvalM (Seconds, Result) -> EvalM () reportItem path loc action = do reportItemStarted path action >>= reportResult path loc -reportItemStarted :: Monad m => Path -> EvalM m ()-reportItemStarted path = do- format <- getFormat formatItemStarted- lift (format path)+reportItemStarted :: Path -> EvalM ()+reportItemStarted = formatEvent . Format.ItemStarted -reportItemDone :: Monad m => Path -> Format.Item -> EvalM m ()+reportItemDone :: Path -> Format.Item -> EvalM () reportItemDone path item = do addResult path item- format <- getFormat formatItemDone- lift (format path item)--failureItem :: Maybe Location -> Seconds -> String -> FailureReason -> Format.Item-failureItem loc duration info err = Format.Item loc duration info (Format.Failure err)+ formatEvent $ Format.ItemDone path item -reportResult :: Monad m => Path -> Maybe Location -> (Seconds, Result) -> EvalM m ()+reportResult :: Path -> Maybe Location -> (Seconds, Result) -> EvalM () reportResult path loc (duration, result) = do case result of- Result info status -> case status of- Success -> reportItemDone path (Format.Item loc duration info Format.Success)- Pending loc_ reason -> reportItemDone path (Format.Item (loc_ <|> loc) duration info $ Format.Pending reason)- Failure loc_ err@(Error _ e) -> reportItemDone path (failureItem (loc_ <|> extractLocation e <|> loc) duration info err)- Failure loc_ err -> reportItemDone path (failureItem (loc_ <|> loc) duration info err)+ 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 -groupStarted :: Monad m => Path -> EvalM m ()-groupStarted path = do- format <- getFormat formatGroupStarted- lift $ format path+groupStarted :: Path -> EvalM ()+groupStarted = formatEvent . Format.GroupStarted -groupDone :: Monad m => Path -> EvalM m ()-groupDone path = do- format <- getFormat formatGroupDone- lift $ format path+groupDone :: Path -> EvalM ()+groupDone = formatEvent . Format.GroupDone data EvalItem = EvalItem { evalItemDescription :: String@@ -113,28 +111,32 @@ type EvalTree = Tree (IO ()) EvalItem -runEvalM :: Monad m => EvalConfig m -> EvalM m () -> m (State m)-runEvalM config action = execStateT action (State config [])- -- | Evaluate all examples of a given spec and produce a report.-runFormatter :: forall m. MonadIO m => EvalConfig m -> [EvalTree] -> IO ([(Path, Format.Item)])+runFormatter :: EvalConfig -> [EvalTree] -> IO ([(Path, Format.Item)]) runFormatter config specs = do+ ref <- newIORef []+ let start = parallelizeTree (evalConfigConcurrentJobs config) specs cancel = cancelMany . concatMap toList . map (fmap fst)+ E.bracket start cancel $ \ runningSpecs -> do withTimer 0.05 $ \ timer -> do- state <- formatRun format $ do- runEvalM config $- run $ map (fmap (fmap (. reportProgress timer) . snd)) runningSpecs- return (reverse $ stateResults state)++ format Format.Started+ runReaderT (run $ map (fmap (fmap (. reportProgress timer) . snd)) runningSpecs) (Env config ref) `E.finally` do+ results <- reverse <$> readIORef ref+ format (Format.Done results)++ results <- reverse <$> readIORef ref+ return results where format = evalConfigFormat config - reportProgress :: IO Bool -> Path -> Progress -> m () reportProgress timer path progress = do- r <- liftIO timer- when r (formatProgress format path progress)+ r <- timer+ when r $ do+ format (Format.Progress path progress) cancelMany :: [Async a] -> IO () cancelMany asyncs = do@@ -206,12 +208,12 @@ replaceMVar :: MVar a -> a -> IO () replaceMVar mvar p = tryTakeMVar mvar >> putMVar mvar p -run :: forall m. MonadIO m => [RunningTree m] -> EvalM m ()+run :: [RunningTree IO] -> EvalM () run specs = do- fastFail <- gets (evalConfigFastFail . stateConfig)+ fastFail <- asks (evalConfigFastFail . envConfig) sequenceActions fastFail (concatMap foldSpec specs) where- foldSpec :: RunningTree m -> [EvalM m ()]+ foldSpec :: RunningTree IO -> [EvalM ()] foldSpec = foldTree FoldTree { onGroupStarted = groupStarted , onGroupDone = groupDone@@ -219,16 +221,16 @@ , onLeafe = evalItem } - runCleanup :: [String] -> IO () -> EvalM m ()- runCleanup groups action = do+ 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 Nothing (return r)+ _ -> reportItem path loc (return r) where path = (groups, "afterAll-hook") - evalItem :: [String] -> RunningItem m -> EvalM m ()+ evalItem :: [String] -> RunningItem IO -> EvalM () evalItem groups (Item requirement loc action) = do reportItem path loc $ lift (action path) where@@ -238,7 +240,7 @@ data FoldTree c a r = FoldTree { onGroupStarted :: Path -> r , onGroupDone :: Path -> r-, onCleanup :: [String] -> c -> r+, onCleanup :: Maybe Location -> [String] -> c -> r , onLeafe :: [String] -> a -> r } @@ -251,20 +253,20 @@ start = onGroupStarted path children = concatMap (go (group : rGroups)) xs done = onGroupDone path- go rGroups (NodeWithCleanup action xs) = children ++ [cleanup]+ go rGroups (NodeWithCleanup loc action xs) = children ++ [cleanup] where children = concatMap (go rGroups) xs- cleanup = onCleanup (reverse rGroups) action+ cleanup = onCleanup loc (reverse rGroups) action go rGroups (Leaf a) = [onLeafe (reverse rGroups) a] -sequenceActions :: Monad m => Bool -> [EvalM m ()] -> EvalM m ()+sequenceActions :: Bool -> [EvalM ()] -> EvalM () sequenceActions fastFail = go where- go :: Monad m => [EvalM m ()] -> EvalM m ()+ go :: [EvalM ()] -> EvalM () go [] = return () go (action : actions) = do action- hasFailures <- any resultItemIsFailure <$> gets stateResults+ hasFailures <- any resultItemIsFailure <$> getResults let stopNow = fastFail && hasFailures unless stopNow (go actions)
+ src/Test/Hspec/Core/Runner/PrintSlowSpecItems.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+module Test.Hspec.Core.Runner.PrintSlowSpecItems (+ printSlowSpecItems+) where++import Prelude ()+import Test.Hspec.Core.Compat++import Test.Hspec.Core.Util+import Test.Hspec.Core.Format++import Test.Hspec.Core.Clock+import Test.Hspec.Core.Formatters.V2 (formatLocation)++data SlowItem = SlowItem {+ location :: Maybe Location+, path :: Path+, duration :: Int+}++printSlowSpecItems :: Int -> Format -> Format+printSlowSpecItems n format event = do+ format event+ case event of+ Done items -> do+ let xs = slowItems n $ map toSlowItem items+ unless (null xs) $ do+ putStrLn "\nSlow spec items:"+ mapM_ printSlowSpecItem xs+ _ -> return ()++toSlowItem :: (Path, Item) -> SlowItem+toSlowItem (path, item) = SlowItem (itemLocation item) path (toMilliseconds $ itemDuration item)++slowItems :: Int -> [SlowItem] -> [SlowItem]+slowItems n = take n . reverse . sortOn duration . filter ((/= 0) . duration)++printSlowSpecItem :: SlowItem -> IO ()+printSlowSpecItem SlowItem{..} = do+ putStrLn $ " " ++ maybe "" formatLocation location ++ joinPath path ++ " (" ++ show duration ++ "ms)"
src/Test/Hspec/Core/Shuffle.hs view
@@ -22,7 +22,7 @@ shuffleTree :: STRef s StdGen -> Tree c a -> ST s (Tree c a) shuffleTree ref t = case t of Node d xs -> Node d <$> shuffleForest ref xs- NodeWithCleanup c xs -> NodeWithCleanup c <$> shuffleForest ref xs+ NodeWithCleanup loc c xs -> NodeWithCleanup loc c <$> shuffleForest ref xs Leaf {} -> return t shuffle :: STRef s StdGen -> [a] -> ST s [a]
src/Test/Hspec/Core/Tree.hs view
@@ -33,7 +33,7 @@ -- | Internal tree data structure data Tree c a = Node String [Tree c a]- | NodeWithCleanup c [Tree c a]+ | NodeWithCleanup (Maybe Location) c [Tree c a] | Leaf a deriving (Show, Eq, Functor, Foldable, Traversable) @@ -49,7 +49,7 @@ where go spec = case spec of Node d xs -> Node d (map go xs)- NodeWithCleanup cleanup xs -> NodeWithCleanup (g cleanup) (map go xs)+ NodeWithCleanup loc cleanup xs -> NodeWithCleanup loc (g cleanup) (map go xs) Leaf item -> Leaf (f item) filterTree :: (a -> Bool) -> Tree c a -> Maybe (Tree c a)@@ -70,7 +70,7 @@ filterTree_ :: [String] -> ([String] -> a -> Bool) -> Tree c a -> Maybe (Tree c a) filterTree_ groups p tree = case tree of Node group xs -> Just $ Node group $ filterForest_ (groups ++ [group]) p xs- NodeWithCleanup action xs -> Just $ NodeWithCleanup action $ filterForest_ groups p xs+ NodeWithCleanup loc action xs -> Just $ NodeWithCleanup loc action $ filterForest_ groups p xs Leaf item -> Leaf <$> guarded (p groups) item pruneForest :: [Tree c a] -> [Tree c a]@@ -79,7 +79,7 @@ pruneTree :: Tree c a -> Maybe (Tree c a) pruneTree node = case node of Node group xs -> Node group <$> prune xs- NodeWithCleanup action xs -> NodeWithCleanup action <$> prune xs+ NodeWithCleanup loc action xs -> NodeWithCleanup loc action <$> prune xs Leaf{} -> Just node where prune = guarded (not . null) . pruneForest
src/Test/Hspec/Core/Util.hs view
@@ -16,13 +16,13 @@ , formatException ) where -import Data.List+import Prelude ()+import Test.Hspec.Core.Compat hiding (join)+ import Data.Char (isSpace) import GHC.IO.Exception import Control.Exception import Control.Concurrent.Async--import Test.Hspec.Core.Compat (showType) -- | -- @pluralize count singular@ pluralizes the given @singular@ word unless given
test/All.hs view
@@ -1,1 +1,2 @@+{-# OPTIONS -fno-warn-implicit-prelude #-} {-# OPTIONS_GHC -fforce-recomp -F -pgmF hspec-meta-discover -optF --module-name=All #-}
test/Helper.hs view
@@ -14,6 +14,7 @@ , noOpProgressCallback , captureLines , normalizeSummary+, normalizeTimes , ignoreExitCode , ignoreUserInterrupt@@ -31,7 +32,6 @@ import Prelude () import Test.Hspec.Core.Compat -import Data.List import Data.Char import System.Environment (withArgs, getEnvironment) import System.Exit@@ -97,6 +97,14 @@ | otherwise = x g x | isNumber x = '0' | otherwise = x++normalizeTimes :: [String] -> [String]+normalizeTimes = map go+ where+ go xs = case xs of+ [] -> []+ '(' : y : ys | isNumber y, Just zs <- stripPrefix "ms)" $ dropWhile isNumber ys -> "(2ms)" ++ go zs+ y : ys -> y : go ys defaultParams :: H.Params defaultParams = H.defaultParams {H.paramsQuickCheckArgs = stdArgs {replay = Just (mkGen 23, 0), maxSuccess = 1000}}
test/Spec.hs view
@@ -1,5 +1,8 @@ module Main where +import Prelude ()+import Helper+ import Test.Hspec.Meta import System.SetEnv import qualified All
test/Test/Hspec/Core/ClockSpec.hs view
@@ -1,11 +1,16 @@ module Test.Hspec.Core.ClockSpec (spec) where +import Prelude () import Helper import Test.Hspec.Core.Clock spec :: Spec spec = do+ describe "toMilliseconds" $ do+ it "converts Seconds to milliseconds" $ do+ toMilliseconds 0.1 `shouldBe` 100+ describe "toMicroseconds" $ do it "converts Seconds to microseconds" $ do toMicroseconds 2.5 `shouldBe` 2500000
test/Test/Hspec/Core/CompatSpec.hs view
@@ -1,7 +1,9 @@ {-# LANGUAGE DeriveDataTypeable #-} module Test.Hspec.Core.CompatSpec (spec) where +import Prelude () import Helper+ import System.SetEnv import Data.Typeable
test/Test/Hspec/Core/Config/OptionsSpec.hs view
@@ -5,8 +5,9 @@ import System.Exit -import qualified Test.Hspec.Core.Config.Options as Options+import Test.Hspec.Core.Config import Test.Hspec.Core.Config.Options hiding (parseOptions)+import qualified Test.Hspec.Core.Config.Options as Options fromLeft :: Either a b -> a fromLeft (Left a) = a@@ -37,14 +38,14 @@ it "prints help" $ do help `shouldStartWith` ["Usage: my-spec [OPTION]..."] - context "with --no-color" $ do- it "sets configColorMode to ColorNever" $ do- configColorMode <$> parseOptions [] Nothing ["--no-color"] `shouldBe` Right ColorNever- context "with --color" $ do it "sets configColorMode to ColorAlways" $ do configColorMode <$> parseOptions [] Nothing ["--color"] `shouldBe` Right ColorAlways + context "with --no-color" $ do+ it "sets configColorMode to ColorNever" $ do+ configColorMode <$> parseOptions [] Nothing ["--no-color"] `shouldBe` Right ColorNever+ context "with --diff" $ do it "sets configDiff to True" $ do configDiff <$> parseOptions [] Nothing ["--diff"] `shouldBe` Right True@@ -53,14 +54,32 @@ it "sets configDiff to False" $ do configDiff <$> parseOptions [] Nothing ["--no-diff"] `shouldBe` Right False - context "with --out" $ do- it "sets configOutputFile" $ do- either (const Nothing) Just . configOutputFile <$> parseOptions [] Nothing ["--out", "foo"] `shouldBe` Right (Just "foo")+ context "with --print-slow-items" $ do+ it "sets configPrintSlowItems to N" $ do+ configPrintSlowItems <$> parseOptions [] Nothing ["--print-slow-items=5"] `shouldBe` Right (Just 5) + it "defaults N to 10" $ do+ configPrintSlowItems <$> parseOptions [] Nothing ["--print-slow-items"] `shouldBe` Right (Just 10)++ it "rejects invalid values" $ do+ let msg = "my-spec: invalid argument `foo' for `--print-slow-items'\nTry `my-spec --help' for more information.\n"+ void (parseOptions [] Nothing ["--print-slow-items=foo"]) `shouldBe` Left (ExitFailure 1, msg)++ context "when N is 0" $ do+ it "disables the option" $ do+ configPrintSlowItems <$> parseOptions [] Nothing ["-p0"] `shouldBe` Right Nothing+ context "with --qc-max-success" $ do+ it "sets QuickCheck maxSuccess" $ do+ maxSuccess . configQuickCheckArgs <$> (parseOptions [] Nothing ["--qc-max-success", "23"]) `shouldBe` Right 23+ context "when given an invalid argument" $ do it "returns an error message" $ do fromLeft (parseOptions [] Nothing ["--qc-max-success", "foo"]) `shouldBe` (ExitFailure 1, "my-spec: invalid argument `foo' for `--qc-max-success'\nTry `my-spec --help' for more information.\n")++ context "with --qc-max-shrinks" $ do+ it "sets QuickCheck maxShrinks" $ do+ maxShrinks . configQuickCheckArgs <$> (parseOptions [] Nothing ["--qc-max-shrinks", "23"]) `shouldBe` Right 23 context "with --depth" $ do it "sets depth parameter for SmallCheck" $ do
test/Test/Hspec/Core/Config/UtilSpec.hs view
@@ -1,5 +1,6 @@ module Test.Hspec.Core.Config.UtilSpec (spec) where +import Prelude () import Helper import System.Console.GetOpt
test/Test/Hspec/Core/ConfigSpec.hs view
@@ -1,6 +1,8 @@ module Test.Hspec.Core.ConfigSpec (spec) where +import Prelude () import Helper+ import System.Directory import System.FilePath
test/Test/Hspec/Core/Example/LocationSpec.hs view
@@ -6,7 +6,9 @@ {-# OPTIONS_GHC -O0 #-} module Test.Hspec.Core.Example.LocationSpec (spec) where +import Prelude () import Helper+ import Control.Exception import Test.Hspec.Core.Example@@ -90,7 +92,7 @@ context "with NoMethodError" $ do it "extracts Location" $ do Left e <- try $ someMethod ()- extractLocation e `shouldBe` Just (Location __FILE__ 18 10)+ extractLocation e `shouldBe` Just (Location __FILE__ 20 10) context "with AssertionFailed" $ do it "extracts Location" $ do
test/Test/Hspec/Core/ExampleSpec.hs view
@@ -3,7 +3,9 @@ {-# LANGUAGE TypeFamilies #-} module Test.Hspec.Core.ExampleSpec (spec) where +import Prelude () import Helper+ import Mock import Control.Exception import Test.HUnit (assertFailure, assertEqual)
test/Test/Hspec/Core/FailureReportSpec.hs view
@@ -1,5 +1,6 @@ module Test.Hspec.Core.FailureReportSpec (spec) where +import Prelude () import Helper import System.IO
+ test/Test/Hspec/Core/Formatters/V1Spec.hs view
@@ -0,0 +1,308 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+module Test.Hspec.Core.Formatters.V1Spec (spec) where++import Prelude ()+import Helper+import Data.String+import Control.Monad.IO.Class+import Control.Monad.Trans.Writer+import qualified Control.Exception as E++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.Monad as H (interpretWith)+import Test.Hspec.Core.Formatters.Monad (FormatM, Environment(..), FailureRecord(..), FailureReason(..))++data ColorizedText =+ Plain String+ | Transient String+ | Info String+ | Succeeded String+ | Failed String+ | Pending String+ | Extra String+ | Missing String+ deriving (Eq, Show)++instance IsString ColorizedText where+ fromString = Plain++removeColors :: [ColorizedText] -> String+removeColors input = case input of+ Plain x : xs -> x ++ removeColors xs+ Transient _ : xs -> removeColors xs+ Info x : xs -> x ++ removeColors xs+ Succeeded x : xs -> x ++ removeColors xs+ Failed x : xs -> x ++ removeColors xs+ Pending x : xs -> x ++ removeColors xs+ Extra x : xs -> x ++ removeColors xs+ Missing x : xs -> x ++ removeColors xs+ [] -> ""++simplify :: [ColorizedText] -> [ColorizedText]+simplify input = case input of+ Plain xs : Plain ys : zs -> simplify (Plain (xs ++ ys) : zs)+ Extra xs : Extra ys : zs -> simplify (Extra (xs ++ ys) : zs)+ Missing xs : Missing ys : zs -> simplify (Missing (xs ++ ys) : zs)+ x : xs -> x : simplify xs+ [] -> []++colorize :: (String -> ColorizedText) -> [ColorizedText] -> [ColorizedText]+colorize color input = case simplify input of+ Plain x : xs -> color x : xs+ xs -> xs++interpret :: FormatM a -> IO [ColorizedText]+interpret = interpretWith environment++interpretWith :: Environment (WriterT [ColorizedText] IO) -> FormatM a -> IO [ColorizedText]+interpretWith env = fmap simplify . execWriterT . H.interpretWith env++environment :: Environment (WriterT [ColorizedText] IO)+environment = Environment {+ environmentGetSuccessCount = return 0+, environmentGetPendingCount = return 0+, environmentGetFailMessages = return []+, environmentGetFinalCount = return 0+, environmentUsedSeed = return 0+, environmentGetCPUTime = return Nothing+, environmentGetRealTime = return 0+, environmentWrite = tell . return . Plain+, environmentWriteTransient = tell . return . Transient+, environmentWithFailColor = \ action -> do+ (a, r) <- liftIO $ runWriterT action+ tell (colorize Failed r) >> return a+, environmentWithSuccessColor = \ action -> do+ (a, r) <- liftIO $ runWriterT action+ tell (colorize Succeeded r) >> return a+, environmentWithPendingColor = \ action -> do+ (a, r) <- liftIO $ runWriterT action+ tell (colorize Pending r) >> return a+, environmentWithInfoColor = \ action -> do+ (a, r) <- liftIO $ runWriterT action+ tell (colorize Info r) >> return a+, environmentUseDiff = return True+, environmentPrintTimes = return False+, environmentExtraChunk = tell . return . Extra+, environmentMissingChunk = tell . return . Missing+, environmentLiftIO = liftIO+}++testSpec :: H.Spec+testSpec = do+ H.describe "Example" $ do+ H.it "success" (H.Result "" H.Success)+ H.it "fail 1" (H.Result "" $ H.Failure Nothing $ H.Reason "fail message")+ H.it "pending" (H.pendingWith "pending message")+ H.it "fail 2" (H.Result "" $ H.Failure Nothing H.NoReason)+ H.it "exceptions" (undefined :: H.Result)+ H.it "fail 3" (H.Result "" $ H.Failure Nothing H.NoReason)++spec :: Spec+spec = do+ describe "progress" $ do+ let formatter = H.progress++ describe "exampleSucceeded" $ do+ it "marks succeeding examples with ." $ do+ interpret (H.exampleSucceeded formatter undefined undefined) `shouldReturn` [+ Succeeded "."+ ]++ describe "exampleFailed" $ do+ it "marks failing examples with F" $ do+ interpret (H.exampleFailed formatter undefined undefined undefined) `shouldReturn` [+ Failed "F"+ ]++ describe "examplePending" $ do+ it "marks pending examples with ." $ do+ interpret (H.examplePending formatter undefined undefined undefined) `shouldReturn` [+ Pending "."+ ]++ describe "specdoc" $ do+ let+ formatter = H.specdoc+ runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormatter = Just formatter}++ it "displays a header for each thing being described" $ do+ _:x:_ <- runSpec testSpec+ x `shouldBe` "Example"++ it "displays one row for each behavior" $ do+ r <- runSpec $ do+ H.describe "List as a Monoid" $ do+ H.describe "mappend" $ do+ H.it "is associative" True+ H.describe "mempty" $ do+ H.it "is a left identity" True+ H.it "is a right identity" True+ H.describe "Maybe as a Monoid" $ do+ H.describe "mappend" $ do+ H.it "is associative" True+ H.describe "mempty" $ do+ H.it "is a left identity" True+ H.it "is a right identity" True+ normalizeSummary r `shouldBe` [+ ""+ , "List as a Monoid"+ , " mappend"+ , " is associative"+ , " mempty"+ , " is a left identity"+ , " is a right identity"+ , "Maybe as a Monoid"+ , " mappend"+ , " is associative"+ , " mempty"+ , " is a left identity"+ , " is a right identity"+ , ""+ , "Finished in 0.0000 seconds"+ , "6 examples, 0 failures"+ ]++ it "outputs an empty line at the beginning (even for non-nested specs)" $ do+ r <- runSpec $ do+ H.it "example 1" True+ H.it "example 2" True+ normalizeSummary r `shouldBe` [+ ""+ , "example 1"+ , "example 2"+ , ""+ , "Finished in 0.0000 seconds"+ , "2 examples, 0 failures"+ ]++ it "displays a row for each successfull, failed, or pending example" $ do+ r <- runSpec testSpec+ r `shouldSatisfy` any (== " fail 1 FAILED [1]")+ r `shouldSatisfy` any (== " success")++ it "displays a '#' with an additional message for pending examples" $ do+ r <- runSpec testSpec+ r `shouldSatisfy` any (== " # PENDING: pending message")++ context "with an empty group" $ do+ it "omits that group from the report" $ do+ r <- runSpec $ do+ H.describe "foo" $ do+ H.it "example 1" True+ H.describe "bar" $ do+ return ()+ H.describe "baz" $ do+ H.it "example 2" True++ normalizeSummary r `shouldBe` [+ ""+ , "foo"+ , " example 1"+ , "baz"+ , " example 2"+ , ""+ , "Finished in 0.0000 seconds"+ , "2 examples, 0 failures"+ ]++ describe "failedFormatter" $ do+ let action = H.failedFormatter formatter++ context "when actual/expected contain newlines" $ do+ let+ env = environment {+ environmentGetFailMessages = return [FailureRecord Nothing ([], "") (ExpectedButGot Nothing "first\nsecond\nthird" "first\ntwo\nthird")]+ }+ it "adds indentation" $ do+ (removeColors <$> interpretWith env action) `shouldReturn` unlines [+ ""+ , "Failures:"+ , ""+ , " 1) "+ , " expected: first"+ , " second"+ , " third"+ , " but got: first"+ , " two"+ , " third"+ , ""+ , " To rerun use: --match \"//\""+ , ""+ , "Randomized with seed 0"+ , ""+ ]++ describe "footerFormatter" $ do+ let action = H.footerFormatter formatter++ context "without failures" $ do+ let env = environment {environmentGetSuccessCount = return 1}+ it "shows summary in green if there are no failures" $ do+ interpretWith env action `shouldReturn` [+ "Finished in 0.0000 seconds\n"+ , Succeeded "1 example, 0 failures\n"+ ]++ context "with pending examples" $ do+ let env = environment {environmentGetPendingCount = return 1}+ it "shows summary in yellow if there are pending examples" $ do+ interpretWith env action `shouldReturn` [+ "Finished in 0.0000 seconds\n"+ , Pending "1 example, 0 failures, 1 pending\n"+ ]++ context "with failures" $ do+ let env = environment {environmentGetFailMessages = return [undefined]}+ it "shows summary in red" $ do+ interpretWith env action `shouldReturn` [+ "Finished in 0.0000 seconds\n"+ , Failed "1 example, 1 failure\n"+ ]++ context "with both failures and pending examples" $ do+ let env = environment {environmentGetFailMessages = return [undefined], environmentGetPendingCount = return 1}+ it "shows summary in red" $ do+ interpretWith env action `shouldReturn` [+ "Finished in 0.0000 seconds\n"+ , Failed "2 examples, 1 failure, 1 pending\n"+ ]++ context "same as failed_examples" $ do+ failed_examplesSpec formatter++failed_examplesSpec :: H.Formatter -> Spec+failed_examplesSpec formatter = do+ let runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormatter = Just formatter}++ context "displays a detailed list of failures" $ do+ it "prints all requirements that are not met" $ do+ r <- runSpec testSpec+ r `shouldSatisfy` any (== " 1) Example fail 1")++ it "prints the exception type for requirements that fail due to an uncaught exception" $ do+ r <- runSpec $ do+ H.it "foobar" (E.throw (E.ErrorCall "baz") :: Bool)+ r `shouldContain` [+ " 1) foobar"+ , " uncaught exception: ErrorCall"+ , " baz"+ ]++ it "prints all descriptions when a nested requirement fails" $ do+ r <- runSpec $+ H.describe "foo" $ do+ H.describe "bar" $ do+ H.it "baz" False+ r `shouldSatisfy` any (== " 1) foo.bar baz")+++ context "when a failed example has a source location" $ do+ it "includes that source location above the error message" $ do+ let loc = H.Location "test/FooSpec.hs" 23 4+ addLoc e = e {H.itemLocation = Just loc}+ r <- runSpec $ H.mapSpecItem_ addLoc $ do+ H.it "foo" False+ r `shouldContain` [" test/FooSpec.hs:23:4: ", " 1) foo"]
+ test/Test/Hspec/Core/Formatters/V2Spec.hs view
@@ -0,0 +1,340 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveFunctor #-}+module Test.Hspec.Core.Formatters.V2Spec (spec) where++import Prelude ()+import Helper+import Data.String+import Control.Monad.IO.Class+import Control.Monad.Trans.Writer+import qualified Control.Exception as E++import qualified Test.Hspec.Core.Spec as H+import qualified Test.Hspec.Core.Spec as Spec+import qualified Test.Hspec.Core.Runner as H+import qualified Test.Hspec.Core.Formatters.V2 as H+import qualified Test.Hspec.Core.Formatters.V2 as Formatter+import qualified Test.Hspec.Core.Formatters.Monad as H+import Test.Hspec.Core.Formatters.Monad (FormatM, Environment(..))++data Colorized a =+ Plain a+ | Transient a+ | Info a+ | Succeeded a+ | Failed a+ | Pending a+ | Extra a+ | Missing a+ deriving (Functor, Eq, Show)++instance IsString (Colorized String) where+ fromString = Plain++removeColors :: [Colorized String] -> String+removeColors input = case input of+ Plain x : xs -> x ++ removeColors xs+ Transient _ : xs -> removeColors xs+ Info x : xs -> x ++ removeColors xs+ Succeeded x : xs -> x ++ removeColors xs+ Failed x : xs -> x ++ removeColors xs+ Pending x : xs -> x ++ removeColors xs+ Extra x : xs -> x ++ removeColors xs+ Missing x : xs -> x ++ removeColors xs+ [] -> ""++simplify :: [Colorized String] -> [Colorized String]+simplify input = case input of+ Plain xs : Plain ys : zs -> simplify (Plain (xs ++ ys) : zs)+ Extra xs : Extra ys : zs -> simplify (Extra (xs ++ ys) : zs)+ Missing xs : Missing ys : zs -> simplify (Missing (xs ++ ys) : zs)+ x : xs -> x : simplify xs+ [] -> []++colorize :: (String -> Colorized String) -> [Colorized String] -> [Colorized String]+colorize color input = case simplify input of+ Plain x : xs -> color x : xs+ xs -> xs++interpret :: FormatM a -> IO [Colorized String]+interpret = interpretWith environment++interpretWith :: Environment (WriterT [Colorized String] IO) -> FormatM a -> IO [Colorized String]+interpretWith env = fmap simplify . execWriterT . H.interpretWith env++environment :: Environment (WriterT [Colorized String] IO)+environment = Environment {+ environmentGetSuccessCount = return 0+, environmentGetPendingCount = return 0+, environmentGetFailMessages = return []+, environmentGetFinalCount = return 0+, environmentUsedSeed = return 0+, environmentGetCPUTime = return Nothing+, environmentGetRealTime = return 0+, environmentWrite = tell . return . Plain+, environmentWriteTransient = tell . return . Transient+, environmentWithFailColor = \ action -> do+ (a, r) <- liftIO $ runWriterT action+ tell (colorize Failed r) >> return a+, environmentWithSuccessColor = \ action -> do+ (a, r) <- liftIO $ runWriterT action+ tell (colorize Succeeded r) >> return a+, environmentWithPendingColor = \ action -> do+ (a, r) <- liftIO $ runWriterT action+ tell (colorize Pending r) >> return a+, environmentWithInfoColor = \ action -> do+ (a, r) <- liftIO $ runWriterT action+ tell (colorize Info r) >> return a+, environmentUseDiff = return True+, environmentPrintTimes = return False+, environmentExtraChunk = tell . return . Extra+, environmentMissingChunk = tell . return . Missing+, environmentLiftIO = liftIO+}++testSpec :: H.Spec+testSpec = do+ H.describe "Example" $ do+ H.it "success" (H.Result "" Spec.Success)+ H.it "fail 1" (H.Result "" $ Spec.Failure Nothing $ H.Reason "fail message")+ H.it "pending" (H.pendingWith "pending message")+ H.it "fail 2" (H.Result "" $ Spec.Failure Nothing H.NoReason)+ H.it "exceptions" (undefined :: Spec.Result)+ H.it "fail 3" (H.Result "" $ Spec.Failure Nothing H.NoReason)++spec :: Spec+spec = do+ describe "progress" $ do+ let formatter = H.progress+ item = Formatter.Item Nothing 0 ""++ describe "formatterItemDone" $ do+ it "marks succeeding examples with ." $ do+ interpret (H.formatterItemDone formatter undefined (item Formatter.Success)) `shouldReturn` [+ Succeeded "."+ ]++ it "marks failing examples with F" $ do+ interpret (H.formatterItemDone formatter undefined (item $ Formatter.Failure Nothing H.NoReason)) `shouldReturn` [+ Failed "F"+ ]++ it "marks pending examples with ." $ do+ interpret (H.formatterItemDone formatter undefined (item $ Formatter.Pending Nothing Nothing)) `shouldReturn` [+ Pending "."+ ]++ describe "specdoc" $ do+ let+ formatter = H.specdoc+ runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormat = Just $ H.formatterToFormat formatter}++ it "displays a header for each thing being described" $ do+ _:x:_ <- runSpec testSpec+ x `shouldBe` "Example"++ it "displays one row for each behavior" $ do+ r <- runSpec $ do+ H.describe "List as a Monoid" $ do+ H.describe "mappend" $ do+ H.it "is associative" True+ H.describe "mempty" $ do+ H.it "is a left identity" True+ H.it "is a right identity" True+ H.describe "Maybe as a Monoid" $ do+ H.describe "mappend" $ do+ H.it "is associative" True+ H.describe "mempty" $ do+ H.it "is a left identity" True+ H.it "is a right identity" True+ normalizeSummary r `shouldBe` [+ ""+ , "List as a Monoid"+ , " mappend"+ , " is associative"+ , " mempty"+ , " is a left identity"+ , " is a right identity"+ , "Maybe as a Monoid"+ , " mappend"+ , " is associative"+ , " mempty"+ , " is a left identity"+ , " is a right identity"+ , ""+ , "Finished in 0.0000 seconds"+ , "6 examples, 0 failures"+ ]++ it "outputs an empty line at the beginning (even for non-nested specs)" $ do+ r <- runSpec $ do+ H.it "example 1" True+ H.it "example 2" True+ normalizeSummary r `shouldBe` [+ ""+ , "example 1"+ , "example 2"+ , ""+ , "Finished in 0.0000 seconds"+ , "2 examples, 0 failures"+ ]++ it "displays a row for each successfull, failed, or pending example" $ do+ r <- runSpec testSpec+ r `shouldSatisfy` any (== " fail 1 FAILED [1]")+ r `shouldSatisfy` any (== " success")++ it "displays a '#' with an additional message for pending examples" $ do+ r <- runSpec testSpec+ r `shouldSatisfy` any (== " # PENDING: pending message")++ context "with an empty group" $ do+ it "omits that group from the report" $ do+ r <- runSpec $ do+ H.describe "foo" $ do+ H.it "example 1" True+ H.describe "bar" $ do+ return ()+ H.describe "baz" $ do+ H.it "example 2" True++ normalizeSummary r `shouldBe` [+ ""+ , "foo"+ , " example 1"+ , "baz"+ , " example 2"+ , ""+ , "Finished in 0.0000 seconds"+ , "2 examples, 0 failures"+ ]++ describe "formatterDone" $ do+ let action = H.formatterDone formatter++ context "when actual/expected contain newlines" $ do+ let+ env = environment {+ environmentGetFailMessages = return [H.FailureRecord Nothing ([], "") (H.ExpectedButGot Nothing "first\nsecond\nthird" "first\ntwo\nthird")]+ }+ it "adds indentation" $ do+ (removeColors <$> interpretWith env action) `shouldReturn` unlines [+ ""+ , "Failures:"+ , ""+ , " 1) "+ , " expected: first"+ , " second"+ , " third"+ , " but got: first"+ , " two"+ , " third"+ , ""+ , " To rerun use: --match \"//\""+ , ""+ , "Randomized with seed 0"+ , ""+ , "Finished in 0.0000 seconds"+ , "1 example, 1 failure"+ ]++ context "without failures" $ do+ let env = environment {environmentGetSuccessCount = return 1}+ it "shows summary in green if there are no failures" $ do+ interpretWith env action `shouldReturn` [+ "\nFinished in 0.0000 seconds\n"+ , Succeeded "1 example, 0 failures\n"+ ]++ context "with pending examples" $ do+ let env = environment {environmentGetPendingCount = return 1}+ it "shows summary in yellow if there are pending examples" $ do+ interpretWith env action `shouldReturn` [+ "\nFinished in 0.0000 seconds\n"+ , Pending "1 example, 0 failures, 1 pending\n"+ ]++ context "with failures" $ do+ let env = environment {environmentGetFailMessages = return [H.FailureRecord Nothing ([], "") H.NoReason]}+ it "shows summary in red" $ do+ interpretWith env action `shouldReturn` [+ Plain $ unlines [+ ""+ , "Failures:"+ , ""+ , " 1) "+ , ""+ , " To rerun use: --match \"//\""+ , ""+ , "Randomized with seed 0"+ , ""+ , "Finished in 0.0000 seconds"+ ]+ , Failed "1 example, 1 failure\n"+ ]++ context "with both failures and pending examples" $ do+ let env = environment {environmentGetFailMessages = return [H.FailureRecord Nothing ([], "") H.NoReason], environmentGetPendingCount = return 1}+ it "shows summary in red" $ do+ interpretWith env action `shouldReturn` [+ Plain $ unlines [+ ""+ , "Failures:"+ , ""+ , " 1) "+ , ""+ , " To rerun use: --match \"//\""+ , ""+ , "Randomized with seed 0"+ , ""+ , "Finished in 0.0000 seconds"+ ]+ , Failed "2 examples, 1 failure, 1 pending\n"+ ]++ context "same as failed_examples" $ do+ failed_examplesSpec formatter++ describe "additional formatter features" $ do+ describe "getFinalCount" $ do+ let formatter = H.silent {H.formatterDone = fmap show H.getFinalCount >>= H.writeLine}+ runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormat = Just $ H.formatterToFormat formatter}+ it "counts examples" $ do+ result:_ <- runSpec testSpec+ result `shouldBe` "6"++failed_examplesSpec :: H.Formatter -> Spec+failed_examplesSpec formatter = do+ let runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormat = Just $ H.formatterToFormat formatter}++ context "displays a detailed list of failures" $ do+ it "prints all requirements that are not met" $ do+ r <- runSpec testSpec+ r `shouldSatisfy` any (== " 1) Example fail 1")++ it "prints the exception type for requirements that fail due to an uncaught exception" $ do+ r <- runSpec $ do+ H.it "foobar" (E.throw (E.ErrorCall "baz") :: Bool)+ r `shouldContain` [+ " 1) foobar"+ , " uncaught exception: ErrorCall"+ , " baz"+ ]++ it "prints all descriptions when a nested requirement fails" $ do+ r <- runSpec $+ H.describe "foo" $ do+ H.describe "bar" $ do+ H.it "baz" False+ r `shouldSatisfy` any (== " 1) foo.bar baz")+++ context "when a failed example has a source location" $ do+ it "includes that source location above the error message" $ do+ let loc = H.Location "test/FooSpec.hs" 23 4+ addLoc e = e {Spec.itemLocation = Just loc}+ r <- runSpec $ H.mapSpecItem_ addLoc $ do+ H.it "foo" False+ r `shouldContain` [" test/FooSpec.hs:23:4: ", " 1) foo"]
− test/Test/Hspec/Core/FormattersSpec.hs
@@ -1,314 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-module Test.Hspec.Core.FormattersSpec (spec) where--import Prelude ()-import Helper-import Data.String-import Control.Monad.IO.Class-import Control.Monad.Trans.Writer-import qualified Control.Exception as E--import qualified Test.Hspec.Core.Spec as H-import qualified Test.Hspec.Core.Runner as H-import qualified Test.Hspec.Core.Formatters as H-import qualified Test.Hspec.Core.Formatters.Monad as H-import Test.Hspec.Core.Formatters.Monad hiding (interpretWith)--data ColorizedText =- Plain String- | Transient String- | Info String- | Succeeded String- | Failed String- | Pending String- | Extra String- | Missing String- deriving (Eq, Show)--instance IsString ColorizedText where- fromString = Plain--removeColors :: [ColorizedText] -> String-removeColors input = case input of- Plain x : xs -> x ++ removeColors xs- Transient _ : xs -> removeColors xs- Info x : xs -> x ++ removeColors xs- Succeeded x : xs -> x ++ removeColors xs- Failed x : xs -> x ++ removeColors xs- Pending x : xs -> x ++ removeColors xs- Extra x : xs -> x ++ removeColors xs- Missing x : xs -> x ++ removeColors xs- [] -> ""--simplify :: [ColorizedText] -> [ColorizedText]-simplify input = case input of- Plain xs : Plain ys : zs -> simplify (Plain (xs ++ ys) : zs)- Extra xs : Extra ys : zs -> simplify (Extra (xs ++ ys) : zs)- Missing xs : Missing ys : zs -> simplify (Missing (xs ++ ys) : zs)- x : xs -> x : simplify xs- [] -> []--colorize :: (String -> ColorizedText) -> [ColorizedText] -> [ColorizedText]-colorize color input = case simplify input of- Plain x : xs -> color x : xs- xs -> xs--interpret :: FormatM a -> IO [ColorizedText]-interpret = interpretWith environment--interpretWith :: Environment (WriterT [ColorizedText] IO) -> FormatM a -> IO [ColorizedText]-interpretWith env = fmap simplify . execWriterT . H.interpretWith env--environment :: Environment (WriterT [ColorizedText] IO)-environment = Environment {- environmentGetSuccessCount = return 0-, environmentGetPendingCount = return 0-, environmentGetFailMessages = return []-, environmentUsedSeed = return 0-, environmentGetCPUTime = return Nothing-, environmentGetRealTime = return 0-, environmentWrite = tell . return . Plain-, environmentWriteTransient = tell . return . Transient-, environmentWithFailColor = \ action -> do- (a, r) <- liftIO $ runWriterT action- tell (colorize Failed r) >> return a-, environmentWithSuccessColor = \ action -> do- (a, r) <- liftIO $ runWriterT action- tell (colorize Succeeded r) >> return a-, environmentWithPendingColor = \ action -> do- (a, r) <- liftIO $ runWriterT action- tell (colorize Pending r) >> return a-, environmentWithInfoColor = \ action -> do- (a, r) <- liftIO $ runWriterT action- tell (colorize Info r) >> return a-, environmentUseDiff = return True-, environmentExtraChunk = tell . return . Extra-, environmentMissingChunk = tell . return . Missing-, environmentLiftIO = liftIO-}--testSpec :: H.Spec-testSpec = do- H.describe "Example" $ do- H.it "success" (H.Result "" H.Success)- H.it "fail 1" (H.Result "" $ H.Failure Nothing $ H.Reason "fail message")- H.it "pending" (H.pendingWith "pending message")- H.it "fail 2" (H.Result "" $ H.Failure Nothing H.NoReason)- H.it "exceptions" (undefined :: H.Result)- H.it "fail 3" (H.Result "" $ H.Failure Nothing H.NoReason)--spec :: Spec-spec = do- describe "progress" $ do- let formatter = H.progress-- describe "exampleSucceeded" $ do- it "marks succeeding examples with ." $ do- interpret (H.exampleSucceeded formatter undefined undefined) `shouldReturn` [- Succeeded "."- ]-- describe "exampleFailed" $ do- it "marks failing examples with F" $ do- interpret (H.exampleFailed formatter undefined undefined undefined) `shouldReturn` [- Failed "F"- ]-- describe "examplePending" $ do- it "marks pending examples with ." $ do- interpret (H.examplePending formatter undefined undefined undefined) `shouldReturn` [- Pending "."- ]-- describe "specdoc" $ do- let- formatter = H.specdoc- runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormatter = Just formatter}-- it "displays a header for each thing being described" $ do- _:x:_ <- runSpec testSpec- x `shouldBe` "Example"-- it "displays one row for each behavior" $ do- r <- runSpec $ do- H.describe "List as a Monoid" $ do- H.describe "mappend" $ do- H.it "is associative" True- H.describe "mempty" $ do- H.it "is a left identity" True- H.it "is a right identity" True- H.describe "Maybe as a Monoid" $ do- H.describe "mappend" $ do- H.it "is associative" True- H.describe "mempty" $ do- H.it "is a left identity" True- H.it "is a right identity" True- normalizeSummary r `shouldBe` [- ""- , "List as a Monoid"- , " mappend"- , " is associative"- , " mempty"- , " is a left identity"- , " is a right identity"- , "Maybe as a Monoid"- , " mappend"- , " is associative"- , " mempty"- , " is a left identity"- , " is a right identity"- , ""- , "Finished in 0.0000 seconds"- , "6 examples, 0 failures"- ]-- it "outputs an empty line at the beginning (even for non-nested specs)" $ do- r <- runSpec $ do- H.it "example 1" True- H.it "example 2" True- normalizeSummary r `shouldBe` [- ""- , "example 1"- , "example 2"- , ""- , "Finished in 0.0000 seconds"- , "2 examples, 0 failures"- ]-- it "displays a row for each successfull, failed, or pending example" $ do- r <- runSpec testSpec- r `shouldSatisfy` any (== " fail 1 FAILED [1]")- r `shouldSatisfy` any (== " success")-- it "displays a '#' with an additional message for pending examples" $ do- r <- runSpec testSpec- r `shouldSatisfy` any (== " # PENDING: pending message")-- context "with an empty group" $ do- it "omits that group from the report" $ do- r <- runSpec $ do- H.describe "foo" $ do- H.it "example 1" True- H.describe "bar" $ do- return ()- H.describe "baz" $ do- H.it "example 2" True-- normalizeSummary r `shouldBe` [- ""- , "foo"- , " example 1"- , "baz"- , " example 2"- , ""- , "Finished in 0.0000 seconds"- , "2 examples, 0 failures"- ]-- describe "failedFormatter" $ do- let action = H.failedFormatter formatter-- context "when actual/expected contain newlines" $ do- let- env = environment {- environmentGetFailMessages = return [FailureRecord Nothing ([], "") (ExpectedButGot Nothing "first\nsecond\nthird" "first\ntwo\nthird")]- }- it "adds indentation" $ do- (removeColors <$> interpretWith env action) `shouldReturn` unlines [- ""- , "Failures:"- , ""- , " 1) "- , " expected: first"- , " second"- , " third"- , " but got: first"- , " two"- , " third"- , ""- , " To rerun use: --match \"//\""- , ""-#if __GLASGOW_HASKELL__ == 800- , "WARNING:"- , " Your version of GHC is affected by https://ghc.haskell.org/trac/ghc/ticket/13285."- , " Source locations may not work as expected."- , ""- , " Please consider upgrading GHC!"- , ""-#endif- , "Randomized with seed 0"- , ""- ]-- describe "footerFormatter" $ do- let action = H.footerFormatter formatter-- context "without failures" $ do- let env = environment {environmentGetSuccessCount = return 1}- it "shows summary in green if there are no failures" $ do- interpretWith env action `shouldReturn` [- "Finished in 0.0000 seconds\n"- , Succeeded "1 example, 0 failures\n"- ]-- context "with pending examples" $ do- let env = environment {environmentGetPendingCount = return 1}- it "shows summary in yellow if there are pending examples" $ do- interpretWith env action `shouldReturn` [- "Finished in 0.0000 seconds\n"- , Pending "1 example, 0 failures, 1 pending\n"- ]-- context "with failures" $ do- let env = environment {environmentGetFailMessages = return [undefined]}- it "shows summary in red" $ do- interpretWith env action `shouldReturn` [- "Finished in 0.0000 seconds\n"- , Failed "1 example, 1 failure\n"- ]-- context "with both failures and pending examples" $ do- let env = environment {environmentGetFailMessages = return [undefined], environmentGetPendingCount = return 1}- it "shows summary in red" $ do- interpretWith env action `shouldReturn` [- "Finished in 0.0000 seconds\n"- , Failed "2 examples, 1 failure, 1 pending\n"- ]-- context "same as failed_examples" $ do- failed_examplesSpec formatter--failed_examplesSpec :: H.Formatter -> Spec-failed_examplesSpec formatter = do- let runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormatter = Just formatter}-- context "displays a detailed list of failures" $ do- it "prints all requirements that are not met" $ do- r <- runSpec testSpec- r `shouldSatisfy` any (== " 1) Example fail 1")-- it "prints the exception type for requirements that fail due to an uncaught exception" $ do- r <- runSpec $ do- H.it "foobar" (E.throw (E.ErrorCall "baz") :: Bool)- r `shouldContain` [- " 1) foobar"- , " uncaught exception: ErrorCall"- , " baz"- ]-- it "prints all descriptions when a nested requirement fails" $ do- r <- runSpec $- H.describe "foo" $ do- H.describe "bar" $ do- H.it "baz" False- r `shouldSatisfy` any (== " 1) foo.bar baz")--- context "when a failed example has a source location" $ do- it "includes that source location above the error message" $ do- let loc = H.Location "test/FooSpec.hs" 23 4- addLoc e = e {H.itemLocation = Just loc}- r <- runSpec $ H.mapSpecItem_ addLoc $ do- H.it "foo" False- r `shouldContain` [" test/FooSpec.hs:23:4: ", " 1) foo"]
test/Test/Hspec/Core/HooksSpec.hs view
@@ -21,20 +21,19 @@ evalSpec = fmap normalize . (H.specToEvalForest H.defaultConfig >=> runFormatter config) where config = EvalConfig {- evalConfigFormat = format+ evalConfigFormat = \ _ -> return () , evalConfigConcurrentJobs = 1 , evalConfigFastFail = False }- format = Format {- formatRun = id- , formatGroupStarted = \ _ -> return ()- , formatGroupDone = \ _ -> return ()- , formatProgress = \ _ _ -> return ()- , formatItemStarted = \ _ -> return ()- , formatItemDone = \ _ _ -> return ()- } normalize = map $ \ (path, item) -> (pathToList path, normalizeItem item)- normalizeItem item = item {itemLocation = Nothing, itemDuration = 0}+ normalizeItem item = item {+ itemLocation = Nothing+ , itemDuration = 0+ , itemResult = case itemResult item of+ Success -> Success+ Pending _ reason -> Pending Nothing reason+ Failure _ reason -> Failure Nothing reason+ } pathToList (xs, x) = xs ++ [x] mkAppend :: IO (String -> IO (), IO [String])@@ -143,7 +142,7 @@ n `shouldBe` 23 `shouldReturn` [ item ["foo"] divideByZero- , item ["bar"] (Pending (Just "exception in beforeAll-hook (see previous failure)"))+ , item ["bar"] (Pending Nothing (Just "exception in beforeAll-hook (see previous failure)")) ] context "when used with an empty list of examples" $ do@@ -234,7 +233,7 @@ n `shouldBe` 23 `shouldReturn` [ item ["foo"] divideByZero- , item ["bar"] (Pending (Just "exception in beforeAll-hook (see previous failure)"))+ , item ["bar"] (Pending Nothing (Just "exception in beforeAll-hook (see previous failure)")) ] context "when used with an empty list of examples" $ do@@ -380,7 +379,7 @@ H.it "foo" True `shouldReturn` [ item ["foo"] Success- , item ["afterAll-hook"] (Pending Nothing)+ , item ["afterAll-hook"] (Pending Nothing Nothing) ] context "when action throws an exception" $ do@@ -521,7 +520,7 @@ H.it "foo" True `shouldReturn` [ item ["foo"] divideByZero- , item ["afterAll-hook"] (Pending (Just "exception in beforeAll-hook (see previous failure)"))+ , item ["afterAll-hook"] (Pending Nothing (Just "exception in beforeAll-hook (see previous failure)")) ] it "reports exceptions on release" $ do@@ -555,7 +554,7 @@ H.it "foo" H.pending `shouldReturn` [ item ["foo"] divideByZero- , item ["afterAll-hook"] (Pending (Just "exception in beforeAll-hook (see previous failure)"))+ , item ["afterAll-hook"] (Pending Nothing (Just "exception in beforeAll-hook (see previous failure)")) ] it "reports exceptions on release" $ do@@ -569,7 +568,7 @@ where divideByZero :: Result- divideByZero = Failure (Error Nothing $ toException DivideByZero)+ divideByZero = Failure Nothing (Error Nothing $ toException DivideByZero) item :: [String] -> Result -> ([String], Item) item path result = (path, Item Nothing 0 "" result)
test/Test/Hspec/Core/QuickCheckUtilSpec.hs view
@@ -4,6 +4,7 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-} module Test.Hspec.Core.QuickCheckUtilSpec (spec) where +import Prelude () import Helper import qualified Test.QuickCheck.Property as QCP
+ test/Test/Hspec/Core/Runner/PrintSlowSpecItemsSpec.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE RecordWildCards #-}+module Test.Hspec.Core.Runner.PrintSlowSpecItemsSpec (spec) where++import Prelude ()+import Helper++import Test.Hspec.Core.Format+import Test.Hspec.Core.Runner.PrintSlowSpecItems++location :: Location+location = Location {+ locationFile = "Foo.hs"+, locationLine = 23+, locationColumn = 42+}++item :: Item+item = Item {+ itemLocation = Just location+, itemDuration = 0+, itemInfo = undefined+, itemResult = undefined+}++spec :: Spec+spec = do+ describe "printSlowSpecItems" $ do+ let format = printSlowSpecItems 2 $ \ _ -> return ()+ it "prints slow spec items" $ do+ capture_ $ format $ Done [+ ((["foo", "bar"], "one"), item {itemDuration = 0.100})+ , ((["foo", "bar"], "two"), item {itemDuration = 0.500})+ , ((["foo", "bar"], "thr"), item {itemDuration = 0.050})+ ]+ `shouldReturn` unlines [+ ""+ , "Slow spec items:"+ , " Foo.hs:23:42: /foo/bar/two/ (500ms)"+ , " Foo.hs:23:42: /foo/bar/one/ (100ms)"+ ]++ context "when there are no slow items" $ do+ it "prints nothing" $ do+ capture_ $ format $ Done [((["foo", "bar"], "one"), item {itemDuration = 0})]+ `shouldReturn` ""
test/Test/Hspec/Core/RunnerSpec.hs view
@@ -26,7 +26,7 @@ import qualified Test.Hspec.Expectations as H import qualified Test.Hspec.Core.Spec as H import qualified Test.Hspec.Core.Runner as H-import qualified Test.Hspec.Core.Formatters as H (silent)+import qualified Test.Hspec.Core.Formatters.V2 as V2 import qualified Test.Hspec.Core.QuickCheck as H import qualified Test.QuickCheck as QC@@ -201,16 +201,10 @@ , "" , " To rerun use: --match \"/foo/\"" , ""-#if __GLASGOW_HASKELL__ == 800- , "WARNING:"- , " Your version of GHC is affected by https://ghc.haskell.org/trac/ghc/ticket/13285."- , " Source locations may not work as expected."- , ""- , " Please consider upgrading GHC!"- , ""-#endif , "Randomized with seed 23" , ""+ , "Finished in 0.0000 seconds"+ , "1 example, 1 failure" ] it "throws UserInterrupt" $ do@@ -286,14 +280,6 @@ , "" , " To rerun use: --match \"/bar/\"" , ""-#if __GLASGOW_HASKELL__ == 800- , "WARNING:"- , " Your version of GHC is affected by https://ghc.haskell.org/trac/ghc/ticket/13285."- , " Source locations may not work as expected."- , ""- , " Please consider upgrading GHC!"- , ""-#endif , "Randomized with seed 23" , "" , "Finished in 0.0000 seconds"@@ -317,14 +303,6 @@ , "" , " To rerun use: --match \"/bar/\"" , ""-#if __GLASGOW_HASKELL__ == 800- , "WARNING:"- , " Your version of GHC is affected by https://ghc.haskell.org/trac/ghc/ticket/13285."- , " Source locations may not work as expected."- , ""- , " Please consider upgrading GHC!"- , ""-#endif , "Randomized with seed 23" , "" , "Finished in 0.0000 seconds"@@ -365,14 +343,6 @@ , "" , " To rerun use: --match \"/foo/bar/\"" , ""-#if __GLASGOW_HASKELL__ == 800- , "WARNING:"- , " Your version of GHC is affected by https://ghc.haskell.org/trac/ghc/ticket/13285."- , " Source locations may not work as expected."- , ""- , " Please consider upgrading GHC!"- , ""-#endif , "Randomized with seed 23" , "" , "Finished in 0.0000 seconds"@@ -442,6 +412,25 @@ , red ++ " but got: " ++ reset ++ "23" ] + context "with --print-slow-items" $ do+ it "prints slow items" $ do+ r <- captureLines . ignoreExitCode . withArgs ["--print-slow-items"] . H.hspec $ do+ H.it "foo" $ threadDelay 2000+ normalizeTimes (normalizeSummary r) `shouldBe` [+ ""+ , "foo"+ , ""+ , "Finished in 0.0000 seconds"+ , "1 example, 0 failures"+ , ""+ , "Slow spec items:"+#if MIN_VERSION_base(4,8,1)+ , " test/Test/Hspec/Core/RunnerSpec.hs:418:11: /foo/ (2ms)"+#else+ , " /foo/ (2ms)"+#endif+ ]+ context "with --format" $ do it "uses specified formatter" $ do r <- capture_ . ignoreExitCode . withArgs ["--format", "progress"] . H.hspec $ do@@ -551,7 +540,7 @@ r `shouldBe` "Foo.Bar" it "can use a custom formatter" $ do- r <- capture_ . H.hspecWithResult H.defaultConfig {H.configFormatter = Just H.silent} $ do+ r <- capture_ . H.hspecWithResult H.defaultConfig {H.configFormat = Just $ V2.formatterToFormat V2.silent} $ do H.describe "Foo.Bar" $ do H.it "some example" True r `shouldBe` ""
test/Test/Hspec/Core/ShuffleSpec.hs view
@@ -32,8 +32,8 @@ it "recurses into NodeWithCleanup" $ do shuffleForest 1- [NodeWithCleanup () [NodeWithCleanup () [Leaf 1, Leaf 2, Leaf 3]]] `shouldBe`- [NodeWithCleanup () [NodeWithCleanup () [Leaf 2, Leaf 3, Leaf 1]]]+ [NodeWithCleanup Nothing () [NodeWithCleanup Nothing () [Leaf 1, Leaf 2, Leaf 3]]] `shouldBe`+ [NodeWithCleanup Nothing () [NodeWithCleanup Nothing () [Leaf 2, Leaf 3, Leaf 1]]] describe "shuffle" $ do it "shuffles a list" $ do
test/Test/Hspec/Core/TimerSpec.hs view
@@ -1,5 +1,6 @@ module Test.Hspec.Core.TimerSpec (spec) where +import Prelude () import Helper -- import Test.Hspec.Core.Timer
test/Test/Hspec/Core/UtilSpec.hs view
@@ -1,6 +1,8 @@ module Test.Hspec.Core.UtilSpec (spec) where +import Prelude () import Helper+ import Control.Concurrent import qualified Control.Exception as E
vendor/Control/Concurrent/Async.hs view
@@ -6,7 +6,7 @@ #if __GLASGOW_HASKELL__ < 710 {-# LANGUAGE DeriveDataTypeable #-} #endif-{-# OPTIONS -Wall #-}+{-# OPTIONS -Wall -fno-warn-implicit-prelude #-} ----------------------------------------------------------------------------- -- |
version.yaml view
@@ -1,1 +1,1 @@-&version 2.7.10+&version 2.8.0