packages feed

hspec-core 2.9.2 → 2.11.17

raw patch · 85 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
@@ -7,36 +7,53 @@               --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-focused  fail on focused spec items-        --[no-]fail-fast        abort on first failure-        --[no-]randomize        randomize execution order-  -r    --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-        --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)+        --[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 FORMATTER  --format=FORMATTER      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-                --[no-]pretty           try to pretty-print diff values-                --[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)+  -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@@ -46,7 +63,6 @@         --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)-        --seed=N            used seed for QuickCheck properties  OPTIONS FOR SMALLCHECK     --depth=N  maximum depth of generated test values for SmallCheck properties
hspec-core.cabal view
@@ -1,14 +1,14 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.5.+-- 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.9.2+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>@@ -19,7 +19,8 @@ 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. @@ -35,23 +36,29 @@   ghc-options: -Wall -fno-warn-incomplete-uni-patterns   build-depends:       HUnit ==1.6.*-    , QuickCheck >=2.13.1+    , 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@@ -67,6 +74,7 @@       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@@ -74,23 +82,42 @@       Test.Hspec.Core.Config.Options       Test.Hspec.Core.Example       Test.Hspec.Core.Example.Location+      Test.Hspec.Core.Extension.Config.Type       Test.Hspec.Core.FailureReport       Test.Hspec.Core.Formatters.Diff       Test.Hspec.Core.Formatters.Internal+      Test.Hspec.Core.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.QuickCheckUtil+      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-      Text.Show.Unicode       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@@ -106,23 +133,22 @@     , QuickCheck >=2.14     , ansi-terminal >=0.6.2     , array-    , base >=4.5.0.0 && <5+    , base >=4.9.0.0 && <5     , base-orphans-    , call-stack-    , clock >=0.7.1+    , call-stack >=0.2.0+    , containers     , deepseq     , directory     , filepath-    , hspec-expectations ==0.8.2.*-    , hspec-meta ==2.9.0.1+    , 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@@ -132,6 +158,7 @@       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@@ -139,35 +166,47 @@       Test.Hspec.Core.Config.Options       Test.Hspec.Core.Example       Test.Hspec.Core.Example.Location+      Test.Hspec.Core.Extension+      Test.Hspec.Core.Extension.Config+      Test.Hspec.Core.Extension.Config.Type+      Test.Hspec.Core.Extension.Item+      Test.Hspec.Core.Extension.Option+      Test.Hspec.Core.Extension.Spec+      Test.Hspec.Core.Extension.Tree       Test.Hspec.Core.FailureReport       Test.Hspec.Core.Format       Test.Hspec.Core.Formatters       Test.Hspec.Core.Formatters.Diff       Test.Hspec.Core.Formatters.Internal+      Test.Hspec.Core.Formatters.Pretty+      Test.Hspec.Core.Formatters.Pretty.Parser+      Test.Hspec.Core.Formatters.Pretty.Unicode       Test.Hspec.Core.Formatters.V1       Test.Hspec.Core.Formatters.V1.Free+      Test.Hspec.Core.Formatters.V1.Internal       Test.Hspec.Core.Formatters.V1.Monad       Test.Hspec.Core.Formatters.V2       Test.Hspec.Core.Hooks       Test.Hspec.Core.QuickCheck-      Test.Hspec.Core.QuickCheckUtil+      Test.Hspec.Core.QuickCheck.Util       Test.Hspec.Core.Runner       Test.Hspec.Core.Runner.Eval+      Test.Hspec.Core.Runner.JobQueue       Test.Hspec.Core.Runner.PrintSlowSpecItems+      Test.Hspec.Core.Runner.Result       Test.Hspec.Core.Shuffle       Test.Hspec.Core.Spec       Test.Hspec.Core.Spec.Monad       Test.Hspec.Core.Timer       Test.Hspec.Core.Tree       Test.Hspec.Core.Util-      Control.Concurrent.Async       Data.Algorithm.Diff-      Text.Show.Unicode-      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@@ -179,16 +218,36 @@       Test.Hspec.Core.FormatSpec       Test.Hspec.Core.Formatters.DiffSpec       Test.Hspec.Core.Formatters.InternalSpec+      Test.Hspec.Core.Formatters.Pretty.ParserSpec+      Test.Hspec.Core.Formatters.Pretty.UnicodeSpec+      Test.Hspec.Core.Formatters.PrettySpec       Test.Hspec.Core.Formatters.V1Spec       Test.Hspec.Core.Formatters.V2Spec       Test.Hspec.Core.HooksSpec-      Test.Hspec.Core.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/Interpret.hs view
@@ -7,13 +7,12 @@  import           Prelude () import           Test.Hspec.Core.Compat-import           Data.Maybe  import           System.Console.GetOpt (OptDescr, ArgOrder(..), getOpt) import qualified System.Console.GetOpt as GetOpt  import           GetOpt.Declarative.Types-import           GetOpt.Declarative.Util (mkUsageInfo, mapOptDescr)+import           GetOpt.Declarative.Util (mkUsageInfo)  data InvalidArgument = InvalidArgument String String @@ -31,7 +30,7 @@      usage :: String     usage = "Usage: " ++ prog ++ " [OPTION]...\n\n"-      ++ (intercalate "\n" $ map (uncurry mkUsageInfo) documentedOptions)+      ++ intercalate "\n" (map (uncurry mkUsageInfo) documentedOptions)  addHelpFlag :: [(a, [OptDescr a1])] -> [(a, [OptDescr (Maybe a1)])] addHelpFlag opts = case opts of@@ -41,7 +40,7 @@     help = Nothing      noHelp :: [OptDescr a] -> [OptDescr (Maybe a)]-    noHelp = map (mapOptDescr Just)+    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
src/GetOpt/Declarative/Util.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-module GetOpt.Declarative.Util (mkUsageInfo, mapOptDescr) where+module GetOpt.Declarative.Util (mkUsageInfo) where  import           Prelude () import           Test.Hspec.Core.Compat@@ -27,21 +27,7 @@  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+  Option short [optionA] arg help : Option "" [optionB] _ _ : ys | optionB == ("no-" ++ optionA) ->+    Option short ["[no-]" ++ optionA] arg help : condenseNoOptions ys   x : xs -> x : condenseNoOptions xs   [] -> []--mapOptDescr :: (a -> b) -> OptDescr a -> OptDescr b-#if MIN_VERSION_base(4,7,0)-mapOptDescr = fmap-#else-mapOptDescr f opt = case opt of-  Option short long arg help -> Option short long (mapArgDescr f arg) help--mapArgDescr :: (a -> b) -> ArgDescr a -> ArgDescr b-mapArgDescr f arg = case arg of-  NoArg a -> NoArg (f a)-  ReqArg parse name -> ReqArg (fmap f parse) name-  OptArg parse name -> OptArg (fmap f parse) name-#endif
+ 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,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-} module Test.Hspec.Core.Clock (   Seconds(..) , toMilliseconds@@ -9,14 +10,23 @@ , 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, Ord, Num, Fractional, PrintfArg) @@ -27,9 +37,13 @@ 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
@@ -2,8 +2,11 @@ module Test.Hspec.Core.Compat (   module Imports , module Test.Hspec.Core.Compat+, Typeable ) where +import           Control.Exception as Imports+import           Control.Arrow as Imports ((>>>), (&&&), first, second) import           Control.Applicative as Imports import           Control.Monad as Imports hiding (     mapM@@ -14,25 +17,34 @@   , sequence   , sequence_   )+import           Data.Maybe as Imports import           Data.Foldable as Imports+import           GHC.Stack as Imports (HasCallStack, withFrozenCallStack) +import           System.IO+import           System.Exit+import           System.Environment+ #if MIN_VERSION_base(4,11,0)-import           Data.Functor as Imports+import           Data.Functor as Imports ((<&>)) #endif  import           Data.Traversable as Imports-import           Data.Monoid 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-#if MIN_VERSION_base(4,8,0)   , sortOn-#endif   )  import           Prelude as Imports hiding (@@ -56,111 +68,104 @@   , sequence   , sequence_   , sum-#if !MIN_VERSION_base(4,6,0)-  , catch-#endif+  , length+  , null   ) -import           Data.Typeable (Typeable, typeOf, typeRepTyCon)+import           Data.Typeable import           Data.IORef as Imports -#if MIN_VERSION_base(4,6,0)-import           Text.Read as Imports (readMaybe)-import           System.Environment as Imports (lookupEnv)+#if MIN_VERSION_base(4,12,0)+import           GHC.ResponseFile as Imports (unescapeArgs) #else-import           Text.Read-import           System.Environment-import qualified Text.ParserCombinators.ReadP as P+import           Data.Char #endif -#if !MIN_VERSION_base(4,8,0)-import           Data.Ord (comparing)-#endif+import           Text.Read as Imports (readMaybe)+import           System.Environment as Imports (lookupEnv) -import           Data.Typeable (tyConModule, tyConName)++import           Data.Bool as Imports (bool)+ import           Control.Concurrent -#if MIN_VERSION_base(4,9,0)-import           Control.Exception as Imports (interruptible)+#ifndef __MHS__+import           GHC.IO.Exception #else-import           GHC.IO+import           System.IO.Error #endif--#if !MIN_VERSION_base(4,6,0)--- |Strict version of 'modifyIORef'-modifyIORef' :: IORef a -> (a -> a) -> IO ()-modifyIORef' ref f = do-    x <- readIORef ref-    let x' = f x-    x' `seq` writeIORef ref x'--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---- | 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+  ( ioe_type, IOErrorType(..) ) --- | Return the value of the environment variable @var@, or @Nothing@ if--- there is no such value.------ For POSIX users, this is equivalent to 'System.Posix.Env.getEnv'.-lookupEnv :: String -> IO (Maybe String)-lookupEnv k = lookup k `fmap` getEnvironment-#endif+isUnsupportedOperation :: IOError -> Bool+isUnsupportedOperation e = ioe_type e == UnsupportedOperation  showType :: Typeable a => a -> String-showType a = let t = typeRepTyCon (typeOf a) in-  show t--showFullType :: Typeable a => a -> String-showFullType a = let t = typeRepTyCon (typeOf a) in-  tyConModule t ++ "." ++ tyConName t+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,8,0)-sortOn :: Ord b => (a -> b) -> [a] -> [a]-sortOn f =-  map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x))-#endif- #if !MIN_VERSION_base(4,11,0) infixl 1 <&> (<&>) :: Functor f => f a -> (a -> b) -> f b (<&>) = flip (<$>)+#endif++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
@@ -18,8 +18,6 @@ import           Prelude () import           Test.Hspec.Core.Compat -import           Control.Exception-import           Data.Maybe import           System.IO import           System.IO.Error import           System.Exit@@ -30,11 +28,21 @@  import           Test.Hspec.Core.Util import           Test.Hspec.Core.Config.Options-import           Test.Hspec.Core.Config.Definition (Config(..), ColorMode(..), UnicodeMode(..), defaultConfig, filterOr)+import           Test.Hspec.Core.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@@ -43,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@@ -68,7 +76,7 @@ configQuickCheckArgs c = qcArgs   where     qcArgs = (-        maybe id setSeed (configQuickCheckSeed c)+        maybe id setSeed (configSeed c)       . maybe id setMaxShrinks (configQuickCheckMaxShrinks c)       . maybe id setMaxSize (configQuickCheckMaxSize c)       . maybe id setMaxDiscardRatio (configQuickCheckMaxDiscardRatio c)@@ -95,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)@@ -140,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@@ -155,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
@@ -3,32 +3,74 @@   Config(..) , ColorMode(..) , UnicodeMode(..)+, mkDefaultConfig+ , filterOr-, defaultConfig +, setConfigAnnotation+, getConfigAnnotation++, addExtensionOptions+, getExtensionOptions++, getSeed+, getFormatter+ , commandLineOnlyOptions , formatterOptions , smallCheckOptions , quickCheckOptions , runnerOptions +, flag+, option+ #ifdef TEST-, formatOrList+, splitOn #endif ) where  import           Prelude () import           Test.Hspec.Core.Compat -import           Test.Hspec.Core.Example (Params(..), defaultParams)+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 qualified Test.Hspec.Core.Formatters.V1 as V1-import qualified Test.Hspec.Core.Formatters.V2 as V2+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) @@ -39,11 +81,16 @@   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@@ -53,68 +100,104 @@ -- that satisfy the predicate are run. , configFilterPredicate :: Maybe (Path -> Bool) , configSkipPredicate :: Maybe (Path -> Bool)-, configQuickCheckSeed :: Maybe Integer , configQuickCheckMaxSuccess :: Maybe Int , configQuickCheckMaxDiscardRatio :: Maybe Int , configQuickCheckMaxSize :: Maybe Int , configQuickCheckMaxShrinks :: Maybe Int-, configSmallCheckDepth :: Int+, 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-, configAvailableFormatters :: [(String, FormatConfig -> IO Format)]+, configExpertMode :: Bool -- ^ @since 2.11.2+, configAvailableFormatters :: [(String, FormatConfig -> IO Format)] -- ^ @since 2.9.0 , configFormat :: Maybe (FormatConfig -> IO Format)-, configFormatter :: Maybe V1.Formatter -- ^ deprecated, use `configFormat` instead+, 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." #-} -defaultConfig :: Config-defaultConfig = Config {+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-, configQuickCheckSeed = Nothing , configQuickCheckMaxSuccess = Nothing , configQuickCheckMaxDiscardRatio = Nothing , configQuickCheckMaxSize = Nothing , configQuickCheckMaxShrinks = Nothing-, configSmallCheckDepth = paramsSmallCheckDepth defaultParams+, configSmallCheckDepth = Nothing , configColorMode = ColorAuto , configUnicodeMode = UnicodeAuto , configDiff = True+, configDiffContext = Just defaultDiffContext+, configExternalDiff = Nothing , configPrettyPrint = True+, configPrettyPrintFunction = pretty2+, configFormatException = formatExceptionWith show , configTimes = False-, configAvailableFormatters = map (fmap V2.formatterToFormat) [-    ("checks", V2.checks)-  , ("specdoc", V2.specdoc)-  , ("progress", V2.progress)-  , ("failed-examples", V2.failed_examples)-  , ("silent", V2.silent)-  ]+, 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 -mkFlag :: String -> (Bool -> Config -> Config) -> String -> Option Config-mkFlag name setter = option name (Flag setter)+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@@ -125,25 +208,41 @@ undocumented :: Option config -> Option config undocumented opt = opt {optionDocumented = False} -argument :: String -> (String -> Maybe a) -> (a -> Config -> Config) -> OptionSetter Config+argument :: String -> (String -> Maybe a) -> (a -> config -> config) -> OptionSetter config argument name parser setter = Arg name $ \ input c -> flip setter c <$> parser input  formatterOptions :: [(String, FormatConfig -> IO Format)] -> [Option Config] formatterOptions formatters = [-    mkOption "format" (Just 'f') (argument "FORMATTER" readFormatter setFormatter) helpForFormat-  , mkFlag "color" setColor "colorize the output"-  , mkFlag "unicode" setUnicode "output unicode"-  , mkFlag "diff" setDiff "show colorized diffs"-  , mkFlag "pretty" setPretty "try to pretty-print diff values"-  , mkFlag "times" setTimes "report times for individual spec items"+    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@@ -164,14 +263,33 @@     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@@ -185,9 +303,8 @@      parseArg :: String -> Config -> Maybe Config     parseArg input c = case readMaybe input of-      Just 0 -> Just (setter Nothing c)-      Just n -> Just (setter (Just n) c)       Nothing -> Nothing+      mn -> Just (setter (find (> 0) mn) c)  smallCheckOptions :: [Option Config] smallCheckOptions = [@@ -195,7 +312,7 @@   ]  setDepth :: Int -> Config -> Config-setDepth n c = c {configSmallCheckDepth = n}+setDepth n c = c {configSmallCheckDepth = Just n}  quickCheckOptions :: [Option Config] quickCheckOptions = [@@ -203,7 +320,6 @@   , option "qc-max-discard" (argument "N" readMaybe setMaxDiscardRatio) "maximum number of discarded tests per successful test before giving up"   , option "qc-max-size" (argument "N" readMaybe setMaxSize) "size to use for the biggest test cases"   , option "qc-max-shrinks" (argument "N" readMaybe setMaxShrinks) "maximum number of shrinks to perform before giving up (a value of 0 turns shrinking off)"-  , option "seed" (argument "N" readMaybe setSeed) "used seed for QuickCheck properties"      -- for compatibility with test-framework   , undocumented $ option "maximum-generated-tests" (argument "NUMBER" readMaybe setMaxSuccess) "how many automated tests something like QuickCheck should try, by default"@@ -222,21 +338,86 @@ setMaxShrinks n c = c {configQuickCheckMaxShrinks = Just n}  setSeed :: Integer -> Config -> Config-setSeed n c = c {configQuickCheckSeed = Just n}+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 = [-    mkFlag "dry-run" setDryRun "pretend that everything passed; don't verify anything"-  , mkFlag "focused-only" setFocusedOnly "do not run anything, unless there are focused spec items"-  , mkFlag "fail-on-focused" setFailOnFocused "fail on focused spec items"-  , mkFlag "fail-fast" setFailFast "abort on first failure"-  , mkFlag "randomize" setRandomize "randomize execution order"-  , mkOptionNoArg "rerun" (Just 'r') setRerun "rerun all examples that failed in the previous test run (only works in combination with --failure-report or in GHCi)"+    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"-  , mkOptionNoArg "rerun-all-on-success" Nothing setRerunAllOnSuccess "run the whole test suite after a previously failing rerun succeeds for the first time (only works in combination with --rerun)"+  , 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@@ -255,17 +436,32 @@     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 config = config {configRerun = True}-    setRerunAllOnSuccess config = config {configRerunAllOnSuccess = True}+    setRerun :: Bool -> Config -> Config+    setRerun value config = config {configRerun = value}++    setRerunAllOnSuccess :: Bool -> Config -> Config+    setRerunAllOnSuccess value config = config {configRerunAllOnSuccess = value}  commandLineOnlyOptions :: [Option Config] commandLineOnlyOptions = [
src/Test/Hspec/Core/Config/Options.hs view
@@ -11,7 +11,6 @@  import           System.Exit -import           Test.Hspec.Core.Format (Format, FormatConfig) import           Test.Hspec.Core.Config.Definition import qualified GetOpt.Declarative as Declarative import           GetOpt.Declarative.Interpret (parse, interpretOptions, ParseResult(..))@@ -22,18 +21,21 @@ envVarName :: String envVarName = "HSPEC_OPTIONS" -commandLineOptions :: [(String, FormatConfig -> IO Format)] -> [(String, [Declarative.Option Config])]-commandLineOptions formatters =+commandLineOptions :: Config -> [(String, [Declarative.Option Config])]+commandLineOptions config =     ("OPTIONS", commandLineOnlyOptions)-  : otherOptions formatters+  : otherOptions config -otherOptions :: [(String, FormatConfig -> IO Format)] -> [(String, [Declarative.Option Config])]-otherOptions formatters = [+otherOptions :: Config -> [(String, [Declarative.Option Config])]+otherOptions config = [     ("RUNNER OPTIONS", runnerOptions)   , ("FORMATTER OPTIONS", formatterOptions formatters)   , ("OPTIONS FOR QUICKCHECK", quickCheckOptions)   , ("OPTIONS FOR SMALLCHECK", smallCheckOptions)-  ]+  ] ++ extensionOptions+  where+    formatters = configAvailableFormatters config+    extensionOptions = getExtensionOptions config  ignoreConfigFile :: Config -> [String] -> IO Bool ignoreConfigFile config args = do@@ -49,28 +51,18 @@       foldM (parseFileOptions prog) config configFiles   >>= maybe return (parseEnvVarOptions prog) envVar   >>= parseEnvironmentOptions env-  >>= traverseTuple (parseCommandLineOptions prog args)--traverseTuple :: Applicative f => (a -> f b) -> (c, a) -> f (c, b)-#if MIN_VERSION_base(4,7,0)-traverseTuple = traverse-#else-traverseTuple f (c, a) = (,) c <$> f a-#endif+  >>= traverse (parseCommandLineOptions prog args)  parseCommandLineOptions :: String -> [String] -> Config -> Either (ExitCode, String) Config-parseCommandLineOptions prog args config = case Declarative.parseCommandLineOptions (commandLineOptions formatters) prog args config of+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)-  where-    formatters = configAvailableFormatters config  parseEnvironmentOptions :: [(String, String)] -> Config -> Either (ExitCode, String) ([String], Config)-parseEnvironmentOptions env config = case Declarative.parseEnvironmentOptions "HSPEC" env config (concatMap snd $ commandLineOptions formatters) of+parseEnvironmentOptions env config = case Declarative.parseEnvironmentOptions "HSPEC" env config (concatMap snd $ commandLineOptions config) of   (warnings, c) -> Right (map formatWarning warnings, c)   where-    formatters = configAvailableFormatters config     formatWarning (Declarative.InvalidValue name value) = "invalid value `" ++ value ++ "' for environment variable " ++ name  parseFileOptions :: String -> Config -> ConfigFile -> Either (ExitCode, String) Config@@ -87,9 +79,7 @@   Left err -> failure err   where     options :: [Declarative.Option Config]-    options = filter Declarative.optionDocumented $ concatMap snd (otherOptions formatters)--    formatters = configAvailableFormatters config+    options = filter Declarative.optionDocumented $ concatMap snd (otherOptions config)      failure err = Left (ExitFailure 1, prog ++ ": " ++ message)       where
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,6 +21,11 @@ , FailureReason (..) , safeEvaluate , safeEvaluateExample+-- END RE-EXPORTED from Test.Hspec.Core.Spec+, safeEvaluateResultStatus+, exceptionToResultStatus+, toLocation+, hunitFailureToResult ) where  import           Prelude ()@@ -26,121 +33,211 @@  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.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@@ -157,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,23 +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.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@@ -26,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@@ -45,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@@ -82,8 +115,8 @@   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@@ -96,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@@ -114,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,13 +5,24 @@ , 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 (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)@@ -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,10 +1,17 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ExistentialQuantification #-} -- |--- Stability: experimental-module Test.Hspec.Core.Format (+-- 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@@ -19,15 +26,13 @@ import           Prelude () import           Test.Hspec.Core.Compat -import           Control.Exception import           Control.Concurrent-import           Control.Concurrent.Async (async)+import           Control.Concurrent.Async (Async, async) import qualified Control.Concurrent.Async as Async import           Control.Monad.IO.Class -import           Test.Hspec.Core.Spec (Progress, Location(..))-import           Test.Hspec.Core.Example (FailureReason(..))-import           Test.Hspec.Core.Util (Path)+import           Test.Hspec.Core.Example (Progress, Location(..), FailureReason(..))+import           Test.Hspec.Core.Util (Path, formatExceptionWith) import           Test.Hspec.Core.Clock (Seconds(..))  type Format = Event -> IO ()@@ -57,16 +62,44 @@  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-} deriving (Eq, Show)+, 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@@ -91,23 +124,24 @@       event <- takeEvent       format event       case event of-        Done {} -> return ()+        Done {} -> pass         _ -> do           signal Ok           go -  t <- async $ do+  worker <- async $ do     (run go >> signal Ok) `catch` (signal . NotOk)    return $ \ event -> do-    running <- Async.poll t-    case running of-      Just _ -> return ()-      Nothing -> do-        putEvent event-        r <- wait-        case r of-          Ok -> return ()-          NotOk err -> do-            Async.wait t-            throwIO err+    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,2 +1,5 @@-module Test.Hspec.Core.Formatters (module V1) where+{-# 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,46 +1,139 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} module Test.Hspec.Core.Formatters.Diff (   Diff (..)-, recover , diff++, LineDiff(..)+, lineDiff++, splitLines+ #ifdef TEST-, recoverString , partition , breakList #endif ) where  import           Prelude ()-import           Control.Arrow-import           Test.Hspec.Core.Compat hiding (First)+import           Test.Hspec.Core.Compat  import           Data.Char import qualified Data.Algorithm.Diff as Diff-import           Text.Show.Unicode (urecover)  data Diff = First String | Second String | Both String   deriving (Eq, Show) -recover :: Bool -> String -> String -> (String, String)-recover unicode expected actual = case (recoverString unicode expected, recoverString unicode actual) of-  (Just expected_, Just actual_) -> (expected_, actual_)-  _ -> (rec expected, rec actual)+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-    rec = if unicode then urecover else id+    diffs :: [LineDiff]+    diffs = Diff.getGroupedDiff expectedLines actualLines <&> \ case+      Diff.First xs -> LinesFirst xs+      Diff.Second xs -> LinesSecond xs+      Diff.Both xs _ -> LinesBoth xs -recoverString :: Bool -> String -> Maybe String-recoverString unicode input = case readMaybe input of-  Just r | shouldParseBack r -> Just r-  _ -> Nothing+    expectedLines :: [String]+    expectedLines = splitLines expected++    actualLines :: [String]+    actualLines = splitLines actual++singleLineDiffs :: [LineDiff] -> [LineDiff]+singleLineDiffs = go   where-    shouldParseBack = (&&) <$> all isSafe <*> isMultiLine-    isMultiLine = lines >>> length >>> (> 1)-    isSafe c = (unicode || isAscii c) && (not $ isControl c) || c == '\n'+    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 = map (toDiff . fmap concat) $ Diff.getGroupedDiff (partition expected) (partition actual)+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@@ -67,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/Internal.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-} module Test.Hspec.Core.Formatters.Internal (   Formatter(..) , Item(..)@@ -9,6 +10,10 @@ , FormatM , formatterToFormat +, getConfig+, getConfigValue+, FormatConfig(..)+ , getSuccessCount , getPendingCount , getFailCount@@ -35,12 +40,18 @@ , outputUnicode  , useDiff+, diffContext+, externalDiffAction , prettyPrint+, prettyPrintFunction , extraChunk , missingChunk +, unlessExpert+ #ifdef TEST-, overwriteWith+, runFormatM+, splitLines #endif ) where @@ -48,15 +59,14 @@ import           Test.Hspec.Core.Compat  import qualified System.IO as IO-import           System.IO (Handle, stdout)-import           Control.Exception (bracket_)-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           Test.Hspec.Core.Formatters.V1.Monad (FailureRecord(..)) import           Test.Hspec.Core.Format import           Test.Hspec.Core.Clock @@ -83,21 +93,28 @@ , formatterDone :: FormatM () } +data FailureRecord = FailureRecord {+  failureRecordLocation :: Maybe Location+, failureRecordPath     :: Path+, failureRecordMessage  :: FailureReason+}+ formatterToFormat :: Formatter -> FormatConfig -> IO Format-formatterToFormat Formatter{..} config = monadic (runFormatM config) $ \ event -> case event of+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-    clearTransientOutput     case itemResult item of       Success {} -> increaseSuccessCount       Pending {} -> increasePendingCount-      Failure loc err -> addFailMessage (loc <|> itemLocation item) path err+      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@@ -105,15 +122,52 @@  -- | Return `True` if the user requested colorized diffs, `False` otherwise. useDiff :: FormatM Bool-useDiff = getConfig formatConfigUseDiff+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 = getConfig formatConfigPrettyPrint+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 = getConfig formatConfigOutputUnicode+outputUnicode = getConfigValue formatConfigOutputUnicode  -- | The same as `write`, but adds a newline character. writeLine :: String -> FormatM ()@@ -131,12 +185,12 @@ -- | A lifted version of `Control.Monad.Trans.State.gets` gets :: (FormatterState -> a) -> FormatM a gets f = FormatM $ do-  f <$> (get >>= liftIO . readIORef)+  f <$> (ask >>= liftIO . readIORef)  -- | A lifted version of `Control.Monad.Trans.State.modify` modify :: (FormatterState -> FormatterState) -> FormatM () modify f = FormatM $ do-  get >>= liftIO . (`modifyIORef'` f)+  ask >>= liftIO . (`modifyIORef'` f)  data FormatterState = FormatterState {   stateSuccessCount    :: !Int@@ -144,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 = return stdout+-- | @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}@@ -186,49 +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  -- | 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 = getConfig formatConfigExpectedTotalCount--overwriteWith :: String -> String -> String-overwriteWith old new-  | n == 0 = new-  | otherwise = '\r' : new ++ replicate (n - length new) ' '-  where-    n = length old+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@@ -252,33 +331,27 @@ -- | 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-  diff <- getConfig formatConfigUseDiff+  diff <- getConfigValue formatConfigUseDiff   case diff of     True -> extra s     False -> write s@@ -289,7 +362,7 @@ -- | Output given chunk in green. missingChunk :: String -> FormatM () missingChunk s = do-  diff <- getConfig formatConfigUseDiff+  diff <- getConfigValue formatConfigUseDiff   case diff of     True -> missing s     False -> write s@@ -298,9 +371,14 @@     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@@ -310,7 +388,7 @@ 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/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
@@ -1,12 +1,11 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE RecordWildCards #-} -- | -- Stability: deprecated -- -- This module contains formatters that can be used with -- `Test.Hspec.Core.Runner.hspecWith`.-module Test.Hspec.Core.Formatters.V1 (-+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@@ -60,290 +59,4 @@ ) where  import           Prelude ()-import           Test.Hspec.Core.Compat hiding (First)--import           Data.Maybe-import           Test.Hspec.Core.Util-import           Test.Hspec.Core.Clock-import           Test.Hspec.Core.Spec (Location(..))-import           Text.Printf-import           Control.Monad.IO.Class-import           Control.Exception---- We use an explicit import list for "Test.Hspec.Formatters.Internal", to make--- sure, that we only use the public API to implement formatters.------ Everything imported here has to be re-exported, so that users can implement--- their own formatters.-import Test.Hspec.Core.Formatters.V1.Monad (-    Formatter(..)-  , FailureReason(..)-  , FormatM--  , getSuccessCount-  , getPendingCount-  , getFailCount-  , getTotalCount--  , FailureRecord(..)-  , getFailMessages-  , usedSeed--  , getCPUTime-  , getRealTime--  , write-  , writeLine-  , writeTransient--  , withInfoColor-  , withSuccessColor-  , withPendingColor-  , withFailColor--  , useDiff-  , extraChunk-  , missingChunk-  )--import           Test.Hspec.Core.Format (FormatConfig, Format)--import           Test.Hspec.Core.Formatters.Diff-import qualified Test.Hspec.Core.Formatters.V2 as V2-import           Test.Hspec.Core.Formatters.V1.Monad (Item(..), Result(..), Environment(..), interpretWith)--formatterToFormat :: Formatter -> FormatConfig -> IO Format-formatterToFormat = V2.formatterToFormat . legacyFormatterToFormatter--legacyFormatterToFormatter :: Formatter -> V2.Formatter-legacyFormatterToFormatter Formatter{..} = V2.Formatter {-  V2.formatterStarted = interpret headerFormatter-, V2.formatterGroupStarted = interpret . uncurry exampleGroupStarted-, V2.formatterGroupDone = interpret . const exampleGroupDone-, V2.formatterProgress = \ path -> interpret . exampleProgress path-, V2.formatterItemStarted = interpret . exampleStarted-, V2.formatterItemDone = \ path item -> interpret $ do-    case itemResult item of-      Success -> exampleSucceeded path (itemInfo item)-      Pending _ reason -> examplePending path (itemInfo item) reason-      Failure _ reason -> exampleFailed path (itemInfo item) reason-, V2.formatterDone = interpret $ failedFormatter >> footerFormatter-}--interpret :: FormatM a -> V2.FormatM a-interpret = interpretWith Environment {-  environmentGetSuccessCount = V2.getSuccessCount-, environmentGetPendingCount = V2.getPendingCount-, environmentGetFailMessages = V2.getFailMessages-, environmentUsedSeed = V2.usedSeed-, environmentPrintTimes = V2.printTimes-, environmentGetCPUTime = V2.getCPUTime-, environmentGetRealTime = V2.getRealTime-, environmentWrite = V2.write-, environmentWriteTransient = V2.writeTransient-, environmentWithFailColor = V2.withFailColor-, environmentWithSuccessColor = V2.withSuccessColor-, environmentWithPendingColor = V2.withPendingColor-, environmentWithInfoColor = V2.withInfoColor-, environmentUseDiff = V2.useDiff-, environmentExtraChunk = V2.extraChunk-, environmentMissingChunk = V2.missingChunk-, environmentLiftIO = liftIO-}--silent :: Formatter-silent = Formatter {-  headerFormatter     = return ()-, exampleGroupStarted = \_ _ -> return ()-, exampleGroupDone    = return ()-, exampleStarted      = \_ -> return ()-, exampleProgress     = \_ _ -> return ()-, exampleSucceeded    = \ _ _ -> return ()-, exampleFailed       = \_ _ _ -> return ()-, examplePending      = \_ _ _ -> return ()-, failedFormatter     = return ()-, footerFormatter     = return ()-}--checks :: Formatter-checks = specdoc {-  exampleStarted = \(nesting, requirement) -> do-    writeTransient $ indentationFor nesting ++ requirement ++ " [ ]"--, exampleProgress = \(nesting, requirement) p -> do-    writeTransient $ indentationFor nesting ++ requirement ++ " [" ++ (formatProgress p) ++ "]"--, exampleSucceeded = \(nesting, requirement) info -> do-    writeResult nesting requirement info $ withSuccessColor $ write "✔"--, exampleFailed = \(nesting, requirement) info _ -> do-    writeResult nesting requirement info $ withFailColor $ write "✘"--, examplePending = \(nesting, requirement) info reason -> do-    writeResult nesting requirement info $ withPendingColor $ write "‐"--    withPendingColor $ do-      writeLine $ indentationFor ("" : nesting) ++ "# PENDING: " ++ fromMaybe "No reason given" reason-} where-    indentationFor nesting = replicate (length nesting * 2) ' '--    writeResult :: [String] -> String -> String -> FormatM () -> FormatM ()-    writeResult nesting requirement info action = do-      write $ indentationFor nesting ++ requirement ++ " ["-      action-      writeLine "]"-      forM_ (lines info) $ \ s ->-        writeLine $ indentationFor ("" : nesting) ++ s--    formatProgress (current, total)-      | total == 0 = show current-      | otherwise  = show current ++ "/" ++ show total--specdoc :: Formatter-specdoc = silent {--  headerFormatter = do-    writeLine ""--, exampleGroupStarted = \nesting name -> do-    writeLine (indentationFor nesting ++ name)--, exampleProgress = \_ p -> do-    writeTransient (formatProgress p)--, exampleSucceeded = \(nesting, requirement) info -> withSuccessColor $ do-    writeLine $ indentationFor nesting ++ requirement-    forM_ (lines info) $ \ s ->-      writeLine $ indentationFor ("" : nesting) ++ s--, exampleFailed = \(nesting, requirement) info _ -> withFailColor $ do-    n <- getFailCount-    writeLine $ indentationFor nesting ++ requirement ++ " FAILED [" ++ show n ++ "]"-    forM_ (lines info) $ \ s ->-      writeLine $ indentationFor ("" : nesting) ++ s--, examplePending = \(nesting, requirement) info reason -> withPendingColor $ do-    writeLine $ indentationFor nesting ++ requirement-    forM_ (lines info) $ \ s ->-      writeLine $ indentationFor ("" : nesting) ++ s-    writeLine $ indentationFor ("" : nesting) ++ "# PENDING: " ++ fromMaybe "No reason given" reason--, failedFormatter = defaultFailedFormatter--, footerFormatter = defaultFooter-} where-    indentationFor nesting = replicate (length nesting * 2) ' '-    formatProgress (current, total)-      | total == 0 = show current-      | otherwise  = show current ++ "/" ++ show total---progress :: Formatter-progress = silent {-  exampleSucceeded = \_ _ -> withSuccessColor $ write "."-, exampleFailed    = \_ _ _ -> withFailColor    $ write "F"-, examplePending   = \_ _ _ -> withPendingColor $ write "."-, failedFormatter  = defaultFailedFormatter-, footerFormatter  = defaultFooter-}---failed_examples :: Formatter-failed_examples   = silent {-  failedFormatter = defaultFailedFormatter-, footerFormatter = defaultFooter-}--defaultFailedFormatter :: FormatM ()-defaultFailedFormatter = do-  writeLine ""--  failures <- getFailMessages--  unless (null failures) $ do-    writeLine "Failures:"-    writeLine ""--    forM_ (zip [1..] failures) $ \x -> do-      formatFailure x-      writeLine ""--    write "Randomized with seed " >> usedSeed >>= writeLine . show-    writeLine ""-  where-    formatFailure :: (Int, FailureRecord) -> FormatM ()-    formatFailure (n, FailureRecord mLoc path reason) = do-      forM_ mLoc $ \loc -> do-        withInfoColor $ writeLine (formatLoc loc)-      write ("  " ++ show n ++ ") ")-      writeLine (formatRequirement path)-      case reason of-        NoReason -> return ()-        Reason err -> withFailColor $ indent err-        ExpectedButGot preface expected actual -> do-          mapM_ indent preface--          b <- useDiff--          let threshold = 2 :: Seconds--          mchunks <- liftIO $ if b-            then timeout threshold (evaluate $ diff expected actual)-            else return Nothing--          case mchunks of-            Just chunks -> do-              writeDiff chunks extraChunk missingChunk-            Nothing -> do-              writeDiff [First expected, Second actual] write write-          where-            indented output text = case break (== '\n') text of-              (xs, "") -> output xs-              (xs, _ : ys) -> output (xs ++ "\n") >> write (indentation ++ "          ") >> indented output ys--            writeDiff chunks extra missing = do-              withFailColor $ write (indentation ++ "expected: ")-              forM_ chunks $ \ chunk -> case chunk of-                Both a -> indented write a-                First a -> indented extra a-                Second _ -> return ()-              writeLine ""--              withFailColor $ write (indentation ++ " but got: ")-              forM_ chunks $ \ chunk -> case chunk of-                Both a -> indented write a-                First _ -> return ()-                Second a -> indented missing a-              writeLine ""--        Error _ e -> withFailColor . indent $ (("uncaught exception: " ++) . formatException) e--      writeLine ""-      writeLine ("  To rerun use: --match " ++ show (joinPath path))-      where-        indentation = "       "-        indent message = do-          forM_ (lines message) $ \line -> do-            writeLine (indentation ++ line)-        formatLoc (Location file line column) = "  " ++ file ++ ":" ++ show line ++ ":" ++ show column ++ ": "--defaultFooter :: FormatM ()-defaultFooter = do--  writeLine =<< (++)-    <$> (printf "Finished in %1.4f seconds" <$> getRealTime)-    <*> (maybe "" (printf ", used %1.4f seconds of CPU time") <$> getCPUTime)--  fails   <- getFailCount-  pending <- getPendingCount-  total   <- getTotalCount--  let-    output =-         pluralize total   "example"-      ++ ", " ++ pluralize fails "failure"-      ++ if pending == 0 then "" else ", " ++ show pending ++ " pending"-    c | fails /= 0   = withFailColor-      | pending /= 0 = withPendingColor-      | otherwise    = withSuccessColor-  c $ writeLine output+import           Test.Hspec.Core.Formatters.V1.Internal
+ 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
@@ -2,7 +2,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ExistentialQuantification #-} module Test.Hspec.Core.Formatters.V1.Monad (   Formatter(..)@@ -48,7 +47,14 @@  import           Test.Hspec.Core.Formatters.V1.Free import           Test.Hspec.Core.Clock-import           Test.Hspec.Core.Format+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 {
src/Test/Hspec/Core/Formatters/V2.hs view
@@ -1,11 +1,14 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} -- |--- Stability: experimental+-- Stability: unstable ----- This module contains formatters that can be used with--- `Test.Hspec.Core.Runner.hspecWith`.-module Test.Hspec.Core.Formatters.V2 (-+-- 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@@ -21,12 +24,20 @@ -- 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@@ -58,33 +69,37 @@ , outputUnicode  , useDiff+, diffContext+, externalDiffAction , prettyPrint+, prettyPrintFunction , extraChunk , missingChunk +-- ** expert mode+, unlessExpert+ -- ** Helpers , formatLocation-, formatException+, Util.formatException  #ifdef TEST , Chunk(..) , ColorChunk(..)-, indentChunks #endif ) where  import           Prelude ()-import           Test.Hspec.Core.Compat hiding (First)+import           Test.Hspec.Core.Compat+import           System.IO (hFlush, stdout) -import           Data.Char-import           Data.Maybe-import           Test.Hspec.Core.Util+import           Test.Hspec.Core.Util hiding (formatException)+import qualified Test.Hspec.Core.Util as Util import           Test.Hspec.Core.Clock-import           Test.Hspec.Core.Spec (Location(..))+import           Test.Hspec.Core.Example (Location(..), Progress) import           Text.Printf-import           Text.Show.Unicode (ushow)+import           Test.Hspec.Core.Formatters.Pretty.Unicode (ushow) import           Control.Monad.IO.Class-import           Control.Exception  -- We use an explicit import list for "Test.Hspec.Formatters.Monad", to make -- sure, that we only use the public API to implement formatters.@@ -99,6 +114,10 @@   , FormatM   , formatterToFormat +  , getConfig+  , getConfigValue+  , FormatConfig(..)+   , getSuccessCount   , getPendingCount   , getFailCount@@ -125,28 +144,33 @@   , outputUnicode    , useDiff+  , diffContext+  , externalDiffAction   , prettyPrint+  , prettyPrintFunction   , extraChunk   , missingChunk++  , unlessExpert   )  import           Test.Hspec.Core.Formatters.Diff  silent :: Formatter silent = Formatter {-  formatterStarted      = return ()-, formatterGroupStarted = \ _ -> return ()-, formatterGroupDone    = \ _ -> return ()-, formatterProgress     = \ _ _ -> return ()-, formatterItemStarted  = \ _ -> return ()-, formatterItemDone     = \ _ _ -> return ()-, formatterDone         = return ()+  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) ++ "]"+    writeTransient $ indentationFor nesting ++ requirement ++ " [" ++ formatProgress p ++ "]"  , formatterItemStarted = \(nesting, requirement) -> do     writeTransient $ indentationFor nesting ++ requirement ++ " [ ]"@@ -159,10 +183,10 @@       Pending {} -> (withPendingColor, fallback "‐" "-")       Failure {} -> (withFailColor,    fallback "✘" "x")     case itemResult item of-      Success {} -> return ()-      Failure {} -> return ()+      Success {} -> pass+      Failure {} -> pass       Pending _ reason -> withPendingColor $ do-        writeLine $ indentationFor ("" : nesting) ++ "# PENDING: " ++ fromMaybe "No reason given" reason+        indentBy (indentationFor ("" : nesting)) $ "# PENDING: " ++ fromMaybe "No reason given" reason } where     indentationFor nesting = replicate (length nesting * 2) ' ' @@ -172,8 +196,7 @@       write $ indentationFor nesting ++ requirement ++ " ["       withColor $ write symbol       writeLine $ "]" ++ if shouldPrintTimes then times else ""-      forM_ (lines info) $ \ s ->-        writeLine $ indentationFor ("" : nesting) ++ s+      indentBy (indentationFor ("" : nesting)) info       where         dt :: Int         dt = toMilliseconds duration@@ -207,7 +230,7 @@         writeResult nesting requirement duration info       Pending _ reason -> withPendingColor $ do         writeResult nesting requirement duration info-        writeLine $ indentationFor ("" : nesting) ++ "# PENDING: " ++ fromMaybe "No reason given" reason+        indentBy (indentationFor ("" : nesting)) $ "# PENDING: " ++ fromMaybe "No reason given" reason       Failure {} -> withFailColor $ do         n <- getFailCount         writeResult nesting (requirement ++ " FAILED [" ++ show n ++ "]") duration info@@ -219,8 +242,7 @@     writeResult nesting requirement (Seconds duration) info = do       shouldPrintTimes <- printTimes       writeLine $ indentationFor nesting ++ requirement ++ if shouldPrintTimes then times else ""-      forM_ (lines info) $ \ s ->-        writeLine $ indentationFor ("" : nesting) ++ s+      indentBy (indentationFor ("" : nesting)) info       where         dt :: Int         dt = floor (duration * 1000)@@ -235,10 +257,12 @@  progress :: Formatter progress = failed_examples {-  formatterItemDone = \ _ item -> case itemResult item of-    Success{} -> withSuccessColor $ write "."-    Pending{} -> withPendingColor $ write "."-    Failure{} -> withFailColor $ write "F"+  formatterItemDone = \ _ item -> do+    case itemResult item of+      Success{} -> withSuccessColor $ write "."+      Pending{} -> withPendingColor $ write "."+      Failure{} -> withFailColor $ write "F"+    liftIO $ hFlush stdout }  failed_examples :: Formatter@@ -271,14 +295,15 @@       write ("  " ++ show n ++ ") ")       writeLine (formatRequirement path)       case reason of-        NoReason -> return ()+        NoReason -> pass         Reason err -> withFailColor $ indent err+        ColorizedReason err -> indent err         ExpectedButGot preface expected_ actual_ -> do-          pretty <- prettyPrint+          pretty <- prettyPrintFunction           let-            (expected, actual)-              | pretty = recover unicode expected_ actual_-              | otherwise = (expected_, actual_)+            (expected, actual) = case pretty of+              Just f -> f expected_ actual_+              Nothing -> (expected_, actual_)            mapM_ indent preface @@ -286,16 +311,26 @@            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+          mExternalDiff <- externalDiffAction++          case mExternalDiff of+            Just externalDiff -> do+              liftIO $ externalDiff expected actual+             Nothing -> do-              writeDiff [First expected, Second actual] write write+              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@@ -303,70 +338,76 @@             writeChunks :: String -> [Chunk] -> (String -> FormatM ()) -> FormatM ()             writeChunks pre chunks colorize = do               withFailColor $ write (indentation ++ pre)-              forM_ (indentChunks indentation_ chunks) $ \ chunk -> case chunk of-                PlainChunk a -> write a-                ColorChunk a -> colorize a-              writeLine ""+              go pass chunks               where+                indentation_ :: [Char]                 indentation_ = indentation ++ replicate (length pre) ' ' -        Error _ e -> withFailColor . indent $ (("uncaught exception: " ++) . formatException) e+                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 -      writeLine ""+        Error info e -> do+          mapM_ indent info+          formatException <- getConfigValue formatConfigFormatException+          withFailColor . indent $ "uncaught exception: " ++ formatException e -      let path_ = (if unicode then ushow else show) (joinPath path)-      writeLine ("  To rerun use: --match " ++ path_)++      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 message = do-          forM_ (lines message) $ \line -> do-            writeLine (indentation ++ line)+        indent = indentBy indentation -data Chunk = Original String | Modified String+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 :: [Diff] -> [Chunk]-expectedChunks = mapMaybe $ \ chunk -> case chunk of-  Both a -> Just $ Original a-  First a -> Just $ Modified a-  Second _ -> Nothing+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 :: [Diff] -> [Chunk]-actualChunks = mapMaybe $ \ chunk -> case chunk of-  Both a -> Just $ Original a-  First _ -> Nothing-  Second a -> Just $ Modified 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) -indentChunks :: String -> [Chunk] -> [ColorChunk]-indentChunks indentation = concatMap $ \ chunk -> case chunk of-  Original y -> [indentOriginal indentation y]-  Modified y -> indentModified indentation y--indentOriginal :: String -> String -> ColorChunk-indentOriginal indentation = PlainChunk . go-  where-    go text = case break (== '\n') text of-      (xs, _ : ys) -> xs ++ "\n" ++ indentation ++ go ys-      (xs, "") -> xs--indentModified :: String -> String -> [ColorChunk]-indentModified indentation = go-  where-    go text = case text of-      "\n" -> [PlainChunk "\n", ColorChunk indentation]-      '\n' : ys@('\n' : _) -> PlainChunk "\n" : ColorChunk indentation : go ys-      _ -> case break (== '\n') text of-        (xs, _ : ys) -> segment xs ++ PlainChunk ('\n' : indentation) : go ys-        (xs, "") -> segment xs--    segment xs = case span isSpace $ reverse xs of-      ("", "") -> []-      ("", _) -> [ColorChunk xs]-      (_, "") -> [ColorChunk xs]-      (ys, zs) -> [ColorChunk (reverse zs), ColorChunk (reverse ys)]+formatOmittedLines :: Int -> String+formatOmittedLines n = "@@ " <> show n <> " lines omitted @@"  defaultFooter :: FormatM () defaultFooter = do@@ -384,10 +425,12 @@          pluralize total   "example"       ++ ", " ++ pluralize fails "failure"       ++ if pending == 0 then "" else ", " ++ show pending ++ " pending"-    c | fails /= 0   = withFailColor++    color+      | fails /= 0   = withFailColor       | pending /= 0 = withPendingColor       | otherwise    = withSuccessColor-  c $ writeLine output+  color $ writeLine output  formatLocation :: Location -> String formatLocation (Location file line column) = file ++ ":" ++ show line ++ ":" ++ show column ++ ": "
src/Test/Hspec/Core/Hooks.hs view
@@ -1,9 +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@@ -22,15 +29,16 @@  , mapSubject , ignoreSubject++#ifdef TEST+, decompose+#endif ) where  import           Prelude () import           Test.Hspec.Core.Compat-import           Data.CallStack -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@@ -49,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@@ -71,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.@@ -89,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 :: HasCallStack => ActionWith a -> SpecWith a -> SpecWith a-afterAll action spec = runIO (runSpecM spec) >>= fromSpecList . return . NodeWithCleanup location action+afterAll action = aroundAllWith (\ hook a -> hook a >> action a)  -- | Run a custom action after the last spec item. afterAll_ :: HasCallStack => IO () -> SpecWith a -> SpecWith a-afterAll_ action = afterAll (\_ -> action)+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@@ -107,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 ()
src/Test/Hspec/Core/QuickCheck.hs view
@@ -1,18 +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           Prelude () import           Test.Hspec.Core.Compat -import           Test.QuickCheck-import           Test.Hspec.Core.Spec+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@@ -47,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,147 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-module Test.Hspec.Core.QuickCheckUtil where--import           Prelude ()-import           Test.Hspec.Core.Compat--import           Control.Exception-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,34 +1,96 @@+{-# 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@@ -37,35 +99,55 @@ ) 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 (hSupportsANSI) -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.Format (FormatConfig(..))-import qualified Test.Hspec.Core.Formatters.V1 as V1+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.PrintSlowSpecItems-import           Test.Hspec.Core.Runner.Eval+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@@ -79,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. --@@ -141,97 +231,170 @@ -- 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-  let-      seed = (fromJust . configQuickCheckSeed) config-      qcArgs = configQuickCheckArgs config-      !numberOfItems = countSpecItems filteredSpec+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 <- colorOutputSupported (configColorMode config) (hSupportsANSI stdout)+  colorMode <- colorOutputSupported (configColorMode config) (hSupportsANSI stdout)   outputUnicode <- unicodeOutputSupported (configUnicodeMode config) stdout -  results <- withHiddenCursor useColor stdout $ do+  let+    filteredSpec = specToEvalForest seed config spec+    qcArgs = configQuickCheckArgs config+    !numberOfItems = countEvalItems filteredSpec++  when (configFailOnEmpty config && numberOfItems == 0) $ do+    when (countSpecItems spec /= 0) $ do+      die "all spec items have been filtered; failing due to --fail-on=empty"++  concurrentJobs <- maybe getDefaultConcurrentJobs return $ configConcurrentJobs config++  results <- fmap toSpecResult . withHiddenCursor (progressReporting colorMode) stdout $ do     let       formatConfig = FormatConfig {-        formatConfigUseColor = useColor+        formatConfigUseColor = shouldUseColor colorMode+      , formatConfigReportProgress = progressReporting colorMode == ProgressReportingEnabled       , formatConfigOutputUnicode = outputUnicode       , formatConfigUseDiff = configDiff config+      , formatConfigDiffContext = configDiffContext config+      , formatConfigExternalDiff = if configDiff config then ($ configDiffContext config) <$> configExternalDiff config else Nothing       , formatConfigPrettyPrint = configPrettyPrint config+      , formatConfigPrettyPrintFunction = if configPrettyPrint config then Just (configPrettyPrintFunction config outputUnicode) else Nothing+      , formatConfigFormatException = configFormatException config       , formatConfigPrintTimes = configTimes config       , formatConfigHtmlOutput = configHtmlOutput config       , formatConfigPrintCpuTime = configPrintCpuTime config       , formatConfigUsedSeed = seed       , formatConfigExpectedTotalCount = numberOfItems+      , formatConfigExpertMode = configExpertMode config       } -      formatter = fromMaybe (V2.formatterToFormat V2.checks) (configFormat config <|> V1.formatterToFormat <$> configFormatter config)+      formatter :: FormatConfig -> IO Format+      formatter = fromMaybe (V2.formatterToFormat V2.checks) (Config.getFormatter config)      format <- maybe id printSlowSpecItems (configPrintSlowItems config) <$> formatter formatConfig @@ -240,34 +403,63 @@         evalConfigFormat = format       , evalConfigConcurrentJobs = concurrentJobs       , evalConfigFailFast = configFailFast config+      , evalConfigColorMode = bool Eval.ColorDisabled Eval.ColorEnabled (shouldUseColor colorMode)       }     runFormatter evalConfig filteredSpec -  let failures = filter resultItemIsFailure results+  let+    failures :: [Path]+    failures = map resultItemPath $ filter resultItemIsFailure $ specResultItems results -  dumpFailureReport config seed qcArgs (map fst failures)+  dumpFailureReport config seed qcArgs failures -  return Summary {-    summaryExamples = length results-  , summaryFailures = length failures-  }+  return results -specToEvalForest :: Config -> Spec -> IO [EvalTree]-specToEvalForest config spec = do-  let-    seed = (fromJust . configQuickCheckSeed) config-    focusedSpec = focusSpec config (failFocusedItems config spec)+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 ()@@ -285,57 +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) -colorOutputSupported :: ColorMode -> IO Bool -> IO Bool-colorOutputSupported mode isTerminalDevice = case mode of-  ColorAuto  -> (&&) <$> (not <$> noColor) <*> isTerminalDevice-  ColorNever -> return False-  ColorAlways -> return True+data UseColor = ColorDisabled | ColorEnabled ProgressReporting+  deriving (Eq, Show) +data ProgressReporting = ProgressReportingDisabled | ProgressReportingEnabled+  deriving (Eq, Show)++shouldUseColor :: UseColor -> Bool+shouldUseColor c = case c of+  ColorDisabled -> False+  ColorEnabled _ -> True++progressReporting :: UseColor -> ProgressReporting+progressReporting c = case c of+  ColorDisabled -> ProgressReportingDisabled+  ColorEnabled r -> r++colorOutputSupported :: ColorMode -> IO Bool -> IO UseColor+colorOutputSupported mode isTerminalDevice = do+  github <- githubActions+  buildkite <- lookupEnv "BUILDKITE" <&> (== Just "true")+  let+    progress :: ProgressReporting+    progress+      | github || buildkite = ProgressReportingDisabled+      | otherwise = ProgressReportingEnabled++    colorEnabled :: UseColor+    colorEnabled = ColorEnabled progress+  case mode of+    ColorAuto -> bool ColorDisabled colorEnabled . (github ||) <$> colorTerminal+    ColorNever -> return ColorDisabled+    ColorAlways -> return colorEnabled+  where+    githubActions :: IO Bool+    githubActions = lookupEnv "GITHUB_ACTIONS" <&> (== Just "true")++    colorTerminal :: IO Bool+    colorTerminal = (&&) <$> (not <$> noColor) <*> isTerminalDevice++    noColor :: IO Bool+    noColor = lookupEnv "NO_COLOR" <&> (/= Nothing)+ unicodeOutputSupported :: UnicodeMode -> Handle -> IO Bool unicodeOutputSupported mode h = case mode of-  UnicodeAuto -> (== Just "UTF-8") . fmap show <$> hGetEncoding h+  UnicodeAuto -> Compat.unicodeOutputSupported h   UnicodeNever -> return False   UnicodeAlways -> return True -noColor :: IO Bool-noColor = lookupEnv "NO_COLOR" <&> (/= Nothing)--rerunAll :: Config -> Maybe FailureReport -> Summary -> Bool-rerunAll _ Nothing _ = False-rerunAll config (Just oldFailureReport) summary =-     configRerunAllOnSuccess config-  && configRerun config-  && isSuccess summary-  && (not . null) (failureReportPaths oldFailureReport)---- | 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)+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 -countSpecItems :: [EvalTree] -> Int+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,61 +1,60 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE RankNTypes #-}--#if MIN_VERSION_base(4,6,0) && !MIN_VERSION_base(4,7,0)--- Control.Concurrent.QSem is deprecated in base-4.6.0.*-{-# 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.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 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(..)) +import           Test.Hspec.Core.Runner.JobQueue++data Tree c a =+    Node String (NonEmpty (Tree c a))+  | NodeWithCleanup (Maybe (String, Location)) c (NonEmpty (Tree c a))+  | Leaf a+  deriving (Eq, Show, Functor, Foldable, Traversable)+ data EvalConfig = EvalConfig {   evalConfigFormat :: Format , evalConfigConcurrentJobs :: Int , evalConfigFailFast :: Bool+, evalConfigColorMode :: ColorMode } +data ColorMode = ColorDisabled | ColorEnabled+ data Env = Env {   envConfig :: EvalConfig+, envAbort :: IORef Bool , envResults :: IORef [(Path, Format.Item)] } @@ -66,14 +65,21 @@  type EvalM = ReaderT Env IO +abort :: EvalM ()+abort = do+  ref <- asks envAbort+  liftIO $ writeIORef ref True++shouldAbort :: EvalM Bool+shouldAbort = do+  ref <- asks envAbort+  liftIO $ readIORef ref+ addResult :: Path -> Format.Item -> EvalM () addResult path item = do   ref <- asks envResults   liftIO $ modifyIORef ref ((path, item) :) -getResults :: EvalM [(Path, Format.Item)]-getResults = reverse <$> (asks envResults >>= liftIO . readIORef)- reportItem :: Path -> Maybe Location -> EvalM (Seconds, Result)  -> EvalM () reportItem path loc action = do   reportItemStarted path@@ -87,14 +93,30 @@   addResult path item   formatEvent $ Format.ItemDone path item +isFailure :: Result -> Bool+isFailure r = case resultStatus r of+  Success{} -> False+  Pending{} -> False+  Failure{} -> True+ reportResult :: Path -> Maybe Location -> (Seconds, Result) -> EvalM () reportResult path loc (duration, result) = do+  mode <- asks (evalConfigColorMode . envConfig)   case result of     Result info status -> reportItemDone path $ Format.Item loc duration info $ case status of       Success                      -> Format.Success       Pending loc_ reason          -> Format.Pending loc_ reason       Failure loc_ err@(Error _ e) -> Format.Failure (loc_ <|> extractLocation e) err-      Failure loc_ err             -> Format.Failure loc_ err+      Failure loc_ err             -> Format.Failure loc_ $ case mode of+        ColorEnabled -> err+        ColorDisabled -> case err of+          NoReason -> err+          Reason _ -> err+          ExpectedButGot _ _ _ -> err+          ColorizedReason r -> Reason (stripAnsi r)+#if __GLASGOW_HASKELL__ < 900+          Error _ _ -> err+#endif  groupStarted :: Path -> EvalM () groupStarted = formatEvent . Format.GroupStarted@@ -105,115 +127,153 @@ 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  -- | Evaluate all examples of a given spec and produce a report.-runFormatter :: EvalConfig -> [EvalTree] -> IO ([(Path, Format.Item)])+runFormatter :: EvalConfig -> [EvalTree] -> IO [(Path, Format.Item)] runFormatter config specs = do-  ref <- newIORef []+  withJobQueue (evalConfigConcurrentJobs config) $ \ queue -> do+    withTimer 0.05 $ \ timer -> do+      env <- mkEnv+      runningSpecs_ <- enqueueItems queue specs -  let-    start = parallelizeTree (evalConfigConcurrentJobs config) specs-    cancel = cancelMany . concatMap toList . map (fmap fst)+      let+        applyReportProgress :: RunningItem_ IO -> RunningItem IO+        applyReportProgress item = fmap (. reportProgress timer) item -  E.bracket start cancel $ \ runningSpecs -> do-    withTimer 0.05 $ \ timer -> do+        runningSpecs :: [RunningTree () EvalM]+        runningSpecs = applyCleanup abortEarly $ map (fmap applyReportProgress) runningSpecs_ -      format Format.Started-      runReaderT (run $ map (fmap (fmap (. reportProgress timer) . snd)) runningSpecs) (Env config ref) `E.finally` do-        results <- reverse <$> readIORef ref-        format (Format.Done results)+        abortEarly :: Result -> Bool+        abortEarly result = evalConfigFailFast config && isFailure result -      results <- reverse <$> readIORef ref-      return results+        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 -> IO ()     reportProgress timer path progress = do       r <- timer       when r $ do         format (Format.Progress path progress) -cancelMany :: [Async a] -> IO ()-cancelMany asyncs = do-  mapM_ (killThread . asyncThreadId) asyncs-  mapM_ waitCatch asyncs- 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 :: [RunningTree IO] -> EvalM ()-run specs = do-  fastFail <- asks (evalConfigFailFast . envConfig)-  sequenceActions fastFail (concatMap foldSpec specs)+eval :: [RunningTree () EvalM] -> EvalM ()+eval specs = do+  sequenceActions (concatMap foldSpec specs)   where-    foldSpec :: RunningTree IO -> [EvalM ()]+    foldSpec :: RunningTree () EvalM -> [EvalM ()]     foldSpec = foldTree FoldTree {       onGroupStarted = groupStarted     , onGroupDone = groupDone@@ -221,18 +281,12 @@     , onLeafe = evalItem     } -    runCleanup :: Maybe Location -> [String] -> IO () -> EvalM ()-    runCleanup loc groups action = do-      r <- liftIO $ measure $ safeEvaluate (action >> return (Result "" Success))-      case r of-        (_, Result "" Success) -> return ()-        _ -> reportItem path loc (return r)-      where-        path = (groups, "afterAll-hook")+    runCleanup :: Maybe (String, Location) -> [String] -> () -> EvalM ()+    runCleanup _loc _groups = return -    evalItem :: [String] -> RunningItem IO -> EvalM ()+    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)@@ -240,7 +294,7 @@ data FoldTree c a r = FoldTree {   onGroupStarted :: Path -> r , onGroupDone :: Path -> r-, onCleanup :: Maybe Location -> [String] -> c -> r+, onCleanup :: Maybe (String, Location) -> [String] -> c -> r , onLeafe :: [String] -> a -> r } @@ -259,21 +313,13 @@         cleanup = onCleanup loc (reverse rGroups) action     go rGroups (Leaf a) = [onLeafe (reverse rGroups) a] -sequenceActions :: Bool -> [EvalM ()] -> EvalM ()-sequenceActions fastFail = go+sequenceActions :: [EvalM ()] -> EvalM ()+sequenceActions = go   where     go :: [EvalM ()] -> EvalM ()-    go [] = return ()+    go [] = pass     go (action : actions) = do       action-      hasFailures <- any resultItemIsFailure <$> getResults-      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
@@ -7,6 +7,8 @@ import           Prelude () import           Test.Hspec.Core.Compat +import           System.IO (stderr, hPutStrLn)+ import           Test.Hspec.Core.Util import           Test.Hspec.Core.Format @@ -26,9 +28,9 @@     Done items -> do       let xs = slowItems n $ map toSlowItem items       unless (null xs) $ do-        putStrLn "\nSlow spec items:"+        hPutStrLn stderr "\nSlow spec items:"         mapM_ printSlowSpecItem xs-    _ -> return ()+    _ -> pass  toSlowItem :: (Path, Item) -> SlowItem toSlowItem (path, item) = SlowItem (itemLocation item)  path (toMilliseconds $ itemDuration item)@@ -38,4 +40,4 @@  printSlowSpecItem :: SlowItem -> IO () printSlowSpecItem SlowItem{..} = do-  putStrLn $ "  " ++ maybe "" formatLocation location ++ joinPath path ++ " (" ++ show duration ++ "ms)"+  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 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 (Maybe Location) 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 loc cleanup xs -> NodeWithCleanup loc (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)@@ -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@@ -14,14 +17,20 @@ -- * Working with exceptions , safeTry , formatException+, formatExceptionWith ) where  import           Prelude () import           Test.Hspec.Core.Compat hiding (join)  import           Data.Char (isSpace)++#ifndef __MHS__ import           GHC.IO.Exception-import           Control.Exception+#else+import           System.IO.Error+#endif+ import           Control.Concurrent.Async  -- |@@ -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,2 +0,0 @@-{-# OPTIONS -fno-warn-implicit-prelude #-}-{-# OPTIONS_GHC -fforce-recomp -F -pgmF hspec-meta-discover -optF --module-name=All #-}
test/Helper.hs view
@@ -8,6 +8,7 @@ , module Test.Hspec.Core.Compat , module Test.QuickCheck , module System.IO.Silently+, Seconds(..) , sleep , timeout , defaultParams@@ -22,25 +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.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,18 +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) -import           Data.Orphans()+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@@ -73,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_@@ -108,20 +124,47 @@ 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@@ -140,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,14 +1,1 @@-module Main where--import           Prelude ()-import           Helper--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/CompatSpec.hs view
@@ -4,21 +4,15 @@ 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
@@ -7,6 +7,16 @@  spec :: Spec spec = do-  describe "formatOrList" $ do-    it "formats a list of or-options" $ do-      formatOrList ["foo", "bar", "baz"] `shouldBe` "foo, bar or baz"+  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
@@ -43,6 +43,45 @@         expected <- readFile "help.txt"         help `shouldBe` expected +    describe "RUNNER OPTIONS" $ do+      let parseOptions_ args = snd <$> Options.parseOptions defaultConfig "my-spec" [] Nothing [] args++      it "gives HSPEC_FAIL_ON precedence over HSPEC_STRICT" $ do+        (configFailOnFocused &&& configFailOnPending) <$> parseOptions [] Nothing [("HSPEC_STRICT", "no"), ("HSPEC_FAIL_ON", "focused")] []+          `shouldBe` Right (True, False)++      it "gives HSPEC_NO_FAIL_ON precedence over HSPEC_STRICT" $ do+        (configFailOnFocused &&& configFailOnPending) <$> parseOptions [] Nothing [("HSPEC_STRICT", "yes"), ("HSPEC_NO_FAIL_ON", "focused")] []+          `shouldBe` Right (False, True)++      context "with --fail-on-focused" $ do+        it "sets configFailOnFocused to True" $ do+          configFailOnFocused <$> parseOptions_ ["--fail-on-focused"] `shouldBe` Right True++      context "with --fail-on-pending" $ do+        it "sets configFailOnPending to True" $ do+          configFailOnPending <$> parseOptions_ ["--fail-on-pending"] `shouldBe` Right True++      context "with --fail-on" $ do+        it "accepts a list of values" $ do+          let config = parseOptions_ ["--fail-on=focused,pending"]+          configFailOnFocused <$> config `shouldBe` Right True+          configFailOnPending <$> config `shouldBe` Right True++        context "with focused" $ do+          it "sets configFailOnFocused to True" $ do+            configFailOnFocused <$> parseOptions_ ["--fail-on=focused"] `shouldBe` Right True++        context "with pending" $ do+          it "sets configFailOnPending to True" $ do+            configFailOnPending <$> parseOptions_ ["--fail-on=pending"] `shouldBe` Right True++      context "with --no-fail-on" $ do+        it "inverts --fail-on" $ do+          let config = parseOptions_ ["--fail-on=focused,pending", "--no-fail-on=focused,pending"]+          configFailOnFocused <$> config `shouldBe` Right False+          configFailOnPending <$> config `shouldBe` Right False+     context "with --color" $ do       it "sets configColorMode to ColorAlways" $ do         configColorMode <$> parseOptions [] Nothing [] ["--color"] `shouldBe` Right ColorAlways@@ -59,6 +98,29 @@       it "sets configDiff to False" $ do         configDiff <$> parseOptions [] Nothing [] ["--no-diff"] `shouldBe` Right False +    context "with --diff-context" $ do+      it "accepts 0" $ do+        configDiffContext <$> parseOptions [] Nothing [] ["--diff-context=0"] `shouldBe` Right (Just 0)++      it "accepts positive values" $ do+        configDiffContext <$> parseOptions [] Nothing [] ["--diff-context=5"] `shouldBe` Right (Just 5)++      it "rejects invalid values" $ do+          let msg = "my-spec: invalid argument `foo' for `--diff-context'\nTry `my-spec --help' for more information.\n"+          void (parseOptions [] Nothing [] ["--diff-context=foo"]) `shouldBe` Left (ExitFailure 1, msg)++      context "with negative values" $ do+        it "disables the option" $ do+          configDiffContext <$> parseOptions [] Nothing [] ["--diff-context=-1"] `shouldBe` Right Nothing++      context "with 'full'" $ do+        it "disables the option" $ do+          configDiffContext <$> parseOptions [] Nothing [] ["--diff-context=full"] `shouldBe` Right Nothing++    context "with --diff-command=" $ do+      it "sets configExternalDiff to Nothing" $ do+        fmap (const ()) . configExternalDiff <$> parseOptions [] Nothing [] ["--diff-command="] `shouldBe` Right Nothing+     context "with --print-slow-items" $ do       it "sets configPrintSlowItems to N" $ do         configPrintSlowItems <$> parseOptions [] Nothing [] ["--print-slow-items=5"] `shouldBe` Right (Just 5)@@ -74,6 +136,10 @@         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@@ -88,7 +154,7 @@      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@@ -112,12 +178,11 @@         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"           ]           )
test/Test/Hspec/Core/ConfigSpec.hs view
@@ -1,10 +1,10 @@+{-# LANGUAGE CPP #-} module Test.Hspec.Core.ConfigSpec (spec) where  import           Prelude () import           Helper  import           System.Directory-import           System.FilePath  import           Test.Hspec.Core.Config @@ -23,9 +23,10 @@     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"@@ -42,3 +43,4 @@         dir <- getCurrentDirectory         removeDirectory dir         readConfigFiles `shouldReturn` []+#endif
test/Test/Hspec/Core/Example/LocationSpec.hs view
@@ -10,13 +10,11 @@ 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 @@ -36,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)@@ -45,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@@ -59,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 @@ -71,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             ))@@ -86,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__ 21 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,20 +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@@ -32,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@@ -43,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@@ -143,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@@ -198,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
@@ -4,7 +4,6 @@ import           Helper  import           System.IO-import qualified Control.Exception as E import           Test.Hspec.Core.FailureReport import           Test.Hspec.Core.Config @@ -12,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
@@ -3,8 +3,6 @@ import           Prelude () import           Helper -import           Control.Exception- import           Test.Hspec.Core.Format  spec :: Spec
test/Test/Hspec/Core/Formatters/DiffSpec.hs view
@@ -2,44 +2,102 @@ module Test.Hspec.Core.Formatters.DiffSpec (spec) where  import           Prelude ()-import           Helper hiding (First)+import           Helper import           Data.Char  import           Test.Hspec.Core.Formatters.Diff as Diff  dropQuotes :: String -> String-dropQuotes = init . tail+dropQuotes = init . drop 1  spec :: Spec spec = do-  describe "recover" $ do-    context "with single-line string literals" $ do-      context "with --unicode" $ do-        it "recovers unicode" $ do-          recover True (show "foo\955bar") (show "foo-bar") `shouldBe` ("\"foo\955bar\"", "\"foo-bar\"")+  describe "lineDiff" $ do+    let+      enumerate name n = map ((name ++) . show) [1 .. n :: Int]+      diff_ expected actual = lineDiff (Just 2) (unlines expected) (unlines actual) -      context "with --no-unicode" $ do-        it "does not recover unicode" $ do-          recover False (show "foo\955bar") (show "foo-bar") `shouldBe` ("\"foo\\955bar\"", "\"foo-bar\"")+    it "suppresses excessive diff output" $ do+      let+        expected = enumerate "foo" 99+        actual = replace "foo50" "bar50" expected -  describe "recoverString" $ do-    it "parses back multi-line string literals" $ do-      recoverString True (show "foo\nbar\nbaz\n") `shouldBe` Just "foo\nbar\nbaz\n"+      diff_ expected actual `shouldBe` [+          LinesOmitted 47+        , LinesBoth [+            "foo48"+          , "foo49"+          ]+        , SingleLineDiff [First "foo50", Second "bar50"]+        , LinesBoth [+            "foo51"+          , "foo52"+          ]+        , LinesOmitted 47+        , LinesBoth [""]+        ] -    it "does not parse back string literals that contain control characters" $ do-      recoverString True (show "foo\n\tbar\nbaz\n") `shouldBe` Nothing+    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) -    it "does not parse back string literals that span a single line" $ do-      recoverString True (show "foo\n") `shouldBe` Nothing+    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 -    context "when unicode is True" $ do-      it "parses back string literals that contain unicode" $ do-        recoverString True (show "foo\n\955\nbaz\n") `shouldBe` Just "foo\n\955\nbaz\n"+          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 "when unicode is False" $ do-      it "does not parse back string literals that contain unicode" $ do-        recoverString False (show "foo\n\955\nbaz\n") `shouldBe` Nothing+    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@@ -54,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
@@ -1,17 +1,17 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-} module Test.Hspec.Core.Formatters.V1Spec (spec) where  import           Prelude ()-import           Helper+import           Helper hiding (colorize) import           Data.String import           Control.Monad.IO.Class-import           Control.Monad.Trans.Writer-import qualified Control.Exception as E+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+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(..)) @@ -192,7 +192,7 @@           H.describe "foo" $ do             H.it "example 1" True           H.describe "bar" $ do-            return ()+            pass           H.describe "baz" $ do             H.it "example 2" True @@ -283,7 +283,7 @@      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)+        H.it "foobar" (throw (ErrorCall "baz") :: Bool)       r `shouldContain` [           "  1) foobar"         , "       uncaught exception: ErrorCall"
test/Test/Hspec/Core/Formatters/V2Spec.hs view
@@ -1,8 +1,8 @@+{-# OPTIONS_GHC -fno-warn-deprecations #-} module Test.Hspec.Core.Formatters.V2Spec (spec) where  import           Prelude () import           Helper-import qualified Control.Exception as E  import qualified Test.Hspec.Core.Spec as H import qualified Test.Hspec.Core.Spec as Spec@@ -20,59 +20,22 @@     H.it "exceptions" (undefined :: Spec.Result)     H.it "fail 3"     (H.Result "" $ Spec.Failure Nothing H.NoReason) - formatConfig :: FormatConfig-formatConfig = FormatConfig {-  formatConfigUseColor = False-, formatConfigOutputUnicode = True+formatConfig = defaultFormatConfig {+  formatConfigOutputUnicode = unicode , formatConfigUseDiff = True+, formatConfigDiffContext = Just 3+, formatConfigExternalDiff = Nothing , formatConfigPrettyPrint = True-, formatConfigPrintTimes = False-, formatConfigHtmlOutput = False-, formatConfigPrintCpuTime = False-, formatConfigUsedSeed = 0-, formatConfigExpectedTotalCount = 0-}+, 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 "indentChunks" $ do-    context "with Original" $ do-      it "does not indent single-line input" $ do-        indentChunks "  " [Original "foo"] `shouldBe` [PlainChunk "foo"]--      it "indents multi-line input" $ do-        indentChunks "  " [Original "foo\nbar\nbaz\n"] `shouldBe` [PlainChunk "foo\n  bar\n  baz\n  "]--    context "with Modified" $ do-      it "returns the empty list on empty input" $ do-        indentChunks "  " [Modified ""] `shouldBe` []--      it "does not indent single-line input" $ do-        indentChunks "  " [Modified "foo"] `shouldBe` [ColorChunk "foo"]--      it "indents multi-line input" $ do-        indentChunks "  " [Modified "foo\nbar\nbaz\n"] `shouldBe` [ColorChunk "foo", PlainChunk "\n  ", ColorChunk "bar", PlainChunk "\n  ", ColorChunk "baz", PlainChunk "\n  "]--      it "colorizes whitespace-only input" $ do-        indentChunks "  " [Modified "  "] `shouldBe` [ColorChunk "  "]--      it "colorizes whitespace-only lines" $ do-        indentChunks "  " [Modified "foo\n  \n"] `shouldBe` [ColorChunk "foo", PlainChunk "\n  ", ColorChunk "  ", PlainChunk "\n  "]--      it "colorizes whitespace at the end of the input" $ do-        indentChunks "  " [Modified "foo\n  "] `shouldBe` [ColorChunk "foo", PlainChunk "\n  ", ColorChunk "  "]--      it "splits off whitespace-only segments at the end of a line so that they get colorized" $ do-        indentChunks "  " [Modified "foo  \n"] `shouldBe` [ColorChunk "foo", ColorChunk "  ", PlainChunk "\n  "]--      context "with empty lines" $ do-        it "colorizes indentation" $ do-          indentChunks "  " [Original "foo", Modified "\n\n", Original "bar"] `shouldBe` [PlainChunk "foo", PlainChunk "\n", ColorChunk "  ", PlainChunk "\n", ColorChunk "  ", PlainChunk "bar"]-   describe "progress" $ do     let item = ItemDone ([], "") . Item Nothing 0 ""     describe "formatterItemDone" $ do@@ -96,7 +59,7 @@       formatter = checks       config = H.defaultConfig { H.configFormat = Just $ formatterToFormat formatter } -    it "" $ do+    it "prints unicode check marks" $ do       r <- captureLines . H.hspecWithResult config $ do         H.it "foo" True       normalizeSummary r `shouldBe` [@@ -107,7 +70,7 @@         , "1 example, 0 failures"         ] -    it "" $ do+    it "uses ASCII as a fallback" $ do       r <- captureLines . H.hspecWithResult config { H.configUnicodeMode = H.UnicodeNever } $ do         H.it "foo" True       normalizeSummary r `shouldBe` [@@ -187,7 +150,7 @@           H.describe "foo" $ do             H.it "example 1" True           H.describe "bar" $ do-            return ()+            pass           H.describe "baz" $ do             H.it "example 2" True @@ -203,9 +166,11 @@           ]      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 progress formatConfig { formatConfigOutputUnicode = True }-        _ <- formatter .  ItemDone ([], "") . Item Nothing 0 "" $ Failure Nothing $ ExpectedButGot Nothing (show "\955") (show "\956")+        formatter <- formatterToFormat failed_examples formatConfig { formatConfigOutputUnicode = True }+        formatter $ expectedButGot (show "\955") (show "\956")         (fmap normalizeSummary . captureLines) (formatter $ Done []) `shouldReturn` [             ""           , "Failures:"@@ -214,7 +179,7 @@           , "       expected: \"λ\""           , "        but got: \"μ\""           , ""-          , "  To rerun use: --match \"//\""+          , "  To rerun use: --match \"//\" --seed 0"           , ""           , "Randomized with seed 0"           , ""@@ -222,10 +187,28 @@           , "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 progress formatConfig-          _ <- formatter .  ItemDone ([], "") . Item Nothing 0 "" $ Failure Nothing $ ExpectedButGot Nothing "first\nsecond\nthird" "first\ntwo\nthird"+          formatter <- formatterToFormat failed_examples formatConfig+          formatter $ expectedButGot "first\nsecond\nthird" "first\ntwo\nthird"           (fmap normalizeSummary . captureLines) (formatter $ Done []) `shouldReturn` [               ""             , "Failures:"@@ -238,7 +221,7 @@             , "                 two"             , "                 third"             , ""-            , "  To rerun use: --match \"//\""+            , "  To rerun use: --match \"//\" --seed 0"             , ""             , "Randomized with seed 0"             , ""@@ -248,8 +231,8 @@        context "without failures" $ do         it "shows summary in green if there are no failures" $ do-          formatter <- formatterToFormat progress formatConfig-          _ <- formatter .  ItemDone ([], "") . Item Nothing 0 "" $ Success+          formatter <- formatterToFormat failed_examples formatConfig+          formatter . ItemDone ([], "") . Item Nothing 0 "" $ Success           (fmap normalizeSummary . captureLines) (formatter $ Done []) `shouldReturn` [               ""             , "Finished in 0.0000 seconds"@@ -258,8 +241,8 @@        context "with pending examples" $ do         it "shows summary in yellow if there are pending examples" $ do-          formatter <- formatterToFormat progress formatConfig-          _ <- formatter .  ItemDone ([], "") . Item Nothing 0 "" $ Pending Nothing Nothing+          formatter <- formatterToFormat failed_examples formatConfig+          formatter . ItemDone ([], "") . Item Nothing 0 "" $ Pending Nothing Nothing           (fmap normalizeSummary . captureLines) (formatter $ Done []) `shouldReturn` [               ""             , "Finished in 0.0000 seconds"@@ -287,7 +270,7 @@      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)+        H.it "foobar" (throw (ErrorCall "baz") :: Bool)       r `shouldContain` [           "  1) foobar"         , "       uncaught exception: ErrorCall"
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,13 +16,15 @@ 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 = \ _ -> return ()+      evalConfigFormat = \ _ -> pass     , evalConfigConcurrentJobs = 1     , evalConfigFailFast = False+    , evalConfigColorMode = ColorEnabled     }     normalize = map $ \ (path, item) -> (pathToList path, normalizeItem item)     normalizeItem item = item {@@ -36,6 +37,9 @@     }     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])@@ -142,14 +146,14 @@             n `shouldBe` 23         `shouldReturn` [           item ["foo"] divideByZero-        , item ["bar"] (Pending Nothing (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@@ -233,7 +237,7 @@                 n `shouldBe` 23         `shouldReturn` [           item ["foo"] divideByZero-        , item ["bar"] (Pending Nothing (Just "exception in beforeAll-hook (see previous failure)"))+        , item ["bar"] (Pending Nothing $ exceptionIn "beforeAllWith")         ]      context "when used with an empty list of examples" $ do@@ -241,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@@ -317,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@@ -349,7 +353,6 @@         , "foo"         , "before"         , "bar"-        , "before"         , "afterAll_"         ] @@ -369,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@@ -377,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 Nothing)+        , item ["bar"] (Pending Nothing Nothing)         ]      context "when action throws an exception" $ do@@ -387,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@@ -497,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@@ -512,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 Nothing (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@@ -546,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 Nothing (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 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,241 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}-module Test.Hspec.Core.QuickCheckUtilSpec (spec) where--import           Prelude ()-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
@@ -1,9 +1,10 @@-{-# LANGUAGE RecordWildCards #-} 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 @@ -25,9 +26,12 @@ spec :: Spec spec = do   describe "printSlowSpecItems" $ do-    let format = printSlowSpecItems 2 $ \ _ -> return ()+    let+      format = printSlowSpecItems 2 $ \ _ -> pass+      run = hCapture_ [stderr] . format . Done+     it "prints slow spec items" $ do-      capture_ $ format $ Done [+      run [             ((["foo", "bar"], "one"), item {itemDuration = 0.100})           , ((["foo", "bar"], "two"), item {itemDuration = 0.500})           , ((["foo", "bar"], "thr"), item {itemDuration = 0.050})@@ -41,5 +45,5 @@      context "when there are no slow items" $ do       it "prints nothing" $ do-        capture_ $ format $ Done [((["foo", "bar"], "one"), item {itemDuration = 0})]+        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-import           System.Environment (withArgs, withProgName, getArgs)+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.V2 as V2+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,7 +232,7 @@             H.it "baz" True           putMVar mvar r         takeMVar sync-        throwTo threadId E.UserInterrupt+        throwTo threadId UserInterrupt         r <- takeMVar mvar         normalizeSummary r `shouldBe` [             ""@@ -199,7 +242,7 @@           , ""           , "  1) foo"           , ""-          , "  To rerun use: --match \"/foo/\""+          , "  To rerun use: --match \"/foo/\" --seed 23"           , ""           , "Randomized with seed 23"           , ""@@ -215,18 +258,18 @@             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 [✔]"@@ -250,35 +293,46 @@         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 [✘]"           , ""           , "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"           , ""           , "Randomized with seed 23"           , ""@@ -286,13 +340,62 @@           , "1 example, 1 failure"           ] +    context "with --fail-on=empty-description" $ do+      let run = hspecCapture ["--fail-on=empty-description", "--seed", "23"]+      it "fails on items with empty requirement" $ do+        run $ do+          H.it "foo" True+          H.it "" True+        `shouldReturn` unlines [+            ""+          , "foo [✔]"+          , "(unspecified behavior) [✘]"+          , ""+          , "Failures:"+          , ""+          , "  1) (unspecified behavior)"+          , "       item has no description; failing due to --fail-on=empty-description"+          , ""+          , "  To rerun use: --match \"/(unspecified behavior)/\" --seed 23"+          , ""+          , "Randomized with seed 23"+          , ""+          , "Finished in 0.0000 seconds"+          , "2 examples, 1 failure"+          ]++    context "with --fail-on=pending" $ do+      let run = hspecCapture ["--fail-on=pending", "--seed", "23"]+      it "fails on pending spec items" $ do+        run $ do+          H.it "foo" True+          H.it "bar" $ do+            void $ throwIO (H.Pending Nothing Nothing)+        `shouldReturn` unlines [+            ""+          , "foo [✔]"+          , "bar [✘]"+          , ""+          , "Failures:"+          , ""+          , "  1) bar"+          , "       item is pending; failing due to --fail-on=pending"+          , ""+          , "  To rerun use: --match \"/bar/\" --seed 23"+          , ""+          , "Randomized with seed 23"+          , ""+          , "Finished in 0.0000 seconds"+          , "2 examples, 1 failure"+          ]+     context "with --fail-fast" $ do       it "stops after first failure" $ do-        r <- captureLines . ignoreExitCode . withArgs ["--fail-fast", "--seed", "23"] . H.hspec . removeLocations $ do+        hspecCapture ["--fail-fast", "--seed", "23"] $ do           H.it "foo" True           H.it "bar" False           H.it "baz" False-        normalizeSummary r `shouldBe` [+        `shouldReturn` unlines [             ""           , "foo [✔]"           , "bar [✘]"@@ -301,7 +404,7 @@           , ""           , "  1) bar"           , ""-          , "  To rerun use: --match \"/bar/\""+          , "  To rerun use: --match \"/bar/\" --seed 23"           , ""           , "Randomized with seed 23"           , ""@@ -322,17 +425,17 @@             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 [✘]"@@ -341,7 +444,7 @@           , ""           , "  1) foo bar"           , ""-          , "  To rerun use: --match \"/foo/bar/\""+          , "  To rerun use: --match \"/foo/bar/\" --seed 23"           , ""           , "Randomized with seed 23"           , ""@@ -349,6 +452,26 @@           , "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@@ -392,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@@ -408,13 +668,82 @@           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 <- captureLines . ignoreExitCode . withArgs ["--print-slow-items"] . H.hspec $ do+        r <- fmap lines . hCapture_ [stdout, stderr] . ignoreExitCode . withArgs ["--print-slow-items"] . H.hspec $ do           H.it "foo" $ threadDelay 2000         normalizeTimes (normalizeSummary r) `shouldBe` [             ""@@ -424,11 +753,7 @@           , "1 example, 0 failures"           , ""           , "Slow spec items:"-#if MIN_VERSION_base(4,8,1)-          , "  test/Test/Hspec/Core/RunnerSpec.hs:418:11: /foo/ (2ms)"-#else-          , "  /foo/ (2ms)"-#endif+          , "  test" </> "Test" </> "Hspec" </> "Core" </> "RunnerSpec.hs:" <> show (__LINE__ - 9 :: Int) <> ":11: /foo/ (2ms)"           ]      context "with --format" $ do@@ -447,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"]@@ -516,8 +880,8 @@    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@@ -533,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.configFormat = Just $ V2.formatterToFormat V2.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)@@ -570,28 +938,42 @@               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-    it "returns False" $ do-      withEnvironment [] $ do-        H.colorOutputSupported H.ColorAuto (return False) `shouldReturn` False+    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 "returns True" $ do-        withEnvironment [] $ do-          H.colorOutputSupported H.ColorAuto isTerminalDevice `shouldReturn` 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 "returns False" $ do+        it "disables color output" $ do           withEnvironment [("NO_COLOR", "yes")] $ do-            H.colorOutputSupported H.ColorAuto isTerminalDevice `shouldReturn` False+            H.colorOutputSupported H.ColorAuto isTerminalDevice `shouldReturn` ColorDisabled -  describe "colorOutputSupported" $ do+  describe "unicodeOutputSupported" $ do     context "with UnicodeAlways" $ do       it "returns True" $ do         H.unicodeOutputSupported H.UnicodeAlways undefined `shouldReturn` True@@ -619,31 +1001,27 @@     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/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
@@ -8,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
@@ -4,7 +4,6 @@ import           Helper  import           Control.Concurrent-import qualified Control.Exception as E  import           Test.Hspec.Core.Util @@ -22,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)"@@ -44,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)@@ -51,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@@ -95,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 -fno-warn-implicit-prelude #-}---------------------------------------------------------------------------------- |--- 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,5 +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/Text/Show/Unicode.hs 
@@ -1,140 +0,0 @@-{- |-Copyright   : (c) Takayuki Muranushi, 2016-License     : BSD3-Maintainer  : whosekiteneverfly@gmail.com-Stability   : experimental---Provides a interactive printer for printing Unicode characters in ghci REPL. Our design goal is that 'uprint' produces String representations that are valid Haskell 'String' literals and uses as many Unicode printable characters as possible. Hence--@-read . ushow == id-@--see the tests of this package for detailed specifications.--__Example__--With 'print' :--@-$ __ghci__-...-> __["哈斯克尔7.6.1"]__-["\\21704\\26031\\20811\\23572\\&7.6.1"]->-@--With 'uprint' :--@-$ __ghci -interactive-print=Text.Show.Unicode.uprint Text.Show.Unicode__-...-Ok, modules loaded: Text.Show.Unicode.-> __("Хорошо!",["哈斯克尔7.6.1的力量","感じる"])__-("Хорошо!",["哈斯克尔7.6.1的力量","感じる"])-> "改\\n行"-"改\\n行"-@--You can make 'uprint' the default interactive printer in several ways. One is to-@cabal install unicode-show@, and add the following lines to your @~/.ghci@ config file.--@-import qualified Text.Show.Unicode-:set -interactive-print=Text.Show.Unicode.uprint-@---}--module Text.Show.Unicode (ushow, uprint, urecover, ushowWith, uprintWith, urecoverWith) where--import           Prelude ()-import           Test.Hspec.Core.Compat hiding (many, (<*>), (*>), (<*))--import           Data.Char                    (isAscii, isPrint)-import           Text.ParserCombinators.ReadP-import           Text.Read.Lex                (lexChar)-import qualified Data.List                     as L--infixl 4 <*--(<*) :: Monad m => m a -> m b -> m a-(<*) = flip (>>)---- Represents a replaced character using its literal form and its escaped form.-type Replacement = (String, String)---- | Parse one Haskell character literal expression from a 'String' produced by 'show', and------  * If the found char satisfies the predicate, replace the literal string with the character itself.---  * Otherwise, leave the string as it was.---  * Note that special delimiter sequence "\&" may appear in a string. c.f.  <https://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-200002.6 Section 2.6 of the Haskell 2010 specification>.-recoverChar :: (Char -> Bool) -> ReadP Replacement-recoverChar p = represent <$> gather lexCharAndConsumeEmpties-  where-    represent :: (String, Char) -> Replacement-    represent (o,lc)-      -- This is too dirty a hack.-      -- However, I couldn't think of any other way to recover the & consumed by lexChar while not needlessly increasing the number of & by mis-detecting the escape sequence.-      | p lc      =-        if head o /= '\\' &&-        "\\&" `L.isSuffixOf` o-        then (o, lc : "\\&")-        else (o, [lc])-      | otherwise = (o, o)---- | The base library lexChar has been handling & by itself since 4.9.1.0,--- so consumeEmpties is a meaningless action,--- but it makes sense for older versions of lexChar.-lexCharAndConsumeEmpties :: ReadP Char-lexCharAndConsumeEmpties = lexChar <* consumeEmpties-    where-    -- Consumes the string "\&" repeatedly and greedily (will only produce one match)-    consumeEmpties :: ReadP ()-    consumeEmpties = do-        rest <- look-        case rest of-            ('\\':'&':_) -> string "\\&" >> consumeEmpties-            _ -> return ()---- | Show the input, and then replace Haskell character literals--- with the character it represents, for any Unicode printable characters except backslash, single and double quotation marks.--- If something fails, fallback to standard 'show'.-ushow :: Show a => a -> String-ushow = ushowWith shouldRecover---- | Replace Haskell character literals with the character it represents, for--- any Unicode printable characters except backslash, single and double--- quotation marks.-urecover :: String -> String-urecover = urecoverWith shouldRecover--shouldRecover :: Char -> Bool-shouldRecover c = isPrint c && not (isAscii c)---- | A version of 'print' that uses 'ushow'.-uprint :: Show a => a -> IO ()-uprint = putStrLn . ushow---- | Show the input, and then replace character literals--- with the character itself, for characters that satisfy the given predicate.-ushowWith :: Show a => (Char -> Bool) -> a -> String-ushowWith p = urecoverWith p . show---- | Replace character literals with the character itself, for characters that--- satisfy the given predicate.-urecoverWith :: (Char -> Bool) -> String -> String-urecoverWith p = go ("", "") . readP_to_S (many $ recoverChar p)-  where-    go :: Replacement -> [([Replacement], String)] -> String-    go _  []            = ""-    go _  (([],""):_)   = ""-    go _  ((rs,""):_)   = snd $ last rs-    go _  [(_,o)]       = o-    go pr (([],_):rest) = go pr rest-    go _  ((rs,_):rest) = let r = last rs in snd r ++ go r rest---- | A version of 'print' that uses 'ushowWith'.-uprintWith :: Show a => (Char -> Bool) -> a -> IO ()-uprintWith p = putStrLn . ushowWith p
+ 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.9.2+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/