hspec-meta 2.4.6 → 2.5.6

raw patch · 29 files changed

+2295/−857 lines, 29 filesdep +clockdep +stmdep −asyncdep ~QuickCheckPVP ok

version bump matches the API change (PVP)

Dependencies added: clock, stm

Dependencies removed: async

Dependency ranges changed: QuickCheck

API changes (from Hackage documentation)

Files

• CHANGES.markdown +49/−0
• LICENSE +1/−1
• hspec-core/src/Test/Hspec/Core/Clock.hs +33/−0
• hspec-core/src/Test/Hspec/Core/Compat.hs +35/−0
• hspec-core/src/Test/Hspec/Core/Config.hs +2/−3
• hspec-core/src/Test/Hspec/Core/Config/Options.hs +311/−0
• hspec-core/src/Test/Hspec/Core/Config/Util.hs +37/−0
• hspec-core/src/Test/Hspec/Core/Example.hs +91/−101
• hspec-core/src/Test/Hspec/Core/Example/Location.hs +88/−0
• hspec-core/src/Test/Hspec/Core/FailureReport.hs +4/−3
• hspec-core/src/Test/Hspec/Core/Format.hs +36/−0
• hspec-core/src/Test/Hspec/Core/Formatters.hs +46/−40
• hspec-core/src/Test/Hspec/Core/Formatters/Diff.hs +59/−2
• hspec-core/src/Test/Hspec/Core/Formatters/Internal.hs +119/−62
• hspec-core/src/Test/Hspec/Core/Formatters/Monad.hs +24/−24
• hspec-core/src/Test/Hspec/Core/Hooks.hs +1/−1
• hspec-core/src/Test/Hspec/Core/Options.hs +0/−283
• hspec-core/src/Test/Hspec/Core/QuickCheckUtil.hs +117/−30
• hspec-core/src/Test/Hspec/Core/Runner.hs +30/−21
• hspec-core/src/Test/Hspec/Core/Runner/Eval.hs +224/−113
• hspec-core/src/Test/Hspec/Core/Spec.hs +25/−11
• hspec-core/src/Test/Hspec/Core/Spec/Monad.hs +3/−3
• hspec-core/src/Test/Hspec/Core/Timer.hs +19/−12
• hspec-core/src/Test/Hspec/Core/Tree.hs +21/−13
• hspec-core/src/Test/Hspec/Core/Util.hs +12/−14
• hspec-core/vendor/Control/Concurrent/Async.hs +870/−0
• hspec-meta.cabal +37/−31
• src/Test/Hspec/Discover.hs +1/−65
• src/Test/Hspec/HUnit.hs +0/−24

@@ -1,3 +1,52 @@+## Changes in 2.5.5+  - Use `module[line:column]` instead of `module:line:column` as default label+    for `describe`/`it` (fixes #366)++## Changes in 2.5.4+  - Show how to rerun individual spec items on test failures (see #205)++## Changes in 2.5.3+  - Treat character escapes like `\NUL` as single tokens on `--diff` (see #351)+  - Allow a `/` at the beginning and at the end of an absolute path that is+    passed to `--match` or `--skip`++## Changes in 2.5.2+  - Use module:line:column as default label for describe/it (see #250)+  - Warn if user is affected by https://ghc.haskell.org/trac/ghc/ticket/13285 (see #329)++## Changes in 2.5.1+  - Disable tests for Test.Hspec.Core.Timer (see #352)++## Changes in 2.5.0+  - Add `sequential` (see #311)+  - Add support for `--diff` when `shouldBe` is uesd with+    `QuickCheck`-properties+  - Add source locations when `shouldBe` is uesd with `QuickCheck` properties+  - Print `QuickCheck` labels on success (see #297)+  - Retain output of `verbose`, `label`, `collect`, `classify`, etc. for+    `QuickCheck` properties (see #257)+  - Extract source location from error / undefined (see #316)+  - Parse source locations from pattern match failures+  - Include source column when formatting source locations+  - Colorize whitespaces with background color instead of foreground color with+    `--diff`+  - Run `Test.Hspec.Core.Formatters.exampleProgress` in `FormatM` instead of+    `IO`+  - Make sure that progress output is always cleared (fixes #301)+  - Add location information to `pending` (not used by any formatter yet)+  - Include duration for each spec item in new formatter API (see #315) (not yet exposed)+  - Removed deprecated module `Test.Hspec.HUnit`, use+    `Test.Hspec.Contrib.HUnit` instead+  - Deprecate `--out`+  - Remove `BestEffort` source locations++## Changes in 2.4.8+  - compatibility with GHC 8.4.1-alpha3++## Changes in 2.4.7+  - compatibility with `QuickCheck-2.11.3` and up (note that `QuickCheck`+    versions `2.11` to `2.11.2` are not fully supported)+ ## Changes in 2.4.6   - compatibility with the upcoming version `4.11.0.0` of `base` 

@@ -1,4 +1,4 @@-Copyright (c) 2011-2017 Simon Hengel <sol@typeful.net>+Copyright (c) 2011-2018 Simon Hengel <sol@typeful.net> Copyright (c) 2011-2012 Trystan Spangler <trystan.s@comcast.net> Copyright (c) 2011-2011 Greg Weber <greg@gregweber.info> 

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

@@ -9,19 +9,33 @@  , module Prelude , module Control.Applicative+, module Control.Monad , 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           Control.Monad hiding (+    mapM+  , mapM_+  , forM+  , forM_+  , msum+  , sequence+  , sequence_+  ) import           Data.Foldable import           Data.Traversable import           Data.Monoid+import           Data.List (intercalate)  import           Prelude hiding (     all@@ -54,6 +68,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 +84,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 +129,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

@@ -12,9 +12,9 @@ ) where  import           Prelude ()+import           Test.Hspec.Core.Compat  import           Control.Exception-import           Control.Monad import           Data.Maybe import           System.IO import           System.IO.Error@@ -24,8 +24,7 @@ import qualified Test.QuickCheck as QC  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,311 @@+module Test.Hspec.Core.Config.Options (+  Config(..)+, ColorMode (..)+, defaultConfig+, filterOr+, parseOptions+, ConfigFile+, ignoreConfigFile+, envVarName+) where++import           Prelude ()+import           Test.Hspec.Core.Compat++import           System.IO+import           System.Exit+import           System.Console.GetOpt++import           Test.Hspec.Core.Formatters+import           Test.Hspec.Core.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,8 +112,8 @@ instance Example (a -> Result) where   type Arg (a -> Result) = a   evaluateExample example _params action _callback = do-    ref <- newIORef Success-    action (writeIORef ref . example)+    ref <- newIORef (Result "" Success)+    action (evaluate . example >=> writeIORef ref)     readIORef ref  instance Example Bool where@@ -121,44 +123,42 @@ instance Example (a -> Bool) where   type Arg (a -> Bool) = a   evaluateExample p _params action _callback = do-    ref <- newIORef Success-    action $ \a -> example a >>= writeIORef ref+    ref <- newIORef (Result "" Success)+    action (evaluate . example >=> writeIORef ref)     readIORef ref     where       example a-        | p a = return Success-        | otherwise = return (Failure Nothing NoReason)+        | p a = Result "" Success+        | otherwise = 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,51 +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-                x:xs | x == (exceptionPrefix ++ show e ++ "' " ++ numbers ++ ": ") -> unlines xs-                _ -> 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 (== ':')

@@ -5,16 +5,17 @@ , readFailureReport ) where +import           Prelude ()+import           Test.Hspec.Core.Compat+ #ifndef __GHCJS__ import           System.SetEnv import           Test.Hspec.Core.Util (safeTry) #endif-import           Control.Monad import           System.IO 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 ()+}

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} -- | -- Stability: experimental --@@ -32,12 +33,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 +60,8 @@  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)  -- 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,19 @@       formatFailure x       writeLine "" -    when (hasBestEffortLocations failures) $ do-      withInfoColor $ writeLine "Source locations marked with \"best-effort\" are calculated heuristically and may be incorrect."+#if __GLASGOW_HASKELL__ == 800+    withFailColor $ do+      writeLine "WARNING:"+      writeLine "  Your version of GHC is affected by https://ghc.haskell.org/trac/ghc/ticket/13285."+      writeLine "  Source locations may not work as expected."       writeLine ""+      writeLine "  Please consider upgrading GHC!"+      writeLine ""+#endif      write "Randomized with seed " >> usedSeed >>= writeLine . show     writeLine ""   where-    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 +204,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 +228,16 @@             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++      writeLine ""+      writeLine ("  To rerun use: --match " ++ show (joinPath path))       where         indentation = "       "         indent message = do           forM_ (lines message) $ \line -> do             writeLine (indentation ++ line)-        formatLoc (Location file line _column 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,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-} module Test.Hspec.Core.Formatters.Diff (   Diff (..) , diff@@ -8,17 +9,21 @@ #endif ) where +import           Prelude ()+import           Test.Hspec.Core.Compat+ import           Data.Char+import           Data.List (stripPrefix) import           Data.Algorithm.Diff  diff :: String -> String -> [Diff String] diff expected actual = map (fmap concat) $ getGroupedDiff (partition expected) (partition actual)  partition :: String -> [String]-partition = mergeBackslashes . breakList isAlphaNum+partition = filter (not . null) . mergeBackslashes . breakList isAlphaNum   where     mergeBackslashes xs = case xs of-      ['\\'] : (y : ys) : zs -> ['\\', y] : ys : mergeBackslashes zs+      ['\\'] : (splitEscape -> Just (escape, ys)) : zs -> ("\\" ++ escape) : ys : mergeBackslashes zs       z : zs -> z : mergeBackslashes zs       [] -> [] @@ -31,3 +36,55 @@     cons x       | null x = id       | otherwise = (x :)++splitEscape :: String -> Maybe (String, String)+splitEscape xs = splitNumericEscape xs <|> (msum $ map split escapes)+  where+    split :: String -> Maybe (String, String)+    split escape = (,) escape <$> stripPrefix escape xs++splitNumericEscape :: String -> Maybe (String, String)+splitNumericEscape xs = case span isDigit xs of+  ("", _) -> Nothing+  r -> Just r++escapes :: [String]+escapes = [+    "ACK"+  , "CAN"+  , "DC1"+  , "DC2"+  , "DC3"+  , "DC4"+  , "DEL"+  , "DLE"+  , "ENQ"+  , "EOT"+  , "ESC"+  , "ETB"+  , "ETX"+  , "NAK"+  , "NUL"+  , "SOH"+  , "STX"+  , "SUB"+  , "SYN"+  , "EM"+  , "FS"+  , "GS"+  , "RS"+  , "SI"+  , "SO"+  , "US"+  , "a"+  , "b"+  , "f"+  , "n"+  , "r"+  , "t"+  , "v"+  , "&"+  , "'"+  , "\""+  , "\\"+  ]

@@ -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 ()@@ -15,31 +16,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 +83,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 +191,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 +217,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,29 @@-{-# 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 qualified Test.QuickCheck.Test as QC (showTestCount)+import           Test.QuickCheck.State (State(..))  import           Test.Hspec.Core.Util  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 +34,115 @@   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-#else-mkGen :: Int -> StdGen-mkGen = mkStdGen-#endif++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+      colonNewline = ":\n"++  GaveUp {..} ->+    case stripSuffix outputWithoutVerbose output of+      Just info -> otherFailure info ("Gave up after " ++ numbers ++ "!")+      Nothing -> couldNotParse output+    where+      numbers = showTestCount numTests numDiscarded+      outputWithoutVerbose = "*** Gave up! Passed only " ++ numbers ++ " tests.\n"++  NoExpectedFailure {..} -> case splitBy "*** Failed! " output of+    Just (info, err) -> otherFailure info err+    Nothing -> couldNotParse output++  where+    result = QuickCheckResult (numTests r) . strip+    otherFailure info err = result info (QuickCheckOtherFailure $ strip err)+    couldNotParse = result "" . QuickCheckOtherFailure++showTestCount :: Int -> Int -> String+showTestCount success discarded = QC.showTestCount state+  where+    state = MkState {+      terminal                  = undefined+    , maxSuccessTests           = undefined+    , maxDiscardedRatio         = undefined+    , coverageConfidence        = undefined+    , computeSize               = undefined+    , numTotMaxShrinks          = 0+    , numSuccessTests           = success+    , numDiscardedTests         = discarded+    , numRecentlyDiscardedTests = 0+    , labels                    = mempty+    , classes                   = mempty+    , tables                    = mempty+    , requiredCoverage          = mempty+    , expected                  = True+    , randomSeed                = mkGen 0+    , numSuccessShrinks         = 0+    , numTryShrinks             = 0+    , numTotTryShrinks          = 0+    }++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 (@@ -30,24 +25,20 @@ import           Prelude () import           Test.Hspec.Core.Compat -import           Control.Monad import           Data.Maybe import           System.IO 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 +74,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 +151,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,268 @@ {-# 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 @@ -41,22 +45,22 @@ import           Test.Hspec.Core.Spec.Monad  -- | The @describe@ function combines a list of specs into a larger spec.-describe :: String -> SpecWith a -> SpecWith a+describe :: HasCallStack => String -> SpecWith a -> SpecWith a describe label spec = runIO (runSpecM spec) >>= fromSpecList . return . specGroup label  -- | @context@ is an alias for `describe`.-context :: String -> SpecWith a -> SpecWith a+context :: HasCallStack => String -> SpecWith a -> SpecWith a context = describe  -- | -- Changing `describe` to `xdescribe` marks all spec items of the corresponding subtree as pending. -- -- This can be used to temporarily disable spec items.-xdescribe :: String -> SpecWith a -> SpecWith a-xdescribe label spec = before_ pending $ describe label spec+xdescribe :: HasCallStack => String -> SpecWith a -> SpecWith a+xdescribe label spec = before_ pending_ $ describe label spec  -- | @xcontext@ is an alias for `xdescribe`.-xcontext :: String -> SpecWith a -> SpecWith a+xcontext :: HasCallStack => String -> SpecWith a -> SpecWith a xcontext = xdescribe  -- | The @it@ function creates a spec item.@@ -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

@@ -7,7 +7,6 @@ , fromSpecList , runIO -, mapSpecTree , mapSpecItem , mapSpecItem_ , modifyParams@@ -16,6 +15,7 @@ import           Prelude () import           Test.Hspec.Core.Compat +import           Control.Arrow import           Control.Monad.Trans.Writer import           Control.Monad.IO.Class (liftIO) @@ -49,8 +49,8 @@ runIO :: IO r -> SpecM a r runIO = SpecM . liftIO -mapSpecTree :: (SpecTree a -> SpecTree b) -> SpecWith a -> SpecWith b-mapSpecTree f spec = runIO (runSpecM spec) >>= fromSpecList . map f+mapSpecTree :: (SpecTree a -> SpecTree b) -> SpecM a r -> SpecM b r+mapSpecTree f (SpecM specs) = SpecM (mapWriterT (fmap (second (map f))) specs)  mapSpecItem :: (ActionWith a -> ActionWith b) -> (Item a -> Item b) -> SpecWith a -> SpecWith b mapSpecItem g f = mapSpecTree go

@@ -1,14 +1,21 @@-module Test.Hspec.Core.Timer where+module Test.Hspec.Core.Timer (withTimer) where -import           Data.IORef-import           Data.Time.Clock.POSIX+import           Prelude ()+import           Test.Hspec.Core.Compat -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           Control.Exception+import           Control.Concurrent.Async++import           Test.Hspec.Core.Clock++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,15 @@ , Item (..) , specGroup , specItem+, location ) where -import           Data.CallStack-import           Control.Exception- import           Prelude () import           Test.Hspec.Core.Compat +import           Data.CallStack+import           Data.Maybe+ import           Test.Hspec.Core.Example  -- | Internal tree data structure@@ -50,28 +51,35 @@ , 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.-specGroup :: String -> [SpecTree a] -> SpecTree a+specGroup :: HasCallStack => String -> [SpecTree a] -> SpecTree a specGroup s = Node msg   where+    msg :: HasCallStack => String     msg-      | null s = "(no description given)"+      | null s = fromMaybe "(no description given)" defaultDescription       | otherwise = s  -- | 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 :: HasCallStack => String     requirement-      | null s = "(unspecified behavior)"+      | null s = fromMaybe "(unspecified behavior)" defaultDescription       | 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++defaultDescription :: HasCallStack => Maybe String+defaultDescription = case reverse callStack of+  (_, loc) : _ -> Just (srcLocModule loc ++ "[" ++ show (srcLocStartLine loc) ++ ":" ++ show (srcLocStartCol loc) ++ "]")+  _ -> Nothing

@@ -7,6 +7,7 @@  -- * Working with paths , Path+, joinPath , formatRequirement , filterPredicate @@ -68,6 +69,12 @@ type Path = ([String], String)  -- |+-- Join a `Path` with slashes.  The result will have a leading and a trailing+-- slash.+joinPath :: Path -> String+joinPath (groups, requirement) = "/" ++ intercalate "/" (groups ++ [requirement]) ++ "/"++-- | -- Try to create a proper English sentence from a path by applying some -- heuristics. formatRequirement :: Path -> String@@ -83,11 +90,11 @@  -- | A predicate that can be used to filter a spec tree. filterPredicate :: String -> Path -> Bool-filterPredicate pattern path@(groups, requirement) =+filterPredicate pattern path =      pattern `isInfixOf` plain   || pattern `isInfixOf` formatted   where-    plain = intercalate "/" (groups ++ [requirement])+    plain = joinPath path     formatted = formatRequirement path  -- | The function `formatException` converts an exception to a string.@@ -100,8 +107,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 +136,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

@@ -0,0 +1,870 @@+{-# LANGUAGE CPP, MagicHash, UnboxedTuples, RankNTypes,+    ExistentialQuantification #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif+#if __GLASGOW_HASKELL__ < 710+{-# LANGUAGE DeriveDataTypeable #-}+#endif+{-# OPTIONS -Wall #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Concurrent.Async+-- Copyright   :  (c) Simon Marlow 2012+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainer  :  Simon Marlow <marlowsd@gmail.com>+-- Stability   :  provisional+-- Portability :  non-portable (requires concurrency)+--+-- This module provides a set of operations for running IO operations+-- asynchronously and waiting for their results.  It is a thin layer+-- over the basic concurrency operations provided by+-- "Control.Concurrent".  The main additional functionality it+-- provides is the ability to wait for the return value of a thread,+-- but the interface also provides some additional safety and+-- robustness over using threads and @MVar@ directly.+--+-- The basic type is @'Async' a@, which represents an asynchronous+-- @IO@ action that will return a value of type @a@, or die with an+-- exception.  An @Async@ corresponds to a thread, and its 'ThreadId'+-- can be obtained with 'asyncThreadId', although that should rarely+-- be necessary.+--+-- For example, to fetch two web pages at the same time, we could do+-- this (assuming a suitable @getURL@ function):+--+-- >    do a1 <- async (getURL url1)+-- >       a2 <- async (getURL url2)+-- >       page1 <- wait a1+-- >       page2 <- wait a2+-- >       ...+--+-- where 'async' starts the operation in a separate thread, and+-- 'wait' waits for and returns the result.  If the operation+-- throws an exception, then that exception is re-thrown by+-- 'wait'.  This is one of the ways in which this library+-- provides some additional safety: it is harder to accidentally+-- forget about exceptions thrown in child threads.+--+-- A slight improvement over the previous example is this:+--+-- >       withAsync (getURL url1) $ \a1 -> do+-- >       withAsync (getURL url2) $ \a2 -> do+-- >       page1 <- wait a1+-- >       page2 <- wait a2+-- >       ...+--+-- 'withAsync' is like 'async', except that the 'Async' is+-- automatically killed (using 'uninterruptibleCancel') if the+-- enclosing IO operation returns before it has completed.  Consider+-- the case when the first 'wait' throws an exception; then the second+-- 'Async' will be automatically killed rather than being left to run+-- in the background, possibly indefinitely.  This is the second way+-- that the library provides additional safety: using 'withAsync'+-- means we can avoid accidentally leaving threads running.+-- Furthermore, 'withAsync' allows a tree of threads to be built, such+-- that children are automatically killed if their parents die for any+-- reason.+--+-- The pattern of performing two IO actions concurrently and waiting+-- for their results is packaged up in a combinator 'concurrently', so+-- we can further shorten the above example to:+--+-- >       (page1, page2) <- concurrently (getURL url1) (getURL url2)+-- >       ...+--+-- The 'Functor' instance can be used to change the result of an+-- 'Async'.  For example:+--+-- > ghci> a <- async (return 3)+-- > ghci> wait a+-- > 3+-- > ghci> wait (fmap (+1) a)+-- > 4++-----------------------------------------------------------------------------++module Control.Concurrent.Async (++    -- * Asynchronous actions+    Async,+    -- ** Spawning+    async, asyncBound, asyncOn, asyncWithUnmask, asyncOnWithUnmask,++    -- ** Spawning with automatic 'cancel'ation+    withAsync, withAsyncBound, withAsyncOn, withAsyncWithUnmask,+    withAsyncOnWithUnmask,++    -- ** Querying 'Async's+    wait, poll, waitCatch, asyncThreadId,+    cancel, uninterruptibleCancel, cancelWith, AsyncCancelled(..),++    -- ** STM operations+    waitSTM, pollSTM, waitCatchSTM,++    -- ** Waiting for multiple 'Async's+    waitAny, waitAnyCatch, waitAnyCancel, waitAnyCatchCancel,+    waitEither, waitEitherCatch, waitEitherCancel, waitEitherCatchCancel,+    waitEither_,+    waitBoth,++    -- ** Waiting for multiple 'Async's in STM+    waitAnySTM, waitAnyCatchSTM,+    waitEitherSTM, waitEitherCatchSTM,+    waitEitherSTM_,+    waitBothSTM,++    -- ** Linking+    link, link2, ExceptionInLinkedThread(..),++    -- * Convenient utilities+    race, race_,+    concurrently, concurrently_,+    mapConcurrently, forConcurrently,+    mapConcurrently_, forConcurrently_,+    replicateConcurrently, replicateConcurrently_,+    Concurrently(..),+    compareAsyncs,++  ) where++import Control.Concurrent.STM+import Control.Exception+import Control.Concurrent+import qualified Data.Foldable as F+#if !MIN_VERSION_base(4,6,0)+import Prelude hiding (catch)+#endif+import Control.Monad+import Control.Applicative+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (Monoid(mempty,mappend))+import Data.Traversable+#endif+#if __GLASGOW_HASKELL__ < 710+import Data.Typeable+#endif+#if MIN_VERSION_base(4,9,0)+import Data.Semigroup (Semigroup((<>)))+#endif++import Data.IORef++import GHC.Exts+import GHC.IO hiding (finally, onException)+import GHC.Conc++-- -----------------------------------------------------------------------------+-- STM Async API+++-- | An asynchronous action spawned by 'async' or 'withAsync'.+-- Asynchronous actions are executed in a separate thread, and+-- operations are provided for waiting for asynchronous actions to+-- complete and obtaining their results (see e.g. 'wait').+--+data Async a = Async+  { asyncThreadId :: {-# UNPACK #-} !ThreadId+                  -- ^ Returns the 'ThreadId' of the thread running+                  -- the given 'Async'.+  , _asyncWait    :: STM (Either SomeException a)+  }++instance Eq (Async a) where+  Async a _ == Async b _  =  a == b++instance Ord (Async a) where+  Async a _ `compare` Async b _  =  a `compare` b++instance Functor Async where+  fmap f (Async a w) = Async a (fmap (fmap f) w)++-- | Compare two 'Async's that may have different types+compareAsyncs :: Async a -> Async b -> Ordering+compareAsyncs (Async t1 _) (Async t2 _) = compare t1 t2++-- | Spawn an asynchronous action in a separate thread.+async :: IO a -> IO (Async a)+async = inline asyncUsing rawForkIO++-- | Like 'async' but using 'forkOS' internally.+asyncBound :: IO a -> IO (Async a)+asyncBound = asyncUsing forkOS++-- | Like 'async' but using 'forkOn' internally.+asyncOn :: Int -> IO a -> IO (Async a)+asyncOn = asyncUsing . rawForkOn++-- | Like 'async' but using 'forkIOWithUnmask' internally.  The child+-- thread is passed a function that can be used to unmask asynchronous+-- exceptions.+asyncWithUnmask :: ((forall b . IO b -> IO b) -> IO a) -> IO (Async a)+asyncWithUnmask actionWith = asyncUsing rawForkIO (actionWith unsafeUnmask)++-- | Like 'asyncOn' but using 'forkOnWithUnmask' internally.  The+-- child thread is passed a function that can be used to unmask+-- asynchronous exceptions.+asyncOnWithUnmask :: Int -> ((forall b . IO b -> IO b) -> IO a) -> IO (Async a)+asyncOnWithUnmask cpu actionWith =+  asyncUsing (rawForkOn cpu) (actionWith unsafeUnmask)++asyncUsing :: (IO () -> IO ThreadId)+           -> IO a -> IO (Async a)+asyncUsing doFork = \action -> do+   var <- newEmptyTMVarIO+   -- t <- forkFinally action (\r -> atomically $ putTMVar var r)+   -- slightly faster:+   t <- mask $ \restore ->+          doFork $ try (restore action) >>= atomically . putTMVar var+   return (Async t (readTMVar var))++-- | Spawn an asynchronous action in a separate thread, and pass its+-- @Async@ handle to the supplied function.  When the function returns+-- or throws an exception, 'uninterruptibleCancel' is called on the @Async@.+--+-- > withAsync action inner = mask $ \restore -> do+-- >   a <- async (restore action)+-- >   restore inner `finally` uninterruptibleCancel a+--+-- This is a useful variant of 'async' that ensures an @Async@ is+-- never left running unintentionally.+--+-- Note: a reference to the child thread is kept alive until the call+-- to `withAsync` returns, so nesting many `withAsync` calls requires+-- linear memory.+--+withAsync :: IO a -> (Async a -> IO b) -> IO b+withAsync = inline withAsyncUsing rawForkIO++-- | Like 'withAsync' but uses 'forkOS' internally.+withAsyncBound :: IO a -> (Async a -> IO b) -> IO b+withAsyncBound = withAsyncUsing forkOS++-- | Like 'withAsync' but uses 'forkOn' internally.+withAsyncOn :: Int -> IO a -> (Async a -> IO b) -> IO b+withAsyncOn = withAsyncUsing . rawForkOn++-- | Like 'withAsync' but uses 'forkIOWithUnmask' internally.  The+-- child thread is passed a function that can be used to unmask+-- asynchronous exceptions.+withAsyncWithUnmask+  :: ((forall c. IO c -> IO c) -> IO a) -> (Async a -> IO b) -> IO b+withAsyncWithUnmask actionWith =+  withAsyncUsing rawForkIO (actionWith unsafeUnmask)++-- | Like 'withAsyncOn' but uses 'forkOnWithUnmask' internally.  The+-- child thread is passed a function that can be used to unmask+-- asynchronous exceptions+withAsyncOnWithUnmask+  :: Int -> ((forall c. IO c -> IO c) -> IO a) -> (Async a -> IO b) -> IO b+withAsyncOnWithUnmask cpu actionWith =+  withAsyncUsing (rawForkOn cpu) (actionWith unsafeUnmask)++withAsyncUsing :: (IO () -> IO ThreadId)+               -> IO a -> (Async a -> IO b) -> IO b+-- The bracket version works, but is slow.  We can do better by+-- hand-coding it:+withAsyncUsing doFork = \action inner -> do+  var <- newEmptyTMVarIO+  mask $ \restore -> do+    t <- doFork $ try (restore action) >>= atomically . putTMVar var+    let a = Async t (readTMVar var)+    r <- restore (inner a) `catchAll` \e -> do+      uninterruptibleCancel a+      throwIO e+    uninterruptibleCancel a+    return r++-- | Wait for an asynchronous action to complete, and return its+-- value.  If the asynchronous action threw an exception, then the+-- exception is re-thrown by 'wait'.+--+-- > wait = atomically . waitSTM+--+{-# INLINE wait #-}+wait :: Async a -> IO a+wait = atomically . waitSTM++-- | Wait for an asynchronous action to complete, and return either+-- @Left e@ if the action raised an exception @e@, or @Right a@ if it+-- returned a value @a@.+--+-- > waitCatch = atomically . waitCatchSTM+--+{-# INLINE waitCatch #-}+waitCatch :: Async a -> IO (Either SomeException a)+waitCatch = tryAgain . atomically . waitCatchSTM+  where+    -- See: https://github.com/simonmar/async/issues/14+    tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f++-- | Check whether an 'Async' has completed yet.  If it has not+-- completed yet, then the result is @Nothing@, otherwise the result+-- is @Just e@ where @e@ is @Left x@ if the @Async@ raised an+-- exception @x@, or @Right a@ if it returned a value @a@.+--+-- > poll = atomically . pollSTM+--+{-# INLINE poll #-}+poll :: Async a -> IO (Maybe (Either SomeException a))+poll = atomically . pollSTM++-- | A version of 'wait' that can be used inside an STM transaction.+--+waitSTM :: Async a -> STM a+waitSTM a = do+   r <- waitCatchSTM a+   either throwSTM return r++-- | A version of 'waitCatch' that can be used inside an STM transaction.+--+{-# INLINE waitCatchSTM #-}+waitCatchSTM :: Async a -> STM (Either SomeException a)+waitCatchSTM (Async _ w) = w++-- | A version of 'poll' that can be used inside an STM transaction.+--+{-# INLINE pollSTM #-}+pollSTM :: Async a -> STM (Maybe (Either SomeException a))+pollSTM (Async _ w) = (Just <$> w) `orElse` return Nothing++-- | Cancel an asynchronous action by throwing the @AsyncCancelled@+-- exception to it, and waiting for the `Async` thread to quit.+-- Has no effect if the 'Async' has already completed.+--+-- > cancel a = throwTo (asyncThreadId a) AsyncCancelled <* waitCatch a+--+-- Note that 'cancel' will not terminate until the thread the 'Async'+-- refers to has terminated. This means that 'cancel' will block for+-- as long said thread blocks when receiving an asynchronous exception.+--+-- For example, it could block if:+--+-- * It's executing a foreign call, and thus cannot receive the asynchronous+-- exception;+-- * It's executing some cleanup handler after having received the exception,+-- and the handler is blocking.+{-# INLINE cancel #-}+cancel :: Async a -> IO ()+cancel a@(Async t _) = throwTo t AsyncCancelled <* waitCatch a++-- | The exception thrown by `cancel` to terminate a thread.+data AsyncCancelled = AsyncCancelled+  deriving (Show, Eq+#if __GLASGOW_HASKELL__ < 710+    ,Typeable+#endif+    )++instance Exception AsyncCancelled where+#if __GLASGOW_HASKELL__ >= 708+  fromException = asyncExceptionFromException+  toException = asyncExceptionToException+#endif++-- | Cancel an asynchronous action+--+-- This is a variant of `cancel`, but it is not interruptible.+{-# INLINE uninterruptibleCancel #-}+uninterruptibleCancel :: Async a -> IO ()+uninterruptibleCancel = uninterruptibleMask_ . cancel++-- | Cancel an asynchronous action by throwing the supplied exception+-- to it.+--+-- > cancelWith a x = throwTo (asyncThreadId a) x+--+-- The notes about the synchronous nature of 'cancel' also apply to+-- 'cancelWith'.+cancelWith :: Exception e => Async a -> e -> IO ()+cancelWith a@(Async t _) e = throwTo t e <* waitCatch a++-- | Wait for any of the supplied asynchronous operations to complete.+-- The value returned is a pair of the 'Async' that completed, and the+-- result that would be returned by 'wait' on that 'Async'.+--+-- If multiple 'Async's complete or have completed, then the value+-- returned corresponds to the first completed 'Async' in the list.+--+{-# INLINE waitAnyCatch #-}+waitAnyCatch :: [Async a] -> IO (Async a, Either SomeException a)+waitAnyCatch = atomically . waitAnyCatchSTM++-- | A version of 'waitAnyCatch' that can be used inside an STM transaction.+--+-- @since 2.1.0+waitAnyCatchSTM :: [Async a] -> STM (Async a, Either SomeException a)+waitAnyCatchSTM asyncs =+    foldr orElse retry $+      map (\a -> do r <- waitCatchSTM a; return (a, r)) asyncs++-- | Like 'waitAnyCatch', but also cancels the other asynchronous+-- operations as soon as one has completed.+--+waitAnyCatchCancel :: [Async a] -> IO (Async a, Either SomeException a)+waitAnyCatchCancel asyncs =+  waitAnyCatch asyncs `finally` mapM_ cancel asyncs++-- | Wait for any of the supplied @Async@s to complete.  If the first+-- to complete throws an exception, then that exception is re-thrown+-- by 'waitAny'.+--+-- If multiple 'Async's complete or have completed, then the value+-- returned corresponds to the first completed 'Async' in the list.+--+{-# INLINE waitAny #-}+waitAny :: [Async a] -> IO (Async a, a)+waitAny = atomically . waitAnySTM++-- | A version of 'waitAny' that can be used inside an STM transaction.+--+-- @since 2.1.0+waitAnySTM :: [Async a] -> STM (Async a, a)+waitAnySTM asyncs =+    foldr orElse retry $+      map (\a -> do r <- waitSTM a; return (a, r)) asyncs++-- | Like 'waitAny', but also cancels the other asynchronous+-- operations as soon as one has completed.+--+waitAnyCancel :: [Async a] -> IO (Async a, a)+waitAnyCancel asyncs =+  waitAny asyncs `finally` mapM_ cancel asyncs++-- | Wait for the first of two @Async@s to finish.+{-# INLINE waitEitherCatch #-}+waitEitherCatch :: Async a -> Async b+                -> IO (Either (Either SomeException a)+                              (Either SomeException b))+waitEitherCatch left right =+  tryAgain $ atomically (waitEitherCatchSTM left right)+  where+    -- See: https://github.com/simonmar/async/issues/14+    tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f++-- | A version of 'waitEitherCatch' that can be used inside an STM transaction.+--+-- @since 2.1.0+waitEitherCatchSTM :: Async a -> Async b+                -> STM (Either (Either SomeException a)+                               (Either SomeException b))+waitEitherCatchSTM left right =+    (Left  <$> waitCatchSTM left)+      `orElse`+    (Right <$> waitCatchSTM right)++-- | Like 'waitEitherCatch', but also 'cancel's both @Async@s before+-- returning.+--+waitEitherCatchCancel :: Async a -> Async b+                      -> IO (Either (Either SomeException a)+                                    (Either SomeException b))+waitEitherCatchCancel left right =+  waitEitherCatch left right `finally` (cancel left >> cancel right)++-- | Wait for the first of two @Async@s to finish.  If the @Async@+-- that finished first raised an exception, then the exception is+-- re-thrown by 'waitEither'.+--+{-# INLINE waitEither #-}+waitEither :: Async a -> Async b -> IO (Either a b)+waitEither left right = atomically (waitEitherSTM left right)++-- | A version of 'waitEither' that can be used inside an STM transaction.+--+-- @since 2.1.0+waitEitherSTM :: Async a -> Async b -> STM (Either a b)+waitEitherSTM left right =+    (Left  <$> waitSTM left)+      `orElse`+    (Right <$> waitSTM right)++-- | Like 'waitEither', but the result is ignored.+--+{-# INLINE waitEither_ #-}+waitEither_ :: Async a -> Async b -> IO ()+waitEither_ left right = atomically (waitEitherSTM_ left right)++-- | A version of 'waitEither_' that can be used inside an STM transaction.+--+-- @since 2.1.0+waitEitherSTM_:: Async a -> Async b -> STM ()+waitEitherSTM_ left right =+    (void $ waitSTM left)+      `orElse`+    (void $ waitSTM right)++-- | Like 'waitEither', but also 'cancel's both @Async@s before+-- returning.+--+waitEitherCancel :: Async a -> Async b -> IO (Either a b)+waitEitherCancel left right =+  waitEither left right `finally` (cancel left >> cancel right)++-- | Waits for both @Async@s to finish, but if either of them throws+-- an exception before they have both finished, then the exception is+-- re-thrown by 'waitBoth'.+--+{-# INLINE waitBoth #-}+waitBoth :: Async a -> Async b -> IO (a,b)+waitBoth left right = atomically (waitBothSTM left right)++-- | A version of 'waitBoth' that can be used inside an STM transaction.+--+-- @since 2.1.0+waitBothSTM :: Async a -> Async b -> STM (a,b)+waitBothSTM left right = do+    a <- waitSTM left+           `orElse`+         (waitSTM right >> retry)+    b <- waitSTM right+    return (a,b)+++-- -----------------------------------------------------------------------------+-- Linking threads++data ExceptionInLinkedThread =+  forall a . ExceptionInLinkedThread (Async a) SomeException+#if __GLASGOW_HASKELL__ < 710+  deriving Typeable+#endif++instance Show ExceptionInLinkedThread where+  show (ExceptionInLinkedThread (Async t _) e) =+    "ExceptionInLinkedThread " ++ show t ++ " " ++ show e++instance Exception ExceptionInLinkedThread where+#if __GLASGOW_HASKELL__ >= 708+  fromException = asyncExceptionFromException+  toException = asyncExceptionToException+#endif++-- | Link the given @Async@ to the current thread, such that if the+-- @Async@ raises an exception, that exception will be re-thrown in+-- the current thread, wrapped in 'ExceptionInLinkedThread'.+--+-- 'link' ignores 'AsyncCancelled' exceptions thrown in the other thread,+-- so that it's safe to 'cancel' a thread you're linked to.  If you want+-- different behaviour, use 'linkOnly'.+--+link :: Async a -> IO ()+link = linkOnly (not . isCancel)++-- | Link the given @Async@ to the current thread, such that if the+-- @Async@ raises an exception, that exception will be re-thrown in+-- the current thread.  The supplied predicate determines which+-- exceptions in the target thread should be propagated to the source+-- thread.+--+linkOnly+  :: (SomeException -> Bool)  -- ^ return 'True' if the exception+                              -- should be propagated, 'False'+                              -- otherwise.+  -> Async a+  -> IO ()+linkOnly shouldThrow a = do+  me <- myThreadId+  void $ forkRepeat $ do+    r <- waitCatch a+    case r of+      Left e | shouldThrow e -> throwTo me (ExceptionInLinkedThread a e)+      _otherwise -> return ()++-- | Link two @Async@s together, such that if either raises an+-- exception, the same exception is re-thrown in the other @Async@,+-- wrapped in 'ExceptionInLinkedThread'.+--+-- 'link2' ignores 'AsyncCancelled' exceptions, so that it's possible+-- to 'cancel' either thread without cancelling the other.  If you+-- want different behaviour, use 'link2Only'.+--+link2 :: Async a -> Async b -> IO ()+link2 = link2Only (not . isCancel)++link2Only :: (SomeException -> Bool) -> Async a -> Async b -> IO ()+link2Only shouldThrow left@(Async tl _)  right@(Async tr _) =+  void $ forkRepeat $ do+    r <- waitEitherCatch left right+    case r of+      Left  (Left e) | shouldThrow e ->+        throwTo tr (ExceptionInLinkedThread left e)+      Right (Left e) | shouldThrow e ->+        throwTo tl (ExceptionInLinkedThread right e)+      _ -> return ()++isCancel :: SomeException -> Bool+isCancel e+  | Just AsyncCancelled <- fromException e = True+  | otherwise = False+++-- -----------------------------------------------------------------------------++-- | Run two @IO@ actions concurrently, and return the first to+-- finish.  The loser of the race is 'cancel'led.+--+-- > race left right =+-- >   withAsync left $ \a ->+-- >   withAsync right $ \b ->+-- >   waitEither a b+--+race :: IO a -> IO b -> IO (Either a b)++-- | Like 'race', but the result is ignored.+--+race_ :: IO a -> IO b -> IO ()++-- | Run two @IO@ actions concurrently, and return both results.  If+-- either action throws an exception at any time, then the other+-- action is 'cancel'led, and the exception is re-thrown by+-- 'concurrently'.+--+-- > concurrently left right =+-- >   withAsync left $ \a ->+-- >   withAsync right $ \b ->+-- >   waitBoth a b+concurrently :: IO a -> IO b -> IO (a,b)++#define USE_ASYNC_VERSIONS 0++#if USE_ASYNC_VERSIONS++race left right =+  withAsync left $ \a ->+  withAsync right $ \b ->+  waitEither a b++race_ left right =+  withAsync left $ \a ->+  withAsync right $ \b ->+  waitEither_ a b++concurrently left right =+  withAsync left $ \a ->+  withAsync right $ \b ->+  waitBoth a b++#else++-- MVar versions of race/concurrently+-- More ugly than the Async versions, but quite a bit faster.++-- race :: IO a -> IO b -> IO (Either a b)+race left right = concurrently' left right collect+  where+    collect m = do+        e <- m+        case e of+            Left ex -> throwIO ex+            Right r -> return r++-- race_ :: IO a -> IO b -> IO ()+race_ left right = void $ race left right++-- concurrently :: IO a -> IO b -> IO (a,b)+concurrently left right = concurrently' left right (collect [])+  where+    collect [Left a, Right b] _ = return (a,b)+    collect [Right b, Left a] _ = return (a,b)+    collect xs m = do+        e <- m+        case e of+            Left ex -> throwIO ex+            Right r -> collect (r:xs) m++concurrently' :: IO a -> IO b+             -> (IO (Either SomeException (Either a b)) -> IO r)+             -> IO r+concurrently' left right collect = do+    done <- newEmptyMVar+    mask $ \restore -> do+        -- Note: uninterruptibleMask here is because we must not allow+        -- the putMVar in the exception handler to be interrupted,+        -- otherwise the parent thread will deadlock when it waits for+        -- the thread to terminate.+        lid <- forkIO $ uninterruptibleMask_ $+          restore (left >>= putMVar done . Right . Left)+            `catchAll` (putMVar done . Left)+        rid <- forkIO $ uninterruptibleMask_ $+          restore (right >>= putMVar done . Right . Right)+            `catchAll` (putMVar done . Left)++        count <- newIORef (2 :: Int)+        let takeDone = do+                r <- takeMVar done      -- interruptible+                -- Decrement the counter so we know how many takes are left.+                -- Since only the parent thread is calling this, we can+                -- use non-atomic modifications.+                -- NB. do this *after* takeMVar, because takeMVar might be+                -- interrupted.+                modifyIORef count (subtract 1)+                return r++        let tryAgain f = f `catch` \BlockedIndefinitelyOnMVar -> f++            stop = do+                -- kill right before left, to match the semantics of+                -- the version using withAsync. (#27)+                uninterruptibleMask_ $ do+                  count' <- readIORef count+                  -- we only need to use killThread if there are still+                  -- children alive.  Note: forkIO here is because the+                  -- child thread could be in an uninterruptible+                  -- putMVar.+                  when (count' > 0) $+                    void $ forkIO $ do+                      throwTo rid AsyncCancelled+                      throwTo lid AsyncCancelled+                  -- ensure the children are really dead+                  replicateM_ count' (tryAgain $ takeMVar done)++        r <- collect (tryAgain $ takeDone) `onException` stop+        stop+        return r++#endif++-- | maps an @IO@-performing function over any @Traversable@ data+-- type, performing all the @IO@ actions concurrently, and returning+-- the original data structure with the arguments replaced by the+-- results.+--+-- If any of the actions throw an exception, then all other actions are+-- cancelled and the exception is re-thrown.+--+-- For example, @mapConcurrently@ works with lists:+--+-- > pages <- mapConcurrently getURL ["url1", "url2", "url3"]+--+mapConcurrently :: Traversable t => (a -> IO b) -> t a -> IO (t b)+mapConcurrently f = runConcurrently . traverse (Concurrently . f)++-- | `forConcurrently` is `mapConcurrently` with its arguments flipped+--+-- > pages <- forConcurrently ["url1", "url2", "url3"] $ \url -> getURL url+--+-- @since 2.1.0+forConcurrently :: Traversable t => t a -> (a -> IO b) -> IO (t b)+forConcurrently = flip mapConcurrently++-- | `mapConcurrently_` is `mapConcurrently` with the return value discarded,+-- just like @mapM_+mapConcurrently_ :: F.Foldable f => (a -> IO b) -> f a -> IO ()+mapConcurrently_ f = runConcurrently . F.foldMap (Concurrently . void . f)++-- | `forConcurrently_` is `forConcurrently` with the return value discarded,+-- just like @forM_+forConcurrently_ :: F.Foldable f => f a -> (a -> IO b) -> IO ()+forConcurrently_ = flip mapConcurrently_++-- | 'concurrently', but ignore the result values+--+-- @since 2.1.1+concurrently_ :: IO a -> IO b -> IO ()+concurrently_ left right = concurrently' left right (collect 0)+  where+    collect 2 _ = return ()+    collect i m = do+        e <- m+        case e of+            Left ex -> throwIO ex+            Right _ -> collect (i + 1 :: Int) m++-- | Perform the action in the given number of threads.+--+-- @since 2.1.1+replicateConcurrently :: Int -> IO a -> IO [a]+replicateConcurrently cnt = runConcurrently . sequenceA . replicate cnt . Concurrently++-- | Same as 'replicateConcurrently', but ignore the results.+--+-- @since 2.1.1+replicateConcurrently_ :: Int -> IO a -> IO ()+replicateConcurrently_ cnt = runConcurrently . F.fold . replicate cnt . Concurrently . void++-- -----------------------------------------------------------------------------++-- | A value of type @Concurrently a@ is an @IO@ operation that can be+-- composed with other @Concurrently@ values, using the @Applicative@+-- and @Alternative@ instances.+--+-- Calling @runConcurrently@ on a value of type @Concurrently a@ will+-- execute the @IO@ operations it contains concurrently, before+-- delivering the result of type @a@.+--+-- For example+--+-- > (page1, page2, page3)+-- >     <- runConcurrently $ (,,)+-- >     <$> Concurrently (getURL "url1")+-- >     <*> Concurrently (getURL "url2")+-- >     <*> Concurrently (getURL "url3")+--+newtype Concurrently a = Concurrently { runConcurrently :: IO a }++instance Functor Concurrently where+  fmap f (Concurrently a) = Concurrently $ f <$> a++instance Applicative Concurrently where+  pure = Concurrently . return+  Concurrently fs <*> Concurrently as =+    Concurrently $ (\(f, a) -> f a) <$> concurrently fs as++instance Alternative Concurrently where+  empty = Concurrently $ forever (threadDelay maxBound)+  Concurrently as <|> Concurrently bs =+    Concurrently $ either id id <$> race as bs++#if MIN_VERSION_base(4,9,0)+-- | Only defined by @async@ for @base >= 4.9@+--+-- @since 2.1.0+instance Semigroup a => Semigroup (Concurrently a) where+  (<>) = liftA2 (<>)++-- | @since 2.1.0+instance (Semigroup a, Monoid a) => Monoid (Concurrently a) where+  mempty = pure mempty+  mappend = (<>)+#else+-- | @since 2.1.0+instance Monoid a => Monoid (Concurrently a) where+  mempty = pure mempty+  mappend = liftA2 mappend+#endif++-- ----------------------------------------------------------------------------++-- | Fork a thread that runs the supplied action, and if it raises an+-- exception, re-runs the action.  The thread terminates only when the+-- action runs to completion without raising an exception.+forkRepeat :: IO a -> IO ThreadId+forkRepeat action =+  mask $ \restore ->+    let go = do r <- tryAll (restore action)+                case r of+                  Left _ -> go+                  _      -> return ()+    in forkIO go++catchAll :: IO a -> (SomeException -> IO a) -> IO a+catchAll = catch++tryAll :: IO a -> IO (Either SomeException a)+tryAll = try++-- A version of forkIO that does not include the outer exception+-- handler: saves a bit of time when we will be installing our own+-- exception handler.+{-# INLINE rawForkIO #-}+rawForkIO :: IO () -> IO ThreadId+rawForkIO action = IO $ \ s ->+   case (fork# action s) of (# s1, tid #) -> (# s1, ThreadId tid #)++{-# INLINE rawForkOn #-}+rawForkOn :: Int -> IO () -> IO ThreadId+rawForkOn (I# cpu) action = IO $ \ s ->+   case (forkOn# cpu action s) of (# s1, tid #) -> (# s1, ThreadId tid #)

@@ -1,19 +1,20 @@--- This file has been generated from package.yaml by hpack version 0.21.2.+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.30.0. -- -- see: https://github.com/sol/hpack ----- hash: a127653a989c7ff69649480ddd6226dd61f3e9eded4419b7214fa6deb0da8f7c+-- hash: b9089eec6ed9c224790a988a565a1089609beb176824d8eafe653098556dc71c  name:             hspec-meta-version:          2.4.6+version:          2.5.6 license:          MIT license-file:     LICENSE-copyright:        (c) 2011-2017 Simon Hengel,+copyright:        (c) 2011-2018 Simon Hengel,                   (c) 2011-2012 Trystan Spangler,                   (c) 2011 Greg Weber maintainer:       Simon Hengel <sol@typeful.net> build-type:       Simple-cabal-version:    >= 1.10 category:         Testing stability:        experimental bug-reports:      https://github.com/hspec/hspec/issues@@ -21,7 +22,6 @@ synopsis:         A version of Hspec which is used to test Hspec itself description:      A stable version of Hspec which is used to test the                   in-development version of Hspec.- extra-source-files:     CHANGES.markdown @@ -30,28 +30,6 @@   location: https://github.com/hspec/hspec  library-  ghc-options: -Wall-  hs-source-dirs:-      src-      hspec-core/src-      hspec-core/vendor/-  build-depends:-      HUnit-    , QuickCheck >=2.5.1-    , ansi-terminal-    , array-    , async-    , base ==4.*-    , call-stack-    , deepseq-    , directory-    , filepath-    , hspec-expectations >=0.8.0-    , quickcheck-io-    , random-    , setenv-    , time-    , transformers >=0.2.2.0   exposed-modules:       Test.Hspec.Meta   other-modules:@@ -59,20 +37,23 @@       Test.Hspec.Core       Test.Hspec.Discover       Test.Hspec.Formatters-      Test.Hspec.HUnit       Test.Hspec.QuickCheck       Test.Hspec.Runner+      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@@ -82,8 +63,32 @@       Test.Hspec.Core.Timer       Test.Hspec.Core.Tree       Test.Hspec.Core.Util+      Control.Concurrent.Async       Data.Algorithm.Diff       Paths_hspec_meta+  ghc-options: -Wall+  hs-source-dirs:+      src+      hspec-core/src+      hspec-core/vendor+  build-depends:+      HUnit+    , QuickCheck >=2.5.1+    , ansi-terminal+    , array+    , base ==4.*+    , call-stack+    , clock+    , deepseq+    , directory+    , filepath+    , hspec-expectations >=0.8.0+    , quickcheck-io+    , random+    , setenv+    , stm >=2.2+    , time+    , transformers >=0.2.2.0   default-language: Haskell2010  executable hspec-meta-discover@@ -97,9 +102,9 @@     , QuickCheck >=2.5.1     , ansi-terminal     , array-    , async     , base ==4.*     , call-stack+    , clock     , deepseq     , directory     , filepath@@ -107,6 +112,7 @@     , quickcheck-io     , random     , setenv+    , stm >=2.2     , time     , transformers >=0.2.2.0   other-modules:

@@ -11,16 +11,10 @@ ) where  import           Prelude hiding (mapM)-import           Control.Applicative-import           Data.Maybe-import           Data.List-import           Data.Traversable-import           Control.Monad.Trans.State  import           Test.Hspec.Core.Spec import           Test.Hspec.Core.Runner import           Test.Hspec.Formatters-import           Test.Hspec.Core.Util (safeTry)  class IsFormatter a where   toFormatter :: a -> IO Formatter@@ -37,62 +31,4 @@   hspecWith defaultConfig {configFormatter = Just f} spec  postProcessSpec :: FilePath -> Spec -> Spec-postProcessSpec = locationHeuristicFromFile--locationHeuristicFromFile :: FilePath -> Spec -> Spec-locationHeuristicFromFile file spec = do-  mInput <- either (const Nothing) Just <$> (runIO . safeTry . readFile) file-  let lookupLoc = maybe (\_ _ _ -> Nothing) (lookupLocation file)  mInput-  runIO (runSpecM spec) >>= fromSpecList . addLoctions lookupLoc--addLoctions :: (Int -> Int -> String -> Maybe Location) -> [SpecTree a] -> [SpecTree a]-addLoctions lookupLoc = map (fmap f) . enumerate-  where-    f :: ((Int, Int), Item a) -> Item a-    f ((n, total), item) = item {itemLocation = itemLocation item <|> lookupLoc n total (itemRequirement item)}--type EnumerateM = State [(String, Int)]--enumerate :: [SpecTree a] -> [Tree (ActionWith a) ((Int, Int), (Item a))]-enumerate tree = (mapM (traverse addPosition) tree >>= mapM (traverse addTotal)) `evalState` []-  where-    addPosition :: Item a -> EnumerateM (Int, Item a)-    addPosition item = (,) <$> getOccurrence (itemRequirement item) <*> pure item--    addTotal :: (Int, Item a) -> EnumerateM ((Int, Int), Item a)-    addTotal (n, item) = do-      total <- getTotal (itemRequirement item)-      return ((n, total), item)--    getTotal :: String -> EnumerateM Int-    getTotal requirement = do-      gets $ fromMaybe err . lookup requirement-      where-        err = error ("Test.Hspec.Discover.getTotal: No entry for requirement " ++ show requirement ++ "!")--    getOccurrence :: String -> EnumerateM Int-    getOccurrence requirement = do-      xs <- get-      let n = maybe 1 succ (lookup requirement xs)-      put ((requirement, n) : filter ((/= requirement) . fst) xs)-      return n--lookupLocation :: FilePath -> String -> Int -> Int -> String -> Maybe Location-lookupLocation file input n total requirement = loc-  where-    loc :: Maybe Location-    loc = Location file <$> line <*> pure 0 <*> pure BestEffort--    line :: Maybe Int-    line = case occurrences of-      xs | length xs == total -> Just (xs !! pred n)-      _ -> Nothing--    occurrences :: [Int]-    occurrences = map fst (filter p inputLines)-      where-        p :: (Int, String) -> Bool-        p = isInfixOf (show requirement) . snd--    inputLines :: [(Int, String)]-    inputLines = zip [1..] (lines input)+postProcessSpec _ = id

@@ -1,24 +0,0 @@-module Test.Hspec.HUnit {-# DEPRECATED "use \"Test.Hspec.Contrib.HUnit\" from package @hspec-contrib@ instead" #-}-(--- * Interoperability with HUnit-  fromHUnitTest-) where--import           Test.Hspec.Core.Spec-import           Test.HUnit (Test (..))---- |--- Convert a HUnit test suite to a spec.  This can be used to run existing--- HUnit tests with Hspec.-fromHUnitTest :: Test -> Spec-fromHUnitTest t = case t of-  TestList xs -> mapM_ go xs-  x -> go x-  where-    go :: Test -> Spec-    go t_ = case t_ of-      TestLabel s (TestCase e) -> it s e-      TestLabel s (TestList xs) -> describe s (mapM_ go xs)-      TestLabel s x -> describe s (go x)-      TestList xs -> describe "<unlabeled>" (mapM_ go xs)-      TestCase e -> it "<unlabeled>" e