packages feed

hspec-core 2.2.4 → 2.11.17

raw patch · 101 files changed

Files

LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2011-2015 Simon Hengel <sol@typeful.net>+Copyright (c) 2011-2026 Simon Hengel <sol@typeful.net> Copyright (c) 2011-2012 Trystan Spangler <trystan.s@comcast.net> Copyright (c) 2011-2011 Greg Weber <greg@gregweber.info>
+ help.txt view
@@ -0,0 +1,68 @@+Usage: spec [OPTION]...++OPTIONS+              --help              display this help and exit+              --ignore-dot-hspec  do not read options from ~/.hspec and .hspec+  -m PATTERN  --match=PATTERN     only run examples that match given PATTERN+              --skip=PATTERN      skip examples that match given PATTERN++RUNNER OPTIONS+        --[no-]dry-run               pretend that everything passed; don't+                                     verify anything+        --[no-]focused-only          do not run anything, unless there are+                                     focused spec items+        --[no-]fail-on=ITEMS         empty: fail if all spec items have been+                                     filtered+                                     focused: fail on focused spec items+                                     pending: fail on pending spec items+                                     empty-description: fail on empty+                                     descriptions+        --[no-]strict                same as --fail-on=focused,pending+        --[no-]fail-fast             abort on first failure+        --[no-]randomize             randomize execution order+  -r    --[no-]rerun                 rerun all examples that failed in the+                                     previous test run (only works in+                                     combination with --failure-report or in+                                     GHCi)+        --failure-report=FILE        read/write a failure report for use with+                                     --rerun+        --[no-]rerun-all-on-success  run the whole test suite after a previously+                                     failing rerun succeeds for the first time+                                     (only works in combination with --rerun)+  -j N  --jobs=N                     run at most N parallelizable tests+                                     simultaneously (default: number of+                                     available processors)+        --seed=N                     used seed for --randomize and QuickCheck+                                     properties++FORMATTER OPTIONS+  -f NAME  --format=NAME           use a custom formatter; this can be one of+                                   checks, specdoc, progress, failed-examples or+                                   silent+           --[no-]color            colorize the output+           --[no-]unicode          output unicode+           --[no-]diff             show colorized diffs+           --diff-context=N        output N lines of diff context (default: 3)+                                   use a value of 'full' to see the full context+           --diff-command=CMD      use an external diff command+                                   example: --diff-command="git diff"+           --[no-]pretty           try to pretty-print diff values+           --show-exceptions       use `show` when formatting exceptions+           --display-exceptions    use `displayException` when formatting+                                   exceptions+           --[no-]times            report times for individual spec items+           --print-cpu-time        include used CPU time in summary+  -p[N]    --print-slow-items[=N]  print the N slowest spec items (default: 10)+           --[no-]expert           be less verbose++OPTIONS FOR QUICKCHECK+  -a N  --qc-max-success=N  maximum number of successful tests before a+                            QuickCheck property succeeds+        --qc-max-discard=N  maximum number of discarded tests per successful+                            test before giving up+        --qc-max-size=N     size to use for the biggest test cases+        --qc-max-shrinks=N  maximum number of shrinks to perform before giving+                            up (a value of 0 turns shrinking off)++OPTIONS FOR SMALLCHECK+    --depth=N  maximum depth of generated test values for SmallCheck properties
hspec-core.cabal view
@@ -1,21 +1,26 @@--- This file has been generated from package.yaml by hpack version 0.14.1.+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack  name:             hspec-core-version:          2.2.4+version:          2.11.17 license:          MIT license-file:     LICENSE-copyright:        (c) 2011-2015 Simon Hengel,+copyright:        (c) 2011-2026 Simon Hengel,                   (c) 2011-2012 Trystan Spangler,                   (c) 2011 Greg Weber maintainer:       Simon Hengel <sol@typeful.net> build-type:       Simple-cabal-version:    >= 1.10+extra-source-files:+    version.yaml+    help.txt category:         Testing stability:        experimental bug-reports:      https://github.com/hspec/hspec/issues-homepage:         http://hspec.github.io/+author:           Simon Hengel <sol@typeful.net>+homepage:         https://hspec.github.io/ synopsis:         A Testing Framework for Haskell description:      This package exposes internal types and functions that can be used to extend Hspec's functionality. @@ -27,96 +32,222 @@ library   hs-source-dirs:       src-  ghc-options: -Wall+      vendor+  ghc-options: -Wall -fno-warn-incomplete-uni-patterns   build-depends:-      base >= 4.3 && < 5+      HUnit ==1.6.*+    , QuickCheck >=2.13.1 && <2.19+    , ansi-terminal >=0.6.2+    , array+    , base >=4.9.0.0 && <5+    , call-stack >=0.2.0+    , containers+    , deepseq+    , directory+    , filepath+    , haskell-lexer+    , hspec-expectations ==0.8.4.*+    , process+    , quickcheck-io >=0.2.0     , random-    , tf-random-    , setenv-    , ansi-terminal >= 0.5     , time-    , transformers >= 0.2.2.0-    , deepseq-    , HUnit >= 1.2.5-    , QuickCheck >= 2.5.1-    , quickcheck-io-    , hspec-expectations == 0.7.2.*-    , async >= 2+    , transformers >=0.2.2.0   exposed-modules:+      Test.Hspec.Core.Extension+      Test.Hspec.Core.Extension.Item+      Test.Hspec.Core.Extension.Spec+      Test.Hspec.Core.Extension.Tree+      Test.Hspec.Core.Extension.Option+      Test.Hspec.Core.Extension.Config       Test.Hspec.Core.Spec       Test.Hspec.Core.Hooks       Test.Hspec.Core.Runner+      Test.Hspec.Core.Format       Test.Hspec.Core.Formatters+      Test.Hspec.Core.Formatters.V1+      Test.Hspec.Core.Formatters.V2       Test.Hspec.Core.QuickCheck       Test.Hspec.Core.Util   other-modules:-      Test.Hspec.Compat-      Test.Hspec.Config+      GetOpt.Declarative+      GetOpt.Declarative.Environment+      GetOpt.Declarative.Interpret+      GetOpt.Declarative.Types+      GetOpt.Declarative.Util+      Test.Hspec.Core.Annotations+      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.Example+      Test.Hspec.Core.Example.Location+      Test.Hspec.Core.Extension.Config.Type+      Test.Hspec.Core.FailureReport+      Test.Hspec.Core.Formatters.Diff       Test.Hspec.Core.Formatters.Internal-      Test.Hspec.Core.QuickCheckUtil+      Test.Hspec.Core.Formatters.Pretty+      Test.Hspec.Core.Formatters.Pretty.Parser+      Test.Hspec.Core.Formatters.Pretty.Unicode+      Test.Hspec.Core.Formatters.V1.Free+      Test.Hspec.Core.Formatters.V1.Internal+      Test.Hspec.Core.Formatters.V1.Monad+      Test.Hspec.Core.QuickCheck.Util       Test.Hspec.Core.Runner.Eval+      Test.Hspec.Core.Runner.JobQueue+      Test.Hspec.Core.Runner.PrintSlowSpecItems+      Test.Hspec.Core.Runner.Result+      Test.Hspec.Core.Shuffle       Test.Hspec.Core.Spec.Monad+      Test.Hspec.Core.Timer       Test.Hspec.Core.Tree-      Test.Hspec.FailureReport-      Test.Hspec.Options-      Test.Hspec.Timer+      Data.Algorithm.Diff       Paths_hspec_core   default-language: Haskell2010+  if impl(ghc)+    other-modules:+        Control.Concurrent.Async+    hs-source-dirs:+        vendor/async-2.2.5/+    cpp-options: -DENABLE_SPEC_HOOK_ARGS+    if impl(ghc >= 8.4.1)+      build-depends:+          stm >=2.2+    else+      other-modules:+          Control.Concurrent.STM.TMVar+      hs-source-dirs:+          vendor/stm-2.5.0.1/  test-suite spec   type: exitcode-stdio-1.0   main-is: Spec.hs   hs-source-dirs:+      src+      vendor       test-    , src-  ghc-options: -Wall+  ghc-options: -Wall -fno-warn-incomplete-uni-patterns+  cpp-options: -DTEST   build-depends:-      base >= 4.3 && < 5-    , random-    , tf-random-    , setenv-    , ansi-terminal >= 0.5-    , time-    , transformers >= 0.2.2.0+      HUnit ==1.6.*+    , QuickCheck >=2.14+    , ansi-terminal >=0.6.2+    , array+    , base >=4.9.0.0 && <5+    , base-orphans+    , call-stack >=0.2.0+    , containers     , deepseq-    , HUnit >= 1.2.5-    , QuickCheck >= 2.5.1-    , quickcheck-io-    , hspec-expectations == 0.7.2.*-    , async >= 2-    , hspec-meta >= 2.2.0-    , silently >= 1.2.4+    , directory+    , filepath+    , haskell-lexer+    , hspec-expectations ==0.8.4.*+    , hspec-meta ==2.11.17     , process+    , quickcheck-io >=0.2.0+    , random+    , silently >=1.2.4+    , temporary+    , time+    , transformers >=0.2.2.0+  build-tool-depends:+      hspec-meta:hspec-meta-discover   other-modules:-      Helper-      Mock-      Test.Hspec.CompatSpec-      Test.Hspec.Core.ExampleSpec-      Test.Hspec.Core.FormattersSpec-      Test.Hspec.Core.HooksSpec-      Test.Hspec.Core.QuickCheckUtilSpec-      Test.Hspec.Core.RunnerSpec-      Test.Hspec.Core.SpecSpec-      Test.Hspec.Core.UtilSpec-      Test.Hspec.FailureReportSpec-      Test.Hspec.OptionsSpec-      Test.Hspec.TimerSpec-      Test.Hspec.Compat-      Test.Hspec.Config+      GetOpt.Declarative+      GetOpt.Declarative.Environment+      GetOpt.Declarative.Interpret+      GetOpt.Declarative.Types+      GetOpt.Declarative.Util+      Test.Hspec.Core.Annotations+      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.Example+      Test.Hspec.Core.Example.Location+      Test.Hspec.Core.Extension+      Test.Hspec.Core.Extension.Config+      Test.Hspec.Core.Extension.Config.Type+      Test.Hspec.Core.Extension.Item+      Test.Hspec.Core.Extension.Option+      Test.Hspec.Core.Extension.Spec+      Test.Hspec.Core.Extension.Tree+      Test.Hspec.Core.FailureReport+      Test.Hspec.Core.Format       Test.Hspec.Core.Formatters+      Test.Hspec.Core.Formatters.Diff       Test.Hspec.Core.Formatters.Internal+      Test.Hspec.Core.Formatters.Pretty+      Test.Hspec.Core.Formatters.Pretty.Parser+      Test.Hspec.Core.Formatters.Pretty.Unicode+      Test.Hspec.Core.Formatters.V1+      Test.Hspec.Core.Formatters.V1.Free+      Test.Hspec.Core.Formatters.V1.Internal+      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.QuickCheck.Util       Test.Hspec.Core.Runner       Test.Hspec.Core.Runner.Eval+      Test.Hspec.Core.Runner.JobQueue+      Test.Hspec.Core.Runner.PrintSlowSpecItems+      Test.Hspec.Core.Runner.Result+      Test.Hspec.Core.Shuffle       Test.Hspec.Core.Spec       Test.Hspec.Core.Spec.Monad+      Test.Hspec.Core.Timer       Test.Hspec.Core.Tree       Test.Hspec.Core.Util-      Test.Hspec.FailureReport-      Test.Hspec.Options-      Test.Hspec.Timer+      Data.Algorithm.Diff+      GetOpt.Declarative.EnvironmentSpec+      GetOpt.Declarative.UtilSpec+      Helper+      Mock+      SpecHook+      Test.Hspec.Core.AnnotationsSpec+      Test.Hspec.Core.ClockSpec+      Test.Hspec.Core.CompatSpec+      Test.Hspec.Core.Config.DefinitionSpec+      Test.Hspec.Core.Config.OptionsSpec+      Test.Hspec.Core.ConfigSpec+      Test.Hspec.Core.Example.LocationSpec+      Test.Hspec.Core.ExampleSpec+      Test.Hspec.Core.FailureReportSpec+      Test.Hspec.Core.FormatSpec+      Test.Hspec.Core.Formatters.DiffSpec+      Test.Hspec.Core.Formatters.InternalSpec+      Test.Hspec.Core.Formatters.Pretty.ParserSpec+      Test.Hspec.Core.Formatters.Pretty.UnicodeSpec+      Test.Hspec.Core.Formatters.PrettySpec+      Test.Hspec.Core.Formatters.V1Spec+      Test.Hspec.Core.Formatters.V2Spec+      Test.Hspec.Core.HooksSpec+      Test.Hspec.Core.QuickCheck.UtilSpec+      Test.Hspec.Core.Runner.EvalSpec+      Test.Hspec.Core.Runner.JobQueueSpec+      Test.Hspec.Core.Runner.PrintSlowSpecItemsSpec+      Test.Hspec.Core.Runner.ResultSpec+      Test.Hspec.Core.RunnerSpec+      Test.Hspec.Core.ShuffleSpec+      Test.Hspec.Core.SpecSpec+      Test.Hspec.Core.TimerSpec+      Test.Hspec.Core.TreeSpec+      Test.Hspec.Core.UtilSpec+      Paths_hspec_core   default-language: Haskell2010+  if impl(ghc)+    other-modules:+        Control.Concurrent.Async+    hs-source-dirs:+        vendor/async-2.2.5/+    cpp-options: -DENABLE_SPEC_HOOK_ARGS+    if impl(ghc >= 8.4.1)+      build-depends:+          stm >=2.2+    else+      other-modules:+          Control.Concurrent.STM.TMVar+      hs-source-dirs:+          vendor/stm-2.5.0.1/
+ 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
+ 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
+ src/GetOpt/Declarative/Interpret.hs view
@@ -0,0 +1,96 @@+module GetOpt.Declarative.Interpret (+  ParseResult(..)+, parseCommandLineOptions+, parse+, interpretOptions+) where++import           Prelude ()+import           Test.Hspec.Core.Compat++import           System.Console.GetOpt (OptDescr, ArgOrder(..), getOpt)+import qualified System.Console.GetOpt as GetOpt++import           GetOpt.Declarative.Types+import           GetOpt.Declarative.Util (mkUsageInfo)++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 (fmap 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
+ 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)
+ src/GetOpt/Declarative/Util.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE CPP #-}+module GetOpt.Declarative.Util (mkUsageInfo) 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 short [optionA] arg help : Option "" [optionB] _ _ : ys | optionB == ("no-" ++ optionA) ->+    Option short ["[no-]" ++ optionA] arg help : condenseNoOptions ys+  x : xs -> x : condenseNoOptions xs+  [] -> []
− src/Test/Hspec/Compat.hs 
@@ -1,127 +0,0 @@-{-# LANGUAGE CPP #-}-module Test.Hspec.Compat (-  getDefaultConcurrentJobs-, showType-, showFullType-, readMaybe-, lookupEnv-, module Data.IORef--, module Prelude-, module Control.Applicative-, module Data.Foldable-, module Data.Traversable-, module Data.Monoid--#if !MIN_VERSION_base(4,6,0)-, modifyIORef'-#endif-) where--import           Control.Applicative-import           Data.Foldable-import           Data.Traversable-import           Data.Monoid--import           Prelude hiding (-    all-  , and-  , any-  , concat-  , concatMap-  , elem-  , foldl-  , foldl1-  , foldr-  , foldr1-  , mapM-  , mapM_-  , maximum-  , minimum-  , notElem-  , or-  , product-  , sequence-  , sequence_-  , sum-  )--#if !MIN_VERSION_base(4,3,0)-import           Control.Monad.Trans.Error () -- for Monad (Either e)-#endif--import           Data.Typeable (Typeable, typeOf, typeRepTyCon)-import           Text.Read-import           Data.IORef-import           System.Environment--#if MIN_VERSION_base(4,4,0)-import           Data.Typeable.Internal (tyConModule, tyConName)-import           Control.Concurrent-#endif--#if !MIN_VERSION_base(4,6,0)-import qualified Text.ParserCombinators.ReadP as P-#endif--getDefaultConcurrentJobs :: IO Int-#if MIN_VERSION_base(4,4,0)-getDefaultConcurrentJobs = getNumCapabilities-#else-getDefaultConcurrentJobs = return 1-#endif--#if !MIN_VERSION_base(4,6,0)--- |Strict version of 'modifyIORef'-modifyIORef' :: IORef a -> (a -> a) -> IO ()-modifyIORef' ref f = do-    x <- readIORef ref-    let x' = f x-    x' `seq` writeIORef ref x'---- | Parse a string using the 'Read' instance.--- Succeeds if there is exactly one valid result.--- A 'Left' value indicates a parse error.-readEither :: Read a => String -> Either String a-readEither s =-  case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of-    [x] -> Right x-    []  -> Left "Prelude.read: no parse"-    _   -> Left "Prelude.read: ambiguous parse"- where-  read' =-    do x <- readPrec-       lift P.skipSpaces-       return x---- | Parse a string using the 'Read' instance.--- Succeeds if there is exactly one valid result.-readMaybe :: Read a => String -> Maybe a-readMaybe s = case readEither s of-                Left _  -> Nothing-                Right a -> Just a---- | Return the value of the environment variable @var@, or @Nothing@ if--- there is no such value.------ For POSIX users, this is equivalent to 'System.Posix.Env.getEnv'.-lookupEnv :: String -> IO (Maybe String)-lookupEnv k = lookup k `fmap` getEnvironment-#endif--showType :: Typeable a => a -> String-showType a = let t = typeRepTyCon (typeOf a) in-#if MIN_VERSION_base(4,4,0)-  show t-#else-  (reverse . takeWhile (/= '.') . reverse . show) t-#endif---showFullType :: Typeable a => a -> String-showFullType a = let t = typeRepTyCon (typeOf a) in-#if MIN_VERSION_base(4,4,0)-  tyConModule t ++ "." ++ tyConName t-#else-  show t-#endif
− src/Test/Hspec/Config.hs 
@@ -1,86 +0,0 @@-module Test.Hspec.Config (-  Config (..)-, ColorMode(..)-, defaultConfig-, getConfig-, configAddFilter-, configQuickCheckArgs-) where--import           Control.Applicative-import           System.IO-import           System.Exit-import qualified Test.QuickCheck as QC--import           Test.Hspec.Core.Util-import           Test.Hspec.Options-import           Test.Hspec.FailureReport-import           Test.Hspec.Core.QuickCheckUtil (mkGen)-import           Test.Hspec.Core.Example (Params(..), defaultParams)---- | Add a filter predicate to config.  If there is already a filter predicate,--- then combine them with `||`.-configAddFilter :: (Path -> Bool) -> Config -> Config-configAddFilter p1 c = c {-    configFilterPredicate = Just p1 `filterOr` configFilterPredicate c-  }--mkConfig :: Maybe FailureReport -> Config -> Config-mkConfig mFailureReport opts = opts {-    configFilterPredicate = matchFilter `filterOr` rerunFilter-  , configQuickCheckSeed = mSeed-  , configQuickCheckMaxSuccess = mMaxSuccess-  , configQuickCheckMaxDiscardRatio = mMaxDiscardRatio-  , configQuickCheckMaxSize = mMaxSize-  }-  where--    mSeed = configQuickCheckSeed opts <|> (failureReportSeed <$> mFailureReport)-    mMaxSuccess = configQuickCheckMaxSuccess opts <|> (failureReportMaxSuccess <$> mFailureReport)-    mMaxSize = configQuickCheckMaxSize opts <|> (failureReportMaxSize <$> mFailureReport)-    mMaxDiscardRatio = configQuickCheckMaxDiscardRatio opts <|> (failureReportMaxDiscardRatio <$> mFailureReport)--    matchFilter = configFilterPredicate opts--    rerunFilter = case failureReportPaths <$> mFailureReport of-      Just [] -> Nothing-      Just xs -> Just (`elem` xs)-      Nothing -> Nothing--configQuickCheckArgs :: Config -> QC.Args-configQuickCheckArgs c = qcArgs-  where-    qcArgs = (-        maybe id setSeed (configQuickCheckSeed c)-      . maybe id setMaxDiscardRatio (configQuickCheckMaxDiscardRatio c)-      . maybe id setMaxSize (configQuickCheckMaxSize c)-      . maybe id setMaxSuccess (configQuickCheckMaxSuccess c)) (paramsQuickCheckArgs defaultParams)--    setMaxSuccess :: Int -> QC.Args -> QC.Args-    setMaxSuccess n args = args {QC.maxSuccess = 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}--    setSeed :: Integer -> QC.Args -> QC.Args-    setSeed n args = args {QC.replay = Just (mkGen (fromIntegral n), 0)}--getConfig :: Config -> String -> [String] -> IO Config-getConfig opts_ prog args = do-  case parseOptions opts_ prog args of-    Left (err, msg) -> exitWithMessage err msg-    Right opts -> do-      r <- if configRerun opts then readFailureReport else return Nothing-      return (mkConfig r opts)--exitWithMessage :: ExitCode -> String -> IO a-exitWithMessage err msg = do-  hPutStr h msg-  exitWith err-  where-    h = case err of-      ExitSuccess -> stdout-      _           -> stderr
+ src/Test/Hspec/Core/Annotations.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Test.Hspec.Core.Annotations (+  Annotations+, setValue+, getValue+) where++import           Prelude ()+import           Test.Hspec.Core.Compat++import           Data.Typeable+import           Data.Dynamic+import           Data.Map (Map)+import qualified Data.Map as Map++newtype Annotations = Annotations (Map TypeRep Dynamic)+  deriving (+#if MIN_VERSION_base(4,11,0)+  Semigroup,+#endif+  Monoid)++setValue :: Typeable value => value -> Annotations -> Annotations+setValue value (Annotations values) = Annotations $ Map.insert (typeOf value) (toDyn value) values++getValue :: forall value. Typeable value => Annotations -> Maybe value+getValue (Annotations values) = Map.lookup (typeOf (undefined :: value)) values >>= fromDynamic
+ src/Test/Hspec/Core/Clock.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-}+module Test.Hspec.Core.Clock (+  Seconds(..)+, toMilliseconds+, toMicroseconds+, getMonotonicTime+, measure+, sleep+, timeout+) where++#if MIN_VERSION_base(4,11,0) && !defined(__MHS__)+#define HAS_GET_MONOTONIC_TIME+#endif++import           Prelude ()+import           Test.Hspec.Core.Compat++import           Text.Printf+import           Control.Concurrent+import qualified System.Timeout as System++#ifdef HAS_GET_MONOTONIC_TIME+import qualified GHC.Clock as GHC+#else+import           Data.Time.Clock.POSIX+#endif++newtype Seconds = Seconds Double+  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)++getMonotonicTime :: IO Seconds+#ifdef HAS_GET_MONOTONIC_TIME+getMonotonicTime = Seconds <$> GHC.getMonotonicTime+#else+getMonotonicTime = do+  t <- getPOSIXTime+  return $ Seconds (realToFrac t)+#endif++measure :: IO a -> IO (Seconds, a)+measure action = do+  t0 <- getMonotonicTime+  a <- action+  t1 <- getMonotonicTime+  return (t1 - t0, a)++sleep :: Seconds -> IO ()+sleep = threadDelay . toMicroseconds++timeout :: Seconds -> IO a -> IO (Maybe a)+timeout = System.timeout . toMicroseconds
+ src/Test/Hspec/Core/Compat.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE CPP #-}+module Test.Hspec.Core.Compat (+  module Imports+, module Test.Hspec.Core.Compat+, Typeable+) where++import           Control.Exception as Imports+import           Control.Arrow as Imports ((>>>), (&&&), first, second)+import           Control.Applicative as Imports+import           Control.Monad as Imports hiding (+    mapM+  , mapM_+  , forM+  , forM_+  , msum+  , sequence+  , sequence_+  )+import           Data.Maybe as Imports+import           Data.Foldable as Imports+import           GHC.Stack as Imports (HasCallStack, withFrozenCallStack)++import           System.IO+import           System.Exit+import           System.Environment++#if MIN_VERSION_base(4,11,0)+import           Data.Functor as Imports ((<&>))+#endif++import           Data.Traversable as Imports+#ifndef __MHS__+import           Data.Monoid as Imports hiding (First)+#else+import           Data.Monoid as Imports (Endo(..), Sum(..))+#endif+import           Data.List as Imports (+    stripPrefix+  , isPrefixOf+  , isInfixOf+  , isSuffixOf+  , intercalate+  , inits+  , tails+  , sortBy+  , sortOn+  )++import           Prelude as Imports hiding (+    all+  , and+  , any+  , concat+  , concatMap+  , elem+  , foldl+  , foldl1+  , foldr+  , foldr1+  , mapM+  , mapM_+  , maximum+  , minimum+  , notElem+  , or+  , product+  , sequence+  , sequence_+  , sum+  , length+  , null+  )++import           Data.Typeable+import           Data.IORef as Imports++#if MIN_VERSION_base(4,12,0)+import           GHC.ResponseFile as Imports (unescapeArgs)+#else+import           Data.Char+#endif++import           Text.Read as Imports (readMaybe)+import           System.Environment as Imports (lookupEnv)+++import           Data.Bool as Imports (bool)++import           Control.Concurrent++#ifndef __MHS__+import           GHC.IO.Exception+#else+import           System.IO.Error+#endif+  ( ioe_type, IOErrorType(..) )++isUnsupportedOperation :: IOError -> Bool+isUnsupportedOperation e = ioe_type e == UnsupportedOperation++showType :: Typeable a => a -> String+showType = show . typeRepTyCon . typeOf++getDefaultConcurrentJobs :: IO Int+getDefaultConcurrentJobs = getNumCapabilities++guarded :: Alternative m => (a -> Bool) -> a -> m a+guarded p a = if p a then pure a else empty++#if !MIN_VERSION_base(4,11,0)+infixl 1 <&>+(<&>) :: Functor f => f a -> (a -> b) -> f b+(<&>) = flip (<$>)+#endif++endsWith :: Eq a => [a] -> [a] -> Bool+endsWith = flip isSuffixOf++pass :: Applicative m => m ()+pass = pure ()++die :: String -> IO a+die err = do+  name <- getProgName+  hPutStrLn stderr $ name <> ": " <> err+  exitFailure++#if !MIN_VERSION_base(4,12,0)+unescapeArgs :: String -> [String]+unescapeArgs = filter (not . null) . unescape++data Quoting = NoneQ | SngQ | DblQ++unescape :: String -> [String]+unescape args = reverse . map reverse $ go args NoneQ False [] []+    where+      -- n.b., the order of these cases matters; these are cribbed from gcc+      -- case 1: end of input+      go []     _q    _bs   a as = a:as+      -- case 2: back-slash escape in progress+      go (c:cs) q     True  a as = go cs q     False (c:a) as+      -- case 3: no back-slash escape in progress, but got a back-slash+      go (c:cs) q     False a as+        | '\\' == c              = go cs q     True  a     as+      -- case 4: single-quote escaping in progress+      go (c:cs) SngQ  False a as+        | '\'' == c              = go cs NoneQ False a     as+        | otherwise              = go cs SngQ  False (c:a) as+      -- case 5: double-quote escaping in progress+      go (c:cs) DblQ  False a as+        | '"' == c               = go cs NoneQ False a     as+        | otherwise              = go cs DblQ  False (c:a) as+      -- case 6: no escaping is in progress+      go (c:cs) NoneQ False a as+        | isSpace c              = go cs NoneQ False []    (a:as)+        | '\'' == c              = go cs SngQ  False a     as+        | '"'  == c              = go cs DblQ  False a     as+        | otherwise              = go cs NoneQ False (c:a) as+#endif++unicodeOutputSupported :: Handle -> IO Bool+unicodeOutputSupported _h = do+#ifndef __MHS__+  (== Just "UTF-8") . fmap show <$> hGetEncoding _h+#else+  return True++canonicalizePath :: FilePath -> IO FilePath+canonicalizePath = return+#endif
+ src/Test/Hspec/Core/Config.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE CPP #-}+module Test.Hspec.Core.Config (+  Config (..)+, ColorMode(..)+, UnicodeMode(..)+, defaultConfig+, readConfig+, configAddFilter+, configQuickCheckArgs++, readFailureReportOnRerun+, applyFailureReport+#ifdef TEST+, readConfigFiles+#endif+) where++import           Prelude ()+import           Test.Hspec.Core.Compat++import           System.IO+import           System.IO.Error+import           System.Exit+import           System.FilePath+import           System.Directory+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+import           Test.Hspec.Core.FailureReport+import           Test.Hspec.Core.QuickCheck.Util (mkGen)+import           Test.Hspec.Core.Example (Params(..), defaultParams)+import qualified Test.Hspec.Core.Formatters.V2 as V2++defaultConfig :: Config+defaultConfig = mkDefaultConfig $ map (fmap V2.formatterToFormat) [+    ("checks", V2.checks)+  , ("specdoc", V2.specdoc)+  , ("progress", V2.progress)+  , ("failed-examples", V2.failed_examples)+  , ("silent", V2.silent)+  ]++-- | Add a filter predicate to config.  If there is already a filter predicate,+-- then combine them with `||`.+configAddFilter :: (Path -> Bool) -> Config -> Config+configAddFilter p1 c = c {+    configFilterPredicate = Just p1 `filterOr` configFilterPredicate c+  }++applyFailureReport :: Maybe FailureReport -> Config -> Config+applyFailureReport mFailureReport config = config {+    configFilterPredicate = matchFilter `filterOr` rerunFilter+  , configSeed = mSeed+  , configQuickCheckMaxSuccess = mMaxSuccess+  , configQuickCheckMaxDiscardRatio = mMaxDiscardRatio+  , configQuickCheckMaxSize = mMaxSize+  }+  where++    mSeed = getSeed config <|> (failureReportSeed <$> mFailureReport)+    mMaxSuccess = configQuickCheckMaxSuccess config <|> (failureReportMaxSuccess <$> mFailureReport)+    mMaxSize = configQuickCheckMaxSize config <|> (failureReportMaxSize <$> mFailureReport)+    mMaxDiscardRatio = configQuickCheckMaxDiscardRatio config <|> (failureReportMaxDiscardRatio <$> mFailureReport)++    matchFilter = configFilterPredicate config++    rerunFilter = case failureReportPaths <$> mFailureReport of+      Just [] -> Nothing+      Just xs -> Just (`elem` xs)+      Nothing -> Nothing++configQuickCheckArgs :: Config -> QC.Args+configQuickCheckArgs c = qcArgs+  where+    qcArgs = (+        maybe id setSeed (configSeed 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}++    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)}++-- |+-- `readConfig` parses config options from several sources and constructs a+-- `Config` value.  It takes options from:+--+-- 1. @~/.hspec@ (a config file in the user's home directory)+-- 1. @.hspec@ (a config file in the current working directory)+-- 1. [environment variables starting with @HSPEC_@](https://hspec.github.io/options.html#specifying-options-through-environment-variables)+-- 1. the provided list of command-line options (the second argument to @readConfig@)+--+-- (precedence from low to high)+--+-- When parsing fails then @readConfig@ writes an error message to `stderr` and+-- exits with `exitFailure`.+--+-- When @--help@ is provided as a command-line option then @readConfig@ writes+-- a help message to `stdout` and exits with `exitSuccess`.+--+-- A common way to use @readConfig@ is:+--+-- @+-- `System.Environment.getArgs` >>= readConfig `defaultConfig`+-- @+readConfig :: Config -> [String] -> IO Config+readConfig opts_ args = do+  prog <- getProgName+  configFiles <- do+    ignore <- ignoreConfigFile opts_ args+    case ignore of+      True -> return []+      False -> readConfigFiles+  env <- getEnvironment+  let envVar = words <$> lookup envVarName env+  case parseOptions opts_ prog configFiles envVar env args of+    Left (err, msg) -> exitWithMessage err msg+    Right (warnings, opts) -> do+      mapM_ (hPutStrLn stderr) warnings+      return opts++readFailureReportOnRerun :: Config -> IO (Maybe FailureReport)+readFailureReportOnRerun config+  | configRerun config = readFailureReport config+  | otherwise = return Nothing++readConfigFiles :: IO [ConfigFile]+readConfigFiles = do+  global <- readGlobalConfigFile+  local <- readLocalConfigFile+  return $ catMaybes [global, local]++readGlobalConfigFile :: IO (Maybe ConfigFile)+readGlobalConfigFile = do+  mHome <- tryJust (guard . unavailable) getHomeDirectory+  case mHome of+    Left _ -> return Nothing+    Right home -> readConfigFile (home </> ".hspec")+  where+    unavailable :: IOError -> Bool+    unavailable e = isDoesNotExistError e || isUnsupportedOperation e++readLocalConfigFile :: IO (Maybe ConfigFile)+readLocalConfigFile = do+  mName <- tryJust (guard . isDoesNotExistError) (canonicalizePath ".hspec")+  case mName of+    Left _ -> return Nothing+    Right name -> readConfigFile name++readConfigFile :: FilePath -> IO (Maybe ConfigFile)+readConfigFile name = do+  exists <- doesFileExist name+  if exists then Just . (,) name . unescapeArgs <$> readFile name else return Nothing++exitWithMessage :: ExitCode -> String -> IO a+exitWithMessage err msg = do+  hPutStr h msg+  exitWith err+  where+    h = case err of+      ExitSuccess -> stdout+      _           -> stderr
+ src/Test/Hspec/Core/Config/Definition.hs view
@@ -0,0 +1,492 @@+{-# LANGUAGE CPP #-}+module Test.Hspec.Core.Config.Definition (+  Config(..)+, ColorMode(..)+, UnicodeMode(..)+, mkDefaultConfig++, filterOr++, setConfigAnnotation+, getConfigAnnotation++, addExtensionOptions+, getExtensionOptions++, getSeed+, getFormatter++, commandLineOnlyOptions+, formatterOptions+, smallCheckOptions+, quickCheckOptions+, runnerOptions++, flag+, option++#ifdef TEST+, splitOn+#endif+) where++import           Prelude ()+import           Test.Hspec.Core.Compat++import           System.Directory (getTemporaryDirectory, removeFile)+import           System.IO (openTempFile, hClose)+import           System.Process (system)++import           Test.Hspec.Core.Annotations (Annotations)+import qualified Test.Hspec.Core.Annotations as Annotations++import           Test.Hspec.Core.Format (Format, FormatConfig)+import           Test.Hspec.Core.Formatters.Pretty (pretty2)+import qualified Test.Hspec.Core.Formatters.V1.Monad as V1+import qualified Test.Hspec.Core.Formatters.V1.Internal as V1 (formatterToFormat)+import           Test.Hspec.Core.Util++import           GetOpt.Declarative++setConfigAnnotation :: Typeable value => value -> Config -> Config+setConfigAnnotation value config = config { configAnnotations = Annotations.setValue value $ configAnnotations config }++getConfigAnnotation :: Typeable value => Config -> Maybe value+getConfigAnnotation = Annotations.getValue . configAnnotations++newtype ExtensionOptions = ExtensionOptions { unExtensionOptions :: [(String, [Option Config])] }++addExtensionOptions :: String -> [Option Config] -> Config -> Config+addExtensionOptions section opts config = setExtensionOptions ((section, opts) : getExtensionOptions config) config++setExtensionOptions :: [(String, [Option Config])] -> Config -> Config+setExtensionOptions = setConfigAnnotation . ExtensionOptions++getExtensionOptions :: Config -> [(String, [Option Config])]+getExtensionOptions = maybe [] unExtensionOptions . getConfigAnnotation++getFormatter :: Config -> Maybe (FormatConfig -> IO Format)+getFormatter config = configFormat config <|> V1.formatterToFormat <$> configFormatter config++getSeed :: Config -> Maybe Integer+getSeed config = configSeed config <|> configQuickCheckSeed config++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+, configFailOnEmpty :: Bool+, configFailOnFocused :: Bool+, configFailOnPending :: Bool+, configFailOnEmptyDescription :: Bool+, configPrintSlowItems :: Maybe Int+, configPrintCpuTime :: Bool+, configFailFast :: Bool+, configRandomize :: Bool+, configSeed :: Maybe Integer+, configQuickCheckSeed :: Maybe Integer+, 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)+, configQuickCheckMaxSuccess :: Maybe Int+, configQuickCheckMaxDiscardRatio :: Maybe Int+, configQuickCheckMaxSize :: Maybe Int+, configQuickCheckMaxShrinks :: Maybe Int+, configSmallCheckDepth :: Maybe Int+, configColorMode :: ColorMode+, configUnicodeMode :: UnicodeMode+, configDiff :: Bool+, configDiffContext :: Maybe Int++-- |+-- An action that is used to print diffs.  The first argument is the value of+-- `configDiffContext`.  The remaining two arguments are the @expected@ and+-- @actual@ value.+--+-- @since 2.10.6+, configExternalDiff :: Maybe (Maybe Int -> String -> String -> IO ())++, configPrettyPrint :: Bool+, configPrettyPrintFunction :: Bool -> String -> String -> (String, String)+, configFormatException :: SomeException -> String -- ^ @since 2.11.5+, configTimes :: Bool+, configExpertMode :: Bool -- ^ @since 2.11.2+, configAvailableFormatters :: [(String, FormatConfig -> IO Format)] -- ^ @since 2.9.0+, configFormat :: Maybe (FormatConfig -> IO Format)+, configFormatter :: Maybe V1.Formatter+, configHtmlOutput :: Bool+, configConcurrentJobs :: Maybe Int+, configAnnotations :: Annotations+}+{-# DEPRECATED configFormatter "Use [@useFormatter@](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Formatters-V1.html#v:useFormatter) instead." #-}+{-# DEPRECATED configQuickCheckSeed "Use `configSeed` instead." #-}++mkDefaultConfig :: [(String, FormatConfig -> IO Format)] -> Config+mkDefaultConfig formatters = Config {+  configIgnoreConfigFile = False+, configDryRun = False+, configFocusedOnly = False+, configFailOnEmpty = False+, configFailOnFocused = False+, configFailOnPending = False+, configFailOnEmptyDescription = False+, configPrintSlowItems = Nothing+, configPrintCpuTime = False+, configFailFast = False+, configRandomize = False+, configSeed = Nothing+, configQuickCheckSeed = Nothing+, configFailureReport = Nothing+, configRerun = False+, configRerunAllOnSuccess = False+, configFilterPredicate = Nothing+, configSkipPredicate = Nothing+, configQuickCheckMaxSuccess = Nothing+, configQuickCheckMaxDiscardRatio = Nothing+, configQuickCheckMaxSize = Nothing+, configQuickCheckMaxShrinks = Nothing+, configSmallCheckDepth = Nothing+, configColorMode = ColorAuto+, configUnicodeMode = UnicodeAuto+, configDiff = True+, configDiffContext = Just defaultDiffContext+, configExternalDiff = Nothing+, configPrettyPrint = True+, configPrettyPrintFunction = pretty2+, configFormatException = formatExceptionWith show+, configTimes = False+, configExpertMode = False+, configAvailableFormatters = formatters+, configFormat = Nothing+, configFormatter = Nothing+, configHtmlOutput = False+, configConcurrentJobs = Nothing+, configAnnotations = mempty+}++defaultDiffContext :: Int+defaultDiffContext = 3++externalDiff :: String -> String -> String -> IO ()+externalDiff command expected actual = do+  tmp <- getTemporaryDirectory+  withTempFile tmp "hspec-expected" expected $ \ expectedFile -> do+    withTempFile tmp "hspec-actual" actual $ \ actualFile -> do+      void . system $ unwords [command, expectedFile, actualFile]++withTempFile :: FilePath -> FilePath -> String -> (FilePath -> IO a) -> IO a+withTempFile dir file contents action = do+  bracket (openTempFile dir file) (removeFile . fst) $ \ (path, h) -> do+    hClose h+    writeFile path contents+    action path++option :: String -> OptionSetter config -> String -> Option config+option name arg help = Option name Nothing arg help True++flag :: String -> (Bool -> config -> config) -> String -> Option config+flag 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 "NAME" readFormatter setFormatter) helpForFormat+  , flag "color" setColor "colorize the output"+  , flag "unicode" setUnicode "output unicode"+  , flag "diff" setDiff "show colorized diffs"+  , option "diff-context" (argument "N" readDiffContext setDiffContext) $ unlines [+        "output N lines of diff context (default: " <> show defaultDiffContext <> ")"+      , "use a value of 'full' to see the full context"+      ]+  , option "diff-command" (argument "CMD" return setDiffCommand) "use an external diff command\nexample: --diff-command=\"git diff\""+  , flag "pretty" setPretty "try to pretty-print diff values"+  , mkOptionNoArg "show-exceptions" Nothing setShowException "use `show` when formatting exceptions"+  , mkOptionNoArg "display-exceptions" Nothing setDisplayException "use `displayException` when formatting exceptions"++  , flag "times" setTimes "report times for individual spec items"+  , mkOptionNoArg "print-cpu-time" Nothing setPrintCpuTime "include used CPU time in summary"+  , printSlowItemsOption+  , flag "expert" setExpertMode "be less verbose"++    -- 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+    setDiffCommand :: String -> Config -> Config+    setDiffCommand command config = config {+      configExternalDiff = case strip command of+        "" -> Nothing+        _ -> Just $ \ _context -> externalDiff command+    }++    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}++    readDiffContext :: String -> Maybe (Maybe Int)+    readDiffContext input = case input of+      "full" -> Just Nothing+      _ -> case readMaybe input of+        Nothing -> Nothing+        mn -> Just (find (>= 0) mn)++    setDiffContext :: Maybe Int -> Config -> Config+    setDiffContext value c = c { configDiffContext = value }++    setPretty :: Bool -> Config -> Config+    setPretty v config = config {configPrettyPrint = v}++    setShowException :: Config -> Config+    setShowException config = config {configFormatException = formatExceptionWith show}++    setDisplayException :: Config -> Config+    setDisplayException config = config {configFormatException = formatExceptionWith displayException}++    setTimes :: Bool -> Config -> Config+    setTimes v config = config {configTimes = v}++    setPrintCpuTime config = config {configPrintCpuTime = True}++    setExpertMode :: Bool -> Config -> Config+    setExpertMode v config = config {configExpertMode = v}++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+      Nothing -> Nothing+      mn -> Just (setter (find (> 0) mn) c)++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 = Just 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)"++    -- 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 {configSeed = Just n}++data FailOn =+    FailOnEmpty+  | FailOnFocused+  | FailOnPending+  | FailOnEmptyDescription+  deriving (Bounded, Enum)++allFailOnItems :: [FailOn]+allFailOnItems = [minBound .. maxBound]++showFailOn :: FailOn -> String+showFailOn item = case item of+  FailOnEmpty -> "empty"+  FailOnFocused -> "focused"+  FailOnPending -> "pending"+  FailOnEmptyDescription -> "empty-description"++readFailOn :: String -> Maybe FailOn+readFailOn = (`lookup` items)+  where+    items = map (showFailOn &&& id) allFailOnItems++splitOn :: Char -> String -> [String]+splitOn sep = go+  where+    go xs =  case break (== sep) xs of+      ("", "") -> []+      (y, "") -> [y]+      (y, _ : ys) -> y : go ys++runnerOptions :: [Option Config]+runnerOptions = [+    flag "dry-run" setDryRun "pretend that everything passed; don't verify anything"+  , flag "focused-only" setFocusedOnly "do not run anything, unless there are focused spec items"++  , undocumented $ flag "fail-on-focused" setFailOnFocused "fail on focused spec items"+  , undocumented $ flag "fail-on-pending" setFailOnPending "fail on pending spec items"++  , mkOption    "fail-on" Nothing (argument "ITEMS" readFailOnItems (setFailOnItems True )) helpForFailOn+  , mkOption "no-fail-on" Nothing (argument "ITEMS" readFailOnItems (setFailOnItems False)) helpForFailOn+  , flag "strict" setStrict $ "same as --fail-on=" <> showFailOnItems strict++  , flag "fail-fast" setFailFast "abort on first failure"+  , flag "randomize" setRandomize "randomize execution order"+  , (flag "rerun" setRerun "rerun all examples that failed in the previous test run (only works in combination with --failure-report or in GHCi)") {optionShortcut = Just 'r'}+  , option "failure-report" (argument "FILE" return setFailureReport) "read/write a failure report for use with --rerun"+  , flag "rerun-all-on-success" 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)"+  , option "seed" (argument "N" readMaybe setSeed) "used seed for --randomize and QuickCheck properties"+  ]+  where+    strict = [FailOnFocused, FailOnPending]++    readFailOnItems :: String -> Maybe [FailOn]+    readFailOnItems = mapM readFailOn . splitOn ','++    showFailOnItems :: [FailOn] -> String+    showFailOnItems = intercalate "," . map showFailOn++    helpForFailOn :: String+    helpForFailOn = unlines . flip map allFailOnItems $ \ item ->+      showFailOn item <> ": " <> help item+      where+        help item = case item of+          FailOnEmpty -> "fail if all spec items have been filtered"+          FailOnFocused -> "fail on focused spec items"+          FailOnPending -> "fail on pending spec items"+          FailOnEmptyDescription -> "fail on empty descriptions"++    setFailOnItems :: Bool -> [FailOn] -> Config -> Config+    setFailOnItems value = flip $ foldr (`setItem` value)+      where+        setItem item = case item of+          FailOnEmpty -> setFailOnEmpty+          FailOnFocused -> setFailOnFocused+          FailOnPending -> setFailOnPending+          FailOnEmptyDescription -> setFailOnEmptyDescription++    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}++    setFailOnEmpty :: Bool -> Config -> Config+    setFailOnEmpty value config = config {configFailOnEmpty = value}++    setFailOnFocused :: Bool -> Config -> Config+    setFailOnFocused value config = config {configFailOnFocused = value}++    setFailOnPending :: Bool -> Config -> Config+    setFailOnPending value config = config {configFailOnPending = value}++    setFailOnEmptyDescription :: Bool -> Config -> Config+    setFailOnEmptyDescription value config = config {configFailOnEmptyDescription = value}++    setStrict :: Bool -> Config -> Config+    setStrict = (`setFailOnItems` strict)++    setFailFast :: Bool -> Config -> Config+    setFailFast value config = config {configFailFast = value}++    setRandomize :: Bool -> Config -> Config+    setRandomize value config = config {configRandomize = value}++    setRerun :: Bool -> Config -> Config+    setRerun value config = config {configRerun = value}++    setRerunAllOnSuccess :: Bool -> Config -> Config+    setRerunAllOnSuccess value config = config {configRerunAllOnSuccess = value}++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
+ src/Test/Hspec/Core/Config/Options.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE CPP #-}+module Test.Hspec.Core.Config.Options (+  ConfigFile+, envVarName+, ignoreConfigFile+, parseOptions+) where++import           Prelude ()+import           Test.Hspec.Core.Compat++import           System.Exit++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"++commandLineOptions :: Config -> [(String, [Declarative.Option Config])]+commandLineOptions config =+    ("OPTIONS", commandLineOnlyOptions)+  : otherOptions config++otherOptions :: Config -> [(String, [Declarative.Option Config])]+otherOptions config = [+    ("RUNNER OPTIONS", runnerOptions)+  , ("FORMATTER OPTIONS", formatterOptions formatters)+  , ("OPTIONS FOR QUICKCHECK", quickCheckOptions)+  , ("OPTIONS FOR SMALLCHECK", smallCheckOptions)+  ] ++ extensionOptions+  where+    formatters = configAvailableFormatters config+    extensionOptions = getExtensionOptions config++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, String)] -> [String] -> Either (ExitCode, String) ([String], Config)+parseOptions config prog configFiles envVar env args = do+      foldM (parseFileOptions prog) config configFiles+  >>= maybe return (parseEnvVarOptions prog) envVar+  >>= parseEnvironmentOptions env+  >>= traverse (parseCommandLineOptions prog args)++parseCommandLineOptions :: String -> [String] -> Config -> Either (ExitCode, String) Config+parseCommandLineOptions prog args config = case Declarative.parseCommandLineOptions (commandLineOptions config) prog args config of+  Success c -> Right c+  Help message -> Left (ExitSuccess, message)+  Failure message -> Left (ExitFailure 1, message)++parseEnvironmentOptions :: [(String, String)] -> Config -> Either (ExitCode, String) ([String], Config)+parseEnvironmentOptions env config = case Declarative.parseEnvironmentOptions "HSPEC" env config (concatMap snd $ commandLineOptions config) of+  (warnings, c) -> Right (map formatWarning warnings, c)+  where+    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 -> 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 (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 config)++    failure err = Left (ExitFailure 1, prog ++ ": " ++ message)+      where+        message = unlines $ case lines err of+          [x] -> [x ++ " " ++ source]+          xs -> xs ++ [source]
src/Test/Hspec/Core/Example.hs view
@@ -1,161 +1,273 @@-{-# LANGUAGE CPP, TypeFamilies, FlexibleInstances, TypeSynonymInstances, DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+ module Test.Hspec.Core.Example (+-- RE-EXPORTED from Test.Hspec.Core.Spec   Example (..)+#ifndef ENABLE_SPEC_HOOK_ARGS+, Arg+#endif , Params (..) , defaultParams , ActionWith , Progress , ProgressCallback-, Result (..)+, Result(..)+, ResultStatus (..) , Location (..)-, LocationAccuracy (..)+, FailureReason (..)+, safeEvaluate+, safeEvaluateExample+-- END RE-EXPORTED from Test.Hspec.Core.Spec+, safeEvaluateResultStatus+, exceptionToResultStatus+, toLocation+, hunitFailureToResult ) where -import           Data.Maybe (fromMaybe)-import           Data.List (isPrefixOf)+import           Prelude ()+import           Test.Hspec.Core.Compat+ import qualified Test.HUnit.Lang as HUnit-import qualified Control.Exception as E-import           Data.Typeable (Typeable)++import           Data.CallStack (SrcLoc(..))++import           Control.DeepSeq import qualified Test.QuickCheck as QC import           Test.Hspec.Expectations (Expectation) -import qualified Test.QuickCheck.State as QC-import qualified Test.QuickCheck.Property as QCP--import           Test.Hspec.Core.QuickCheckUtil import           Test.Hspec.Core.Util-import           Test.Hspec.Compat+import           Test.Hspec.Core.QuickCheck.Util (liftHook)+import           Test.Hspec.Core.Example.Location --- | A type class for examples+#ifdef ENABLE_SPEC_HOOK_ARGS+-- | A type class for examples, that is to say, test bodies as used in+-- `Test.Hspec.Core.Spec.it` and similar functions. class Example e where+  -- | The argument type that is needed to run this `Example`.+  -- If `Arg` is @()@, no argument is required and the `Example` can be run+  -- as-is.+  --+  -- The value of `Arg` is the difference between `Test.Hspec.Core.Spec.Spec`+  -- (aka @`Test.Hspec.Core.Hspec.SpecWith` ()@), which can be executed, and+  -- @`Test.Hspec.Core.Spec.SpecWith` a@, which cannot be executed without+  -- turning it into `Test.Hspec.Core.Spec.Spec` first.+  --+  -- To supply an argument to examples, use the functions in+  -- "Test.Hspec.Core.Hooks" such as `Test.Hspec.Core.Hooks.around',+  -- `Test.Hspec.Core.Hooks.before', `Test.Hspec.Core.Hooks.mapSubject' and+  -- similar.   type Arg e-#if __GLASGOW_HASKELL__ >= 704   type Arg e = ()+#else+type Arg e = ()++-- | A type class for examples, that is to say, test bodies as used in+-- `Test.Hspec.Core.Spec.it` and similar functions.+class Example e where #endif-  evaluateExample :: e -> Params -> (ActionWith (Arg e) -> IO ()) -> ProgressCallback -> IO Result +  -- | Evaluates an example.+  --+  -- `evaluateExample` is expected to execute the test body inside the IO action+  -- passed to the hook. It's often necessary to use an `IORef` to pass data+  -- out like whether the test succeeded to the outer IO action so it can be+  -- returned as a `Result`.+  --+  -- Example:+  --+  -- @+  -- newtype MyAction = MyAction (Int -> IO Bool)+  --+  -- instance Example MyAction where+  --   type Arg MyAction = Int+  --+  --   evaluateExample (MyAction act) _params hook _progress = do+  --     result <- newIORef (Result "" Success)+  --     hook $ \arg -> do+  --       -- e.g. determines if arg is 42+  --       ok <- act arg+  --       let result' = Result "" $ if ok then Success else Failure Nothing NoReason+  --       writeIORef result result'+  --     readIORef result+  -- @+  evaluateExample+    :: e+    -- ^ The example being evaluated+    -> Params+    -- ^ QuickCheck/SmallCheck settings+    -> (ActionWith (Arg e) -> IO ())+    -- ^ Hook: takes an @`ActionWith` (`Arg` e)@, namely, the IO action to run+    -- the test body, obtains @`Arg` e@ from somewhere, then executes the test+    -- body (or possibly decides not to execute it!).+    --+    -- This is used to implement `Test.Hspec.Core.Hooks.around` and similar+    -- hook functionality.+    -> ProgressCallback+    -- ^ Callback for composite tests like QuickCheck to report their progress.+    -> IO Result++-- | QuickCheck and SmallCheck related parameters. data Params = Params {   paramsQuickCheckArgs  :: QC.Args-, paramsSmallCheckDepth :: Int+, paramsSmallCheckDepth :: Maybe Int } deriving (Show)  defaultParams :: Params defaultParams = Params {   paramsQuickCheckArgs = QC.stdArgs-, paramsSmallCheckDepth = 5+, paramsSmallCheckDepth = Nothing } +-- | @(CurrentItem, TotalItems)@ tuple. type Progress = (Int, Int)+-- | Callback used by composite test items that contain many tests to report+-- their progress towards finishing them all.+--+-- This is used, for example, to report how many QuickCheck examples are finished. type ProgressCallback = Progress -> IO () --- | An `IO` action that expects an argument of type @a@+-- | An `IO` action that expects an argument of type @a@.+--+-- This type is what `Example`s are ultimately unlifted into for execution. type ActionWith a = a -> IO ()  -- | The result of running an example-data Result = Success | Pending (Maybe String) | Fail (Maybe Location) String-  deriving (Eq, Show, Read, Typeable)+data Result = Result {+  resultInfo :: String+, resultStatus :: ResultStatus+} deriving Show -instance E.Exception Result+data ResultStatus =+    Success+  | Pending (Maybe Location) (Maybe String)+  | Failure (Maybe Location) FailureReason+  deriving Show --- | @Location@ is used to represent source locations.-data Location = Location {-  locationFile :: FilePath-, locationLine :: Int-, locationColumn :: Int-, locationAccuracy :: LocationAccuracy-} deriving (Eq, Show, Read)+data FailureReason =+    NoReason+  | Reason String+  | ColorizedReason String+  | ExpectedButGot (Maybe String) String String+  | Error (Maybe String) SomeException+  deriving Show --- | A marker for source locations-data LocationAccuracy =-  -- | The source location is accurate-  ExactLocation |-  -- | The source location was determined on a best-effort basis and my be-  -- wrong or inaccurate-  BestEffort-  deriving (Eq, Show, Read)+instance NFData FailureReason where+  rnf reason = case reason of+    NoReason -> ()+    Reason r -> r `deepseq` ()+    ColorizedReason r -> r `deepseq` ()+    ExpectedButGot p e a  -> p `deepseq` e `deepseq` a `deepseq` ()+    Error m e -> m `deepseq` show e `deepseq` () -instance Example Bool where-  type Arg Bool = ()-  evaluateExample b _ _ _ = if b then return Success else return (Fail Nothing "")+instance Exception ResultStatus -instance Example Expectation where-  type Arg Expectation = ()-  evaluateExample e = evaluateExample (\() -> e)+forceResult :: Result -> Result+forceResult r@(Result info status) = info `deepseq` (forceResultStatus status) `seq` r -hunitFailureToResult :: HUnit.HUnitFailure -> Result-hunitFailureToResult e = case e of-#if MIN_VERSION_HUnit(1,3,0)-  HUnit.HUnitFailure mLoc err -> Fail location err-    where-      location = case mLoc of-        Nothing -> Nothing-        Just loc -> Just $ Location (HUnit.locationFile loc) (HUnit.locationLine loc) (HUnit.locationColumn loc) ExactLocation-#else-  HUnit.HUnitFailure err -> Fail Nothing err-#endif+forceResultStatus :: ResultStatus -> ResultStatus+forceResultStatus r = case r of+  Success -> r+  Pending _ m -> m `deepseq` r+  Failure _ m -> m `deepseq` r -instance Example (a -> Expectation) where-  type Arg (a -> Expectation) = a-  evaluateExample e _ action _ = (action e >> return Success) `E.catches` [-      E.Handler (return . hunitFailureToResult)-    , E.Handler (return :: Result -> IO Result)-    ]+safeEvaluateExample :: Example e => e -> Params -> (ActionWith (Arg e) -> IO ()) -> ProgressCallback -> IO Result+safeEvaluateExample example params around = safeEvaluate . evaluateExample example params around +safeEvaluate :: IO Result -> IO Result+safeEvaluate action = do+  r <- safeTry $ forceResult <$> action+  case r of+    Left e -> Result "" <$> exceptionToResultStatus e+    Right result -> return result++safeEvaluateResultStatus :: IO ResultStatus -> IO ResultStatus+safeEvaluateResultStatus action = do+  r <- safeTry $ forceResultStatus <$> action+  case r of+    Left e -> exceptionToResultStatus e+    Right status -> return status++exceptionToResultStatus :: SomeException -> IO ResultStatus+exceptionToResultStatus = safeEvaluateResultStatus . pure . toResultStatus+  where+    toResultStatus :: SomeException -> ResultStatus+    toResultStatus e+      | Just result <- fromException e = result+      | Just hunit <- fromException e = hunitFailureToResult Nothing hunit+      | otherwise = Failure Nothing $ Error Nothing e+ instance Example Result where+#ifdef ENABLE_SPEC_HOOK_ARGS   type Arg Result = ()-  evaluateExample r _ _ _ = return r+#endif+  evaluateExample e = evaluateExample (\() -> e) -instance Example QC.Property where-  type Arg QC.Property = ()+#ifdef ENABLE_SPEC_HOOK_ARGS+instance Example (a -> Result) where+  type Arg (a -> Result) = a+#else+instance Example (() -> Result) where+#endif+  evaluateExample example _params hook _callback = do+    liftHook (Result "" Success) hook (evaluate . example)++instance Example Bool where+#ifdef ENABLE_SPEC_HOOK_ARGS+  type Arg Bool = ()+#endif   evaluateExample e = evaluateExample (\() -> e) -instance Example (a -> QC.Property) where-  type Arg (a -> QC.Property) = a-  evaluateExample p c action progressCallback = do-    r <- QC.quickCheckWithResult (paramsQuickCheckArgs c) {QC.chatty = False} (QCP.callback qcProgressCallback $ aroundProperty action p)-    return $-      case r of-        QC.Success {}               -> Success-        QC.Failure {QC.output = m}  -> fromMaybe (Fail Nothing $ sanitizeFailureMessage r) (parsePending m)-        QC.GaveUp {QC.numTests = n} -> Fail Nothing ("Gave up after " ++ pluralize n "test" )-        QC.NoExpectedFailure {}     -> Fail Nothing ("No expected failure")-#if MIN_VERSION_QuickCheck(2,8,0)-        QC.InsufficientCoverage {}  -> Fail Nothing ("Insufficient coverage")+#ifdef ENABLE_SPEC_HOOK_ARGS+instance Example (a -> Bool) where+  type Arg (a -> Bool) = a+#else+instance Example (() -> Bool) where #endif+  evaluateExample p _params hook _callback = do+    liftHook (Result "" Success) hook (evaluate . example)     where-      qcProgressCallback = QCP.PostTest QCP.NotCounterexample $-        \st _ -> progressCallback (QC.numSuccessTests st, QC.maxSuccessTests st)+      example a+        | p a = Result "" Success+        | otherwise = Result "" $ Failure Nothing NoReason -      sanitizeFailureMessage :: QC.Result -> String-      sanitizeFailureMessage r = let m = QC.output r in strip $-#if MIN_VERSION_QuickCheck(2,7,0)-        case QC.theException r of-          Just e -> let numbers = formatNumbers r in-            "uncaught exception: " ++ formatException e ++ " " ++ numbers ++ "\n" ++ case lines m of-              x:xs | x == (exceptionPrefix ++ show e ++ "' " ++ numbers ++ ": ") -> unlines xs-              _ -> m-          Nothing ->+instance Example Expectation where+#ifdef ENABLE_SPEC_HOOK_ARGS+  type Arg Expectation = () #endif-            (addFalsifiable . stripFailed) m--      addFalsifiable :: String -> String-      addFalsifiable m-        | "(after " `isPrefixOf` m = "Falsifiable " ++ m-        | otherwise = m+  evaluateExample e = evaluateExample (\() -> e) -      stripFailed :: String -> String-      stripFailed m-        | prefix `isPrefixOf` m = drop n m-        | otherwise = m-        where-          prefix = "*** Failed! "-          n = length prefix+hunitFailureToResult :: Maybe String -> HUnit.HUnitFailure -> ResultStatus+hunitFailureToResult pre e = case e of+  HUnit.HUnitFailure mLoc err ->+      case err of+        HUnit.Reason reason -> Failure location (Reason $ addPre reason)+        HUnit.ExpectedButGot preface expected actual -> Failure location (ExpectedButGot (addPreMaybe preface) expected actual)+          where+            addPreMaybe :: Maybe String -> Maybe String+            addPreMaybe xs = case (pre, xs) of+              (Just x, Just y) -> Just (x ++ "\n" ++ y)+              _ -> pre <|> xs+    where+      location = case mLoc of+        Nothing -> Nothing+        Just loc -> Just $ toLocation loc+  where+    addPre :: String -> String+    addPre xs = case pre of+      Just x -> x ++ "\n" ++ xs+      Nothing -> xs -      parsePending :: String -> Maybe Result-      parsePending m-        | exceptionPrefix `isPrefixOf` m = (readMaybe . takeWhile (/= '\'') . drop n) m-        | otherwise = Nothing-        where-          n = length exceptionPrefix+toLocation :: SrcLoc -> Location+toLocation loc = Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc) -      exceptionPrefix = "*** Failed! Exception: '"+#ifdef ENABLE_SPEC_HOOK_ARGS+instance Example (a -> Expectation) where+  type Arg (a -> Expectation) = a+#else+instance Example (() -> Expectation) where+#endif+  evaluateExample e _params hook _ = hook e >> return (Result "" Success)
+ src/Test/Hspec/Core/Example/Location.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wno-missing-signatures #-}+module Test.Hspec.Core.Example.Location (+  Location(..)+, extractLocation++#ifdef TEST+, parseBacktraces+, parseAssertionFailed+, parseCallStack+, parseLocation+, parseSourceSpan++, workaroundForIssue19236+#endif+) where++import           Prelude ()+import           Test.Hspec.Core.Compat++import           Data.Char+import           GHC.IO.Exception++#if MIN_VERSION_base(4,21,0)+import           Control.Exception.Context+#endif++#ifdef mingw32_HOST_OS+import           System.FilePath+#endif++-- | @Location@ is used to represent source locations.+data Location = Location {+  locationFile :: FilePath+, locationLine :: Int+, locationColumn :: Int+} deriving (Eq, Show, Read)++extractLocation :: SomeException -> Maybe Location+#ifdef __MHS__+extractLocation _ = Nothing+#else+extractLocation e =+      locationFromErrorCall e+  <|> locationFromPatternMatchFail e+  <|> locationFromRecConError e+  <|> locationFromIOException e+  <|> locationFromNoMethodError e+#if !MIN_VERSION_base(4,21,0)+  <|> locationFromAssertionFailed e+#else+  <|> locationFromSomeException e++locationFromSomeException :: SomeException -> Maybe Location+locationFromSomeException = someExceptionContext >>> locationFromExceptionContext++locationFromExceptionContext :: ExceptionContext -> Maybe Location+locationFromExceptionContext = displayExceptionContext >>> parseBacktraces+#endif++_ignoreUnusedWarning = (parseBacktraces, locationFromAssertionFailed)++parseBacktraces :: String -> Maybe Location+parseBacktraces =+      lines+  >>> dropWhile (/= "HasCallStack backtrace:") >>> drop 1+  >>> takeWhile (isPrefixOf "  ")+  >>> parseCallStack++locationFromNoMethodError :: SomeException -> Maybe Location+locationFromNoMethodError e = case fromException e of+  Just (NoMethodError s) -> listToMaybe (words s) >>= parseSourceSpan+  Nothing -> Nothing++locationFromAssertionFailed :: SomeException -> Maybe Location+locationFromAssertionFailed e = case fromException e of+  Just (AssertionFailed loc) -> parseAssertionFailed loc+  Nothing -> Nothing++parseAssertionFailed :: String -> Maybe Location+parseAssertionFailed loc = parseCallStack (lines loc) <|> parseSourceSpan loc++locationFromErrorCall :: SomeException -> Maybe Location+locationFromErrorCall e = case fromException e of+#if MIN_VERSION_base(4,21,0)+  Just (ErrorCall _) -> Nothing+#else+  Just (ErrorCallWithLocation err loc) ->+    parseCallStack (lines loc) <|>+    fromPatternMatchFailureInDoExpression err+#endif+  Nothing -> Nothing++locationFromPatternMatchFail :: SomeException -> Maybe Location+locationFromPatternMatchFail e = case fromException e of+  Just (PatternMatchFail s) -> listToMaybe (words s) >>= parseSourceSpan+  Nothing -> Nothing++locationFromRecConError :: SomeException -> Maybe Location+locationFromRecConError e = case fromException e of+  Just (RecConError s) -> listToMaybe (words s) >>= parseSourceSpan+  Nothing -> Nothing++locationFromIOException :: SomeException -> Maybe Location+locationFromIOException e = case fromException e of+  Just (IOError {ioe_type = UserError, ioe_description = xs}) -> fromPatternMatchFailureInDoExpression xs+  Just _ -> Nothing+  Nothing -> Nothing++fromPatternMatchFailureInDoExpression :: String -> Maybe Location+fromPatternMatchFailureInDoExpression input =+#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 input of+  [] -> Nothing+  line : _ -> findLocation line+  where+    findLocation xs = case xs of+      [] -> Nothing+      _ : ys -> case stripPrefix prefix xs of+        Just zs -> parseLocation (takeWhile (not . isSpace) zs)+        Nothing -> findLocation ys+    prefix = ", called at "++parseLocation :: String -> Maybe Location+parseLocation input = case fmap breakColon (breakColon input) of+  (file, (line, column)) -> mkLocation file <$> readMaybe line <*> readMaybe column++parseSourceSpan :: String -> Maybe Location+parseSourceSpan input = case breakColon input of+  (file, xs) -> (uncurry $ mkLocation file) <$> (tuple <|> colonSeparated)+    where+      lineAndColumn :: String+      lineAndColumn = takeWhile (/= '-') xs++      tuple :: Maybe (Int, Int)+      tuple = readMaybe lineAndColumn++      colonSeparated :: Maybe (Int, Int)+      colonSeparated = case breakColon lineAndColumn of+        (l, c) -> (,) <$> readMaybe l <*> readMaybe c++breakColon :: String -> (String, String)+breakColon = fmap (drop 1) . break (== ':')++mkLocation :: FilePath -> Int -> Int -> Location+mkLocation file line column = Location (workaroundForIssue19236 file) line column++workaroundForIssue19236 :: FilePath -> FilePath -- https://gitlab.haskell.org/ghc/ghc/-/issues/19236+workaroundForIssue19236 =+#ifdef mingw32_HOST_OS+  joinPath . splitDirectories+#else+  id+#endif+#endif
+ src/Test/Hspec/Core/Extension.hs view
@@ -0,0 +1,112 @@+{-# OPTIONS_GHC -fno-warn-deprecations #-}+-- | Stability: unstable+module Test.Hspec.Core.Extension {-# WARNING "This API is experimental." #-} (+-- * Lifecycle of a test run+{- |+A test run goes through four distinct phases:++1. A tree of spec items and a default `Config` are constructed in `SpecM`.+2. Command-line options are parsed.  This transforms the default `Config` that was constructed in phase 1.+3. The tree of spec items is transformed in various ways, depending on specific `Config` values.+4. Each spec item is executed and its result is reported to the user.++An extension can directly influence phase 1, and indirectly influence phases 2-4.++When writing extensions the following imports are recommended:++@+import "Test.Hspec.Core.Extension"+import "Test.Hspec.Core.Extension.Config" qualified as Config+import "Test.Hspec.Core.Extension.Option" qualified as Option+import "Test.Hspec.Core.Extension.Item" qualified as Item+import "Test.Hspec.Core.Extension.Spec" qualified as Spec+import "Test.Hspec.Core.Extension.Tree" qualified as Tree+@+-}++-- ** Phase 1: Constructing a spec tree+{- |+- An extension can use @Spec.`Test.Hspec.Core.Extension.Spec.mapItems`@ to transform spec items in phase 1.++    * @Item.`setAnnotation`@ can be used to add custom metadata to a spec `Item`.++- An extension can use `modifyConfig` to modify the default config.++    * @Config.`Test.Hspec.Core.Extension.Config.setAnnotation`@ can be used to add custom metadata to the default `Config`.+-}+  runIO+, modifyConfig++-- ** Phase 2: Parsing command-line options+{- |+An extension can use `registerOptions` during phase 1 to register custom command-line options, and as a consequence indirectly influence this phase.++* Options can use @Config.`Test.Hspec.Core.Extension.Config.setAnnotation`@ to add custom metadata to the `Config`.+-}+, Option+, registerOptions++-- ** Phase 3: Transforming the spec tree+{- |+An extension can use `registerTransformation` during phase 1 to indirectly influence this phase.+-}+, registerTransformation++-- ** Phase 4: Reporting results+{- |+An extension can register a [custom formatter](https://hspec.github.io/extending-hspec-formatter.html) in phase 1 to indirectly influence this phase.+-}++-- * Types+{- |+Operations on these types are provided by the following modules respectively:++* "Test.Hspec.Core.Extension.Config"+* "Test.Hspec.Core.Extension.Item"+* "Test.Hspec.Core.Extension.Spec"+* "Test.Hspec.Core.Extension.Tree"+-}+, Config+, Item+, SpecM+, SpecWith+, SpecTree+) where++import           Prelude ()+import           Test.Hspec.Core.Compat++import qualified Data.CallStack as CallStack++import qualified GetOpt.Declarative as Declarative+import           Test.Hspec.Core.Spec (SpecM, SpecWith, runIO, modifyConfig)+import qualified Test.Hspec.Core.Spec as Core+import qualified Test.Hspec.Core.Config.Definition as Core++import           Test.Hspec.Core.Extension.Config (Config)+import qualified Test.Hspec.Core.Extension.Config.Type as Config+import           Test.Hspec.Core.Extension.Option+import           Test.Hspec.Core.Extension.Item+import           Test.Hspec.Core.Extension.Tree++registerOptions :: HasCallStack => [Option] -> SpecWith a+registerOptions = Core.modifyConfig . Core.addExtensionOptions section . map liftOption+  where+    section = "OPTIONS FOR " <> package+    package = maybe "main" (CallStack.srcLocPackage . snd) CallStack.callSite++    liftOption :: Option -> Declarative.Option Core.Config+    liftOption = Config.unOption++{- |+Register a transformation that transforms the spec tree in phase 3.++The registered transformation can use:++- @Tree.`mapItems`@ to modify spec items+- @Tree.`filterItems`@ to discard spec items+- @Config.`Test.Hspec.Core.Extension.Config.getAnnotation`@ to access custom config metadata+- @Item.`getAnnotation`@ to access custom item metadata+-}+registerTransformation :: (Config -> [SpecTree] -> [SpecTree]) -> SpecWith a+registerTransformation = modifyConfig . Config.addSpecTransformation
+ src/Test/Hspec/Core/Extension/Config.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS_GHC -fno-warn-deprecations #-}+module Test.Hspec.Core.Extension.Config {-# WARNING "This API is experimental." #-} (+-- * Types+  Config(..)+, Path+, ColorMode(..)+, UnicodeMode(..)++-- * Operations+, setAnnotation+, getAnnotation+) where++import           Prelude ()++import           Test.Hspec.Core.Format+import           Test.Hspec.Core.Config.Definition (ColorMode(..), UnicodeMode(..))++import           Test.Hspec.Core.Extension.Config.Type
+ src/Test/Hspec/Core/Extension/Config/Type.hs view
@@ -0,0 +1,43 @@+{-# OPTIONS_GHC -fno-warn-deprecations #-}+module Test.Hspec.Core.Extension.Config.Type (+  Option(..)+, Config(..)++, setAnnotation+, getAnnotation++, addSpecTransformation+, applySpecTransformation+) where++import           Prelude ()+import           Test.Hspec.Core.Compat++import qualified GetOpt.Declarative as Declarative++import           Test.Hspec.Core.Config.Definition (Config(..))+import qualified Test.Hspec.Core.Config.Definition as Core++import           Test.Hspec.Core.Extension.Tree (SpecTree)++newtype Option = Option { unOption :: Declarative.Option Config }++setAnnotation :: Typeable value => value -> Config -> Config+setAnnotation = Core.setConfigAnnotation++getAnnotation :: Typeable value => Config -> Maybe value+getAnnotation = Core.getConfigAnnotation++newtype SpecTransformation = SpecTransformation { unSpecTransformation :: Config -> [SpecTree] -> [SpecTree] }++setSpecTransformation :: (Config -> [SpecTree] -> [SpecTree]) -> Config -> Config+setSpecTransformation = setAnnotation . SpecTransformation++getSpecTransformation :: Config -> Config -> [SpecTree] -> [SpecTree]+getSpecTransformation = maybe (\ _ -> id) unSpecTransformation . getAnnotation++addSpecTransformation :: (Config -> [SpecTree] -> [SpecTree]) -> Config -> Config+addSpecTransformation f config = setSpecTransformation (\ c -> f c . getSpecTransformation config c) config++applySpecTransformation :: Core.Config -> [SpecTree] -> [SpecTree]+applySpecTransformation config = getSpecTransformation config config
+ src/Test/Hspec/Core/Extension/Item.hs view
@@ -0,0 +1,46 @@+module Test.Hspec.Core.Extension.Item {-# WARNING "This API is experimental." #-} (+-- * Types+  Item(..)+, Location(..)+, Params(..)+, ActionWith+, Progress+, ProgressCallback+, Result(..)+, ResultStatus(..)+, FailureReason(..)++-- * Operations+, isFocused+, pending+, pendingWith+, setAnnotation+, getAnnotation+) where++import           Prelude ()+import           Test.Hspec.Core.Compat++import           Test.Hspec.Core.Spec hiding (pending, pendingWith)+import           Test.Hspec.Core.Tree++isFocused :: Item a -> Bool+isFocused = itemIsFocused++pending :: Item a -> Item a+pending item = item { itemExample = \ _params _hook _progress -> result }+  where+    result :: IO Result+    result = return $ Result "" (Pending Nothing Nothing)++pendingWith :: String -> Item a -> Item a+pendingWith reason item = item { itemExample = \ _params _hook _progress -> result }+  where+    result :: IO Result+    result = return $ Result "" (Pending Nothing (Just reason))++setAnnotation :: Typeable value => value -> Item a -> Item a+setAnnotation = setItemAnnotation++getAnnotation :: Typeable value => Item a -> Maybe value+getAnnotation = getItemAnnotation
+ src/Test/Hspec/Core/Extension/Option.hs view
@@ -0,0 +1,27 @@+module Test.Hspec.Core.Extension.Option {-# WARNING "This API is experimental." #-} (+  Option+, flag+, argument+, noArgument+, optionalArgument+) where++import           Prelude ()+import           Test.Hspec.Core.Compat++import qualified GetOpt.Declarative as Declarative+import qualified Test.Hspec.Core.Config.Definition as Core++import           Test.Hspec.Core.Extension.Config.Type (Option(..), Config)++flag :: String -> (Bool -> Config -> Config) -> String -> Option+flag name setter = Option . Core.flag name setter++argument :: String -> String -> (String -> Config -> Maybe Config) -> String -> Option+argument name argumentName setter = Option . Core.option name (Declarative.Arg argumentName setter)++optionalArgument :: String -> String -> (Maybe String -> Config -> Maybe Config) -> String -> Option+optionalArgument name argumentName setter = Option . Core.option name (Declarative.OptArg argumentName setter)++noArgument :: String -> (Config -> Config) -> String -> Option+noArgument name setter help = Option $ Declarative.Option name Nothing (Declarative.NoArg setter) help False
+ src/Test/Hspec/Core/Extension/Spec.hs view
@@ -0,0 +1,10 @@+module Test.Hspec.Core.Extension.Spec {-# WARNING "This API is experimental." #-} (+  mapItems+) where++import           Prelude ()++import           Test.Hspec.Core.Spec++mapItems :: (Item a -> Item b) -> SpecWith a -> SpecWith b+mapItems = mapSpecItem_
+ src/Test/Hspec/Core/Extension/Tree.hs view
@@ -0,0 +1,19 @@+module Test.Hspec.Core.Extension.Tree {-# WARNING "This API is experimental." #-} (+  SpecTree+, mapItems+, filterItems+) where++import           Prelude ()+import           Test.Hspec.Core.Compat++import           Test.Hspec.Core.Spec hiding (SpecTree)+import qualified Test.Hspec.Core.Spec as Core++type SpecTree = Core.SpecTree ()++mapItems :: (Item () -> Item ()) -> [SpecTree] -> [SpecTree]+mapItems = map . fmap++filterItems :: (Item () -> Bool) -> [SpecTree] -> [SpecTree]+filterItems = filterForest
+ src/Test/Hspec/Core/FailureReport.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE CPP #-}+module Test.Hspec.Core.FailureReport (+  FailureReport (..)+, writeFailureReport+, readFailureReport+) where++#if !defined(__GHCJS__) && !defined(__MHS__)+-- ghcjs currently does not support setting environment variables+-- (https://github.com/ghcjs/ghcjs/issues/263). Since writing a failure report+-- into the environment is a non-essential feature we just disable this to be+-- able to run hspec test-suites with ghcjs at all. Should be reverted once+-- the issue is fixed.+#define HAS_SET_ENV+#endif+++import           Prelude ()+import           Test.Hspec.Core.Compat++#ifdef HAS_SET_ENV+import           System.Environment (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.Definition (Config(..))++data FailureReport = FailureReport {+  failureReportSeed :: Integer+, failureReportMaxSuccess :: Int+, failureReportMaxSize :: Int+, failureReportMaxDiscardRatio :: Int+, failureReportPaths :: [Path]+} deriving (Eq, Show, Read)++writeFailureReport :: Config -> FailureReport -> IO ()+writeFailureReport config report = case configFailureReport config of+  Just file -> writeFile file (show report)+  Nothing -> do+#ifdef HAS_SET_ENV+    -- on Windows this can throw an exception when the input is too large, hence+    -- we use `safeTry` here+    safeTry (setEnv "HSPEC_FAILURES" $ show report) >>= either onError return+    where+      onError err = do+        hPutStrLn stderr ("WARNING: Could not write environment variable HSPEC_FAILURES (" ++ show err ++ ")")+#else+    pass+#endif++readFailureReport :: Config -> IO (Maybe FailureReport)+readFailureReport config = case configFailureReport config of+  Just file -> do+    exists <- doesFileExist file+    if exists+      then do+        r <- readFile file+        let report = readMaybe r+        when (report == Nothing) $ do+          hPutStrLn stderr ("WARNING: Could not read failure report from file " ++ show file ++ "!")+        return report+      else return Nothing+  Nothing -> do+    mx <- lookupEnv "HSPEC_FAILURES"+    case mx >>= readMaybe of+      Nothing -> do+        hPutStrLn stderr "WARNING: Could not read environment variable HSPEC_FAILURES; `--rerun' is ignored!"+        return Nothing+      report -> return report
+ src/Test/Hspec/Core/Format.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ExistentialQuantification #-}+-- |+-- Stability: unstable+--+-- This is an unstable API.  Use+-- [Test.Hspec.Api.Format.V2](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Format-V2.html)+-- instead.+module Test.Hspec.Core.Format+-- {-# WARNING "Use [Test.Hspec.Api.Format.V2](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Format-V2.html) instead." #-}+(+  Format+, FormatConfig(..)+, defaultFormatConfig+, Event(..)+, Progress+, Path+, Location(..)+, Seconds(..)+, Item(..)+, Result(..)+, FailureReason(..)+, monadic+) where++import           Prelude ()+import           Test.Hspec.Core.Compat++import           Control.Concurrent+import           Control.Concurrent.Async (Async, async)+import qualified Control.Concurrent.Async as Async+import           Control.Monad.IO.Class++import           Test.Hspec.Core.Example (Progress, Location(..), FailureReason(..))+import           Test.Hspec.Core.Util (Path, formatExceptionWith)+import           Test.Hspec.Core.Clock (Seconds(..))++type Format = Event -> IO ()++data Item = Item {+  itemLocation :: Maybe Location+, itemDuration :: Seconds+, itemInfo :: String+, itemResult :: Result+} deriving Show++data Result =+    Success+  | Pending (Maybe Location) (Maybe String)+  | Failure (Maybe Location) FailureReason+  deriving Show++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+, formatConfigReportProgress :: Bool+, formatConfigOutputUnicode :: Bool+, formatConfigUseDiff :: Bool+, formatConfigDiffContext :: Maybe Int+, formatConfigExternalDiff :: Maybe (String -> String -> IO ())+, formatConfigPrettyPrint :: Bool+, formatConfigPrettyPrintFunction :: Maybe (String -> String -> (String, String))+, formatConfigFormatException :: SomeException -> String -- ^ @since 2.11.5+, formatConfigPrintTimes :: Bool+, formatConfigHtmlOutput :: Bool+, formatConfigPrintCpuTime :: Bool+, formatConfigUsedSeed :: Integer+, formatConfigExpectedTotalCount :: Int+, formatConfigExpertMode :: Bool+}++{-# DEPRECATED formatConfigPrettyPrint "Use `formatConfigPrettyPrintFunction` instead" #-}++-- ^ @since 2.11.5+defaultFormatConfig :: FormatConfig+defaultFormatConfig = FormatConfig {+  formatConfigUseColor = False+, formatConfigReportProgress = False+, formatConfigOutputUnicode = False+, formatConfigUseDiff = False+, formatConfigDiffContext = Nothing+, formatConfigExternalDiff = Nothing+, formatConfigPrettyPrint = False+, formatConfigPrettyPrintFunction = Nothing+, formatConfigFormatException = formatExceptionWith show+, formatConfigPrintTimes = False+, formatConfigHtmlOutput = False+, formatConfigPrintCpuTime = False+, formatConfigUsedSeed = 0+, formatConfigExpectedTotalCount = 0+, formatConfigExpertMode = False+}++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 {} -> pass+        _ -> do+          signal Ok+          go++  worker <- async $ do+    (run go >> signal Ok) `catch` (signal . NotOk)++  return $ \ event -> do+    running <- asyncRunning worker+    when running $ do+      putEvent event+      r <- wait+      case r of+        Ok -> pass+        NotOk err -> do+          Async.wait worker+          throwIO err++asyncRunning :: Async () -> IO Bool+asyncRunning worker = maybe True (const False) <$> Async.poll worker
src/Test/Hspec/Core/Formatters.hs view
@@ -1,222 +1,5 @@--- |--- Stability: experimental------ This module contains formatters that can be used with--- `Test.Hspec.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 (..)-, FormatM---- ** Accessing the runner state-, getSuccessCount-, getPendingCount-, getFailCount-, getTotalCount--, FailureRecord (..)-, getFailMessages-, usedSeed--, getCPUTime-, getRealTime---- ** Appending to the gerenated report-, write-, writeLine-, newParagraph---- ** Dealing with colors-, withInfoColor-, withSuccessColor-, withPendingColor-, withFailColor---- ** Helpers-, formatException-) where--import           Prelude ()-import           Test.Hspec.Compat--import           Data.Maybe-import           Test.Hspec.Core.Util-import           Test.Hspec.Core.Spec (Location(..), LocationAccuracy(..))-import           Text.Printf-import           Control.Monad (when, unless)-import           System.IO (hPutStr, hFlush)---- We use an explicit import list for "Test.Hspec.Formatters.Internal", to make--- sure, that we only use the public API to implement formatters.------ Everything imported here has to be re-exported, so that users can implement--- their own formatters.-import Test.Hspec.Core.Formatters.Internal (-    Formatter (..)-  , FormatM--  , getSuccessCount-  , getPendingCount-  , getFailCount-  , getTotalCount--  , FailureRecord (..)-  , getFailMessages-  , usedSeed--  , getCPUTime-  , getRealTime--  , write-  , writeLine-  , newParagraph--  , withInfoColor-  , withSuccessColor-  , withPendingColor-  , withFailColor-  )--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 = \h _ p -> do-    hPutStr h (formatProgress p)-    hFlush h--, exampleSucceeded = \(nesting, requirement) -> withSuccessColor $ do-    writeLine $ indentationFor nesting ++ requirement--, exampleFailed = \(nesting, requirement) _ -> withFailColor $ do-    n <- getFailCount-    writeLine $ indentationFor nesting ++ requirement ++ " FAILED [" ++ show n ++ "]"--, examplePending = \(nesting, requirement) reason -> withPendingColor $ do-    writeLine $ indentationFor nesting ++ requirement ++ "\n     # PENDING: " ++ fromMaybe "No reason given" reason--, failedFormatter = defaultFailedFormatter--, footerFormatter = defaultFooter-} where-    indentationFor nesting = replicate (length nesting * 2) ' '-    formatProgress (current, total)-      | total == 0 = show current ++ "\r"-      | otherwise  = show current ++ "/" ++ show total ++ "\r"---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 ""--    when (hasBestEffortLocations failures) $ do-      withInfoColor $ writeLine "Source locations marked with \"best-effort\" are calculated heuristically and may be incorrect."-      writeLine ""--    write "Randomized with seed " >> usedSeed >>= writeLine . show-    writeLine ""-  where-    hasBestEffortLocations :: [FailureRecord] -> Bool-    hasBestEffortLocations = any p-      where-        p :: FailureRecord -> Bool-        p failure = (locationAccuracy <$> failureRecordLocation failure) == Just BestEffort--    formatFailure :: (Int, FailureRecord) -> FormatM ()-    formatFailure (n, FailureRecord mLoc path reason) = do-      forM_ mLoc $ \loc -> do-        withInfoColor $ writeLine (formatLoc loc)-      write ("  " ++ show n ++ ") ")-      writeLine (formatRequirement path)-      withFailColor $ do-        forM_ (lines err) $ \x -> do-          writeLine ("       " ++ x)-      where-        err = either (("uncaught exception: " ++) . formatException) id reason-        formatLoc (Location file line _column accuracy) = "  " ++ file ++ ":" ++ show line ++ ":" ++ message-          where-            message = case accuracy of-              ExactLocation -> " " -- NOTE: Vim's default 'errorformat'-                                   -- requires a non-empty message.  This is-                                   -- why we use a single space as message-                                   -- here.-              BestEffort -> " (best-effort)"--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 c | fails /= 0   = withFailColor-        | pending /= 0 = withPendingColor-        | otherwise    = withSuccessColor-  c $ do-    write $ pluralize total   "example"-    write (", " ++ pluralize fails "failure")-    unless (pending == 0) $-      write (", " ++ show pending ++ " pending")-  writeLine ""+{-# OPTIONS_GHC -fno-warn-deprecations #-}+module Test.Hspec.Core.Formatters+{-# DEPRECATED "Use [Test.Hspec.Api.Formatters.V1](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Formatters-V1.html) instead." #-}+(module V1) where+import           Test.Hspec.Core.Formatters.V1 as V1
+ src/Test/Hspec/Core/Formatters/Diff.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ViewPatterns #-}+module Test.Hspec.Core.Formatters.Diff (+  Diff (..)+, diff++, LineDiff(..)+, lineDiff++, splitLines++#ifdef TEST+, partition+, breakList+#endif+) where++import           Prelude ()+import           Test.Hspec.Core.Compat++import           Data.Char+import qualified Data.Algorithm.Diff as Diff++data Diff = First String | Second String | Both String+  deriving (Eq, Show)++data LineDiff =+    LinesFirst [String]+  | LinesSecond [String]+  | LinesBoth [String]+  | SingleLineDiff [Diff]+  | LinesOmitted Int+  deriving (Eq, Show)++lineDiff :: Maybe Int -> String -> String -> [LineDiff]+lineDiff context expected actual = maybe id applyContext context $ singleLineDiffs diffs+  where+    diffs :: [LineDiff]+    diffs = Diff.getGroupedDiff expectedLines actualLines <&> \ case+      Diff.First xs -> LinesFirst xs+      Diff.Second xs -> LinesSecond xs+      Diff.Both xs _ -> LinesBoth xs++    expectedLines :: [String]+    expectedLines = splitLines expected++    actualLines :: [String]+    actualLines = splitLines actual++singleLineDiffs :: [LineDiff] -> [LineDiff]+singleLineDiffs = go+  where+    go = \ case+      [] -> []+      LinesFirst [first_] : LinesSecond [second_] : xs -> SingleLineDiff (diff first_ second_) : go xs+      x : xs -> x : go xs++splitLines :: String -> [String]+splitLines = go+  where+    go :: String -> [String]+    go xs = case break (== '\n') xs of+      (ys, '\n' : zs) -> ys : go zs+      _ -> [xs]++data TrimMode = FirstChunk | Chunk | LastChunk++applyContext :: Int -> [LineDiff] -> [LineDiff]+applyContext context = \ diffs -> case diffs of+  [] -> []+  x : xs -> trimChunk FirstChunk x (go xs)+  where+    omitThreshold :: Int+    omitThreshold = 3++    go :: [LineDiff] -> [LineDiff]+    go diffs = case diffs of+      [] -> []+      [x] -> trimChunk LastChunk x []+      x : xs -> trimChunk Chunk x (go xs)++    trimChunk :: TrimMode -> LineDiff -> [LineDiff] -> [LineDiff]+    trimChunk mode chunk = case chunk of+      LinesBoth allLines | meetsThreshold -> keep start . (LinesOmitted omitted :) . keep end+        where+          meetsThreshold :: Bool+          meetsThreshold = omitThreshold <= omitted++          lastLineHasNL = case (mode, reverse allLines) of+            (LastChunk, "" : _) -> True+            _ -> False++          omitted :: Int+          omitted = n - keepStart - keepEnd++          keepStart :: Int+          keepStart = case mode of+            FirstChunk -> 0+            _ -> context++          keepEnd :: Int+          keepEnd = case mode of+            LastChunk -> 0+            _ -> context++          n :: Int+          n = length allLines - case lastLineHasNL of+            False -> 0+            True -> 1++          start :: [String]+          start = take keepStart allLines++          end :: [String]+          end = drop (keepStart + omitted) allLines++      _ -> (chunk :)++keep :: [String] -> [LineDiff] -> [LineDiff]+keep xs+  | null xs = id+  | otherwise = (LinesBoth xs :)++diff :: String -> String -> [Diff]+diff expected actual = diffs+  where+    diffs :: [Diff]+    diffs = map (toDiff . fmap concat) $ Diff.getGroupedDiff expectedChunks actualChunks++    expectedChunks :: [String]+    expectedChunks = partition expected++    actualChunks :: [String]+    actualChunks = partition actual++toDiff :: Diff.Diff String -> Diff+toDiff d = case d of+  Diff.First xs -> First xs+  Diff.Second xs -> Second xs+  Diff.Both xs _ -> Both xs++partition :: String -> [String]+partition = filter (not . null) . mergeBackslashes . breakList isAlphaNum+  where+    mergeBackslashes :: [String] -> [String]+    mergeBackslashes xs = case xs of+      ['\\'] : (splitEscape -> Just (escape, ys)) : zs -> ("\\" ++ escape) : ys : mergeBackslashes zs+      z : zs -> z : mergeBackslashes zs+      [] -> []++breakList :: (a -> Bool) -> [a] -> [[a]]+breakList _ [] = []+breakList p xs = case break p xs of+  (y, ys) -> map return y ++ case span p ys of+    (z, zs) -> z `cons` breakList p zs+  where+    cons x+      | null x = id+      | otherwise = (x :)++splitEscape :: String -> Maybe (String, String)+splitEscape xs = splitNumericEscape xs <|> msum (map split escapes)+  where+    split :: String -> Maybe (String, String)+    split escape = (,) escape <$> stripPrefix escape xs++splitNumericEscape :: String -> Maybe (String, String)+splitNumericEscape xs = case span isDigit xs of+  ("", _) -> Nothing+  r -> Just r++escapes :: [String]+escapes = [+    "ACK"+  , "CAN"+  , "DC1"+  , "DC2"+  , "DC3"+  , "DC4"+  , "DEL"+  , "DLE"+  , "ENQ"+  , "EOT"+  , "ESC"+  , "ETB"+  , "ETX"+  , "NAK"+  , "NUL"+  , "SOH"+  , "STX"+  , "SUB"+  , "SYN"+  , "EM"+  , "FS"+  , "GS"+  , "RS"+  , "SI"+  , "SO"+  , "US"+  , "a"+  , "b"+  , "f"+  , "n"+  , "r"+  , "t"+  , "v"+  , "&"+  , "'"+  , "\""+  , "\\"+  ]
src/Test/Hspec/Core/Formatters/Internal.hs view
@@ -1,191 +1,313 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-} module Test.Hspec.Core.Formatters.Internal (---- * Public API-  Formatter (..)+  Formatter(..)+, Item(..)+, Result(..)+, FailureReason(..) , FormatM+, formatterToFormat +, getConfig+, getConfigValue+, FormatConfig(..)+ , getSuccessCount , getPendingCount , getFailCount , getTotalCount+, getExpectedTotalCount -, FailureRecord (..)+, FailureRecord(..) , getFailMessages , usedSeed +, printTimes , getCPUTime , getRealTime  , write , writeLine-, newParagraph+, writeTransient  , withInfoColor , withSuccessColor , withPendingColor , withFailColor --- * Functions for internal use+, outputUnicode++, useDiff+, diffContext+, externalDiffAction+, prettyPrint+, prettyPrintFunction+, extraChunk+, missingChunk++, unlessExpert++#ifdef TEST , runFormatM-, increaseSuccessCount-, increasePendingCount-, increaseFailCount-, addFailMessage-, finally_+, splitLines+#endif ) where  import           Prelude ()-import           Test.Hspec.Compat+import           Test.Hspec.Core.Compat  import qualified System.IO as IO-import           System.IO (Handle)-import           Control.Monad-import           Control.Exception (SomeException, AsyncException(..), bracket_, try, throwIO)-import           System.Console.ANSI-import           Control.Monad.Trans.State hiding (gets, modify)+import           System.IO (stdout)+import           System.Console.ANSI hiding (clearLine)+import           Control.Monad.Trans.Reader (ReaderT(..), ask) import           Control.Monad.IO.Class+import           Data.Char (isSpace)+import           Data.List (groupBy) import qualified System.CPUTime as CPUTime-import           Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) -import           Test.Hspec.Core.Util (Path)-import           Test.Hspec.Core.Spec (Progress, Location)+import           Test.Hspec.Core.Format+import           Test.Hspec.Core.Clock +data Formatter = Formatter {+-- | evaluated before a test run+  formatterStarted :: FormatM ()++-- | 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 ()+}++data FailureRecord = FailureRecord {+  failureRecordLocation :: Maybe Location+, failureRecordPath     :: Path+, failureRecordMessage  :: FailureReason+}++formatterToFormat :: Formatter -> FormatConfig -> IO Format+formatterToFormat Formatter{..} config = monadic (runFormatM config) $ \ case+  Started -> formatterStarted+  GroupStarted path -> formatterGroupStarted path+  GroupDone path -> formatterGroupDone path+  Progress path progress -> formatterProgress path progress+  ItemStarted path -> formatterItemStarted path+  ItemDone path item -> do+    case itemResult item of+      Success {} -> increaseSuccessCount+      Pending {} -> increasePendingCount+      Failure loc err -> addFailure $ FailureRecord (loc <|> itemLocation item) path err+    formatterItemDone path item+  Done _ -> formatterDone+  where+    addFailure r = modify $ \ s -> s { stateFailMessages = r : stateFailMessages s }++-- | Get the number of failed examples encountered so far.+getFailCount :: FormatM Int+getFailCount = length <$> getFailMessages++-- | Return `True` if the user requested colorized diffs, `False` otherwise.+useDiff :: FormatM Bool+useDiff = getConfigValue formatConfigUseDiff++-- | Do nothing on `--expert`, otherwise run the given action.+--+-- @since 2.11.2+unlessExpert :: FormatM () -> FormatM ()+unlessExpert action = getConfigValue formatConfigExpertMode >>= \ case+  False -> action+  True -> return ()++-- |+-- Return the value of `Test.Hspec.Core.Runner.configDiffContext`.+--+-- @since 2.10.6+diffContext :: FormatM (Maybe Int)+diffContext = getConfigValue formatConfigDiffContext++-- | An action for printing diffs.+--+-- The action takes @expected@ and @actual@ as arguments.+--+-- When this is a `Just`-value then it should be used instead of any built-in+-- diff implementation.  A `Just`-value also implies that `useDiff` returns+-- `True`.+--+-- @since 2.10.6+externalDiffAction :: FormatM (Maybe (String -> String -> IO ()))+externalDiffAction = getConfigValue formatConfigExternalDiff++-- | Return `True` if the user requested pretty diffs, `False` otherwise.+prettyPrint :: FormatM Bool+prettyPrint = maybe False (const True) <$> getConfigValue formatConfigPrettyPrintFunction+{-# DEPRECATED prettyPrint "use `prettyPrintFunction` instead" #-}++-- | Return a function for pretty-printing if the user requested pretty diffs,+-- `Nothing` otherwise.+--+-- @since 2.10.0+prettyPrintFunction :: FormatM (Maybe (String -> String -> (String, String)))+prettyPrintFunction = getConfigValue formatConfigPrettyPrintFunction++-- | Return `True` if the user requested unicode output, `False` otherwise.+--+-- @since 2.9.0+outputUnicode :: FormatM Bool+outputUnicode = getConfigValue 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-  f <$> (get >>= liftIO . readIORef)+  f <$> (ask >>= liftIO . readIORef)  -- | A lifted version of `Control.Monad.Trans.State.modify` modify :: (FormatterState -> FormatterState) -> FormatM () modify f = FormatM $ do-  get >>= liftIO . (`modifyIORef'` f)+  ask >>= liftIO . (`modifyIORef'` f)  data FormatterState = FormatterState {-  stateHandle     :: Handle-, stateUseColor   :: Bool-, produceHTML     :: Bool-, successCount    :: Int-, pendingCount    :: Int-, failCount       :: Int-, failMessages    :: [FailureRecord]-, stateUsedSeed   :: Integer-, cpuStartTime    :: Maybe Integer-, startTime       :: POSIXTime+  stateSuccessCount    :: !Int+, statePendingCount    :: !Int+, stateFailMessages    :: [FailureRecord]+, stateCpuStartTime    :: Maybe Integer+, stateStartTime       :: Seconds+, stateConfig          :: FormatConfig+, stateColor           :: Maybe SGR } +-- | @since 2.11.5+getConfig :: FormatM FormatConfig+getConfig = gets stateConfig++-- | @since 2.11.5+getConfigValue :: (FormatConfig -> a) -> FormatM a+getConfigValue f = gets (f . stateConfig)+ -- | The random seed that is used for QuickCheck. usedSeed :: FormatM Integer-usedSeed = gets stateUsedSeed---- | The total number of examples encountered so far.-totalCount :: FormatterState -> Int-totalCount s = successCount s + pendingCount s + failCount s+usedSeed = getConfigValue formatConfigUsedSeed  -- NOTE: We use an IORef here, so that the state persists when UserInterrupt is -- thrown.-newtype FormatM a = FormatM (StateT (IORef FormatterState) IO a)+newtype FormatM a = FormatM (ReaderT (IORef FormatterState) IO a)   deriving (Functor, Applicative, Monad, MonadIO) -runFormatM :: Bool -> Bool -> Bool -> Integer -> Handle -> FormatM a -> IO a-runFormatM useColor produceHTML_ printCpuTime seed handle (FormatM action) = do-  time <- getPOSIXTime-  cpuTime <- if printCpuTime then Just <$> CPUTime.getCPUTime else pure Nothing-  st <- newIORef (FormatterState handle useColor produceHTML_ 0 0 0 [] seed cpuTime time)-  evalStateT action st+runFormatM :: FormatConfig -> FormatM a -> IO a+runFormatM config (FormatM action) = withLineBuffering $ do+  time <- getMonotonicTime+  cpuTime <- if formatConfigPrintCpuTime config then Just <$> CPUTime.getCPUTime else pure Nothing +  let+    progress = formatConfigReportProgress config && not (formatConfigHtmlOutput config)+    state = FormatterState {+      stateSuccessCount = 0+    , statePendingCount = 0+    , stateFailMessages = []+    , stateCpuStartTime = cpuTime+    , stateStartTime = time+    , stateConfig = config { formatConfigReportProgress = progress }+    , stateColor = Nothing+    }+  newIORef state >>= runReaderT action++withLineBuffering :: IO a -> IO a+withLineBuffering action = bracket (IO.hGetBuffering stdout) (IO.hSetBuffering stdout) $ \ _ -> do+  IO.hSetBuffering stdout IO.LineBuffering >> action+ -- | Increase the counter for successful examples increaseSuccessCount :: FormatM ()-increaseSuccessCount = modify $ \s -> s {successCount = succ $ successCount s}+increaseSuccessCount = modify $ \s -> s {stateSuccessCount = succ $ stateSuccessCount s}  -- | Increase the counter for pending examples increasePendingCount :: FormatM ()-increasePendingCount = modify $ \s -> s {pendingCount = succ $ pendingCount s}---- | Increase the counter for failed examples-increaseFailCount :: FormatM ()-increaseFailCount = modify $ \s -> s {failCount = succ $ failCount s}+increasePendingCount = modify $ \s -> s {statePendingCount = succ $ statePendingCount s}  -- | Get the number of successful examples encountered so far. getSuccessCount :: FormatM Int-getSuccessCount = gets successCount+getSuccessCount = gets stateSuccessCount  -- | Get the number of pending examples encountered so far. getPendingCount :: FormatM Int-getPendingCount = gets pendingCount---- | Get the number of failed examples encountered so far.-getFailCount :: FormatM Int-getFailCount = gets failCount---- | Get the total number of examples encountered so far.-getTotalCount :: FormatM Int-getTotalCount = gets totalCount---- | Append to the list of accumulated failure messages.-addFailMessage :: Maybe Location -> Path -> Either SomeException String -> FormatM ()-addFailMessage loc p m = modify $ \s -> s {failMessages = FailureRecord loc p m : failMessages s}+getPendingCount = gets statePendingCount  -- | Get the list of accumulated failure messages. getFailMessages :: FormatM [FailureRecord]-getFailMessages = reverse `fmap` gets failMessages--data FailureRecord = FailureRecord {-  failureRecordLocation :: Maybe Location-, failureRecordPath     :: Path-, failureRecordMessage  :: Either SomeException String-}--data Formatter = Formatter {--  headerFormatter :: FormatM ()---- | evaluated before each test group------ The given number indicates the position within the parent group.-, exampleGroupStarted :: [String] -> String -> FormatM ()--, exampleGroupDone    :: FormatM ()+getFailMessages = reverse `fmap` gets stateFailMessages --- | used to notify the progress of the currently evaluated example+-- | Get the number of spec items that will have been encountered when this run+-- completes (if it is not terminated early). ----- /Note/: This is only called when interactive/color mode.-, exampleProgress     :: Handle -> Path -> Progress -> IO ()---- | evaluated after each successful example-, exampleSucceeded    :: Path -> FormatM ()---- | evaluated after each failed example-, exampleFailed       :: Path -> Either SomeException String -> FormatM ()---- | evaluated after each pending example-, examplePending      :: Path -> Maybe String -> FormatM ()---- | evaluated after a test run-, failedFormatter     :: FormatM ()+-- @since 2.9.0+getExpectedTotalCount :: FormatM Int+getExpectedTotalCount = getConfigValue formatConfigExpectedTotalCount --- | evaluated after `failuresFormatter`-, footerFormatter     :: FormatM ()-}+writeTransient :: String -> FormatM ()+writeTransient new = do+  reportProgress <- getConfigValue formatConfigReportProgress+  when reportProgress . liftIO $ do+    bracket_ disableLineWrapping enableLineWrapping $ writePlain new+    IO.hFlush stdout+    clearLine+  where+    disableLineWrapping :: IO ()+    disableLineWrapping = writePlain "\ESC[?7l" +    enableLineWrapping :: IO ()+    enableLineWrapping = writePlain "\ESC[?7h" --- | Append an empty line to the report.------ Calling this multiple times has the same effect as calling it once.-newParagraph :: FormatM ()-newParagraph = writeLine ""-{-# DEPRECATED newParagraph "use @writeLine \"\"@ instead" #-}+    clearLine :: IO ()+    clearLine = writePlain "\r\ESC[K"  -- | Append some output to the report. write :: String -> FormatM ()-write s = do-  h <- gets stateHandle-  liftIO $ IO.hPutStr h s+write = mapM_ writeChunk . splitLines --- | The same as `write`, but adds a newline character.-writeLine :: String -> FormatM ()-writeLine s = write s >> write "\n"+splitLines :: String -> [String]+splitLines = groupBy (\ a b -> isNewline a == isNewline b)+  where+    isNewline = (== '\n') +writeChunk :: String -> FormatM ()+writeChunk str = do+  let+    plainOutput = writePlain str+    colorOutput color = bracket_ (hSetSGR stdout [color]) (hSetSGR stdout [Reset]) plainOutput+  mColor <- gets stateColor+  liftIO $ case mColor of+    Just (SetColor Foreground _ _) | all isSpace str -> plainOutput+    Just color -> colorOutput color+    Nothing -> plainOutput++writePlain :: String -> IO ()+writePlain = IO.hPutStr stdout+ -- | Set output color to red, run given action, and finally restore the default -- color. withFailColor :: FormatM a -> FormatM a@@ -209,55 +331,70 @@ -- | Set a color, run an action, and finally reset colors. withColor :: SGR -> String -> FormatM a -> FormatM a withColor color cls action = do-  r <- gets produceHTML-  (if r then htmlSpan cls else withColor_ color) action+  produceHTML <- getConfigValue formatConfigHtmlOutput+  (if produceHTML then htmlSpan cls else withColor_ color) action  htmlSpan :: String -> FormatM a -> FormatM a htmlSpan cls action = write ("<span class=\"" ++ cls ++ "\">") *> action <* write "</span>"  withColor_ :: SGR -> FormatM a -> FormatM a-withColor_ color (FormatM action) = do-  useColor <- gets stateUseColor-  h        <- gets stateHandle+withColor_ color action = do+  oldColor <- gets stateColor+  setColor (Just color) *> action <* setColor oldColor -  FormatM . StateT $ \st -> do-    bracket_+setColor :: Maybe SGR -> FormatM ()+setColor color = do+  useColor <- getConfigValue formatConfigUseColor+  when useColor $ do+    modify (\ state -> state { stateColor = color }) -      -- set color-      (when useColor $ hSetSGR h [color])+-- | Output given chunk in red.+extraChunk :: String -> FormatM ()+extraChunk s = do+  diff <- getConfigValue formatConfigUseDiff+  case diff of+    True -> extra s+    False -> write s+  where+    extra :: String -> FormatM ()+    extra = diffColorize Red "hspec-failure" -      -- reset colors-      (when useColor $ hSetSGR h [Reset])+-- | Output given chunk in green.+missingChunk :: String -> FormatM ()+missingChunk s = do+  diff <- getConfigValue formatConfigUseDiff+  case diff of+    True -> missing s+    False -> write s+  where+    missing :: String-> FormatM ()+    missing = diffColorize Green "hspec-success" -      -- run action-      (runStateT action st)+diffColorize :: Color -> String -> String-> FormatM ()+diffColorize color cls s = withColor (SetColor layer Dull color) cls $ case s of+  "" -> write eraseInLine+  _ -> write s+  where+    eraseInLine :: String+    eraseInLine = "\ESC[K" --- |--- @finally_ actionA actionB@ runs @actionA@ and then @actionB@.  @actionB@ is--- run even when a `UserInterrupt` occurs during @actionA@.-finally_ :: FormatM () -> FormatM () -> FormatM ()-finally_ (FormatM actionA) (FormatM actionB) = FormatM . StateT $ \st -> do-  r <- try (execStateT actionA st)-  case r of-    Left e -> do-      when (e == UserInterrupt) $-        runStateT actionB st >> return ()-      throwIO e-    Right st_ -> do-      runStateT actionB st_+    layer :: ConsoleLayer+    layer+      | all isSpace s = Background+      | otherwise = Foreground  -- | Get the used CPU time since the test run has been started.-getCPUTime :: FormatM (Maybe Double)+getCPUTime :: FormatM (Maybe Seconds) getCPUTime = do   t1  <- liftIO CPUTime.getCPUTime-  mt0 <- gets cpuStartTime-  return $ toSeconds <$> ((-) <$> pure t1 <*> mt0)+  mt0 <- gets stateCpuStartTime+  return $ toSeconds <$> ((t1 -) <$> mt0)   where-    toSeconds x = fromIntegral x / (10.0 ^ (12 :: Integer))+    toSeconds x = Seconds (fromIntegral x / (10.0 ^ (12 :: Integer)))  -- | Get the passed real time since the test run has been started.-getRealTime :: FormatM Double+getRealTime :: FormatM Seconds getRealTime = do-  t1 <- liftIO getPOSIXTime-  t0 <- gets startTime-  return (realToFrac $ t1 - t0)+  t1 <- liftIO getMonotonicTime+  t0 <- gets stateStartTime+  return (t1 - t0)
+ src/Test/Hspec/Core/Formatters/Pretty.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+module Test.Hspec.Core.Formatters.Pretty (+  pretty2+#ifdef TEST+, pretty+, recoverString+, recoverMultiLineString+#endif+) where++import           Prelude ()+import           Test.Hspec.Core.Compat hiding (shows, intercalate)++import           Data.Char+import           Data.String+import           Data.List (intersperse)+import qualified Text.Show as Show++import           Test.Hspec.Core.Formatters.Pretty.Unicode+import           Test.Hspec.Core.Formatters.Pretty.Parser++pretty2 :: Bool -> String -> String -> (String, String)+pretty2 unicode expected actual = case (recoverMultiLineString unicode expected, recoverMultiLineString unicode actual) of+  (Just expected_, Just actual_) -> (expected_, actual_)+  _ -> case (pretty unicode expected, pretty unicode actual) of+    (Just expected_, Just actual_) | expected_ /= actual_ -> (expected_, actual_)+    _ -> (expected, actual)++recoverString :: String -> Maybe String+recoverString xs = case xs of+  '"' : _ -> case reverse xs of+    '"' : _ -> readMaybe xs+    _ -> Nothing+  _ -> Nothing++recoverMultiLineString :: Bool -> String -> Maybe String+recoverMultiLineString unicode input = case recoverString input of+  Just r | shouldParseBack r -> Just r+  _ -> Nothing+  where+    shouldParseBack = (&&) <$> all isSafe <*> isMultiLine+    isMultiLine = lines >>> length >>> (> 1)+    isSafe c = (unicode || isAscii c) && not (isControl c) || c == '\n'++pretty :: Bool -> String -> Maybe String+pretty unicode = parseValue >=> render_+  where+    render_ :: Value -> Maybe String+    render_ value = guard (shouldParseBack value) >> Just (renderValue unicode value)++    shouldParseBack :: Value -> Bool+    shouldParseBack = go+      where+        go value = case value of+          Char _ -> False+          String _ -> True+          Number _ -> False+          Operator _ _ _ -> True+          Record _ _ -> True+          Constructor _ xs -> any go xs+          Tuple xs -> any go xs+          List xs -> any go xs++newtype Builder = Builder ShowS++instance Monoid Builder where+  mempty = Builder id+#if MIN_VERSION_base(4,11,0)+instance Semigroup Builder where+#endif+  Builder xs+#if MIN_VERSION_base(4,11,0)+    <>+#else+    `mappend`+#endif+    Builder ys = Builder (xs . ys)++runBuilder :: Builder -> String+runBuilder (Builder xs) = xs ""++intercalate :: Builder -> [Builder] -> Builder+intercalate x xs = mconcat $ intersperse x xs++shows :: Show a => a -> Builder+shows = Builder . Show.shows++instance IsString Builder where+  fromString = Builder . showString++renderValue :: Bool -> Value -> String+renderValue unicode = runBuilder . render 0+  where+    render :: Int -> Value -> Builder+    render indentation = \ case+      Char c -> shows c+      String str -> if unicode then Builder $ ushows str else shows str+      Number n -> fromString n+      Operator a name b -> render indentation a <> " " <> fromString name <> " " <> render indentation b+      Record name fields -> fromString name <> renderFields fields+      Constructor name values -> intercalate " " (fromString name : map (render indentation) values)+      Tuple [e@Record{}] -> render indentation e+      Tuple xs -> "(" <> intercalate ", " (map (render indentation) xs) <> ")"+      List xs -> "[" <> intercalate ", " (map (render indentation) xs) <> "]"+      where+        spaces :: Builder+        spaces = indentBy (succ indentation)++        renderFields :: [(String, Value)] -> Builder+        renderFields fields = mconcat [+            " {\n" <> spaces+          , intercalate (",\n" <> spaces) $ map renderField fields+          , "\n" <> indentBy indentation <> "}"+          ]++        renderField :: (String, Value) -> Builder+        renderField (name, value) = fromString name <> " = " <> render (succ indentation) value++    indentBy :: Int -> Builder+    indentBy n = fromString $ replicate (2 * n) ' '
+ src/Test/Hspec/Core/Formatters/Pretty/Parser.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Test.Hspec.Core.Formatters.Pretty.Parser (+  Value(..)+, parseValue+) where++import           Prelude ()+import           Test.Hspec.Core.Compat hiding (Alternative(..), read, exp)++import           Language.Haskell.Lexer hiding (Token, Pos(..))+import qualified Language.Haskell.Lexer as Lexer++type Name = String++data Value =+    Char Char+  | String String+  | Number String+  | Operator Value Name Value+  | Record Name [(Name, Value)]+  | Constructor Name [Value]+  | Tuple [Value]+  | List [Value]+  deriving (Eq, Show)++type Token = (TokenType, String)++type TokenType = Lexer.Token++newtype Parser a = Parser {+  runParser :: [Token] -> Maybe (a, [Token])+} deriving Functor++instance Applicative Parser where+  pure a = Parser $ \ input -> Just (a, input)+  (<*>) = ap++instance Monad Parser where+  return = pure+  p1 >>= p2 = Parser $ runParser p1 >=> uncurry (runParser . p2)++parseValue :: String -> Maybe Value+parseValue input = case runParser exp (tokenize input) of+  Just (v, []) -> Just v+  _ -> Nothing++tokenize :: String -> [Token]+tokenize = go . map (fmap snd) . rmSpace . lexerPass0+  where+    go :: [Token] -> [Token]+    go tokens = case tokens of+      [] -> []+      (Varsym, "-") : (IntLit, n) : xs -> (IntLit, "-" ++ n) : go xs+      (Varsym, "-") : (FloatLit, n) : xs -> (FloatLit, "-" ++ n) : go xs+      x : xs -> x : go xs++exp :: Parser Value+exp = infixexp++infixexp :: Parser Value+infixexp = aexp accept reject+  where+    accept :: Value -> Parser Value+    accept value = peek >>= \ case+      (Varsym, "%") -> skip >> Operator value "%" <$> exp+      (Consym, name) -> skip >> Operator value name <$> exp+      _ -> return value++    reject :: Parser Value+    reject = next >>= unexpected++aexp :: forall a. (Value -> Parser a) -> Parser a -> Parser a+aexp continue done = peek >>= \ case+  (CharLit, value) -> read Char value+  (StringLit, value) -> read String value+  (IntLit, value) -> number value+  (FloatLit, value) -> number value+  (Conid, name) -> accept $ constructor name+  (Special, "(") -> accept tuple+  (Special, "[") -> accept list+  _ -> done+  where+    read :: Read v => (v -> Value) -> String -> Parser a+    read c v = skip >> c <$> readValue v >>= continue++    number :: String -> Parser a+    number value = skip >> continue (Number value)++    accept :: Parser Value -> Parser a+    accept action = skip >> action >>= continue++constructor :: String -> Parser Value+constructor name = peek >>= \ case+  (Special, "{") -> skip >> Record name <$> commaSeparated field "}"+    where+      field :: Parser (Name, Value)+      field = (,) <$> require Varid <* equals <*> exp++  _ -> Constructor name <$> parameters+    where+      parameters :: Parser [Value]+      parameters = aexp more done++      more :: Value -> Parser [Value]+      more v = (:) v <$> parameters++      done :: Parser [Value]+      done = return []++tuple :: Parser Value+tuple = Tuple <$> commaSeparated exp ")"++list :: Parser Value+list = List <$> commaSeparated exp "]"++commaSeparated :: forall a. Parser a -> String -> Parser [a]+commaSeparated item close = peek >>= \ case+  (Special, c) | c == close -> skip >> return []+  _ -> items+  where+    items :: Parser [a]+    items = (:) <$> item <*> moreItems++    moreItems :: Parser [a]+    moreItems = next >>= \ case+      (Special, c)+        | c == "," -> items+        | c == close -> return []+      t -> unexpected t++equals :: Parser ()+equals = requireToken (Reservedop, "=")++require :: TokenType -> Parser String+require expected = next >>= \ case+  (token, v) | token == expected -> return v+  token -> unexpected token++requireToken :: Token -> Parser ()+requireToken expected = next >>= \ case+  token | token == expected -> return ()+  token -> unexpected token++peek :: Parser Token+peek = Parser $ \ input -> case input of+  t : _ -> Just (t, input)+  [] -> Just ((GotEOF, ""), input)++next :: Parser Token+next = Parser $ \ case+  t : ts -> Just (t, ts)+  ts -> Just ((GotEOF, ""), ts)++skip :: Parser ()+skip = Parser $ \ case+  _ : ts -> Just ((), ts)+  ts -> Just ((), ts)++empty :: Parser a+empty = Parser $ const Nothing++readValue :: Read a => String -> Parser a+readValue = maybe empty pure . readMaybe++unexpected :: Token -> Parser a+unexpected _ = empty++-- unexpected :: HasCallStack => (Token, String) -> Parser a+-- unexpected = error . show
+ src/Test/Hspec/Core/Formatters/Pretty/Unicode.hs view
@@ -0,0 +1,28 @@+module Test.Hspec.Core.Formatters.Pretty.Unicode (+  ushow+, ushows+) where++import           Prelude ()+import           Test.Hspec.Core.Compat++import           Data.Char++ushow :: String -> String+ushow xs = ushows xs ""++ushows :: String -> ShowS+ushows = uShowString++uShowString :: String -> ShowS+uShowString cs = showChar '"' . showLitString cs . showChar '"'++showLitString :: String -> ShowS+showLitString []         s = s+showLitString ('"' : cs) s = showString "\\\"" (showLitString cs s)+showLitString (c   : cs) s = uShowLitChar c (showLitString cs s)++uShowLitChar :: Char -> ShowS+uShowLitChar c+  | isPrint c && not (isAscii c) = showChar c+  | otherwise = showLitChar c
+ src/Test/Hspec/Core/Formatters/V1.hs view
@@ -0,0 +1,62 @@+-- |+-- Stability: deprecated+--+-- This module contains formatters that can be used with+-- `Test.Hspec.Core.Runner.hspecWith`.+module Test.Hspec.Core.Formatters.V1+{-# DEPRECATED "Use [Test.Hspec.Api.Formatters.V1](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Formatters-V1.html) instead." #-}+(+-- * 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.Formatters.V1.Internal
+ 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)
+ src/Test/Hspec/Core/Formatters/V1/Internal.hs view
@@ -0,0 +1,357 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE LambdaCase #-}+module Test.Hspec.Core.Formatters.V1.Internal (+-- * 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++import           Test.Hspec.Core.Util+import           Test.Hspec.Core.Clock+import           Test.Hspec.Core.Example (Location(..))+import           Text.Printf+import           Control.Monad.IO.Class++-- 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) (unliftFailureReason reason)+, V2.formatterDone = interpret $ failedFormatter >> footerFormatter+}++unliftFailureRecord :: V2.FailureRecord -> FailureRecord+unliftFailureRecord V2.FailureRecord{..} = FailureRecord {+  failureRecordLocation+, failureRecordPath+, failureRecordMessage = unliftFailureReason failureRecordMessage+}++unliftFailureReason :: V2.FailureReason -> FailureReason+unliftFailureReason = \ case+  V2.NoReason -> NoReason+  V2.Reason reason -> Reason reason+  V2.ColorizedReason reason -> Reason (stripAnsi reason)+  V2.ExpectedButGot preface expected actual -> ExpectedButGot preface expected actual+  V2.Error info e -> Error info e++interpret :: FormatM a -> V2.FormatM a+interpret = interpretWith Environment {+  environmentGetSuccessCount = V2.getSuccessCount+, environmentGetPendingCount = V2.getPendingCount+, environmentGetFailMessages = map unliftFailureRecord <$> 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     = pass+, exampleGroupStarted = \_ _ -> pass+, exampleGroupDone    = pass+, exampleStarted      = \_ -> pass+, exampleProgress     = \_ _ -> pass+, exampleSucceeded    = \ _ _ -> pass+, exampleFailed       = \_ _ _ -> pass+, examplePending      = \_ _ _ -> pass+, failedFormatter     = pass+, footerFormatter     = pass+}++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 -> pass+        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 $ \ case+                Both a -> indented write a+                First a -> indented extra a+                Second _ -> pass+              writeLine ""++              withFailColor $ write (indentation ++ " but got: ")+              forM_ chunks $ \ case+                Both a -> indented write a+                First _ -> pass+                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
+ src/Test/Hspec/Core/Formatters/V1/Monad.hs view
@@ -0,0 +1,264 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+{-# 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 hiding (FailureReason)++data FailureReason =+    NoReason+  | Reason String+  | ExpectedButGot (Maybe String) String String+  | Error (Maybe String) SomeException+  deriving Show++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 ())
+ src/Test/Hspec/Core/Formatters/V2.hs view
@@ -0,0 +1,436 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+-- |+-- Stability: unstable+--+-- This is an unstable API.  Use+-- [Test.Hspec.Api.Formatters.V3](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Formatters-V3.html)+-- instead.+module Test.Hspec.Core.Formatters.V2+-- {-# WARNING "Use [Test.Hspec.Api.Formatters.V3](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Formatters-V3.html) instead." #-}+(+-- * 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 (..)+, Path+, Progress+, Location(..)+, Item(..)+, Result(..)+, FailureReason (..)+, FormatM+, formatterToFormat++-- ** Accessing config values+, getConfig+, getConfigValue+, FormatConfig(..)++-- ** 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+, diffContext+, externalDiffAction+, prettyPrint+, prettyPrintFunction+, extraChunk+, missingChunk++-- ** expert mode+, unlessExpert++-- ** Helpers+, formatLocation+, Util.formatException++#ifdef TEST+, Chunk(..)+, ColorChunk(..)+#endif+) where++import           Prelude ()+import           Test.Hspec.Core.Compat+import           System.IO (hFlush, stdout)++import           Test.Hspec.Core.Util hiding (formatException)+import qualified Test.Hspec.Core.Util as Util+import           Test.Hspec.Core.Clock+import           Test.Hspec.Core.Example (Location(..), Progress)+import           Text.Printf+import           Test.Hspec.Core.Formatters.Pretty.Unicode (ushow)+import           Control.Monad.IO.Class++-- 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++  , getConfig+  , getConfigValue+  , FormatConfig(..)++  , getSuccessCount+  , getPendingCount+  , getFailCount+  , getTotalCount+  , getExpectedTotalCount++  , FailureRecord (..)+  , getFailMessages+  , usedSeed++  , printTimes+  , getCPUTime+  , getRealTime++  , write+  , writeLine+  , writeTransient++  , withInfoColor+  , withSuccessColor+  , withPendingColor+  , withFailColor++  , outputUnicode++  , useDiff+  , diffContext+  , externalDiffAction+  , prettyPrint+  , prettyPrintFunction+  , extraChunk+  , missingChunk++  , unlessExpert+  )++import           Test.Hspec.Core.Formatters.Diff++silent :: Formatter+silent = Formatter {+  formatterStarted      = pass+, formatterGroupStarted = \ _ -> pass+, formatterGroupDone    = \ _ -> pass+, formatterProgress     = \ _ _ -> pass+, formatterItemStarted  = \ _ -> pass+, formatterItemDone     = \ _ _ -> pass+, formatterDone         = pass+}++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 {} -> pass+      Failure {} -> pass+      Pending _ reason -> withPendingColor $ do+        indentBy (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 ""+      indentBy (indentationFor ("" : nesting)) info+      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+        indentBy (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 ""+      indentBy (indentationFor ("" : nesting)) info+      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 -> do+    case itemResult item of+      Success{} -> withSuccessColor $ write "."+      Pending{} -> withPendingColor $ write "."+      Failure{} -> withFailColor $ write "F"+    liftIO $ hFlush stdout+}++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+      unicode <- outputUnicode+      forM_ mLoc $ \loc -> do+        withInfoColor $ writeLine ("  " ++ formatLocation loc)+      write ("  " ++ show n ++ ") ")+      writeLine (formatRequirement path)+      case reason of+        NoReason -> pass+        Reason err -> withFailColor $ indent err+        ColorizedReason err -> indent err+        ExpectedButGot preface expected_ actual_ -> do+          pretty <- prettyPrintFunction+          let+            (expected, actual) = case pretty of+              Just f -> f expected_ actual_+              Nothing -> (expected_, actual_)++          mapM_ indent preface++          b <- useDiff++          let threshold = 2 :: Seconds+++          mExternalDiff <- externalDiffAction++          case mExternalDiff of+            Just externalDiff -> do+              liftIO $ externalDiff expected actual++            Nothing -> do+              context <- diffContext+              mchunks <- liftIO $ if b+                then timeout threshold (evaluate $ lineDiff context expected actual)+                else return Nothing++              case mchunks of+                Just chunks -> do+                  writeDiff chunks extraChunk missingChunk+                Nothing -> do+                  writeDiff [LinesFirst (splitLines expected), LinesSecond (splitLines actual)] write write+          where+            writeDiff :: [LineDiff] -> (String -> FormatM ()) -> (String -> FormatM ()) -> FormatM ()+            writeDiff chunks extra missing = do+              writeChunks "expected: " (expectedChunks chunks) extra+              writeChunks " but got: " (actualChunks chunks) missing++            writeChunks :: String -> [Chunk] -> (String -> FormatM ()) -> FormatM ()+            writeChunks pre chunks colorize = do+              withFailColor $ write (indentation ++ pre)+              go pass chunks+              where+                indentation_ :: [Char]+                indentation_ = indentation ++ replicate (length pre) ' '++                go :: FormatM () -> [Chunk] -> FormatM ()+                go indent_ = \ case+                  [] -> pass+                  c : cs -> do+                    indent_+                    case c of+                      Original a -> write a+                      Modified a -> colorize a+                      Info text -> withInfoColor $ write text+                      ModifiedChunks xs -> for_ xs $ \ case+                        PlainChunk a -> write a+                        ColorChunk a -> colorize a+                    write "\n"+                    go (write indentation_) cs++        Error info e -> do+          mapM_ indent info+          formatException <- getConfigValue formatConfigFormatException+          withFailColor . indent $ "uncaught exception: " ++ formatException e+++      unlessExpert $ do+        let path_ = (if unicode then ushow else show) (joinPath path)+        writeLine ""+        seed <- usedSeed+        writeLine ("  To rerun use: --match " ++ path_ <> " --seed " <> show seed)+      where+        indentation = "       "+        indent = indentBy indentation++indentBy :: String -> String -> FormatM ()+indentBy indentation message = do+  forM_ (lines message) $ \ line -> do+    writeLine (indentation ++ line)++data Chunk = Original String | Modified String | Info String | ModifiedChunks [ColorChunk]+  deriving (Eq, Show)++expectedChunks :: [LineDiff] -> [Chunk]+expectedChunks = concatMap $ \ case+  LinesBoth a -> map Original a+  LinesFirst a -> map Modified a+  LinesSecond _ -> []+  LinesOmitted n -> [Info $ formatOmittedLines n]+  SingleLineDiff diffs -> return . ModifiedChunks . flip mapMaybe diffs $ \ case+    First a -> Just $ ColorChunk a+    Second _ -> Nothing+    Both a -> Just $ PlainChunk a++actualChunks :: [LineDiff] -> [Chunk]+actualChunks = concatMap $ \ case+  LinesBoth a -> map Original a+  LinesFirst _ -> []+  LinesSecond a -> map Modified a+  LinesOmitted n -> [Info $ formatOmittedLines n]+  SingleLineDiff diffs -> return . ModifiedChunks . flip mapMaybe diffs $ \ case+    First _ -> Nothing+    Second a -> Just $ ColorChunk a+    Both a -> Just $ PlainChunk a++data ColorChunk = PlainChunk String | ColorChunk String+  deriving (Eq, Show)++formatOmittedLines :: Int -> String+formatOmittedLines n = "@@ " <> show n <> " lines omitted @@"++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"++    color+      | fails /= 0   = withFailColor+      | pending /= 0 = withPendingColor+      | otherwise    = withSuccessColor+  color $ writeLine output++formatLocation :: Location -> String+formatLocation (Location file line column) = file ++ ":" ++ show line ++ ":" ++ show column ++ ": "
src/Test/Hspec/Core/Hooks.hs view
@@ -1,10 +1,21 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE RecordWildCards #-} -- | Stability: provisional module Test.Hspec.Core.Hooks (-  before+-- * Types+  Spec+, SpecWith+, ActionWith+-- * Hooks+, before , before_ , beforeWith , beforeAll , beforeAll_+, beforeAllWith , after , after_ , afterAll@@ -12,13 +23,27 @@ , around , around_ , aroundWith+, aroundAll+, aroundAll_+, aroundAllWith++, mapSubject+, ignoreSubject++#ifdef TEST+, decompose+#endif ) where -import           Control.Exception (finally)-import           Control.Concurrent.MVar+import           Prelude ()+import           Test.Hspec.Core.Compat -import           Test.Hspec.Core.Spec+import           Control.Concurrent +import           Test.Hspec.Core.Example+import           Test.Hspec.Core.Tree+import           Test.Hspec.Core.Spec.Monad+ -- | Run a custom action before every spec item. before :: IO a -> SpecWith a -> Spec before action = around (action >>=)@@ -32,24 +57,38 @@ beforeWith action = aroundWith $ \e x -> action x >>= e  -- | Run a custom action before the first spec item.-beforeAll :: IO a -> SpecWith a -> Spec+beforeAll :: HasCallStack => IO a -> SpecWith a -> Spec beforeAll action spec = do-  mvar <- runIO (newMVar Nothing)+  mvar <- runIO (newMVar Empty)   before (memoize mvar action) spec  -- | Run a custom action before the first spec item.-beforeAll_ :: IO () -> SpecWith a -> SpecWith a+beforeAll_ :: HasCallStack => IO () -> SpecWith a -> SpecWith a beforeAll_ action spec = do-  mvar <- runIO (newMVar Nothing)+  mvar <- runIO (newMVar Empty)   before_ (memoize mvar action) spec -memoize :: MVar (Maybe a) -> IO a -> IO a-memoize mvar action = modifyMVar mvar $ \ma -> case ma of-  Just a -> return (ma, a)-  Nothing -> do-    a <- action-    return (Just a, a)+-- | Run a custom action with an argument before the first spec item.+beforeAllWith :: HasCallStack => (b -> IO a) -> SpecWith a -> SpecWith b+beforeAllWith action spec = do+  mvar <- runIO (newMVar Empty)+  beforeWith (memoize mvar . action) spec +data Memoized a =+    Empty+  | Memoized a+  | Failed SomeException++memoize :: HasCallStack => MVar (Memoized a) -> IO a -> IO a+memoize mvar action = do+  result <- modifyMVar mvar $ \ma -> case ma of+    Empty -> do+      a <- try action+      return (either Failed Memoized a, a)+    Memoized a -> return (ma, Right a)+    Failed _ -> throwIO (Pending Nothing (Just $ "exception in " <> maybe "beforeAll" fst callSite <> "-hook (see previous failure)"))+  either throwIO return result+ -- | Run a custom action after every spec item. after :: ActionWith a -> SpecWith a -> SpecWith a after action = aroundWith $ \e x -> e x `finally` action x@@ -58,17 +97,27 @@ after_ :: IO () -> SpecWith a -> SpecWith a after_ action = after $ \_ -> action --- | Run a custom action before and/or after every spec item.-around :: (ActionWith a -> IO ()) -> SpecWith a -> Spec+-- | Run a custom action before and/or after every spec item, supplying it with+-- an argument obtained via IO.+--+-- This is useful for tasks like creating a file handle or similar resource+-- before a test and destroying it after the test.+around+  :: (ActionWith a -> IO ())+  -- ^ Function provided with an action to run the spec item as argument. It+  -- should return the action to actually execute the item.+  -> SpecWith a+  -- ^ Spec to modify+  -> Spec 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 = aroundAllWith (\ hook a -> hook a >> action a)  -- | Run a custom action after the last spec item.-afterAll_ :: IO () -> SpecWith a -> SpecWith a-afterAll_ action = afterAll (\_ -> action)+afterAll_ :: HasCallStack => IO () -> SpecWith a -> SpecWith a+afterAll_ action = mapSpecForest (return . NodeWithCleanup callSite action)  -- | Run a custom action before and/or after every spec item. around_ :: (IO () -> IO ()) -> SpecWith a -> SpecWith a@@ -76,10 +125,96 @@  -- | Run a custom action before and/or after every spec item. aroundWith :: (ActionWith a -> ActionWith b) -> SpecWith a -> SpecWith b-aroundWith action = mapAround (. action)+aroundWith = mapSpecItem_ . modifyHook -mapAround :: ((ActionWith b -> IO ()) -> ActionWith a -> IO ()) -> SpecWith a -> SpecWith b-mapAround f = mapSpecItem (untangle f) $ \i@Item{itemExample = e} -> i{itemExample = (. f) . e}+modifyHook :: (ActionWith a -> ActionWith b) -> Item a -> Item b+modifyHook action Item{..} = Item {+    itemExample = \ params hook -> itemExample params (hook . action)+  , ..+  } -untangle  :: ((ActionWith b -> IO ()) -> ActionWith a -> IO ()) -> ActionWith a -> ActionWith b-untangle f g = \b -> f ($ b) g+-- | Wrap an action around the given spec.+aroundAll :: HasCallStack => (ActionWith a -> IO ()) -> SpecWith a -> Spec+aroundAll action = aroundAllWith $ \ e () -> action e++-- | Wrap an action around the given spec.+aroundAll_ :: HasCallStack => (IO () -> IO ()) -> SpecWith a -> SpecWith a+aroundAll_ action spec = do+  (acquire, release) <- runIO $ decompose (action .)+  beforeAll_ (acquire ()) $ afterAll_ release spec++-- | Wrap an action around the given spec. Changes the arg type inside.+aroundAllWith :: forall a b. HasCallStack => (ActionWith a -> ActionWith b) -> SpecWith a -> SpecWith b+aroundAllWith action spec = do+  (acquire, release) <- runIO $ decompose action+  beforeAllWith acquire $ afterAll_ release spec++data Acquired a = Acquired a | ExceptionDuringAcquire SomeException+data Released   = Released   | ExceptionDuringRelease SomeException++decompose :: forall a b. ((a -> IO ()) -> b -> IO ()) -> IO (b -> IO a, IO ())+decompose action = do+  doCleanupNow <- newEmptyMVar+  acquired <- newEmptyMVar+  released <- newEmptyMVar++  let+    notify :: Either SomeException () -> IO ()+    -- `notify` is guaranteed to run without being interrupted by an async+    -- exception for the following reasons:+    --+    -- 1. `forkFinally` runs the final action within `mask`+    -- 2. `tryPutMVar` is guaranteed not to be interruptible+    -- 3. `putMVar` is guaranteed not to be interruptible on an empty `MVar`+    notify r = case r of+      Left err -> do+        exceptionDuringAcquire <- tryPutMVar acquired (ExceptionDuringAcquire err)+        putMVar released $ if exceptionDuringAcquire then Released else ExceptionDuringRelease err+      Right () -> do+        putMVar released Released++    forkWorker :: b -> IO ()+    forkWorker b = void . flip forkFinally notify $ do+      flip action b $ \ a -> do+        putMVar acquired (Acquired a)+        waitFor doCleanupNow++    acquire :: b -> IO a+    acquire b = do+      forkWorker b+      r <- readMVar acquired -- This does not work reliably with base < 4.7+      case r of+        Acquired a -> return a+        ExceptionDuringAcquire err -> throwIO err++    release :: IO ()+    release = do+      acquireHasNotBeenCalled <- isEmptyMVar acquired -- NOTE: This can happen if an outer beforeAll fails+      unless acquireHasNotBeenCalled $ do+        signal doCleanupNow+        r <- takeMVar released+        case r of+          Released -> pass+          ExceptionDuringRelease err -> throwIO err++  return (acquire, release)++type BinarySemaphore = MVar ()++signal :: BinarySemaphore -> IO ()+signal = flip putMVar ()++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 ())
src/Test/Hspec/Core/QuickCheck.hs view
@@ -1,14 +1,30 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-} -- | Stability: provisional module Test.Hspec.Core.QuickCheck (   modifyMaxSuccess , modifyMaxDiscardRatio , modifyMaxSize-+, modifyMaxShrinks+, modifyArgs ) where -import           Test.QuickCheck-import           Test.Hspec.Core.Spec+import           Prelude ()+import           Test.Hspec.Core.Compat +import           Test.QuickCheck (Args(..))+import qualified Test.QuickCheck as QC+import qualified Test.QuickCheck.State as QC (numSuccessTests, maxSuccessTests)+import qualified Test.QuickCheck.Property as QCP++import           Test.Hspec.Core.Util+import           Test.Hspec.Core.QuickCheck.Util+import           Test.Hspec.Core.Example (Example(..), Params(..), Result(..), ResultStatus(..), FailureReason(..), hunitFailureToResult)+import           Test.Hspec.Core.Spec.Monad (SpecWith, modifyParams)+ -- | Use a modified `maxSuccess` for given spec. modifyMaxSuccess :: (Int -> Int) -> SpecWith a -> SpecWith a modifyMaxSuccess = modifyArgs . modify@@ -30,8 +46,70 @@     modify :: (Int -> Int) -> Args -> Args     modify f args = args {maxSize = f (maxSize args)} +-- | Use a modified `maxShrinks` for given spec.+modifyMaxShrinks :: (Int -> Int) -> SpecWith a -> SpecWith a+modifyMaxShrinks = modifyArgs . modify+  where+    modify :: (Int -> Int) -> Args -> Args+    modify f args = args {maxShrinks = f (maxShrinks args)}++-- | Use modified `Args` for given spec. modifyArgs :: (Args -> Args) -> SpecWith a -> SpecWith a modifyArgs = modifyParams . modify   where     modify :: (Args -> Args) -> Params -> Params     modify f p = p {paramsQuickCheckArgs = f (paramsQuickCheckArgs p)}++instance Example QC.Property where+#ifdef ENABLE_SPEC_HOOK_ARGS+  type Arg QC.Property = ()+#endif+  evaluateExample e = evaluateExample (\() -> e)++#ifdef ENABLE_SPEC_HOOK_ARGS+instance Example (a -> QC.Property) where+  type Arg (a -> QC.Property) = a+#else+instance Example (() -> QC.Property) where+#endif+  evaluateExample p params hook progressCallback = do+    let args = paramsQuickCheckArgs params+    r <- QC.quickCheckWithResult args {QC.chatty = False} (QCP.callback qcProgressCallback $ aroundProperty hook p)+    return $ fromQuickCheckResult args r+    where+      qcProgressCallback = QCP.PostTest QCP.NotCounterexample $+        \st _ -> progressCallback (QC.numSuccessTests st, QC.maxSuccessTests st)++fromQuickCheckResult :: QC.Args -> QC.Result -> Result+fromQuickCheckResult args r = case parseQuickCheckResult r of+  QuickCheckResult _ info (QuickCheckOtherFailure err) -> Result info $ Failure Nothing (Reason err)+  QuickCheckResult _ info QuickCheckSuccess -> Result (if QC.chatty args then info else "") Success+  QuickCheckResult n info (QuickCheckFailure QCFailure{..}) -> case quickCheckFailureException of+    Just e | Just result <- fromException e -> Result info result+    Just e | Just hunit <- fromException e -> Result info $ hunitFailureToResult (Just hunitAssertion) hunit+    Just e -> failure (uncaughtException e)+    Nothing -> failure falsifiable+    where+      failure = Result info . Failure Nothing . Reason++      numbers = formatNumbers n quickCheckFailureNumShrinks++      hunitAssertion :: String+      hunitAssertion = intercalate "\n" [+          "Falsifiable " ++ numbers ++ ":"+        , indent (unlines quickCheckFailureCounterexample)+        ]++      uncaughtException e = intercalate "\n" [+          "uncaught exception: " ++ formatException e+        , numbers+        , indent (unlines quickCheckFailureCounterexample)+        ]++      falsifiable = intercalate "\n" [+          quickCheckFailureReason ++ " " ++ numbers ++ ":"+        , indent (unlines quickCheckFailureCounterexample)+        ]++indent :: String -> String+indent = intercalate "\n" . map ("  " ++) . lines
+ src/Test/Hspec/Core/QuickCheck/Util.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP #-}+module Test.Hspec.Core.QuickCheck.Util (+  liftHook+, aroundProperty++, QuickCheckResult(..)+, Status(..)+, QuickCheckFailure(..)+, parseQuickCheckResult++, formatNumbers++, mkGen+, newSeed+#ifdef TEST+, stripSuffix+, splitBy+#endif+) where++import           Prelude ()+import           Test.Hspec.Core.Compat++import           Data.Int+import           System.Random++import           Test.QuickCheck+import           Test.QuickCheck.Text (isOneLine)+import qualified Test.QuickCheck.Property as QCP+import           Test.QuickCheck.Property hiding (Result(..))+import           Test.QuickCheck.Gen+import           Test.QuickCheck.IO ()+import           Test.QuickCheck.Random+import qualified Test.QuickCheck.Test as QC (showTestCount)+import           Test.QuickCheck.State (State(..))++import           Test.Hspec.Core.Util++liftHook+  :: r+  -- ^ Default result, taken if the hook decides to not run the test+  -> ((a -> IO ()) -> IO ())+  -- ^ Hook: given an action to actually run the test, potentially does+  -- some IO actions before the test, runs it while supplying an argument (or+  -- skips it!), then may execute some more actions after running it.+  -> (a -> IO r)+  -- ^ The actual test being run, producing a result+  -> IO r+liftHook def hook inner = do+  ref <- newIORef def+  hook $ inner >=> writeIORef ref+  readIORef ref++aroundProperty :: ((a -> IO ()) -> IO ()) -> (a -> Property) -> Property+aroundProperty hook p = MkProperty . MkGen $ \r n -> aroundProp hook $ \a -> (unGen . unProperty $ p a) r n++aroundProp :: ((a -> IO ()) -> IO ()) -> (a -> Prop) -> Prop+aroundProp hook p = MkProp $ aroundRose hook (\a -> unProp $ p a)++aroundRose :: ((a -> IO ()) -> IO ()) -> (a -> Rose QCP.Result) -> Rose QCP.Result+aroundRose hook r = ioRose $ do+  liftHook (return QCP.succeeded) hook $ \ a -> reduceRose (r a)++newSeed :: IO Int+newSeed = fst . randomR (0, fromIntegral (maxBound :: Int32)) <$>+  newQCGen++mkGen :: Int -> QCGen+mkGen = mkQCGen++formatNumbers :: Int -> Int -> String+formatNumbers n shrinks = "(after " ++ pluralize n "test" ++ shrinks_ ++ ")"+  where+    shrinks_+      | shrinks > 0 = " and " ++ pluralize shrinks "shrink"+      | otherwise = ""++data QuickCheckResult = QuickCheckResult {+  quickCheckResultNumTests :: Int+, quickCheckResultInfo :: String+, quickCheckResultStatus :: Status+} deriving Show++data Status =+    QuickCheckSuccess+  | QuickCheckFailure QuickCheckFailure+  | QuickCheckOtherFailure String+  deriving Show++data QuickCheckFailure = QCFailure {+  quickCheckFailureNumShrinks :: Int+, quickCheckFailureException :: Maybe SomeException+, quickCheckFailureReason :: String+, quickCheckFailureCounterexample :: [String]+} deriving Show++parseQuickCheckResult :: Result -> QuickCheckResult+parseQuickCheckResult r = case r of+  Success {..} -> result output QuickCheckSuccess++  Failure {..} ->+    case stripSuffix outputWithoutVerbose output of+      Just xs -> result verboseOutput (QuickCheckFailure $ QCFailure numShrinks theException reason failingTestCase)+        where+          verboseOutput+            | xs == "*** Failed! " = ""+            | otherwise = maybeStripSuffix "*** Failed!" (strip xs)+      Nothing -> couldNotParse output+    where+      outputWithoutVerbose = reasonAndNumbers ++ unlines failingTestCase+      reasonAndNumbers+        | isOneLine reason = reason ++ " " ++ numbers ++ colonNewline+        | otherwise = numbers ++ colonNewline ++ ensureTrailingNewline reason+      numbers = formatNumbers numTests numShrinks+      colonNewline = ":\n"++  GaveUp {..} ->+    case stripSuffix outputWithoutVerbose output of+      Just info -> otherFailure info ("Gave up after " ++ numbers ++ "!")+      Nothing -> couldNotParse output+    where+      numbers = showTestCount numTests numDiscarded+      outputWithoutVerbose = "*** Gave up! Passed only " ++ numbers ++ " tests.\n"++  NoExpectedFailure {..} -> case splitBy "*** Failed! " output of+    Just (info, err) -> otherFailure info err+    Nothing -> couldNotParse output++  where+    result = QuickCheckResult (numTests r) . strip+    otherFailure info err = result info (QuickCheckOtherFailure $ strip err)+    couldNotParse = result "" . QuickCheckOtherFailure++showTestCount :: Int -> Int -> String+showTestCount success discarded = QC.showTestCount state+  where+    state = MkState {+      terminal                  = undefined+    , maxSuccessTests           = undefined+    , maxDiscardedRatio         = undefined+    , coverageConfidence        = undefined+#if MIN_VERSION_QuickCheck(2,15,0)+    , maxTestSize               = 0+    , replayStartSize           = undefined+#else+    , computeSize               = undefined+#endif+    , numTotMaxShrinks          = 0+    , numSuccessTests           = success+    , numDiscardedTests         = discarded+    , numRecentlyDiscardedTests = 0+    , labels                    = mempty+    , classes                   = mempty+    , tables                    = mempty+    , requiredCoverage          = mempty+    , expected                  = True+    , randomSeed                = mkGen 0+    , numSuccessShrinks         = 0+    , numTryShrinks             = 0+    , numTotTryShrinks          = 0+    }++ensureTrailingNewline :: String -> String+ensureTrailingNewline = unlines . lines++maybeStripPrefix :: String -> String -> String+maybeStripPrefix prefix m = fromMaybe m (stripPrefix prefix m)++maybeStripSuffix :: String -> String -> String+maybeStripSuffix suffix = reverse . maybeStripPrefix (reverse suffix) . reverse++stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]+stripSuffix suffix = fmap reverse . stripPrefix (reverse suffix) . reverse++splitBy :: String -> String -> Maybe (String, String)+splitBy sep xs = listToMaybe [+    (x, y) | (x, Just y) <- zip (inits xs) (map stripSep $ tails xs)+  ]+  where+    stripSep = stripPrefix sep
− src/Test/Hspec/Core/QuickCheckUtil.hs 
@@ -1,61 +0,0 @@-{-# LANGUAGE CPP #-}-module Test.Hspec.Core.QuickCheckUtil where--import           Prelude ()-import           Test.Hspec.Compat--import           Data.Int-import           Test.QuickCheck hiding (Result(..))-import           Test.QuickCheck as QC-import           Test.QuickCheck.Property hiding (Result(..))-import           Test.QuickCheck.Gen-import qualified Test.QuickCheck.Property as QCP-import           Test.QuickCheck.IO ()---#if MIN_VERSION_QuickCheck(2,7,0)-import           Test.QuickCheck.Random-#endif--import           System.Random--import           Test.Hspec.Core.Util--aroundProperty :: ((a -> IO ()) -> IO ()) -> (a -> Property) -> Property-#if MIN_VERSION_QuickCheck(2,7,0)-aroundProperty action p = MkProperty . MkGen $ \r n -> aroundProp action $ \a -> (unGen . unProperty $ p a) r n-#else-aroundProperty action p = MkGen $ \r n -> aroundProp action $ \a -> (unGen $ p a) r n-#endif--aroundProp :: ((a -> IO ()) -> IO ()) -> (a -> Prop) -> Prop-aroundProp action p = MkProp $ aroundRose action (\a -> unProp $ p a)--aroundRose :: ((a -> IO ()) -> IO ()) -> (a -> Rose QCP.Result) -> Rose QCP.Result-aroundRose action r = ioRose $ do-  ref <- newIORef (return QCP.succeeded)-  action $ \a -> reduceRose (r a) >>= writeIORef ref-  readIORef ref--formatNumbers :: Result -> String-formatNumbers r = "(after " ++ pluralize (numTests r) "test" ++ shrinks ++ ")"-  where-    shrinks-      | 0 < numShrinks r = " and " ++ pluralize (numShrinks r) "shrink"-      | otherwise = ""--newSeed :: IO Int-newSeed = fst . randomR (0, fromIntegral (maxBound :: Int32)) <$>-#if MIN_VERSION_QuickCheck(2,7,0)-  newQCGen-#else-  newStdGen-#endif--#if MIN_VERSION_QuickCheck(2,7,0)-mkGen :: Int -> QCGen-mkGen = mkQCGen-#else-mkGen :: Int -> StdGen-mkGen = mkStdGen-#endif
src/Test/Hspec/Core/Runner.hs view
@@ -1,112 +1,222 @@-{-# LANGUAGE CPP #-}--#if MIN_VERSION_base(4,6,0)--- Control.Concurrent.QSem is deprecated in base-4.6.0.* {-# OPTIONS_GHC -fno-warn-deprecations #-}-#endif+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | -- Stability: provisional module Test.Hspec.Core.Runner (--- * Running a spec+-- * Simple interface   hspec , hspecWith , hspecResult , hspecWithResult --- * Types+-- ** Summary , Summary (..)+, isSuccess+, evaluateSummary++-- * Running a spec+{- |+To run a spec `hspec` performs a sequence of steps:++1. Evaluate a `Spec` to a forest of `SpecTree`s+1. Read config values from the command-line, config files and the process environment+1. Execute each spec item of the forest and report results to `stdout`+1. Exit with `exitFailure` if at least on spec item fails++The four primitives `evalSpec`, `readConfig`, `runSpecForest` and+`evaluateResult` each perform one of these steps respectively.++`hspec` is defined in terms of these primitives. Loosely speaking, a definition+for @hspec@ is:++@+hspec = `evalSpec` `defaultConfig` >=> \\ (config, spec) ->+      `getArgs`+  >>= `readConfig` config+  >>= `withArgs` [] . `runSpecForest` spec+  >>= `evaluateResult`+@++Loosely speaking in the sense that this definition of @hspec@ ignores+@--rerun-all-on-success@.++Using these primitives individually gives you more control over how a spec is+run.  However, if you need support for @--rerun-all-on-success@ then you should+try hard to solve your use case with one of `hspec`, `hspecWith`, `hspecResult`+or `hspecWithResult`.++-}+, evalSpec+, runSpecForest+, evaluateResult++-- ** Result++-- *** Spec Result+, Test.Hspec.Core.Runner.Result.SpecResult+, Test.Hspec.Core.Runner.Result.specResultItems+, Test.Hspec.Core.Runner.Result.specResultSuccess+, toSummary++-- *** Result Item+, Test.Hspec.Core.Runner.Result.ResultItem+, Test.Hspec.Core.Runner.Result.resultItemPath+, Test.Hspec.Core.Runner.Result.resultItemStatus+, Test.Hspec.Core.Runner.Result.resultItemIsFailure++-- *** Result Item Status+, Test.Hspec.Core.Runner.Result.ResultItemStatus(..)++-- * Config , Config (..) , ColorMode (..)+, UnicodeMode(..) , Path , defaultConfig+, registerFormatter+, registerDefaultFormatter , configAddFilter+, readConfig++-- * Legacy+, runSpec++-- * Re-exports+, Spec+, SpecWith++#ifdef TEST+, UseColor(..)+, ProgressReporting(..)+, rerunAll+, specToEvalForest+, colorOutputSupported+, unicodeOutputSupported+#endif ) where  import           Prelude ()-import           Test.Hspec.Compat+import           Test.Hspec.Core.Compat hiding (unicodeOutputSupported)+import qualified Test.Hspec.Core.Compat as Compat -import           Control.Monad-import           Data.Maybe+import           Data.List.NonEmpty (nonEmpty) import           System.IO-import           System.Environment (getProgName, getArgs, withArgs)-import           System.Exit-import qualified Control.Exception as E-import           Control.Concurrent+import           System.Environment (getArgs, withArgs)+import           System.Exit (exitFailure)+import           System.Random+import           Control.Monad.ST+import           Data.STRef -import           System.Console.ANSI (hHideCursor, hShowCursor)+import           System.Console.ANSI (hSupportsANSI, hHideCursor, hShowCursor) import qualified Test.QuickCheck as QC-import           Control.Monad.IO.Class (liftIO)  import           Test.Hspec.Core.Util (Path)-import           Test.Hspec.Core.Spec-import           Test.Hspec.Config-import           Test.Hspec.Core.Formatters-import           Test.Hspec.Core.Formatters.Internal-import           Test.Hspec.FailureReport-import           Test.Hspec.Core.QuickCheckUtil+import           Test.Hspec.Core.Clock+import           Test.Hspec.Core.Spec hiding (pruneTree, pruneForest)+import           Test.Hspec.Core.Tree (formatDefaultDescription)+import           Test.Hspec.Core.Config+import           Test.Hspec.Core.Config.Definition as Config (getSeed, getFormatter)+import           Test.Hspec.Core.Extension.Config.Type as Extension (applySpecTransformation)+import           Test.Hspec.Core.Format (Format, FormatConfig(..))+import qualified Test.Hspec.Core.Formatters.V2 as V2+import           Test.Hspec.Core.FailureReport+import           Test.Hspec.Core.QuickCheck.Util+import           Test.Hspec.Core.Shuffle -import           Test.Hspec.Core.Runner.Eval+import           Test.Hspec.Core.Runner.PrintSlowSpecItems+import           Test.Hspec.Core.Runner.Eval hiding (ColorMode(..), Tree(..))+import qualified Test.Hspec.Core.Runner.Eval as Eval+import           Test.Hspec.Core.Runner.Result --- | Filter specs by given predicate.+-- |+-- Make a formatter available for use with @--format@. ----- The predicate takes a list of "describe" labels and a "requirement".-filterSpecs :: Config -> [SpecTree a] -> [SpecTree a]-filterSpecs c = go []-  where-    p :: Path -> Bool-    p path = (fromMaybe (const True) (configFilterPredicate c) path) &&-               not (fromMaybe (const False) (configSkipPredicate c) path)+-- @since 2.10.5+registerFormatter :: (String, FormatConfig -> IO Format) -> Config -> Config+{-# DEPRECATED registerFormatter "Use [@registerFormatter@](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Format-V2.html#v:registerFormatter) instead." #-}+registerFormatter formatter config = config { configAvailableFormatters = formatter : configAvailableFormatters config } -    go :: [String] -> [SpecTree a] -> [SpecTree a]-    go groups = mapMaybe (goSpec groups)+-- |+-- Make a formatter available for use with @--format@ and use it by default.+--+-- @since 2.10.5+registerDefaultFormatter :: (String, FormatConfig -> IO Format) -> Config -> Config+{-# DEPRECATED registerDefaultFormatter "Use [@useFormatter@](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Format-V2.html#v:useFormatter) instead." #-}+registerDefaultFormatter formatter@(_, format) config = (registerFormatter formatter config) { configFormat = Just format } -    goSpecs :: [String] -> [SpecTree a] -> ([SpecTree a] -> b) -> Maybe b-    goSpecs groups specs ctor = case go groups specs of-      [] -> Nothing-      xs -> Just (ctor xs)+applyFilterPredicates :: Config -> [Tree c EvalItem] -> [Tree c EvalItem]+applyFilterPredicates c = filterForestWithLabels p+  where+    include :: Path -> Bool+    include = fromMaybe (const True) (configFilterPredicate c) -    goSpec :: [String] -> SpecTree a -> Maybe (SpecTree a)-    goSpec groups spec = case spec of-      Leaf item -> guard (p (groups, itemRequirement item)) >> return spec-      Node group specs -> goSpecs (groups ++ [group]) specs (Node group)-      NodeWithCleanup action specs -> goSpecs groups specs (NodeWithCleanup action)+    skip :: Path -> Bool+    skip = fromMaybe (const False) (configSkipPredicate c) -applyDryRun :: Config -> [SpecTree ()] -> [SpecTree ()]+    p :: [String] -> EvalItem -> Bool+    p groups item = include path && not (skip path)+      where+        path = (groups, evalItemDescription item)++applyDryRun :: Config -> [EvalItemTree] -> [EvalItemTree] applyDryRun c-  | configDryRun c = map (removeCleanup . fmap markSuccess)+  | configDryRun c = bimapForest removeCleanup markSuccess   | otherwise = id   where-    markSuccess :: Item () -> Item ()-    markSuccess item = item {itemExample = evaluateExample Success}+    removeCleanup :: IO () -> IO ()+    removeCleanup _ = pass -    removeCleanup :: SpecTree () -> SpecTree ()-    removeCleanup spec = case spec of-      Node x xs -> Node x (map removeCleanup xs)-      NodeWithCleanup _ xs -> NodeWithCleanup (\() -> return ()) (map removeCleanup xs)-      leaf@(Leaf _) -> leaf+    markSuccess :: EvalItem -> EvalItem+    markSuccess item = item {evalItemAction = \ _ -> return (0, Result "" Success)} --- | Run given spec and write a report to `stdout`.+-- | Run a given spec and write a report to `stdout`. -- Exit with `exitFailure` if at least one spec item fails.+--+-- /Note/: `hspec` handles command-line options and reads config files.  This+-- is not always desirable.  Use `evalSpec` and `runSpecForest` if you need+-- more control over these aspects. hspec :: Spec -> IO () hspec = hspecWith defaultConfig +-- |+-- Evaluate a `Spec` to a forest of `SpecTree`s.  This does not execute any+-- spec items, but it does run any IO that is used during spec construction+-- time (see `runIO`).+--+-- A `Spec` may modify a `Config` through `modifyConfig`.  These modifications+-- are applied to the given config (the first argument).+--+-- @since 2.10.0+evalSpec :: Config -> SpecWith a -> IO (Config, [SpecTree a])+evalSpec config spec = do+  (Endo f, forest) <- runSpecM spec+  return (f config, forest)+ -- Add a seed to given config if there is none.  That way the same seed is used -- for all properties.  This helps with --seed and --rerun.-ensureSeed :: Config -> IO Config-ensureSeed c = case configQuickCheckSeed c of-  Nothing -> do-    seed <- newSeed-    return c {configQuickCheckSeed = Just (fromIntegral seed)}-  _       -> return c+ensureSeed :: Config -> IO (Config, Integer)+ensureSeed config = do+  seed <- case Config.getSeed config of+    Nothing -> toInteger <$> newSeed+    Just seed -> return seed+  return (config { configSeed = Just seed }, seed)  -- | Run given spec with custom options. -- This is similar to `hspec`, but more flexible. hspecWith :: Config -> Spec -> IO ()-hspecWith conf spec = do-  r <- hspecWithResult conf spec-  unless (summaryFailures r == 0) exitFailure+hspecWith defaults = hspecWithSpecResult defaults >=> evaluateResult +-- | Exit with `exitFailure` if the given `Summary` indicates that there was at+-- least one failure.+evaluateSummary :: Summary -> IO ()+evaluateSummary summary = unless (isSuccess summary) exitFailure++evaluateResult :: SpecResult -> IO ()+evaluateResult result = unless (specResultSuccess result) exitFailure+ -- | Run given spec and returns a summary of the test run. -- -- /Note/: `hspecResult` does not exit with `exitFailure` on failing spec@@ -121,67 +231,321 @@ -- items.  If you need this, you have to check the `Summary` yourself and act -- accordingly. hspecWithResult :: Config -> Spec -> IO Summary-hspecWithResult conf spec = do-  prog <- getProgName-  args <- getArgs-  c <- getConfig conf prog args >>= ensureSeed-  withArgs [] {- do not leak command-line arguments to examples -} $ withHandle c $ \h -> do-    let formatter = fromMaybe specdoc (configFormatter c)-        seed = (fromJust . configQuickCheckSeed) c-        qcArgs = configQuickCheckArgs c+hspecWithResult config = fmap toSummary . hspecWithSpecResult config -    jobsSem <- newQSem =<< case configConcurrentJobs c of-      Nothing -> getDefaultConcurrentJobs-      Just maxJobs -> return maxJobs+hspecWithSpecResult :: Config -> Spec -> IO SpecResult+hspecWithSpecResult defaults spec = do+  (c, forest) <- evalSpec defaults spec+  config <- getArgs >>= readConfig c+  oldFailureReport <- readFailureReportOnRerun config -    useColor <- doesUseColor h c+  let+    normalMode :: IO SpecResult+    normalMode = doNotLeakCommandLineArgumentsToExamples $ runSpecForest_ oldFailureReport forest config -    filteredSpec <- filterSpecs c . applyDryRun c <$> runSpecM spec+    rerunAllMode :: IO SpecResult+    rerunAllMode = do+      result <- normalMode+      if rerunAll config oldFailureReport result then+        hspecWithSpecResult defaults spec+      else+        return result -    withHiddenCursor useColor h $-      runFormatM useColor (configHtmlOutput c) (configPrintCpuTime c) seed h $ do-        runFormatter jobsSem useColor h c formatter filteredSpec `finally_` do-          failedFormatter formatter+  -- With --rerun-all we may run the spec twice. For that reason GHC can not+  -- optimize away the spec tree. That means that the whole spec tree has to+  -- be constructed in memory and we loose constant space behavior.+  --+  -- By separating between rerunAllMode and normalMode here, we retain+  -- constant space behavior in normalMode.+  --+  -- see: https://github.com/hspec/hspec/issues/169+  if configRerunAllOnSuccess config then do+    rerunAllMode+  else do+    normalMode -        footerFormatter formatter+-- |+-- /Note/: `runSpec` is deprecated. It ignores any modifications applied+-- through `modifyConfig`.  Use `evalSpec` and `runSpecForest` instead.+runSpec :: Spec -> Config -> IO Summary+runSpec spec config = evalSpec defaultConfig spec >>= fmap toSummary . flip runSpecForest config . snd -        -- dump failure report-        xs <- map failureRecordPath <$> getFailMessages-        liftIO $ writeFailureReport FailureReport {-            failureReportSeed = seed-          , failureReportMaxSuccess = QC.maxSuccess qcArgs-          , failureReportMaxSize = QC.maxSize qcArgs-          , failureReportMaxDiscardRatio = QC.maxDiscardRatio qcArgs-          , failureReportPaths = xs-          }+-- |+-- `runSpecForest` is the most basic primitive to run a spec. `hspec` is+-- defined in terms of @runSpecForest@:+--+-- @+-- hspec = `evalSpec` `defaultConfig` >=> \\ (config, spec) ->+--       `getArgs`+--   >>= `readConfig` config+--   >>= `withArgs` [] . runSpecForest spec+--   >>= `evaluateResult`+-- @+--+-- @since 2.10.0+runSpecForest :: [SpecTree ()] -> Config -> IO SpecResult+runSpecForest spec config = do+  oldFailureReport <- readFailureReportOnRerun config+  runSpecForest_ oldFailureReport spec config -        Summary <$> getTotalCount <*> getFailCount+mapItem :: (Item a -> Item b) -> [SpecTree a] -> [SpecTree b]+mapItem f = map (fmap f)++mapItemIf :: (Item a -> Bool) -> (Item a -> Item a) -> [SpecTree a] -> [SpecTree a]+mapItemIf p f = mapItem $ \ item -> if p item then f item else item++addDefaultDescriptions :: [SpecTree a] -> [SpecTree a]+addDefaultDescriptions = mapItem addDefaultDescription   where-    withHiddenCursor :: Bool -> Handle -> IO a -> IO a-    withHiddenCursor useColor h-      | useColor  = E.bracket_ (hHideCursor h) (hShowCursor h)+    addDefaultDescription :: Item a -> Item a+    addDefaultDescription item+      | null (itemRequirement item) = item { itemRequirement = defaultRequirement }+      | otherwise = item+      where+        defaultRequirement = maybe "(unspecified behavior)" formatDefaultDescription (itemLocation item)++failItemsWithEmptyDescription :: Config -> [SpecTree a] -> [SpecTree a]+failItemsWithEmptyDescription config+  | configFailOnEmptyDescription config = mapItemIf condition (failWith failure)+  | otherwise = id+  where+    condition = null . itemRequirement+    failure = "item has no description; failing due to --fail-on=empty-description"++failFocusedItems :: Config -> [SpecTree a] -> [SpecTree a]+failFocusedItems config+  | configFailOnFocused config = mapItemIf condition (failWith failure)+  | otherwise = id+  where+    condition = itemIsFocused+    failure = "item is focused; failing due to --fail-on=focused"++failWith :: forall a. String -> Item a -> Item a+failWith reason item = item {itemExample = example}+  where+    failure :: ResultStatus+    failure = Failure Nothing (Reason reason)++    example :: Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result+    example params hook p = do+      Result info status <- itemExample item params hook p+      return $ Result info $ case status of+        Success -> failure+        Pending _ _ -> failure+        Failure{} -> status++failPendingItems :: Config -> [SpecTree a] -> [SpecTree a]+failPendingItems config+  | configFailOnPending config = mapItem failPending+  | otherwise = id++failPending :: forall a. Item a -> Item a+failPending item = item {itemExample = example}+  where+    example :: Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result+    example params hook p = do+      Result info status <- itemExample item params hook p+      return $ Result info $ case status of+        Pending loc _ -> Failure loc (Reason "item is pending; failing due to --fail-on=pending")+        _ -> status++focusSpec :: Config -> [SpecTree a] -> [SpecTree a]+focusSpec config spec+  | configFocusedOnly config = spec+  | otherwise = focusForest spec++runSpecForest_ :: Maybe FailureReport -> [SpecTree ()] -> Config -> IO SpecResult+runSpecForest_ oldFailureReport spec c_ = do++  (config, seed) <- ensureSeed (applyFailureReport oldFailureReport c_)++  colorMode <- colorOutputSupported (configColorMode config) (hSupportsANSI stdout)+  outputUnicode <- unicodeOutputSupported (configUnicodeMode config) stdout++  let+    filteredSpec = specToEvalForest seed config spec+    qcArgs = configQuickCheckArgs config+    !numberOfItems = countEvalItems filteredSpec++  when (configFailOnEmpty config && numberOfItems == 0) $ do+    when (countSpecItems spec /= 0) $ do+      die "all spec items have been filtered; failing due to --fail-on=empty"++  concurrentJobs <- maybe getDefaultConcurrentJobs return $ configConcurrentJobs config++  results <- fmap toSpecResult . withHiddenCursor (progressReporting colorMode) stdout $ do+    let+      formatConfig = FormatConfig {+        formatConfigUseColor = shouldUseColor colorMode+      , formatConfigReportProgress = progressReporting colorMode == ProgressReportingEnabled+      , formatConfigOutputUnicode = outputUnicode+      , formatConfigUseDiff = configDiff config+      , formatConfigDiffContext = configDiffContext config+      , formatConfigExternalDiff = if configDiff config then ($ configDiffContext config) <$> configExternalDiff config else Nothing+      , formatConfigPrettyPrint = configPrettyPrint config+      , formatConfigPrettyPrintFunction = if configPrettyPrint config then Just (configPrettyPrintFunction config outputUnicode) else Nothing+      , formatConfigFormatException = configFormatException config+      , formatConfigPrintTimes = configTimes config+      , formatConfigHtmlOutput = configHtmlOutput config+      , formatConfigPrintCpuTime = configPrintCpuTime config+      , formatConfigUsedSeed = seed+      , formatConfigExpectedTotalCount = numberOfItems+      , formatConfigExpertMode = configExpertMode config+      }++      formatter :: FormatConfig -> IO Format+      formatter = fromMaybe (V2.formatterToFormat V2.checks) (Config.getFormatter config)++    format <- maybe id printSlowSpecItems (configPrintSlowItems config) <$> formatter formatConfig++    let+      evalConfig = EvalConfig {+        evalConfigFormat = format+      , evalConfigConcurrentJobs = concurrentJobs+      , evalConfigFailFast = configFailFast config+      , evalConfigColorMode = bool Eval.ColorDisabled Eval.ColorEnabled (shouldUseColor colorMode)+      }+    runFormatter evalConfig filteredSpec++  let+    failures :: [Path]+    failures = map resultItemPath $ filter resultItemIsFailure $ specResultItems results++  dumpFailureReport config seed qcArgs failures++  return results++specToEvalForest :: Integer -> Config -> [SpecTree ()] -> [EvalTree]+specToEvalForest seed config =+      failItemsWithEmptyDescription config+  >>> addDefaultDescriptions+  >>> failFocusedItems config+  >>> failPendingItems config+  >>> Extension.applySpecTransformation config+  >>> focusSpec config+  >>> toEvalItemForest params+  >>> applyDryRun config+  >>> applyFilterPredicates config+  >>> randomize+  >>> pruneForest+  where+    params :: Params+    params = Params (configQuickCheckArgs config) (configSmallCheckDepth config)++    randomize :: [Tree c a] -> [Tree c a]+    randomize+      | configRandomize config = randomizeForest seed       | otherwise = id -    doesUseColor :: Handle -> Config -> IO Bool-    doesUseColor h c = case configColorMode c of-      ColorAuto  -> (&&) <$> hIsTerminalDevice h <*> (not <$> isDumb)-      ColorNever -> return False-      ColorAlways -> return True+pruneForest :: [Tree c a] -> [Eval.Tree c a]+pruneForest = mapMaybe pruneTree -    withHandle :: Config -> (Handle -> IO a) -> IO a-    withHandle c action = case configOutputFile c of-      Left h -> action h-      Right path -> withFile path WriteMode action+pruneTree :: Tree c a -> Maybe (Eval.Tree c a)+pruneTree node = case node of+  Node group xs -> Eval.Node group <$> prune xs+  NodeWithCleanup loc action xs -> Eval.NodeWithCleanup loc action <$> prune xs+  Leaf item -> Just (Eval.Leaf item)+  where+    prune = nonEmpty . pruneForest -isDumb :: IO Bool-isDumb = maybe False (== "dumb") <$> lookupEnv "TERM"+type EvalItemTree = Tree (IO ()) EvalItem --- | Summary of a test run.-data Summary = Summary {-  summaryExamples :: Int-, summaryFailures :: Int-} deriving (Eq, Show)+toEvalItemForest :: Params -> [SpecTree ()] -> [EvalItemTree]+toEvalItemForest params = bimapForest id toEvalItem . filterForest itemIsFocused+  where+    toEvalItem :: Item () -> EvalItem+    toEvalItem (Item requirement loc isParallelizable _isFocused _annotations e) = EvalItem {+      evalItemDescription = requirement+    , evalItemLocation = loc+    , evalItemConcurrency = if isParallelizable == Just True then Concurrent else Sequential+    , evalItemAction = \ progress -> measure $ e params withUnit progress+    } -instance Monoid Summary where-  mempty = Summary 0 0-  (Summary x1 x2) `mappend` (Summary y1 y2) = Summary (x1 + y1) (x2 + y2)+    withUnit :: ActionWith () -> IO ()+    withUnit action = action ()++dumpFailureReport :: Config -> Integer -> QC.Args -> [Path] -> IO ()+dumpFailureReport config seed qcArgs xs = do+  writeFailureReport config FailureReport {+      failureReportSeed = seed+    , failureReportMaxSuccess = QC.maxSuccess qcArgs+    , failureReportMaxSize = QC.maxSize qcArgs+    , failureReportMaxDiscardRatio = QC.maxDiscardRatio qcArgs+    , failureReportPaths = xs+    }++doNotLeakCommandLineArgumentsToExamples :: IO a -> IO a+doNotLeakCommandLineArgumentsToExamples = withArgs []++withHiddenCursor :: ProgressReporting -> Handle -> IO a -> IO a+withHiddenCursor progress h = case progress of+  ProgressReportingDisabled -> id+  ProgressReportingEnabled -> bracket_ (hHideCursor h) (hShowCursor h)++data UseColor = ColorDisabled | ColorEnabled ProgressReporting+  deriving (Eq, Show)++data ProgressReporting = ProgressReportingDisabled | ProgressReportingEnabled+  deriving (Eq, Show)++shouldUseColor :: UseColor -> Bool+shouldUseColor c = case c of+  ColorDisabled -> False+  ColorEnabled _ -> True++progressReporting :: UseColor -> ProgressReporting+progressReporting c = case c of+  ColorDisabled -> ProgressReportingDisabled+  ColorEnabled r -> r++colorOutputSupported :: ColorMode -> IO Bool -> IO UseColor+colorOutputSupported mode isTerminalDevice = do+  github <- githubActions+  buildkite <- lookupEnv "BUILDKITE" <&> (== Just "true")+  let+    progress :: ProgressReporting+    progress+      | github || buildkite = ProgressReportingDisabled+      | otherwise = ProgressReportingEnabled++    colorEnabled :: UseColor+    colorEnabled = ColorEnabled progress+  case mode of+    ColorAuto -> bool ColorDisabled colorEnabled . (github ||) <$> colorTerminal+    ColorNever -> return ColorDisabled+    ColorAlways -> return colorEnabled+  where+    githubActions :: IO Bool+    githubActions = lookupEnv "GITHUB_ACTIONS" <&> (== Just "true")++    colorTerminal :: IO Bool+    colorTerminal = (&&) <$> (not <$> noColor) <*> isTerminalDevice++    noColor :: IO Bool+    noColor = lookupEnv "NO_COLOR" <&> (/= Nothing)++unicodeOutputSupported :: UnicodeMode -> Handle -> IO Bool+unicodeOutputSupported mode h = case mode of+  UnicodeAuto -> Compat.unicodeOutputSupported h+  UnicodeNever -> return False+  UnicodeAlways -> return True++rerunAll :: Config -> Maybe FailureReport -> SpecResult -> Bool+rerunAll config mOldFailureReport result = case mOldFailureReport of+  Nothing -> False+  Just oldFailureReport ->+       configRerunAllOnSuccess config+    && configRerun config+    && specResultSuccess result+    && (not . null) (failureReportPaths oldFailureReport)++randomizeForest :: Integer -> [Tree c a] -> [Tree c a]+randomizeForest seed t = runST $ do+  ref <- newSTRef (mkStdGen $ fromIntegral seed)+  shuffleForest ref t++countEvalItems :: [Eval.Tree c a] -> Int+countEvalItems = getSum . foldMap (foldMap . const $ Sum 1)++countSpecItems :: [Tree c a] -> Int+countSpecItems = getSum . foldMap (foldMap . const $ Sum 1)
src/Test/Hspec/Core/Runner/Eval.hs view
@@ -1,166 +1,325 @@ {-# LANGUAGE CPP #-}--#if MIN_VERSION_base(4,6,0)--- Control.Concurrent.QSem is deprecated in base-4.6.0.*-{-# OPTIONS_GHC -fno-warn-deprecations #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE LambdaCase #-}+module Test.Hspec.Core.Runner.Eval (+  EvalConfig(..)+, ColorMode(..)+, EvalTree+, Tree(..)+, EvalItem(..)+, Concurrency(..)+, runFormatter+#ifdef TEST+, mergeResults #endif--module Test.Hspec.Core.Runner.Eval (runFormatter) where+) where  import           Prelude ()-import           Test.Hspec.Compat--import           Control.Monad (unless, when)-import qualified Control.Exception as E-import           Control.Concurrent-import           System.IO (Handle)+import           Test.Hspec.Core.Compat hiding (Monad)  import           Control.Monad.IO.Class (liftIO)-import           Control.DeepSeq (deepseq)-import           Data.Time.Clock.POSIX+import           Control.Monad.Trans.Reader+import           Control.Monad.Trans.Class  import           Test.Hspec.Core.Util-import           Test.Hspec.Core.Spec-import           Test.Hspec.Config-import           Test.Hspec.Core.Formatters-import           Test.Hspec.Core.Formatters.Internal-import           Test.Hspec.Timer+import           Test.Hspec.Core.Spec (Progress, FailureReason(..), Result(..), ResultStatus(..), ProgressCallback)+import           Test.Hspec.Core.Timer+import           Test.Hspec.Core.Format (Format)+import qualified Test.Hspec.Core.Format as Format+import           Test.Hspec.Core.Clock+import           Test.Hspec.Core.Example.Location+import           Test.Hspec.Core.Example (safeEvaluateResultStatus, exceptionToResultStatus) -type EvalTree = Tree (ActionWith ()) (String, Maybe Location, ProgressCallback -> FormatResult -> IO (FormatM ()))+import qualified Data.List.NonEmpty as NonEmpty+import           Data.List.NonEmpty (NonEmpty(..)) +import           Test.Hspec.Core.Runner.JobQueue++data Tree c a =+    Node String (NonEmpty (Tree c a))+  | NodeWithCleanup (Maybe (String, Location)) c (NonEmpty (Tree c a))+  | Leaf a+  deriving (Eq, Show, Functor, Foldable, Traversable)++data EvalConfig = EvalConfig {+  evalConfigFormat :: Format+, evalConfigConcurrentJobs :: Int+, evalConfigFailFast :: Bool+, evalConfigColorMode :: ColorMode+}++data ColorMode = ColorDisabled | ColorEnabled++data Env = Env {+  envConfig :: EvalConfig+, envAbort :: IORef Bool+, envResults :: IORef [(Path, Format.Item)]+}++formatEvent :: Format.Event -> EvalM ()+formatEvent event = do+  format <- asks $ evalConfigFormat . envConfig+  liftIO $ format event++type EvalM = ReaderT Env IO++abort :: EvalM ()+abort = do+  ref <- asks envAbort+  liftIO $ writeIORef ref True++shouldAbort :: EvalM Bool+shouldAbort = do+  ref <- asks envAbort+  liftIO $ readIORef ref++addResult :: Path -> Format.Item -> EvalM ()+addResult path item = do+  ref <- asks envResults+  liftIO $ modifyIORef ref ((path, item) :)++reportItem :: Path -> Maybe Location -> EvalM (Seconds, Result)  -> EvalM ()+reportItem path loc action = do+  reportItemStarted path+  action >>= reportResult path loc++reportItemStarted :: Path -> EvalM ()+reportItemStarted = formatEvent . Format.ItemStarted++reportItemDone :: Path -> Format.Item -> EvalM ()+reportItemDone path item = do+  addResult path item+  formatEvent $ Format.ItemDone path item++isFailure :: Result -> Bool+isFailure r = case resultStatus r of+  Success{} -> False+  Pending{} -> False+  Failure{} -> True++reportResult :: Path -> Maybe Location -> (Seconds, Result) -> EvalM ()+reportResult path loc (duration, result) = do+  mode <- asks (evalConfigColorMode . envConfig)+  case result of+    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_ $ case mode of+        ColorEnabled -> err+        ColorDisabled -> case err of+          NoReason -> err+          Reason _ -> err+          ExpectedButGot _ _ _ -> err+          ColorizedReason r -> Reason (stripAnsi r)+#if __GLASGOW_HASKELL__ < 900+          Error _ _ -> err+#endif++groupStarted :: Path -> EvalM ()+groupStarted = formatEvent . Format.GroupStarted++groupDone :: Path -> EvalM ()+groupDone = formatEvent . Format.GroupDone++data EvalItem = EvalItem {+  evalItemDescription :: String+, evalItemLocation :: Maybe Location+, evalItemConcurrency :: Concurrency+, evalItemAction :: ProgressCallback -> IO (Seconds, Result)+}++type EvalTree = Tree (IO ()) EvalItem+ -- | Evaluate all examples of a given spec and produce a report.-runFormatter :: QSem -> Bool -> Handle -> Config -> Formatter -> [SpecTree ()] -> FormatM ()-runFormatter jobsSem useColor h c formatter specs = do-  headerFormatter formatter-  chan <- liftIO newChan-  reportProgress <- liftIO mkReportProgress-  run chan reportProgress c formatter (toEvalTree specs)+runFormatter :: EvalConfig -> [EvalTree] -> IO [(Path, Format.Item)]+runFormatter config specs = do+  withJobQueue (evalConfigConcurrentJobs config) $ \ queue -> do+    withTimer 0.05 $ \ timer -> do+      env <- mkEnv+      runningSpecs_ <- enqueueItems queue specs++      let+        applyReportProgress :: RunningItem_ IO -> RunningItem IO+        applyReportProgress item = fmap (. reportProgress timer) item++        runningSpecs :: [RunningTree () EvalM]+        runningSpecs = applyCleanup abortEarly $ map (fmap applyReportProgress) runningSpecs_++        abortEarly :: Result -> Bool+        abortEarly result = evalConfigFailFast config && isFailure result++        getResults :: IO [(Path, Format.Item)]+        getResults = reverse <$> readIORef (envResults env)++        formatItems :: IO ()+        formatItems = runReaderT (eval runningSpecs) env++        formatDone :: IO ()+        formatDone = getResults >>= format . Format.Done++      format Format.Started+      formatItems `finally` formatDone+      getResults   where-    mkReportProgress :: IO (Path -> Progress -> IO ())-    mkReportProgress-      | useColor = every 0.05 $ exampleProgress formatter h-      | otherwise = return $ \_ _ -> return ()+    mkEnv :: IO Env+    mkEnv = Env config <$> newIORef False <*> newIORef [] -    toEvalTree :: [SpecTree ()] -> [EvalTree]-    toEvalTree = map (fmap f)-      where-        f :: Item () -> (String, Maybe Location, ProgressCallback -> FormatResult -> IO (FormatM ()))-        f (Item requirement loc isParallelizable e) = (requirement, loc, parallelize jobsSem isParallelizable $ e params ($ ()))+    format :: Format+    format = evalConfigFormat config -    params :: Params-    params = Params (configQuickCheckArgs c) (configSmallCheckDepth c)+    reportProgress :: IO Bool -> Path -> Progress -> IO ()+    reportProgress timer path progress = do+      r <- timer+      when r $ do+        format (Format.Progress path progress) --- | Execute given action at most every specified number of seconds.-every :: POSIXTime -> (a -> b -> IO ()) -> IO (a -> b -> IO ())-every seconds action = do-  timer <- newTimer seconds-  return $ \a b -> do-    r <- timer-    when r (action a b)+data Item a = Item {+  itemDescription :: String+, itemLocation :: Maybe Location+, itemAction :: a+} deriving Functor -type FormatResult = Either E.SomeException Result -> FormatM ()+type RunningItem m = Item (Path -> m (Seconds, Result))+type RunningTree c m = Tree c (RunningItem m) -parallelize :: QSem -> Bool -> (ProgressCallback -> IO Result) -> ProgressCallback -> FormatResult -> IO (FormatM ())-parallelize jobsSem isParallelizable e-  | isParallelizable = runParallel jobsSem e-  | otherwise = runSequentially e+type RunningItem_ m = Item (Job m Progress (Seconds, Result))+type RunningTree_ m = Tree (IO ()) (RunningItem_ m) -runSequentially :: (ProgressCallback -> IO Result) -> ProgressCallback -> FormatResult -> IO (FormatM ())-runSequentially e reportProgress formatResult = return $ do-  result <- liftIO $ evalExample (e reportProgress)-  formatResult result+applyFailFast :: (Result -> Bool) -> RunningTree () IO -> RunningTree () EvalM+applyFailFast = fmap . fmap . fmap . applyToItem+  where+    applyToItem abortEarly action = do+      result@(_, r) <- lift action+      when (abortEarly r) abort+      return result -data Report = ReportProgress Progress | ReportResult (Either E.SomeException Result)+applyCleanup :: (Result -> Bool) -> [RunningTree (IO ()) IO] -> [RunningTree () EvalM]+applyCleanup abortEarly = map (applyFailFast abortEarly . go)+  where+    go :: RunningTree (IO ()) IO -> RunningTree () IO+    go t = case t of+      Node label xs -> Node label (go <$> xs)+      NodeWithCleanup loc cleanup xs -> NodeWithCleanup loc () (applyCleanupAction abortEarly loc cleanup $ go <$> xs)+      Leaf a -> Leaf a -runParallel :: QSem -> (ProgressCallback -> IO Result) -> ProgressCallback -> FormatResult -> IO (FormatM ())-runParallel jobsSem e reportProgress formatResult = do-  mvar <- newEmptyMVar-  _ <- forkIO $ E.bracket_ (waitQSem jobsSem) (signalQSem jobsSem) $ do-    let progressCallback = replaceMVar mvar . ReportProgress-    result <- evalExample (e progressCallback)-    replaceMVar mvar (ReportResult result)-  return $ evalReport mvar+applyCleanupAction :: (Result -> Bool) -> Maybe (String, Location) -> IO () -> NonEmpty (RunningTree () IO) -> NonEmpty (RunningTree () IO)+applyCleanupAction abortEarly loc cleanup = forLastLeaf (addCleanupOn (not . abortEarly)) . forEachLeaf (addCleanupOn abortEarly)   where-    evalReport :: MVar Report -> FormatM ()-    evalReport mvar = do-      r <- liftIO (takeMVar mvar)-      case r of-        ReportProgress p -> do-          liftIO $ reportProgress p-          evalReport mvar-        ReportResult result -> formatResult result+    addCleanupOn p = addCleanupToItem p loc cleanup -    replaceMVar :: MVar a -> a -> IO ()-    replaceMVar mvar p = tryTakeMVar mvar >> putMVar mvar p+forEachLeaf :: (a -> b) -> NonEmpty (Tree () a) -> NonEmpty (Tree () b)+forEachLeaf f = fmap (fmap f) -evalExample :: IO Result -> IO (Either E.SomeException Result)-evalExample e = safeTry $ forceResult <$> e+forLastLeaf :: (a -> a) -> NonEmpty (Tree () a) -> NonEmpty (Tree () a)+forLastLeaf p = go   where-    forceResult :: Result -> Result-    forceResult r = case r of-      Success -> r-      Pending m -> m `deepseq` r-      Fail _ m -> m `deepseq` r+    go = NonEmpty.reverse . mapHead goNode . NonEmpty.reverse -data Message = Done | Run (FormatM ())+    goNode node = case node of+      Node description xs -> Node description (go xs)+      NodeWithCleanup loc_ () xs -> NodeWithCleanup loc_ () (go xs)+      Leaf item -> Leaf (p item) -run :: Chan Message -> (Path -> ProgressCallback) -> Config -> Formatter -> [EvalTree] -> FormatM ()-run chan reportProgress_ c formatter specs = do-  liftIO $ do-    forM_ specs (queueSpec [])-    writeChan chan Done-  processMessages (readChan chan) (configFastFail c)+mapHead :: (a -> a) -> NonEmpty a -> NonEmpty a+mapHead f xs = case xs of+  y :| ys -> f y :| ys++addCleanupToItem :: (Result -> Bool) -> Maybe (String, Location) -> IO () -> RunningItem IO -> RunningItem IO+addCleanupToItem shouldRunCleanup loc cleanup item = item {+  itemAction = \ path -> do+    result@(t1, r1) <- itemAction item path+    if shouldRunCleanup r1 then do+      (t2, r2) <- measure $ safeEvaluateResultStatus (cleanup >> return Success)+      let t = t1 + t2+      return (t, mergeResults loc r1 r2)+    else do+      return result+}++mergeResults :: Maybe (String, Location) -> Result -> ResultStatus -> Result+mergeResults mCallSite (Result info r1) r2 = Result info $ case (r1, r2) of+  (_, Success) -> r1+  (Failure{}, _) -> r1+  (Pending{}, Pending{}) -> r1+  (Success, Pending{}) -> r2+  (_, Failure mLoc err) -> Failure (mLoc <|> hookLoc) $ case err of+    Error message e -> Error (message <|> hookFailed) e+    _ -> err   where-    defer :: FormatM () -> IO ()-    defer = writeChan chan . Run+    hookLoc = snd <$> mCallSite+    hookFailed = case mCallSite of+      Just (name, _) -> Just $ "in " ++ name ++ "-hook:"+      Nothing -> Nothing -    runCleanup :: IO () -> Path -> FormatM ()-    runCleanup action path = do-      r <- liftIO $ safeTry action-      either (failed Nothing path . Left) return r+enqueueItems :: MonadIO m => JobQueue -> [EvalTree] -> IO [RunningTree_ m]+enqueueItems queue = mapM (traverse $ enqueueItem queue) -    queueSpec :: [String] -> EvalTree -> IO ()-    queueSpec rGroups (Node group xs) = do-      defer (exampleGroupStarted formatter (reverse rGroups) group)-      forM_ xs (queueSpec (group : rGroups))-      defer (exampleGroupDone formatter)-    queueSpec rGroups (NodeWithCleanup action xs) = do-      forM_ xs (queueSpec rGroups)-      defer (runCleanup (action ()) (reverse rGroups, "afterAll-hook"))-    queueSpec rGroups (Leaf e) =-      queueExample (reverse rGroups) e+enqueueItem :: MonadIO m => JobQueue -> EvalItem -> IO (RunningItem_ m)+enqueueItem queue EvalItem{..} = do+  job <- enqueueJob queue evalItemConcurrency evalItemAction+  return Item {+    itemDescription = evalItemDescription+  , itemLocation = evalItemLocation+  , itemAction = job >=> liftIO . either exceptionToResult return+  }+  where+    exceptionToResult :: SomeException -> IO (Seconds, Result)+    exceptionToResult err = (,) 0 . Result "" <$> exceptionToResultStatus err -    queueExample :: [String] -> (String, Maybe Location, ProgressCallback -> FormatResult -> IO (FormatM ())) -> IO ()-    queueExample groups (requirement, loc, e) = e reportProgress formatResult >>= defer+eval :: [RunningTree () EvalM] -> EvalM ()+eval specs = do+  sequenceActions (concatMap foldSpec specs)+  where+    foldSpec :: RunningTree () EvalM -> [EvalM ()]+    foldSpec = foldTree FoldTree {+      onGroupStarted = groupStarted+    , onGroupDone = groupDone+    , onCleanup = runCleanup+    , onLeafe = evalItem+    }++    runCleanup :: Maybe (String, Location) -> [String] -> () -> EvalM ()+    runCleanup _loc _groups = return++    evalItem :: [String] -> RunningItem EvalM -> EvalM ()+    evalItem groups (Item requirement loc action) = do+      reportItem path loc $ action path       where         path :: Path         path = (groups, requirement) -        reportProgress = reportProgress_ path--        formatResult :: Either E.SomeException Result -> FormatM ()-        formatResult result = do-          case result of-            Right Success -> do-              increaseSuccessCount-              exampleSucceeded formatter path-            Right (Pending reason) -> do-              increasePendingCount-              examplePending formatter path reason-            Right (Fail loc_ err) -> failed (loc_ <|> loc) path (Right err)-            Left err         -> failed loc path (Left  err)+data FoldTree c a r = FoldTree {+  onGroupStarted :: Path -> r+, onGroupDone :: Path -> r+, onCleanup :: Maybe (String, Location) -> [String] -> c -> r+, onLeafe :: [String] -> a -> r+} -    failed loc path err = do-      increaseFailCount-      addFailMessage loc path err-      exampleFailed formatter path err+foldTree :: FoldTree c a r -> Tree c a -> [r]+foldTree FoldTree{..} = go []+  where+    go rGroups (Node group xs) = start : children ++ [done]+      where+        path = (reverse rGroups, group)+        start = onGroupStarted path+        children = concatMap (go (group : rGroups)) xs+        done =  onGroupDone path+    go rGroups (NodeWithCleanup loc action xs) = children ++ [cleanup]+      where+        children = concatMap (go rGroups) xs+        cleanup = onCleanup loc (reverse rGroups) action+    go rGroups (Leaf a) = [onLeafe (reverse rGroups) a] -processMessages :: IO Message -> Bool -> FormatM ()-processMessages getMessage fastFail = go+sequenceActions :: [EvalM ()] -> EvalM ()+sequenceActions = go   where-    go = liftIO getMessage >>= \m -> case m of-      Run action -> do-        action-        fails <- getFailCount-        unless (fastFail && fails /= 0) go-      Done -> return ()+    go :: [EvalM ()] -> EvalM ()+    go [] = pass+    go (action : actions) = do+      action+      shouldAbort >>= \ case+        False -> go actions+        True -> pass
+ src/Test/Hspec/Core/Runner/JobQueue.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ConstraintKinds #-}++module Test.Hspec.Core.Runner.JobQueue (+  MonadIO+, Job+, Concurrency(..)+, JobQueue+, withJobQueue+, enqueueJob+) where++import           Prelude ()+import           Test.Hspec.Core.Compat hiding (Monad)+import qualified Test.Hspec.Core.Compat as M++import           Control.Concurrent+import           Control.Concurrent.Async (Async, async, waitCatch, cancelMany)++import           Control.Monad.IO.Class (liftIO)+import qualified Control.Monad.IO.Class as M++-- for compatibility with GHC < 7.10.1+type Monad m = (Functor m, Applicative m, M.Monad m)+type MonadIO m = (Monad m, M.MonadIO m)++type Job m progress a = (progress -> m ()) -> m a++data Concurrency = Sequential | Concurrent++data JobQueue = JobQueue {+  _semaphore :: Semaphore+, _cancelQueue :: CancelQueue+}++data Semaphore = Semaphore {+  _wait :: IO ()+, _signal :: IO ()+}++type CancelQueue = IORef [Async ()]++withJobQueue :: Int -> (JobQueue -> IO a) -> IO a+withJobQueue concurrency = bracket new cancelAll+  where+    new :: IO JobQueue+    new = JobQueue <$> newSemaphore concurrency <*> newIORef []++    cancelAll :: JobQueue -> IO ()+    cancelAll (JobQueue _ cancelQueue) = readIORef cancelQueue >>= cancelMany++newSemaphore :: Int -> IO Semaphore+newSemaphore capacity = do+  sem <- newQSem capacity+  return $ Semaphore (waitQSem sem) (signalQSem sem)++enqueueJob :: MonadIO m => JobQueue -> Concurrency -> Job IO progress a -> IO (Job m progress (Either SomeException a))+enqueueJob (JobQueue sem cancelQueue) concurrency = case concurrency of+  Sequential -> runSequentially cancelQueue+  Concurrent -> runConcurrently sem cancelQueue++runSequentially :: forall m progress a. MonadIO m => CancelQueue -> Job IO progress a -> IO (Job m progress (Either SomeException a))+runSequentially cancelQueue action = do+  barrier <- newEmptyMVar+  let+    wait :: IO ()+    wait = takeMVar barrier++    signal :: m ()+    signal = liftIO $ putMVar barrier ()++  job <- runConcurrently (Semaphore wait pass) cancelQueue action+  return $ \ notifyPartial -> signal >> job notifyPartial++data Partial progress a = Partial progress | Done++runConcurrently :: forall m progress a. MonadIO m => Semaphore -> CancelQueue -> Job IO progress a -> IO (Job m progress (Either SomeException a))+runConcurrently (Semaphore wait signal) cancelQueue action = do+  result :: MVar (Partial progress a) <- newEmptyMVar+  let+    worker :: IO a+    worker = bracket_ wait signal $ do+      interruptible (action partialResult) `finally` done+      where+        partialResult :: progress -> IO ()+        partialResult = replaceMVar result . Partial++        done :: IO ()+        done = replaceMVar result Done++    pushOnCancelQueue :: Async a -> IO ()+    pushOnCancelQueue = (modifyIORef cancelQueue . (:) . void)++  job <- bracket (async worker) pushOnCancelQueue return++  let+    waitForResult :: (progress -> m ()) -> m (Either SomeException a)+    waitForResult notifyPartial = do+      r <- liftIO (takeMVar result)+      case r of+        Partial progress -> notifyPartial progress >> waitForResult notifyPartial+        Done -> liftIO $ waitCatch job++  return waitForResult++replaceMVar :: MVar a -> a -> IO ()+replaceMVar mvar p = tryTakeMVar mvar >> putMVar mvar p
+ src/Test/Hspec/Core/Runner/PrintSlowSpecItems.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+module Test.Hspec.Core.Runner.PrintSlowSpecItems (+  printSlowSpecItems+) where++import           Prelude ()+import           Test.Hspec.Core.Compat++import           System.IO (stderr, hPutStrLn)++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+        hPutStrLn stderr "\nSlow spec items:"+        mapM_ printSlowSpecItem xs+    _ -> pass++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+  hPutStrLn stderr $ "  " ++ maybe "" formatLocation location ++ joinPath path ++ " (" ++ show duration ++ "ms)"
+ src/Test/Hspec/Core/Runner/Result.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE CPP #-}+module Test.Hspec.Core.Runner.Result (+-- RE-EXPORTED from Test.Hspec.Core.Runner+  SpecResult(SpecResult)+, specResultItems+, specResultSuccess++, ResultItem(ResultItem)+, resultItemPath+, resultItemStatus+, resultItemIsFailure++, ResultItemStatus(..)++, Summary(..)+, toSummary+, isSuccess+-- END RE-EXPORTED from Test.Hspec.Core.Runner++, toSpecResult+) where++import           Prelude ()+import           Test.Hspec.Core.Compat++import           Test.Hspec.Core.Util+import qualified Test.Hspec.Core.Format as Format++-- |+-- @since 2.10.0+data SpecResult = SpecResult {+  -- |+  -- @since 2.10.0+  specResultItems :: [ResultItem]++  -- |+  -- @since 2.10.0+, specResultSuccess :: !Bool+} deriving (Eq, Show)++-- |+-- @since 2.10.0+data ResultItem = ResultItem {+  -- |+  -- @since 2.10.0+  resultItemPath :: Path++  -- |+  -- @since 2.10.0+, resultItemStatus :: ResultItemStatus+} deriving (Eq, Show)++-- |+-- @since 2.10.0+resultItemIsFailure :: ResultItem -> Bool+resultItemIsFailure item = case resultItemStatus item of+  ResultItemSuccess -> False+  ResultItemPending -> False+  ResultItemFailure -> True++data ResultItemStatus =+    ResultItemSuccess+  | ResultItemPending+  | ResultItemFailure+  deriving (Eq, Show)++toSpecResult :: [(Path, Format.Item)] -> SpecResult+toSpecResult results = SpecResult items success+  where+    items = map toResultItem results+    success = all (not . resultItemIsFailure) items++toResultItem :: (Path, Format.Item) -> ResultItem+toResultItem (path, item) = ResultItem path status+  where+    status = case Format.itemResult item of+      Format.Success{} -> ResultItemSuccess+      Format.Pending{} -> ResultItemPending+      Format.Failure{} -> ResultItemFailure++-- | Summary of a test run.+data Summary = Summary {+  summaryExamples :: !Int+, summaryFailures :: !Int+} deriving (Eq, Show)++instance Monoid Summary where+  mempty = Summary 0 0+#if MIN_VERSION_base(4,11,0)+instance Semigroup Summary where+#endif+  (Summary x1 x2)+#if MIN_VERSION_base(4,11,0)+    <>+#else+    `mappend`+#endif+    (Summary y1 y2) = Summary (x1 + y1) (x2 + y2)++toSummary :: SpecResult -> Summary+toSummary result = Summary {+  summaryExamples = length items+, summaryFailures = length failures+} where+    items = specResultItems result+    failures = filter resultItemIsFailure items++-- | `True` if the given `Summary` indicates that there were no+-- failures, `False` otherwise.+isSuccess :: Summary -> Bool+isSuccess summary = summaryFailures summary == 0
+ src/Test/Hspec/Core/Shuffle.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE CPP #-}+module Test.Hspec.Core.Shuffle (+  shuffleForest+#ifdef TEST+, shuffle+, mkArray+#endif+) where++import           Prelude ()+import           Test.Hspec.Core.Compat+import           Test.Hspec.Core.Tree++import           System.Random+import           Control.Monad.ST+import           Data.STRef+import           Data.Array.ST++shuffleForest :: STRef st StdGen -> [Tree c a] -> ST st [Tree c a]+shuffleForest ref xs = (shuffle ref xs >>= mapM (shuffleTree ref))++shuffleTree :: STRef st StdGen -> Tree c a -> ST st (Tree c a)+shuffleTree ref t = case t of+  Node d xs -> Node d <$> shuffleForest ref xs+  NodeWithCleanup loc c xs -> NodeWithCleanup loc c <$> shuffleForest ref xs+  Leaf {} -> return t++shuffle :: STRef st StdGen -> [a] -> ST st [a]+shuffle ref xs = do+  arr <- mkArray xs+  bounds@(_, n) <- getBounds arr+  forM (range bounds) $ \ i -> do+    j <- randomIndex (i, n)+    vi <- readArray arr i+    vj <- readArray arr j+    writeArray arr j vi+    return vj+  where+    randomIndex bounds = do+      (a, gen) <- randomR bounds <$> readSTRef ref+      writeSTRef ref gen+      return a++mkArray :: [a] -> ST st (STArray st Int a)+mkArray xs = newListArray (1, length xs) xs
src/Test/Hspec/Core/Spec.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE CPP #-}-#if MIN_VERSION_base(4,8,1)-#define HAS_SOURCE_LOCATIONS-{-# LANGUAGE ImplicitParams #-}-#endif+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-} -- | -- Stability: unstable --@@ -11,38 +9,119 @@ module Test.Hspec.Core.Spec (  -- * Defining a spec-  describe-, it+  it+, specify+, describe+, context , pending , pendingWith+, xit+, xspecify+, xdescribe+, xcontext++-- * Focused spec items #focus#+-- |+-- During a test run, when a spec contains /focused/ spec items, all other spec+-- items are ignored.+, focus+, fit+, fspecify+, fdescribe+, fcontext+ , parallel+, sequential  -- * The @SpecM@ monad-, module Test.Hspec.Core.Spec.Monad+, Test.Hspec.Core.Spec.Monad.Spec+, Test.Hspec.Core.Spec.Monad.SpecWith+, Test.Hspec.Core.Spec.Monad.SpecM(..)+, Test.Hspec.Core.Spec.Monad.runSpecM+, Test.Hspec.Core.Spec.Monad.fromSpecList+, Test.Hspec.Core.Spec.Monad.runIO+, Test.Hspec.Core.Spec.Monad.mapSpecForest+, Test.Hspec.Core.Spec.Monad.mapSpecItem+, Test.Hspec.Core.Spec.Monad.mapSpecItem_+, Test.Hspec.Core.Spec.Monad.modifyParams+, Test.Hspec.Core.Spec.Monad.modifyConfig+, getSpecDescriptionPath  -- * A type class for examples-, module Test.Hspec.Core.Example+, Test.Hspec.Core.Example.Example (..)+#ifndef ENABLE_SPEC_HOOK_ARGS+, Test.Hspec.Core.Example.Arg+#endif+, Test.Hspec.Core.Example.Params (..)+, Test.Hspec.Core.Example.defaultParams+, Test.Hspec.Core.Example.ActionWith+, Test.Hspec.Core.Example.Progress+, Test.Hspec.Core.Example.ProgressCallback+, Test.Hspec.Core.Example.Result(..)+, Test.Hspec.Core.Example.ResultStatus (..)+, Test.Hspec.Core.Example.Location (..)+, Test.Hspec.Core.Example.FailureReason (..)+, Test.Hspec.Core.Example.safeEvaluate+, Test.Hspec.Core.Example.safeEvaluateExample  -- * Internal representation of a spec tree-, module Test.Hspec.Core.Tree+, Test.Hspec.Core.Tree.SpecTree+, Test.Hspec.Core.Tree.Tree (..)+, Test.Hspec.Core.Tree.Item (..)+, Test.Hspec.Core.Tree.specGroup+, Test.Hspec.Core.Tree.specItem+, Test.Hspec.Core.Tree.bimapTree+, Test.Hspec.Core.Tree.bimapForest+, Test.Hspec.Core.Tree.filterTree+, Test.Hspec.Core.Tree.filterForest+, Test.Hspec.Core.Tree.filterTreeWithLabels+, Test.Hspec.Core.Tree.filterForestWithLabels+, Test.Hspec.Core.Tree.pruneTree -- unused+, Test.Hspec.Core.Tree.pruneForest -- unused+, Test.Hspec.Core.Tree.location++, focusForest++-- * Re-exports+, HasCallStack+, Expectation ) where -#ifdef HAS_SOURCE_LOCATIONS-import           GHC.Stack-#endif+import           Prelude ()+import           Test.Hspec.Core.Compat -import qualified Control.Exception as E+import           Control.Monad.Trans.Class (lift)+import           Control.Monad.Trans.Reader (asks)  import           Test.Hspec.Expectations (Expectation)  import           Test.Hspec.Core.Example+import           Test.Hspec.Core.Hooks import           Test.Hspec.Core.Tree import           Test.Hspec.Core.Spec.Monad+import           Test.Hspec.Core.QuickCheck ()  -- | The @describe@ function combines a list of specs into a larger spec.-describe :: String -> SpecWith a -> SpecWith a-describe label spec = runIO (runSpecM spec) >>= fromSpecList . return . specGroup label+describe :: HasCallStack => String -> SpecWith a -> SpecWith a+describe label = withEnv pushLabel . mapSpecForest (return . specGroup label)+  where+    pushLabel (Env labels) = Env $ label : labels +-- | @context@ is an alias for `describe`.+context :: HasCallStack => String -> SpecWith a -> SpecWith a+context = describe++-- |+-- Changing `describe` to `xdescribe` marks all spec items of the corresponding subtree as pending.+--+-- This can be used to temporarily disable spec items.+xdescribe :: HasCallStack => String -> SpecWith a -> SpecWith a+xdescribe label spec = before_ pending_ $ describe label spec++-- | @xcontext@ is an alias for `xdescribe`.+xcontext :: HasCallStack => String -> SpecWith a -> SpecWith a+xcontext = xdescribe+ -- | The @it@ function creates a spec item. -- -- A spec item consists of:@@ -54,19 +133,75 @@ -- > describe "absolute" $ do -- >   it "returns a positive number when given a negative number" $ -- >     absolute (-1) == 1-#ifdef HAS_SOURCE_LOCATIONS-it :: (?loc :: CallStack, Example a) => String -> a -> SpecWith (Arg a)-#else-it :: Example a => String -> a -> SpecWith (Arg a)-#endif+--+-- @`Example` a@ optionally accepts an argument @`Arg` a@, which is then given+-- to the test body. This is useful for provisioning resources for a test which+-- are created and cleaned up outside the test itself. See `Arg` for details.+--+-- Note that this function is often on the scene of nasty type errors due to GHC failing+-- to infer the type of @do@ notation in the test body.+-- It can be helpful to use+-- [TypeApplications](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/type_applications.html)+-- to explicitly specify the intended `Example` type.+it :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a) it label action = fromSpecList [specItem label action] +-- | @specify@ is an alias for `it`.+specify :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)+specify = it++-- |+-- Changing `it` to `xit` marks the corresponding spec item as pending.+--+-- This can be used to temporarily disable a spec item.+xit :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)+xit label action = before_ pending_ $ it label action++-- | @xspecify@ is an alias for `xit`.+xspecify :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)+xspecify = xit++-- | `focus` focuses all spec items of the given spec.+--+-- Applying `focus` to a spec with focused spec items has no effect.+focus :: SpecWith a -> SpecWith a+focus = mapSpecForest focusForest++-- | Marks an entire spec forest as focused if nothing in it is already focused.+focusForest :: [SpecTree a] -> [SpecTree a]+focusForest xs+  | any (any itemIsFocused) xs = xs+  | otherwise = bimapForest id (\ item -> item {itemIsFocused = True}) xs++-- | @fit@ is an alias for @fmap focus . it@+fit :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)+fit = fmap focus . it++-- | @fspecify@ is an alias for `fit`.+fspecify :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)+fspecify = fit++-- | @fdescribe@ is an alias for @fmap focus . describe@+fdescribe :: HasCallStack => String -> SpecWith a -> SpecWith a+fdescribe = fmap focus . describe++-- | @fcontext@ is an alias for `fdescribe`.+fcontext :: HasCallStack => String -> SpecWith a -> SpecWith a+fcontext = fdescribe+ -- | `parallel` marks all spec items of the given spec to be safe for parallel -- evaluation. parallel :: SpecWith a -> SpecWith a-parallel = mapSpecItem_ $ \item -> item {itemIsParallelizable = True}+parallel = mapSpecItem_ (setParallelizable True) --- | `pending` can be used to indicate that an example is /pending/.+-- | `sequential` marks all spec items of the given spec to be evaluated sequentially.+sequential :: SpecWith a -> SpecWith a+sequential = mapSpecItem_ (setParallelizable False)++setParallelizable :: Bool -> Item a -> Item a+setParallelizable value item = item {itemIsParallelizable = itemIsParallelizable item <|> Just value}++-- | `pending` can be used to mark a spec item as pending. -- -- If you want to textually specify a behavior but do not have an example yet, -- use this:@@ -74,11 +209,30 @@ -- > describe "fancyFormatter" $ do -- >   it "can format text in a way that everyone likes" $ -- >     pending-pending :: Expectation-pending = E.throwIO (Pending Nothing)+pending :: HasCallStack => Expectation+pending = throwIO (Pending location Nothing) +pending_ :: Expectation+pending_ = (throwIO (Pending Nothing Nothing))+ -- | -- `pendingWith` is similar to `pending`, but it takes an additional string--- argument that can be used to specify the reason for why it's pending.-pendingWith :: String -> Expectation-pendingWith = E.throwIO . Pending . Just+-- argument that can be used to specify the reason for why the spec item is pending.+pendingWith :: HasCallStack => String -> Expectation+pendingWith = throwIO . Pending location . Just++-- | Get the path of `describe` labels, from the root all the way in to the+-- call-site of this function.+--+-- ==== __Example__+-- >>> :{+-- runSpecM $ do+--   describe "foo" $ do+--     describe "bar" $ do+--       getSpecDescriptionPath >>= runIO . print+-- :}+-- ["foo","bar"]+--+-- @since 2.10.0+getSpecDescriptionPath :: SpecM a [String]+getSpecDescriptionPath = SpecM $ lift $ reverse <$> asks envSpecDescriptionPath
src/Test/Hspec/Core/Spec/Monad.hs view
@@ -1,47 +1,88 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Test.Hspec.Core.Spec.Monad (+-- RE-EXPORTED from Test.Hspec.Core.Spec   Spec , SpecWith-, SpecM (..)+, SpecM (SpecM) , runSpecM , fromSpecList , runIO -, mapSpecTree+, mapSpecForest , mapSpecItem , mapSpecItem_ , modifyParams++, modifyConfig+-- END RE-EXPORTED from Test.Hspec.Core.Spec++, Env(..)+, withEnv ) where  import           Prelude ()-import           Test.Hspec.Compat+import           Test.Hspec.Core.Compat -import           Control.Monad.Trans.Writer import           Control.Monad.IO.Class (liftIO)+import           Control.Monad.Trans.Reader+import           Control.Monad.Trans.Writer  import           Test.Hspec.Core.Example import           Test.Hspec.Core.Tree +import           Test.Hspec.Core.Config.Definition (Config)++-- | A `SpecWith` that can be evaluated directly by the+-- `Test.Hspec.Core.Runner.hspec` function as it does not require any+-- parameters. type Spec = SpecWith () +-- | A @'SpecWith' a@ represents a test or group of tests that require an @a@+-- value to run.+--+-- In the common case, a 'Spec' is a @'SpecWith' ()@ which requires @()@ and+-- can thus be executed with `Test.Hspec.Core.Runner.hspec'.+--+-- To supply an argument to `SpecWith` tests to turn them into `Spec`, use+-- functions from "Test.Hspec.Core.Hooks" such as+-- `Test.Hspec.Core.Hooks.around`, `Test.Hspec.Core.Hooks.before',+-- `Test.Hspec.Core.Hooks.mapSubject' and similar.+--+-- Values of this type are created by `Test.Hspec.Core.Spec.it`,+-- `Test.Hspec.Core.Spec.describe` and similar. type SpecWith a = SpecM a () --- | A writer monad for `SpecTree` forests-newtype SpecM a r = SpecM (WriterT [SpecTree a] IO r)+-- |+-- @since 2.10.0+modifyConfig :: (Config -> Config) -> SpecWith a+modifyConfig f = SpecM $ tell (Endo f, mempty)++-- | A writer monad for `SpecTree` forests.+--+-- This is used by `Test.Hspec.Core.Spec.describe` and is used+-- to construct the forest of spec items.+--+-- It allows for dynamically generated spec trees, for example, by using data+-- obtained by performing IO actions with 'runIO'.+newtype SpecM a r = SpecM { unSpecM :: WriterT (Endo Config, [SpecTree a]) (ReaderT Env IO) r }   deriving (Functor, Applicative, Monad)  -- | Convert a `Spec` to a forest of `SpecTree`s.-runSpecM :: SpecWith a -> IO [SpecTree a]-runSpecM (SpecM specs) = execWriterT specs+runSpecM :: SpecWith a -> IO (Endo Config, [SpecTree a])+runSpecM = flip runReaderT (Env []) . execWriterT . unSpecM  -- | Create a `Spec` from a forest of `SpecTree`s.+fromSpecForest :: (Endo Config, [SpecTree a]) -> SpecWith a+fromSpecForest = SpecM . tell++-- | Create a `Spec` from a forest of `SpecTree`s. fromSpecList :: [SpecTree a] -> SpecWith a-fromSpecList = SpecM . tell+fromSpecList = fromSpecForest . (,) mempty  -- | Run an IO action while constructing the spec tree. -- -- `SpecM` is a monad to construct a spec tree, without executing any spec--- items.  @runIO@ allows you to run IO actions during this construction phase.+-- items itself.  @runIO@ allows you to run IO actions during this construction phase. -- The IO action is always run when the spec tree is constructed (e.g. even -- when @--dry-run@ is specified). -- If you do not need the result of the IO action to construct the spec tree,@@ -49,19 +90,30 @@ runIO :: IO r -> SpecM a r runIO = SpecM . liftIO -mapSpecTree :: (SpecTree a -> SpecTree b) -> SpecWith a -> SpecWith b-mapSpecTree f spec = runIO (runSpecM spec) >>= fromSpecList . map f+mapSpecForest :: ([SpecTree a] -> [SpecTree b]) -> SpecM a r -> SpecM b r+mapSpecForest f (SpecM specs) = SpecM (mapWriterT (fmap (fmap (second f))) specs) +-- {-# DEPRECATED mapSpecItem "Use `mapSpecItem_` instead." #-}+-- | Deprecated: Use `mapSpecItem_` instead. mapSpecItem :: (ActionWith a -> ActionWith b) -> (Item a -> Item b) -> SpecWith a -> SpecWith b-mapSpecItem g f = mapSpecTree go-  where-    go spec = case spec of-      Node d xs -> Node d (map go xs)-      NodeWithCleanup cleanup xs -> NodeWithCleanup (g cleanup) (map go xs)-      Leaf item -> Leaf (f item)+mapSpecItem _ = mapSpecItem_ -mapSpecItem_ :: (Item a -> Item a) -> SpecWith a -> SpecWith a-mapSpecItem_ = mapSpecItem id+mapSpecItem_ :: (Item a -> Item b) -> SpecWith a -> SpecWith b+mapSpecItem_ = mapSpecForest . bimapForest id +-- | Modifies the `Params` on the spec items to be generated by `SpecWith`. modifyParams :: (Params -> Params) -> SpecWith a -> SpecWith a modifyParams f = mapSpecItem_ $ \item -> item {itemExample = \p -> (itemExample item) (f p)}++newtype Env = Env {+  -- | The path of _parent_ `Hspec.Core.Spec.describe` labels from innermost to+  -- outermost.+  envSpecDescriptionPath :: [String]+}++-- | Applies a function to modify the `Env` of items being written by a child+-- spec writer.+--+-- This is used to implement `Hspec.Core.Spec.describe`.+withEnv :: (Env -> Env) -> SpecM a r -> SpecM a r+withEnv f = SpecM . WriterT . local f . runWriterT . unSpecM
+ src/Test/Hspec/Core/Timer.hs view
@@ -0,0 +1,20 @@+module Test.Hspec.Core.Timer (withTimer) where++import           Prelude ()+import           Test.Hspec.Core.Compat++import           Control.Concurrent.Async++import           Test.Hspec.Core.Clock++withTimer :: Seconds -> (IO Bool -> IO a) -> IO a+withTimer delay action = do+  ref <- newIORef False+  bracket (async $ worker delay ref) cancel $ \_ -> do+    action $ atomicModifyIORef ref (\a -> (False, a))++worker :: Seconds -> IORef Bool -> IO ()+worker delay ref = do+  forever $ do+    sleep delay+    atomicWriteIORef ref True
src/Test/Hspec/Core/Tree.hs view
@@ -1,62 +1,99 @@ {-# LANGUAGE DeriveFunctor #-}--{-# LANGUAGE CPP #-}-#if MIN_VERSION_base(4,8,1)-#define HAS_SOURCE_LOCATIONS-{-# LANGUAGE ImplicitParams #-}-#endif+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-} --- |--- Stability: unstable module Test.Hspec.Core.Tree (+-- RE-EXPORTED from Test.Hspec.Core.Spec   SpecTree , Tree (..) , Item (..) , specGroup , specItem-) where+, bimapTree+, bimapForest+, filterTree+, filterForest+, filterTreeWithLabels+, filterForestWithLabels+, pruneTree -- unused+, pruneForest -- unused+, location+-- END RE-EXPORTED from Test.Hspec.Core.Spec+, callSite+, formatDefaultDescription+, toModuleName -#ifdef HAS_SOURCE_LOCATIONS-#if !MIN_VERSION_base(4,9,0)-import           GHC.SrcLoc-#endif-import           GHC.Stack-#endif+, setItemAnnotation+, getItemAnnotation+) where  import           Prelude ()-import           Test.Hspec.Compat+import           Test.Hspec.Core.Compat +import           Data.Char+import           System.FilePath+import qualified Data.CallStack as CallStack+ import           Test.Hspec.Core.Example+import           Test.Hspec.Core.Annotations (Annotations)+import qualified Test.Hspec.Core.Annotations as Annotations  -- | Internal tree data structure data Tree c a =     Node String [Tree c a]-  | NodeWithCleanup c [Tree c a]+  | NodeWithCleanup (Maybe (String, Location)) c [Tree c a]   | Leaf a-  deriving Functor+  deriving (Eq, Show, Functor, Foldable, Traversable) -instance Foldable (Tree c) where -- Note: GHC 7.0.1 fails to derive this instance-  foldMap = go-    where-      go :: Monoid m => (a -> m) -> Tree c a -> m-      go f t = case t of-        Node _ xs -> foldMap (foldMap f) xs-        NodeWithCleanup _ xs -> foldMap (foldMap f) xs-        Leaf x -> f x+-- | A tree is used to represent a spec internally.  The tree is parameterized+-- over the type of cleanup actions and the type of the actual spec items.+type SpecTree a = Tree (IO ()) (Item a) -instance Traversable (Tree c) where -- Note: GHC 7.0.1 fails to derive this instance-  sequenceA = go-    where-      go :: Applicative f => Tree c (f a) -> f (Tree c a)-      go t = case t of-        Node label xs -> Node label <$> sequenceA (map go xs)-        NodeWithCleanup action xs -> NodeWithCleanup action <$> sequenceA (map go xs)-        Leaf a -> Leaf <$> a+bimapForest :: (a -> b) -> (c -> d) -> [Tree a c] -> [Tree b d]+bimapForest g f = map (bimapTree g f) --- | A tree is used to represent a spec internally.  The tree is parametrize--- over the type of cleanup actions and the type of the actual spec items.-type SpecTree a = Tree (ActionWith a) (Item a)+bimapTree :: (a -> b) -> (c -> d) -> Tree a c -> Tree b d+bimapTree g f = go+  where+    go spec = case spec of+      Node d xs -> Node d (map go xs)+      NodeWithCleanup loc action xs -> NodeWithCleanup loc (g action) (map go xs)+      Leaf item -> Leaf (f item) +filterTree :: (a -> Bool) -> Tree c a -> Maybe (Tree c a)+filterTree = filterTreeWithLabels . const++filterForest :: (a -> Bool) -> [Tree c a] -> [Tree c a]+filterForest = filterForestWithLabels . const++filterTreeWithLabels :: ([String] -> a -> Bool) -> Tree c a -> Maybe (Tree c a)+filterTreeWithLabels = filterTree_ []++filterForestWithLabels :: ([String] -> a -> Bool) -> [Tree c a] -> [Tree c a]+filterForestWithLabels = filterForest_ []++filterForest_ :: [String] -> ([String] -> a -> Bool) -> [Tree c a] -> [Tree c a]+filterForest_ groups = mapMaybe . filterTree_ groups++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 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]+pruneForest = mapMaybe pruneTree++pruneTree :: Tree c a -> Maybe (Tree c a)+pruneTree node = case node of+  Node group xs -> Node group <$> prune xs+  NodeWithCleanup loc action xs -> NodeWithCleanup loc action <$> prune xs+  Leaf{} -> Just node+  where+    prune = guarded (not . null) . pruneForest+ -- | -- @Item@ is used to represent spec items internally.  A spec item consists of: --@@ -68,42 +105,71 @@ -- example, including QuickCheck properties, Hspec expectations and HUnit -- assertions. data Item a = Item {+   -- | Textual description of behavior   itemRequirement :: String+   -- | Source location of the spec item , itemLocation :: Maybe Location+   -- | A flag that indicates whether it is safe to evaluate this spec item in   -- parallel with other spec items-, itemIsParallelizable :: Bool+, itemIsParallelizable :: Maybe Bool++  -- | A flag that indicates whether this spec item is focused+, itemIsFocused :: Bool++  -- | Arbitrary additional data that can be used by third-party extensions.+  --+  -- @since 2.12.0+, itemAnnotations :: Annotations+   -- | Example for behavior , itemExample :: Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result } +setItemAnnotation :: Typeable value => value -> Item a -> Item a+setItemAnnotation value config = config { itemAnnotations = Annotations.setValue value $ itemAnnotations config }++getItemAnnotation :: Typeable value => Item a -> Maybe value+getItemAnnotation = Annotations.getValue . itemAnnotations+ -- | The @specGroup@ function combines a list of specs into a larger spec.-specGroup :: String -> [SpecTree a] -> SpecTree a+specGroup :: HasCallStack => String -> [SpecTree a] -> SpecTree a specGroup s = Node msg   where+    msg :: HasCallStack => String     msg-      | null s = "(no description given)"+      | null s = maybe "(no description given)" formatDefaultDescription location       | otherwise = s  -- | The @specItem@ function creates a spec item.-#ifdef HAS_SOURCE_LOCATIONS-specItem :: (?loc :: CallStack, Example a) => String -> a -> SpecTree (Arg a)-#else-specItem :: Example a => String -> a -> SpecTree (Arg a)-#endif-specItem s e = Leaf $ Item requirement location False (evaluateExample e)-  where-    requirement-      | null s = "(unspecified behavior)"-      | otherwise = s+specItem :: (HasCallStack, Example e) => String -> e -> SpecTree (Arg e)+specItem s e = Leaf Item {+    itemRequirement = s+  , itemLocation = location+  , itemIsParallelizable = Nothing+  , itemIsFocused = False+  , itemAnnotations = mempty+  , itemExample = safeEvaluateExample e+  } -    location :: Maybe Location-#ifdef HAS_SOURCE_LOCATIONS-    location = case reverse (getCallStack ?loc) of-      (_, loc) : _ -> Just (Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc) ExactLocation)-      _ -> Nothing-#else-    location = Nothing-#endif+location :: HasCallStack => Maybe Location+location = snd <$> callSite++callSite :: HasCallStack => Maybe (String, Location)+callSite = fmap toLocation <$> CallStack.callSite++formatDefaultDescription :: Location -> String+formatDefaultDescription loc = toModuleName (locationFile loc) ++ "[" ++ show (locationLine loc) ++ ":" ++ show (locationColumn loc) ++ "]"++toModuleName :: FilePath -> String+toModuleName = intercalate "." . reverse . takeWhile isModuleNameComponent . reverse . splitDirectories . dropExtension++isModuleNameComponent :: String -> Bool+isModuleNameComponent name = case name of+  x : xs -> isUpper x && all isIdChar xs+  _ -> False++isIdChar :: Char -> Bool+isIdChar c = isAlphaNum c || c == '_' || c == '\''
src/Test/Hspec/Core/Util.hs view
@@ -1,27 +1,37 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-} -- | Stability: unstable module Test.Hspec.Core.Util ( -- * String functions   pluralize , strip , lineBreaksAt+, stripAnsi  -- * Working with paths , Path+, joinPath , formatRequirement , filterPredicate --- * Working with exception+-- * Working with exceptions , safeTry , formatException+, formatExceptionWith ) where -import           Data.List+import           Prelude ()+import           Test.Hspec.Core.Compat hiding (join)+ import           Data.Char (isSpace)++#ifndef __MHS__ import           GHC.IO.Exception-import           Control.Exception-import           Control.Concurrent.Async+#else+import           System.IO.Error+#endif -import           Test.Hspec.Compat (showType)+import           Control.Concurrent.Async  -- | -- @pluralize count singular@ pluralizes the given @singular@ word unless given@@ -37,22 +47,30 @@ -- -- >>> pluralize 2 "example" -- "2 examples"+--+-- @since 2.0.0 pluralize :: Int -> String -> String pluralize 1 s = "1 " ++ s pluralize n s = show n ++ " " ++ s ++ "s"  -- | Strip leading and trailing whitespace+--+-- @since 2.0.0 strip :: String -> String strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse  -- |--- ensure that lines are not longer then given `n`, insert line breaks at word+-- Ensure that lines are not longer than given `n`, insert line breaks at word -- boundaries+--+-- @since 2.0.0 lineBreaksAt :: Int -> String -> [String]-lineBreaksAt n input = case words input of-  []   -> []-  x:xs -> go (x, xs)+lineBreaksAt n = concatMap f . lines   where+    f input = case words input of+      []   -> []+      x:xs -> go (x, xs)+     go :: (String, [String]) -> [String]     go c = case c of       (s, [])   -> [s]@@ -62,14 +80,45 @@           else s : go (y, ys)  -- |--- A `Path` represents the location of an example within the spec tree.+-- Remove ANSI color escape sequences. --+-- @since 2.11.0+stripAnsi :: String -> String+stripAnsi = go+  where+    go :: String -> String+    go input = case input of+      '\ESC' : '[' : (parameters -> 'm' : xs) -> go xs+      x : xs -> x : go xs+      [] -> []++    parameters :: String -> String+    parameters = dropWhile p+      where+        p :: Char -> Bool+        p c = c >= '0' && c <= '9' || c == ';'++-- |+-- A `Path` describes the location of a spec item within a spec tree.+-- -- It consists of a list of group descriptions and a requirement description.+--+-- @since 2.0.0 type Path = ([String], String)  -- |+-- Join a `Path` with slashes.  The result will have a leading and a trailing+-- slash.+--+-- @since 2.5.4+joinPath :: Path -> String+joinPath (groups, requirement) = "/" ++ intercalate "/" (groups ++ [requirement]) ++ "/"++-- | -- Try to create a proper English sentence from a path by applying some -- heuristics.+--+-- @since 2.0.0 formatRequirement :: Path -> String formatRequirement (groups, requirement) = groups_ ++ requirement   where@@ -82,12 +131,14 @@       ys  -> concatMap (++ ", ") ys  -- | A predicate that can be used to filter a spec tree.+--+-- @since 2.0.0 filterPredicate :: String -> Path -> Bool-filterPredicate pattern path@(groups, requirement) =-     pattern `isInfixOf` plain-  || pattern `isInfixOf` formatted+filterPredicate pattern_ path =+     pattern_ `isInfixOf` plain+  || pattern_ `isInfixOf` formatted   where-    plain = intercalate "/" (groups ++ [requirement])+    plain = joinPath path     formatted = formatRequirement path  -- | The function `formatException` converts an exception to a string.@@ -95,13 +146,19 @@ -- This is different from `show`.  The type of the exception is included, e.g.: -- -- >>> formatException (toException DivideByZero)--- "ArithException (divide by zero)"+-- "ArithException\ndivide by zero" -- -- For `IOException`s the `IOErrorType` is included, as well.+--+-- @since 2.0.0 formatException :: SomeException -> String-formatException err@(SomeException e) = case fromException err of-  Just ioe -> showType ioe ++ " of type " ++ showIOErrorType ioe ++ " (" ++ show ioe ++ ")"-  Nothing  -> showType e ++ " (" ++ show e ++ ")"+formatException = formatExceptionWith show++-- | @since 2.11.5+formatExceptionWith :: (SomeException -> String) -> SomeException -> String+formatExceptionWith showException err = case fromException err of+  Nothing  -> showExceptionType err ++ "\n" ++ showException err+  Just ioe -> showType ioe ++ " of type " ++ showIOErrorType ioe ++ "\n" ++ showException (toException ioe)   where     showIOErrorType :: IOException -> String     showIOErrorType ioe = case ioe_type ioe of@@ -125,8 +182,13 @@       ResourceVanished -> "ResourceVanished"       Interrupted -> "Interrupted" +showExceptionType :: SomeException -> String+showExceptionType (SomeException e) = showType e+ -- | @safeTry@ evaluates given action and returns its result.  If an exception -- occurs, the exception is returned instead.  Unlike `try` it is agnostic to -- asynchronous exceptions.+--+-- @since 2.0.0 safeTry :: IO a -> IO (Either SomeException a) safeTry action = withAsync (action >>= evaluate) waitCatch
− src/Test/Hspec/FailureReport.hs 
@@ -1,49 +0,0 @@-{-# LANGUAGE CPP #-}-module Test.Hspec.FailureReport (-  FailureReport (..)-, writeFailureReport-, readFailureReport-) where--#ifndef __GHCJS__-import           System.SetEnv-import           Test.Hspec.Core.Util (safeTry)-#endif-import           System.IO-import           Test.Hspec.Compat-import           Test.Hspec.Core.Util (Path)--data FailureReport = FailureReport {-  failureReportSeed :: Integer-, failureReportMaxSuccess :: Int-, failureReportMaxSize :: Int-, failureReportMaxDiscardRatio :: Int-, failureReportPaths :: [Path]-} deriving (Eq, Show, Read)--writeFailureReport :: FailureReport -> IO ()-#ifdef __GHCJS__-writeFailureReport _ = return ()-  -- ghcjs currently does not support setting environment variables-  -- (https://github.com/ghcjs/ghcjs/issues/263). Since writing a failure report-  -- into the environment is a non-essential feature we just disable this to be-  -- able to run hspec test-suites with ghcjs at all. Should be reverted once-  -- the issue is fixed.-#else-writeFailureReport x = do-  -- on Windows this can throw an exception when the input is too large, hence-  -- we use `safeTry` here-  safeTry (setEnv "HSPEC_FAILURES" $ show x) >>= either onError return-  where-    onError err = do-      hPutStrLn stderr ("WARNING: Could not write environment variable HSPEC_FAILURES (" ++ show err ++ ")")-#endif--readFailureReport :: IO (Maybe FailureReport)-readFailureReport = do-  mx <- lookupEnv "HSPEC_FAILURES"-  case mx >>= readMaybe of-    Nothing -> do-      hPutStrLn stderr "WARNING: Could not read environment variable HSPEC_FAILURES; `--rerun' is ignored!"-      return Nothing-    x -> return x
− src/Test/Hspec/Options.hs 
@@ -1,198 +0,0 @@-module Test.Hspec.Options (-  Config(..)-, ColorMode (..)-, defaultConfig-, filterOr-, parseOptions-) where--import           Prelude ()-import           Control.Monad-import           Test.Hspec.Compat--import           System.IO-import           System.Exit-import           System.Console.GetOpt--import           Test.Hspec.Core.Formatters-import           Test.Hspec.Core.Util-import           Test.Hspec.Core.Example (Params(..), defaultParams)--data Config = Config {-  configDryRun :: Bool-, configPrintCpuTime :: Bool-, configFastFail :: Bool---- |--- A predicate that is used to filter the spec before it is run.  Only examples--- that satisfy the predicate are run.-, configRerun :: Bool-, configFilterPredicate :: Maybe (Path -> Bool)-, configSkipPredicate :: Maybe (Path -> Bool)-, configQuickCheckSeed :: Maybe Integer-, configQuickCheckMaxSuccess :: Maybe Int-, configQuickCheckMaxDiscardRatio :: Maybe Int-, configQuickCheckMaxSize :: Maybe Int-, configSmallCheckDepth :: Int-, configColorMode :: ColorMode-, configFormatter :: Maybe Formatter-, configHtmlOutput :: Bool-, configOutputFile :: Either Handle FilePath-, configConcurrentJobs :: Maybe Int-}--defaultConfig :: Config-defaultConfig = Config {-  configDryRun = False-, configPrintCpuTime = False-, configFastFail = False-, configRerun = False-, configFilterPredicate = Nothing-, configSkipPredicate = Nothing-, configQuickCheckSeed = Nothing-, configQuickCheckMaxSuccess = Nothing-, configQuickCheckMaxDiscardRatio = Nothing-, configQuickCheckMaxSize = Nothing-, configSmallCheckDepth = paramsSmallCheckDepth defaultParams-, configColorMode = ColorAuto-, configFormatter = Nothing-, configHtmlOutput = False-, configOutputFile = Left stdout-, configConcurrentJobs = Nothing-}--filterOr :: Maybe (Path -> Bool) -> Maybe (Path -> Bool) -> Maybe (Path -> Bool)-filterOr p1_ p2_ = case (p1_, p2_) of-  (Just p1, Just p2) -> Just $ \path -> p1 path || p2 path-  _ -> p1_ <|> p2_--addMatch :: String -> Config -> Config-addMatch s c = c {configFilterPredicate = Just (filterPredicate s) `filterOr` configFilterPredicate c}--addSkip :: String -> Config -> Config-addSkip s c = c {configSkipPredicate = Just (filterPredicate s) `filterOr` configSkipPredicate c}--setDepth :: Int -> Config -> Config-setDepth n c = c {configSmallCheckDepth = n}--setMaxSuccess :: Int -> Config -> Config-setMaxSuccess n c = c {configQuickCheckMaxSuccess = Just n}--setMaxSize :: Int -> Config -> Config-setMaxSize n c = c {configQuickCheckMaxSize = Just n}--setMaxDiscardRatio :: Int -> Config -> Config-setMaxDiscardRatio n c = c {configQuickCheckMaxDiscardRatio = Just n}--setSeed :: Integer -> Config -> Config-setSeed n c = c {configQuickCheckSeed = Just n}--data ColorMode = ColorAuto | ColorNever | ColorAlways-  deriving (Eq, Show)--formatters :: [(String, Formatter)]-formatters = [-    ("specdoc", specdoc)-  , ("progress", progress)-  , ("failed-examples", failed_examples)-  , ("silent", silent)-  ]--formatHelp :: String-formatHelp = unlines (addLineBreaks "use a custom formatter; this can be one of:" ++ map (("   " ++) . fst) formatters)--type Result = Either NoConfig Config--data NoConfig = Help | InvalidArgument String String--data Arg a = Arg {-  _argumentName   :: String-, _argumentParser :: String -> Maybe a-, _argumentSetter :: a -> Config -> Config-}--mkOption :: [Char] -> String -> Arg a -> String -> OptDescr (Result -> Result)-mkOption shortcut name (Arg argName parser setter) help = Option shortcut [name] (ReqArg arg argName) help-  where-    arg :: String -> Result -> Result-    arg input x = x >>= \c -> case parser input of-      Just n -> Right (setter n c)-      Nothing -> Left (InvalidArgument name input)--addLineBreaks :: String -> [String]-addLineBreaks = lineBreaksAt 44--options :: [OptDescr (Result -> Result)]-options = [-    Option   []  ["help"]             (NoArg (const $ Left Help))         (h "display this help and exit")-  , mkOption "m"  "match"             (Arg "PATTERN" return addMatch)     (h "only run examples that match given PATTERN")-  , mkOption []   "skip"              (Arg "PATTERN" return addSkip)      (h "skip examples that match given PATTERN")-  , Option   []  ["color"]            (NoArg setColor)                    (h "colorize the output")-  , Option   []  ["no-color"]         (NoArg setNoColor)                  (h "do not colorize the output")-  , mkOption "f"  "format"            (Arg "FORMATTER" readFormatter setFormatter) formatHelp-  , mkOption "o"  "out"               (Arg "FILE" return setOutputFile)   (h "write output to a file instead of STDOUT")-  , mkOption []   "depth"             (Arg "N" readMaybe setDepth)        (h "maximum depth of generated test values for SmallCheck properties")-  , mkOption "a"  "qc-max-success"    (Arg "N" readMaybe setMaxSuccess)   (h "maximum number of successful tests before a QuickCheck property succeeds")-  , mkOption ""   "qc-max-size"       (Arg "N" readMaybe setMaxSize)      (h "size to use for the biggest test cases")-  , mkOption ""   "qc-max-discard"    (Arg "N" readMaybe setMaxDiscardRatio) (h "maximum number of discarded tests per successful test before giving up")-  , mkOption []   "seed"              (Arg "N" readMaybe setSeed)         (h "used seed for QuickCheck properties")-  , Option   []  ["print-cpu-time"]   (NoArg setPrintCpuTime)             (h "include used CPU time in summary")-  , Option   []  ["dry-run"]          (NoArg setDryRun)                   (h "pretend that everything passed; don't verify anything")-  , Option   []  ["fail-fast"]        (NoArg setFastFail)                 (h "abort on first failure")-  , Option   "r" ["rerun"]            (NoArg  setRerun)                   (h "rerun all examples that failed in the previously test run (only works in GHCi)")-  , mkOption "j"  "jobs"              (Arg "N" readMaxJobs setMaxJobs)    (h "run at most N parallelizable tests simultaneously (default: number of available processors)")-  ]-  where-    h = unlines . addLineBreaks--    readFormatter :: String -> Maybe Formatter-    readFormatter = (`lookup` formatters)--    readMaxJobs :: String -> Maybe Int-    readMaxJobs s = do-      n <- readMaybe s-      guard $ n > 0-      return n--    setFormatter :: Formatter -> Config -> Config-    setFormatter f c = c {configFormatter = Just f}--    setOutputFile :: String -> Config -> Config-    setOutputFile file c = c {configOutputFile = Right file}--    setMaxJobs :: Int -> Config -> Config-    setMaxJobs n c = c {configConcurrentJobs = Just n}--    setPrintCpuTime x = x >>= \c -> return c {configPrintCpuTime = True}-    setDryRun       x = x >>= \c -> return c {configDryRun = True}-    setFastFail     x = x >>= \c -> return c {configFastFail = True}-    setRerun        x = x >>= \c -> return c {configRerun = True}-    setNoColor      x = x >>= \c -> return c {configColorMode = ColorNever}-    setColor        x = x >>= \c -> return c {configColorMode = ColorAlways}--undocumentedOptions :: [OptDescr (Result -> Result)]-undocumentedOptions = [-    -- for compatibility with test-framework-    mkOption [] "maximum-generated-tests" (Arg "NUMBER" readMaybe setMaxSuccess) "how many automated tests something like QuickCheck should try, by default"--    -- undocumented for now, as we probably want to change this to produce a-    -- standalone HTML report in the future-  , Option []  ["html"]                    (NoArg setHtml)                    "produce HTML output"--    -- now a noop-  , Option "v" ["verbose"]                 (NoArg id)                         "do not suppress output to stdout when evaluating examples"-  ]-  where-    setHtml :: Result -> Result-    setHtml x = x >>= \c -> return c {configHtmlOutput = True}--parseOptions :: Config -> String -> [String] -> Either (ExitCode, String) Config-parseOptions c prog args = case getOpt Permute (options ++ undocumentedOptions) args of-    (opts, [], []) -> case foldl' (flip id) (Right c) opts of-        Left Help                         -> Left (ExitSuccess, usageInfo ("Usage: " ++ prog ++ " [OPTION]...\n\nOPTIONS") options)-        Left (InvalidArgument flag value) -> tryHelp ("invalid argument `" ++ value ++ "' for `--" ++ flag ++ "'\n")-        Right x -> Right x-    (_, _, err:_)  -> tryHelp err-    (_, arg:_, _)  -> tryHelp ("unexpected argument `" ++ arg ++ "'\n")-  where-    tryHelp msg = Left (ExitFailure 1, prog ++ ": " ++ msg ++ "Try `" ++ prog ++ " --help' for more information.\n")
− src/Test/Hspec/Timer.hs 
@@ -1,14 +0,0 @@-module Test.Hspec.Timer where--import           Data.IORef-import           Data.Time.Clock.POSIX--newTimer :: POSIXTime -> IO (IO Bool)-newTimer delay = do-  ref <- getPOSIXTime >>= newIORef-  return $ do-    t0 <- readIORef ref-    t1 <- getPOSIXTime-    if delay < t1 - t0-      then writeIORef ref t1 >> return True-      else return False
+ test/GetOpt/Declarative/EnvironmentSpec.hs view
@@ -0,0 +1,71 @@+{-# OPTIONS_GHC -fno-warn-missing-fields #-}+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}+module GetOpt.Declarative.EnvironmentSpec (spec) where++import           Prelude ()+import           Helper++import           GetOpt.Declarative.Types+import           GetOpt.Declarative.Environment++spec :: Spec+spec = do+  describe "parseEnvironmentOption" $ do+    context "with NoArg" $ do+      let+        option :: Option Bool+        option = Option {+          optionName = "some-flag"+        , optionSetter = NoArg $ const True+        }+      it "accepts 'yes'" $ do+        parseEnvironmentOption "FOO" [("FOO_SOME_FLAG", "yes")] False option `shouldBe` Right True++      it "rejects other values" $ do+        parseEnvironmentOption "FOO" [("FOO_SOME_FLAG", "no")] False option `shouldBe` invalidValue "FOO_SOME_FLAG" "no"++    context "with Flag" $ do+      let+        option :: Option Bool+        option = Option {+          optionName = "some-flag"+        , optionSetter = Flag $ \ value _ -> value+        }+      it "accepts 'yes'" $ do+        parseEnvironmentOption "FOO" [("FOO_SOME_FLAG", "yes")] False option `shouldBe` Right True++      it "accepts 'no'" $ do+        parseEnvironmentOption "FOO" [("FOO_SOME_FLAG", "no")] True option `shouldBe` Right False++      it "rejects other values" $ do+        parseEnvironmentOption "FOO" [("FOO_SOME_FLAG", "nay")] True option `shouldBe` invalidValue "FOO_SOME_FLAG" "nay"++    context "with OptArg" $ do+      let+        option :: Option String+        option = Option {+          optionName = "some-flag"+        , optionSetter = OptArg undefined $ \ (Just arg) _ -> guard (arg == "yes") >> Just arg+        }++      it "accepts valid values" $ do+        parseEnvironmentOption "FOO" [("FOO_SOME_FLAG", "yes")] "" option `shouldBe` Right "yes"++      it "rejects invalid values" $ do+        parseEnvironmentOption "FOO" [("FOO_SOME_FLAG", "no")] "" option `shouldBe` invalidValue "FOO_SOME_FLAG" "no"++    context "with Arg" $ do+      let+        option :: Option String+        option = Option {+          optionName = "some-flag"+        , optionSetter = Arg undefined $ \ arg _ -> guard (arg == "yes") >> Just arg+        }++      it "accepts valid values" $ do+        parseEnvironmentOption "FOO" [("FOO_SOME_FLAG", "yes")] "" option `shouldBe` Right "yes"++      it "rejects invalid values" $ do+        parseEnvironmentOption "FOO" [("FOO_SOME_FLAG", "no")] "" option `shouldBe` invalidValue "FOO_SOME_FLAG" "no"+  where+    invalidValue name = Left . InvalidValue name
+ test/GetOpt/Declarative/UtilSpec.hs view
@@ -0,0 +1,31 @@+module GetOpt.Declarative.UtilSpec (spec) where++import           Prelude ()+import           Helper++import           System.Console.GetOpt++import           GetOpt.Declarative.Util++spec :: Spec+spec = do+  describe "mkUsageInfo" $ do+    it "restricts output size to 80 characters" $ do+      let options = [+              Option "" ["color"] (NoArg ()) (unwords $ replicate 3 "some very long and verbose help text")+            ]+      mkUsageInfo "" options `shouldBe` unlines [+          ""+        , "    --color  some very long and verbose help text some very long and verbose"+        , "             help text some very long and verbose help text"+        ]++    it "condenses help for --no-options" $ do+      let options = [+              Option "" ["color"] (NoArg ()) "some help"+            , Option "" ["no-color"] (NoArg ()) "some other help"+            ]+      mkUsageInfo "" options `shouldBe` unlines [+          ""+        , "    --[no-]color  some help"+        ]
test/Helper.hs view
@@ -1,53 +1,104 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Helper (   module Test.Hspec.Meta-, module Test.Hspec.Compat+, module Test.Hspec.Core.Compat , module Test.QuickCheck , module System.IO.Silently+, Seconds(..) , sleep , timeout , defaultParams , noOpProgressCallback , captureLines , normalizeSummary+, normalizeTimes  , ignoreExitCode , ignoreUserInterrupt , throwException+, throwException_ +, withEnvironment+, withTempDirectory+, inTempDirectory++, hspecSilent+, hspecResultSilent+, hspecCapture , shouldUseArgs  , removeLocations++, (</>)+, mkLocation+, workaroundForIssue19236++, replace++, red+, green+, colorize ) where  import           Prelude ()-import           Test.Hspec.Compat+import           Test.Hspec.Core.Compat -import           Data.List import           Data.Char-import           Control.Monad-import           System.Environment (withArgs)+import           System.Environment (withArgs, getEnvironment, setEnv, unsetEnv) import           System.Exit-import           Control.Concurrent-import qualified Control.Exception as E-import qualified System.Timeout as System-import           Data.Time.Clock.POSIX import           System.IO.Silently+import           System.FilePath+import           System.Directory+import           System.IO.Temp (withSystemTempDirectory)+import           System.Console.ANSI -import           Test.Hspec.Meta+import           Test.Hspec.Meta hiding (hspec, hspecResult, pending, pendingWith) import           Test.QuickCheck hiding (Result(..))+import qualified Test.HUnit.Lang as HUnit  import qualified Test.Hspec.Core.Spec as H import qualified Test.Hspec.Core.Runner as H-import           Test.Hspec.Core.QuickCheckUtil (mkGen)+import           Test.Hspec.Core.QuickCheck.Util (mkGen)+import           Test.Hspec.Core.Clock+import           Test.Hspec.Core.Example (Result(..), ResultStatus(..), FailureReason(..), Location(..))+import           Test.Hspec.Core.Example.Location (workaroundForIssue19236)+import           Test.Hspec.Core.Util+import qualified Test.Hspec.Core.Format as Format+import           Test.Hspec.Core.Formatters.V2 (formatterToFormat, silent) -throwException :: IO ()-throwException = E.throwIO (E.ErrorCall "foobar")+import           Data.Orphans () +exceptionEq :: SomeException -> SomeException -> Bool+exceptionEq a b+  | Just ea <- fromException a, Just eb <- fromException b = ea == (eb :: ErrorCall)+  | Just ea <- fromException a, Just eb <- fromException b = ea == (eb :: ArithException)+  | otherwise = throw (HUnit.HUnitFailure Nothing $ HUnit.ExpectedButGot Nothing (formatException b) (formatException a))++deriving instance Eq FailureReason+deriving instance Eq ResultStatus+deriving instance Eq Result++deriving instance Eq Format.Result+deriving instance Eq Format.Item++instance Eq SomeException where+  (==) = exceptionEq++throwException :: IO a+throwException = throwIO DivideByZero++throwException_ :: IO ()+throwException_ = throwException+ ignoreExitCode :: IO () -> IO ()-ignoreExitCode action = action `E.catch` \e -> let _ = e :: ExitCode in return ()+ignoreExitCode action = action `catch` \e -> let _ = e :: ExitCode in pass  ignoreUserInterrupt :: IO () -> IO ()-ignoreUserInterrupt action = E.catchJust (guard . (== E.UserInterrupt)) action return+ignoreUserInterrupt action = catchJust (guard . (== UserInterrupt)) action return  captureLines :: IO a -> IO [String] captureLines = fmap lines . capture_@@ -61,26 +112,99 @@     g x | isNumber x = '0'         | otherwise  = x +normalizeTimes :: [String] -> [String]+normalizeTimes = map go+  where+    go xs = case xs of+      [] -> []+      '(' : y : ys | isNumber y, Just zs <- stripPrefix "ms)" $ dropWhile isNumber ys -> "(2ms)" ++ go zs+      y : ys -> y : go ys+ defaultParams :: H.Params defaultParams = H.defaultParams {H.paramsQuickCheckArgs = stdArgs {replay = Just (mkGen 23, 0), maxSuccess = 1000}}  noOpProgressCallback :: H.ProgressCallback-noOpProgressCallback _ = return ()+noOpProgressCallback _ = pass -sleep :: POSIXTime -> IO ()-sleep = threadDelay . floor . (* 1000000)+silentConfig :: H.Config+silentConfig = H.defaultConfig {H.configFormat = Just $ formatterToFormat silent} -timeout :: POSIXTime -> IO a -> IO (Maybe a)-timeout = System.timeout . floor . (* 1000000)+hspecSilent :: H.Spec -> IO ()+hspecSilent = H.hspecWith silentConfig -shouldUseArgs :: [String] -> (Args -> Bool) -> Expectation-shouldUseArgs args p = do-  spy <- newIORef (H.paramsQuickCheckArgs defaultParams)-  let interceptArgs item = item {H.itemExample = \params action progressCallback -> writeIORef spy (H.paramsQuickCheckArgs params) >> H.itemExample item params action progressCallback}-      spec = H.mapSpecItem_ interceptArgs $-        H.it "foo" False-  (silence . ignoreExitCode . withArgs args . H.hspec) spec-  readIORef spy >>= (`shouldSatisfy` p)+hspecResultSilent :: H.Spec -> IO H.Summary+hspecResultSilent = H.hspecWithResult silentConfig +hspecCapture :: [String] -> H.Spec -> IO String+hspecCapture args = fmap (unlines . normalizeSummary) . captureLines . ignoreExitCode . withArgs args . H.hspec . removeLocations++shouldUseArgs :: HasCallStack => (Eq n, Show n) => [String] -> (Args -> n,  n) -> Expectation+shouldUseArgs args (accessor, expected) = do+  spy <- newIORef stdArgs+  let+    interceptArgs :: H.Item a -> H.Item a+    interceptArgs item = item {+      H.itemExample = \ params action progressCallback -> do+        writeIORef spy (H.paramsQuickCheckArgs params)+        H.itemExample item params action progressCallback+    }+    spec :: H.Spec+    spec = H.mapSpecItem_ interceptArgs $ H.it "" True+  withArgs args $ hspecSilent spec+  accessor <$> readIORef spy `shouldReturn` expected+ removeLocations :: H.SpecWith a -> H.SpecWith a-removeLocations = H.mapSpecItem_ (\item -> item{H.itemLocation = Nothing})+removeLocations = H.mapSpecItem_ $ \ item -> item {+  H.itemLocation = Nothing+, H.itemExample = \ params action progressCallback -> removeResultLocation <$> H.itemExample item params action progressCallback+}++removeResultLocation :: Result -> Result+removeResultLocation (Result info status) = case status of+  Success -> Result info status+  Pending _loc reason -> Result info (Pending Nothing reason)+  Failure _loc reason -> Result info (Failure Nothing reason)++withEnvironment :: [(String, String)] -> IO a -> IO a+withEnvironment environment action = bracket saveEnv restoreEnv $ const action+  where+    saveEnv :: IO [(String, String)]+    saveEnv = do+      env <- clearEnv+      forM_ environment $ uncurry setEnv+      return env+    restoreEnv :: [(String, String)] -> IO ()+    restoreEnv env = do+      _ <- clearEnv+      forM_ env $ uncurry setEnv+    clearEnv :: IO [(String, String)]+    clearEnv = do+      env <- getEnvironment+      forM_ env (unsetEnv . fst)+      return env++withTempDirectory :: (FilePath -> IO a) -> IO a+withTempDirectory = withSystemTempDirectory "hspec"++inTempDirectory :: IO a -> IO a+inTempDirectory action = withTempDirectory $ \path -> do+  bracket getCurrentDirectory setCurrentDirectory $ \_ -> do+    setCurrentDirectory path+    action++mkLocation :: FilePath -> Int -> Int -> Maybe Location+mkLocation file line column = Just (Location (workaroundForIssue19236 file) line column)++replace :: Eq a => a -> a -> [a] -> [a]+replace x y xs = case break (== x) xs of+  (ys, _: zs) -> ys ++ y : zs+  _ -> xs++green :: String -> String+green = colorize Foreground Green++red :: String -> String+red = colorize Foreground Red++colorize :: ConsoleLayer -> Color -> String -> String+colorize layer color text = setSGRCode [SetColor layer Dull color] <> text <> setSGRCode [Reset]
test/Mock.hs view
@@ -1,7 +1,7 @@ module Mock where  import           Prelude ()-import           Test.Hspec.Compat+import           Test.Hspec.Core.Compat  newtype Mock = Mock (IORef Int)
test/Spec.hs view
@@ -1,1 +1,1 @@-{-# OPTIONS_GHC -F -pgmF hspec-meta-discover #-}+{-# OPTIONS_GHC -fforce-recomp -F -pgmF hspec-meta-discover #-}
+ test/SpecHook.hs view
@@ -0,0 +1,17 @@+module SpecHook (hook) where++import           Prelude ()+import           Helper++import           System.Environment (getEnvironment)++ignoreHspecConfig :: IO a -> IO a+ignoreHspecConfig action = do+  env <- getEnvironment+  let filteredEnv = ("IGNORE_DOT_HSPEC", "yes") : filter p env+  withEnvironment filteredEnv action+  where+    p (name, _value) = name == "COMSPEC" || name == "PATH"++hook :: Spec -> Spec+hook = aroundAll_ ignoreHspecConfig
− test/Test/Hspec/CompatSpec.hs 
@@ -1,31 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-module Test.Hspec.CompatSpec (main, spec) where--import           Helper-import           System.SetEnv-import           Data.Typeable--data SomeType = SomeType-  deriving Typeable--main :: IO ()-main = hspec spec--spec :: Spec-spec = do-  describe "showType" $ do-    it "shows unqualified name of type" $ do-      showType SomeType `shouldBe` "SomeType"--  describe "showFullType (currently unused)" $ do-    it "shows fully qualified name of type" $ do-      showFullType SomeType `shouldBe` "Test.Hspec.CompatSpec.SomeType"--  describe "lookupEnv" $ do-    it "returns value of specified environment variable" $ do-      setEnv "FOO" "bar"-      lookupEnv "FOO" `shouldReturn` Just "bar"--    it "returns Nothing if specified environment variable is not set" $ do-      unsetEnv "FOO"-      lookupEnv "FOO" `shouldReturn` Nothing
+ test/Test/Hspec/Core/AnnotationsSpec.hs view
@@ -0,0 +1,29 @@+module Test.Hspec.Core.AnnotationsSpec (spec) where++import           Prelude ()+import           Helper++import           Test.Hspec.Core.Annotations++newtype A = A Int+  deriving (Eq, Show)++newtype B = B Int+  deriving (Eq, Show)++spec :: Spec+spec = do+  describe "Annotations" $ do+    it "can store a value" $ do+      let annotations = setValue (A 23) mempty+      getValue annotations `shouldBe` Just (A 23)++    it "can store multiple values of different types" $ do+      let annotations = setValue (B 42) $ setValue (A 23) mempty+      getValue annotations `shouldBe` Just (A 23)+      getValue annotations `shouldBe` Just (B 42)++    context "when a value of the same type is added multiple times" $ do+      it "gives precedence to the value that was added last" $ do+        let annotations = setValue (A 42) $  setValue (A 23) mempty+        getValue annotations `shouldBe` Just (A 42)
+ test/Test/Hspec/Core/ClockSpec.hs view
@@ -0,0 +1,16 @@+module Test.Hspec.Core.ClockSpec (spec) where++import           Prelude ()+import           Helper++import           Test.Hspec.Core.Clock++spec :: Spec+spec = do+  describe "toMilliseconds" $ do+    it "converts Seconds to milliseconds" $ do+      toMilliseconds 0.1 `shouldBe` 100++  describe "toMicroseconds" $ do+    it "converts Seconds to microseconds" $ do+      toMicroseconds 2.5 `shouldBe` 2500000
+ test/Test/Hspec/Core/CompatSpec.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Test.Hspec.Core.CompatSpec (spec) where++import           Prelude ()+import           Helper++import           System.Environment++data SomeType = SomeType++spec :: Spec+spec = do+  describe "showType" $ do+    it "shows unqualified name of type" $ do+      showType SomeType `shouldBe` "SomeType"++  describe "lookupEnv" $ do+    it "returns value of specified environment variable" $ do+      setEnv "FOO" "bar"+      lookupEnv "FOO" `shouldReturn` Just "bar"++    it "returns Nothing if specified environment variable is not set" $ do+      unsetEnv "FOO"+      lookupEnv "FOO" `shouldReturn` Nothing
+ test/Test/Hspec/Core/Config/DefinitionSpec.hs view
@@ -0,0 +1,22 @@+module Test.Hspec.Core.Config.DefinitionSpec (spec) where++import           Prelude ()+import           Helper++import           Test.Hspec.Core.Config.Definition++spec :: Spec+spec = do+  describe "splitOn" $ do+    it "splits a string" $ do+      splitOn ',' "foo,bar,baz" `shouldBe` ["foo", "bar", "baz"]++    it "splits *arbitrary* strings" $ property $ do+      let+        string :: Gen String+        string = arbitrary `suchThat` p++        p :: String -> Bool+        p = (&&) <$> not . null <*> all (/= ',')++      forAll (listOf string) $ \ xs -> splitOn ',' (intercalate "," xs) `shouldBe` xs
+ test/Test/Hspec/Core/Config/OptionsSpec.hs view
@@ -0,0 +1,230 @@+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}+module Test.Hspec.Core.Config.OptionsSpec (spec) where++import           Prelude ()+import           Helper++import           System.Exit++import           Test.Hspec.Core.Config+import           Test.Hspec.Core.Config.Options hiding (parseOptions)+import qualified Test.Hspec.Core.Config.Options as Options++fromLeft :: Either a b -> a+fromLeft (Left a) = a+fromLeft _ = error "fromLeft: No left value!"++spec :: Spec+spec = do+  describe "parseOptions" $ do++    let parseOptions configFiles envVar env args = snd <$> Options.parseOptions defaultConfig "my-spec" configFiles envVar env args++    it "rejects unexpected arguments" $ do+      fromLeft (parseOptions [] Nothing [] ["foo"]) `shouldBe` (ExitFailure 1, "my-spec: unexpected argument `foo'\nTry `my-spec --help' for more information.\n")++    it "rejects unrecognized options" $ do+      fromLeft (parseOptions [] Nothing [] ["--foo"]) `shouldBe` (ExitFailure 1, "my-spec: unrecognized option `--foo'\nTry `my-spec --help' for more information.\n")++    it "sets configColorMode to ColorAuto" $ do+      configColorMode <$> parseOptions [] Nothing [] [] `shouldBe` Right ColorAuto++    context "when the same option is specified multiple times" $ do+      it "gives later occurrences precedence" $ do+        configColorMode <$> parseOptions [] Nothing [] ["--color", "--no-color"] `shouldBe` Right ColorNever++    context "with --help" $ do+      let Left (code, help) = Options.parseOptions defaultConfig "spec" [] Nothing [] ["--help"]++      it "returns ExitSuccess" $ do+        code `shouldBe` ExitSuccess++      it "prints help" $ do+        expected <- readFile "help.txt"+        help `shouldBe` expected++    describe "RUNNER OPTIONS" $ do+      let parseOptions_ args = snd <$> Options.parseOptions defaultConfig "my-spec" [] Nothing [] args++      it "gives HSPEC_FAIL_ON precedence over HSPEC_STRICT" $ do+        (configFailOnFocused &&& configFailOnPending) <$> parseOptions [] Nothing [("HSPEC_STRICT", "no"), ("HSPEC_FAIL_ON", "focused")] []+          `shouldBe` Right (True, False)++      it "gives HSPEC_NO_FAIL_ON precedence over HSPEC_STRICT" $ do+        (configFailOnFocused &&& configFailOnPending) <$> parseOptions [] Nothing [("HSPEC_STRICT", "yes"), ("HSPEC_NO_FAIL_ON", "focused")] []+          `shouldBe` Right (False, True)++      context "with --fail-on-focused" $ do+        it "sets configFailOnFocused to True" $ do+          configFailOnFocused <$> parseOptions_ ["--fail-on-focused"] `shouldBe` Right True++      context "with --fail-on-pending" $ do+        it "sets configFailOnPending to True" $ do+          configFailOnPending <$> parseOptions_ ["--fail-on-pending"] `shouldBe` Right True++      context "with --fail-on" $ do+        it "accepts a list of values" $ do+          let config = parseOptions_ ["--fail-on=focused,pending"]+          configFailOnFocused <$> config `shouldBe` Right True+          configFailOnPending <$> config `shouldBe` Right True++        context "with focused" $ do+          it "sets configFailOnFocused to True" $ do+            configFailOnFocused <$> parseOptions_ ["--fail-on=focused"] `shouldBe` Right True++        context "with pending" $ do+          it "sets configFailOnPending to True" $ do+            configFailOnPending <$> parseOptions_ ["--fail-on=pending"] `shouldBe` Right True++      context "with --no-fail-on" $ do+        it "inverts --fail-on" $ do+          let config = parseOptions_ ["--fail-on=focused,pending", "--no-fail-on=focused,pending"]+          configFailOnFocused <$> config `shouldBe` Right False+          configFailOnPending <$> config `shouldBe` Right False++    context "with --color" $ do+      it "sets configColorMode to ColorAlways" $ do+        configColorMode <$> parseOptions [] Nothing [] ["--color"] `shouldBe` Right ColorAlways++    context "with --no-color" $ do+      it "sets configColorMode to ColorNever" $ do+        configColorMode <$> parseOptions [] Nothing [] ["--no-color"] `shouldBe` Right ColorNever++    context "with --diff" $ do+      it "sets configDiff to True" $ do+        configDiff <$> parseOptions [] Nothing [] ["--diff"] `shouldBe` Right True++    context "with --no-diff" $ do+      it "sets configDiff to False" $ do+        configDiff <$> parseOptions [] Nothing [] ["--no-diff"] `shouldBe` Right False++    context "with --diff-context" $ do+      it "accepts 0" $ do+        configDiffContext <$> parseOptions [] Nothing [] ["--diff-context=0"] `shouldBe` Right (Just 0)++      it "accepts positive values" $ do+        configDiffContext <$> parseOptions [] Nothing [] ["--diff-context=5"] `shouldBe` Right (Just 5)++      it "rejects invalid values" $ do+          let msg = "my-spec: invalid argument `foo' for `--diff-context'\nTry `my-spec --help' for more information.\n"+          void (parseOptions [] Nothing [] ["--diff-context=foo"]) `shouldBe` Left (ExitFailure 1, msg)++      context "with negative values" $ do+        it "disables the option" $ do+          configDiffContext <$> parseOptions [] Nothing [] ["--diff-context=-1"] `shouldBe` Right Nothing++      context "with 'full'" $ do+        it "disables the option" $ do+          configDiffContext <$> parseOptions [] Nothing [] ["--diff-context=full"] `shouldBe` Right Nothing++    context "with --diff-command=" $ do+      it "sets configExternalDiff to Nothing" $ do+        fmap (const ()) . configExternalDiff <$> parseOptions [] Nothing [] ["--diff-command="] `shouldBe` Right Nothing++    context "with --print-slow-items" $ do+      it "sets configPrintSlowItems to N" $ do+        configPrintSlowItems <$> parseOptions [] Nothing [] ["--print-slow-items=5"] `shouldBe` Right (Just 5)++      it "defaults N to 10" $ do+        configPrintSlowItems <$> parseOptions [] Nothing [] ["--print-slow-items"] `shouldBe` Right (Just 10)++      it "rejects invalid values" $ do+        let msg = "my-spec: invalid argument `foo' for `--print-slow-items'\nTry `my-spec --help' for more information.\n"+        void (parseOptions [] Nothing [] ["--print-slow-items=foo"]) `shouldBe` Left (ExitFailure 1, msg)++      context "when N is 0" $ do+        it "disables the option" $ do+          configPrintSlowItems <$> parseOptions [] Nothing [] ["-p0"] `shouldBe` Right Nothing++      context "when N is negative" $ do+        it "disables the option" $ do+          configPrintSlowItems <$> parseOptions [] Nothing [] ["--print-slow-items=-23"] `shouldBe` Right Nothing++    context "with --qc-max-success" $ do+      it "sets QuickCheck maxSuccess" $ do+        maxSuccess . configQuickCheckArgs <$> (parseOptions [] Nothing [] ["--qc-max-success", "23"]) `shouldBe`  Right 23++      context "when given an invalid argument" $ do+        it "returns an error message" $ do+          fromLeft (parseOptions [] Nothing [] ["--qc-max-success", "foo"]) `shouldBe` (ExitFailure 1, "my-spec: invalid argument `foo' for `--qc-max-success'\nTry `my-spec --help' for more information.\n")++    context "with --qc-max-shrinks" $ do+      it "sets QuickCheck maxShrinks" $ do+        maxShrinks . configQuickCheckArgs <$> (parseOptions [] Nothing [] ["--qc-max-shrinks", "23"]) `shouldBe`  Right 23++    context "with --depth" $ do+      it "sets depth parameter for SmallCheck" $ do+        configSmallCheckDepth <$> parseOptions [] Nothing [] ["--depth", "23"] `shouldBe` Right (Just 23)++    context "with --jobs" $ do+      it "sets number of concurrent jobs" $ do+        configConcurrentJobs <$> parseOptions [] Nothing [] ["--jobs=23"] `shouldBe` Right (Just 23)++      it "rejects values < 1" $ do+        let msg = "my-spec: invalid argument `0' for `--jobs'\nTry `my-spec --help' for more information.\n"+        void (parseOptions [] Nothing [] ["--jobs=0"]) `shouldBe` Left (ExitFailure 1, msg)++    context "when given a config file" $ do+      it "uses options from config file" $ do+        configColorMode <$> parseOptions [("~/.hspec", ["--no-color"])] Nothing [] [] `shouldBe` Right ColorNever++      it "gives command-line options precedence" $ do+        configColorMode <$> parseOptions [("~/.hspec", ["--no-color"])] Nothing [] ["--color"] `shouldBe` Right ColorAlways++      it "rejects --help" $ do+        fromLeft (parseOptions [("~/.hspec", ["--help"])] Nothing [] []) `shouldBe` (ExitFailure 1, "my-spec: unrecognized option `--help' in config file ~/.hspec\n")++      it "rejects unrecognized options" $ do+        fromLeft (parseOptions [("~/.hspec", ["--invalid"])] Nothing [] []) `shouldBe` (ExitFailure 1, "my-spec: unrecognized option `--invalid' in config file ~/.hspec\n")++      it "rejects ambiguous options" $ do+        fromLeft (parseOptions [("~/.hspec", ["--print"])] Nothing [] []) `shouldBe` (ExitFailure 1,+          unlines [+            "my-spec: option `--print' is ambiguous; could be one of:"+          , "         --print-cpu-time        include used CPU time in summary"+          , "  -p[N]  --print-slow-items[=N]  print the N slowest spec items (default: 10)"+          , "in config file ~/.hspec"+          ]+          )++      context "when the same option is specified multiple times" $ do+        it "gives later occurrences precedence" $ do+          configColorMode <$> parseOptions [("~/.hspec", ["--color", "--no-color"])] Nothing [] [] `shouldBe` Right ColorNever++    context "when given multiple config files" $ do+      it "gives later config files precedence" $ do+        configColorMode <$> parseOptions [("~/.hspec", ["--no-color"]), (".hspec", ["--color"])] Nothing [] [] `shouldBe` Right ColorAlways++    context "when given HSPEC_OPTIONS (deprecated)" $ do+      it "uses options from HSPEC_OPTIONS" $ do+        configColorMode <$> parseOptions [] (Just ["--no-color"]) [] [] `shouldBe` Right ColorNever++      it "gives command-line options precedence" $ do+        configColorMode <$> parseOptions [] (Just ["--no-color"]) [] ["--color"] `shouldBe` Right ColorAlways++      it "rejects unrecognized options" $ do+        fromLeft (parseOptions [] (Just ["--invalid"]) [] []) `shouldBe` (ExitFailure 1, "my-spec: unrecognized option `--invalid' from environment variable HSPEC_OPTIONS\n")++    context "when given an option as an environment variable" $ do+      it "sets config value from environment variable" $ do+        configColorMode <$> parseOptions [] Nothing [("HSPEC_COLOR", "no")] [] `shouldBe` Right ColorNever++      it "gives command-line options precedence" $ do+        configColorMode <$> parseOptions [] Nothing [("HSPEC_COLOR", "no")] ["--color"] `shouldBe` Right ColorAlways++      it "warns on unrecognized option values" $ do+        fmap configColorMode <$> Options.parseOptions defaultConfig "my-spec" [] Nothing [("HSPEC_COLOR", "foo")] [] `shouldBe` Right (["invalid value `foo' for environment variable HSPEC_COLOR"], ColorAuto)++  describe "ignoreConfigFile" $ around_ (withEnvironment []) $ do+    context "by default" $ do+      it "returns False" $ do+        ignoreConfigFile defaultConfig [] `shouldReturn` False++    context "with --ignore-dot-hspec" $ do+      it "returns True" $ do+        ignoreConfigFile defaultConfig ["--ignore-dot-hspec"] `shouldReturn` True++    context "with IGNORE_DOT_HSPEC" $ do+      it "returns True" $ do+        withEnvironment [("IGNORE_DOT_HSPEC", "yes")] $ do+          ignoreConfigFile defaultConfig [] `shouldReturn` True
+ test/Test/Hspec/Core/ConfigSpec.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE CPP #-}+module Test.Hspec.Core.ConfigSpec (spec) where++import           Prelude ()+import           Helper++import           System.Directory++import           Test.Hspec.Core.Config++spec :: Spec+spec = around_ inTempDirectory $ around_ (withEnvironment [("HOME", "foo")]) $ do+  describe "readConfig" $ do+    it "recognizes options from HSPEC_OPTIONS" $ do+      withEnvironment [("HSPEC_OPTIONS", "--color")] $ do+        configColorMode <$> readConfig defaultConfig [] `shouldReturn` ColorAlways++    it "recognizes options from HSPEC_*" $ do+      withEnvironment [("HSPEC_COLOR", "yes")] $ do+        configColorMode <$> readConfig defaultConfig [] `shouldReturn` ColorAlways++  describe "readConfigFiles" $ do+    it "reads .hspec" $ do+      dir <- getCurrentDirectory+      let name = dir </> ".hspec"+      writeFile name "--diff --foo 'bar baz'"+      readConfigFiles `shouldReturn` [(name, ["--diff", "--foo", "bar baz"])]++#ifndef mingw32_HOST_OS+    it "reads ~/.hspec" $ do+      let name = "my-home/.hspec"+      createDirectory "my-home"+      writeFile name "--diff"+      withEnvironment [("HOME", "my-home")] $ do+        readConfigFiles `shouldReturn` [(name, ["--diff"])]++    context "without $HOME" $ do+      it "returns empty list" $ do+        readConfigFiles `shouldReturn` []++    context "without current directory" $ do+      it "returns empty list" $ do+        dir <- getCurrentDirectory+        removeDirectory dir+        readConfigFiles `shouldReturn` []+#endif
+ test/Test/Hspec/Core/Example/LocationSpec.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-}+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}+{-# OPTIONS_GHC -fno-warn-missing-methods #-}+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -O0 #-}+module Test.Hspec.Core.Example.LocationSpec (spec) where++import           Prelude ()+import           Helper++import           Test.Hspec.Core.Example+import           Test.Hspec.Core.Example.Location++class SomeClass a where+  someMethod :: a -> IO ()++instance SomeClass () where++data Person = Person {+  name :: String+, age :: Int+} deriving (Eq, Show)++spec :: Spec+spec = do+  describe "parseAssertionFailed" $ do+    context "with pre-GHC-8.* error message" $ do+      it "extracts source location" $ do+        parseAssertionFailed "Foo.hs:4:7-12: Assertion failed\n" `shouldBe` Just (Location "Foo.hs" 4 7)++  describe "extractLocation" $ do+    context "with pattern match failure in do expression" $ do+      context "in IO" $ do+        it "extracts Location" $ do+          let location = Just $ Location file (__LINE__ + 2) 13+          Left e <- try $ do+            Just n <- return Nothing+            return (n :: Int)+          extractLocation e `shouldBe` location++#if !MIN_VERSION_base(4,12,0)+      context "in Either" $ do+        it "extracts Location" $ do+          let location = Just $ Location file (__LINE__ + 4) 15+          let+            foo :: Either () ()+            foo = do+              23 <- Right (42 :: Int)+              pass+          Left e <- try (evaluate foo)+          extractLocation e `shouldBe` location+#endif++    context "with ErrorCall" $ do+      it "extracts Location" $ do+        let+          location =+            Just $ Location file (succ __LINE__) 34+        Left e <- try (evaluate (undefined :: ()))+        extractLocation e `shouldBe` location++    context "with PatternMatchFail" $ do+      context "with single-line source span" $ do+        it "extracts Location" $ do+          let+            location = Just $ Location file (__LINE__ + 1) 40+          Left e <- try (evaluate (let Just n = Nothing in (n :: Int)))+          extractLocation e `shouldBe` location++      context "with multi-line source span" $ do+        it "extracts Location" $ do+          let location = Just $ Location file (__LINE__ + 1) 36+          Left e <- try (evaluate (case Nothing of+            Just n -> n :: Int+            ))+          extractLocation e `shouldBe` location++    context "with RecConError" $ do+      it "extracts Location" $ do+        let+          location = Just $ Location file (__LINE__ + 1) 39+        Left e <- try $ evaluate (age Person {name = "foo"})+        extractLocation e `shouldBe` location++    context "with NoMethodError" $ do+      it "extracts Location" $ do+        Left e <- try $ someMethod ()+        extractLocation e `shouldBe` Just (Location file 19 10)++    context "with AssertionFailed" $ do+      it "extracts Location" $ do+        let+          location = Just $ Location file (__LINE__ + 1) 36+        Left e <- try . evaluate $ assert False ()+        extractLocation e `shouldBe` location++  describe "parseBacktraces" $ do+    it "parses Location from Backtraces" $ do+      let+        input :: String+        input = unlines [+            "Cost-centre stack backtrace:"+          , "  ..."+          , "IPE backtrace:"+          , "  ..."+          , "HasCallStack backtrace:"+          , "  foo, called at Foo.hs:23:7 in main:Foo"+          , "  bar, called at Foo.hs:42:7 in main:Foo"+          , "  baz, called at Foo.hs:65:9 in main:Foo"+          , "..."+          , "  ..."+          ]+      parseBacktraces input `shouldBe` Just Location {+        locationFile = "Foo.hs"+      , locationLine = 65+      , locationColumn = 9+      }++  describe "parseCallStack" $ do+    it "parses Location from call stack" $ do+      let input = [+              "CallStack (from HasCallStack):"+            , "  error, called at libraries/base/GHC/Err.hs:79:14 in base:GHC.Err"+            , "  undefined, called at test/Test/Hspec.hs:13:32 in main:Test.Hspec"+            ]+      parseCallStack input `shouldBe` Just (Location ("test" </> "Test" </> "Hspec.hs") 13 32)++  describe "parseLocation" $ do+    it "parses Location" $ do+      parseLocation "test/Test/Hspec.hs:13:32" `shouldBe` Just (Location ("test" </> "Test" </> "Hspec.hs") 13 32)++  describe "parseSourceSpan" $ do+    it "parses single-line source span" $ do+      parseSourceSpan "test/Test/Hspec.hs:25:36-51:" `shouldBe` Just (Location ("test" </> "Test" </> "Hspec.hs") 25 36)++    it "parses multi-line source span" $ do+      parseSourceSpan "test/Test/Hspec.hs:(15,7)-(17,26):" `shouldBe` Just (Location ("test" </> "Test" </> "Hspec.hs") 15 7)++file :: FilePath+file = workaroundForIssue19236 __FILE__
test/Test/Hspec/Core/ExampleSpec.hs view
@@ -1,49 +1,161 @@-{-# LANGUAGE CPP, ScopedTypeVariables, TypeFamilies #-}-module Test.Hspec.Core.ExampleSpec (main, spec) where+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} +module Test.Hspec.Core.ExampleSpec (spec) where++import           Prelude () import           Helper+ import           Mock-import           Data.List-import qualified Control.Exception as E+import           Test.HUnit (assertFailure, assertEqual) +import           Test.Hspec.Core.Example (Result(..), ResultStatus(..), FailureReason(..))+import qualified Test.Hspec.Expectations as H import qualified Test.Hspec.Core.Example as H import qualified Test.Hspec.Core.Spec as H import qualified Test.Hspec.Core.Runner as H -main :: IO ()-main = hspec spec+safeEvaluateExample :: (H.Example e,  H.Arg e ~ ()) => e -> IO Result+safeEvaluateExample e = H.safeEvaluateExample e defaultParams ($ ()) noOpProgressCallback -evaluateExample :: (H.Example e,  H.Arg e ~ ()) => e -> IO H.Result+evaluateExample :: (H.Example e,  H.Arg e ~ ()) => e -> IO Result evaluateExample e = H.evaluateExample e defaultParams ($ ()) noOpProgressCallback -evaluateExampleWith :: (H.Example e, H.Arg e ~ ()) => (IO () -> IO ()) -> e -> IO H.Result+evaluateExampleWith :: (H.Example e, H.Arg e ~ ()) => (IO () -> IO ()) -> e -> IO Result evaluateExampleWith action e = H.evaluateExample e defaultParams (action . ($ ())) noOpProgressCallback +evaluateExampleWithArgument :: H.Example e => (ActionWith (H.Arg e) -> IO ()) -> e -> IO Result+evaluateExampleWithArgument action e = H.evaluateExample e defaultParams action noOpProgressCallback++bottom :: a+bottom = throw DivideByZero+ spec :: Spec spec = do+  describe "safeEvaluate" $ do+    let+      status :: ResultStatus+      status = Failure Nothing (Error Nothing $ toException DivideByZero)++      err :: Result+      err = Result "" status++    it "forces Result" $ do+      H.safeEvaluate (return $ Result "" bottom) `shouldReturn` err++    it "handles ResultStatus exceptions" $ do+      H.safeEvaluate (throwIO status) `shouldReturn` err++    it "forces ResultStatus exceptions" $ do+      H.safeEvaluate (throwIO $ Failure Nothing bottom) `shouldReturn` err++    it "handles other exceptions" $ do+      H.safeEvaluate (throwIO DivideByZero) `shouldReturn` err++    it "forces other exceptions" $ do+      H.safeEvaluate (throwIO $ ErrorCall bottom) `shouldReturn` err++  describe "safeEvaluateResultStatus" $ do+    let+      err :: ResultStatus+      err = Failure Nothing (Error Nothing $ toException DivideByZero)++    it "forces ResultStatus" $ do+      H.safeEvaluateResultStatus (return $ Failure Nothing bottom) `shouldReturn` err++    it "handles ResultStatus exceptions" $ do+      H.safeEvaluateResultStatus (throwIO err) `shouldReturn` err++    it "forces ResultStatus exceptions" $ do+      H.safeEvaluateResultStatus (throwIO $ Failure Nothing bottom) `shouldReturn` err++    it "handles other exceptions" $ do+      H.safeEvaluateResultStatus (throwIO DivideByZero) `shouldReturn` err++    it "forces other exceptions" $ do+      H.safeEvaluateResultStatus (throwIO $ ErrorCall bottom) `shouldReturn` err++  describe "safeEvaluateExample" $ do+    context "for Expectation" $ do+      it "returns Failure if an expectation does not hold" $ do+        Result "" (Failure _ msg) <- safeEvaluateExample (23 `H.shouldBe` (42 :: Int))+        msg `shouldBe` ExpectedButGot Nothing "42" "23"++      context "when used with `pending`" $ do+        it "returns Pending" $ do+          result <- safeEvaluateExample (H.pending)+          let location = mkLocation __FILE__ (pred __LINE__) 42+          result `shouldBe` Result "" (Pending location Nothing)++      context "when used with `pendingWith`" $ do+        it "includes the optional reason" $ do+          result <- safeEvaluateExample (H.pendingWith "foo")+          let location = mkLocation __FILE__ (pred __LINE__) 42+          result `shouldBe` Result "" (Pending location $ Just "foo")+   describe "evaluateExample" $ do+    context "for Result" $ do+      it "propagates exceptions" $ do+        evaluateExample (error "foobar" :: Result) `shouldThrow` errorCall "foobar"++      it "runs around-action" $ do+        ref <- newIORef (0 :: Int)+        let action :: IO () -> IO ()+            action e = do+              e+              modifyIORef ref succ++            result = Result "" (Failure Nothing NoReason)+        evaluateExampleWith action result `shouldReturn` result+        readIORef ref `shouldReturn` 1++      it "accepts arguments" $ do+        ref <- newIORef (0 :: Int)+        let action :: (Integer -> IO ()) -> IO ()+            action e = do+              e 42+              modifyIORef ref succ+        evaluateExampleWithArgument action (Result "" . Failure Nothing . Reason . show) `shouldReturn` Result "" (Failure Nothing $ Reason "42")+        readIORef ref `shouldReturn` 1+     context "for Bool" $ do       it "returns Success on True" $ do-        evaluateExample True `shouldReturn` H.Success+        evaluateExample True `shouldReturn` Result "" Success -      it "returns Fail on False" $ do-        evaluateExample False `shouldReturn` H.Fail Nothing ""+      it "returns Failure on False" $ do+        evaluateExample False `shouldReturn` Result "" (Failure Nothing NoReason)        it "propagates exceptions" $ do         evaluateExample (error "foobar" :: Bool) `shouldThrow` errorCall "foobar" +      it "runs around-action" $ do+        ref <- newIORef (0 :: Int)+        let action :: IO () -> IO ()+            action e = do+              e+              modifyIORef ref succ+        evaluateExampleWith action False `shouldReturn` Result "" (Failure Nothing NoReason)+        readIORef ref `shouldReturn` 1++      it "accepts arguments" $ do+        ref <- newIORef (0 :: Int)+        let action :: (Integer -> IO ()) -> IO ()+            action e = do+              e 42+              modifyIORef ref succ+        evaluateExampleWithArgument action (== (23 :: Integer)) `shouldReturn` Result "" (Failure Nothing NoReason)+        readIORef ref `shouldReturn` 1+     context "for Expectation" $ do       it "returns Success if all expectations hold" $ do-        evaluateExample (23 `shouldBe` (23 :: Int)) `shouldReturn` H.Success--      it "returns Fail if an expectation does not hold" $ do-        H.Fail _ msg <- evaluateExample (23 `shouldBe` (42 :: Int))-        msg `shouldEndWith` "expected: 42\n but got: 23"+        evaluateExample (23 `shouldBe` (23 :: Int)) `shouldReturn` Result "" Success        it "propagates exceptions" $ do         evaluateExample (error "foobar" :: Expectation) `shouldThrow` errorCall "foobar" -      it "runs provided action around expectation" $ do+      it "runs around-action" $ do         ref <- newIORef (0 :: Int)         let action :: IO () -> IO ()             action e = do@@ -51,34 +163,30 @@               e               readIORef ref `shouldReturn` succ n               modifyIORef ref succ-        evaluateExampleWith action (modifyIORef ref succ) `shouldReturn` H.Success+        evaluateExampleWith action (modifyIORef ref succ) `shouldReturn` Result "" Success         readIORef ref `shouldReturn` 2 -      context "when used with `pending`" $ do-        it "returns Pending" $ do-          evaluateExample (H.pending) `shouldReturn` H.Pending Nothing--      context "when used with `pendingWith`" $ do-        it "includes the optional reason" $ do-          evaluateExample (H.pendingWith "foo") `shouldReturn` H.Pending (Just "foo")-     context "for Property" $ do       it "returns Success if property holds" $ do-        evaluateExample (property $ \n -> n == (n :: Int)) `shouldReturn` H.Success+        evaluateExample (property $ \n -> n == (n :: Int)) `shouldReturn` Result "+++ OK, passed 1000 tests." Success -      it "returns Fail if property does not hold" $ do-        H.Fail _ _ <- evaluateExample $ property $ \n -> n /= (n :: Int)-        return ()+      it "shows the collected labels" $ do+        Result info Success <- evaluateExample $ property $ \ () -> label "unit" True+        info `shouldBe` "+++ OK, passed 1000 tests (100.0% unit)." +      it "returns Failure if property does not hold" $ do+        Result "" (Failure _ _) <- evaluateExample $ property $ \n -> n /= (n :: Int)+        pass+       it "shows what falsified it" $ do-        H.Fail _ r <- evaluateExample $ property $ \ (x :: Int) (y :: Int) -> (x == 0 && y == 1) ==> False-        r `shouldBe` intercalate "\n"  [-            "Falsifiable (after 1 test): "-          , "0"-          , "1"+        Result "" (Failure _ r) <- evaluateExample $ property $ \ (x :: Int) (y :: Int) -> (x == 0 && y == 1) ==> False+        r `shouldBe` (Reason . intercalate "\n")  [+            "Falsified (after 1 test):"+          , "  0"+          , "  1"           ] -      it "runs provided action around each single check of the property" $ do+      it "runs around-action for each single check of the property" $ do         ref <- newIORef (0 :: Int)         let action :: IO () -> IO ()             action e = do@@ -86,51 +194,63 @@               e               readIORef ref `shouldReturn` succ n               modifyIORef ref succ-        H.Success <- evaluateExampleWith action (property $ \(_ :: Int) -> modifyIORef ref succ)+        Result _ Success <- evaluateExampleWith action (property $ \(_ :: Int) -> modifyIORef ref succ)         readIORef ref `shouldReturn` 2000        it "pretty-prints exceptions" $ do-        H.Fail _ r <- evaluateExample $ property (\ (x :: Int) -> (x == 0) ==> (E.throw (E.ErrorCall "foobar") :: Bool))-        r `shouldBe` intercalate "\n" [-#if MIN_VERSION_QuickCheck(2,7,0)-            "uncaught exception: ErrorCall (foobar) (after 1 test)"-#else-            "Exception: 'foobar' (after 1 test): "-#endif-          , "0"+        Result "" (Failure _ r) <- evaluateExample $ property (\ (x :: Int) -> (x == 0) ==> (throw (ErrorCall "foobar") :: Bool))+        r `shouldBe` (Reason . intercalate "\n") [+            "uncaught exception: ErrorCall"+          , "foobar"+          , "(after 1 test)"+          , "  0"           ] -      context "when used with shouldBe" $ do-        it "shows what falsified it" $ do-          H.Fail _ r <- evaluateExample $ property $ \ (x :: Int) (y :: Int) -> (x == 0 && y == 1) ==> 23 `shouldBe` (42 :: Int)-          r `shouldStartWith` "Falsifiable (after 1 test): \n"-          r `shouldEndWith` intercalate "\n" [-              "expected: 42"-            , " but got: 23"-            , "0"-            , "1"-            ]+      context "when used with Expectation" $ do+        let prop p = property $ \ (x :: Int) (y :: Int) -> (x == 0 && y == 1) ==> p+        context "when used with shouldBe" $ do+          it "shows what falsified it" $ do+            Result "" (Failure _ err) <- evaluateExample $ prop $ 23 `H.shouldBe` (42 :: Int)+            err `shouldBe` ExpectedButGot (Just "Falsifiable (after 1 test):\n  0\n  1") "42" "23" +        context "when used with assertEqual" $ do+          it "includes prefix" $ do+            Result "" (Failure _ err) <- evaluateExample $ prop $ assertEqual "foobar" (42 :: Int) 23+            err `shouldBe` ExpectedButGot (Just "Falsifiable (after 1 test):\n  0\n  1\nfoobar") "42" "23"++        context "when used with assertFailure" $ do+          it "includes reason" $ do+            Result "" (Failure _ err) <- evaluateExample $ prop (assertFailure "foobar" :: IO ())+            err `shouldBe` Reason "Falsifiable (after 1 test):\n  0\n  1\nfoobar"++        context "when used with verbose" $ do+          it "includes verbose output" $ do+            Result info (Failure _ err) <- evaluateExample $ verbose $ (`H.shouldBe` (23 :: Int))+            info `shouldBe` "Failed:\n0"+            err `shouldBe` ExpectedButGot (Just "Falsifiable (after 1 test):\n  0") "23" "0"+       context "when used with `pending`" $ do         it "returns Pending" $ do-          evaluateExample (property H.pending) `shouldReturn` H.Pending Nothing+          let location = mkLocation __FILE__ (succ __LINE__) 37+          evaluateExample (property H.pending) `shouldReturn` Result "" (Pending location Nothing)        context "when used with `pendingWith`" $ do         it "includes the optional reason" $ do-          evaluateExample (property $ H.pendingWith "foo") `shouldReturn` H.Pending (Just "foo")+          let location = mkLocation __FILE__ (succ __LINE__) 39+          evaluateExample (property $ H.pendingWith "foo") `shouldReturn` Result "" (Pending location $ Just "foo")    describe "Expectation" $ do     context "as a QuickCheck property" $ do       it "can be quantified" $ do         e <- newMock-        silence . H.hspec $ do+        hspecSilent $ do           H.it "some behavior" $ property $ \xs -> do             mockAction e             (reverse . reverse) xs `shouldBe` (xs :: [Int])         mockCounter e `shouldReturn` 100        it "can be used with expectations/HUnit assertions" $ do-        silence . H.hspecResult $ do+        hspecResultSilent $ do           H.describe "readIO" $ do             H.it "is inverse to show" $ property $ \x -> do               (readIO . show) x `shouldReturn` (x :: Int)
+ test/Test/Hspec/Core/FailureReportSpec.hs view
@@ -0,0 +1,48 @@+module Test.Hspec.Core.FailureReportSpec (spec) where++import           Prelude ()+import           Helper++import           System.IO+import           Test.Hspec.Core.FailureReport+import           Test.Hspec.Core.Config++spec :: Spec+spec = do+  describe "writeFailureReport" $ do+    it "prints a warning on unexpected exceptions" $ do+      r <- hCapture_ [stderr] $ writeFailureReport defaultConfig (throw (ErrorCall "some error"))+      r `shouldBe` "WARNING: Could not write environment variable HSPEC_FAILURES (some error)\n"++  describe "readFailureReport" $ do+    context "when configFailureReport is specified" $ do+      let+        file = "report"+        config = defaultConfig {configFailureReport = Just file}+        report = FailureReport {+            failureReportSeed = 23+          , failureReportMaxSuccess = 42+          , failureReportMaxSize = 65+          , failureReportMaxDiscardRatio = 123+          , failureReportPaths = [(["foo", "bar"], "baz")]+          }+      it "reads a failure report from a file" $ do+        inTempDirectory $ do+          writeFailureReport config report+          readFailureReport config `shouldReturn` Just report++      context "when file does not exist" $ do+        it "returns Nothing" $ do+          inTempDirectory $ do+            readFailureReport config `shouldReturn` Nothing++      context "when file is malformed" $ do+        it "returns Nothing" $ do+          hSilence [stderr] $ inTempDirectory $ do+            writeFile file "foo"+            readFailureReport config `shouldReturn` Nothing++        it "prints a warning" $ do+          inTempDirectory $ do+            writeFile file "foo"+            hCapture_ [stderr] (readFailureReport config) `shouldReturn` "WARNING: Could not read failure report from file \"report\"!\n"
+ test/Test/Hspec/Core/FormatSpec.hs view
@@ -0,0 +1,19 @@+module Test.Hspec.Core.FormatSpec (spec) where++import           Prelude ()+import           Helper++import           Test.Hspec.Core.Format++spec :: Spec+spec = do+  describe "monadic" $ do+    context "on exception" $ do+      it "propagates" $ do+        format <- monadic id (\ _ -> throwIO DivideByZero)+        format (Done []) `shouldThrow` (== DivideByZero)++      it "does not hang" $ do+        format <- monadic id (\ _ -> throwIO DivideByZero)+        format (Done []) `shouldThrow` (== DivideByZero)+        format (Done [])
+ test/Test/Hspec/Core/Formatters/DiffSpec.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Test.Hspec.Core.Formatters.DiffSpec (spec) where++import           Prelude ()+import           Helper+import           Data.Char++import           Test.Hspec.Core.Formatters.Diff as Diff++dropQuotes :: String -> String+dropQuotes = init . drop 1++spec :: Spec+spec = do+  describe "lineDiff" $ do+    let+      enumerate name n = map ((name ++) . show) [1 .. n :: Int]+      diff_ expected actual = lineDiff (Just 2) (unlines expected) (unlines actual)++    it "suppresses excessive diff output" $ do+      let+        expected = enumerate "foo" 99+        actual = replace "foo50" "bar50" expected++      diff_ expected actual `shouldBe` [+          LinesOmitted 47+        , LinesBoth [+            "foo48"+          , "foo49"+          ]+        , SingleLineDiff [First "foo50", Second "bar50"]+        , LinesBoth [+            "foo51"+          , "foo52"+          ]+        , LinesOmitted 47+        , LinesBoth [""]+        ]++    it "ensures that omitted sections are at least three lines in size" $ do+      forAll (elements [1..20]) $ \ size -> do+        let expected = enumerate "" size+        forAll (elements expected) $ \ i -> do+          let actual = replace i "bar" expected+          [n | LinesOmitted n <- diff_ expected actual] `shouldSatisfy` all (>= 3)++    context "with modifications within a line" $ do+        it "suppresses excessive diff output" $ do+          let+            expected = enumerate "foo " 99+            actual = replace "foo 42" "foo 23" expected++          diff_ expected actual `shouldBe` [+              LinesOmitted 39+            , LinesBoth [+                "foo 40"+              , "foo 41"+              ]+            , SingleLineDiff  [Both "foo ", First "42", Second "23"]+            , LinesBoth [+                "foo 43"+              , "foo 44"+              ]+            , LinesOmitted 55+            , LinesBoth [""]+            ]++    context "with modifications at start / end" $ do+      it "suppresses excessive diff output" $ do+        let+          expected = enumerate "foo" 9+          actual = replace "foo9" "bar9" $ replace "foo1" "bar1" expected++        diff_ expected actual `shouldBe` [+            SingleLineDiff  [First "foo1", Second "bar1"]+          , LinesBoth [+              "foo2"+            , "foo3"+            ]+          , LinesOmitted 3+          , LinesBoth [+              "foo7"+            , "foo8"+            ]+          , SingleLineDiff  [First "foo9", Second "bar9"]+          , LinesBoth [""]+          ]++  describe "splitLines" $ do+    it "splits on newline characters" $ do+      splitLines "foo\nbar\nbaz" `shouldBe` ["foo", "bar", "baz"]++    describe "with a newline characters at the start" $ do+      it "splits on newline characters" $ do+        splitLines "\nfoo\nbar\nbaz" `shouldBe` ["", "foo", "bar", "baz"]++    describe "with a newline characters at the end" $ do+      it "splits on newline characters" $ do+        splitLines "foo\nbar\nbaz\n" `shouldBe` ["foo", "bar", "baz", ""]++  describe "partition" $ do+    context "with a single shown Char" $ do+      it "never partitions a character escape" $ do+        property $ \ (c :: Char) -> partition (show c) `shouldBe` ["'", dropQuotes (show c), "'"]++    context "with a shown String" $ do+      it "puts backslash-escaped characters into separate chunks" $ do+        partition (show "foo\nbar") `shouldBe` ["\"", "foo", "\\n", "bar", "\""]++      it "puts *arbitrary* backslash-escaped characters into separate chunks" $ do+        property $ \ xs c ys ->+          let+            char = dropQuotes (show [c])+            isEscaped = length char > 1+            escape = drop 1 char+            sep = case ys of+              x : _ | all isDigit escape && isDigit x || escape == "SO" && x == 'H' -> ["\\&"]+              _ -> []+            actual = partition (show (xs ++ c : ys))+            expected = partition (init $ show xs) ++ [char] ++ sep ++ partition (drop 1 $ show ys)+          in isEscaped ==> actual `shouldBe` expected++  describe "breakList" $ do+    context "with a list where the predicate matches at the beginning and the end" $ do+      it "breaks the list into pieces" $ do+        breakList isAlphaNum "foo bar  baz" `shouldBe` ["foo", " ", "bar", " ", " ", "baz"]++    context "with a list where the predicate does not match at the beginning and the end" $ do+      it "breaks the list into pieces" $ do+        breakList isAlphaNum "  foo bar  baz  " `shouldBe` [" ", " ", "foo", " ", "bar", " ", " ", "baz", " ", " "]
+ test/Test/Hspec/Core/Formatters/InternalSpec.hs view
@@ -0,0 +1,64 @@+{-# OPTIONS_GHC -fno-warn-deprecations #-}+module Test.Hspec.Core.Formatters.InternalSpec (spec) where++import           Prelude ()+import           Helper++import           System.Console.ANSI++import           Test.Hspec.Core.Format+import           Test.Hspec.Core.Formatters.Internal++formatConfig :: FormatConfig+formatConfig = defaultFormatConfig {+  formatConfigUseColor = True+, formatConfigUseDiff = True+, formatConfigDiffContext = Just 3+}++spec :: Spec+spec = do+  forM_ [+      ("extraChunk", extraChunk, Red)+    , ("missingChunk", missingChunk, Green)+    ] $ \ (name, chunk, color) -> do++    describe name $ do+      it "colorizes chunks" $ do+        capture_ $ runFormatM formatConfig $ do+          chunk "foo"+        `shouldReturn` colorize Foreground color "foo"++      context "with an all-spaces chunk" $ do+        it "colorizes background" $ do+          capture_ $ runFormatM formatConfig $ do+            chunk "  "+          `shouldReturn` colorize Background color "  "++      context "with an all-newlines chunk" $ do+        it "colorizes background" $ do+          capture_ $ runFormatM formatConfig $ do+            chunk "\n\n\n"+          `shouldReturn` colorize Background color "\n\n\n"++  describe "write" $ do+    it "does not span colored output over multiple lines" $ do++      -- This helps with output on Jenkins and Buildkite:+      -- https://github.com/hspec/hspec/issues/346++      capture_ $ runFormatM formatConfig $ do+        withSuccessColor $ write "foo\nbar\nbaz\n"+      `shouldReturn` unlines [green "foo", green "bar", green "baz"]++  describe "splitLines" $ do+    it "splits a string into chunks" $ do+      splitLines "foo\nbar\nbaz" `shouldBe` ["foo", "\n", "bar", "\n", "baz"]++    it "splits *arbitrary* strings into chunks" $ do+      property $ \ xs -> do+        mconcat (splitLines xs) `shouldBe` xs++    it "puts newlines into separate chunks" $ do+      property $ \ xs -> do+        filter (notElem '\n') (splitLines xs) `shouldBe` filter (not . null) (lines xs)
+ test/Test/Hspec/Core/Formatters/Pretty/ParserSpec.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+module Test.Hspec.Core.Formatters.Pretty.ParserSpec (+  spec+, Person(..)+, Address(..)+, person+) where++import           Prelude ()+import           Helper++import           Test.Hspec.Core.Formatters.Pretty.Parser++data OperatorType = String :*: Int+  deriving (Eq, Show)++data Person = Person {+  personName :: String+, personAge :: Int+, personAddress :: Maybe Address+} deriving (Eq, Show)++data Address = Address {+  addressStreet :: String+, addressPostalCode :: Int+} deriving (Eq, Show)++person :: Person+person = Person "Joe" 23 (Just $ Address "Main Street" 50000)++infix 1 `shouldParseAs`++shouldParseAs :: HasCallStack => String -> Value -> Expectation+shouldParseAs input expected = parseValue input `shouldBe` Just expected++unit :: Value+unit = Tuple []++parentheses :: Value -> Value+parentheses value = Tuple [value]++spec :: Spec+spec = do+  describe "parseValue" $ do+    it "parses unit" $ do+      show () `shouldParseAs` unit++    it "parses characters" $ do+      show 'c' `shouldParseAs` Char 'c'++    it "parses strings" $ do+      show "foo" `shouldParseAs` String "foo"++    it "accepts rationals" $ do+      show (0.5 :: Rational) `shouldParseAs` Operator (Number "1") "%" (Number "2")++    it "accepts negative rationals" $ do+      show (-0.5 :: Rational) `shouldParseAs` Operator (parentheses $ Number "-1") "%" (Number "2")++    it "accepts constructor symbols" $ do+      show ("foo" :*: 23) `shouldParseAs` Operator (String "foo") ":*:" (Number "23")++    it "accepts integers" $ do+      "23" `shouldParseAs` Number "23"++    it "accepts negative integers" $ do+      "-23" `shouldParseAs` Number "-23"++    it "accepts floats" $ do+      show (23.0 :: Float) `shouldParseAs` Number "23.0"++    it "accepts negative floats" $ do+      show (-23.0 :: Float) `shouldParseAs` Number "-23.0"++    it "parses lists" $ do+      show ["foo", "bar", "baz"] `shouldParseAs` List [String "foo", String "bar", String "baz"]++    it "parses tuples" $ do+      show ("foo", "bar", "baz") `shouldParseAs` Tuple [String "foo", String "bar", String "baz"]++    it "parses Nothing" $ do+      show (Nothing :: Maybe Int) `shouldParseAs` Constructor "Nothing" []++    it "parses Just" $ do+      show (Just "foo") `shouldParseAs` Constructor "Just" [String "foo"]++    it "parses nested Just" $ do+      show (Just $ Just "foo") `shouldParseAs` Constructor "Just" [parentheses (Constructor "Just" [String "foo"])]++    it "parses records" $ do+      show person `shouldParseAs` Record "Person" [+          ("personName", String "Joe")+        , ("personAge", Number "23")+        , ("personAddress", Constructor "Just" [Tuple [Record "Address" [+            ("addressStreet", String "Main Street")+          , ("addressPostalCode", Number "50000")+          ]]])+        ]++    context "with deeply nested data structures" $ do+      it "completes in O(n) time" $ do+        let+          input = show (+            "0", (+            "1", (+            "2", (+            "3", (+            "4", (+            "5", (+            "6", (+            "7", (+            "8", (+            "9", (+            "10", (+            "11", (+            "12", (+            "13", (+            "14", (+            "15", (+            "16", (+            "17", (+            "18", (+            "19", (+            "20", (+            "21", (+            "22", (+            "23", (+            "24", (+            "25", (+            "26", (+            "27", (+            "28", (+            "29", (+            )))))))))))))))))))))))))))))))+        r <- timeout 1 $ evaluate (parseValue input)+        (join r :: Maybe Value) `shouldSatisfy` isJust
+ test/Test/Hspec/Core/Formatters/Pretty/UnicodeSpec.hs view
@@ -0,0 +1,16 @@+module Test.Hspec.Core.Formatters.Pretty.UnicodeSpec (spec) where++import           Prelude ()+import           Helper++import           Test.Hspec.Core.Formatters.Pretty.Unicode++spec :: Spec+spec = do+  describe "ushow" $ do+    it "retains unicode characters" $ do+      ushow "foo-\955-bar" `shouldBe` "\"foo-\955-bar\""++    it "is inverted by read" $ do+      property $ \ xs ->+        read (ushow xs) `shouldBe` xs
+ test/Test/Hspec/Core/Formatters/PrettySpec.hs view
@@ -0,0 +1,158 @@+module Test.Hspec.Core.Formatters.PrettySpec (spec) where++import           Prelude ()+import           Helper++import           Test.Hspec.Core.Formatters.Pretty.ParserSpec hiding (spec)++import           Test.Hspec.Core.Formatters.Pretty++spec :: Spec+spec = do+  describe "pretty2" $ do+    context "with single-line string literals" $ do+      context "with --unicode" $ do+        it "recovers unicode" $ do+          pretty2 True (show "foo\955bar") (show "foo-bar") `shouldBe` ("\"foo\955bar\"", "\"foo-bar\"")++      context "with --no-unicode" $ do+        it "does not recover unicode" $ do+          pretty2 False (show "foo\955bar") (show "foo-bar") `shouldBe` ("\"foo\\955bar\"", "\"foo-bar\"")++      context "when expected and actual would be equal after pretty-printing" $ do+        it "returns the original values unmodified" $ do+          pretty2 True (show "foo") (show "foo" <> "   ") `shouldBe` (show "foo", show "foo" <> "   ")++  describe "recoverString" $ do+    it "recovers a string" $ do+      recoverString (show "foo") `shouldBe` Just "foo"++    it "recovers the empty string" $ do+      recoverString (show "") `shouldBe` Just ""++    it "does not recover a string with leading space" $ do+      recoverString ("   " <> show "foo") `shouldBe` Nothing++    it "does not recover a string with trailing space" $ do+      recoverString (show "foo" <> "   ") `shouldBe` Nothing++    it "does not recover an empty list" $ do+      recoverString "[]" `shouldBe` Nothing++  describe "recoverMultiLineString" $ do+    let+      multiLineString :: String+      multiLineString = "foo\nbar\nbaz\n"++    it "recovers multi-line string literals" $ do+      recoverMultiLineString True (show multiLineString) `shouldBe` Just multiLineString++    it "does not recover string literals that contain control characters" $ do+      recoverMultiLineString True (show "foo\n\tbar\nbaz\n") `shouldBe` Nothing++    it "does not recover string literals that span a single line" $ do+      recoverMultiLineString True (show "foo\n") `shouldBe` Nothing++    it "does not recover a string with trailing space" $ do+      recoverMultiLineString True ("   " <> show multiLineString) `shouldBe` Nothing++    it "does not recover a string with trailing space" $ do+      recoverMultiLineString True (show multiLineString <> "   ") `shouldBe` Nothing++    context "when unicode is True" $ do+      it "recovers string literals that contain unicode" $ do+        recoverMultiLineString True (show "foo\n\955\nbaz\n") `shouldBe` Just "foo\n\955\nbaz\n"++    context "when unicode is False" $ do+      it "does not recover string literals that contain unicode" $ do+        recoverMultiLineString False (show "foo\n\955\nbaz\n") `shouldBe` Nothing++  describe "pretty" $ do+    it "pretty-prints records" $ do+      pretty True (show person) `shouldBe` just [+          "Person {"+        , "  personName = \"Joe\","+        , "  personAge = 23,"+        , "  personAddress = Just Address {"+        , "    addressStreet = \"Main Street\","+        , "    addressPostalCode = 50000"+        , "  }"+        , "}"+        ]++    it "pretty-prints Just-values" $ do+      pretty True (show $ Just person) `shouldBe` just [+          "Just Person {"+        , "  personName = \"Joe\","+        , "  personAge = 23,"+        , "  personAddress = Just Address {"+        , "    addressStreet = \"Main Street\","+        , "    addressPostalCode = 50000"+        , "  }"+        , "}"+        ]++    it "pretty-prints tuples" $ do+      pretty True (show (person, -0.5 :: Rational)) `shouldBe` just [+          "(Person {"+        , "  personName = \"Joe\","+        , "  personAge = 23,"+        , "  personAddress = Just Address {"+        , "    addressStreet = \"Main Street\","+        , "    addressPostalCode = 50000"+        , "  }"+        , "}, (-1) % 2)"+        ]++    it "pretty-prints lists" $ do+      pretty True (show [Just person, Nothing]) `shouldBe` just [+          "[Just Person {"+        , "  personName = \"Joe\","+        , "  personAge = 23,"+        , "  personAddress = Just Address {"+        , "    addressStreet = \"Main Street\","+        , "    addressPostalCode = 50000"+        , "  }"+        , "}, Nothing]"+        ]++    context "with --unicode" $ do+      it "retains unicode characters in record fields" $ do+        pretty True (show $ Person "λ-Joe" 23 Nothing) `shouldBe` just [+            "Person {"+          , "  personName = \"λ-Joe\","+          , "  personAge = 23,"+          , "  personAddress = Nothing"+          , "}"+          ]++      it "retains unicode characters in list elements" $ do+        pretty True (show ["foo", "λ", "bar"]) `shouldBe` just ["[\"foo\", \"λ\", \"bar\"]"]++    context "with --no-unicode" $ do+      it "does not retain unicode characters in record fields" $ do+        pretty False (show $ Person "λ-Joe" 23 Nothing) `shouldBe` just [+            "Person {"+          , "  personName = \"\\955-Joe\","+          , "  personAge = 23,"+          , "  personAddress = Nothing"+          , "}"+          ]++      it "does not retain unicode characters in list elements" $ do+        pretty False (show ["foo", "λ", "bar"]) `shouldBe` just ["[\"foo\", \"\\955\", \"bar\"]"]++    context "with input that looks like a list" $ do+      it "it returns Nothing" $ do+        pretty True "[23,42]" `shouldBe` Nothing++    context "with input that looks like a tuple" $ do+      it "it returns Nothing" $ do+        pretty True "(23,42)" `shouldBe` Nothing++    context "with input that looks like function applications" $ do+      it "it returns Nothing" $ do+        let input = unlines ["foo", "bar", "baz"]+        pretty True input `shouldBe` Nothing+  where+    just = Just . intercalate "\n"
+ test/Test/Hspec/Core/Formatters/V1Spec.hs view
@@ -0,0 +1,307 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-}+module Test.Hspec.Core.Formatters.V1Spec (spec) where++import           Prelude ()+import           Helper hiding (colorize)+import           Data.String+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Writer hiding (pass)++import qualified Test.Hspec.Core.Spec as H+import qualified Test.Hspec.Core.Runner as H+import qualified Test.Hspec.Core.Formatters.V1 as H hiding (FailureReason(..))+import qualified Test.Hspec.Core.Formatters.V1.Monad as H (interpretWith)+import           Test.Hspec.Core.Formatters.V1.Monad (FormatM, Environment(..), FailureRecord(..), FailureReason(..))++data ColorizedText =+    Plain String+  | Transient String+  | Info String+  | Succeeded String+  | Failed String+  | Pending String+  | Extra String+  | Missing String+  deriving (Eq, Show)++instance IsString ColorizedText where+  fromString = Plain++removeColors :: [ColorizedText] -> String+removeColors input = case input of+  Plain x : xs -> x ++ removeColors xs+  Transient _ : xs -> removeColors xs+  Info x : xs -> x ++ removeColors xs+  Succeeded x : xs -> x ++ removeColors xs+  Failed x : xs -> x ++ removeColors xs+  Pending x : xs -> x ++ removeColors xs+  Extra x : xs -> x ++ removeColors xs+  Missing x : xs -> x ++ removeColors xs+  [] -> ""++simplify :: [ColorizedText] -> [ColorizedText]+simplify input = case input of+  Plain xs : Plain ys : zs -> simplify (Plain (xs ++ ys) : zs)+  Extra xs : Extra ys : zs -> simplify (Extra (xs ++ ys) : zs)+  Missing xs : Missing ys : zs -> simplify (Missing (xs ++ ys) : zs)+  x : xs -> x : simplify xs+  [] -> []++colorize :: (String -> ColorizedText) -> [ColorizedText] -> [ColorizedText]+colorize color input = case simplify input of+  Plain x : xs -> color x : xs+  xs -> xs++interpret :: FormatM a -> IO [ColorizedText]+interpret = interpretWith environment++interpretWith :: Environment (WriterT [ColorizedText] IO) -> FormatM a -> IO [ColorizedText]+interpretWith env = fmap simplify . execWriterT . H.interpretWith env++environment :: Environment (WriterT [ColorizedText] IO)+environment = Environment {+  environmentGetSuccessCount = return 0+, environmentGetPendingCount = return 0+, environmentGetFailMessages = return []+, environmentUsedSeed = return 0+, environmentGetCPUTime = return Nothing+, environmentGetRealTime = return 0+, environmentWrite = tell . return . Plain+, environmentWriteTransient = tell . return . Transient+, environmentWithFailColor = \ action -> do+    (a, r) <- liftIO $ runWriterT action+    tell (colorize Failed r) >> return a+, environmentWithSuccessColor = \ action -> do+    (a, r) <- liftIO $ runWriterT action+    tell (colorize Succeeded r) >> return a+, environmentWithPendingColor = \ action -> do+    (a, r) <- liftIO $ runWriterT action+    tell (colorize Pending r) >> return a+, environmentWithInfoColor = \ action -> do+    (a, r) <- liftIO $ runWriterT action+    tell (colorize Info r) >> return a+, environmentUseDiff = return True+, environmentPrintTimes = return False+, environmentExtraChunk = tell . return . Extra+, environmentMissingChunk = tell . return . Missing+, environmentLiftIO = liftIO+}++testSpec :: H.Spec+testSpec = do+  H.describe "Example" $ do+    H.it "success"    (H.Result "" H.Success)+    H.it "fail 1"     (H.Result "" $ H.Failure Nothing $ H.Reason "fail message")+    H.it "pending"    (H.pendingWith "pending message")+    H.it "fail 2"     (H.Result "" $ H.Failure Nothing H.NoReason)+    H.it "exceptions" (undefined :: H.Result)+    H.it "fail 3"     (H.Result "" $ H.Failure Nothing H.NoReason)++spec :: Spec+spec = do+  describe "progress" $ do+    let formatter = H.progress++    describe "exampleSucceeded" $ do+      it "marks succeeding examples with ." $ do+        interpret (H.exampleSucceeded formatter undefined undefined) `shouldReturn` [+            Succeeded "."+          ]++    describe "exampleFailed" $ do+      it "marks failing examples with F" $ do+        interpret (H.exampleFailed formatter undefined undefined undefined) `shouldReturn` [+            Failed "F"+          ]++    describe "examplePending" $ do+      it "marks pending examples with ." $ do+        interpret (H.examplePending formatter undefined undefined undefined) `shouldReturn` [+            Pending "."+          ]++  describe "specdoc" $ do+    let+      formatter = H.specdoc+      runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormatter = Just formatter}++    it "displays a header for each thing being described" $ do+      _:x:_ <- runSpec testSpec+      x `shouldBe` "Example"++    it "displays one row for each behavior" $ do+      r <- runSpec $ do+        H.describe "List as a Monoid" $ do+          H.describe "mappend" $ do+            H.it "is associative" True+          H.describe "mempty" $ do+            H.it "is a left identity" True+            H.it "is a right identity" True+        H.describe "Maybe as a Monoid" $ do+          H.describe "mappend" $ do+            H.it "is associative" True+          H.describe "mempty" $ do+            H.it "is a left identity" True+            H.it "is a right identity" True+      normalizeSummary r `shouldBe` [+          ""+        , "List as a Monoid"+        , "  mappend"+        , "    is associative"+        , "  mempty"+        , "    is a left identity"+        , "    is a right identity"+        , "Maybe as a Monoid"+        , "  mappend"+        , "    is associative"+        , "  mempty"+        , "    is a left identity"+        , "    is a right identity"+        , ""+        , "Finished in 0.0000 seconds"+        , "6 examples, 0 failures"+        ]++    it "outputs an empty line at the beginning (even for non-nested specs)" $ do+      r <- runSpec $ do+        H.it "example 1" True+        H.it "example 2" True+      normalizeSummary r `shouldBe` [+          ""+        , "example 1"+        , "example 2"+        , ""+        , "Finished in 0.0000 seconds"+        , "2 examples, 0 failures"+        ]++    it "displays a row for each successful, failed, or pending example" $ do+      r <- runSpec testSpec+      r `shouldSatisfy` any (== "  fail 1 FAILED [1]")+      r `shouldSatisfy` any (== "  success")++    it "displays a '#' with an additional message for pending examples" $ do+      r <- runSpec testSpec+      r `shouldSatisfy` any (== "    # PENDING: pending message")++    context "with an empty group" $ do+      it "omits that group from the report" $ do+        r <- runSpec $ do+          H.describe "foo" $ do+            H.it "example 1" True+          H.describe "bar" $ do+            pass+          H.describe "baz" $ do+            H.it "example 2" True++        normalizeSummary r `shouldBe` [+            ""+          , "foo"+          , "  example 1"+          , "baz"+          , "  example 2"+          , ""+          , "Finished in 0.0000 seconds"+          , "2 examples, 0 failures"+          ]++    describe "failedFormatter" $ do+      let action = H.failedFormatter formatter++      context "when actual/expected contain newlines" $ do+        let+          env = environment {+            environmentGetFailMessages = return [FailureRecord Nothing ([], "") (ExpectedButGot Nothing "first\nsecond\nthird" "first\ntwo\nthird")]+            }+        it "adds indentation" $ do+          (removeColors <$> interpretWith env action) `shouldReturn` unlines [+              ""+            , "Failures:"+            , ""+            , "  1) "+            , "       expected: first"+            , "                 second"+            , "                 third"+            , "        but got: first"+            , "                 two"+            , "                 third"+            , ""+            , "  To rerun use: --match \"//\""+            , ""+            , "Randomized with seed 0"+            , ""+            ]++    describe "footerFormatter" $ do+      let action = H.footerFormatter formatter++      context "without failures" $ do+        let env = environment {environmentGetSuccessCount = return 1}+        it "shows summary in green if there are no failures" $ do+          interpretWith env action `shouldReturn` [+              "Finished in 0.0000 seconds\n"+            , Succeeded "1 example, 0 failures\n"+            ]++      context "with pending examples" $ do+        let env = environment {environmentGetPendingCount = return 1}+        it "shows summary in yellow if there are pending examples" $ do+          interpretWith env action `shouldReturn` [+              "Finished in 0.0000 seconds\n"+            , Pending "1 example, 0 failures, 1 pending\n"+            ]++      context "with failures" $ do+        let env = environment {environmentGetFailMessages = return [undefined]}+        it "shows summary in red" $ do+          interpretWith env action `shouldReturn` [+              "Finished in 0.0000 seconds\n"+            , Failed "1 example, 1 failure\n"+            ]++      context "with both failures and pending examples" $ do+        let env = environment {environmentGetFailMessages = return [undefined], environmentGetPendingCount = return 1}+        it "shows summary in red" $ do+          interpretWith env action `shouldReturn` [+              "Finished in 0.0000 seconds\n"+            , Failed "2 examples, 1 failure, 1 pending\n"+            ]++    context "same as failed_examples" $ do+      failed_examplesSpec formatter++failed_examplesSpec :: H.Formatter -> Spec+failed_examplesSpec formatter = do+  let runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormatter = Just formatter}++  context "displays a detailed list of failures" $ do+    it "prints all requirements that are not met" $ do+      r <- runSpec testSpec+      r `shouldSatisfy` any (== "  1) Example fail 1")++    it "prints the exception type for requirements that fail due to an uncaught exception" $ do+      r <- runSpec $ do+        H.it "foobar" (throw (ErrorCall "baz") :: Bool)+      r `shouldContain` [+          "  1) foobar"+        , "       uncaught exception: ErrorCall"+        , "       baz"+        ]++    it "prints all descriptions when a nested requirement fails" $ do+      r <- runSpec $+        H.describe "foo" $ do+          H.describe "bar" $ do+            H.it "baz" False+      r `shouldSatisfy` any (== "  1) foo.bar baz")+++    context "when a failed example has a source location" $ do+      it "includes that source location above the error message" $ do+        let loc = H.Location "test/FooSpec.hs" 23 4+            addLoc e = e {H.itemLocation = Just loc}+        r <- runSpec $ H.mapSpecItem_ addLoc $ do+          H.it "foo" False+        r `shouldContain` ["  test/FooSpec.hs:23:4: ", "  1) foo"]
+ test/Test/Hspec/Core/Formatters/V2Spec.hs view
@@ -0,0 +1,294 @@+{-# OPTIONS_GHC -fno-warn-deprecations #-}+module Test.Hspec.Core.Formatters.V2Spec (spec) where++import           Prelude ()+import           Helper++import qualified Test.Hspec.Core.Spec as H+import qualified Test.Hspec.Core.Spec as Spec+import qualified Test.Hspec.Core.Runner as H+import           Test.Hspec.Core.Format+import           Test.Hspec.Core.Formatters.V2++testSpec :: H.Spec+testSpec = do+  H.describe "Example" $ do+    H.it "success"    (H.Result "" Spec.Success)+    H.it "fail 1"     (H.Result "" $ Spec.Failure Nothing $ H.Reason "fail message")+    H.it "pending"    (H.pendingWith "pending message")+    H.it "fail 2"     (H.Result "" $ Spec.Failure Nothing H.NoReason)+    H.it "exceptions" (undefined :: Spec.Result)+    H.it "fail 3"     (H.Result "" $ Spec.Failure Nothing H.NoReason)++formatConfig :: FormatConfig+formatConfig = defaultFormatConfig {+  formatConfigOutputUnicode = unicode+, formatConfigUseDiff = True+, formatConfigDiffContext = Just 3+, formatConfigExternalDiff = Nothing+, formatConfigPrettyPrint = True+, formatConfigPrettyPrintFunction = Just (H.configPrettyPrintFunction H.defaultConfig unicode)+} where+    unicode = True++runSpecWith :: Formatter -> H.Spec -> IO [String]+runSpecWith formatter = captureLines . H.hspecWithResult H.defaultConfig {H.configFormat = Just $ formatterToFormat formatter}++spec :: Spec+spec = do+  describe "progress" $ do+    let item = ItemDone ([], "") . Item Nothing 0 ""+    describe "formatterItemDone" $ do+      it "marks succeeding examples with ." $ do+        formatter <- formatterToFormat progress formatConfig+        captureLines (formatter $ item Success)+          `shouldReturn` ["."]++      it "marks failing examples with F" $ do+        formatter <- formatterToFormat progress formatConfig+        captureLines (formatter . item $ Failure Nothing NoReason)+          `shouldReturn` ["F"]++      it "marks pending examples with ." $ do+        formatter <- formatterToFormat progress formatConfig+        captureLines (formatter . item $ Pending Nothing Nothing)+          `shouldReturn` ["."]++  describe "checks" $ do+    let+      formatter = checks+      config = H.defaultConfig { H.configFormat = Just $ formatterToFormat formatter }++    it "prints unicode check marks" $ do+      r <- captureLines . H.hspecWithResult config $ do+        H.it "foo" True+      normalizeSummary r `shouldBe` [+          ""+        , "foo [✔]"+        , ""+        , "Finished in 0.0000 seconds"+        , "1 example, 0 failures"+        ]++    it "uses ASCII as a fallback" $ do+      r <- captureLines . H.hspecWithResult config { H.configUnicodeMode = H.UnicodeNever } $ do+        H.it "foo" True+      normalizeSummary r `shouldBe` [+          ""+        , "foo [v]"+        , ""+        , "Finished in 0.0000 seconds"+        , "1 example, 0 failures"+        ]++  describe "specdoc" $ do++    let runSpec = runSpecWith specdoc++    it "displays a header for each thing being described" $ do+      _:x:_ <- runSpec testSpec+      x `shouldBe` "Example"++    it "displays one row for each behavior" $ do+      r <- runSpec $ do+        H.describe "List as a Monoid" $ do+          H.describe "mappend" $ do+            H.it "is associative" True+          H.describe "mempty" $ do+            H.it "is a left identity" True+            H.it "is a right identity" True+        H.describe "Maybe as a Monoid" $ do+          H.describe "mappend" $ do+            H.it "is associative" True+          H.describe "mempty" $ do+            H.it "is a left identity" True+            H.it "is a right identity" True+      normalizeSummary r `shouldBe` [+          ""+        , "List as a Monoid"+        , "  mappend"+        , "    is associative"+        , "  mempty"+        , "    is a left identity"+        , "    is a right identity"+        , "Maybe as a Monoid"+        , "  mappend"+        , "    is associative"+        , "  mempty"+        , "    is a left identity"+        , "    is a right identity"+        , ""+        , "Finished in 0.0000 seconds"+        , "6 examples, 0 failures"+        ]++    it "outputs an empty line at the beginning (even for non-nested specs)" $ do+      r <- runSpec $ do+        H.it "example 1" True+        H.it "example 2" True+      normalizeSummary r `shouldBe` [+          ""+        , "example 1"+        , "example 2"+        , ""+        , "Finished in 0.0000 seconds"+        , "2 examples, 0 failures"+        ]++    it "displays a row for each successful, failed, or pending example" $ do+      r <- runSpec testSpec+      r `shouldSatisfy` any (== "  fail 1 FAILED [1]")+      r `shouldSatisfy` any (== "  success")++    it "displays a '#' with an additional message for pending examples" $ do+      r <- runSpec testSpec+      r `shouldSatisfy` any (== "    # PENDING: pending message")++    context "with an empty group" $ do+      it "omits that group from the report" $ do+        r <- runSpec $ do+          H.describe "foo" $ do+            H.it "example 1" True+          H.describe "bar" $ do+            pass+          H.describe "baz" $ do+            H.it "example 2" True++        normalizeSummary r `shouldBe` [+            ""+          , "foo"+          , "  example 1"+          , "baz"+          , "  example 2"+          , ""+          , "Finished in 0.0000 seconds"+          , "2 examples, 0 failures"+          ]++    describe "formatterDone" $ do+      let expectedButGot expected actual = ItemDone ([], "") . Item Nothing 0 "" $ Failure Nothing $ ExpectedButGot Nothing expected actual++      it "recovers unicode from ExpectedButGot" $ do+        formatter <- formatterToFormat failed_examples formatConfig { formatConfigOutputUnicode = True }+        formatter $ expectedButGot (show "\955") (show "\956")+        (fmap normalizeSummary . captureLines) (formatter $ Done []) `shouldReturn` [+            ""+          , "Failures:"+          , ""+          , "  1) "+          , "       expected: \"λ\""+          , "        but got: \"μ\""+          , ""+          , "  To rerun use: --match \"//\" --seed 0"+          , ""+          , "Randomized with seed 0"+          , ""+          , "Finished in 0.0000 seconds"+          , "1 example, 1 failure"+          ]++      context "on --expert" $ do+        it "does not print rerun message" $ do+          formatter <- formatterToFormat failed_examples formatConfig { formatConfigExpertMode = True }+          formatter $ expectedButGot "foo" "bar"+          (fmap normalizeSummary . captureLines) (formatter $ Done []) `shouldReturn` [+              ""+            , "Failures:"+            , ""+            , "  1) "+            , "       expected: foo"+            , "        but got: bar"+            , ""+            , "Randomized with seed 0"+            , ""+            , "Finished in 0.0000 seconds"+            , "1 example, 1 failure"+            ]++      context "when actual/expected contain newlines" $ do+        it "adds indentation" $ do+          formatter <- formatterToFormat failed_examples formatConfig+          formatter $ expectedButGot "first\nsecond\nthird" "first\ntwo\nthird"+          (fmap normalizeSummary . captureLines) (formatter $ Done []) `shouldReturn` [+              ""+            , "Failures:"+            , ""+            , "  1) "+            , "       expected: first"+            , "                 second"+            , "                 third"+            , "        but got: first"+            , "                 two"+            , "                 third"+            , ""+            , "  To rerun use: --match \"//\" --seed 0"+            , ""+            , "Randomized with seed 0"+            , ""+            , "Finished in 0.0000 seconds"+            , "1 example, 1 failure"+            ]++      context "without failures" $ do+        it "shows summary in green if there are no failures" $ do+          formatter <- formatterToFormat failed_examples formatConfig+          formatter . ItemDone ([], "") . Item Nothing 0 "" $ Success+          (fmap normalizeSummary . captureLines) (formatter $ Done []) `shouldReturn` [+              ""+            , "Finished in 0.0000 seconds"+            , "1 example, 0 failures"+            ]++      context "with pending examples" $ do+        it "shows summary in yellow if there are pending examples" $ do+          formatter <- formatterToFormat failed_examples formatConfig+          formatter . ItemDone ([], "") . Item Nothing 0 "" $ Pending Nothing Nothing+          (fmap normalizeSummary . captureLines) (formatter $ Done []) `shouldReturn` [+              ""+            , "Finished in 0.0000 seconds"+            , "1 example, 0 failures, 1 pending"+            ]++    context "same as failed_examples" $ do+      failed_examplesSpec specdoc++  describe "getExpectedTotalCount" $ do+    let formatter = silent { formatterStarted = fmap show getExpectedTotalCount >>= writeLine }+        runSpec = runSpecWith formatter+    it "returns the total number of spec items" $ do+      result:_ <- runSpec testSpec+      result `shouldBe` "6"++failed_examplesSpec :: Formatter -> Spec+failed_examplesSpec formatter = do+  let runSpec = runSpecWith formatter++  context "displays a detailed list of failures" $ do+    it "prints all requirements that are not met" $ do+      r <- runSpec testSpec+      r `shouldSatisfy` any (== "  1) Example fail 1")++    it "prints the exception type for requirements that fail due to an uncaught exception" $ do+      r <- runSpec $ do+        H.it "foobar" (throw (ErrorCall "baz") :: Bool)+      r `shouldContain` [+          "  1) foobar"+        , "       uncaught exception: ErrorCall"+        , "       baz"+        ]++    it "prints all descriptions when a nested requirement fails" $ do+      r <- runSpec $+        H.describe "foo" $ do+          H.describe "bar" $ do+            H.it "baz" False+      r `shouldSatisfy` any (== "  1) foo.bar baz")+++    context "when a failed example has a source location" $ do+      it "includes that source location above the error message" $ do+        let loc = H.Location "test/FooSpec.hs" 23 4+            addLoc e = e {Spec.itemLocation = Just loc}+        r <- runSpec $ H.mapSpecItem_ addLoc $ do+          H.it "foo" False+        r `shouldContain` ["  test/FooSpec.hs:23:4: ", "  1) foo"]
− test/Test/Hspec/Core/FormattersSpec.hs 
@@ -1,236 +0,0 @@-{-# LANGUAGE CPP #-}-module Test.Hspec.Core.FormattersSpec (main, spec) where--import           Prelude ()-import           Helper-import qualified Control.Exception as E--import qualified Test.Hspec.Core.Spec as H-import qualified Test.Hspec.Core.Runner as H-import qualified Test.Hspec.Core.Formatters as H--#ifndef mingw32_HOST_OS-import           System.Console.ANSI-#endif--main :: IO ()-main = hspec spec--testSpec :: H.Spec-testSpec = do-  H.describe "Example" $ do-    H.it "success"    (H.Success)-    H.it "fail 1"     (H.Fail Nothing "fail message")-    H.it "pending"    (H.pendingWith "pending message")-    H.it "fail 2"     (H.Fail Nothing "")-    H.it "exceptions" (undefined :: H.Result)-    H.it "fail 3"     (H.Fail Nothing "")--spec :: Spec-spec = do-  describe "silent" $ do-    let runSpec = fmap fst . capture . H.hspecWithResult H.defaultConfig {H.configFormatter = Just H.silent}-    it "produces no output" $ do-      runSpec testSpec `shouldReturn` ""--  describe "failed_examples" $ do-    failed_examplesSpec H.failed_examples--  describe "progress" $ do-    let runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormatter = Just H.progress}--    it "produces '..F...FF.F' style output" $ do-      r <- runSpec testSpec-      head r `shouldBe` ".F.FFF"--    context "same as failed_examples" $ do-      failed_examplesSpec H.progress--  describe "specdoc" $ do-    let runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormatter = Just H.specdoc}--    it "displays a header for each thing being described" $ do-      _:x:_ <- runSpec testSpec-      x `shouldBe` "Example"--    it "displays one row for each behavior" $ do-      r <- runSpec $ do-        H.describe "List as a Monoid" $ do-          H.describe "mappend" $ do-            H.it "is associative" True-          H.describe "mempty" $ do-            H.it "is a left identity" True-            H.it "is a right identity" True-        H.describe "Maybe as a Monoid" $ do-          H.describe "mappend" $ do-            H.it "is associative" True-          H.describe "mempty" $ do-            H.it "is a left identity" True-            H.it "is a right identity" True-      normalizeSummary r `shouldBe` [-          ""-        , "List as a Monoid"-        , "  mappend"-        , "    is associative"-        , "  mempty"-        , "    is a left identity"-        , "    is a right identity"-        , "Maybe as a Monoid"-        , "  mappend"-        , "    is associative"-        , "  mempty"-        , "    is a left identity"-        , "    is a right identity"-        , ""-        , "Finished in 0.0000 seconds"-        , "6 examples, 0 failures"-        ]--    it "outputs an empty line at the beginning (even for non-nested specs)" $ do-      r <- runSpec $ do-        H.it "example 1" True-        H.it "example 2" True-      normalizeSummary r `shouldBe` [-          ""-        , "example 1"-        , "example 2"-        , ""-        , "Finished in 0.0000 seconds"-        , "2 examples, 0 failures"-        ]--    it "displays a row for each successfull, failed, or pending example" $ do-      r <- runSpec testSpec-      r `shouldSatisfy` any (== "  fail 1 FAILED [1]")-      r `shouldSatisfy` any (== "  success")--    it "displays a '#' with an additional message for pending examples" $ do-      r <- runSpec testSpec-      r `shouldSatisfy` any (== "     # PENDING: pending message")--    context "with an empty group" $ do-      it "omits that group from the report" $ do-        r <- runSpec $ do-          H.describe "foo" $ do-            H.it "example 1" True-          H.describe "bar" $ do-            return ()-          H.describe "baz" $ do-            H.it "example 2" True--        normalizeSummary r `shouldBe` [-            ""-          , "foo"-          , "  example 1"-          , "baz"-          , "  example 2"-          , ""-          , "Finished in 0.0000 seconds"-          , "2 examples, 0 failures"-          ]--    context "same as failed_examples" $ do-      failed_examplesSpec H.progress--failed_examplesSpec :: H.Formatter -> Spec-failed_examplesSpec formatter = do-  let runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormatter = Just formatter}--  it "summarizes the time it takes to finish" $ do-    r <- runSpec (return ())-    normalizeSummary r `shouldSatisfy` any (== "Finished in 0.0000 seconds")--  context "displays a detailed list of failures" $ do-    it "prints all requirements that are not met" $ do-      r <- runSpec testSpec-      r `shouldSatisfy` any (== "  1) Example fail 1")--    it "prints the exception type for requirements that fail due to an uncaught exception" $ do-      r <- runSpec $ do-        H.it "foobar" (E.throw (E.ErrorCall "baz") :: Bool)-      r `shouldContain` [-          "  1) foobar"-        , "       uncaught exception: ErrorCall (baz)"-        ]--    it "prints all descriptions when a nested requirement fails" $ do-      r <- runSpec $-        H.describe "foo" $ do-          H.describe "bar" $ do-            H.it "baz" False-      r `shouldSatisfy` any (== "  1) foo.bar baz")---    context "when a failed example has a source location" $ do-      let bestEffortExplanation = "Source locations marked with \"best-effort\" are calculated heuristically and may be incorrect."--      it "includes the source locations above the error messages" $ do-        let loc = H.Location "test/FooSpec.hs" 23 0 H.ExactLocation-            addLoc e = e {H.itemLocation = Just loc}-        r <- runSpec $ H.mapSpecItem_ addLoc $ do-          H.it "foo" False-        r `shouldContain` ["  test/FooSpec.hs:23: ", "  1) foo"]--      context "when source location is exact" $ do-        it "includes that source locations" $ do-          let loc = H.Location "test/FooSpec.hs" 23 0 H.ExactLocation-              addLoc e = e {H.itemLocation = Just loc}-          r <- runSpec $ H.mapSpecItem_ addLoc $ do-            H.it "foo" False-          r `shouldSatisfy` any (== "  test/FooSpec.hs:23: ")--        it "does not include 'best-effort' explanation" $ do-          let loc = H.Location "test/FooSpec.hs" 23 0 H.ExactLocation-              addLoc e = e {H.itemLocation = Just loc}-          r <- runSpec $ H.mapSpecItem_ addLoc $ do-            H.it "foo" False-          r `shouldSatisfy` all (/= bestEffortExplanation)--      context "when source location is best-effort" $ do-        it "marks that source location as 'best-effort'" $ do-          let loc = H.Location "test/FooSpec.hs" 23 0 H.BestEffort-              addLoc e = e {H.itemLocation = Just loc}-          r <- runSpec $ H.mapSpecItem_ addLoc $ do-            H.it "foo" False-          r `shouldSatisfy` any (== "  test/FooSpec.hs:23: (best-effort)")--        it "includes 'best-effort' explanation" $ do-          let loc = H.Location "test/FooSpec.hs" 23 0 H.BestEffort-              addLoc e = e {H.itemLocation = Just loc}-          r <- runSpec $ H.mapSpecItem_ addLoc $ do-            H.it "foo" False-          r `shouldSatisfy` any (== bestEffortExplanation)--  it "summarizes the number of examples and failures" $ do-    r <- runSpec testSpec-    r `shouldSatisfy` any (== "6 examples, 4 failures, 1 pending")--  -- Windows has no support for ANSI escape codes.  The Console API is used for-  -- colorized output, hence the following tests do not work on Windows.-#ifndef mingw32_HOST_OS-  it "shows summary in green if there are no failures" $ do-    r <- captureLines $ H.hspecWithResult H.defaultConfig {H.configColorMode = H.ColorAlways} $ do-      H.it "foobar" True-    r `shouldSatisfy` any (== (green ++ "1 example, 0 failures" ++ reset))--  it "shows summary in yellow if there are pending examples" $ do-    r <- captureLines $ H.hspecWithResult H.defaultConfig {H.configColorMode = H.ColorAlways} $ do-      H.it "foobar" H.pending-    r `shouldSatisfy` any (== (yellow ++ "1 example, 0 failures, 1 pending" ++ reset))--  it "shows summary in red if there are failures" $ do-    r <- captureLines $ H.hspecWithResult H.defaultConfig {H.configColorMode = H.ColorAlways} $ do-      H.it "foobar" False-    r `shouldSatisfy` any (== (red ++ "1 example, 1 failure" ++ reset))--  it "shows summary in red if there are both failures and pending examples" $ do-    r <- captureLines $ H.hspecWithResult H.defaultConfig {H.configColorMode = H.ColorAlways} $ do-      H.it "foo" False-      H.it "bar" H.pending-    r `shouldSatisfy` any (== (red ++ "2 examples, 1 failure, 1 pending" ++ reset))-  where-    green  = setSGRCode [SetColor Foreground Dull Green]-    yellow = setSGRCode [SetColor Foreground Dull Yellow]-    red    = setSGRCode [SetColor Foreground Dull Red]-    reset  = setSGRCode [Reset]-#endif
test/Test/Hspec/Core/HooksSpec.hs view
@@ -1,20 +1,45 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-}-module Test.Hspec.Core.HooksSpec (main, spec) where+module Test.Hspec.Core.HooksSpec (spec) where  import           Prelude () import           Helper+import           Mock -import qualified Test.Hspec.Core.Spec as H import qualified Test.Hspec.Core.Runner as H+import qualified Test.Hspec.Core.Spec as H+import           Test.Hspec.Core.Format+import           Test.Hspec.Core.Runner.Eval  import qualified Test.Hspec.Core.Hooks as H -main :: IO ()-main = hspec spec+evalSpec_ :: H.Spec -> IO ()+evalSpec_ = void . evalSpec -runSilent :: H.Spec -> IO ()-runSilent = silence . H.hspec +evalSpec :: H.Spec -> IO [([String], Item)]+evalSpec = fmap normalize . (toEvalForest >=> runFormatter config)+  where+    config = EvalConfig {+      evalConfigFormat = \ _ -> pass+    , evalConfigConcurrentJobs = 1+    , evalConfigFailFast = False+    , evalConfigColorMode = ColorEnabled+    }+    normalize = map $ \ (path, item) -> (pathToList path, normalizeItem item)+    normalizeItem item = item {+      itemLocation = Nothing+    , itemDuration = 0+    , itemResult = case itemResult item of+        Success -> Success+        Pending _  reason -> Pending Nothing reason+        Failure _  reason -> Failure Nothing reason+    }+    pathToList (xs, x) = xs ++ [x]++toEvalForest :: H.SpecWith () -> IO [EvalTree]+toEvalForest = fmap (uncurry (H.specToEvalForest 0) . first (($ H.defaultConfig) . appEndo)) . H.runSpecM+ mkAppend :: IO (String -> IO (), IO [String]) mkAppend = do   ref <- newIORef ([] :: [String])@@ -26,32 +51,24 @@   describe "before" $ do     it "runs an action before every spec item" $ do       (rec, retrieve) <- mkAppend-      runSilent $ H.before (rec "before" >> return "value") $ do+      evalSpec_ $ H.before (rec "before" >> return "value") $ do         H.it "foo" $ \value -> do           rec (value ++ " foo")         H.it "bar" $ \value -> do           rec (value ++ " bar")       retrieve `shouldReturn` ["before", "value foo", "before", "value bar"] -    context "when used multiple times" $ do-      it "is evaluated outside in" $ do-        pending-     context "when used with a QuickCheck property" $ do       it "runs action before every check of the property" $ do         (rec, retrieve) <- mkAppend-        runSilent $ H.before (rec "before" >> return "value") $ do+        evalSpec_ $ H.before (rec "before" >> return "value") $ do           H.it "foo" $ \value -> property $ \(_ :: Int) -> rec value         retrieve `shouldReturn` (take 200 . cycle) ["before", "value"] -      context "when used multiple times" $ do-        it "is evaluated outside in" $ do-          pending-   describe "before_" $ do     it "runs an action before every spec item" $ do       (rec, retrieve) <- mkAppend-      runSilent $ H.before_ (rec "before") $ do+      evalSpec_ $ H.before_ (rec "before") $ do         H.it "foo" $ do           rec "foo"         H.it "bar" $ do@@ -61,7 +78,7 @@     context "when used multiple times" $ do       it "is evaluated outside in" $ do         (rec, retrieve) <- mkAppend-        runSilent $ H.before_ (rec "outer") $ H.before_ (rec "inner") $ do+        evalSpec_ $ H.before_ (rec "outer") $ H.before_ (rec "inner") $ do           H.it "foo" $ do             rec "foo"         retrieve `shouldReturn` ["outer", "inner", "foo"]@@ -69,14 +86,14 @@     context "when used with a QuickCheck property" $ do       it "runs action before every check of the property" $ do         (rec, retrieve) <- mkAppend-        runSilent $ H.before_ (rec "before") $ do+        evalSpec_ $ H.before_ (rec "before") $ do           H.it "foo" $ property $ \(_ :: Int) -> rec "foo"         retrieve `shouldReturn` (take 200 . cycle) ["before", "foo"]        context "when used multiple times" $ do         it "is evaluated outside in" $ do           (rec, retrieve) <- mkAppend-          runSilent $ H.before_ (rec "outer") $ H.before_ (rec "inner") $ do+          evalSpec_ $ H.before_ (rec "outer") $ H.before_ (rec "inner") $ do             H.it "foo" $ property $ \(_ :: Int) -> rec "foo"           retrieve `shouldReturn` (take 300 . cycle) ["outer", "inner", "foo"] @@ -85,7 +102,7 @@       (rec, retrieve) <- mkAppend       let action :: Int -> IO String           action = return . show-      runSilent $ H.before (return 23) $ H.beforeWith action $ do+      evalSpec_ $ H.before (return 23) $ H.beforeWith action $ do         H.it "foo" $ \value -> rec value       retrieve `shouldReturn` ["23"] @@ -101,7 +118,7 @@        (rec, retrieve) <- mkAppend -      runSilent $ H.before (return 23) $ H.beforeWith action1 $ H.beforeWith action2 $ H.beforeWith action3 $ do+      evalSpec_ $ H.before (return 23) $ H.beforeWith action1 $ H.beforeWith action2 $ H.beforeWith action3 $ do         H.it "foo" $ \value -> rec value        retrieve `shouldReturn` ["foo 24"]@@ -109,7 +126,7 @@   describe "beforeAll" $ do     it "runs an action before the first spec item" $ do       (rec, retrieve) <- mkAppend-      runSilent $ H.beforeAll (rec "beforeAll" >> return "value") $ do+      evalSpec_ $ H.beforeAll (rec "beforeAll" >> return "value") $ do         H.it "foo" $ \value -> do           rec $ "foo " ++ value         H.it "bar" $ \value -> do@@ -120,21 +137,29 @@         , "bar value"         ] +    context "when specified action throws an exception" $ do+      it "sets subsequent spec items to pending" $ do+        evalSpec $ H.beforeAll throwException $ do+          H.it "foo" $ \n -> do+            n `shouldBe` (23 :: Int)+          H.it "bar" $ \n -> do+            n `shouldBe` 23+        `shouldReturn` [+          item ["foo"] divideByZero+        , item ["bar"] (Pending Nothing $ exceptionIn "beforeAll")+        ]+     context "when used with an empty list of examples" $ do       it "does not run specified action" $ do         (rec, retrieve) <- mkAppend-        runSilent $ H.beforeAll (rec "beforeAll" >> return "value") $ do-          return ()+        evalSpec_ $ H.beforeAll (rec "beforeAll" >> return "value") $ do+          pass         retrieve `shouldReturn` [] -    context "when used multiple times" $ do-      it "is evaluated outside in" $ do-        pending-   describe "beforeAll_" $ do     it "runs an action before the first spec item" $ do       (rec, retrieve) <- mkAppend-      runSilent $ H.beforeAll_ (rec "beforeAll_") $ do+      evalSpec_ $ H.beforeAll_ (rec "beforeAll_") $ do         H.it "foo" $ do           rec "foo"         H.it "bar" $ do@@ -148,7 +173,7 @@     context "when used multiple times" $ do       it "is evaluated outside in" $ do         (rec, retrieve) <- mkAppend-        runSilent $ H.beforeAll_ (rec "outer") $ H.beforeAll_ (rec "inner") $ do+        evalSpec_ $ H.beforeAll_ (rec "outer") $ H.beforeAll_ (rec "inner") $ do           H.it "foo" $ do             rec "foo"           H.it "bar" $ do@@ -160,10 +185,73 @@           , "bar"           ] +  describe "beforeAllWith" $ do+    it "transforms the spec argument" $ do+      (rec, retrieve) <- mkAppend+      let action :: Int -> IO String+          action = return . show+      evalSpec_ $ H.beforeAll (return 23) $ H.beforeAllWith action $ do+        H.it "foo" $ \value -> rec value+      retrieve `shouldReturn` ["23"]++    it "can be used multiple times" $ do+      let action1 :: Int -> IO Int+          action1 = return . succ++          action2 :: Int -> IO String+          action2 = return . show++          action3 :: String -> IO String+          action3 = return . ("foo " ++)++      (rec, retrieve) <- mkAppend++      evalSpec_ $ H.beforeAll (return 23) $+        H.beforeAllWith action1 $ H.beforeAllWith action2 $ H.beforeAllWith action3 $ do+          H.it "foo" $ \value -> rec value++      retrieve `shouldReturn` ["foo 24"]++    it "runs an action before the first spec item" $ do+      (rec, retrieve) <- mkAppend+      evalSpec_ $ H.beforeAll (return (23 :: Int)) $+        H.beforeAllWith (\value -> rec "beforeAllWith" >> return (show value)) $ do+          H.it "foo" $ \value -> do+            rec $ "foo " ++ value+          H.it "bar" $ \value -> do+            rec $ "bar " ++ value+      retrieve `shouldReturn` [+          "beforeAllWith"+        , "foo 23"+        , "bar 23"+        ]++    context "when specified action throws an exception" $ do+      it "sets subsequent spec items to pending" $ do+        evalSpec $ do+          H.beforeAll (return (23 :: Int)) $ do+            H.beforeAllWith (\ _ -> throwException) $ do+              H.it "foo" $ \n -> do+                n `shouldBe` (23 :: Int)+              H.it "bar" $ \n -> do+                n `shouldBe` 23+        `shouldReturn` [+          item ["foo"] divideByZero+        , item ["bar"] (Pending Nothing $ exceptionIn "beforeAllWith")+        ]++    context "when used with an empty list of examples" $ do+      it "does not run specified action" $ do+        (rec, retrieve) <- mkAppend+        evalSpec_ $ H.beforeAll (return (23 :: Int)) $+          H.beforeAllWith (\_ -> rec "beforeAllWith" >> return "value") $ do+            pass+        retrieve `shouldReturn` []+   describe "after" $ do     it "runs an action after every spec item" $ do       (rec, retrieve) <- mkAppend-      runSilent $ H.before (rec "before" >> return "from before") $ H.after rec $ do+      evalSpec_ $ H.before (rec "before" >> return "from before") $ H.after rec $ do         H.it "foo" $ \_ -> do           rec "foo"         H.it "bar" $ \_ -> do@@ -179,20 +267,16 @@      it "guarantees that action is run" $ do       (rec, retrieve) <- mkAppend-      silence . ignoreExitCode . H.hspec $ H.before (rec "before" >> return "from before") $ H.after rec $ do+      evalSpec_ $ H.before (rec "before" >> return "from before") $ H.after rec $ do         H.it "foo" $ \_ -> do-          ioError $ userError "foo" :: IO ()+          throwException_           rec "foo"       retrieve `shouldReturn` ["before", "from before"] -    context "when used multiple times" $ do-      it "is evaluated inside out" $ do-        pending-   describe "after_" $ do     it "runs an action after every spec item" $ do       (rec, retrieve) <- mkAppend-      runSilent $ H.after_ (rec "after") $ do+      evalSpec_ $ H.after_ (rec "after") $ do         H.it "foo" $ do           rec "foo"         H.it "bar" $ do@@ -206,16 +290,16 @@      it "guarantees that action is run" $ do       (rec, retrieve) <- mkAppend-      silence . ignoreExitCode $ H.hspec $ H.after_ (rec "after") $ do+      evalSpec_ $ H.after_ (rec "after") $ do         H.it "foo" $ do-          ioError $ userError "foo" :: IO ()+          throwException_           rec "foo"       retrieve `shouldReturn` ["after"]      context "when used multiple times" $ do       it "is evaluated inside out" $ do         (rec, retrieve) <- mkAppend-        runSilent $ H.after_ (rec "after outer") $ H.after_ (rec "after inner") $ do+        evalSpec_ $ H.after_ (rec "after outer") $ H.after_ (rec "after inner") $ do           H.it "foo" $ do             rec "foo"         retrieve `shouldReturn` [@@ -227,7 +311,7 @@   describe "afterAll" $ do     it "runs an action after the last spec item" $ do       (rec, retrieve) <- mkAppend-      runSilent $ H.before (rec "before" >> return "from before") $ H.afterAll rec $ do+      evalSpec_ $ H.before (rec "before" >> return "from before") $ H.afterAll rec $ do         H.it "foo" $ \_ -> do           rec "foo"         H.it "bar" $ \_ -> do@@ -237,27 +321,29 @@         , "foo"         , "before"         , "bar"-        , "before"         , "from before"         ]      context "when used with an empty list of examples" $ do       it "does not run specified action" $ do-        (rec, retrieve) <- mkAppend-        runSilent $ H.before (rec "before" >> return "from before") $ H.afterAll rec $ do-          return ()-        retrieve `shouldReturn` []+        evalSpec $ H.before undefined $ H.afterAll undefined $ do+          pass+        `shouldReturn` []      context "when action throws an exception" $ do       it "reports a failure" $ do-        r <- runSpec $ H.before (return "from before") $ H.afterAll (\_ -> throwException) $ do+        evalSpec $ H.before (return "from before") $ H.afterAll (\_ -> throwException) $ do           H.it "foo" $ \a -> a `shouldBe` "from before"-        r `shouldSatisfy` any (== "afterAll-hook FAILED [1]")+          H.it "bar" $ \a -> a `shouldBe` "from before"+        `shouldReturn` [+          item ["foo"] Success+        , item ["bar"] $ divideByZeroIn "afterAll"+        ]    describe "afterAll_" $ do     it "runs an action after the last spec item" $ do       (rec, retrieve) <- mkAppend-      runSilent $ H.before_ (rec "before") $ H.afterAll_ (rec "afterAll_") $ do+      evalSpec_ $ H.before_ (rec "before") $ H.afterAll_ (rec "afterAll_") $ do         H.it "foo" $ do           rec "foo"         H.it "bar" $ do@@ -267,14 +353,13 @@         , "foo"         , "before"         , "bar"-        , "before"         , "afterAll_"         ]      context "when used multiple times" $ do       it "is evaluated inside out" $ do         (rec, retrieve) <- mkAppend-        runSilent $ H.afterAll_ (rec "after outer") $ H.afterAll_ (rec "after inner") $ do+        evalSpec_ $ H.afterAll_ (rec "after outer") $ H.afterAll_ (rec "after inner") $ do           H.it "foo" $ do             rec "foo"         retrieve `shouldReturn` [@@ -286,22 +371,46 @@     context "when used with an empty list of examples" $ do       it "does not run specified action" $ do         (rec, retrieve) <- mkAppend-        runSilent $ H.afterAll_ (rec "afterAll_") $ do-          return ()+        evalSpec_ $ H.afterAll_ (rec "afterAll_") $ do+          pass         retrieve `shouldReturn` [] +    context "when action is pending" $ do+      it "reports pending" $ do+        evalSpec $ do+          H.afterAll_ H.pending $ do+            H.it "foo" True+            H.it "bar" True+        `shouldReturn` [+          item ["foo"] Success+        , item ["bar"] (Pending Nothing Nothing)+        ]+     context "when action throws an exception" $ do       it "reports a failure" $ do-        r <- runSpec $ do+        evalSpec $ do           H.afterAll_ throwException $ do             H.it "foo" True-        r `shouldSatisfy` any (== "afterAll-hook FAILED [1]")+            H.it "bar" True+        `shouldReturn` [+          item ["foo"] Success+        , item ["bar"] $ divideByZeroIn "afterAll_"+        ] +    context "when action is successful" $ do+      it "does not report anything" $ do+        evalSpec $ do+          H.afterAll_ pass $ do+            H.it "foo" True+        `shouldReturn` [+          item ["foo"] Success+        ]+   describe "around" $ do     it "wraps every spec item with an action" $ do       (rec, retrieve) <- mkAppend       let action e = rec "before" >> e "from around" >> rec "after"-      runSilent $ H.around action $ do+      evalSpec_ $ H.around action $ do         H.it "foo" $ rec . ("foo " ++)         H.it "bar" $ rec . ("bar " ++)       retrieve `shouldReturn` [@@ -313,15 +422,11 @@         , "after"         ] -    context "when used multiple times" $ do-      it "is evaluated outside in" $ do-        pending-   describe "around_" $ do     it "wraps every spec item with an action" $ do       (rec, retrieve) <- mkAppend       let action e = rec "before" >> e >> rec "after"-      runSilent $ H.around_ action $ do+      evalSpec_ $ H.around_ action $ do         H.it "foo" $ do           rec "foo"         H.it "bar" $ do@@ -340,7 +445,7 @@         (rec, retrieve) <- mkAppend         let actionOuter e = rec "before outer" >> e >> rec "after outer"             actionInner e = rec "before inner" >> e >> rec "after inner"-        runSilent $ H.around_ actionOuter $ H.around_ actionInner $ do+        evalSpec_ $ H.around_ actionOuter $ H.around_ actionInner $ do           H.it "foo" $ do             rec "foo"         retrieve `shouldReturn` [@@ -353,12 +458,218 @@    describe "aroundWith" $ do     it "wraps every spec item with an action" $ do+      mock <- newMock       (rec, retrieve) <- mkAppend-      let action :: H.ActionWith String -> H.ActionWith Int-          action e = e . show-      runSilent $ H.before (return 23) $ H.aroundWith action $ do+      let action = (. show)+      evalSpec_ $ H.before (mockAction mock >> mockCounter mock) $ H.aroundWith action $ do         H.it "foo" rec-      retrieve `shouldReturn` ["23"]+        H.it "bar" rec+        H.it "baz" rec+      retrieve `shouldReturn` [+          "1"+        , "2"+        , "3"+        ]+      mockCounter mock `shouldReturn` 3++  describe "aroundAll" $ do+    it "wraps an action around a spec" $ do+      (rec, retrieve) <- mkAppend+      let action e = rec "before" *> e "from around" <* rec "after"+      evalSpec_ $ H.aroundAll action $ do+        H.it "foo" $ rec . ("foo " ++)+        H.it "bar" $ rec . ("bar " ++)+        H.it "baz" $ rec . ("baz " ++)+      retrieve `shouldReturn` [+          "before"+        , "foo from around"+        , "bar from around"+        , "baz from around"+        , "after"+        ]++  describe "aroundAll_" $ do+    it "wraps an action around a spec" $ do+      (rec, retrieve) <- mkAppend+      let action inner = rec "before" *> inner <* rec "after"+      evalSpec_ $ H.aroundAll_ action $ do+        H.it "foo" $ rec "foo"+        H.it "bar" $ rec "bar"+      retrieve `shouldReturn` [+          "before"+        , "foo"+        , "bar"+        , "after"+        ]++    it "wrap actions around a spec in order" $ do+      (rec, retrieve) <- mkAppend+      let action i inner = rec ("before " <> i) *> inner <* rec ("after " <> i)+      evalSpec_ $ H.aroundAll_ (action "1") $ H.aroundAll_ (action "2") $ do+        H.it "foo" $ rec "foo"+        H.it "bar" $ rec "bar"+      retrieve `shouldReturn` [+          "before 1"+        , "before 2"+        , "foo"+        , "bar"+        , "after 2"+        , "after 1"+        ]++    it "does not call actions wrapped around a failing action" $ do+      (rec, retrieve) <- mkAppend+      let action i inner = rec ("before " <> i) *> inner <* rec ("after " <> i)+      evalSpec_ $+        H.aroundAll_ (action "1") $+          H.aroundAll_ (action "2 failing" . const throwException) $+            H.aroundAll_ (action "3") $ do+              H.it "foo" $ rec "foo"+              H.it "bar" $ rec "bar"+      retrieve `shouldReturn` [+          "before 1"+        , "before 2 failing"+        , "after 1"+        ]++    it "does not memoize subject" $ do+      mock <- newMock+      let action :: IO Int+          action = mockAction mock >> mockCounter mock++      (rec, retrieve) <- mkAppend+      evalSpec_ $ H.before action $ H.aroundAll_ id $ do+        H.it "foo" $ rec . show+        H.it "bar" $ rec . show+        H.it "baz" $ rec . show+      retrieve `shouldReturn` [+          "1"+        , "2"+        , "3"+        ]+      mockCounter mock `shouldReturn` 3++    it "reports exceptions on acquire" $ do+      evalSpec $ do+        H.aroundAll_ (throwException <*) $ do+          H.it "foo" True+          H.it "bar" True+      `shouldReturn` [+        item ["foo"] divideByZero+      , item ["bar"] (Pending Nothing $ exceptionIn "aroundAll_")+      ]++    it "reports exceptions on release" $ do+      evalSpec $ do+        H.aroundAll_ (<* throwException) $ do+          H.it "foo" True+          H.it "bar" True+      `shouldReturn` [+        item ["foo"] Success+      , item ["bar"] $ divideByZeroIn "aroundAll_"+      ]++  describe "aroundAllWith" $ do+    it "wraps an action around a spec" $ do+      mock <- newMock+      (rec, retrieve) <- mkAppend+      let action = (. show)+      evalSpec_ $ H.before (mockAction mock >> mockCounter mock) $ H.aroundAllWith action $ do+        H.it "foo" rec+        H.it "bar" rec+        H.it "baz" rec+      retrieve `shouldReturn` [+          "1"+        , "1"+        , "1"+        ]+      mockCounter mock `shouldReturn` 3++    it "wrap actions around a spec in order" $ do+      (rec, retrieve) <- mkAppend+      let action i inner a = rec ("before " <> i) *> inner a <* rec ("after " <> i)+      evalSpec_ $ H.aroundAllWith (action "1") $ H.aroundAllWith (action "2") $ do+        H.it "foo" $ rec "foo"+        H.it "bar" $ rec "bar"+      retrieve `shouldReturn` [+          "before 1"+        , "before 2"+        , "foo"+        , "bar"+        , "after 2"+        , "after 1"+        ]++    it "does not call actions wrapped around a failing action" $ do+      (rec, retrieve) <- mkAppend+      let action i inner a = rec ("before " <> i) *> inner a <* rec ("after " <> i)+      evalSpec_ $+        H.aroundAllWith (action "1") $+          H.aroundAllWith (action "2 failing" . const . const throwException) $+            H.aroundAllWith (action "3") $ do+              H.it "foo" $ rec "foo"+              H.it "bar" $ rec "bar"+      retrieve `shouldReturn` [+          "before 1"+        , "before 2 failing"+        , "after 1"+        ]++    it "reports exceptions on acquire" $ do+      evalSpec $ do+        H.aroundAllWith (\ action () -> throwException >>= action) $ do+          H.it "foo" H.pending+      `shouldReturn` [+        item ["foo"] divideByZero+      ]++    it "reports exceptions on release" $ do+      evalSpec $ do+        H.aroundAllWith (\ action () -> action () <* throwException) $ do+          H.it "foo" True+          H.it "bar" True+      `shouldReturn` [+        item ["foo"] Success+      , item ["bar"] $ divideByZeroIn "aroundAllWith"+      ]++  describe "decompose" $ do+    it "decomposes a with-style action into acquire / release" $ do+      (acquire, release) <- H.decompose $ \ action x -> do+        action (x + 42 :: Int)+      acquire 23 `shouldReturn` 65+      release++    context "when release is called before acquire" $ do+      it "does nothing" $ do+        (_, release) <- H.decompose $ \ action x -> do+          action (x + 42 :: Int)+        release++    context "with an exception during resource acquisition" $ do+      it "propagates that exception" $ do+        (acquire, release) <- H.decompose $ \ action () -> do+          throwException_+          action ()+        acquire () `shouldThrow` (== DivideByZero)+        release++    context "with an exception during resource deallocation" $ do+      it "propagates that exception" $ do+        (acquire, release) <- H.decompose $ \ action () -> do+          action ()+          throwException_+        acquire ()+        release `shouldThrow` (== DivideByZero)+   where-    runSpec :: H.Spec -> IO [String]-    runSpec = captureLines . H.hspecResult+    divideByZero :: Result+    divideByZero = Failure Nothing (Error Nothing $ toException DivideByZero)++    divideByZeroIn :: String -> Result+    divideByZeroIn hook = Failure Nothing (Error (Just $ "in " <> hook <> "-hook:") $ toException DivideByZero)++    item :: [String] -> Result -> ([String], Item)+    item path result = (path, Item Nothing 0 "" result)++    exceptionIn name = Just ("exception in " <> name <> "-hook (see previous failure)")
+ test/Test/Hspec/Core/QuickCheck/UtilSpec.hs view
@@ -0,0 +1,251 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}+module Test.Hspec.Core.QuickCheck.UtilSpec (spec) where++import           Prelude ()+import           Helper++import qualified Test.QuickCheck.Property as QCP++import           Test.Hspec.Core.QuickCheck.Util++deriving instance Eq QuickCheckResult+deriving instance Eq Status+deriving instance Eq QuickCheckFailure++spec :: Spec+spec = do+  describe "formatNumbers" $ do+    it "includes number of tests" $ do+      formatNumbers 1 0 `shouldBe` "(after 1 test)"++    it "pluralizes number of tests" $ do+      formatNumbers 3 0 `shouldBe` "(after 3 tests)"++    it "includes number of shrinks" $ do+      formatNumbers 3 1 `shouldBe` "(after 3 tests and 1 shrink)"++    it "pluralizes number of shrinks" $ do+      formatNumbers 3 3 `shouldBe` "(after 3 tests and 3 shrinks)"++  describe "stripSuffix" $ do+    it "drops the given suffix from a list" $ do+      stripSuffix "bar" "foobar" `shouldBe` Just "foo"++  describe "splitBy" $ do+    it "splits a string by a given infix" $ do+      splitBy "bar" "foo bar baz" `shouldBe` Just ("foo ", " baz")++  describe "parseQuickCheckResult" $ do+    let+      args = stdArgs {chatty = False, replay = Just (mkGen 0, 0)}+      qc = quickCheckWithResult args++    context "with Success" $ do+      let p :: Int -> Bool+          p n = n == n++      it "parses result" $ do+        parseQuickCheckResult <$> qc p `shouldReturn`+          QuickCheckResult 100 "+++ OK, passed 100 tests." QuickCheckSuccess++      it "includes labels" $ do+        parseQuickCheckResult <$> qc (label "unit" p) `shouldReturn`+          QuickCheckResult 100 "+++ OK, passed 100 tests (100% unit)." QuickCheckSuccess++    context "with GaveUp" $ do+      let p :: Int -> Property+          p n = (n == 1234) ==> True++          qc = quickCheckWithResult args {maxSuccess = 2, maxDiscardRatio = 1}+          result = QuickCheckResult 0 "" (QuickCheckOtherFailure "Gave up after 0 tests; 2 discarded!")++      it "parses result" $ do+        parseQuickCheckResult <$> qc p `shouldReturn` result++      it "includes verbose output" $ do+        let+          info = intercalate "\n" [+              "Skipped (precondition false):"+            , "0"+            , ""+            , "Skipped (precondition false):"+            , "0"+            ]+        parseQuickCheckResult <$> qc (verbose p) `shouldReturn` result {quickCheckResultInfo = info}++    context "with NoExpectedFailure" $ do+      let+        p :: Int -> Property+        p _ = expectFailure True++      it "parses result" $ do+        parseQuickCheckResult <$> qc p `shouldReturn`+          QuickCheckResult 100 "" (QuickCheckOtherFailure "Passed 100 tests (expected failure).")++      it "includes verbose output" $ do+        let+          info = intercalate "\n" [+              "Passed:"+            , "0"+            , ""+            , "Passed:"+            , "23"+            ]+        parseQuickCheckResult <$> quickCheckWithResult args {maxSuccess = 2} (verbose p) `shouldReturn`+          QuickCheckResult 2 info (QuickCheckOtherFailure "Passed 2 tests (expected failure).")++    context "with cover" $ do+      context "without checkCoverage" $ do+        let+          p :: Int -> Property+          p n = cover 10 (n == 5) "is 5" True++        it "parses result" $ do+          parseQuickCheckResult <$> qc p `shouldReturn`+            QuickCheckResult 100 "+++ OK, passed 100 tests (1% is 5).\n\nOnly 1% is 5, but expected 10%" QuickCheckSuccess++        it "includes verbose output" $ do+          let+            info = intercalate "\n" [+                "Passed:"+              , "0"+              , ""+              , "Passed:"+              , "23"+              , ""+#if MIN_VERSION_QuickCheck(2,15,0)+              , "+++ OK, passed 2 tests (0% is 5)."+#else+              , "+++ OK, passed 2 tests."+#endif+              , ""+              , "Only 0% is 5, but expected 10%"+              ]+          parseQuickCheckResult <$> quickCheckWithResult args {maxSuccess = 2} (verbose p) `shouldReturn`+            QuickCheckResult 2 info QuickCheckSuccess++      context "with checkCoverage" $ do+        let+          p :: Int -> Property+          p n = checkCoverage $ cover 10 (n == 23) "is 23" True++          failure :: QuickCheckFailure+          failure = QCFailure {+              quickCheckFailureNumShrinks = 0+            , quickCheckFailureException = Nothing+            , quickCheckFailureReason = "Insufficient coverage"+            , quickCheckFailureCounterexample = [+                " 0.9% is 23"+              , ""+              , "Only 0.9% is 23, but expected 10.0%"+              ]+            }++        it "parses result" $ do+          parseQuickCheckResult <$> qc p `shouldReturn`+            QuickCheckResult 800 "" (QuickCheckFailure failure)++        it "includes verbose output" $ do+-- This off-by-one error was fixed in QuickCheck 2.15+#if MIN_VERSION_QuickCheck(2,15,0)+          let info = intercalate "\n\n" (replicate 800 "Passed:")+#else+          let info = intercalate "\n\n" (replicate 799 "Passed:")+#endif+          parseQuickCheckResult <$> qc (verbose . p) `shouldReturn`+            QuickCheckResult 800 info (QuickCheckFailure failure)++    context "with Failure" $ do+      context "with single-line failure reason" $ do+        let+          p :: Int -> Bool+          p = (< 1)++          err = "Falsified"+          result = QuickCheckResult 4 "" (QuickCheckFailure $ QCFailure 2 Nothing err ["1"])++        it "parses result" $ do+          parseQuickCheckResult <$> qc p `shouldReturn` result++        it "includes verbose output" $ do+          let info = intercalate "\n" [+                  "Passed:"+                , "0"+                , ""+                , "Passed:"+                , "0"+                , ""+                , "Passed:"+                , "-2"+                , ""+                , "Failed:"+                , "3"+                , ""+                , "Passed:"+                , "0"+                , ""+                , "Failed:"+                , "2"+                , ""+                , "Passed:"+                , "0"+                , ""+                , "Failed:"+                , "1"+                , ""+                , "Passed:"+                , "0"+                ]++          parseQuickCheckResult <$> qc (verbose p) `shouldReturn` result {quickCheckResultInfo = info}++      context "with multi-line failure reason" $ do+        let+          p :: Int -> QCP.Result+          p n = if n /= 2 then QCP.succeeded else QCP.failed {QCP.reason = err}++          err = "foo\nbar"+          result = QuickCheckResult 5 "" (QuickCheckFailure $ QCFailure 0 Nothing err ["2"])++        it "parses result" $ do+          parseQuickCheckResult <$> qc p `shouldReturn` result++        it "includes verbose output" $ do+          let info = intercalate "\n" [+                  "Passed:"+                , "0"+                , ""+                , "Passed:"+                , "0"+                , ""+                , "Passed:"+                , "-2"+                , ""+                , "Passed:"+                , "3"+                , ""+                , "Failed:"+                , "2"+                , ""+                , "Passed:"+                , "0"+                , ""+                , "Passed:"+                , "1"+                ]+          parseQuickCheckResult <$> qc (verbose p) `shouldReturn` result {quickCheckResultInfo = info}++      context "with HUnit assertion" $ do+        let p :: Int -> Int -> Expectation+            p m n = do+              m `shouldBe` n++        it "includes counterexample" $ do+          result <- qc p+          let QuickCheckResult _ _ (QuickCheckFailure r) = parseQuickCheckResult result+          quickCheckFailureCounterexample r `shouldBe` ["0", "1"]
− test/Test/Hspec/Core/QuickCheckUtilSpec.hs 
@@ -1,31 +0,0 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-missing-fields #-}-module Test.Hspec.Core.QuickCheckUtilSpec (main, spec) where--import           Helper--import           Test.QuickCheck-import           Test.Hspec.Core.QuickCheckUtil--main :: IO ()-main = hspec spec--spec :: Spec-spec = do-  describe "formatNumbers" $ do-    it "includes number of tests" $ do-      formatNumbers (failure 1 0) `shouldBe` "(after 1 test)"--    it "pluralizes number of tests" $ do-      formatNumbers (failure 3 0) `shouldBe` "(after 3 tests)"--    it "includes number of shrinks" $ do-      formatNumbers (failure 3 1) `shouldBe` "(after 3 tests and 1 shrink)"--    it "pluralizes number of shrinks" $ do-      formatNumbers (failure 3 3) `shouldBe` "(after 3 tests and 3 shrinks)"-  where-    failure tests shrinks = Failure {-      numTests = tests-    , numShrinks = shrinks-    }
+ test/Test/Hspec/Core/Runner/EvalSpec.hs view
@@ -0,0 +1,75 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Test.Hspec.Core.Runner.EvalSpec (spec) where++import           Prelude ()+import           Helper++import           Data.List.NonEmpty (fromList)++import           Test.Hspec.Core.Spec (FailureReason(..), Result(..), ResultStatus(..), Location(..))++import           Test.Hspec.Core.Runner.Eval++instance Arbitrary ResultStatus where+  arbitrary = oneof [+      pure Success+    , Pending <$> arbitrary <*> arbitrary+    , failure+    ]++instance Arbitrary FailureReason where+  arbitrary = oneof [+      pure NoReason+    , ExpectedButGot <$> arbitrary <*> (show <$> positive) <*> (show <$> positive)+    , Error <$> arbitrary <*> pure (toException DivideByZero)+    ]++instance Arbitrary Location where+  arbitrary = Location <$> elements ["src/Foo.hs", "src/Bar.hs", "src/Baz.hs"] <*> positive <*> positive++positive :: Gen Int+positive = getPositive <$> arbitrary++failureResult :: Gen Result+failureResult = Result <$> arbitrary <*> failure++pendingResult :: Gen Result+pendingResult = Result <$> arbitrary <*> pending++successResult :: Gen Result+successResult = Result <$> arbitrary <*> pure Success++pending :: Gen ResultStatus+pending = Pending <$> arbitrary <*> arbitrary++failure :: Gen ResultStatus+failure = Failure <$> arbitrary <*> arbitrary++spec :: Spec+spec = do+  describe "mergeResults" $ do+    it "gives failures from items precedence" $ do+      forAll failureResult $ \ item hook -> do+        mergeResults Nothing item hook `shouldBe` item++    it "gives failures from hooks precedence over succeeding items" $ do+      forAll successResult $ \ item@(Result info _) -> forAll failure $ \ hook -> do+        mergeResults Nothing item hook `shouldBe` Result info hook++    it "gives failures from hooks precedence over pending items" $ do+      forAll pendingResult $ \ item@(Result info _) -> forAll failure $ \ hook -> do+        mergeResults Nothing item hook `shouldBe` Result info hook++    it "gives pending items precedence over pending hooks" $ do+      forAll pendingResult $ \ item -> forAll pending $ \ hook -> do+        mergeResults Nothing item hook `shouldBe` item++  describe "traverse" $ do+    context "when used with Tree" $ do+      let+        tree :: Tree () Int+        tree = Node "" $ fromList [Node "" $ fromList [Leaf 1, Node "" $ fromList [Leaf 2, Leaf 3]], Leaf 4]+      it "walks the tree left-to-right, depth-first" $ do+        ref <- newIORef []+        traverse_ (modifyIORef ref . (:) ) tree+        reverse <$> readIORef ref `shouldReturn` [1 .. 4]
+ test/Test/Hspec/Core/Runner/JobQueueSpec.hs view
@@ -0,0 +1,44 @@+module Test.Hspec.Core.Runner.JobQueueSpec (spec) where++import           Prelude ()+import           Helper++import           Control.Concurrent++import           Test.Hspec.Core.Runner.JobQueue++spec :: Spec+spec = do+  describe "enqueueJob" $ do+    let+      waitFor job = job (\ _ -> pass) >>= either throwIO return++    context "with Sequential" $ do+      it "runs actions sequentially" $ do+        withJobQueue 10 $ \ queue -> do+          ref <- newIORef []+          jobA <- enqueueJob queue Sequential $ \ _ -> modifyIORef ref (23 :)+          jobB <- enqueueJob queue Sequential $ \ _ -> modifyIORef ref (42 :)+          waitFor jobB+          readIORef ref `shouldReturn` [42 :: Int]+          waitFor jobA+          readIORef ref `shouldReturn` [23, 42]++    context "with Concurrent" $ do+      it "runs actions concurrently" $ do+        withJobQueue 10 $ \ queue -> do+          barrierA <- newEmptyMVar+          barrierB <- newEmptyMVar++          jobA <- enqueueJob queue Concurrent $ \ _ -> do+            putMVar barrierB ()+            takeMVar barrierA++          jobB <- enqueueJob queue Concurrent $ \ _ -> do+            putMVar barrierA ()+            takeMVar barrierB++          timeout (0.1 :: Seconds) $ do+            waitFor jobA+            waitFor jobB+          `shouldReturn` Just ()
+ test/Test/Hspec/Core/Runner/PrintSlowSpecItemsSpec.hs view
@@ -0,0 +1,49 @@+module Test.Hspec.Core.Runner.PrintSlowSpecItemsSpec (spec) where++import           Prelude ()+import           Helper++import           System.IO (stderr)++import           Test.Hspec.Core.Format+import           Test.Hspec.Core.Runner.PrintSlowSpecItems++location :: Location+location = Location {+  locationFile = "Foo.hs"+, locationLine = 23+, locationColumn = 42+}++item :: Item+item = Item {+  itemLocation = Just location+, itemDuration = 0+, itemInfo = undefined+, itemResult = undefined+}++spec :: Spec+spec = do+  describe "printSlowSpecItems" $ do+    let+      format = printSlowSpecItems 2 $ \ _ -> pass+      run = hCapture_ [stderr] . format . Done++    it "prints slow spec items" $ do+      run [+            ((["foo", "bar"], "one"), item {itemDuration = 0.100})+          , ((["foo", "bar"], "two"), item {itemDuration = 0.500})+          , ((["foo", "bar"], "thr"), item {itemDuration = 0.050})+          ]+      `shouldReturn` unlines [+        ""+      , "Slow spec items:"+      , "  Foo.hs:23:42: /foo/bar/two/ (500ms)"+      , "  Foo.hs:23:42: /foo/bar/one/ (100ms)"+      ]++    context "when there are no slow items" $ do+      it "prints nothing" $ do+        run [((["foo", "bar"], "one"), item {itemDuration = 0})]+        `shouldReturn` ""
+ test/Test/Hspec/Core/Runner/ResultSpec.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE RecordWildCards #-}+module Test.Hspec.Core.Runner.ResultSpec (spec) where++import           Prelude ()+import           Helper++import           Test.Hspec.Core.Format++import           Test.Hspec.Core.Runner.Result++spec :: Spec+spec = do+  describe "Summary" $ do+    let+      summary :: Summary+      summary = toSummary $ toSpecResult [item Success, item failure]++    it "can be deconstructed via accessor functions" $ do+      (summaryExamples &&& summaryFailures) summary `shouldBe` (2, 1)++    it "can be deconstructed via pattern matching" $ do+      let Summary examples failures = summary+      (examples, failures) `shouldBe` (2, 1)++    it "can be deconstructed via RecordWildCards" $ do+      let Summary{..} = summary+      (summaryExamples, summaryFailures) `shouldBe` (2, 1)++  describe "specResultSuccess" $ do+    context "when all spec items passed" $ do+      it "returns True" $ do+        specResultSuccess (toSpecResult [item Success]) `shouldBe` True++    context "with a failed spec item" $ do+      it "returns False" $ do+        specResultSuccess (toSpecResult [item Success, item failure]) `shouldBe` False++    context "with an empty result list" $ do+      it "returns True" $ do+        specResultSuccess (toSpecResult []) `shouldBe` True+  where+    failure = Failure Nothing NoReason+    item result = (([], ""), Item Nothing 0 "" result)
test/Test/Hspec/Core/RunnerSpec.hs view
@@ -1,32 +1,34 @@+{-# OPTIONS_GHC -fno-warn-deprecations #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-}-module Test.Hspec.Core.RunnerSpec (main, spec) where+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+module Test.Hspec.Core.RunnerSpec (spec) where  import           Prelude () import           Helper -import           System.IO (stderr)-import           Control.Monad (replicateM_)-import           System.Environment (withArgs, withProgName, getArgs)+import           System.IO+import           System.Environment (withArgs, withProgName, getArgs, setEnv, unsetEnv) import           System.Exit import           Control.Concurrent-import qualified Control.Exception as E+import           Control.Concurrent.Async import           Mock-import           System.SetEnv -import           Test.Hspec.FailureReport (FailureReport(..))+import           Test.Hspec.Core.FailureReport (FailureReport(..))+import qualified Test.Hspec.Expectations as H import qualified Test.Hspec.Core.Spec as H+import           Test.Hspec.Core.Runner (UseColor(..), ProgressReporting(..)) import qualified Test.Hspec.Core.Runner as H-import qualified Test.Hspec.Core.Formatters as H (silent)+import           Test.Hspec.Core.Runner.Result import qualified Test.Hspec.Core.QuickCheck as H  import qualified Test.QuickCheck as QC import qualified Test.Hspec.Core.Hooks as H -main :: IO ()-main = hspec spec--quickCheckOptions :: [([Char], Args -> Int)]-quickCheckOptions = [("--qc-max-success", QC.maxSuccess), ("--qc-max-size", QC.maxSize), ("--qc-max-discard", QC.maxDiscardRatio)]+import           Test.Hspec.Core.Formatters.Pretty.ParserSpec (Person(..))+import           Test.Hspec.Core.Extension ()  runPropFoo :: [String] -> IO String runPropFoo args = unlines . normalizeSummary . lines <$> do@@ -34,16 +36,54 @@     H.it "foo" $ do       property (/= (23 :: Int)) +person :: Int -> Person+person age = Person "Joe" age Nothing++data MyException = MyException+  deriving (Eq, Show)++instance Exception MyException where+  displayException MyException = "my exception"++resultWithColorizedReason :: H.Result+resultWithColorizedReason = H.Result {+  H.resultInfo = "info"+, H.resultStatus = H.Failure Nothing . H.ColorizedReason $ "some " <> green "colorized" <> " error message"+}+ spec :: Spec spec = do   describe "hspec" $ do++    let+      hspec args = withArgs args . hspecSilent+      hspec_ = hspecSilent++    it "evaluates examples Unmasked" $ do+      mvar <- newEmptyMVar+      hspec_ $ do+        H.it "foo" $ do+          getMaskingState >>= putMVar mvar+      takeMVar mvar `shouldReturn` Unmasked++    it "runs finalizers" $ do+      mvar <- newEmptyMVar+      ref <- newIORef "did not run finalizer"+      a <- async $ hspec_ $ do+          H.it "foo" $ do+            (putMVar mvar () >> threadDelay 10000000) `finally`+              writeIORef ref "ran finalizer"+      takeMVar mvar+      cancel a+      readIORef ref `shouldReturn` "ran finalizer"+     it "runs a spec" $ do-      silence . H.hspec $ do+      hspec_ $ do         H.it "foobar" True       `shouldReturn` ()      it "exits with exitFailure if not all examples pass" $ do-      silence . H.hspec $ do+      hspec_ $ do         H.it "foobar" False       `shouldThrow` (== ExitFailure 1) @@ -62,7 +102,7 @@           ]      it "stores a failure report in the environment" $ do-      silence . ignoreExitCode . withArgs ["--seed", "23"] . H.hspec $ do+      ignoreExitCode . hspec ["--seed", "23"] $ do         H.describe "foo" $ do           H.describe "bar" $ do             H.it "example 1" True@@ -80,73 +120,105 @@           ]         } -    describe "with --rerun" $ do-      let runSpec = (captureLines . ignoreExitCode . H.hspec) $ do-            H.it "example 1" True-            H.it "example 2" False-            H.it "example 3" False-            H.it "example 4" True-            H.it "example 5" False+    context "with --rerun" $ do+      let+        failingSpec = do+          H.it "example 1" True+          H.it "example 2" False+          H.it "example 3" False+          H.it "example 4" True+          H.it "example 5" False -      it "reruns examples that previously failed" $ do-        r0 <- runSpec-        r0 `shouldSatisfy` elem "5 examples, 3 failures"+        succeedingSpec = do+          H.it "example 1" True+          H.it "example 2" True+          H.it "example 3" True+          H.it "example 4" True+          H.it "example 5" True -        r1 <- withArgs ["--rerun"] runSpec-        r1 `shouldSatisfy` elem "3 examples, 3 failures"+        run = captureLines . H.hspecResult+        rerun = withArgs ["--rerun"] . run -      it "reuses the same seed" $ do+      it "reuses same --seed" $ do         r <- runPropFoo ["--seed", "42"]         runPropFoo ["--rerun"] `shouldReturn` r -      forM_ quickCheckOptions $ \(flag, accessor) -> do-        it ("reuses same " ++ flag) $ do-          [flag, "23"] `shouldUseArgs` ((== 23) . accessor)-          ["--rerun"] `shouldUseArgs` ((== 23) . accessor)+      it "reuses same --qc-max-success" $ do+        n <- generate arbitrary+        ["--qc-max-success", show n] `shouldUseArgs` (QC.maxSuccess, n)+        ["--rerun"] `shouldUseArgs` (QC.maxSuccess, n) -      context "when no examples failed previously" $ do-        it "runs all examples" $ do-          let run = capture_ . H.hspec $ do-                H.it "example 1" True-                H.it "example 2" True-                H.it "example 3" True+      it "reuses same --qc-max-discard" $ do+        n <- generate arbitrary+        ["--qc-max-discard", show n] `shouldUseArgs` (QC.maxDiscardRatio, n)+        ["--rerun"] `shouldUseArgs` (QC.maxDiscardRatio, n) -          r0 <- run-          r0 `shouldContain` "3 examples, 0 failures"+      it "reuses same --qc-max-size" $ do+        n <- generate arbitrary+        ["--qc-max-size", show n] `shouldUseArgs` (QC.maxSize, n)+        ["--rerun"] `shouldUseArgs` (QC.maxSize, n) -          r1 <- withArgs ["--rerun"] run-          r1 `shouldContain` "3 examples, 0 failures"+      context "with failing examples" $ do+        it "only reruns failing examples" $ do+          r0 <- run failingSpec+          last r0 `shouldBe` "5 examples, 3 failures" +          r1 <- rerun failingSpec+          last r1 `shouldBe` "3 examples, 3 failures"++      context "without failing examples" $ do+        it "runs all examples" $ do+          r0 <- run succeedingSpec+          last r0 `shouldBe` "5 examples, 0 failures"++          r1 <- rerun succeedingSpec+          last r1 `shouldBe` "5 examples, 0 failures"+       context "when there is no failure report in the environment" $ do-        it "runs everything" $ do+        it "runs all examples" $ do           unsetEnv "HSPEC_FAILURES"-          r <- hSilence [stderr] $ withArgs ["--rerun"] runSpec+          r <- hSilence [stderr] $ rerun failingSpec           r `shouldSatisfy` elem "5 examples, 3 failures"          it "prints a warning to stderr" $ do           unsetEnv "HSPEC_FAILURES"-          r <- hCapture_ [stderr] $ withArgs ["--rerun"] runSpec+          r <- hCapture_ [stderr] $ rerun failingSpec           r `shouldBe` "WARNING: Could not read environment variable HSPEC_FAILURES; `--rerun' is ignored!\n"        context "when parsing of failure report fails" $ do-        it "runs everything" $ do+        it "runs all examples" $ do           setEnv "HSPEC_FAILURES" "some invalid report"-          r <- hSilence [stderr] $ withArgs ["--rerun"] runSpec+          r <- hSilence [stderr] $ rerun failingSpec           r `shouldSatisfy` elem "5 examples, 3 failures"          it "prints a warning to stderr" $ do           setEnv "HSPEC_FAILURES" "some invalid report"-          r <- hCapture_ [stderr] $ withArgs ["--rerun"] runSpec+          r <- hCapture_ [stderr] $ rerun failingSpec           r `shouldBe` "WARNING: Could not read environment variable HSPEC_FAILURES; `--rerun' is ignored!\n" +      context "with --rerun-all-on-success" $ do+        let rerunAllOnSuccess = withArgs ["--rerun", "--rerun-all-on-success"] . run+        context "after a previously failing rerun succeeds for the first time" $ do+          it "runs the whole test suite" $ do+            _ <- run failingSpec+            output <- rerunAllOnSuccess succeedingSpec+            output `shouldSatisfy` elem "3 examples, 0 failures"+            last output `shouldBe` "5 examples, 0 failures" -    it "does not leak command-line flags to examples" $ do-      silence . withArgs ["--verbose"] $ do-        H.hspec $ do-          H.it "foobar" $ do-            getArgs `shouldReturn` []-        `shouldReturn` ()+          it "reruns runIO-actions" $ do+            ref <- newIORef (0 :: Int)+            let succeedingSpecWithRunIO = H.runIO (modifyIORef ref succ) >> succeedingSpec +            _ <- run failingSpec+            _ <- rerunAllOnSuccess succeedingSpecWithRunIO+            readIORef ref `shouldReturn` 2++    it "does not leak command-line options to examples" $ do+      hspec ["--diff"] $ do+        H.it "foobar" $ do+          getArgs `shouldReturn` []+      `shouldReturn` ()+     context "when interrupted with ctrl-c" $ do       it "prints summary immediately" $ do         mvar <- newEmptyMVar@@ -160,55 +232,47 @@             H.it "baz" True           putMVar mvar r         takeMVar sync-        throwTo threadId E.UserInterrupt+        throwTo threadId UserInterrupt         r <- takeMVar mvar         normalizeSummary r `shouldBe` [             ""-          , "foo FAILED [1]"+          , "foo [✘]"           , ""           , "Failures:"           , ""           , "  1) foo"           , ""+          , "  To rerun use: --match \"/foo/\" --seed 23"+          , ""           , "Randomized with seed 23"           , ""+          , "Finished in 0.0000 seconds"+          , "1 example, 1 failure"           ]        it "throws UserInterrupt" $ do         mvar <- newEmptyMVar         sync <- newEmptyMVar         threadId <- forkIO $ do-          silence . H.hspec $ do+          hspec_ $ do             H.it "foo" $ do               putMVar sync ()               threadDelay 1000000-          `E.catch` putMVar mvar+          `catch` putMVar mvar         takeMVar sync-        throwTo threadId E.UserInterrupt-        takeMVar mvar `shouldReturn` E.UserInterrupt--    context "with --help" $ do-      let printHelp = withProgName "spec" . withArgs ["--help"] . H.hspec $ pure ()-      it "prints help" $ do-        r <- (captureLines . ignoreExitCode) printHelp-        r `shouldStartWith` ["Usage: spec [OPTION]..."]-        silence printHelp `shouldThrow` (== ExitSuccess)--      it "constrains lines to 80 characters" $ do-        r <- (captureLines . ignoreExitCode) printHelp-        r `shouldSatisfy` all ((<= 80) . length)-        r `shouldSatisfy` any ((78 <=) . length)+        throwTo threadId UserInterrupt+        takeMVar mvar `shouldReturn` UserInterrupt      context "with --dry-run" $ do-      let withDryRun = captureLines . withArgs ["--dry-run"] . H.hspec+      let withDryRun = hspecCapture ["--dry-run"]       it "produces a report" $ do-        r <- withDryRun $ do+        withDryRun $ do           H.it "foo" True           H.it "bar" True-        normalizeSummary r `shouldBe` [+        `shouldReturn` unlines [             ""-          , "foo"-          , "bar"+          , "foo [✔]"+          , "bar [✔]"           , ""           , "Finished in 0.0000 seconds"           , "2 examples, 0 failures"@@ -228,53 +292,192 @@             H.it "bar" True         readIORef ref `shouldReturn` False +    context "with --focused-only" $ do+      let run = hspecCapture ["--focused-only"]+      context "when there aren't any focused spec items" $ do+        it "does not run anything" $ do+          run $ do+            H.it "foo" True+            H.it "bar" True+          `shouldReturn` unlines [+              ""+            , ""+            , "Finished in 0.0000 seconds"+            , "0 examples, 0 failures"+            ]++    context "with --fail-on=empty" $ do+      it "fails if no spec items have been run" $ do+        (out, r) <- hCapture [stdout, stderr] . try . withProgName "spec" . withArgs ["--skip=", "--fail-on=empty"] . H.hspec $ do+          H.it "foo" True+          H.it "bar" True+          H.it "baz" True+        unlines (normalizeSummary (lines out)) `shouldBe` unlines [+            "spec: all spec items have been filtered; failing due to --fail-on=empty"+          ]+        r `shouldBe` Left (ExitFailure 1)++    context "with --fail-on=focused" $ do+      let run = hspecCapture ["--fail-on=focused", "--seed", "23"]+      it "fails on focused spec items" $ do+        run $ do+          H.it "foo" True+          H.fit "bar" True+        `shouldReturn` unlines [+            ""+          , "bar [✘]"+          , ""+          , "Failures:"+          , ""+          , "  1) bar"+          , "       item is focused; failing due to --fail-on=focused"+          , ""+          , "  To rerun use: --match \"/bar/\" --seed 23"+          , ""+          , "Randomized with seed 23"+          , ""+          , "Finished in 0.0000 seconds"+          , "1 example, 1 failure"+          ]++    context "with --fail-on=empty-description" $ do+      let run = hspecCapture ["--fail-on=empty-description", "--seed", "23"]+      it "fails on items with empty requirement" $ do+        run $ do+          H.it "foo" True+          H.it "" True+        `shouldReturn` unlines [+            ""+          , "foo [✔]"+          , "(unspecified behavior) [✘]"+          , ""+          , "Failures:"+          , ""+          , "  1) (unspecified behavior)"+          , "       item has no description; failing due to --fail-on=empty-description"+          , ""+          , "  To rerun use: --match \"/(unspecified behavior)/\" --seed 23"+          , ""+          , "Randomized with seed 23"+          , ""+          , "Finished in 0.0000 seconds"+          , "2 examples, 1 failure"+          ]++    context "with --fail-on=pending" $ do+      let run = hspecCapture ["--fail-on=pending", "--seed", "23"]+      it "fails on pending spec items" $ do+        run $ do+          H.it "foo" True+          H.it "bar" $ do+            void $ throwIO (H.Pending Nothing Nothing)+        `shouldReturn` unlines [+            ""+          , "foo [✔]"+          , "bar [✘]"+          , ""+          , "Failures:"+          , ""+          , "  1) bar"+          , "       item is pending; failing due to --fail-on=pending"+          , ""+          , "  To rerun use: --match \"/bar/\" --seed 23"+          , ""+          , "Randomized with seed 23"+          , ""+          , "Finished in 0.0000 seconds"+          , "2 examples, 1 failure"+          ]+     context "with --fail-fast" $ do       it "stops after first failure" $ do-        r <- captureLines . ignoreExitCode . withArgs ["--fail-fast", "--seed", "23"] . H.hspec . removeLocations $ do+        hspecCapture ["--fail-fast", "--seed", "23"] $ do           H.it "foo" True           H.it "bar" False           H.it "baz" False-        normalizeSummary r `shouldBe` [+        `shouldReturn` unlines [             ""-          , "foo"-          , "bar FAILED [1]"+          , "foo [✔]"+          , "bar [✘]"           , ""           , "Failures:"           , ""           , "  1) bar"           , ""+          , "  To rerun use: --match \"/bar/\" --seed 23"+          , ""           , "Randomized with seed 23"           , ""           , "Finished in 0.0000 seconds"           , "2 examples, 1 failure"           ] +      it "cancels running parallel spec items on failure" $ do+        child1 <- newQSem 0+        child2 <- newQSem 0+        parent <- newQSem 0+        ref <- newIORef ""+        ignoreExitCode . hspec ["--fail-fast", "-j", "2"] $ do+          H.parallel $ do+            H.it "foo" $ do+              waitQSem child1+              "foo" `shouldBe` "bar"+            H.it "bar" $ do+              -- NOTE: waitQSem should never return here, as we want to+              -- guarantee that the thread is killed before hspec returns+              (signalQSem child1 >> waitQSem child2 >> writeIORef ref "foo") `finally` signalQSem parent+        signalQSem child2+        waitQSem parent+        readIORef ref `shouldReturn` ""+       it "works for nested specs" $ do-        r <- captureLines . ignoreExitCode . withArgs ["--fail-fast", "--seed", "23"] . H.hspec . removeLocations $ do+        hspecCapture ["--fail-fast", "--seed", "23"] $ do           H.describe "foo" $ do             H.it "bar" False             H.it "baz" True-        normalizeSummary r `shouldBe` [+        `shouldReturn` unlines [             ""           , "foo"-          , "  bar FAILED [1]"+          , "  bar [✘]"           , ""           , "Failures:"           , ""           , "  1) foo bar"           , ""+          , "  To rerun use: --match \"/foo/bar/\" --seed 23"+          , ""           , "Randomized with seed 23"           , ""           , "Finished in 0.0000 seconds"           , "1 example, 1 failure"           ] +      context "with a cleanup action" $ do+        it "runs cleanup action" $ do+          ref <- newIORef 0+          ignoreExitCode $ hspec ["--fail-fast"] $ do+            H.afterAll_ (modifyIORef ref succ) $ do+              H.it "foo" True+              H.it "bar" False+              H.it "baz" True+          readIORef ref `shouldReturn` (1 :: Int)++        context "when last leaf fails" $ do+          it "runs cleanup action exactly once" $ do+            ref <- newIORef 0+            ignoreExitCode $ hspec ["--fail-fast"] $ do+              H.afterAll_ (modifyIORef ref succ) $ do+                H.it "foo" True+                H.it "bar" True+                H.it "baz" False+            readIORef ref `shouldReturn` (1 :: Int)+     context "with --match" $ do       it "only runs examples that match a given pattern" $ do         e1 <- newMock         e2 <- newMock         e3 <- newMock-        silence . withArgs ["-m", "/bar/example"] . H.hspec $ do+        hspec ["-m", "/bar/example"] $ do           H.describe "foo" $ do             H.describe "bar" $ do               H.it "example 1" $ mockAction e1@@ -288,7 +491,7 @@         e2 <- newMock         e3 <- newMock         e4 <- newMock-        silence . withArgs ["-m", "/bar/example", "--skip", "example 3"] . H.hspec $ do+        hspec ["-m", "/bar/example", "--skip", "example 3"] $ do           H.describe "foo" $ do             H.describe "bar" $ do               H.it "example 1" $ mockAction e1@@ -303,7 +506,7 @@         e1 <- newMock         e2 <- newMock         e3 <- newMock-        silence . withArgs ["-m", "foo", "-m", "baz"] . H.hspec $ do+        hspec ["-m", "foo", "-m", "baz"] $ do           H.describe "foo" $ do             H.it "example 1" $ mockAction e1           H.describe "bar" $ do@@ -312,6 +515,247 @@             H.it "example 3" $ mockAction e3         (,,) <$> mockCounter e1 <*> mockCounter e2 <*> mockCounter e3 `shouldReturn` (1, 0, 1) +#if __GLASGOW_HASKELL__ >= 802+    context "with --pretty" $ do+      it "pretty-prints Haskell values" $ do+        let args = ["--pretty", "--seed=0", "--format=failed-examples"]+        r <- fmap (unlines . normalizeSummary . lines) . capture_ . ignoreExitCode . withArgs args . H.hspec . removeLocations $ do+          H.it "foo" $ do+            person 23 `H.shouldBe` person 42+        r `shouldBe` unlines [+            ""+          , "Failures:"+          , ""+          , "  1) foo"+          , "       expected: Person {"+          , "                   personName = \"Joe\","+          , "                   personAge = 42,"+          , "                   personAddress = Nothing"+          , "                 }"+          , "        but got: Person {"+          , "                   personName = \"Joe\","+          , "                   personAge = 23,"+          , "                   personAddress = Nothing"+          , "                 }"+          , ""+          , "  To rerun use: --match \"/foo/\" --seed 0"+          , ""+          , "Randomized with seed 0"+          , ""+          , "Finished in 0.0000 seconds"+          , "1 example, 1 failure"+          ]+#endif++      it "uses custom pretty-print functions" $ do+        let pretty _ _ _ = ("foo", "bar")++        r <- capture_ . ignoreExitCode . withArgs ["--pretty"] . H.hspec $ do+          H.modifyConfig $ \ c -> c { H.configPrettyPrintFunction = pretty }+          H.it "foo" $ do+            23 `H.shouldBe` (42 :: Int)+        r `shouldContain` unlines [+            "       expected: foo"+          , "        but got: bar"+          ]++    context "with --no-pretty" $ do+      it "does not pretty-prints Haskell values" $ do+        r <- capture_ . ignoreExitCode . withArgs ["--no-pretty"] . H.hspec $ do+          H.it "foo" $ do+            person 23 `H.shouldBe` person 42+        r `shouldContain` unlines [+            "       expected: Person {personName = \"Joe\", personAge = 42, personAddress = Nothing}"+          , "        but got: Person {personName = \"Joe\", personAge = 23, personAddress = Nothing}"+          ]++    context "when formatting exceptions" $ do+      let spec_ = H.it "foo" $ void (withFrozenCallStack throwIO MyException)+      context "with --show-exceptions" $ do+        it "uses `show`" $ do+          hspecCapture ["--seed=0", "--format=failed-examples", "--display-exceptions", "--show-exceptions"] spec_+          `shouldReturn` unlines [+              ""+            , "Failures:"+            , ""+            , "  1) foo"+            , "       uncaught exception: MyException"+            , "       MyException"+            , ""+            , "  To rerun use: --match \"/foo/\" --seed 0"+            , ""+            , "Randomized with seed 0"+            , ""+            , "Finished in 0.0000 seconds"+            , "1 example, 1 failure"+            ]++      context "with --display-exceptions" $ do+        it "uses `displayException`" $ do+          hspecCapture ["--seed=0", "--format=failed-examples", "--show-exceptions", "--display-exceptions"] spec_+          `shouldReturn` unlines [+              ""+            , "Failures:"+            , ""+            , "  1) foo"+            , "       uncaught exception: MyException"+            , "       my exception"+#if MIN_VERSION_base(4,20,0) && !MIN_VERSION_base(4,21,0)+            , "       HasCallStack backtrace:"+            , "       "+#endif+            , ""+            , "  To rerun use: --match \"/foo/\" --seed 0"+            , ""+            , "Randomized with seed 0"+            , ""+            , "Finished in 0.0000 seconds"+            , "1 example, 1 failure"+            ]++    context "with --color" $ do+      it "outputs ColorizedReason" $ do+        hspecCapture ["--seed=0", "--format=failed-examples", "--color"] $ do+          H.it "foo" resultWithColorizedReason+        `shouldReturn` unlines [+            "\ESC[?25l"+          , "Failures:"+          , ""+          , "  1) foo"+          , "       some " ++ green "colorized" ++ " error message"+          , ""+          , "  To rerun use: --match \"/foo/\" --seed 0"+          , ""+          , "Randomized with seed 0"+          , ""+          , "Finished in 0.0000 seconds"+          , red "1 example, 1 failure"+          , "\ESC[?25h"+          ]++    context "with --no-color" $ do+      it "strips ANSI sequences from ColorizedReason" $ do+        hspecCapture ["--seed=0", "--format=failed-examples", "--no-color"] $ do+          H.it "foo" resultWithColorizedReason+        `shouldReturn` unlines [+            ""+          , "Failures:"+          , ""+          , "  1) foo"+          , "       some colorized error message"+          , ""+          , "  To rerun use: --match \"/foo/\" --seed 0"+          , ""+          , "Randomized with seed 0"+          , ""+          , "Finished in 0.0000 seconds"+          , "1 example, 1 failure"+          ]++    context "with --diff" $ do+      it "shows colorized diffs" $ do+        r <- capture_ . ignoreExitCode . withArgs ["--diff", "--color"] . H.hspec $ do+          H.it "foo" $ do+            23 `H.shouldBe` (42 :: Int)+        r `shouldContain` unlines [+            red "       expected: " ++ red "42"+          , red "        but got: " ++ green "23"+          ]++    context "with --no-diff" $ do+      it "it does not show colorized diffs" $ do+        r <- capture_ . ignoreExitCode . withArgs ["--no-diff", "--color"] . H.hspec $ do+          H.it "foo" $ do+            23 `H.shouldBe` (42 :: Int)+        r `shouldContain` unlines [+            red "       expected: " ++ "42"+          , red "        but got: " ++ "23"+          ]++    context "with --diff-context" $ do+      it "suppresses excessive diff output" $ do+        let+          args = ["--seed=0", "--format=failed-examples", "--diff-context=1"]+          expected = map show [1 .. 99 :: Int]+          actual = replace "50" "foo" expected+        r <- fmap (unlines . normalizeSummary . lines) . capture_ . ignoreExitCode . withArgs args . H.hspec . removeLocations $ do+          H.it "foo" $ do+            unlines actual `H.shouldBe` unlines expected+        r `shouldBe` unlines [+            ""+          , "Failures:"+          , ""+          , "  1) foo"+          , "       expected: @@ 48 lines omitted @@"+          , "                 49"+          , "                 50"+          , "                 51"+          , "                 @@ 48 lines omitted @@"+          , "                 "+          , "        but got: @@ 48 lines omitted @@"+          , "                 49"+          , "                 foo"+          , "                 51"+          , "                 @@ 48 lines omitted @@"+          , "                 "+          , ""+          , "  To rerun use: --match \"/foo/\" --seed 0"+          , ""+          , "Randomized with seed 0"+          , ""+          , "Finished in 0.0000 seconds"+          , "1 example, 1 failure"+          ]++    context "with --diff-command" $ do+      it "uses an external diff command" $ do+        let+          args = ["--seed=0", "--format=failed-examples", "--diff-command", "diff -u -L expected -L actual"]+          expected = map show [1 .. 99 :: Int]+          actual = replace "50" "foo" expected+        r <- fmap (unlines . normalizeSummary . lines) . capture_ . ignoreExitCode . withArgs args . H.hspec . removeLocations $ do+          H.it "foo" $ do+            unlines actual `H.shouldBe` unlines expected+        r `shouldBe` unlines [+            ""+          , "Failures:"+          , ""+          , "  1) foo"+          , "--- expected"+          , "+++ actual"+          , "@@ -47,7 +47,7 @@"+          , " 47"+          , " 48"+          , " 49"+          , "-50"+          , "+foo"+          , " 51"+          , " 52"+          , " 53"+          , ""+          , "  To rerun use: --match \"/foo/\" --seed 0"+          , ""+          , "Randomized with seed 0"+          , ""+          , "Finished in 0.0000 seconds"+          , "1 example, 1 failure"+          ]++    context "with --print-slow-items" $ do+      it "prints slow items" $ do+        r <- fmap lines . hCapture_ [stdout, stderr] . ignoreExitCode . withArgs ["--print-slow-items"] . H.hspec $ do+          H.it "foo" $ threadDelay 2000+        normalizeTimes (normalizeSummary r) `shouldBe` [+            ""+          , "foo [✔]"+          , ""+          , "Finished in 0.0000 seconds"+          , "1 example, 0 failures"+          , ""+          , "Slow spec items:"+          , "  test" </> "Test" </> "Hspec" </> "Core" </> "RunnerSpec.hs:" <> show (__LINE__ - 9 :: Int) <> ":11: /foo/ (2ms)"+          ]+     context "with --format" $ do       it "uses specified formatter" $ do         r <- capture_ . ignoreExitCode . withArgs ["--format", "progress"] . H.hspec $ do@@ -328,26 +772,65 @@           r `shouldContain` "invalid argument `foo' for `--format'"      context "with --qc-max-success" $ do+      let+        run :: HasCallStack => String -> IO ()+        run option = do+          m <- newMock+          hspec [option, "23"] $ do+            H.it "foo" $ property $ \(_ :: Int) -> do+              mockAction m+          mockCounter m `shouldReturn` 23+       it "tries QuickCheck properties specified number of times" $ do-        m <- newMock-        silence . withArgs ["--qc-max-success", "23"] . H.hspec $ do-          H.it "foo" $ property $ \(_ :: Int) -> do-            mockAction m-        mockCounter m `shouldReturn` 23+        run "--qc-max-success" +      it "accepts --maximum-generated-tests as an alias" $ do+        run "--maximum-generated-tests"+       context "when run with --rerun" $ do         it "takes precedence" $ do-          ["--qc-max-success", "23"] `shouldUseArgs` ((== 23) . QC.maxSuccess)-          ["--rerun", "--qc-max-success", "42"] `shouldUseArgs` ((== 42) . QC.maxSuccess)+          ["--qc-max-success", "23"] `shouldUseArgs` (QC.maxSuccess, 23)+          ["--rerun", "--qc-max-success", "42"] `shouldUseArgs` (QC.maxSuccess, 42) +    context "with --qc-max-discard" $ do+      it "passes specified maxDiscardRatio to QuickCheck properties" $ do+        ["--qc-max-discard", "23"] `shouldUseArgs` (QC.maxDiscardRatio, 23)+     context "with --qc-max-size" $ do-      it "passes specified size to QuickCheck properties" $ do-        ["--qc-max-size", "23"] `shouldUseArgs` ((== 23) . QC.maxSize)+      it "passes specified maxSize to QuickCheck properties" $ do+        ["--qc-max-size", "23"] `shouldUseArgs` (QC.maxSize, 23) -    context "with --qc-max-discard" $ do-      it "uses specified discard ratio to QuickCheck properties" $ do-        ["--qc-max-discard", "23"] `shouldUseArgs` ((== 23) . QC.maxDiscardRatio)+    context "with --qc-max-shrinks" $ do+      it "passes specified maxShrinks to QuickCheck properties" $ do+        ["--qc-max-shrinks", "23"] `shouldUseArgs` (QC.maxShrinks, 23) +    describe "Test.QuickCheck.Args.chatty" $ do+      let+        setChatty value args = args { chatty = value }+        withChatty value = hspecCapture [] .  H.modifyArgs (setChatty value) $ do+          H.it "foo" $ once $ property True++      context "when True" $ do+        it "includes informational output" $ do+          withChatty True `shouldReturn` unlines [+              ""+            , "foo [✔]"+            , "  +++ OK, passed 1 test."+            , ""+            , "Finished in 0.0000 seconds"+            , "1 example, 0 failures"+            ]++      context "when False" $ do+        it "suppresses informational output" $ do+          withChatty False `shouldReturn` unlines [+              ""+            , "foo [✔]"+            , ""+            , "Finished in 0.0000 seconds"+            , "1 example, 0 failures"+            ]+     context "with --seed" $ do       it "uses specified seed" $ do         r <- runPropFoo ["--seed", "42"]@@ -383,21 +866,25 @@       it "marks successful examples with CSS class hspec-success" $ do         r <- capture_ . withArgs ["--html"] . H.hspec $ do           H.it "foo" True-        r `shouldContain` "<span class=\"hspec-success\">foo\n</span>"+        r `shouldContain` "foo [<span class=\"hspec-success\">✔</span>]\n"        it "marks pending examples with CSS class hspec-pending" $ do         r <- capture_ . withArgs ["--html"] . H.hspec $ do           H.it "foo" H.pending-        r `shouldContain` "<span class=\"hspec-pending\">foo"+        r `shouldContain` "foo [<span class=\"hspec-pending\">‐</span>]\n"        it "marks failed examples with CSS class hspec-failure" $ do         r <- capture_ . ignoreExitCode . withArgs ["--html"] . H.hspec $ do           H.it "foo" False-        r `shouldContain` "<span class=\"hspec-failure\">foo"+        r `shouldContain` "foo [<span class=\"hspec-failure\">✘</span>]\n"    describe "hspecResult" $ do+    let+      hspecResult args = withArgs args . hspecResultSilent+      hspecResult_ = hspecResultSilent+     it "returns a summary of the test run" $ do-      silence . H.hspecResult $ do+      hspecResult_ $ do         H.it "foo" True         H.it "foo" False         H.it "foo" False@@ -406,32 +893,36 @@       `shouldReturn` H.Summary 5 2      it "treats uncaught exceptions as failure" $ do-      silence . H.hspecResult  $ do-        H.it "foobar" throwException+      hspecResult_  $ do+        H.it "foobar" throwException_       `shouldReturn` H.Summary 1 1 +    it "handles unguarded exceptions in runner" $ do+      let+        throwExceptionThatIsNotGuardedBy_safeTry :: H.Item () -> H.Item ()+        throwExceptionThatIsNotGuardedBy_safeTry item = item {+          H.itemExample = \ _params _hook _progress -> throwIO DivideByZero+        }+      hspecResult_ $ H.mapSpecItem_ throwExceptionThatIsNotGuardedBy_safeTry $ do+        H.it "foo" True+      `shouldReturn` H.Summary 1 1+     it "uses the specdoc formatter by default" $ do       _:r:_ <- captureLines . H.hspecResult $ do         H.describe "Foo.Bar" $ do           H.it "some example" True       r `shouldBe` "Foo.Bar" -    it "can use a custom formatter" $ do-      r <- capture_ . H.hspecWithResult H.defaultConfig {H.configFormatter = Just H.silent} $ do-        H.describe "Foo.Bar" $ do-          H.it "some example" True-      r `shouldBe` ""-     it "does not let escape error thunks from failure messages" $ do-      r <- silence . H.hspecResult $ do-        H.it "some example" (H.Fail Nothing $ "foobar" ++ undefined)+      r <- hspecResult_ $ do+        H.it "some example" (H.Result "" $ H.Failure Nothing . H.Reason $ "foobar" ++ undefined)       r `shouldBe` H.Summary 1 1      it "runs specs in parallel" $ do-      let n = 10+      let n = 100           t = 0.01           dt = t * (fromIntegral n / 2)-      r <- timeout dt . silence . withArgs ["-j", show n] . H.hspecResult . H.parallel $ do+      r <- timeout dt . hspecResult ["-j", show n] . H.parallel $ do         replicateM_ n (H.it "foo" $ sleep t)       r `shouldBe` Just (H.Summary n 0) @@ -446,8 +937,91 @@               current <- atomicModifyIORef currentRef $ \x -> let y = succ x in (y, y)               atomicModifyIORef highRef $ \x -> (max x current, ())             stop = atomicModifyIORef currentRef $ \x -> (pred x, ())-        r <- withArgs ["-j", show j] . H.hspecResult . H.parallel $ do-          replicateM_ n $ H.it "foo" $ E.bracket_ start stop $ sleep t+        r <- hspecResult ["-j", show j] . H.parallel $ do+          replicateM_ n $ H.it "foo" $ bracket_ start stop $ sleep t         r `shouldBe` H.Summary n 0         high <- readIORef highRef         high `shouldBe` j++  describe "colorOutputSupported" $ do+    context "without a terminal device" $ do++      let isTerminalDevice = return False++      it "disables color output" $ do+        H.colorOutputSupported H.ColorAuto isTerminalDevice `shouldReturn` ColorDisabled++      context "with GITHUB_ACTIONS=true" $ do+        it "enable color output" $ do+          withEnvironment [("GITHUB_ACTIONS", "true")] $ do+            H.colorOutputSupported H.ColorAuto isTerminalDevice `shouldReturn` ColorEnabled ProgressReportingDisabled++    context "with a terminal device" $ do++      let isTerminalDevice = return True++      it "enable color output" $ do+        H.colorOutputSupported H.ColorAuto isTerminalDevice `shouldReturn` ColorEnabled ProgressReportingEnabled++      context "with BUILDKITE=true" $ do+        it "disables progress reporting" $ do+          withEnvironment [("BUILDKITE", "true")] $ do+            H.colorOutputSupported H.ColorAuto isTerminalDevice `shouldReturn` ColorEnabled ProgressReportingDisabled++      context "when NO_COLOR is set" $ do+        it "disables color output" $ do+          withEnvironment [("NO_COLOR", "yes")] $ do+            H.colorOutputSupported H.ColorAuto isTerminalDevice `shouldReturn` ColorDisabled++  describe "unicodeOutputSupported" $ do+    context "with UnicodeAlways" $ do+      it "returns True" $ do+        H.unicodeOutputSupported H.UnicodeAlways undefined `shouldReturn` True++    context "with UnicodeNever" $ do+      it "returns False" $ do+        H.unicodeOutputSupported H.UnicodeNever undefined `shouldReturn` False++    context "with UnicodeAuto" $ do+      context "when file encoding is UTF-8" $ do+        it "returns True" $ do+          inTempDirectory $ do+            withFile "foo" WriteMode $ \ h -> do+              hSetEncoding h utf8+              H.unicodeOutputSupported H.UnicodeAuto h `shouldReturn` True++      context "when file encoding is not UTF-8" $ do+        it "returns False" $ do+          inTempDirectory $ do+            withFile "foo" WriteMode $ \ h -> do+              hSetEncoding h latin1+              H.unicodeOutputSupported H.UnicodeAuto h `shouldReturn` False++  describe "rerunAll" $ do+    let+      report = FailureReport 0 0 0 0 [([], "foo")]+      config = H.defaultConfig {H.configRerun = True, H.configRerunAllOnSuccess = True}+      result = SpecResult [] True+    context "with --rerun, --rerun-all-on-success, previous failures, on success" $ do+      it "returns True" $ do+        H.rerunAll config (Just report) result `shouldBe` True++    context "without --rerun" $ do+      it "returns False" $ do+        H.rerunAll config {H.configRerun = False} (Just report) result `shouldBe` False++    context "without --rerun-all-on-success" $ do+      it "returns False" $ do+        H.rerunAll config {H.configRerunAllOnSuccess = False} (Just report) result `shouldBe` False++    context "without previous failures" $ do+      it "returns False" $ do+        H.rerunAll config (Just report {failureReportPaths = []}) result `shouldBe` False++    context "without failure report" $ do+      it "returns False" $ do+        H.rerunAll config Nothing result `shouldBe` False++    context "on failure" $ do+      it "returns False" $ do+        H.rerunAll config (Just report) result { specResultSuccess = False } `shouldBe` False
+ test/Test/Hspec/Core/ShuffleSpec.hs view
@@ -0,0 +1,47 @@+module Test.Hspec.Core.ShuffleSpec (spec) where++import           Prelude ()+import           Helper++import qualified Test.Hspec.Core.Shuffle as H+import           Test.Hspec.Core.Tree++import           Data.Array.ST+import           Control.Monad.ST+import           Data.STRef+import           System.Random++spec :: Spec+spec = do+  describe "shuffleForest" $ do+    let+      shuffleForest :: Int -> [Tree () Int] -> [Tree () Int]+      shuffleForest seed xs = runST $ do+        gen <- newSTRef (mkStdGen seed)+        H.shuffleForest gen xs++    it "shuffles a forest" $ do+      shuffleForest 2+        [Leaf 1, Leaf 2, Leaf 3] `shouldBe`+        [Leaf 3, Leaf 1, Leaf 2]++    it "recurses into Node" $ do+      shuffleForest 1+        [Node "foo" [Node "bar" [Leaf 1, Leaf 2, Leaf 3]]] `shouldBe`+        [Node "foo" [Node "bar" [Leaf 2, Leaf 3, Leaf 1]]]++    it "recurses into NodeWithCleanup" $ do+      shuffleForest 1+        [NodeWithCleanup Nothing () [NodeWithCleanup Nothing () [Leaf 1, Leaf 2, Leaf 3]]] `shouldBe`+        [NodeWithCleanup Nothing () [NodeWithCleanup Nothing () [Leaf 2, Leaf 3, Leaf 1]]]++  describe "shuffle" $ do+    it "shuffles a list" $ do+      runST $ do+        gen <- newSTRef (mkStdGen 2)+        H.shuffle gen [1, 2, 3 :: Int]+      `shouldBe` [3, 1, 2]++  describe "mkArray" $ do+    it "creates an STArray from a list" $ do+      runST (H.mkArray [1, 2, 3 :: Int] >>= getElems) `shouldBe` [1, 2, 3]
test/Test/Hspec/Core/SpecSpec.hs view
@@ -1,24 +1,41 @@-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-}-module Test.Hspec.Core.SpecSpec (main, spec) where+module Test.Hspec.Core.SpecSpec (spec) where  import           Prelude () import           Helper -import           Test.Hspec.Core.Spec (Item(..), Result(..))+import           Test.Hspec.Core.Spec (Item(..), Result(..), ResultStatus(..)) import qualified Test.Hspec.Core.Runner as H-import           Test.Hspec.Core.Spec (Tree(..), runSpecM)+import           Test.Hspec.Core.Spec (Tree(..))  import qualified Test.Hspec.Core.Spec as H -main :: IO ()-main = hspec spec+extract :: (Item () -> a) -> H.Spec -> IO [Tree () a]+extract f = fmap (H.bimapForest (const ()) f) . fmap snd . H.runSpecM  runSpec :: H.Spec -> IO [String] runSpec = captureLines . H.hspecResult  spec :: Spec spec = do+  let+    runSpecM :: H.SpecWith a -> IO [H.SpecTree a]+    runSpecM = fmap snd . H.runSpecM++    runItem :: Item () -> IO Result+    runItem item = itemExample item defaultParams ($ ()) noOpProgressCallback++  describe "getSpecDescriptionPath" $ do+    it "returns the spec path" $ do+      let descriptionPathShouldBe xs =+            H.getSpecDescriptionPath >>= H.runIO . (`shouldBe` xs)+      void . runSpecM $ do+        descriptionPathShouldBe []+        H.describe "foo" $ do+          H.describe "bar" $ do+            descriptionPathShouldBe ["foo", "bar"]+            H.it "baz" True+   describe "describe" $ do     it "can be nested" $ do       [Node foo [Node bar [Leaf _]]] <- runSpecM $ do@@ -30,8 +47,13 @@     context "when no description is given" $ do       it "uses a default description" $ do         [Node d _] <- runSpecM (H.describe "" (pure ()))-        d `shouldBe` "(no description given)"+        d `shouldBe` "Test.Hspec.Core.SpecSpec[" ++ show (pred __LINE__ :: Int) ++ ":33]" +  describe "xdescribe" $ do+    it "creates a tree of pending spec items" $ do+      [Node _ [Leaf item]] <- runSpecM (H.xdescribe "" $ H.it "whatever" True)+      runItem item `shouldReturn` Result "" (Pending Nothing Nothing)+   describe "it" $ do     it "takes a description of a desired behavior" $ do       [Leaf item] <- runSpecM (H.it "whatever" True)@@ -39,41 +61,62 @@      it "takes an example of that behavior" $ do       [Leaf item] <- runSpecM (H.it "whatever" True)-      itemExample item defaultParams ($ ()) noOpProgressCallback `shouldReturn` Success+      runItem item `shouldReturn` Result "" Success -#ifdef HAS_SOURCE_LOCATIONS     it "adds source locations" $ do       [Leaf item] <- runSpecM (H.it "foo" True)-      let location = H.Location __FILE__ (pred $ __LINE__) 32 H.ExactLocation-      itemLocation item `shouldBe` Just location-#endif+      let location = mkLocation __FILE__ (pred __LINE__) 32+      itemLocation item `shouldBe` location -    context "when no description is given" $ do-      it "uses a default description" $ do-        [Leaf item] <- runSpecM (H.it "" True)-        itemRequirement item `shouldBe` "(unspecified behavior)"+  describe "xit" $ do+    it "creates a pending spec item" $ do+      [Leaf item] <- runSpecM (H.xit "whatever" True)+      runItem item `shouldReturn` Result "" (Pending Nothing Nothing)    describe "pending" $ do     it "specifies a pending example" $ do       r <- runSpec $ do         H.it "foo" H.pending-      r `shouldSatisfy` any (== "     # PENDING: No reason given")+      r `shouldSatisfy` any (== "  # PENDING: No reason given")    describe "pendingWith" $ do     it "specifies a pending example with a reason for why it's pending" $ do       r <- runSpec $ do         H.it "foo" $ do           H.pendingWith "for some reason"-      r `shouldSatisfy` any (== "     # PENDING: for some reason")+      r `shouldSatisfy` any (== "  # PENDING: for some reason") +  describe "focus" $ do+    it "focuses spec items" $ do+      items <- extract itemIsFocused $ H.focus $ do+        H.it "is focused and will run" True+        H.it "is also focused and will also run" True+      items `shouldBe` [Leaf True, Leaf True]++    context "when applied to a spec with focused spec items" $ do+      it "has no effect" $ do+        items <- extract itemIsFocused $ H.focus $ do+          H.focus $ H.it "is focused and will run" True+          H.it "is not focused and will not run" True+        items `shouldBe` [Leaf True, Leaf False]+   describe "parallel" $ do     it "marks examples for parallel execution" $ do-      [Leaf item] <- runSpecM . H.parallel $ H.it "whatever" True-      itemIsParallelizable item `shouldBe` True+      items <- extract itemIsParallelizable . H.parallel $ H.it "whatever" H.pending+      items `shouldBe` [Leaf $ Just True]      it "is applied recursively" $ do-      [Node _ [Node _ [Leaf item]]] <- runSpecM . H.parallel $ do+      items <- extract itemIsParallelizable . H.parallel $ do         H.describe "foo" $ do           H.describe "bar" $ do-            H.it "baz" True-      itemIsParallelizable item `shouldBe` True+            H.it "baz" H.pending+      items `shouldBe` [Node "foo" [Node "bar" [Leaf $ Just True]]]++  describe "sequential" $ do+    it "marks examples for sequential execution" $ do+      items <- extract itemIsParallelizable . H.sequential $ H.it "whatever" H.pending+      items `shouldBe` [Leaf $ Just False]++    it "takes precedence over a later `parallel`" $ do+      items <- extract itemIsParallelizable . H.parallel . H.sequential $ H.it "whatever" H.pending+      items `shouldBe` [Leaf $ Just False]
+ test/Test/Hspec/Core/TimerSpec.hs view
@@ -0,0 +1,32 @@+module Test.Hspec.Core.TimerSpec (spec) where++import           Prelude ()+import           Helper++-- import           Test.Hspec.Core.Timer++spec :: Spec+spec = do+  describe "timer action provided by withTimer" $ do+    pass -- this test is fragile, see e.g. https://github.com/hspec/hspec/issues/352++{-+    let+      dt = 0.01+      wait = sleep (dt * 1.1)++    it "returns False" $ do+      withTimer dt $ \timer -> do+        timer `shouldReturn` False++    context "after specified time" $ do+      it "returns True" $ do+        withTimer dt $ \timer -> do+          wait+          timer `shouldReturn` True+          timer `shouldReturn` False+          wait+          wait+          timer `shouldReturn` True+          timer `shouldReturn` False+          -}
+ test/Test/Hspec/Core/TreeSpec.hs view
@@ -0,0 +1,12 @@+module Test.Hspec.Core.TreeSpec (spec) where++import           Prelude ()+import           Helper++import           Test.Hspec.Core.Tree++spec :: Spec+spec = do+  describe "toModuleName" $ do+    it "derives a module name from a FilePath" $ do+      toModuleName "src/Foo/Bar.hs" `shouldBe` "Foo.Bar"
test/Test/Hspec/Core/UtilSpec.hs view
@@ -1,14 +1,12 @@-module Test.Hspec.Core.UtilSpec (main, spec) where+module Test.Hspec.Core.UtilSpec (spec) where +import           Prelude () import           Helper+ import           Control.Concurrent-import qualified Control.Exception as E  import           Test.Hspec.Core.Util -main :: IO ()-main = hspec spec- spec :: Spec spec = do   describe "pluralize" $ do@@ -23,12 +21,16 @@    describe "formatException" $ do     it "converts exception to string" $ do-      formatException (E.toException E.DivideByZero) `shouldBe` "ArithException (divide by zero)"+      formatException (toException DivideByZero) `shouldBe` "ArithException\ndivide by zero"      context "when used with an IOException" $ do       it "includes the IOErrorType" $ do-        Left e <- E.try (readFile "foo")-        formatException e `shouldBe` "IOException of type NoSuchThing (foo: openFile: does not exist (No such file or directory))"+        inTempDirectory $ do+          Left e <- try (readFile "foo")+          formatException e `shouldBe` intercalate "\n" [+              "IOException of type NoSuchThing"+            , "foo: openFile: does not exist (No such file or directory)"+            ]    describe "lineBreaksAt" $ do     it "inserts line breaks at word boundaries" $ do@@ -41,6 +43,18 @@         , "sed do eiusmod"         ] +    it "preserves existing line breaks" $ do+      lineBreaksAt 10 "foo bar baz\none two three" `shouldBe` [+          "foo bar"+        , "baz"+        , "one two"+        , "three"+        ]++  describe "stripAnsi" $ do+    it "removes ANSI color sequences" $ do+      stripAnsi ("some " <> green "colorized" <> " text") `shouldBe` "some colorized text"+   describe "safeTry" $ do     it "returns Right on success" $ do       Right e <- safeTry (return 23 :: IO Int)@@ -48,21 +62,21 @@      it "returns Left on exception" $ do       Left e <- safeTry throwException-      show e `shouldBe` "foobar"+      fromException e `shouldBe` Just DivideByZero      it "evaluates result to weak head normal form" $ do-      Left e <- safeTry (return $ E.throw $ E.ErrorCall "foo")+      Left e <- safeTry (return $ throw $ ErrorCall "foo")       show e `shouldBe` "foo"      it "does not catch asynchronous exceptions" $ do       mvar <- newEmptyMVar       sync <- newEmptyMVar       threadId <- forkIO $ do-        safeTry (putMVar sync () >> threadDelay 1000000) >> return ()-        `E.catch` putMVar mvar+        safeTry (putMVar sync () >> threadDelay 1000000) >> pass+        `catch` putMVar mvar       takeMVar sync-      throwTo threadId E.UserInterrupt-      readMVar mvar `shouldReturn` E.UserInterrupt+      throwTo threadId UserInterrupt+      readMVar mvar `shouldReturn` UserInterrupt    describe "filterPredicate" $ do     it "tries to match a pattern against a path" $ do@@ -79,15 +93,20 @@       let p = filterPredicate "bar/baz"       p (["foo", "bar", "baz"], "example 1") `shouldBe` True -    it "succeeds with a pattern that matches the message give in the failure list" $ do+    it "succeeds with a pattern that matches the message given in the failure list" $ do       let p = filterPredicate "ModuleA.ModuleB.foo does something"       p (["ModuleA", "ModuleB", "foo"], "does something") `shouldBe` True +    context "with an absolute path that begins or ends with a slash" $ do+      it "succeeds" $ do+        let p = filterPredicate "/foo/bar/baz/example 1/"+        p (["foo", "bar", "baz"], "example 1") `shouldBe` True+   describe "formatRequirement" $ do     it "creates a sentence from a subject and a requirement" $ do       formatRequirement (["reverse"], "reverses a list") `shouldBe` "reverse reverses a list" -    it "creates a sentence from a subject and a requirement when the subject consits of multiple words" $ do+    it "creates a sentence from a subject and a requirement when the subject consists of multiple words" $ do       formatRequirement (["The reverse function"], "reverses a list") `shouldBe` "The reverse function reverses a list"      it "returns the requirement if no subject is given" $ do
− test/Test/Hspec/FailureReportSpec.hs 
@@ -1,17 +0,0 @@-module Test.Hspec.FailureReportSpec (main, spec) where--import           Helper--import           System.IO-import qualified Control.Exception as E-import           Test.Hspec.FailureReport--main :: IO ()-main = hspec spec--spec :: Spec-spec = do-  describe "writeFailureReport" $ do-    it "prints a warning on unexpected exceptions" $ do-      r <- hCapture_ [stderr] $ writeFailureReport (E.throw (E.ErrorCall "some error"))-      r `shouldBe` "WARNING: Could not write environment variable HSPEC_FAILURES (some error)\n"
− test/Test/Hspec/OptionsSpec.hs 
@@ -1,53 +0,0 @@-module Test.Hspec.OptionsSpec (main, spec) where--import           Control.Monad-import           Helper-import           System.Exit--import qualified Test.Hspec.Options as Options-import           Test.Hspec.Options hiding (parseOptions)--main :: IO ()-main = hspec spec--fromLeft :: Either a b -> a-fromLeft (Left a) = a-fromLeft _ = error "fromLeft: No left value!"--spec :: Spec-spec = do-  describe "parseOptions" $ do--    let parseOptions = Options.parseOptions defaultConfig "my-spec"--    it "sets configColorMode to ColorAuto" $ do-      configColorMode <$> parseOptions [] `shouldBe` Right ColorAuto--    context "with --no-color" $ do-      it "sets configColorMode to ColorNever" $ do-        configColorMode <$> parseOptions ["--no-color"] `shouldBe` Right ColorNever--    context "with --color" $ do-      it "sets configColorMode to ColorAlways" $ do-        configColorMode <$> parseOptions ["--color"] `shouldBe` Right ColorAlways--    context "with --out" $ do-      it "sets configOutputFile" $ do-        either (const Nothing) Just . configOutputFile <$> parseOptions ["--out", "foo"] `shouldBe` Right (Just "foo")--    context "with --qc-max-success" $ do-      context "when given an invalid argument" $ do-        it "returns an error message" $ do-          fromLeft (parseOptions ["--qc-max-success", "foo"]) `shouldBe` (ExitFailure 1, "my-spec: invalid argument `foo' for `--qc-max-success'\nTry `my-spec --help' for more information.\n")--    context "with --depth" $ do-      it "sets depth parameter for SmallCheck" $ do-        configSmallCheckDepth <$> parseOptions ["--depth", "23"] `shouldBe` Right 23--    context "with --jobs" $ do-      it "sets number of concurrent jobs" $ do-        configConcurrentJobs <$> parseOptions ["--jobs=23"] `shouldBe` Right (Just 23)--      it "rejects values < 1" $ do-        let msg = "my-spec: invalid argument `0' for `--jobs'\nTry `my-spec --help' for more information.\n"-        void (parseOptions ["--jobs=0"]) `shouldBe` Left (ExitFailure 1, msg)
− test/Test/Hspec/TimerSpec.hs 
@@ -1,29 +0,0 @@-module Test.Hspec.TimerSpec (main, spec) where--import           Helper--import           Test.Hspec.Timer--main :: IO ()-main = hspec spec--spec :: Spec-spec = do-  describe "timer action returned by newTimer" $ do--    let dt = 0.01--    it "returns False" $ do-      timer <- newTimer dt-      timer `shouldReturn` False--    context "after specified time" $ do-      it "returns True" $ do-        timer <- newTimer dt-        sleep dt-        timer `shouldReturn` True-        timer `shouldReturn` False-        sleep dt-        sleep dt-        timer `shouldReturn` True-        timer `shouldReturn` False
+ vendor/Data/Algorithm/Diff.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}+#if __GLASGOW_HASKELL__ >= 908+{-# OPTIONS_GHC -fno-warn-x-partial #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Algorithm.Diff+-- Copyright   :  (c) Sterling Clover 2008-2011, Kevin Charter 2011+-- License     :  BSD 3 Clause+-- Maintainer  :  s.clover@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- This is an implementation of the O(ND) diff algorithm as described in+-- \"An O(ND) Difference Algorithm and Its Variations (1986)\"+-- <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.4.6927>. It is O(mn) in space.+-- The algorithm is the same one used by standared Unix diff.+-----------------------------------------------------------------------------++module Data.Algorithm.Diff+    ( Diff(..)+    -- * Comparing lists for differences+    , getDiff+    , getDiffBy++    -- * Finding chunks of differences+    , getGroupedDiff+    , getGroupedDiffBy+    ) where++import Prelude hiding (pi)++import Data.Array++data DI = F | S | B deriving (Show, Eq)++-- | A value is either from the 'First' list, the 'Second' or from 'Both'.+-- 'Both' contains both the left and right values, in case you are using a form+-- of equality that doesn't check all data (for example, if you are using a+-- newtype to only perform equality on side of a tuple).+data Diff a = First a | Second a | Both a a deriving (Show, Eq, Functor)++data DL = DL {poi :: !Int, poj :: !Int, path::[DI]} deriving (Show, Eq)++instance Ord DL+        where x <= y = if poi x == poi y+                then  poj x > poj y+                else poi x <= poi y++canDiag :: (a -> a -> Bool) -> [a] -> [a] -> Int -> Int -> Int -> Int -> Bool+canDiag eq as bs lena lenb = \ i j ->+   if i < lena && j < lenb then (arAs ! i) `eq` (arBs ! j) else False+    where arAs = listArray (0,lena - 1) as+          arBs = listArray (0,lenb - 1) bs++dstep :: (Int -> Int -> Bool) -> [DL] -> [DL]+dstep cd dls = hd:pairMaxes rst+  where (hd:rst) = nextDLs dls+        nextDLs [] = []+        nextDLs (dl:rest) = dl':dl'':nextDLs rest+          where dl'  = addsnake cd $ dl {poi=poi dl + 1, path=(F : pdl)}+                dl'' = addsnake cd $ dl {poj=poj dl + 1, path=(S : pdl)}+                pdl = path dl+        pairMaxes [] = []+        pairMaxes [x] = [x]+        pairMaxes (x:y:rest) = max x y:pairMaxes rest++addsnake :: (Int -> Int -> Bool) -> DL -> DL+addsnake cd dl+    | cd pi pj = addsnake cd $+                 dl {poi = pi + 1, poj = pj + 1, path=(B : path dl)}+    | otherwise   = dl+    where pi = poi dl; pj = poj dl++lcs :: (a -> a -> Bool) -> [a] -> [a] -> [DI]+lcs eq as bs = path . head . dropWhile (\dl -> poi dl /= lena || poj dl /= lenb) .+            concat . iterate (dstep cd) . (:[]) . addsnake cd $+            DL {poi=0,poj=0,path=[]}+            where cd = canDiag eq as bs lena lenb+                  lena = length as; lenb = length bs++-- | Takes two lists and returns a list of differences between them. This is+-- 'getDiffBy' with '==' used as predicate.+getDiff :: (Eq t) => [t] -> [t] -> [Diff t]+getDiff = getDiffBy (==)++-- | Takes two lists and returns a list of differences between them, grouped+-- into chunks. This is 'getGroupedDiffBy' with '==' used as predicate.+getGroupedDiff :: (Eq t) => [t] -> [t] -> [Diff [t]]+getGroupedDiff = getGroupedDiffBy (==)++-- | A form of 'getDiff' with no 'Eq' constraint. Instead, an equality predicate+-- is taken as the first argument.+getDiffBy :: (t -> t -> Bool) -> [t] -> [t] -> [Diff t]+getDiffBy eq a b = markup a b . reverse $ lcs eq a b+    where markup (x:xs)   ys   (F:ds) = First x  : markup xs ys ds+          markup   xs   (y:ys) (S:ds) = Second y : markup xs ys ds+          markup (x:xs) (y:ys) (B:ds) = Both x y : markup xs ys ds+          markup _ _ _ = []++getGroupedDiffBy :: (t -> t -> Bool) -> [t] -> [t] -> [Diff [t]]+getGroupedDiffBy eq a b = go $ getDiffBy eq a b+    where go (First x  : xs) = let (fs, rest) = goFirsts  xs in First  (x:fs)     : go rest+          go (Second x : xs) = let (fs, rest) = goSeconds xs in Second (x:fs)     : go rest+          go (Both x y : xs) = let (fs, rest) = goBoth    xs+                                   (fxs, fys) = unzip fs+                               in Both (x:fxs) (y:fys) : go rest+          go [] = []++          goFirsts  (First x  : xs) = let (fs, rest) = goFirsts  xs in (x:fs, rest)+          goFirsts  xs = ([],xs)++          goSeconds (Second x : xs) = let (fs, rest) = goSeconds xs in (x:fs, rest)+          goSeconds xs = ([],xs)++          goBoth    (Both x y : xs) = let (fs, rest) = goBoth xs    in ((x,y):fs, rest)+          goBoth    xs = ([],xs)
+ vendor/async-2.2.5/Control/Concurrent/Async.hs view
@@ -0,0 +1,870 @@+{-# LANGUAGE CPP, MagicHash, UnboxedTuples, RankNTypes,+    ExistentialQuantification #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif+#if __GLASGOW_HASKELL__ < 710+{-# LANGUAGE DeriveDataTypeable #-}+#endif+{-# OPTIONS -Wall -fno-warn-implicit-prelude -fno-warn-unused-imports #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Concurrent.Async.Internal+-- Copyright   :  (c) Simon Marlow 2012+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainer  :  Simon Marlow <marlowsd@gmail.com>+-- Stability   :  provisional+-- Portability :  non-portable (requires concurrency)+--+-- This module is an internal module. The public API is provided in+-- "Control.Concurrent.Async". Breaking changes to this module will not be+-- reflected in a major bump, and using this module may break your code+-- unless you are extremely careful.+--+-----------------------------------------------------------------------------++module Control.Concurrent.Async where++import Control.Concurrent.STM.TMVar+import Control.Exception+import Control.Concurrent+import qualified Data.Foldable as F+#if !MIN_VERSION_base(4,6,0)+import Prelude hiding (catch)+#endif+import Control.Monad+import Control.Applicative+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (Monoid(mempty,mappend))+import Data.Traversable+#endif+#if __GLASGOW_HASKELL__ < 710+import Data.Typeable+#endif+#if MIN_VERSION_base(4,8,0)+import Data.Bifunctor+#endif+#if MIN_VERSION_base(4,9,0)+import Data.Semigroup (Semigroup((<>)))+#endif++import Data.IORef++import GHC.Exts+import GHC.IO hiding (finally, onException)+import GHC.Conc++-- -----------------------------------------------------------------------------+-- STM Async API+++-- | An asynchronous action spawned by 'async' or 'withAsync'.+-- Asynchronous actions are executed in a separate thread, and+-- operations are provided for waiting for asynchronous actions to+-- complete and obtaining their results (see e.g. 'wait').+--+data Async a = Async+  { asyncThreadId :: {-# UNPACK #-} !ThreadId+                  -- ^ Returns the 'ThreadId' of the thread running+                  -- the given 'Async'.+  , _asyncWait    :: STM (Either SomeException a)+  }++instance Eq (Async a) where+  Async a _ == Async b _  =  a == b++instance Ord (Async a) where+  Async a _ `compare` Async b _  =  a `compare` b++instance Functor Async where+  fmap f (Async a w) = Async a (fmap (fmap f) w)++-- | Compare two Asyncs that may have different types by their 'ThreadId'.+compareAsyncs :: Async a -> Async b -> Ordering+compareAsyncs (Async t1 _) (Async t2 _) = compare t1 t2++-- | Spawn an asynchronous action in a separate thread.+--+-- Like for 'forkIO', the action may be left running unintentionally+-- (see module-level documentation for details).+--+-- __Use 'withAsync' style functions wherever you can instead!__+async :: IO a -> IO (Async a)+async = inline asyncUsing rawForkIO++-- | Like 'async' but using 'forkOS' internally.+asyncBound :: IO a -> IO (Async a)+asyncBound = asyncUsing forkOS++-- | Like 'async' but using 'forkOn' internally.+asyncOn :: Int -> IO a -> IO (Async a)+asyncOn = asyncUsing . rawForkOn++-- | Like 'async' but using 'forkIOWithUnmask' internally.  The child+-- thread is passed a function that can be used to unmask asynchronous+-- exceptions.+asyncWithUnmask :: ((forall b . IO b -> IO b) -> IO a) -> IO (Async a)+asyncWithUnmask actionWith = asyncUsing rawForkIO (actionWith unsafeUnmask)++-- | Like 'asyncOn' but using 'forkOnWithUnmask' internally.  The+-- child thread is passed a function that can be used to unmask+-- asynchronous exceptions.+asyncOnWithUnmask :: Int -> ((forall b . IO b -> IO b) -> IO a) -> IO (Async a)+asyncOnWithUnmask cpu actionWith =+  asyncUsing (rawForkOn cpu) (actionWith unsafeUnmask)++asyncUsing :: (IO () -> IO ThreadId)+           -> IO a -> IO (Async a)+asyncUsing doFork = \action -> do+   var <- newEmptyTMVarIO+   -- t <- forkFinally action (\r -> atomically $ putTMVar var r)+   -- slightly faster:+   t <- mask $ \restore ->+          doFork $ try (restore action) >>= atomically . putTMVar var+   return (Async t (readTMVar var))++-- | Spawn an asynchronous action in a separate thread, and pass its+-- @Async@ handle to the supplied function.  When the function returns+-- or throws an exception, 'uninterruptibleCancel' is called on the @Async@.+--+-- > withAsync action inner = mask $ \restore -> do+-- >   a <- async (restore action)+-- >   restore (inner a) `finally` uninterruptibleCancel a+--+-- This is a useful variant of 'async' that ensures an @Async@ is+-- never left running unintentionally.+--+-- Note: a reference to the child thread is kept alive until the call+-- to `withAsync` returns, so nesting many `withAsync` calls requires+-- linear memory.+--+withAsync :: IO a -> (Async a -> IO b) -> IO b+withAsync = inline withAsyncUsing rawForkIO++-- | Like 'withAsync' but uses 'forkOS' internally.+withAsyncBound :: IO a -> (Async a -> IO b) -> IO b+withAsyncBound = withAsyncUsing forkOS++-- | Like 'withAsync' but uses 'forkOn' internally.+withAsyncOn :: Int -> IO a -> (Async a -> IO b) -> IO b+withAsyncOn = withAsyncUsing . rawForkOn++-- | Like 'withAsync' but uses 'forkIOWithUnmask' internally.  The+-- child thread is passed a function that can be used to unmask+-- asynchronous exceptions.+withAsyncWithUnmask+  :: ((forall c. IO c -> IO c) -> IO a) -> (Async a -> IO b) -> IO b+withAsyncWithUnmask actionWith =+  withAsyncUsing rawForkIO (actionWith unsafeUnmask)++-- | Like 'withAsyncOn' but uses 'forkOnWithUnmask' internally.  The+-- child thread is passed a function that can be used to unmask+-- asynchronous exceptions+withAsyncOnWithUnmask+  :: Int -> ((forall c. IO c -> IO c) -> IO a) -> (Async a -> IO b) -> IO b+withAsyncOnWithUnmask cpu actionWith =+  withAsyncUsing (rawForkOn cpu) (actionWith unsafeUnmask)++withAsyncUsing :: (IO () -> IO ThreadId)+               -> IO a -> (Async a -> IO b) -> IO b+-- The bracket version works, but is slow.  We can do better by+-- hand-coding it:+withAsyncUsing doFork = \action inner -> do+  var <- newEmptyTMVarIO+  mask $ \restore -> do+    t <- doFork $ try (restore action) >>= atomically . putTMVar var+    let a = Async t (readTMVar var)+    r <- restore (inner a) `catchAll` \e -> do+      uninterruptibleCancel a+      throwIO e+    uninterruptibleCancel a+    return r++-- | Wait for an asynchronous action to complete, and return its+-- value.  If the asynchronous action threw an exception, then the+-- exception is re-thrown by 'wait'.+--+-- > wait = atomically . waitSTM+--+{-# INLINE wait #-}+wait :: Async a -> IO a+wait = tryAgain . atomically . waitSTM+  where+    -- See: https://github.com/simonmar/async/issues/14+    tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f++-- | Wait for an asynchronous action to complete, and return either+-- @Left e@ if the action raised an exception @e@, or @Right a@ if it+-- returned a value @a@.+--+-- > waitCatch = atomically . waitCatchSTM+--+{-# INLINE waitCatch #-}+waitCatch :: Async a -> IO (Either SomeException a)+waitCatch = tryAgain . atomically . waitCatchSTM+  where+    -- See: https://github.com/simonmar/async/issues/14+    tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f++-- | Check whether an 'Async' has completed yet.  If it has not+-- completed yet, then the result is @Nothing@, otherwise the result+-- is @Just e@ where @e@ is @Left x@ if the @Async@ raised an+-- exception @x@, or @Right a@ if it returned a value @a@.+--+-- > poll = atomically . pollSTM+--+{-# INLINE poll #-}+poll :: Async a -> IO (Maybe (Either SomeException a))+poll = atomically . pollSTM++-- | A version of 'wait' that can be used inside an STM transaction.+--+waitSTM :: Async a -> STM a+waitSTM a = do+   r <- waitCatchSTM a+   either throwSTM return r++-- | A version of 'waitCatch' that can be used inside an STM transaction.+--+{-# INLINE waitCatchSTM #-}+waitCatchSTM :: Async a -> STM (Either SomeException a)+waitCatchSTM (Async _ w) = w++-- | A version of 'poll' that can be used inside an STM transaction.+--+{-# INLINE pollSTM #-}+pollSTM :: Async a -> STM (Maybe (Either SomeException a))+pollSTM (Async _ w) = (Just <$> w) `orElse` return Nothing++-- | Cancel an asynchronous action by throwing the @AsyncCancelled@+-- exception to it, and waiting for the `Async` thread to quit.+-- Has no effect if the 'Async' has already completed.+--+-- > cancel a = throwTo (asyncThreadId a) AsyncCancelled <* waitCatch a+--+-- Note that 'cancel' will not terminate until the thread the 'Async'+-- refers to has terminated. This means that 'cancel' will block for+-- as long said thread blocks when receiving an asynchronous exception.+--+-- For example, it could block if:+--+-- * It's executing a foreign call, and thus cannot receive the asynchronous+-- exception;+-- * It's executing some cleanup handler after having received the exception,+-- and the handler is blocking.+{-# INLINE cancel #-}+cancel :: Async a -> IO ()+cancel a@(Async t _) = throwTo t AsyncCancelled <* waitCatch a++-- | Cancel multiple asynchronous actions by throwing the @AsyncCancelled@+-- exception to each of them in turn, then waiting for all the `Async` threads+-- to complete.+cancelMany :: [Async a] -> IO ()+cancelMany as = do+  mapM_ (\(Async t _) -> throwTo t AsyncCancelled) as+  mapM_ waitCatch as++-- | The exception thrown by `cancel` to terminate a thread.+data AsyncCancelled = AsyncCancelled+  deriving (Show, Eq+#if __GLASGOW_HASKELL__ < 710+    ,Typeable+#endif+    )++instance Exception AsyncCancelled where+#if __GLASGOW_HASKELL__ >= 708+  fromException = asyncExceptionFromException+  toException = asyncExceptionToException+#endif++-- | Cancel an asynchronous action+--+-- This is a variant of `cancel`, but it is not interruptible.+{-# INLINE uninterruptibleCancel #-}+uninterruptibleCancel :: Async a -> IO ()+uninterruptibleCancel = uninterruptibleMask_ . cancel++-- | Cancel an asynchronous action by throwing the supplied exception+-- to it.+--+-- > cancelWith a x = throwTo (asyncThreadId a) x+--+-- The notes about the synchronous nature of 'cancel' also apply to+-- 'cancelWith'.+cancelWith :: Exception e => Async a -> e -> IO ()+cancelWith a@(Async t _) e = throwTo t e <* waitCatch a++-- | Wait for any of the supplied asynchronous operations to complete.+-- The value returned is a pair of the 'Async' that completed, and the+-- result that would be returned by 'wait' on that 'Async'.+-- The input list must be non-empty.+--+-- If multiple 'Async's complete or have completed, then the value+-- returned corresponds to the first completed 'Async' in the list.+--+{-# INLINE waitAnyCatch #-}+waitAnyCatch :: [Async a] -> IO (Async a, Either SomeException a)+waitAnyCatch = atomically . waitAnyCatchSTM++-- | A version of 'waitAnyCatch' that can be used inside an STM transaction.+--+-- @since 2.1.0+waitAnyCatchSTM :: [Async a] -> STM (Async a, Either SomeException a)+waitAnyCatchSTM [] =+    throwSTM $ ErrorCall+      "waitAnyCatchSTM: invalid argument: input list must be non-empty"+waitAnyCatchSTM asyncs =+    foldr orElse retry $+      map (\a -> do r <- waitCatchSTM a; return (a, r)) asyncs++-- | Like 'waitAnyCatch', but also cancels the other asynchronous+-- operations as soon as one has completed.+--+waitAnyCatchCancel :: [Async a] -> IO (Async a, Either SomeException a)+waitAnyCatchCancel asyncs =+  waitAnyCatch asyncs `finally` cancelMany asyncs++-- | Wait for any of the supplied @Async@s to complete.  If the first+-- to complete throws an exception, then that exception is re-thrown+-- by 'waitAny'.+-- The input list must be non-empty.+--+-- If multiple 'Async's complete or have completed, then the value+-- returned corresponds to the first completed 'Async' in the list.+--+{-# INLINE waitAny #-}+waitAny :: [Async a] -> IO (Async a, a)+waitAny = atomically . waitAnySTM++-- | A version of 'waitAny' that can be used inside an STM transaction.+--+-- @since 2.1.0+waitAnySTM :: [Async a] -> STM (Async a, a)+waitAnySTM [] =+    throwSTM $ ErrorCall+      "waitAnySTM: invalid argument: input list must be non-empty"+waitAnySTM asyncs =+    foldr orElse retry $+      map (\a -> do r <- waitSTM a; return (a, r)) asyncs++-- | Like 'waitAny', but also cancels the other asynchronous+-- operations as soon as one has completed.+--+waitAnyCancel :: [Async a] -> IO (Async a, a)+waitAnyCancel asyncs =+  waitAny asyncs `finally` cancelMany asyncs++-- | Wait for the first of two @Async@s to finish.+{-# INLINE waitEitherCatch #-}+waitEitherCatch :: Async a -> Async b+                -> IO (Either (Either SomeException a)+                              (Either SomeException b))+waitEitherCatch left right =+  tryAgain $ atomically (waitEitherCatchSTM left right)+  where+    -- See: https://github.com/simonmar/async/issues/14+    tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f++-- | A version of 'waitEitherCatch' that can be used inside an STM transaction.+--+-- @since 2.1.0+waitEitherCatchSTM :: Async a -> Async b+                -> STM (Either (Either SomeException a)+                               (Either SomeException b))+waitEitherCatchSTM left right =+    (Left  <$> waitCatchSTM left)+      `orElse`+    (Right <$> waitCatchSTM right)++-- | Like 'waitEitherCatch', but also 'cancel's both @Async@s before+-- returning.+--+waitEitherCatchCancel :: Async a -> Async b+                      -> IO (Either (Either SomeException a)+                                    (Either SomeException b))+waitEitherCatchCancel left right =+  waitEitherCatch left right `finally` cancelMany [() <$ left, () <$ right]++-- | Wait for the first of two @Async@s to finish.  If the @Async@+-- that finished first raised an exception, then the exception is+-- re-thrown by 'waitEither'.+--+{-# INLINE waitEither #-}+waitEither :: Async a -> Async b -> IO (Either a b)+waitEither left right = atomically (waitEitherSTM left right)++-- | A version of 'waitEither' that can be used inside an STM transaction.+--+-- @since 2.1.0+waitEitherSTM :: Async a -> Async b -> STM (Either a b)+waitEitherSTM left right =+    (Left  <$> waitSTM left)+      `orElse`+    (Right <$> waitSTM right)++-- | Like 'waitEither', but the result is ignored.+--+{-# INLINE waitEither_ #-}+waitEither_ :: Async a -> Async b -> IO ()+waitEither_ left right = atomically (waitEitherSTM_ left right)++-- | A version of 'waitEither_' that can be used inside an STM transaction.+--+-- @since 2.1.0+waitEitherSTM_:: Async a -> Async b -> STM ()+waitEitherSTM_ left right =+    (void $ waitSTM left)+      `orElse`+    (void $ waitSTM right)++-- | Like 'waitEither', but also 'cancel's both @Async@s before+-- returning.+--+waitEitherCancel :: Async a -> Async b -> IO (Either a b)+waitEitherCancel left right =+  waitEither left right `finally` cancelMany [() <$ left, () <$ right]++-- | Waits for both @Async@s to finish, but if either of them throws+-- an exception before they have both finished, then the exception is+-- re-thrown by 'waitBoth'.+--+{-# INLINE waitBoth #-}+waitBoth :: Async a -> Async b -> IO (a,b)+waitBoth left right = tryAgain $ atomically (waitBothSTM left right)+  where+    -- See: https://github.com/simonmar/async/issues/14+    tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f++-- | A version of 'waitBoth' that can be used inside an STM transaction.+--+-- @since 2.1.0+waitBothSTM :: Async a -> Async b -> STM (a,b)+waitBothSTM left right = do+    a <- waitSTM left+           `orElse`+         (waitSTM right >> retry)+    b <- waitSTM right+    return (a,b)+++-- -----------------------------------------------------------------------------+-- Linking threads++data ExceptionInLinkedThread =+  forall a . ExceptionInLinkedThread (Async a) SomeException+#if __GLASGOW_HASKELL__ < 710+  deriving Typeable+#endif++instance Show ExceptionInLinkedThread where+  showsPrec p (ExceptionInLinkedThread (Async t _) e) =+    showParen (p >= 11) $+      showString "ExceptionInLinkedThread " .+      showsPrec 11 t .+      showString " " .+      showsPrec 11 e++instance Exception ExceptionInLinkedThread where+#if __GLASGOW_HASKELL__ >= 708+  fromException = asyncExceptionFromException+  toException = asyncExceptionToException+#endif++-- | Link the given @Async@ to the current thread, such that if the+-- @Async@ raises an exception, that exception will be re-thrown in+-- the current thread, wrapped in 'ExceptionInLinkedThread'.+--+-- 'link' ignores 'AsyncCancelled' exceptions thrown in the other thread,+-- so that it's safe to 'cancel' a thread you're linked to.  If you want+-- different behaviour, use 'linkOnly'.+--+link :: Async a -> IO ()+link = linkOnly (not . isCancel)++-- | Link the given @Async@ to the current thread, such that if the+-- @Async@ raises an exception, that exception will be re-thrown in+-- the current thread, wrapped in 'ExceptionInLinkedThread'.+--+-- The supplied predicate determines which exceptions in the target+-- thread should be propagated to the source thread.+--+linkOnly+  :: (SomeException -> Bool)  -- ^ return 'True' if the exception+                              -- should be propagated, 'False'+                              -- otherwise.+  -> Async a+  -> IO ()+linkOnly shouldThrow a = do+  me <- myThreadId+  void $ forkRepeat $ do+    r <- waitCatch a+    case r of+      Left e | shouldThrow e -> throwTo me (ExceptionInLinkedThread a e)+      _otherwise -> return ()++-- | Link two @Async@s together, such that if either raises an+-- exception, the same exception is re-thrown in the other @Async@,+-- wrapped in 'ExceptionInLinkedThread'.+--+-- 'link2' ignores 'AsyncCancelled' exceptions, so that it's possible+-- to 'cancel' either thread without cancelling the other.  If you+-- want different behaviour, use 'link2Only'.+--+link2 :: Async a -> Async b -> IO ()+link2 = link2Only (not . isCancel)++-- | Link two @Async@s together, such that if either raises an+-- exception, the same exception is re-thrown in the other @Async@,+-- wrapped in 'ExceptionInLinkedThread'.+--+-- The supplied predicate determines which exceptions in the target+-- thread should be propagated to the source thread.+--+link2Only :: (SomeException -> Bool) -> Async a -> Async b -> IO ()+link2Only shouldThrow left@(Async tl _)  right@(Async tr _) =+  void $ forkRepeat $ do+    r <- waitEitherCatch left right+    case r of+      Left  (Left e) | shouldThrow e ->+        throwTo tr (ExceptionInLinkedThread left e)+      Right (Left e) | shouldThrow e ->+        throwTo tl (ExceptionInLinkedThread right e)+      _ -> return ()++isCancel :: SomeException -> Bool+isCancel e+  | Just AsyncCancelled <- fromException e = True+  | otherwise = False+++-- -----------------------------------------------------------------------------++-- | Run two @IO@ actions concurrently, and return the first to+-- finish.  The loser of the race is 'cancel'led.+--+-- > race left right =+-- >   withAsync left $ \a ->+-- >   withAsync right $ \b ->+-- >   waitEither a b+--+race :: IO a -> IO b -> IO (Either a b)++-- | Like 'race', but the result is ignored.+--+race_ :: IO a -> IO b -> IO ()+++-- | Run two @IO@ actions concurrently, and return both results.  If+-- either action throws an exception at any time, then the other+-- action is 'cancel'led, and the exception is re-thrown by+-- 'concurrently'.+--+-- > concurrently left right =+-- >   withAsync left $ \a ->+-- >   withAsync right $ \b ->+-- >   waitBoth a b+concurrently :: IO a -> IO b -> IO (a,b)+++-- | Run two @IO@ actions concurrently. If both of them end with @Right@,+-- return both results.  If one of then ends with @Left@, interrupt the other+-- action and return the @Left@.+--+concurrentlyE :: IO (Either e a) -> IO (Either e b) -> IO (Either e (a, b))++-- | 'concurrently', but ignore the result values+--+-- @since 2.1.1+concurrently_ :: IO a -> IO b -> IO ()++#define USE_ASYNC_VERSIONS 0++#if USE_ASYNC_VERSIONS++race left right =+  withAsync left $ \a ->+  withAsync right $ \b ->+  waitEither a b++race_ left right = void $ race left right++concurrently left right =+  withAsync left $ \a ->+  withAsync right $ \b ->+  waitBoth a b++concurrently_ left right = void $ concurrently left right++#else++-- MVar versions of race/concurrently+-- More ugly than the Async versions, but quite a bit faster.++-- race :: IO a -> IO b -> IO (Either a b)+race left right = concurrently' left right collect+  where+    collect m = do+        e <- m+        case e of+            Left ex -> throwIO ex+            Right r -> return r++-- race_ :: IO a -> IO b -> IO ()+race_ left right = void $ race left right++-- concurrently :: IO a -> IO b -> IO (a,b)+concurrently left right = concurrently' left right (collect [])+  where+    collect [Left a, Right b] _ = return (a,b)+    collect [Right b, Left a] _ = return (a,b)+    collect xs m = do+        e <- m+        case e of+            Left ex -> throwIO ex+            Right r -> collect (r:xs) m++-- concurrentlyE :: IO (Either e a) -> IO (Either e b) -> IO (Either e (a, b))+concurrentlyE left right = concurrently' left right (collect [])+  where+    collect [Left (Right a), Right (Right b)] _ = return $ Right (a,b)+    collect [Right (Right b), Left (Right a)] _ = return $ Right (a,b)+    collect (Left (Left ea):_) _ = return $ Left ea+    collect (Right (Left eb):_) _ = return $ Left eb+    collect xs m = do+        e <- m+        case e of+            Left ex -> throwIO ex+            Right r -> collect (r:xs) m++concurrently' :: IO a -> IO b+             -> (IO (Either SomeException (Either a b)) -> IO r)+             -> IO r+concurrently' left right collect = do+    done <- newEmptyMVar+    mask $ \restore -> do+        -- Note: uninterruptibleMask here is because we must not allow+        -- the putMVar in the exception handler to be interrupted,+        -- otherwise the parent thread will deadlock when it waits for+        -- the thread to terminate.+        lid <- forkIO $ uninterruptibleMask_ $+          restore (left >>= putMVar done . Right . Left)+            `catchAll` (putMVar done . Left)+        rid <- forkIO $ uninterruptibleMask_ $+          restore (right >>= putMVar done . Right . Right)+            `catchAll` (putMVar done . Left)++        count <- newIORef (2 :: Int)+        let takeDone = do+                r <- takeMVar done      -- interruptible+                -- Decrement the counter so we know how many takes are left.+                -- Since only the parent thread is calling this, we can+                -- use non-atomic modifications.+                -- NB. do this *after* takeMVar, because takeMVar might be+                -- interrupted.+                modifyIORef count (subtract 1)+                return r++        let tryAgain f = f `catch` \BlockedIndefinitelyOnMVar -> f++            stop = do+                -- kill right before left, to match the semantics of+                -- the version using withAsync. (#27)+                uninterruptibleMask_ $ do+                  count' <- readIORef count+                  -- we only need to use killThread if there are still+                  -- children alive.  Note: forkIO here is because the+                  -- child thread could be in an uninterruptible+                  -- putMVar.+                  when (count' > 0) $+                    void $ forkIO $ do+                      throwTo rid AsyncCancelled+                      throwTo lid AsyncCancelled+                  -- ensure the children are really dead+                  replicateM_ count' (tryAgain $ takeMVar done)++        r <- collect (tryAgain $ takeDone) `onException` stop+        stop+        return r++concurrently_ left right = concurrently' left right (collect 0)+  where+    collect 2 _ = return ()+    collect i m = do+        e <- m+        case e of+            Left ex -> throwIO ex+            Right _ -> collect (i + 1 :: Int) m+++#endif++-- | Maps an 'IO'-performing function over any 'Traversable' data+-- type, performing all the @IO@ actions concurrently, and returning+-- the original data structure with the arguments replaced by the+-- results.+--+-- If any of the actions throw an exception, then all other actions are+-- cancelled and the exception is re-thrown.+--+-- For example, @mapConcurrently@ works with lists:+--+-- > pages <- mapConcurrently getURL ["url1", "url2", "url3"]+--+-- Take into account that @async@ will try to immediately spawn a thread+-- for each element of the @Traversable@, so running this on large+-- inputs without care may lead to resource exhaustion (of memory,+-- file descriptors, or other limited resources).+mapConcurrently :: Traversable t => (a -> IO b) -> t a -> IO (t b)+mapConcurrently f = runConcurrently . traverse (Concurrently . f)++-- | `forConcurrently` is `mapConcurrently` with its arguments flipped+--+-- > pages <- forConcurrently ["url1", "url2", "url3"] $ \url -> getURL url+--+-- @since 2.1.0+forConcurrently :: Traversable t => t a -> (a -> IO b) -> IO (t b)+forConcurrently = flip mapConcurrently++-- | `mapConcurrently_` is `mapConcurrently` with the return value discarded;+-- a concurrent equivalent of 'mapM_'.+mapConcurrently_ :: F.Foldable f => (a -> IO b) -> f a -> IO ()+mapConcurrently_ f = runConcurrently . F.foldMap (Concurrently . void . f)++-- | `forConcurrently_` is `forConcurrently` with the return value discarded;+-- a concurrent equivalent of 'forM_'.+forConcurrently_ :: F.Foldable f => f a -> (a -> IO b) -> IO ()+forConcurrently_ = flip mapConcurrently_++-- | Perform the action in the given number of threads.+--+-- @since 2.1.1+replicateConcurrently :: Int -> IO a -> IO [a]+replicateConcurrently cnt = runConcurrently . sequenceA . replicate cnt . Concurrently++-- | Same as 'replicateConcurrently', but ignore the results.+--+-- @since 2.1.1+replicateConcurrently_ :: Int -> IO a -> IO ()+replicateConcurrently_ cnt = runConcurrently . F.fold . replicate cnt . Concurrently . void++-- -----------------------------------------------------------------------------++-- | A value of type @Concurrently a@ is an @IO@ operation that can be+-- composed with other @Concurrently@ values, using the @Applicative@+-- and @Alternative@ instances.+--+-- Calling @runConcurrently@ on a value of type @Concurrently a@ will+-- execute the @IO@ operations it contains concurrently, before+-- delivering the result of type @a@.+--+-- For example+--+-- > (page1, page2, page3)+-- >     <- runConcurrently $ (,,)+-- >     <$> Concurrently (getURL "url1")+-- >     <*> Concurrently (getURL "url2")+-- >     <*> Concurrently (getURL "url3")+--+newtype Concurrently a = Concurrently { runConcurrently :: IO a }++instance Functor Concurrently where+  fmap f (Concurrently a) = Concurrently $ f <$> a++instance Applicative Concurrently where+  pure = Concurrently . return+  Concurrently fs <*> Concurrently as =+    Concurrently $ (\(f, a) -> f a) <$> concurrently fs as++-- | 'Control.Alternative.empty' waits forever. 'Control.Alternative.<|>' returns the first to finish and 'cancel's the other.+instance Alternative Concurrently where+  empty = Concurrently $ forever (threadDelay maxBound)+  Concurrently as <|> Concurrently bs =+    Concurrently $ either id id <$> race as bs++#if MIN_VERSION_base(4,9,0)+-- | Only defined by @async@ for @base >= 4.9@+--+-- @since 2.1.0+instance Semigroup a => Semigroup (Concurrently a) where+  (<>) = liftA2 (<>)++-- | @since 2.1.0+instance (Semigroup a, Monoid a) => Monoid (Concurrently a) where+  mempty = pure mempty+  mappend = (<>)+#else+-- | @since 2.1.0+instance Monoid a => Monoid (Concurrently a) where+  mempty = pure mempty+  mappend = liftA2 mappend+#endif++-- | A value of type @ConcurrentlyE e a@ is an @IO@ operation that can be+-- composed with other @ConcurrentlyE@ values, using the @Applicative@ instance.+--+-- Calling @runConcurrentlyE@ on a value of type @ConcurrentlyE e a@ will+-- execute the @IO@ operations it contains concurrently, before delivering+-- either the result of type @a@, or an error of type @e@ if one of the actions+-- returns @Left@.+--+-- | @since 2.2.5+newtype ConcurrentlyE e a = ConcurrentlyE { runConcurrentlyE :: IO (Either e a) }++instance Functor (ConcurrentlyE e) where+  fmap f (ConcurrentlyE ea) = ConcurrentlyE $ fmap (fmap f) ea++#if MIN_VERSION_base(4,8,0)+instance Bifunctor ConcurrentlyE where+  bimap f g (ConcurrentlyE ea) = ConcurrentlyE $ fmap (bimap f g) ea+#endif++instance Applicative (ConcurrentlyE e) where+  pure = ConcurrentlyE . return . return+  ConcurrentlyE fs <*> ConcurrentlyE eas =+    ConcurrentlyE $ fmap (\(f, a) -> f a) <$> concurrentlyE fs eas++#if MIN_VERSION_base(4,9,0)+-- | Either the combination of the successful results, or the first failure.+instance Semigroup a => Semigroup (ConcurrentlyE e a) where+  (<>) = liftA2 (<>)++instance (Semigroup a, Monoid a) => Monoid (ConcurrentlyE e a) where+  mempty = pure mempty+  mappend = (<>)+#endif++-- ----------------------------------------------------------------------------++-- | Fork a thread that runs the supplied action, and if it raises an+-- exception, re-runs the action.  The thread terminates only when the+-- action runs to completion without raising an exception.+forkRepeat :: IO a -> IO ThreadId+forkRepeat action =+  mask $ \restore ->+    let go = do r <- tryAll (restore action)+                case r of+                  Left _ -> go+                  _      -> return ()+    in forkIO go++catchAll :: IO a -> (SomeException -> IO a) -> IO a+catchAll = catch++tryAll :: IO a -> IO (Either SomeException a)+tryAll = try++-- A version of forkIO that does not include the outer exception+-- handler: saves a bit of time when we will be installing our own+-- exception handler.+{-# INLINE rawForkIO #-}+rawForkIO :: IO () -> IO ThreadId+rawForkIO (IO action) = IO $ \ s ->+   case (fork# action s) of (# s1, tid #) -> (# s1, ThreadId tid #)++{-# INLINE rawForkOn #-}+rawForkOn :: Int -> IO () -> IO ThreadId+rawForkOn (I# cpu) (IO action) = IO $ \ s ->+   case (forkOn# cpu action s) of (# s1, tid #) -> (# s1, ThreadId tid #)
+ vendor/stm-2.5.0.1/Control/Concurrent/STM/TMVar.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE CPP, DeriveDataTypeable, MagicHash, UnboxedTuples #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif++{-# OPTIONS -fno-warn-implicit-prelude #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Concurrent.STM.TMVar+-- Copyright   :  (c) The University of Glasgow 2004+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (requires STM)+--+-- TMVar: Transactional MVars, for use in the STM monad+-- (GHC only)+--+-----------------------------------------------------------------------------++module Control.Concurrent.STM.TMVar (+#ifdef __GLASGOW_HASKELL__+        -- * TMVars+        TMVar,+        newTMVar,+        newEmptyTMVar,+        newTMVarIO,+        newEmptyTMVarIO,+        takeTMVar,+        putTMVar,+        readTMVar,+        tryReadTMVar,+        swapTMVar,+        tryTakeTMVar,+        tryPutTMVar,+        isEmptyTMVar,+        mkWeakTMVar+#endif+  ) where++#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.Conc+import GHC.Weak++import Data.Typeable (Typeable)++newtype TMVar a = TMVar (TVar (Maybe a)) deriving (Eq, Typeable)+{- ^+A 'TMVar' is a synchronising variable, used+for communication between concurrent threads.  It can be thought of+as a box, which may be empty or full.+-}++-- |Create a 'TMVar' which contains the supplied value.+newTMVar :: a -> STM (TMVar a)+newTMVar a = do+  t <- newTVar (Just a)+  return (TMVar t)++-- |@IO@ version of 'newTMVar'.  This is useful for creating top-level+-- 'TMVar's using 'System.IO.Unsafe.unsafePerformIO', because using+-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't+-- possible.+newTMVarIO :: a -> IO (TMVar a)+newTMVarIO a = do+  t <- newTVarIO (Just a)+  return (TMVar t)++-- |Create a 'TMVar' which is initially empty.+newEmptyTMVar :: STM (TMVar a)+newEmptyTMVar = do+  t <- newTVar Nothing+  return (TMVar t)++-- |@IO@ version of 'newEmptyTMVar'.  This is useful for creating top-level+-- 'TMVar's using 'System.IO.Unsafe.unsafePerformIO', because using+-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't+-- possible.+newEmptyTMVarIO :: IO (TMVar a)+newEmptyTMVarIO = do+  t <- newTVarIO Nothing+  return (TMVar t)++-- |Return the contents of the 'TMVar'.  If the 'TMVar' is currently+-- empty, the transaction will 'retry'.  After a 'takeTMVar',+-- the 'TMVar' is left empty.+takeTMVar :: TMVar a -> STM a+takeTMVar (TMVar t) = do+  m <- readTVar t+  case m of+    Nothing -> retry+    Just a  -> do writeTVar t Nothing; return a++-- | A version of 'takeTMVar' that does not 'retry'.  The 'tryTakeTMVar'+-- function returns 'Nothing' if the 'TMVar' was empty, or @'Just' a@ if+-- the 'TMVar' was full with contents @a@.  After 'tryTakeTMVar', the+-- 'TMVar' is left empty.+tryTakeTMVar :: TMVar a -> STM (Maybe a)+tryTakeTMVar (TMVar t) = do+  m <- readTVar t+  case m of+    Nothing -> return Nothing+    Just a  -> do writeTVar t Nothing; return (Just a)++-- |Put a value into a 'TMVar'.  If the 'TMVar' is currently full,+-- 'putTMVar' will 'retry'.+putTMVar :: TMVar a -> a -> STM ()+putTMVar (TMVar t) a = do+  m <- readTVar t+  case m of+    Nothing -> do writeTVar t (Just a); return ()+    Just _  -> retry++-- | A version of 'putTMVar' that does not 'retry'.  The 'tryPutTMVar'+-- function attempts to put the value @a@ into the 'TMVar', returning+-- 'True' if it was successful, or 'False' otherwise.+tryPutTMVar :: TMVar a -> a -> STM Bool+tryPutTMVar (TMVar t) a = do+  m <- readTVar t+  case m of+    Nothing -> do writeTVar t (Just a); return True+    Just _  -> return False++-- | This is a combination of 'takeTMVar' and 'putTMVar'; ie. it+-- takes the value from the 'TMVar', puts it back, and also returns+-- it.+readTMVar :: TMVar a -> STM a+readTMVar (TMVar t) = do+  m <- readTVar t+  case m of+    Nothing -> retry+    Just a  -> return a++-- | A version of 'readTMVar' which does not retry. Instead it+-- returns @Nothing@ if no value is available.+--+-- @since 2.3+tryReadTMVar :: TMVar a -> STM (Maybe a)+tryReadTMVar (TMVar t) = readTVar t++-- |Swap the contents of a 'TMVar' for a new value.+swapTMVar :: TMVar a -> a -> STM a+swapTMVar (TMVar t) new = do+  m <- readTVar t+  case m of+    Nothing -> retry+    Just old -> do writeTVar t (Just new); return old++-- |Check whether a given 'TMVar' is empty.+isEmptyTMVar :: TMVar a -> STM Bool+isEmptyTMVar (TMVar t) = do+  m <- readTVar t+  case m of+    Nothing -> return True+    Just _  -> return False++-- | Make a 'Weak' pointer to a 'TMVar', using the second argument as+-- a finalizer to run when the 'TMVar' is garbage-collected.+--+-- @since 2.4.4+mkWeakTMVar :: TMVar a -> IO () -> IO (Weak (TMVar a))+mkWeakTMVar tmv@(TMVar (TVar t#)) (IO finalizer) = IO $ \s ->+    case mkWeak# t# tmv finalizer s of (# s1, w #) -> (# s1, Weak w #)+#endif
+ version.yaml view
@@ -0,0 +1,7 @@+version: &version 2.11.17+synopsis: A Testing Framework for Haskell+author: Simon Hengel <sol@typeful.net>+maintainer: Simon Hengel <sol@typeful.net>+category: Testing+stability: experimental+homepage: https://hspec.github.io/