packages feed

hspec-core 2.7.10 → 2.11.17

raw patch · 97 files changed

Files

LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2011-2021 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,24 +1,26 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- 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.7.10+version:          2.11.17 license:          MIT license-file:     LICENSE-copyright:        (c) 2011-2021 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 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. @@ -31,56 +33,91 @@   hs-source-dirs:       src       vendor-  ghc-options: -Wall+  ghc-options: -Wall -fno-warn-incomplete-uni-patterns   build-depends:       HUnit ==1.6.*-    , QuickCheck >=2.13.1-    , ansi-terminal >=0.5+    , QuickCheck >=2.13.1 && <2.19+    , ansi-terminal >=0.6.2     , array-    , base >=4.5.0.0 && <5-    , call-stack-    , clock >=0.7.1+    , base >=4.9.0.0 && <5+    , call-stack >=0.2.0+    , containers     , deepseq     , directory     , filepath-    , hspec-expectations ==0.8.2.*+    , haskell-lexer+    , hspec-expectations ==0.8.4.*+    , process     , quickcheck-io >=0.2.0     , random-    , setenv-    , stm >=2.2-    , tf-random+    , time     , 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:+      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.Config.Util       Test.Hspec.Core.Example       Test.Hspec.Core.Example.Location+      Test.Hspec.Core.Extension.Config.Type       Test.Hspec.Core.FailureReport-      Test.Hspec.Core.Format       Test.Hspec.Core.Formatters.Diff-      Test.Hspec.Core.Formatters.Free       Test.Hspec.Core.Formatters.Internal-      Test.Hspec.Core.Formatters.Monad-      Test.Hspec.Core.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-      Control.Concurrent.Async       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@@ -89,81 +126,128 @@       src       vendor       test-  ghc-options: -Wall+  ghc-options: -Wall -fno-warn-incomplete-uni-patterns   cpp-options: -DTEST   build-depends:       HUnit ==1.6.*     , QuickCheck >=2.14-    , ansi-terminal >=0.5+    , ansi-terminal >=0.6.2     , array-    , base >=4.5.0.0 && <5-    , call-stack-    , clock >=0.7.1+    , base >=4.9.0.0 && <5+    , base-orphans+    , call-stack >=0.2.0+    , containers     , deepseq     , directory     , filepath-    , hspec-expectations ==0.8.2.*-    , hspec-meta ==2.7.8+    , haskell-lexer+    , hspec-expectations ==0.8.4.*+    , hspec-meta ==2.11.17     , process     , quickcheck-io >=0.2.0     , random-    , setenv     , silently >=1.2.4-    , stm >=2.2     , temporary-    , tf-random+    , time     , transformers >=0.2.2.0   build-tool-depends:       hspec-meta:hspec-meta-discover   other-modules:+      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.Config.Util       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.Free       Test.Hspec.Core.Formatters.Internal-      Test.Hspec.Core.Formatters.Monad+      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-      Control.Concurrent.Async       Data.Algorithm.Diff-      All+      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.Config.UtilSpec       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.FormattersSpec+      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.QuickCheckUtilSpec+      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/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
@@ -1,6 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-} module Test.Hspec.Core.Clock (   Seconds(..)+, toMilliseconds , toMicroseconds , getMonotonicTime , measure@@ -8,21 +10,40 @@ , 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           System.Clock 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, Num, Fractional, PrintfArg)+  deriving (Eq, Show, Ord, Num, Fractional, PrintfArg) +toMilliseconds :: Seconds -> Int+toMilliseconds (Seconds s) = floor (s * 1000)+ toMicroseconds :: Seconds -> Int toMicroseconds (Seconds s) = floor (s * 1000000)  getMonotonicTime :: IO Seconds+#ifdef HAS_GET_MONOTONIC_TIME+getMonotonicTime = Seconds <$> GHC.getMonotonicTime+#else getMonotonicTime = do-  t <- getTime Monotonic-  return $ Seconds ((fromIntegral . toNanoSecs $ t) / 1000000000)+  t <- getPOSIXTime+  return $ Seconds (realToFrac t)+#endif  measure :: IO a -> IO (Seconds, a) measure action = do
src/Test/Hspec/Core/Compat.hs view
@@ -1,31 +1,14 @@ {-# LANGUAGE CPP #-} module Test.Hspec.Core.Compat (-  getDefaultConcurrentJobs-, showType-, showFullType-, readMaybe-, lookupEnv-, module Data.IORef--, module Prelude-, module Control.Applicative-, module Control.Monad-, module Data.Foldable-, module Data.Traversable-, module Data.Monoid-, module Data.List--#if !MIN_VERSION_base(4,6,0)-, modifyIORef'-, atomicWriteIORef-#endif-, interruptible--, guarded+  module Imports+, module Test.Hspec.Core.Compat+, Typeable ) where -import           Control.Applicative-import           Control.Monad hiding (+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@@ -34,12 +17,37 @@   , sequence   , sequence_   )-import           Data.Foldable-import           Data.Traversable-import           Data.Monoid-import           Data.List (intercalate)+import           Data.Maybe as Imports+import           Data.Foldable as Imports+import           GHC.Stack as Imports (HasCallStack, withFrozenCallStack) -import           Prelude hiding (+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@@ -60,90 +68,104 @@   , sequence   , sequence_   , sum-#if !MIN_VERSION_base(4,6,0)-  , catch-#endif+  , length+  , null   ) -import           Data.Typeable (Typeable, typeOf, typeRepTyCon)-import           Text.Read-import           Data.IORef-import           System.Environment--import           Data.Typeable (tyConModule, tyConName)-import           Control.Concurrent+import           Data.Typeable+import           Data.IORef as Imports -#if MIN_VERSION_base(4,9,0)-import           Control.Exception (interruptible)+#if MIN_VERSION_base(4,12,0)+import           GHC.ResponseFile as Imports (unescapeArgs) #else-import           GHC.IO+import           Data.Char #endif -#if !MIN_VERSION_base(4,6,0)-import qualified Text.ParserCombinators.ReadP as P+import           Text.Read as Imports (readMaybe)+import           System.Environment as Imports (lookupEnv) --- |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' -atomicWriteIORef :: IORef a -> a -> IO ()-atomicWriteIORef ref a = do-    x <- atomicModifyIORef ref (\_ -> (a, ()))-    x `seq` return ()---- | Parse a string using the 'Read' instance.--- Succeeds if there is exactly one valid result.--- A 'Left' value indicates a parse error.-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+import           Data.Bool as Imports (bool) --- | 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+import           Control.Concurrent --- | 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+#ifndef __MHS__+import           GHC.IO.Exception+#else+import           System.IO.Error #endif+  ( ioe_type, IOErrorType(..) ) -showType :: Typeable a => a -> String-showType a = let t = typeRepTyCon (typeOf a) in-  show t+isUnsupportedOperation :: IOError -> Bool+isUnsupportedOperation e = ioe_type e == UnsupportedOperation -showFullType :: Typeable a => a -> String-showFullType a = let t = typeRepTyCon (typeOf a) in-  tyConModule t ++ "." ++ tyConName t+showType :: Typeable a => a -> String+showType = show . typeRepTyCon . typeOf  getDefaultConcurrentJobs :: IO Int getDefaultConcurrentJobs = getNumCapabilities -#if !MIN_VERSION_base(4,9,0)-interruptible :: IO a -> IO a-interruptible act = do-  st <- getMaskingState-  case st of-    Unmasked              -> act-    MaskedInterruptible   -> unsafeUnmask act-    MaskedUninterruptible -> act-#endif- 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
@@ -2,6 +2,7 @@ module Test.Hspec.Core.Config (   Config (..) , ColorMode(..)+, UnicodeMode(..) , defaultConfig , readConfig , configAddFilter@@ -17,22 +18,31 @@ import           Prelude () import           Test.Hspec.Core.Compat -import           Control.Exception-import           Data.Maybe import           System.IO import           System.IO.Error import           System.Exit import           System.FilePath import           System.Directory-import           System.Environment (getProgName)+import           System.Environment (getProgName, getEnvironment) import qualified Test.QuickCheck as QC  import           Test.Hspec.Core.Util import           Test.Hspec.Core.Config.Options+import           Test.Hspec.Core.Config.Definition import           Test.Hspec.Core.FailureReport-import           Test.Hspec.Core.QuickCheckUtil (mkGen)+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@@ -41,21 +51,21 @@   }  applyFailureReport :: Maybe FailureReport -> Config -> Config-applyFailureReport mFailureReport opts = opts {+applyFailureReport mFailureReport config = config {     configFilterPredicate = matchFilter `filterOr` rerunFilter-  , configQuickCheckSeed = mSeed+  , configSeed = 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)+    mSeed = getSeed config <|> (failureReportSeed <$> mFailureReport)+    mMaxSuccess = configQuickCheckMaxSuccess config <|> (failureReportMaxSuccess <$> mFailureReport)+    mMaxSize = configQuickCheckMaxSize config <|> (failureReportMaxSize <$> mFailureReport)+    mMaxDiscardRatio = configQuickCheckMaxDiscardRatio config <|> (failureReportMaxDiscardRatio <$> mFailureReport) -    matchFilter = configFilterPredicate opts+    matchFilter = configFilterPredicate config      rerunFilter = case failureReportPaths <$> mFailureReport of       Just [] -> Nothing@@ -66,19 +76,23 @@ configQuickCheckArgs c = qcArgs   where     qcArgs = (-        maybe id setSeed (configQuickCheckSeed c)-      . maybe id setMaxDiscardRatio (configQuickCheckMaxDiscardRatio c)+        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} -    setMaxDiscardRatio :: Int -> QC.Args -> QC.Args-    setMaxDiscardRatio n args = args {QC.maxDiscardRatio = n}+    setMaxShrinks :: Int -> QC.Args -> QC.Args+    setMaxShrinks n args = args {QC.maxShrinks = n}      setSeed :: Integer -> QC.Args -> QC.Args     setSeed n args = args {QC.replay = Just (mkGen (fromIntegral n), 0)}@@ -89,7 +103,7 @@ -- -- 1. @~/.hspec@ (a config file in the user's home directory) -- 1. @.hspec@ (a config file in the current working directory)--- 1. the environment variable @HSPEC_OPTIONS@+-- 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)@@ -113,10 +127,13 @@     case ignore of       True -> return []       False -> readConfigFiles-  envVar <- fmap words <$> lookupEnv envVarName-  case parseOptions opts_ prog configFiles envVar args of+  env <- getEnvironment+  let envVar = words <$> lookup envVarName env+  case parseOptions opts_ prog configFiles envVar env args of     Left (err, msg) -> exitWithMessage err msg-    Right opts -> return opts+    Right (warnings, opts) -> do+      mapM_ (hPutStrLn stderr) warnings+      return opts  readFailureReportOnRerun :: Config -> IO (Maybe FailureReport) readFailureReportOnRerun config@@ -131,10 +148,13 @@  readGlobalConfigFile :: IO (Maybe ConfigFile) readGlobalConfigFile = do-  mHome <- tryJust (guard . isDoesNotExistError) getHomeDirectory+  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@@ -146,7 +166,7 @@ readConfigFile :: FilePath -> IO (Maybe ConfigFile) readConfigFile name = do   exists <- doesFileExist name-  if exists then Just . (,) name . words <$> readFile name else return Nothing+  if exists then Just . (,) name . unescapeArgs <$> readFile name else return Nothing  exitWithMessage :: ExitCode -> String -> IO a exitWithMessage err msg = do
+ 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
@@ -1,337 +1,88 @@+{-# LANGUAGE CPP #-} module Test.Hspec.Core.Config.Options (-  Config(..)-, ColorMode (..)-, defaultConfig-, filterOr-, parseOptions-, ConfigFile-, ignoreConfigFile+  ConfigFile , envVarName+, ignoreConfigFile+, parseOptions ) where  import           Prelude () import           Test.Hspec.Core.Compat -import           System.IO import           System.Exit-import           System.Console.GetOpt -import           Test.Hspec.Core.Formatters-import           Test.Hspec.Core.Config.Util-import           Test.Hspec.Core.Util-import           Test.Hspec.Core.Example (Params(..), defaultParams)-import           Data.Functor.Identity-import           Data.Maybe+import           Test.Hspec.Core.Config.Definition+import qualified GetOpt.Declarative as Declarative+import           GetOpt.Declarative.Interpret (parse, interpretOptions, ParseResult(..))  type ConfigFile = (FilePath, [String])- type EnvVar = [String]  envVarName :: String envVarName = "HSPEC_OPTIONS" -data Config = Config {-  configIgnoreConfigFile :: Bool-, configDryRun :: Bool-, configFocusedOnly :: Bool-, configFailOnFocused :: Bool-, configPrintCpuTime :: Bool-, configFastFail :: Bool-, configRandomize :: Bool-, configFailureReport :: Maybe FilePath-, configRerun :: Bool-, configRerunAllOnSuccess :: Bool---- |--- A predicate that is used to filter the spec before it is run.  Only examples--- that satisfy the predicate are run.-, configFilterPredicate :: Maybe (Path -> Bool)-, configSkipPredicate :: Maybe (Path -> Bool)-, configQuickCheckSeed :: Maybe Integer-, configQuickCheckMaxSuccess :: Maybe Int-, configQuickCheckMaxDiscardRatio :: Maybe Int-, configQuickCheckMaxSize :: Maybe Int-, configSmallCheckDepth :: Int-, configColorMode :: ColorMode-, configDiff :: Bool-, configFormatter :: Maybe Formatter-, configHtmlOutput :: Bool-, configOutputFile :: Either Handle FilePath-, configConcurrentJobs :: Maybe Int-}--defaultConfig :: Config-defaultConfig = Config {-  configIgnoreConfigFile = False-, configDryRun = False-, configFocusedOnly = False-, configFailOnFocused = False-, configPrintCpuTime = False-, configFastFail = False-, configRandomize = False-, configFailureReport = Nothing-, configRerun = False-, configRerunAllOnSuccess = False-, configFilterPredicate = Nothing-, configSkipPredicate = Nothing-, configQuickCheckSeed = Nothing-, configQuickCheckMaxSuccess = Nothing-, configQuickCheckMaxDiscardRatio = Nothing-, configQuickCheckMaxSize = Nothing-, configSmallCheckDepth = paramsSmallCheckDepth defaultParams-, configColorMode = ColorAuto-, configDiff = True-, configFormatter = Nothing-, configHtmlOutput = False-, configOutputFile = Left stdout-, configConcurrentJobs = Nothing-}--filterOr :: Maybe (Path -> Bool) -> Maybe (Path -> Bool) -> Maybe (Path -> Bool)-filterOr p1_ p2_ = case (p1_, p2_) of-  (Just p1, Just p2) -> Just $ \path -> p1 path || p2 path-  _ -> p1_ <|> p2_--addMatch :: String -> Config -> Config-addMatch s c = c {configFilterPredicate = Just (filterPredicate s) `filterOr` configFilterPredicate c}--addSkip :: String -> Config -> Config-addSkip s c = c {configSkipPredicate = Just (filterPredicate s) `filterOr` configSkipPredicate c}--setDepth :: Int -> Config -> Config-setDepth n c = c {configSmallCheckDepth = n}--setMaxSuccess :: Int -> Config -> Config-setMaxSuccess n c = c {configQuickCheckMaxSuccess = Just n}--setMaxSize :: Int -> Config -> Config-setMaxSize n c = c {configQuickCheckMaxSize = Just n}--setMaxDiscardRatio :: Int -> Config -> Config-setMaxDiscardRatio n c = c {configQuickCheckMaxDiscardRatio = Just n}--setSeed :: Integer -> Config -> Config-setSeed n c = c {configQuickCheckSeed = Just n}--data ColorMode = ColorAuto | ColorNever | ColorAlways-  deriving (Eq, Show)--type Result m = Either InvalidArgument (m Config)--data InvalidArgument = InvalidArgument String String--data Arg a = Arg {-  _argumentName   :: String-, _argumentParser :: String -> Maybe a-, _argumentSetter :: a -> Config -> Config-}--mkOption :: Monad m => [Char] -> String -> Arg a -> String -> OptDescr (Result m -> Result m)-mkOption shortcut name (Arg argName parser setter) help = Option shortcut [name] (ReqArg arg argName) help-  where-    arg input x = x >>= \c -> case parser input of-      Just n -> Right (setter n `liftM` c)-      Nothing -> Left (InvalidArgument name input)--mkFlag :: Monad m => String -> (Bool -> Config -> Config) -> String -> [OptDescr (Result m -> Result m)]-mkFlag name setter help = [-    Option [] [name] (NoArg $ set $ setter True) help-  , Option [] ["no-" ++ name] (NoArg $ set $ setter False) ("do not " ++ help)-  ]--commandLineOptions :: [OptDescr (Result Maybe -> Result Maybe)]-commandLineOptions = [-    Option [] ["help"] (NoArg (const $ Right Nothing)) "display this help and exit"-  , Option [] ["ignore-dot-hspec"] (NoArg setIgnoreConfigFile) "do not read options from ~/.hspec and .hspec"-  , mkOption "m" "match" (Arg "PATTERN" return addMatch) "only run examples that match given PATTERN"-  , mkOption [] "skip" (Arg "PATTERN" return addSkip) "skip examples that match given PATTERN"-  ]-  where-    setIgnoreConfigFile = set $ \config -> config {configIgnoreConfigFile = True}--formatterOptions :: Monad m => [OptDescr (Result m -> Result m)]-formatterOptions = concat [-    [mkOption "f" "format" (Arg "FORMATTER" readFormatter setFormatter) helpForFormat]-  , mkFlag "color" setColor "colorize the output"-  , mkFlag "diff" setDiff "show colorized diffs"-  , [Option [] ["print-cpu-time"] (NoArg setPrintCpuTime) "include used CPU time in summary"]-  ]-  where-    formatters :: [(String, Formatter)]-    formatters = [-        ("checks", checks)-      , ("specdoc", specdoc)-      , ("progress", progress)-      , ("failed-examples", failed_examples)-      , ("silent", silent)-      ]--    helpForFormat :: String-    helpForFormat = "use a custom formatter; this can be one of " ++ (formatOrList $ map fst formatters)--    readFormatter :: String -> Maybe Formatter-    readFormatter = (`lookup` formatters)--    setFormatter :: Formatter -> Config -> Config-    setFormatter f c = c {configFormatter = Just f}--    setColor :: Bool -> Config -> Config-    setColor v config = config {configColorMode = if v then ColorAlways else ColorNever}--    setDiff :: Bool -> Config -> Config-    setDiff v config = config {configDiff = v}--    setPrintCpuTime = set $ \config -> config {configPrintCpuTime = True}--smallCheckOptions :: Monad m => [OptDescr (Result m -> Result m)]-smallCheckOptions = [-    mkOption [] "depth" (Arg "N" readMaybe setDepth) "maximum depth of generated test values for SmallCheck properties"-  ]--quickCheckOptions :: Monad m => [OptDescr (Result m -> Result m)]-quickCheckOptions = [-    mkOption "a" "qc-max-success" (Arg "N" readMaybe setMaxSuccess) "maximum number of successful tests before a QuickCheck property succeeds"-  , mkOption "" "qc-max-size" (Arg "N" readMaybe setMaxSize) "size to use for the biggest test cases"-  , mkOption "" "qc-max-discard" (Arg "N" readMaybe setMaxDiscardRatio) "maximum number of discarded tests per successful test before giving up"-  , mkOption [] "seed" (Arg "N" readMaybe setSeed) "used seed for QuickCheck properties"-  ]--runnerOptions :: Monad m => [OptDescr (Result m -> Result m)]-runnerOptions = concat [-    mkFlag "dry-run" setDryRun "pretend that everything passed; don't verify anything"-  , mkFlag "focused-only" setFocusedOnly "do not run anything, unless there are focused spec items"-  , mkFlag "fail-on-focused" setFailOnFocused "fail on focused spec items"-  , mkFlag "fail-fast" setFastFail "abort on first failure"-  , mkFlag "randomize" setRandomize "randomize execution order"-  ] ++ [-    Option "r" ["rerun"] (NoArg  setRerun) "rerun all examples that failed in the previous test run (only works in combination with --failure-report or in GHCi)"-  , mkOption [] "failure-report" (Arg "FILE" return setFailureReport) "read/write a failure report for use with --rerun"-  , Option [] ["rerun-all-on-success"] (NoArg setRerunAllOnSuccess) "run the whole test suite after a previously failing rerun succeeds for the first time (only works in combination with --rerun)"---  , mkOption "j" "jobs" (Arg "N" readMaxJobs setMaxJobs) "run at most N parallelizable tests simultaneously (default: number of available processors)"-  ]-  where-    readMaxJobs :: String -> Maybe Int-    readMaxJobs s = do-      n <- readMaybe s-      guard $ n > 0-      return n--    setFailureReport :: String -> Config -> Config-    setFailureReport file c = c {configFailureReport = Just file}--    setMaxJobs :: Int -> Config -> Config-    setMaxJobs n c = c {configConcurrentJobs = Just n}--    setDryRun :: Bool -> Config -> Config-    setDryRun value config = config {configDryRun = value}--    setFocusedOnly :: Bool -> Config -> Config-    setFocusedOnly value config = config {configFocusedOnly = value}--    setFailOnFocused :: Bool -> Config -> Config-    setFailOnFocused value config = config {configFailOnFocused = value}--    setFastFail :: Bool -> Config -> Config-    setFastFail value config = config {configFastFail = value}--    setRandomize :: Bool -> Config -> Config-    setRandomize value config = config {configRandomize = value}--    setRerun        = set $ \config -> config {configRerun = True}-    setRerunAllOnSuccess = set $ \config -> config {configRerunAllOnSuccess = True}+commandLineOptions :: Config -> [(String, [Declarative.Option Config])]+commandLineOptions config =+    ("OPTIONS", commandLineOnlyOptions)+  : otherOptions config -documentedConfigFileOptions :: Monad m => [(String, [OptDescr (Result m -> Result m)])]-documentedConfigFileOptions = [+otherOptions :: Config -> [(String, [Declarative.Option Config])]+otherOptions config = [     ("RUNNER OPTIONS", runnerOptions)-  , ("FORMATTER OPTIONS", formatterOptions)+  , ("FORMATTER OPTIONS", formatterOptions formatters)   , ("OPTIONS FOR QUICKCHECK", quickCheckOptions)   , ("OPTIONS FOR SMALLCHECK", smallCheckOptions)-  ]--documentedOptions :: [(String, [OptDescr (Result Maybe -> Result Maybe)])]-documentedOptions = ("OPTIONS", commandLineOptions) : documentedConfigFileOptions--configFileOptions :: Monad m => [OptDescr (Result m -> Result m)]-configFileOptions = (concat . map snd) documentedConfigFileOptions--set :: Monad m => (Config -> Config) -> Either a (m Config) -> Either a (m Config)-set = liftM . liftM--undocumentedOptions :: Monad m => [OptDescr (Result m -> Result m)]-undocumentedOptions = [-    -- for compatibility with test-framework-    mkOption [] "maximum-generated-tests" (Arg "NUMBER" readMaybe setMaxSuccess) "how many automated tests something like QuickCheck should try, by default"--    -- undocumented for now, as we probably want to change this to produce a-    -- standalone HTML report in the future-  , Option []  ["html"]                    (NoArg setHtml)                    "produce HTML output"--  , mkOption "o"  "out"                    (Arg "FILE" return setOutputFile)  "write output to a file instead of STDOUT"--    -- now a noop-  , Option "v" ["verbose"]                 (NoArg id)                         "do not suppress output to stdout when evaluating examples"-  ]+  ] ++ extensionOptions   where-    setHtml = set $ \config -> config {configHtmlOutput = True}--    setOutputFile :: String -> Config -> Config-    setOutputFile file c = c {configOutputFile = Right file}+    formatters = configAvailableFormatters config+    extensionOptions = getExtensionOptions config -recognizedOptions :: [OptDescr (Result Maybe -> Result Maybe)]-recognizedOptions = commandLineOptions ++ configFileOptions ++ undocumentedOptions+ignoreConfigFile :: Config -> [String] -> IO Bool+ignoreConfigFile config args = do+  ignore <- lookupEnv "IGNORE_DOT_HSPEC"+  case ignore of+    Just _ -> return True+    Nothing -> case parseCommandLineOptions "" args config of+      Right c -> return (configIgnoreConfigFile c)+      _ -> return False -parseOptions :: Config -> String -> [ConfigFile] -> Maybe EnvVar -> [String] -> Either (ExitCode, String) Config-parseOptions config prog configFiles envVar args = do+parseOptions :: Config -> String -> [ConfigFile] -> Maybe EnvVar -> [(String, String)] -> [String] -> Either (ExitCode, String) ([String], Config)+parseOptions config prog configFiles envVar env args = do       foldM (parseFileOptions prog) config configFiles-  >>= parseEnvVarOptions prog envVar-  >>= parseCommandLineOptions prog args+  >>= maybe return (parseEnvVarOptions prog) envVar+  >>= parseEnvironmentOptions env+  >>= traverse (parseCommandLineOptions prog args)  parseCommandLineOptions :: String -> [String] -> Config -> Either (ExitCode, String) Config-parseCommandLineOptions prog args config = case parse recognizedOptions config args of-  Right Nothing -> Left (ExitSuccess, usage)-  Right (Just c) -> Right c-  Left err -> failure err-  where-    failure err = Left (ExitFailure 1, prog ++ ": " ++ err ++ "\nTry `" ++ prog ++ " --help' for more information.\n")+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) -    usage :: String-    usage = "Usage: " ++ prog ++ " [OPTION]...\n\n"-      ++ (intercalate "\n" $ map (uncurry mkUsageInfo) documentedOptions)+parseEnvironmentOptions :: [(String, String)] -> Config -> Either (ExitCode, String) ([String], Config)+parseEnvironmentOptions env config = case Declarative.parseEnvironmentOptions "HSPEC" env config (concatMap snd $ commandLineOptions 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 -> (Maybe EnvVar) -> Config -> Either (ExitCode, String) Config-parseEnvVarOptions prog args =-  parseOtherOptions prog ("from environment variable " ++ envVarName) (fromMaybe [] args)+parseEnvVarOptions :: String -> EnvVar -> Config -> Either (ExitCode, String) Config+parseEnvVarOptions prog =+  parseOtherOptions prog ("from environment variable " ++ envVarName)  parseOtherOptions :: String -> String -> [String] -> Config -> Either (ExitCode, String) Config-parseOtherOptions prog source args config = case parse configFileOptions config args of-  Right (Identity c) -> Right c+parseOtherOptions prog source args config = case parse (interpretOptions options) config args of+  Right c -> Right c   Left err -> failure err   where+    options :: [Declarative.Option Config]+    options = filter Declarative.optionDocumented $ concatMap snd (otherOptions config)+     failure err = Left (ExitFailure 1, prog ++ ": " ++ message)       where         message = unlines $ case lines err of           [x] -> [x ++ " " ++ source]           xs -> xs ++ [source]--parse :: Monad m => [OptDescr (Result m -> Result m)] -> Config -> [String] -> Either String (m Config)-parse options config args = case getOpt Permute options args of-  (opts, [], []) -> case foldl' (flip id) (Right $ return config) opts of-    Left (InvalidArgument name value) -> Left ("invalid argument `" ++ value ++ "' for `--" ++ name ++ "'")-    Right x -> Right x-  (_, _, err:_) -> Left (init err)-  (_, arg:_, _) -> Left ("unexpected argument `" ++ arg ++ "'")--ignoreConfigFile :: Config -> [String] -> IO Bool-ignoreConfigFile config args = do-  ignore <- lookupEnv "IGNORE_DOT_HSPEC"-  case ignore of-    Just _ -> return True-    Nothing -> case parse recognizedOptions config args of-      Right (Just c) -> return (configIgnoreConfigFile c)-      _ -> return False
− src/Test/Hspec/Core/Config/Util.hs 
@@ -1,37 +0,0 @@-module Test.Hspec.Core.Config.Util where--import           System.Console.GetOpt--import           Test.Hspec.Core.Util--modifyHelp :: (String -> String) -> OptDescr a -> OptDescr a-modifyHelp modify (Option s n a help) = Option s n a (modify help)--mkUsageInfo :: String -> [OptDescr a] -> String-mkUsageInfo title = usageInfo title . addLineBreaksForHelp . condenseNoOptions--addLineBreaksForHelp :: [OptDescr a] -> [OptDescr a]-addLineBreaksForHelp options = map (modifyHelp addLineBreaks) options-  where-    withoutHelpWidth = maxLength . usageInfo "" . map removeHelp-    helpWidth = 80 - withoutHelpWidth options--    addLineBreaks = unlines . lineBreaksAt helpWidth--    maxLength = maximum . map length . lines-    removeHelp = modifyHelp (const "")--condenseNoOptions :: [OptDescr a] -> [OptDescr a]-condenseNoOptions options = case options of-  Option "" [optionA] arg help : Option "" [optionB] _ _ : ys | optionB == ("no-" ++ optionA) ->-    Option "" ["[no-]" ++ optionA] arg help : condenseNoOptions ys-  x : xs -> x : condenseNoOptions xs-  [] -> []--formatOrList :: [String] -> String-formatOrList xs = case xs of-  [] -> ""-  x : ys -> (case ys of-    [] -> x-    _ : [] -> x ++ " or "-    _ : _ : _ -> x ++ ", ") ++ formatOrList ys
src/Test/Hspec/Core/Example.hs view
@@ -1,13 +1,15 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} --- NOTE: re-exported from Test.Hspec.Core.Spec module Test.Hspec.Core.Example (+-- RE-EXPORTED from Test.Hspec.Core.Spec   Example (..)+#ifndef ENABLE_SPEC_HOOK_ARGS+, Arg+#endif , Params (..) , defaultParams , ActionWith@@ -19,126 +21,223 @@ , FailureReason (..) , safeEvaluate , safeEvaluateExample+-- END RE-EXPORTED from Test.Hspec.Core.Spec+, safeEvaluateResultStatus+, exceptionToResultStatus+, toLocation+, hunitFailureToResult ) where +import           Prelude ()+import           Test.Hspec.Core.Compat+ import qualified Test.HUnit.Lang as HUnit -import           Data.CallStack+import           Data.CallStack (SrcLoc(..)) -import           Control.Exception import           Control.DeepSeq-import           Data.Typeable (Typeable) import qualified Test.QuickCheck as QC import           Test.Hspec.Expectations (Expectation) -import qualified Test.QuickCheck.State as QC (numSuccessTests, maxSuccessTests)-import qualified Test.QuickCheck.Property as QCP--import           Test.Hspec.Core.QuickCheckUtil import           Test.Hspec.Core.Util-import           Test.Hspec.Core.Compat+import           Test.Hspec.Core.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   type Arg e = ()-  evaluateExample :: e -> Params -> (ActionWith (Arg e) -> IO ()) -> ProgressCallback -> IO Result+#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++  -- | 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 = Result {   resultInfo :: String , resultStatus :: ResultStatus-} deriving (Show, Typeable)+} deriving Show  data ResultStatus =     Success   | Pending (Maybe Location) (Maybe String)   | Failure (Maybe Location) FailureReason-  deriving (Show, Typeable)+  deriving Show  data FailureReason =     NoReason   | Reason String+  | ColorizedReason String   | ExpectedButGot (Maybe String) String String   | Error (Maybe String) SomeException-  deriving (Show, Typeable)+  deriving Show  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` e `seq` ()+    Error m e -> m `deepseq` show e `deepseq` ()  instance Exception ResultStatus -safeEvaluateExample :: Example e => e -> Params -> (ActionWith (Arg e) -> IO ()) -> ProgressCallback -> IO Result-safeEvaluateExample example params around progress = safeEvaluate $ forceResult <$> evaluateExample example params around progress-  where-    forceResult :: Result -> Result-    forceResult r@(Result info status) = info `deepseq` (forceResultStatus status) `seq` r+forceResult :: Result -> Result+forceResult r@(Result info status) = info `deepseq` (forceResultStatus status) `seq` r -    forceResultStatus :: ResultStatus -> ResultStatus-    forceResultStatus r = case r of-      Success -> r-      Pending _ m -> m `deepseq` r-      Failure _ m -> m `deepseq` r+forceResultStatus :: ResultStatus -> ResultStatus+forceResultStatus r = case r of+  Success -> r+  Pending _ m -> m `deepseq` r+  Failure _ m -> m `deepseq` r +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 $ action-  return $ case r of-    Left e | Just result <- fromException e -> Result "" result-    Left e | Just hunit <- fromException e -> Result "" $ hunitFailureToResult Nothing hunit-    Left e -> Result "" $ Failure Nothing $ Error Nothing e-    Right result -> result+  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 = ()+#endif   evaluateExample e = evaluateExample (\() -> e) +#ifdef ENABLE_SPEC_HOOK_ARGS instance Example (a -> Result) where   type Arg (a -> Result) = a-  evaluateExample example _params action _callback = do-    ref <- newIORef (Result "" Success)-    action (evaluate . example >=> writeIORef ref)-    readIORef ref+#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) +#ifdef ENABLE_SPEC_HOOK_ARGS instance Example (a -> Bool) where   type Arg (a -> Bool) = a-  evaluateExample p _params action _callback = do-    ref <- newIORef (Result "" Success)-    action (evaluate . example >=> writeIORef ref)-    readIORef ref+#else+instance Example (() -> Bool) where+#endif+  evaluateExample p _params hook _callback = do+    liftHook (Result "" Success) hook (evaluate . example)     where       example a         | p a = Result "" Success         | otherwise = Result "" $ Failure Nothing NoReason  instance Example Expectation where+#ifdef ENABLE_SPEC_HOOK_ARGS   type Arg Expectation = ()+#endif   evaluateExample e = evaluateExample (\() -> e)  hunitFailureToResult :: Maybe String -> HUnit.HUnitFailure -> ResultStatus@@ -155,60 +254,20 @@     where       location = case mLoc of         Nothing -> Nothing-        Just loc -> Just $ Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc)+        Just loc -> Just $ toLocation loc   where     addPre :: String -> String     addPre xs = case pre of       Just x -> x ++ "\n" ++ xs       Nothing -> xs +toLocation :: SrcLoc -> Location+toLocation loc = Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc)++#ifdef ENABLE_SPEC_HOOK_ARGS instance Example (a -> Expectation) where   type Arg (a -> Expectation) = a-  evaluateExample e _ action _ = action e >> return (Result "" Success)--instance Example QC.Property where-  type Arg QC.Property = ()-  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 $ fromQuickCheckResult r-    where-      qcProgressCallback = QCP.PostTest QCP.NotCounterexample $-        \st _ -> progressCallback (QC.numSuccessTests st, QC.maxSuccessTests st)--fromQuickCheckResult :: QC.Result -> Result-fromQuickCheckResult r = case parseQuickCheckResult r of-  QuickCheckResult _ info (QuickCheckOtherFailure err) -> Result info $ Failure Nothing (Reason err)-  QuickCheckResult _ info QuickCheckSuccess -> Result info Success-  QuickCheckResult n info (QuickCheckFailure QCFailure{..}) -> case quickCheckFailureException of-    Just e | Just result <- fromException e -> Result info result-    Just e | Just hunit <- fromException e -> Result info $ hunitFailureToResult (Just hunitAssertion) hunit-    Just e -> failure (uncaughtException e)-    Nothing -> failure falsifiable-    where-      failure = Result info . Failure Nothing . Reason--      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+#else+instance Example (() -> Expectation) where+#endif+  evaluateExample e _params hook _ = hook e >> return (Result "" Success)
src/Test/Hspec/Core/Example/Location.hs view
@@ -1,24 +1,34 @@ {-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wno-missing-signatures #-} module Test.Hspec.Core.Example.Location (   Location(..) , extractLocation --- for testing+#ifdef TEST+, parseBacktraces , parseAssertionFailed , parseCallStack , parseLocation , parseSourceSpan++, workaroundForIssue19236+#endif ) where  import           Prelude () import           Test.Hspec.Core.Compat -import           Control.Exception-import           Data.List import           Data.Char-import           Data.Maybe 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@@ -27,14 +37,36 @@ } 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@@ -46,17 +78,17 @@   Nothing -> Nothing  parseAssertionFailed :: String -> Maybe Location-parseAssertionFailed loc = parseCallStack loc <|> parseSourceSpan loc+parseAssertionFailed loc = parseCallStack (lines loc) <|> parseSourceSpan loc  locationFromErrorCall :: SomeException -> Maybe Location locationFromErrorCall e = case fromException e of-#if MIN_VERSION_base(4,9,0)-  Just (ErrorCallWithLocation err loc) ->-    parseCallStack loc <|>+#if MIN_VERSION_base(4,21,0)+  Just (ErrorCall _) -> Nothing #else-  Just (ErrorCall err) ->-#endif+  Just (ErrorCallWithLocation err loc) ->+    parseCallStack (lines loc) <|>     fromPatternMatchFailureInDoExpression err+#endif   Nothing -> Nothing  locationFromPatternMatchFail :: SomeException -> Maybe Location@@ -77,10 +109,14 @@  fromPatternMatchFailureInDoExpression :: String -> Maybe Location fromPatternMatchFailureInDoExpression input =+#if MIN_VERSION_base(4,16,0)+  stripPrefix "Pattern match failure in 'do' block at " input >>= parseSourceSpan+#else   stripPrefix "Pattern match failure in do expression at " input >>= parseSourceSpan+#endif -parseCallStack :: String -> Maybe Location-parseCallStack input = case reverse (lines input) of+parseCallStack :: [String] -> Maybe Location+parseCallStack input = case reverse input of   [] -> Nothing   line : _ -> findLocation line   where@@ -93,11 +129,11 @@  parseLocation :: String -> Maybe Location parseLocation input = case fmap breakColon (breakColon input) of-  (file, (line, column)) -> Location file <$> readMaybe line <*> readMaybe column+  (file, (line, column)) -> mkLocation file <$> readMaybe line <*> readMaybe column  parseSourceSpan :: String -> Maybe Location parseSourceSpan input = case breakColon input of-  (file, xs) -> (uncurry $ Location file) <$> (tuple <|> colonSeparated)+  (file, xs) -> (uncurry $ mkLocation file) <$> (tuple <|> colonSeparated)     where       lineAndColumn :: String       lineAndColumn = takeWhile (/= '-') xs@@ -111,3 +147,15 @@  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
@@ -5,17 +5,28 @@ , 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 -#ifndef __GHCJS__-import           System.SetEnv+#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.Options (Config(..))+import           Test.Hspec.Core.Config.Definition (Config(..))  data FailureReport = FailureReport {   failureReportSeed :: Integer@@ -29,20 +40,15 @@ writeFailureReport config report = case configFailureReport config of   Just file -> writeFile file (show report)   Nothing -> do-#ifdef __GHCJS__-    -- 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.-    return ()-#else+#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)
src/Test/Hspec/Core/Format.hs view
@@ -1,6 +1,18 @@ {-# LANGUAGE RankNTypes #-}-module Test.Hspec.Core.Format (-  Format(..)+{-# 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(..)@@ -8,13 +20,23 @@ , Item(..) , Result(..) , FailureReason(..)+, monadic ) where -import           Test.Hspec.Core.Spec (Progress, Location(..))-import           Test.Hspec.Core.Example (FailureReason(..))-import           Test.Hspec.Core.Util (Path)-import           Test.Hspec.Core.Clock+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@@ -24,15 +46,102 @@  data Result =     Success-  | Pending (Maybe String)-  | Failure FailureReason+  | Pending (Maybe Location) (Maybe String)+  | Failure (Maybe Location) FailureReason   deriving Show -data Format m = Format {-  formatRun :: forall a. m a -> IO a-, formatGroupStarted :: Path -> m ()-, formatGroupDone :: Path -> m ()-, formatProgress :: Path -> Progress -> m ()-, formatItemStarted :: Path -> m ()-, formatItemDone :: Path -> Item -> m ()+data Event =+    Started+  | GroupStarted Path+  | GroupDone Path+  | Progress Path Progress+  | ItemStarted Path+  | ItemDone Path Item+  | Done [(Path, Item)]+  deriving Show++data FormatConfig = FormatConfig {+  formatConfigUseColor :: Bool+, 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,314 +1,5 @@-{-# LANGUAGE CPP #-}--- |--- Stability: experimental------ This module contains formatters that can be used with--- `Test.Hspec.Core.Runner.hspecWith`.-module Test.Hspec.Core.Formatters (---- * Formatters-  silent-, 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---- ** Accessing the runner state-, getSuccessCount-, getPendingCount-, getFailCount-, getTotalCount--, FailureRecord (..)-, getFailMessages-, usedSeed--, Seconds(..)-, getCPUTime-, getRealTime---- ** Appending to the generated report-, write-, writeLine-, writeTransient---- ** Dealing with colors-, withInfoColor-, withSuccessColor-, withPendingColor-, withFailColor--, useDiff-, extraChunk-, missingChunk---- ** Helpers-, formatException-) where--import           Prelude ()-import           Test.Hspec.Core.Compat hiding (First)--import           Data.Maybe-import           Test.Hspec.Core.Util-import           Test.Hspec.Core.Clock-import           Test.Hspec.Core.Spec (Location(..))-import           Text.Printf-import           Control.Monad.IO.Class-import           Control.Exception---- We use an explicit import list for "Test.Hspec.Formatters.Internal", to make--- sure, that we only use the public API to implement formatters.------ Everything imported here has to be re-exported, so that users can implement--- their own formatters.-import Test.Hspec.Core.Formatters.Monad (-    Formatter (..)-  , FailureReason (..)-  , FormatM--  , getSuccessCount-  , getPendingCount-  , getFailCount-  , getTotalCount--  , FailureRecord (..)-  , getFailMessages-  , usedSeed--  , getCPUTime-  , getRealTime--  , write-  , writeLine-  , writeTransient--  , withInfoColor-  , withSuccessColor-  , withPendingColor-  , withFailColor--  , useDiff-  , extraChunk-  , missingChunk-  )--import           Test.Hspec.Core.Formatters.Diff--silent :: Formatter-silent = Formatter {-  headerFormatter     = return ()-, exampleGroupStarted = \_ _ -> return ()-, exampleGroupDone    = return ()-, exampleStarted      = \_ -> return ()-, exampleProgress     = \_ _ -> return ()-, exampleSucceeded    = \ _ _ -> return ()-, exampleFailed       = \_ _ _ -> return ()-, examplePending      = \_ _ _ -> return ()-, failedFormatter     = return ()-, footerFormatter     = return ()-}--checks :: Formatter-checks = specdoc {-  exampleStarted = \(nesting, requirement) -> do-    writeTransient $ indentationFor nesting ++ requirement ++ " [ ]"--, exampleProgress = \(nesting, requirement) p -> do-    writeTransient $ indentationFor nesting ++ requirement ++ " [" ++ (formatProgress p) ++ "]"--, exampleSucceeded = \(nesting, requirement) info -> do-    writeResult nesting requirement info $ withSuccessColor $ write "✔"--, exampleFailed = \(nesting, requirement) info _ -> do-    writeResult nesting requirement info $ withFailColor $ write "✘"--, examplePending = \(nesting, requirement) info reason -> do-    writeResult nesting requirement info $ withPendingColor $ write "‐"--    withPendingColor $ do-      writeLine $ indentationFor ("" : nesting) ++ "# PENDING: " ++ fromMaybe "No reason given" reason-} where-    indentationFor nesting = replicate (length nesting * 2) ' '--    writeResult :: [String] -> String -> String -> FormatM () -> FormatM ()-    writeResult nesting requirement info action = do-      write $ indentationFor nesting ++ requirement ++ " ["-      action-      writeLine "]"-      forM_ (lines info) $ \ s ->-        writeLine $ indentationFor ("" : nesting) ++ s--    formatProgress (current, total)-      | total == 0 = show current-      | otherwise  = show current ++ "/" ++ show total--specdoc :: Formatter-specdoc = silent {--  headerFormatter = do-    writeLine ""--, exampleGroupStarted = \nesting name -> do-    writeLine (indentationFor nesting ++ name)--, exampleProgress = \_ p -> do-    writeTransient (formatProgress p)--, exampleSucceeded = \(nesting, requirement) info -> withSuccessColor $ do-    writeLine $ indentationFor nesting ++ requirement-    forM_ (lines info) $ \ s ->-      writeLine $ indentationFor ("" : nesting) ++ s--, exampleFailed = \(nesting, requirement) info _ -> withFailColor $ do-    n <- getFailCount-    writeLine $ indentationFor nesting ++ requirement ++ " FAILED [" ++ show n ++ "]"-    forM_ (lines info) $ \ s ->-      writeLine $ indentationFor ("" : nesting) ++ s--, examplePending = \(nesting, requirement) info reason -> withPendingColor $ do-    writeLine $ indentationFor nesting ++ requirement-    forM_ (lines info) $ \ s ->-      writeLine $ indentationFor ("" : nesting) ++ s-    writeLine $ indentationFor ("" : nesting) ++ "# PENDING: " ++ fromMaybe "No reason given" reason--, failedFormatter = defaultFailedFormatter--, footerFormatter = defaultFooter-} where-    indentationFor nesting = replicate (length nesting * 2) ' '-    formatProgress (current, total)-      | total == 0 = show current-      | otherwise  = show current ++ "/" ++ show total---progress :: Formatter-progress = silent {-  exampleSucceeded = \_ _ -> withSuccessColor $ write "."-, exampleFailed    = \_ _ _ -> withFailColor    $ write "F"-, examplePending   = \_ _ _ -> withPendingColor $ write "."-, failedFormatter  = defaultFailedFormatter-, footerFormatter  = defaultFooter-}---failed_examples :: Formatter-failed_examples   = silent {-  failedFormatter = defaultFailedFormatter-, footerFormatter = defaultFooter-}--defaultFailedFormatter :: FormatM ()-defaultFailedFormatter = do-  writeLine ""--  failures <- getFailMessages--  unless (null failures) $ do-    writeLine "Failures:"-    writeLine ""--    forM_ (zip [1..] failures) $ \x -> do-      formatFailure x-      writeLine ""--#if __GLASGOW_HASKELL__ == 800-    withFailColor $ do-      writeLine "WARNING:"-      writeLine "  Your version of GHC is affected by https://ghc.haskell.org/trac/ghc/ticket/13285."-      writeLine "  Source locations may not work as expected."-      writeLine ""-      writeLine "  Please consider upgrading GHC!"-      writeLine ""-#endif--    write "Randomized with seed " >> usedSeed >>= writeLine . show-    writeLine ""-  where-    formatFailure :: (Int, FailureRecord) -> FormatM ()-    formatFailure (n, FailureRecord mLoc path reason) = do-      forM_ mLoc $ \loc -> do-        withInfoColor $ writeLine (formatLoc loc)-      write ("  " ++ show n ++ ") ")-      writeLine (formatRequirement path)-      case reason of-        NoReason -> return ()-        Reason err -> withFailColor $ indent err-        ExpectedButGot preface expected actual -> do-          mapM_ indent preface--          b <- useDiff--          let threshold = 2 :: Seconds--          mchunks <- liftIO $ if b-            then timeout threshold (evaluate $ diff expected actual)-            else return Nothing--          case mchunks of-            Just chunks -> do-              writeDiff chunks extraChunk missingChunk-            Nothing -> do-              writeDiff [First expected, Second actual] write write-          where-            indented output text = case break (== '\n') text of-              (xs, "") -> output xs-              (xs, _ : ys) -> output (xs ++ "\n") >> write (indentation ++ "          ") >> indented output ys--            writeDiff chunks extra missing = do-              withFailColor $ write (indentation ++ "expected: ")-              forM_ chunks $ \ chunk -> case chunk of-                Both a _ -> indented write a-                First a -> indented extra a-                Second _ -> return ()-              writeLine ""--              withFailColor $ write (indentation ++ " but got: ")-              forM_ chunks $ \ chunk -> case chunk of-                Both a _ -> indented write a-                First _ -> return ()-                Second a -> indented missing a-              writeLine ""--        Error _ e -> withFailColor . indent $ (("uncaught exception: " ++) . formatException) e--      writeLine ""-      writeLine ("  To rerun use: --match " ++ show (joinPath path))-      where-        indentation = "       "-        indent message = do-          forM_ (lines message) $ \line -> do-            writeLine (indentation ++ line)-        formatLoc (Location file line column) = "  " ++ file ++ ":" ++ show line ++ ":" ++ show column ++ ": "--defaultFooter :: FormatM ()-defaultFooter = do--  writeLine =<< (++)-    <$> (printf "Finished in %1.4f seconds" <$> getRealTime)-    <*> (maybe "" (printf ", used %1.4f seconds of CPU time") <$> getCPUTime)--  fails   <- getFailCount-  pending <- getPendingCount-  total   <- getTotalCount--  let-    output =-         pluralize total   "example"-      ++ ", " ++ pluralize fails "failure"-      ++ if pending == 0 then "" else ", " ++ show pending ++ " pending"-    c | fails /= 0   = withFailColor-      | pending /= 0 = withPendingColor-      | otherwise    = withSuccessColor-  c $ writeLine output+{-# 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
@@ -1,8 +1,15 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} module Test.Hspec.Core.Formatters.Diff (   Diff (..) , diff++, LineDiff(..)+, lineDiff++, splitLines+ #ifdef TEST , partition , breakList@@ -13,15 +20,130 @@ import           Test.Hspec.Core.Compat  import           Data.Char-import           Data.List (stripPrefix)-import           Data.Algorithm.Diff+import qualified Data.Algorithm.Diff as Diff -diff :: String -> String -> [Diff String]-diff expected actual = map (fmap concat) $ getGroupedDiff (partition expected) (partition actual)+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@@ -38,7 +160,7 @@       | otherwise = (x :)  splitEscape :: String -> Maybe (String, String)-splitEscape xs = splitNumericEscape xs <|> (msum $ map split escapes)+splitEscape xs = splitNumericEscape xs <|> msum (map split escapes)   where     split :: String -> Maybe (String, String)     split escape = (,) escape <$> stripPrefix escape xs
− src/Test/Hspec/Core/Formatters/Free.hs 
@@ -1,22 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-module Test.Hspec.Core.Formatters.Free where--import           Prelude ()-import           Test.Hspec.Core.Compat--data Free f a = Free (f (Free f a)) | Pure a-  deriving Functor--instance Functor f => Applicative (Free f) where-  pure = Pure-  Pure f <*> Pure a = Pure (f a)-  Pure f <*> Free m = Free (fmap f <$> m)-  Free m <*> b = Free (fmap (<*> b) m)--instance Functor f => Monad (Free f) where-  return = pure-  Pure a >>= f = f a-  Free m >>= f = Free (fmap (>>= f) m)--liftF :: Functor f => f a -> Free f a-liftF command = Free (fmap Pure command)
src/Test/Hspec/Core/Formatters/Internal.hs view
@@ -1,16 +1,57 @@-{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-} module Test.Hspec.Core.Formatters.Internal (-  FormatM-, FormatConfig(..)-, runFormatM-, interpret-, increaseSuccessCount-, increasePendingCount-, addFailMessage-, finally_+  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+ #ifdef TEST-, overwriteWith+, runFormatM+, splitLines #endif ) where @@ -18,87 +59,138 @@ import           Test.Hspec.Core.Compat  import qualified System.IO as IO-import           System.IO (Handle)-import           Control.Exception (AsyncException(..), bracket_, try, throwIO)-import           System.Console.ANSI-import           Control.Monad.Trans.State hiding (state, 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 qualified Test.Hspec.Core.Formatters.Monad as M-import           Test.Hspec.Core.Formatters.Monad (Environment(..), interpretWith, FailureRecord(..)) import           Test.Hspec.Core.Format import           Test.Hspec.Core.Clock -formatterToFormat :: M.Formatter -> FormatConfig -> Format FormatM-formatterToFormat formatter config = Format {-  formatRun = \action -> runFormatM config $ do-    interpret (M.headerFormatter formatter)-    a <- action `finally_` interpret (M.failedFormatter formatter)-    interpret (M.footerFormatter formatter)-    return a-, formatGroupStarted = \ (nesting, name) -> interpret $ M.exampleGroupStarted formatter nesting name-, formatGroupDone = \ _ -> interpret (M.exampleGroupDone formatter)+data Formatter = Formatter {+-- | evaluated before a test run+  formatterStarted :: FormatM () -, formatProgress = \ path progress -> do-    interpret $ M.exampleProgress formatter path progress+-- | evaluated before each spec group+, formatterGroupStarted :: Path -> FormatM () -, formatItemStarted = \ path -> do-    interpret $ M.exampleStarted formatter path+-- | evaluated after each spec group+, formatterGroupDone :: Path -> FormatM () -, formatItemDone = \ path (Item loc _duration info result) -> do-    clearTransientOutput-    case result of-      Success -> do-        increaseSuccessCount-        interpret $ M.exampleSucceeded formatter path info-      Pending reason -> do-        increasePendingCount-        interpret $ M.examplePending formatter path info reason-      Failure err -> do-        addFailMessage loc path err-        interpret $ M.exampleFailed formatter path info err+-- | 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 () } -interpret :: M.FormatM a -> FormatM a-interpret = interpretWith Environment {-  environmentGetSuccessCount = getSuccessCount-, environmentGetPendingCount = getPendingCount-, environmentGetFailMessages = getFailMessages-, environmentUsedSeed = usedSeed-, environmentGetCPUTime = getCPUTime-, environmentGetRealTime = getRealTime-, environmentWrite = write-, environmentWriteTransient = writeTransient-, environmentWithFailColor = withFailColor-, environmentWithSuccessColor = withSuccessColor-, environmentWithPendingColor = withPendingColor-, environmentWithInfoColor = withInfoColor-, environmentUseDiff = gets (formatConfigUseDiff . stateConfig)-, environmentExtraChunk = extraChunk-, environmentMissingChunk = missingChunk-, environmentLiftIO = liftIO+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)--data FormatConfig = FormatConfig {-  formatConfigHandle :: Handle-, formatConfigUseColor :: Bool-, formatConfigUseDiff :: Bool-, formatConfigHtmlOutput :: Bool-, formatConfigPrintCpuTime :: Bool-, formatConfigUsedSeed :: Integer-} deriving (Eq, Show)+  ask >>= liftIO . (`modifyIORef'` f)  data FormatterState = FormatterState {   stateSuccessCount    :: !Int@@ -106,32 +198,49 @@ , stateFailMessages    :: [FailureRecord] , stateCpuStartTime    :: Maybe Integer , stateStartTime       :: Seconds-, stateTransientOutput :: String-, stateConfig :: FormatConfig+, stateConfig          :: FormatConfig+, stateColor           :: Maybe SGR } -getConfig :: (FormatConfig -> a) -> FormatM a-getConfig f = gets (f . stateConfig)+-- | @since 2.11.5+getConfig :: FormatM FormatConfig+getConfig = gets stateConfig -getHandle :: FormatM Handle-getHandle = getConfig formatConfigHandle+-- | @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 = getConfig formatConfigUsedSeed+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 :: FormatConfig -> FormatM a -> IO a-runFormatM config (FormatM action) = do+runFormatM config (FormatM action) = withLineBuffering $ do   time <- getMonotonicTime-  cpuTime <- if (formatConfigPrintCpuTime config) then Just <$> CPUTime.getCPUTime else pure Nothing-  st <- newIORef (FormatterState 0 0 [] cpuTime time "" config)-  evalStateT action st+  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 {stateSuccessCount = succ $ stateSuccessCount s}@@ -148,44 +257,57 @@ getPendingCount :: FormatM Int getPendingCount = gets statePendingCount --- | Append to the list of accumulated failure messages.-addFailMessage :: Maybe Location -> Path -> FailureReason -> FormatM ()-addFailMessage loc p m = modify $ \s -> s {stateFailMessages = FailureRecord loc p m : stateFailMessages s}- -- | Get the list of accumulated failure messages. getFailMessages :: FormatM [FailureRecord] getFailMessages = reverse `fmap` gets stateFailMessages -overwriteWith :: String -> String -> String-overwriteWith old new-  | n == 0 = new-  | otherwise = '\r' : new ++ replicate (n - length new) ' '-  where-    n = length old+-- | Get the number of spec items that will have been encountered when this run+-- completes (if it is not terminated early).+--+-- @since 2.9.0+getExpectedTotalCount :: FormatM Int+getExpectedTotalCount = getConfigValue formatConfigExpectedTotalCount  writeTransient :: String -> FormatM () writeTransient new = do-  useColor <- getConfig formatConfigUseColor-  when (useColor) $ do-    old <- gets stateTransientOutput-    write $ old `overwriteWith` new-    modify $ \ state -> state {stateTransientOutput = new}-    h <- getHandle-    liftIO $ IO.hFlush h+  reportProgress <- getConfigValue formatConfigReportProgress+  when reportProgress . liftIO $ do+    bracket_ disableLineWrapping enableLineWrapping $ writePlain new+    IO.hFlush stdout+    clearLine+  where+    disableLineWrapping :: IO ()+    disableLineWrapping = writePlain "\ESC[?7l" -clearTransientOutput :: FormatM ()-clearTransientOutput = do-  n <- length <$> gets stateTransientOutput-  unless (n == 0) $ do-    write ("\r" ++ replicate n ' ' ++ "\r")-    modify $ \ state -> state {stateTransientOutput = ""}+    enableLineWrapping :: IO ()+    enableLineWrapping = writePlain "\ESC[?7h" +    clearLine :: IO ()+    clearLine = writePlain "\r\ESC[K"+ -- | Append some output to the report. write :: String -> FormatM ()-write s = do-  h <- getHandle-  liftIO $ IO.hPutStr h s+write = mapM_ writeChunk . splitLines +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,34 +331,28 @@ -- | Set a color, run an action, and finally reset colors. withColor :: SGR -> String -> FormatM a -> FormatM a withColor color cls action = do-  produceHTML <- getConfig formatConfigHtmlOutput+  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 <- getConfig formatConfigUseColor-  h <- getHandle--  FormatM . StateT $ \st -> do-    bracket_--      -- set color-      (when useColor $ hSetSGR h [color])--      -- reset colors-      (when useColor $ hSetSGR h [Reset])+withColor_ color action = do+  oldColor <- gets stateColor+  setColor (Just color) *> action <* setColor oldColor -      -- run action-      (runStateT action st)+setColor :: Maybe SGR -> FormatM ()+setColor color = do+  useColor <- getConfigValue formatConfigUseColor+  when useColor $ do+    modify (\ state -> state { stateColor = color })  -- | Output given chunk in red. extraChunk :: String -> FormatM () extraChunk s = do-  useDiff <- getConfig formatConfigUseDiff-  case useDiff of+  diff <- getConfigValue formatConfigUseDiff+  case diff of     True -> extra s     False -> write s   where@@ -246,8 +362,8 @@ -- | Output given chunk in green. missingChunk :: String -> FormatM () missingChunk s = do-  useDiff <- getConfig formatConfigUseDiff-  case useDiff of+  diff <- getConfigValue formatConfigUseDiff+  case diff of     True -> missing s     False -> write s   where@@ -255,35 +371,24 @@     missing = diffColorize Green "hspec-success"  diffColorize :: Color -> String -> String-> FormatM ()-diffColorize color cls s = withColor (SetColor layer Dull color) cls $ do-  write s+diffColorize color cls s = withColor (SetColor layer Dull color) cls $ case s of+  "" -> write eraseInLine+  _ -> write s   where+    eraseInLine :: String+    eraseInLine = "\ESC[K"++    layer :: ConsoleLayer     layer       | all isSpace s = Background       | otherwise = Foreground --- |--- @finally_ actionA actionB@ runs @actionA@ and then @actionB@.  @actionB@ is--- run even when a `UserInterrupt` occurs during @actionA@.-finally_ :: FormatM a -> FormatM () -> FormatM a-finally_ (FormatM actionA) (FormatM actionB) = FormatM . StateT $ \st -> do-  r <- try (runStateT actionA st)-  case r of-    Left e -> do-      when (e == UserInterrupt) $-        runStateT actionB st >> return ()-      throwIO e-    Right (a, st_) -> do-      runStateT actionB st_ >>= return . replaceValue a-  where-    replaceValue a (_, st) = (a, st)- -- | Get the used CPU time since the test run has been started. getCPUTime :: FormatM (Maybe Seconds) getCPUTime = do   t1  <- liftIO CPUTime.getCPUTime   mt0 <- gets stateCpuStartTime-  return $ toSeconds <$> ((-) <$> pure t1 <*> mt0)+  return $ toSeconds <$> ((t1 -) <$> mt0)   where     toSeconds x = Seconds (fromIntegral x / (10.0 ^ (12 :: Integer)))
− src/Test/Hspec/Core/Formatters/Monad.hs 
@@ -1,248 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE ExistentialQuantification #-}-module Test.Hspec.Core.Formatters.Monad (-  Formatter (..)-, FailureReason (..)-, FormatM--, getSuccessCount-, getPendingCount-, getFailCount-, getTotalCount--, FailureRecord (..)-, getFailMessages-, usedSeed--, getCPUTime-, getRealTime--, write-, writeLine-, writeTransient--, withInfoColor-, withSuccessColor-, withPendingColor-, withFailColor--, useDiff-, extraChunk-, missingChunk--, Environment(..)-, interpretWith-) where--import           Prelude ()-import           Test.Hspec.Core.Compat--import           Control.Monad.IO.Class--import           Test.Hspec.Core.Formatters.Free-import           Test.Hspec.Core.Example (FailureReason(..))-import           Test.Hspec.Core.Util (Path)-import           Test.Hspec.Core.Spec (Progress, Location)-import           Test.Hspec.Core.Clock--data Formatter = Formatter {--  headerFormatter :: FormatM ()---- | evaluated before each test group-, exampleGroupStarted :: [String] -> String -> FormatM ()---- | 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 `failuresFormatter`-, footerFormatter :: FormatM ()-}--data FailureRecord = FailureRecord {-  failureRecordLocation :: Maybe Location-, failureRecordPath     :: Path-, failureRecordMessage  :: FailureReason-}--data FormatF next =-    GetSuccessCount (Int -> next)-  | GetPendingCount (Int -> next)-  | GetFailMessages ([FailureRecord] -> next)-  | UsedSeed (Integer -> next)-  | GetCPUTime (Maybe Seconds -> next)-  | GetRealTime (Seconds -> next)-  | Write String next-  | WriteTransient String next-  | forall a. WithFailColor (FormatM a) (a -> next)-  | forall a. WithSuccessColor (FormatM a) (a -> next)-  | forall a. WithPendingColor (FormatM a) (a -> next)-  | forall a. WithInfoColor (FormatM a) (a -> next)-  | UseDiff (Bool -> next)-  | ExtraChunk String next-  | MissingChunk String next-  | forall a. LiftIO (IO a) (a -> next)--instance Functor FormatF where -- deriving this instance would require GHC >= 7.10.1-  fmap f x = case x of-    GetSuccessCount next -> GetSuccessCount (fmap f next)-    GetPendingCount next -> GetPendingCount (fmap f next)-    GetFailMessages next -> GetFailMessages (fmap f next)-    UsedSeed next -> UsedSeed (fmap f next)-    GetCPUTime next -> GetCPUTime (fmap f next)-    GetRealTime next -> GetRealTime (fmap f next)-    Write s next -> Write s (f next)-    WriteTransient s next -> WriteTransient s (f next)-    WithFailColor action next -> WithFailColor action (fmap f next)-    WithSuccessColor action next -> WithSuccessColor action (fmap f next)-    WithPendingColor action next -> WithPendingColor action (fmap f next)-    WithInfoColor action next -> WithInfoColor action (fmap f next)-    UseDiff next -> UseDiff (fmap f next)-    ExtraChunk s next -> ExtraChunk s (f next)-    MissingChunk s next -> MissingChunk s (f next)-    LiftIO action next -> LiftIO action (fmap f next)--type FormatM = Free FormatF--instance MonadIO FormatM where-  liftIO s = liftF (LiftIO s id)--data Environment m = Environment {-  environmentGetSuccessCount :: m Int-, environmentGetPendingCount :: m Int-, environmentGetFailMessages :: m [FailureRecord]-, environmentUsedSeed :: m Integer-, environmentGetCPUTime :: m (Maybe Seconds)-, environmentGetRealTime :: m Seconds-, environmentWrite :: String -> m ()-, environmentWriteTransient :: String -> m ()-, environmentWithFailColor :: forall a. m a -> m a-, environmentWithSuccessColor :: forall a. m a -> m a-, environmentWithPendingColor :: forall a. m a -> m a-, environmentWithInfoColor :: forall a. m a -> m a-, environmentUseDiff :: m Bool-, environmentExtraChunk :: String -> m ()-, environmentMissingChunk :: String -> m ()-, environmentLiftIO :: forall a. IO a -> m a-}--interpretWith :: forall m a. Monad m => Environment m -> FormatM a -> m a-interpretWith Environment{..} = go-  where-    go :: forall b. FormatM b -> m b-    go m = case m of-      Pure value -> return value-      Free action -> case action of-        GetSuccessCount next -> environmentGetSuccessCount >>= go . next-        GetPendingCount next -> environmentGetPendingCount >>= go . next-        GetFailMessages next -> environmentGetFailMessages >>= go . next-        UsedSeed next -> environmentUsedSeed >>= go . next-        GetCPUTime next -> environmentGetCPUTime >>= go . next-        GetRealTime next -> environmentGetRealTime >>= go . next-        Write s next -> environmentWrite s >> go next-        WriteTransient s next -> environmentWriteTransient s >> go next-        WithFailColor inner next -> environmentWithFailColor (go inner) >>= go . next-        WithSuccessColor inner next -> environmentWithSuccessColor (go inner) >>= go . next-        WithPendingColor inner next -> environmentWithPendingColor (go inner) >>= go . next-        WithInfoColor inner next -> environmentWithInfoColor (go inner) >>= go . next-        UseDiff next -> environmentUseDiff >>= go . next-        ExtraChunk s next -> environmentExtraChunk s >> go next-        MissingChunk s next -> environmentMissingChunk s >> go next-        LiftIO inner next -> environmentLiftIO inner >>= go . next---- | Get the number of successful examples encountered so far.-getSuccessCount :: FormatM Int-getSuccessCount = liftF (GetSuccessCount id)---- | Get the number of pending examples encountered so far.-getPendingCount :: FormatM Int-getPendingCount = liftF (GetPendingCount id)---- | Get the number of failed examples encountered so far.-getFailCount :: FormatM Int-getFailCount = length <$> getFailMessages---- | Get the total number of examples encountered so far.-getTotalCount :: FormatM Int-getTotalCount = sum <$> sequence [getSuccessCount, getFailCount, getPendingCount]---- | Get the list of accumulated failure messages.-getFailMessages :: FormatM [FailureRecord]-getFailMessages = liftF (GetFailMessages id)---- | The random seed that is used for QuickCheck.-usedSeed :: FormatM Integer-usedSeed = liftF (UsedSeed id)---- | Get the used CPU time since the test run has been started.-getCPUTime :: FormatM (Maybe Seconds)-getCPUTime = liftF (GetCPUTime id)---- | Get the passed real time since the test run has been started.-getRealTime :: FormatM Seconds-getRealTime = liftF (GetRealTime id)---- | Append some output to the report.-write :: String -> FormatM ()-write s = liftF (Write s ())---- | The same as `write`, but adds a newline character.-writeLine :: String -> FormatM ()-writeLine s = write s >> write "\n"--writeTransient :: String -> FormatM ()-writeTransient s = liftF (WriteTransient s ())---- | Set output color to red, run given action, and finally restore the default--- color.-withFailColor :: FormatM a -> FormatM a-withFailColor s = liftF (WithFailColor s id)---- | Set output color to green, run given action, and finally restore the--- default color.-withSuccessColor :: FormatM a -> FormatM a-withSuccessColor s = liftF (WithSuccessColor s id)---- | Set output color to yellow, run given action, and finally restore the--- default color.-withPendingColor :: FormatM a -> FormatM a-withPendingColor s = liftF (WithPendingColor s id)---- | Set output color to cyan, run given action, and finally restore the--- default color.-withInfoColor :: FormatM a -> FormatM a-withInfoColor s = liftF (WithInfoColor s id)---- | Return `True` if the user requested colorized diffs, `False` otherwise.-useDiff :: FormatM Bool-useDiff = liftF (UseDiff id)---- | Output given chunk in red.-extraChunk :: String -> FormatM ()-extraChunk s = liftF (ExtraChunk s ())---- | Output given chunk in green.-missingChunk :: String -> FormatM ()-missingChunk s = liftF (MissingChunk s ())
+ 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,7 +1,16 @@+{-# 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@@ -17,14 +26,19 @@ , aroundAll , aroundAll_ , aroundAllWith++, mapSubject+, ignoreSubject++#ifdef TEST+, decompose+#endif ) where  import           Prelude () import           Test.Hspec.Core.Compat -import           Control.Exception (SomeException, finally, throwIO, try, catch)-import           Control.Concurrent.MVar-import           Control.Concurrent.Async+import           Control.Concurrent  import           Test.Hspec.Core.Example import           Test.Hspec.Core.Tree@@ -43,19 +57,19 @@ 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 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 Empty)   before_ (memoize mvar action) spec  -- | Run a custom action with an argument before the first spec item.-beforeAllWith :: (b -> IO a) -> SpecWith a -> SpecWith b+beforeAllWith :: HasCallStack => (b -> IO a) -> SpecWith a -> SpecWith b beforeAllWith action spec = do   mvar <- runIO (newMVar Empty)   beforeWith (memoize mvar . action) spec@@ -65,14 +79,14 @@   | Memoized a   | Failed SomeException -memoize :: MVar (Memoized a) -> IO a -> IO a+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 beforeAll-hook (see previous failure)"))+    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.@@ -83,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@@ -101,60 +125,79 @@  -- | Run a custom action before and/or after every spec item. aroundWith :: (ActionWith a -> ActionWith b) -> SpecWith a -> SpecWith b-aroundWith action = mapSpecItem action (modifyAroundAction action)+aroundWith = mapSpecItem_ . modifyHook -modifyAroundAction :: (ActionWith a -> ActionWith b) -> Item a -> Item b-modifyAroundAction action item@Item{itemExample = e} =-  item{ itemExample = \params aroundAction -> e params (aroundAction . action) }+modifyHook :: (ActionWith a -> ActionWith b) -> Item a -> Item b+modifyHook action Item{..} = Item {+    itemExample = \ params hook -> itemExample params (hook . action)+  , ..+  }  -- | Wrap an action around the given spec.-aroundAll :: (ActionWith a -> IO ()) -> SpecWith a -> Spec+aroundAll :: HasCallStack => (ActionWith a -> IO ()) -> SpecWith a -> Spec aroundAll action = aroundAllWith $ \ e () -> action e  -- | Wrap an action around the given spec.-aroundAll_ :: (IO () -> IO ()) -> SpecWith a -> SpecWith a+aroundAll_ :: HasCallStack => (IO () -> IO ()) -> SpecWith a -> SpecWith a aroundAll_ action spec = do-  allSpecItemsDone <- runIO newEmptyMVar-  workerRef <- runIO newEmptyMVar-  let-    acquire :: IO ()-    acquire = do-      resource <- newEmptyMVar-      worker <- async $ do-        action $ do-          signal resource-          waitFor allSpecItemsDone-      putMVar workerRef worker-      unwrapExceptionsFromLinkedThread $ do-        link worker-        waitFor resource-    release :: IO ()-    release = signal allSpecItemsDone >> takeMVar workerRef >>= wait-  beforeAll_ acquire $ afterAll_ release spec+  (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. (ActionWith a -> ActionWith b) -> SpecWith a -> SpecWith b+aroundAllWith :: forall a b. HasCallStack => (ActionWith a -> ActionWith b) -> SpecWith a -> SpecWith b aroundAllWith action spec = do-  allSpecItemsDone <- runIO newEmptyMVar-  workerRef <- runIO newEmptyMVar+  (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-      resource <- newEmptyMVar-      worker <- async $ do-        flip action b $ \ a -> do-          putMVar resource a-          waitFor allSpecItemsDone-      putMVar workerRef worker-      unwrapExceptionsFromLinkedThread $ do-        link worker-        takeMVar resource+      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 = signal allSpecItemsDone >> takeMVar workerRef >>= wait-  beforeAllWith acquire $ afterAll_ release spec+    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 -unwrapExceptionsFromLinkedThread :: IO a -> IO a-unwrapExceptionsFromLinkedThread = (`catch` \ (ExceptionInLinkedThread _ e) -> throwIO e)+  return (acquire, release)  type BinarySemaphore = MVar () @@ -163,3 +206,15 @@  waitFor :: BinarySemaphore -> IO () waitFor = takeMVar++-- | Modify the subject under test.+--+-- Note that this resembles a contravariant functor on the first type parameter+-- of `SpecM`.  This is because the subject is passed inwards, as an argument+-- to the spec item.+mapSubject :: (b -> a) -> SpecWith a -> SpecWith b+mapSubject f = aroundWith (. f)++-- | Ignore the subject under test for a given spec.+ignoreSubject :: SpecWith () -> SpecWith a+ignoreSubject = mapSubject (const ())
src/Test/Hspec/Core/QuickCheck.hs view
@@ -1,15 +1,30 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-} -- | Stability: provisional module Test.Hspec.Core.QuickCheck (-  modifyArgs-, modifyMaxSuccess+  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@@ -44,3 +59,57 @@   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,148 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-module Test.Hspec.Core.QuickCheckUtil where--import           Prelude ()-import           Test.Hspec.Core.Compat--import           Control.Exception-import           Data.List-import           Data.Maybe-import           Data.Int-import           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--aroundProperty :: ((a -> IO ()) -> IO ()) -> (a -> Property) -> Property-aroundProperty action p = MkProperty . MkGen $ \r n -> aroundProp action $ \a -> (unGen . unProperty $ p a) r n--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--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-    , computeSize               = undefined-    , numTotMaxShrinks          = 0-    , numSuccessTests           = success-    , numDiscardedTests         = discarded-    , numRecentlyDiscardedTests = 0-    , labels                    = mempty-    , classes                   = mempty-    , tables                    = mempty-    , requiredCoverage          = mempty-    , expected                  = True-    , randomSeed                = mkGen 0-    , numSuccessShrinks         = 0-    , numTryShrinks             = 0-    , numTotTryShrinks          = 0-    }--ensureTrailingNewline :: String -> String-ensureTrailingNewline = unlines . lines--maybeStripPrefix :: String -> String -> String-maybeStripPrefix prefix m = fromMaybe m (stripPrefix prefix m)--maybeStripSuffix :: String -> String -> String-maybeStripSuffix suffix = reverse . maybeStripPrefix (reverse suffix) . reverse--stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]-stripSuffix suffix = fmap reverse . stripPrefix (reverse suffix) . reverse--splitBy :: String -> String -> Maybe (String, String)-splitBy sep xs = listToMaybe [-    (x, y) | (x, Just y) <- zip (inits xs) (map stripSep $ tails xs)-  ]-  where-    stripSep = stripPrefix sep
src/Test/Hspec/Core/Runner.hs view
@@ -1,64 +1,153 @@+{-# OPTIONS_GHC -fno-warn-deprecations #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | -- Stability: provisional module Test.Hspec.Core.Runner (--- * Running a spec+-- * Simple interface   hspec-, runSpec+, hspecWith+, hspecResult+, hspecWithResult +-- ** 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 --- * Summary-, Summary (..)-, isSuccess-, evaluateSummary- -- * Legacy--- | The following primitives are deprecated.  Use `runSpec` instead.-, hspecWith-, hspecResult-, hspecWithResult+, runSpec +-- * Re-exports+, Spec+, SpecWith+ #ifdef TEST+, UseColor(..)+, ProgressReporting(..) , rerunAll , specToEvalForest+, colorOutputSupported+, unicodeOutputSupported #endif ) where  import           Prelude ()-import           Test.Hspec.Core.Compat+import           Test.Hspec.Core.Compat hiding (unicodeOutputSupported)+import qualified Test.Hspec.Core.Compat as Compat -import           Data.Maybe+import           Data.List.NonEmpty (nonEmpty) import           System.IO import           System.Environment (getArgs, withArgs)-import           System.Exit-import qualified Control.Exception as E+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           Test.Hspec.Core.Util (Path)-import           Test.Hspec.Core.Spec+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.Formatters-import           Test.Hspec.Core.Formatters.Internal+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.QuickCheckUtil+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 -applyFilterPredicates :: Config -> [EvalTree] -> [EvalTree]+-- |+-- Make a formatter available for use with @--format@.+--+-- @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 }++-- |+-- 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 }++applyFilterPredicates :: Config -> [Tree c EvalItem] -> [Tree c EvalItem] applyFilterPredicates c = filterForestWithLabels p   where     include :: Path -> Bool@@ -72,61 +161,69 @@       where         path = (groups, evalItemDescription item) -applyDryRun :: Config -> [EvalTree] -> [EvalTree]+applyDryRun :: Config -> [EvalItemTree] -> [EvalItemTree] applyDryRun c   | configDryRun c = bimapForest removeCleanup markSuccess   | otherwise = id   where     removeCleanup :: IO () -> IO ()-    removeCleanup _ = return ()+    removeCleanup _ = pass      markSuccess :: EvalItem -> EvalItem-    markSuccess item = item {evalItemAction = \ _ -> return $ Result "" Success}+    markSuccess item = item {evalItemAction = \ _ -> return (0, Result "" Success)}  -- | 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 desired.  Use `runSpec` if you need more control over these--- aspects.+-- is not always desirable.  Use `evalSpec` and `runSpecForest` if you need+-- more control over these aspects. hspec :: Spec -> IO ()-hspec spec =-      getArgs-  >>= readConfig defaultConfig-  >>= doNotLeakCommandLineArgumentsToExamples . runSpec spec-  >>= evaluateSummary+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 config spec = getArgs >>= readConfig config >>= doNotLeakCommandLineArgumentsToExamples . runSpec spec >>= evaluateSummary---- | `True` if the given `Summary` indicates that there were no--- failures, `False` otherwise.-isSuccess :: Summary -> Bool-isSuccess summary = summaryFailures summary == 0+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 -- items.  If you need this, you have to check the `Summary` yourself and act -- accordingly. hspecResult :: Spec -> IO Summary-hspecResult spec = getArgs >>= readConfig defaultConfig >>= doNotLeakCommandLineArgumentsToExamples . runSpec spec+hspecResult = hspecWithResult defaultConfig  -- | Run given spec with custom options and returns a summary of the test run. --@@ -134,123 +231,235 @@ -- items.  If you need this, you have to check the `Summary` yourself and act -- accordingly. hspecWithResult :: Config -> Spec -> IO Summary-hspecWithResult config spec = getArgs >>= readConfig config >>= doNotLeakCommandLineArgumentsToExamples . runSpec spec+hspecWithResult config = fmap toSummary . hspecWithSpecResult config +hspecWithSpecResult :: Config -> Spec -> IO SpecResult+hspecWithSpecResult defaults spec = do+  (c, forest) <- evalSpec defaults spec+  config <- getArgs >>= readConfig c+  oldFailureReport <- readFailureReportOnRerun config++  let+    normalMode :: IO SpecResult+    normalMode = doNotLeakCommandLineArgumentsToExamples $ runSpecForest_ oldFailureReport forest config++    rerunAllMode :: IO SpecResult+    rerunAllMode = do+      result <- normalMode+      if rerunAll config oldFailureReport result then+        hspecWithSpecResult defaults spec+      else+        return result++  -- 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+ -- |--- `runSpec` is the most basic primitive to run a spec. `hspec` is defined in--- terms of @runSpec@:+-- /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++-- |+-- `runSpecForest` is the most basic primitive to run a spec. `hspec` is+-- defined in terms of @runSpecForest@: -- -- @--- hspec spec =+-- hspec = `evalSpec` `defaultConfig` >=> \\ (config, spec) -> --       `getArgs`---   >>= `readConfig` `defaultConfig`---   >>= `withArgs` [] . runSpec spec---   >>= `evaluateSummary`+--   >>= `readConfig` config+--   >>= `withArgs` [] . runSpecForest spec+--   >>= `evaluateResult` -- @-runSpec :: Spec -> Config -> IO Summary-runSpec spec c_ = do-  oldFailureReport <- readFailureReportOnRerun c_+--+-- @since 2.10.0+runSpecForest :: [SpecTree ()] -> Config -> IO SpecResult+runSpecForest spec config = do+  oldFailureReport <- readFailureReportOnRerun config+  runSpecForest_ oldFailureReport spec config -  c <- ensureSeed (applyFailureReport oldFailureReport c_)+mapItem :: (Item a -> Item b) -> [SpecTree a] -> [SpecTree b]+mapItem f = map (fmap f) -  if configRerunAllOnSuccess c-    -- 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-    then rerunAllMode c oldFailureReport-    else normalMode c+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-    normalMode c = runSpec_ c spec-    rerunAllMode c oldFailureReport = do-      summary <- runSpec_ c spec-      if rerunAll c oldFailureReport summary-        then runSpec spec c_-        else return summary+    addDefaultDescription :: Item a -> Item a+    addDefaultDescription item+      | null (itemRequirement item) = item { itemRequirement = defaultRequirement }+      | otherwise = item+      where+        defaultRequirement = maybe "(unspecified behavior)" formatDefaultDescription (itemLocation item) -failFocused :: Item a -> Item a-failFocused item = item {itemExample = example}+failItemsWithEmptyDescription :: Config -> [SpecTree a] -> [SpecTree a]+failItemsWithEmptyDescription config+  | configFailOnEmptyDescription config = mapItemIf condition (failWith failure)+  | otherwise = id   where-    failure = Failure Nothing (Reason "item is focused; failing due to --fail-on-focused")-    example-      | itemIsFocused item = \ params hook p -> do-          Result info status <- itemExample item params hook p-          return $ Result info $ case status of-            Success -> failure-            Pending _ _ -> failure-            Failure{} -> status-      | otherwise = itemExample item+    condition = null . itemRequirement+    failure = "item has no description; failing due to --fail-on=empty-description" -failFocusedItems :: Config -> Spec -> Spec-failFocusedItems config spec-  | configFailOnFocused config = mapSpecItem_ failFocused spec-  | otherwise = spec+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" -focusSpec :: Config -> Spec -> Spec+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 = focus spec+  | otherwise = focusForest spec -runSpec_ :: Config -> Spec -> IO Summary-runSpec_ config spec = do-  filteredSpec <- specToEvalForest config spec-  withHandle config $ \h -> do-    let formatter = fromMaybe specdoc (configFormatter config)-        seed = (fromJust . configQuickCheckSeed) config-        qcArgs = configQuickCheckArgs config+runSpecForest_ :: Maybe FailureReport -> [SpecTree ()] -> Config -> IO SpecResult+runSpecForest_ oldFailureReport spec c_ = do -    concurrentJobs <- case configConcurrentJobs config of-      Nothing -> getDefaultConcurrentJobs-      Just n -> return n+  (config, seed) <- ensureSeed (applyFailureReport oldFailureReport c_) -    useColor <- doesUseColor h config+  colorMode <- colorOutputSupported (configColorMode config) (hSupportsANSI stdout)+  outputUnicode <- unicodeOutputSupported (configUnicodeMode config) stdout -    results <- withHiddenCursor useColor h $ do-      let-        formatConfig = FormatConfig {-          formatConfigHandle = h-        , formatConfigUseColor = useColor-        , formatConfigUseDiff = configDiff config-        , formatConfigHtmlOutput = configHtmlOutput config-        , formatConfigPrintCpuTime = configPrintCpuTime config-        , formatConfigUsedSeed =  seed-        }-        evalConfig = EvalConfig {-          evalConfigFormat = formatterToFormat formatter formatConfig-        , evalConfigConcurrentJobs = concurrentJobs-        , evalConfigFastFail = configFastFail config-        }-      runFormatter evalConfig filteredSpec+  let+    filteredSpec = specToEvalForest seed config spec+    qcArgs = configQuickCheckArgs config+    !numberOfItems = countEvalItems filteredSpec -    let failures = filter resultItemIsFailure results+  when (configFailOnEmpty config && numberOfItems == 0) $ do+    when (countSpecItems spec /= 0) $ do+      die "all spec items have been filtered; failing due to --fail-on=empty" -    dumpFailureReport config seed qcArgs (map fst failures)+  concurrentJobs <- maybe getDefaultConcurrentJobs return $ configConcurrentJobs config -    return Summary {-      summaryExamples = length results-    , summaryFailures = length failures-    }+  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+      } -specToEvalForest :: Config -> Spec -> IO [EvalTree]-specToEvalForest config spec = do+      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-    seed = (fromJust . configQuickCheckSeed) config-    focusedSpec = focusSpec config (failFocusedItems config spec)+    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-  randomize . pruneForest . applyFilterPredicates config . applyDryRun config . toEvalForest params <$> runSpecM focusedSpec -toEvalForest :: Params -> [SpecTree ()] -> [EvalTree]-toEvalForest params = bimapForest withUnit toEvalItem . filterForest itemIsFocused+pruneForest :: [Tree c a] -> [Eval.Tree c a]+pruneForest = mapMaybe pruneTree++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++type EvalItemTree = Tree (IO ()) EvalItem++toEvalItemForest :: Params -> [SpecTree ()] -> [EvalItemTree]+toEvalItemForest params = bimapForest id toEvalItem . filterForest itemIsFocused+  where     toEvalItem :: Item () -> EvalItem-    toEvalItem (Item requirement loc isParallelizable _isFocused e) = EvalItem requirement loc (fromMaybe False isParallelizable) (e params withUnit)+    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+    }      withUnit :: ActionWith () -> IO ()     withUnit action = action ()@@ -268,49 +477,75 @@ doNotLeakCommandLineArgumentsToExamples :: IO a -> IO a doNotLeakCommandLineArgumentsToExamples = withArgs [] -withHiddenCursor :: Bool -> Handle -> IO a -> IO a-withHiddenCursor useColor h-  | useColor  = E.bracket_ (hHideCursor h) (hShowCursor h)-  | otherwise = id+withHiddenCursor :: ProgressReporting -> Handle -> IO a -> IO a+withHiddenCursor progress h = case progress of+  ProgressReportingDisabled -> id+  ProgressReportingEnabled -> bracket_ (hHideCursor h) (hShowCursor h) -doesUseColor :: Handle -> Config -> IO Bool-doesUseColor h c = case configColorMode c of-  ColorAuto  -> (&&) <$> hIsTerminalDevice h <*> (not <$> isDumb)-  ColorNever -> return False-  ColorAlways -> return True+data UseColor = ColorDisabled | ColorEnabled ProgressReporting+  deriving (Eq, Show) -withHandle :: Config -> (Handle -> IO a) -> IO a-withHandle c action = case configOutputFile c of-  Left h -> action h-  Right path -> withFile path WriteMode action+data ProgressReporting = ProgressReportingDisabled | ProgressReportingEnabled+  deriving (Eq, Show) -rerunAll :: Config -> Maybe FailureReport -> Summary -> Bool-rerunAll _ Nothing _ = False-rerunAll config (Just oldFailureReport) summary =-     configRerunAllOnSuccess config-  && configRerun config-  && isSuccess summary-  && (not . null) (failureReportPaths oldFailureReport)+shouldUseColor :: UseColor -> Bool+shouldUseColor c = case c of+  ColorDisabled -> False+  ColorEnabled _ -> True -isDumb :: IO Bool-isDumb = maybe False (== "dumb") <$> lookupEnv "TERM"+progressReporting :: UseColor -> ProgressReporting+progressReporting c = case c of+  ColorDisabled -> ProgressReportingDisabled+  ColorEnabled r -> r --- | Summary of a test run.-data Summary = Summary {-  summaryExamples :: Int-, summaryFailures :: Int-} deriving (Eq, Show)+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 -instance Monoid Summary where-  mempty = Summary 0 0-#if !MIN_VERSION_base(4,11,0)-  (Summary x1 x2) `mappend` (Summary y1 y2) = Summary (x1 + y1) (x2 + y2)-#else-instance Semigroup Summary where-  (Summary x1 x2) <> (Summary y1 y2) = Summary (x1 + y1) (x2 + y2)-#endif+    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,217 +1,279 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ConstraintKinds #-}--#if MIN_VERSION_base(4,6,0) && !MIN_VERSION_base(4,7,0)--- Control.Concurrent.QSem is deprecated in base-4.6.0.*-{-# OPTIONS_GHC -fno-warn-deprecations #-}-#endif-+{-# LANGUAGE LambdaCase #-} module Test.Hspec.Core.Runner.Eval (   EvalConfig(..)+, ColorMode(..) , EvalTree+, Tree(..) , EvalItem(..)+, Concurrency(..) , runFormatter-, resultItemIsFailure #ifdef TEST-, runSequentially+, mergeResults #endif ) where  import           Prelude () import           Test.Hspec.Core.Compat hiding (Monad)-import qualified Test.Hspec.Core.Compat as M -import qualified Control.Exception as E-import           Control.Concurrent-import           Control.Concurrent.Async hiding (cancel)- import           Control.Monad.IO.Class (liftIO)-import qualified Control.Monad.IO.Class as M--import           Control.Monad.Trans.State hiding (State, state)+import           Control.Monad.Trans.Reader import           Control.Monad.Trans.Class  import           Test.Hspec.Core.Util-import           Test.Hspec.Core.Spec (Tree(..), Progress, FailureReason(..), Result(..), ResultStatus(..), ProgressCallback)+import           Test.Hspec.Core.Spec (Progress, FailureReason(..), Result(..), ResultStatus(..), ProgressCallback) import           Test.Hspec.Core.Timer-import           Test.Hspec.Core.Format (Format(..))+import           Test.Hspec.Core.Format (Format) import qualified Test.Hspec.Core.Format as Format import           Test.Hspec.Core.Clock import           Test.Hspec.Core.Example.Location-import           Test.Hspec.Core.Example (safeEvaluate)+import           Test.Hspec.Core.Example (safeEvaluateResultStatus, exceptionToResultStatus) --- 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)+import qualified Data.List.NonEmpty as NonEmpty+import           Data.List.NonEmpty (NonEmpty(..)) -data EvalConfig m = EvalConfig {-  evalConfigFormat :: Format m+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-, evalConfigFastFail :: Bool+, evalConfigFailFast :: Bool+, evalConfigColorMode :: ColorMode } -data State m = State {-  stateConfig :: EvalConfig m-, stateResults :: [(Path, Format.Item)]+data ColorMode = ColorDisabled | ColorEnabled++data Env = Env {+  envConfig :: EvalConfig+, envAbort :: IORef Bool+, envResults :: IORef [(Path, Format.Item)] } -type EvalM m = StateT (State m) m+formatEvent :: Format.Event -> EvalM ()+formatEvent event = do+  format <- asks $ evalConfigFormat . envConfig+  liftIO $ format event -addResult :: Monad m => Path -> Format.Item -> EvalM m ()-addResult path item = modify $ \ state -> state {stateResults = (path, item) : stateResults state}+type EvalM = ReaderT Env IO -getFormat :: Monad m => (Format m -> a) -> EvalM m a-getFormat format = gets (format . evalConfigFormat . stateConfig)+abort :: EvalM ()+abort = do+  ref <- asks envAbort+  liftIO $ writeIORef ref True -reportItem :: Monad m => Path -> Maybe Location -> EvalM m (Seconds, Result)  -> EvalM m ()+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 :: Monad m => Path -> EvalM m ()-reportItemStarted path = do-  format <- getFormat formatItemStarted-  lift (format path)+reportItemStarted :: Path -> EvalM ()+reportItemStarted = formatEvent . Format.ItemStarted -reportItemDone :: Monad m => Path -> Format.Item -> EvalM m ()+reportItemDone :: Path -> Format.Item -> EvalM () reportItemDone path item = do   addResult path item-  format <- getFormat formatItemDone-  lift (format path item)+  formatEvent $ Format.ItemDone path item -failureItem :: Maybe Location -> Seconds -> String -> FailureReason -> Format.Item-failureItem loc duration info err = Format.Item loc duration info (Format.Failure err)+isFailure :: Result -> Bool+isFailure r = case resultStatus r of+  Success{} -> False+  Pending{} -> False+  Failure{} -> True -reportResult :: Monad m => Path -> Maybe Location -> (Seconds, Result) -> EvalM m ()+reportResult :: Path -> Maybe Location -> (Seconds, Result) -> EvalM () reportResult path loc (duration, result) = do+  mode <- asks (evalConfigColorMode . envConfig)   case result of-    Result info status -> case status of-      Success -> reportItemDone path (Format.Item loc duration info Format.Success)-      Pending loc_ reason -> reportItemDone path (Format.Item (loc_ <|> loc) duration info $ Format.Pending reason)-      Failure loc_ err@(Error _ e) -> reportItemDone path (failureItem (loc_ <|> extractLocation e <|> loc) duration info err)-      Failure loc_ err -> reportItemDone path (failureItem (loc_ <|> loc) duration info err)+    Result info status -> reportItemDone path $ Format.Item loc duration info $ case status of+      Success                      -> Format.Success+      Pending loc_ reason          -> Format.Pending loc_ reason+      Failure loc_ err@(Error _ e) -> Format.Failure (loc_ <|> extractLocation e) err+      Failure loc_ err             -> Format.Failure loc_ $ 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 :: Monad m => Path -> EvalM m ()-groupStarted path = do-  format <- getFormat formatGroupStarted-  lift $ format path+groupStarted :: Path -> EvalM ()+groupStarted = formatEvent . Format.GroupStarted -groupDone :: Monad m => Path -> EvalM m ()-groupDone path = do-  format <- getFormat formatGroupDone-  lift $ format path+groupDone :: Path -> EvalM ()+groupDone = formatEvent . Format.GroupDone  data EvalItem = EvalItem {   evalItemDescription :: String , evalItemLocation :: Maybe Location-, evalItemParallelize :: Bool-, evalItemAction :: ProgressCallback -> IO Result+, evalItemConcurrency :: Concurrency+, evalItemAction :: ProgressCallback -> IO (Seconds, Result) }  type EvalTree = Tree (IO ()) EvalItem -runEvalM :: Monad m => EvalConfig m -> EvalM m () -> m (State m)-runEvalM config action = execStateT action (State config [])- -- | Evaluate all examples of a given spec and produce a report.-runFormatter :: forall m. MonadIO m => EvalConfig m -> [EvalTree] -> IO ([(Path, Format.Item)])+runFormatter :: EvalConfig -> [EvalTree] -> IO [(Path, Format.Item)] runFormatter config specs = do-  let-    start = parallelizeTree (evalConfigConcurrentJobs config) specs-    cancel = cancelMany . concatMap toList . map (fmap fst)-  E.bracket start cancel $ \ runningSpecs -> do+  withJobQueue (evalConfigConcurrentJobs config) $ \ queue -> do     withTimer 0.05 $ \ timer -> do-      state <- formatRun format $ do-        runEvalM config $-          run $ map (fmap (fmap (. reportProgress timer) . snd)) runningSpecs-      return (reverse $ stateResults state)+      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+    mkEnv :: IO Env+    mkEnv = Env config <$> newIORef False <*> newIORef []++    format :: Format     format = evalConfigFormat config -    reportProgress :: IO Bool -> Path -> Progress -> m ()+    reportProgress :: IO Bool -> Path -> Progress -> IO ()     reportProgress timer path progress = do-      r <- liftIO timer-      when r (formatProgress format path progress)--cancelMany :: [Async a] -> IO ()-cancelMany asyncs = do-  mapM_ (killThread . asyncThreadId) asyncs-  mapM_ waitCatch asyncs+      r <- timer+      when r $ do+        format (Format.Progress path progress)  data Item a = Item {-  _itemDescription :: String-, _itemLocation :: Maybe Location-, _itemAction :: a+  itemDescription :: String+, itemLocation :: Maybe Location+, itemAction :: a } deriving Functor -type Job m p a = (p -> m ()) -> m a- type RunningItem m = Item (Path -> m (Seconds, Result))-type RunningTree m = Tree (IO ()) (RunningItem m)+type RunningTree c m = Tree c (RunningItem m) -type RunningItem_ m = (Async (), Item (Job m Progress (Seconds, Result)))+type RunningItem_ m = Item (Job m Progress (Seconds, Result)) type RunningTree_ m = Tree (IO ()) (RunningItem_ m) -data Semaphore = Semaphore {-  semaphoreWait :: IO ()-, semaphoreSignal :: IO ()-}+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 -parallelizeTree :: MonadIO m => Int -> [EvalTree] -> IO [RunningTree_ m]-parallelizeTree n specs = do-  sem <- newQSem n-  mapM (traverse $ parallelizeItem sem) specs+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 -parallelizeItem :: MonadIO m => QSem -> EvalItem -> IO (RunningItem_ m)-parallelizeItem sem EvalItem{..} = do-  (asyncAction, evalAction) <- parallelize (Semaphore (waitQSem sem) (signalQSem sem)) evalItemParallelize (interruptible . evalItemAction)-  return (asyncAction, Item evalItemDescription evalItemLocation evalAction)+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+    addCleanupOn p = addCleanupToItem p loc cleanup -parallelize :: MonadIO m => Semaphore -> Bool -> Job IO p a -> IO (Async (), Job m p (Seconds, a))-parallelize sem isParallelizable-  | isParallelizable = runParallel sem-  | otherwise = runSequentially+forEachLeaf :: (a -> b) -> NonEmpty (Tree () a) -> NonEmpty (Tree () b)+forEachLeaf f = fmap (fmap f) -runSequentially :: MonadIO m => Job IO p a -> IO (Async (), Job m p (Seconds, a))-runSequentially action = do-  mvar <- newEmptyMVar-  (asyncAction, evalAction) <- runParallel (Semaphore (takeMVar mvar) (return ())) action-  return (asyncAction, \ notifyPartial -> liftIO (putMVar mvar ()) >> evalAction notifyPartial)+forLastLeaf :: (a -> a) -> NonEmpty (Tree () a) -> NonEmpty (Tree () a)+forLastLeaf p = go+  where+    go = NonEmpty.reverse . mapHead goNode . NonEmpty.reverse -data Parallel p a = Partial p | Return a+    goNode node = case node of+      Node description xs -> Node description (go xs)+      NodeWithCleanup loc_ () xs -> NodeWithCleanup loc_ () (go xs)+      Leaf item -> Leaf (p item) -runParallel :: forall m p a. MonadIO m => Semaphore -> Job IO p a -> IO (Async (), Job m p (Seconds, a))-runParallel Semaphore{..} action = do-  mvar <- newEmptyMVar-  asyncAction <- async $ E.bracket_ semaphoreWait semaphoreSignal (worker mvar)-  return (asyncAction, eval mvar)+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-    worker mvar = do-      let partialCallback = replaceMVar mvar . Partial-      result <- measure $ action partialCallback-      replaceMVar mvar (Return result)+    hookLoc = snd <$> mCallSite+    hookFailed = case mCallSite of+      Just (name, _) -> Just $ "in " ++ name ++ "-hook:"+      Nothing -> Nothing -    eval :: MVar (Parallel p (Seconds, a)) -> (p -> m ()) -> m (Seconds, a)-    eval mvar notifyPartial = do-      r <- liftIO (takeMVar mvar)-      case r of-        Partial p -> do-          notifyPartial p-          eval mvar notifyPartial-        Return result -> return result+enqueueItems :: MonadIO m => JobQueue -> [EvalTree] -> IO [RunningTree_ m]+enqueueItems queue = mapM (traverse $ enqueueItem queue) -replaceMVar :: MVar a -> a -> IO ()-replaceMVar mvar p = tryTakeMVar mvar >> putMVar mvar p+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 -run :: forall m. MonadIO m => [RunningTree m] -> EvalM m ()-run specs = do-  fastFail <- gets (evalConfigFastFail . stateConfig)-  sequenceActions fastFail (concatMap foldSpec specs)+eval :: [RunningTree () EvalM] -> EvalM ()+eval specs = do+  sequenceActions (concatMap foldSpec specs)   where-    foldSpec :: RunningTree m -> [EvalM m ()]+    foldSpec :: RunningTree () EvalM -> [EvalM ()]     foldSpec = foldTree FoldTree {       onGroupStarted = groupStarted     , onGroupDone = groupDone@@ -219,18 +281,12 @@     , onLeafe = evalItem     } -    runCleanup :: [String] -> IO () -> EvalM m ()-    runCleanup groups action = do-      r <- liftIO $ measure $ safeEvaluate (action >> return (Result "" Success))-      case r of-        (_, Result "" Success) -> return ()-        _ -> reportItem path Nothing (return r)-      where-        path = (groups, "afterAll-hook")+    runCleanup :: Maybe (String, Location) -> [String] -> () -> EvalM ()+    runCleanup _loc _groups = return -    evalItem :: [String] -> RunningItem m -> EvalM m ()+    evalItem :: [String] -> RunningItem EvalM -> EvalM ()     evalItem groups (Item requirement loc action) = do-      reportItem path loc $ lift (action path)+      reportItem path loc $ action path       where         path :: Path         path = (groups, requirement)@@ -238,7 +294,7 @@ data FoldTree c a r = FoldTree {   onGroupStarted :: Path -> r , onGroupDone :: Path -> r-, onCleanup :: [String] -> c -> r+, onCleanup :: Maybe (String, Location) -> [String] -> c -> r , onLeafe :: [String] -> a -> r } @@ -251,27 +307,19 @@         start = onGroupStarted path         children = concatMap (go (group : rGroups)) xs         done =  onGroupDone path-    go rGroups (NodeWithCleanup action xs) = children ++ [cleanup]+    go rGroups (NodeWithCleanup loc action xs) = children ++ [cleanup]       where         children = concatMap (go rGroups) xs-        cleanup = onCleanup (reverse rGroups) action+        cleanup = onCleanup loc (reverse rGroups) action     go rGroups (Leaf a) = [onLeafe (reverse rGroups) a] -sequenceActions :: Monad m => Bool -> [EvalM m ()] -> EvalM m ()-sequenceActions fastFail = go+sequenceActions :: [EvalM ()] -> EvalM ()+sequenceActions = go   where-    go :: Monad m => [EvalM m ()] -> EvalM m ()-    go [] = return ()+    go :: [EvalM ()] -> EvalM ()+    go [] = pass     go (action : actions) = do       action-      hasFailures <- any resultItemIsFailure <$> gets stateResults-      let stopNow = fastFail && hasFailures-      unless stopNow (go actions)--resultItemIsFailure :: (Path, Format.Item) -> Bool-resultItemIsFailure = isFailure . Format.itemResult . snd-  where-    isFailure r = case r of-      Format.Success{} -> False-      Format.Pending{} -> False-      Format.Failure{} -> True+      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
@@ -16,16 +16,16 @@ import           Data.STRef import           Data.Array.ST -shuffleForest :: STRef s StdGen -> [Tree c a] -> ST s [Tree c a]+shuffleForest :: STRef st StdGen -> [Tree c a] -> ST st [Tree c a] shuffleForest ref xs = (shuffle ref xs >>= mapM (shuffleTree ref)) -shuffleTree :: STRef s StdGen -> Tree c a -> ST s (Tree c a)+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 c xs -> NodeWithCleanup c <$> shuffleForest ref xs+  NodeWithCleanup loc c xs -> NodeWithCleanup loc c <$> shuffleForest ref xs   Leaf {} -> return t -shuffle :: STRef s StdGen -> [a] -> ST s [a]+shuffle :: STRef st StdGen -> [a] -> ST st [a] shuffle ref xs = do   arr <- mkArray xs   bounds@(_, n) <- getBounds arr@@ -41,5 +41,5 @@       writeSTRef ref gen       return a -mkArray :: [a] -> ST s (STArray s Int a)+mkArray :: [a] -> ST st (STArray st Int a) mkArray xs = newListArray (1, length xs) xs
src/Test/Hspec/Core/Spec.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} -- |@@ -19,6 +20,10 @@ , 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@@ -29,20 +34,64 @@ , 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  import           Prelude () import           Test.Hspec.Core.Compat -import qualified Control.Exception as E-import           Data.CallStack+import           Control.Monad.Trans.Class (lift)+import           Control.Monad.Trans.Reader (asks)  import           Test.Hspec.Expectations (Expectation) @@ -50,10 +99,13 @@ 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 :: HasCallStack => String -> SpecWith a -> SpecWith a-describe label spec = runIO (runSpecM spec) >>= fromSpecList . return . specGroup label+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@@ -81,6 +133,16 @@ -- > describe "absolute" $ do -- >   it "returns a positive number when given a negative number" $ -- >     absolute (-1) == 1+--+-- @`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] @@ -103,14 +165,14 @@ -- -- Applying `focus` to a spec with focused spec items has no effect. focus :: SpecWith a -> SpecWith a-focus spec = do-  xs <- runIO (runSpecM spec)-  let-    ys-      | any (any itemIsFocused) xs = xs-      | otherwise = bimapForest id (\ item -> item {itemIsFocused = True}) xs-  fromSpecList ys+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@@ -148,13 +210,29 @@ -- >   it "can format text in a way that everyone likes" $ -- >     pending pending :: HasCallStack => Expectation-pending = E.throwIO (Pending location Nothing)+pending = throwIO (Pending location Nothing)  pending_ :: Expectation-pending_ = (E.throwIO (Pending Nothing Nothing))+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 the spec item is pending. pendingWith :: HasCallStack => String -> Expectation-pendingWith = E.throwIO . Pending location . Just+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,49 +1,88 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}---- NOTE: re-exported from Test.Hspec.Core.Spec module Test.Hspec.Core.Spec.Monad (+-- RE-EXPORTED from Test.Hspec.Core.Spec   Spec , SpecWith-, SpecM (..)+, SpecM (SpecM) , runSpecM , fromSpecList , runIO +, mapSpecForest , mapSpecItem , mapSpecItem_ , modifyParams++, modifyConfig+-- END RE-EXPORTED from Test.Hspec.Core.Spec++, Env(..)+, withEnv ) where  import           Prelude () import           Test.Hspec.Core.Compat -import           Control.Arrow-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,@@ -52,13 +91,29 @@ runIO = SpecM . liftIO  mapSpecForest :: ([SpecTree a] -> [SpecTree b]) -> SpecM a r -> SpecM b r-mapSpecForest f (SpecM specs) = SpecM (mapWriterT (fmap (second f)) specs)+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 = mapSpecForest (bimapForest g f)+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
@@ -3,7 +3,6 @@ import           Prelude () import           Test.Hspec.Core.Compat -import           Control.Exception import           Control.Concurrent.Async  import           Test.Hspec.Core.Clock
src/Test/Hspec/Core/Tree.hs view
@@ -4,8 +4,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} --- NOTE: re-exported from Test.Hspec.Core.Spec module Test.Hspec.Core.Tree (+-- RE-EXPORTED from Test.Hspec.Core.Spec   SpecTree , Tree (..) , Item (..)@@ -17,29 +17,39 @@ , filterForest , filterTreeWithLabels , filterForestWithLabels-, pruneTree-, pruneForest+, pruneTree -- unused+, pruneForest -- unused , location+-- END RE-EXPORTED from Test.Hspec.Core.Spec+, callSite+, formatDefaultDescription+, toModuleName++, setItemAnnotation+, getItemAnnotation ) where  import           Prelude () import           Test.Hspec.Core.Compat -import           Data.CallStack-import           Data.Maybe+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 (Show, Eq, Functor, Foldable, Traversable)+  deriving (Eq, Show, Functor, Foldable, Traversable) --- | A tree is used to represent a spec internally.  The tree is parametrize+-- | 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 (ActionWith a) (Item a)+type SpecTree a = Tree (IO ()) (Item a)  bimapForest :: (a -> b) -> (c -> d) -> [Tree a c] -> [Tree b d] bimapForest g f = map (bimapTree g f)@@ -49,7 +59,7 @@   where     go spec = case spec of       Node d xs -> Node d (map go xs)-      NodeWithCleanup cleanup xs -> NodeWithCleanup (g cleanup) (map go xs)+      NodeWithCleanup loc action xs -> NodeWithCleanup loc (g action) (map go xs)       Leaf item -> Leaf (f item)  filterTree :: (a -> Bool) -> Tree c a -> Maybe (Tree c a)@@ -70,7 +80,7 @@ filterTree_ :: [String] -> ([String] -> a -> Bool) -> Tree c a -> Maybe (Tree c a) filterTree_ groups p tree = case tree of   Node group xs -> Just $ Node group $ filterForest_ (groups ++ [group]) p xs-  NodeWithCleanup action xs -> Just $ NodeWithCleanup action $ filterForest_ groups p xs+  NodeWithCleanup loc action xs -> Just $ NodeWithCleanup loc action $ filterForest_ groups p xs   Leaf item -> Leaf <$> guarded (p groups) item  pruneForest :: [Tree c a] -> [Tree c a]@@ -79,7 +89,7 @@ pruneTree :: Tree c a -> Maybe (Tree c a) pruneTree node = case node of   Node group xs -> Node group <$> prune xs-  NodeWithCleanup action xs -> NodeWithCleanup action <$> prune xs+  NodeWithCleanup loc action xs -> NodeWithCleanup loc action <$> prune xs   Leaf{} -> Just node   where     prune = guarded (not . null) . pruneForest@@ -106,37 +116,60 @@   -- parallel with other spec items , itemIsParallelizable :: Maybe Bool -  -- | A flag that indicates whether this spec item is focused.+  -- | 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 :: HasCallStack => String -> [SpecTree a] -> SpecTree a specGroup s = Node msg   where     msg :: HasCallStack => String     msg-      | null s = fromMaybe "(no description given)" defaultDescription+      | null s = maybe "(no description given)" formatDefaultDescription location       | otherwise = s  -- | The @specItem@ function creates a spec item.-specItem :: (HasCallStack, Example a) => String -> a -> SpecTree (Arg a)-specItem s e = Leaf $ Item requirement location Nothing False (safeEvaluateExample e)-  where-    requirement :: HasCallStack => String-    requirement-      | null s = fromMaybe "(unspecified behavior)" defaultDescription-      | 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 :: HasCallStack => Maybe Location-location = case reverse callStack of-  (_, loc) : _ -> Just (Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc))-  _ -> Nothing+location = snd <$> callSite -defaultDescription :: HasCallStack => Maybe String-defaultDescription = case reverse callStack of-  (_, loc) : _ -> Just (srcLocModule loc ++ "[" ++ show (srcLocStartLine loc) ++ ":" ++ show (srcLocStartCol loc) ++ "]")-  _ -> Nothing+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,9 +1,12 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-} -- | Stability: unstable module Test.Hspec.Core.Util ( -- * String functions   pluralize , strip , lineBreaksAt+, stripAnsi  -- * Working with paths , Path@@ -11,18 +14,24 @@ , 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.Core.Compat (showType)+import           Control.Concurrent.Async  -- | -- @pluralize count singular@ pluralizes the given @singular@ word unless given@@ -38,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 than 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]@@ -63,20 +80,45 @@           else s : go (y, ys)  -- |+-- 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@@ -89,10 +131,12 @@       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 =-     pattern `isInfixOf` plain-  || pattern `isInfixOf` formatted+filterPredicate pattern_ path =+     pattern_ `isInfixOf` plain+  || pattern_ `isInfixOf` formatted   where     plain = joinPath path     formatted = formatRequirement path@@ -102,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 ++ "\n" ++ show ioe-  Nothing  -> showType e ++ "\n" ++ 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@@ -132,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
− test/All.hs 
@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -fforce-recomp -F -pgmF hspec-meta-discover -optF --module-name=All #-}
+ 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
@@ -8,12 +8,14 @@ , module Test.Hspec.Core.Compat , module Test.QuickCheck , module System.IO.Silently+, Seconds(..) , sleep , timeout , defaultParams , noOpProgressCallback , captureLines , normalizeSummary+, normalizeTimes  , ignoreExitCode , ignoreUserInterrupt@@ -21,26 +23,38 @@ , throwException_  , withEnvironment+, withTempDirectory , inTempDirectory +, hspecSilent+, hspecResultSilent+, hspecCapture , shouldUseArgs  , removeLocations++, (</>)+, mkLocation+, workaroundForIssue19236++, replace++, red+, green+, colorize ) where  import           Prelude () import           Test.Hspec.Core.Compat -import           Data.List import           Data.Char-import           System.Environment (withArgs, getEnvironment)+import           System.Environment (withArgs, getEnvironment, setEnv, unsetEnv) import           System.Exit-import qualified Control.Exception as E-import           Control.Exception import           System.IO.Silently-import           System.SetEnv+import           System.FilePath import           System.Directory-import           System.IO.Temp+import           System.IO.Temp (withSystemTempDirectory)+import           System.Console.ANSI  import           Test.Hspec.Meta hiding (hspec, hspecResult, pending, pendingWith) import           Test.QuickCheck hiding (Result(..))@@ -48,20 +62,20 @@  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(..))+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) -#if !MIN_VERSION_base(4,7,0)-deriving instance Eq ErrorCall-#endif+import           Data.Orphans () -exceptionEq :: E.SomeException -> E.SomeException -> Bool+exceptionEq :: SomeException -> SomeException -> Bool exceptionEq a b-  | Just ea <- E.fromException a, Just eb <- E.fromException b = ea == (eb :: E.ErrorCall)-  | Just ea <- E.fromException a, Just eb <- E.fromException b = ea == (eb :: E.ArithException)+  | 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@@ -75,16 +89,16 @@   (==) = exceptionEq  throwException :: IO a-throwException = E.throwIO DivideByZero+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_@@ -98,24 +112,59 @@     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 -shouldUseArgs :: HasCallStack => [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)+silentConfig :: H.Config+silentConfig = H.defaultConfig {H.configFormat = Just $ formatterToFormat silent} +hspecSilent :: H.Spec -> IO ()+hspecSilent = H.hspecWith silentConfig++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@@ -134,8 +183,28 @@       forM_ env (unsetEnv . fst)       return env +withTempDirectory :: (FilePath -> IO a) -> IO a+withTempDirectory = withSystemTempDirectory "hspec"+ inTempDirectory :: IO a -> IO a-inTempDirectory action = withSystemTempDirectory "mockery" $ \path -> do+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/Spec.hs view
@@ -1,11 +1,1 @@-module Main where--import           Test.Hspec.Meta-import           System.SetEnv-import qualified All--spec :: Spec-spec = beforeAll_ (setEnv "IGNORE_DOT_HSPEC" "yes" >> unsetEnv "HSPEC_OPTIONS") $ afterAll_ (unsetEnv "IGNORE_DOT_HSPEC") All.spec--main :: IO ()-main = hspec spec+{-# 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/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
@@ -1,11 +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
@@ -1,22 +1,18 @@ {-# LANGUAGE DeriveDataTypeable #-} module Test.Hspec.Core.CompatSpec (spec) where +import           Prelude () import           Helper-import           System.SetEnv-import           Data.Typeable +import           System.Environment+ data SomeType = SomeType-  deriving Typeable  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.Core.CompatSpec.SomeType"    describe "lookupEnv" $ do     it "returns value of specified environment variable" $ do
+ 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
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} module Test.Hspec.Core.Config.OptionsSpec (spec) where  import           Prelude ()@@ -5,8 +6,9 @@  import           System.Exit -import qualified Test.Hspec.Core.Config.Options as Options+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@@ -16,101 +18,202 @@ spec = do   describe "parseOptions" $ do -    let parseOptions = Options.parseOptions defaultConfig "my-spec"+    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")+      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")+      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+      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, output) = parseOptions [] Nothing ["--help"]-          help = lines output+      let Left (code, help) = Options.parseOptions defaultConfig "spec" [] Nothing [] ["--help"]        it "returns ExitSuccess" $ do         code `shouldBe` ExitSuccess        it "prints help" $ do-        help `shouldStartWith` ["Usage: my-spec [OPTION]..."]+        expected <- readFile "help.txt"+        help `shouldBe` expected -    context "with --no-color" $ do-      it "sets configColorMode to ColorNever" $ do-        configColorMode <$> parseOptions [] Nothing ["--no-color"] `shouldBe` Right ColorNever+    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+        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+        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+        configDiff <$> parseOptions [] Nothing [] ["--no-diff"] `shouldBe` Right False -    context "with --out" $ do-      it "sets configOutputFile" $ do-        either (const Nothing) Just . configOutputFile <$> parseOptions [] Nothing ["--out", "foo"] `shouldBe` Right (Just "foo")+    context "with --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")+          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 23+        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)+        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)+        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+        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+        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")+        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")+        fromLeft (parseOptions [("~/.hspec", ["--invalid"])] Nothing [] []) `shouldBe` (ExitFailure 1, "my-spec: unrecognized option `--invalid' in config file ~/.hspec\n")        it "rejects ambiguous options" $ do-        fromLeft (parseOptions [("~/.hspec", ["--fail"])] Nothing []) `shouldBe` (ExitFailure 1,+        fromLeft (parseOptions [("~/.hspec", ["--print"])] Nothing [] []) `shouldBe` (ExitFailure 1,           unlines [-            "my-spec: option `--fail' is ambiguous; could be one of:"-          , "    --fail-on-focused      fail on focused spec items"-          , "    --fail-fast            abort on first failure"-          , "    --failure-report=FILE  read/write a failure report for use with --rerun"+            "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+        configColorMode <$> parseOptions [("~/.hspec", ["--no-color"]), (".hspec", ["--color"])] Nothing [] [] `shouldBe` Right ColorAlways -    context "when given an environment variable" $ do-      it "uses options from environment variable" $ do-        configColorMode <$> parseOptions [] (Just ["--no-color"]) [] `shouldBe` Right ColorNever+    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+        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")+        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
− test/Test/Hspec/Core/Config/UtilSpec.hs 
@@ -1,34 +0,0 @@-module Test.Hspec.Core.Config.UtilSpec (spec) where--import           Helper--import           System.Console.GetOpt--import           Test.Hspec.Core.Config.Util--spec :: Spec-spec = do-  describe "mkUsageInfo" $ do-    it "restricts output size to 80 characters" $ do-      let options = [-              Option "" ["color"] (NoArg ()) (unwords $ replicate 3 "some very long and verbose help text")-            ]-      mkUsageInfo "" options `shouldBe` unlines [-          ""-        , "    --color  some very long and verbose help text some very long and verbose"-        , "             help text some very long and verbose help text"-        ]--    it "condenses help for --no-options" $ do-      let options = [-              Option "" ["color"] (NoArg ()) "some help"-            , Option "" ["no-color"] (NoArg ()) "some other help"-            ]-      mkUsageInfo "" options `shouldBe` unlines [-          ""-        , "    --[no-]color  some help"-        ]--  describe "formatOrList" $ do-    it "formats a list of or-options" $ do-      formatOrList ["foo", "bar", "baz"] `shouldBe` "foo, bar or baz"
test/Test/Hspec/Core/ConfigSpec.hs view
@@ -1,20 +1,32 @@+{-# LANGUAGE CPP #-} module Test.Hspec.Core.ConfigSpec (spec) where +import           Prelude () import           Helper+ import           System.Directory-import           System.FilePath  import           Test.Hspec.Core.Config  spec :: Spec-spec = do-  describe "readConfigFiles" $ around_ inTempDirectory $ around_ (withEnvironment [("HOME", "/foo")]) $ do+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"-      readConfigFiles `shouldReturn` [(name, ["--diff"])]+      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"@@ -31,3 +43,4 @@         dir <- getCurrentDirectory         removeDirectory dir         readConfigFiles `shouldReturn` []+#endif
test/Test/Hspec/Core/Example/LocationSpec.hs view
@@ -3,17 +3,18 @@ {-# 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           Control.Exception  import           Test.Hspec.Core.Example import           Test.Hspec.Core.Example.Location  class SomeClass a where-    someMethod :: a -> IO ()+  someMethod :: a -> IO ()  instance SomeClass () where @@ -33,7 +34,7 @@     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+          let location = Just $ Location file (__LINE__ + 2) 13           Left e <- try $ do             Just n <- return Nothing             return (n :: Int)@@ -42,12 +43,12 @@ #if !MIN_VERSION_base(4,12,0)       context "in Either" $ do         it "extracts Location" $ do-          let location = Just $ Location __FILE__ (__LINE__ + 4) 15+          let location = Just $ Location file (__LINE__ + 4) 15           let             foo :: Either () ()             foo = do               23 <- Right (42 :: Int)-              return ()+              pass           Left e <- try (evaluate foo)           extractLocation e `shouldBe` location #endif@@ -56,11 +57,7 @@       it "extracts Location" $ do         let           location =-#if MIN_VERSION_base(4,9,0)-            Just $ Location __FILE__ (__LINE__ + 4) 34-#else-            Nothing-#endif+            Just $ Location file (succ __LINE__) 34         Left e <- try (evaluate (undefined :: ()))         extractLocation e `shouldBe` location @@ -68,13 +65,13 @@       context "with single-line source span" $ do         it "extracts Location" $ do           let-            location = Just $ Location __FILE__ (__LINE__ + 1) 40+            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+          let location = Just $ Location file (__LINE__ + 1) 36           Left e <- try (evaluate (case Nothing of             Just n -> n :: Int             ))@@ -83,38 +80,63 @@     context "with RecConError" $ do       it "extracts Location" $ do         let-          location = Just $ Location __FILE__ (__LINE__ + 1) 39+          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__ 18 10)+        extractLocation e `shouldBe` Just (Location file 19 10)      context "with AssertionFailed" $ do       it "extracts Location" $ do         let-          location = Just $ Location __FILE__ (__LINE__ + 1) 36+          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 = unlines [+      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)+      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)+      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)+      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)+      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,18 +1,17 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+ module Test.Hspec.Core.ExampleSpec (spec) where +import           Prelude () import           Helper+ import           Mock-import           Control.Exception import           Test.HUnit (assertFailure, assertEqual) -import           Test.Hspec.Core.Example (Result(..), ResultStatus(..)-#if MIN_VERSION_base(4,8,1)-  , Location(..)-#endif-  , FailureReason(..))+import           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@@ -30,8 +29,54 @@ 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@@ -41,23 +86,13 @@       context "when used with `pending`" $ do         it "returns Pending" $ do           result <- safeEvaluateExample (H.pending)-          let location =-#if MIN_VERSION_base(4,8,1)-                Just $ Location __FILE__ (__LINE__ - 3) 42-#else-                Nothing-#endif+          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 =-#if MIN_VERSION_base(4,8,1)-                Just $ Location __FILE__ (__LINE__ - 3) 42-#else-                Nothing-#endif+          let location = mkLocation __FILE__ (pred __LINE__) 42           result `shouldBe` Result "" (Pending location $ Just "foo")    describe "evaluateExample" $ do@@ -141,7 +176,7 @@        it "returns Failure if property does not hold" $ do         Result "" (Failure _ _) <- evaluateExample $ property $ \n -> n /= (n :: Int)-        return ()+        pass        it "shows what falsified it" $ do         Result "" (Failure _ r) <- evaluateExample $ property $ \ (x :: Int) (y :: Int) -> (x == 0 && y == 1) ==> False@@ -196,36 +231,26 @@        context "when used with `pending`" $ do         it "returns Pending" $ do-          let location =-#if MIN_VERSION_base(4,8,1)-                Just $ Location __FILE__ (__LINE__ + 4) 37-#else-                Nothing-#endif+          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-          let location =-#if MIN_VERSION_base(4,8,1)-                Just $ Location __FILE__ (__LINE__ + 4) 39-#else-                Nothing-#endif+          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
@@ -1,9 +1,9 @@ module Test.Hspec.Core.FailureReportSpec (spec) where +import           Prelude () import           Helper  import           System.IO-import qualified Control.Exception as E import           Test.Hspec.Core.FailureReport import           Test.Hspec.Core.Config @@ -11,7 +11,7 @@ spec = do   describe "writeFailureReport" $ do     it "prints a warning on unexpected exceptions" $ do-      r <- hCapture_ [stderr] $ writeFailureReport defaultConfig (E.throw (E.ErrorCall "some error"))+      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
+ 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
@@ -2,18 +2,102 @@ module Test.Hspec.Core.Formatters.DiffSpec (spec) where  import           Prelude ()-import           Test.Hspec.Core.Compat- import           Helper import           Data.Char -import           Test.Hspec.Core.Formatters.Diff+import           Test.Hspec.Core.Formatters.Diff as Diff  dropQuotes :: String -> String-dropQuotes = init . tail+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@@ -28,12 +112,12 @@           let             char = dropQuotes (show [c])             isEscaped = length char > 1-            escape = tail char+            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 (tail $ show ys)+            expected = partition (init $ show xs) ++ [char] ++ sep ++ partition (drop 1 $ show ys)           in isEscaped ==> actual `shouldBe` expected    describe "breakList" $ do
test/Test/Hspec/Core/Formatters/InternalSpec.hs view
@@ -1,26 +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-  describe "overwriteWith" $ do-    context "when old is null" $ do-      it "returns new" $ do-        ("" `overwriteWith` "foo") `shouldBe` "foo"+  forM_ [+      ("extraChunk", extraChunk, Red)+    , ("missingChunk", missingChunk, Green)+    ] $ \ (name, chunk, color) -> do -    context "when old and new have the same length" $ do-      it "overwrites old" $ do-        ("foo" `overwriteWith` "bar") `shouldBe` "\rbar"+    describe name $ do+      it "colorizes chunks" $ do+        capture_ $ runFormatM formatConfig $ do+          chunk "foo"+        `shouldReturn` colorize Foreground color "foo" -    context "when old is shorter than new" $ do-      it "overwrites old" $ do-        ("ba" `overwriteWith` "foo") `shouldBe` "\rfoo"+      context "with an all-spaces chunk" $ do+        it "colorizes background" $ do+          capture_ $ runFormatM formatConfig $ do+            chunk "  "+          `shouldReturn` colorize Background color "  " -    context "when old is longer than new" $ do-      it "overwrites old" $ do-        ("foobar" `overwriteWith` "foo") `shouldBe` "\rfoo   "+      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,314 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-module Test.Hspec.Core.FormattersSpec (spec) where--import           Prelude ()-import           Helper-import           Data.String-import           Control.Monad.IO.Class-import           Control.Monad.Trans.Writer-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-import qualified Test.Hspec.Core.Formatters.Monad as H-import           Test.Hspec.Core.Formatters.Monad hiding (interpretWith)--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-, 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 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"-          ]--    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 \"//\""-            , ""-#if __GLASGOW_HASKELL__ == 800-            , "WARNING:"-            , "  Your version of GHC is affected by https://ghc.haskell.org/trac/ghc/ticket/13285."-            , "  Source locations may not work as expected."-            , ""-            , "  Please consider upgrading GHC!"-            , ""-#endif-            , "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" (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-      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/HooksSpec.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} module Test.Hspec.Core.HooksSpec (spec) where @@ -5,8 +6,6 @@ import           Helper import           Mock -import           Control.Exception- import qualified Test.Hspec.Core.Runner as H import qualified Test.Hspec.Core.Spec as H import           Test.Hspec.Core.Format@@ -17,26 +16,30 @@ evalSpec_ :: H.Spec -> IO () evalSpec_ = void . evalSpec + evalSpec :: H.Spec -> IO [([String], Item)]-evalSpec = fmap normalize . (H.specToEvalForest H.defaultConfig >=> runFormatter config)+evalSpec = fmap normalize . (toEvalForest >=> runFormatter config)   where     config = EvalConfig {-      evalConfigFormat = format+      evalConfigFormat = \ _ -> pass     , evalConfigConcurrentJobs = 1-    , evalConfigFastFail = False-    }-    format = Format {-      formatRun = id-    , formatGroupStarted = \ _ -> return ()-    , formatGroupDone = \ _ -> return ()-    , formatProgress = \ _ _ -> return ()-    , formatItemStarted = \ _ -> return ()-    , formatItemDone = \ _ _ -> return ()+    , evalConfigFailFast = False+    , evalConfigColorMode = ColorEnabled     }     normalize = map $ \ (path, item) -> (pathToList path, normalizeItem item)-    normalizeItem item = item {itemLocation = Nothing, itemDuration = 0}+    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])@@ -143,14 +146,14 @@             n `shouldBe` 23         `shouldReturn` [           item ["foo"] divideByZero-        , item ["bar"] (Pending (Just "exception in beforeAll-hook (see previous failure)"))+        , 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         evalSpec_ $ H.beforeAll (rec "beforeAll" >> return "value") $ do-          return ()+          pass         retrieve `shouldReturn` []    describe "beforeAll_" $ do@@ -234,7 +237,7 @@                 n `shouldBe` 23         `shouldReturn` [           item ["foo"] divideByZero-        , item ["bar"] (Pending (Just "exception in beforeAll-hook (see previous failure)"))+        , item ["bar"] (Pending Nothing $ exceptionIn "beforeAllWith")         ]      context "when used with an empty list of examples" $ do@@ -242,7 +245,7 @@         (rec, retrieve) <- mkAppend         evalSpec_ $ H.beforeAll (return (23 :: Int)) $           H.beforeAllWith (\_ -> rec "beforeAllWith" >> return "value") $ do-            return ()+            pass         retrieve `shouldReturn` []    describe "after" $ do@@ -318,23 +321,23 @@         , "foo"         , "before"         , "bar"-        , "before"         , "from before"         ]      context "when used with an empty list of examples" $ do       it "does not run specified action" $ do         evalSpec $ H.before undefined $ H.afterAll undefined $ do-          return ()+          pass         `shouldReturn` []      context "when action throws an exception" $ do       it "reports a failure" $ do         evalSpec $ H.before (return "from before") $ H.afterAll (\_ -> throwException) $ do           H.it "foo" $ \a -> a `shouldBe` "from before"+          H.it "bar" $ \a -> a `shouldBe` "from before"         `shouldReturn` [           item ["foo"] Success-        , item ["afterAll-hook"] divideByZero+        , item ["bar"] $ divideByZeroIn "afterAll"         ]    describe "afterAll_" $ do@@ -350,7 +353,6 @@         , "foo"         , "before"         , "bar"-        , "before"         , "afterAll_"         ] @@ -370,7 +372,7 @@       it "does not run specified action" $ do         (rec, retrieve) <- mkAppend         evalSpec_ $ H.afterAll_ (rec "afterAll_") $ do-          return ()+          pass         retrieve `shouldReturn` []      context "when action is pending" $ do@@ -378,9 +380,10 @@         evalSpec $ do           H.afterAll_ H.pending $ do             H.it "foo" True+            H.it "bar" True         `shouldReturn` [           item ["foo"] Success-        , item ["afterAll-hook"] (Pending Nothing)+        , item ["bar"] (Pending Nothing Nothing)         ]      context "when action throws an exception" $ do@@ -388,15 +391,16 @@         evalSpec $ do           H.afterAll_ throwException $ do             H.it "foo" True+            H.it "bar" True         `shouldReturn` [           item ["foo"] Success-        , item ["afterAll-hook"] divideByZero+        , item ["bar"] $ divideByZeroIn "afterAll_"         ]      context "when action is successful" $ do-      it "does not report anythig" $ do+      it "does not report anything" $ do         evalSpec $ do-          H.afterAll_ (return ()) $ do+          H.afterAll_ pass $ do             H.it "foo" True         `shouldReturn` [           item ["foo"] Success@@ -498,6 +502,36 @@         , "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@@ -513,24 +547,26 @@         , "2"         , "3"         ]-      mockCounter mock `shouldReturn` 4+      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 ["afterAll-hook"] (Pending (Just "exception in beforeAll-hook (see previous failure)"))+      , 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 ["afterAll-hook"] divideByZero+      , item ["bar"] $ divideByZeroIn "aroundAll_"       ]    describe "aroundAllWith" $ do@@ -547,29 +583,93 @@         , "1"         , "1"         ]-      mockCounter mock `shouldReturn` 4+      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-      , item ["afterAll-hook"] (Pending (Just "exception in beforeAll-hook (see previous failure)"))       ]      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 ["afterAll-hook"] divideByZero+      , 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     divideByZero :: Result-    divideByZero = Failure (Error Nothing $ toException DivideByZero)+    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,239 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-module Test.Hspec.Core.QuickCheckUtilSpec (spec) where--import           Helper--import qualified Test.QuickCheck.Property as QCP--import           Test.Hspec.Core.QuickCheckUtil--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"-              , ""-              , "+++ OK, passed 2 tests."-              , ""-              , "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-          let info = intercalate "\n\n" (replicate 799 "Passed:")-          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/Runner/EvalSpec.hs view
@@ -1,29 +1,75 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} module Test.Hspec.Core.Runner.EvalSpec (spec) where  import           Prelude () import           Helper -import           Test.Hspec.Core.Tree+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 "" [Node "" [Leaf 1, Node "" [Leaf 2, Leaf 3]], Leaf 4]+        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]--  describe "runSequentially" $ do-    it "runs actions sequentially" $ do-      ref <- newIORef []-      (_, actionA) <- runSequentially $ \ _ -> modifyIORef ref (23 :)-      (_, actionB) <- runSequentially $ \ _ -> modifyIORef ref (42 :)-      (_, ()) <- actionB (\_ -> return ())-      readIORef ref `shouldReturn` [42 :: Int]-      (_, ()) <- actionA (\_ -> return ())-      readIORef ref `shouldReturn` [23, 42]
+ 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,39 +1,34 @@+{-# OPTIONS_GHC -fno-warn-deprecations #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}--#if MIN_VERSION_base(4,6,0) && !MIN_VERSION_base(4,7,0)--- Control.Concurrent.QSem is deprecated in base-4.6.0.*-{-# OPTIONS_GHC -fno-warn-deprecations #-}-#endif-+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-} module Test.Hspec.Core.RunnerSpec (spec) where  import           Prelude () import           Helper -import           System.IO (stderr)-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           System.Console.ANSI  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 -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@@ -41,27 +36,42 @@     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 ("--format=silent" : args) . H.hspec-      hspec_ = hspec []+      hspec args = withArgs args . hspecSilent+      hspec_ = hspecSilent      it "evaluates examples Unmasked" $ do       mvar <- newEmptyMVar       hspec_ $ do         H.it "foo" $ do-          E.getMaskingState >>= putMVar mvar-      takeMVar mvar `shouldReturn` E.Unmasked+          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) `E.finally`+            (putMVar mvar () >> threadDelay 10000000) `finally`               writeIORef ref "ran finalizer"       takeMVar mvar       cancel a@@ -110,66 +120,99 @@           ]         } -    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 $ \(name, accessor) -> do-        it ("reuses same " ++ name) $ do-          [name, "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 "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@@ -189,28 +232,22 @@             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/\""-          , ""-#if __GLASGOW_HASKELL__ == 800-          , "WARNING:"-          , "  Your version of GHC is affected by https://ghc.haskell.org/trac/ghc/ticket/13285."-          , "  Source locations may not work as expected."-          , ""-          , "  Please consider upgrading GHC!"+          , "  To rerun use: --match \"/foo/\" --seed 23"           , ""-#endif           , "Randomized with seed 23"           , ""+          , "Finished in 0.0000 seconds"+          , "1 example, 1 failure"           ]        it "throws UserInterrupt" $ do@@ -221,21 +258,21 @@             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+        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"@@ -256,75 +293,119 @@         readIORef ref `shouldReturn` False      context "with --focused-only" $ do-      let run = captureLines . withArgs ["--focused-only"] . H.hspec+      let run = hspecCapture ["--focused-only"]       context "when there aren't any focused spec items" $ do         it "does not run anything" $ do-          r <- run $ do+          run $ do             H.it "foo" True             H.it "bar" True-          normalizeSummary r `shouldBe` [+          `shouldReturn` unlines [               ""             , ""             , "Finished in 0.0000 seconds"             , "0 examples, 0 failures"             ] -    context "with --fail-on-focused" $ do-      let run = captureLines . ignoreExitCode . withArgs ["--fail-on-focused", "--seed", "23"] . H.hspec . removeLocations+    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-        r <- run $ do+        run $ do           H.it "foo" True           H.fit "bar" True-        normalizeSummary r `shouldBe` [+        `shouldReturn` unlines [             ""-          , "bar FAILED [1]"+          , "bar [✘]"           , ""           , "Failures:"           , ""           , "  1) bar"-          , "       item is focused; failing due to --fail-on-focused"+          , "       item is focused; failing due to --fail-on=focused"           , ""-          , "  To rerun use: --match \"/bar/\""+          , "  To rerun use: --match \"/bar/\" --seed 23"           , ""-#if __GLASGOW_HASKELL__ == 800-          , "WARNING:"-          , "  Your version of GHC is affected by https://ghc.haskell.org/trac/ghc/ticket/13285."-          , "  Source locations may not work as expected."+          , "Randomized with seed 23"           , ""-          , "  Please consider upgrading GHC!"+          , "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) [✘]"           , ""-#endif+          , "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"-          , "1 example, 1 failure"+          , "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/\""-          , ""-#if __GLASGOW_HASKELL__ == 800-          , "WARNING:"-          , "  Your version of GHC is affected by https://ghc.haskell.org/trac/ghc/ticket/13285."-          , "  Source locations may not work as expected."-          , ""-          , "  Please consider upgrading GHC!"+          , "  To rerun use: --match \"/bar/\" --seed 23"           , ""-#endif           , "Randomized with seed 23"           , ""           , "Finished in 0.0000 seconds"@@ -344,41 +425,53 @@             H.it "bar" $ do               -- NOTE: waitQSem should never return here, as we want to               -- guarantee that the thread is killed before hspec returns-              (signalQSem child1 >> waitQSem child2 >> writeIORef ref "foo") `E.finally` signalQSem parent+              (signalQSem 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/\""-          , ""-#if __GLASGOW_HASKELL__ == 800-          , "WARNING:"-          , "  Your version of GHC is affected by https://ghc.haskell.org/trac/ghc/ticket/13285."-          , "  Source locations may not work as expected."-          , ""-          , "  Please consider upgrading GHC!"+          , "  To rerun use: --match \"/foo/bar/\" --seed 23"           , ""-#endif           , "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@@ -422,14 +515,151 @@             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: " ++ reset ++ red ++ "42" ++ reset-          , red ++ "        but got: " ++ reset ++ green ++ "23" ++ reset+            red "       expected: " ++ red "42"+          , red "        but got: " ++ green "23"           ]      context "with --no-diff" $ do@@ -438,10 +668,94 @@           H.it "foo" $ do             23 `H.shouldBe` (42 :: Int)         r `shouldContain` unlines [-            red ++ "       expected: " ++ reset ++ "42"-          , red ++ "        but got: " ++ reset ++ "23"+            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@@ -458,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-        hspec ["--qc-max-success", "23"] $ 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"]@@ -513,22 +866,22 @@       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 ("--format=silent" : args) . H.hspecResult-      hspecResult_ = hspecResult []+      hspecResult args = withArgs args . hspecResultSilent+      hspecResult_ = hspecResultSilent      it "returns a summary of the test run" $ do       hspecResult_ $ do@@ -544,18 +897,22 @@         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 <- hspecResult_ $ do         H.it "some example" (H.Result "" $ H.Failure Nothing . H.Reason $ "foobar" ++ undefined)@@ -581,40 +938,90 @@               atomicModifyIORef highRef $ \x -> (max x current, ())             stop = atomicModifyIORef currentRef $ \x -> (pred x, ())         r <- hspecResult ["-j", show j] . H.parallel $ do-          replicateM_ n $ H.it "foo" $ E.bracket_ start stop $ sleep t+          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}-      summary = H.Summary 1 0+      result = SpecResult [] True     context "with --rerun, --rerun-all-on-success, previous failures, on success" $ do       it "returns True" $ do-        H.rerunAll config (Just report) summary `shouldBe` True+        H.rerunAll config (Just report) result `shouldBe` True      context "without --rerun" $ do       it "returns False" $ do-        H.rerunAll config {H.configRerun = False} (Just report) summary `shouldBe` False+        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) summary `shouldBe` False+        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 = []}) summary `shouldBe` False+        H.rerunAll config (Just report {failureReportPaths = []}) result `shouldBe` False      context "without failure report" $ do       it "returns False" $ do-        H.rerunAll config Nothing summary `shouldBe` False+        H.rerunAll config Nothing result `shouldBe` False      context "on failure" $ do       it "returns False" $ do-        H.rerunAll config (Just report) summary {H.summaryFailures = 1} `shouldBe` False-  where-    green  = setSGRCode [SetColor Foreground Dull Green]-    red    = setSGRCode [SetColor Foreground Dull Red]-    reset  = setSGRCode [Reset]+        H.rerunAll config (Just report) result { specResultSuccess = False } `shouldBe` False
test/Test/Hspec/Core/ShuffleSpec.hs view
@@ -32,8 +32,8 @@      it "recurses into NodeWithCleanup" $ do       shuffleForest 1-        [NodeWithCleanup () [NodeWithCleanup () [Leaf 1, Leaf 2, Leaf 3]]] `shouldBe`-        [NodeWithCleanup () [NodeWithCleanup () [Leaf 2, Leaf 3, Leaf 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
test/Test/Hspec/Core/SpecSpec.hs view
@@ -6,18 +6,36 @@  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  extract :: (Item () -> a) -> H.Spec -> IO [Tree () a]-extract f = fmap (H.bimapForest (const ()) f) . runSpecM+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@@ -29,17 +47,12 @@     context "when no description is given" $ do       it "uses a default description" $ do         [Node d _] <- runSpecM (H.describe "" (pure ()))-#if MIN_VERSION_base(4,8,1)-        d `shouldBe` "Test.Hspec.Core.SpecSpec[" ++ show (__LINE__ - 2 :: Int) ++ ":33]"-#else-        d `shouldBe` "(no description given)"-#endif+        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)-      r <- itemExample item defaultParams ($ ()) noOpProgressCallback-      r `shouldBe` Result "" (Pending Nothing Nothing)+      runItem item `shouldReturn` Result "" (Pending Nothing Nothing)    describe "it" $ do     it "takes a description of a desired behavior" $ do@@ -48,33 +61,17 @@      it "takes an example of that behavior" $ do       [Leaf item] <- runSpecM (H.it "whatever" True)-      r <- itemExample item defaultParams ($ ()) noOpProgressCallback-      r `shouldBe` Result "" Success+      runItem item `shouldReturn` Result "" Success      it "adds source locations" $ do       [Leaf item] <- runSpecM (H.it "foo" True)-      let location =-#if MIN_VERSION_base(4,8,1)-            Just $ H.Location __FILE__ (__LINE__ - 3) 32-#else-            Nothing-#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)-#if MIN_VERSION_base(4,8,1)-        itemRequirement item `shouldBe` "Test.Hspec.Core.SpecSpec[" ++ show (__LINE__ - 2 :: Int) ++ ":34]"-#else-        itemRequirement item `shouldBe` "(unspecified behavior)"-#endif-   describe "xit" $ do     it "creates a pending spec item" $ do       [Leaf item] <- runSpecM (H.xit "whatever" True)-      r <- itemExample item defaultParams ($ ()) noOpProgressCallback-      r `shouldBe` Result "" (Pending Nothing Nothing)+      runItem item `shouldReturn` Result "" (Pending Nothing Nothing)    describe "pending" $ do     it "specifies a pending example" $ do
test/Test/Hspec/Core/TimerSpec.hs view
@@ -1,5 +1,6 @@ module Test.Hspec.Core.TimerSpec (spec) where +import           Prelude () import           Helper  -- import           Test.Hspec.Core.Timer@@ -7,7 +8,7 @@ spec :: Spec spec = do   describe "timer action provided by withTimer" $ do-    return () -- this test is fragile, see e.g. https://github.com/hspec/hspec/issues/352+    pass -- this test is fragile, see e.g. https://github.com/hspec/hspec/issues/352  {-     let
+ 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,8 +1,9 @@ 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 @@ -20,12 +21,12 @@    describe "formatException" $ do     it "converts exception to string" $ do-      formatException (E.toException E.DivideByZero) `shouldBe` "ArithException\ndivide by zero"+      formatException (toException DivideByZero) `shouldBe` "ArithException\ndivide by zero"      context "when used with an IOException" $ do       it "includes the IOErrorType" $ do         inTempDirectory $ do-          Left e <- E.try (readFile "foo")+          Left e <- try (readFile "foo")           formatException e `shouldBe` intercalate "\n" [               "IOException of type NoSuchThing"             , "foo: openFile: does not exist (No such file or directory)"@@ -42,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)@@ -49,21 +62,21 @@      it "returns Left on exception" $ do       Left e <- safeTry throwException-      E.fromException e `shouldBe` Just E.DivideByZero+      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@@ -93,7 +106,7 @@     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
− vendor/Control/Concurrent/Async.hs 
@@ -1,870 +0,0 @@-{-# LANGUAGE CPP, MagicHash, UnboxedTuples, RankNTypes,-    ExistentialQuantification #-}-#if __GLASGOW_HASKELL__ >= 701-{-# LANGUAGE Trustworthy #-}-#endif-#if __GLASGOW_HASKELL__ < 710-{-# LANGUAGE DeriveDataTypeable #-}-#endif-{-# OPTIONS -Wall #-}---------------------------------------------------------------------------------- |--- Module      :  Control.Concurrent.Async--- Copyright   :  (c) Simon Marlow 2012--- License     :  BSD3 (see the file LICENSE)------ Maintainer  :  Simon Marlow <marlowsd@gmail.com>--- Stability   :  provisional--- Portability :  non-portable (requires concurrency)------ This module provides a set of operations for running IO operations--- asynchronously and waiting for their results.  It is a thin layer--- over the basic concurrency operations provided by--- "Control.Concurrent".  The main additional functionality it--- provides is the ability to wait for the return value of a thread,--- but the interface also provides some additional safety and--- robustness over using threads and @MVar@ directly.------ The basic type is @'Async' a@, which represents an asynchronous--- @IO@ action that will return a value of type @a@, or die with an--- exception.  An @Async@ corresponds to a thread, and its 'ThreadId'--- can be obtained with 'asyncThreadId', although that should rarely--- be necessary.------ For example, to fetch two web pages at the same time, we could do--- this (assuming a suitable @getURL@ function):------ >    do a1 <- async (getURL url1)--- >       a2 <- async (getURL url2)--- >       page1 <- wait a1--- >       page2 <- wait a2--- >       ...------ where 'async' starts the operation in a separate thread, and--- 'wait' waits for and returns the result.  If the operation--- throws an exception, then that exception is re-thrown by--- 'wait'.  This is one of the ways in which this library--- provides some additional safety: it is harder to accidentally--- forget about exceptions thrown in child threads.------ A slight improvement over the previous example is this:------ >       withAsync (getURL url1) $ \a1 -> do--- >       withAsync (getURL url2) $ \a2 -> do--- >       page1 <- wait a1--- >       page2 <- wait a2--- >       ...------ 'withAsync' is like 'async', except that the 'Async' is--- automatically killed (using 'uninterruptibleCancel') if the--- enclosing IO operation returns before it has completed.  Consider--- the case when the first 'wait' throws an exception; then the second--- 'Async' will be automatically killed rather than being left to run--- in the background, possibly indefinitely.  This is the second way--- that the library provides additional safety: using 'withAsync'--- means we can avoid accidentally leaving threads running.--- Furthermore, 'withAsync' allows a tree of threads to be built, such--- that children are automatically killed if their parents die for any--- reason.------ The pattern of performing two IO actions concurrently and waiting--- for their results is packaged up in a combinator 'concurrently', so--- we can further shorten the above example to:------ >       (page1, page2) <- concurrently (getURL url1) (getURL url2)--- >       ...------ The 'Functor' instance can be used to change the result of an--- 'Async'.  For example:------ > ghci> a <- async (return 3)--- > ghci> wait a--- > 3--- > ghci> wait (fmap (+1) a)--- > 4---------------------------------------------------------------------------------module Control.Concurrent.Async (--    -- * Asynchronous actions-    Async,-    -- ** Spawning-    async, asyncBound, asyncOn, asyncWithUnmask, asyncOnWithUnmask,--    -- ** Spawning with automatic 'cancel'ation-    withAsync, withAsyncBound, withAsyncOn, withAsyncWithUnmask,-    withAsyncOnWithUnmask,--    -- ** Querying 'Async's-    wait, poll, waitCatch, asyncThreadId,-    cancel, uninterruptibleCancel, cancelWith, AsyncCancelled(..),--    -- ** STM operations-    waitSTM, pollSTM, waitCatchSTM,--    -- ** Waiting for multiple 'Async's-    waitAny, waitAnyCatch, waitAnyCancel, waitAnyCatchCancel,-    waitEither, waitEitherCatch, waitEitherCancel, waitEitherCatchCancel,-    waitEither_,-    waitBoth,--    -- ** Waiting for multiple 'Async's in STM-    waitAnySTM, waitAnyCatchSTM,-    waitEitherSTM, waitEitherCatchSTM,-    waitEitherSTM_,-    waitBothSTM,--    -- ** Linking-    link, link2, ExceptionInLinkedThread(..),--    -- * Convenient utilities-    race, race_,-    concurrently, concurrently_,-    mapConcurrently, forConcurrently,-    mapConcurrently_, forConcurrently_,-    replicateConcurrently, replicateConcurrently_,-    Concurrently(..),-    compareAsyncs,--  ) where--import Control.Concurrent.STM-import Control.Exception-import Control.Concurrent-import qualified Data.Foldable as F-#if !MIN_VERSION_base(4,6,0)-import Prelude hiding (catch)-#endif-import Control.Monad-import Control.Applicative-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (Monoid(mempty,mappend))-import Data.Traversable-#endif-#if __GLASGOW_HASKELL__ < 710-import Data.Typeable-#endif-#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,13,0)-import Data.Semigroup (Semigroup((<>)))-#endif--import Data.IORef--import GHC.Exts-import GHC.IO hiding (finally, onException)-import GHC.Conc---- -------------------------------------------------------------------------------- STM Async API----- | An asynchronous action spawned by 'async' or 'withAsync'.--- Asynchronous actions are executed in a separate thread, and--- operations are provided for waiting for asynchronous actions to--- complete and obtaining their results (see e.g. 'wait').----data Async a = Async-  { asyncThreadId :: {-# UNPACK #-} !ThreadId-                  -- ^ Returns the 'ThreadId' of the thread running-                  -- the given 'Async'.-  , _asyncWait    :: STM (Either SomeException a)-  }--instance Eq (Async a) where-  Async a _ == Async b _  =  a == b--instance Ord (Async a) where-  Async a _ `compare` Async b _  =  a `compare` b--instance Functor Async where-  fmap f (Async a w) = Async a (fmap (fmap f) w)---- | Compare two 'Async's that may have different types-compareAsyncs :: Async a -> Async b -> Ordering-compareAsyncs (Async t1 _) (Async t2 _) = compare t1 t2---- | Spawn an asynchronous action in a separate thread.-async :: IO a -> IO (Async a)-async = inline asyncUsing rawForkIO---- | Like 'async' but using 'forkOS' internally.-asyncBound :: IO a -> IO (Async a)-asyncBound = asyncUsing forkOS---- | Like 'async' but using 'forkOn' internally.-asyncOn :: Int -> IO a -> IO (Async a)-asyncOn = asyncUsing . rawForkOn---- | Like 'async' but using 'forkIOWithUnmask' internally.  The child--- thread is passed a function that can be used to unmask asynchronous--- exceptions.-asyncWithUnmask :: ((forall b . IO b -> IO b) -> IO a) -> IO (Async a)-asyncWithUnmask actionWith = asyncUsing rawForkIO (actionWith unsafeUnmask)---- | Like 'asyncOn' but using 'forkOnWithUnmask' internally.  The--- child thread is passed a function that can be used to unmask--- asynchronous exceptions.-asyncOnWithUnmask :: Int -> ((forall b . IO b -> IO b) -> IO a) -> IO (Async a)-asyncOnWithUnmask cpu actionWith =-  asyncUsing (rawForkOn cpu) (actionWith unsafeUnmask)--asyncUsing :: (IO () -> IO ThreadId)-           -> IO a -> IO (Async a)-asyncUsing doFork = \action -> do-   var <- newEmptyTMVarIO-   -- t <- forkFinally action (\r -> atomically $ putTMVar var r)-   -- slightly faster:-   t <- mask $ \restore ->-          doFork $ try (restore action) >>= atomically . putTMVar var-   return (Async t (readTMVar var))---- | Spawn an asynchronous action in a separate thread, and pass its--- @Async@ handle to the supplied function.  When the function returns--- or throws an exception, 'uninterruptibleCancel' is called on the @Async@.------ > withAsync action inner = mask $ \restore -> do--- >   a <- async (restore action)--- >   restore inner `finally` uninterruptibleCancel a------ This is a useful variant of 'async' that ensures an @Async@ is--- never left running unintentionally.------ Note: a reference to the child thread is kept alive until the call--- to `withAsync` returns, so nesting many `withAsync` calls requires--- linear memory.----withAsync :: IO a -> (Async a -> IO b) -> IO b-withAsync = inline withAsyncUsing rawForkIO---- | Like 'withAsync' but uses 'forkOS' internally.-withAsyncBound :: IO a -> (Async a -> IO b) -> IO b-withAsyncBound = withAsyncUsing forkOS---- | Like 'withAsync' but uses 'forkOn' internally.-withAsyncOn :: Int -> IO a -> (Async a -> IO b) -> IO b-withAsyncOn = withAsyncUsing . rawForkOn---- | Like 'withAsync' but uses 'forkIOWithUnmask' internally.  The--- child thread is passed a function that can be used to unmask--- asynchronous exceptions.-withAsyncWithUnmask-  :: ((forall c. IO c -> IO c) -> IO a) -> (Async a -> IO b) -> IO b-withAsyncWithUnmask actionWith =-  withAsyncUsing rawForkIO (actionWith unsafeUnmask)---- | Like 'withAsyncOn' but uses 'forkOnWithUnmask' internally.  The--- child thread is passed a function that can be used to unmask--- asynchronous exceptions-withAsyncOnWithUnmask-  :: Int -> ((forall c. IO c -> IO c) -> IO a) -> (Async a -> IO b) -> IO b-withAsyncOnWithUnmask cpu actionWith =-  withAsyncUsing (rawForkOn cpu) (actionWith unsafeUnmask)--withAsyncUsing :: (IO () -> IO ThreadId)-               -> IO a -> (Async a -> IO b) -> IO b--- The bracket version works, but is slow.  We can do better by--- hand-coding it:-withAsyncUsing doFork = \action inner -> do-  var <- newEmptyTMVarIO-  mask $ \restore -> do-    t <- doFork $ try (restore action) >>= atomically . putTMVar var-    let a = Async t (readTMVar var)-    r <- restore (inner a) `catchAll` \e -> do-      uninterruptibleCancel a-      throwIO e-    uninterruptibleCancel a-    return r---- | Wait for an asynchronous action to complete, and return its--- value.  If the asynchronous action threw an exception, then the--- exception is re-thrown by 'wait'.------ > wait = atomically . waitSTM----{-# INLINE wait #-}-wait :: Async a -> IO a-wait = atomically . waitSTM---- | Wait for an asynchronous action to complete, and return either--- @Left e@ if the action raised an exception @e@, or @Right a@ if it--- returned a value @a@.------ > waitCatch = atomically . waitCatchSTM----{-# INLINE waitCatch #-}-waitCatch :: Async a -> IO (Either SomeException a)-waitCatch = tryAgain . atomically . waitCatchSTM-  where-    -- See: https://github.com/simonmar/async/issues/14-    tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f---- | Check whether an 'Async' has completed yet.  If it has not--- completed yet, then the result is @Nothing@, otherwise the result--- is @Just e@ where @e@ is @Left x@ if the @Async@ raised an--- exception @x@, or @Right a@ if it returned a value @a@.------ > poll = atomically . pollSTM----{-# INLINE poll #-}-poll :: Async a -> IO (Maybe (Either SomeException a))-poll = atomically . pollSTM---- | A version of 'wait' that can be used inside an STM transaction.----waitSTM :: Async a -> STM a-waitSTM a = do-   r <- waitCatchSTM a-   either throwSTM return r---- | A version of 'waitCatch' that can be used inside an STM transaction.----{-# INLINE waitCatchSTM #-}-waitCatchSTM :: Async a -> STM (Either SomeException a)-waitCatchSTM (Async _ w) = w---- | A version of 'poll' that can be used inside an STM transaction.----{-# INLINE pollSTM #-}-pollSTM :: Async a -> STM (Maybe (Either SomeException a))-pollSTM (Async _ w) = (Just <$> w) `orElse` return Nothing---- | Cancel an asynchronous action by throwing the @AsyncCancelled@--- exception to it, and waiting for the `Async` thread to quit.--- Has no effect if the 'Async' has already completed.------ > cancel a = throwTo (asyncThreadId a) AsyncCancelled <* waitCatch a------ Note that 'cancel' will not terminate until the thread the 'Async'--- refers to has terminated. This means that 'cancel' will block for--- as long said thread blocks when receiving an asynchronous exception.------ For example, it could block if:------ * It's executing a foreign call, and thus cannot receive the asynchronous--- exception;--- * It's executing some cleanup handler after having received the exception,--- and the handler is blocking.-{-# INLINE cancel #-}-cancel :: Async a -> IO ()-cancel a@(Async t _) = throwTo t AsyncCancelled <* waitCatch a---- | The exception thrown by `cancel` to terminate a thread.-data AsyncCancelled = AsyncCancelled-  deriving (Show, Eq-#if __GLASGOW_HASKELL__ < 710-    ,Typeable-#endif-    )--instance Exception AsyncCancelled where-#if __GLASGOW_HASKELL__ >= 708-  fromException = asyncExceptionFromException-  toException = asyncExceptionToException-#endif---- | Cancel an asynchronous action------ This is a variant of `cancel`, but it is not interruptible.-{-# INLINE uninterruptibleCancel #-}-uninterruptibleCancel :: Async a -> IO ()-uninterruptibleCancel = uninterruptibleMask_ . cancel---- | Cancel an asynchronous action by throwing the supplied exception--- to it.------ > cancelWith a x = throwTo (asyncThreadId a) x------ The notes about the synchronous nature of 'cancel' also apply to--- 'cancelWith'.-cancelWith :: Exception e => Async a -> e -> IO ()-cancelWith a@(Async t _) e = throwTo t e <* waitCatch a---- | Wait for any of the supplied asynchronous operations to complete.--- The value returned is a pair of the 'Async' that completed, and the--- result that would be returned by 'wait' on that 'Async'.------ If multiple 'Async's complete or have completed, then the value--- returned corresponds to the first completed 'Async' in the list.----{-# INLINE waitAnyCatch #-}-waitAnyCatch :: [Async a] -> IO (Async a, Either SomeException a)-waitAnyCatch = atomically . waitAnyCatchSTM---- | A version of 'waitAnyCatch' that can be used inside an STM transaction.------ @since 2.1.0-waitAnyCatchSTM :: [Async a] -> STM (Async a, Either SomeException a)-waitAnyCatchSTM asyncs =-    foldr orElse retry $-      map (\a -> do r <- waitCatchSTM a; return (a, r)) asyncs---- | Like 'waitAnyCatch', but also cancels the other asynchronous--- operations as soon as one has completed.----waitAnyCatchCancel :: [Async a] -> IO (Async a, Either SomeException a)-waitAnyCatchCancel asyncs =-  waitAnyCatch asyncs `finally` mapM_ cancel asyncs---- | Wait for any of the supplied @Async@s to complete.  If the first--- to complete throws an exception, then that exception is re-thrown--- by 'waitAny'.------ If multiple 'Async's complete or have completed, then the value--- returned corresponds to the first completed 'Async' in the list.----{-# INLINE waitAny #-}-waitAny :: [Async a] -> IO (Async a, a)-waitAny = atomically . waitAnySTM---- | A version of 'waitAny' that can be used inside an STM transaction.------ @since 2.1.0-waitAnySTM :: [Async a] -> STM (Async a, a)-waitAnySTM asyncs =-    foldr orElse retry $-      map (\a -> do r <- waitSTM a; return (a, r)) asyncs---- | Like 'waitAny', but also cancels the other asynchronous--- operations as soon as one has completed.----waitAnyCancel :: [Async a] -> IO (Async a, a)-waitAnyCancel asyncs =-  waitAny asyncs `finally` mapM_ cancel asyncs---- | Wait for the first of two @Async@s to finish.-{-# INLINE waitEitherCatch #-}-waitEitherCatch :: Async a -> Async b-                -> IO (Either (Either SomeException a)-                              (Either SomeException b))-waitEitherCatch left right =-  tryAgain $ atomically (waitEitherCatchSTM left right)-  where-    -- See: https://github.com/simonmar/async/issues/14-    tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f---- | A version of 'waitEitherCatch' that can be used inside an STM transaction.------ @since 2.1.0-waitEitherCatchSTM :: Async a -> Async b-                -> STM (Either (Either SomeException a)-                               (Either SomeException b))-waitEitherCatchSTM left right =-    (Left  <$> waitCatchSTM left)-      `orElse`-    (Right <$> waitCatchSTM right)---- | Like 'waitEitherCatch', but also 'cancel's both @Async@s before--- returning.----waitEitherCatchCancel :: Async a -> Async b-                      -> IO (Either (Either SomeException a)-                                    (Either SomeException b))-waitEitherCatchCancel left right =-  waitEitherCatch left right `finally` (cancel left >> cancel right)---- | Wait for the first of two @Async@s to finish.  If the @Async@--- that finished first raised an exception, then the exception is--- re-thrown by 'waitEither'.----{-# INLINE waitEither #-}-waitEither :: Async a -> Async b -> IO (Either a b)-waitEither left right = atomically (waitEitherSTM left right)---- | A version of 'waitEither' that can be used inside an STM transaction.------ @since 2.1.0-waitEitherSTM :: Async a -> Async b -> STM (Either a b)-waitEitherSTM left right =-    (Left  <$> waitSTM left)-      `orElse`-    (Right <$> waitSTM right)---- | Like 'waitEither', but the result is ignored.----{-# INLINE waitEither_ #-}-waitEither_ :: Async a -> Async b -> IO ()-waitEither_ left right = atomically (waitEitherSTM_ left right)---- | A version of 'waitEither_' that can be used inside an STM transaction.------ @since 2.1.0-waitEitherSTM_:: Async a -> Async b -> STM ()-waitEitherSTM_ left right =-    (void $ waitSTM left)-      `orElse`-    (void $ waitSTM right)---- | Like 'waitEither', but also 'cancel's both @Async@s before--- returning.----waitEitherCancel :: Async a -> Async b -> IO (Either a b)-waitEitherCancel left right =-  waitEither left right `finally` (cancel left >> cancel right)---- | Waits for both @Async@s to finish, but if either of them throws--- an exception before they have both finished, then the exception is--- re-thrown by 'waitBoth'.----{-# INLINE waitBoth #-}-waitBoth :: Async a -> Async b -> IO (a,b)-waitBoth left right = atomically (waitBothSTM left right)---- | A version of 'waitBoth' that can be used inside an STM transaction.------ @since 2.1.0-waitBothSTM :: Async a -> Async b -> STM (a,b)-waitBothSTM left right = do-    a <- waitSTM left-           `orElse`-         (waitSTM right >> retry)-    b <- waitSTM right-    return (a,b)----- -------------------------------------------------------------------------------- Linking threads--data ExceptionInLinkedThread =-  forall a . ExceptionInLinkedThread (Async a) SomeException-#if __GLASGOW_HASKELL__ < 710-  deriving Typeable-#endif--instance Show ExceptionInLinkedThread where-  show (ExceptionInLinkedThread (Async t _) e) =-    "ExceptionInLinkedThread " ++ show t ++ " " ++ show e--instance Exception ExceptionInLinkedThread where-#if __GLASGOW_HASKELL__ >= 708-  fromException = asyncExceptionFromException-  toException = asyncExceptionToException-#endif---- | Link the given @Async@ to the current thread, such that if the--- @Async@ raises an exception, that exception will be re-thrown in--- the current thread, wrapped in 'ExceptionInLinkedThread'.------ 'link' ignores 'AsyncCancelled' exceptions thrown in the other thread,--- so that it's safe to 'cancel' a thread you're linked to.  If you want--- different behaviour, use 'linkOnly'.----link :: Async a -> IO ()-link = linkOnly (not . isCancel)---- | Link the given @Async@ to the current thread, such that if the--- @Async@ raises an exception, that exception will be re-thrown in--- the current thread.  The supplied predicate determines which--- exceptions in the target thread should be propagated to the source--- thread.----linkOnly-  :: (SomeException -> Bool)  -- ^ return 'True' if the exception-                              -- should be propagated, 'False'-                              -- otherwise.-  -> Async a-  -> IO ()-linkOnly shouldThrow a = do-  me <- myThreadId-  void $ forkRepeat $ do-    r <- waitCatch a-    case r of-      Left e | shouldThrow e -> throwTo me (ExceptionInLinkedThread a e)-      _otherwise -> return ()---- | Link two @Async@s together, such that if either raises an--- exception, the same exception is re-thrown in the other @Async@,--- wrapped in 'ExceptionInLinkedThread'.------ 'link2' ignores 'AsyncCancelled' exceptions, so that it's possible--- to 'cancel' either thread without cancelling the other.  If you--- want different behaviour, use 'link2Only'.----link2 :: Async a -> Async b -> IO ()-link2 = link2Only (not . isCancel)--link2Only :: (SomeException -> Bool) -> Async a -> Async b -> IO ()-link2Only shouldThrow left@(Async tl _)  right@(Async tr _) =-  void $ forkRepeat $ do-    r <- waitEitherCatch left right-    case r of-      Left  (Left e) | shouldThrow e ->-        throwTo tr (ExceptionInLinkedThread left e)-      Right (Left e) | shouldThrow e ->-        throwTo tl (ExceptionInLinkedThread right e)-      _ -> return ()--isCancel :: SomeException -> Bool-isCancel e-  | Just AsyncCancelled <- fromException e = True-  | otherwise = False----- --------------------------------------------------------------------------------- | Run two @IO@ actions concurrently, and return the first to--- finish.  The loser of the race is 'cancel'led.------ > race left right =--- >   withAsync left $ \a ->--- >   withAsync right $ \b ->--- >   waitEither a b----race :: IO a -> IO b -> IO (Either a b)---- | Like 'race', but the result is ignored.----race_ :: IO a -> IO b -> IO ()---- | Run two @IO@ actions concurrently, and return both results.  If--- either action throws an exception at any time, then the other--- action is 'cancel'led, and the exception is re-thrown by--- 'concurrently'.------ > concurrently left right =--- >   withAsync left $ \a ->--- >   withAsync right $ \b ->--- >   waitBoth a b-concurrently :: IO a -> IO b -> IO (a,b)--#define USE_ASYNC_VERSIONS 0--#if USE_ASYNC_VERSIONS--race left right =-  withAsync left $ \a ->-  withAsync right $ \b ->-  waitEither a b--race_ left right =-  withAsync left $ \a ->-  withAsync right $ \b ->-  waitEither_ a b--concurrently left right =-  withAsync left $ \a ->-  withAsync right $ \b ->-  waitBoth a b--#else---- MVar versions of race/concurrently--- More ugly than the Async versions, but quite a bit faster.---- race :: IO a -> IO b -> IO (Either a b)-race left right = concurrently' left right collect-  where-    collect m = do-        e <- m-        case e of-            Left ex -> throwIO ex-            Right r -> return r---- race_ :: IO a -> IO b -> IO ()-race_ left right = void $ race left right---- concurrently :: IO a -> IO b -> IO (a,b)-concurrently left right = concurrently' left right (collect [])-  where-    collect [Left a, Right b] _ = return (a,b)-    collect [Right b, Left a] _ = return (a,b)-    collect xs m = do-        e <- m-        case e of-            Left ex -> throwIO ex-            Right r -> collect (r:xs) m--concurrently' :: IO a -> IO b-             -> (IO (Either SomeException (Either a b)) -> IO r)-             -> IO r-concurrently' left right collect = do-    done <- newEmptyMVar-    mask $ \restore -> do-        -- Note: uninterruptibleMask here is because we must not allow-        -- the putMVar in the exception handler to be interrupted,-        -- otherwise the parent thread will deadlock when it waits for-        -- the thread to terminate.-        lid <- forkIO $ uninterruptibleMask_ $-          restore (left >>= putMVar done . Right . Left)-            `catchAll` (putMVar done . Left)-        rid <- forkIO $ uninterruptibleMask_ $-          restore (right >>= putMVar done . Right . Right)-            `catchAll` (putMVar done . Left)--        count <- newIORef (2 :: Int)-        let takeDone = do-                r <- takeMVar done      -- interruptible-                -- Decrement the counter so we know how many takes are left.-                -- Since only the parent thread is calling this, we can-                -- use non-atomic modifications.-                -- NB. do this *after* takeMVar, because takeMVar might be-                -- interrupted.-                modifyIORef count (subtract 1)-                return r--        let tryAgain f = f `catch` \BlockedIndefinitelyOnMVar -> f--            stop = do-                -- kill right before left, to match the semantics of-                -- the version using withAsync. (#27)-                uninterruptibleMask_ $ do-                  count' <- readIORef count-                  -- we only need to use killThread if there are still-                  -- children alive.  Note: forkIO here is because the-                  -- child thread could be in an uninterruptible-                  -- putMVar.-                  when (count' > 0) $-                    void $ forkIO $ do-                      throwTo rid AsyncCancelled-                      throwTo lid AsyncCancelled-                  -- ensure the children are really dead-                  replicateM_ count' (tryAgain $ takeMVar done)--        r <- collect (tryAgain $ takeDone) `onException` stop-        stop-        return r--#endif---- | maps an @IO@-performing function over any @Traversable@ data--- type, performing all the @IO@ actions concurrently, and returning--- the original data structure with the arguments replaced by the--- results.------ If any of the actions throw an exception, then all other actions are--- cancelled and the exception is re-thrown.------ For example, @mapConcurrently@ works with lists:------ > pages <- mapConcurrently getURL ["url1", "url2", "url3"]----mapConcurrently :: Traversable t => (a -> IO b) -> t a -> IO (t b)-mapConcurrently f = runConcurrently . traverse (Concurrently . f)---- | `forConcurrently` is `mapConcurrently` with its arguments flipped------ > pages <- forConcurrently ["url1", "url2", "url3"] $ \url -> getURL url------ @since 2.1.0-forConcurrently :: Traversable t => t a -> (a -> IO b) -> IO (t b)-forConcurrently = flip mapConcurrently---- | `mapConcurrently_` is `mapConcurrently` with the return value discarded,--- just like @mapM_-mapConcurrently_ :: F.Foldable f => (a -> IO b) -> f a -> IO ()-mapConcurrently_ f = runConcurrently . F.foldMap (Concurrently . void . f)---- | `forConcurrently_` is `forConcurrently` with the return value discarded,--- just like @forM_-forConcurrently_ :: F.Foldable f => f a -> (a -> IO b) -> IO ()-forConcurrently_ = flip mapConcurrently_---- | 'concurrently', but ignore the result values------ @since 2.1.1-concurrently_ :: IO a -> IO b -> IO ()-concurrently_ left right = concurrently' left right (collect 0)-  where-    collect 2 _ = return ()-    collect i m = do-        e <- m-        case e of-            Left ex -> throwIO ex-            Right _ -> collect (i + 1 :: Int) m---- | Perform the action in the given number of threads.------ @since 2.1.1-replicateConcurrently :: Int -> IO a -> IO [a]-replicateConcurrently cnt = runConcurrently . sequenceA . replicate cnt . Concurrently---- | Same as 'replicateConcurrently', but ignore the results.------ @since 2.1.1-replicateConcurrently_ :: Int -> IO a -> IO ()-replicateConcurrently_ cnt = runConcurrently . F.fold . replicate cnt . Concurrently . void---- --------------------------------------------------------------------------------- | A value of type @Concurrently a@ is an @IO@ operation that can be--- composed with other @Concurrently@ values, using the @Applicative@--- and @Alternative@ instances.------ Calling @runConcurrently@ on a value of type @Concurrently a@ will--- execute the @IO@ operations it contains concurrently, before--- delivering the result of type @a@.------ For example------ > (page1, page2, page3)--- >     <- runConcurrently $ (,,)--- >     <$> Concurrently (getURL "url1")--- >     <*> Concurrently (getURL "url2")--- >     <*> Concurrently (getURL "url3")----newtype Concurrently a = Concurrently { runConcurrently :: IO a }--instance Functor Concurrently where-  fmap f (Concurrently a) = Concurrently $ f <$> a--instance Applicative Concurrently where-  pure = Concurrently . return-  Concurrently fs <*> Concurrently as =-    Concurrently $ (\(f, a) -> f a) <$> concurrently fs as--instance Alternative Concurrently where-  empty = Concurrently $ forever (threadDelay maxBound)-  Concurrently as <|> Concurrently bs =-    Concurrently $ either id id <$> race as bs--#if MIN_VERSION_base(4,9,0)--- | Only defined by @async@ for @base >= 4.9@------ @since 2.1.0-instance Semigroup a => Semigroup (Concurrently a) where-  (<>) = liftA2 (<>)---- | @since 2.1.0-instance (Semigroup a, Monoid a) => Monoid (Concurrently a) where-  mempty = pure mempty-  mappend = (<>)-#else--- | @since 2.1.0-instance Monoid a => Monoid (Concurrently a) where-  mempty = pure mempty-  mappend = liftA2 mappend-#endif---- -------------------------------------------------------------------------------- | Fork a thread that runs the supplied action, and if it raises an--- exception, re-runs the action.  The thread terminates only when the--- action runs to completion without raising an exception.-forkRepeat :: IO a -> IO ThreadId-forkRepeat action =-  mask $ \restore ->-    let go = do r <- tryAll (restore action)-                case r of-                  Left _ -> go-                  _      -> return ()-    in forkIO go--catchAll :: IO a -> (SomeException -> IO a) -> IO a-catchAll = catch--tryAll :: IO a -> IO (Either SomeException a)-tryAll = try---- A version of forkIO that does not include the outer exception--- handler: saves a bit of time when we will be installing our own--- exception handler.-{-# INLINE rawForkIO #-}-rawForkIO :: IO () -> IO ThreadId-rawForkIO action = IO $ \ s ->-   case (fork# action s) of (# s1, tid #) -> (# s1, ThreadId tid #)--{-# INLINE rawForkOn #-}-rawForkOn :: Int -> IO () -> IO ThreadId-rawForkOn (I# cpu) action = IO $ \ s ->-   case (forkOn# cpu action s) of (# s1, tid #) -> (# s1, ThreadId tid #)
vendor/Data/Algorithm/Diff.hs view
@@ -1,4 +1,9 @@+{-# 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
+ 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
@@ -1,1 +1,7 @@-&version 2.7.10+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/