packages feed

hspec-meta 2.7.8 → 2.9.0

raw patch · 41 files changed

+2175/−1196 lines, 41 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

+ Test.Hspec.Meta: aroundAll :: (ActionWith a -> IO ()) -> SpecWith a -> Spec
+ Test.Hspec.Meta: aroundAllWith :: forall a b. (ActionWith a -> ActionWith b) -> SpecWith a -> SpecWith b
+ Test.Hspec.Meta: aroundAll_ :: (IO () -> IO ()) -> SpecWith a -> SpecWith a
+ Test.Hspec.Meta: ignoreSubject :: SpecWith () -> SpecWith a
+ Test.Hspec.Meta: mapSubject :: (b -> a) -> SpecWith a -> SpecWith b
- Test.Hspec.Meta: afterAll :: ActionWith a -> SpecWith a -> SpecWith a
+ Test.Hspec.Meta: afterAll :: HasCallStack => ActionWith a -> SpecWith a -> SpecWith a
- Test.Hspec.Meta: afterAll_ :: IO () -> SpecWith a -> SpecWith a
+ Test.Hspec.Meta: afterAll_ :: HasCallStack => IO () -> SpecWith a -> SpecWith a

Files

+ hspec-core/src/GetOpt/Declarative.hs view
@@ -0,0 +1,5 @@+module GetOpt.Declarative (module GetOpt.Declarative) where+import           Prelude ()+import           GetOpt.Declarative.Types as GetOpt.Declarative+import           GetOpt.Declarative.Interpret as GetOpt.Declarative+import           GetOpt.Declarative.Environment as GetOpt.Declarative
+ hspec-core/src/GetOpt/Declarative/Environment.hs view
@@ -0,0 +1,51 @@+module GetOpt.Declarative.Environment (+  InvalidValue(..)+, parseEnvironmentOptions+, parseEnvironmentOption+) where++import           Prelude ()+import           Test.Hspec.Core.Compat+import           Data.Char++import           GetOpt.Declarative.Types++data InvalidValue = InvalidValue String String+  deriving (Eq, Show)++parseEnvironmentOptions :: String -> [(String, String)] -> config -> [Option config] -> ([InvalidValue], config)+parseEnvironmentOptions prefix env = foldr f . (,) []+  where+    f :: Option config -> ([InvalidValue], config) -> ([InvalidValue], config)+    f option (errs, config) = case parseEnvironmentOption prefix env config option of+        Left err -> (err : errs, config)+        Right c -> (errs, c)++parseEnvironmentOption :: String -> [(String, String)] -> config -> Option config -> Either InvalidValue config+parseEnvironmentOption prefix env config option = case lookup name env of+  Nothing -> Right config+  Just value -> case optionSetter option of+    NoArg setter -> case value of+      "yes" -> Right $ setter config+      _ -> invalidValue+    Flag setter -> case value of+      "yes" -> Right $ setter True config+      "no" -> Right $ setter False config+      _ -> invalidValue+    OptArg _ setter -> case setter (Just value) config of+      Just c -> Right c+      Nothing -> invalidValue+    Arg _ setter -> case setter value config of+      Just c -> Right c+      Nothing -> invalidValue+    where+      invalidValue = Left (InvalidValue name value)+  where+    name = envVarName prefix option++envVarName :: String -> Option config -> String+envVarName prefix option = prefix ++ '_' : map f (optionName option)+  where+    f c = case c of+      '-' -> '_'+      _ -> toUpper c
+ hspec-core/src/GetOpt/Declarative/Interpret.hs view
@@ -0,0 +1,97 @@+module GetOpt.Declarative.Interpret (+  ParseResult(..)+, parseCommandLineOptions+, parse+, interpretOptions+) where++import           Prelude ()+import           Test.Hspec.Core.Compat+import           Data.Maybe++import           System.Console.GetOpt (OptDescr, ArgOrder(..), getOpt)+import qualified System.Console.GetOpt as GetOpt++import           GetOpt.Declarative.Types+import           GetOpt.Declarative.Util (mkUsageInfo, mapOptDescr)++data InvalidArgument = InvalidArgument String String++data ParseResult config = Help String | Failure String | Success config++parseCommandLineOptions :: [(String, [Option config])] -> String -> [String] -> config -> ParseResult config+parseCommandLineOptions opts prog args config = case parseWithHelp (concatMap snd options) config args of+  Nothing -> Help usage+  Just (Right c) -> Success c+  Just (Left err) -> Failure $ prog ++ ": " ++ err ++ "\nTry `" ++ prog ++ " --help' for more information.\n"+  where+    options = addHelpFlag $ map (fmap interpretOptions) opts++    documentedOptions = addHelpFlag $ map (fmap $ interpretOptions . filter optionDocumented) opts++    usage :: String+    usage = "Usage: " ++ prog ++ " [OPTION]...\n\n"+      ++ (intercalate "\n" $ map (uncurry mkUsageInfo) documentedOptions)++addHelpFlag :: [(a, [OptDescr a1])] -> [(a, [OptDescr (Maybe a1)])]+addHelpFlag opts = case opts of+  (section, xs) : ys -> (section, GetOpt.Option [] ["help"] (GetOpt.NoArg help) "display this help and exit" : noHelp xs) : map (fmap noHelp) ys+  [] -> []+  where+    help = Nothing++    noHelp :: [OptDescr a] -> [OptDescr (Maybe a)]+    noHelp = map (mapOptDescr Just)++parseWithHelp :: [OptDescr (Maybe (config -> Either InvalidArgument config))] -> config -> [String] -> Maybe (Either String config)+parseWithHelp options config args = case getOpt Permute options args of+  (opts, [], []) | _ : _ <- [() | Nothing <- opts] -> Nothing+  (opts, xs, ys) -> Just $ interpretResult config (catMaybes opts, xs, ys)++parse :: [OptDescr (config -> Either InvalidArgument config)] -> config -> [String] -> Either String config+parse options config = interpretResult config . getOpt Permute options++interpretResult :: config -> ([config -> Either InvalidArgument config], [String], [String]) -> Either String config+interpretResult config = interpretGetOptResult >=> foldResult config++foldResult :: config -> [config -> Either InvalidArgument config] -> Either String config+foldResult config opts = either (Left . renderInvalidArgument) return $ foldlM (flip id) config opts++renderInvalidArgument :: InvalidArgument -> String+renderInvalidArgument (InvalidArgument name value) = "invalid argument `" ++ value ++ "' for `--" ++ name ++ "'"++interpretGetOptResult :: ([a], [String], [String]) -> Either String [a]+interpretGetOptResult result = case result of+  (opts, [], []) -> Right opts+  (_, _, err:_) -> Left (init err)+  (_, arg:_, _) -> Left ("unexpected argument `" ++ arg ++ "'")++interpretOptions :: [Option config] -> [OptDescr (config -> Either InvalidArgument config)]+interpretOptions = concatMap interpretOption++interpretOption :: Option config -> [OptDescr (config -> Either InvalidArgument config)]+interpretOption (Option name shortcut argDesc help _) = case argDesc of+  NoArg setter -> [option $ GetOpt.NoArg (Right . setter)]++  Flag setter -> [+      option (arg True)+    , GetOpt.Option [] ["no-" ++ name] (arg False) ("do not " ++ help)+    ]+    where+      arg v = GetOpt.NoArg (Right . setter v)++  OptArg argName setter -> [option $ GetOpt.OptArg arg argName]+    where+      arg mInput c = case setter mInput c of+        Just c_ -> Right c_+        Nothing -> case mInput of+          Just input -> invalid input+          Nothing -> Right c++  Arg argName setter -> [option (GetOpt.ReqArg arg argName)]+    where+      arg input = maybe (invalid input) Right . setter input++  where+    invalid = Left . InvalidArgument name+    option arg = GetOpt.Option (maybeToList shortcut) [name] arg help
+ hspec-core/src/GetOpt/Declarative/Types.hs view
@@ -0,0 +1,18 @@+module GetOpt.Declarative.Types where++import           Prelude ()+import           Test.Hspec.Core.Compat++data Option config = Option {+  optionName :: String+, optionShortcut :: Maybe Char+, optionSetter :: OptionSetter config+, optionHelp :: String+, optionDocumented :: Bool+}++data OptionSetter config =+    NoArg (config -> config)+  | Flag (Bool -> config -> config)+  | OptArg String (Maybe String -> config -> Maybe config)+  | Arg String (String -> config -> Maybe config)
+ hspec-core/src/GetOpt/Declarative/Util.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE CPP #-}+module GetOpt.Declarative.Util (mkUsageInfo, mapOptDescr) where++import           Prelude ()+import           Test.Hspec.Core.Compat++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+  [] -> []++mapOptDescr :: (a -> b) -> OptDescr a -> OptDescr b+#if MIN_VERSION_base(4,7,0)+mapOptDescr = fmap+#else+mapOptDescr f opt = case opt of+  Option short long arg help -> Option short long (mapArgDescr f arg) help++mapArgDescr :: (a -> b) -> ArgDescr a -> ArgDescr b+mapArgDescr f arg = case arg of+  NoArg a -> NoArg (f a)+  ReqArg parse name -> ReqArg (fmap f parse) name+  OptArg parse name -> OptArg (fmap f parse) name+#endif
hspec-core/src/Test/Hspec/Core/Clock.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Test.Hspec.Core.Clock (   Seconds(..)+, toMilliseconds , toMicroseconds , getMonotonicTime , measure@@ -8,13 +9,19 @@ , timeout ) where +import           Prelude ()+import           Test.Hspec.Core.Compat+ import           Text.Printf import           System.Clock import           Control.Concurrent import qualified System.Timeout as System  newtype Seconds = Seconds Double-  deriving (Eq, Show, Num, Fractional, PrintfArg)+  deriving (Eq, Show, Ord, Num, Fractional, PrintfArg)++toMilliseconds :: Seconds -> Int+toMilliseconds (Seconds s) = floor (s * 1000)  toMicroseconds :: Seconds -> Int toMicroseconds (Seconds s) = floor (s * 1000000)
hspec-core/src/Test/Hspec/Core/Compat.hs view
@@ -1,31 +1,11 @@ {-# LANGUAGE CPP #-} module Test.Hspec.Core.Compat (-  getDefaultConcurrentJobs-, showType-, showFullType-, readMaybe-, lookupEnv-, module Data.IORef--, module Prelude-, module Control.Applicative-, module Control.Monad-, module Data.Foldable-, module Data.Traversable-, module Data.Monoid-, module Data.List--#if !MIN_VERSION_base(4,6,0)-, modifyIORef'-, atomicWriteIORef-#endif-, interruptible--, guarded+  module Imports+, module Test.Hspec.Core.Compat ) where -import           Control.Applicative-import           Control.Monad hiding (+import           Control.Applicative as Imports+import           Control.Monad as Imports hiding (     mapM   , mapM_   , forM@@ -34,12 +14,28 @@   , sequence   , sequence_   )-import           Data.Foldable-import           Data.Traversable-import           Data.Monoid-import           Data.List (intercalate)+import           Data.Foldable as Imports -import           Prelude hiding (+#if MIN_VERSION_base(4,11,0)+import           Data.Functor as Imports+#endif++import           Data.Traversable as Imports+import           Data.Monoid as Imports+import           Data.List as Imports (+    stripPrefix+  , isPrefixOf+  , isInfixOf+  , intercalate+  , inits+  , tails+  , sortBy+#if MIN_VERSION_base(4,8,0)+  , sortOn+#endif+  )++import           Prelude as Imports hiding (     all   , and   , any@@ -66,22 +62,31 @@   )  import           Data.Typeable (Typeable, typeOf, typeRepTyCon)+import           Data.IORef as Imports++#if MIN_VERSION_base(4,6,0)+import           Text.Read as Imports (readMaybe)+import           System.Environment as Imports (lookupEnv)+#else import           Text.Read-import           Data.IORef import           System.Environment+import qualified Text.ParserCombinators.ReadP as P+#endif +#if !MIN_VERSION_base(4,8,0)+import           Data.Ord (comparing)+#endif+ import           Data.Typeable (tyConModule, tyConName) import           Control.Concurrent  #if MIN_VERSION_base(4,9,0)-import           Control.Exception (interruptible)+import           Control.Exception as Imports (interruptible) #else import           GHC.IO #endif  #if !MIN_VERSION_base(4,6,0)-import qualified Text.ParserCombinators.ReadP as P- -- |Strict version of 'modifyIORef' modifyIORef' :: IORef a -> (a -> a) -> IO () modifyIORef' ref f = do@@ -147,3 +152,15 @@  guarded :: Alternative m => (a -> Bool) -> a -> m a guarded p a = if p a then pure a else empty++#if !MIN_VERSION_base(4,8,0)+sortOn :: Ord b => (a -> b) -> [a] -> [a]+sortOn f =+  map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x))+#endif++#if !MIN_VERSION_base(4,11,0)+infixl 1 <&>+(<&>) :: Functor f => f a -> (a -> b) -> f b+(<&>) = flip (<$>)+#endif
hspec-core/src/Test/Hspec/Core/Config.hs view
@@ -2,6 +2,7 @@ module Test.Hspec.Core.Config (   Config (..) , ColorMode(..)+, UnicodeMode(..) , defaultConfig , readConfig , configAddFilter@@ -24,11 +25,12 @@ import           System.Exit import           System.FilePath import           System.Directory-import           System.Environment (getProgName)+import           System.Environment (getProgName, getEnvironment) import qualified Test.QuickCheck as QC  import           Test.Hspec.Core.Util import           Test.Hspec.Core.Config.Options+import           Test.Hspec.Core.Config.Definition (Config(..), ColorMode(..), UnicodeMode(..), defaultConfig, filterOr) import           Test.Hspec.Core.FailureReport import           Test.Hspec.Core.QuickCheckUtil (mkGen) import           Test.Hspec.Core.Example (Params(..), defaultParams)@@ -67,18 +69,22 @@   where     qcArgs = (         maybe id setSeed (configQuickCheckSeed c)-      . maybe id setMaxDiscardRatio (configQuickCheckMaxDiscardRatio c)+      . maybe id setMaxShrinks (configQuickCheckMaxShrinks c)       . maybe id setMaxSize (configQuickCheckMaxSize c)+      . maybe id setMaxDiscardRatio (configQuickCheckMaxDiscardRatio c)       . maybe id setMaxSuccess (configQuickCheckMaxSuccess c)) (paramsQuickCheckArgs defaultParams)      setMaxSuccess :: Int -> QC.Args -> QC.Args     setMaxSuccess n args = args {QC.maxSuccess = n} +    setMaxDiscardRatio :: Int -> QC.Args -> QC.Args+    setMaxDiscardRatio n args = args {QC.maxDiscardRatio = n}+     setMaxSize :: Int -> QC.Args -> QC.Args     setMaxSize n args = args {QC.maxSize = n} -    setMaxDiscardRatio :: Int -> QC.Args -> QC.Args-    setMaxDiscardRatio n args = args {QC.maxDiscardRatio = n}+    setMaxShrinks :: Int -> QC.Args -> QC.Args+    setMaxShrinks n args = args {QC.maxShrinks = n}      setSeed :: Integer -> QC.Args -> QC.Args     setSeed n args = args {QC.replay = Just (mkGen (fromIntegral n), 0)}@@ -113,10 +119,13 @@     case ignore of       True -> return []       False -> readConfigFiles-  envVar <- fmap words <$> lookupEnv envVarName-  case parseOptions opts_ prog configFiles envVar args of+  env <- getEnvironment+  let envVar = words <$> lookup envVarName env+  case parseOptions opts_ prog configFiles envVar env args of     Left (err, msg) -> exitWithMessage err msg-    Right opts -> return opts+    Right (warnings, opts) -> do+      mapM_ (hPutStrLn stderr) warnings+      return opts  readFailureReportOnRerun :: Config -> IO (Maybe FailureReport) readFailureReportOnRerun config
+ hspec-core/src/Test/Hspec/Core/Config/Definition.hs view
@@ -0,0 +1,290 @@+{-# LANGUAGE CPP #-}+module Test.Hspec.Core.Config.Definition (+  Config(..)+, ColorMode(..)+, UnicodeMode(..)+, filterOr+, defaultConfig++, commandLineOnlyOptions+, formatterOptions+, smallCheckOptions+, quickCheckOptions+, runnerOptions++#ifdef TEST+, formatOrList+#endif+) where++import           Prelude ()+import           Test.Hspec.Core.Compat++import           Test.Hspec.Core.Example (Params(..), defaultParams)+import           Test.Hspec.Core.Format (Format, FormatConfig)+import qualified Test.Hspec.Core.Formatters.V1 as V1+import qualified Test.Hspec.Core.Formatters.V2 as V2+import           Test.Hspec.Core.Util++import           GetOpt.Declarative+++data ColorMode = ColorAuto | ColorNever | ColorAlways+  deriving (Eq, Show)++data UnicodeMode = UnicodeAuto | UnicodeNever | UnicodeAlways+  deriving (Eq, Show)++data Config = Config {+  configIgnoreConfigFile :: Bool+, configDryRun :: Bool+, configFocusedOnly :: Bool+, configFailOnFocused :: Bool+, configPrintSlowItems :: Maybe Int+, configPrintCpuTime :: Bool+, configFailFast :: Bool+, configRandomize :: 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+, configQuickCheckMaxShrinks :: Maybe Int+, configSmallCheckDepth :: Int+, configColorMode :: ColorMode+, configUnicodeMode :: UnicodeMode+, configDiff :: Bool+, configTimes :: Bool+, configAvailableFormatters :: [(String, FormatConfig -> IO Format)]+, configFormat :: Maybe (FormatConfig -> IO Format)+, configFormatter :: Maybe V1.Formatter -- ^ deprecated, use `configFormat` instead+, configHtmlOutput :: Bool+, configConcurrentJobs :: Maybe Int+}++defaultConfig :: Config+defaultConfig = Config {+  configIgnoreConfigFile = False+, configDryRun = False+, configFocusedOnly = False+, configFailOnFocused = False+, configPrintSlowItems = Nothing+, configPrintCpuTime = False+, configFailFast = False+, configRandomize = False+, configFailureReport = Nothing+, configRerun = False+, configRerunAllOnSuccess = False+, configFilterPredicate = Nothing+, configSkipPredicate = Nothing+, configQuickCheckSeed = Nothing+, configQuickCheckMaxSuccess = Nothing+, configQuickCheckMaxDiscardRatio = Nothing+, configQuickCheckMaxSize = Nothing+, configQuickCheckMaxShrinks = Nothing+, configSmallCheckDepth = paramsSmallCheckDepth defaultParams+, configColorMode = ColorAuto+, configUnicodeMode = UnicodeAuto+, configDiff = True+, configTimes = False+, configAvailableFormatters = map (fmap V2.formatterToFormat) [+    ("checks", V2.checks)+  , ("specdoc", V2.specdoc)+  , ("progress", V2.progress)+  , ("failed-examples", V2.failed_examples)+  , ("silent", V2.silent)+  ]+, configFormat = Nothing+, configFormatter = Nothing+, configHtmlOutput = False+, configConcurrentJobs = Nothing+}++option :: String -> OptionSetter config -> String -> Option config+option name arg help = Option name Nothing arg help True++mkFlag :: String -> (Bool -> Config -> Config) -> String -> Option Config+mkFlag name setter = option name (Flag setter)++mkOptionNoArg :: String -> Maybe Char -> (Config -> Config) -> String -> Option Config+mkOptionNoArg name shortcut setter help = Option name shortcut (NoArg setter) help True++mkOption :: String -> Maybe Char -> OptionSetter Config -> String -> Option Config+mkOption name shortcut arg help = Option name shortcut arg help True++undocumented :: Option config -> Option config+undocumented opt = opt {optionDocumented = False}++argument :: String -> (String -> Maybe a) -> (a -> Config -> Config) -> OptionSetter Config+argument name parser setter = Arg name $ \ input c -> flip setter c <$> parser input++formatterOptions :: [(String, FormatConfig -> IO Format)] -> [Option Config]+formatterOptions formatters = [+    mkOption "format" (Just 'f') (argument "FORMATTER" readFormatter setFormatter) helpForFormat+  , mkFlag "color" setColor "colorize the output"+  , mkFlag "unicode" setUnicode "output unicode"+  , mkFlag "diff" setDiff "show colorized diffs"+  , mkFlag "times" setTimes "report times for individual spec items"+  , mkOptionNoArg "print-cpu-time" Nothing setPrintCpuTime "include used CPU time in summary"+  , printSlowItemsOption++    -- undocumented for now, as we probably want to change this to produce a+    -- standalone HTML report in the future+  , undocumented $ mkOptionNoArg "html" Nothing setHtml "produce HTML output"+  ]+  where+    setHtml config = config {configHtmlOutput = True}++    helpForFormat :: String+    helpForFormat = "use a custom formatter; this can be one of " ++ (formatOrList $ map fst formatters)++    readFormatter :: String -> Maybe (FormatConfig -> IO Format)+    readFormatter = (`lookup` formatters)++    setFormatter :: (FormatConfig -> IO Format) -> Config -> Config+    setFormatter f c = c {configFormat = Just f}++    setColor :: Bool -> Config -> Config+    setColor v config = config {configColorMode = if v then ColorAlways else ColorNever}++    setUnicode :: Bool -> Config -> Config+    setUnicode v config = config {configUnicodeMode = if v then UnicodeAlways else UnicodeNever}++    setDiff :: Bool -> Config -> Config+    setDiff v config = config {configDiff = v}++    setTimes :: Bool -> Config -> Config+    setTimes v config = config {configTimes = v}++    setPrintCpuTime config = config {configPrintCpuTime = True}++printSlowItemsOption :: Option Config+printSlowItemsOption = Option name (Just 'p') (OptArg "N" arg) "print the N slowest spec items (default: 10)" True+  where+    name = "print-slow-items"++    setter :: Maybe Int -> Config -> Config+    setter v c = c {configPrintSlowItems = v}++    arg :: Maybe String -> Config -> Maybe Config+    arg = maybe (Just . (setter $ Just 10)) parseArg++    parseArg :: String -> Config -> Maybe Config+    parseArg input c = case readMaybe input of+      Just 0 -> Just (setter Nothing c)+      Just n -> Just (setter (Just n) c)+      Nothing -> Nothing++smallCheckOptions :: [Option Config]+smallCheckOptions = [+    option "depth" (argument "N" readMaybe setDepth) "maximum depth of generated test values for SmallCheck properties"+  ]++setDepth :: Int -> Config -> Config+setDepth n c = c {configSmallCheckDepth = n}++quickCheckOptions :: [Option Config]+quickCheckOptions = [+    Option "qc-max-success" (Just 'a') (argument "N" readMaybe setMaxSuccess) "maximum number of successful tests before a QuickCheck property succeeds" True+  , option "qc-max-discard" (argument "N" readMaybe setMaxDiscardRatio) "maximum number of discarded tests per successful test before giving up"+  , option "qc-max-size" (argument "N" readMaybe setMaxSize) "size to use for the biggest test cases"+  , option "qc-max-shrinks" (argument "N" readMaybe setMaxShrinks) "maximum number of shrinks to perform before giving up (a value of 0 turns shrinking off)"+  , option "seed" (argument "N" readMaybe setSeed) "used seed for QuickCheck properties"++    -- for compatibility with test-framework+  , undocumented $ option "maximum-generated-tests" (argument "NUMBER" readMaybe setMaxSuccess) "how many automated tests something like QuickCheck should try, by default"+  ]++setMaxSuccess :: Int -> Config -> Config+setMaxSuccess n c = c {configQuickCheckMaxSuccess = Just n}++setMaxDiscardRatio :: Int -> Config -> Config+setMaxDiscardRatio n c = c {configQuickCheckMaxDiscardRatio = Just n}++setMaxSize :: Int -> Config -> Config+setMaxSize n c = c {configQuickCheckMaxSize = Just n}++setMaxShrinks :: Int -> Config -> Config+setMaxShrinks n c = c {configQuickCheckMaxShrinks = Just n}++setSeed :: Integer -> Config -> Config+setSeed n c = c {configQuickCheckSeed = Just n}++runnerOptions :: [Option Config]+runnerOptions = [+    mkFlag "dry-run" setDryRun "pretend that everything passed; don't verify anything"+  , mkFlag "focused-only" setFocusedOnly "do not run anything, unless there are focused spec items"+  , mkFlag "fail-on-focused" setFailOnFocused "fail on focused spec items"+  , mkFlag "fail-fast" setFailFast "abort on first failure"+  , mkFlag "randomize" setRandomize "randomize execution order"+  , mkOptionNoArg "rerun" (Just 'r') setRerun "rerun all examples that failed in the previous test run (only works in combination with --failure-report or in GHCi)"+  , option "failure-report" (argument "FILE" return setFailureReport) "read/write a failure report for use with --rerun"+  , mkOptionNoArg "rerun-all-on-success" Nothing setRerunAllOnSuccess "run the whole test suite after a previously failing rerun succeeds for the first time (only works in combination with --rerun)"+  , mkOption "jobs" (Just 'j') (argument "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 :: Bool -> Config -> Config+    setDryRun value config = config {configDryRun = value}++    setFocusedOnly :: Bool -> Config -> Config+    setFocusedOnly value config = config {configFocusedOnly = value}++    setFailOnFocused :: Bool -> Config -> Config+    setFailOnFocused value config = config {configFailOnFocused = value}++    setFailFast :: Bool -> Config -> Config+    setFailFast value config = config {configFailFast = value}++    setRandomize :: Bool -> Config -> Config+    setRandomize value config = config {configRandomize = value}++    setRerun config = config {configRerun = True}+    setRerunAllOnSuccess config = config {configRerunAllOnSuccess = True}++commandLineOnlyOptions :: [Option Config]+commandLineOnlyOptions = [+    mkOptionNoArg "ignore-dot-hspec" Nothing setIgnoreConfigFile "do not read options from ~/.hspec and .hspec"+  , mkOption "match" (Just 'm') (argument "PATTERN" return addMatch) "only run examples that match given PATTERN"+  , option "skip" (argument "PATTERN" return addSkip) "skip examples that match given PATTERN"+  ]+  where+    setIgnoreConfigFile config = config {configIgnoreConfigFile = True}++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}++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_++formatOrList :: [String] -> String+formatOrList xs = case xs of+  [] -> ""+  x : ys -> (case ys of+    [] -> x+    _ : [] -> x ++ " or "+    _ : _ : _ -> x ++ ", ") ++ formatOrList ys
hspec-core/src/Test/Hspec/Core/Config/Options.hs view
@@ -1,336 +1,98 @@+{-# LANGUAGE CPP #-} module Test.Hspec.Core.Config.Options (-  Config(..)-, ColorMode (..)-, defaultConfig-, filterOr-, parseOptions-, ConfigFile-, ignoreConfigFile+  ConfigFile , envVarName+, ignoreConfigFile+, parseOptions ) 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+import           Test.Hspec.Core.Format (Format, FormatConfig)+import           Test.Hspec.Core.Config.Definition+import qualified GetOpt.Declarative as Declarative+import           GetOpt.Declarative.Interpret (parse, interpretOptions, ParseResult(..))  type ConfigFile = (FilePath, [String])- type EnvVar = [String]  envVarName :: String envVarName = "HSPEC_OPTIONS" -data Config = Config {-  configIgnoreConfigFile :: Bool-, configDryRun :: Bool-, configFocusedOnly :: Bool-, configFailOnFocused :: Bool-, configPrintCpuTime :: Bool-, configFastFail :: Bool-, configRandomize :: 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-, configFocusedOnly = False-, configFailOnFocused = False-, configPrintCpuTime = False-, configFastFail = False-, configRandomize = 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 = concat [-    mkFlag "dry-run" setDryRun "pretend that everything passed; don't verify anything"-  , mkFlag "focused-only" setFocusedOnly "do not run anything, unless there are focused spec items"-  , mkFlag "fail-on-focused" setFailOnFocused "fail on focused spec items"-  , mkFlag "fail-fast" setFastFail "abort on first failure"-  , mkFlag "randomize" setRandomize "randomize execution order"-  ] ++ [-    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 :: Bool -> Config -> Config-    setDryRun value config = config {configDryRun = value}--    setFocusedOnly :: Bool -> Config -> Config-    setFocusedOnly value config = config {configFocusedOnly = value}--    setFailOnFocused :: Bool -> Config -> Config-    setFailOnFocused value config = config {configFailOnFocused = value}--    setFastFail :: Bool -> Config -> Config-    setFastFail value config = config {configFastFail = value}--    setRandomize :: Bool -> Config -> Config-    setRandomize value config = config {configRandomize = value}--    setRerun        = set $ \config -> config {configRerun = True}-    setRerunAllOnSuccess = set $ \config -> config {configRerunAllOnSuccess = True}+commandLineOptions :: [(String, FormatConfig -> IO Format)] -> [(String, [Declarative.Option Config])]+commandLineOptions formatters =+    ("OPTIONS", commandLineOnlyOptions)+  : otherOptions formatters -documentedConfigFileOptions :: Monad m => [(String, [OptDescr (Result m -> Result m)])]-documentedConfigFileOptions = [+otherOptions :: [(String, FormatConfig -> IO Format)] -> [(String, [Declarative.Option Config])]+otherOptions formatters = [     ("RUNNER OPTIONS", runnerOptions)-  , ("FORMATTER OPTIONS", formatterOptions)+  , ("FORMATTER OPTIONS", formatterOptions formatters)   , ("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+ignoreConfigFile :: Config -> [String] -> IO Bool+ignoreConfigFile config args = do+  ignore <- lookupEnv "IGNORE_DOT_HSPEC"+  case ignore of+    Just _ -> return True+    Nothing -> case parseCommandLineOptions "" args config of+      Right c -> return (configIgnoreConfigFile c)+      _ -> return False -parseOptions :: Config -> String -> [ConfigFile] -> Maybe EnvVar -> [String] -> Either (ExitCode, String) Config-parseOptions config prog configFiles envVar args = do+parseOptions :: Config -> String -> [ConfigFile] -> Maybe EnvVar -> [(String, String)] -> [String] -> Either (ExitCode, String) ([String], Config)+parseOptions config prog configFiles envVar env args = do       foldM (parseFileOptions prog) config configFiles-  >>= parseEnvVarOptions prog envVar-  >>= parseCommandLineOptions prog args+  >>= maybe return (parseEnvVarOptions prog) envVar+  >>= parseEnvironmentOptions env+  >>= traverseTuple (parseCommandLineOptions prog args) +traverseTuple :: Applicative f => (a -> f b) -> (c, a) -> f (c, b)+#if MIN_VERSION_base(4,7,0)+traverseTuple = traverse+#else+traverseTuple f (c, a) = (,) c <$> f a+#endif+ 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+parseCommandLineOptions prog args config = case Declarative.parseCommandLineOptions (commandLineOptions formatters) prog args config of+  Success c -> Right c+  Help message -> Left (ExitSuccess, message)+  Failure message -> Left (ExitFailure 1, message)   where-    failure err = Left (ExitFailure 1, prog ++ ": " ++ err ++ "\nTry `" ++ prog ++ " --help' for more information.\n")+    formatters = configAvailableFormatters config -    usage :: String-    usage = "Usage: " ++ prog ++ " [OPTION]...\n\n"-      ++ (intercalate "\n" $ map (uncurry mkUsageInfo) documentedOptions)+parseEnvironmentOptions :: [(String, String)] -> Config -> Either (ExitCode, String) ([String], Config)+parseEnvironmentOptions env config = case Declarative.parseEnvironmentOptions "HSPEC" env config (concatMap snd $ commandLineOptions formatters) of+  (warnings, c) -> Right (map formatWarning warnings, c)+  where+    formatters = configAvailableFormatters config+    formatWarning (Declarative.InvalidValue name value) = "invalid value `" ++ value ++ "' for environment variable " ++ name  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)+parseEnvVarOptions :: String -> EnvVar -> Config -> Either (ExitCode, String) Config+parseEnvVarOptions prog =+  parseOtherOptions prog ("from environment variable " ++ envVarName)  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+parseOtherOptions prog source args config = case parse (interpretOptions options) config args of+  Right c -> Right c   Left err -> failure err   where+    options :: [Declarative.Option Config]+    options = filter Declarative.optionDocumented $ concatMap snd (otherOptions formatters)++    formatters = configAvailableFormatters config+     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
− hspec-core/src/Test/Hspec/Core/Config/Util.hs 
@@ -1,37 +0,0 @@-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
hspec-core/src/Test/Hspec/Core/Example.hs view
@@ -21,6 +21,9 @@ , safeEvaluateExample ) where +import           Prelude ()+import           Test.Hspec.Core.Compat+ import qualified Test.HUnit.Lang as HUnit  import           Data.CallStack@@ -36,7 +39,6 @@  import           Test.Hspec.Core.QuickCheckUtil import           Test.Hspec.Core.Util-import           Test.Hspec.Core.Compat import           Test.Hspec.Core.Example.Location  -- | A type class for examples
hspec-core/src/Test/Hspec/Core/Example/Location.hs view
@@ -14,7 +14,6 @@ import           Test.Hspec.Core.Compat  import           Control.Exception-import           Data.List import           Data.Char import           Data.Maybe import           GHC.IO.Exception@@ -77,7 +76,11 @@  fromPatternMatchFailureInDoExpression :: String -> Maybe Location fromPatternMatchFailureInDoExpression input =+#if MIN_VERSION_base(4,16,0)+  stripPrefix "Pattern match failure in 'do' block at " input >>= parseSourceSpan+#else   stripPrefix "Pattern match failure in do expression at " input >>= parseSourceSpan+#endif  parseCallStack :: String -> Maybe Location parseCallStack input = case reverse (lines input) of
hspec-core/src/Test/Hspec/Core/FailureReport.hs view
@@ -9,13 +9,13 @@ import           Test.Hspec.Core.Compat  #ifndef __GHCJS__-import           System.SetEnv+import           System.SetEnv (setEnv) import           Test.Hspec.Core.Util (safeTry) #endif import           System.IO import           System.Directory import           Test.Hspec.Core.Util (Path)-import           Test.Hspec.Core.Config.Options (Config(..))+import           Test.Hspec.Core.Config.Definition (Config(..))  data FailureReport = FailureReport {   failureReportSeed :: Integer
hspec-core/src/Test/Hspec/Core/Format.hs view
@@ -1,6 +1,11 @@ {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ExistentialQuantification #-}+-- |+-- Stability: experimental module Test.Hspec.Core.Format (-  Format(..)+  Format+, FormatConfig(..)+, Event(..) , Progress , Path , Location(..)@@ -8,13 +13,25 @@ , Item(..) , Result(..) , FailureReason(..)+, monadic ) where +import           Prelude ()+import           Test.Hspec.Core.Compat++import           Control.Exception+import           Control.Concurrent+import           Control.Concurrent.Async (async)+import qualified Control.Concurrent.Async as Async+import           Control.Monad.IO.Class+ import           Test.Hspec.Core.Spec (Progress, Location(..)) import           Test.Hspec.Core.Example (FailureReason(..)) import           Test.Hspec.Core.Util (Path)-import           Test.Hspec.Core.Clock+import           Test.Hspec.Core.Clock (Seconds(..)) +type Format = Event -> IO ()+ data Item = Item {   itemLocation :: Maybe Location , itemDuration :: Seconds@@ -24,14 +41,72 @@  data Result =     Success-  | Pending (Maybe String)-  | Failure FailureReason+  | Pending (Maybe Location) (Maybe String)+  | Failure (Maybe Location) FailureReason   deriving Show -data Format m = Format {-  formatRun :: forall a. m a -> IO a-, formatGroupStarted :: Path -> m ()-, formatGroupDone :: Path -> m ()-, formatProgress :: Path -> Progress -> m ()-, formatItem :: Path -> Item -> m ()-}+data Event =+    Started+  | GroupStarted Path+  | GroupDone Path+  | Progress Path Progress+  | ItemStarted Path+  | ItemDone Path Item+  | Done [(Path, Item)]+  deriving Show++data FormatConfig = FormatConfig {+  formatConfigUseColor :: Bool+, formatConfigOutputUnicode :: Bool+, formatConfigUseDiff :: Bool+, formatConfigPrintTimes :: Bool+, formatConfigHtmlOutput :: Bool+, formatConfigPrintCpuTime :: Bool+, formatConfigUsedSeed :: Integer+, formatConfigExpectedTotalCount :: Int+} deriving (Eq, Show)++data Signal = Ok | NotOk SomeException++monadic :: MonadIO m => (m () -> IO ()) -> (Event -> m ()) -> IO Format+monadic run format = do+  mvar <- newEmptyMVar+  done <- newEmptyMVar++  let+    putEvent :: Event -> IO ()+    putEvent = putMVar mvar++    takeEvent :: MonadIO m => m Event+    takeEvent = liftIO $ takeMVar mvar++    signal :: MonadIO m => Signal -> m ()+    signal = liftIO . putMVar done++    wait :: IO Signal+    wait = takeMVar done++    go = do+      event <- takeEvent+      format event+      case event of+        Done {} -> return ()+        _ -> do+          signal Ok+          go++  t <- async $ do+    (run go >> signal Ok) `catch` (signal . NotOk)++  return $ \ event -> do+    running <- Async.poll t+    case running of+      Just _ -> return ()+      Nothing -> do+        putEvent event+        r <- wait+        case r of+          Ok -> return ()+          NotOk err -> do+            Async.wait t+            throwIO err
hspec-core/src/Test/Hspec/Core/Formatters.hs view
@@ -1,278 +1,2 @@-{-# LANGUAGE CPP #-}--- |--- Stability: experimental------ This module contains formatters that can be used with--- `Test.Hspec.Core.Runner.hspecWith`.-module Test.Hspec.Core.Formatters (---- * Formatters-  silent-, specdoc-, progress-, failed_examples---- * Implementing a custom Formatter--- |--- A formatter is a set of actions.  Each action is evaluated when a certain--- situation is encountered during a test run.------ Actions live in the `FormatM` monad.  It provides access to the runner state--- and primitives for appending to the generated report.-, Formatter (..)-, FailureReason (..)-, FormatM---- ** Accessing the runner state-, getSuccessCount-, getPendingCount-, getFailCount-, getTotalCount--, FailureRecord (..)-, getFailMessages-, usedSeed--, Seconds(..)-, getCPUTime-, getRealTime---- ** Appending to the generated report-, write-, writeLine-, writeTransient---- ** Dealing with colors-, withInfoColor-, withSuccessColor-, withPendingColor-, withFailColor--, useDiff-, extraChunk-, missingChunk---- ** Helpers-, formatException-) where--import           Prelude ()-import           Test.Hspec.Core.Compat hiding (First)--import           Data.Maybe-import           Test.Hspec.Core.Util-import           Test.Hspec.Core.Clock-import           Test.Hspec.Core.Spec (Location(..))-import           Text.Printf-import           Control.Monad.IO.Class-import           Control.Exception---- We use an explicit import list for "Test.Hspec.Formatters.Internal", to make--- sure, that we only use the public API to implement formatters.------ Everything imported here has to be re-exported, so that users can implement--- their own formatters.-import Test.Hspec.Core.Formatters.Monad (-    Formatter (..)-  , FailureReason (..)-  , FormatM--  , getSuccessCount-  , getPendingCount-  , getFailCount-  , getTotalCount--  , FailureRecord (..)-  , getFailMessages-  , usedSeed--  , getCPUTime-  , getRealTime--  , write-  , writeLine-  , writeTransient--  , withInfoColor-  , withSuccessColor-  , withPendingColor-  , withFailColor--  , useDiff-  , extraChunk-  , missingChunk-  )--import           Test.Hspec.Core.Formatters.Diff--silent :: Formatter-silent = Formatter {-  headerFormatter     = return ()-, exampleGroupStarted = \_ _ -> return ()-, exampleGroupDone    = return ()-, exampleProgress     = \_ _ -> return ()-, exampleSucceeded    = \ _ _ -> return ()-, exampleFailed       = \_ _ _ -> return ()-, examplePending      = \_ _ _ -> return ()-, failedFormatter     = return ()-, footerFormatter     = return ()-}--specdoc :: Formatter-specdoc = silent {--  headerFormatter = do-    writeLine ""--, exampleGroupStarted = \nesting name -> do-    writeLine (indentationFor nesting ++ name)--, exampleProgress = \_ p -> do-    writeTransient (formatProgress p)--, exampleSucceeded = \(nesting, requirement) info -> withSuccessColor $ do-    writeLine $ indentationFor nesting ++ requirement-    forM_ (lines info) $ \ s ->-      writeLine $ indentationFor ("" : nesting) ++ s--, exampleFailed = \(nesting, requirement) info _ -> withFailColor $ do-    n <- getFailCount-    writeLine $ indentationFor nesting ++ requirement ++ " FAILED [" ++ show n ++ "]"-    forM_ (lines info) $ \ s ->-      writeLine $ indentationFor ("" : nesting) ++ s--, examplePending = \(nesting, requirement) info reason -> withPendingColor $ do-    writeLine $ indentationFor nesting ++ requirement-    forM_ (lines info) $ \ s ->-      writeLine $ indentationFor ("" : nesting) ++ s-    writeLine $ indentationFor ("" : nesting) ++ "# PENDING: " ++ fromMaybe "No reason given" reason--, failedFormatter = defaultFailedFormatter--, footerFormatter = defaultFooter-} where-    indentationFor nesting = replicate (length nesting * 2) ' '-    formatProgress (current, total)-      | total == 0 = show current-      | otherwise  = show current ++ "/" ++ show total---progress :: Formatter-progress = silent {-  exampleSucceeded = \_ _ -> withSuccessColor $ write "."-, exampleFailed    = \_ _ _ -> withFailColor    $ write "F"-, examplePending   = \_ _ _ -> withPendingColor $ write "."-, failedFormatter  = defaultFailedFormatter-, footerFormatter  = defaultFooter-}---failed_examples :: Formatter-failed_examples   = silent {-  failedFormatter = defaultFailedFormatter-, footerFormatter = defaultFooter-}--defaultFailedFormatter :: FormatM ()-defaultFailedFormatter = do-  writeLine ""--  failures <- getFailMessages--  unless (null failures) $ do-    writeLine "Failures:"-    writeLine ""--    forM_ (zip [1..] failures) $ \x -> do-      formatFailure x-      writeLine ""--#if __GLASGOW_HASKELL__ == 800-    withFailColor $ do-      writeLine "WARNING:"-      writeLine "  Your version of GHC is affected by https://ghc.haskell.org/trac/ghc/ticket/13285."-      writeLine "  Source locations may not work as expected."-      writeLine ""-      writeLine "  Please consider upgrading GHC!"-      writeLine ""-#endif--    write "Randomized with seed " >> usedSeed >>= writeLine . show-    writeLine ""-  where-    formatFailure :: (Int, FailureRecord) -> FormatM ()-    formatFailure (n, FailureRecord mLoc path reason) = do-      forM_ mLoc $ \loc -> do-        withInfoColor $ writeLine (formatLoc loc)-      write ("  " ++ show n ++ ") ")-      writeLine (formatRequirement path)-      case reason of-        NoReason -> return ()-        Reason err -> withFailColor $ indent err-        ExpectedButGot preface expected actual -> do-          mapM_ indent preface--          b <- useDiff--          let threshold = 2 :: Seconds--          mchunks <- liftIO $ if b-            then timeout threshold (evaluate $ diff expected actual)-            else return Nothing--          case mchunks of-            Just chunks -> do-              writeDiff chunks extraChunk missingChunk-            Nothing -> do-              writeDiff [First expected, Second actual] write write-          where-            indented output text = case break (== '\n') text of-              (xs, "") -> output xs-              (xs, _ : ys) -> output (xs ++ "\n") >> write (indentation ++ "          ") >> indented output ys--            writeDiff chunks extra missing = do-              withFailColor $ write (indentation ++ "expected: ")-              forM_ chunks $ \ chunk -> case chunk of-                Both a _ -> indented write a-                First a -> indented extra a-                Second _ -> return ()-              writeLine ""--              withFailColor $ write (indentation ++ " but got: ")-              forM_ chunks $ \ chunk -> case chunk of-                Both a _ -> indented write a-                First _ -> return ()-                Second a -> indented missing a-              writeLine ""--        Error _ e -> withFailColor . indent $ (("uncaught exception: " ++) . formatException) e--      writeLine ""-      writeLine ("  To rerun use: --match " ++ show (joinPath path))-      where-        indentation = "       "-        indent message = do-          forM_ (lines message) $ \line -> do-            writeLine (indentation ++ line)-        formatLoc (Location file line column) = "  " ++ file ++ ":" ++ show line ++ ":" ++ show column ++ ": "--defaultFooter :: FormatM ()-defaultFooter = do--  writeLine =<< (++)-    <$> (printf "Finished in %1.4f seconds" <$> getRealTime)-    <*> (maybe "" (printf ", used %1.4f seconds of CPU time") <$> getCPUTime)--  fails   <- getFailCount-  pending <- getPendingCount-  total   <- getTotalCount--  let-    output =-         pluralize total   "example"-      ++ ", " ++ pluralize fails "failure"-      ++ if pending == 0 then "" else ", " ++ show pending ++ " pending"-    c | fails /= 0   = withFailColor-      | pending /= 0 = withPendingColor-      | otherwise    = withSuccessColor-  c $ writeLine output+module Test.Hspec.Core.Formatters (module V1) where+import           Test.Hspec.Core.Formatters.V1 as V1
hspec-core/src/Test/Hspec/Core/Formatters/Diff.hs view
@@ -13,7 +13,6 @@ import           Test.Hspec.Core.Compat  import           Data.Char-import           Data.List (stripPrefix) import           Data.Algorithm.Diff  diff :: String -> String -> [Diff String]
− hspec-core/src/Test/Hspec/Core/Formatters/Free.hs 
@@ -1,22 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-module Test.Hspec.Core.Formatters.Free where--import           Prelude ()-import           Test.Hspec.Core.Compat--data Free f a = Free (f (Free f a)) | Pure a-  deriving Functor--instance Functor f => Applicative (Free f) where-  pure = Pure-  Pure f <*> Pure a = Pure (f a)-  Pure f <*> Free m = Free (fmap f <$> m)-  Free m <*> b = Free (fmap (<*> b) m)--instance Functor f => Monad (Free f) where-  return = pure-  Pure a >>= f = f a-  Free m >>= f = Free (fmap (>>= f) m)--liftF :: Functor f => f a -> Free f a-liftF command = Free (fmap Pure command)
hspec-core/src/Test/Hspec/Core/Formatters/Internal.hs view
@@ -1,14 +1,43 @@-{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-} module Test.Hspec.Core.Formatters.Internal (-  FormatM-, FormatConfig(..)-, runFormatM-, interpret-, increaseSuccessCount-, increasePendingCount-, addFailMessage-, finally_+  Formatter(..)+, Item(..)+, Result(..)+, FailureReason(..)+, FormatM , formatterToFormat++, getSuccessCount+, getPendingCount+, getFailCount+, getTotalCount+, getExpectedTotalCount++, FailureRecord(..)+, getFailMessages+, usedSeed++, printTimes+, getCPUTime+, getRealTime++, write+, writeLine+, writeTransient++, withInfoColor+, withSuccessColor+, withPendingColor+, withFailColor++, outputUnicode++, useDiff+, extraChunk+, missingChunk+ #ifdef TEST , overwriteWith #endif@@ -18,65 +47,82 @@ import           Test.Hspec.Core.Compat  import qualified System.IO as IO-import           System.IO (Handle)-import           Control.Exception (AsyncException(..), bracket_, try, throwIO)+import           System.IO (Handle, stdout)+import           Control.Exception (bracket_) import           System.Console.ANSI import           Control.Monad.Trans.State hiding (state, gets, modify) import           Control.Monad.IO.Class import           Data.Char (isSpace) import qualified System.CPUTime as CPUTime -import qualified Test.Hspec.Core.Formatters.Monad as M-import           Test.Hspec.Core.Formatters.Monad (Environment(..), interpretWith, FailureRecord(..))+import           Test.Hspec.Core.Formatters.V1.Monad (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+data Formatter = Formatter {+-- | evaluated before a test run+  formatterStarted :: FormatM () -interpret :: M.FormatM a -> FormatM a-interpret = interpretWith Environment {-  environmentGetSuccessCount = getSuccessCount-, environmentGetPendingCount = getPendingCount-, environmentGetFailMessages = getFailMessages-, environmentUsedSeed = usedSeed-, environmentGetCPUTime = getCPUTime-, environmentGetRealTime = getRealTime-, environmentWrite = write-, environmentWriteTransient = writeTransient-, environmentWithFailColor = withFailColor-, environmentWithSuccessColor = withSuccessColor-, environmentWithPendingColor = withPendingColor-, environmentWithInfoColor = withInfoColor-, environmentUseDiff = gets (formatConfigUseDiff . stateConfig)-, environmentExtraChunk = extraChunk-, environmentMissingChunk = missingChunk-, environmentLiftIO = liftIO+-- | evaluated before each spec group+, formatterGroupStarted :: Path -> FormatM ()++-- | evaluated after each spec group+, formatterGroupDone :: Path -> FormatM ()++-- | used to notify the progress of the currently evaluated example+, formatterProgress :: Path -> Progress -> FormatM ()++-- | evaluated before each spec item+, formatterItemStarted :: Path -> FormatM ()++-- | evaluated after each spec item+, formatterItemDone :: Path -> Item -> FormatM ()++-- | evaluated after a test run+, formatterDone :: FormatM () } +formatterToFormat :: Formatter -> FormatConfig -> IO Format+formatterToFormat Formatter{..} config = monadic (runFormatM config) $ \ event -> case event of+  Started -> formatterStarted+  GroupStarted path -> formatterGroupStarted path+  GroupDone path -> formatterGroupDone path+  Progress path progress -> formatterProgress path progress+  ItemStarted path -> formatterItemStarted path+  ItemDone path item -> do+    clearTransientOutput+    case itemResult item of+      Success {} -> increaseSuccessCount+      Pending {} -> increasePendingCount+      Failure loc err -> addFailMessage (loc <|> itemLocation item) path err+    formatterItemDone path item+  Done _ -> formatterDone++-- | Get the number of failed examples encountered so far.+getFailCount :: FormatM Int+getFailCount = length <$> getFailMessages++-- | Return `True` if the user requested colorized diffs, `False` otherwise.+useDiff :: FormatM Bool+useDiff = getConfig formatConfigUseDiff++-- | Return `True` if the user requested unicode output, `False` otherwise.+outputUnicode :: FormatM Bool+outputUnicode = getConfig formatConfigOutputUnicode++-- | The same as `write`, but adds a newline character.+writeLine :: String -> FormatM ()+writeLine s = write s >> write "\n"++-- | Return `True` if the user requested time reporting for individual spec+-- items, `False` otherwise.+printTimes :: FormatM Bool+printTimes = gets (formatConfigPrintTimes . stateConfig)++-- | Get the total number of examples encountered so far.+getTotalCount :: FormatM Int+getTotalCount = sum <$> sequence [getSuccessCount, getFailCount, getPendingCount]+ -- | A lifted version of `Control.Monad.Trans.State.gets` gets :: (FormatterState -> a) -> FormatM a gets f = FormatM $ do@@ -87,15 +133,6 @@ modify f = FormatM $ do   get >>= liftIO . (`modifyIORef'` f) -data FormatConfig = FormatConfig {-  formatConfigHandle :: Handle-, formatConfigUseColor :: Bool-, formatConfigUseDiff :: Bool-, formatConfigHtmlOutput :: Bool-, formatConfigPrintCpuTime :: Bool-, formatConfigUsedSeed :: Integer-} deriving (Eq, Show)- data FormatterState = FormatterState {   stateSuccessCount    :: !Int , statePendingCount    :: !Int@@ -110,7 +147,7 @@ getConfig f = gets (f . stateConfig)  getHandle :: FormatM Handle-getHandle = getConfig formatConfigHandle+getHandle = return stdout  -- | The random seed that is used for QuickCheck. usedSeed :: FormatM Integer@@ -152,6 +189,11 @@ getFailMessages :: FormatM [FailureRecord] getFailMessages = reverse `fmap` gets stateFailMessages +-- | Get the number of spec items that will have been encountered when this run+-- completes (if it is not terminated early).+getExpectedTotalCount :: FormatM Int+getExpectedTotalCount = getConfig formatConfigExpectedTotalCount+ overwriteWith :: String -> String -> String overwriteWith old new   | n == 0 = new@@ -161,11 +203,13 @@  writeTransient :: String -> FormatM () writeTransient new = do-  old <- gets stateTransientOutput-  write $ old `overwriteWith` new-  modify $ \ state -> state {stateTransientOutput = new}-  h <- getHandle-  liftIO $ IO.hFlush h+  useColor <- getConfig formatConfigUseColor+  when (useColor) $ do+    old <- gets stateTransientOutput+    write $ old `overwriteWith` new+    modify $ \ state -> state {stateTransientOutput = new}+    h <- getHandle+    liftIO $ IO.hFlush h  clearTransientOutput :: FormatM () clearTransientOutput = do@@ -229,8 +273,8 @@ -- | Output given chunk in red. extraChunk :: String -> FormatM () extraChunk s = do-  useDiff <- getConfig formatConfigUseDiff-  case useDiff of+  diff <- getConfig formatConfigUseDiff+  case diff of     True -> extra s     False -> write s   where@@ -240,8 +284,8 @@ -- | Output given chunk in green. missingChunk :: String -> FormatM () missingChunk s = do-  useDiff <- getConfig formatConfigUseDiff-  case useDiff of+  diff <- getConfig formatConfigUseDiff+  case diff of     True -> missing s     False -> write s   where@@ -255,22 +299,6 @@     layer       | all isSpace s = Background       | otherwise = Foreground---- |--- @finally_ actionA actionB@ runs @actionA@ and then @actionB@.  @actionB@ is--- run even when a `UserInterrupt` occurs during @actionA@.-finally_ :: FormatM a -> FormatM () -> FormatM a-finally_ (FormatM actionA) (FormatM actionB) = FormatM . StateT $ \st -> do-  r <- try (runStateT actionA st)-  case r of-    Left e -> do-      when (e == UserInterrupt) $-        runStateT actionB st >> return ()-      throwIO e-    Right (a, st_) -> do-      runStateT actionB st_ >>= return . replaceValue a-  where-    replaceValue a (_, st) = (a, st)  -- | Get the used CPU time since the test run has been started. getCPUTime :: FormatM (Maybe Seconds)
− hspec-core/src/Test/Hspec/Core/Formatters/Monad.hs 
@@ -1,246 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE ExistentialQuantification #-}-module Test.Hspec.Core.Formatters.Monad (-  Formatter (..)-, FailureReason (..)-, FormatM--, getSuccessCount-, getPendingCount-, getFailCount-, getTotalCount--, FailureRecord (..)-, getFailMessages-, usedSeed--, getCPUTime-, getRealTime--, write-, writeLine-, writeTransient--, withInfoColor-, withSuccessColor-, withPendingColor-, withFailColor--, useDiff-, extraChunk-, missingChunk--, Environment(..)-, interpretWith-) where--import           Prelude ()-import           Test.Hspec.Core.Compat--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-, exampleGroupStarted :: [String] -> String -> FormatM ()--, exampleGroupDone :: FormatM ()---- | used to notify the progress of the currently evaluated example------ /Note/: This is only called when interactive/color mode.-, exampleProgress :: Path -> Progress -> FormatM ()---- | evaluated after each successful example-, exampleSucceeded :: Path -> String -> FormatM ()---- | evaluated after each failed example-, exampleFailed :: Path -> String -> FailureReason -> FormatM ()---- | evaluated after each pending example-, examplePending :: Path -> String -> Maybe String -> FormatM ()---- | evaluated after a test run-, failedFormatter :: FormatM ()---- | evaluated after `failuresFormatter`-, footerFormatter :: FormatM ()-}--data FailureRecord = FailureRecord {-  failureRecordLocation :: Maybe Location-, failureRecordPath     :: Path-, failureRecordMessage  :: FailureReason-}--data FormatF next =-    GetSuccessCount (Int -> next)-  | GetPendingCount (Int -> next)-  | GetFailMessages ([FailureRecord] -> next)-  | UsedSeed (Integer -> 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)-  | forall a. WithInfoColor (FormatM a) (a -> next)-  | UseDiff (Bool -> next)-  | ExtraChunk String next-  | MissingChunk String next-  | forall a. LiftIO (IO a) (a -> next)--instance Functor FormatF where -- deriving this instance would require GHC >= 7.10.1-  fmap f x = case x of-    GetSuccessCount next -> GetSuccessCount (fmap f next)-    GetPendingCount next -> GetPendingCount (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)-    WithInfoColor action next -> WithInfoColor action (fmap f next)-    UseDiff next -> UseDiff (fmap f next)-    ExtraChunk s next -> ExtraChunk s (f next)-    MissingChunk s next -> MissingChunk s (f next)-    LiftIO action next -> LiftIO action (fmap f next)--type FormatM = Free FormatF--instance MonadIO FormatM where-  liftIO s = liftF (LiftIO s id)--data Environment m = Environment {-  environmentGetSuccessCount :: m Int-, environmentGetPendingCount :: m Int-, environmentGetFailMessages :: m [FailureRecord]-, environmentUsedSeed :: m Integer-, 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-, environmentWithInfoColor :: forall a. m a -> m a-, environmentUseDiff :: m Bool-, environmentExtraChunk :: String -> m ()-, environmentMissingChunk :: String -> m ()-, environmentLiftIO :: forall a. IO a -> m a-}--interpretWith :: forall m a. Monad m => Environment m -> FormatM a -> m a-interpretWith Environment{..} = go-  where-    go :: forall b. FormatM b -> m b-    go m = case m of-      Pure value -> return value-      Free action -> case action of-        GetSuccessCount next -> environmentGetSuccessCount >>= go . next-        GetPendingCount next -> environmentGetPendingCount >>= 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-        WithInfoColor inner next -> environmentWithInfoColor (go inner) >>= go . next-        UseDiff next -> environmentUseDiff >>= go . next-        ExtraChunk s next -> environmentExtraChunk s >> go next-        MissingChunk s next -> environmentMissingChunk s >> go next-        LiftIO inner next -> environmentLiftIO inner >>= go . next---- | Get the number of successful examples encountered so far.-getSuccessCount :: FormatM Int-getSuccessCount = liftF (GetSuccessCount id)---- | Get the number of pending examples encountered so far.-getPendingCount :: FormatM Int-getPendingCount = liftF (GetPendingCount id)---- | Get the number of failed examples encountered so far.-getFailCount :: FormatM Int-getFailCount = length <$> getFailMessages---- | Get the total number of examples encountered so far.-getTotalCount :: FormatM Int-getTotalCount = sum <$> sequence [getSuccessCount, getFailCount, getPendingCount]---- | Get the list of accumulated failure messages.-getFailMessages :: FormatM [FailureRecord]-getFailMessages = liftF (GetFailMessages id)---- | The random seed that is used for QuickCheck.-usedSeed :: FormatM Integer-usedSeed = liftF (UsedSeed id)---- | Get the used CPU time since the test run has been started.-getCPUTime :: FormatM (Maybe Seconds)-getCPUTime = liftF (GetCPUTime id)---- | Get the passed real time since the test run has been started.-getRealTime :: FormatM Seconds-getRealTime = liftF (GetRealTime id)---- | Append some output to the report.-write :: String -> FormatM ()-write s = liftF (Write s ())---- | 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.-withFailColor :: FormatM a -> FormatM a-withFailColor s = liftF (WithFailColor s id)---- | Set output color to green, run given action, and finally restore the--- default color.-withSuccessColor :: FormatM a -> FormatM a-withSuccessColor s = liftF (WithSuccessColor s id)---- | Set output color to yellow, run given action, and finally restore the--- default color.-withPendingColor :: FormatM a -> FormatM a-withPendingColor s = liftF (WithPendingColor s id)---- | Set output color to cyan, run given action, and finally restore the--- default color.-withInfoColor :: FormatM a -> FormatM a-withInfoColor s = liftF (WithInfoColor s id)---- | Return `True` if the user requested colorized diffs, `False` otherwise.-useDiff :: FormatM Bool-useDiff = liftF (UseDiff id)---- | Output given chunk in red.-extraChunk :: String -> FormatM ()-extraChunk s = liftF (ExtraChunk s ())---- | Output given chunk in green.-missingChunk :: String -> FormatM ()-missingChunk s = liftF (MissingChunk s ())
+ hspec-core/src/Test/Hspec/Core/Formatters/V1.hs view
@@ -0,0 +1,349 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+-- |+-- Stability: deprecated+--+-- This module contains formatters that can be used with+-- `Test.Hspec.Core.Runner.hspecWith`.+module Test.Hspec.Core.Formatters.V1 (++-- * Formatters+  silent+, checks+, specdoc+, progress+, failed_examples++-- * Implementing a custom Formatter+-- |+-- A formatter is a set of actions.  Each action is evaluated when a certain+-- situation is encountered during a test run.+--+-- Actions live in the `FormatM` monad.  It provides access to the runner state+-- and primitives for appending to the generated report.+, Formatter (..)+, FailureReason (..)+, FormatM+, formatterToFormat++-- ** Accessing the runner state+, getSuccessCount+, getPendingCount+, getFailCount+, getTotalCount++, FailureRecord (..)+, getFailMessages+, usedSeed++, Seconds(..)+, getCPUTime+, getRealTime++-- ** Appending to the generated report+, write+, writeLine+, writeTransient++-- ** Dealing with colors+, withInfoColor+, withSuccessColor+, withPendingColor+, withFailColor++, useDiff+, extraChunk+, missingChunk++-- ** Helpers+, formatException+) where++import           Prelude ()+import           Test.Hspec.Core.Compat hiding (First)++import           Data.Maybe+import           Test.Hspec.Core.Util+import           Test.Hspec.Core.Clock+import           Test.Hspec.Core.Spec (Location(..))+import           Text.Printf+import           Control.Monad.IO.Class+import           Control.Exception++-- We use an explicit import list for "Test.Hspec.Formatters.Internal", to make+-- sure, that we only use the public API to implement formatters.+--+-- Everything imported here has to be re-exported, so that users can implement+-- their own formatters.+import Test.Hspec.Core.Formatters.V1.Monad (+    Formatter(..)+  , FailureReason(..)+  , FormatM++  , getSuccessCount+  , getPendingCount+  , getFailCount+  , getTotalCount++  , FailureRecord(..)+  , getFailMessages+  , usedSeed++  , getCPUTime+  , getRealTime++  , write+  , writeLine+  , writeTransient++  , withInfoColor+  , withSuccessColor+  , withPendingColor+  , withFailColor++  , useDiff+  , extraChunk+  , missingChunk+  )++import           Test.Hspec.Core.Format (FormatConfig, Format)++import           Test.Hspec.Core.Formatters.Diff+import qualified Test.Hspec.Core.Formatters.V2 as V2+import           Test.Hspec.Core.Formatters.V1.Monad (Item(..), Result(..), Environment(..), interpretWith)++formatterToFormat :: Formatter -> FormatConfig -> IO Format+formatterToFormat = V2.formatterToFormat . legacyFormatterToFormatter++legacyFormatterToFormatter :: Formatter -> V2.Formatter+legacyFormatterToFormatter Formatter{..} = V2.Formatter {+  V2.formatterStarted = interpret headerFormatter+, V2.formatterGroupStarted = interpret . uncurry exampleGroupStarted+, V2.formatterGroupDone = interpret . const exampleGroupDone+, V2.formatterProgress = \ path -> interpret . exampleProgress path+, V2.formatterItemStarted = interpret . exampleStarted+, V2.formatterItemDone = \ path item -> interpret $ do+    case itemResult item of+      Success -> exampleSucceeded path (itemInfo item)+      Pending _ reason -> examplePending path (itemInfo item) reason+      Failure _ reason -> exampleFailed path (itemInfo item) reason+, V2.formatterDone = interpret $ failedFormatter >> footerFormatter+}++interpret :: FormatM a -> V2.FormatM a+interpret = interpretWith Environment {+  environmentGetSuccessCount = V2.getSuccessCount+, environmentGetPendingCount = V2.getPendingCount+, environmentGetFailMessages = V2.getFailMessages+, environmentUsedSeed = V2.usedSeed+, environmentPrintTimes = V2.printTimes+, environmentGetCPUTime = V2.getCPUTime+, environmentGetRealTime = V2.getRealTime+, environmentWrite = V2.write+, environmentWriteTransient = V2.writeTransient+, environmentWithFailColor = V2.withFailColor+, environmentWithSuccessColor = V2.withSuccessColor+, environmentWithPendingColor = V2.withPendingColor+, environmentWithInfoColor = V2.withInfoColor+, environmentUseDiff = V2.useDiff+, environmentExtraChunk = V2.extraChunk+, environmentMissingChunk = V2.missingChunk+, environmentLiftIO = liftIO+}++silent :: Formatter+silent = Formatter {+  headerFormatter     = return ()+, exampleGroupStarted = \_ _ -> return ()+, exampleGroupDone    = return ()+, exampleStarted      = \_ -> return ()+, exampleProgress     = \_ _ -> return ()+, exampleSucceeded    = \ _ _ -> return ()+, exampleFailed       = \_ _ _ -> return ()+, examplePending      = \_ _ _ -> return ()+, failedFormatter     = return ()+, footerFormatter     = return ()+}++checks :: Formatter+checks = specdoc {+  exampleStarted = \(nesting, requirement) -> do+    writeTransient $ indentationFor nesting ++ requirement ++ " [ ]"++, exampleProgress = \(nesting, requirement) p -> do+    writeTransient $ indentationFor nesting ++ requirement ++ " [" ++ (formatProgress p) ++ "]"++, exampleSucceeded = \(nesting, requirement) info -> do+    writeResult nesting requirement info $ withSuccessColor $ write "✔"++, exampleFailed = \(nesting, requirement) info _ -> do+    writeResult nesting requirement info $ withFailColor $ write "✘"++, examplePending = \(nesting, requirement) info reason -> do+    writeResult nesting requirement info $ withPendingColor $ write "‐"++    withPendingColor $ do+      writeLine $ indentationFor ("" : nesting) ++ "# PENDING: " ++ fromMaybe "No reason given" reason+} where+    indentationFor nesting = replicate (length nesting * 2) ' '++    writeResult :: [String] -> String -> String -> FormatM () -> FormatM ()+    writeResult nesting requirement info action = do+      write $ indentationFor nesting ++ requirement ++ " ["+      action+      writeLine "]"+      forM_ (lines info) $ \ s ->+        writeLine $ indentationFor ("" : nesting) ++ s++    formatProgress (current, total)+      | total == 0 = show current+      | otherwise  = show current ++ "/" ++ show total++specdoc :: Formatter+specdoc = silent {++  headerFormatter = do+    writeLine ""++, exampleGroupStarted = \nesting name -> do+    writeLine (indentationFor nesting ++ name)++, exampleProgress = \_ p -> do+    writeTransient (formatProgress p)++, exampleSucceeded = \(nesting, requirement) info -> withSuccessColor $ do+    writeLine $ indentationFor nesting ++ requirement+    forM_ (lines info) $ \ s ->+      writeLine $ indentationFor ("" : nesting) ++ s++, exampleFailed = \(nesting, requirement) info _ -> withFailColor $ do+    n <- getFailCount+    writeLine $ indentationFor nesting ++ requirement ++ " FAILED [" ++ show n ++ "]"+    forM_ (lines info) $ \ s ->+      writeLine $ indentationFor ("" : nesting) ++ s++, examplePending = \(nesting, requirement) info reason -> withPendingColor $ do+    writeLine $ indentationFor nesting ++ requirement+    forM_ (lines info) $ \ s ->+      writeLine $ indentationFor ("" : nesting) ++ s+    writeLine $ indentationFor ("" : nesting) ++ "# PENDING: " ++ fromMaybe "No reason given" reason++, failedFormatter = defaultFailedFormatter++, footerFormatter = defaultFooter+} where+    indentationFor nesting = replicate (length nesting * 2) ' '+    formatProgress (current, total)+      | total == 0 = show current+      | otherwise  = show current ++ "/" ++ show total+++progress :: Formatter+progress = silent {+  exampleSucceeded = \_ _ -> withSuccessColor $ write "."+, exampleFailed    = \_ _ _ -> withFailColor    $ write "F"+, examplePending   = \_ _ _ -> withPendingColor $ write "."+, failedFormatter  = defaultFailedFormatter+, footerFormatter  = defaultFooter+}+++failed_examples :: Formatter+failed_examples   = silent {+  failedFormatter = defaultFailedFormatter+, footerFormatter = defaultFooter+}++defaultFailedFormatter :: FormatM ()+defaultFailedFormatter = do+  writeLine ""++  failures <- getFailMessages++  unless (null failures) $ do+    writeLine "Failures:"+    writeLine ""++    forM_ (zip [1..] failures) $ \x -> do+      formatFailure x+      writeLine ""++    write "Randomized with seed " >> usedSeed >>= writeLine . show+    writeLine ""+  where+    formatFailure :: (Int, FailureRecord) -> FormatM ()+    formatFailure (n, FailureRecord mLoc path reason) = do+      forM_ mLoc $ \loc -> do+        withInfoColor $ writeLine (formatLoc loc)+      write ("  " ++ show n ++ ") ")+      writeLine (formatRequirement path)+      case reason of+        NoReason -> return ()+        Reason err -> withFailColor $ indent err+        ExpectedButGot preface expected actual -> do+          mapM_ indent preface++          b <- useDiff++          let threshold = 2 :: Seconds++          mchunks <- liftIO $ if b+            then timeout threshold (evaluate $ diff expected actual)+            else return Nothing++          case mchunks of+            Just chunks -> do+              writeDiff chunks extraChunk missingChunk+            Nothing -> do+              writeDiff [First expected, Second actual] write write+          where+            indented output text = case break (== '\n') text of+              (xs, "") -> output xs+              (xs, _ : ys) -> output (xs ++ "\n") >> write (indentation ++ "          ") >> indented output ys++            writeDiff chunks extra missing = do+              withFailColor $ write (indentation ++ "expected: ")+              forM_ chunks $ \ chunk -> case chunk of+                Both a _ -> indented write a+                First a -> indented extra a+                Second _ -> return ()+              writeLine ""++              withFailColor $ write (indentation ++ " but got: ")+              forM_ chunks $ \ chunk -> case chunk of+                Both a _ -> indented write a+                First _ -> return ()+                Second a -> indented missing a+              writeLine ""++        Error _ e -> withFailColor . indent $ (("uncaught exception: " ++) . formatException) e++      writeLine ""+      writeLine ("  To rerun use: --match " ++ show (joinPath path))+      where+        indentation = "       "+        indent message = do+          forM_ (lines message) $ \line -> do+            writeLine (indentation ++ line)+        formatLoc (Location file line column) = "  " ++ file ++ ":" ++ show line ++ ":" ++ show column ++ ": "++defaultFooter :: FormatM ()+defaultFooter = do++  writeLine =<< (++)+    <$> (printf "Finished in %1.4f seconds" <$> getRealTime)+    <*> (maybe "" (printf ", used %1.4f seconds of CPU time") <$> getCPUTime)++  fails   <- getFailCount+  pending <- getPendingCount+  total   <- getTotalCount++  let+    output =+         pluralize total   "example"+      ++ ", " ++ pluralize fails "failure"+      ++ if pending == 0 then "" else ", " ++ show pending ++ " pending"+    c | fails /= 0   = withFailColor+      | pending /= 0 = withPendingColor+      | otherwise    = withSuccessColor+  c $ writeLine output
+ hspec-core/src/Test/Hspec/Core/Formatters/V1/Free.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE DeriveFunctor #-}+module Test.Hspec.Core.Formatters.V1.Free where++import           Prelude ()+import           Test.Hspec.Core.Compat++data Free f a = Free (f (Free f a)) | Pure a+  deriving Functor++instance Functor f => Applicative (Free f) where+  pure = Pure+  Pure f <*> Pure a = Pure (f a)+  Pure f <*> Free m = Free (fmap f <$> m)+  Free m <*> b = Free (fmap (<*> b) m)++instance Functor f => Monad (Free f) where+  return = pure+  Pure a >>= f = f a+  Free m >>= f = Free (fmap (>>= f) m)++liftF :: Functor f => f a -> Free f a+liftF command = Free (fmap Pure command)
+ hspec-core/src/Test/Hspec/Core/Formatters/V1/Monad.hs view
@@ -0,0 +1,258 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ExistentialQuantification #-}+module Test.Hspec.Core.Formatters.V1.Monad (+  Formatter(..)+, Item(..)+, Result(..)+, FailureReason (..)+, FormatM++, getSuccessCount+, getPendingCount+, getFailCount+, getTotalCount++, FailureRecord (..)+, getFailMessages+, usedSeed++, printTimes+, getCPUTime+, getRealTime++, write+, writeLine+, writeTransient++, withInfoColor+, withSuccessColor+, withPendingColor+, withFailColor++, useDiff+, extraChunk+, missingChunk++, Environment(..)+, interpretWith+) where++import           Prelude ()+import           Test.Hspec.Core.Compat++import           Control.Monad.IO.Class++import           Test.Hspec.Core.Formatters.V1.Free+import           Test.Hspec.Core.Clock+import           Test.Hspec.Core.Format++data Formatter = Formatter {++  headerFormatter :: FormatM ()++-- | evaluated before each test group+, exampleGroupStarted :: [String] -> String -> FormatM ()++-- | evaluated after each test group+, exampleGroupDone :: FormatM ()++-- | evaluated before each example+, exampleStarted :: Path -> FormatM ()++-- | used to notify the progress of the currently evaluated example+, exampleProgress :: Path -> Progress -> FormatM ()++-- | evaluated after each successful example+, exampleSucceeded :: Path -> String -> FormatM ()++-- | evaluated after each failed example+, exampleFailed :: Path -> String -> FailureReason -> FormatM ()++-- | evaluated after each pending example+, examplePending :: Path -> String -> Maybe String -> FormatM ()++-- | evaluated after a test run+, failedFormatter :: FormatM ()++-- | evaluated after `failedFormatter`+, footerFormatter :: FormatM ()+}++data FailureRecord = FailureRecord {+  failureRecordLocation :: Maybe Location+, failureRecordPath     :: Path+, failureRecordMessage  :: FailureReason+}++data FormatF next =+    GetSuccessCount (Int -> next)+  | GetPendingCount (Int -> next)+  | GetFailMessages ([FailureRecord] -> next)+  | UsedSeed (Integer -> next)+  | PrintTimes (Bool -> 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)+  | forall a. WithInfoColor (FormatM a) (a -> next)+  | UseDiff (Bool -> next)+  | ExtraChunk String next+  | MissingChunk String next+  | forall a. LiftIO (IO a) (a -> next)++instance Functor FormatF where -- deriving this instance would require GHC >= 7.10.1+  fmap f x = case x of+    GetSuccessCount next -> GetSuccessCount (fmap f next)+    GetPendingCount next -> GetPendingCount (fmap f next)+    GetFailMessages next -> GetFailMessages (fmap f next)+    UsedSeed next -> UsedSeed (fmap f next)+    PrintTimes next -> PrintTimes (fmap f next)+    GetCPUTime next -> GetCPUTime (fmap f next)+    GetRealTime next -> GetRealTime (fmap f next)+    Write s next -> Write s (f next)+    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)+    WithInfoColor action next -> WithInfoColor action (fmap f next)+    UseDiff next -> UseDiff (fmap f next)+    ExtraChunk s next -> ExtraChunk s (f next)+    MissingChunk s next -> MissingChunk s (f next)+    LiftIO action next -> LiftIO action (fmap f next)++type FormatM = Free FormatF++instance MonadIO FormatM where+  liftIO s = liftF (LiftIO s id)++data Environment m = Environment {+  environmentGetSuccessCount :: m Int+, environmentGetPendingCount :: m Int+, environmentGetFailMessages :: m [FailureRecord]+, environmentUsedSeed :: m Integer+, environmentPrintTimes :: m Bool+, 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+, environmentWithInfoColor :: forall a. m a -> m a+, environmentUseDiff :: m Bool+, environmentExtraChunk :: String -> m ()+, environmentMissingChunk :: String -> m ()+, environmentLiftIO :: forall a. IO a -> m a+}++interpretWith :: forall m a. Monad m => Environment m -> FormatM a -> m a+interpretWith Environment{..} = go+  where+    go :: forall b. FormatM b -> m b+    go m = case m of+      Pure value -> return value+      Free action -> case action of+        GetSuccessCount next -> environmentGetSuccessCount >>= go . next+        GetPendingCount next -> environmentGetPendingCount >>= go . next+        GetFailMessages next -> environmentGetFailMessages >>= go . next+        UsedSeed next -> environmentUsedSeed >>= go . next+        PrintTimes next -> environmentPrintTimes >>= go . next+        GetCPUTime next -> environmentGetCPUTime >>= go . next+        GetRealTime next -> environmentGetRealTime >>= go . next+        Write s next -> environmentWrite s >> go next+        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+        WithInfoColor inner next -> environmentWithInfoColor (go inner) >>= go . next+        UseDiff next -> environmentUseDiff >>= go . next+        ExtraChunk s next -> environmentExtraChunk s >> go next+        MissingChunk s next -> environmentMissingChunk s >> go next+        LiftIO inner next -> environmentLiftIO inner >>= go . next++-- | Get the number of successful examples encountered so far.+getSuccessCount :: FormatM Int+getSuccessCount = liftF (GetSuccessCount id)++-- | Get the number of pending examples encountered so far.+getPendingCount :: FormatM Int+getPendingCount = liftF (GetPendingCount id)++-- | Get the number of failed examples encountered so far.+getFailCount :: FormatM Int+getFailCount = length <$> getFailMessages++-- | Get the total number of examples encountered so far.+getTotalCount :: FormatM Int+getTotalCount = sum <$> sequence [getSuccessCount, getFailCount, getPendingCount]++-- | Get the list of accumulated failure messages.+getFailMessages :: FormatM [FailureRecord]+getFailMessages = liftF (GetFailMessages id)++-- | The random seed that is used for QuickCheck.+usedSeed :: FormatM Integer+usedSeed = liftF (UsedSeed id)++-- | Return `True` if the user requested time reporting for individual spec+-- items, `False` otherwise.+printTimes :: FormatM Bool+printTimes = liftF (PrintTimes id)++-- | Get the used CPU time since the test run has been started.+getCPUTime :: FormatM (Maybe Seconds)+getCPUTime = liftF (GetCPUTime id)++-- | Get the passed real time since the test run has been started.+getRealTime :: FormatM Seconds+getRealTime = liftF (GetRealTime id)++-- | Append some output to the report.+write :: String -> FormatM ()+write s = liftF (Write s ())++-- | 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.+withFailColor :: FormatM a -> FormatM a+withFailColor s = liftF (WithFailColor s id)++-- | Set output color to green, run given action, and finally restore the+-- default color.+withSuccessColor :: FormatM a -> FormatM a+withSuccessColor s = liftF (WithSuccessColor s id)++-- | Set output color to yellow, run given action, and finally restore the+-- default color.+withPendingColor :: FormatM a -> FormatM a+withPendingColor s = liftF (WithPendingColor s id)++-- | Set output color to cyan, run given action, and finally restore the+-- default color.+withInfoColor :: FormatM a -> FormatM a+withInfoColor s = liftF (WithInfoColor s id)++-- | Return `True` if the user requested colorized diffs, `False` otherwise.+useDiff :: FormatM Bool+useDiff = liftF (UseDiff id)++-- | Output given chunk in red.+extraChunk :: String -> FormatM ()+extraChunk s = liftF (ExtraChunk s ())++-- | Output given chunk in green.+missingChunk :: String -> FormatM ()+missingChunk s = liftF (MissingChunk s ())
+ hspec-core/src/Test/Hspec/Core/Formatters/V2.hs view
@@ -0,0 +1,333 @@+{-# LANGUAGE CPP #-}+-- |+-- Stability: experimental+--+-- This module contains formatters that can be used with+-- `Test.Hspec.Core.Runner.hspecWith`.+module Test.Hspec.Core.Formatters.V2 (++-- * Formatters+  silent+, checks+, specdoc+, progress+, failed_examples++-- * Implementing a custom Formatter+-- |+-- A formatter is a set of actions.  Each action is evaluated when a certain+-- situation is encountered during a test run.+--+-- Actions live in the `FormatM` monad.  It provides access to the runner state+-- and primitives for appending to the generated report.+, Formatter (..)+, Item(..)+, Result(..)+, FailureReason (..)+, FormatM+, formatterToFormat++-- ** Accessing the runner state+, getSuccessCount+, getPendingCount+, getFailCount+, getTotalCount+, getExpectedTotalCount++, FailureRecord (..)+, getFailMessages+, usedSeed++, printTimes++, Seconds(..)+, getCPUTime+, getRealTime++-- ** Appending to the generated report+, write+, writeLine+, writeTransient++-- ** Dealing with colors+, withInfoColor+, withSuccessColor+, withPendingColor+, withFailColor++, outputUnicode++, useDiff+, extraChunk+, missingChunk++-- ** Helpers+, formatLocation+, formatException+) where++import           Prelude ()+import           Test.Hspec.Core.Compat hiding (First)++import           Data.Maybe+import           Test.Hspec.Core.Util+import           Test.Hspec.Core.Clock+import           Test.Hspec.Core.Spec (Location(..))+import           Text.Printf+import           Control.Monad.IO.Class+import           Control.Exception++-- We use an explicit import list for "Test.Hspec.Formatters.Monad", to make+-- sure, that we only use the public API to implement formatters.+--+-- Everything imported here has to be re-exported, so that users can implement+-- their own formatters.+import Test.Hspec.Core.Formatters.Internal (+    Formatter(..)+  , Item(..)+  , Result(..)+  , FailureReason (..)+  , FormatM+  , formatterToFormat++  , getSuccessCount+  , getPendingCount+  , getFailCount+  , getTotalCount+  , getExpectedTotalCount++  , FailureRecord (..)+  , getFailMessages+  , usedSeed++  , printTimes+  , getCPUTime+  , getRealTime++  , write+  , writeLine+  , writeTransient++  , withInfoColor+  , withSuccessColor+  , withPendingColor+  , withFailColor++  , outputUnicode++  , useDiff+  , extraChunk+  , missingChunk+  )++import           Test.Hspec.Core.Formatters.Diff++silent :: Formatter+silent = Formatter {+  formatterStarted      = return ()+, formatterGroupStarted = \ _ -> return ()+, formatterGroupDone    = \ _ -> return ()+, formatterProgress     = \ _ _ -> return ()+, formatterItemStarted  = \ _ -> return ()+, formatterItemDone     = \ _ _ -> return ()+, formatterDone         = return ()+}++checks :: Formatter+checks = specdoc {+  formatterProgress = \(nesting, requirement) p -> do+    writeTransient $ indentationFor nesting ++ requirement ++ " [" ++ (formatProgress p) ++ "]"++, formatterItemStarted = \(nesting, requirement) -> do+    writeTransient $ indentationFor nesting ++ requirement ++ " [ ]"++, formatterItemDone = \ (nesting, requirement) item -> do+    unicode <- outputUnicode+    let fallback a b = if unicode then a else b+    uncurry (writeResult nesting requirement (itemDuration item) (itemInfo item)) $ case itemResult item of+      Success {} -> (withSuccessColor, fallback "✔" "v")+      Pending {} -> (withPendingColor, fallback "‐" "-")+      Failure {} -> (withFailColor,    fallback "✘" "x")+    case itemResult item of+      Success {} -> return ()+      Failure {} -> return ()+      Pending _ reason -> withPendingColor $ do+        writeLine $ indentationFor ("" : nesting) ++ "# PENDING: " ++ fromMaybe "No reason given" reason+} where+    indentationFor nesting = replicate (length nesting * 2) ' '++    writeResult :: [String] -> String -> Seconds -> String -> (FormatM () -> FormatM ()) -> String -> FormatM ()+    writeResult nesting requirement duration info withColor symbol = do+      shouldPrintTimes <- printTimes+      write $ indentationFor nesting ++ requirement ++ " ["+      withColor $ write symbol+      writeLine $ "]" ++ if shouldPrintTimes then times else ""+      forM_ (lines info) $ \ s ->+        writeLine $ indentationFor ("" : nesting) ++ s+      where+        dt :: Int+        dt = toMilliseconds duration++        times+          | dt == 0 = ""+          | otherwise = " (" ++ show dt ++ "ms)"++    formatProgress (current, total)+      | total == 0 = show current+      | otherwise  = show current ++ "/" ++ show total++specdoc :: Formatter+specdoc = silent {++  formatterStarted = do+    writeLine ""++, formatterGroupStarted = \ (nesting, name) -> do+    writeLine (indentationFor nesting ++ name)++, formatterProgress = \_ p -> do+    writeTransient (formatProgress p)++, formatterItemDone = \(nesting, requirement) item -> do+    let duration = itemDuration item+        info = itemInfo item++    case itemResult item of+      Success -> withSuccessColor $ do+        writeResult nesting requirement duration info+      Pending _ reason -> withPendingColor $ do+        writeResult nesting requirement duration info+        writeLine $ indentationFor ("" : nesting) ++ "# PENDING: " ++ fromMaybe "No reason given" reason+      Failure {} -> withFailColor $ do+        n <- getFailCount+        writeResult nesting (requirement ++ " FAILED [" ++ show n ++ "]") duration info++, formatterDone = defaultFailedFormatter >> defaultFooter+} where+    indentationFor nesting = replicate (length nesting * 2) ' '++    writeResult nesting requirement (Seconds duration) info = do+      shouldPrintTimes <- printTimes+      writeLine $ indentationFor nesting ++ requirement ++ if shouldPrintTimes then times else ""+      forM_ (lines info) $ \ s ->+        writeLine $ indentationFor ("" : nesting) ++ s+      where+        dt :: Int+        dt = floor (duration * 1000)++        times+          | dt == 0 = ""+          | otherwise = " (" ++ show dt ++ "ms)"++    formatProgress (current, total)+      | total == 0 = show current+      | otherwise  = show current ++ "/" ++ show total++progress :: Formatter+progress = failed_examples {+  formatterItemDone = \ _ item -> case itemResult item of+    Success{} -> withSuccessColor $ write "."+    Pending{} -> withPendingColor $ write "."+    Failure{} -> withFailColor $ write "F"+}++failed_examples :: Formatter+failed_examples   = silent {+  formatterDone = defaultFailedFormatter >> defaultFooter+}++defaultFailedFormatter :: FormatM ()+defaultFailedFormatter = do+  writeLine ""++  failures <- getFailMessages++  unless (null failures) $ do+    writeLine "Failures:"+    writeLine ""++    forM_ (zip [1..] failures) $ \x -> do+      formatFailure x+      writeLine ""++    write "Randomized with seed " >> usedSeed >>= writeLine . show+    writeLine ""+  where+    formatFailure :: (Int, FailureRecord) -> FormatM ()+    formatFailure (n, FailureRecord mLoc path reason) = do+      forM_ mLoc $ \loc -> do+        withInfoColor $ writeLine ("  " ++ formatLocation loc)+      write ("  " ++ show n ++ ") ")+      writeLine (formatRequirement path)+      case reason of+        NoReason -> return ()+        Reason err -> withFailColor $ indent err+        ExpectedButGot preface expected actual -> do+          mapM_ indent preface++          b <- useDiff++          let threshold = 2 :: Seconds++          mchunks <- liftIO $ if b+            then timeout threshold (evaluate $ diff expected actual)+            else return Nothing++          case mchunks of+            Just chunks -> do+              writeDiff chunks extraChunk missingChunk+            Nothing -> do+              writeDiff [First expected, Second actual] write write+          where+            indented output text = case break (== '\n') text of+              (xs, "") -> output xs+              (xs, _ : ys) -> output (xs ++ "\n") >> write (indentation ++ "          ") >> indented output ys++            writeDiff chunks extra missing = do+              withFailColor $ write (indentation ++ "expected: ")+              forM_ chunks $ \ chunk -> case chunk of+                Both a _ -> indented write a+                First a -> indented extra a+                Second _ -> return ()+              writeLine ""++              withFailColor $ write (indentation ++ " but got: ")+              forM_ chunks $ \ chunk -> case chunk of+                Both a _ -> indented write a+                First _ -> return ()+                Second a -> indented missing a+              writeLine ""++        Error _ e -> withFailColor . indent $ (("uncaught exception: " ++) . formatException) e++      writeLine ""+      writeLine ("  To rerun use: --match " ++ show (joinPath path))+      where+        indentation = "       "+        indent message = do+          forM_ (lines message) $ \line -> do+            writeLine (indentation ++ line)++defaultFooter :: FormatM ()+defaultFooter = do++  writeLine =<< (++)+    <$> (printf "Finished in %1.4f seconds" <$> getRealTime)+    <*> (maybe "" (printf ", used %1.4f seconds of CPU time") <$> getCPUTime)++  fails   <- getFailCount+  pending <- getPendingCount+  total   <- getTotalCount++  let+    output =+         pluralize total   "example"+      ++ ", " ++ pluralize fails "failure"+      ++ if pending == 0 then "" else ", " ++ show pending ++ " pending"+    c | fails /= 0   = withFailColor+      | pending /= 0 = withPendingColor+      | otherwise    = withSuccessColor+  c $ writeLine output++formatLocation :: Location -> String+formatLocation (Location file line column) = file ++ ":" ++ show line ++ ":" ++ show column ++ ": "
hspec-core/src/Test/Hspec/Core/Hooks.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-} -- | Stability: provisional module Test.Hspec.Core.Hooks (   before@@ -17,10 +19,14 @@ , aroundAll , aroundAll_ , aroundAllWith++, mapSubject+, ignoreSubject ) where  import           Prelude () import           Test.Hspec.Core.Compat+import           Data.CallStack  import           Control.Exception (SomeException, finally, throwIO, try, catch) import           Control.Concurrent.MVar@@ -88,11 +94,11 @@ around action = aroundWith $ \e () -> action e  -- | Run a custom action after the last spec item.-afterAll :: ActionWith a -> SpecWith a -> SpecWith a-afterAll action spec = runIO (runSpecM spec) >>= fromSpecList . return . NodeWithCleanup action+afterAll :: HasCallStack => ActionWith a -> SpecWith a -> SpecWith a+afterAll action spec = runIO (runSpecM spec) >>= fromSpecList . return . NodeWithCleanup location action  -- | Run a custom action after the last spec item.-afterAll_ :: IO () -> SpecWith a -> SpecWith a+afterAll_ :: HasCallStack => IO () -> SpecWith a -> SpecWith a afterAll_ action = afterAll (\_ -> action)  -- | Run a custom action before and/or after every spec item.@@ -163,3 +169,15 @@  waitFor :: BinarySemaphore -> IO () waitFor = takeMVar++-- | Modify the subject under test.+--+-- Note that this resembles a contravariant functor on the first type parameter+-- of `SpecM`.  This is because the subject is passed inwards, as an argument+-- to the spec item.+mapSubject :: (b -> a) -> SpecWith a -> SpecWith b+mapSubject f = aroundWith (. f)++-- | Ignore the subject under test for a given spec.+ignoreSubject :: SpecWith () -> SpecWith a+ignoreSubject = mapSubject (const ())
hspec-core/src/Test/Hspec/Core/QuickCheck.hs view
@@ -7,6 +7,9 @@ , modifyMaxShrinks ) where +import           Prelude ()+import           Test.Hspec.Core.Compat+ import           Test.QuickCheck import           Test.Hspec.Core.Spec
hspec-core/src/Test/Hspec/Core/QuickCheckUtil.hs view
@@ -5,7 +5,6 @@ import           Test.Hspec.Core.Compat  import           Control.Exception-import           Data.List import           Data.Maybe import           Data.Int import           System.Random
hspec-core/src/Test/Hspec/Core/Runner.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}  -- | -- Stability: provisional@@ -10,6 +11,7 @@ -- * Config , Config (..) , ColorMode (..)+, UnicodeMode(..) , Path , defaultConfig , configAddFilter@@ -29,6 +31,8 @@ #ifdef TEST , rerunAll , specToEvalForest+, colorOutputSupported+, unicodeOutputSupported #endif ) where @@ -43,6 +47,7 @@ import           System.Random import           Control.Monad.ST import           Data.STRef+import           System.Console.ANSI (hSupportsANSI)  import           System.Console.ANSI (hHideCursor, hShowCursor) import qualified Test.QuickCheck as QC@@ -50,12 +55,14 @@ import           Test.Hspec.Core.Util (Path) import           Test.Hspec.Core.Spec import           Test.Hspec.Core.Config-import           Test.Hspec.Core.Formatters-import           Test.Hspec.Core.Formatters.Internal+import           Test.Hspec.Core.Format (FormatConfig(..))+import qualified Test.Hspec.Core.Formatters.V1 as V1+import qualified Test.Hspec.Core.Formatters.V2 as V2 import           Test.Hspec.Core.FailureReport import           Test.Hspec.Core.QuickCheckUtil import           Test.Hspec.Core.Shuffle +import           Test.Hspec.Core.Runner.PrintSlowSpecItems import           Test.Hspec.Core.Runner.Eval  applyFilterPredicates :: Config -> [EvalTree] -> [EvalTree]@@ -198,43 +205,52 @@ runSpec_ :: Config -> Spec -> IO Summary runSpec_ config spec = do   filteredSpec <- specToEvalForest config spec-  withHandle config $ \h -> do-    let formatter = fromMaybe specdoc (configFormatter config)-        seed = (fromJust . configQuickCheckSeed) config-        qcArgs = configQuickCheckArgs config+  let+      seed = (fromJust . configQuickCheckSeed) config+      qcArgs = configQuickCheckArgs config+      !numberOfItems = countSpecItems filteredSpec -    concurrentJobs <- case configConcurrentJobs config of-      Nothing -> getDefaultConcurrentJobs-      Just n -> return n+  concurrentJobs <- case configConcurrentJobs config of+    Nothing -> getDefaultConcurrentJobs+    Just n -> return n -    useColor <- doesUseColor h config+  useColor <- colorOutputSupported (configColorMode config) (hSupportsANSI stdout)+  outputUnicode <- unicodeOutputSupported (configUnicodeMode config) stdout -    results <- withHiddenCursor useColor h $ do-      let-        formatConfig = FormatConfig {-          formatConfigHandle = h-        , formatConfigUseColor = useColor-        , formatConfigUseDiff = configDiff config-        , formatConfigHtmlOutput = configHtmlOutput config-        , formatConfigPrintCpuTime = configPrintCpuTime config-        , formatConfigUsedSeed =  seed-        }-        evalConfig = EvalConfig {-          evalConfigFormat = formatterToFormat formatter formatConfig-        , evalConfigConcurrentJobs = concurrentJobs-        , evalConfigFastFail = configFastFail config-        }-      runFormatter evalConfig filteredSpec+  results <- withHiddenCursor useColor stdout $ do+    let+      formatConfig = FormatConfig {+        formatConfigUseColor = useColor+      , formatConfigOutputUnicode = outputUnicode+      , formatConfigUseDiff = configDiff config+      , formatConfigPrintTimes = configTimes config+      , formatConfigHtmlOutput = configHtmlOutput config+      , formatConfigPrintCpuTime = configPrintCpuTime config+      , formatConfigUsedSeed = seed+      , formatConfigExpectedTotalCount = numberOfItems+      } -    let failures = filter resultItemIsFailure results+      formatter = fromMaybe (V2.formatterToFormat V2.checks) (configFormat config <|> V1.formatterToFormat <$> configFormatter config) -    dumpFailureReport config seed qcArgs (map fst failures)+    format <- maybe id printSlowSpecItems (configPrintSlowItems config) <$> formatter formatConfig -    return Summary {-      summaryExamples = length results-    , summaryFailures = length failures-    }+    let+      evalConfig = EvalConfig {+        evalConfigFormat = format+      , evalConfigConcurrentJobs = concurrentJobs+      , evalConfigFailFast = configFailFast config+      }+    runFormatter evalConfig filteredSpec +  let failures = filter resultItemIsFailure results++  dumpFailureReport config seed qcArgs (map fst failures)++  return Summary {+    summaryExamples = length results+  , summaryFailures = length failures+  }+ specToEvalForest :: Config -> Spec -> IO [EvalTree] specToEvalForest config spec = do   let@@ -273,17 +289,21 @@   | useColor  = E.bracket_ (hHideCursor h) (hShowCursor h)   | otherwise = id -doesUseColor :: Handle -> Config -> IO Bool-doesUseColor h c = case configColorMode c of-  ColorAuto  -> (&&) <$> hIsTerminalDevice h <*> (not <$> isDumb)+colorOutputSupported :: ColorMode -> IO Bool -> IO Bool+colorOutputSupported mode isTerminalDevice = case mode of+  ColorAuto  -> (&&) <$> (not <$> noColor) <*> isTerminalDevice   ColorNever -> return False   ColorAlways -> return True -withHandle :: Config -> (Handle -> IO a) -> IO a-withHandle c action = case configOutputFile c of-  Left h -> action h-  Right path -> withFile path WriteMode action+unicodeOutputSupported :: UnicodeMode -> Handle -> IO Bool+unicodeOutputSupported mode h = case mode of+  UnicodeAuto -> (== Just "UTF-8") . fmap show <$> hGetEncoding h+  UnicodeNever -> return False+  UnicodeAlways -> return True +noColor :: IO Bool+noColor = lookupEnv "NO_COLOR" <&> (/= Nothing)+ rerunAll :: Config -> Maybe FailureReport -> Summary -> Bool rerunAll _ Nothing _ = False rerunAll config (Just oldFailureReport) summary =@@ -292,9 +312,6 @@   && isSuccess summary   && (not . null) (failureReportPaths oldFailureReport) -isDumb :: IO Bool-isDumb = maybe False (== "dumb") <$> lookupEnv "TERM"- -- | Summary of a test run. data Summary = Summary {   summaryExamples :: Int@@ -303,14 +320,21 @@  instance Monoid Summary where   mempty = Summary 0 0-#if !MIN_VERSION_base(4,11,0)-  (Summary x1 x2) `mappend` (Summary y1 y2) = Summary (x1 + y1) (x2 + y2)-#else+#if MIN_VERSION_base(4,11,0) instance Semigroup Summary where-  (Summary x1 x2) <> (Summary y1 y2) = Summary (x1 + y1) (x2 + y2) #endif+  (Summary x1 x2)+#if MIN_VERSION_base(4,11,0)+    <>+#else+    `mappend`+#endif+    (Summary y1 y2) = Summary (x1 + y1) (x2 + y2)  randomizeForest :: Integer -> [Tree c a] -> [Tree c a] randomizeForest seed t = runST $ do   ref <- newSTRef (mkStdGen $ fromIntegral seed)   shuffleForest ref t++countSpecItems :: [EvalTree] -> Int+countSpecItems = getSum . foldMap (foldMap . const $ Sum 1)
hspec-core/src/Test/Hspec/Core/Runner/Eval.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE RankNTypes #-}  #if MIN_VERSION_base(4,6,0) && !MIN_VERSION_base(4,7,0) -- Control.Concurrent.QSem is deprecated in base-4.6.0.*@@ -31,13 +32,13 @@ import           Control.Monad.IO.Class (liftIO) import qualified Control.Monad.IO.Class as M -import           Control.Monad.Trans.State hiding (State, state)+import           Control.Monad.Trans.Reader import           Control.Monad.Trans.Class  import           Test.Hspec.Core.Util import           Test.Hspec.Core.Spec (Tree(..), Progress, FailureReason(..), Result(..), ResultStatus(..), ProgressCallback) import           Test.Hspec.Core.Timer-import           Test.Hspec.Core.Format (Format(..))+import           Test.Hspec.Core.Format (Format) import qualified Test.Hspec.Core.Format as Format import           Test.Hspec.Core.Clock import           Test.Hspec.Core.Example.Location@@ -47,52 +48,59 @@ type Monad m = (Functor m, Applicative m, M.Monad m) type MonadIO m = (Monad m, M.MonadIO m) -data EvalConfig m = EvalConfig {-  evalConfigFormat :: Format m+data EvalConfig = EvalConfig {+  evalConfigFormat :: Format , evalConfigConcurrentJobs :: Int-, evalConfigFastFail :: Bool+, evalConfigFailFast :: Bool } -data State m = State {-  stateConfig :: EvalConfig m-, stateResults :: [(Path, Format.Item)]+data Env = Env {+  envConfig :: EvalConfig+, envResults :: IORef [(Path, Format.Item)] } -type EvalM m = StateT (State m) m+formatEvent :: Format.Event -> EvalM ()+formatEvent event = do+  format <- asks $ evalConfigFormat . envConfig+  liftIO $ format event -addResult :: Monad m => Path -> Format.Item -> EvalM m ()-addResult path item = modify $ \ state -> state {stateResults = (path, item) : stateResults state}+type EvalM = ReaderT Env IO -getFormat :: Monad m => (Format m -> a) -> EvalM m a-getFormat format = gets (format . evalConfigFormat . stateConfig)+addResult :: Path -> Format.Item -> EvalM ()+addResult path item = do+  ref <- asks envResults+  liftIO $ modifyIORef ref ((path, item) :) -reportItem :: Monad m => Path -> Format.Item -> EvalM m ()-reportItem path item = do-  addResult path item-  format <- getFormat formatItem-  lift (format path item)+getResults :: EvalM [(Path, Format.Item)]+getResults = reverse <$> (asks envResults >>= liftIO . readIORef) -failureItem :: Maybe Location -> Seconds -> String -> FailureReason -> Format.Item-failureItem loc duration info err = Format.Item loc duration info (Format.Failure err)+reportItem :: Path -> Maybe Location -> EvalM (Seconds, Result)  -> EvalM ()+reportItem path loc action = do+  reportItemStarted path+  action >>= reportResult path loc -reportResult :: Monad m => Path -> Maybe Location -> (Seconds, Result) -> EvalM m ()+reportItemStarted :: Path -> EvalM ()+reportItemStarted = formatEvent . Format.ItemStarted++reportItemDone :: Path -> Format.Item -> EvalM ()+reportItemDone path item = do+  addResult path item+  formatEvent $ Format.ItemDone path item++reportResult :: Path -> Maybe Location -> (Seconds, Result) -> EvalM () 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)+    Result info status -> reportItemDone path $ Format.Item loc duration info $ case status of+      Success                      -> Format.Success+      Pending loc_ reason          -> Format.Pending loc_ reason+      Failure loc_ err@(Error _ e) -> Format.Failure (loc_ <|> extractLocation e) err+      Failure loc_ err             -> Format.Failure loc_ err -groupStarted :: Monad m => Path -> EvalM m ()-groupStarted path = do-  format <- getFormat formatGroupStarted-  lift $ format path+groupStarted :: Path -> EvalM ()+groupStarted = formatEvent . Format.GroupStarted -groupDone :: Monad m => Path -> EvalM m ()-groupDone path = do-  format <- getFormat formatGroupDone-  lift $ format path+groupDone :: Path -> EvalM ()+groupDone = formatEvent . Format.GroupDone  data EvalItem = EvalItem {   evalItemDescription :: String@@ -103,28 +111,32 @@  type EvalTree = Tree (IO ()) EvalItem -runEvalM :: Monad m => EvalConfig m -> EvalM m () -> m (State m)-runEvalM config action = execStateT action (State config [])- -- | Evaluate all examples of a given spec and produce a report.-runFormatter :: forall m. MonadIO m => EvalConfig m -> [EvalTree] -> IO ([(Path, Format.Item)])+runFormatter :: EvalConfig -> [EvalTree] -> IO ([(Path, Format.Item)]) runFormatter config specs = do+  ref <- newIORef []+   let     start = parallelizeTree (evalConfigConcurrentJobs config) specs     cancel = cancelMany . concatMap toList . map (fmap fst)+   E.bracket start cancel $ \ runningSpecs -> do     withTimer 0.05 $ \ timer -> do-      state <- formatRun format $ do-        runEvalM config $-          run $ map (fmap (fmap (. reportProgress timer) . snd)) runningSpecs-      return (reverse $ stateResults state)++      format Format.Started+      runReaderT (run $ map (fmap (fmap (. reportProgress timer) . snd)) runningSpecs) (Env config ref) `E.finally` do+        results <- reverse <$> readIORef ref+        format (Format.Done results)++      results <- reverse <$> readIORef ref+      return results   where     format = evalConfigFormat config -    reportProgress :: IO Bool -> Path -> Progress -> m ()     reportProgress timer path progress = do-      r <- liftIO timer-      when r (formatProgress format path progress)+      r <- timer+      when r $ do+        format (Format.Progress path progress)  cancelMany :: [Async a] -> IO () cancelMany asyncs = do@@ -196,12 +208,12 @@ replaceMVar :: MVar a -> a -> IO () replaceMVar mvar p = tryTakeMVar mvar >> putMVar mvar p -run :: forall m. MonadIO m => [RunningTree m] -> EvalM m ()+run :: [RunningTree IO] -> EvalM () run specs = do-  fastFail <- gets (evalConfigFastFail . stateConfig)+  fastFail <- asks (evalConfigFailFast . envConfig)   sequenceActions fastFail (concatMap foldSpec specs)   where-    foldSpec :: RunningTree m -> [EvalM m ()]+    foldSpec :: RunningTree IO -> [EvalM ()]     foldSpec = foldTree FoldTree {       onGroupStarted = groupStarted     , onGroupDone = groupDone@@ -209,18 +221,18 @@     , onLeafe = evalItem     } -    runCleanup :: [String] -> IO () -> EvalM m ()-    runCleanup groups action = do+    runCleanup :: Maybe Location -> [String] -> IO () -> EvalM ()+    runCleanup loc groups action = do       r <- liftIO $ measure $ safeEvaluate (action >> return (Result "" Success))       case r of         (_, Result "" Success) -> return ()-        _ -> reportResult path Nothing r+        _ -> reportItem path loc (return r)       where         path = (groups, "afterAll-hook") -    evalItem :: [String] -> RunningItem m -> EvalM m ()+    evalItem :: [String] -> RunningItem IO -> EvalM ()     evalItem groups (Item requirement loc action) = do-      lift (action path) >>= reportResult path loc+      reportItem path loc $ lift (action path)       where         path :: Path         path = (groups, requirement)@@ -228,7 +240,7 @@ data FoldTree c a r = FoldTree {   onGroupStarted :: Path -> r , onGroupDone :: Path -> r-, onCleanup :: [String] -> c -> r+, onCleanup :: Maybe Location -> [String] -> c -> r , onLeafe :: [String] -> a -> r } @@ -241,20 +253,20 @@         start = onGroupStarted path         children = concatMap (go (group : rGroups)) xs         done =  onGroupDone path-    go rGroups (NodeWithCleanup action xs) = children ++ [cleanup]+    go rGroups (NodeWithCleanup loc action xs) = children ++ [cleanup]       where         children = concatMap (go rGroups) xs-        cleanup = onCleanup (reverse rGroups) action+        cleanup = onCleanup loc (reverse rGroups) action     go rGroups (Leaf a) = [onLeafe (reverse rGroups) a] -sequenceActions :: Monad m => Bool -> [EvalM m ()] -> EvalM m ()+sequenceActions :: Bool -> [EvalM ()] -> EvalM () sequenceActions fastFail = go   where-    go :: Monad m => [EvalM m ()] -> EvalM m ()+    go :: [EvalM ()] -> EvalM ()     go [] = return ()     go (action : actions) = do       action-      hasFailures <- any resultItemIsFailure <$> gets stateResults+      hasFailures <- any resultItemIsFailure <$> getResults       let stopNow = fastFail && hasFailures       unless stopNow (go actions)
+ hspec-core/src/Test/Hspec/Core/Runner/PrintSlowSpecItems.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+module Test.Hspec.Core.Runner.PrintSlowSpecItems (+  printSlowSpecItems+) where++import           Prelude ()+import           Test.Hspec.Core.Compat++import           Test.Hspec.Core.Util+import           Test.Hspec.Core.Format++import           Test.Hspec.Core.Clock+import           Test.Hspec.Core.Formatters.V2 (formatLocation)++data SlowItem = SlowItem {+  location :: Maybe Location+, path :: Path+, duration :: Int+}++printSlowSpecItems :: Int -> Format -> Format+printSlowSpecItems n format event = do+  format event+  case event of+    Done items -> do+      let xs = slowItems n $ map toSlowItem items+      unless (null xs) $ do+        putStrLn "\nSlow spec items:"+        mapM_ printSlowSpecItem xs+    _ -> return ()++toSlowItem :: (Path, Item) -> SlowItem+toSlowItem (path, item) = SlowItem (itemLocation item)  path (toMilliseconds $ itemDuration item)++slowItems :: Int -> [SlowItem] -> [SlowItem]+slowItems n = take n . reverse . sortOn duration . filter ((/= 0) . duration)++printSlowSpecItem :: SlowItem -> IO ()+printSlowSpecItem SlowItem{..} = do+  putStrLn $ "  " ++ maybe "" formatLocation location ++ joinPath path ++ " (" ++ show duration ++ "ms)"
hspec-core/src/Test/Hspec/Core/Shuffle.hs view
@@ -22,7 +22,7 @@ shuffleTree :: STRef s StdGen -> Tree c a -> ST s (Tree c a) shuffleTree ref t = case t of   Node d xs -> Node d <$> shuffleForest ref xs-  NodeWithCleanup c xs -> NodeWithCleanup c <$> shuffleForest ref xs+  NodeWithCleanup loc c xs -> NodeWithCleanup loc c <$> shuffleForest ref xs   Leaf {} -> return t  shuffle :: STRef s StdGen -> [a] -> ST s [a]
hspec-core/src/Test/Hspec/Core/Tree.hs view
@@ -33,7 +33,7 @@ -- | Internal tree data structure data Tree c a =     Node String [Tree c a]-  | NodeWithCleanup c [Tree c a]+  | NodeWithCleanup (Maybe Location) c [Tree c a]   | Leaf a   deriving (Show, Eq, Functor, Foldable, Traversable) @@ -49,7 +49,7 @@   where     go spec = case spec of       Node d xs -> Node d (map go xs)-      NodeWithCleanup cleanup xs -> NodeWithCleanup (g cleanup) (map go xs)+      NodeWithCleanup loc cleanup xs -> NodeWithCleanup loc (g cleanup) (map go xs)       Leaf item -> Leaf (f item)  filterTree :: (a -> Bool) -> Tree c a -> Maybe (Tree c a)@@ -70,7 +70,7 @@ filterTree_ :: [String] -> ([String] -> a -> Bool) -> Tree c a -> Maybe (Tree c a) filterTree_ groups p tree = case tree of   Node group xs -> Just $ Node group $ filterForest_ (groups ++ [group]) p xs-  NodeWithCleanup action xs -> Just $ NodeWithCleanup action $ filterForest_ groups p xs+  NodeWithCleanup loc action xs -> Just $ NodeWithCleanup loc action $ filterForest_ groups p xs   Leaf item -> Leaf <$> guarded (p groups) item  pruneForest :: [Tree c a] -> [Tree c a]@@ -79,7 +79,7 @@ pruneTree :: Tree c a -> Maybe (Tree c a) pruneTree node = case node of   Node group xs -> Node group <$> prune xs-  NodeWithCleanup action xs -> NodeWithCleanup action <$> prune xs+  NodeWithCleanup loc action xs -> NodeWithCleanup loc action <$> prune xs   Leaf{} -> Just node   where     prune = guarded (not . null) . pruneForest
hspec-core/src/Test/Hspec/Core/Util.hs view
@@ -16,13 +16,13 @@ , formatException ) where -import           Data.List+import           Prelude ()+import           Test.Hspec.Core.Compat hiding (join)+ import           Data.Char (isSpace) import           GHC.IO.Exception import           Control.Exception import           Control.Concurrent.Async--import           Test.Hspec.Core.Compat (showType)  -- | -- @pluralize count singular@ pluralizes the given @singular@ word unless given
hspec-core/vendor/Control/Concurrent/Async.hs view
@@ -6,7 +6,7 @@ #if __GLASGOW_HASKELL__ < 710 {-# LANGUAGE DeriveDataTypeable #-} #endif-{-# OPTIONS -Wall #-}+{-# OPTIONS -Wall -fno-warn-implicit-prelude #-}  ----------------------------------------------------------------------------- -- |
hspec-core/vendor/Data/Algorithm/Diff.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveFunctor #-}+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} ----------------------------------------------------------------------------- -- | -- Module      :  Data.Algorithm.Diff
hspec-discover/src/Test/Hspec/Discover/Run.hs view
@@ -10,12 +10,13 @@ -- exported for testing , Spec(..) , importList-, fileToSpec-, findSpecs-, getFilesRecursive , driverWithFormatter , moduleNameFromId , pathToModule+, Tree(..)+, Forest(..)+, Hook(..)+, discover ) where import           Control.Monad import           Control.Applicative@@ -35,10 +36,8 @@ instance IsString ShowS where   fromString = showString -data Spec = Spec {-  specFile :: FilePath-, specModule :: String-} deriving (Eq, Show)+data Spec = Spec String | Hook String [Spec]+  deriving (Eq, Show)  run :: [String] -> IO () run args_ = do@@ -49,16 +48,19 @@         hPutStrLn stderr err         exitFailure       Right conf -> do-        when (configNested conf) (hPutStrLn stderr "hspec-discover: WARNING - The `--nested' option is deprecated and will be removed in a future release!")+        when (configNested conf)             (hPutStrLn stderr "hspec-discover: WARNING - The `--nested' option is deprecated and will be removed in a future release!")+        when (configNoMain conf)             (hPutStrLn stderr "hspec-discover: WARNING - The `--no-main' option is deprecated and will be removed in a future release!")+        when (isJust $ configFormatter conf) (hPutStrLn stderr "hspec-discover: WARNING - The `--formatter' option is deprecated and will be removed in a future release!")         specs <- findSpecs src         writeFile dst (mkSpecModule src conf specs)     _ -> do       hPutStrLn stderr (usage name)       exitFailure -mkSpecModule :: FilePath -> Config -> [Spec] -> String+mkSpecModule :: FilePath -> Config -> Maybe [Spec] -> String mkSpecModule src conf nodes =   ( "{-# LINE 1 " . shows src . " #-}\n"+  . showString "{-# LANGUAGE NoImplicitPrelude #-}\n"   . showString "{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}\n"   . showString ("module " ++ moduleName src conf ++" where\n")   . importList nodes@@ -97,42 +99,58 @@ moduleNameFromId = reverse . dropWhile (== '.') . dropWhile (/= '.') . reverse  -- | Generate imports for a list of specs.-importList :: [Spec] -> ShowS-importList = foldr (.) "" . map f+importList :: Maybe [Spec] -> ShowS+importList = foldr (.) "" . map f . maybe [] moduleNames   where-    f :: Spec -> ShowS-    f spec = "import qualified " . showString (specModule spec) . "Spec\n"+    f :: String -> ShowS+    f spec = "import qualified " . showString spec . "\n" +moduleNames :: [Spec] -> [String]+moduleNames = fromForest+  where+    fromForest :: [Spec] -> [String]+    fromForest = concatMap fromTree++    fromTree :: Spec -> [String]+    fromTree tree = case tree of+      Spec name -> [name ++ "Spec"]+      Hook name forest -> name : fromForest forest+ -- | Combine a list of strings with (>>). sequenceS :: [ShowS] -> ShowS sequenceS = foldr (.) "" . intersperse " >> " --- | Convert a list of specs to code.-formatSpecs :: [Spec] -> ShowS-formatSpecs xs-  | null xs   = "return ()"-  | otherwise = sequenceS (map formatSpec xs)+formatSpecs :: Maybe [Spec] -> ShowS+formatSpecs specs = case specs of+  Nothing -> "return ()"+  Just xs -> fromForest xs+  where+    fromForest :: [Spec] -> ShowS+    fromForest = sequenceS . map fromTree --- | Convert a spec to code.-formatSpec :: Spec -> ShowS-formatSpec (Spec file name) = "postProcessSpec " . shows file . " (describe " . shows name . " " . showString name . "Spec.spec)"+    fromTree :: Spec -> ShowS+    fromTree tree = case tree of+      Spec name -> "describe " . shows name . " " . showString name . "Spec.spec"+      Hook name forest -> "(" . showString name . ".hook $ " . fromForest forest . ")" -findSpecs :: FilePath -> IO [Spec]-findSpecs src = do-  let (dir, file) = splitFileName src-  mapMaybe (fileToSpec dir) . filter (/= file) <$> getFilesRecursive dir+findSpecs :: FilePath -> IO (Maybe [Spec])+findSpecs = fmap (fmap toSpecs) . discover -fileToSpec :: FilePath -> FilePath -> Maybe Spec-fileToSpec dir file = case reverse $ splitDirectories file of-  x:xs -> case stripSuffix "Spec.hs" x <|> stripSuffix "Spec.lhs" x of-    Just name | isValidModuleName name && all isValidModuleName xs ->-      Just . Spec (dir </> file) $ (intercalate "." . reverse) (name : xs)-    _ -> Nothing-  _ -> Nothing+toSpecs :: Forest -> [Spec]+toSpecs = fromForest []   where-    stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]-    stripSuffix suffix str = reverse <$> stripPrefix (reverse suffix) (reverse str)+    fromForest :: [String] -> Forest -> [Spec]+    fromForest names (Forest WithHook xs) = [Hook (mkModule ("SpecHook" : names)) $ concatMap (fromTree names) xs]+    fromForest names (Forest WithoutHook xs) = concatMap (fromTree names) xs +    fromTree :: [String] -> Tree -> [Spec]+    fromTree names spec = case spec of+      Leaf name -> [Spec $ mkModule (name : names )]+      Node name forest -> fromForest (name : names) forest++    mkModule :: [String] -> String+    mkModule = intercalate "." . reverse+ -- See `Cabal.Distribution.ModuleName` (http://git.io/bj34) isValidModuleName :: String -> Bool isValidModuleName [] = False@@ -141,13 +159,71 @@ isValidModuleChar :: Char -> Bool isValidModuleChar c = isAlphaNum c || c == '_' || c == '\'' -getFilesRecursive :: FilePath -> IO [FilePath]-getFilesRecursive baseDir = sortNaturally <$> go []+data Tree = Leaf String | Node String Forest+  deriving (Eq, Show) +data Forest = Forest Hook [Tree]+  deriving (Eq, Show)++data Hook = WithHook | WithoutHook+  deriving (Eq, Show)++sortKey :: Tree -> (String, Int)+sortKey tree = case tree of+  Leaf name -> (name, 0)+  Node name _ -> (name, 1)++discover :: FilePath -> IO (Maybe Forest)+discover src = (>>= filterSrc) <$> specForest dir   where-    go :: FilePath -> IO [FilePath]-    go dir = do-      c <- map (dir </>) . filter (`notElem` [".", ".."]) <$> getDirectoryContents (baseDir </> dir)-      dirs <- filterM (doesDirectoryExist . (baseDir </>)) c >>= mapM go-      files <- filterM (doesFileExist . (baseDir </>)) c-      return (files ++ concat dirs)+    filterSrc :: Forest -> Maybe Forest+    filterSrc (Forest hook xs) = ensureForest hook $ maybe id (filter . (/=)) (toSpec file) xs++    (dir, file) = splitFileName src++specForest :: FilePath -> IO (Maybe Forest)+specForest dir = do+  files <- listDirectory dir+  hook <- mkHook dir files+  ensureForest hook . sortNaturallyBy sortKey . catMaybes <$> mapM toSpecTree files+  where+    toSpecTree :: FilePath -> IO (Maybe Tree)+    toSpecTree name+      | isValidModuleName name = do+          doesDirectoryExist (dir </> name) `fallback` Nothing $ do+            xs <- specForest (dir </> name)+            return $ Node name <$> xs+      | otherwise = do+          doesFileExist (dir </> name) `fallback` Nothing $ do+            return $ toSpec name++mkHook :: FilePath -> [FilePath] -> IO Hook+mkHook dir files+  | "SpecHook.hs" `elem` files = do+    doesFileExist (dir </> "SpecHook.hs") `fallback` WithoutHook $ do+      return WithHook+  | otherwise = return WithoutHook++fallback :: IO Bool -> a -> IO a -> IO a+fallback p def action = do+  bool <- p+  if bool then action else return def++toSpec :: FilePath -> Maybe Tree+toSpec file = Leaf <$> (spec >>= ensure isValidModuleName)+  where+    spec :: Maybe String+    spec = stripSuffix "Spec.hs" file <|> stripSuffix "Spec.lhs" file++    stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]+    stripSuffix suffix str = reverse <$> stripPrefix (reverse suffix) (reverse str)++ensure :: (a -> Bool) -> a -> Maybe a+ensure p a = guard (p a) >> Just a++ensureForest :: Hook -> [Tree] -> Maybe Forest+ensureForest hook = fmap (Forest hook) . ensure (not . null)++listDirectory :: FilePath -> IO [FilePath]+listDirectory path = filter f <$> getDirectoryContents path+  where f filename = filename /= "." && filename /= ".."
hspec-discover/src/Test/Hspec/Discover/Sort.hs view
@@ -1,5 +1,8 @@+-- |+-- /NOTE:/ This module is not meant for public consumption.  For user+-- documentation look at http://hspec.github.io/hspec-discover.html. module Test.Hspec.Discover.Sort (-  sortNaturally+  sortNaturallyBy , NaturalSortKey , naturalSortKey ) where@@ -9,8 +12,8 @@ import           Data.List import           Data.Ord -sortNaturally :: [String] -> [String]-sortNaturally = sortBy (comparing naturalSortKey)+sortNaturallyBy :: (a -> (String, Int)) -> [a] -> [a]+sortNaturallyBy f = sortBy (comparing ((\ (k, t) -> (naturalSortKey k, t)) . f))  data NaturalSortKey = NaturalSortKey [Chunk]   deriving (Eq, Ord)
hspec-meta.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.3.+-- This file has been generated from package.yaml by hpack version 0.34.5. -- -- see: https://github.com/sol/hpack  name:           hspec-meta-version:        2.7.8+version:        2.9.0 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.@@ -36,25 +36,33 @@       Test.Hspec.Formatters       Test.Hspec.QuickCheck       Test.Hspec.Runner+      GetOpt.Declarative+      GetOpt.Declarative.Environment+      GetOpt.Declarative.Interpret+      GetOpt.Declarative.Types+      GetOpt.Declarative.Util       Test.Hspec.Core.Clock       Test.Hspec.Core.Compat       Test.Hspec.Core.Config+      Test.Hspec.Core.Config.Definition       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.Formatters.V1+      Test.Hspec.Core.Formatters.V1.Free+      Test.Hspec.Core.Formatters.V1.Monad+      Test.Hspec.Core.Formatters.V2       Test.Hspec.Core.Hooks       Test.Hspec.Core.QuickCheck       Test.Hspec.Core.QuickCheckUtil       Test.Hspec.Core.Runner       Test.Hspec.Core.Runner.Eval+      Test.Hspec.Core.Runner.PrintSlowSpecItems       Test.Hspec.Core.Shuffle       Test.Hspec.Core.Spec       Test.Hspec.Core.Spec.Monad
src/Test/Hspec.hs view
@@ -64,6 +64,11 @@ , around , around_ , aroundWith+, aroundAll+, aroundAll_+, aroundAllWith+, mapSubject+, ignoreSubject  -- * Running a spec , hspec
src/Test/Hspec/Discover.hs view
@@ -10,8 +10,6 @@ , describe ) where -import           Prelude hiding (mapM)- import           Test.Hspec.Core.Spec import           Test.Hspec.Core.Runner import           Test.Hspec.Formatters
version.yaml view
@@ -1,1 +1,1 @@-&version 2.7.8+&version 2.9.0