diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2011-2021 Simon Hengel +Copyright (c) 2011-2022 Simon Hengel Copyright (c) 2011-2012 Trystan Spangler Copyright (c) 2011-2011 Greg Weber diff --git a/hspec-core/src/NonEmpty.hs b/hspec-core/src/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/hspec-core/src/NonEmpty.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +module NonEmpty ( + NonEmpty(..) +, nonEmpty +, reverse +#ifdef TEST +, fromList +#endif +) where + +import Prelude () +import Test.Hspec.Core.Compat hiding (reverse) + +import qualified Data.List as List +import qualified Data.Foldable as Foldable + +data NonEmpty a = a :| [a] + deriving (Eq, Show, Functor, Foldable, Traversable) + +infixr 5 :| + +nonEmpty :: [a] -> Maybe (NonEmpty a) +nonEmpty [] = Nothing +nonEmpty (a:as) = Just (a :| as) + +reverse :: NonEmpty a -> NonEmpty a +reverse = lift List.reverse + +lift :: Foldable f => ([a] -> [b]) -> f a -> NonEmpty b +lift f = fromList . f . Foldable.toList + +fromList :: [a] -> NonEmpty a +fromList (a:as) = a :| as +fromList [] = error "NonEmpty.fromList: empty list" diff --git a/hspec-core/src/Test/Hspec/Core/Clock.hs b/hspec-core/src/Test/Hspec/Core/Clock.hs --- a/hspec-core/src/Test/Hspec/Core/Clock.hs +++ b/hspec-core/src/Test/Hspec/Core/Clock.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} module Test.Hspec.Core.Clock ( Seconds(..) , toMilliseconds @@ -13,10 +14,15 @@ import Test.Hspec.Core.Compat import Text.Printf -import System.Clock import Control.Concurrent import qualified System.Timeout as System +#if MIN_VERSION_base(4,11,0) +import qualified GHC.Clock as GHC +#else +import Data.Time.Clock.POSIX +#endif + newtype Seconds = Seconds Double deriving (Eq, Show, Ord, Num, Fractional, PrintfArg) @@ -27,9 +33,13 @@ toMicroseconds (Seconds s) = floor (s * 1000000) getMonotonicTime :: IO Seconds +#if MIN_VERSION_base(4,11,0) +getMonotonicTime = Seconds <$> GHC.getMonotonicTime +#else getMonotonicTime = do - t <- getTime Monotonic - return $ Seconds ((fromIntegral . toNanoSecs $ t) / 1000000000) + t <- getPOSIXTime + return $ Seconds (realToFrac t) +#endif measure :: IO a -> IO (Seconds, a) measure action = do diff --git a/hspec-core/src/Test/Hspec/Core/Compat.hs b/hspec-core/src/Test/Hspec/Core/Compat.hs --- a/hspec-core/src/Test/Hspec/Core/Compat.hs +++ b/hspec-core/src/Test/Hspec/Core/Compat.hs @@ -4,6 +4,7 @@ , module Test.Hspec.Core.Compat ) where +import Control.Arrow as Imports ((>>>), (&&&), first, second) import Control.Applicative as Imports import Control.Monad as Imports hiding ( mapM @@ -68,6 +69,7 @@ import Text.Read as Imports (readMaybe) import System.Environment as Imports (lookupEnv) #else +import Control.Exception import Text.Read import System.Environment import qualified Text.ParserCombinators.ReadP as P @@ -87,6 +89,11 @@ #endif #if !MIN_VERSION_base(4,6,0) +forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId +forkFinally action and_then = + mask $ \restore -> + forkIO $ try (restore action) >>= and_then + -- |Strict version of 'modifyIORef' modifyIORef' :: IORef a -> (a -> a) -> IO () modifyIORef' ref f = do diff --git a/hspec-core/src/Test/Hspec/Core/Config/Definition.hs b/hspec-core/src/Test/Hspec/Core/Config/Definition.hs --- a/hspec-core/src/Test/Hspec/Core/Config/Definition.hs +++ b/hspec-core/src/Test/Hspec/Core/Config/Definition.hs @@ -13,7 +13,7 @@ , runnerOptions #ifdef TEST -, formatOrList +, splitOn #endif ) where @@ -22,6 +22,7 @@ import Test.Hspec.Core.Example (Params(..), defaultParams) import Test.Hspec.Core.Format (Format, FormatConfig) +import Test.Hspec.Core.Formatters.Pretty (pretty2) import qualified Test.Hspec.Core.Formatters.V1 as V1 import qualified Test.Hspec.Core.Formatters.V2 as V2 import Test.Hspec.Core.Util @@ -39,7 +40,9 @@ configIgnoreConfigFile :: Bool , configDryRun :: Bool , configFocusedOnly :: Bool +, configFailOnEmpty :: Bool , configFailOnFocused :: Bool +, configFailOnPending :: Bool , configPrintSlowItems :: Maybe Int , configPrintCpuTime :: Bool , configFailFast :: Bool @@ -58,11 +61,12 @@ , configQuickCheckMaxDiscardRatio :: Maybe Int , configQuickCheckMaxSize :: Maybe Int , configQuickCheckMaxShrinks :: Maybe Int -, configSmallCheckDepth :: Int +, configSmallCheckDepth :: Maybe Int , configColorMode :: ColorMode , configUnicodeMode :: UnicodeMode , configDiff :: Bool , configPrettyPrint :: Bool +, configPrettyPrintFunction :: Bool -> String -> String -> (String, String) , configTimes :: Bool , configAvailableFormatters :: [(String, FormatConfig -> IO Format)] , configFormat :: Maybe (FormatConfig -> IO Format) @@ -76,7 +80,9 @@ configIgnoreConfigFile = False , configDryRun = False , configFocusedOnly = False +, configFailOnEmpty = False , configFailOnFocused = False +, configFailOnPending = False , configPrintSlowItems = Nothing , configPrintCpuTime = False , configFailFast = False @@ -96,6 +102,7 @@ , configUnicodeMode = UnicodeAuto , configDiff = True , configPrettyPrint = True +, configPrettyPrintFunction = pretty2 , configTimes = False , configAvailableFormatters = map (fmap V2.formatterToFormat) [ ("checks", V2.checks) @@ -195,7 +202,7 @@ ] setDepth :: Int -> Config -> Config -setDepth n c = c {configSmallCheckDepth = n} +setDepth n c = c {configSmallCheckDepth = Just n} quickCheckOptions :: [Option Config] quickCheckOptions = [ @@ -224,11 +231,46 @@ setSeed :: Integer -> Config -> Config setSeed n c = c {configQuickCheckSeed = Just n} +data FailOn = + FailOnEmpty + | FailOnFocused + | FailOnPending + deriving (Bounded, Enum) + +allFailOnItems :: [FailOn] +allFailOnItems = [minBound .. maxBound] + +showFailOn :: FailOn -> String +showFailOn item = case item of + FailOnEmpty -> "empty" + FailOnFocused -> "focused" + FailOnPending -> "pending" + +readFailOn :: String -> Maybe FailOn +readFailOn = (`lookup` items) + where + items = map (showFailOn &&& id) allFailOnItems + +splitOn :: Char -> String -> [String] +splitOn sep = go + where + go xs = case break (== sep) xs of + ("", "") -> [] + (y, "") -> [y] + (y, _ : ys) -> y : go ys + runnerOptions :: [Option Config] runnerOptions = [ mkFlag "dry-run" setDryRun "pretend that everything passed; don't verify anything" , mkFlag "focused-only" setFocusedOnly "do not run anything, unless there are focused spec items" - , mkFlag "fail-on-focused" setFailOnFocused "fail on focused spec items" + + , undocumented $ mkFlag "fail-on-focused" setFailOnFocused "fail on focused spec items" + , undocumented $ mkFlag "fail-on-pending" setFailOnPending "fail on pending spec items" + + , mkOption "fail-on" Nothing (argument "ITEMS" readFailOnItems (setFailOnItems True )) helpForFailOn + , mkOption "no-fail-on" Nothing (argument "ITEMS" readFailOnItems (setFailOnItems False)) helpForFailOn + , mkFlag "strict" setStrict $ "same as --fail-on=" <> showFailOnItems strict + , mkFlag "fail-fast" setFailFast "abort on first failure" , mkFlag "randomize" setRandomize "randomize execution order" , mkOptionNoArg "rerun" (Just 'r') setRerun "rerun all examples that failed in the previous test run (only works in combination with --failure-report or in GHCi)" @@ -237,6 +279,31 @@ , mkOption "jobs" (Just 'j') (argument "N" readMaxJobs setMaxJobs) "run at most N parallelizable tests simultaneously (default: number of available processors)" ] where + strict = allFailOnItems + + readFailOnItems :: String -> Maybe [FailOn] + readFailOnItems = mapM readFailOn . splitOn ',' + + showFailOnItems :: [FailOn] -> String + showFailOnItems = intercalate "," . map showFailOn + + helpForFailOn :: String + helpForFailOn = unlines . flip map allFailOnItems $ \ item -> + showFailOn item <> ": " <> help item + where + help item = case item of + FailOnEmpty -> "fail if no spec items have been run" + FailOnFocused -> "fail on focused spec items" + FailOnPending -> "fail on pending spec items" + + setFailOnItems :: Bool -> [FailOn] -> Config -> Config + setFailOnItems value = flip $ foldr (`setItem` value) + where + setItem item = case item of + FailOnEmpty -> setFailOnEmpty + FailOnFocused -> setFailOnFocused + FailOnPending -> setFailOnPending + readMaxJobs :: String -> Maybe Int readMaxJobs s = do n <- readMaybe s @@ -255,8 +322,17 @@ setFocusedOnly :: Bool -> Config -> Config setFocusedOnly value config = config {configFocusedOnly = value} + setFailOnEmpty :: Bool -> Config -> Config + setFailOnEmpty value config = config {configFailOnEmpty = value} + setFailOnFocused :: Bool -> Config -> Config setFailOnFocused value config = config {configFailOnFocused = value} + + setFailOnPending :: Bool -> Config -> Config + setFailOnPending value config = config {configFailOnPending = value} + + setStrict :: Bool -> Config -> Config + setStrict = (`setFailOnItems` strict) setFailFast :: Bool -> Config -> Config setFailFast value config = config {configFailFast = value} diff --git a/hspec-core/src/Test/Hspec/Core/Example.hs b/hspec-core/src/Test/Hspec/Core/Example.hs --- a/hspec-core/src/Test/Hspec/Core/Example.hs +++ b/hspec-core/src/Test/Hspec/Core/Example.hs @@ -5,8 +5,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} --- NOTE: re-exported from Test.Hspec.Core.Spec module Test.Hspec.Core.Example ( +-- RE-EXPORTED from Test.Hspec.Core.Spec Example (..) , Params (..) , defaultParams @@ -19,6 +19,8 @@ , FailureReason (..) , safeEvaluate , safeEvaluateExample +-- END RE-EXPORTED from Test.Hspec.Core.Spec +, safeEvaluateResultStatus ) where import Prelude () @@ -49,13 +51,13 @@ data Params = Params { paramsQuickCheckArgs :: QC.Args -, paramsSmallCheckDepth :: Int +, paramsSmallCheckDepth :: Maybe Int } deriving (Show) defaultParams :: Params defaultParams = Params { paramsQuickCheckArgs = QC.stdArgs -, paramsSmallCheckDepth = 5 +, paramsSmallCheckDepth = Nothing } type Progress = (Int, Int) @@ -106,12 +108,19 @@ safeEvaluate :: IO Result -> IO Result safeEvaluate action = do - r <- safeTry $ action + r <- safeTry action return $ case r of - Left e | Just result <- fromException e -> Result "" result - Left e | Just hunit <- fromException e -> Result "" $ hunitFailureToResult Nothing hunit - Left e -> Result "" $ Failure Nothing $ Error Nothing e + Left e -> Result "" (toResultStatus e) Right result -> result + +safeEvaluateResultStatus :: IO ResultStatus -> IO ResultStatus +safeEvaluateResultStatus action = either toResultStatus id <$> safeTry action + +toResultStatus :: SomeException -> ResultStatus +toResultStatus e + | Just result <- fromException e = result + | Just hunit <- fromException e = hunitFailureToResult Nothing hunit + | otherwise = Failure Nothing $ Error Nothing e instance Example Result where type Arg Result = () diff --git a/hspec-core/src/Test/Hspec/Core/Example/Location.hs b/hspec-core/src/Test/Hspec/Core/Example/Location.hs --- a/hspec-core/src/Test/Hspec/Core/Example/Location.hs +++ b/hspec-core/src/Test/Hspec/Core/Example/Location.hs @@ -3,11 +3,14 @@ Location(..) , extractLocation --- for testing +#ifdef TEST , parseAssertionFailed , parseCallStack , parseLocation , parseSourceSpan + +, workaroundForIssue19236 +#endif ) where import Prelude () @@ -18,6 +21,10 @@ import Data.Maybe import GHC.IO.Exception +#ifdef mingw32_HOST_OS +import System.FilePath +#endif + -- | @Location@ is used to represent source locations. data Location = Location { locationFile :: FilePath @@ -96,11 +103,11 @@ parseLocation :: String -> Maybe Location parseLocation input = case fmap breakColon (breakColon input) of - (file, (line, column)) -> Location file <$> readMaybe line <*> readMaybe column + (file, (line, column)) -> mkLocation file <$> readMaybe line <*> readMaybe column parseSourceSpan :: String -> Maybe Location parseSourceSpan input = case breakColon input of - (file, xs) -> (uncurry $ Location file) <$> (tuple <|> colonSeparated) + (file, xs) -> (uncurry $ mkLocation file) <$> (tuple <|> colonSeparated) where lineAndColumn :: String lineAndColumn = takeWhile (/= '-') xs @@ -114,3 +121,14 @@ breakColon :: String -> (String, String) breakColon = fmap (drop 1) . break (== ':') + +mkLocation :: FilePath -> Int -> Int -> Location +mkLocation file line column = Location (workaroundForIssue19236 file) line column + +workaroundForIssue19236 :: FilePath -> FilePath -- https://gitlab.haskell.org/ghc/ghc/-/issues/19236 +workaroundForIssue19236 = +#ifdef mingw32_HOST_OS + joinPath . splitDirectories +#else + id +#endif diff --git a/hspec-core/src/Test/Hspec/Core/Format.hs b/hspec-core/src/Test/Hspec/Core/Format.hs --- a/hspec-core/src/Test/Hspec/Core/Format.hs +++ b/hspec-core/src/Test/Hspec/Core/Format.hs @@ -56,15 +56,17 @@ data FormatConfig = FormatConfig { formatConfigUseColor :: Bool +, formatConfigReportProgress :: Bool , formatConfigOutputUnicode :: Bool , formatConfigUseDiff :: Bool -, formatConfigPrettyPrint :: Bool +, formatConfigPrettyPrint :: Bool -- ^ Deprecated: use `formatConfigPrettyPrintFunction` instead +, formatConfigPrettyPrintFunction :: Maybe (String -> String -> (String, String)) , formatConfigPrintTimes :: Bool , formatConfigHtmlOutput :: Bool , formatConfigPrintCpuTime :: Bool , formatConfigUsedSeed :: Integer , formatConfigExpectedTotalCount :: Int -} deriving (Eq, Show) +} data Signal = Ok | NotOk SomeException diff --git a/hspec-core/src/Test/Hspec/Core/Formatters.hs b/hspec-core/src/Test/Hspec/Core/Formatters.hs --- a/hspec-core/src/Test/Hspec/Core/Formatters.hs +++ b/hspec-core/src/Test/Hspec/Core/Formatters.hs @@ -1,2 +1,6 @@ -module Test.Hspec.Core.Formatters (module V1) where +-- | +-- Deprecated\: Use "Test.Hspec.Core.Formatters.V1" instead. +module Test.Hspec.Core.Formatters +-- {-# DEPRECATED "Use \"Test.Hspec.Core.Formatters.V1\" instead." #-} +(module V1) where import Test.Hspec.Core.Formatters.V1 as V1 diff --git a/hspec-core/src/Test/Hspec/Core/Formatters/Internal.hs b/hspec-core/src/Test/Hspec/Core/Formatters/Internal.hs --- a/hspec-core/src/Test/Hspec/Core/Formatters/Internal.hs +++ b/hspec-core/src/Test/Hspec/Core/Formatters/Internal.hs @@ -36,11 +36,13 @@ , useDiff , prettyPrint +, prettyPrintFunction , extraChunk , missingChunk #ifdef TEST -, overwriteWith +, runFormatM +, splitLines #endif ) where @@ -49,11 +51,12 @@ import qualified System.IO as IO import System.IO (Handle, stdout) -import Control.Exception (bracket_) +import Control.Exception (bracket_, bracket) import System.Console.ANSI import Control.Monad.Trans.State hiding (state, gets, modify) import Control.Monad.IO.Class import Data.Char (isSpace) +import Data.List (groupBy) import qualified System.CPUTime as CPUTime import Test.Hspec.Core.Formatters.V1.Monad (FailureRecord(..)) @@ -91,13 +94,14 @@ Progress path progress -> formatterProgress path progress ItemStarted path -> formatterItemStarted path ItemDone path item -> do - clearTransientOutput case itemResult item of Success {} -> increaseSuccessCount Pending {} -> increasePendingCount - Failure loc err -> addFailMessage (loc <|> itemLocation item) path err + Failure loc err -> addFailure $ FailureRecord (loc <|> itemLocation item) path err formatterItemDone path item Done _ -> formatterDone + where + addFailure r = modify $ \ s -> s { stateFailMessages = r : stateFailMessages s } -- | Get the number of failed examples encountered so far. getFailCount :: FormatM Int @@ -109,8 +113,16 @@ -- | Return `True` if the user requested pretty diffs, `False` otherwise. prettyPrint :: FormatM Bool -prettyPrint = getConfig formatConfigPrettyPrint +prettyPrint = maybe False (const True) <$> getConfig formatConfigPrettyPrintFunction +{-# DEPRECATED prettyPrint "use `prettyPrintFunction` instead" #-} +-- | Return a function for pretty-printing if the user requested pretty diffs, +-- `Nothing` otherwise. +-- +-- @since 2.10.0 +prettyPrintFunction :: FormatM (Maybe (String -> String -> (String, String))) +prettyPrintFunction = getConfig formatConfigPrettyPrintFunction + -- | Return `True` if the user requested unicode output, `False` otherwise. outputUnicode :: FormatM Bool outputUnicode = getConfig formatConfigOutputUnicode @@ -144,8 +156,8 @@ , stateFailMessages :: [FailureRecord] , stateCpuStartTime :: Maybe Integer , stateStartTime :: Seconds -, stateTransientOutput :: String -, stateConfig :: FormatConfig +, stateConfig :: FormatConfig +, stateColor :: Maybe SGR } getConfig :: (FormatConfig -> a) -> FormatM a @@ -164,12 +176,27 @@ deriving (Functor, Applicative, Monad, MonadIO) runFormatM :: FormatConfig -> FormatM a -> IO a -runFormatM config (FormatM action) = do +runFormatM config (FormatM action) = withLineBuffering $ do time <- getMonotonicTime cpuTime <- if (formatConfigPrintCpuTime config) then Just <$> CPUTime.getCPUTime else pure Nothing - st <- newIORef (FormatterState 0 0 [] cpuTime time "" config) - evalStateT action st + let + progress = formatConfigReportProgress config && not (formatConfigHtmlOutput config) + state = FormatterState { + stateSuccessCount = 0 + , statePendingCount = 0 + , stateFailMessages = [] + , stateCpuStartTime = cpuTime + , stateStartTime = time + , stateConfig = config { formatConfigReportProgress = progress } + , stateColor = Nothing + } + newIORef state >>= evalStateT action + +withLineBuffering :: IO a -> IO a +withLineBuffering action = bracket (IO.hGetBuffering stdout) (IO.hSetBuffering stdout) $ \ _ -> do + IO.hSetBuffering stdout IO.LineBuffering >> action + -- | Increase the counter for successful examples increaseSuccessCount :: FormatM () increaseSuccessCount = modify $ \s -> s {stateSuccessCount = succ $ stateSuccessCount s} @@ -186,10 +213,6 @@ getPendingCount :: FormatM Int getPendingCount = gets statePendingCount --- | Append to the list of accumulated failure messages. -addFailMessage :: Maybe Location -> Path -> FailureReason -> FormatM () -addFailMessage loc p m = modify $ \s -> s {stateFailMessages = FailureRecord loc p m : stateFailMessages s} - -- | Get the list of accumulated failure messages. getFailMessages :: FormatM [FailureRecord] getFailMessages = reverse `fmap` gets stateFailMessages @@ -199,35 +222,35 @@ getExpectedTotalCount :: FormatM Int getExpectedTotalCount = getConfig formatConfigExpectedTotalCount -overwriteWith :: String -> String -> String -overwriteWith old new - | n == 0 = new - | otherwise = '\r' : new ++ replicate (n - length new) ' ' - where - n = length old - writeTransient :: String -> FormatM () writeTransient new = do - useColor <- getConfig formatConfigUseColor - when (useColor) $ do - old <- gets stateTransientOutput - write $ old `overwriteWith` new - modify $ \ state -> state {stateTransientOutput = new} + reportProgress <- getConfig formatConfigReportProgress + when (reportProgress) $ do h <- getHandle + write $ new liftIO $ IO.hFlush h - -clearTransientOutput :: FormatM () -clearTransientOutput = do - n <- length <$> gets stateTransientOutput - unless (n == 0) $ do - write ("\r" ++ replicate n ' ' ++ "\r") - modify $ \ state -> state {stateTransientOutput = ""} + write $ "\r" ++ replicate (length new) ' ' ++ "\r" -- | Append some output to the report. write :: String -> FormatM () -write s = do +write = mapM_ writeChunk . splitLines + +splitLines :: String -> [String] +splitLines = groupBy (\ a b -> isNewline a == isNewline b) + where + isNewline = (== '\n') + +writeChunk :: String -> FormatM () +writeChunk str = do h <- getHandle - liftIO $ IO.hPutStr h s + let + plainOutput = IO.hPutStr h str + colorOutput color = bracket_ (hSetSGR h [color]) (hSetSGR h [Reset]) plainOutput + mColor <- gets stateColor + liftIO $ case mColor of + Just (SetColor Foreground _ _) | all isSpace str -> plainOutput + Just color -> colorOutput color + Nothing -> plainOutput -- | Set output color to red, run given action, and finally restore the default -- color. @@ -259,21 +282,15 @@ htmlSpan cls action = write ("") *> action <* write "" withColor_ :: SGR -> FormatM a -> FormatM a -withColor_ color (FormatM action) = do - useColor <- getConfig formatConfigUseColor - h <- getHandle - - FormatM . StateT $ \st -> do - bracket_ - - -- set color - (when useColor $ hSetSGR h [color]) - - -- reset colors - (when useColor $ hSetSGR h [Reset]) +withColor_ color action = do + oldColor <- gets stateColor + setColor (Just color) *> action <* setColor oldColor - -- run action - (runStateT action st) +setColor :: Maybe SGR -> FormatM () +setColor color = do + useColor <- getConfig formatConfigUseColor + when useColor $ do + modify (\ state -> state { stateColor = color }) -- | Output given chunk in red. extraChunk :: String -> FormatM () diff --git a/hspec-core/src/Test/Hspec/Core/Formatters/Pretty.hs b/hspec-core/src/Test/Hspec/Core/Formatters/Pretty.hs --- a/hspec-core/src/Test/Hspec/Core/Formatters/Pretty.hs +++ b/hspec-core/src/Test/Hspec/Core/Formatters/Pretty.hs @@ -11,7 +11,6 @@ import Prelude () import Test.Hspec.Core.Compat hiding (shows, intercalate) -import Control.Arrow import Data.Char import Data.String import Data.List (intersperse) @@ -99,7 +98,7 @@ Char c -> shows c String str -> if unicode then Builder $ ushows str else shows str Integer n -> shows n - Rational n -> shows n + Rational n -> fromString n render :: Expression -> Builder render expr = case expr of diff --git a/hspec-core/src/Test/Hspec/Core/Formatters/Pretty/Parser.hs b/hspec-core/src/Test/Hspec/Core/Formatters/Pretty/Parser.hs --- a/hspec-core/src/Test/Hspec/Core/Formatters/Pretty/Parser.hs +++ b/hspec-core/src/Test/Hspec/Core/Formatters/Pretty/Parser.hs @@ -16,8 +16,14 @@ import Test.Hspec.Core.Compat hiding (fail) import Test.Hspec.Core.Formatters.Pretty.Parser.Types -#if __GLASGOW_HASKELL__ < 802 || __GLASGOW_HASKELL__ > 902 +#ifndef __GHCJS__ +#if __GLASGOW_HASKELL__ >= 802 && __GLASGOW_HASKELL__ <= 904 +#define PRETTY_PRINTING_SUPPORTED +#endif +#endif +#ifndef PRETTY_PRINTING_SUPPORTED + parseExpression :: String -> Maybe Expression parseExpression _ = Nothing @@ -29,7 +35,12 @@ import GHC.Stack import GHC.Exception (throw, errorCallWithCallStackException) -#if __GLASGOW_HASKELL__ >= 804 +#if __GLASGOW_HASKELL__ >= 904 +import GHC.Utils.Error +import GHC.Utils.Outputable +#endif + +#if __GLASGOW_HASKELL__ >= 804 && __GLASGOW_HASKELL__ < 904 import GHC.LanguageExtensions.Type #endif @@ -46,7 +57,6 @@ import GHC.Data.StringBuffer import GHC.Data.FastString import GHC.Types.SrcLoc -import qualified GHC.Data.EnumSet as EnumSet import GHC.Types.Name import GHC.Types.Name.Reader import GHC.Parser.PostProcess hiding (Tuple) @@ -60,7 +70,12 @@ import RdrName import BasicTypes import Module -#if __GLASGOW_HASKELL__ >= 804 +#endif + +#if __GLASGOW_HASKELL__ >= 804 && __GLASGOW_HASKELL__ < 904 +#if __GLASGOW_HASKELL__ >= 900 +import qualified GHC.Data.EnumSet as EnumSet +#else import qualified EnumSet #endif #endif @@ -140,21 +155,30 @@ HsOverLit _x lit -> toExpression lit HsApp _x f x -> App <$> toExpression f <*> toExpression x NegApp _x e _ -> toExpression e >>= \ x -> case x of - Literal (Rational n) -> return $ Literal (Rational $ negate n) + Literal (Rational n) -> return $ Literal (Rational $ '-' : n) Literal (Integer n) -> return $ Literal (Integer $ negate n) _ -> fail "NegApp" - HsPar _x e -> Parentheses <$> toExpression e + + HsPar _x +#if __GLASGOW_HASKELL__ >= 904 + _ e _ -> +#else + e -> +#endif + Parentheses <$> toExpression e ExplicitTuple _x xs _ -> Tuple <$> mapM toExpression xs ExplicitList _ _listSynExpr xs -> List <$> mapM toExpression xs RecCon(name, fields) -> Record (showRdrName name) <$> (recordFields $ rec_flds fields) where +#if __GLASGOW_HASKELL__ >= 904 + hsRecFieldLbl = hfbLHS + hsRecFieldArg = hfbRHS +#endif fieldName = showFieldLabel . unLoc . hsRecFieldLbl recordFields = mapM (recordField . unLoc) recordField field = (,) (fieldName field) <$> toExpression (hsRecFieldArg field) REJECT(HsUnboundVar) - REJECT(HsConLikeOut) - REJECT(HsRecFld) REJECT(HsOverLabel) REJECT(HsIPVar) REJECT(HsLam) @@ -172,14 +196,15 @@ REJECT(RecordUpd) REJECT(ExprWithTySig) REJECT(ArithSeq) - REJECT(HsBracket) - REJECT(HsRnBracketOut) - REJECT(HsTcBracketOut) REJECT(HsSpliceE) REJECT(HsProc) REJECT(HsStatic) - REJECT(HsTick) - REJECT(HsBinTick) + +#if __GLASGOW_HASKELL__ >= 904 + REJECT(HsRecSel) + REJECT(HsTypedBracket) + REJECT(HsUntypedBracket) +#endif #if __GLASGOW_HASKELL__ >= 902 REJECT(HsGetField) REJECT(HsProjection) @@ -187,13 +212,23 @@ #if __GLASGOW_HASKELL__ >= 900 REJECT(HsPragE) #endif -#if __GLASGOW_HASKELL__ <= 810 + +#if __GLASGOW_HASKELL__ < 904 + REJECT(HsConLikeOut) + REJECT(HsRecFld) + REJECT(HsBracket) + REJECT(HsRnBracketOut) + REJECT(HsTcBracketOut) + REJECT(HsTick) + REJECT(HsBinTick) +#endif +#if __GLASGOW_HASKELL__ < 900 REJECT(HsSCC) REJECT(HsCoreAnn) REJECT(HsTickPragma) REJECT(HsWrap) #endif -#if __GLASGOW_HASKELL__ <= 808 +#if __GLASGOW_HASKELL__ < 810 REJECT(HsArrApp) REJECT(HsArrForm) REJECT(EWildPat) @@ -201,7 +236,7 @@ REJECT(EViewPat) REJECT(ELazyPat) #endif -#if __GLASGOW_HASKELL__ <= 804 +#if __GLASGOW_HASKELL__ < 806 REJECT(HsAppTypeOut) REJECT(ExplicitPArr) REJECT(ExprWithTySigOut) @@ -238,12 +273,14 @@ HsIsString _ str -> toExpression str instance ToExpression FractionalLit where - toExpression fl = toExpression (fl_value fl) - -#if __GLASGOW_HASKELL__ >= 902 -fl_value :: FractionalLit -> Rational -fl_value = rationalFromFractionalLit + toExpression fl = case fl_text fl of +#if __GLASGOW_HASKELL__ > 802 + REJECT(NoSourceText) + SourceText n +#else + n #endif + -> return . Literal $ Rational n instance ToExpression FastString where toExpression = return . Literal . String . unpackFS @@ -251,9 +288,6 @@ instance ToExpression Integer where toExpression = return . Literal . Integer -instance ToExpression Rational where - toExpression = return . Literal . Rational - instance ToExpression Char where toExpression = return . Literal . Char @@ -317,14 +351,24 @@ location = mkRealSrcLoc "" 1 1 input = stringToStringBuffer str parseState = initParserState opts input location - opts = mkParserOpts warn extensions False False False True + opts = mkParserOpts warn +#if __GLASGOW_HASKELL__ >= 904 + (DiagOpts mempty mempty False False Nothing defaultSDocContext) +#endif + extensions False False False True -#if __GLASGOW_HASKELL__ >= 804 - extensions = EnumSet.fromList [TraditionalRecordSyntax] +#if __GLASGOW_HASKELL__ >= 804 && __GLASGOW_HASKELL__ < 904 warn = EnumSet.empty #else - extensions = mempty warn = mempty +#endif + +#if __GLASGOW_HASKELL__ >= 904 + extensions = ["TraditionalRecordSyntax"] +#elif __GLASGOW_HASKELL__ >= 804 + extensions = EnumSet.fromList [TraditionalRecordSyntax] +#else + extensions = mempty #endif #if __GLASGOW_HASKELL__ <= 900 diff --git a/hspec-core/src/Test/Hspec/Core/Formatters/Pretty/Parser/Types.hs b/hspec-core/src/Test/Hspec/Core/Formatters/Pretty/Parser/Types.hs --- a/hspec-core/src/Test/Hspec/Core/Formatters/Pretty/Parser/Types.hs +++ b/hspec-core/src/Test/Hspec/Core/Formatters/Pretty/Parser/Types.hs @@ -17,5 +17,5 @@ Char Char | String String | Integer Integer - | Rational Rational + | Rational String deriving (Eq, Show) diff --git a/hspec-core/src/Test/Hspec/Core/Formatters/V2.hs b/hspec-core/src/Test/Hspec/Core/Formatters/V2.hs --- a/hspec-core/src/Test/Hspec/Core/Formatters/V2.hs +++ b/hspec-core/src/Test/Hspec/Core/Formatters/V2.hs @@ -59,6 +59,7 @@ , useDiff , prettyPrint +, prettyPrintFunction , extraChunk , missingChunk @@ -126,12 +127,12 @@ , useDiff , prettyPrint + , prettyPrintFunction , extraChunk , missingChunk ) import Test.Hspec.Core.Formatters.Diff -import Test.Hspec.Core.Formatters.Pretty (pretty2) silent :: Formatter silent = Formatter { @@ -275,11 +276,11 @@ NoReason -> return () Reason err -> withFailColor $ indent err ExpectedButGot preface expected_ actual_ -> do - pretty <- prettyPrint + pretty <- prettyPrintFunction let - (expected, actual) - | pretty = pretty2 unicode expected_ actual_ - | otherwise = (expected_, actual_) + (expected, actual) = case pretty of + Just f -> f expected_ actual_ + Nothing -> (expected_, actual_) mapM_ indent preface @@ -311,7 +312,9 @@ where indentation_ = indentation ++ replicate (length pre) ' ' - Error _ e -> withFailColor . indent $ (("uncaught exception: " ++) . formatException) e + Error info e -> do + mapM_ indent info + withFailColor . indent $ "uncaught exception: " ++ formatException e writeLine "" diff --git a/hspec-core/src/Test/Hspec/Core/Hooks.hs b/hspec-core/src/Test/Hspec/Core/Hooks.hs --- a/hspec-core/src/Test/Hspec/Core/Hooks.hs +++ b/hspec-core/src/Test/Hspec/Core/Hooks.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} @@ -22,15 +23,18 @@ , mapSubject , ignoreSubject + +#ifdef TEST +, decompose +#endif ) where import Prelude () import Test.Hspec.Core.Compat -import Data.CallStack +import Data.CallStack (HasCallStack) -import Control.Exception (SomeException, finally, throwIO, try, catch) -import Control.Concurrent.MVar -import Control.Concurrent.Async +import Control.Exception (SomeException, finally, throwIO, try) +import Control.Concurrent import Test.Hspec.Core.Example import Test.Hspec.Core.Tree @@ -49,19 +53,19 @@ beforeWith action = aroundWith $ \e x -> action x >>= e -- | Run a custom action before the first spec item. -beforeAll :: IO a -> SpecWith a -> Spec +beforeAll :: HasCallStack => IO a -> SpecWith a -> Spec beforeAll action spec = do mvar <- runIO (newMVar Empty) before (memoize mvar action) spec -- | Run a custom action before the first spec item. -beforeAll_ :: IO () -> SpecWith a -> SpecWith a +beforeAll_ :: HasCallStack => IO () -> SpecWith a -> SpecWith a beforeAll_ action spec = do mvar <- runIO (newMVar Empty) before_ (memoize mvar action) spec -- | Run a custom action with an argument before the first spec item. -beforeAllWith :: (b -> IO a) -> SpecWith a -> SpecWith b +beforeAllWith :: HasCallStack => (b -> IO a) -> SpecWith a -> SpecWith b beforeAllWith action spec = do mvar <- runIO (newMVar Empty) beforeWith (memoize mvar . action) spec @@ -71,14 +75,14 @@ | Memoized a | Failed SomeException -memoize :: MVar (Memoized a) -> IO a -> IO a +memoize :: HasCallStack => MVar (Memoized a) -> IO a -> IO a memoize mvar action = do result <- modifyMVar mvar $ \ma -> case ma of Empty -> do a <- try action return (either Failed Memoized a, a) Memoized a -> return (ma, Right a) - Failed _ -> throwIO (Pending Nothing (Just "exception in beforeAll-hook (see previous failure)")) + Failed _ -> throwIO (Pending Nothing (Just $ "exception in " <> maybe "beforeAll" fst callSite <> "-hook (see previous failure)")) either throwIO return result -- | Run a custom action after every spec item. @@ -95,11 +99,11 @@ -- | Run a custom action after the last spec item. afterAll :: HasCallStack => ActionWith a -> SpecWith a -> SpecWith a -afterAll action spec = runIO (runSpecM spec) >>= fromSpecList . return . NodeWithCleanup location action +afterAll action = aroundAllWith (\ hook a -> hook a >> action a) -- | Run a custom action after the last spec item. afterAll_ :: HasCallStack => IO () -> SpecWith a -> SpecWith a -afterAll_ action = afterAll (\_ -> action) +afterAll_ action = mapSpecForest (return . NodeWithCleanup callSite action) -- | Run a custom action before and/or after every spec item. around_ :: (IO () -> IO ()) -> SpecWith a -> SpecWith a @@ -107,60 +111,77 @@ -- | Run a custom action before and/or after every spec item. aroundWith :: (ActionWith a -> ActionWith b) -> SpecWith a -> SpecWith b -aroundWith action = mapSpecItem action (modifyAroundAction action) +aroundWith = mapSpecItem_ . modifyAroundAction modifyAroundAction :: (ActionWith a -> ActionWith b) -> Item a -> Item b modifyAroundAction action item@Item{itemExample = e} = item{ itemExample = \params aroundAction -> e params (aroundAction . action) } -- | Wrap an action around the given spec. -aroundAll :: (ActionWith a -> IO ()) -> SpecWith a -> Spec +aroundAll :: HasCallStack => (ActionWith a -> IO ()) -> SpecWith a -> Spec aroundAll action = aroundAllWith $ \ e () -> action e -- | Wrap an action around the given spec. -aroundAll_ :: (IO () -> IO ()) -> SpecWith a -> SpecWith a +aroundAll_ :: HasCallStack => (IO () -> IO ()) -> SpecWith a -> SpecWith a aroundAll_ action spec = do - allSpecItemsDone <- runIO newEmptyMVar - workerRef <- runIO newEmptyMVar - let - acquire :: IO () - acquire = do - resource <- newEmptyMVar - worker <- async $ do - action $ do - signal resource - waitFor allSpecItemsDone - putMVar workerRef worker - unwrapExceptionsFromLinkedThread $ do - link worker - waitFor resource - release :: IO () - release = signal allSpecItemsDone >> takeMVar workerRef >>= wait - beforeAll_ acquire $ afterAll_ release spec + (acquire, release) <- runIO $ decompose (action .) + beforeAll_ (acquire ()) $ afterAll_ release spec -- | Wrap an action around the given spec. Changes the arg type inside. -aroundAllWith :: forall a b. (ActionWith a -> ActionWith b) -> SpecWith a -> SpecWith b +aroundAllWith :: forall a b. HasCallStack => (ActionWith a -> ActionWith b) -> SpecWith a -> SpecWith b aroundAllWith action spec = do - allSpecItemsDone <- runIO newEmptyMVar - workerRef <- runIO newEmptyMVar + (acquire, release) <- runIO $ decompose action + beforeAllWith acquire $ afterAll_ release spec + +data Acquired a = Acquired a | ExceptionDuringAcquire SomeException +data Released = Released | ExceptionDuringRelease SomeException + +decompose :: forall a b. ((a -> IO ()) -> b -> IO ()) -> IO (b -> IO a, IO ()) +decompose action = do + doCleanupNow <- newEmptyMVar + acquired <- newEmptyMVar + released <- newEmptyMVar + let + notify :: Either SomeException () -> IO () + -- `notify` is guaranteed to run without being interrupted by an async + -- exception for the following reasons: + -- + -- 1. `forkFinally` runs the final action within `mask` + -- 2. `tryPutMVar` is guaranteed not to be interruptible + -- 3. `putMVar` is guaranteed not to be interruptible on an empty `MVar` + notify r = case r of + Left err -> do + exceptionDuringAcquire <- tryPutMVar acquired (ExceptionDuringAcquire err) + putMVar released $ if exceptionDuringAcquire then Released else ExceptionDuringRelease err + Right () -> do + putMVar released Released + + forkWorker :: b -> IO () + forkWorker b = void . flip forkFinally notify $ do + flip action b $ \ a -> do + putMVar acquired (Acquired a) + waitFor doCleanupNow + acquire :: b -> IO a acquire b = do - resource <- newEmptyMVar - worker <- async $ do - flip action b $ \ a -> do - putMVar resource a - waitFor allSpecItemsDone - putMVar workerRef worker - unwrapExceptionsFromLinkedThread $ do - link worker - takeMVar resource + forkWorker b + r <- readMVar acquired -- This does not work reliably with base < 4.7 + case r of + Acquired a -> return a + ExceptionDuringAcquire err -> throwIO err + release :: IO () - release = signal allSpecItemsDone >> takeMVar workerRef >>= wait - beforeAllWith acquire $ afterAll_ release spec + release = do + acquireHasNotBeenCalled <- isEmptyMVar acquired -- NOTE: This can happen if an outer beforeAll fails + unless acquireHasNotBeenCalled $ do + signal doCleanupNow + r <- takeMVar released + case r of + Released -> return () + ExceptionDuringRelease err -> throwIO err -unwrapExceptionsFromLinkedThread :: IO a -> IO a -unwrapExceptionsFromLinkedThread = (`catch` \ (ExceptionInLinkedThread _ e) -> throwIO e) + return (acquire, release) type BinarySemaphore = MVar () diff --git a/hspec-core/src/Test/Hspec/Core/Runner.hs b/hspec-core/src/Test/Hspec/Core/Runner.hs --- a/hspec-core/src/Test/Hspec/Core/Runner.hs +++ b/hspec-core/src/Test/Hspec/Core/Runner.hs @@ -5,8 +5,34 @@ -- Stability: provisional module Test.Hspec.Core.Runner ( -- * Running a spec +{- | +To run a spec `hspec` performs a sequence of steps: + +1. Evaluate a `Spec` to a forest of `SpecTree`s +1. Read config values from the command-line, config files and the process environment +1. Execute each spec item of the forest and report results to `stdout` +1. Exit with `exitFailure` if at least on spec item fails + +The four primitives `evalSpec`, `readConfig`, `runSpecForest` and +`evaluateResult` each perform one of these steps respectively. + +`hspec` is defined in terms of these primitives: + +@ +hspec = `evalSpec` `defaultConfig` >=> \\ (config, spec) -> + `getArgs` + >>= `readConfig` config + >>= `withArgs` [] . `runSpecForest` spec + >>= `evaluateResult` +@ + +If you need more control over how a spec is run use these primitives individually. + +-} hspec -, runSpec +, evalSpec +, runSpecForest +, evaluateResult -- * Config , Config (..) @@ -14,20 +40,40 @@ , UnicodeMode(..) , Path , defaultConfig +, registerFormatter +, registerDefaultFormatter , configAddFilter , readConfig --- * Summary -, Summary (..) -, isSuccess -, evaluateSummary +-- * Result +-- ** Spec Result +, Test.Hspec.Core.Runner.Result.SpecResult +, Test.Hspec.Core.Runner.Result.specResultItems +, Test.Hspec.Core.Runner.Result.specResultSuccess + +-- ** Result Item +, Test.Hspec.Core.Runner.Result.ResultItem +, Test.Hspec.Core.Runner.Result.resultItemPath +, Test.Hspec.Core.Runner.Result.resultItemStatus +, Test.Hspec.Core.Runner.Result.resultItemIsFailure + +-- ** Result Item Status +, Test.Hspec.Core.Runner.Result.ResultItemStatus(..) + -- * Legacy --- | The following primitives are deprecated. Use `runSpec` instead. +-- | The following primitives are deprecated. Use `runSpecForest` instead. , hspecWith , hspecResult , hspecWithResult +, runSpec +-- ** Summary +, Summary (..) +, toSummary +, isSuccess +, evaluateSummary + #ifdef TEST , rerunAll , specToEvalForest @@ -40,6 +86,7 @@ import Test.Hspec.Core.Compat import Data.Maybe +import NonEmpty (nonEmpty) import System.IO import System.Environment (getArgs, withArgs) import System.Exit @@ -47,15 +94,14 @@ import System.Random import Control.Monad.ST import Data.STRef -import System.Console.ANSI (hSupportsANSI) -import System.Console.ANSI (hHideCursor, hShowCursor) +import System.Console.ANSI (hSupportsANSI, hHideCursor, hShowCursor) import qualified Test.QuickCheck as QC import Test.Hspec.Core.Util (Path) -import Test.Hspec.Core.Spec +import Test.Hspec.Core.Spec hiding (pruneTree, pruneForest) import Test.Hspec.Core.Config -import Test.Hspec.Core.Format (FormatConfig(..)) +import Test.Hspec.Core.Format (Format, FormatConfig(..)) import qualified Test.Hspec.Core.Formatters.V1 as V1 import qualified Test.Hspec.Core.Formatters.V2 as V2 import Test.Hspec.Core.FailureReport @@ -63,9 +109,21 @@ import Test.Hspec.Core.Shuffle import Test.Hspec.Core.Runner.PrintSlowSpecItems -import Test.Hspec.Core.Runner.Eval +import Test.Hspec.Core.Runner.Eval hiding (Tree(..)) +import qualified Test.Hspec.Core.Runner.Eval as Eval +import Test.Hspec.Core.Runner.Result -applyFilterPredicates :: Config -> [EvalTree] -> [EvalTree] +-- | +-- Make a formatter available for use with @--format@. +registerFormatter :: (String, FormatConfig -> IO Format) -> Config -> Config +registerFormatter formatter config = config { configAvailableFormatters = formatter : configAvailableFormatters config } + +-- | +-- Make a formatter available for use with @--format@ and use it by default. +registerDefaultFormatter :: (String, FormatConfig -> IO Format) -> Config -> Config +registerDefaultFormatter formatter@(_, format) config = (registerFormatter formatter config) { configFormat = Just format } + +applyFilterPredicates :: Config -> [Tree c EvalItem] -> [Tree c EvalItem] applyFilterPredicates c = filterForestWithLabels p where include :: Path -> Bool @@ -79,7 +137,7 @@ where path = (groups, evalItemDescription item) -applyDryRun :: Config -> [EvalTree] -> [EvalTree] +applyDryRun :: Config -> [EvalItemTree] -> [EvalItemTree] applyDryRun c | configDryRun c = bimapForest removeCleanup markSuccess | otherwise = id @@ -94,15 +152,29 @@ -- Exit with `exitFailure` if at least one spec item fails. -- -- /Note/: `hspec` handles command-line options and reads config files. This --- is not always desired. Use `runSpec` if you need more control over these --- aspects. +-- is not always desirable. Use `evalSpec` and `runSpecForest` if you need +-- more control over these aspects. hspec :: Spec -> IO () -hspec spec = +hspec = evalSpec defaultConfig >=> \ (config, spec) -> getArgs - >>= readConfig defaultConfig - >>= doNotLeakCommandLineArgumentsToExamples . runSpec spec - >>= evaluateSummary + >>= readConfig config + >>= doNotLeakCommandLineArgumentsToExamples . runSpecForest spec + >>= evaluateResult +-- | +-- Evaluate a `Spec` to a forest of `SpecTree`s. This does not execute any +-- spec items, but it does run any IO that is used during spec construction +-- time (see `runIO`). +-- +-- A `Spec` may modify a `Config` through `modifyConfig`. These modifications +-- are applied to the given config (the first argument). +-- +-- @since 2.10.0 +evalSpec :: Config -> SpecWith a -> IO (Config, [SpecTree a]) +evalSpec config spec = do + (Endo f, forest) <- runSpecM spec + return (f config, forest) + -- Add a seed to given config if there is none. That way the same seed is used -- for all properties. This helps with --seed and --rerun. ensureSeed :: Config -> IO Config @@ -115,7 +187,7 @@ -- | Run given spec with custom options. -- This is similar to `hspec`, but more flexible. hspecWith :: Config -> Spec -> IO () -hspecWith config spec = getArgs >>= readConfig config >>= doNotLeakCommandLineArgumentsToExamples . runSpec spec >>= evaluateSummary +hspecWith defaults = hspecWithResult defaults >=> evaluateSummary -- | `True` if the given `Summary` indicates that there were no -- failures, `False` otherwise. @@ -127,13 +199,16 @@ evaluateSummary :: Summary -> IO () evaluateSummary summary = unless (isSuccess summary) exitFailure +evaluateResult :: SpecResult -> IO () +evaluateResult result = unless (specResultSuccess result) exitFailure + -- | Run given spec and returns a summary of the test run. -- -- /Note/: `hspecResult` does not exit with `exitFailure` on failing spec -- items. If you need this, you have to check the `Summary` yourself and act -- accordingly. hspecResult :: Spec -> IO Summary -hspecResult spec = getArgs >>= readConfig defaultConfig >>= doNotLeakCommandLineArgumentsToExamples . runSpec spec +hspecResult = hspecWithResult defaultConfig -- | Run given spec with custom options and returns a summary of the test run. -- @@ -141,21 +216,32 @@ -- items. If you need this, you have to check the `Summary` yourself and act -- accordingly. hspecWithResult :: Config -> Spec -> IO Summary -hspecWithResult config spec = getArgs >>= readConfig config >>= doNotLeakCommandLineArgumentsToExamples . runSpec spec +hspecWithResult defaults = evalSpec defaults >=> \ (config, spec) -> + getArgs + >>= readConfig config + >>= doNotLeakCommandLineArgumentsToExamples . fmap toSummary . runSpecForest spec -- | --- `runSpec` is the most basic primitive to run a spec. `hspec` is defined in --- terms of @runSpec@: +-- /Note/: `runSpec` is deprecated. It ignores any modifications applied +-- through `modifyConfig`. Use `evalSpec` and `runSpecForest` instead. +runSpec :: Spec -> Config -> IO Summary +runSpec spec config = evalSpec defaultConfig spec >>= fmap toSummary . flip runSpecForest config . snd + +-- | +-- `runSpecForest` is the most basic primitive to run a spec. `hspec` is +-- defined in terms of @runSpecForest@: -- -- @ --- hspec spec = +-- hspec = `evalSpec` `defaultConfig` >=> \\ (config, spec) -> -- `getArgs` --- >>= `readConfig` `defaultConfig` --- >>= `withArgs` [] . runSpec spec --- >>= `evaluateSummary` +-- >>= `readConfig` config +-- >>= `withArgs` [] . runSpecForest spec +-- >>= `evaluateResult` -- @ -runSpec :: Spec -> Config -> IO Summary -runSpec spec c_ = do +-- +-- @since 2.10.0 +runSpecForest :: [SpecTree ()] -> Config -> IO SpecResult +runSpecForest spec c_ = do oldFailureReport <- readFailureReportOnRerun c_ c <- ensureSeed (applyFailureReport oldFailureReport c_) @@ -172,17 +258,28 @@ then rerunAllMode c oldFailureReport else normalMode c where - normalMode c = runSpec_ c spec + normalMode c = runSpecForest_ c spec rerunAllMode c oldFailureReport = do - summary <- runSpec_ c spec - if rerunAll c oldFailureReport summary - then runSpec spec c_ - else return summary + result <- runSpecForest_ c spec + if rerunAll c oldFailureReport result + then runSpecForest spec c_ + else return result +runSpecForest_ :: Config -> [SpecTree ()] -> IO SpecResult +runSpecForest_ config spec = runEvalTree config (specToEvalForest config spec) + +mapItem :: (Item a -> Item b) -> [SpecTree a] -> [SpecTree b] +mapItem f = map (fmap f) + +failFocusedItems :: Config -> [SpecTree a] -> [SpecTree a] +failFocusedItems config + | configFailOnFocused config = mapItem failFocused + | otherwise = id + failFocused :: Item a -> Item a failFocused item = item {itemExample = example} where - failure = Failure Nothing (Reason "item is focused; failing due to --fail-on-focused") + failure = Failure Nothing (Reason "item is focused; failing due to --fail-on=focused") example | itemIsFocused item = \ params hook p -> do Result info status <- itemExample item params hook p @@ -192,38 +289,49 @@ Failure{} -> status | otherwise = itemExample item -failFocusedItems :: Config -> Spec -> Spec -failFocusedItems config spec - | configFailOnFocused config = mapSpecItem_ failFocused spec - | otherwise = spec +failPendingItems :: Config -> [SpecTree a] -> [SpecTree a] +failPendingItems config + | configFailOnPending config = mapItem failPending + | otherwise = id -focusSpec :: Config -> Spec -> Spec +failPending :: Item a -> Item a +failPending item = item {itemExample = example} + where + example params hook p = do + Result info status <- itemExample item params hook p + return $ Result info $ case status of + Pending loc _ -> Failure loc (Reason "item is pending; failing due to --fail-on=pending") + _ -> status + +focusSpec :: Config -> [SpecTree a] -> [SpecTree a] focusSpec config spec | configFocusedOnly config = spec - | otherwise = focus spec + | otherwise = focusForest spec -runSpec_ :: Config -> Spec -> IO Summary -runSpec_ config spec = do - filteredSpec <- specToEvalForest config spec +runEvalTree :: Config -> [EvalTree] -> IO SpecResult +runEvalTree config spec = do let + failOnEmpty = configFailOnEmpty config seed = (fromJust . configQuickCheckSeed) config qcArgs = configQuickCheckArgs config - !numberOfItems = countSpecItems filteredSpec + !numberOfItems = countSpecItems spec concurrentJobs <- case configConcurrentJobs config of Nothing -> getDefaultConcurrentJobs Just n -> return n - useColor <- colorOutputSupported (configColorMode config) (hSupportsANSI stdout) + (reportProgress, useColor) <- colorOutputSupported (configColorMode config) (hSupportsANSI stdout) outputUnicode <- unicodeOutputSupported (configUnicodeMode config) stdout - results <- withHiddenCursor useColor stdout $ do + results <- fmap (toSpecResult failOnEmpty) . withHiddenCursor reportProgress stdout $ do let formatConfig = FormatConfig { formatConfigUseColor = useColor + , formatConfigReportProgress = reportProgress , formatConfigOutputUnicode = outputUnicode , formatConfigUseDiff = configDiff config , formatConfigPrettyPrint = configPrettyPrint config + , formatConfigPrettyPrintFunction = if configPrettyPrint config then Just (configPrettyPrintFunction config outputUnicode) else Nothing , formatConfigPrintTimes = configTimes config , formatConfigHtmlOutput = configHtmlOutput config , formatConfigPrintCpuTime = configPrintCpuTime config @@ -241,31 +349,57 @@ , evalConfigConcurrentJobs = concurrentJobs , evalConfigFailFast = configFailFast config } - runFormatter evalConfig filteredSpec + runFormatter evalConfig spec - let failures = filter resultItemIsFailure results + let + failures :: [Path] + failures = map resultItemPath $ filter resultItemIsFailure $ specResultItems results - dumpFailureReport config seed qcArgs (map fst failures) + dumpFailureReport config seed qcArgs failures - return Summary { - summaryExamples = length results - , summaryFailures = length failures - } + return results -specToEvalForest :: Config -> Spec -> IO [EvalTree] -specToEvalForest config spec = do - let +toSummary :: SpecResult -> Summary +toSummary result = Summary { + summaryExamples = length items +, summaryFailures = length failures +} where + items = specResultItems result + failures = filter resultItemIsFailure items + +specToEvalForest :: Config -> [SpecTree ()] -> [EvalTree] +specToEvalForest config = + failFocusedItems config + >>> failPendingItems config + >>> focusSpec config + >>> toEvalItemForest params + >>> applyDryRun config + >>> applyFilterPredicates config + >>> randomize + >>> pruneForest + where seed = (fromJust . configQuickCheckSeed) config - focusedSpec = focusSpec config (failFocusedItems config spec) params = Params (configQuickCheckArgs config) (configSmallCheckDepth config) randomize | configRandomize config = randomizeForest seed | otherwise = id - randomize . pruneForest . applyFilterPredicates config . applyDryRun config . toEvalForest params <$> runSpecM focusedSpec -toEvalForest :: Params -> [SpecTree ()] -> [EvalTree] -toEvalForest params = bimapForest withUnit toEvalItem . filterForest itemIsFocused +pruneForest :: [Tree c a] -> [Eval.Tree c a] +pruneForest = mapMaybe pruneTree + +pruneTree :: Tree c a -> Maybe (Eval.Tree c a) +pruneTree node = case node of + Node group xs -> Eval.Node group <$> prune xs + NodeWithCleanup loc action xs -> Eval.NodeWithCleanup loc action <$> prune xs + Leaf item -> Just (Eval.Leaf item) where + prune = nonEmpty . pruneForest + +type EvalItemTree = Tree (IO ()) EvalItem + +toEvalItemForest :: Params -> [SpecTree ()] -> [EvalItemTree] +toEvalItemForest params = bimapForest id toEvalItem . filterForest itemIsFocused + where toEvalItem :: Item () -> EvalItem toEvalItem (Item requirement loc isParallelizable _isFocused e) = EvalItem requirement loc (fromMaybe False isParallelizable) (e params withUnit) @@ -290,33 +424,45 @@ | useColor = E.bracket_ (hHideCursor h) (hShowCursor h) | otherwise = id -colorOutputSupported :: ColorMode -> IO Bool -> IO Bool -colorOutputSupported mode isTerminalDevice = case mode of - ColorAuto -> (&&) <$> (not <$> noColor) <*> isTerminalDevice - ColorNever -> return False - ColorAlways -> return True +colorOutputSupported :: ColorMode -> IO Bool -> IO (Bool, Bool) +colorOutputSupported mode isTerminalDevice = do + github <- githubActions + buildkite <- lookupEnv "BUILDKITE" <&> (== Just "true") + useColor <- case mode of + ColorAuto -> (github ||) <$> colorTerminal + ColorNever -> return False + ColorAlways -> return True + let reportProgress = not github && not buildkite && useColor + return (reportProgress, useColor) + where + githubActions :: IO Bool + githubActions = lookupEnv "GITHUB_ACTIONS" <&> (== Just "true") + colorTerminal :: IO Bool + colorTerminal = (&&) <$> (not <$> noColor) <*> isTerminalDevice + + noColor :: IO Bool + noColor = lookupEnv "NO_COLOR" <&> (/= Nothing) + unicodeOutputSupported :: UnicodeMode -> Handle -> IO Bool unicodeOutputSupported mode h = case mode of UnicodeAuto -> (== Just "UTF-8") . fmap show <$> hGetEncoding h UnicodeNever -> return False UnicodeAlways -> return True -noColor :: IO Bool -noColor = lookupEnv "NO_COLOR" <&> (/= Nothing) - -rerunAll :: Config -> Maybe FailureReport -> Summary -> Bool -rerunAll _ Nothing _ = False -rerunAll config (Just oldFailureReport) summary = - configRerunAllOnSuccess config - && configRerun config - && isSuccess summary - && (not . null) (failureReportPaths oldFailureReport) +rerunAll :: Config -> Maybe FailureReport -> SpecResult -> Bool +rerunAll config mOldFailureReport result = case mOldFailureReport of + Nothing -> False + Just oldFailureReport -> + configRerunAllOnSuccess config + && configRerun config + && specResultSuccess result + && (not . null) (failureReportPaths oldFailureReport) -- | Summary of a test run. data Summary = Summary { - summaryExamples :: Int -, summaryFailures :: Int + summaryExamples :: !Int +, summaryFailures :: !Int } deriving (Eq, Show) instance Monoid Summary where @@ -337,5 +483,5 @@ ref <- newSTRef (mkStdGen $ fromIntegral seed) shuffleForest ref t -countSpecItems :: [EvalTree] -> Int +countSpecItems :: [Eval.Tree c a] -> Int countSpecItems = getSum . foldMap (foldMap . const $ Sum 1) diff --git a/hspec-core/src/Test/Hspec/Core/Runner/Eval.hs b/hspec-core/src/Test/Hspec/Core/Runner/Eval.hs --- a/hspec-core/src/Test/Hspec/Core/Runner/Eval.hs +++ b/hspec-core/src/Test/Hspec/Core/Runner/Eval.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ConstraintKinds #-} @@ -13,10 +15,11 @@ module Test.Hspec.Core.Runner.Eval ( EvalConfig(..) , EvalTree +, Tree(..) , EvalItem(..) , runFormatter -, resultItemIsFailure #ifdef TEST +, mergeResults , runSequentially #endif ) where @@ -36,14 +39,23 @@ import Control.Monad.Trans.Class import Test.Hspec.Core.Util -import Test.Hspec.Core.Spec (Tree(..), Progress, FailureReason(..), Result(..), ResultStatus(..), ProgressCallback) +import Test.Hspec.Core.Spec (Progress, FailureReason(..), Result(..), ResultStatus(..), ProgressCallback) import Test.Hspec.Core.Timer import Test.Hspec.Core.Format (Format) import qualified Test.Hspec.Core.Format as Format import Test.Hspec.Core.Clock import Test.Hspec.Core.Example.Location -import Test.Hspec.Core.Example (safeEvaluate) +import Test.Hspec.Core.Example (safeEvaluateResultStatus) +import qualified NonEmpty +import NonEmpty (NonEmpty(..)) + +data Tree c a = + Node String (NonEmpty (Tree c a)) + | NodeWithCleanup (Maybe (String, Location)) c (NonEmpty (Tree c a)) + | Leaf a + deriving (Eq, Show, Functor, Foldable, Traversable) + -- for compatibility with GHC < 7.10.1 type Monad m = (Functor m, Applicative m, M.Monad m) type MonadIO m = (Monad m, M.MonadIO m) @@ -124,7 +136,7 @@ withTimer 0.05 $ \ timer -> do format Format.Started - runReaderT (run $ map (fmap (fmap (. reportProgress timer) . snd)) runningSpecs) (Env config ref) `E.finally` do + runReaderT (run . applyCleanup $ map (fmap (fmap (. reportProgress timer) . snd)) runningSpecs) (Env config ref) `E.finally` do results <- reverse <$> readIORef ref format (Format.Done results) @@ -146,14 +158,60 @@ data Item a = Item { _itemDescription :: String , _itemLocation :: Maybe Location -, _itemAction :: a +, itemAction :: a } deriving Functor type Job m p a = (p -> m ()) -> m a -type RunningItem m = Item (Path -> m (Seconds, Result)) -type RunningTree m = Tree (IO ()) (RunningItem m) +type RunningItem = Item (Path -> IO (Seconds, Result)) +type RunningTree c = Tree c RunningItem +applyCleanup :: [RunningTree (IO ())] -> [RunningTree ()] +applyCleanup = map go + where + go t = case t of + Leaf a -> Leaf a + Node label xs -> Node label (go <$> xs) + NodeWithCleanup loc cleanup xs -> NodeWithCleanup loc () (addCleanupToLastLeaf loc cleanup $ go <$> xs) + +addCleanupToLastLeaf :: Maybe (String, Location) -> IO () -> NonEmpty (RunningTree ()) -> NonEmpty (RunningTree ()) +addCleanupToLastLeaf loc cleanup = go + where + go = NonEmpty.reverse . mapHead goNode . NonEmpty.reverse + + goNode node = case node of + Leaf item -> Leaf (addCleanupToItem loc cleanup item) + NodeWithCleanup loc_ () zs -> NodeWithCleanup loc_ () (go zs) + Node description zs -> Node description (go zs) + +mapHead :: (a -> a) -> NonEmpty a -> NonEmpty a +mapHead f xs = case xs of + y :| ys -> f y :| ys + +addCleanupToItem :: Maybe (String, Location) -> IO () -> RunningItem -> RunningItem +addCleanupToItem loc cleanup item = item { + itemAction = \ path -> do + (t1, r1) <- itemAction item path + (t2, r2) <- measure $ safeEvaluateResultStatus (cleanup >> return Success) + let t = t1 + t2 + return (t, mergeResults loc r1 r2) +} + +mergeResults :: Maybe (String, Location) -> Result -> ResultStatus -> Result +mergeResults mCallSite (Result info r1) r2 = Result info $ case (r1, r2) of + (_, Success) -> r1 + (Failure{}, _) -> r1 + (Pending{}, Pending{}) -> r1 + (Success, Pending{}) -> r2 + (_, Failure mLoc err) -> Failure (mLoc <|> hookLoc) $ case err of + Error message e -> Error (message <|> hookFailed) e + _ -> err + where + hookLoc = snd <$> mCallSite + hookFailed = case mCallSite of + Just (name, _) -> Just $ "in " ++ name ++ "-hook:" + Nothing -> Nothing + type RunningItem_ m = (Async (), Item (Job m Progress (Seconds, Result))) type RunningTree_ m = Tree (IO ()) (RunningItem_ m) @@ -208,12 +266,12 @@ replaceMVar :: MVar a -> a -> IO () replaceMVar mvar p = tryTakeMVar mvar >> putMVar mvar p -run :: [RunningTree IO] -> EvalM () +run :: [RunningTree ()] -> EvalM () run specs = do - fastFail <- asks (evalConfigFailFast . envConfig) - sequenceActions fastFail (concatMap foldSpec specs) + failFast <- asks (evalConfigFailFast . envConfig) + sequenceActions failFast (concatMap foldSpec specs) where - foldSpec :: RunningTree IO -> [EvalM ()] + foldSpec :: RunningTree () -> [EvalM ()] foldSpec = foldTree FoldTree { onGroupStarted = groupStarted , onGroupDone = groupDone @@ -221,16 +279,10 @@ , onLeafe = evalItem } - runCleanup :: Maybe Location -> [String] -> IO () -> EvalM () - runCleanup loc groups action = do - r <- liftIO $ measure $ safeEvaluate (action >> return (Result "" Success)) - case r of - (_, Result "" Success) -> return () - _ -> reportItem path loc (return r) - where - path = (groups, "afterAll-hook") + runCleanup :: Maybe (String, Location) -> [String] -> () -> EvalM () + runCleanup _loc _groups = return - evalItem :: [String] -> RunningItem IO -> EvalM () + evalItem :: [String] -> RunningItem -> EvalM () evalItem groups (Item requirement loc action) = do reportItem path loc $ lift (action path) where @@ -240,7 +292,7 @@ data FoldTree c a r = FoldTree { onGroupStarted :: Path -> r , onGroupDone :: Path -> r -, onCleanup :: Maybe Location -> [String] -> c -> r +, onCleanup :: Maybe (String, Location) -> [String] -> c -> r , onLeafe :: [String] -> a -> r } @@ -260,20 +312,21 @@ go rGroups (Leaf a) = [onLeafe (reverse rGroups) a] sequenceActions :: Bool -> [EvalM ()] -> EvalM () -sequenceActions fastFail = go +sequenceActions failFast = go where go :: [EvalM ()] -> EvalM () go [] = return () go (action : actions) = do action - hasFailures <- any resultItemIsFailure <$> getResults - let stopNow = fastFail && hasFailures + stopNow <- case failFast of + False -> return False + True -> any itemIsFailure <$> getResults unless stopNow (go actions) -resultItemIsFailure :: (Path, Format.Item) -> Bool -resultItemIsFailure = isFailure . Format.itemResult . snd - where - isFailure r = case r of - Format.Success{} -> False - Format.Pending{} -> False - Format.Failure{} -> True + itemIsFailure :: (Path, Format.Item) -> Bool + itemIsFailure = isFailure . Format.itemResult . snd + where + isFailure r = case r of + Format.Success{} -> False + Format.Pending{} -> False + Format.Failure{} -> True diff --git a/hspec-core/src/Test/Hspec/Core/Runner/Result.hs b/hspec-core/src/Test/Hspec/Core/Runner/Result.hs new file mode 100644 --- /dev/null +++ b/hspec-core/src/Test/Hspec/Core/Runner/Result.hs @@ -0,0 +1,58 @@ +module Test.Hspec.Core.Runner.Result ( +-- RE-EXPORTED from Test.Hspec.Core.Runner + SpecResult(SpecResult) +, specResultItems +, specResultSuccess + +, ResultItem(ResultItem) +, resultItemPath +, resultItemStatus +, resultItemIsFailure + +, ResultItemStatus(..) +-- END RE-EXPORTED from Test.Hspec.Core.Runner + +, toSpecResult +) where + +import Prelude () +import Test.Hspec.Core.Compat + +import Test.Hspec.Core.Util +import qualified Test.Hspec.Core.Format as Format + +data SpecResult = SpecResult { + specResultItems :: [ResultItem] +, specResultSuccess :: !Bool +} deriving (Eq, Show) + +data ResultItem = ResultItem { + resultItemPath :: Path +, resultItemStatus :: ResultItemStatus +} deriving (Eq, Show) + +resultItemIsFailure :: ResultItem -> Bool +resultItemIsFailure item = case resultItemStatus item of + ResultItemSuccess -> False + ResultItemPending -> False + ResultItemFailure -> True + +data ResultItemStatus = + ResultItemSuccess + | ResultItemPending + | ResultItemFailure + deriving (Eq, Show) + +toSpecResult :: Bool -> [(Path, Format.Item)] -> SpecResult +toSpecResult failOnEmpty results = SpecResult items success + where + items = map toResultItem results + success = not (failOnEmpty && null results) && all (not . resultItemIsFailure) items + +toResultItem :: (Path, Format.Item) -> ResultItem +toResultItem (path, item) = ResultItem path status + where + status = case Format.itemResult item of + Format.Success{} -> ResultItemSuccess + Format.Pending{} -> ResultItemPending + Format.Failure{} -> ResultItemFailure diff --git a/hspec-core/src/Test/Hspec/Core/Spec.hs b/hspec-core/src/Test/Hspec/Core/Spec.hs --- a/hspec-core/src/Test/Hspec/Core/Spec.hs +++ b/hspec-core/src/Test/Hspec/Core/Spec.hs @@ -29,13 +29,50 @@ , sequential -- * The @SpecM@ monad -, module Test.Hspec.Core.Spec.Monad +, Test.Hspec.Core.Spec.Monad.Spec +, Test.Hspec.Core.Spec.Monad.SpecWith +, Test.Hspec.Core.Spec.Monad.SpecM(..) +, Test.Hspec.Core.Spec.Monad.runSpecM +, Test.Hspec.Core.Spec.Monad.fromSpecList +, Test.Hspec.Core.Spec.Monad.runIO +, Test.Hspec.Core.Spec.Monad.mapSpecForest +, Test.Hspec.Core.Spec.Monad.mapSpecItem +, Test.Hspec.Core.Spec.Monad.mapSpecItem_ +, Test.Hspec.Core.Spec.Monad.modifyParams +, Test.Hspec.Core.Spec.Monad.modifyConfig +, getSpecDescriptionPath -- * A type class for examples -, module Test.Hspec.Core.Example +, Test.Hspec.Core.Example.Example (..) +, Test.Hspec.Core.Example.Params (..) +, Test.Hspec.Core.Example.defaultParams +, Test.Hspec.Core.Example.ActionWith +, Test.Hspec.Core.Example.Progress +, Test.Hspec.Core.Example.ProgressCallback +, Test.Hspec.Core.Example.Result(..) +, Test.Hspec.Core.Example.ResultStatus (..) +, Test.Hspec.Core.Example.Location (..) +, Test.Hspec.Core.Example.FailureReason (..) +, Test.Hspec.Core.Example.safeEvaluate +, Test.Hspec.Core.Example.safeEvaluateExample -- * Internal representation of a spec tree -, module Test.Hspec.Core.Tree +, Test.Hspec.Core.Tree.SpecTree +, Test.Hspec.Core.Tree.Tree (..) +, Test.Hspec.Core.Tree.Item (..) +, Test.Hspec.Core.Tree.specGroup +, Test.Hspec.Core.Tree.specItem +, Test.Hspec.Core.Tree.bimapTree +, Test.Hspec.Core.Tree.bimapForest +, Test.Hspec.Core.Tree.filterTree +, Test.Hspec.Core.Tree.filterForest +, Test.Hspec.Core.Tree.filterTreeWithLabels +, Test.Hspec.Core.Tree.filterForestWithLabels +, Test.Hspec.Core.Tree.pruneTree -- unused +, Test.Hspec.Core.Tree.pruneForest -- unused +, Test.Hspec.Core.Tree.location + +, focusForest ) where import Prelude () @@ -43,6 +80,8 @@ import qualified Control.Exception as E import Data.CallStack +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (asks) import Test.Hspec.Expectations (Expectation) @@ -53,7 +92,9 @@ -- | The @describe@ function combines a list of specs into a larger spec. describe :: HasCallStack => String -> SpecWith a -> SpecWith a -describe label spec = runIO (runSpecM spec) >>= fromSpecList . return . specGroup label +describe label = withEnv pushLabel . mapSpecForest (return . specGroup label) + where + pushLabel (Env labels) = Env $ label : labels -- | @context@ is an alias for `describe`. context :: HasCallStack => String -> SpecWith a -> SpecWith a @@ -103,14 +144,13 @@ -- -- Applying `focus` to a spec with focused spec items has no effect. focus :: SpecWith a -> SpecWith a -focus spec = do - xs <- runIO (runSpecM spec) - let - ys - | any (any itemIsFocused) xs = xs - | otherwise = bimapForest id (\ item -> item {itemIsFocused = True}) xs - fromSpecList ys +focus = mapSpecForest focusForest +focusForest :: [SpecTree a] -> [SpecTree a] +focusForest xs + | any (any itemIsFocused) xs = xs + | otherwise = bimapForest id (\ item -> item {itemIsFocused = True}) xs + -- | @fit@ is an alias for @fmap focus . it@ fit :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) fit = fmap focus . it @@ -158,3 +198,19 @@ -- argument that can be used to specify the reason for why the spec item is pending. pendingWith :: HasCallStack => String -> Expectation pendingWith = E.throwIO . Pending location . Just + +-- | Get the path of `describe` labels, from the root all the way in to the +-- call-site of this function. +-- +-- ==== __Example__ +-- >>> :{ +-- runSpecM $ do +-- describe "foo" $ do +-- describe "bar" $ do +-- getSpecDescriptionPath >>= runIO . print +-- :} +-- ["foo","bar"] +-- +-- @since 2.10.0 +getSpecDescriptionPath :: SpecM a [String] +getSpecDescriptionPath = SpecM $ lift $ reverse <$> asks envSpecDescriptionPath diff --git a/hspec-core/src/Test/Hspec/Core/Spec/Monad.hs b/hspec-core/src/Test/Hspec/Core/Spec/Monad.hs --- a/hspec-core/src/Test/Hspec/Core/Spec/Monad.hs +++ b/hspec-core/src/Test/Hspec/Core/Spec/Monad.hs @@ -1,44 +1,61 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} - --- NOTE: re-exported from Test.Hspec.Core.Spec module Test.Hspec.Core.Spec.Monad ( +-- RE-EXPORTED from Test.Hspec.Core.Spec Spec , SpecWith -, SpecM (..) +, SpecM (SpecM) , runSpecM , fromSpecList , runIO +, mapSpecForest , mapSpecItem , mapSpecItem_ , modifyParams + +, modifyConfig +-- END RE-EXPORTED from Test.Hspec.Core.Spec + +, Env(..) +, withEnv ) where import Prelude () import Test.Hspec.Core.Compat -import Control.Arrow -import Control.Monad.Trans.Writer import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Writer import Test.Hspec.Core.Example import Test.Hspec.Core.Tree +import Test.Hspec.Core.Config.Definition (Config) + type Spec = SpecWith () type SpecWith a = SpecM a () +-- | +-- @since 2.10.0 +modifyConfig :: (Config -> Config) -> SpecWith a +modifyConfig f = SpecM $ tell (Endo f, mempty) + -- | A writer monad for `SpecTree` forests -newtype SpecM a r = SpecM (WriterT [SpecTree a] IO r) +newtype SpecM a r = SpecM { unSpecM :: WriterT (Endo Config, [SpecTree a]) (ReaderT Env IO) r } deriving (Functor, Applicative, Monad) -- | Convert a `Spec` to a forest of `SpecTree`s. -runSpecM :: SpecWith a -> IO [SpecTree a] -runSpecM (SpecM specs) = execWriterT specs +runSpecM :: SpecWith a -> IO (Endo Config, [SpecTree a]) +runSpecM = flip runReaderT (Env []) . execWriterT . unSpecM -- | Create a `Spec` from a forest of `SpecTree`s. +fromSpecForest :: (Endo Config, [SpecTree a]) -> SpecWith a +fromSpecForest = SpecM . tell + +-- | Create a `Spec` from a forest of `SpecTree`s. fromSpecList :: [SpecTree a] -> SpecWith a -fromSpecList = SpecM . tell +fromSpecList = fromSpecForest . (,) mempty -- | Run an IO action while constructing the spec tree. -- @@ -52,13 +69,20 @@ runIO = SpecM . liftIO mapSpecForest :: ([SpecTree a] -> [SpecTree b]) -> SpecM a r -> SpecM b r -mapSpecForest f (SpecM specs) = SpecM (mapWriterT (fmap (second f)) specs) +mapSpecForest f (SpecM specs) = SpecM (mapWriterT (fmap (fmap (second f))) specs) mapSpecItem :: (ActionWith a -> ActionWith b) -> (Item a -> Item b) -> SpecWith a -> SpecWith b -mapSpecItem g f = mapSpecForest (bimapForest g f) +mapSpecItem _ = mapSpecItem_ -mapSpecItem_ :: (Item a -> Item a) -> SpecWith a -> SpecWith a -mapSpecItem_ = mapSpecItem id +mapSpecItem_ :: (Item a -> Item b) -> SpecWith a -> SpecWith b +mapSpecItem_ = mapSpecForest . bimapForest id modifyParams :: (Params -> Params) -> SpecWith a -> SpecWith a modifyParams f = mapSpecItem_ $ \item -> item {itemExample = \p -> (itemExample item) (f p)} + +newtype Env = Env { + envSpecDescriptionPath :: [String] +} + +withEnv :: (Env -> Env) -> SpecM a r -> SpecM a r +withEnv f = SpecM . WriterT . local f . runWriterT . unSpecM diff --git a/hspec-core/src/Test/Hspec/Core/Tree.hs b/hspec-core/src/Test/Hspec/Core/Tree.hs --- a/hspec-core/src/Test/Hspec/Core/Tree.hs +++ b/hspec-core/src/Test/Hspec/Core/Tree.hs @@ -4,8 +4,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} --- NOTE: re-exported from Test.Hspec.Core.Spec module Test.Hspec.Core.Tree ( +-- RE-EXPORTED from Test.Hspec.Core.Spec SpecTree , Tree (..) , Item (..) @@ -17,15 +17,18 @@ , filterForest , filterTreeWithLabels , filterForestWithLabels -, pruneTree -, pruneForest +, pruneTree -- unused +, pruneForest -- unused , location +-- END RE-EXPORTED from Test.Hspec.Core.Spec +, callSite ) where import Prelude () import Test.Hspec.Core.Compat -import Data.CallStack +import Data.CallStack (HasCallStack, SrcLoc(..)) +import qualified Data.CallStack as CallStack import Data.Maybe import Test.Hspec.Core.Example @@ -33,13 +36,13 @@ -- | Internal tree data structure data Tree c a = Node String [Tree c a] - | NodeWithCleanup (Maybe Location) c [Tree c a] + | NodeWithCleanup (Maybe (String, Location)) c [Tree c a] | Leaf a - deriving (Show, Eq, Functor, Foldable, Traversable) + deriving (Eq, Show, Functor, Foldable, Traversable) --- | A tree is used to represent a spec internally. The tree is parametrize +-- | A tree is used to represent a spec internally. The tree is parameterized -- over the type of cleanup actions and the type of the actual spec items. -type SpecTree a = Tree (ActionWith a) (Item a) +type SpecTree a = Tree (IO ()) (Item a) bimapForest :: (a -> b) -> (c -> d) -> [Tree a c] -> [Tree b d] bimapForest g f = map (bimapTree g f) @@ -132,11 +135,15 @@ | otherwise = s location :: HasCallStack => Maybe Location -location = case reverse callStack of - (_, loc) : _ -> Just (Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc)) - _ -> Nothing +location = snd <$> callSite +callSite :: HasCallStack => Maybe (String, Location) +callSite = fmap toLocation <$> CallStack.callSite + defaultDescription :: HasCallStack => Maybe String -defaultDescription = case reverse callStack of - (_, loc) : _ -> Just (srcLocModule loc ++ "[" ++ show (srcLocStartLine loc) ++ ":" ++ show (srcLocStartCol loc) ++ "]") - _ -> Nothing +defaultDescription = case CallStack.callSite of + Just (_, loc) -> Just (srcLocModule loc ++ "[" ++ show (srcLocStartLine loc) ++ ":" ++ show (srcLocStartCol loc) ++ "]") + Nothing -> Nothing + +toLocation :: SrcLoc -> Location +toLocation loc = Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc) diff --git a/hspec-core/src/Test/Hspec/Core/Util.hs b/hspec-core/src/Test/Hspec/Core/Util.hs --- a/hspec-core/src/Test/Hspec/Core/Util.hs +++ b/hspec-core/src/Test/Hspec/Core/Util.hs @@ -50,10 +50,12 @@ -- ensure that lines are not longer than given `n`, insert line breaks at word -- boundaries lineBreaksAt :: Int -> String -> [String] -lineBreaksAt n input = case words input of - [] -> [] - x:xs -> go (x, xs) +lineBreaksAt n = concatMap f . lines where + f input = case words input of + [] -> [] + x:xs -> go (x, xs) + go :: (String, [String]) -> [String] go c = case c of (s, []) -> [s] @@ -102,7 +104,7 @@ -- This is different from `show`. The type of the exception is included, e.g.: -- -- >>> formatException (toException DivideByZero) --- "ArithException (divide by zero)" +-- "ArithException\ndivide by zero" -- -- For `IOException`s the `IOErrorType` is included, as well. formatException :: SomeException -> String diff --git a/hspec-discover/src/Test/Hspec/Discover/Config.hs b/hspec-discover/src/Test/Hspec/Discover/Config.hs --- a/hspec-discover/src/Test/Hspec/Discover/Config.hs +++ b/hspec-discover/src/Test/Hspec/Discover/Config.hs @@ -35,9 +35,9 @@ parseConfig :: String -> [String] -> Either String Config parseConfig prog args = case getOpt Permute options args of (opts, [], []) -> let - c = (foldl (flip id) defaultConfig opts) + c = foldl (flip id) defaultConfig opts in - if (configNoMain c && isJust (configFormatter c)) + if configNoMain c && isJust (configFormatter c) then formatError "option `--formatter=' does not make sense with `--no-main'\n" else diff --git a/hspec-discover/src/Test/Hspec/Discover/Run.hs b/hspec-discover/src/Test/Hspec/Discover/Run.hs --- a/hspec-discover/src/Test/Hspec/Discover/Run.hs +++ b/hspec-discover/src/Test/Hspec/Discover/Run.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances, OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | A preprocessor that finds and combines specs. -- @@ -61,7 +61,7 @@ mkSpecModule src conf nodes = ( "{-# LINE 1 " . shows src . " #-}\n" . showString "{-# LANGUAGE NoImplicitPrelude #-}\n" - . showString "{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}\n" + . showString "{-# OPTIONS_GHC -w -Wall -fno-warn-warnings-deprecations #-}\n" . showString ("module " ++ moduleName src conf ++" where\n") . importList nodes . showString "import Test.Hspec.Discover\n" @@ -121,9 +121,7 @@ sequenceS = foldr (.) "" . intersperse " >> " formatSpecs :: Maybe [Spec] -> ShowS -formatSpecs specs = case specs of - Nothing -> "return ()" - Just xs -> fromForest xs +formatSpecs = maybe "return ()" fromForest where fromForest :: [Spec] -> ShowS fromForest = sequenceS . map fromTree diff --git a/hspec-discover/src/Test/Hspec/Discover/Sort.hs b/hspec-discover/src/Test/Hspec/Discover/Sort.hs --- a/hspec-discover/src/Test/Hspec/Discover/Sort.hs +++ b/hspec-discover/src/Test/Hspec/Discover/Sort.hs @@ -15,7 +15,7 @@ sortNaturallyBy :: (a -> (String, Int)) -> [a] -> [a] sortNaturallyBy f = sortBy (comparing ((\ (k, t) -> (naturalSortKey k, t)) . f)) -data NaturalSortKey = NaturalSortKey [Chunk] +newtype NaturalSortKey = NaturalSortKey [Chunk] deriving (Eq, Ord) data Chunk = Numeric Integer Int | Textual [(Char, Char)] diff --git a/hspec-meta.cabal b/hspec-meta.cabal --- a/hspec-meta.cabal +++ b/hspec-meta.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.6. +-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack name: hspec-meta -version: 2.9.3 +version: 2.10.5 synopsis: A version of Hspec which is used to test Hspec itself description: A stable version of Hspec which is used to test the in-development version of Hspec. @@ -14,7 +14,7 @@ homepage: http://hspec.github.io/ bug-reports: https://github.com/hspec/hspec/issues maintainer: Simon Hengel -copyright: (c) 2011-2021 Simon Hengel, +copyright: (c) 2011-2022 Simon Hengel, (c) 2011-2012 Trystan Spangler, (c) 2011 Greg Weber license: MIT @@ -41,6 +41,7 @@ GetOpt.Declarative.Interpret GetOpt.Declarative.Types GetOpt.Declarative.Util + NonEmpty Test.Hspec.Core.Clock Test.Hspec.Core.Compat Test.Hspec.Core.Config @@ -67,6 +68,7 @@ Test.Hspec.Core.Runner Test.Hspec.Core.Runner.Eval Test.Hspec.Core.Runner.PrintSlowSpecItems + Test.Hspec.Core.Runner.Result Test.Hspec.Core.Shuffle Test.Hspec.Core.Spec Test.Hspec.Core.Spec.Monad @@ -106,6 +108,7 @@ , setenv , time , transformers >=0.2.2.0 + default-language: Haskell2010 if impl(ghc >= 8.2.1) build-depends: ghc @@ -118,7 +121,6 @@ Control.Concurrent.STM.TMVar hs-source-dirs: hspec-core/vendor/stm-2.5.0.1/ - default-language: Haskell2010 executable hspec-meta-discover main-is: hspec-discover.hs @@ -146,8 +148,8 @@ , setenv , time , transformers >=0.2.2.0 + default-language: Haskell2010 if impl(ghc >= 8.2.1) build-depends: ghc , ghc-boot-th - default-language: Haskell2010 diff --git a/src/Test/Hspec/Discover.hs b/src/Test/Hspec/Discover.hs --- a/src/Test/Hspec/Discover.hs +++ b/src/Test/Hspec/Discover.hs @@ -13,7 +13,7 @@ import Test.Hspec.Core.Spec import Test.Hspec.Core.Runner -import Test.Hspec.Formatters +import Test.Hspec.Core.Formatters.V1 class IsFormatter a where toFormatter :: a -> IO Formatter diff --git a/src/Test/Hspec/Formatters.hs b/src/Test/Hspec/Formatters.hs --- a/src/Test/Hspec/Formatters.hs +++ b/src/Test/Hspec/Formatters.hs @@ -1,2 +1,7 @@ -module Test.Hspec.Formatters (module Test.Hspec.Core.Formatters) where -import Test.Hspec.Core.Formatters +-- | +-- Deprecated\: Use "Test.Hspec.Core.Formatters.V1" instead. +module Test.Hspec.Formatters +-- {-# DEPRECATED "Use \"Test.Hspec.Core.Formatters.V1\" instead." #-} +(module Test.Hspec.Core.Formatters.V1) +where +import Test.Hspec.Core.Formatters.V1 diff --git a/version.yaml b/version.yaml --- a/version.yaml +++ b/version.yaml @@ -1,1 +1,1 @@ -&version 2.9.3 +&version 2.10.5