{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}

-- |
-- Stability: provisional
module Test.Hspec.Core.Runner (
-- * 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:

@
hspec = `evalSpec` `defaultConfig` >=> \\ (config, spec) ->
      `getArgs`
  >>= `readConfig` config
  >>= `withArgs` [] . `runSpecForest` spec
  >>= `evaluateResult`
@

If you need more control over how a spec is run use these primitives individually.

-}
  hspec
, evalSpec
, runSpecForest
, evaluateResult

-- * Config
, Config (..)
, ColorMode (..)
, UnicodeMode(..)
, Path
, defaultConfig
, registerFormatter
, registerDefaultFormatter
, configAddFilter
, readConfig

-- * Result

-- ** Spec Result
, Test.Hspec.Core.Runner.Result.SpecResult
, Test.Hspec.Core.Runner.Result.specResultItems
, Test.Hspec.Core.Runner.Result.specResultSuccess

-- ** 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(..)

-- * Legacy
-- | The following primitives are deprecated.  Use `runSpecForest` instead.
, hspecWith
, hspecResult
, hspecWithResult
, runSpec

-- ** Summary
, Summary (..)
, toSummary
, isSuccess
, evaluateSummary

#ifdef TEST
, rerunAll
, specToEvalForest
, colorOutputSupported
, unicodeOutputSupported
#endif
) where

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 qualified Control.Exception as E
import           System.Random
import           Control.Monad.ST
import           Data.STRef

import           System.Console.ANSI (hSupportsANSI, hHideCursor, hShowCursor)
import qualified Test.QuickCheck as QC

import           Test.Hspec.Core.Util (Path)
import           Test.Hspec.Core.Spec hiding (pruneTree, pruneForest)
import           Test.Hspec.Core.Config
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.FailureReport
import           Test.Hspec.Core.QuickCheckUtil
import           Test.Hspec.Core.Shuffle

import           Test.Hspec.Core.Runner.PrintSlowSpecItems
import           Test.Hspec.Core.Runner.Eval hiding (Tree(..))
import qualified Test.Hspec.Core.Runner.Eval as Eval
import           Test.Hspec.Core.Runner.Result

-- |
-- Make a formatter available for use with @--format@.
--
-- @since 2.10.5
registerFormatter :: (String, FormatConfig -> IO Format) -> Config -> Config
registerFormatter :: (String, FormatConfig -> IO Format) -> Config -> Config
registerFormatter (String, FormatConfig -> IO Format)
formatter Config
config = Config
config { configAvailableFormatters :: [(String, FormatConfig -> IO Format)]
configAvailableFormatters = (String, FormatConfig -> IO Format)
formatter forall a. a -> [a] -> [a]
: Config -> [(String, FormatConfig -> IO Format)]
configAvailableFormatters Config
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
registerDefaultFormatter :: (String, FormatConfig -> IO Format) -> Config -> Config
registerDefaultFormatter formatter :: (String, FormatConfig -> IO Format)
formatter@(String
_, FormatConfig -> IO Format
format) Config
config = ((String, FormatConfig -> IO Format) -> Config -> Config
registerFormatter (String, FormatConfig -> IO Format)
formatter Config
config) { configFormat :: Maybe (FormatConfig -> IO Format)
configFormat = forall a. a -> Maybe a
Just FormatConfig -> IO Format
format }

applyFilterPredicates :: Config -> [Tree c EvalItem] -> [Tree c EvalItem]
applyFilterPredicates :: forall c. Config -> [Tree c EvalItem] -> [Tree c EvalItem]
applyFilterPredicates Config
c = forall a c. ([String] -> a -> Bool) -> [Tree c a] -> [Tree c a]
filterForestWithLabels [String] -> EvalItem -> Bool
p
  where
    include :: Path -> Bool
    include :: Path -> Bool
include = forall a. a -> Maybe a -> a
fromMaybe (forall a b. a -> b -> a
const Bool
True) (Config -> Maybe (Path -> Bool)
configFilterPredicate Config
c)

    skip :: Path -> Bool
    skip :: Path -> Bool
skip = forall a. a -> Maybe a -> a
fromMaybe (forall a b. a -> b -> a
const Bool
False) (Config -> Maybe (Path -> Bool)
configSkipPredicate Config
c)

    p :: [String] -> EvalItem -> Bool
    p :: [String] -> EvalItem -> Bool
p [String]
groups EvalItem
item = Path -> Bool
include Path
path Bool -> Bool -> Bool
&& Bool -> Bool
not (Path -> Bool
skip Path
path)
      where
        path :: Path
path = ([String]
groups, EvalItem -> String
evalItemDescription EvalItem
item)

applyDryRun :: Config -> [EvalItemTree] -> [EvalItemTree]
applyDryRun :: Config -> [EvalItemTree] -> [EvalItemTree]
applyDryRun Config
c
  | Config -> Bool
configDryRun Config
c = forall a b c d. (a -> b) -> (c -> d) -> [Tree a c] -> [Tree b d]
bimapForest IO () -> IO ()
removeCleanup EvalItem -> EvalItem
markSuccess
  | Bool
otherwise = forall a. a -> a
id
  where
    removeCleanup :: IO () -> IO ()
    removeCleanup :: IO () -> IO ()
removeCleanup IO ()
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

    markSuccess :: EvalItem -> EvalItem
    markSuccess :: EvalItem -> EvalItem
markSuccess EvalItem
item = EvalItem
item {evalItemAction :: ProgressCallback -> IO Result
evalItemAction = \ ProgressCallback
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> ResultStatus -> Result
Result String
"" ResultStatus
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 desirable.  Use `evalSpec` and `runSpecForest` if you need
-- more control over these aspects.
hspec :: Spec -> IO ()
hspec :: Spec -> IO ()
hspec = forall a. Config -> SpecWith a -> IO (Config, [SpecTree a])
evalSpec Config
defaultConfig forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \ (Config
config, [SpecTree ()]
spec) ->
      IO [String]
getArgs
  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Config -> [String] -> IO Config
readConfig Config
config
  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. IO a -> IO a
doNotLeakCommandLineArgumentsToExamples forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SpecTree ()] -> Config -> IO SpecResult
runSpecForest [SpecTree ()]
spec
  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SpecResult -> IO ()
evaluateResult

-- |
-- 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 :: forall a. Config -> SpecWith a -> IO (Config, [SpecTree a])
evalSpec Config
config SpecWith a
spec = do
  (Endo Config -> Config
f, [SpecTree a]
forest) <- forall a. SpecWith a -> IO (Endo Config, [SpecTree a])
runSpecM SpecWith a
spec
  forall (m :: * -> *) a. Monad m => a -> m a
return (Config -> Config
f Config
config, [SpecTree a]
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 :: Config -> IO Config
ensureSeed Config
c = case Config -> Maybe Integer
configQuickCheckSeed Config
c of
  Maybe Integer
Nothing -> do
    Int
seed <- IO Int
newSeed
    forall (m :: * -> *) a. Monad m => a -> m a
return Config
c {configQuickCheckSeed :: Maybe Integer
configQuickCheckSeed = forall a. a -> Maybe a
Just (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
seed)}
  Maybe Integer
_       -> forall (m :: * -> *) a. Monad m => a -> m a
return Config
c

-- | Run given spec with custom options.
-- This is similar to `hspec`, but more flexible.
hspecWith :: Config -> Spec -> IO ()
hspecWith :: Config -> Spec -> IO ()
hspecWith Config
defaults = forall a. Config -> SpecWith a -> IO (Config, [SpecTree a])
evalSpec Config
defaults forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \ (Config
config, [SpecTree ()]
spec) ->
      IO [String]
getArgs
  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Config -> [String] -> IO Config
readConfig Config
config
  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. IO a -> IO a
doNotLeakCommandLineArgumentsToExamples forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SpecTree ()] -> Config -> IO SpecResult
runSpecForest [SpecTree ()]
spec
  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SpecResult -> IO ()
evaluateResult

-- | `True` if the given `Summary` indicates that there were no
-- failures, `False` otherwise.
isSuccess :: Summary -> Bool
isSuccess :: Summary -> Bool
isSuccess Summary
summary = Summary -> Int
summaryFailures Summary
summary forall a. Eq a => a -> a -> Bool
== Int
0

-- | Exit with `exitFailure` if the given `Summary` indicates that there was at
-- least one failure.
evaluateSummary :: Summary -> IO ()
evaluateSummary :: Summary -> IO ()
evaluateSummary Summary
summary = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Summary -> Bool
isSuccess Summary
summary) forall a. IO a
exitFailure

evaluateResult :: SpecResult -> IO ()
evaluateResult :: SpecResult -> IO ()
evaluateResult SpecResult
result = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SpecResult -> Bool
specResultSuccess SpecResult
result) forall a. IO a
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 -> IO Summary
hspecResult = Config -> Spec -> IO Summary
hspecWithResult Config
defaultConfig

-- | Run given spec with custom options and returns a summary of the test run.
--
-- /Note/: `hspecWithResult` does not exit with `exitFailure` on failing spec
-- items.  If you need this, you have to check the `Summary` yourself and act
-- accordingly.
hspecWithResult :: Config -> Spec -> IO Summary
hspecWithResult :: Config -> Spec -> IO Summary
hspecWithResult Config
defaults = forall a. Config -> SpecWith a -> IO (Config, [SpecTree a])
evalSpec Config
defaults forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \ (Config
config, [SpecTree ()]
spec) ->
      IO [String]
getArgs
  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Config -> [String] -> IO Config
readConfig Config
config
  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. IO a -> IO a
doNotLeakCommandLineArgumentsToExamples forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SpecResult -> Summary
toSummary forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SpecTree ()] -> Config -> IO SpecResult
runSpecForest [SpecTree ()]
spec

-- |
-- /Note/: `runSpec` is deprecated. It ignores any modifications applied
-- through `modifyConfig`.  Use `evalSpec` and `runSpecForest` instead.
runSpec :: Spec -> Config -> IO Summary
runSpec :: Spec -> Config -> IO Summary
runSpec Spec
spec Config
config = forall a. Config -> SpecWith a -> IO (Config, [SpecTree a])
evalSpec Config
defaultConfig Spec
spec forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SpecResult -> Summary
toSummary forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip [SpecTree ()] -> Config -> IO SpecResult
runSpecForest Config
config forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd

-- |
-- `runSpecForest` is the most basic primitive to run a spec. `hspec` is
-- defined in terms of @runSpecForest@:
--
-- @
-- hspec = `evalSpec` `defaultConfig` >=> \\ (config, spec) ->
--       `getArgs`
--   >>= `readConfig` config
--   >>= `withArgs` [] . runSpecForest spec
--   >>= `evaluateResult`
-- @
--
-- @since 2.10.0
runSpecForest :: [SpecTree ()] -> Config -> IO SpecResult
runSpecForest :: [SpecTree ()] -> Config -> IO SpecResult
runSpecForest [SpecTree ()]
spec Config
c_ = do
  Maybe FailureReport
oldFailureReport <- Config -> IO (Maybe FailureReport)
readFailureReportOnRerun Config
c_

  Config
c <- Config -> IO Config
ensureSeed (Maybe FailureReport -> Config -> Config
applyFailureReport Maybe FailureReport
oldFailureReport Config
c_)

  if Config -> Bool
configRerunAllOnSuccess Config
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 Config -> Maybe FailureReport -> IO SpecResult
rerunAllMode Config
c Maybe FailureReport
oldFailureReport
    else Config -> IO SpecResult
normalMode Config
c
  where
    normalMode :: Config -> IO SpecResult
normalMode Config
c = Config -> [SpecTree ()] -> IO SpecResult
runSpecForest_ Config
c [SpecTree ()]
spec
    rerunAllMode :: Config -> Maybe FailureReport -> IO SpecResult
rerunAllMode Config
c Maybe FailureReport
oldFailureReport = do
      SpecResult
result <- Config -> [SpecTree ()] -> IO SpecResult
runSpecForest_ Config
c [SpecTree ()]
spec
      if Config -> Maybe FailureReport -> SpecResult -> Bool
rerunAll Config
c Maybe FailureReport
oldFailureReport SpecResult
result
        then [SpecTree ()] -> Config -> IO SpecResult
runSpecForest [SpecTree ()]
spec Config
c_
        else forall (m :: * -> *) a. Monad m => a -> m a
return SpecResult
result

runSpecForest_ :: Config -> [SpecTree ()] -> IO SpecResult
runSpecForest_ :: Config -> [SpecTree ()] -> IO SpecResult
runSpecForest_ Config
config [SpecTree ()]
spec = Config -> [EvalTree] -> IO SpecResult
runEvalTree Config
config (Config -> [SpecTree ()] -> [EvalTree]
specToEvalForest Config
config [SpecTree ()]
spec)

mapItem :: (Item a -> Item b) -> [SpecTree a] -> [SpecTree b]
mapItem :: forall a b. (Item a -> Item b) -> [SpecTree a] -> [SpecTree b]
mapItem Item a -> Item b
f = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Item a -> Item b
f)

failFocusedItems :: Config -> [SpecTree a] -> [SpecTree a]
failFocusedItems :: forall a. Config -> [SpecTree a] -> [SpecTree a]
failFocusedItems Config
config
  | Config -> Bool
configFailOnFocused Config
config = forall a b. (Item a -> Item b) -> [SpecTree a] -> [SpecTree b]
mapItem forall a. Item a -> Item a
failFocused
  | Bool
otherwise = forall a. a -> a
id

failFocused :: Item a -> Item a
failFocused :: forall a. Item a -> Item a
failFocused Item a
item = Item a
item {itemExample :: Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result
itemExample = Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result
example}
  where
    failure :: ResultStatus
failure = Maybe Location -> FailureReason -> ResultStatus
Failure forall a. Maybe a
Nothing (String -> FailureReason
Reason String
"item is focused; failing due to --fail-on=focused")
    example :: Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result
example
      | forall a. Item a -> Bool
itemIsFocused Item a
item = \ Params
params ActionWith a -> IO ()
hook ProgressCallback
p -> do
          Result String
info ResultStatus
status <- forall a.
Item a
-> Params
-> (ActionWith a -> IO ())
-> ProgressCallback
-> IO Result
itemExample Item a
item Params
params ActionWith a -> IO ()
hook ProgressCallback
p
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> ResultStatus -> Result
Result String
info forall a b. (a -> b) -> a -> b
$ case ResultStatus
status of
            ResultStatus
Success -> ResultStatus
failure
            Pending Maybe Location
_ Maybe String
_ -> ResultStatus
failure
            Failure{} -> ResultStatus
status
      | Bool
otherwise = forall a.
Item a
-> Params
-> (ActionWith a -> IO ())
-> ProgressCallback
-> IO Result
itemExample Item a
item

failPendingItems :: Config -> [SpecTree a] -> [SpecTree a]
failPendingItems :: forall a. Config -> [SpecTree a] -> [SpecTree a]
failPendingItems Config
config
  | Config -> Bool
configFailOnPending Config
config = forall a b. (Item a -> Item b) -> [SpecTree a] -> [SpecTree b]
mapItem forall a. Item a -> Item a
failPending
  | Bool
otherwise = forall a. a -> a
id

failPending :: Item a -> Item a
failPending :: forall a. Item a -> Item a
failPending Item a
item = Item a
item {itemExample :: Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result
itemExample = Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result
example}
  where
    example :: Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result
example Params
params ActionWith a -> IO ()
hook ProgressCallback
p = do
      Result String
info ResultStatus
status <- forall a.
Item a
-> Params
-> (ActionWith a -> IO ())
-> ProgressCallback
-> IO Result
itemExample Item a
item Params
params ActionWith a -> IO ()
hook ProgressCallback
p
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> ResultStatus -> Result
Result String
info forall a b. (a -> b) -> a -> b
$ case ResultStatus
status of
        Pending Maybe Location
loc Maybe String
_ -> Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
loc (String -> FailureReason
Reason String
"item is pending; failing due to --fail-on=pending")
        ResultStatus
_ -> ResultStatus
status

focusSpec :: Config -> [SpecTree a] -> [SpecTree a]
focusSpec :: forall a. Config -> [SpecTree a] -> [SpecTree a]
focusSpec Config
config [SpecTree a]
spec
  | Config -> Bool
configFocusedOnly Config
config = [SpecTree a]
spec
  | Bool
otherwise = forall a. [SpecTree a] -> [SpecTree a]
focusForest [SpecTree a]
spec

runEvalTree :: Config -> [EvalTree] -> IO SpecResult
runEvalTree :: Config -> [EvalTree] -> IO SpecResult
runEvalTree Config
config [EvalTree]
spec = do
  let
      failOnEmpty :: Bool
failOnEmpty = Config -> Bool
configFailOnEmpty Config
config
      seed :: Integer
seed = (forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Maybe Integer
configQuickCheckSeed) Config
config
      qcArgs :: Args
qcArgs = Config -> Args
configQuickCheckArgs Config
config
      !numberOfItems :: Int
numberOfItems = forall c a. [Tree c a] -> Int
countSpecItems [EvalTree]
spec

  Int
concurrentJobs <- case Config -> Maybe Int
configConcurrentJobs Config
config of
    Maybe Int
Nothing -> IO Int
getDefaultConcurrentJobs
    Just Int
n -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
n

  (Bool
reportProgress, Bool
useColor) <- ColorMode -> IO Bool -> IO (Bool, Bool)
colorOutputSupported (Config -> ColorMode
configColorMode Config
config) (Handle -> IO Bool
hSupportsANSI Handle
stdout)
  Bool
outputUnicode <- UnicodeMode -> Handle -> IO Bool
unicodeOutputSupported (Config -> UnicodeMode
configUnicodeMode Config
config) Handle
stdout

  SpecResult
results <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Bool -> [(Path, Item)] -> SpecResult
toSpecResult Bool
failOnEmpty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Bool -> Handle -> IO a -> IO a
withHiddenCursor Bool
reportProgress Handle
stdout forall a b. (a -> b) -> a -> b
$ do
    let
      formatConfig :: FormatConfig
formatConfig = FormatConfig {
        formatConfigUseColor :: Bool
formatConfigUseColor = Bool
useColor
      , formatConfigReportProgress :: Bool
formatConfigReportProgress = Bool
reportProgress
      , formatConfigOutputUnicode :: Bool
formatConfigOutputUnicode = Bool
outputUnicode
      , formatConfigUseDiff :: Bool
formatConfigUseDiff = Config -> Bool
configDiff Config
config
      , formatConfigDiffContext :: Maybe Int
formatConfigDiffContext = Config -> Maybe Int
configDiffContext Config
config
      , formatConfigExternalDiff :: Maybe (String -> String -> IO ())
formatConfigExternalDiff = if Config -> Bool
configDiff Config
config then (forall a b. (a -> b) -> a -> b
$ Config -> Maybe Int
configDiffContext Config
config) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config -> Maybe (Maybe Int -> String -> String -> IO ())
configExternalDiff Config
config else forall a. Maybe a
Nothing
      , formatConfigPrettyPrint :: Bool
formatConfigPrettyPrint = Config -> Bool
configPrettyPrint Config
config
      , formatConfigPrettyPrintFunction :: Maybe (String -> String -> (String, String))
formatConfigPrettyPrintFunction = if Config -> Bool
configPrettyPrint Config
config then forall a. a -> Maybe a
Just (Config -> Bool -> String -> String -> (String, String)
configPrettyPrintFunction Config
config Bool
outputUnicode) else forall a. Maybe a
Nothing
      , formatConfigPrintTimes :: Bool
formatConfigPrintTimes = Config -> Bool
configTimes Config
config
      , formatConfigHtmlOutput :: Bool
formatConfigHtmlOutput = Config -> Bool
configHtmlOutput Config
config
      , formatConfigPrintCpuTime :: Bool
formatConfigPrintCpuTime = Config -> Bool
configPrintCpuTime Config
config
      , formatConfigUsedSeed :: Integer
formatConfigUsedSeed = Integer
seed
      , formatConfigExpectedTotalCount :: Int
formatConfigExpectedTotalCount = Int
numberOfItems
      }

      formatter :: FormatConfig -> IO Format
formatter = forall a. a -> Maybe a -> a
fromMaybe (Formatter -> FormatConfig -> IO Format
V2.formatterToFormat Formatter
V2.checks) (Config -> Maybe (FormatConfig -> IO Format)
configFormat Config
config forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Formatter -> FormatConfig -> IO Format
V1.formatterToFormat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config -> Maybe Formatter
configFormatter Config
config)

    Format
format <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id Int -> Format -> Format
printSlowSpecItems (Config -> Maybe Int
configPrintSlowItems Config
config) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FormatConfig -> IO Format
formatter FormatConfig
formatConfig

    let
      evalConfig :: EvalConfig
evalConfig = EvalConfig {
        evalConfigFormat :: Format
evalConfigFormat = Format
format
      , evalConfigConcurrentJobs :: Int
evalConfigConcurrentJobs = Int
concurrentJobs
      , evalConfigFailFast :: Bool
evalConfigFailFast = Config -> Bool
configFailFast Config
config
      }
    EvalConfig -> [EvalTree] -> IO [(Path, Item)]
runFormatter EvalConfig
evalConfig [EvalTree]
spec

  let
    failures :: [Path]
    failures :: [Path]
failures = forall a b. (a -> b) -> [a] -> [b]
map ResultItem -> Path
resultItemPath forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ResultItem -> Bool
resultItemIsFailure forall a b. (a -> b) -> a -> b
$ SpecResult -> [ResultItem]
specResultItems SpecResult
results

  Config -> Integer -> Args -> [Path] -> IO ()
dumpFailureReport Config
config Integer
seed Args
qcArgs [Path]
failures

  forall (m :: * -> *) a. Monad m => a -> m a
return SpecResult
results

toSummary :: SpecResult -> Summary
toSummary :: SpecResult -> Summary
toSummary SpecResult
result = Summary {
  summaryExamples :: Int
summaryExamples = forall (t :: * -> *) a. Foldable t => t a -> Int
length [ResultItem]
items
, summaryFailures :: Int
summaryFailures = forall (t :: * -> *) a. Foldable t => t a -> Int
length [ResultItem]
failures
} where
    items :: [ResultItem]
items = SpecResult -> [ResultItem]
specResultItems SpecResult
result
    failures :: [ResultItem]
failures = forall a. (a -> Bool) -> [a] -> [a]
filter ResultItem -> Bool
resultItemIsFailure [ResultItem]
items

specToEvalForest :: Config -> [SpecTree ()] -> [EvalTree]
specToEvalForest :: Config -> [SpecTree ()] -> [EvalTree]
specToEvalForest Config
config =
      forall a. Config -> [SpecTree a] -> [SpecTree a]
failFocusedItems Config
config
  forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a. Config -> [SpecTree a] -> [SpecTree a]
failPendingItems Config
config
  forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a. Config -> [SpecTree a] -> [SpecTree a]
focusSpec Config
config
  forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Params -> [SpecTree ()] -> [EvalItemTree]
toEvalItemForest Params
params
  forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Config -> [EvalItemTree] -> [EvalItemTree]
applyDryRun Config
config
  forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall c. Config -> [Tree c EvalItem] -> [Tree c EvalItem]
applyFilterPredicates Config
config
  forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall {c} {a}. [Tree c a] -> [Tree c a]
randomize
  forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall c a. [Tree c a] -> [Tree c a]
pruneForest
  where
    seed :: Integer
seed = (forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Maybe Integer
configQuickCheckSeed) Config
config
    params :: Params
params = Args -> Maybe Int -> Params
Params (Config -> Args
configQuickCheckArgs Config
config) (Config -> Maybe Int
configSmallCheckDepth Config
config)
    randomize :: [Tree c a] -> [Tree c a]
randomize
      | Config -> Bool
configRandomize Config
config = forall c a. Integer -> [Tree c a] -> [Tree c a]
randomizeForest Integer
seed
      | Bool
otherwise = forall a. a -> a
id

pruneForest :: [Tree c a] -> [Eval.Tree c a]
pruneForest :: forall c a. [Tree c a] -> [Tree c a]
pruneForest = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall c a. Tree c a -> Maybe (Tree c a)
pruneTree

pruneTree :: Tree c a -> Maybe (Eval.Tree c a)
pruneTree :: forall c a. Tree c a -> Maybe (Tree c a)
pruneTree Tree c a
node = case Tree c a
node of
  Node String
group [Tree c a]
xs -> forall c a. String -> NonEmpty (Tree c a) -> Tree c a
Eval.Node String
group forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {c} {a}. [Tree c a] -> Maybe (NonEmpty (Tree c a))
prune [Tree c a]
xs
  NodeWithCleanup Maybe (String, Location)
loc c
action [Tree c a]
xs -> forall c a.
Maybe (String, Location) -> c -> NonEmpty (Tree c a) -> Tree c a
Eval.NodeWithCleanup Maybe (String, Location)
loc c
action forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {c} {a}. [Tree c a] -> Maybe (NonEmpty (Tree c a))
prune [Tree c a]
xs
  Leaf a
item -> forall a. a -> Maybe a
Just (forall c a. a -> Tree c a
Eval.Leaf a
item)
  where
    prune :: [Tree c a] -> Maybe (NonEmpty (Tree c a))
prune = forall a. [a] -> Maybe (NonEmpty a)
nonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c a. [Tree c a] -> [Tree c a]
pruneForest

type EvalItemTree = Tree (IO ()) EvalItem

toEvalItemForest :: Params -> [SpecTree ()] -> [EvalItemTree]
toEvalItemForest :: Params -> [SpecTree ()] -> [EvalItemTree]
toEvalItemForest Params
params = forall a b c d. (a -> b) -> (c -> d) -> [Tree a c] -> [Tree b d]
bimapForest forall a. a -> a
id Item () -> EvalItem
toEvalItem forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c. (a -> Bool) -> [Tree c a] -> [Tree c a]
filterForest forall a. Item a -> Bool
itemIsFocused
  where
    toEvalItem :: Item () -> EvalItem
    toEvalItem :: Item () -> EvalItem
toEvalItem (Item String
requirement Maybe Location
loc Maybe Bool
isParallelizable Bool
_isFocused Params -> (ActionWith () -> IO ()) -> ProgressCallback -> IO Result
e) = String
-> Maybe Location
-> Bool
-> (ProgressCallback -> IO Result)
-> EvalItem
EvalItem String
requirement Maybe Location
loc (forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
isParallelizable) (Params -> (ActionWith () -> IO ()) -> ProgressCallback -> IO Result
e Params
params ActionWith () -> IO ()
withUnit)

    withUnit :: ActionWith () -> IO ()
    withUnit :: ActionWith () -> IO ()
withUnit ActionWith ()
action = ActionWith ()
action ()

dumpFailureReport :: Config -> Integer -> QC.Args -> [Path] -> IO ()
dumpFailureReport :: Config -> Integer -> Args -> [Path] -> IO ()
dumpFailureReport Config
config Integer
seed Args
qcArgs [Path]
xs = do
  Config -> FailureReport -> IO ()
writeFailureReport Config
config FailureReport {
      failureReportSeed :: Integer
failureReportSeed = Integer
seed
    , failureReportMaxSuccess :: Int
failureReportMaxSuccess = Args -> Int
QC.maxSuccess Args
qcArgs
    , failureReportMaxSize :: Int
failureReportMaxSize = Args -> Int
QC.maxSize Args
qcArgs
    , failureReportMaxDiscardRatio :: Int
failureReportMaxDiscardRatio = Args -> Int
QC.maxDiscardRatio Args
qcArgs
    , failureReportPaths :: [Path]
failureReportPaths = [Path]
xs
    }

doNotLeakCommandLineArgumentsToExamples :: IO a -> IO a
doNotLeakCommandLineArgumentsToExamples :: forall a. IO a -> IO a
doNotLeakCommandLineArgumentsToExamples = forall a. [String] -> IO a -> IO a
withArgs []

withHiddenCursor :: Bool -> Handle -> IO a -> IO a
withHiddenCursor :: forall a. Bool -> Handle -> IO a -> IO a
withHiddenCursor Bool
useColor Handle
h
  | Bool
useColor  = forall a b c. IO a -> IO b -> IO c -> IO c
E.bracket_ (Handle -> IO ()
hHideCursor Handle
h) (Handle -> IO ()
hShowCursor Handle
h)
  | Bool
otherwise = forall a. a -> a
id

colorOutputSupported :: ColorMode -> IO Bool -> IO (Bool, Bool)
colorOutputSupported :: ColorMode -> IO Bool -> IO (Bool, Bool)
colorOutputSupported ColorMode
mode IO Bool
isTerminalDevice = do
  Bool
github <- IO Bool
githubActions
  Bool
buildkite <- String -> IO (Maybe String)
lookupEnv String
"BUILDKITE" forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just String
"true")
  Bool
useColor <- case ColorMode
mode of
    ColorMode
ColorAuto  -> (Bool
github Bool -> Bool -> Bool
||) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Bool
colorTerminal
    ColorMode
ColorNever -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    ColorMode
ColorAlways -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  let reportProgress :: Bool
reportProgress = Bool -> Bool
not Bool
github Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
buildkite Bool -> Bool -> Bool
&& Bool
useColor
  forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
reportProgress, Bool
useColor)
  where
    githubActions :: IO Bool
    githubActions :: IO Bool
githubActions = String -> IO (Maybe String)
lookupEnv String
"GITHUB_ACTIONS" forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just String
"true")

    colorTerminal :: IO Bool
    colorTerminal :: IO Bool
colorTerminal = Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Bool
noColor) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO Bool
isTerminalDevice

    noColor :: IO Bool
    noColor :: IO Bool
noColor = String -> IO (Maybe String)
lookupEnv String
"NO_COLOR" forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall a. Eq a => a -> a -> Bool
/= forall a. Maybe a
Nothing)

unicodeOutputSupported :: UnicodeMode -> Handle -> IO Bool
unicodeOutputSupported :: UnicodeMode -> Handle -> IO Bool
unicodeOutputSupported UnicodeMode
mode Handle
h = case UnicodeMode
mode of
  UnicodeMode
UnicodeAuto -> (forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just String
"UTF-8") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Show a => a -> String
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO (Maybe TextEncoding)
hGetEncoding Handle
h
  UnicodeMode
UnicodeNever -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  UnicodeMode
UnicodeAlways -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

rerunAll :: Config -> Maybe FailureReport -> SpecResult -> Bool
rerunAll :: Config -> Maybe FailureReport -> SpecResult -> Bool
rerunAll Config
config Maybe FailureReport
mOldFailureReport SpecResult
result = case Maybe FailureReport
mOldFailureReport of
  Maybe FailureReport
Nothing -> Bool
False
  Just FailureReport
oldFailureReport ->
       Config -> Bool
configRerunAllOnSuccess Config
config
    Bool -> Bool -> Bool
&& Config -> Bool
configRerun Config
config
    Bool -> Bool -> Bool
&& SpecResult -> Bool
specResultSuccess SpecResult
result
    Bool -> Bool -> Bool
&& (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (FailureReport -> [Path]
failureReportPaths FailureReport
oldFailureReport)

-- | Summary of a test run.
data Summary = Summary {
  Summary -> Int
summaryExamples :: !Int
, Summary -> Int
summaryFailures :: !Int
} deriving (Summary -> Summary -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Summary -> Summary -> Bool
$c/= :: Summary -> Summary -> Bool
== :: Summary -> Summary -> Bool
$c== :: Summary -> Summary -> Bool
Eq, Int -> Summary -> ShowS
[Summary] -> ShowS
Summary -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Summary] -> ShowS
$cshowList :: [Summary] -> ShowS
show :: Summary -> String
$cshow :: Summary -> String
showsPrec :: Int -> Summary -> ShowS
$cshowsPrec :: Int -> Summary -> ShowS
Show)

instance Monoid Summary where
  mempty :: Summary
mempty = Int -> Int -> Summary
Summary Int
0 Int
0
#if MIN_VERSION_base(4,11,0)
instance Semigroup Summary where
#endif
  (Summary Int
x1 Int
x2)
#if MIN_VERSION_base(4,11,0)
    <> :: Summary -> Summary -> Summary
<>
#else
    `mappend`
#endif
    (Summary Int
y1 Int
y2) = Int -> Int -> Summary
Summary (Int
x1 forall a. Num a => a -> a -> a
+ Int
y1) (Int
x2 forall a. Num a => a -> a -> a
+ Int
y2)

randomizeForest :: Integer -> [Tree c a] -> [Tree c a]
randomizeForest :: forall c a. Integer -> [Tree c a] -> [Tree c a]
randomizeForest Integer
seed [Tree c a]
t = forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
  STRef s StdGen
ref <- forall a s. a -> ST s (STRef s a)
newSTRef (Int -> StdGen
mkStdGen forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
seed)
  forall s c a. STRef s StdGen -> [Tree c a] -> ST s [Tree c a]
shuffleForest STRef s StdGen
ref [Tree c a]
t

countSpecItems :: [Eval.Tree c a] -> Int
countSpecItems :: forall c a. [Tree c a] -> Int
countSpecItems = forall a. Sum a -> a
getSum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. a -> Sum a
Sum Int
1)