diff --git a/hspec-core.cabal b/hspec-core.cabal --- a/hspec-core.cabal +++ b/hspec-core.cabal @@ -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 diff --git a/src/Test/Hspec/Core/Clock.hs b/src/Test/Hspec/Core/Clock.hs --- a/src/Test/Hspec/Core/Clock.hs +++ b/src/Test/Hspec/Core/Clock.hs @@ -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) diff --git a/src/Test/Hspec/Core/Compat.hs b/src/Test/Hspec/Core/Compat.hs --- a/src/Test/Hspec/Core/Compat.hs +++ b/src/Test/Hspec/Core/Compat.hs @@ -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 diff --git a/src/Test/Hspec/Core/Config.hs b/src/Test/Hspec/Core/Config.hs --- a/src/Test/Hspec/Core/Config.hs +++ b/src/Test/Hspec/Core/Config.hs @@ -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)} diff --git a/src/Test/Hspec/Core/Config/Options.hs b/src/Test/Hspec/Core/Config/Options.hs --- a/src/Test/Hspec/Core/Config/Options.hs +++ b/src/Test/Hspec/Core/Config/Options.hs @@ -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 diff --git a/src/Test/Hspec/Core/Config/Util.hs b/src/Test/Hspec/Core/Config/Util.hs --- a/src/Test/Hspec/Core/Config/Util.hs +++ b/src/Test/Hspec/Core/Config/Util.hs @@ -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 diff --git a/src/Test/Hspec/Core/Example.hs b/src/Test/Hspec/Core/Example.hs --- a/src/Test/Hspec/Core/Example.hs +++ b/src/Test/Hspec/Core/Example.hs @@ -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 diff --git a/src/Test/Hspec/Core/Example/Location.hs b/src/Test/Hspec/Core/Example/Location.hs --- a/src/Test/Hspec/Core/Example/Location.hs +++ b/src/Test/Hspec/Core/Example/Location.hs @@ -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 diff --git a/src/Test/Hspec/Core/Format.hs b/src/Test/Hspec/Core/Format.hs --- a/src/Test/Hspec/Core/Format.hs +++ b/src/Test/Hspec/Core/Format.hs @@ -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 diff --git a/src/Test/Hspec/Core/Formatters.hs b/src/Test/Hspec/Core/Formatters.hs --- a/src/Test/Hspec/Core/Formatters.hs +++ b/src/Test/Hspec/Core/Formatters.hs @@ -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 diff --git a/src/Test/Hspec/Core/Formatters/Diff.hs b/src/Test/Hspec/Core/Formatters/Diff.hs --- a/src/Test/Hspec/Core/Formatters/Diff.hs +++ b/src/Test/Hspec/Core/Formatters/Diff.hs @@ -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] diff --git a/src/Test/Hspec/Core/Formatters/Internal.hs b/src/Test/Hspec/Core/Formatters/Internal.hs --- a/src/Test/Hspec/Core/Formatters/Internal.hs +++ b/src/Test/Hspec/Core/Formatters/Internal.hs @@ -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) diff --git a/src/Test/Hspec/Core/Formatters/Monad.hs b/src/Test/Hspec/Core/Formatters/Monad.hs --- a/src/Test/Hspec/Core/Formatters/Monad.hs +++ b/src/Test/Hspec/Core/Formatters/Monad.hs @@ -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) diff --git a/src/Test/Hspec/Core/Formatters/V1.hs b/src/Test/Hspec/Core/Formatters/V1.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Formatters/V1.hs @@ -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 diff --git a/src/Test/Hspec/Core/Formatters/V2.hs b/src/Test/Hspec/Core/Formatters/V2.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Formatters/V2.hs @@ -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 ++ ": " diff --git a/src/Test/Hspec/Core/Hooks.hs b/src/Test/Hspec/Core/Hooks.hs --- a/src/Test/Hspec/Core/Hooks.hs +++ b/src/Test/Hspec/Core/Hooks.hs @@ -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. diff --git a/src/Test/Hspec/Core/QuickCheck.hs b/src/Test/Hspec/Core/QuickCheck.hs --- a/src/Test/Hspec/Core/QuickCheck.hs +++ b/src/Test/Hspec/Core/QuickCheck.hs @@ -7,6 +7,9 @@ , modifyMaxShrinks ) where +import Prelude () +import Test.Hspec.Core.Compat + import Test.QuickCheck import Test.Hspec.Core.Spec diff --git a/src/Test/Hspec/Core/QuickCheckUtil.hs b/src/Test/Hspec/Core/QuickCheckUtil.hs --- a/src/Test/Hspec/Core/QuickCheckUtil.hs +++ b/src/Test/Hspec/Core/QuickCheckUtil.hs @@ -5,7 +5,6 @@ import Test.Hspec.Core.Compat import Control.Exception -import Data.List import Data.Maybe import Data.Int import System.Random diff --git a/src/Test/Hspec/Core/Runner.hs b/src/Test/Hspec/Core/Runner.hs --- a/src/Test/Hspec/Core/Runner.hs +++ b/src/Test/Hspec/Core/Runner.hs @@ -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) diff --git a/src/Test/Hspec/Core/Runner/Eval.hs b/src/Test/Hspec/Core/Runner/Eval.hs --- a/src/Test/Hspec/Core/Runner/Eval.hs +++ b/src/Test/Hspec/Core/Runner/Eval.hs @@ -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) diff --git a/src/Test/Hspec/Core/Runner/PrintSlowSpecItems.hs b/src/Test/Hspec/Core/Runner/PrintSlowSpecItems.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Runner/PrintSlowSpecItems.hs @@ -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)" diff --git a/src/Test/Hspec/Core/Shuffle.hs b/src/Test/Hspec/Core/Shuffle.hs --- a/src/Test/Hspec/Core/Shuffle.hs +++ b/src/Test/Hspec/Core/Shuffle.hs @@ -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] diff --git a/src/Test/Hspec/Core/Tree.hs b/src/Test/Hspec/Core/Tree.hs --- a/src/Test/Hspec/Core/Tree.hs +++ b/src/Test/Hspec/Core/Tree.hs @@ -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 diff --git a/src/Test/Hspec/Core/Util.hs b/src/Test/Hspec/Core/Util.hs --- a/src/Test/Hspec/Core/Util.hs +++ b/src/Test/Hspec/Core/Util.hs @@ -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 diff --git a/test/All.hs b/test/All.hs --- a/test/All.hs +++ b/test/All.hs @@ -1,1 +1,2 @@ +{-# OPTIONS -fno-warn-implicit-prelude #-} {-# OPTIONS_GHC -fforce-recomp -F -pgmF hspec-meta-discover -optF --module-name=All #-} diff --git a/test/Helper.hs b/test/Helper.hs --- a/test/Helper.hs +++ b/test/Helper.hs @@ -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}} diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,5 +1,8 @@ module Main where +import Prelude () +import Helper + import Test.Hspec.Meta import System.SetEnv import qualified All diff --git a/test/Test/Hspec/Core/ClockSpec.hs b/test/Test/Hspec/Core/ClockSpec.hs --- a/test/Test/Hspec/Core/ClockSpec.hs +++ b/test/Test/Hspec/Core/ClockSpec.hs @@ -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 diff --git a/test/Test/Hspec/Core/CompatSpec.hs b/test/Test/Hspec/Core/CompatSpec.hs --- a/test/Test/Hspec/Core/CompatSpec.hs +++ b/test/Test/Hspec/Core/CompatSpec.hs @@ -1,7 +1,9 @@ {-# LANGUAGE DeriveDataTypeable #-} module Test.Hspec.Core.CompatSpec (spec) where +import Prelude () import Helper + import System.SetEnv import Data.Typeable diff --git a/test/Test/Hspec/Core/Config/OptionsSpec.hs b/test/Test/Hspec/Core/Config/OptionsSpec.hs --- a/test/Test/Hspec/Core/Config/OptionsSpec.hs +++ b/test/Test/Hspec/Core/Config/OptionsSpec.hs @@ -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 diff --git a/test/Test/Hspec/Core/Config/UtilSpec.hs b/test/Test/Hspec/Core/Config/UtilSpec.hs --- a/test/Test/Hspec/Core/Config/UtilSpec.hs +++ b/test/Test/Hspec/Core/Config/UtilSpec.hs @@ -1,5 +1,6 @@ module Test.Hspec.Core.Config.UtilSpec (spec) where +import Prelude () import Helper import System.Console.GetOpt diff --git a/test/Test/Hspec/Core/ConfigSpec.hs b/test/Test/Hspec/Core/ConfigSpec.hs --- a/test/Test/Hspec/Core/ConfigSpec.hs +++ b/test/Test/Hspec/Core/ConfigSpec.hs @@ -1,6 +1,8 @@ module Test.Hspec.Core.ConfigSpec (spec) where +import Prelude () import Helper + import System.Directory import System.FilePath diff --git a/test/Test/Hspec/Core/Example/LocationSpec.hs b/test/Test/Hspec/Core/Example/LocationSpec.hs --- a/test/Test/Hspec/Core/Example/LocationSpec.hs +++ b/test/Test/Hspec/Core/Example/LocationSpec.hs @@ -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 diff --git a/test/Test/Hspec/Core/ExampleSpec.hs b/test/Test/Hspec/Core/ExampleSpec.hs --- a/test/Test/Hspec/Core/ExampleSpec.hs +++ b/test/Test/Hspec/Core/ExampleSpec.hs @@ -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) diff --git a/test/Test/Hspec/Core/FailureReportSpec.hs b/test/Test/Hspec/Core/FailureReportSpec.hs --- a/test/Test/Hspec/Core/FailureReportSpec.hs +++ b/test/Test/Hspec/Core/FailureReportSpec.hs @@ -1,5 +1,6 @@ module Test.Hspec.Core.FailureReportSpec (spec) where +import Prelude () import Helper import System.IO diff --git a/test/Test/Hspec/Core/Formatters/V1Spec.hs b/test/Test/Hspec/Core/Formatters/V1Spec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/Formatters/V1Spec.hs @@ -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"] diff --git a/test/Test/Hspec/Core/Formatters/V2Spec.hs b/test/Test/Hspec/Core/Formatters/V2Spec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/Formatters/V2Spec.hs @@ -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"] diff --git a/test/Test/Hspec/Core/FormattersSpec.hs b/test/Test/Hspec/Core/FormattersSpec.hs deleted file mode 100644 --- a/test/Test/Hspec/Core/FormattersSpec.hs +++ /dev/null @@ -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"] diff --git a/test/Test/Hspec/Core/HooksSpec.hs b/test/Test/Hspec/Core/HooksSpec.hs --- a/test/Test/Hspec/Core/HooksSpec.hs +++ b/test/Test/Hspec/Core/HooksSpec.hs @@ -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) diff --git a/test/Test/Hspec/Core/QuickCheckUtilSpec.hs b/test/Test/Hspec/Core/QuickCheckUtilSpec.hs --- a/test/Test/Hspec/Core/QuickCheckUtilSpec.hs +++ b/test/Test/Hspec/Core/QuickCheckUtilSpec.hs @@ -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 diff --git a/test/Test/Hspec/Core/Runner/PrintSlowSpecItemsSpec.hs b/test/Test/Hspec/Core/Runner/PrintSlowSpecItemsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/Runner/PrintSlowSpecItemsSpec.hs @@ -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` "" diff --git a/test/Test/Hspec/Core/RunnerSpec.hs b/test/Test/Hspec/Core/RunnerSpec.hs --- a/test/Test/Hspec/Core/RunnerSpec.hs +++ b/test/Test/Hspec/Core/RunnerSpec.hs @@ -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` "" diff --git a/test/Test/Hspec/Core/ShuffleSpec.hs b/test/Test/Hspec/Core/ShuffleSpec.hs --- a/test/Test/Hspec/Core/ShuffleSpec.hs +++ b/test/Test/Hspec/Core/ShuffleSpec.hs @@ -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 diff --git a/test/Test/Hspec/Core/TimerSpec.hs b/test/Test/Hspec/Core/TimerSpec.hs --- a/test/Test/Hspec/Core/TimerSpec.hs +++ b/test/Test/Hspec/Core/TimerSpec.hs @@ -1,5 +1,6 @@ module Test.Hspec.Core.TimerSpec (spec) where +import Prelude () import Helper -- import Test.Hspec.Core.Timer diff --git a/test/Test/Hspec/Core/UtilSpec.hs b/test/Test/Hspec/Core/UtilSpec.hs --- a/test/Test/Hspec/Core/UtilSpec.hs +++ b/test/Test/Hspec/Core/UtilSpec.hs @@ -1,6 +1,8 @@ module Test.Hspec.Core.UtilSpec (spec) where +import Prelude () import Helper + import Control.Concurrent import qualified Control.Exception as E diff --git a/vendor/Control/Concurrent/Async.hs b/vendor/Control/Concurrent/Async.hs --- a/vendor/Control/Concurrent/Async.hs +++ b/vendor/Control/Concurrent/Async.hs @@ -6,7 +6,7 @@ #if __GLASGOW_HASKELL__ < 710 {-# LANGUAGE DeriveDataTypeable #-} #endif -{-# OPTIONS -Wall #-} +{-# OPTIONS -Wall -fno-warn-implicit-prelude #-} ----------------------------------------------------------------------------- -- | diff --git a/version.yaml b/version.yaml --- a/version.yaml +++ b/version.yaml @@ -1,1 +1,1 @@ -&version 2.7.10 +&version 2.8.0