diff --git a/hspec-core.cabal b/hspec-core.cabal --- a/hspec-core.cabal +++ b/hspec-core.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 8fe188c041ee9e718cde6c89c51a73813fd9b52b772533362134c232c80261f5 +-- hash: b85e0f85042731ca2893e4ab243f2694f46c7b9d527d7d0d81bd05fc2bdfcd32 name: hspec-core -version: 2.4.8 +version: 2.5.0 license: MIT license-file: LICENSE copyright: (c) 2011-2017 Simon Hengel, @@ -32,12 +32,13 @@ vendor ghc-options: -Wall build-depends: - HUnit >=1.2.5 - , QuickCheck >=2.5.1 + HUnit >=1.5.0.0 + , QuickCheck >=2.10 , ansi-terminal >=0.5 , array , base >=4.5.0.0 && <5 , call-stack + , clock , deepseq , directory , filepath @@ -47,7 +48,6 @@ , setenv , stm >=2.2 , tf-random - , time , transformers >=0.2.2.0 exposed-modules: Test.Hspec.Core.Spec @@ -57,15 +57,19 @@ Test.Hspec.Core.QuickCheck Test.Hspec.Core.Util other-modules: + Test.Hspec.Core.Clock Test.Hspec.Core.Compat Test.Hspec.Core.Config + Test.Hspec.Core.Config.Options + Test.Hspec.Core.Config.Util 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.Options Test.Hspec.Core.QuickCheckUtil Test.Hspec.Core.Runner.Eval Test.Hspec.Core.Spec.Monad @@ -86,12 +90,13 @@ ghc-options: -Wall cpp-options: -DTEST build-depends: - HUnit >=1.2.5 - , QuickCheck >=2.5.1 + HUnit >=1.5.0.0 + , QuickCheck >=2.10 , ansi-terminal >=0.5 , array , base >=4.5.0.0 && <5 , call-stack + , clock , deepseq , directory , filepath @@ -105,20 +110,23 @@ , stm >=2.2 , temporary , tf-random - , time , transformers >=0.2.2.0 other-modules: + Test.Hspec.Core.Clock Test.Hspec.Core.Compat Test.Hspec.Core.Config + Test.Hspec.Core.Config.Options + Test.Hspec.Core.Config.Util Test.Hspec.Core.Example + Test.Hspec.Core.Example.Location Test.Hspec.Core.FailureReport + Test.Hspec.Core.Format Test.Hspec.Core.Formatters Test.Hspec.Core.Formatters.Diff Test.Hspec.Core.Formatters.Free Test.Hspec.Core.Formatters.Internal Test.Hspec.Core.Formatters.Monad Test.Hspec.Core.Hooks - Test.Hspec.Core.Options Test.Hspec.Core.QuickCheck Test.Hspec.Core.QuickCheckUtil Test.Hspec.Core.Runner @@ -133,15 +141,19 @@ All Helper Mock + Test.Hspec.Core.ClockSpec Test.Hspec.Core.CompatSpec + Test.Hspec.Core.Config.OptionsSpec + Test.Hspec.Core.Config.UtilSpec Test.Hspec.Core.ConfigSpec + Test.Hspec.Core.Example.LocationSpec Test.Hspec.Core.ExampleSpec Test.Hspec.Core.FailureReportSpec Test.Hspec.Core.Formatters.DiffSpec Test.Hspec.Core.FormattersSpec Test.Hspec.Core.HooksSpec - Test.Hspec.Core.OptionsSpec Test.Hspec.Core.QuickCheckUtilSpec + Test.Hspec.Core.Runner.EvalSpec Test.Hspec.Core.RunnerSpec Test.Hspec.Core.SpecSpec Test.Hspec.Core.TimerSpec diff --git a/src/Test/Hspec/Core/Clock.hs b/src/Test/Hspec/Core/Clock.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Clock.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Test.Hspec.Core.Clock ( + Seconds(..) +, toMicroseconds +, getMonotonicTime +, measure +, sleep +) where + +import Text.Printf +import System.Clock +import Control.Concurrent + +newtype Seconds = Seconds Double + deriving (Eq, Show, Num, Fractional, PrintfArg) + +toMicroseconds :: Seconds -> Int +toMicroseconds (Seconds s) = floor (s * 1000000) + +getMonotonicTime :: IO Seconds +getMonotonicTime = do + t <- getTime Monotonic + return $ Seconds ((fromIntegral . toNanoSecs $ t) / 1000000000) + +measure :: IO a -> IO (Seconds, a) +measure action = do + t0 <- getMonotonicTime + a <- action + t1 <- getMonotonicTime + return (t1 - t0, a) + +sleep :: Seconds -> IO () +sleep = threadDelay . toMicroseconds 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 @@ -12,16 +12,20 @@ , module Data.Foldable , module Data.Traversable , module Data.Monoid +, module Data.List #if !MIN_VERSION_base(4,6,0) , modifyIORef' +, atomicWriteIORef #endif +, interruptible ) where import Control.Applicative import Data.Foldable import Data.Traversable import Data.Monoid +import Data.List (intercalate) import Prelude hiding ( all @@ -54,6 +58,12 @@ import Data.Typeable (tyConModule, tyConName) import Control.Concurrent +#if MIN_VERSION_base(4,9,0) +import Control.Exception (interruptible) +#else +import GHC.IO +#endif + #if !MIN_VERSION_base(4,6,0) import qualified Text.ParserCombinators.ReadP as P @@ -64,6 +74,11 @@ let x' = f x x' `seq` writeIORef ref x' +atomicWriteIORef :: IORef a -> a -> IO () +atomicWriteIORef ref a = do + x <- atomicModifyIORef ref (\_ -> (a, ())) + x `seq` return () + -- | Parse a string using the 'Read' instance. -- Succeeds if there is exactly one valid result. -- A 'Left' value indicates a parse error. @@ -104,3 +119,13 @@ getDefaultConcurrentJobs :: IO Int getDefaultConcurrentJobs = getNumCapabilities + +#if !MIN_VERSION_base(4,9,0) +interruptible :: IO a -> IO a +interruptible act = do + st <- getMaskingState + case st of + Unmasked -> act + MaskedInterruptible -> unsafeUnmask act + MaskedUninterruptible -> act +#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 @@ -25,7 +25,7 @@ import Test.Hspec.Core.Util import Test.Hspec.Core.Compat -import Test.Hspec.Core.Options +import Test.Hspec.Core.Config.Options import Test.Hspec.Core.FailureReport import Test.Hspec.Core.QuickCheckUtil (mkGen) import Test.Hspec.Core.Example (Params(..), defaultParams) diff --git a/src/Test/Hspec/Core/Config/Options.hs b/src/Test/Hspec/Core/Config/Options.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Config/Options.hs @@ -0,0 +1,312 @@ +module Test.Hspec.Core.Config.Options ( + Config(..) +, ColorMode (..) +, defaultConfig +, filterOr +, parseOptions +, ConfigFile +, ignoreConfigFile +, envVarName +) where + +import Prelude () +import Control.Monad +import Test.Hspec.Core.Compat + +import System.IO +import System.Exit +import System.Console.GetOpt + +import Test.Hspec.Core.Formatters +import Test.Hspec.Core.Config.Util +import Test.Hspec.Core.Util +import Test.Hspec.Core.Example (Params(..), defaultParams) +import Data.Functor.Identity +import Data.Maybe + +type ConfigFile = (FilePath, [String]) + +type EnvVar = [String] + +envVarName :: String +envVarName = "HSPEC_OPTIONS" + +data Config = Config { + configIgnoreConfigFile :: Bool +, configDryRun :: Bool +, configPrintCpuTime :: Bool +, configFastFail :: Bool +, configFailureReport :: Maybe FilePath +, configRerun :: Bool +, configRerunAllOnSuccess :: Bool + +-- | +-- A predicate that is used to filter the spec before it is run. Only examples +-- that satisfy the predicate are run. +, configFilterPredicate :: Maybe (Path -> Bool) +, configSkipPredicate :: Maybe (Path -> Bool) +, configQuickCheckSeed :: Maybe Integer +, configQuickCheckMaxSuccess :: Maybe Int +, configQuickCheckMaxDiscardRatio :: Maybe Int +, configQuickCheckMaxSize :: Maybe Int +, configSmallCheckDepth :: Int +, configColorMode :: ColorMode +, configDiff :: Bool +, configFormatter :: Maybe Formatter +, configHtmlOutput :: Bool +, configOutputFile :: Either Handle FilePath +, configConcurrentJobs :: Maybe Int +} + +defaultConfig :: Config +defaultConfig = Config { + configIgnoreConfigFile = False +, configDryRun = False +, configPrintCpuTime = False +, configFastFail = False +, configFailureReport = Nothing +, configRerun = False +, configRerunAllOnSuccess = False +, configFilterPredicate = Nothing +, configSkipPredicate = Nothing +, configQuickCheckSeed = Nothing +, configQuickCheckMaxSuccess = Nothing +, configQuickCheckMaxDiscardRatio = Nothing +, configQuickCheckMaxSize = Nothing +, configSmallCheckDepth = paramsSmallCheckDepth defaultParams +, configColorMode = ColorAuto +, configDiff = True +, configFormatter = Nothing +, configHtmlOutput = False +, configOutputFile = Left stdout +, configConcurrentJobs = Nothing +} + +filterOr :: Maybe (Path -> Bool) -> Maybe (Path -> Bool) -> Maybe (Path -> Bool) +filterOr p1_ p2_ = case (p1_, p2_) of + (Just p1, Just p2) -> Just $ \path -> p1 path || p2 path + _ -> p1_ <|> p2_ + +addMatch :: String -> Config -> Config +addMatch s c = c {configFilterPredicate = Just (filterPredicate s) `filterOr` configFilterPredicate c} + +addSkip :: String -> Config -> Config +addSkip s c = c {configSkipPredicate = Just (filterPredicate s) `filterOr` configSkipPredicate c} + +setDepth :: Int -> Config -> Config +setDepth n c = c {configSmallCheckDepth = n} + +setMaxSuccess :: Int -> Config -> Config +setMaxSuccess n c = c {configQuickCheckMaxSuccess = Just n} + +setMaxSize :: Int -> Config -> Config +setMaxSize n c = c {configQuickCheckMaxSize = Just n} + +setMaxDiscardRatio :: Int -> Config -> Config +setMaxDiscardRatio n c = c {configQuickCheckMaxDiscardRatio = Just n} + +setSeed :: Integer -> Config -> Config +setSeed n c = c {configQuickCheckSeed = Just n} + +data ColorMode = ColorAuto | ColorNever | ColorAlways + deriving (Eq, Show) + +type Result m = Either InvalidArgument (m Config) + +data InvalidArgument = InvalidArgument String String + +data Arg a = Arg { + _argumentName :: String +, _argumentParser :: String -> Maybe a +, _argumentSetter :: a -> Config -> Config +} + +mkOption :: Monad m => [Char] -> String -> Arg a -> String -> OptDescr (Result m -> Result m) +mkOption shortcut name (Arg argName parser setter) help = Option shortcut [name] (ReqArg arg argName) help + where + arg input x = x >>= \c -> case parser input of + Just n -> Right (setter 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 + , Option [] ["no-" ++ name] (NoArg $ set $ setter False) ("do not " ++ help) + ] + +commandLineOptions :: [OptDescr (Result Maybe -> Result Maybe)] +commandLineOptions = [ + Option [] ["help"] (NoArg (const $ Right Nothing)) "display this help and exit" + , Option [] ["ignore-dot-hspec"] (NoArg setIgnoreConfigFile) "do not read options from ~/.hspec and .hspec" + , mkOption "m" "match" (Arg "PATTERN" return addMatch) "only run examples that match given PATTERN" + , mkOption [] "skip" (Arg "PATTERN" return addSkip) "skip examples that match given PATTERN" + ] + where + setIgnoreConfigFile = set $ \config -> config {configIgnoreConfigFile = True} + +formatterOptions :: Monad m => [OptDescr (Result m -> Result m)] +formatterOptions = concat [ + [mkOption "f" "format" (Arg "FORMATTER" readFormatter setFormatter) helpForFormat] + , mkFlag "color" setColor "colorize the output" + , mkFlag "diff" setDiff "show colorized diffs" + , [Option [] ["print-cpu-time"] (NoArg setPrintCpuTime) "include used CPU time in summary"] + ] + where + formatters :: [(String, Formatter)] + formatters = [ + ("specdoc", specdoc) + , ("progress", progress) + , ("failed-examples", failed_examples) + , ("silent", silent) + ] + + helpForFormat :: String + helpForFormat = "use a custom formatter; this can be one of " ++ (formatOrList $ map fst formatters) + + readFormatter :: String -> Maybe Formatter + readFormatter = (`lookup` formatters) + + setFormatter :: Formatter -> Config -> Config + setFormatter f c = c {configFormatter = Just f} + + setColor :: Bool -> Config -> Config + setColor v config = config {configColorMode = if v then ColorAlways else ColorNever} + + setDiff :: Bool -> Config -> Config + setDiff v config = config {configDiff = v} + + setPrintCpuTime = set $ \config -> config {configPrintCpuTime = True} + +smallCheckOptions :: Monad m => [OptDescr (Result m -> Result m)] +smallCheckOptions = [ + mkOption [] "depth" (Arg "N" readMaybe setDepth) "maximum depth of generated test values for SmallCheck properties" + ] + +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 [] "seed" (Arg "N" readMaybe setSeed) "used seed for QuickCheck properties" + ] + +runnerOptions :: Monad m => [OptDescr (Result m -> Result m)] +runnerOptions = [ + Option [] ["dry-run"] (NoArg setDryRun) "pretend that everything passed; don't verify anything" + , Option [] ["fail-fast"] (NoArg setFastFail) "abort on first failure" + , Option "r" ["rerun"] (NoArg setRerun) "rerun all examples that failed in the previous test run (only works in combination with --failure-report or in GHCi)" + , mkOption [] "failure-report" (Arg "FILE" return setFailureReport) "read/write a failure report for use with --rerun" + , Option [] ["rerun-all-on-success"] (NoArg setRerunAllOnSuccess) "run the whole test suite after a previously failing rerun succeeds for the first time (only works in combination with --rerun)" + , mkOption "j" "jobs" (Arg "N" readMaxJobs setMaxJobs) "run at most N parallelizable tests simultaneously (default: number of available processors)" + ] + where + readMaxJobs :: String -> Maybe Int + readMaxJobs s = do + n <- readMaybe s + guard $ n > 0 + return n + + setFailureReport :: String -> Config -> Config + setFailureReport file c = c {configFailureReport = Just file} + + setMaxJobs :: Int -> Config -> Config + setMaxJobs n c = c {configConcurrentJobs = Just n} + + setDryRun = set $ \config -> config {configDryRun = True} + setFastFail = set $ \config -> config {configFastFail = True} + setRerun = set $ \config -> config {configRerun = True} + setRerunAllOnSuccess = set $ \config -> config {configRerunAllOnSuccess = True} + +documentedConfigFileOptions :: Monad m => [(String, [OptDescr (Result m -> Result m)])] +documentedConfigFileOptions = [ + ("RUNNER OPTIONS", runnerOptions) + , ("FORMATTER OPTIONS", formatterOptions) + , ("OPTIONS FOR QUICKCHECK", quickCheckOptions) + , ("OPTIONS FOR SMALLCHECK", smallCheckOptions) + ] + +documentedOptions :: [(String, [OptDescr (Result Maybe -> Result Maybe)])] +documentedOptions = ("OPTIONS", commandLineOptions) : documentedConfigFileOptions + +configFileOptions :: Monad m => [OptDescr (Result m -> Result m)] +configFileOptions = (concat . map snd) documentedConfigFileOptions + +set :: Monad m => (Config -> Config) -> Either a (m Config) -> Either a (m Config) +set = liftM . liftM + +undocumentedOptions :: Monad m => [OptDescr (Result m -> Result m)] +undocumentedOptions = [ + -- for compatibility with test-framework + mkOption [] "maximum-generated-tests" (Arg "NUMBER" readMaybe setMaxSuccess) "how many automated tests something like QuickCheck should try, by default" + + -- 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 + +parseOptions :: Config -> String -> [ConfigFile] -> Maybe EnvVar -> [String] -> Either (ExitCode, String) Config +parseOptions config prog configFiles envVar args = do + foldM (parseFileOptions prog) config configFiles + >>= parseEnvVarOptions prog envVar + >>= parseCommandLineOptions prog args + +parseCommandLineOptions :: String -> [String] -> Config -> Either (ExitCode, String) Config +parseCommandLineOptions prog args config = case parse recognizedOptions config args of + Right Nothing -> Left (ExitSuccess, usage) + Right (Just c) -> Right c + Left err -> failure err + where + failure err = Left (ExitFailure 1, prog ++ ": " ++ err ++ "\nTry `" ++ prog ++ " --help' for more information.\n") + + usage :: String + usage = "Usage: " ++ prog ++ " [OPTION]...\n\n" + ++ (intercalate "\n" $ map (uncurry mkUsageInfo) documentedOptions) + +parseFileOptions :: String -> Config -> ConfigFile -> Either (ExitCode, String) Config +parseFileOptions prog config (name, args) = + parseOtherOptions prog ("in config file " ++ name) args config + +parseEnvVarOptions :: String -> (Maybe EnvVar) -> Config -> Either (ExitCode, String) Config +parseEnvVarOptions prog args = + parseOtherOptions prog ("from environment variable " ++ envVarName) (fromMaybe [] args) + +parseOtherOptions :: String -> String -> [String] -> Config -> Either (ExitCode, String) Config +parseOtherOptions prog source args config = case parse configFileOptions config args of + Right (Identity c) -> Right c + Left err -> failure err + where + failure err = Left (ExitFailure 1, prog ++ ": " ++ message) + where + message = unlines $ case lines err of + [x] -> [x ++ " " ++ source] + xs -> xs ++ [source] + +parse :: Monad m => [OptDescr (Result m -> Result m)] -> Config -> [String] -> Either String (m Config) +parse options config args = case getOpt Permute options args of + (opts, [], []) -> case foldl' (flip id) (Right $ return config) opts of + Left (InvalidArgument name value) -> Left ("invalid argument `" ++ value ++ "' for `--" ++ name ++ "'") + Right x -> Right x + (_, _, err:_) -> Left (init err) + (_, arg:_, _) -> Left ("unexpected argument `" ++ arg ++ "'") + +ignoreConfigFile :: Config -> [String] -> IO Bool +ignoreConfigFile config args = do + ignore <- lookupEnv "IGNORE_DOT_HSPEC" + case ignore of + Just _ -> return True + Nothing -> case parse recognizedOptions config args of + Right (Just c) -> return (configIgnoreConfigFile c) + _ -> return False diff --git a/src/Test/Hspec/Core/Config/Util.hs b/src/Test/Hspec/Core/Config/Util.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Config/Util.hs @@ -0,0 +1,37 @@ +module Test.Hspec.Core.Config.Util where + +import System.Console.GetOpt + +import Test.Hspec.Core.Util + +modifyHelp :: (String -> String) -> OptDescr a -> OptDescr a +modifyHelp modify (Option s n a help) = Option s n a (modify help) + +mkUsageInfo :: String -> [OptDescr a] -> String +mkUsageInfo title = usageInfo title . addLineBreaksForHelp . condenseNoOptions + +addLineBreaksForHelp :: [OptDescr a] -> [OptDescr a] +addLineBreaksForHelp options = map (modifyHelp addLineBreaks) options + where + withoutHelpWidth = maxLength . usageInfo "" . map removeHelp + helpWidth = 80 - withoutHelpWidth options + + addLineBreaks = unlines . lineBreaksAt helpWidth + + maxLength = maximum . map length . lines + removeHelp = modifyHelp (const "") + +condenseNoOptions :: [OptDescr a] -> [OptDescr a] +condenseNoOptions options = case options of + Option "" [optionA] arg help : Option "" [optionB] _ _ : ys | optionB == ("no-" ++ optionA) -> + Option "" ["[no-]" ++ optionA] arg help : condenseNoOptions ys + x : xs -> x : condenseNoOptions xs + [] -> [] + +formatOrList :: [String] -> String +formatOrList xs = case xs of + [] -> "" + x : ys -> (case ys of + [] -> x + _ : [] -> x ++ " or " + _ : _ : _ -> x ++ ", ") ++ formatOrList ys 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 @@ -1,4 +1,9 @@ -{-# LANGUAGE CPP, TypeFamilies, FlexibleInstances, TypeSynonymInstances, DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} module Test.Hspec.Core.Example ( Example (..) , Params (..) @@ -6,33 +11,30 @@ , ActionWith , Progress , ProgressCallback -, Result (..) +, Result(..) +, ResultStatus (..) , Location (..) -, LocationAccuracy (..) , FailureReason (..) , safeEvaluateExample ) where -import Data.Maybe (fromMaybe) -import Data.List (isPrefixOf) import qualified Test.HUnit.Lang as HUnit -#if MIN_VERSION_HUnit(1,4,0) import Data.CallStack -#endif -import qualified Control.Exception as E +import Control.Exception import Control.DeepSeq import Data.Typeable (Typeable) import qualified Test.QuickCheck as QC import Test.Hspec.Expectations (Expectation) -import qualified Test.QuickCheck.State as QC +import qualified Test.QuickCheck.State as QC (numSuccessTests, maxSuccessTests) import qualified Test.QuickCheck.Property as QCP 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 class Example e where @@ -58,49 +60,49 @@ type ActionWith a = a -> IO () -- | The result of running an example -data Result = Success | Pending (Maybe String) | Failure (Maybe Location) FailureReason - deriving (Eq, Show, Read, Typeable) +data Result = Result { + resultInfo :: String +, resultStatus :: ResultStatus +} deriving (Show, Typeable) -data FailureReason = NoReason | Reason String | ExpectedButGot (Maybe String) String String - deriving (Eq, Show, Read, Typeable) +data ResultStatus = + Success + | Pending (Maybe Location) (Maybe String) + | Failure (Maybe Location) FailureReason + deriving (Show, Typeable) +data FailureReason = + NoReason + | Reason String + | ExpectedButGot (Maybe String) String String + | Error (Maybe String) SomeException + deriving (Show, Typeable) + instance NFData FailureReason where rnf reason = case reason of NoReason -> () Reason r -> r `deepseq` () ExpectedButGot p e a -> p `deepseq` e `deepseq` a `deepseq` () - -instance E.Exception Result - --- | @Location@ is used to represent source locations. -data Location = Location { - locationFile :: FilePath -, locationLine :: Int -, locationColumn :: Int -, locationAccuracy :: LocationAccuracy -} deriving (Eq, Show, Read) + Error m e -> m `deepseq` e `seq` () --- | A marker for source locations -data LocationAccuracy = - -- | The source location is accurate - ExactLocation | - -- | The source location was determined on a best-effort basis and my be - -- wrong or inaccurate - BestEffort - deriving (Eq, Show, Read) +instance Exception ResultStatus -safeEvaluateExample :: Example e => e -> Params -> (ActionWith (Arg e) -> IO ()) -> ProgressCallback -> IO (Either E.SomeException Result) +safeEvaluateExample :: Example e => e -> Params -> (ActionWith (Arg e) -> IO ()) -> ProgressCallback -> IO Result safeEvaluateExample example params around progress = do r <- safeTry $ forceResult <$> evaluateExample example params around progress return $ case r of - Left e | Just result <- E.fromException e -> Right result - Left e | Just hunit <- E.fromException e -> Right (hunitFailureToResult hunit) - _ -> r + 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 + Right result -> result where forceResult :: Result -> Result - forceResult r = case r of + forceResult r@(Result info status) = info `deepseq` (forceResultStatus status) `seq` r + + forceResultStatus :: ResultStatus -> ResultStatus + forceResultStatus r = case r of Success -> r - Pending m -> m `deepseq` r + Pending _ m -> m `deepseq` r Failure _ m -> m `deepseq` r instance Example Result where @@ -110,7 +112,7 @@ instance Example (a -> Result) where type Arg (a -> Result) = a evaluateExample example _params action _callback = do - ref <- newIORef Success + ref <- newIORef (Result "" Success) action (writeIORef ref . example) readIORef ref @@ -121,44 +123,42 @@ instance Example (a -> Bool) where type Arg (a -> Bool) = a evaluateExample p _params action _callback = do - ref <- newIORef Success + ref <- newIORef (Result "" Success) action $ \a -> example a >>= writeIORef ref readIORef ref where example a - | p a = return Success - | otherwise = return (Failure Nothing NoReason) + | p a = return (Result "" Success) + | otherwise = return (Result "" $ Failure Nothing NoReason) instance Example Expectation where type Arg Expectation = () evaluateExample e = evaluateExample (\() -> e) -hunitFailureToResult :: HUnit.HUnitFailure -> Result -hunitFailureToResult e = case e of -#if MIN_VERSION_HUnit(1,3,0) +hunitFailureToResult :: Maybe String -> HUnit.HUnitFailure -> ResultStatus +hunitFailureToResult pre e = case e of HUnit.HUnitFailure mLoc err -> -#if MIN_VERSION_HUnit(1,5,0) case err of - HUnit.Reason reason -> Failure location (Reason reason) - HUnit.ExpectedButGot preface expected actual -> Failure location (ExpectedButGot preface expected actual) -#else - Failure location (Reason err) -#endif + HUnit.Reason reason -> Failure location (Reason $ addPre reason) + HUnit.ExpectedButGot preface expected actual -> Failure location (ExpectedButGot (addPreMaybe preface) expected actual) + where + addPreMaybe :: Maybe String -> Maybe String + addPreMaybe xs = case (pre, xs) of + (Just x, Just y) -> Just (x ++ "\n" ++ y) + _ -> pre <|> xs where location = case mLoc of Nothing -> Nothing -#if MIN_VERSION_HUnit(1,4,0) - Just loc -> Just $ Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc) ExactLocation -#else - Just loc -> Just $ Location (HUnit.locationFile loc) (HUnit.locationLine loc) (HUnit.locationColumn loc) ExactLocation -#endif -#else - HUnit.HUnitFailure err -> Failure Nothing (Reason err) -#endif + Just loc -> Just $ Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc) + where + addPre :: String -> String + addPre xs = case pre of + Just x -> x ++ "\n" ++ xs + Nothing -> xs instance Example (a -> Expectation) where type Arg (a -> Expectation) = a - evaluateExample e _ action _ = action e >> return Success + evaluateExample e _ action _ = action e >> return (Result "" Success) instance Example QC.Property where type Arg QC.Property = () @@ -168,55 +168,41 @@ type Arg (a -> QC.Property) = a evaluateExample p c action progressCallback = do r <- QC.quickCheckWithResult (paramsQuickCheckArgs c) {QC.chatty = False} (QCP.callback qcProgressCallback $ aroundProperty action p) - return $ - case r of - QC.Success {} -> Success - QC.Failure {QC.output = m} -> fromMaybe (Failure Nothing . Reason $ sanitizeFailureMessage r) (parsePending m) - QC.GaveUp {QC.numTests = n} -> Failure Nothing (Reason $ "Gave up after " ++ pluralize n "test" ) - QC.NoExpectedFailure {} -> Failure Nothing (Reason $ "No expected failure") -#if MIN_VERSION_QuickCheck(2,8,0) - QC.InsufficientCoverage {} -> Failure Nothing (Reason $ "Insufficient coverage") -#endif + return $ fromQuickCheckResult r where qcProgressCallback = QCP.PostTest QCP.NotCounterexample $ \st _ -> progressCallback (QC.numSuccessTests st, QC.maxSuccessTests st) - sanitizeFailureMessage :: QC.Result -> String - sanitizeFailureMessage r = let m = QC.output r in strip $ -#if MIN_VERSION_QuickCheck(2,7,0) - case QC.theException r of - Just e -> case E.fromException e :: Maybe (HUnit.HUnitFailure) of - Just _ -> (addFalsifiable . stripFailed) m - Nothing -> let numbers = formatNumbers r in - "uncaught exception: " ++ formatException e ++ " " ++ numbers ++ "\n" ++ case lines m of -#if MIN_VERSION_QuickCheck(2,11,0) - x:xs | x == (exceptionPrefix ++ show e ++ "' " ++ numbers ++ ":") -> unlines xs -#else - x:xs | x == (exceptionPrefix ++ show e ++ "' " ++ numbers ++ ": ") -> unlines xs -#endif - _ -> m - Nothing -> -#endif - (addFalsifiable . stripFailed) m +fromQuickCheckResult :: QC.Result -> Result +fromQuickCheckResult r = case parseQuickCheckResult r of + QuickCheckResult _ info (QuickCheckOtherFailure err) -> Result info $ Failure Nothing (Reason err) + QuickCheckResult _ info QuickCheckSuccess -> Result info Success + QuickCheckResult n info (QuickCheckFailure QCFailure{..}) -> case quickCheckFailureException of + Just e | Just result <- fromException e -> Result info result + Just e | Just hunit <- fromException e -> Result info $ hunitFailureToResult (Just hunitAssertion) hunit + Just e -> failure (uncaughtException e) + Nothing -> failure falsifiable + where + failure = Result info . Failure Nothing . Reason - addFalsifiable :: String -> String - addFalsifiable m - | "(after " `isPrefixOf` m = "Falsifiable " ++ m - | otherwise = m + numbers = formatNumbers n quickCheckFailureNumShrinks - stripFailed :: String -> String - stripFailed m - | prefix `isPrefixOf` m = drop n m - | otherwise = m - where - prefix = "*** Failed! " - n = length prefix + hunitAssertion :: String + hunitAssertion = intercalate "\n" [ + "Falsifiable " ++ numbers ++ ":" + , indent (unlines quickCheckFailureCounterexample) + ] - parsePending :: String -> Maybe Result - parsePending m - | exceptionPrefix `isPrefixOf` m = (readMaybe . takeWhile (/= '\'') . drop n) m - | otherwise = Nothing - where - n = length exceptionPrefix + uncaughtException e = intercalate "\n" [ + "uncaught exception: " ++ formatException e + , numbers + , indent (unlines quickCheckFailureCounterexample) + ] - exceptionPrefix = "*** Failed! Exception: '" + falsifiable = intercalate "\n" [ + quickCheckFailureReason ++ " " ++ numbers ++ ":" + , indent (unlines quickCheckFailureCounterexample) + ] + +indent :: String -> String +indent = intercalate "\n" . map (" " ++) . lines diff --git a/src/Test/Hspec/Core/Example/Location.hs b/src/Test/Hspec/Core/Example/Location.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Example/Location.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE CPP #-} +module Test.Hspec.Core.Example.Location ( + Location(..) +, extractLocation + +-- for testing +, parseCallStack +, parseLocation +, parseSourceSpan +) where + +import Prelude () +import Test.Hspec.Core.Compat + +import Control.Exception +import Data.List +import Data.Char +import Data.Maybe +import GHC.IO.Exception + +-- | @Location@ is used to represent source locations. +data Location = Location { + locationFile :: FilePath +, locationLine :: Int +, locationColumn :: Int +} deriving (Eq, Show, Read) + +extractLocation :: SomeException -> Maybe Location +extractLocation e = locationFromErrorCall e <|> locationFromPatternMatchFail e <|> locationFromIOException e + +locationFromErrorCall :: SomeException -> Maybe Location +locationFromErrorCall e = case fromException e of +#if MIN_VERSION_base(4,9,0) + Just (ErrorCallWithLocation err loc) -> + parseCallStack loc <|> +#else + Just (ErrorCall err) -> +#endif + fromPatternMatchFailureInDoExpression err + Nothing -> Nothing + +locationFromPatternMatchFail :: SomeException -> Maybe Location +locationFromPatternMatchFail e = case fromException e of + Just (PatternMatchFail s) -> listToMaybe (words s) >>= parseSourceSpan + Nothing -> Nothing + +locationFromIOException :: SomeException -> Maybe Location +locationFromIOException e = case fromException e of + Just (IOError {ioe_type = UserError, ioe_description = xs}) -> fromPatternMatchFailureInDoExpression xs + Just _ -> Nothing + Nothing -> Nothing + +fromPatternMatchFailureInDoExpression :: String -> Maybe Location +fromPatternMatchFailureInDoExpression input = + stripPrefix "Pattern match failure in do expression at " input >>= parseSourceSpan + +parseCallStack :: String -> Maybe Location +parseCallStack input = case reverse (lines input) of + [] -> Nothing + line : _ -> findLocation line + where + findLocation xs = case xs of + [] -> Nothing + _ : ys -> case stripPrefix prefix xs of + Just zs -> parseLocation (takeWhile (not . isSpace) zs) + Nothing -> findLocation ys + prefix = ", called at " + +parseLocation :: String -> Maybe Location +parseLocation input = case fmap breakColon (breakColon input) of + (file, (line, column)) -> Location file <$> readMaybe line <*> readMaybe column + +parseSourceSpan :: String -> Maybe Location +parseSourceSpan input = case breakColon input of + (file, xs) -> (uncurry $ Location file) <$> (tuple <|> colonSeparated) + where + lineAndColumn :: String + lineAndColumn = takeWhile (/= '-') xs + + tuple :: Maybe (Int, Int) + tuple = readMaybe lineAndColumn + + colonSeparated :: Maybe (Int, Int) + colonSeparated = case breakColon lineAndColumn of + (l, c) -> (,) <$> readMaybe l <*> readMaybe c + +breakColon :: String -> (String, String) +breakColon = fmap (drop 1) . break (== ':') diff --git a/src/Test/Hspec/Core/FailureReport.hs b/src/Test/Hspec/Core/FailureReport.hs --- a/src/Test/Hspec/Core/FailureReport.hs +++ b/src/Test/Hspec/Core/FailureReport.hs @@ -14,7 +14,7 @@ import System.Directory import Test.Hspec.Core.Compat import Test.Hspec.Core.Util (Path) -import Test.Hspec.Core.Options (Config(..)) +import Test.Hspec.Core.Config.Options (Config(..)) data FailureReport = FailureReport { failureReportSeed :: Integer diff --git a/src/Test/Hspec/Core/Format.hs b/src/Test/Hspec/Core/Format.hs new file mode 100644 --- /dev/null +++ b/src/Test/Hspec/Core/Format.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE RankNTypes #-} +module Test.Hspec.Core.Format ( + Format(..) +, Progress +, Path +, Location(..) +, Seconds(..) +, Item(..) +, Result(..) +, FailureReason(..) +) where + +import Test.Hspec.Core.Spec (Progress, Location(..)) +import Test.Hspec.Core.Example (FailureReason(..)) +import Test.Hspec.Core.Util (Path) +import Test.Hspec.Core.Clock + +data Item = Item { + itemLocation :: Maybe Location +, itemDuration :: Seconds +, itemInfo :: String +, itemResult :: Result +} + +data Result = + Success + | Pending (Maybe String) + | Failure FailureReason + +data Format m = Format { + formatRun :: forall a. m a -> IO a +, formatGroupStarted :: Path -> m () +, formatGroupDone :: Path -> m () +, formatProgress :: Path -> Progress -> m () +, formatItem :: Path -> Item -> m () +} 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 @@ -32,12 +32,14 @@ , getFailMessages , usedSeed +, Seconds(..) , getCPUTime , getRealTime --- ** Appending to the gerenated report +-- ** Appending to the generated report , write , writeLine +, writeTransient -- ** Dealing with colors , withInfoColor @@ -57,10 +59,9 @@ import Data.Maybe import Test.Hspec.Core.Util -import Test.Hspec.Core.Spec (Location(..), LocationAccuracy(..)) +import Test.Hspec.Core.Spec (Location(..)) import Text.Printf -import Control.Monad (when, unless) -import System.IO (hPutStr, hFlush) +import Control.Monad (unless) -- We use an explicit import list for "Test.Hspec.Formatters.Internal", to make -- sure, that we only use the public API to implement formatters. @@ -86,6 +87,7 @@ , write , writeLine + , writeTransient , withInfoColor , withSuccessColor @@ -96,6 +98,8 @@ , missingChunk ) +import Test.Hspec.Core.Clock (Seconds(..)) + import Test.Hspec.Core.Formatters.Diff silent :: Formatter @@ -103,10 +107,10 @@ headerFormatter = return () , exampleGroupStarted = \_ _ -> return () , exampleGroupDone = return () -, exampleProgress = \_ _ _ -> return () -, exampleSucceeded = \_ -> return () -, exampleFailed = \_ _ -> return () -, examplePending = \_ _ -> return () +, exampleProgress = \_ _ -> return () +, exampleSucceeded = \ _ _ -> return () +, exampleFailed = \_ _ _ -> return () +, examplePending = \_ _ _ -> return () , failedFormatter = return () , footerFormatter = return () } @@ -120,19 +124,25 @@ , exampleGroupStarted = \nesting name -> do writeLine (indentationFor nesting ++ name) -, exampleProgress = \h _ p -> do - hPutStr h (formatProgress p) - hFlush h +, exampleProgress = \_ p -> do + writeTransient (formatProgress p) -, exampleSucceeded = \(nesting, requirement) -> withSuccessColor $ do +, exampleSucceeded = \(nesting, requirement) info -> withSuccessColor $ do writeLine $ indentationFor nesting ++ requirement + forM_ (lines info) $ \ s -> + writeLine $ indentationFor ("" : nesting) ++ s -, exampleFailed = \(nesting, requirement) _ -> withFailColor $ do +, 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) reason -> withPendingColor $ do - writeLine $ indentationFor nesting ++ requirement ++ "\n # PENDING: " ++ fromMaybe "No reason given" reason +, 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 @@ -140,15 +150,15 @@ } where indentationFor nesting = replicate (length nesting * 2) ' ' formatProgress (current, total) - | total == 0 = show current ++ "\r" - | otherwise = show current ++ "/" ++ show total ++ "\r" + | total == 0 = show current + | otherwise = show current ++ "/" ++ show total progress :: Formatter progress = silent { - exampleSucceeded = \_ -> withSuccessColor $ write "." -, exampleFailed = \_ _ -> withFailColor $ write "F" -, examplePending = \_ _ -> withPendingColor $ write "." + exampleSucceeded = \_ _ -> withSuccessColor $ write "." +, exampleFailed = \_ _ _ -> withFailColor $ write "F" +, examplePending = \_ _ _ -> withPendingColor $ write "." , failedFormatter = defaultFailedFormatter , footerFormatter = defaultFooter } @@ -174,19 +184,9 @@ formatFailure x writeLine "" - when (hasBestEffortLocations failures) $ do - withInfoColor $ writeLine "Source locations marked with \"best-effort\" are calculated heuristically and may be incorrect." - writeLine "" - write "Randomized with seed " >> usedSeed >>= writeLine . show writeLine "" where - hasBestEffortLocations :: [FailureRecord] -> Bool - hasBestEffortLocations = any p - where - p :: FailureRecord -> Bool - p failure = (locationAccuracy <$> failureRecordLocation failure) == Just BestEffort - formatFailure :: (Int, FailureRecord) -> FormatM () formatFailure (n, FailureRecord mLoc path reason) = do forM_ mLoc $ \loc -> do @@ -194,10 +194,9 @@ write (" " ++ show n ++ ") ") writeLine (formatRequirement path) case reason of - Left e -> withFailColor . indent $ (("uncaught exception: " ++) . formatException) e - Right NoReason -> return () - Right (Reason err) -> withFailColor $ indent err - Right (ExpectedButGot preface expected actual) -> do + NoReason -> return () + Reason err -> withFailColor $ indent err + ExpectedButGot preface expected actual -> do mapM_ indent preface let chunks = diff expected actual @@ -219,19 +218,13 @@ indented output text = case break (== '\n') text of (xs, "") -> output xs (xs, _ : ys) -> output (xs ++ "\n") >> write (indentation ++ " ") >> indented output ys + Error _ e -> withFailColor . indent $ (("uncaught exception: " ++) . formatException) e where indentation = " " indent message = do forM_ (lines message) $ \line -> do writeLine (indentation ++ line) - formatLoc (Location file line _column accuracy) = " " ++ file ++ ":" ++ show line ++ ":" ++ message - where - message = case accuracy of - ExactLocation -> " " -- NOTE: Vim's default 'errorformat' - -- requires a non-empty message. This is - -- why we use a single space as message - -- here. - BestEffort -> " (best-effort)" + formatLoc (Location file line column) = " " ++ file ++ ":" ++ show line ++ ":" ++ show column ++ ": " defaultFooter :: FormatM () defaultFooter = do 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,14 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Test.Hspec.Core.Formatters.Internal ( FormatM +, FormatConfig(..) , runFormatM , interpret , increaseSuccessCount , increasePendingCount -, increaseFailCount , addFailMessage , finally_ +, formatterToFormat ) where import Prelude () @@ -16,30 +17,54 @@ import qualified System.IO as IO import System.IO (Handle) import Control.Monad -import Control.Exception (SomeException, AsyncException(..), bracket_, try, throwIO) +import Control.Exception (AsyncException(..), bracket_, try, throwIO) import System.Console.ANSI -import Control.Monad.Trans.State hiding (gets, modify) +import Control.Monad.Trans.State hiding (state, gets, modify) import Control.Monad.IO.Class +import Data.Char (isSpace) import qualified System.CPUTime as CPUTime -import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) -import Test.Hspec.Core.Util (Path) -import Test.Hspec.Core.Spec (Location) -import Test.Hspec.Core.Example (FailureReason(..)) - import qualified Test.Hspec.Core.Formatters.Monad as M import Test.Hspec.Core.Formatters.Monad (Environment(..), interpretWith, FailureRecord(..)) +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 -> when useColor $ do + interpret $ M.exampleProgress formatter path progress +, formatItem = \ path (Item loc _duration info result) -> 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 +} where + useColor = formatConfigUseColor config + interpret :: M.FormatM a -> FormatM a interpret = interpretWith Environment { environmentGetSuccessCount = getSuccessCount , environmentGetPendingCount = getPendingCount -, environmentGetFailCount = getFailCount , environmentGetFailMessages = getFailMessages , environmentUsedSeed = usedSeed , environmentGetCPUTime = getCPUTime , environmentGetRealTime = getRealTime , environmentWrite = write +, environmentWriteTransient = writeTransient , environmentWithFailColor = withFailColor , environmentWithSuccessColor = withSuccessColor , environmentWithPendingColor = withPendingColor @@ -59,72 +84,89 @@ 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 { - stateHandle :: Handle -, stateUseColor :: Bool -, stateUseDiff :: Bool -, produceHTML :: Bool -, successCount :: Int -, pendingCount :: Int -, failCount :: Int -, failMessages :: [FailureRecord] -, stateUsedSeed :: Integer -, cpuStartTime :: Maybe Integer -, startTime :: POSIXTime + stateSuccessCount :: Int +, statePendingCount :: Int +, stateFailMessages :: [FailureRecord] +, stateCpuStartTime :: Maybe Integer +, stateStartTime :: Seconds +, stateTransientOutput :: String +, stateConfig :: FormatConfig } +getConfig :: (FormatConfig -> a) -> FormatM a +getConfig f = gets (f . stateConfig) + +getHandle :: FormatM Handle +getHandle = getConfig formatConfigHandle + -- | The random seed that is used for QuickCheck. usedSeed :: FormatM Integer -usedSeed = gets stateUsedSeed +usedSeed = getConfig formatConfigUsedSeed -- NOTE: We use an IORef here, so that the state persists when UserInterrupt is -- thrown. newtype FormatM a = FormatM (StateT (IORef FormatterState) IO a) deriving (Functor, Applicative, Monad, MonadIO) -runFormatM :: Bool -> Bool -> Bool -> Bool -> Integer -> Handle -> FormatM a -> IO a -runFormatM useColor useDiff produceHTML_ printCpuTime seed handle (FormatM action) = do - time <- getPOSIXTime - cpuTime <- if printCpuTime then Just <$> CPUTime.getCPUTime else pure Nothing - st <- newIORef (FormatterState handle useColor useDiff produceHTML_ 0 0 0 [] seed cpuTime time) +runFormatM :: FormatConfig -> FormatM a -> IO a +runFormatM config (FormatM action) = 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 -- | Increase the counter for successful examples increaseSuccessCount :: FormatM () -increaseSuccessCount = modify $ \s -> s {successCount = succ $ successCount s} +increaseSuccessCount = modify $ \s -> s {stateSuccessCount = succ $ stateSuccessCount s} -- | Increase the counter for pending examples increasePendingCount :: FormatM () -increasePendingCount = modify $ \s -> s {pendingCount = succ $ pendingCount s} - --- | Increase the counter for failed examples -increaseFailCount :: FormatM () -increaseFailCount = modify $ \s -> s {failCount = succ $ failCount s} +increasePendingCount = modify $ \s -> s {statePendingCount = succ $ statePendingCount s} -- | Get the number of successful examples encountered so far. getSuccessCount :: FormatM Int -getSuccessCount = gets successCount +getSuccessCount = gets stateSuccessCount -- | Get the number of pending examples encountered so far. getPendingCount :: FormatM Int -getPendingCount = gets pendingCount - --- | Get the number of failed examples encountered so far. -getFailCount :: FormatM Int -getFailCount = gets failCount +getPendingCount = gets statePendingCount -- | Append to the list of accumulated failure messages. -addFailMessage :: Maybe Location -> Path -> Either SomeException FailureReason -> FormatM () -addFailMessage loc p m = modify $ \s -> s {failMessages = FailureRecord loc p m : failMessages s} +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 failMessages +getFailMessages = reverse `fmap` gets stateFailMessages +writeTransient :: String -> FormatM () +writeTransient s = do + write ("\r" ++ s) + modify $ \ state -> state {stateTransientOutput = s} + h <- getHandle + 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 = ""} + -- | Append some output to the report. write :: String -> FormatM () write s = do - h <- gets stateHandle + h <- getHandle liftIO $ IO.hPutStr h s -- | Set output color to red, run given action, and finally restore the default @@ -150,16 +192,16 @@ -- | Set a color, run an action, and finally reset colors. withColor :: SGR -> String -> FormatM a -> FormatM a withColor color cls action = do - r <- gets produceHTML - (if r then htmlSpan cls else withColor_ color) action + produceHTML <- getConfig formatConfigHtmlOutput + (if produceHTML then htmlSpan cls else withColor_ color) action htmlSpan :: String -> FormatM a -> FormatM a htmlSpan cls action = write ("") *> action <* write "" withColor_ :: SGR -> FormatM a -> FormatM a withColor_ color (FormatM action) = do - useColor <- gets stateUseColor - h <- gets stateHandle + useColor <- getConfig formatConfigUseColor + h <- getHandle FormatM . StateT $ \st -> do bracket_ @@ -176,45 +218,61 @@ -- | Output given chunk in red. extraChunk :: String -> FormatM () extraChunk s = do - useDiff <- gets stateUseDiff + useDiff <- getConfig formatConfigUseDiff case useDiff of - True -> withFailColor $ write s + True -> extra s False -> write s + where + extra :: String -> FormatM () + extra = diffColorize Red "hspec-failure" -- | Output given chunk in green. missingChunk :: String -> FormatM () missingChunk s = do - useDiff <- gets stateUseDiff + useDiff <- getConfig formatConfigUseDiff case useDiff of - True -> withSuccessColor $ write s + True -> missing s False -> write s + where + missing :: String-> FormatM () + missing = diffColorize Green "hspec-success" +diffColorize :: Color -> String -> String-> FormatM () +diffColorize color cls s = withColor (SetColor layer Dull color) cls $ do + write s + where + 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 () -> FormatM () -> FormatM () +finally_ :: FormatM a -> FormatM () -> FormatM a finally_ (FormatM actionA) (FormatM actionB) = FormatM . StateT $ \st -> do - r <- try (execStateT actionA st) + r <- try (runStateT actionA st) case r of Left e -> do when (e == UserInterrupt) $ runStateT actionB st >> return () throwIO e - Right st_ -> do - runStateT actionB st_ + 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 Double) +getCPUTime :: FormatM (Maybe Seconds) getCPUTime = do t1 <- liftIO CPUTime.getCPUTime - mt0 <- gets cpuStartTime + mt0 <- gets stateCpuStartTime return $ toSeconds <$> ((-) <$> pure t1 <*> mt0) where - toSeconds x = fromIntegral x / (10.0 ^ (12 :: Integer)) + toSeconds x = Seconds (fromIntegral x / (10.0 ^ (12 :: Integer))) -- | Get the passed real time since the test run has been started. -getRealTime :: FormatM Double +getRealTime :: FormatM Seconds getRealTime = do - t1 <- liftIO getPOSIXTime - t0 <- gets startTime - return (realToFrac $ t1 - t0) + t1 <- liftIO getMonotonicTime + t0 <- gets stateStartTime + return (t1 - t0) 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 @@ -23,6 +23,7 @@ , write , writeLine +, writeTransient , withInfoColor , withSuccessColor @@ -39,63 +40,59 @@ import Prelude () import Test.Hspec.Core.Compat -import System.IO (Handle) -import Control.Exception 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 data Formatter = Formatter { headerFormatter :: FormatM () -- | evaluated before each test group --- --- The given number indicates the position within the parent group. , exampleGroupStarted :: [String] -> String -> FormatM () -, exampleGroupDone :: FormatM () +, exampleGroupDone :: FormatM () -- | used to notify the progress of the currently evaluated example -- -- /Note/: This is only called when interactive/color mode. -, exampleProgress :: Handle -> Path -> Progress -> IO () +, exampleProgress :: Path -> Progress -> FormatM () -- | evaluated after each successful example -, exampleSucceeded :: Path -> FormatM () +, exampleSucceeded :: Path -> String -> FormatM () -- | evaluated after each failed example -, exampleFailed :: Path -> Either SomeException FailureReason -> FormatM () +, exampleFailed :: Path -> String -> FailureReason -> FormatM () -- | evaluated after each pending example -, examplePending :: Path -> Maybe String -> FormatM () +, examplePending :: Path -> String -> Maybe String -> FormatM () -- | evaluated after a test run -, failedFormatter :: FormatM () +, failedFormatter :: FormatM () -- | evaluated after `failuresFormatter` -, footerFormatter :: FormatM () +, footerFormatter :: FormatM () } data FailureRecord = FailureRecord { failureRecordLocation :: Maybe Location , failureRecordPath :: Path -, failureRecordMessage :: Either SomeException FailureReason +, failureRecordMessage :: FailureReason } data FormatF next = GetSuccessCount (Int -> next) | GetPendingCount (Int -> next) - | GetFailCount (Int -> next) | GetFailMessages ([FailureRecord] -> next) | UsedSeed (Integer -> next) - | GetCPUTime (Maybe Double -> next) - | GetRealTime (Double -> next) + | GetCPUTime (Maybe Seconds -> next) + | GetRealTime (Seconds -> next) | Write String next + | WriteTransient String next | forall a. WithFailColor (FormatM a) (a -> next) | forall a. WithSuccessColor (FormatM a) (a -> next) | forall a. WithPendingColor (FormatM a) (a -> next) @@ -108,12 +105,12 @@ fmap f x = case x of GetSuccessCount next -> GetSuccessCount (fmap f next) GetPendingCount next -> GetPendingCount (fmap f next) - GetFailCount next -> GetFailCount (fmap f next) GetFailMessages next -> GetFailMessages (fmap f next) UsedSeed next -> UsedSeed (fmap f next) GetCPUTime next -> GetCPUTime (fmap f next) GetRealTime next -> GetRealTime (fmap f next) Write s next -> Write s (f next) + WriteTransient s next -> WriteTransient s (f next) WithFailColor action next -> WithFailColor action (fmap f next) WithSuccessColor action next -> WithSuccessColor action (fmap f next) WithPendingColor action next -> WithPendingColor action (fmap f next) @@ -130,12 +127,12 @@ data Environment m = Environment { environmentGetSuccessCount :: m Int , environmentGetPendingCount :: m Int -, environmentGetFailCount :: m Int , environmentGetFailMessages :: m [FailureRecord] , environmentUsedSeed :: m Integer -, environmentGetCPUTime :: m (Maybe Double) -, environmentGetRealTime :: m Double +, environmentGetCPUTime :: m (Maybe Seconds) +, environmentGetRealTime :: m Seconds , environmentWrite :: String -> m () +, environmentWriteTransient :: String -> m () , environmentWithFailColor :: forall a. m a -> m a , environmentWithSuccessColor :: forall a. m a -> m a , environmentWithPendingColor :: forall a. m a -> m a @@ -154,12 +151,12 @@ Free action -> case action of GetSuccessCount next -> environmentGetSuccessCount >>= go . next GetPendingCount next -> environmentGetPendingCount >>= go . next - GetFailCount next -> environmentGetFailCount >>= go . next GetFailMessages next -> environmentGetFailMessages >>= go . next UsedSeed next -> environmentUsedSeed >>= go . next GetCPUTime next -> environmentGetCPUTime >>= go . next GetRealTime next -> environmentGetRealTime >>= go . next Write s next -> environmentWrite s >> go next + WriteTransient s next -> environmentWriteTransient s >> go next WithFailColor inner next -> environmentWithFailColor (go inner) >>= go . next WithSuccessColor inner next -> environmentWithSuccessColor (go inner) >>= go . next WithPendingColor inner next -> environmentWithPendingColor (go inner) >>= go . next @@ -178,7 +175,7 @@ -- | Get the number of failed examples encountered so far. getFailCount :: FormatM Int -getFailCount = liftF (GetFailCount id) +getFailCount = length <$> getFailMessages -- | Get the total number of examples encountered so far. getTotalCount :: FormatM Int @@ -193,11 +190,11 @@ usedSeed = liftF (UsedSeed id) -- | Get the used CPU time since the test run has been started. -getCPUTime :: FormatM (Maybe Double) +getCPUTime :: FormatM (Maybe Seconds) getCPUTime = liftF (GetCPUTime id) -- | Get the passed real time since the test run has been started. -getRealTime :: FormatM Double +getRealTime :: FormatM Seconds getRealTime = liftF (GetRealTime id) -- | Append some output to the report. @@ -207,6 +204,9 @@ -- | The same as `write`, but adds a newline character. writeLine :: String -> FormatM () writeLine s = write s >> write "\n" + +writeTransient :: String -> FormatM () +writeTransient s = liftF (WriteTransient s ()) -- | Set output color to red, run given action, and finally restore the default -- color. 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 @@ -57,7 +57,7 @@ a <- try action return (either Failed Memoized a, a) Memoized a -> return (ma, Right a) - Failed _ -> throwIO (Pending (Just "exception in beforeAll-hook (see previous failure)")) + Failed _ -> throwIO (Pending Nothing (Just "exception in beforeAll-hook (see previous failure)")) either throwIO return result -- | Run a custom action after every spec item. diff --git a/src/Test/Hspec/Core/Options.hs b/src/Test/Hspec/Core/Options.hs deleted file mode 100644 --- a/src/Test/Hspec/Core/Options.hs +++ /dev/null @@ -1,283 +0,0 @@ -module Test.Hspec.Core.Options ( - Config(..) -, ColorMode (..) -, defaultConfig -, filterOr -, parseOptions -, ConfigFile -, ignoreConfigFile -, envVarName -) where - -import Prelude () -import Control.Monad -import Test.Hspec.Core.Compat - -import System.IO -import System.Exit -import System.Console.GetOpt - -import Test.Hspec.Core.Formatters -import Test.Hspec.Core.Util -import Test.Hspec.Core.Example (Params(..), defaultParams) -import Data.Functor.Identity -import Data.Maybe - -type ConfigFile = (FilePath, [String]) - -type EnvVar = [String] - -envVarName :: String -envVarName = "HSPEC_OPTIONS" - -data Config = Config { - configIgnoreConfigFile :: Bool -, configDryRun :: Bool -, configPrintCpuTime :: Bool -, configFastFail :: Bool -, configFailureReport :: Maybe FilePath -, configRerun :: Bool -, configRerunAllOnSuccess :: Bool - --- | --- A predicate that is used to filter the spec before it is run. Only examples --- that satisfy the predicate are run. -, configFilterPredicate :: Maybe (Path -> Bool) -, configSkipPredicate :: Maybe (Path -> Bool) -, configQuickCheckSeed :: Maybe Integer -, configQuickCheckMaxSuccess :: Maybe Int -, configQuickCheckMaxDiscardRatio :: Maybe Int -, configQuickCheckMaxSize :: Maybe Int -, configSmallCheckDepth :: Int -, configColorMode :: ColorMode -, configDiff :: Bool -, configFormatter :: Maybe Formatter -, configHtmlOutput :: Bool -, configOutputFile :: Either Handle FilePath -, configConcurrentJobs :: Maybe Int -} - -defaultConfig :: Config -defaultConfig = Config { - configIgnoreConfigFile = False -, configDryRun = False -, configPrintCpuTime = False -, configFastFail = False -, configFailureReport = Nothing -, configRerun = False -, configRerunAllOnSuccess = False -, configFilterPredicate = Nothing -, configSkipPredicate = Nothing -, configQuickCheckSeed = Nothing -, configQuickCheckMaxSuccess = Nothing -, configQuickCheckMaxDiscardRatio = Nothing -, configQuickCheckMaxSize = Nothing -, configSmallCheckDepth = paramsSmallCheckDepth defaultParams -, configColorMode = ColorAuto -, configDiff = True -, configFormatter = Nothing -, configHtmlOutput = False -, configOutputFile = Left stdout -, configConcurrentJobs = Nothing -} - -filterOr :: Maybe (Path -> Bool) -> Maybe (Path -> Bool) -> Maybe (Path -> Bool) -filterOr p1_ p2_ = case (p1_, p2_) of - (Just p1, Just p2) -> Just $ \path -> p1 path || p2 path - _ -> p1_ <|> p2_ - -addMatch :: String -> Config -> Config -addMatch s c = c {configFilterPredicate = Just (filterPredicate s) `filterOr` configFilterPredicate c} - -addSkip :: String -> Config -> Config -addSkip s c = c {configSkipPredicate = Just (filterPredicate s) `filterOr` configSkipPredicate c} - -setDepth :: Int -> Config -> Config -setDepth n c = c {configSmallCheckDepth = n} - -setMaxSuccess :: Int -> Config -> Config -setMaxSuccess n c = c {configQuickCheckMaxSuccess = Just n} - -setMaxSize :: Int -> Config -> Config -setMaxSize n c = c {configQuickCheckMaxSize = Just n} - -setMaxDiscardRatio :: Int -> Config -> Config -setMaxDiscardRatio n c = c {configQuickCheckMaxDiscardRatio = Just n} - -setSeed :: Integer -> Config -> Config -setSeed n c = c {configQuickCheckSeed = Just n} - -data ColorMode = ColorAuto | ColorNever | ColorAlways - deriving (Eq, Show) - -formatters :: [(String, Formatter)] -formatters = [ - ("specdoc", specdoc) - , ("progress", progress) - , ("failed-examples", failed_examples) - , ("silent", silent) - ] - -formatHelp :: String -formatHelp = unlines (addLineBreaks "use a custom formatter; this can be one of:" ++ map ((" " ++) . fst) formatters) - -type Result m = Either InvalidArgument (m Config) - -data InvalidArgument = InvalidArgument String String - -data Arg a = Arg { - _argumentName :: String -, _argumentParser :: String -> Maybe a -, _argumentSetter :: a -> Config -> Config -} - -mkOption :: Monad m => [Char] -> String -> Arg a -> String -> OptDescr (Result m -> Result m) -mkOption shortcut name (Arg argName parser setter) help = Option shortcut [name] (ReqArg arg argName) help - where - arg input x = x >>= \c -> case parser input of - Just n -> Right (setter n `liftM` c) - Nothing -> Left (InvalidArgument name input) - -addLineBreaks :: String -> [String] -addLineBreaks = lineBreaksAt 40 - -h :: String -> String -h = unlines . addLineBreaks - -commandLineOptions :: [OptDescr (Result Maybe -> Result Maybe)] -commandLineOptions = [ - Option [] ["help"] (NoArg (const $ Right Nothing)) (h "display this help and exit") - , Option [] ["ignore-dot-hspec"] (NoArg setIgnoreConfigFile) (h "do not read options from ~/.hspec and .hspec") - , mkOption "m" "match" (Arg "PATTERN" return addMatch) (h "only run examples that match given PATTERN") - , mkOption [] "skip" (Arg "PATTERN" return addSkip) (h "skip examples that match given PATTERN") - ] - where - setIgnoreConfigFile = set $ \config -> config {configIgnoreConfigFile = True} - -configFileOptions :: Monad m => [OptDescr (Result m -> Result m)] -configFileOptions = [ - Option [] ["color"] (NoArg setColor) (h "colorize the output") - , Option [] ["no-color"] (NoArg setNoColor) (h "do not colorize the output") - , Option [] ["diff"] (NoArg setDiff) (h "show colorized diffs") - , Option [] ["no-diff"] (NoArg setNoDiff) (h "do not show colorized diffs") - , mkOption "f" "format" (Arg "FORMATTER" readFormatter setFormatter) formatHelp - , mkOption "o" "out" (Arg "FILE" return setOutputFile) (h "write output to a file instead of STDOUT") - , mkOption [] "depth" (Arg "N" readMaybe setDepth) (h "maximum depth of generated test values for SmallCheck properties") - , mkOption "a" "qc-max-success" (Arg "N" readMaybe setMaxSuccess) (h "maximum number of successful tests before a QuickCheck property succeeds") - , mkOption "" "qc-max-size" (Arg "N" readMaybe setMaxSize) (h "size to use for the biggest test cases") - , mkOption "" "qc-max-discard" (Arg "N" readMaybe setMaxDiscardRatio) (h "maximum number of discarded tests per successful test before giving up") - , mkOption [] "seed" (Arg "N" readMaybe setSeed) (h "used seed for QuickCheck properties") - , Option [] ["print-cpu-time"] (NoArg setPrintCpuTime) (h "include used CPU time in summary") - , Option [] ["dry-run"] (NoArg setDryRun) (h "pretend that everything passed; don't verify anything") - , Option [] ["fail-fast"] (NoArg setFastFail) (h "abort on first failure") - , Option "r" ["rerun"] (NoArg setRerun) (h "rerun all examples that failed in the previous test run (only works in combination with --failure-report or in GHCi)") - , mkOption [] "failure-report" (Arg "FILE" return setFailureReport)(h "read/write a failure report for use with --rerun") - , Option [] ["rerun-all-on-success"] (NoArg setRerunAllOnSuccess) (h "run the whole test suite after a previously failing rerun succeeds for the first time (only works in combination with --rerun)") - , mkOption "j" "jobs" (Arg "N" readMaxJobs setMaxJobs) (h "run at most N parallelizable tests simultaneously (default: number of available processors)") - ] - where - readFormatter :: String -> Maybe Formatter - readFormatter = (`lookup` formatters) - - readMaxJobs :: String -> Maybe Int - readMaxJobs s = do - n <- readMaybe s - guard $ n > 0 - return n - - setFormatter :: Formatter -> Config -> Config - setFormatter f c = c {configFormatter = Just f} - - setOutputFile :: String -> Config -> Config - setOutputFile file c = c {configOutputFile = Right file} - - setFailureReport :: String -> Config -> Config - setFailureReport file c = c {configFailureReport = Just file} - - setMaxJobs :: Int -> Config -> Config - setMaxJobs n c = c {configConcurrentJobs = Just n} - - setPrintCpuTime = set $ \config -> config {configPrintCpuTime = True} - setDryRun = set $ \config -> config {configDryRun = True} - setFastFail = set $ \config -> config {configFastFail = True} - setRerun = set $ \config -> config {configRerun = True} - setRerunAllOnSuccess = set $ \config -> config {configRerunAllOnSuccess = True} - setColor = set $ \config -> config {configColorMode = ColorAlways} - setNoColor = set $ \config -> config {configColorMode = ColorNever} - setDiff = set $ \config -> config {configDiff = True} - setNoDiff = set $ \config -> config {configDiff = False} - -set :: Monad m => (Config -> Config) -> Either a (m Config) -> Either a (m Config) -set = liftM . liftM - -documentedOptions :: [OptDescr (Result Maybe -> Result Maybe)] -documentedOptions = commandLineOptions ++ configFileOptions - -undocumentedOptions :: [OptDescr (Result Maybe -> Result Maybe)] -undocumentedOptions = [ - -- for compatibility with test-framework - mkOption [] "maximum-generated-tests" (Arg "NUMBER" readMaybe setMaxSuccess) "how many automated tests something like QuickCheck should try, by default" - - -- 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" - - -- now a noop - , Option "v" ["verbose"] (NoArg id) "do not suppress output to stdout when evaluating examples" - ] - where - setHtml :: Result Maybe -> Result Maybe - setHtml = set $ \config -> config {configHtmlOutput = True} - -recognizedOptions :: [OptDescr (Result Maybe -> Result Maybe)] -recognizedOptions = documentedOptions ++ undocumentedOptions - -parseOptions :: Config -> String -> [ConfigFile] -> Maybe EnvVar -> [String] -> Either (ExitCode, String) Config -parseOptions config prog configFiles envVar args = do - foldM (parseFileOptions prog) config configFiles - >>= parseEnvVarOptions prog envVar - >>= parseCommandLineOptions prog args - -parseCommandLineOptions :: String -> [String] -> Config -> Either (ExitCode, String) Config -parseCommandLineOptions prog args config = case parse recognizedOptions config args of - Right Nothing -> Left (ExitSuccess, usageInfo ("Usage: " ++ prog ++ " [OPTION]...\n\nOPTIONS") documentedOptions) - Right (Just c) -> Right c - Left err -> failure err - where - failure err = Left (ExitFailure 1, prog ++ ": " ++ err ++ "\nTry `" ++ prog ++ " --help' for more information.\n") - -parseFileOptions :: String -> Config -> ConfigFile -> Either (ExitCode, String) Config -parseFileOptions prog config (name, args) = - parseOtherOptions prog ("in config file " ++ name) args config - -parseEnvVarOptions :: String -> (Maybe EnvVar) -> Config -> Either (ExitCode, String) Config -parseEnvVarOptions prog args = - parseOtherOptions prog ("from environment variable " ++ envVarName) (fromMaybe [] args) - -parseOtherOptions :: String -> String -> [String] -> Config -> Either (ExitCode, String) Config -parseOtherOptions prog source args config = case parse configFileOptions config args of - Right (Identity c) -> Right c - Left err -> failure err - where - failure err = Left (ExitFailure 1, prog ++ ": " ++ message) - where - message = unlines $ case lines err of - [x] -> [x ++ " " ++ source] - xs -> xs ++ [source] - -parse :: Monad m => [OptDescr (Result m -> Result m)] -> Config -> [String] -> Either String (m Config) -parse options config args = case getOpt Permute options args of - (opts, [], []) -> case foldl' (flip id) (Right $ return config) opts of - Left (InvalidArgument name value) -> Left ("invalid argument `" ++ value ++ "' for `--" ++ name ++ "'") - Right x -> Right x - (_, _, err:_) -> Left (init err) - (_, arg:_, _) -> Left ("unexpected argument `" ++ arg ++ "'") - -ignoreConfigFile :: Config -> [String] -> IO Bool -ignoreConfigFile config args = do - ignore <- lookupEnv "IGNORE_DOT_HSPEC" - case ignore of - Just _ -> return True - Nothing -> case parse recognizedOptions config args of - Right (Just c) -> return (configIgnoreConfigFile c) - _ -> return False 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 @@ -1,32 +1,32 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} module Test.Hspec.Core.QuickCheckUtil where import Prelude () import Test.Hspec.Core.Compat +import Control.Exception +import Data.List +import Data.Maybe import Data.Int -import Test.QuickCheck hiding (Result(..)) -import Test.QuickCheck as QC +import System.Random +import Test.QuickCheck +import Test.QuickCheck.Text (isOneLine) +import qualified Test.QuickCheck.Property as QCP import Test.QuickCheck.Property hiding (Result(..)) import Test.QuickCheck.Gen -import qualified Test.QuickCheck.Property as QCP import Test.QuickCheck.IO () - - -#if MIN_VERSION_QuickCheck(2,7,0) import Test.QuickCheck.Random -#endif -import System.Random - import Test.Hspec.Core.Util +import Test.QuickCheck.Test (formatLabel) + +formatLabels :: Int -> [(String, Double)] -> String +formatLabels n = unlines . map (formatLabel n True) + aroundProperty :: ((a -> IO ()) -> IO ()) -> (a -> Property) -> Property -#if MIN_VERSION_QuickCheck(2,7,0) aroundProperty action p = MkProperty . MkGen $ \r n -> aroundProp action $ \a -> (unGen . unProperty $ p a) r n -#else -aroundProperty action p = MkGen $ \r n -> aroundProp action $ \a -> (unGen $ p a) r n -#endif aroundProp :: ((a -> IO ()) -> IO ()) -> (a -> Prop) -> Prop aroundProp action p = MkProp $ aroundRose action (\a -> unProp $ p a) @@ -37,25 +37,100 @@ action $ \a -> reduceRose (r a) >>= writeIORef ref readIORef ref -formatNumbers :: Result -> String -formatNumbers r = "(after " ++ pluralize (numTests r) "test" ++ shrinks ++ ")" - where - shrinks - | 0 < numShrinks r = " and " ++ pluralize (numShrinks r) "shrink" - | otherwise = "" - newSeed :: IO Int newSeed = fst . randomR (0, fromIntegral (maxBound :: Int32)) <$> -#if MIN_VERSION_QuickCheck(2,7,0) newQCGen -#else - newStdGen -#endif -#if MIN_VERSION_QuickCheck(2,7,0) mkGen :: Int -> QCGen mkGen = mkQCGen + +formatNumbers :: Int -> Int -> String +formatNumbers n shrinks = "(after " ++ pluralize n "test" ++ shrinks_ ++ ")" + where + shrinks_ + | shrinks > 0 = " and " ++ pluralize shrinks "shrink" + | otherwise = "" + +data QuickCheckResult = QuickCheckResult { + quickCheckResultNumTests :: Int +, quickCheckResultInfo :: String +, quickCheckResultStatus :: Status +} deriving Show + +data Status = + QuickCheckSuccess + | QuickCheckFailure QuickCheckFailure + | QuickCheckOtherFailure String + deriving Show + +data QuickCheckFailure = QCFailure { + quickCheckFailureNumShrinks :: Int +, quickCheckFailureException :: Maybe SomeException +, quickCheckFailureReason :: String +, quickCheckFailureCounterexample :: [String] +} deriving Show + +parseQuickCheckResult :: Result -> QuickCheckResult +parseQuickCheckResult r = case r of + Success {..} -> result output QuickCheckSuccess + + Failure {..} -> + case stripSuffix outputWithoutVerbose output of + Just xs -> result verboseOutput (QuickCheckFailure $ QCFailure numShrinks theException reason failingTestCase) + where + verboseOutput + | xs == "*** Failed! " = "" + | otherwise = maybeStripSuffix "*** Failed!" (strip xs) + Nothing -> couldNotParse output + where + outputWithoutVerbose = reasonAndNumbers ++ unlines failingTestCase + reasonAndNumbers + | isOneLine reason = reason ++ " " ++ numbers ++ colonNewline + | otherwise = numbers ++ colonNewline ++ ensureTrailingNewline reason + numbers = formatNumbers numTests numShrinks +#if MIN_VERSION_QuickCheck(2,11,0) + colonNewline = ":\n" #else -mkGen :: Int -> StdGen -mkGen = mkStdGen + colonNewline = ": \n" #endif + + GaveUp {..} -> + case stripSuffix outputWithoutVerbose output of + Just info -> otherFailure info ("Gave up after " ++ pluralize numTests "test" ++ "!") + Nothing -> couldNotParse output + where + outputWithoutVerbose = "*** Gave up! Passed only " ++ pluralize numTests "test" ++ ".\n" + + NoExpectedFailure {..} -> case splitBy "*** Failed! " output of + Just (info, err) -> otherFailure info err + Nothing -> couldNotParse output + + InsufficientCoverage {..} -> case splitBy ("*** " ++ pre) output of + Just (info, err) -> otherFailure info (pre ++ err) + Nothing -> couldNotParse output + where + pre = "Insufficient coverage after " + + where + result = QuickCheckResult (numTests r) . strip + otherFailure info err = result info (QuickCheckOtherFailure $ strip err) + couldNotParse = result "" . QuickCheckOtherFailure + +ensureTrailingNewline :: String -> String +ensureTrailingNewline = unlines . lines + +maybeStripPrefix :: String -> String -> String +maybeStripPrefix prefix m = fromMaybe m (stripPrefix prefix m) + +maybeStripSuffix :: String -> String -> String +maybeStripSuffix suffix = reverse . maybeStripPrefix (reverse suffix) . reverse + +stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] +stripSuffix suffix = fmap reverse . stripPrefix (reverse suffix) . reverse + +splitBy :: String -> String -> Maybe (String, String) +splitBy sep xs = listToMaybe [ + (x, y) | (x, Just y) <- zip (inits xs) (map stripSep $ tails xs) + ] + where + stripSep = stripPrefix sep 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,10 +1,5 @@ {-# LANGUAGE CPP #-} -#if MIN_VERSION_base(4,6,0) --- Control.Concurrent.QSem is deprecated in base-4.6.0.* -{-# OPTIONS_GHC -fno-warn-deprecations #-} -#endif - -- | -- Stability: provisional module Test.Hspec.Core.Runner ( @@ -36,18 +31,15 @@ import System.Environment (getProgName, getArgs, withArgs) import System.Exit import qualified Control.Exception as E -import Control.Concurrent import System.Console.ANSI (hHideCursor, hShowCursor) import qualified Test.QuickCheck as QC -import Control.Monad.IO.Class (liftIO) 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 qualified Test.Hspec.Core.Formatters.Internal as Formatter import Test.Hspec.Core.FailureReport import Test.Hspec.Core.QuickCheckUtil @@ -83,7 +75,7 @@ | otherwise = id where markSuccess :: Item () -> Item () - markSuccess item = item {itemExample = safeEvaluateExample Success} + markSuccess item = item {itemExample = safeEvaluateExample (Result "" Success)} removeCleanup :: SpecTree () -> SpecTree () removeCleanup spec = case spec of @@ -160,25 +152,43 @@ seed = (fromJust . configQuickCheckSeed) config qcArgs = configQuickCheckArgs config - jobsSem <- newQSem =<< case configConcurrentJobs config of + concurrentJobs <- case configConcurrentJobs config of Nothing -> getDefaultConcurrentJobs - Just maxJobs -> return maxJobs + Just n -> return n useColor <- doesUseColor h config - filteredSpec <- filterSpecs config . applyDryRun config <$> runSpecM spec + let params = Params (configQuickCheckArgs config) (configSmallCheckDepth config) - withHiddenCursor useColor h $ - runFormatM useColor (configDiff config) (configHtmlOutput config) (configPrintCpuTime config) seed h $ do - runFormatter jobsSem useColor h config formatter filteredSpec `finally_` do - Formatter.interpret $ failedFormatter formatter + filteredSpec <- map (toEvalTree params) . filterSpecs config . applyDryRun config <$> runSpecM spec - Formatter.interpret $ footerFormatter formatter + (total, failures) <- 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 - xs <- map failureRecordPath <$> Formatter.interpret getFailMessages - liftIO $ dumpFailureReport config seed qcArgs xs + dumpFailureReport config seed qcArgs failures + return (Summary total (length failures)) - Summary <$> Formatter.interpret getTotalCount <*> Formatter.interpret getFailCount +toEvalTree :: Params -> SpecTree () -> EvalTree +toEvalTree params = go + where + go t = case t of + Node s xs -> Node s (map go xs) + NodeWithCleanup c xs -> NodeWithCleanup (c ()) (map go xs) + Leaf (Item requirement loc isParallelizable e) -> Leaf (EvalItem requirement loc (fromMaybe False isParallelizable) (e params $ ($ ()))) dumpFailureReport :: Config -> Integer -> QC.Args -> [Path] -> IO () dumpFailureReport config seed qcArgs xs = do 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 @@ -1,157 +1,269 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ConstraintKinds #-} -#if MIN_VERSION_base(4,6,0) +#if MIN_VERSION_base(4,6,0) && !MIN_VERSION_base(4,7,0) -- Control.Concurrent.QSem is deprecated in base-4.6.0.* {-# OPTIONS_GHC -fno-warn-deprecations #-} #endif -module Test.Hspec.Core.Runner.Eval (runFormatter) where +module Test.Hspec.Core.Runner.Eval ( + EvalConfig(..) +, EvalTree +, EvalItem(..) +, runFormatter +#ifdef TEST +, runSequentially +#endif +) where import Prelude () -import Test.Hspec.Core.Compat +import Test.Hspec.Core.Compat hiding (Monad) +import qualified Test.Hspec.Core.Compat as M import Control.Monad (unless, when) import qualified Control.Exception as E import Control.Concurrent -import System.IO (Handle) +import Control.Concurrent.Async hiding (cancel) import Control.Monad.IO.Class (liftIO) -import Data.Time.Clock.POSIX +import qualified Control.Monad.IO.Class as M +import Control.Monad.Trans.State hiding (State, state) +import Control.Monad.Trans.Class + import Test.Hspec.Core.Util -import Test.Hspec.Core.Spec -import Test.Hspec.Core.Config -import Test.Hspec.Core.Formatters hiding (FormatM) -import Test.Hspec.Core.Formatters.Internal -import qualified Test.Hspec.Core.Formatters.Internal as Formatter +import Test.Hspec.Core.Spec (Tree(..), 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 -type EvalTree = Tree (ActionWith ()) (String, Maybe Location, ProgressCallback -> FormatResult -> IO (FormatM ())) +-- 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) +data EvalConfig m = EvalConfig { + evalConfigFormat :: Format m +, evalConfigConcurrentJobs :: Int +, evalConfigFastFail :: Bool +} + +data State m = State { + stateConfig :: EvalConfig m +, stateSuccessCount :: Int +, statePendingCount :: Int +, stateFailures :: [Path] +} + +type EvalM m = StateT (State m) m + +increaseSuccessCount :: Monad m => EvalM m () +increaseSuccessCount = modify $ \state -> state {stateSuccessCount = stateSuccessCount state + 1} + +increasePendingCount :: Monad m => EvalM m () +increasePendingCount = modify $ \state -> state {statePendingCount = statePendingCount state + 1} + +addFailure :: Monad m => Path -> EvalM m () +addFailure path = modify $ \state -> state {stateFailures = path : stateFailures state} + +getFormat :: Monad m => (Format m -> a) -> EvalM m a +getFormat format = gets (format . evalConfigFormat . stateConfig) + +reportItem :: Monad m => Path -> Format.Item -> EvalM m () +reportItem path item = do + case Format.itemResult item of + Format.Success {} -> increaseSuccessCount + Format.Pending {} -> increasePendingCount + Format.Failure {} -> addFailure path + format <- getFormat formatItem + 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) + +reportResult :: Monad m => Path -> Maybe Location -> (Seconds, Result) -> EvalM m () +reportResult path loc (duration, result) = do + case result of + Result info status -> case status of + Success -> reportItem path (Format.Item loc duration info Format.Success) + Pending loc_ reason -> reportItem path (Format.Item (loc_ <|> loc) duration info $ Format.Pending reason) + Failure loc_ err@(Error _ e) -> reportItem path (failureItem (loc_ <|> extractLocation e <|> loc) duration info err) + Failure loc_ err -> reportItem path (failureItem (loc_ <|> loc) duration info err) + +groupStarted :: Monad m => Path -> EvalM m () +groupStarted path = do + format <- getFormat formatGroupStarted + lift $ format path + +groupDone :: Monad m => Path -> EvalM m () +groupDone path = do + format <- getFormat formatGroupDone + lift $ format path + +data EvalItem = EvalItem { + evalItemDescription :: String +, evalItemLocation :: Maybe Location +, evalItemParallelize :: Bool +, evalItemAction :: ProgressCallback -> IO Result +} + +type EvalTree = Tree (IO ()) EvalItem + +runEvalM :: Monad m => EvalConfig m -> EvalM m () -> m (State m) +runEvalM config action = execStateT action (State config 0 0 []) + -- | Evaluate all examples of a given spec and produce a report. -runFormatter :: QSem -> Bool -> Handle -> Config -> Formatter -> [SpecTree ()] -> FormatM () -runFormatter jobsSem useColor h c formatter specs = do - Formatter.interpret $ headerFormatter formatter - chan <- liftIO newChan - reportProgress <- liftIO mkReportProgress - run chan reportProgress c formatter (toEvalTree specs) +runFormatter :: forall m. MonadIO m => EvalConfig m -> [EvalTree] -> IO (Int, [Path]) +runFormatter config specs = do + 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 + let + failures = stateFailures state + total = stateSuccessCount state + statePendingCount state + length failures + return (total, reverse failures) where - mkReportProgress :: IO (Path -> Progress -> IO ()) - mkReportProgress - | useColor = every 0.05 $ exampleProgress formatter h - | otherwise = return $ \_ _ -> return () + format = evalConfigFormat config - toEvalTree :: [SpecTree ()] -> [EvalTree] - toEvalTree = map (fmap f) - where - f :: Item () -> (String, Maybe Location, ProgressCallback -> FormatResult -> IO (FormatM ())) - f (Item requirement loc isParallelizable e) = (requirement, loc, parallelize jobsSem isParallelizable $ e params ($ ())) + reportProgress :: IO Bool -> Path -> Progress -> m () + reportProgress timer path progress = do + r <- liftIO timer + when r (formatProgress format path progress) - params :: Params - params = Params (configQuickCheckArgs c) (configSmallCheckDepth c) +cancelMany :: [Async a] -> IO () +cancelMany asyncs = do + mapM_ (killThread . asyncThreadId) asyncs + mapM_ waitCatch asyncs --- | Execute given action at most every specified number of seconds. -every :: POSIXTime -> (a -> b -> IO ()) -> IO (a -> b -> IO ()) -every seconds action = do - timer <- newTimer seconds - return $ \a b -> do - r <- timer - when r (action a b) +data Item a = Item { + _itemDescription :: String +, _itemLocation :: Maybe Location +, _itemAction :: a +} deriving Functor -type FormatResult = Either E.SomeException Result -> FormatM () +type Job m p a = (p -> m ()) -> m a -parallelize :: QSem -> Bool -> (ProgressCallback -> IO (Either E.SomeException Result)) -> ProgressCallback -> FormatResult -> IO (FormatM ()) -parallelize jobsSem isParallelizable e - | isParallelizable = runParallel jobsSem e - | otherwise = runSequentially e +type RunningItem m = Item (Path -> m (Seconds, Result)) +type RunningTree m = Tree (IO ()) (RunningItem m) -runSequentially :: (ProgressCallback -> IO (Either E.SomeException Result)) -> ProgressCallback -> FormatResult -> IO (FormatM ()) -runSequentially e reportProgress formatResult = return $ do - result <- liftIO $ e reportProgress - formatResult result +type RunningItem_ m = (Async (), Item (Job m Progress (Seconds, Result))) +type RunningTree_ m = Tree (IO ()) (RunningItem_ m) -data Report = ReportProgress Progress | ReportResult (Either E.SomeException Result) +data Semaphore = Semaphore { + semaphoreWait :: IO () +, semaphoreSignal :: IO () +} -runParallel :: QSem -> (ProgressCallback -> IO (Either E.SomeException Result)) -> ProgressCallback -> FormatResult -> IO (FormatM ()) -runParallel jobsSem e reportProgress formatResult = do +parallelizeTree :: MonadIO m => Int -> [EvalTree] -> IO [RunningTree_ m] +parallelizeTree n specs = do + sem <- newQSem n + mapM (traverse $ parallelizeItem sem) specs + +parallelizeItem :: MonadIO m => QSem -> EvalItem -> IO (RunningItem_ m) +parallelizeItem sem EvalItem{..} = do + (asyncAction, evalAction) <- parallelize (Semaphore (waitQSem sem) (signalQSem sem)) evalItemParallelize (interruptible . evalItemAction) + return (asyncAction, Item evalItemDescription evalItemLocation evalAction) + +parallelize :: MonadIO m => Semaphore -> Bool -> Job IO p a -> IO (Async (), Job m p (Seconds, a)) +parallelize sem isParallelizable + | isParallelizable = runParallel sem + | otherwise = runSequentially + +runSequentially :: MonadIO m => Job IO p a -> IO (Async (), Job m p (Seconds, a)) +runSequentially action = do mvar <- newEmptyMVar - _ <- forkIO $ E.bracket_ (waitQSem jobsSem) (signalQSem jobsSem) $ do - let progressCallback = replaceMVar mvar . ReportProgress - result <- e progressCallback - replaceMVar mvar (ReportResult result) - return $ evalReport mvar + (asyncAction, evalAction) <- runParallel (Semaphore (takeMVar mvar) (return ())) action + return (asyncAction, \ notifyPartial -> liftIO (putMVar mvar ()) >> evalAction notifyPartial) + +data Parallel p a = Partial p | Return a + +runParallel :: forall m p a. MonadIO m => Semaphore -> Job IO p a -> IO (Async (), Job m p (Seconds, a)) +runParallel Semaphore{..} action = do + mvar <- newEmptyMVar + asyncAction <- async $ E.bracket_ semaphoreWait semaphoreSignal (worker mvar) + return (asyncAction, eval mvar) where - evalReport :: MVar Report -> FormatM () - evalReport mvar = do + worker mvar = do + let partialCallback = replaceMVar mvar . Partial + result <- measure $ action partialCallback + replaceMVar mvar (Return result) + + eval :: MVar (Parallel p (Seconds, a)) -> (p -> m ()) -> m (Seconds, a) + eval mvar notifyPartial = do r <- liftIO (takeMVar mvar) case r of - ReportProgress p -> do - liftIO $ reportProgress p - evalReport mvar - ReportResult result -> formatResult result - - replaceMVar :: MVar a -> a -> IO () - replaceMVar mvar p = tryTakeMVar mvar >> putMVar mvar p + Partial p -> do + notifyPartial p + eval mvar notifyPartial + Return result -> return result -data Message = Done | Run (FormatM ()) +replaceMVar :: MVar a -> a -> IO () +replaceMVar mvar p = tryTakeMVar mvar >> putMVar mvar p -run :: Chan Message -> (Path -> ProgressCallback) -> Config -> Formatter -> [EvalTree] -> FormatM () -run chan reportProgress_ c formatter specs = do - liftIO $ do - forM_ specs (queueSpec []) - writeChan chan Done - processMessages (readChan chan) (configFastFail c) +run :: forall m. MonadIO m => [RunningTree m] -> EvalM m () +run specs = do + fastFail <- gets (evalConfigFastFail . stateConfig) + sequenceActions fastFail (concatMap foldSpec specs) where - defer :: FormatM () -> IO () - defer = writeChan chan . Run - - runCleanup :: IO () -> Path -> FormatM () - runCleanup action path = do - r <- liftIO $ safeTry action - either (failed Nothing path . Left) return r + foldSpec :: RunningTree m -> [EvalM m ()] + foldSpec = foldTree FoldTree { + onGroupStarted = groupStarted + , onGroupDone = groupDone + , onCleanup = runCleanup + , onLeafe = evalItem + } - queueSpec :: [String] -> EvalTree -> IO () - queueSpec rGroups (Node group xs) = do - defer (Formatter.interpret $ exampleGroupStarted formatter (reverse rGroups) group) - forM_ xs (queueSpec (group : rGroups)) - defer (Formatter.interpret $ exampleGroupDone formatter) - queueSpec rGroups (NodeWithCleanup action xs) = do - forM_ xs (queueSpec rGroups) - defer (runCleanup (action ()) (reverse rGroups, "afterAll-hook")) - queueSpec rGroups (Leaf e) = - queueExample (reverse rGroups) e + runCleanup :: [String] -> IO () -> EvalM m () + runCleanup groups action = do + (dt, r) <- liftIO $ measure $ safeTry action + either (\ e -> reportItem path . failureItem (extractLocation e) dt "" . Error Nothing $ e) return r + where + path = (groups, "afterAll-hook") - queueExample :: [String] -> (String, Maybe Location, ProgressCallback -> FormatResult -> IO (FormatM ())) -> IO () - queueExample groups (requirement, loc, e) = e reportProgress formatResult >>= defer + evalItem :: [String] -> RunningItem m -> EvalM m () + evalItem groups (Item requirement loc action) = do + lift (action path) >>= reportResult path loc where path :: Path path = (groups, requirement) - reportProgress = reportProgress_ path - - formatResult :: FormatResult - formatResult result = do - case result of - Right Success -> do - increaseSuccessCount - Formatter.interpret $ exampleSucceeded formatter path - Right (Pending reason) -> do - increasePendingCount - Formatter.interpret $ examplePending formatter path reason - Right (Failure loc_ err) -> failed (loc_ <|> loc) path (Right err) - Left err -> failed loc path (Left err) +data FoldTree c a r = FoldTree { + onGroupStarted :: Path -> r +, onGroupDone :: Path -> r +, onCleanup :: [String] -> c -> r +, onLeafe :: [String] -> a -> r +} - failed loc path err = do - increaseFailCount - addFailMessage loc path err - Formatter.interpret $ exampleFailed formatter path err +foldTree :: FoldTree c a r -> Tree c a -> [r] +foldTree FoldTree{..} = go [] + where + go rGroups (Node group xs) = start : children ++ [done] + where + path = (reverse rGroups, group) + start = onGroupStarted path + children = concatMap (go (group : rGroups)) xs + done = onGroupDone path + go rGroups (NodeWithCleanup action xs) = children ++ [cleanup] + where + children = concatMap (go rGroups) xs + cleanup = onCleanup (reverse rGroups) action + go rGroups (Leaf a) = [onLeafe (reverse rGroups) a] -processMessages :: IO Message -> Bool -> FormatM () -processMessages getMessage fastFail = go +sequenceActions :: Monad m => Bool -> [EvalM m ()] -> EvalM m () +sequenceActions fastFail = go where - go = liftIO getMessage >>= \m -> case m of - Run action -> do - action - fails <- Formatter.interpret getFailCount - unless (fastFail && fails /= 0) go - Done -> return () + go [] = return () + go (action : actions) = do + () <- action + hasFailures <- (not . null) <$> gets stateFailures + let stopNow = fastFail && hasFailures + unless stopNow (go actions) diff --git a/src/Test/Hspec/Core/Spec.hs b/src/Test/Hspec/Core/Spec.hs --- a/src/Test/Hspec/Core/Spec.hs +++ b/src/Test/Hspec/Core/Spec.hs @@ -19,6 +19,7 @@ , xdescribe , xcontext , parallel +, sequential -- * The @SpecM@ monad , module Test.Hspec.Core.Spec.Monad @@ -30,6 +31,9 @@ , module Test.Hspec.Core.Tree ) where +import Prelude () +import Test.Hspec.Core.Compat + import qualified Control.Exception as E import Data.CallStack @@ -53,7 +57,7 @@ -- -- This can be used to temporarily disable spec items. xdescribe :: String -> SpecWith a -> SpecWith a -xdescribe label spec = before_ pending $ describe label spec +xdescribe label spec = before_ pending_ $ describe label spec -- | @xcontext@ is an alias for `xdescribe`. xcontext :: String -> SpecWith a -> SpecWith a @@ -82,7 +86,7 @@ -- -- This can be used to temporarily disable a spec item. xit :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) -xit label action = before_ pending $ it label action +xit label action = before_ pending_ $ it label action -- | @xspecify@ is an alias for `xit`. xspecify :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) @@ -91,8 +95,15 @@ -- | `parallel` marks all spec items of the given spec to be safe for parallel -- evaluation. parallel :: SpecWith a -> SpecWith a -parallel = mapSpecItem_ $ \item -> item {itemIsParallelizable = True} +parallel = mapSpecItem_ (setParallelizable True) +-- | `sequential` marks all spec items of the given spec to be evaluated sequentially. +sequential :: SpecWith a -> SpecWith a +sequential = mapSpecItem_ (setParallelizable False) + +setParallelizable :: Bool -> Item a -> Item a +setParallelizable value item = item {itemIsParallelizable = itemIsParallelizable item <|> Just value} + -- | `pending` can be used to mark a spec item as pending. -- -- If you want to textually specify a behavior but do not have an example yet, @@ -101,11 +112,14 @@ -- > describe "fancyFormatter" $ do -- > it "can format text in a way that everyone likes" $ -- > pending -pending :: Expectation -pending = E.throwIO (Pending Nothing) +pending :: HasCallStack => Expectation +pending = E.throwIO (Pending location Nothing) +pending_ :: Expectation +pending_ = (E.throwIO (Pending Nothing Nothing)) + -- | -- `pendingWith` is similar to `pending`, but it takes an additional string -- argument that can be used to specify the reason for why the spec item is pending. -pendingWith :: String -> Expectation -pendingWith = E.throwIO . Pending . Just +pendingWith :: HasCallStack => String -> Expectation +pendingWith = E.throwIO . Pending location . Just diff --git a/src/Test/Hspec/Core/Timer.hs b/src/Test/Hspec/Core/Timer.hs --- a/src/Test/Hspec/Core/Timer.hs +++ b/src/Test/Hspec/Core/Timer.hs @@ -1,14 +1,20 @@ -module Test.Hspec.Core.Timer where +module Test.Hspec.Core.Timer (withTimer) where -import Data.IORef -import Data.Time.Clock.POSIX +import Control.Exception +import Control.Monad +import Control.Concurrent.Async -newTimer :: POSIXTime -> IO (IO Bool) -newTimer delay = do - ref <- getPOSIXTime >>= newIORef - return $ do - t0 <- readIORef ref - t1 <- getPOSIXTime - if delay < t1 - t0 - then writeIORef ref t1 >> return True - else return False +import Test.Hspec.Core.Clock +import Test.Hspec.Core.Compat + +withTimer :: Seconds -> (IO Bool -> IO a) -> IO a +withTimer delay action = do + ref <- newIORef False + bracket (async $ worker delay ref) cancel $ \_ -> do + action $ atomicModifyIORef ref (\a -> (False, a)) + +worker :: Seconds -> IORef Bool -> IO () +worker delay ref = do + forever $ do + sleep delay + atomicWriteIORef ref True 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 @@ -12,14 +12,14 @@ , Item (..) , specGroup , specItem +, location ) where -import Data.CallStack -import Control.Exception - import Prelude () import Test.Hspec.Core.Compat +import Data.CallStack + import Test.Hspec.Core.Example -- | Internal tree data structure @@ -50,9 +50,9 @@ , itemLocation :: Maybe Location -- | A flag that indicates whether it is safe to evaluate this spec item in -- parallel with other spec items -, itemIsParallelizable :: Bool +, itemIsParallelizable :: Maybe Bool -- | Example for behavior -, itemExample :: Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO (Either SomeException Result) +, itemExample :: Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result } -- | The @specGroup@ function combines a list of specs into a larger spec. @@ -65,13 +65,13 @@ -- | The @specItem@ function creates a spec item. specItem :: (HasCallStack, Example a) => String -> a -> SpecTree (Arg a) -specItem s e = Leaf $ Item requirement location False (safeEvaluateExample e) +specItem s e = Leaf $ Item requirement location Nothing (safeEvaluateExample e) where requirement | null s = "(unspecified behavior)" | otherwise = s - location :: Maybe Location - location = case reverse callStack of - (_, loc) : _ -> Just (Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc) ExactLocation) - _ -> Nothing +location :: HasCallStack => Maybe Location +location = case reverse callStack of + (_, loc) : _ -> Just (Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc)) + _ -> Nothing 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 @@ -100,8 +100,8 @@ -- For `IOException`s the `IOErrorType` is included, as well. formatException :: SomeException -> String formatException err@(SomeException e) = case fromException err of - Just ioe -> showType ioe ++ " of type " ++ showIOErrorType ioe ++ " (" ++ show ioe ++ ")" - Nothing -> showType e ++ " (" ++ show e ++ ")" + Just ioe -> showType ioe ++ " of type " ++ showIOErrorType ioe ++ "\n" ++ show ioe + Nothing -> showType e ++ "\n" ++ show e where showIOErrorType :: IOException -> String showIOErrorType ioe = case ioe_type ioe of @@ -129,13 +129,4 @@ -- occurs, the exception is returned instead. Unlike `try` it is agnostic to -- asynchronous exceptions. safeTry :: IO a -> IO (Either SomeException a) -safeTry action = bracket runAction cancelAction waitForAction - where - runAction = async ((action >>= evaluate)) - waitForAction = waitCatch - cancelAction a = do - cancel a - -- It is important to wait here to make sure all finalizers in action have - -- been run. Otherwise the main thread can exit before they have finished - -- and the finalizers are only partially run. - waitCatch a -- We use waitCatch to hide the ThreadKilled exception +safeTry action = withAsync (action >>= evaluate) waitCatch diff --git a/test/All.hs b/test/All.hs --- a/test/All.hs +++ b/test/All.hs @@ -1,1 +1,1 @@ -{-# OPTIONS_GHC -F -pgmF hspec-meta-discover -optF --module-name=All #-} +{-# 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 @@ -1,3 +1,6 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Helper ( module Test.Hspec.Meta , module Test.Hspec.Core.Compat @@ -30,11 +33,9 @@ import Control.Monad (guard) import System.Environment (withArgs, getEnvironment) import System.Exit -import Control.Concurrent import qualified Control.Exception as E -import Control.Exception (bracket) +import Control.Exception import qualified System.Timeout as System -import Data.Time.Clock.POSIX import System.IO.Silently import System.SetEnv import System.Directory @@ -46,7 +47,26 @@ import qualified Test.Hspec.Core.Spec as H import qualified Test.Hspec.Core.Runner as H import Test.Hspec.Core.QuickCheckUtil (mkGen) +import Test.Hspec.Core.Clock +import Test.Hspec.Core.Example(Result(..), ResultStatus(..), FailureReason(..)) +#if !MIN_VERSION_base(4,7,0) +deriving instance Eq ErrorCall +#endif + +exceptionEq :: E.SomeException -> E.SomeException -> Bool +exceptionEq a b + | Just ea <- E.fromException a, Just eb <- E.fromException b = ea == (eb :: E.ErrorCall) + | Just ea <- E.fromException a, Just eb <- E.fromException b = ea == (eb :: E.ArithException) + | otherwise = undefined + +deriving instance Eq FailureReason +deriving instance Eq ResultStatus +deriving instance Eq Result + +instance Eq SomeException where + (==) = exceptionEq + throwException :: IO () throwException = E.throwIO (E.ErrorCall "foobar") @@ -74,11 +94,8 @@ noOpProgressCallback :: H.ProgressCallback noOpProgressCallback _ = return () -sleep :: POSIXTime -> IO () -sleep = threadDelay . floor . (* 1000000) - -timeout :: POSIXTime -> IO a -> IO (Maybe a) -timeout = System.timeout . floor . (* 1000000) +timeout :: Seconds -> IO a -> IO (Maybe a) +timeout = System.timeout . toMicroseconds shouldUseArgs :: [String] -> (Args -> Bool) -> Expectation shouldUseArgs args p = do diff --git a/test/Test/Hspec/Core/ClockSpec.hs b/test/Test/Hspec/Core/ClockSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/ClockSpec.hs @@ -0,0 +1,11 @@ +module Test.Hspec.Core.ClockSpec (spec) where + +import Helper + +import Test.Hspec.Core.Clock + +spec :: Spec +spec = do + 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,5 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} -module Test.Hspec.Core.CompatSpec (main, spec) where +module Test.Hspec.Core.CompatSpec (spec) where import Helper import System.SetEnv @@ -7,9 +7,6 @@ data SomeType = SomeType deriving Typeable - -main :: IO () -main = hspec spec spec :: Spec spec = do diff --git a/test/Test/Hspec/Core/Config/OptionsSpec.hs b/test/Test/Hspec/Core/Config/OptionsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/Config/OptionsSpec.hs @@ -0,0 +1,127 @@ +module Test.Hspec.Core.Config.OptionsSpec (spec) where + +import Prelude () +import Helper + +import Control.Monad +import System.Exit + +import qualified Test.Hspec.Core.Config.Options as Options +import Test.Hspec.Core.Config.Options hiding (parseOptions) + +fromLeft :: Either a b -> a +fromLeft (Left a) = a +fromLeft _ = error "fromLeft: No left value!" + +spec :: Spec +spec = do + describe "parseOptions" $ do + + let parseOptions = Options.parseOptions defaultConfig "my-spec" + + it "rejects unexpected arguments" $ do + fromLeft (parseOptions [] Nothing ["foo"]) `shouldBe` (ExitFailure 1, "my-spec: unexpected argument `foo'\nTry `my-spec --help' for more information.\n") + + it "rejects unrecognized options" $ do + fromLeft (parseOptions [] Nothing ["--foo"]) `shouldBe` (ExitFailure 1, "my-spec: unrecognized option `--foo'\nTry `my-spec --help' for more information.\n") + + it "sets configColorMode to ColorAuto" $ do + configColorMode <$> parseOptions [] Nothing [] `shouldBe` Right ColorAuto + + context "with --help" $ do + let Left (code, output) = parseOptions [] Nothing ["--help"] + help = lines output + + it "returns ExitSuccess" $ do + code `shouldBe` ExitSuccess + + 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 --diff" $ do + it "sets configDiff to True" $ do + configDiff <$> parseOptions [] Nothing ["--diff"] `shouldBe` Right True + + context "with --no-diff" $ do + 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 --qc-max-success" $ do + 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 --depth" $ do + it "sets depth parameter for SmallCheck" $ do + configSmallCheckDepth <$> parseOptions [] Nothing ["--depth", "23"] `shouldBe` Right 23 + + context "with --jobs" $ do + it "sets number of concurrent jobs" $ do + configConcurrentJobs <$> parseOptions [] Nothing ["--jobs=23"] `shouldBe` Right (Just 23) + + it "rejects values < 1" $ do + let msg = "my-spec: invalid argument `0' for `--jobs'\nTry `my-spec --help' for more information.\n" + void (parseOptions [] Nothing ["--jobs=0"]) `shouldBe` Left (ExitFailure 1, msg) + + context "when given a config file" $ do + it "uses options from config file" $ do + configColorMode <$> parseOptions [("~/.hspec", ["--no-color"])] Nothing [] `shouldBe` Right ColorNever + + it "gives command-line options precedence" $ do + configColorMode <$> parseOptions [("~/.hspec", ["--no-color"])] Nothing ["--color"] `shouldBe` Right ColorAlways + + it "rejects --help" $ do + fromLeft (parseOptions [("~/.hspec", ["--help"])] Nothing []) `shouldBe` (ExitFailure 1, "my-spec: unrecognized option `--help' in config file ~/.hspec\n") + + it "rejects unrecognized options" $ do + fromLeft (parseOptions [("~/.hspec", ["--invalid"])] Nothing []) `shouldBe` (ExitFailure 1, "my-spec: unrecognized option `--invalid' in config file ~/.hspec\n") + + it "rejects ambiguous options" $ do + fromLeft (parseOptions [("~/.hspec", ["--fail"])] Nothing []) `shouldBe` (ExitFailure 1, + unlines [ + "my-spec: option `--fail' is ambiguous; could be one of:" + , " --fail-fast abort on first failure" + , " --failure-report=FILE read/write a failure report for use with --rerun" + , "in config file ~/.hspec" + ] + ) + + context "when given multiple config files" $ do + it "gives later config files precedence" $ do + configColorMode <$> parseOptions [("~/.hspec", ["--no-color"]), (".hspec", ["--color"])] Nothing [] `shouldBe` Right ColorAlways + + context "when given an environment variable" $ do + it "uses options from environment variable" $ do + configColorMode <$> parseOptions [] (Just ["--no-color"]) [] `shouldBe` Right ColorNever + + it "gives command-line options precedence" $ do + configColorMode <$> parseOptions [] (Just ["--no-color"]) ["--color"] `shouldBe` Right ColorAlways + + it "rejects unrecognized options" $ do + fromLeft (parseOptions [] (Just ["--invalid"]) []) `shouldBe` (ExitFailure 1, "my-spec: unrecognized option `--invalid' from environment variable HSPEC_OPTIONS\n") + + describe "ignoreConfigFile" $ around_ (withEnvironment []) $ do + context "by default" $ do + it "returns False" $ do + ignoreConfigFile defaultConfig [] `shouldReturn` False + + context "with --ignore-dot-hspec" $ do + it "returns True" $ do + ignoreConfigFile defaultConfig ["--ignore-dot-hspec"] `shouldReturn` True + + context "with IGNORE_DOT_HSPEC" $ do + it "returns True" $ do + withEnvironment [("IGNORE_DOT_HSPEC", "yes")] $ do + ignoreConfigFile defaultConfig [] `shouldReturn` True diff --git a/test/Test/Hspec/Core/Config/UtilSpec.hs b/test/Test/Hspec/Core/Config/UtilSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/Config/UtilSpec.hs @@ -0,0 +1,34 @@ +module Test.Hspec.Core.Config.UtilSpec (spec) where + +import Helper + +import System.Console.GetOpt + +import Test.Hspec.Core.Config.Util + +spec :: Spec +spec = do + describe "mkUsageInfo" $ do + it "restricts output size to 80 characters" $ do + let options = [ + Option "" ["color"] (NoArg ()) (unwords $ replicate 3 "some very long and verbose help text") + ] + mkUsageInfo "" options `shouldBe` unlines [ + "" + , " --color some very long and verbose help text some very long and verbose" + , " help text some very long and verbose help text" + ] + + it "condenses help for --no-options" $ do + let options = [ + Option "" ["color"] (NoArg ()) "some help" + , Option "" ["no-color"] (NoArg ()) "some other help" + ] + mkUsageInfo "" options `shouldBe` unlines [ + "" + , " --[no-]color some help" + ] + + describe "formatOrList" $ do + it "formats a list of or-options" $ do + formatOrList ["foo", "bar", "baz"] `shouldBe` "foo, bar or baz" diff --git a/test/Test/Hspec/Core/Example/LocationSpec.hs b/test/Test/Hspec/Core/Example/LocationSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/Example/LocationSpec.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +module Test.Hspec.Core.Example.LocationSpec (spec) where + +import Helper +import Control.Exception + +import Test.Hspec.Core.Example +import Test.Hspec.Core.Example.Location + +spec :: Spec +spec = do + describe "extractLocation" $ do + context "with pattern match failure in do expression" $ do + context "in IO" $ do + it "extracts Location" $ do + let location = Just $ Location __FILE__ (__LINE__ + 2) 13 + Left e <- try $ do + Just n <- return Nothing + return (n :: Int) + extractLocation e `shouldBe` location + + context "in Either" $ do + it "extracts Location" $ do + let location = Just $ Location __FILE__ (__LINE__ + 4) 15 + let + foo :: Either () () + foo = do + 23 <- Right (42 :: Int) + return () + Left e <- try (evaluate foo) + extractLocation e `shouldBe` location + + context "with ErrorCall" $ do + it "extracts Location" $ do + let + location = +#if MIN_VERSION_base(4,9,0) + Just $ Location __FILE__ (__LINE__ + 4) 34 +#else + Nothing +#endif + Left e <- try (evaluate (undefined :: ())) + extractLocation e `shouldBe` location + + context "with PatternMatchFail" $ do + context "with single-line source space" $ do + it "extracts Location" $ do + let + location = Just $ Location __FILE__ (__LINE__ + 1) 40 + Left e <- try (evaluate (let Just n = Nothing in (n :: Int))) + extractLocation e `shouldBe` location + + context "with multi-line source space" $ do + it "extracts Location" $ do + let location = Just $ Location __FILE__ (__LINE__ + 1) 36 + Left e <- try (evaluate (case Nothing of + Just n -> n :: Int + )) + extractLocation e `shouldBe` location + + describe "parseCallStack" $ do + it "parses Location from call stack" $ do + let input = unlines [ + "CallStack (from HasCallStack):" + , " error, called at libraries/base/GHC/Err.hs:79:14 in base:GHC.Err" + , " undefined, called at test/Test/Hspec.hs:13:32 in main:Test.Hspec" + ] + parseCallStack input `shouldBe` Just (Location "test/Test/Hspec.hs" 13 32) + + describe "parseLocation" $ do + it "parses Location" $ do + parseLocation "test/Test/Hspec.hs:13:32" `shouldBe` Just (Location "test/Test/Hspec.hs" 13 32) + + describe "parseSourceSpan" $ do + it "parses single-line source span" $ do + parseSourceSpan "test/Test/Hspec.hs:25:36-51:" `shouldBe` Just (Location "test/Test/Hspec.hs" 25 36) + + it "parses multi-line source span" $ do + parseSourceSpan "test/Test/Hspec.hs:(15,7)-(17,26):" `shouldBe` Just (Location "test/Test/Hspec.hs" 15 7) 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 @@ -1,28 +1,32 @@ -{-# LANGUAGE CPP, ScopedTypeVariables, TypeFamilies #-} -module Test.Hspec.Core.ExampleSpec (main, spec) where +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Test.Hspec.Core.ExampleSpec (spec) where import Helper import Mock -import Data.List -import qualified Control.Exception as E +import Control.Exception +import Test.HUnit (assertFailure, assertEqual) +import Test.Hspec.Core.Example (Result(..), ResultStatus(..) +#if MIN_VERSION_base(4,8,1) + , Location(..) +#endif + , FailureReason(..)) import qualified Test.Hspec.Core.Example as H import qualified Test.Hspec.Core.Spec as H import qualified Test.Hspec.Core.Runner as H -main :: IO () -main = hspec spec - -safeEvaluateExample :: (H.Example e, H.Arg e ~ ()) => e -> IO (Either E.SomeException H.Result) +safeEvaluateExample :: (H.Example e, H.Arg e ~ ()) => e -> IO Result safeEvaluateExample e = H.safeEvaluateExample e defaultParams ($ ()) noOpProgressCallback -evaluateExample :: (H.Example e, H.Arg e ~ ()) => e -> IO H.Result +evaluateExample :: (H.Example e, H.Arg e ~ ()) => e -> IO Result evaluateExample e = H.evaluateExample e defaultParams ($ ()) noOpProgressCallback -evaluateExampleWith :: (H.Example e, H.Arg e ~ ()) => (IO () -> IO ()) -> e -> IO H.Result +evaluateExampleWith :: (H.Example e, H.Arg e ~ ()) => (IO () -> IO ()) -> e -> IO Result evaluateExampleWith action e = H.evaluateExample e defaultParams (action . ($ ())) noOpProgressCallback -evaluateExampleWithArgument :: H.Example e => (ActionWith (H.Arg e) -> IO ()) -> e -> IO H.Result +evaluateExampleWithArgument :: H.Example e => (ActionWith (H.Arg e) -> IO ()) -> e -> IO Result evaluateExampleWithArgument action e = H.evaluateExample e defaultParams action noOpProgressCallback spec :: Spec @@ -30,22 +34,30 @@ describe "safeEvaluateExample" $ do context "for Expectation" $ do it "returns Failure if an expectation does not hold" $ do - Right (H.Failure _ msg) <- safeEvaluateExample (23 `shouldBe` (42 :: Int)) -#if MIN_VERSION_HUnit(1,5,0) - msg `shouldBe` H.ExpectedButGot Nothing "42" "23" -#else - msg `shouldBe` H.Reason "expected: 42\n but got: 23" -#endif + Result "" (Failure _ msg) <- safeEvaluateExample (23 `shouldBe` (42 :: Int)) + msg `shouldBe` ExpectedButGot Nothing "42" "23" context "when used with `pending`" $ do it "returns Pending" $ do - Right result <- safeEvaluateExample (H.pending) - result `shouldBe` H.Pending Nothing + result <- safeEvaluateExample (H.pending) + let location = +#if MIN_VERSION_base(4,8,1) + Just $ Location __FILE__ (__LINE__ - 3) 42 +#else + Nothing +#endif + result `shouldBe` Result "" (Pending location Nothing) context "when used with `pendingWith`" $ do it "includes the optional reason" $ do - Right result <- safeEvaluateExample (H.pendingWith "foo") - result `shouldBe` H.Pending (Just "foo") + result <- safeEvaluateExample (H.pendingWith "foo") + let location = +#if MIN_VERSION_base(4,8,1) + Just $ Location __FILE__ (__LINE__ - 3) 42 +#else + Nothing +#endif + result `shouldBe` Result "" (Pending location $ Just "foo") describe "evaluateExample" $ do context "for Result" $ do @@ -55,7 +67,9 @@ action e = do e modifyIORef ref succ - evaluateExampleWith action (H.Failure Nothing H.NoReason) `shouldReturn` H.Failure Nothing H.NoReason + + result = Result "" (Failure Nothing NoReason) + evaluateExampleWith action result `shouldReturn` result readIORef ref `shouldReturn` 1 it "accepts arguments" $ do @@ -64,15 +78,15 @@ action e = do e 42 modifyIORef ref succ - evaluateExampleWithArgument action (H.Failure Nothing . H.Reason . show) `shouldReturn` H.Failure Nothing (H.Reason "42") + evaluateExampleWithArgument action (Result "" . Failure Nothing . Reason . show) `shouldReturn` Result "" (Failure Nothing $ Reason "42") readIORef ref `shouldReturn` 1 context "for Bool" $ do it "returns Success on True" $ do - evaluateExample True `shouldReturn` H.Success + evaluateExample True `shouldReturn` Result "" Success it "returns Failure on False" $ do - evaluateExample False `shouldReturn` H.Failure Nothing H.NoReason + evaluateExample False `shouldReturn` Result "" (Failure Nothing NoReason) it "propagates exceptions" $ do evaluateExample (error "foobar" :: Bool) `shouldThrow` errorCall "foobar" @@ -83,7 +97,7 @@ action e = do e modifyIORef ref succ - evaluateExampleWith action False `shouldReturn` H.Failure Nothing H.NoReason + evaluateExampleWith action False `shouldReturn` Result "" (Failure Nothing NoReason) readIORef ref `shouldReturn` 1 it "accepts arguments" $ do @@ -92,12 +106,12 @@ action e = do e 42 modifyIORef ref succ - evaluateExampleWithArgument action (== (23 :: Integer)) `shouldReturn` H.Failure Nothing H.NoReason + evaluateExampleWithArgument action (== (23 :: Integer)) `shouldReturn` Result "" (Failure Nothing NoReason) readIORef ref `shouldReturn` 1 context "for Expectation" $ do it "returns Success if all expectations hold" $ do - evaluateExample (23 `shouldBe` (23 :: Int)) `shouldReturn` H.Success + evaluateExample (23 `shouldBe` (23 :: Int)) `shouldReturn` Result "" Success it "propagates exceptions" $ do evaluateExample (error "foobar" :: Expectation) `shouldThrow` errorCall "foobar" @@ -110,27 +124,27 @@ e readIORef ref `shouldReturn` succ n modifyIORef ref succ - evaluateExampleWith action (modifyIORef ref succ) `shouldReturn` H.Success + evaluateExampleWith action (modifyIORef ref succ) `shouldReturn` Result "" Success readIORef ref `shouldReturn` 2 context "for Property" $ do it "returns Success if property holds" $ do - evaluateExample (property $ \n -> n == (n :: Int)) `shouldReturn` H.Success + evaluateExample (property $ \n -> n == (n :: Int)) `shouldReturn` Result "+++ OK, passed 1000 tests." Success + it "shows the collected labels" $ do + Result info Success <- evaluateExample $ property $ \ () -> label "unit" True + info `shouldBe` "+++ OK, passed 1000 tests (100.0% unit)." + it "returns Failure if property does not hold" $ do - H.Failure _ _ <- evaluateExample $ property $ \n -> n /= (n :: Int) + Result "" (Failure _ _) <- evaluateExample $ property $ \n -> n /= (n :: Int) return () it "shows what falsified it" $ do - H.Failure _ r <- evaluateExample $ property $ \ (x :: Int) (y :: Int) -> (x == 0 && y == 1) ==> False - r `shouldBe` (H.Reason . intercalate "\n") [ -#if MIN_VERSION_QuickCheck(2,11,0) + Result "" (Failure _ r) <- evaluateExample $ property $ \ (x :: Int) (y :: Int) -> (x == 0 && y == 1) ==> False + r `shouldBe` (Reason . intercalate "\n") [ "Falsifiable (after 1 test):" -#else - "Falsifiable (after 1 test): " -#endif - , "0" - , "1" + , " 0" + , " 1" ] it "runs around-action for each single check of the property" $ do @@ -141,38 +155,60 @@ e readIORef ref `shouldReturn` succ n modifyIORef ref succ - H.Success <- evaluateExampleWith action (property $ \(_ :: Int) -> modifyIORef ref succ) + Result _ Success <- evaluateExampleWith action (property $ \(_ :: Int) -> modifyIORef ref succ) readIORef ref `shouldReturn` 2000 it "pretty-prints exceptions" $ do - H.Failure _ r <- evaluateExample $ property (\ (x :: Int) -> (x == 0) ==> (E.throw (E.ErrorCall "foobar") :: Bool)) - r `shouldBe` (H.Reason . intercalate "\n") [ -#if MIN_VERSION_QuickCheck(2,7,0) - "uncaught exception: ErrorCall (foobar) (after 1 test)" -#else - "Exception: 'foobar' (after 1 test): " -#endif - , "0" + Result "" (Failure _ r) <- evaluateExample $ property (\ (x :: Int) -> (x == 0) ==> (throw (ErrorCall "foobar") :: Bool)) + r `shouldBe` (Reason . intercalate "\n") [ + "uncaught exception: ErrorCall" + , "foobar" + , "(after 1 test)" + , " 0" ] - context "when used with shouldBe" $ do - it "shows what falsified it" $ do - H.Failure _ (H.Reason r) <- evaluateExample $ property $ \ (x :: Int) (y :: Int) -> (x == 0 && y == 1) ==> 23 `shouldBe` (42 :: Int) - r `shouldStartWith` "Falsifiable (after 1 test):" - r `shouldEndWith` intercalate "\n" [ - "expected: 42" - , " but got: 23" - , "0" - , "1" - ] + context "when used with Expectation" $ do + let prop p = property $ \ (x :: Int) (y :: Int) -> (x == 0 && y == 1) ==> p + context "when used with shouldBe" $ do + it "shows what falsified it" $ do + Result "" (Failure _ err) <- evaluateExample $ prop $ 23 `shouldBe` (42 :: Int) + err `shouldBe` ExpectedButGot (Just "Falsifiable (after 1 test):\n 0\n 1") "42" "23" + context "when used with assertEqual" $ do + it "includes prefix" $ do + Result "" (Failure _ err) <- evaluateExample $ prop $ assertEqual "foobar" (42 :: Int) 23 + err `shouldBe` ExpectedButGot (Just "Falsifiable (after 1 test):\n 0\n 1\nfoobar") "42" "23" + + context "when used with assertFailure" $ do + it "includes reason" $ do + Result "" (Failure _ err) <- evaluateExample $ prop (assertFailure "foobar" :: IO ()) + err `shouldBe` Reason "Falsifiable (after 1 test):\n 0\n 1\nfoobar" + + context "when used with verbose" $ do + it "includes verbose output" $ do + Result info (Failure _ err) <- evaluateExample $ verbose $ (`shouldBe` (23 :: Int)) + info `shouldBe` "Failed:\n0" + err `shouldBe` ExpectedButGot (Just "Falsifiable (after 1 test):\n 0") "23" "0" + context "when used with `pending`" $ do it "returns Pending" $ do - evaluateExample (property H.pending) `shouldReturn` H.Pending Nothing + let location = +#if MIN_VERSION_base(4,8,1) + Just $ Location __FILE__ (__LINE__ + 4) 37 +#else + Nothing +#endif + evaluateExample (property H.pending) `shouldReturn` Result "" (Pending location Nothing) context "when used with `pendingWith`" $ do it "includes the optional reason" $ do - evaluateExample (property $ H.pendingWith "foo") `shouldReturn` H.Pending (Just "foo") + let location = +#if MIN_VERSION_base(4,8,1) + Just $ Location __FILE__ (__LINE__ + 4) 39 +#else + Nothing +#endif + evaluateExample (property $ H.pendingWith "foo") `shouldReturn` Result "" (Pending location $ Just "foo") describe "Expectation" $ do context "as a QuickCheck property" $ do 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,4 +1,4 @@ -module Test.Hspec.Core.FailureReportSpec (main, spec) where +module Test.Hspec.Core.FailureReportSpec (spec) where import Helper @@ -6,9 +6,6 @@ import qualified Control.Exception as E import Test.Hspec.Core.FailureReport import Test.Hspec.Core.Config - -main :: IO () -main = hspec spec spec :: Spec spec = do diff --git a/test/Test/Hspec/Core/FormattersSpec.hs b/test/Test/Hspec/Core/FormattersSpec.hs --- a/test/Test/Hspec/Core/FormattersSpec.hs +++ b/test/Test/Hspec/Core/FormattersSpec.hs @@ -15,6 +15,7 @@ data ColorizedText = Plain String + | Transient String | Info String | Succeeded String | Failed String @@ -29,6 +30,7 @@ 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 @@ -60,12 +62,12 @@ environment = Environment { environmentGetSuccessCount = return 0 , environmentGetPendingCount = return 0 -, environmentGetFailCount = return 0 , environmentGetFailMessages = return [] , environmentUsedSeed = return 0 , environmentGetCPUTime = return Nothing , environmentGetRealTime = return 0 , environmentWrite = tell . return . Plain +, environmentWriteTransient = tell . return . Transient , environmentWithFailColor = \action -> let (a, r) = runWriter action in tell (colorize Failed r) >> return a , environmentWithSuccessColor = \action -> let (a, r) = runWriter action in tell (colorize Succeeded r) >> return a , environmentWithPendingColor = \action -> let (a, r) = runWriter action in tell (colorize Pending r) >> return a @@ -78,12 +80,12 @@ testSpec :: H.Spec testSpec = do H.describe "Example" $ do - H.it "success" (H.Success) - H.it "fail 1" (H.Failure Nothing $ H.Reason "fail message") + 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.Failure Nothing H.NoReason) + H.it "fail 2" (H.Result "" $ H.Failure Nothing H.NoReason) H.it "exceptions" (undefined :: H.Result) - H.it "fail 3" (H.Failure Nothing H.NoReason) + H.it "fail 3" (H.Result "" $ H.Failure Nothing H.NoReason) spec :: Spec spec = do @@ -92,19 +94,19 @@ describe "exampleSucceeded" $ do it "marks succeeding examples with ." $ do - interpret (H.exampleSucceeded formatter undefined) `shouldBe` [ + interpret (H.exampleSucceeded formatter undefined undefined) `shouldBe` [ Succeeded "." ] describe "exampleFailed" $ do it "marks failing examples with F" $ do - interpret (H.exampleFailed formatter undefined undefined) `shouldBe` [ + interpret (H.exampleFailed formatter undefined undefined undefined) `shouldBe` [ Failed "F" ] describe "examplePending" $ do it "marks pending examples with ." $ do - interpret (H.examplePending formatter undefined undefined) `shouldBe` [ + interpret (H.examplePending formatter undefined undefined undefined) `shouldBe` [ Pending "." ] @@ -170,7 +172,7 @@ it "displays a '#' with an additional message for pending examples" $ do r <- runSpec testSpec - r `shouldSatisfy` any (== " # PENDING: pending message") + r `shouldSatisfy` any (== " # PENDING: pending message") context "with an empty group" $ do it "omits that group from the report" $ do @@ -199,7 +201,7 @@ context "when actual/expected contain newlines" $ do let env = environment { - environmentGetFailMessages = return [FailureRecord Nothing ([], "") (Right $ ExpectedButGot Nothing "first\nsecond\nthird" "first\ntwo\nthird")] + environmentGetFailMessages = return [FailureRecord Nothing ([], "") (ExpectedButGot Nothing "first\nsecond\nthird" "first\ntwo\nthird")] } it "adds indentation" $ do removeColors (interpretWith env action) `shouldBe` unlines [ @@ -238,7 +240,7 @@ ] context "with failures" $ do - let env = environment {environmentGetFailCount = return 1} + let env = environment {environmentGetFailMessages = return [undefined]} it "shows summary in red" $ do interpretWith env action `shouldBe` [ "Finished in 0.0000 seconds\n" @@ -246,7 +248,7 @@ ] context "with both failures and pending examples" $ do - let env = environment {environmentGetFailCount = return 1, environmentGetPendingCount = return 1} + let env = environment {environmentGetFailMessages = return [undefined], environmentGetPendingCount = return 1} it "shows summary in red" $ do interpretWith env action `shouldBe` [ "Finished in 0.0000 seconds\n" @@ -270,7 +272,8 @@ H.it "foobar" (E.throw (E.ErrorCall "baz") :: Bool) r `shouldContain` [ " 1) foobar" - , " uncaught exception: ErrorCall (baz)" + , " uncaught exception: ErrorCall" + , " baz" ] it "prints all descriptions when a nested requirement fails" $ do @@ -282,41 +285,9 @@ context "when a failed example has a source location" $ do - let bestEffortExplanation = "Source locations marked with \"best-effort\" are calculated heuristically and may be incorrect." - - it "includes the source locations above the error messages" $ do - let loc = H.Location "test/FooSpec.hs" 23 0 H.ExactLocation + 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: ", " 1) foo"] - - context "when source location is exact" $ do - it "includes that source locations" $ do - let loc = H.Location "test/FooSpec.hs" 23 0 H.ExactLocation - addLoc e = e {H.itemLocation = Just loc} - r <- runSpec $ H.mapSpecItem_ addLoc $ do - H.it "foo" False - r `shouldSatisfy` any (== " test/FooSpec.hs:23: ") - - it "does not include 'best-effort' explanation" $ do - let loc = H.Location "test/FooSpec.hs" 23 0 H.ExactLocation - addLoc e = e {H.itemLocation = Just loc} - r <- runSpec $ H.mapSpecItem_ addLoc $ do - H.it "foo" False - r `shouldSatisfy` all (/= bestEffortExplanation) - - context "when source location is best-effort" $ do - it "marks that source location as 'best-effort'" $ do - let loc = H.Location "test/FooSpec.hs" 23 0 H.BestEffort - addLoc e = e {H.itemLocation = Just loc} - r <- runSpec $ H.mapSpecItem_ addLoc $ do - H.it "foo" False - r `shouldSatisfy` any (== " test/FooSpec.hs:23: (best-effort)") - - it "includes 'best-effort' explanation" $ do - let loc = H.Location "test/FooSpec.hs" 23 0 H.BestEffort - addLoc e = e {H.itemLocation = Just loc} - r <- runSpec $ H.mapSpecItem_ addLoc $ do - H.it "foo" False - r `shouldSatisfy` any (== bestEffortExplanation) + 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 @@ -1,5 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} -module Test.Hspec.Core.HooksSpec (main, spec) where +module Test.Hspec.Core.HooksSpec (spec) where import Control.Exception import Helper @@ -10,9 +10,6 @@ import qualified Test.Hspec.Core.Hooks as H -main :: IO () -main = hspec spec - runSilent :: H.Spec -> IO () runSilent = silence . H.hspec @@ -34,10 +31,6 @@ rec (value ++ " bar") retrieve `shouldReturn` ["before", "value foo", "before", "value bar"] - context "when used multiple times" $ do - it "is evaluated outside in" $ do - pending - context "when used with a QuickCheck property" $ do it "runs action before every check of the property" $ do (rec, retrieve) <- mkAppend @@ -45,10 +38,6 @@ H.it "foo" $ \value -> property $ \(_ :: Int) -> rec value retrieve `shouldReturn` (take 200 . cycle) ["before", "value"] - context "when used multiple times" $ do - it "is evaluated outside in" $ do - pending - describe "before_" $ do it "runs an action before every spec item" $ do (rec, retrieve) <- mkAppend @@ -137,10 +126,6 @@ return () retrieve `shouldReturn` [] - context "when used multiple times" $ do - it "is evaluated outside in" $ do - pending - describe "beforeAll_" $ do it "runs an action before the first spec item" $ do (rec, retrieve) <- mkAppend @@ -195,10 +180,6 @@ rec "foo" retrieve `shouldReturn` ["before", "from before"] - context "when used multiple times" $ do - it "is evaluated inside out" $ do - pending - describe "after_" $ do it "runs an action after every spec item" $ do (rec, retrieve) <- mkAppend @@ -322,10 +303,6 @@ , "bar from around" , "after" ] - - context "when used multiple times" $ do - it "is evaluated outside in" $ do - pending describe "around_" $ do it "wraps every spec item with an action" $ do diff --git a/test/Test/Hspec/Core/OptionsSpec.hs b/test/Test/Hspec/Core/OptionsSpec.hs deleted file mode 100644 --- a/test/Test/Hspec/Core/OptionsSpec.hs +++ /dev/null @@ -1,108 +0,0 @@ -module Test.Hspec.Core.OptionsSpec (spec) where - -import Control.Monad -import Helper -import System.Exit - -import qualified Test.Hspec.Core.Options as Options -import Test.Hspec.Core.Options hiding (parseOptions) - -fromLeft :: Either a b -> a -fromLeft (Left a) = a -fromLeft _ = error "fromLeft: No left value!" - -spec :: Spec -spec = do - describe "parseOptions" $ do - - let parseOptions = Options.parseOptions defaultConfig "my-spec" - - it "rejects unexpected arguments" $ do - fromLeft (parseOptions [] Nothing ["foo"]) `shouldBe` (ExitFailure 1, "my-spec: unexpected argument `foo'\nTry `my-spec --help' for more information.\n") - - it "rejects unrecognized options" $ do - fromLeft (parseOptions [] Nothing ["--foo"]) `shouldBe` (ExitFailure 1, "my-spec: unrecognized option `--foo'\nTry `my-spec --help' for more information.\n") - - it "sets configColorMode to ColorAuto" $ do - configColorMode <$> parseOptions [] Nothing [] `shouldBe` Right ColorAuto - - 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 --out" $ do - it "sets configOutputFile" $ do - either (const Nothing) Just . configOutputFile <$> parseOptions [] Nothing ["--out", "foo"] `shouldBe` Right (Just "foo") - - context "with --qc-max-success" $ do - 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 --depth" $ do - it "sets depth parameter for SmallCheck" $ do - configSmallCheckDepth <$> parseOptions [] Nothing ["--depth", "23"] `shouldBe` Right 23 - - context "with --jobs" $ do - it "sets number of concurrent jobs" $ do - configConcurrentJobs <$> parseOptions [] Nothing ["--jobs=23"] `shouldBe` Right (Just 23) - - it "rejects values < 1" $ do - let msg = "my-spec: invalid argument `0' for `--jobs'\nTry `my-spec --help' for more information.\n" - void (parseOptions [] Nothing ["--jobs=0"]) `shouldBe` Left (ExitFailure 1, msg) - - context "when given a config file" $ do - it "uses options from config file" $ do - configColorMode <$> parseOptions [("~/.hspec", ["--no-color"])] Nothing [] `shouldBe` Right ColorNever - - it "gives command-line options precedence" $ do - configColorMode <$> parseOptions [("~/.hspec", ["--no-color"])] Nothing ["--color"] `shouldBe` Right ColorAlways - - it "rejects --help" $ do - fromLeft (parseOptions [("~/.hspec", ["--help"])] Nothing []) `shouldBe` (ExitFailure 1, "my-spec: unrecognized option `--help' in config file ~/.hspec\n") - - it "rejects unrecognized options" $ do - fromLeft (parseOptions [("~/.hspec", ["--invalid"])] Nothing []) `shouldBe` (ExitFailure 1, "my-spec: unrecognized option `--invalid' in config file ~/.hspec\n") - - it "rejects ambiguous options" $ do - fromLeft (parseOptions [("~/.hspec", ["--qc-max-s"])] Nothing []) `shouldBe` (ExitFailure 1, - unlines [ - "my-spec: option `--qc-max-s' is ambiguous; could be one of:" - , " -a N --qc-max-success=N maximum number of successful tests" - , " before a QuickCheck property succeeds" - , " --qc-max-size=N size to use for the biggest test cases" - , "in config file ~/.hspec" - ] - ) - - context "when given multiple config files" $ do - it "gives later config files precedence" $ do - configColorMode <$> parseOptions [("~/.hspec", ["--no-color"]), (".hspec", ["--color"])] Nothing [] `shouldBe` Right ColorAlways - - context "when given an environment variable" $ do - it "uses options from environment variable" $ do - configColorMode <$> parseOptions [] (Just ["--no-color"]) [] `shouldBe` Right ColorNever - - it "gives command-line options precedence" $ do - configColorMode <$> parseOptions [] (Just ["--no-color"]) ["--color"] `shouldBe` Right ColorAlways - - it "rejects unrecognized options" $ do - fromLeft (parseOptions [] (Just ["--invalid"]) []) `shouldBe` (ExitFailure 1, "my-spec: unrecognized option `--invalid' from environment variable HSPEC_OPTIONS\n") - - describe "ignoreConfigFile" $ around_ (withEnvironment []) $ do - context "by default" $ do - it "returns False" $ do - ignoreConfigFile defaultConfig [] `shouldReturn` False - - context "with --ignore-dot-hspec" $ do - it "returns True" $ do - ignoreConfigFile defaultConfig ["--ignore-dot-hspec"] `shouldReturn` True - - context "with IGNORE_DOT_HSPEC" $ do - it "returns True" $ do - withEnvironment [("IGNORE_DOT_HSPEC", "yes")] $ do - ignoreConfigFile defaultConfig [] `shouldReturn` True 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 @@ -1,31 +1,187 @@ {-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-missing-fields #-} -module Test.Hspec.Core.QuickCheckUtilSpec (main, spec) where +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +module Test.Hspec.Core.QuickCheckUtilSpec (spec) where import Helper -import Test.QuickCheck +import qualified Test.QuickCheck.Property as QCP + import Test.Hspec.Core.QuickCheckUtil -main :: IO () -main = hspec spec +deriving instance Eq QuickCheckResult +deriving instance Eq Status +deriving instance Eq QuickCheckFailure spec :: Spec spec = do describe "formatNumbers" $ do it "includes number of tests" $ do - formatNumbers (failure 1 0) `shouldBe` "(after 1 test)" + formatNumbers 1 0 `shouldBe` "(after 1 test)" it "pluralizes number of tests" $ do - formatNumbers (failure 3 0) `shouldBe` "(after 3 tests)" + formatNumbers 3 0 `shouldBe` "(after 3 tests)" it "includes number of shrinks" $ do - formatNumbers (failure 3 1) `shouldBe` "(after 3 tests and 1 shrink)" + formatNumbers 3 1 `shouldBe` "(after 3 tests and 1 shrink)" it "pluralizes number of shrinks" $ do - formatNumbers (failure 3 3) `shouldBe` "(after 3 tests and 3 shrinks)" - where - failure tests shrinks = Failure { - numTests = tests - , numShrinks = shrinks - } + formatNumbers 3 3 `shouldBe` "(after 3 tests and 3 shrinks)" + + describe "stripSuffix" $ do + it "drops the given suffix from a list" $ do + stripSuffix "bar" "foobar" `shouldBe` Just "foo" + + describe "splitBy" $ do + it "splits a string by a given infix" $ do + splitBy "bar" "foo bar baz" `shouldBe` Just ("foo ", " baz") + + describe "parseQuickCheckResult" $ do + let + args = stdArgs {chatty = False, replay = Just (mkGen 0, 0)} + qc = quickCheckWithResult args + + context "with Success" $ do + let p :: Int -> Bool + p n = n == n + + it "parses result" $ do + parseQuickCheckResult <$> qc p `shouldReturn` + QuickCheckResult 100 "+++ OK, passed 100 tests." QuickCheckSuccess + + it "includes labels" $ do + parseQuickCheckResult <$> qc (label "unit" p) `shouldReturn` + QuickCheckResult 100 "+++ OK, passed 100 tests (100% unit)." QuickCheckSuccess + + context "with GaveUp" $ do + let p :: Int -> Property + p n = (n == 1234) ==> True + + qc = quickCheckWithResult args {maxSuccess = 2, maxDiscardRatio = 1} + result = QuickCheckResult 0 "" (QuickCheckOtherFailure "Gave up after 0 tests!") + + it "parses result" $ do + parseQuickCheckResult <$> qc p `shouldReturn` result + + it "includes verbose output" $ do + let + info = intercalate "\n" [ + "Skipped (precondition false):" + , "0" + , "" + , "Skipped (precondition false):" + , "0" + ] + parseQuickCheckResult <$> qc (verbose p) `shouldReturn` result {quickCheckResultInfo = info} + + context "with NoExpectedFailure" $ do + let + p :: Int -> Property + p _ = expectFailure True + + it "parses result" $ do + parseQuickCheckResult <$> qc p `shouldReturn` + QuickCheckResult 100 "" (QuickCheckOtherFailure "Passed 100 tests (expected failure).") + + it "includes verbose output" $ do + let + info = intercalate "\n" [ + "Passed:" + , "0" + , "" + , "Passed:" + , "-39" + ] + parseQuickCheckResult <$> quickCheckWithResult args {maxSuccess = 2} (verbose p) `shouldReturn` + QuickCheckResult 2 info (QuickCheckOtherFailure "Passed 2 tests (expected failure).") + + context "with InsufficientCoverage" $ do + let + p :: Int -> Property + p n = cover (n == 23) 10 "is 23" True + + it "parses result" $ do + parseQuickCheckResult <$> qc p `shouldReturn` + QuickCheckResult 100 "" (QuickCheckOtherFailure "Insufficient coverage after 100 tests (only 0% is 23, not 10%).") + + it "includes verbose output" $ do + let + info = intercalate "\n" [ + "Passed:" + , "0" + , "" + , "Passed:" + , "-39" + ] + parseQuickCheckResult <$> quickCheckWithResult args {maxSuccess = 2} (verbose p) `shouldReturn` + QuickCheckResult 2 info (QuickCheckOtherFailure "Insufficient coverage after 2 tests (only 0% is 23, not 10%).") + + context "with Failure" $ do + context "with single-line failure reason" $ do + let + p :: Int -> Bool + p = (/= 1) + + err = "Falsifiable" + result = QuickCheckResult 2 "" (QuickCheckFailure $ QCFailure 0 Nothing err ["1"]) + + it "parses result" $ do + parseQuickCheckResult <$> qc p `shouldReturn` result + + it "includes verbose output" $ do + let info = intercalate "\n" [ + "Passed:" + , "0" + , "" + , "Failed:" + , "1" + , "" +#if MIN_VERSION_QuickCheck(2,11,0) + , "Passed:" +#else + , "*** Failed! Passed:" +#endif + , "0" + ] + + parseQuickCheckResult <$> qc (verbose p) `shouldReturn` result {quickCheckResultInfo = info} + + context "with multi-line failure reason" $ do + let + p :: Int -> QCP.Result + p n = if n /= 1 then QCP.succeeded else QCP.failed {QCP.reason = err} + + err = "foo\nbar" + result = QuickCheckResult 2 "" (QuickCheckFailure $ QCFailure 0 Nothing err ["1"]) + + it "parses result" $ do + parseQuickCheckResult <$> qc p `shouldReturn` result + + it "includes verbose output" $ do + let info = intercalate "\n" [ + "Passed:" + , "0" + , "" + , "Failed:" + , "1" + , "" +#if MIN_VERSION_QuickCheck(2,11,0) + , "Passed:" +#else + , "*** Failed! Passed:" +#endif + , "0" + ] + parseQuickCheckResult <$> qc (verbose p) `shouldReturn` result {quickCheckResultInfo = info} + + context "with HUnit assertion" $ do + let p :: Int -> Int -> Expectation + p m n = do + m `shouldBe` n + + it "includes counterexample" $ do + result <- qc p + let QuickCheckResult _ _ (QuickCheckFailure r) = parseQuickCheckResult result + quickCheckFailureCounterexample r `shouldBe` ["0", "1"] diff --git a/test/Test/Hspec/Core/Runner/EvalSpec.hs b/test/Test/Hspec/Core/Runner/EvalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Hspec/Core/Runner/EvalSpec.hs @@ -0,0 +1,29 @@ +module Test.Hspec.Core.Runner.EvalSpec (spec) where + +import Prelude () +import Helper + +import Test.Hspec.Core.Tree +import Test.Hspec.Core.Runner.Eval + +spec :: Spec +spec = do + describe "traverse" $ do + context "when used with Tree" $ do + let + tree :: Tree () Int + tree = Node "" [Node "" [Leaf 1, Node "" [Leaf 2, Leaf 3]], Leaf 4] + it "walks the tree left-to-right, depth-first" $ do + ref <- newIORef [] + traverse_ (modifyIORef ref . (:) ) tree + reverse <$> readIORef ref `shouldReturn` [1 .. 4] + + describe "runSequentially" $ do + it "runs actions sequentially" $ do + ref <- newIORef [] + (_, actionA) <- runSequentially $ \ _ -> modifyIORef ref (23 :) + (_, actionB) <- runSequentially $ \ _ -> modifyIORef ref (42 :) + (_, ()) <- actionB (\_ -> return ()) + readIORef ref `shouldReturn` [42 :: Int] + (_, ()) <- actionA (\_ -> return ()) + readIORef ref `shouldReturn` [23, 42] 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 @@ -1,7 +1,14 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} -module Test.Hspec.Core.RunnerSpec (main, spec) where +{-# LANGUAGE TypeFamilies #-} +#if MIN_VERSION_base(4,6,0) && !MIN_VERSION_base(4,7,0) +-- Control.Concurrent.QSem is deprecated in base-4.6.0.* +{-# OPTIONS_GHC -fno-warn-deprecations #-} +#endif + +module Test.Hspec.Core.RunnerSpec (spec) where + import Prelude () import Helper @@ -11,11 +18,10 @@ import System.Exit import Control.Concurrent import qualified Control.Exception as E +import Control.Concurrent.Async import Mock import System.SetEnv -#if MIN_VERSION_HUnit(1,5,0) import System.Console.ANSI -#endif import Test.Hspec.Core.FailureReport (FailureReport(..)) import qualified Test.Hspec.Core.Spec as H @@ -26,9 +32,6 @@ import qualified Test.QuickCheck as QC import qualified Test.Hspec.Core.Hooks as H -main :: IO () -main = hspec spec - quickCheckOptions :: [([Char], Args -> Int)] quickCheckOptions = [("--qc-max-success", QC.maxSuccess), ("--qc-max-size", QC.maxSize), ("--qc-max-discard", QC.maxDiscardRatio)] @@ -41,6 +44,24 @@ spec :: Spec spec = do describe "hspec" $ do + it "evaluates examples Unmasked" $ do + mvar <- newEmptyMVar + withArgs ["--format", "silent"] . H.hspec $ do + H.it "foo" $ do + E.getMaskingState >>= putMVar mvar + takeMVar mvar `shouldReturn` E.Unmasked + + it "runs finalizers" $ do + mvar <- newEmptyMVar + ref <- newIORef "did not run finalizer" + a <- async $ withArgs ["--format", "silent"] . H.hspec $ do + H.it "foo" $ do + (putMVar mvar () >> threadDelay 10000000) `E.finally` + writeIORef ref "ran finalizer" + takeMVar mvar + cancel a + readIORef ref `shouldReturn` "ran finalizer" + it "runs a spec" $ do silence . H.hspec $ do H.it "foobar" True @@ -191,18 +212,6 @@ throwTo threadId E.UserInterrupt takeMVar mvar `shouldReturn` E.UserInterrupt - context "with --help" $ do - let printHelp = withProgName "spec" . withArgs ["--help"] . H.hspec $ pure () - it "prints help" $ do - r <- (captureLines . ignoreExitCode) printHelp - r `shouldStartWith` ["Usage: spec [OPTION]..."] - silence printHelp `shouldThrow` (== ExitSuccess) - - it "constrains lines to 80 characters" $ do - r <- (captureLines . ignoreExitCode) printHelp - r `shouldSatisfy` all ((<= 80) . length) - r `shouldSatisfy` any ((78 <=) . length) - context "with --dry-run" $ do let withDryRun = captureLines . withArgs ["--dry-run"] . H.hspec it "produces a report" $ do @@ -253,6 +262,24 @@ , "2 examples, 1 failure" ] + it "cancels running parallel spec items on failure" $ do + child1 <- newQSem 0 + child2 <- newQSem 0 + parent <- newQSem 0 + ref <- newIORef "" + ignoreExitCode . withArgs ["--fail-fast", "--format=silent", "-j", "2"] . H.hspec $ do + H.parallel $ do + H.it "foo" $ do + waitQSem child1 + "foo" `shouldBe` "bar" + H.it "bar" $ do + -- NOTE: waitQSem should never return here, as we want to + -- guarantee that the thread is killed before hspec returns + (signalQSem child1 >> waitQSem child2 >> writeIORef ref "foo") `E.finally` signalQSem parent + signalQSem child2 + waitQSem parent + readIORef ref `shouldReturn` "" + it "works for nested specs" $ do r <- captureLines . ignoreExitCode . withArgs ["--fail-fast", "--seed", "23"] . H.hspec . removeLocations $ do H.describe "foo" $ do @@ -318,7 +345,6 @@ context "with --diff" $ do it "shows colorized diffs" $ do -#if MIN_VERSION_HUnit(1,5,0) r <- capture_ . ignoreExitCode . withArgs ["--diff", "--color"] . H.hspec $ do H.it "foo" $ do 23 `shouldBe` (42 :: Int) @@ -326,13 +352,9 @@ red ++ " expected: " ++ reset ++ red ++ "42" ++ reset , red ++ " but got: " ++ reset ++ green ++ "23" ++ reset ] -#else - pending -#endif context "with --no-diff" $ do it "it does not show colorized diffs" $ do -#if MIN_VERSION_HUnit(1,5,0) r <- capture_ . ignoreExitCode . withArgs ["--no-diff", "--color"] . H.hspec $ do H.it "foo" $ do 23 `shouldBe` (42 :: Int) @@ -340,9 +362,6 @@ red ++ " expected: " ++ reset ++ "42" , red ++ " but got: " ++ reset ++ "23" ] -#else - pending -#endif context "with --format" $ do it "uses specified formatter" $ do @@ -456,11 +475,11 @@ it "does not let escape error thunks from failure messages" $ do r <- silence . H.hspecResult $ do - H.it "some example" (H.Failure Nothing . H.Reason $ "foobar" ++ undefined) + H.it "some example" (H.Result "" $ H.Failure Nothing . H.Reason $ "foobar" ++ undefined) r `shouldBe` H.Summary 1 1 it "runs specs in parallel" $ do - let n = 10 + let n = 100 t = 0.01 dt = t * (fromIntegral n / 2) r <- timeout dt . silence . withArgs ["-j", show n] . H.hspecResult . H.parallel $ do @@ -513,8 +532,6 @@ it "returns False" $ do H.rerunAll config (Just report) summary {H.summaryFailures = 1} `shouldBe` False where -#if MIN_VERSION_HUnit(1,5,0) green = setSGRCode [SetColor Foreground Dull Green] red = setSGRCode [SetColor Foreground Dull Red] reset = setSGRCode [Reset] -#endif diff --git a/test/Test/Hspec/Core/SpecSpec.hs b/test/Test/Hspec/Core/SpecSpec.hs --- a/test/Test/Hspec/Core/SpecSpec.hs +++ b/test/Test/Hspec/Core/SpecSpec.hs @@ -1,18 +1,15 @@ {-# LANGUAGE CPP #-} -module Test.Hspec.Core.SpecSpec (main, spec) where +module Test.Hspec.Core.SpecSpec (spec) where import Prelude () import Helper -import Test.Hspec.Core.Spec (Item(..), Result(..)) +import Test.Hspec.Core.Spec (Item(..), Result(..), ResultStatus(..)) import qualified Test.Hspec.Core.Runner as H import Test.Hspec.Core.Spec (Tree(..), runSpecM) import qualified Test.Hspec.Core.Spec as H -main :: IO () -main = hspec spec - runSpec :: H.Spec -> IO [String] runSpec = captureLines . H.hspecResult @@ -34,8 +31,8 @@ describe "xdescribe" $ do it "creates a tree of pending spec items" $ do [Node _ [Leaf item]] <- runSpecM (H.xdescribe "" $ H.it "whatever" True) - Right r <- itemExample item defaultParams ($ ()) noOpProgressCallback - r `shouldBe` Pending Nothing + r <- itemExample item defaultParams ($ ()) noOpProgressCallback + r `shouldBe` Result "" (Pending Nothing Nothing) describe "it" $ do it "takes a description of a desired behavior" $ do @@ -44,14 +41,14 @@ it "takes an example of that behavior" $ do [Leaf item] <- runSpecM (H.it "whatever" True) - Right r <- itemExample item defaultParams ($ ()) noOpProgressCallback - r `shouldBe` Success + r <- itemExample item defaultParams ($ ()) noOpProgressCallback + r `shouldBe` Result "" Success it "adds source locations" $ do [Leaf item] <- runSpecM (H.it "foo" True) let location = #if MIN_VERSION_base(4,8,1) - Just $ H.Location __FILE__ (__LINE__ - 3) 32 H.ExactLocation + Just $ H.Location __FILE__ (__LINE__ - 3) 32 #else Nothing #endif @@ -65,30 +62,39 @@ describe "xit" $ do it "creates a pending spec item" $ do [Leaf item] <- runSpecM (H.xit "whatever" True) - Right r <- itemExample item defaultParams ($ ()) noOpProgressCallback - r `shouldBe` Pending Nothing + r <- itemExample item defaultParams ($ ()) noOpProgressCallback + r `shouldBe` Result "" (Pending Nothing Nothing) describe "pending" $ do it "specifies a pending example" $ do r <- runSpec $ do H.it "foo" H.pending - r `shouldSatisfy` any (== " # PENDING: No reason given") + r `shouldSatisfy` any (== " # PENDING: No reason given") describe "pendingWith" $ do it "specifies a pending example with a reason for why it's pending" $ do r <- runSpec $ do H.it "foo" $ do H.pendingWith "for some reason" - r `shouldSatisfy` any (== " # PENDING: for some reason") + r `shouldSatisfy` any (== " # PENDING: for some reason") describe "parallel" $ do it "marks examples for parallel execution" $ do - [Leaf item] <- runSpecM . H.parallel $ H.it "whatever" True - itemIsParallelizable item `shouldBe` True + [Leaf item] <- runSpecM . H.parallel $ H.it "whatever" H.pending + itemIsParallelizable item `shouldBe` Just True it "is applied recursively" $ do [Node _ [Node _ [Leaf item]]] <- runSpecM . H.parallel $ do H.describe "foo" $ do H.describe "bar" $ do - H.it "baz" True - itemIsParallelizable item `shouldBe` True + H.it "baz" H.pending + itemIsParallelizable item `shouldBe` Just True + + describe "sequential" $ do + it "marks examples for sequential execution" $ do + [Leaf item] <- runSpecM . H.sequential $ H.it "whatever" H.pending + itemIsParallelizable item `shouldBe` Just False + + it "takes precedence over a later `parallel`" $ do + [Leaf item] <- runSpecM . H.parallel . H.sequential $ H.it "whatever" H.pending + itemIsParallelizable item `shouldBe` Just False 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,29 +1,28 @@ -module Test.Hspec.Core.TimerSpec (main, spec) where +module Test.Hspec.Core.TimerSpec (spec) where import Helper import Test.Hspec.Core.Timer -main :: IO () -main = hspec spec - spec :: Spec spec = do - describe "timer action returned by newTimer" $ do + describe "timer action provided by withTimer" $ do - let dt = 0.01 + let + dt = 0.01 + wait = sleep (dt * 1.1) it "returns False" $ do - timer <- newTimer dt - timer `shouldReturn` False + withTimer dt $ \timer -> do + timer `shouldReturn` False context "after specified time" $ do it "returns True" $ do - timer <- newTimer dt - sleep dt - timer `shouldReturn` True - timer `shouldReturn` False - sleep dt - sleep dt - timer `shouldReturn` True - timer `shouldReturn` False + withTimer dt $ \timer -> do + wait + timer `shouldReturn` True + timer `shouldReturn` False + wait + wait + timer `shouldReturn` True + timer `shouldReturn` False 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,4 +1,4 @@ -module Test.Hspec.Core.UtilSpec (main, spec) where +module Test.Hspec.Core.UtilSpec (spec) where import Helper import Control.Concurrent @@ -6,9 +6,6 @@ import Test.Hspec.Core.Util -main :: IO () -main = hspec spec - spec :: Spec spec = do describe "pluralize" $ do @@ -23,12 +20,16 @@ describe "formatException" $ do it "converts exception to string" $ do - formatException (E.toException E.DivideByZero) `shouldBe` "ArithException (divide by zero)" + formatException (E.toException E.DivideByZero) `shouldBe` "ArithException\ndivide by zero" context "when used with an IOException" $ do it "includes the IOErrorType" $ do - Left e <- E.try (readFile "foo") - formatException e `shouldBe` "IOException of type NoSuchThing (foo: openFile: does not exist (No such file or directory))" + inTempDirectory $ do + Left e <- E.try (readFile "foo") + formatException e `shouldBe` intercalate "\n" [ + "IOException of type NoSuchThing" + , "foo: openFile: does not exist (No such file or directory)" + ] describe "lineBreaksAt" $ do it "inserts line breaks at word boundaries" $ do @@ -79,7 +80,7 @@ let p = filterPredicate "bar/baz" p (["foo", "bar", "baz"], "example 1") `shouldBe` True - it "succeeds with a pattern that matches the message give in the failure list" $ do + it "succeeds with a pattern that matches the message given in the failure list" $ do let p = filterPredicate "ModuleA.ModuleB.foo does something" p (["ModuleA", "ModuleB", "foo"], "does something") `shouldBe` True