packages feed

hspec-core 2.8.5 → 2.11.17

raw patch · 88 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,34 +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-]diff             show colorized diffs-                --[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@@ -44,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.4.+-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack  name:             hspec-core-version:          2.8.5+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,22 +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.Free       Test.Hspec.Core.Formatters.Internal-      Test.Hspec.Core.Formatters.Monad-      Test.Hspec.Core.QuickCheckUtil+      Test.Hspec.Core.Formatters.Pretty+      Test.Hspec.Core.Formatters.Pretty.Parser+      Test.Hspec.Core.Formatters.Pretty.Unicode+      Test.Hspec.Core.Formatters.V1.Free+      Test.Hspec.Core.Formatters.V1.Internal+      Test.Hspec.Core.Formatters.V1.Monad+      Test.Hspec.Core.QuickCheck.Util       Test.Hspec.Core.Runner.Eval+      Test.Hspec.Core.Runner.JobQueue       Test.Hspec.Core.Runner.PrintSlowSpecItems+      Test.Hspec.Core.Runner.Result       Test.Hspec.Core.Shuffle       Test.Hspec.Core.Spec.Monad       Test.Hspec.Core.Timer       Test.Hspec.Core.Tree-      Control.Concurrent.Async       Data.Algorithm.Diff       Paths_hspec_core   default-language: Haskell2010+  if impl(ghc)+    other-modules:+        Control.Concurrent.Async+    hs-source-dirs:+        vendor/async-2.2.5/+    cpp-options: -DENABLE_SPEC_HOOK_ARGS+    if impl(ghc >= 8.4.1)+      build-depends:+          stm >=2.2+    else+      other-modules:+          Control.Concurrent.STM.TMVar+      hs-source-dirs:+          vendor/stm-2.5.0.1/  test-suite spec   type: exitcode-stdio-1.0@@ -105,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.7.8+    , haskell-lexer+    , hspec-expectations ==0.8.4.*+    , hspec-meta ==2.11.17     , process     , quickcheck-io >=0.2.0     , random-    , setenv     , silently >=1.2.4-    , stm >=2.2     , temporary-    , tf-random+    , time     , transformers >=0.2.2.0   build-tool-depends:       hspec-meta:hspec-meta-discover@@ -131,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@@ -138,34 +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.Free       Test.Hspec.Core.Formatters.Internal-      Test.Hspec.Core.Formatters.Monad+      Test.Hspec.Core.Formatters.Pretty+      Test.Hspec.Core.Formatters.Pretty.Parser+      Test.Hspec.Core.Formatters.Pretty.Unicode       Test.Hspec.Core.Formatters.V1+      Test.Hspec.Core.Formatters.V1.Free+      Test.Hspec.Core.Formatters.V1.Internal+      Test.Hspec.Core.Formatters.V1.Monad       Test.Hspec.Core.Formatters.V2       Test.Hspec.Core.Hooks       Test.Hspec.Core.QuickCheck-      Test.Hspec.Core.QuickCheckUtil+      Test.Hspec.Core.QuickCheck.Util       Test.Hspec.Core.Runner       Test.Hspec.Core.Runner.Eval+      Test.Hspec.Core.Runner.JobQueue       Test.Hspec.Core.Runner.PrintSlowSpecItems+      Test.Hspec.Core.Runner.Result       Test.Hspec.Core.Shuffle       Test.Hspec.Core.Spec       Test.Hspec.Core.Spec.Monad       Test.Hspec.Core.Timer       Test.Hspec.Core.Tree       Test.Hspec.Core.Util-      Control.Concurrent.Async       Data.Algorithm.Diff-      All       GetOpt.Declarative.EnvironmentSpec       GetOpt.Declarative.UtilSpec       Helper       Mock+      SpecHook+      Test.Hspec.Core.AnnotationsSpec       Test.Hspec.Core.ClockSpec       Test.Hspec.Core.CompatSpec       Test.Hspec.Core.Config.DefinitionSpec@@ -177,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
@@ -2,6 +2,7 @@ module Test.Hspec.Core.Config (   Config (..) , ColorMode(..)+, UnicodeMode(..) , defaultConfig , readConfig , configAddFilter@@ -17,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@@ -29,11 +28,21 @@  import           Test.Hspec.Core.Util import           Test.Hspec.Core.Config.Options-import           Test.Hspec.Core.Config.Definition (Config(..), ColorMode(..), 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@@ -42,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@@ -67,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)@@ -94,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)@@ -139,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@@ -154,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
@@ -2,44 +2,95 @@ module Test.Hspec.Core.Config.Definition (   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) +data UnicodeMode = UnicodeAuto | UnicodeNever | UnicodeAlways+  deriving (Eq, Show)+ data Config = Config {   configIgnoreConfigFile :: Bool , configDryRun :: Bool , configFocusedOnly :: Bool+, configFailOnEmpty :: Bool , configFailOnFocused :: Bool+, configFailOnPending :: Bool+, configFailOnEmptyDescription :: Bool , configPrintSlowItems :: Maybe Int , configPrintCpuTime :: Bool-, configFastFail :: Bool+, configFailFast :: Bool , configRandomize :: Bool+, configSeed :: Maybe Integer+, configQuickCheckSeed :: Maybe Integer , configFailureReport :: Maybe FilePath , configRerun :: Bool , configRerunAllOnSuccess :: Bool@@ -49,56 +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+, 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-, configFastFail = 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+, 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@@ -109,33 +208,42 @@ 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 :: [Option Config]-formatterOptions = [-    mkOption "format" (Just 'f') (argument "FORMATTER" readFormatter setFormatter) helpForFormat-  , mkFlag "color" setColor "colorize the output"-  , mkFlag "diff" setDiff "show colorized diffs"-  , mkFlag "times" setTimes "report times for individual spec items"+formatterOptions :: [(String, FormatConfig -> IO Format)] -> [Option Config]+formatterOptions formatters = [+    mkOption "format" (Just 'f') (argument "NAME" readFormatter setFormatter) helpForFormat+  , flag "color" setColor "colorize the output"+  , flag "unicode" setUnicode "output unicode"+  , flag "diff" setDiff "show colorized diffs"+  , option "diff-context" (argument "N" readDiffContext setDiffContext) $ unlines [+        "output N lines of diff context (default: " <> show defaultDiffContext <> ")"+      , "use a value of 'full' to see the full context"+      ]+  , option "diff-command" (argument "CMD" return setDiffCommand) "use an external diff command\nexample: --diff-command=\"git diff\""+  , flag "pretty" setPretty "try to pretty-print diff values"+  , mkOptionNoArg "show-exceptions" Nothing setShowException "use `show` when formatting exceptions"+  , mkOptionNoArg "display-exceptions" Nothing setDisplayException "use `displayException` when formatting exceptions"++  , flag "times" setTimes "report times for individual spec items"   , mkOptionNoArg "print-cpu-time" Nothing setPrintCpuTime "include used CPU time in summary"   , printSlowItemsOption+  , flag "expert" setExpertMode "be less verbose"      -- undocumented for now, as we probably want to change this to produce a     -- standalone HTML report in the future   , undocumented $ mkOptionNoArg "html" Nothing setHtml "produce HTML output"   ]   where-    setHtml config = config {configHtmlOutput = True}+    setDiffCommand :: String -> Config -> Config+    setDiffCommand command config = config {+      configExternalDiff = case strip command of+        "" -> Nothing+        _ -> Just $ \ _context -> externalDiff command+    } -    formatters :: [(String, FormatConfig -> IO Format)]-    formatters = map (fmap V2.formatterToFormat) [-        ("checks", V2.checks)-      , ("specdoc", V2.specdoc)-      , ("progress", V2.progress)-      , ("failed-examples", V2.failed_examples)-      , ("silent", V2.silent)-      ]+    setHtml config = config {configHtmlOutput = True}      helpForFormat :: String     helpForFormat = "use a custom formatter; this can be one of " ++ (formatOrList $ map fst formatters)@@ -149,14 +257,39 @@     setColor :: Bool -> Config -> Config     setColor v config = config {configColorMode = if v then ColorAlways else ColorNever} +    setUnicode :: Bool -> Config -> Config+    setUnicode v config = config {configUnicodeMode = if v then UnicodeAlways else UnicodeNever}+     setDiff :: Bool -> Config -> Config     setDiff v config = config {configDiff = v} +    readDiffContext :: String -> Maybe (Maybe Int)+    readDiffContext input = case input of+      "full" -> Just Nothing+      _ -> case readMaybe input of+        Nothing -> Nothing+        mn -> Just (find (>= 0) mn)++    setDiffContext :: Maybe Int -> Config -> Config+    setDiffContext value c = c { configDiffContext = value }++    setPretty :: Bool -> Config -> Config+    setPretty v config = config {configPrettyPrint = v}++    setShowException :: Config -> Config+    setShowException config = config {configFormatException = formatExceptionWith show}++    setDisplayException :: Config -> Config+    setDisplayException config = config {configFormatException = formatExceptionWith displayException}+     setTimes :: Bool -> Config -> Config     setTimes v config = config {configTimes = v}      setPrintCpuTime config = config {configPrintCpuTime = True} +    setExpertMode :: Bool -> Config -> Config+    setExpertMode v config = config {configExpertMode = v}+ printSlowItemsOption :: Option Config printSlowItemsOption = Option name (Just 'p') (OptArg "N" arg) "print the N slowest spec items (default: 10)" True   where@@ -170,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 = [@@ -180,7 +312,7 @@   ]  setDepth :: Int -> Config -> Config-setDepth n c = c {configSmallCheckDepth = n}+setDepth n c = c {configSmallCheckDepth = Just n}  quickCheckOptions :: [Option Config] quickCheckOptions = [@@ -188,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"@@ -207,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" setFastFail "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@@ -240,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} -    setFastFail :: Bool -> Config -> Config-    setFastFail value config = config {configFastFail = 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
@@ -21,18 +21,21 @@ envVarName :: String envVarName = "HSPEC_OPTIONS" -commandLineOptions :: [(String, [Declarative.Option Config])]-commandLineOptions =+commandLineOptions :: Config -> [(String, [Declarative.Option Config])]+commandLineOptions config =     ("OPTIONS", commandLineOnlyOptions)-  : otherOptions+  : otherOptions config -otherOptions :: [(String, [Declarative.Option Config])]-otherOptions = [+otherOptions :: Config -> [(String, [Declarative.Option Config])]+otherOptions config = [     ("RUNNER OPTIONS", runnerOptions)-  , ("FORMATTER OPTIONS", formatterOptions)+  , ("FORMATTER OPTIONS", formatterOptions formatters)   , ("OPTIONS FOR QUICKCHECK", quickCheckOptions)   , ("OPTIONS FOR SMALLCHECK", smallCheckOptions)-  ]+  ] ++ extensionOptions+  where+    formatters = configAvailableFormatters config+    extensionOptions = getExtensionOptions config  ignoreConfigFile :: Config -> [String] -> IO Bool ignoreConfigFile config args = do@@ -48,23 +51,16 @@       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 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)  parseEnvironmentOptions :: [(String, String)] -> Config -> Either (ExitCode, String) ([String], Config)-parseEnvironmentOptions env config = case Declarative.parseEnvironmentOptions "HSPEC" env config (concatMap snd commandLineOptions) of+parseEnvironmentOptions env config = case Declarative.parseEnvironmentOptions "HSPEC" env config (concatMap snd $ commandLineOptions config) of   (warnings, c) -> Right (map formatWarning warnings, c)   where     formatWarning (Declarative.InvalidValue name value) = "invalid value `" ++ value ++ "' for environment variable " ++ name@@ -83,7 +79,7 @@   Left err -> failure err   where     options :: [Declarative.Option Config]-    options = filter Declarative.optionDocumented $ concatMap snd otherOptions+    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,14 +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-, formatConfigItemCount :: Int-} deriving (Eq, Show)+, formatConfigExpectedTotalCount :: Int+, formatConfigExpertMode :: Bool+} +{-# DEPRECATED formatConfigPrettyPrint "Use `formatConfigPrettyPrintFunction` instead" #-}++-- ^ @since 2.11.5+defaultFormatConfig :: FormatConfig+defaultFormatConfig = FormatConfig {+  formatConfigUseColor = False+, formatConfigReportProgress = False+, formatConfigOutputUnicode = False+, formatConfigUseDiff = False+, formatConfigDiffContext = Nothing+, formatConfigExternalDiff = Nothing+, formatConfigPrettyPrint = False+, formatConfigPrettyPrintFunction = Nothing+, formatConfigFormatException = formatExceptionWith show+, formatConfigPrintTimes = False+, formatConfigHtmlOutput = False+, formatConfigPrintCpuTime = False+, formatConfigUsedSeed = 0+, formatConfigExpectedTotalCount = 0+, formatConfigExpertMode = False+}+ data Signal = Ok | NotOk SomeException  monadic :: MonadIO m => (m () -> IO ()) -> (Event -> m ()) -> IO Format@@ -89,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,8 +1,15 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} module Test.Hspec.Core.Formatters.Diff (   Diff (..) , diff++, LineDiff(..)+, lineDiff++, splitLines+ #ifdef TEST , partition , breakList@@ -13,14 +20,130 @@ import           Test.Hspec.Core.Compat  import           Data.Char-import           Data.Algorithm.Diff+import qualified Data.Algorithm.Diff as Diff -diff :: String -> String -> [Diff String]-diff expected actual = map (fmap concat) $ getGroupedDiff (partition expected) (partition actual)+data Diff = First String | Second String | Both String+  deriving (Eq, Show) +data LineDiff =+    LinesFirst [String]+  | LinesSecond [String]+  | LinesBoth [String]+  | SingleLineDiff [Diff]+  | LinesOmitted Int+  deriving (Eq, Show)++lineDiff :: Maybe Int -> String -> String -> [LineDiff]+lineDiff context expected actual = maybe id applyContext context $ singleLineDiffs diffs+  where+    diffs :: [LineDiff]+    diffs = Diff.getGroupedDiff expectedLines actualLines <&> \ case+      Diff.First xs -> LinesFirst xs+      Diff.Second xs -> LinesSecond xs+      Diff.Both xs _ -> LinesBoth xs++    expectedLines :: [String]+    expectedLines = splitLines expected++    actualLines :: [String]+    actualLines = splitLines actual++singleLineDiffs :: [LineDiff] -> [LineDiff]+singleLineDiffs = go+  where+    go = \ case+      [] -> []+      LinesFirst [first_] : LinesSecond [second_] : xs -> SingleLineDiff (diff first_ second_) : go xs+      x : xs -> x : go xs++splitLines :: String -> [String]+splitLines = go+  where+    go :: String -> [String]+    go xs = case break (== '\n') xs of+      (ys, '\n' : zs) -> ys : go zs+      _ -> [xs]++data TrimMode = FirstChunk | Chunk | LastChunk++applyContext :: Int -> [LineDiff] -> [LineDiff]+applyContext context = \ diffs -> case diffs of+  [] -> []+  x : xs -> trimChunk FirstChunk x (go xs)+  where+    omitThreshold :: Int+    omitThreshold = 3++    go :: [LineDiff] -> [LineDiff]+    go diffs = case diffs of+      [] -> []+      [x] -> trimChunk LastChunk x []+      x : xs -> trimChunk Chunk x (go xs)++    trimChunk :: TrimMode -> LineDiff -> [LineDiff] -> [LineDiff]+    trimChunk mode chunk = case chunk of+      LinesBoth allLines | meetsThreshold -> keep start . (LinesOmitted omitted :) . keep end+        where+          meetsThreshold :: Bool+          meetsThreshold = omitThreshold <= omitted++          lastLineHasNL = case (mode, reverse allLines) of+            (LastChunk, "" : _) -> True+            _ -> False++          omitted :: Int+          omitted = n - keepStart - keepEnd++          keepStart :: Int+          keepStart = case mode of+            FirstChunk -> 0+            _ -> context++          keepEnd :: Int+          keepEnd = case mode of+            LastChunk -> 0+            _ -> context++          n :: Int+          n = length allLines - case lastLineHasNL of+            False -> 0+            True -> 1++          start :: [String]+          start = take keepStart allLines++          end :: [String]+          end = drop (keepStart + omitted) allLines++      _ -> (chunk :)++keep :: [String] -> [LineDiff] -> [LineDiff]+keep xs+  | null xs = id+  | otherwise = (LinesBoth xs :)++diff :: String -> String -> [Diff]+diff expected actual = diffs+  where+    diffs :: [Diff]+    diffs = map (toDiff . fmap concat) $ Diff.getGroupedDiff expectedChunks actualChunks++    expectedChunks :: [String]+    expectedChunks = partition expected++    actualChunks :: [String]+    actualChunks = partition actual++toDiff :: Diff.Diff String -> Diff+toDiff d = case d of+  Diff.First xs -> First xs+  Diff.Second xs -> Second xs+  Diff.Both xs _ -> Both xs+ partition :: String -> [String] partition = filter (not . null) . mergeBackslashes . breakList isAlphaNum   where+    mergeBackslashes :: [String] -> [String]     mergeBackslashes xs = case xs of       ['\\'] : (splitEscape -> Just (escape, ys)) : zs -> ("\\" ++ escape) : ys : mergeBackslashes zs       z : zs -> z : mergeBackslashes zs@@ -37,7 +160,7 @@       | otherwise = (x :)  splitEscape :: String -> Maybe (String, String)-splitEscape xs = splitNumericEscape xs <|> (msum $ map split escapes)+splitEscape xs = splitNumericEscape xs <|> msum (map split escapes)   where     split :: String -> Maybe (String, String)     split escape = (,) escape <$> stripPrefix escape xs
− src/Test/Hspec/Core/Formatters/Free.hs 
@@ -1,22 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-module Test.Hspec.Core.Formatters.Free where--import           Prelude ()-import           Test.Hspec.Core.Compat--data Free f a = Free (f (Free f a)) | Pure a-  deriving Functor--instance Functor f => Applicative (Free f) where-  pure = Pure-  Pure f <*> Pure a = Pure (f a)-  Pure f <*> Free m = Free (fmap f <$> m)-  Free m <*> b = Free (fmap (<*> b) m)--instance Functor f => Monad (Free f) where-  return = pure-  Pure a >>= f = f a-  Free m >>= f = Free (fmap (>>= f) m)--liftF :: Functor f => f a -> Free f a-liftF command = Free (fmap Pure command)
src/Test/Hspec/Core/Formatters/Internal.hs view
@@ -1,16 +1,57 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-} module Test.Hspec.Core.Formatters.Internal (-  FormatM-, runFormatM-, interpret-, increaseSuccessCount-, increasePendingCount-, addFailMessage+  Formatter(..)+, Item(..)+, Result(..)+, FailureReason(..)+, FormatM , formatterToFormat++, getConfig+, getConfigValue+, FormatConfig(..)++, getSuccessCount+, getPendingCount+, getFailCount+, getTotalCount+, getExpectedTotalCount++, FailureRecord(..)+, getFailMessages+, usedSeed++, printTimes+, getCPUTime+, getRealTime++, write+, writeLine+, writeTransient++, withInfoColor+, withSuccessColor+, withPendingColor+, withFailColor++, outputUnicode++, useDiff+, diffContext+, externalDiffAction+, prettyPrint+, prettyPrintFunction+, extraChunk+, missingChunk++, unlessExpert+ #ifdef TEST-, overwriteWith+, runFormatM+, splitLines #endif ) where @@ -18,66 +59,138 @@ 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 qualified Test.Hspec.Core.Formatters.Monad as M-import           Test.Hspec.Core.Formatters.Monad (Environment(..), interpretWith, FailureRecord(..)) import           Test.Hspec.Core.Format import           Test.Hspec.Core.Clock -formatterToFormat :: M.Formatter -> FormatConfig -> IO Format-formatterToFormat M.Formatter{..} config = monadic (runFormatM config) $ \ event -> case event of-  Started -> interpret formatterStarted-  GroupStarted path -> interpret $ formatterGroupStarted path-  GroupDone path -> interpret $ formatterGroupDone path-  Progress path progress -> interpret $ formatterProgress path progress-  ItemStarted path -> interpret $ formatterItemStarted path+data Formatter = Formatter {+-- | evaluated before a test run+  formatterStarted :: FormatM ()++-- | evaluated before each spec group+, formatterGroupStarted :: Path -> FormatM ()++-- | evaluated after each spec group+, formatterGroupDone :: Path -> FormatM ()++-- | used to notify the progress of the currently evaluated example+, formatterProgress :: Path -> Progress -> FormatM ()++-- | evaluated before each spec item+, formatterItemStarted :: Path -> FormatM ()++-- | evaluated after each spec item+, formatterItemDone :: Path -> Item -> FormatM ()++-- | evaluated after a test run+, formatterDone :: FormatM ()+}++data FailureRecord = FailureRecord {+  failureRecordLocation :: Maybe Location+, failureRecordPath     :: Path+, failureRecordMessage  :: FailureReason+}++formatterToFormat :: Formatter -> FormatConfig -> IO Format+formatterToFormat Formatter{..} config = monadic (runFormatM config) $ \ case+  Started -> formatterStarted+  GroupStarted path -> formatterGroupStarted path+  GroupDone path -> formatterGroupDone path+  Progress path progress -> formatterProgress path progress+  ItemStarted path -> formatterItemStarted path   ItemDone path item -> do-    clearTransientOutput     case itemResult item of       Success {} -> increaseSuccessCount       Pending {} -> increasePendingCount-      Failure loc err -> addFailMessage (loc <|> itemLocation item) path err-    interpret $ formatterItemDone path item-  Done _ -> interpret formatterDone+      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 } -interpret :: M.FormatM a -> FormatM a-interpret = interpretWith Environment {-  environmentGetSuccessCount = getSuccessCount-, environmentGetPendingCount = getPendingCount-, environmentGetFailMessages = getFailMessages-, environmentGetFinalCount = getItemCount-, environmentUsedSeed = usedSeed-, environmentPrintTimes = gets (formatConfigPrintTimes . stateConfig)-, environmentGetCPUTime = getCPUTime-, environmentGetRealTime = getRealTime-, environmentWrite = write-, environmentWriteTransient = writeTransient-, environmentWithFailColor = withFailColor-, environmentWithSuccessColor = withSuccessColor-, environmentWithPendingColor = withPendingColor-, environmentWithInfoColor = withInfoColor-, environmentUseDiff = gets (formatConfigUseDiff . stateConfig)-, environmentExtraChunk = extraChunk-, environmentMissingChunk = missingChunk-, environmentLiftIO = liftIO-}+-- | Get the number of failed examples encountered so far.+getFailCount :: FormatM Int+getFailCount = length <$> getFailMessages +-- | Return `True` if the user requested colorized diffs, `False` otherwise.+useDiff :: FormatM Bool+useDiff = getConfigValue formatConfigUseDiff++-- | Do nothing on `--expert`, otherwise run the given action.+--+-- @since 2.11.2+unlessExpert :: FormatM () -> FormatM ()+unlessExpert action = getConfigValue formatConfigExpertMode >>= \ case+  False -> action+  True -> return ()++-- |+-- Return the value of `Test.Hspec.Core.Runner.configDiffContext`.+--+-- @since 2.10.6+diffContext :: FormatM (Maybe Int)+diffContext = getConfigValue formatConfigDiffContext++-- | An action for printing diffs.+--+-- The action takes @expected@ and @actual@ as arguments.+--+-- When this is a `Just`-value then it should be used instead of any built-in+-- diff implementation.  A `Just`-value also implies that `useDiff` returns+-- `True`.+--+-- @since 2.10.6+externalDiffAction :: FormatM (Maybe (String -> String -> IO ()))+externalDiffAction = getConfigValue formatConfigExternalDiff++-- | Return `True` if the user requested pretty diffs, `False` otherwise.+prettyPrint :: FormatM Bool+prettyPrint = maybe False (const True) <$> getConfigValue formatConfigPrettyPrintFunction+{-# DEPRECATED prettyPrint "use `prettyPrintFunction` instead" #-}++-- | Return a function for pretty-printing if the user requested pretty diffs,+-- `Nothing` otherwise.+--+-- @since 2.10.0+prettyPrintFunction :: FormatM (Maybe (String -> String -> (String, String)))+prettyPrintFunction = getConfigValue formatConfigPrettyPrintFunction++-- | Return `True` if the user requested unicode output, `False` otherwise.+--+-- @since 2.9.0+outputUnicode :: FormatM Bool+outputUnicode = getConfigValue formatConfigOutputUnicode++-- | The same as `write`, but adds a newline character.+writeLine :: String -> FormatM ()+writeLine s = write s >> write "\n"++-- | Return `True` if the user requested time reporting for individual spec+-- items, `False` otherwise.+printTimes :: FormatM Bool+printTimes = gets (formatConfigPrintTimes . stateConfig)++-- | Get the total number of examples encountered so far.+getTotalCount :: FormatM Int+getTotalCount = sum <$> sequence [getSuccessCount, getFailCount, getPendingCount]+ -- | A lifted version of `Control.Monad.Trans.State.gets` gets :: (FormatterState -> a) -> FormatM a gets f = FormatM $ do-  f <$> (get >>= liftIO . readIORef)+  f <$> (ask >>= liftIO . readIORef)  -- | A lifted version of `Control.Monad.Trans.State.modify` modify :: (FormatterState -> FormatterState) -> FormatM () modify f = FormatM $ do-  get >>= liftIO . (`modifyIORef'` f)+  ask >>= liftIO . (`modifyIORef'` f)  data FormatterState = FormatterState {   stateSuccessCount    :: !Int@@ -85,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}@@ -127,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).-getItemCount :: FormatM Int-getItemCount = getConfig formatConfigItemCount--overwriteWith :: String -> String -> String-overwriteWith old new-  | n == 0 = new-  | otherwise = '\r' : new ++ replicate (n - length new) ' '-  where-    n = length old+--+-- @since 2.9.0+getExpectedTotalCount :: FormatM Int+getExpectedTotalCount = getConfigValue formatConfigExpectedTotalCount  writeTransient :: String -> FormatM () writeTransient new = do-  useColor <- getConfig formatConfigUseColor-  when (useColor) $ do-    old <- gets stateTransientOutput-    write $ old `overwriteWith` new-    modify $ \ state -> state {stateTransientOutput = new}-    h <- getHandle-    liftIO $ IO.hFlush h+  reportProgress <- getConfigValue formatConfigReportProgress+  when reportProgress . liftIO $ do+    bracket_ disableLineWrapping enableLineWrapping $ writePlain new+    IO.hFlush stdout+    clearLine+  where+    disableLineWrapping :: IO ()+    disableLineWrapping = writePlain "\ESC[?7l" -clearTransientOutput :: FormatM ()-clearTransientOutput = do-  n <- length <$> gets stateTransientOutput-  unless (n == 0) $ do-    write ("\r" ++ replicate n ' ' ++ "\r")-    modify $ \ state -> state {stateTransientOutput = ""}+    enableLineWrapping :: IO ()+    enableLineWrapping = writePlain "\ESC[?7h" +    clearLine :: IO ()+    clearLine = writePlain "\r\ESC[K"+ -- | Append some output to the report. write :: String -> FormatM ()-write s = do-  h <- getHandle-  liftIO $ IO.hPutStr h s+write = mapM_ writeChunk . splitLines +splitLines :: String -> [String]+splitLines = groupBy (\ a b -> isNewline a == isNewline b)+  where+    isNewline = (== '\n')++writeChunk :: String -> FormatM ()+writeChunk str = do+  let+    plainOutput = writePlain str+    colorOutput color = bracket_ (hSetSGR stdout [color]) (hSetSGR stdout [Reset]) plainOutput+  mColor <- gets stateColor+  liftIO $ case mColor of+    Just (SetColor Foreground _ _) | all isSpace str -> plainOutput+    Just color -> colorOutput color+    Nothing -> plainOutput++writePlain :: String -> IO ()+writePlain = IO.hPutStr stdout+ -- | Set output color to red, run given action, and finally restore the default -- color. withFailColor :: FormatM a -> FormatM a@@ -193,34 +331,28 @@ -- | Set a color, run an action, and finally reset colors. withColor :: SGR -> String -> FormatM a -> FormatM a withColor color cls action = do-  produceHTML <- getConfig formatConfigHtmlOutput+  produceHTML <- getConfigValue formatConfigHtmlOutput   (if produceHTML then htmlSpan cls else withColor_ color) action  htmlSpan :: String -> FormatM a -> FormatM a htmlSpan cls action = write ("<span class=\"" ++ cls ++ "\">") *> action <* write "</span>"  withColor_ :: SGR -> FormatM a -> FormatM a-withColor_ color (FormatM action) = do-  useColor <- getConfig formatConfigUseColor-  h <- getHandle--  FormatM . StateT $ \st -> do-    bracket_--      -- set color-      (when useColor $ hSetSGR h [color])--      -- reset colors-      (when useColor $ hSetSGR h [Reset])+withColor_ color action = do+  oldColor <- gets stateColor+  setColor (Just color) *> action <* setColor oldColor -      -- run action-      (runStateT action st)+setColor :: Maybe SGR -> FormatM ()+setColor color = do+  useColor <- getConfigValue formatConfigUseColor+  when useColor $ do+    modify (\ state -> state { stateColor = color })  -- | Output given chunk in red. extraChunk :: String -> FormatM () extraChunk s = do-  useDiff <- getConfig formatConfigUseDiff-  case useDiff of+  diff <- getConfigValue formatConfigUseDiff+  case diff of     True -> extra s     False -> write s   where@@ -230,8 +362,8 @@ -- | Output given chunk in green. missingChunk :: String -> FormatM () missingChunk s = do-  useDiff <- getConfig formatConfigUseDiff-  case useDiff of+  diff <- getConfigValue formatConfigUseDiff+  case diff of     True -> missing s     False -> write s   where@@ -239,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@@ -251,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/Monad.hs 
@@ -1,260 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE ExistentialQuantification #-}-module Test.Hspec.Core.Formatters.Monad (-  Formatter (..)-, Item(..)-, Result(..)-, FailureReason (..)-, FormatM--, getSuccessCount-, getPendingCount-, getFailCount-, getTotalCount-, getFinalCount--, FailureRecord (..)-, getFailMessages-, usedSeed--, printTimes-, getCPUTime-, getRealTime--, write-, writeLine-, writeTransient--, withInfoColor-, withSuccessColor-, withPendingColor-, withFailColor--, useDiff-, extraChunk-, missingChunk--, Environment(..)-, interpretWith-) where--import           Prelude ()-import           Test.Hspec.Core.Compat--import           Control.Monad.IO.Class--import           Test.Hspec.Core.Formatters.Free-import           Test.Hspec.Core.Clock-import           Test.Hspec.Core.Format--data Formatter = Formatter {---- | evaluated before a test run-  formatterStarted :: FormatM ()---- | evaluated before each spec group-, formatterGroupStarted :: Path -> FormatM ()---- | evaluated after each spec group-, formatterGroupDone :: Path -> FormatM ()---- | used to notify the progress of the currently evaluated example-, formatterProgress :: Path -> Progress -> FormatM ()---- | evaluated before each spec item-, formatterItemStarted :: Path -> FormatM ()---- | evaluated after each spec item-, formatterItemDone :: Path -> Item -> FormatM ()---- | evaluated after a test run-, formatterDone :: FormatM ()-}--data FailureRecord = FailureRecord {-  failureRecordLocation :: Maybe Location-, failureRecordPath     :: Path-, failureRecordMessage  :: FailureReason-}--data FormatF next =-    GetSuccessCount (Int -> next)-  | GetPendingCount (Int -> next)-  | GetFailMessages ([FailureRecord] -> next)-  | GetFinalCount (Int -> next)-  | UsedSeed (Integer -> next)-  | PrintTimes (Bool -> next)-  | GetCPUTime (Maybe Seconds -> next)-  | GetRealTime (Seconds -> next)-  | Write String next-  | WriteTransient String next-  | forall a. WithFailColor (FormatM a) (a -> next)-  | forall a. WithSuccessColor (FormatM a) (a -> next)-  | forall a. WithPendingColor (FormatM a) (a -> next)-  | forall a. WithInfoColor (FormatM a) (a -> next)-  | UseDiff (Bool -> next)-  | ExtraChunk String next-  | MissingChunk String next-  | forall a. LiftIO (IO a) (a -> next)--instance Functor FormatF where -- deriving this instance would require GHC >= 7.10.1-  fmap f x = case x of-    GetSuccessCount next -> GetSuccessCount (fmap f next)-    GetPendingCount next -> GetPendingCount (fmap f next)-    GetFailMessages next -> GetFailMessages (fmap f next)-    GetFinalCount next -> GetFinalCount (fmap f next)-    UsedSeed next -> UsedSeed (fmap f next)-    PrintTimes next -> PrintTimes (fmap f next)-    GetCPUTime next -> GetCPUTime (fmap f next)-    GetRealTime next -> GetRealTime (fmap f next)-    Write s next -> Write s (f next)-    WriteTransient s next -> WriteTransient s (f next)-    WithFailColor action next -> WithFailColor action (fmap f next)-    WithSuccessColor action next -> WithSuccessColor action (fmap f next)-    WithPendingColor action next -> WithPendingColor action (fmap f next)-    WithInfoColor action next -> WithInfoColor action (fmap f next)-    UseDiff next -> UseDiff (fmap f next)-    ExtraChunk s next -> ExtraChunk s (f next)-    MissingChunk s next -> MissingChunk s (f next)-    LiftIO action next -> LiftIO action (fmap f next)--type FormatM = Free FormatF--instance MonadIO FormatM where-  liftIO s = liftF (LiftIO s id)--data Environment m = Environment {-  environmentGetSuccessCount :: m Int-, environmentGetPendingCount :: m Int-, environmentGetFailMessages :: m [FailureRecord]-, environmentGetFinalCount :: m Int-, environmentUsedSeed :: m Integer-, environmentPrintTimes :: m Bool-, environmentGetCPUTime :: m (Maybe Seconds)-, environmentGetRealTime :: m Seconds-, environmentWrite :: String -> m ()-, environmentWriteTransient :: String -> m ()-, environmentWithFailColor :: forall a. m a -> m a-, environmentWithSuccessColor :: forall a. m a -> m a-, environmentWithPendingColor :: forall a. m a -> m a-, environmentWithInfoColor :: forall a. m a -> m a-, environmentUseDiff :: m Bool-, environmentExtraChunk :: String -> m ()-, environmentMissingChunk :: String -> m ()-, environmentLiftIO :: forall a. IO a -> m a-}--interpretWith :: forall m a. Monad m => Environment m -> FormatM a -> m a-interpretWith Environment{..} = go-  where-    go :: forall b. FormatM b -> m b-    go m = case m of-      Pure value -> return value-      Free action -> case action of-        GetSuccessCount next -> environmentGetSuccessCount >>= go . next-        GetPendingCount next -> environmentGetPendingCount >>= go . next-        GetFailMessages next -> environmentGetFailMessages >>= go . next-        GetFinalCount next -> environmentGetFinalCount >>= go . next-        UsedSeed next -> environmentUsedSeed >>= go . next-        PrintTimes next -> environmentPrintTimes >>= go . next-        GetCPUTime next -> environmentGetCPUTime >>= go . next-        GetRealTime next -> environmentGetRealTime >>= go . next-        Write s next -> environmentWrite s >> go next-        WriteTransient s next -> environmentWriteTransient s >> go next-        WithFailColor inner next -> environmentWithFailColor (go inner) >>= go . next-        WithSuccessColor inner next -> environmentWithSuccessColor (go inner) >>= go . next-        WithPendingColor inner next -> environmentWithPendingColor (go inner) >>= go . next-        WithInfoColor inner next -> environmentWithInfoColor (go inner) >>= go . next-        UseDiff next -> environmentUseDiff >>= go . next-        ExtraChunk s next -> environmentExtraChunk s >> go next-        MissingChunk s next -> environmentMissingChunk s >> go next-        LiftIO inner next -> environmentLiftIO inner >>= go . next---- | Get the number of successful examples encountered so far.-getSuccessCount :: FormatM Int-getSuccessCount = liftF (GetSuccessCount id)---- | Get the number of pending examples encountered so far.-getPendingCount :: FormatM Int-getPendingCount = liftF (GetPendingCount id)---- | Get the number of failed examples encountered so far.-getFailCount :: FormatM Int-getFailCount = length <$> getFailMessages---- | Get the total number of examples encountered so far.-getTotalCount :: FormatM Int-getTotalCount = sum <$> sequence [getSuccessCount, getFailCount, getPendingCount]---- | Get the number of spec items that will have been encountered when this run--- completes (if it is not terminated early).-getFinalCount :: FormatM Int-getFinalCount = liftF (GetFinalCount id)---- | Get the list of accumulated failure messages.-getFailMessages :: FormatM [FailureRecord]-getFailMessages = liftF (GetFailMessages id)---- | The random seed that is used for QuickCheck.-usedSeed :: FormatM Integer-usedSeed = liftF (UsedSeed id)---- | Return `True` if the user requested time reporting for individual spec--- items, `False` otherwise.-printTimes :: FormatM Bool-printTimes = liftF (PrintTimes id)---- | Get the used CPU time since the test run has been started.-getCPUTime :: FormatM (Maybe Seconds)-getCPUTime = liftF (GetCPUTime id)---- | Get the passed real time since the test run has been started.-getRealTime :: FormatM Seconds-getRealTime = liftF (GetRealTime id)---- | Append some output to the report.-write :: String -> FormatM ()-write s = liftF (Write s ())---- | The same as `write`, but adds a newline character.-writeLine :: String -> FormatM ()-writeLine s = write s >> write "\n"--writeTransient :: String -> FormatM ()-writeTransient s = liftF (WriteTransient s ())---- | Set output color to red, run given action, and finally restore the default--- color.-withFailColor :: FormatM a -> FormatM a-withFailColor s = liftF (WithFailColor s id)---- | Set output color to green, run given action, and finally restore the--- default color.-withSuccessColor :: FormatM a -> FormatM a-withSuccessColor s = liftF (WithSuccessColor s id)---- | Set output color to yellow, run given action, and finally restore the--- default color.-withPendingColor :: FormatM a -> FormatM a-withPendingColor s = liftF (WithPendingColor s id)---- | Set output color to cyan, run given action, and finally restore the--- default color.-withInfoColor :: FormatM a -> FormatM a-withInfoColor s = liftF (WithInfoColor s id)---- | Return `True` if the user requested colorized diffs, `False` otherwise.-useDiff :: FormatM Bool-useDiff = liftF (UseDiff id)---- | Output given chunk in red.-extraChunk :: String -> FormatM ()-extraChunk s = liftF (ExtraChunk s ())---- | Output given chunk in green.-missingChunk :: String -> FormatM ()-missingChunk s = liftF (MissingChunk s ())
+ src/Test/Hspec/Core/Formatters/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,297 +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.Monad (-    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.Spec (Progress)-import           Test.Hspec.Core.Format (FormatConfig, Format, Item(..), Result(..))-import qualified Test.Hspec.Core.Formatters.V2 as V2--import           Test.Hspec.Core.Formatters.Diff--formatterToFormat :: Formatter -> FormatConfig -> IO Format-formatterToFormat Formatter{..} = V2.formatterToFormat V2.Formatter {-  V2.formatterStarted = headerFormatter-, V2.formatterGroupStarted = uncurry exampleGroupStarted-, V2.formatterGroupDone = \ _ -> exampleGroupDone-, V2.formatterProgress = exampleProgress-, V2.formatterItemStarted = exampleStarted-, V2.formatterItemDone = \ path item -> 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 = failedFormatter >> footerFormatter-}--data Formatter = Formatter {--  headerFormatter :: FormatM ()---- | evaluated before each test group-, exampleGroupStarted :: [String] -> String -> FormatM ()---- | evaluated after each test group-, exampleGroupDone :: FormatM ()---- | evaluated before each example-, exampleStarted :: Path -> FormatM ()---- | used to notify the progress of the currently evaluated example-, exampleProgress :: Path -> Progress -> FormatM ()---- | evaluated after each successful example-, exampleSucceeded :: Path -> String -> FormatM ()---- | evaluated after each failed example-, exampleFailed :: Path -> String -> FailureReason -> FormatM ()---- | evaluated after each pending example-, examplePending :: Path -> String -> Maybe String -> FormatM ()---- | evaluated after a test run-, failedFormatter :: FormatM ()---- | evaluated after `failedFormatter`-, footerFormatter :: FormatM ()-}--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/Free.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE DeriveFunctor #-}+module Test.Hspec.Core.Formatters.V1.Free where++import           Prelude ()+import           Test.Hspec.Core.Compat++data Free f a = Free (f (Free f a)) | Pure a+  deriving Functor++instance Functor f => Applicative (Free f) where+  pure = Pure+  Pure f <*> Pure a = Pure (f a)+  Pure f <*> Free m = Free (fmap f <$> m)+  Free m <*> b = Free (fmap (<*> b) m)++instance Functor f => Monad (Free f) where+  return = pure+  Pure a >>= f = f a+  Free m >>= f = Free (fmap (>>= f) m)++liftF :: Functor f => f a -> Free f a+liftF command = Free (fmap Pure command)
+ src/Test/Hspec/Core/Formatters/V1/Internal.hs view
@@ -0,0 +1,357 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE LambdaCase #-}+module Test.Hspec.Core.Formatters.V1.Internal (+-- * Formatters+  silent+, checks+, specdoc+, progress+, failed_examples++-- * Implementing a custom Formatter+-- |+-- A formatter is a set of actions.  Each action is evaluated when a certain+-- situation is encountered during a test run.+--+-- Actions live in the `FormatM` monad.  It provides access to the runner state+-- and primitives for appending to the generated report.+, Formatter (..)+, FailureReason (..)+, FormatM+, formatterToFormat++-- ** Accessing the runner state+, getSuccessCount+, getPendingCount+, getFailCount+, getTotalCount++, FailureRecord (..)+, getFailMessages+, usedSeed++, Seconds(..)+, getCPUTime+, getRealTime++-- ** Appending to the generated report+, write+, writeLine+, writeTransient++-- ** Dealing with colors+, withInfoColor+, withSuccessColor+, withPendingColor+, withFailColor++, useDiff+, extraChunk+, missingChunk++-- ** Helpers+, formatException+) where++import           Prelude ()+import           Test.Hspec.Core.Compat++import           Test.Hspec.Core.Util+import           Test.Hspec.Core.Clock+import           Test.Hspec.Core.Example (Location(..))+import           Text.Printf+import           Control.Monad.IO.Class++-- We use an explicit import list for "Test.Hspec.Formatters.Internal", to make+-- sure, that we only use the public API to implement formatters.+--+-- Everything imported here has to be re-exported, so that users can implement+-- their own formatters.+import Test.Hspec.Core.Formatters.V1.Monad (+    Formatter(..)+  , FailureReason(..)+  , FormatM++  , getSuccessCount+  , getPendingCount+  , getFailCount+  , getTotalCount++  , FailureRecord(..)+  , getFailMessages+  , usedSeed++  , getCPUTime+  , getRealTime++  , write+  , writeLine+  , writeTransient++  , withInfoColor+  , withSuccessColor+  , withPendingColor+  , withFailColor++  , useDiff+  , extraChunk+  , missingChunk+  )++import           Test.Hspec.Core.Format (FormatConfig, Format)++import           Test.Hspec.Core.Formatters.Diff+import qualified Test.Hspec.Core.Formatters.V2 as V2+import           Test.Hspec.Core.Formatters.V1.Monad (Item(..), Result(..), Environment(..), interpretWith)++formatterToFormat :: Formatter -> FormatConfig -> IO Format+formatterToFormat = V2.formatterToFormat . legacyFormatterToFormatter++legacyFormatterToFormatter :: Formatter -> V2.Formatter+legacyFormatterToFormatter Formatter{..} = V2.Formatter {+  V2.formatterStarted = interpret headerFormatter+, V2.formatterGroupStarted = interpret . uncurry exampleGroupStarted+, V2.formatterGroupDone = interpret . const exampleGroupDone+, V2.formatterProgress = \ path -> interpret . exampleProgress path+, V2.formatterItemStarted = interpret . exampleStarted+, V2.formatterItemDone = \ path item -> interpret $ do+    case itemResult item of+      Success -> exampleSucceeded path (itemInfo item)+      Pending _ reason -> examplePending path (itemInfo item) reason+      Failure _ reason -> exampleFailed path (itemInfo item) (unliftFailureReason reason)+, V2.formatterDone = interpret $ failedFormatter >> footerFormatter+}++unliftFailureRecord :: V2.FailureRecord -> FailureRecord+unliftFailureRecord V2.FailureRecord{..} = FailureRecord {+  failureRecordLocation+, failureRecordPath+, failureRecordMessage = unliftFailureReason failureRecordMessage+}++unliftFailureReason :: V2.FailureReason -> FailureReason+unliftFailureReason = \ case+  V2.NoReason -> NoReason+  V2.Reason reason -> Reason reason+  V2.ColorizedReason reason -> Reason (stripAnsi reason)+  V2.ExpectedButGot preface expected actual -> ExpectedButGot preface expected actual+  V2.Error info e -> Error info e++interpret :: FormatM a -> V2.FormatM a+interpret = interpretWith Environment {+  environmentGetSuccessCount = V2.getSuccessCount+, environmentGetPendingCount = V2.getPendingCount+, environmentGetFailMessages = map unliftFailureRecord <$> V2.getFailMessages+, environmentUsedSeed = V2.usedSeed+, environmentPrintTimes = V2.printTimes+, environmentGetCPUTime = V2.getCPUTime+, environmentGetRealTime = V2.getRealTime+, environmentWrite = V2.write+, environmentWriteTransient = V2.writeTransient+, environmentWithFailColor = V2.withFailColor+, environmentWithSuccessColor = V2.withSuccessColor+, environmentWithPendingColor = V2.withPendingColor+, environmentWithInfoColor = V2.withInfoColor+, environmentUseDiff = V2.useDiff+, environmentExtraChunk = V2.extraChunk+, environmentMissingChunk = V2.missingChunk+, environmentLiftIO = liftIO+}++silent :: Formatter+silent = Formatter {+  headerFormatter     = pass+, exampleGroupStarted = \_ _ -> pass+, exampleGroupDone    = pass+, exampleStarted      = \_ -> pass+, exampleProgress     = \_ _ -> pass+, exampleSucceeded    = \ _ _ -> pass+, exampleFailed       = \_ _ _ -> pass+, examplePending      = \_ _ _ -> pass+, failedFormatter     = pass+, footerFormatter     = pass+}++checks :: Formatter+checks = specdoc {+  exampleStarted = \(nesting, requirement) -> do+    writeTransient $ indentationFor nesting ++ requirement ++ " [ ]"++, exampleProgress = \(nesting, requirement) p -> do+    writeTransient $ indentationFor nesting ++ requirement ++ " [" ++ (formatProgress p) ++ "]"++, exampleSucceeded = \(nesting, requirement) info -> do+    writeResult nesting requirement info $ withSuccessColor $ write "✔"++, exampleFailed = \(nesting, requirement) info _ -> do+    writeResult nesting requirement info $ withFailColor $ write "✘"++, examplePending = \(nesting, requirement) info reason -> do+    writeResult nesting requirement info $ withPendingColor $ write "‐"++    withPendingColor $ do+      writeLine $ indentationFor ("" : nesting) ++ "# PENDING: " ++ fromMaybe "No reason given" reason+} where+    indentationFor nesting = replicate (length nesting * 2) ' '++    writeResult :: [String] -> String -> String -> FormatM () -> FormatM ()+    writeResult nesting requirement info action = do+      write $ indentationFor nesting ++ requirement ++ " ["+      action+      writeLine "]"+      forM_ (lines info) $ \ s ->+        writeLine $ indentationFor ("" : nesting) ++ s++    formatProgress (current, total)+      | total == 0 = show current+      | otherwise  = show current ++ "/" ++ show total++specdoc :: Formatter+specdoc = silent {++  headerFormatter = do+    writeLine ""++, exampleGroupStarted = \nesting name -> do+    writeLine (indentationFor nesting ++ name)++, exampleProgress = \_ p -> do+    writeTransient (formatProgress p)++, exampleSucceeded = \(nesting, requirement) info -> withSuccessColor $ do+    writeLine $ indentationFor nesting ++ requirement+    forM_ (lines info) $ \ s ->+      writeLine $ indentationFor ("" : nesting) ++ s++, exampleFailed = \(nesting, requirement) info _ -> withFailColor $ do+    n <- getFailCount+    writeLine $ indentationFor nesting ++ requirement ++ " FAILED [" ++ show n ++ "]"+    forM_ (lines info) $ \ s ->+      writeLine $ indentationFor ("" : nesting) ++ s++, examplePending = \(nesting, requirement) info reason -> withPendingColor $ do+    writeLine $ indentationFor nesting ++ requirement+    forM_ (lines info) $ \ s ->+      writeLine $ indentationFor ("" : nesting) ++ s+    writeLine $ indentationFor ("" : nesting) ++ "# PENDING: " ++ fromMaybe "No reason given" reason++, failedFormatter = defaultFailedFormatter++, footerFormatter = defaultFooter+} where+    indentationFor nesting = replicate (length nesting * 2) ' '+    formatProgress (current, total)+      | total == 0 = show current+      | otherwise  = show current ++ "/" ++ show total+++progress :: Formatter+progress = silent {+  exampleSucceeded = \_ _ -> withSuccessColor $ write "."+, exampleFailed    = \_ _ _ -> withFailColor    $ write "F"+, examplePending   = \_ _ _ -> withPendingColor $ write "."+, failedFormatter  = defaultFailedFormatter+, footerFormatter  = defaultFooter+}+++failed_examples :: Formatter+failed_examples   = silent {+  failedFormatter = defaultFailedFormatter+, footerFormatter = defaultFooter+}++defaultFailedFormatter :: FormatM ()+defaultFailedFormatter = do+  writeLine ""++  failures <- getFailMessages++  unless (null failures) $ do+    writeLine "Failures:"+    writeLine ""++    forM_ (zip [1..] failures) $ \x -> do+      formatFailure x+      writeLine ""++    write "Randomized with seed " >> usedSeed >>= writeLine . show+    writeLine ""+  where+    formatFailure :: (Int, FailureRecord) -> FormatM ()+    formatFailure (n, FailureRecord mLoc path reason) = do+      forM_ mLoc $ \loc -> do+        withInfoColor $ writeLine (formatLoc loc)+      write ("  " ++ show n ++ ") ")+      writeLine (formatRequirement path)+      case reason of+        NoReason -> pass+        Reason err -> withFailColor $ indent err+        ExpectedButGot preface expected actual -> do+          mapM_ indent preface++          b <- useDiff++          let threshold = 2 :: Seconds++          mchunks <- liftIO $ if b+            then timeout threshold (evaluate $ diff expected actual)+            else return Nothing++          case mchunks of+            Just chunks -> do+              writeDiff chunks extraChunk missingChunk+            Nothing -> do+              writeDiff [First expected, Second actual] write write+          where+            indented output text = case break (== '\n') text of+              (xs, "") -> output xs+              (xs, _ : ys) -> output (xs ++ "\n") >> write (indentation ++ "          ") >> indented output ys++            writeDiff chunks extra missing = do+              withFailColor $ write (indentation ++ "expected: ")+              forM_ chunks $ \ case+                Both a -> indented write a+                First a -> indented extra a+                Second _ -> pass+              writeLine ""++              withFailColor $ write (indentation ++ " but got: ")+              forM_ chunks $ \ case+                Both a -> indented write a+                First _ -> pass+                Second a -> indented missing a+              writeLine ""++        Error _ e -> withFailColor . indent $ (("uncaught exception: " ++) . formatException) e++      writeLine ""+      writeLine ("  To rerun use: --match " ++ show (joinPath path))+      where+        indentation = "       "+        indent message = do+          forM_ (lines message) $ \line -> do+            writeLine (indentation ++ line)+        formatLoc (Location file line column) = "  " ++ file ++ ":" ++ show line ++ ":" ++ show column ++ ": "++defaultFooter :: FormatM ()+defaultFooter = do++  writeLine =<< (++)+    <$> (printf "Finished in %1.4f seconds" <$> getRealTime)+    <*> (maybe "" (printf ", used %1.4f seconds of CPU time") <$> getCPUTime)++  fails   <- getFailCount+  pending <- getPendingCount+  total   <- getTotalCount++  let+    output =+         pluralize total   "example"+      ++ ", " ++ pluralize fails "failure"+      ++ if pending == 0 then "" else ", " ++ show pending ++ " pending"+    c | fails /= 0   = withFailColor+      | pending /= 0 = withPendingColor+      | otherwise    = withSuccessColor+  c $ writeLine output
+ src/Test/Hspec/Core/Formatters/V1/Monad.hs view
@@ -0,0 +1,264 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ExistentialQuantification #-}+module Test.Hspec.Core.Formatters.V1.Monad (+  Formatter(..)+, Item(..)+, Result(..)+, FailureReason (..)+, FormatM++, getSuccessCount+, getPendingCount+, getFailCount+, getTotalCount++, FailureRecord (..)+, getFailMessages+, usedSeed++, printTimes+, getCPUTime+, getRealTime++, write+, writeLine+, writeTransient++, withInfoColor+, withSuccessColor+, withPendingColor+, withFailColor++, useDiff+, extraChunk+, missingChunk++, Environment(..)+, interpretWith+) where++import           Prelude ()+import           Test.Hspec.Core.Compat++import           Control.Monad.IO.Class++import           Test.Hspec.Core.Formatters.V1.Free+import           Test.Hspec.Core.Clock+import           Test.Hspec.Core.Format hiding (FailureReason)++data FailureReason =+    NoReason+  | Reason String+  | ExpectedButGot (Maybe String) String String+  | Error (Maybe String) SomeException+  deriving Show++data Formatter = Formatter {++  headerFormatter :: FormatM ()++-- | evaluated before each test group+, exampleGroupStarted :: [String] -> String -> FormatM ()++-- | evaluated after each test group+, exampleGroupDone :: FormatM ()++-- | evaluated before each example+, exampleStarted :: Path -> FormatM ()++-- | used to notify the progress of the currently evaluated example+, exampleProgress :: Path -> Progress -> FormatM ()++-- | evaluated after each successful example+, exampleSucceeded :: Path -> String -> FormatM ()++-- | evaluated after each failed example+, exampleFailed :: Path -> String -> FailureReason -> FormatM ()++-- | evaluated after each pending example+, examplePending :: Path -> String -> Maybe String -> FormatM ()++-- | evaluated after a test run+, failedFormatter :: FormatM ()++-- | evaluated after `failedFormatter`+, footerFormatter :: FormatM ()+}++data FailureRecord = FailureRecord {+  failureRecordLocation :: Maybe Location+, failureRecordPath     :: Path+, failureRecordMessage  :: FailureReason+}++data FormatF next =+    GetSuccessCount (Int -> next)+  | GetPendingCount (Int -> next)+  | GetFailMessages ([FailureRecord] -> next)+  | UsedSeed (Integer -> next)+  | PrintTimes (Bool -> next)+  | GetCPUTime (Maybe Seconds -> next)+  | GetRealTime (Seconds -> next)+  | Write String next+  | WriteTransient String next+  | forall a. WithFailColor (FormatM a) (a -> next)+  | forall a. WithSuccessColor (FormatM a) (a -> next)+  | forall a. WithPendingColor (FormatM a) (a -> next)+  | forall a. WithInfoColor (FormatM a) (a -> next)+  | UseDiff (Bool -> next)+  | ExtraChunk String next+  | MissingChunk String next+  | forall a. LiftIO (IO a) (a -> next)++instance Functor FormatF where -- deriving this instance would require GHC >= 7.10.1+  fmap f x = case x of+    GetSuccessCount next -> GetSuccessCount (fmap f next)+    GetPendingCount next -> GetPendingCount (fmap f next)+    GetFailMessages next -> GetFailMessages (fmap f next)+    UsedSeed next -> UsedSeed (fmap f next)+    PrintTimes next -> PrintTimes (fmap f next)+    GetCPUTime next -> GetCPUTime (fmap f next)+    GetRealTime next -> GetRealTime (fmap f next)+    Write s next -> Write s (f next)+    WriteTransient s next -> WriteTransient s (f next)+    WithFailColor action next -> WithFailColor action (fmap f next)+    WithSuccessColor action next -> WithSuccessColor action (fmap f next)+    WithPendingColor action next -> WithPendingColor action (fmap f next)+    WithInfoColor action next -> WithInfoColor action (fmap f next)+    UseDiff next -> UseDiff (fmap f next)+    ExtraChunk s next -> ExtraChunk s (f next)+    MissingChunk s next -> MissingChunk s (f next)+    LiftIO action next -> LiftIO action (fmap f next)++type FormatM = Free FormatF++instance MonadIO FormatM where+  liftIO s = liftF (LiftIO s id)++data Environment m = Environment {+  environmentGetSuccessCount :: m Int+, environmentGetPendingCount :: m Int+, environmentGetFailMessages :: m [FailureRecord]+, environmentUsedSeed :: m Integer+, environmentPrintTimes :: m Bool+, environmentGetCPUTime :: m (Maybe Seconds)+, environmentGetRealTime :: m Seconds+, environmentWrite :: String -> m ()+, environmentWriteTransient :: String -> m ()+, environmentWithFailColor :: forall a. m a -> m a+, environmentWithSuccessColor :: forall a. m a -> m a+, environmentWithPendingColor :: forall a. m a -> m a+, environmentWithInfoColor :: forall a. m a -> m a+, environmentUseDiff :: m Bool+, environmentExtraChunk :: String -> m ()+, environmentMissingChunk :: String -> m ()+, environmentLiftIO :: forall a. IO a -> m a+}++interpretWith :: forall m a. Monad m => Environment m -> FormatM a -> m a+interpretWith Environment{..} = go+  where+    go :: forall b. FormatM b -> m b+    go m = case m of+      Pure value -> return value+      Free action -> case action of+        GetSuccessCount next -> environmentGetSuccessCount >>= go . next+        GetPendingCount next -> environmentGetPendingCount >>= go . next+        GetFailMessages next -> environmentGetFailMessages >>= go . next+        UsedSeed next -> environmentUsedSeed >>= go . next+        PrintTimes next -> environmentPrintTimes >>= go . next+        GetCPUTime next -> environmentGetCPUTime >>= go . next+        GetRealTime next -> environmentGetRealTime >>= go . next+        Write s next -> environmentWrite s >> go next+        WriteTransient s next -> environmentWriteTransient s >> go next+        WithFailColor inner next -> environmentWithFailColor (go inner) >>= go . next+        WithSuccessColor inner next -> environmentWithSuccessColor (go inner) >>= go . next+        WithPendingColor inner next -> environmentWithPendingColor (go inner) >>= go . next+        WithInfoColor inner next -> environmentWithInfoColor (go inner) >>= go . next+        UseDiff next -> environmentUseDiff >>= go . next+        ExtraChunk s next -> environmentExtraChunk s >> go next+        MissingChunk s next -> environmentMissingChunk s >> go next+        LiftIO inner next -> environmentLiftIO inner >>= go . next++-- | Get the number of successful examples encountered so far.+getSuccessCount :: FormatM Int+getSuccessCount = liftF (GetSuccessCount id)++-- | Get the number of pending examples encountered so far.+getPendingCount :: FormatM Int+getPendingCount = liftF (GetPendingCount id)++-- | Get the number of failed examples encountered so far.+getFailCount :: FormatM Int+getFailCount = length <$> getFailMessages++-- | Get the total number of examples encountered so far.+getTotalCount :: FormatM Int+getTotalCount = sum <$> sequence [getSuccessCount, getFailCount, getPendingCount]++-- | Get the list of accumulated failure messages.+getFailMessages :: FormatM [FailureRecord]+getFailMessages = liftF (GetFailMessages id)++-- | The random seed that is used for QuickCheck.+usedSeed :: FormatM Integer+usedSeed = liftF (UsedSeed id)++-- | Return `True` if the user requested time reporting for individual spec+-- items, `False` otherwise.+printTimes :: FormatM Bool+printTimes = liftF (PrintTimes id)++-- | Get the used CPU time since the test run has been started.+getCPUTime :: FormatM (Maybe Seconds)+getCPUTime = liftF (GetCPUTime id)++-- | Get the passed real time since the test run has been started.+getRealTime :: FormatM Seconds+getRealTime = liftF (GetRealTime id)++-- | Append some output to the report.+write :: String -> FormatM ()+write s = liftF (Write s ())++-- | The same as `write`, but adds a newline character.+writeLine :: String -> FormatM ()+writeLine s = write s >> write "\n"++writeTransient :: String -> FormatM ()+writeTransient s = liftF (WriteTransient s ())++-- | Set output color to red, run given action, and finally restore the default+-- color.+withFailColor :: FormatM a -> FormatM a+withFailColor s = liftF (WithFailColor s id)++-- | Set output color to green, run given action, and finally restore the+-- default color.+withSuccessColor :: FormatM a -> FormatM a+withSuccessColor s = liftF (WithSuccessColor s id)++-- | Set output color to yellow, run given action, and finally restore the+-- default color.+withPendingColor :: FormatM a -> FormatM a+withPendingColor s = liftF (WithPendingColor s id)++-- | Set output color to cyan, run given action, and finally restore the+-- default color.+withInfoColor :: FormatM a -> FormatM a+withInfoColor s = liftF (WithInfoColor s id)++-- | Return `True` if the user requested colorized diffs, `False` otherwise.+useDiff :: FormatM Bool+useDiff = liftF (UseDiff id)++-- | Output given chunk in red.+extraChunk :: String -> FormatM ()+extraChunk s = liftF (ExtraChunk s ())++-- | Output given chunk in green.+missingChunk :: String -> FormatM ()+missingChunk s = liftF (MissingChunk s ())
src/Test/Hspec/Core/Formatters/V2.hs view
@@ -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,17 +24,26 @@ -- Actions live in the `FormatM` monad.  It provides access to the runner state -- and primitives for appending to the generated report. , Formatter (..)+, Path+, Progress+, Location(..) , Item(..) , Result(..) , FailureReason (..) , FormatM , formatterToFormat +-- ** Accessing config values+, getConfig+, getConfigValue+, FormatConfig(..)+ -- ** Accessing the runner state , getSuccessCount , getPendingCount , getFailCount , getTotalCount+, getExpectedTotalCount  , FailureRecord (..) , getFailMessages@@ -54,42 +66,63 @@ , withPendingColor , withFailColor +, outputUnicode+ , useDiff+, diffContext+, externalDiffAction+, prettyPrint+, prettyPrintFunction , extraChunk , missingChunk +-- ** expert mode+, unlessExpert+ -- ** Helpers , formatLocation-, formatException+, Util.formatException++#ifdef TEST+, Chunk(..)+, ColorChunk(..)+#endif ) where  import           Prelude ()-import           Test.Hspec.Core.Compat hiding (First)+import           Test.Hspec.Core.Compat+import           System.IO (hFlush, stdout) -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           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. -- -- Everything imported here has to be re-exported, so that users can implement -- their own formatters.-import Test.Hspec.Core.Formatters.Monad (-    Formatter (..)+import Test.Hspec.Core.Formatters.Internal (+    Formatter(..)   , Item(..)   , Result(..)   , FailureReason (..)   , FormatM+  , formatterToFormat +  , getConfig+  , getConfigValue+  , FormatConfig(..)+   , getSuccessCount   , getPendingCount   , getFailCount   , getTotalCount+  , getExpectedTotalCount    , FailureRecord (..)   , getFailMessages@@ -108,43 +141,52 @@   , withPendingColor   , withFailColor +  , outputUnicode+   , useDiff+  , diffContext+  , externalDiffAction+  , prettyPrint+  , prettyPrintFunction   , extraChunk   , missingChunk++  , unlessExpert   ) -import           Test.Hspec.Core.Formatters.Internal (formatterToFormat) 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 ++ " [ ]"  , formatterItemDone = \ (nesting, requirement) item -> do+    unicode <- outputUnicode+    let fallback a b = if unicode then a else b     uncurry (writeResult nesting requirement (itemDuration item) (itemInfo item)) $ case itemResult item of-      Success {} -> (withSuccessColor, "✔")-      Pending {} -> (withPendingColor, "‐")-      Failure {} -> (withFailColor, "✘")+      Success {} -> (withSuccessColor, fallback "✔" "v")+      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) ' ' @@ -154,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@@ -189,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@@ -201,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)@@ -217,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@@ -247,59 +289,126 @@   where     formatFailure :: (Int, FailureRecord) -> FormatM ()     formatFailure (n, FailureRecord mLoc path reason) = do+      unicode <- outputUnicode       forM_ mLoc $ \loc -> do         withInfoColor $ writeLine ("  " ++ formatLocation loc)       write ("  " ++ show n ++ ") ")       writeLine (formatRequirement path)       case reason of-        NoReason -> return ()+        NoReason -> pass         Reason err -> withFailColor $ indent err-        ExpectedButGot preface expected actual -> do+        ColorizedReason err -> indent err+        ExpectedButGot preface expected_ actual_ -> do+          pretty <- prettyPrintFunction+          let+            (expected, actual) = case pretty of+              Just f -> f expected_ actual_+              Nothing -> (expected_, actual_)+           mapM_ indent preface            b <- useDiff            let threshold = 2 :: Seconds -          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-          where-            indented output text = case break (== '\n') text of-              (xs, "") -> output xs-              (xs, _ : ys) -> output (xs ++ "\n") >> write (indentation ++ "          ") >> indented output ys+              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-              withFailColor $ write (indentation ++ "expected: ")-              forM_ chunks $ \ chunk -> case chunk of-                Both a _ -> indented write a-                First a -> indented extra a-                Second _ -> return ()-              writeLine ""+              writeChunks "expected: " (expectedChunks chunks) extra+              writeChunks " but got: " (actualChunks chunks) missing -              withFailColor $ write (indentation ++ " but got: ")-              forM_ chunks $ \ chunk -> case chunk of-                Both a _ -> indented write a-                First _ -> return ()-                Second a -> indented missing a-              writeLine ""+            writeChunks :: String -> [Chunk] -> (String -> FormatM ()) -> FormatM ()+            writeChunks pre chunks colorize = do+              withFailColor $ write (indentation ++ pre)+              go pass chunks+              where+                indentation_ :: [Char]+                indentation_ = indentation ++ replicate (length pre) ' ' -        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 ""-      writeLine ("  To rerun use: --match " ++ show (joinPath path))+        Error info e -> do+          mapM_ indent info+          formatException <- getConfigValue formatConfigFormatException+          withFailColor . indent $ "uncaught exception: " ++ formatException e+++      unlessExpert $ do+        let path_ = (if unicode then ushow else show) (joinPath path)+        writeLine ""+        seed <- usedSeed+        writeLine ("  To rerun use: --match " ++ path_ <> " --seed " <> show seed)       where         indentation = "       "-        indent message = do-          forM_ (lines message) $ \line -> do-            writeLine (indentation ++ line)+        indent = indentBy indentation +indentBy :: String -> String -> FormatM ()+indentBy indentation message = do+  forM_ (lines message) $ \ line -> do+    writeLine (indentation ++ line)++data Chunk = Original String | Modified String | Info String | ModifiedChunks [ColorChunk]+  deriving (Eq, Show)++expectedChunks :: [LineDiff] -> [Chunk]+expectedChunks = concatMap $ \ case+  LinesBoth a -> map Original a+  LinesFirst a -> map Modified a+  LinesSecond _ -> []+  LinesOmitted n -> [Info $ formatOmittedLines n]+  SingleLineDiff diffs -> return . ModifiedChunks . flip mapMaybe diffs $ \ case+    First a -> Just $ ColorChunk a+    Second _ -> Nothing+    Both a -> Just $ PlainChunk a++actualChunks :: [LineDiff] -> [Chunk]+actualChunks = concatMap $ \ case+  LinesBoth a -> map Original a+  LinesFirst _ -> []+  LinesSecond a -> map Modified a+  LinesOmitted n -> [Info $ formatOmittedLines n]+  SingleLineDiff diffs -> return . ModifiedChunks . flip mapMaybe diffs $ \ case+    First _ -> Nothing+    Second a -> Just $ ColorChunk a+    Both a -> Just $ PlainChunk a++data ColorChunk = PlainChunk String | ColorChunk String+  deriving (Eq, Show)++formatOmittedLines :: Int -> String+formatOmittedLines n = "@@ " <> show n <> " lines omitted @@"+ defaultFooter :: FormatM () defaultFooter = do @@ -316,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,69 +1,153 @@+{-# OPTIONS_GHC -fno-warn-deprecations #-} {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | -- Stability: provisional module Test.Hspec.Core.Runner (--- * Running a spec+-- * Simple interface   hspec-, runSpec+, hspecWith+, hspecResult+, hspecWithResult +-- ** Summary+, Summary (..)+, isSuccess+, evaluateSummary++-- * Running a spec+{- |+To run a spec `hspec` performs a sequence of steps:++1. Evaluate a `Spec` to a forest of `SpecTree`s+1. Read config values from the command-line, config files and the process environment+1. Execute each spec item of the forest and report results to `stdout`+1. Exit with `exitFailure` if at least on spec item fails++The four primitives `evalSpec`, `readConfig`, `runSpecForest` and+`evaluateResult` each perform one of these steps respectively.++`hspec` is defined in terms of these primitives. Loosely speaking, a definition+for @hspec@ is:++@+hspec = `evalSpec` `defaultConfig` >=> \\ (config, spec) ->+      `getArgs`+  >>= `readConfig` config+  >>= `withArgs` [] . `runSpecForest` spec+  >>= `evaluateResult`+@++Loosely speaking in the sense that this definition of @hspec@ ignores+@--rerun-all-on-success@.++Using these primitives individually gives you more control over how a spec is+run.  However, if you need support for @--rerun-all-on-success@ then you should+try hard to solve your use case with one of `hspec`, `hspecWith`, `hspecResult`+or `hspecWithResult`.++-}+, evalSpec+, runSpecForest+, evaluateResult++-- ** Result++-- *** Spec Result+, Test.Hspec.Core.Runner.Result.SpecResult+, Test.Hspec.Core.Runner.Result.specResultItems+, Test.Hspec.Core.Runner.Result.specResultSuccess+, toSummary++-- *** Result Item+, Test.Hspec.Core.Runner.Result.ResultItem+, Test.Hspec.Core.Runner.Result.resultItemPath+, Test.Hspec.Core.Runner.Result.resultItemStatus+, Test.Hspec.Core.Runner.Result.resultItemIsFailure++-- *** Result Item Status+, Test.Hspec.Core.Runner.Result.ResultItemStatus(..)+ -- * Config , Config (..) , ColorMode (..)+, UnicodeMode(..) , Path , defaultConfig+, registerFormatter+, registerDefaultFormatter , configAddFilter , readConfig --- * Summary-, Summary (..)-, isSuccess-, evaluateSummary- -- * Legacy--- | The following primitives are deprecated.  Use `runSpec` instead.-, hspecWith-, hspecResult-, hspecWithResult+, runSpec +-- * Re-exports+, Spec+, SpecWith+ #ifdef TEST+, UseColor(..)+, ProgressReporting(..) , rerunAll , specToEvalForest , colorOutputSupported+, unicodeOutputSupported #endif ) where  import           Prelude ()-import           Test.Hspec.Core.Compat+import           Test.Hspec.Core.Compat hiding (unicodeOutputSupported)+import qualified Test.Hspec.Core.Compat as Compat -import           Data.Maybe+import           Data.List.NonEmpty (nonEmpty) import           System.IO import           System.Environment (getArgs, withArgs)-import           System.Exit-import qualified Control.Exception as E+import           System.Exit (exitFailure) import           System.Random import           Control.Monad.ST import           Data.STRef-import           System.Console.ANSI (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@@ -77,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. --@@ -139,94 +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+runSpecForest_ :: Maybe FailureReport -> [SpecTree ()] -> Config -> IO SpecResult+runSpecForest_ oldFailureReport spec c_ = do++  (config, seed) <- ensureSeed (applyFailureReport oldFailureReport c_)++  colorMode <- colorOutputSupported (configColorMode config) (hSupportsANSI stdout)+  outputUnicode <- unicodeOutputSupported (configUnicodeMode config) stdout+   let-      seed = (fromJust . configQuickCheckSeed) config-      qcArgs = configQuickCheckArgs config-      !numberOfItems = countSpecItems filteredSpec+    filteredSpec = specToEvalForest seed config spec+    qcArgs = configQuickCheckArgs config+    !numberOfItems = countEvalItems filteredSpec -  concurrentJobs <- case configConcurrentJobs config of-    Nothing -> getDefaultConcurrentJobs-    Just n -> return n+  when (configFailOnEmpty config && numberOfItems == 0) $ do+    when (countSpecItems spec /= 0) $ do+      die "all spec items have been filtered; failing due to --fail-on=empty" -  useColor <- colorOutputSupported (configColorMode config) (hSupportsANSI stdout)+  concurrentJobs <- maybe getDefaultConcurrentJobs return $ configConcurrentJobs config -  results <- withHiddenCursor useColor stdout $ do+  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-      , formatConfigItemCount = numberOfItems+      , formatConfigExpectedTotalCount = numberOfItems+      , formatConfigExpertMode = configExpertMode config       } -      formatter = fromMaybe (V2.formatterToFormat V2.specdoc) (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 @@ -234,35 +402,64 @@       evalConfig = EvalConfig {         evalConfigFormat = format       , evalConfigConcurrentJobs = concurrentJobs-      , evalConfigFastFail = configFastFail config+      , 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 ()@@ -280,51 +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) -noColor :: IO Bool-noColor = lookupEnv "NO_COLOR" <&> (/= Nothing)+data ProgressReporting = ProgressReportingDisabled | ProgressReportingEnabled+  deriving (Eq, Show) -rerunAll :: Config -> Maybe FailureReport -> Summary -> Bool-rerunAll _ Nothing _ = False-rerunAll config (Just oldFailureReport) summary =-     configRerunAllOnSuccess config-  && configRerun config-  && isSuccess summary-  && (not . null) (failureReportPaths oldFailureReport)+shouldUseColor :: UseColor -> Bool+shouldUseColor c = case c of+  ColorDisabled -> False+  ColorEnabled _ -> True --- | Summary of a test run.-data Summary = Summary {-  summaryExamples :: Int-, summaryFailures :: Int-} deriving (Eq, Show)+progressReporting :: UseColor -> ProgressReporting+progressReporting c = case c of+  ColorDisabled -> ProgressReportingDisabled+  ColorEnabled r -> r -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)+colorOutputSupported :: ColorMode -> IO Bool -> IO UseColor+colorOutputSupported mode isTerminalDevice = do+  github <- githubActions+  buildkite <- lookupEnv "BUILDKITE" <&> (== Just "true")+  let+    progress :: ProgressReporting+    progress+      | github || buildkite = ProgressReportingDisabled+      | otherwise = ProgressReportingEnabled +    colorEnabled :: UseColor+    colorEnabled = ColorEnabled progress+  case mode of+    ColorAuto -> bool ColorDisabled colorEnabled . (github ||) <$> colorTerminal+    ColorNever -> return ColorDisabled+    ColorAlways -> return colorEnabled+  where+    githubActions :: IO Bool+    githubActions = lookupEnv "GITHUB_ACTIONS" <&> (== Just "true")++    colorTerminal :: IO Bool+    colorTerminal = (&&) <$> (not <$> noColor) <*> isTerminalDevice++    noColor :: IO Bool+    noColor = lookupEnv "NO_COLOR" <&> (/= Nothing)++unicodeOutputSupported :: UnicodeMode -> Handle -> IO Bool+unicodeOutputSupported mode h = case mode of+  UnicodeAuto -> Compat.unicodeOutputSupported h+  UnicodeNever -> return False+  UnicodeAlways -> return True++rerunAll :: Config -> Maybe FailureReport -> SpecResult -> Bool+rerunAll config mOldFailureReport result = case mOldFailureReport of+  Nothing -> False+  Just oldFailureReport ->+       configRerunAllOnSuccess config+    && configRerun config+    && specResultSuccess result+    && (not . null) (failureReportPaths oldFailureReport)+ randomizeForest :: Integer -> [Tree c a] -> [Tree c a] randomizeForest seed t = runST $ do   ref <- newSTRef (mkStdGen $ fromIntegral seed)   shuffleForest ref t -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-, evalConfigFastFail :: Bool+, 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 (evalConfigFastFail . 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@@ -11,17 +14,23 @@ , formatRequirement , filterPredicate --- * Working with exception+-- * 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/GetOpt/Declarative/EnvironmentSpec.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-missing-fields #-}+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} module GetOpt.Declarative.EnvironmentSpec (spec) where  import           Prelude ()
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
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} module Test.Hspec.Core.Config.OptionsSpec (spec) where  import           Prelude ()@@ -42,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@@ -58,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)@@ -73,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@@ -87,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@@ -111,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
@@ -3,19 +3,18 @@ {-# OPTIONS_GHC -fno-warn-missing-fields #-} {-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} {-# OPTIONS_GHC -fno-warn-missing-methods #-}+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} {-# OPTIONS_GHC -O0 #-} module Test.Hspec.Core.Example.LocationSpec (spec) where  import           Prelude () import           Helper -import           Control.Exception- import           Test.Hspec.Core.Example import           Test.Hspec.Core.Example.Location  class SomeClass a where-    someMethod :: a -> IO ()+  someMethod :: a -> IO ()  instance SomeClass () where @@ -35,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)@@ -44,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@@ -58,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 @@ -70,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             ))@@ -85,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__ 20 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,18 +2,102 @@ module Test.Hspec.Core.Formatters.DiffSpec (spec) where  import           Prelude ()-import           Test.Hspec.Core.Compat- import           Helper import           Data.Char -import           Test.Hspec.Core.Formatters.Diff+import           Test.Hspec.Core.Formatters.Diff as Diff  dropQuotes :: String -> String-dropQuotes = init . tail+dropQuotes = init . drop 1  spec :: Spec spec = do+  describe "lineDiff" $ do+    let+      enumerate name n = map ((name ++) . show) [1 .. n :: Int]+      diff_ expected actual = lineDiff (Just 2) (unlines expected) (unlines actual)++    it "suppresses excessive diff output" $ do+      let+        expected = enumerate "foo" 99+        actual = replace "foo50" "bar50" expected++      diff_ expected actual `shouldBe` [+          LinesOmitted 47+        , LinesBoth [+            "foo48"+          , "foo49"+          ]+        , SingleLineDiff [First "foo50", Second "bar50"]+        , LinesBoth [+            "foo51"+          , "foo52"+          ]+        , LinesOmitted 47+        , LinesBoth [""]+        ]++    it "ensures that omitted sections are at least three lines in size" $ do+      forAll (elements [1..20]) $ \ size -> do+        let expected = enumerate "" size+        forAll (elements expected) $ \ i -> do+          let actual = replace i "bar" expected+          [n | LinesOmitted n <- diff_ expected actual] `shouldSatisfy` all (>= 3)++    context "with modifications within a line" $ do+        it "suppresses excessive diff output" $ do+          let+            expected = enumerate "foo " 99+            actual = replace "foo 42" "foo 23" expected++          diff_ expected actual `shouldBe` [+              LinesOmitted 39+            , LinesBoth [+                "foo 40"+              , "foo 41"+              ]+            , SingleLineDiff  [Both "foo ", First "42", Second "23"]+            , LinesBoth [+                "foo 43"+              , "foo 44"+              ]+            , LinesOmitted 55+            , LinesBoth [""]+            ]++    context "with modifications at start / end" $ do+      it "suppresses excessive diff output" $ do+        let+          expected = enumerate "foo" 9+          actual = replace "foo9" "bar9" $ replace "foo1" "bar1" expected++        diff_ expected actual `shouldBe` [+            SingleLineDiff  [First "foo1", Second "bar1"]+          , LinesBoth [+              "foo2"+            , "foo3"+            ]+          , LinesOmitted 3+          , LinesBoth [+              "foo7"+            , "foo8"+            ]+          , SingleLineDiff  [First "foo9", Second "bar9"]+          , LinesBoth [""]+          ]++  describe "splitLines" $ do+    it "splits on newline characters" $ do+      splitLines "foo\nbar\nbaz" `shouldBe` ["foo", "bar", "baz"]++    describe "with a newline characters at the start" $ do+      it "splits on newline characters" $ do+        splitLines "\nfoo\nbar\nbaz" `shouldBe` ["", "foo", "bar", "baz"]++    describe "with a newline characters at the end" $ do+      it "splits on newline characters" $ do+        splitLines "foo\nbar\nbaz\n" `shouldBe` ["foo", "bar", "baz", ""]+   describe "partition" $ do     context "with a single shown Char" $ do       it "never partitions a character escape" $ do@@ -28,12 +112,12 @@           let             char = dropQuotes (show [c])             isEscaped = length char > 1-            escape = tail char+            escape = drop 1 char             sep = case ys of               x : _ | all isDigit escape && isDigit x || escape == "SO" && x == 'H' -> ["\\&"]               _ -> []             actual = partition (show (xs ++ c : ys))-            expected = partition (init $ show xs) ++ [char] ++ sep ++ partition (tail $ show ys)+            expected = partition (init $ show xs) ++ [char] ++ sep ++ partition (drop 1 $ show ys)           in isEscaped ==> actual `shouldBe` expected    describe "breakList" $ do
test/Test/Hspec/Core/Formatters/InternalSpec.hs view
@@ -1,26 +1,64 @@+{-# OPTIONS_GHC -fno-warn-deprecations #-} module Test.Hspec.Core.Formatters.InternalSpec (spec) where  import           Prelude () import           Helper +import           System.Console.ANSI +import           Test.Hspec.Core.Format import           Test.Hspec.Core.Formatters.Internal +formatConfig :: FormatConfig+formatConfig = defaultFormatConfig {+  formatConfigUseColor = True+, formatConfigUseDiff = True+, formatConfigDiffContext = Just 3+}+ spec :: Spec spec = do-  describe "overwriteWith" $ do-    context "when old is null" $ do-      it "returns new" $ do-        ("" `overwriteWith` "foo") `shouldBe` "foo"+  forM_ [+      ("extraChunk", extraChunk, Red)+    , ("missingChunk", missingChunk, Green)+    ] $ \ (name, chunk, color) -> do -    context "when old and new have the same length" $ do-      it "overwrites old" $ do-        ("foo" `overwriteWith` "bar") `shouldBe` "\rbar"+    describe name $ do+      it "colorizes chunks" $ do+        capture_ $ runFormatM formatConfig $ do+          chunk "foo"+        `shouldReturn` colorize Foreground color "foo" -    context "when old is shorter than new" $ do-      it "overwrites old" $ do-        ("ba" `overwriteWith` "foo") `shouldBe` "\rfoo"+      context "with an all-spaces chunk" $ do+        it "colorizes background" $ do+          capture_ $ runFormatM formatConfig $ do+            chunk "  "+          `shouldReturn` colorize Background color "  " -    context "when old is longer than new" $ do-      it "overwrites old" $ do-        ("foobar" `overwriteWith` "foo") `shouldBe` "\rfoo   "+      context "with an all-newlines chunk" $ do+        it "colorizes background" $ do+          capture_ $ runFormatM formatConfig $ do+            chunk "\n\n\n"+          `shouldReturn` colorize Background color "\n\n\n"++  describe "write" $ do+    it "does not span colored output over multiple lines" $ do++      -- This helps with output on Jenkins and Buildkite:+      -- https://github.com/hspec/hspec/issues/346++      capture_ $ runFormatM formatConfig $ do+        withSuccessColor $ write "foo\nbar\nbaz\n"+      `shouldReturn` unlines [green "foo", green "bar", green "baz"]++  describe "splitLines" $ do+    it "splits a string into chunks" $ do+      splitLines "foo\nbar\nbaz" `shouldBe` ["foo", "\n", "bar", "\n", "baz"]++    it "splits *arbitrary* strings into chunks" $ do+      property $ \ xs -> do+        mconcat (splitLines xs) `shouldBe` xs++    it "puts newlines into separate chunks" $ do+      property $ \ xs -> do+        filter (notElem '\n') (splitLines xs) `shouldBe` filter (not . null) (lines xs)
+ test/Test/Hspec/Core/Formatters/Pretty/ParserSpec.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+module Test.Hspec.Core.Formatters.Pretty.ParserSpec (+  spec+, Person(..)+, Address(..)+, person+) where++import           Prelude ()+import           Helper++import           Test.Hspec.Core.Formatters.Pretty.Parser++data OperatorType = String :*: Int+  deriving (Eq, Show)++data Person = Person {+  personName :: String+, personAge :: Int+, personAddress :: Maybe Address+} deriving (Eq, Show)++data Address = Address {+  addressStreet :: String+, addressPostalCode :: Int+} deriving (Eq, Show)++person :: Person+person = Person "Joe" 23 (Just $ Address "Main Street" 50000)++infix 1 `shouldParseAs`++shouldParseAs :: HasCallStack => String -> Value -> Expectation+shouldParseAs input expected = parseValue input `shouldBe` Just expected++unit :: Value+unit = Tuple []++parentheses :: Value -> Value+parentheses value = Tuple [value]++spec :: Spec+spec = do+  describe "parseValue" $ do+    it "parses unit" $ do+      show () `shouldParseAs` unit++    it "parses characters" $ do+      show 'c' `shouldParseAs` Char 'c'++    it "parses strings" $ do+      show "foo" `shouldParseAs` String "foo"++    it "accepts rationals" $ do+      show (0.5 :: Rational) `shouldParseAs` Operator (Number "1") "%" (Number "2")++    it "accepts negative rationals" $ do+      show (-0.5 :: Rational) `shouldParseAs` Operator (parentheses $ Number "-1") "%" (Number "2")++    it "accepts constructor symbols" $ do+      show ("foo" :*: 23) `shouldParseAs` Operator (String "foo") ":*:" (Number "23")++    it "accepts integers" $ do+      "23" `shouldParseAs` Number "23"++    it "accepts negative integers" $ do+      "-23" `shouldParseAs` Number "-23"++    it "accepts floats" $ do+      show (23.0 :: Float) `shouldParseAs` Number "23.0"++    it "accepts negative floats" $ do+      show (-23.0 :: Float) `shouldParseAs` Number "-23.0"++    it "parses lists" $ do+      show ["foo", "bar", "baz"] `shouldParseAs` List [String "foo", String "bar", String "baz"]++    it "parses tuples" $ do+      show ("foo", "bar", "baz") `shouldParseAs` Tuple [String "foo", String "bar", String "baz"]++    it "parses Nothing" $ do+      show (Nothing :: Maybe Int) `shouldParseAs` Constructor "Nothing" []++    it "parses Just" $ do+      show (Just "foo") `shouldParseAs` Constructor "Just" [String "foo"]++    it "parses nested Just" $ do+      show (Just $ Just "foo") `shouldParseAs` Constructor "Just" [parentheses (Constructor "Just" [String "foo"])]++    it "parses records" $ do+      show person `shouldParseAs` Record "Person" [+          ("personName", String "Joe")+        , ("personAge", Number "23")+        , ("personAddress", Constructor "Just" [Tuple [Record "Address" [+            ("addressStreet", String "Main Street")+          , ("addressPostalCode", Number "50000")+          ]]])+        ]++    context "with deeply nested data structures" $ do+      it "completes in O(n) time" $ do+        let+          input = show (+            "0", (+            "1", (+            "2", (+            "3", (+            "4", (+            "5", (+            "6", (+            "7", (+            "8", (+            "9", (+            "10", (+            "11", (+            "12", (+            "13", (+            "14", (+            "15", (+            "16", (+            "17", (+            "18", (+            "19", (+            "20", (+            "21", (+            "22", (+            "23", (+            "24", (+            "25", (+            "26", (+            "27", (+            "28", (+            "29", (+            )))))))))))))))))))))))))))))))+        r <- timeout 1 $ evaluate (parseValue input)+        (join r :: Maybe Value) `shouldSatisfy` isJust
+ test/Test/Hspec/Core/Formatters/Pretty/UnicodeSpec.hs view
@@ -0,0 +1,16 @@+module Test.Hspec.Core.Formatters.Pretty.UnicodeSpec (spec) where++import           Prelude ()+import           Helper++import           Test.Hspec.Core.Formatters.Pretty.Unicode++spec :: Spec+spec = do+  describe "ushow" $ do+    it "retains unicode characters" $ do+      ushow "foo-\955-bar" `shouldBe` "\"foo-\955-bar\""++    it "is inverted by read" $ do+      property $ \ xs ->+        read (ushow xs) `shouldBe` xs
+ test/Test/Hspec/Core/Formatters/PrettySpec.hs view
@@ -0,0 +1,158 @@+module Test.Hspec.Core.Formatters.PrettySpec (spec) where++import           Prelude ()+import           Helper++import           Test.Hspec.Core.Formatters.Pretty.ParserSpec hiding (spec)++import           Test.Hspec.Core.Formatters.Pretty++spec :: Spec+spec = do+  describe "pretty2" $ do+    context "with single-line string literals" $ do+      context "with --unicode" $ do+        it "recovers unicode" $ do+          pretty2 True (show "foo\955bar") (show "foo-bar") `shouldBe` ("\"foo\955bar\"", "\"foo-bar\"")++      context "with --no-unicode" $ do+        it "does not recover unicode" $ do+          pretty2 False (show "foo\955bar") (show "foo-bar") `shouldBe` ("\"foo\\955bar\"", "\"foo-bar\"")++      context "when expected and actual would be equal after pretty-printing" $ do+        it "returns the original values unmodified" $ do+          pretty2 True (show "foo") (show "foo" <> "   ") `shouldBe` (show "foo", show "foo" <> "   ")++  describe "recoverString" $ do+    it "recovers a string" $ do+      recoverString (show "foo") `shouldBe` Just "foo"++    it "recovers the empty string" $ do+      recoverString (show "") `shouldBe` Just ""++    it "does not recover a string with leading space" $ do+      recoverString ("   " <> show "foo") `shouldBe` Nothing++    it "does not recover a string with trailing space" $ do+      recoverString (show "foo" <> "   ") `shouldBe` Nothing++    it "does not recover an empty list" $ do+      recoverString "[]" `shouldBe` Nothing++  describe "recoverMultiLineString" $ do+    let+      multiLineString :: String+      multiLineString = "foo\nbar\nbaz\n"++    it "recovers multi-line string literals" $ do+      recoverMultiLineString True (show multiLineString) `shouldBe` Just multiLineString++    it "does not recover string literals that contain control characters" $ do+      recoverMultiLineString True (show "foo\n\tbar\nbaz\n") `shouldBe` Nothing++    it "does not recover string literals that span a single line" $ do+      recoverMultiLineString True (show "foo\n") `shouldBe` Nothing++    it "does not recover a string with trailing space" $ do+      recoverMultiLineString True ("   " <> show multiLineString) `shouldBe` Nothing++    it "does not recover a string with trailing space" $ do+      recoverMultiLineString True (show multiLineString <> "   ") `shouldBe` Nothing++    context "when unicode is True" $ do+      it "recovers string literals that contain unicode" $ do+        recoverMultiLineString True (show "foo\n\955\nbaz\n") `shouldBe` Just "foo\n\955\nbaz\n"++    context "when unicode is False" $ do+      it "does not recover string literals that contain unicode" $ do+        recoverMultiLineString False (show "foo\n\955\nbaz\n") `shouldBe` Nothing++  describe "pretty" $ do+    it "pretty-prints records" $ do+      pretty True (show person) `shouldBe` just [+          "Person {"+        , "  personName = \"Joe\","+        , "  personAge = 23,"+        , "  personAddress = Just Address {"+        , "    addressStreet = \"Main Street\","+        , "    addressPostalCode = 50000"+        , "  }"+        , "}"+        ]++    it "pretty-prints Just-values" $ do+      pretty True (show $ Just person) `shouldBe` just [+          "Just Person {"+        , "  personName = \"Joe\","+        , "  personAge = 23,"+        , "  personAddress = Just Address {"+        , "    addressStreet = \"Main Street\","+        , "    addressPostalCode = 50000"+        , "  }"+        , "}"+        ]++    it "pretty-prints tuples" $ do+      pretty True (show (person, -0.5 :: Rational)) `shouldBe` just [+          "(Person {"+        , "  personName = \"Joe\","+        , "  personAge = 23,"+        , "  personAddress = Just Address {"+        , "    addressStreet = \"Main Street\","+        , "    addressPostalCode = 50000"+        , "  }"+        , "}, (-1) % 2)"+        ]++    it "pretty-prints lists" $ do+      pretty True (show [Just person, Nothing]) `shouldBe` just [+          "[Just Person {"+        , "  personName = \"Joe\","+        , "  personAge = 23,"+        , "  personAddress = Just Address {"+        , "    addressStreet = \"Main Street\","+        , "    addressPostalCode = 50000"+        , "  }"+        , "}, Nothing]"+        ]++    context "with --unicode" $ do+      it "retains unicode characters in record fields" $ do+        pretty True (show $ Person "λ-Joe" 23 Nothing) `shouldBe` just [+            "Person {"+          , "  personName = \"λ-Joe\","+          , "  personAge = 23,"+          , "  personAddress = Nothing"+          , "}"+          ]++      it "retains unicode characters in list elements" $ do+        pretty True (show ["foo", "λ", "bar"]) `shouldBe` just ["[\"foo\", \"λ\", \"bar\"]"]++    context "with --no-unicode" $ do+      it "does not retain unicode characters in record fields" $ do+        pretty False (show $ Person "λ-Joe" 23 Nothing) `shouldBe` just [+            "Person {"+          , "  personName = \"\\955-Joe\","+          , "  personAge = 23,"+          , "  personAddress = Nothing"+          , "}"+          ]++      it "does not retain unicode characters in list elements" $ do+        pretty False (show ["foo", "λ", "bar"]) `shouldBe` just ["[\"foo\", \"\\955\", \"bar\"]"]++    context "with input that looks like a list" $ do+      it "it returns Nothing" $ do+        pretty True "[23,42]" `shouldBe` Nothing++    context "with input that looks like a tuple" $ do+      it "it returns Nothing" $ do+        pretty True "(23,42)" `shouldBe` Nothing++    context "with input that looks like function applications" $ do+      it "it returns Nothing" $ do+        let input = unlines ["foo", "bar", "baz"]+        pretty True input `shouldBe` Nothing+  where+    just = Just . intercalate "\n"
test/Test/Hspec/Core/Formatters/V1Spec.hs view
@@ -1,19 +1,19 @@ {-# 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.Monad as H (interpretWith)-import           Test.Hspec.Core.Formatters.Monad (FormatM, Environment(..), FailureRecord(..), FailureReason(..))+import qualified Test.Hspec.Core.Formatters.V1 as H hiding (FailureReason(..))+import qualified Test.Hspec.Core.Formatters.V1.Monad as H (interpretWith)+import           Test.Hspec.Core.Formatters.V1.Monad (FormatM, Environment(..), FailureRecord(..), FailureReason(..))  data ColorizedText =     Plain String@@ -65,7 +65,6 @@   environmentGetSuccessCount = return 0 , environmentGetPendingCount = return 0 , environmentGetFailMessages = return []-, environmentGetFinalCount = return 0 , environmentUsedSeed = return 0 , environmentGetCPUTime = return Nothing , environmentGetRealTime = return 0@@ -178,7 +177,7 @@         , "2 examples, 0 failures"         ] -    it "displays a row for each successfull, failed, or pending example" $ do+    it "displays a row for each successful, failed, or pending example" $ do       r <- runSpec testSpec       r `shouldSatisfy` any (== "  fail 1 FAILED [1]")       r `shouldSatisfy` any (== "  success")@@ -193,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 @@ -284,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,98 +1,14 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DeriveFunctor #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-} module Test.Hspec.Core.Formatters.V2Spec (spec) where  import           Prelude () import           Helper-import           Data.String-import           Control.Monad.IO.Class-import           Control.Monad.Trans.Writer-import qualified Control.Exception as E  import qualified Test.Hspec.Core.Spec as H import qualified Test.Hspec.Core.Spec as Spec import qualified Test.Hspec.Core.Runner as H-import qualified Test.Hspec.Core.Formatters.V2 as H-import qualified Test.Hspec.Core.Formatters.V2 as Formatter-import qualified Test.Hspec.Core.Formatters.Monad as H-import           Test.Hspec.Core.Formatters.Monad (FormatM, Environment(..))--data Colorized a =-    Plain a-  | Transient a-  | Info a-  | Succeeded a-  | Failed a-  | Pending a-  | Extra a-  | Missing a-  deriving (Functor, Eq, Show)--instance IsString (Colorized String) where-  fromString = Plain--removeColors :: [Colorized String] -> String-removeColors input = case input of-  Plain x : xs -> x ++ removeColors xs-  Transient _ : xs -> removeColors xs-  Info x : xs -> x ++ removeColors xs-  Succeeded x : xs -> x ++ removeColors xs-  Failed x : xs -> x ++ removeColors xs-  Pending x : xs -> x ++ removeColors xs-  Extra x : xs -> x ++ removeColors xs-  Missing x : xs -> x ++ removeColors xs-  [] -> ""--simplify :: [Colorized String] -> [Colorized String]-simplify input = case input of-  Plain xs : Plain ys : zs -> simplify (Plain (xs ++ ys) : zs)-  Extra xs : Extra ys : zs -> simplify (Extra (xs ++ ys) : zs)-  Missing xs : Missing ys : zs -> simplify (Missing (xs ++ ys) : zs)-  x : xs -> x : simplify xs-  [] -> []--colorize :: (String -> Colorized String) -> [Colorized String] -> [Colorized String]-colorize color input = case simplify input of-  Plain x : xs -> color x : xs-  xs -> xs--interpret :: FormatM a -> IO [Colorized String]-interpret = interpretWith environment--interpretWith :: Environment (WriterT [Colorized String] IO) -> FormatM a -> IO [Colorized String]-interpretWith env = fmap simplify . execWriterT . H.interpretWith env--environment :: Environment (WriterT [Colorized String] IO)-environment = Environment {-  environmentGetSuccessCount = return 0-, environmentGetPendingCount = return 0-, environmentGetFailMessages = return []-, environmentGetFinalCount = return 0-, environmentUsedSeed = return 0-, environmentGetCPUTime = return Nothing-, environmentGetRealTime = return 0-, environmentWrite = tell . return . Plain-, environmentWriteTransient = tell . return . Transient-, environmentWithFailColor = \ action -> do-    (a, r) <- liftIO $ runWriterT action-    tell (colorize Failed r) >> return a-, environmentWithSuccessColor = \ action -> do-    (a, r) <- liftIO $ runWriterT action-    tell (colorize Succeeded r) >> return a-, environmentWithPendingColor = \ action -> do-    (a, r) <- liftIO $ runWriterT action-    tell (colorize Pending r) >> return a-, environmentWithInfoColor = \ action -> do-    (a, r) <- liftIO $ runWriterT action-    tell (colorize Info r) >> return a-, environmentUseDiff = return True-, environmentPrintTimes = return False-, environmentExtraChunk = tell . return . Extra-, environmentMissingChunk = tell . return . Missing-, environmentLiftIO = liftIO-}+import           Test.Hspec.Core.Format+import           Test.Hspec.Core.Formatters.V2  testSpec :: H.Spec testSpec = do@@ -104,33 +20,71 @@     H.it "exceptions" (undefined :: Spec.Result)     H.it "fail 3"     (H.Result "" $ Spec.Failure Nothing H.NoReason) +formatConfig :: FormatConfig+formatConfig = defaultFormatConfig {+  formatConfigOutputUnicode = unicode+, formatConfigUseDiff = True+, formatConfigDiffContext = Just 3+, formatConfigExternalDiff = Nothing+, formatConfigPrettyPrint = True+, formatConfigPrettyPrintFunction = Just (H.configPrettyPrintFunction H.defaultConfig unicode)+} where+    unicode = True++runSpecWith :: Formatter -> H.Spec -> IO [String]+runSpecWith formatter = captureLines . H.hspecWithResult H.defaultConfig {H.configFormat = Just $ formatterToFormat formatter}+ spec :: Spec spec = do   describe "progress" $ do-    let formatter = H.progress-        item = Formatter.Item Nothing 0 ""-+    let item = ItemDone ([], "") . Item Nothing 0 ""     describe "formatterItemDone" $ do       it "marks succeeding examples with ." $ do-        interpret (H.formatterItemDone formatter undefined (item Formatter.Success)) `shouldReturn` [-            Succeeded "."-          ]+        formatter <- formatterToFormat progress formatConfig+        captureLines (formatter $ item Success)+          `shouldReturn` ["."]        it "marks failing examples with F" $ do-        interpret (H.formatterItemDone formatter undefined (item $ Formatter.Failure Nothing H.NoReason)) `shouldReturn` [-            Failed "F"-          ]+        formatter <- formatterToFormat progress formatConfig+        captureLines (formatter . item $ Failure Nothing NoReason)+          `shouldReturn` ["F"]        it "marks pending examples with ." $ do-        interpret (H.formatterItemDone formatter undefined (item $ Formatter.Pending Nothing Nothing)) `shouldReturn` [-            Pending "."-          ]+        formatter <- formatterToFormat progress formatConfig+        captureLines (formatter . item $ Pending Nothing Nothing)+          `shouldReturn` ["."] -  describe "specdoc" $ do+  describe "checks" $ do     let-      formatter = H.specdoc-      runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormat = Just $ H.formatterToFormat formatter}+      formatter = checks+      config = H.defaultConfig { H.configFormat = Just $ formatterToFormat formatter } +    it "prints unicode check marks" $ do+      r <- captureLines . H.hspecWithResult config $ do+        H.it "foo" True+      normalizeSummary r `shouldBe` [+          ""+        , "foo [✔]"+        , ""+        , "Finished in 0.0000 seconds"+        , "1 example, 0 failures"+        ]++    it "uses ASCII as a fallback" $ do+      r <- captureLines . H.hspecWithResult config { H.configUnicodeMode = H.UnicodeNever } $ do+        H.it "foo" True+      normalizeSummary r `shouldBe` [+          ""+        , "foo [v]"+        , ""+        , "Finished in 0.0000 seconds"+        , "1 example, 0 failures"+        ]++  describe "specdoc" $ do++    let runSpec = runSpecWith specdoc+     it "displays a header for each thing being described" $ do       _:x:_ <- runSpec testSpec       x `shouldBe` "Example"@@ -181,7 +135,7 @@         , "2 examples, 0 failures"         ] -    it "displays a row for each successfull, failed, or pending example" $ do+    it "displays a row for each successful, failed, or pending example" $ do       r <- runSpec testSpec       r `shouldSatisfy` any (== "  fail 1 FAILED [1]")       r `shouldSatisfy` any (== "  success")@@ -196,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 @@ -212,15 +166,50 @@           ]      describe "formatterDone" $ do-      let action = H.formatterDone formatter+      let expectedButGot expected actual = ItemDone ([], "") . Item Nothing 0 "" $ Failure Nothing $ ExpectedButGot Nothing expected actual +      it "recovers unicode from ExpectedButGot" $ do+        formatter <- formatterToFormat failed_examples formatConfig { formatConfigOutputUnicode = True }+        formatter $ expectedButGot (show "\955") (show "\956")+        (fmap normalizeSummary . captureLines) (formatter $ Done []) `shouldReturn` [+            ""+          , "Failures:"+          , ""+          , "  1) "+          , "       expected: \"λ\""+          , "        but got: \"μ\""+          , ""+          , "  To rerun use: --match \"//\" --seed 0"+          , ""+          , "Randomized with seed 0"+          , ""+          , "Finished in 0.0000 seconds"+          , "1 example, 1 failure"+          ]++      context "on --expert" $ do+        it "does not print rerun message" $ do+          formatter <- formatterToFormat failed_examples formatConfig { formatConfigExpertMode = True }+          formatter $ expectedButGot "foo" "bar"+          (fmap normalizeSummary . captureLines) (formatter $ Done []) `shouldReturn` [+              ""+            , "Failures:"+            , ""+            , "  1) "+            , "       expected: foo"+            , "        but got: bar"+            , ""+            , "Randomized with seed 0"+            , ""+            , "Finished in 0.0000 seconds"+            , "1 example, 1 failure"+            ]+       context "when actual/expected contain newlines" $ do-        let-          env = environment {-            environmentGetFailMessages = return [H.FailureRecord Nothing ([], "") (H.ExpectedButGot Nothing "first\nsecond\nthird" "first\ntwo\nthird")]-            }         it "adds indentation" $ do-          (removeColors <$> interpretWith env action) `shouldReturn` unlines [+          formatter <- formatterToFormat failed_examples formatConfig+          formatter $ expectedButGot "first\nsecond\nthird" "first\ntwo\nthird"+          (fmap normalizeSummary . captureLines) (formatter $ Done []) `shouldReturn` [               ""             , "Failures:"             , ""@@ -232,7 +221,7 @@             , "                 two"             , "                 third"             , ""-            , "  To rerun use: --match \"//\""+            , "  To rerun use: --match \"//\" --seed 0"             , ""             , "Randomized with seed 0"             , ""@@ -241,73 +230,38 @@             ]        context "without failures" $ do-        let env = environment {environmentGetSuccessCount = return 1}         it "shows summary in green if there are no failures" $ do-          interpretWith env action `shouldReturn` [-              "\nFinished in 0.0000 seconds\n"-            , Succeeded "1 example, 0 failures\n"+          formatter <- formatterToFormat failed_examples formatConfig+          formatter . ItemDone ([], "") . Item Nothing 0 "" $ Success+          (fmap normalizeSummary . captureLines) (formatter $ Done []) `shouldReturn` [+              ""+            , "Finished in 0.0000 seconds"+            , "1 example, 0 failures"             ]        context "with pending examples" $ do-        let env = environment {environmentGetPendingCount = return 1}         it "shows summary in yellow if there are pending examples" $ do-          interpretWith env action `shouldReturn` [-             "\nFinished in 0.0000 seconds\n"-            , Pending "1 example, 0 failures, 1 pending\n"-            ]--      context "with failures" $ do-        let env = environment {environmentGetFailMessages = return [H.FailureRecord Nothing ([], "") H.NoReason]}-        it "shows summary in red" $ do-          interpretWith env action `shouldReturn` [-              Plain $ unlines [+          formatter <- formatterToFormat failed_examples formatConfig+          formatter . ItemDone ([], "") . Item Nothing 0 "" $ Pending Nothing Nothing+          (fmap normalizeSummary . captureLines) (formatter $ Done []) `shouldReturn` [               ""-            , "Failures:"-            , ""-            , "  1) "-            , ""-            , "  To rerun use: --match \"//\""-            , ""-            , "Randomized with seed 0"-            , ""             , "Finished in 0.0000 seconds"-            ]-            , Failed "1 example, 1 failure\n"-            ]--      context "with both failures and pending examples" $ do-        let env = environment {environmentGetFailMessages = return [H.FailureRecord Nothing ([], "") H.NoReason], environmentGetPendingCount = return 1}-        it "shows summary in red" $ do-          interpretWith env action `shouldReturn` [-              Plain $ unlines [-              ""-            , "Failures:"-            , ""-            , "  1) "-            , ""-            , "  To rerun use: --match \"//\""-            , ""-            , "Randomized with seed 0"-            , ""-            , "Finished in 0.0000 seconds"-            ]-            , Failed "2 examples, 1 failure, 1 pending\n"+            , "1 example, 0 failures, 1 pending"             ]      context "same as failed_examples" $ do-      failed_examplesSpec formatter+      failed_examplesSpec specdoc -  describe "additional formatter features" $ do-    describe "getFinalCount" $ do-      let formatter = H.silent {H.formatterDone = fmap show H.getFinalCount >>= H.writeLine}-          runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormat = Just $ H.formatterToFormat formatter}-      it "counts examples" $ do-        result:_ <- runSpec testSpec-        result `shouldBe` "6"+  describe "getExpectedTotalCount" $ do+    let formatter = silent { formatterStarted = fmap show getExpectedTotalCount >>= writeLine }+        runSpec = runSpecWith formatter+    it "returns the total number of spec items" $ do+      result:_ <- runSpec testSpec+      result `shouldBe` "6" -failed_examplesSpec :: H.Formatter -> Spec+failed_examplesSpec :: Formatter -> Spec failed_examplesSpec formatter = do-  let runSpec = captureLines . H.hspecWithResult H.defaultConfig {H.configFormat = Just $ H.formatterToFormat formatter}+  let runSpec = runSpecWith formatter    context "displays a detailed list of failures" $ do     it "prints all requirements that are not met" $ do@@ -316,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-    , evalConfigFastFail = False+    , 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,240 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}-module Test.Hspec.Core.QuickCheckUtilSpec (spec) where--import           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 (stderr)-import           System.Environment (withArgs, withProgName, getArgs)+import           System.IO+import           System.Environment (withArgs, withProgName, getArgs, setEnv, unsetEnv) import           System.Exit import           Control.Concurrent-import qualified Control.Exception as E import           Control.Concurrent.Async import           Mock-import           System.SetEnv-import           System.Console.ANSI  import           Test.Hspec.Core.FailureReport (FailureReport(..)) import qualified Test.Hspec.Expectations as H import qualified Test.Hspec.Core.Spec as H+import           Test.Hspec.Core.Runner (UseColor(..), ProgressReporting(..)) import qualified Test.Hspec.Core.Runner as H-import qualified Test.Hspec.Core.Formatters.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,17 +232,17 @@             H.it "baz" True           putMVar mvar r         takeMVar sync-        throwTo threadId E.UserInterrupt+        throwTo threadId UserInterrupt         r <- takeMVar mvar         normalizeSummary r `shouldBe` [             ""-          , "foo FAILED [1]"+          , "foo [✘]"           , ""           , "Failures:"           , ""           , "  1) foo"           , ""-          , "  To rerun use: --match \"/foo/\""+          , "  To rerun use: --match \"/foo/\" --seed 23"           , ""           , "Randomized with seed 23"           , ""@@ -215,21 +258,21 @@             H.it "foo" $ do               putMVar sync ()               threadDelay 1000000-          `E.catch` putMVar mvar+          `catch` putMVar mvar         takeMVar sync-        throwTo threadId E.UserInterrupt-        takeMVar mvar `shouldReturn` E.UserInterrupt+        throwTo threadId UserInterrupt+        takeMVar mvar `shouldReturn` UserInterrupt      context "with --dry-run" $ do-      let withDryRun = captureLines . withArgs ["--dry-run"] . H.hspec+      let withDryRun = hspecCapture ["--dry-run"]       it "produces a report" $ do-        r <- withDryRun $ do+        withDryRun $ do           H.it "foo" True           H.it "bar" True-        normalizeSummary r `shouldBe` [+        `shouldReturn` unlines [             ""-          , "foo"-          , "bar"+          , "foo [✔]"+          , "bar [✔]"           , ""           , "Finished in 0.0000 seconds"           , "2 examples, 0 failures"@@ -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 FAILED [1]"+          , "bar [✘]"           , ""           , "Failures:"           , ""           , "  1) bar"-          , "       item is focused; failing due to --fail-on-focused"+          , "       item is focused; failing due to --fail-on=focused"           , ""-          , "  To rerun use: --match \"/bar/\""+          , "  To rerun use: --match \"/bar/\" --seed 23"           , ""           , "Randomized with seed 23"           , ""@@ -286,22 +340,71 @@           , "1 example, 1 failure"           ] +    context "with --fail-on=empty-description" $ do+      let run = hspecCapture ["--fail-on=empty-description", "--seed", "23"]+      it "fails on items with empty requirement" $ do+        run $ do+          H.it "foo" True+          H.it "" True+        `shouldReturn` unlines [+            ""+          , "foo [✔]"+          , "(unspecified behavior) [✘]"+          , ""+          , "Failures:"+          , ""+          , "  1) (unspecified behavior)"+          , "       item has no description; failing due to --fail-on=empty-description"+          , ""+          , "  To rerun use: --match \"/(unspecified behavior)/\" --seed 23"+          , ""+          , "Randomized with seed 23"+          , ""+          , "Finished in 0.0000 seconds"+          , "2 examples, 1 failure"+          ]++    context "with --fail-on=pending" $ do+      let run = hspecCapture ["--fail-on=pending", "--seed", "23"]+      it "fails on pending spec items" $ do+        run $ do+          H.it "foo" True+          H.it "bar" $ do+            void $ throwIO (H.Pending Nothing Nothing)+        `shouldReturn` unlines [+            ""+          , "foo [✔]"+          , "bar [✘]"+          , ""+          , "Failures:"+          , ""+          , "  1) bar"+          , "       item is pending; failing due to --fail-on=pending"+          , ""+          , "  To rerun use: --match \"/bar/\" --seed 23"+          , ""+          , "Randomized with seed 23"+          , ""+          , "Finished in 0.0000 seconds"+          , "2 examples, 1 failure"+          ]+     context "with --fail-fast" $ do       it "stops after first failure" $ do-        r <- captureLines . ignoreExitCode . withArgs ["--fail-fast", "--seed", "23"] . H.hspec . removeLocations $ do+        hspecCapture ["--fail-fast", "--seed", "23"] $ do           H.it "foo" True           H.it "bar" False           H.it "baz" False-        normalizeSummary r `shouldBe` [+        `shouldReturn` unlines [             ""-          , "foo"-          , "bar FAILED [1]"+          , "foo [✔]"+          , "bar [✘]"           , ""           , "Failures:"           , ""           , "  1) bar"           , ""-          , "  To rerun use: --match \"/bar/\""+          , "  To rerun use: --match \"/bar/\" --seed 23"           , ""           , "Randomized with seed 23"           , ""@@ -322,26 +425,26 @@             H.it "bar" $ do               -- NOTE: waitQSem should never return here, as we want to               -- guarantee that the thread is killed before hspec returns-              (signalQSem child1 >> waitQSem child2 >> writeIORef ref "foo") `E.finally` signalQSem parent+              (signalQSem child1 >> waitQSem child2 >> writeIORef ref "foo") `finally` signalQSem parent         signalQSem child2         waitQSem parent         readIORef ref `shouldReturn` ""        it "works for nested specs" $ do-        r <- captureLines . ignoreExitCode . withArgs ["--fail-fast", "--seed", "23"] . H.hspec . removeLocations $ do+        hspecCapture ["--fail-fast", "--seed", "23"] $ do           H.describe "foo" $ do             H.it "bar" False             H.it "baz" True-        normalizeSummary r `shouldBe` [+        `shouldReturn` unlines [             ""           , "foo"-          , "  bar FAILED [1]"+          , "  bar [✘]"           , ""           , "Failures:"           , ""           , "  1) foo bar"           , ""-          , "  To rerun use: --match \"/foo/bar/\""+          , "  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,27 +668,92 @@           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` [             ""-          , "foo"+          , "foo [✔]"           , ""           , "Finished in 0.0000 seconds"           , "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"]@@ -502,22 +866,22 @@       it "marks successful examples with CSS class hspec-success" $ do         r <- capture_ . withArgs ["--html"] . H.hspec $ do           H.it "foo" True-        r `shouldContain` "<span class=\"hspec-success\">foo\n</span>"+        r `shouldContain` "foo [<span class=\"hspec-success\">✔</span>]\n"        it "marks pending examples with CSS class hspec-pending" $ do         r <- capture_ . withArgs ["--html"] . H.hspec $ do           H.it "foo" H.pending-        r `shouldContain` "<span class=\"hspec-pending\">foo"+        r `shouldContain` "foo [<span class=\"hspec-pending\">‐</span>]\n"        it "marks failed examples with CSS class hspec-failure" $ do         r <- capture_ . ignoreExitCode . withArgs ["--html"] . H.hspec $ do           H.it "foo" False-        r `shouldContain` "<span class=\"hspec-failure\">foo"+        r `shouldContain` "foo [<span class=\"hspec-failure\">✘</span>]\n"    describe "hspecResult" $ do     let-      hspecResult args = withArgs ("--format=silent" : args) . H.hspecResult-      hspecResult_ = hspecResult []+      hspecResult args = withArgs args . hspecResultSilent+      hspecResult_ = hspecResultSilent      it "returns a summary of the test run" $ do       hspecResult_ $ do@@ -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,56 +938,90 @@               atomicModifyIORef highRef $ \x -> (max x current, ())             stop = atomicModifyIORef currentRef $ \x -> (pred x, ())         r <- hspecResult ["-j", show j] . H.parallel $ do-          replicateM_ n $ H.it "foo" $ E.bracket_ start stop $ sleep t+          replicateM_ n $ H.it "foo" $ bracket_ start stop $ sleep t         r `shouldBe` H.Summary n 0         high <- readIORef highRef         high `shouldBe` j    describe "colorOutputSupported" $ do-    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 "unicodeOutputSupported" $ do+    context "with UnicodeAlways" $ do+      it "returns True" $ do+        H.unicodeOutputSupported H.UnicodeAlways undefined `shouldReturn` True++    context "with UnicodeNever" $ do+      it "returns False" $ do+        H.unicodeOutputSupported H.UnicodeNever undefined `shouldReturn` False++    context "with UnicodeAuto" $ do+      context "when file encoding is UTF-8" $ do+        it "returns True" $ do+          inTempDirectory $ do+            withFile "foo" WriteMode $ \ h -> do+              hSetEncoding h utf8+              H.unicodeOutputSupported H.UnicodeAuto h `shouldReturn` True++      context "when file encoding is not UTF-8" $ do+        it "returns False" $ do+          inTempDirectory $ do+            withFile "foo" WriteMode $ \ h -> do+              hSetEncoding h latin1+              H.unicodeOutputSupported H.UnicodeAuto h `shouldReturn` False+   describe "rerunAll" $ do     let       report = FailureReport 0 0 0 0 [([], "foo")]       config = H.defaultConfig {H.configRerun = True, H.configRerunAllOnSuccess = True}-      summary = H.Summary 1 0+      result = SpecResult [] True     context "with --rerun, --rerun-all-on-success, previous failures, on success" $ do       it "returns True" $ do-        H.rerunAll config (Just report) summary `shouldBe` True+        H.rerunAll config (Just report) result `shouldBe` True      context "without --rerun" $ do       it "returns False" $ do-        H.rerunAll config {H.configRerun = False} (Just report) summary `shouldBe` False+        H.rerunAll config {H.configRerun = False} (Just report) result `shouldBe` False      context "without --rerun-all-on-success" $ do       it "returns False" $ do-        H.rerunAll config {H.configRerunAllOnSuccess = False} (Just report) summary `shouldBe` False+        H.rerunAll config {H.configRerunAllOnSuccess = False} (Just report) result `shouldBe` False      context "without previous failures" $ do       it "returns False" $ do-        H.rerunAll config (Just report {failureReportPaths = []}) summary `shouldBe` False+        H.rerunAll config (Just report {failureReportPaths = []}) result `shouldBe` False      context "without failure report" $ do       it "returns False" $ do-        H.rerunAll config Nothing summary `shouldBe` False+        H.rerunAll config Nothing result `shouldBe` False      context "on failure" $ do       it "returns False" $ do-        H.rerunAll config (Just report) summary {H.summaryFailures = 1} `shouldBe` False-  where-    green  = setSGRCode [SetColor Foreground Dull Green]-    red    = setSGRCode [SetColor Foreground Dull Red]-    reset  = setSGRCode [Reset]+        H.rerunAll config (Just report) result { specResultSuccess = False } `shouldBe` False
test/Test/Hspec/Core/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/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.8.5+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/