packages feed

hspec-core 2.10.8 → 2.10.9

raw patch · 30 files changed

+422/−227 lines, 30 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

+ Test.Hspec.Core.Formatters.V2: Location :: FilePath -> Int -> Int -> Location
+ Test.Hspec.Core.Formatters.V2: [locationColumn] :: Location -> Int
+ Test.Hspec.Core.Formatters.V2: [locationFile] :: Location -> FilePath
+ Test.Hspec.Core.Formatters.V2: [locationLine] :: Location -> Int
+ Test.Hspec.Core.Formatters.V2: data Location
+ Test.Hspec.Core.Formatters.V2: type Path = ([String], String)
+ Test.Hspec.Core.Formatters.V2: type Progress = (Int, Int)
+ Test.Hspec.Core.Hooks: type ActionWith a = a -> IO ()
+ Test.Hspec.Core.Hooks: type Spec = SpecWith ()
+ Test.Hspec.Core.Hooks: type SpecWith a = SpecM a ()
+ Test.Hspec.Core.Runner: type Spec = SpecWith ()
+ Test.Hspec.Core.Runner: type SpecWith a = SpecM a ()
+ Test.Hspec.Core.Spec: type Expectation = Assertion
+ Test.Hspec.Core.Spec: type HasCallStack = ?callStack :: CallStack
- Test.Hspec.Core.Spec: specItem :: (HasCallStack, Example a) => String -> a -> SpecTree (Arg a)
+ Test.Hspec.Core.Spec: specItem :: (HasCallStack, Example e) => String -> e -> SpecTree (Arg e)

Files

LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2011-2022 Simon Hengel <sol@typeful.net>+Copyright (c) 2011-2023 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
@@ -11,7 +11,7 @@                                 anything         --[no-]focused-only     do not run anything, unless there are focused                                 spec items-        --[no-]fail-on=ITEMS    empty: fail if no spec items have been run+        --[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         --[no-]strict           same as --fail-on=focused,pending
hspec-core.cabal view
@@ -1,14 +1,14 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.0.+-- This file has been generated from package.yaml by hpack version 0.35.1. -- -- see: https://github.com/sol/hpack  name:             hspec-core-version:          2.10.8+version:          2.10.9 license:          MIT license-file:     LICENSE-copyright:        (c) 2011-2022 Simon Hengel,+copyright:        (c) 2011-2023 Simon Hengel,                   (c) 2011-2012 Trystan Spangler,                   (c) 2011 Greg Weber maintainer:       Simon Hengel <sol@typeful.net>@@ -19,7 +19,7 @@ category:         Testing stability:        experimental bug-reports:      https://github.com/hspec/hspec/issues-homepage:         http://hspec.github.io/+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. @@ -87,6 +87,7 @@       Test.Hspec.Core.Formatters.V1.Monad       Test.Hspec.Core.QuickCheckUtil       Test.Hspec.Core.Runner.Eval+      Test.Hspec.Core.Runner.JobQueue       Test.Hspec.Core.Runner.PrintSlowSpecItems       Test.Hspec.Core.Runner.Result       Test.Hspec.Core.Shuffle@@ -172,6 +173,7 @@       Test.Hspec.Core.QuickCheckUtil       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@@ -206,6 +208,7 @@       Test.Hspec.Core.HooksSpec       Test.Hspec.Core.QuickCheckUtilSpec       Test.Hspec.Core.Runner.EvalSpec+      Test.Hspec.Core.Runner.JobQueueSpec       Test.Hspec.Core.Runner.PrintSlowSpecItemsSpec       Test.Hspec.Core.Runner.ResultSpec       Test.Hspec.Core.RunnerSpec
src/GetOpt/Declarative/Interpret.hs view
@@ -7,7 +7,6 @@  import           Prelude () import           Test.Hspec.Core.Compat-import           Data.Maybe  import           System.Console.GetOpt (OptDescr, ArgOrder(..), getOpt) import qualified System.Console.GetOpt as GetOpt
src/Test/Hspec/Core/Compat.hs view
@@ -16,9 +16,14 @@   , sequence   , sequence_   )+import           Data.Maybe as Imports import           Data.Foldable as Imports import           Data.CallStack as Imports (HasCallStack) +import           System.IO+import           System.Exit+import           System.Environment+ #if MIN_VERSION_base(4,11,0) import           Data.Functor as Imports #endif@@ -73,7 +78,6 @@ import           System.Environment as Imports (lookupEnv) #else import           Text.Read-import           System.Environment import qualified Text.ParserCombinators.ReadP as P #endif @@ -182,3 +186,9 @@ pass :: Monad m => m () pass = return () #endif++die :: String -> IO a+die err = do+  name <- getProgName+  hPutStrLn stderr $ name <> ": " <> err+  exitFailure
src/Test/Hspec/Core/Config.hs view
@@ -18,7 +18,6 @@ import           Prelude () import           Test.Hspec.Core.Compat -import           Data.Maybe import           System.IO import           System.IO.Error import           System.Exit@@ -29,10 +28,20 @@  import           Test.Hspec.Core.Util import           Test.Hspec.Core.Config.Options-import           Test.Hspec.Core.Config.Definition (Config(..), ColorMode(..), UnicodeMode(..), defaultConfig, filterOr)+import           Test.Hspec.Core.Config.Definition (Config(..), ColorMode(..), UnicodeMode(..), mkDefaultConfig, filterOr) import           Test.Hspec.Core.FailureReport import           Test.Hspec.Core.QuickCheckUtil (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 `||`.
src/Test/Hspec/Core/Config/Definition.hs view
@@ -4,7 +4,7 @@ , ColorMode(..) , UnicodeMode(..) , filterOr-, defaultConfig+, mkDefaultConfig  , commandLineOnlyOptions , formatterOptions@@ -27,8 +27,7 @@ import           Test.Hspec.Core.Example (Params(..), defaultParams) import           Test.Hspec.Core.Format (Format, FormatConfig) import           Test.Hspec.Core.Formatters.Pretty (pretty2)-import qualified Test.Hspec.Core.Formatters.V1 as V1-import qualified Test.Hspec.Core.Formatters.V2 as V2+import qualified Test.Hspec.Core.Formatters.V1.Monad as V1 import           Test.Hspec.Core.Util  import           GetOpt.Declarative@@ -89,8 +88,8 @@ , configConcurrentJobs :: Maybe Int } -defaultConfig :: Config-defaultConfig = Config {+mkDefaultConfig :: [(String, FormatConfig -> IO Format)] -> Config+mkDefaultConfig formatters = Config {   configIgnoreConfigFile = False , configDryRun = False , configFocusedOnly = False@@ -120,13 +119,7 @@ , configPrettyPrint = True , configPrettyPrintFunction = pretty2 , configTimes = False-, configAvailableFormatters = map (fmap V2.formatterToFormat) [-    ("checks", V2.checks)-  , ("specdoc", V2.specdoc)-  , ("progress", V2.progress)-  , ("failed-examples", V2.failed_examples)-  , ("silent", V2.silent)-  ]+, configAvailableFormatters = formatters , configFormat = Nothing , configFormatter = Nothing , configHtmlOutput = False@@ -346,7 +339,7 @@       showFailOn item <> ": " <> help item       where         help item = case item of-          FailOnEmpty -> "fail if no spec items have been run"+          FailOnEmpty -> "fail if all spec items have been filtered"           FailOnFocused -> "fail on focused spec items"           FailOnPending -> "fail on pending spec items"
src/Test/Hspec/Core/Example.hs view
@@ -21,6 +21,7 @@ , safeEvaluateExample -- END RE-EXPORTED from Test.Hspec.Core.Spec , safeEvaluateResultStatus+, exceptionToResultStatus , toLocation ) where
src/Test/Hspec/Core/Example/Location.hs view
@@ -17,7 +17,6 @@ import           Test.Hspec.Core.Compat  import           Data.Char-import           Data.Maybe import           GHC.IO.Exception  #ifdef mingw32_HOST_OS
src/Test/Hspec/Core/Formatters/Internal.hs view
@@ -198,7 +198,7 @@ runFormatM :: FormatConfig -> FormatM a -> IO a runFormatM config (FormatM action) = withLineBuffering $ do   time <- getMonotonicTime-  cpuTime <- if (formatConfigPrintCpuTime config) then Just <$> CPUTime.getCPUTime else pure Nothing+  cpuTime <- if formatConfigPrintCpuTime config then Just <$> CPUTime.getCPUTime else pure Nothing    let     progress = formatConfigReportProgress config && not (formatConfigHtmlOutput config)@@ -245,9 +245,9 @@ writeTransient :: String -> FormatM () writeTransient new = do   reportProgress <- getConfig formatConfigReportProgress-  when (reportProgress) $ do+  when reportProgress $ do     h <- getHandle-    write $ new+    write new     liftIO $ IO.hFlush h     write $ "\r" ++ replicate (length new) ' ' ++ "\r" @@ -347,7 +347,7 @@ getCPUTime = do   t1  <- liftIO CPUTime.getCPUTime   mt0 <- gets stateCpuStartTime-  return $ toSeconds <$> ((-) <$> pure t1 <*> mt0)+  return $ toSeconds <$> ((t1 -) <$> mt0)   where     toSeconds x = Seconds (fromIntegral x / (10.0 ^ (12 :: Integer)))
src/Test/Hspec/Core/Formatters/Pretty.hs view
@@ -5,6 +5,7 @@ #ifdef TEST , pretty , recoverString+, recoverMultiLineString #endif ) where @@ -20,25 +21,27 @@ import           Test.Hspec.Core.Formatters.Pretty.Parser  pretty2 :: Bool -> String -> String -> (String, String)-pretty2 unicode expected actual = case (recoverString unicode expected, recoverString unicode actual) of+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_)-    _ -> (rec expected, rec actual)-  where-    rec = if unicode then urecover else id+    (Just expected_, Just actual_) | expected_ /= actual_ -> (expected_, actual_)+    _ -> (expected, actual) -    urecover :: String -> String-    urecover xs = maybe xs ushow $ readMaybe xs+recoverString :: String -> Maybe String+recoverString xs = case xs of+  '"' : _ -> case reverse xs of+    '"' : _ -> readMaybe xs+    _ -> Nothing+  _ -> Nothing -recoverString :: Bool -> String -> Maybe String-recoverString unicode input = case readMaybe input of+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'+    isSafe c = (unicode || isAscii c) && not (isControl c) || c == '\n'  pretty :: Bool -> String -> Maybe String pretty unicode = parseValue >=> render_
src/Test/Hspec/Core/Formatters/V1.hs view
@@ -62,7 +62,6 @@ 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.Example (Location(..))
src/Test/Hspec/Core/Formatters/V2.hs view
@@ -21,6 +21,9 @@ -- 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 (..)@@ -80,10 +83,9 @@ import           Test.Hspec.Core.Compat hiding (First)  import           Data.Char-import           Data.Maybe import           Test.Hspec.Core.Util import           Test.Hspec.Core.Clock-import           Test.Hspec.Core.Example (Location(..))+import           Test.Hspec.Core.Example (Location(..), Progress) import           Text.Printf import           Test.Hspec.Core.Formatters.Pretty.Unicode (ushow) import           Control.Monad.IO.Class
src/Test/Hspec/Core/Hooks.hs view
@@ -4,7 +4,12 @@ {-# LANGUAGE ConstraintKinds #-} -- | Stability: provisional module Test.Hspec.Core.Hooks (-  before+-- * Types+  Spec+, SpecWith+, ActionWith+-- * Hooks+, before , before_ , beforeWith , beforeAll@@ -109,11 +114,12 @@  -- | Run a custom action before and/or after every spec item. aroundWith :: (ActionWith a -> ActionWith b) -> SpecWith a -> SpecWith b-aroundWith = mapSpecItem_ . modifyAroundAction+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 item params (hook . action)+  }  -- | Wrap an action around the given spec. aroundAll :: HasCallStack => (ActionWith a -> IO ()) -> SpecWith a -> Spec
src/Test/Hspec/Core/QuickCheckUtil.hs view
@@ -22,7 +22,6 @@ import           Prelude () import           Test.Hspec.Core.Compat -import           Data.Maybe import           Data.Int import           System.Random
src/Test/Hspec/Core/Runner.hs view
@@ -75,6 +75,10 @@ , isSuccess , evaluateSummary +-- * Re-exports+, Spec+, SpecWith+ #ifdef TEST , rerunAll , specToEvalForest@@ -86,11 +90,10 @@ import           Prelude () import           Test.Hspec.Core.Compat -import           Data.Maybe import           NonEmpty (nonEmpty) import           System.IO import           System.Environment (getArgs, withArgs)-import           System.Exit+import           System.Exit (exitFailure) import           System.Random import           Control.Monad.ST import           Data.STRef@@ -99,6 +102,7 @@ import qualified Test.QuickCheck as QC  import           Test.Hspec.Core.Util (Path)+import           Test.Hspec.Core.Clock import           Test.Hspec.Core.Spec hiding (pruneTree, pruneForest) import           Test.Hspec.Core.Config import           Test.Hspec.Core.Format (Format, FormatConfig(..))@@ -150,7 +154,7 @@     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.@@ -273,9 +277,6 @@         then runSpecForest spec c_         else return result -runSpecForest_ :: Config -> [SpecTree ()] -> IO SpecResult-runSpecForest_ config spec = runEvalTree config (specToEvalForest config spec)- mapItem :: (Item a -> Item b) -> [SpecTree a] -> [SpecTree b] mapItem f = map (fmap f) @@ -320,14 +321,18 @@   | configFocusedOnly config = spec   | otherwise = focusForest spec -runEvalTree :: Config -> [EvalTree] -> IO SpecResult-runEvalTree config spec = do+runSpecForest_ :: Config -> [SpecTree ()] -> IO SpecResult+runSpecForest_ config spec = do   let-      failOnEmpty = configFailOnEmpty config-      seed = (fromJust . configQuickCheckSeed) config-      qcArgs = configQuickCheckArgs config-      !numberOfItems = countSpecItems spec+    filteredSpec = specToEvalForest config spec+    seed = (fromJust . configQuickCheckSeed) config+    qcArgs = configQuickCheckArgs config+    !numberOfItems = countEvalItems filteredSpec +  when (configFailOnEmpty config && numberOfItems == 0) $ do+    when (countSpecItems spec /= 0) $ do+      die "all spec items have been filtered; failing due to --fail-on=empty"+   concurrentJobs <- case configConcurrentJobs config of     Nothing -> getDefaultConcurrentJobs     Just n -> return n@@ -335,7 +340,7 @@   (reportProgress, useColor) <- colorOutputSupported (configColorMode config) (hSupportsANSI stdout)   outputUnicode <- unicodeOutputSupported (configUnicodeMode config) stdout -  results <- fmap (toSpecResult failOnEmpty) . withHiddenCursor reportProgress stdout $ do+  results <- fmap toSpecResult . withHiddenCursor reportProgress stdout $ do     let       formatConfig = FormatConfig {         formatConfigUseColor = useColor@@ -363,7 +368,7 @@       , evalConfigConcurrentJobs = concurrentJobs       , evalConfigFailFast = configFailFast config       }-    runFormatter evalConfig spec+    runFormatter evalConfig filteredSpec    let     failures :: [Path]@@ -392,8 +397,13 @@   >>> randomize   >>> pruneForest   where+    seed :: Integer     seed = (fromJust . configQuickCheckSeed) config++    params :: Params     params = Params (configQuickCheckArgs config) (configSmallCheckDepth config)++    randomize :: [Tree c a] -> [Tree c a]     randomize       | configRandomize config = randomizeForest seed       | otherwise = id@@ -415,7 +425,12 @@ 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 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 ()@@ -434,8 +449,8 @@ doNotLeakCommandLineArgumentsToExamples = withArgs []  withHiddenCursor :: Bool -> Handle -> IO a -> IO a-withHiddenCursor useColor h-  | useColor  = bracket_ (hHideCursor h) (hShowCursor h)+withHiddenCursor reportProgress h+  | reportProgress  = bracket_ (hHideCursor h) (hShowCursor h)   | otherwise = id  colorOutputSupported :: ColorMode -> IO Bool -> IO (Bool, Bool)@@ -497,5 +512,8 @@   ref <- newSTRef (mkStdGen $ fromIntegral seed)   shuffleForest ref t -countSpecItems :: [Eval.Tree c a] -> 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
@@ -2,38 +2,24 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE RankNTypes #-}--#if MIN_VERSION_base(4,6,0) && !MIN_VERSION_base(4,7,0)--- Control.Concurrent.QSem is deprecated in base-4.6.0.*-{-# OPTIONS_GHC -fno-warn-deprecations #-}-#endif- module Test.Hspec.Core.Runner.Eval (   EvalConfig(..) , EvalTree , Tree(..) , EvalItem(..)+, Concurrency(..) , runFormatter #ifdef TEST , mergeResults-, runSequentially #endif ) 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 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 @@ -44,21 +30,19 @@ import qualified Test.Hspec.Core.Format as Format import           Test.Hspec.Core.Clock import           Test.Hspec.Core.Example.Location-import           Test.Hspec.Core.Example (safeEvaluateResultStatus)+import           Test.Hspec.Core.Example (safeEvaluateResultStatus, exceptionToResultStatus)  import qualified NonEmpty import           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) --- 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)- data EvalConfig = EvalConfig {   evalConfigFormat :: Format , evalConfigConcurrentJobs :: Int@@ -67,6 +51,7 @@  data Env = Env {   envConfig :: EvalConfig+, envFailed :: IORef Bool , envResults :: IORef [(Path, Format.Item)] } @@ -77,14 +62,21 @@  type EvalM = ReaderT Env IO +setFailed :: EvalM ()+setFailed = do+  ref <- asks envFailed+  liftIO $ writeIORef ref True++hasFailed :: EvalM Bool+hasFailed = do+  ref <- asks envFailed+  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@@ -95,6 +87,12 @@  reportItemDone :: Path -> Format.Item -> EvalM () reportItemDone path item = do+  let+    isFailure = case Format.itemResult item of+      Format.Success{} -> False+      Format.Pending{} -> False+      Format.Failure{} -> True+  when isFailure setFailed   addResult path item   formatEvent $ Format.ItemDone path item @@ -116,8 +114,8 @@ 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@@ -125,46 +123,55 @@ -- | Evaluate all examples of a given spec and produce a report. 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+        applyReportProgress item = fmap (. reportProgress timer) item -  bracket start cancel $ \ runningSpecs -> do-    withTimer 0.05 $ \ timer -> do+        runningSpecs :: [RunningTree ()]+        runningSpecs = applyCleanup $ map (fmap applyReportProgress) runningSpecs_ -      format Format.Started-      runReaderT (run . applyCleanup $ map (fmap (fmap (. reportProgress timer) . snd)) runningSpecs) (Env config ref) `finally` do-        results <- reverse <$> readIORef ref-        format (Format.Done results)+        getResults :: IO [(Path, Format.Item)]+        getResults = reverse <$> readIORef (envResults env) -      results <- reverse <$> readIORef ref-      return results+        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+  itemDescription :: String+, itemLocation :: Maybe Location , itemAction :: a } deriving Functor -type Job m progress a = (progress -> m ()) -> m a- type RunningItem = Item (Path -> IO (Seconds, Result)) type RunningTree c = Tree c RunningItem +type RunningItem_ m = Item (Job m Progress (Seconds, Result))+type RunningTree_ m = Tree (IO ()) (RunningItem_ m)+ applyCleanup :: [RunningTree (IO ())] -> [RunningTree ()] applyCleanup = map go   where@@ -211,63 +218,23 @@       Just (name, _) -> Just $ "in " ++ name ++ "-hook:"       Nothing -> Nothing -type RunningItem_ m = (Async (), Item (Job m Progress (Seconds, Result)))-type RunningTree_ m = Tree (IO ()) (RunningItem_ m)--data Semaphore = Semaphore {-  semaphoreWait :: IO ()-, semaphoreSignal :: IO ()-}--parallelizeTree :: MonadIO m => Int -> [EvalTree] -> IO [RunningTree_ m]-parallelizeTree n specs = do-  sem <- newQSem n-  mapM (traverse $ parallelizeItem sem) specs--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)--parallelize :: MonadIO m => Semaphore -> Bool -> Job IO progress a -> IO (Async (), Job m progress (Seconds, a))-parallelize sem isParallelizable-  | isParallelizable = runParallel sem-  | otherwise = runSequentially--runSequentially :: MonadIO m => Job IO progress a -> IO (Async (), Job m progress (Seconds, a))-runSequentially action = do-  mvar <- newEmptyMVar-  (asyncAction, evalAction) <- runParallel (Semaphore (takeMVar mvar) pass) action-  return (asyncAction, \ notifyPartial -> liftIO (putMVar mvar ()) >> evalAction notifyPartial)--data Parallel progress a = Partial progress | Return a+enqueueItems :: MonadIO m => JobQueue -> [EvalTree] -> IO [RunningTree_ m]+enqueueItems queue = mapM (traverse $ enqueueItem queue) -runParallel :: forall m progress a. MonadIO m => Semaphore -> Job IO progress a -> IO (Async (), Job m progress (Seconds, a))-runParallel Semaphore{..} action = do-  mvar <- newEmptyMVar-  asyncAction <- async $ bracket_ semaphoreWait semaphoreSignal (worker mvar)-  return (asyncAction, eval mvar)+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-    worker :: MVar (Parallel progress (Seconds, a)) -> IO ()-    worker mvar = do-      let partialCallback = replaceMVar mvar . Partial-      result <- measure $ action partialCallback-      replaceMVar mvar (Return result)--    eval :: MVar (Parallel progress (Seconds, a)) -> (progress -> 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--replaceMVar :: MVar a -> a -> IO ()-replaceMVar mvar p = tryTakeMVar mvar >> putMVar mvar p+    exceptionToResult :: SomeException -> IO (Seconds, Result)+    exceptionToResult err = (,) 0 . Result "" <$> exceptionToResultStatus err -run :: [RunningTree ()] -> EvalM ()-run specs = do+eval :: [RunningTree ()] -> EvalM ()+eval specs = do   failFast <- asks (evalConfigFailFast . envConfig)   sequenceActions failFast (concatMap foldSpec specs)   where@@ -320,13 +287,5 @@       action       stopNow <- case failFast of         False -> return False-        True -> any itemIsFailure <$> getResults+        True -> hasFailed       unless stopNow (go actions)--    itemIsFailure :: (Path, Format.Item) -> Bool-    itemIsFailure = isFailure . Format.itemResult . snd-      where-        isFailure r = case r of-          Format.Success{} -> False-          Format.Pending{} -> False-          Format.Failure{} -> True
+ src/Test/Hspec/Core/Runner/JobQueue.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ConstraintKinds #-}++#if MIN_VERSION_base(4,6,0) && !MIN_VERSION_base(4,7,0)+-- Control.Concurrent.QSem is deprecated in base-4.6.0.*+{-# OPTIONS_GHC -fno-warn-deprecations #-}+#endif++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, AsyncCancelled(..), async, waitCatch, asyncThreadId)++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++    cancelMany :: [Async a] -> IO ()+    cancelMany jobs = do+      mapM_ notifyCancel jobs+      mapM_ waitCatch jobs++    notifyCancel :: Async a -> IO ()+    notifyCancel = flip throwTo AsyncCancelled . asyncThreadId++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/Result.hs view
@@ -59,11 +59,11 @@   | ResultItemFailure   deriving (Eq, Show) -toSpecResult :: Bool -> [(Path, Format.Item)] -> SpecResult-toSpecResult failOnEmpty results = SpecResult items success+toSpecResult :: [(Path, Format.Item)] -> SpecResult+toSpecResult results = SpecResult items success   where     items = map toResultItem results-    success = not (failOnEmpty && null results) && all (not . resultItemIsFailure) items+    success = all (not . resultItemIsFailure) items  toResultItem :: (Path, Format.Item) -> ResultItem toResultItem (path, item) = ResultItem path status
src/Test/Hspec/Core/Spec.hs view
@@ -73,6 +73,10 @@ , Test.Hspec.Core.Tree.location  , focusForest++-- * Re-exports+, HasCallStack+, Expectation ) where  import           Prelude ()
src/Test/Hspec/Core/Tree.hs view
@@ -29,7 +29,6 @@  import           Data.CallStack (SrcLoc(..)) import qualified Data.CallStack as CallStack-import           Data.Maybe  import           Test.Hspec.Core.Example @@ -126,8 +125,14 @@       | 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)+specItem :: (HasCallStack, Example e) => String -> e -> SpecTree (Arg e)+specItem s e = Leaf Item {+    itemRequirement = requirement+  , itemLocation = location+  , itemIsParallelizable = Nothing+  , itemIsFocused = False+  , itemExample = safeEvaluateExample e+  }   where     requirement :: HasCallStack => String     requirement
test/Helper.hs view
@@ -8,6 +8,7 @@ , module Test.Hspec.Core.Compat , module Test.QuickCheck , module System.IO.Silently+, Seconds(..) , sleep , timeout , defaultParams
test/Test/Hspec/Core/Formatters/PrettySpec.hs view
@@ -19,23 +19,53 @@         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 "parses back multi-line string literals" $ do-      recoverString True (show "foo\nbar\nbaz\n") `shouldBe` Just "foo\nbar\nbaz\n"+    it "recovers a string" $ do+      recoverString (show "foo") `shouldBe` Just "foo" -    it "does not parse back string literals that contain control characters" $ do-      recoverString True (show "foo\n\tbar\nbaz\n") `shouldBe` Nothing+    it "recovers the empty string" $ do+      recoverString (show "") `shouldBe` Just "" -    it "does not parse back string literals that span a single line" $ do-      recoverString True (show "foo\n") `shouldBe` Nothing+    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 "parses back string literals that contain unicode" $ do-        recoverString True (show "foo\n\955\nbaz\n") `shouldBe` Just "foo\n\955\nbaz\n"+      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 parse back string literals that contain unicode" $ do-        recoverString False (show "foo\n\955\nbaz\n") `shouldBe` Nothing+      it "does not recover string literals that contain unicode" $ do+        recoverMultiLineString False (show "foo\n\955\nbaz\n") `shouldBe` Nothing    describe "pretty" $ do     let person = Person "Joe" 23
test/Test/Hspec/Core/Formatters/V2Spec.hs view
@@ -100,7 +100,7 @@       formatter = checks       config = H.defaultConfig { H.configFormat = Just $ formatterToFormat formatter } -    it "" $ do+    it "prints unicode check marks" $ do       r <- captureLines . H.hspecWithResult config $ do         H.it "foo" True       normalizeSummary r `shouldBe` [@@ -111,7 +111,7 @@         , "1 example, 0 failures"         ] -    it "" $ do+    it "uses ASCII as a fallback" $ do       r <- captureLines . H.hspecWithResult config { H.configUnicodeMode = H.UnicodeNever } $ do         H.it "foo" True       normalizeSummary r `shouldBe` [
test/Test/Hspec/Core/Runner/EvalSpec.hs view
@@ -73,13 +73,3 @@         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 (\_ -> pass)-      readIORef ref `shouldReturn` [42 :: Int]-      (_, ()) <- actionA (\_ -> pass)-      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/ResultSpec.hs view
@@ -16,21 +16,12 @@      context "when all spec items passed" $ do       it "returns True" $ do-        specResultSuccess (toSpecResult False [item Success]) `shouldBe` True+        specResultSuccess (toSpecResult [item Success]) `shouldBe` True      context "with a failed spec item" $ do       it "returns False" $ do-        specResultSuccess (toSpecResult False [item Success, item failure]) `shouldBe` False+        specResultSuccess (toSpecResult [item Success, item failure]) `shouldBe` False      context "with an empty result list" $ do       it "returns True" $ do-        specResultSuccess (toSpecResult False []) `shouldBe` True--    context "when configFailOnEmpty is True" $ do-      context "when all spec items passed" $ do-        it "returns True" $ do-          specResultSuccess (toSpecResult True [item Success]) `shouldBe` True--      context "with an empty result list" $ do-        it "returns False" $ do-          specResultSuccess (toSpecResult True []) `shouldBe` False+        specResultSuccess (toSpecResult []) `shouldBe` True
test/Test/Hspec/Core/RunnerSpec.hs view
@@ -270,15 +270,12 @@      context "with --fail-on=empty" $ do       it "fails if no spec items have been run" $ do-        (out, r) <- capture . try . withArgs ["--skip=", "--fail-on=empty"] . H.hspec $ 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 [-            ""-          , ""-          , "Finished in 0.0000 seconds"-          , "0 examples, 0 failures"+            "spec: all spec items have been filtered; failing due to --fail-on=empty"           ]         r `shouldBe` Left (ExitFailure 1) @@ -697,6 +694,16 @@     it "treats uncaught exceptions as failure" $ do       hspecResult_  $ do         H.it "foobar" throwException_+      `shouldReturn` H.Summary 1 1++    it "handles unguarded exceptions in runner" $ do+      let+        throwExceptionThatIsNotGuardedBy_safeTry :: H.Item () -> H.Item ()+        throwExceptionThatIsNotGuardedBy_safeTry item = item {+          H.itemExample = \ _params _hook _progress -> throwIO DivideByZero+        }+      hspecResult_ $ H.mapSpecItem_ throwExceptionThatIsNotGuardedBy_safeTry $ do+        H.it "foo" True       `shouldReturn` H.Summary 1 1      it "uses the specdoc formatter by default" $ do
test/Test/Hspec/Core/SpecSpec.hs view
@@ -18,8 +18,13 @@  spec :: Spec spec = do-  let runSpecM = fmap snd . H.runSpecM+  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 =@@ -51,8 +56,7 @@   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@@ -61,8 +65,7 @@      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)@@ -81,8 +84,7 @@   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
version.yaml view
@@ -1,1 +1,1 @@-&version 2.10.8+&version 2.10.9