hspec-core 2.4.8 → 2.5.0

raw patch · 40 files changed

+1922/−1070 lines, 40 filesdep +clockdep −timedep ~HUnitdep ~QuickCheckPVP ok

version bump matches the API change (PVP)

Dependencies added: clock

Dependencies removed: time

Dependency ranges changed: HUnit, QuickCheck

API changes (from Hackage documentation)

Files

• hspec-core.cabal +23/−11
• src/Test/Hspec/Core/Clock.hs +33/−0
• src/Test/Hspec/Core/Compat.hs +25/−0
• src/Test/Hspec/Core/Config.hs +1/−1
• src/Test/Hspec/Core/Config/Options.hs +312/−0
• src/Test/Hspec/Core/Config/Util.hs +37/−0
• src/Test/Hspec/Core/Example.hs +89/−103
• src/Test/Hspec/Core/Example/Location.hs +88/−0
• src/Test/Hspec/Core/FailureReport.hs +1/−1
• src/Test/Hspec/Core/Format.hs +36/−0
• src/Test/Hspec/Core/Formatters.hs +35/−42
• src/Test/Hspec/Core/Formatters/Internal.hs +119/−61
• src/Test/Hspec/Core/Formatters/Monad.hs +24/−24
• src/Test/Hspec/Core/Hooks.hs +1/−1
• src/Test/Hspec/Core/Options.hs +0/−283
• src/Test/Hspec/Core/QuickCheckUtil.hs +102/−27
• src/Test/Hspec/Core/Runner.hs +30/−20
• src/Test/Hspec/Core/Runner/Eval.hs +224/−112
• src/Test/Hspec/Core/Spec.hs +21/−7
• src/Test/Hspec/Core/Timer.hs +18/−12
• src/Test/Hspec/Core/Tree.hs +10/−10
• src/Test/Hspec/Core/Util.hs +3/−12
• test/All.hs +1/−1
• test/Helper.hs +25/−8
• test/Test/Hspec/Core/ClockSpec.hs +11/−0
• test/Test/Hspec/Core/CompatSpec.hs +1/−4
• test/Test/Hspec/Core/Config/OptionsSpec.hs +127/−0
• test/Test/Hspec/Core/Config/UtilSpec.hs +34/−0
• test/Test/Hspec/Core/Example/LocationSpec.hs +80/−0
• test/Test/Hspec/Core/ExampleSpec.hs +96/−60
• test/Test/Hspec/Core/FailureReportSpec.hs +1/−4
• test/Test/Hspec/Core/FormattersSpec.hs +19/−48
• test/Test/Hspec/Core/HooksSpec.hs +1/−24
• test/Test/Hspec/Core/OptionsSpec.hs +0/−108
• test/Test/Hspec/Core/QuickCheckUtilSpec.hs +170/−14
• test/Test/Hspec/Core/Runner/EvalSpec.hs +29/−0
• test/Test/Hspec/Core/RunnerSpec.hs +47/−30
• test/Test/Hspec/Core/SpecSpec.hs +24/−18
• test/Test/Hspec/Core/TimerSpec.hs +15/−16
• test/Test/Hspec/Core/UtilSpec.hs +9/−8

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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 (== ':')

@@ -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

@@ -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 ()+}

@@ -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

@@ -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 ("<span class=\"" ++ cls ++ "\">") *> action <* write "</span>"  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)

@@ -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.

@@ -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.

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 #-}

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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"

@@ -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)

@@ -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

@@ -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

@@ -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"]

@@ -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

@@ -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

@@ -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"]

@@ -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]

@@ -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

@@ -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

@@ -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

@@ -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