{-# OPTIONS_GHC -fno-warn-deprecations #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}

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

-- * Legacy
, runSpec

-- * Re-exports
, Spec
, SpecWith

#ifdef TEST
, UseColor(..)
, ProgressReporting(..)
, rerunAll
, specToEvalForest
, colorOutputSupported
, unicodeOutputSupported
#endif
) where

import           Prelude ()
import           Test.Hspec.Core.Compat

import           NonEmpty (nonEmpty)
import           System.IO
import           System.Environment (getArgs, withArgs)
import           System.Exit (exitFailure)
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.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 (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.QuickCheck.Util
import           Test.Hspec.Core.Shuffle

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

-- |
-- 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 :: (String, FormatConfig -> IO Format) -> Config -> Config
registerFormatter (String, FormatConfig -> IO Format)
formatter Config
config = 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 :: (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 = Just format }

applyFilterPredicates :: Config -> [Tree c EvalItem] -> [Tree c EvalItem]
applyFilterPredicates :: forall c. Config -> [Tree c EvalItem] -> [Tree c EvalItem]
applyFilterPredicates Config
c = ([String] -> EvalItem -> Bool)
-> [Tree c EvalItem] -> [Tree c EvalItem]
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 = (Path -> Bool) -> Maybe (Path -> Bool) -> Path -> Bool
forall a. a -> Maybe a -> a
fromMaybe (Bool -> Path -> Bool
forall a b. a -> b -> a
const Bool
True) (Config -> Maybe (Path -> Bool)
configFilterPredicate Config
c)

    skip :: Path -> Bool
    skip :: Path -> Bool
skip = (Path -> Bool) -> Maybe (Path -> Bool) -> Path -> Bool
forall a. a -> Maybe a -> a
fromMaybe (Bool -> Path -> Bool
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 = (IO () -> IO ())
-> (EvalItem -> EvalItem) -> [EvalItemTree] -> [EvalItemTree]
forall a b c d. (a -> b) -> (c -> d) -> [Tree a c] -> [Tree b d]
bimapForest IO () -> IO ()
removeCleanup EvalItem -> EvalItem
markSuccess
  | Bool
otherwise = [EvalItemTree] -> [EvalItemTree]
forall a. a -> a
id
  where
    removeCleanup :: IO () -> IO ()
    removeCleanup :: IO () -> IO ()
removeCleanup IO ()
_ = IO ()
forall (m :: * -> *). Applicative m => m ()
pass

    markSuccess :: EvalItem -> EvalItem
    markSuccess :: EvalItem -> EvalItem
markSuccess EvalItem
item = EvalItem
item {evalItemAction = \ ProgressCallback
_ -> (Seconds, Result) -> IO (Seconds, Result)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Seconds
0, 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 = Config -> Spec -> IO ()
hspecWith Config
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 :: forall a. Config -> SpecWith a -> IO (Config, [SpecTree a])
evalSpec Config
config SpecWith a
spec = do
  (Endo Config -> Config
f, [SpecTree a]
forest) <- SpecWith a -> IO (Endo Config, [SpecTree a])
forall a. SpecWith a -> IO (Endo Config, [SpecTree a])
runSpecM SpecWith a
spec
  (Config, [SpecTree a]) -> IO (Config, [SpecTree a])
forall a. a -> IO a
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, Integer)
ensureSeed :: Config -> IO (Config, Integer)
ensureSeed Config
config = do
  Integer
seed <- case Config -> Maybe Integer
configSeed Config
config Maybe Integer -> Maybe Integer -> Maybe Integer
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Config -> Maybe Integer
configQuickCheckSeed Config
config of
    Maybe Integer
Nothing -> Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> IO Int -> IO Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Int
newSeed
    Just Integer
seed -> Integer -> IO Integer
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
seed
  (Config, Integer) -> IO (Config, Integer)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Config
config { configSeed = Just seed }, Integer
seed)

-- | 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 = Config -> Spec -> IO SpecResult
hspecWithSpecResult Config
defaults (Spec -> IO SpecResult) -> (SpecResult -> IO ()) -> Spec -> IO ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> SpecResult -> IO ()
evaluateResult

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

evaluateResult :: SpecResult -> IO ()
evaluateResult :: SpecResult -> IO ()
evaluateResult SpecResult
result = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SpecResult -> Bool
specResultSuccess SpecResult
result) IO ()
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
config = (SpecResult -> Summary) -> IO SpecResult -> IO Summary
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SpecResult -> Summary
toSummary (IO SpecResult -> IO Summary)
-> (Spec -> IO SpecResult) -> Spec -> IO Summary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Spec -> IO SpecResult
hspecWithSpecResult Config
config

hspecWithSpecResult :: Config -> Spec -> IO SpecResult
hspecWithSpecResult :: Config -> Spec -> IO SpecResult
hspecWithSpecResult Config
defaults Spec
spec = do
  (Config
c, [SpecTree ()]
forest) <- Config -> Spec -> IO (Config, [SpecTree ()])
forall a. Config -> SpecWith a -> IO (Config, [SpecTree a])
evalSpec Config
defaults Spec
spec
  Config
config <- IO [String]
getArgs IO [String] -> ([String] -> IO Config) -> IO Config
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Config -> [String] -> IO Config
readConfig Config
c
  Maybe FailureReport
oldFailureReport <- Config -> IO (Maybe FailureReport)
readFailureReportOnRerun Config
config

  let
    normalMode :: IO SpecResult
    normalMode :: IO SpecResult
normalMode = IO SpecResult -> IO SpecResult
forall a. IO a -> IO a
doNotLeakCommandLineArgumentsToExamples (IO SpecResult -> IO SpecResult) -> IO SpecResult -> IO SpecResult
forall a b. (a -> b) -> a -> b
$ Maybe FailureReport -> [SpecTree ()] -> Config -> IO SpecResult
runSpecForest_ Maybe FailureReport
oldFailureReport [SpecTree ()]
forest Config
config

    rerunAllMode :: IO SpecResult
    rerunAllMode :: IO SpecResult
rerunAllMode = do
      SpecResult
result <- IO SpecResult
normalMode
      if Config -> Maybe FailureReport -> SpecResult -> Bool
rerunAll Config
config Maybe FailureReport
oldFailureReport SpecResult
result then
        Config -> Spec -> IO SpecResult
hspecWithSpecResult Config
defaults Spec
spec
      else
        SpecResult -> IO SpecResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SpecResult
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 Config -> Bool
configRerunAllOnSuccess Config
config then do
    IO SpecResult
rerunAllMode
  else do
    IO SpecResult
normalMode

-- |
-- /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 = Config -> Spec -> IO (Config, [SpecTree ()])
forall a. Config -> SpecWith a -> IO (Config, [SpecTree a])
evalSpec Config
defaultConfig Spec
spec IO (Config, [SpecTree ()])
-> ((Config, [SpecTree ()]) -> IO Summary) -> IO Summary
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SpecResult -> Summary) -> IO SpecResult -> IO Summary
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SpecResult -> Summary
toSummary (IO SpecResult -> IO Summary)
-> ((Config, [SpecTree ()]) -> IO SpecResult)
-> (Config, [SpecTree ()])
-> IO Summary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([SpecTree ()] -> Config -> IO SpecResult)
-> Config -> [SpecTree ()] -> IO SpecResult
forall a b c. (a -> b -> c) -> b -> a -> c
flip [SpecTree ()] -> Config -> IO SpecResult
runSpecForest Config
config ([SpecTree ()] -> IO SpecResult)
-> ((Config, [SpecTree ()]) -> [SpecTree ()])
-> (Config, [SpecTree ()])
-> IO SpecResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Config, [SpecTree ()]) -> [SpecTree ()]
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
config = do
  Maybe FailureReport
oldFailureReport <- Config -> IO (Maybe FailureReport)
readFailureReportOnRerun Config
config
  Maybe FailureReport -> [SpecTree ()] -> Config -> IO SpecResult
runSpecForest_ Maybe FailureReport
oldFailureReport [SpecTree ()]
spec Config
config

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 = (SpecTree a -> SpecTree b) -> [SpecTree a] -> [SpecTree b]
forall a b. (a -> b) -> [a] -> [b]
map ((Item a -> Item b) -> SpecTree a -> SpecTree b
forall a b. (a -> b) -> Tree (IO ()) a -> Tree (IO ()) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Item a -> Item b
f)

mapItemIf :: (Item a -> Bool) -> (Item a -> Item a) -> [SpecTree a] -> [SpecTree a]
mapItemIf :: forall a.
(Item a -> Bool)
-> (Item a -> Item a) -> [SpecTree a] -> [SpecTree a]
mapItemIf Item a -> Bool
p Item a -> Item a
f = (Item a -> Item a) -> [SpecTree a] -> [SpecTree a]
forall a b. (Item a -> Item b) -> [SpecTree a] -> [SpecTree b]
mapItem ((Item a -> Item a) -> [SpecTree a] -> [SpecTree a])
-> (Item a -> Item a) -> [SpecTree a] -> [SpecTree a]
forall a b. (a -> b) -> a -> b
$ \ Item a
item -> if Item a -> Bool
p Item a
item then Item a -> Item a
f Item a
item else Item a
item

addDefaultDescriptions :: [SpecTree a] -> [SpecTree a]
addDefaultDescriptions :: forall a. [SpecTree a] -> [SpecTree a]
addDefaultDescriptions = (Item a -> Item a) -> [SpecTree a] -> [SpecTree a]
forall a b. (Item a -> Item b) -> [SpecTree a] -> [SpecTree b]
mapItem Item a -> Item a
forall a. Item a -> Item a
addDefaultDescription
  where
    addDefaultDescription :: Item a -> Item a
    addDefaultDescription :: forall a. Item a -> Item a
addDefaultDescription Item a
item
      | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Item a -> String
forall a. Item a -> String
itemRequirement Item a
item) = Item a
item { itemRequirement = defaultRequirement }
      | Bool
otherwise = Item a
item
      where
        defaultRequirement :: String
defaultRequirement = String -> (Location -> String) -> Maybe Location -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"(unspecified behavior)" Location -> String
formatDefaultDescription (Item a -> Maybe Location
forall a. Item a -> Maybe Location
itemLocation Item a
item)

failItemsWithEmptyDescription :: Config -> [SpecTree a] -> [SpecTree a]
failItemsWithEmptyDescription :: forall a. Config -> [SpecTree a] -> [SpecTree a]
failItemsWithEmptyDescription Config
config
  | Config -> Bool
configFailOnEmptyDescription Config
config = (Item a -> Bool)
-> (Item a -> Item a) -> [SpecTree a] -> [SpecTree a]
forall a.
(Item a -> Bool)
-> (Item a -> Item a) -> [SpecTree a] -> [SpecTree a]
mapItemIf Item a -> Bool
forall {a}. Item a -> Bool
condition (String -> Item a -> Item a
forall a. String -> Item a -> Item a
failWith String
failure)
  | Bool
otherwise = [SpecTree a] -> [SpecTree a]
forall a. a -> a
id
  where
    condition :: Item a -> Bool
condition = String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> (Item a -> String) -> Item a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Item a -> String
forall a. Item a -> String
itemRequirement
    failure :: String
failure = String
"item has no description; failing due to --fail-on=empty-description"

failFocusedItems :: Config -> [SpecTree a] -> [SpecTree a]
failFocusedItems :: forall a. Config -> [SpecTree a] -> [SpecTree a]
failFocusedItems Config
config
  | Config -> Bool
configFailOnFocused Config
config = (Item a -> Bool)
-> (Item a -> Item a) -> [SpecTree a] -> [SpecTree a]
forall a.
(Item a -> Bool)
-> (Item a -> Item a) -> [SpecTree a] -> [SpecTree a]
mapItemIf Item a -> Bool
forall {a}. Item a -> Bool
condition (String -> Item a -> Item a
forall a. String -> Item a -> Item a
failWith String
failure)
  | Bool
otherwise = [SpecTree a] -> [SpecTree a]
forall a. a -> a
id
  where
    condition :: Item a -> Bool
condition = Item a -> Bool
forall {a}. Item a -> Bool
itemIsFocused
    failure :: String
failure = String
"item is focused; failing due to --fail-on=focused"

failWith :: forall a. String -> Item a -> Item a
failWith :: forall a. String -> Item a -> Item a
failWith String
reason Item a
item = Item a
item {itemExample = example}
  where
    failure :: ResultStatus
    failure :: ResultStatus
failure = Maybe Location -> FailureReason -> ResultStatus
Failure Maybe Location
forall a. Maybe a
Nothing (String -> FailureReason
Reason String
reason)

    example :: Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result
    example :: Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result
example Params
params ActionWith a -> IO ()
hook ProgressCallback
p = do
      Result String
info ResultStatus
status <- Item a
-> Params
-> (ActionWith a -> IO ())
-> ProgressCallback
-> IO Result
forall a.
Item a
-> Params
-> (ActionWith a -> IO ())
-> ProgressCallback
-> IO Result
itemExample Item a
item Params
params ActionWith a -> IO ()
hook ProgressCallback
p
      Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ String -> ResultStatus -> Result
Result String
info (ResultStatus -> Result) -> ResultStatus -> Result
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

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

failPending :: forall a. Item a -> Item a
failPending :: forall a. Item a -> Item a
failPending Item a
item = Item a
item {itemExample = example}
  where
    example :: Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result
    example :: Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result
example Params
params ActionWith a -> IO ()
hook ProgressCallback
p = do
      Result String
info ResultStatus
status <- Item a
-> Params
-> (ActionWith a -> IO ())
-> ProgressCallback
-> IO Result
forall a.
Item a
-> Params
-> (ActionWith a -> IO ())
-> ProgressCallback
-> IO Result
itemExample Item a
item Params
params ActionWith a -> IO ()
hook ProgressCallback
p
      Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ String -> ResultStatus -> Result
Result String
info (ResultStatus -> Result) -> ResultStatus -> Result
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 = [SpecTree a] -> [SpecTree a]
forall a. [SpecTree a] -> [SpecTree a]
focusForest [SpecTree a]
spec

runSpecForest_ :: Maybe FailureReport -> [SpecTree ()] -> Config -> IO SpecResult
runSpecForest_ :: Maybe FailureReport -> [SpecTree ()] -> Config -> IO SpecResult
runSpecForest_ Maybe FailureReport
oldFailureReport [SpecTree ()]
spec Config
c_ = do

  (Config
config, Integer
seed) <- Config -> IO (Config, Integer)
ensureSeed (Maybe FailureReport -> Config -> Config
applyFailureReport Maybe FailureReport
oldFailureReport Config
c_)

  UseColor
colorMode <- ColorMode -> IO Bool -> IO UseColor
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

  let
    filteredSpec :: [EvalTree]
filteredSpec = Integer -> Config -> [SpecTree ()] -> [EvalTree]
specToEvalForest Integer
seed Config
config [SpecTree ()]
spec
    qcArgs :: Args
qcArgs = Config -> Args
configQuickCheckArgs Config
config
    !numberOfItems :: Int
numberOfItems = [EvalTree] -> Int
forall c a. [Tree c a] -> Int
countEvalItems [EvalTree]
filteredSpec

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Bool
configFailOnEmpty Config
config Bool -> Bool -> Bool
&& Int
numberOfItems Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([SpecTree ()] -> Int
forall c a. [Tree c a] -> Int
countSpecItems [SpecTree ()]
spec Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      String -> IO ()
forall a. String -> IO a
die String
"all spec items have been filtered; failing due to --fail-on=empty"

  Int
concurrentJobs <- IO Int -> (Int -> IO Int) -> Maybe Int -> IO Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO Int
getDefaultConcurrentJobs Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int -> IO Int) -> Maybe Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Config -> Maybe Int
configConcurrentJobs Config
config

  SpecResult
results <- ([(Path, Item)] -> SpecResult)
-> IO [(Path, Item)] -> IO SpecResult
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Path, Item)] -> SpecResult
toSpecResult (IO [(Path, Item)] -> IO SpecResult)
-> (IO [(Path, Item)] -> IO [(Path, Item)])
-> IO [(Path, Item)]
-> IO SpecResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProgressReporting
-> Handle -> IO [(Path, Item)] -> IO [(Path, Item)]
forall a. ProgressReporting -> Handle -> IO a -> IO a
withHiddenCursor (UseColor -> ProgressReporting
progressReporting UseColor
colorMode) Handle
stdout (IO [(Path, Item)] -> IO SpecResult)
-> IO [(Path, Item)] -> IO SpecResult
forall a b. (a -> b) -> a -> b
$ do
    let
      formatConfig :: FormatConfig
formatConfig = FormatConfig {
        formatConfigUseColor :: Bool
formatConfigUseColor = UseColor -> Bool
shouldUseColor UseColor
colorMode
      , formatConfigReportProgress :: Bool
formatConfigReportProgress = UseColor -> ProgressReporting
progressReporting UseColor
colorMode ProgressReporting -> ProgressReporting -> Bool
forall a. Eq a => a -> a -> Bool
== ProgressReporting
ProgressReportingEnabled
      , 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 ((Maybe Int -> String -> String -> IO ())
-> Maybe Int -> String -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Config -> Maybe Int
configDiffContext Config
config) ((Maybe Int -> String -> String -> IO ())
 -> String -> String -> IO ())
-> Maybe (Maybe Int -> String -> String -> IO ())
-> Maybe (String -> String -> IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config -> Maybe (Maybe Int -> String -> String -> IO ())
configExternalDiff Config
config else Maybe (String -> String -> IO ())
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 (String -> String -> (String, String))
-> Maybe (String -> String -> (String, String))
forall a. a -> Maybe a
Just (Config -> Bool -> String -> String -> (String, String)
configPrettyPrintFunction Config
config Bool
outputUnicode) else Maybe (String -> String -> (String, String))
forall a. Maybe a
Nothing
      , formatConfigFormatException :: SomeException -> String
formatConfigFormatException = Config -> SomeException -> String
configFormatException Config
config
      , 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
      , formatConfigExpertMode :: Bool
formatConfigExpertMode = Config -> Bool
configExpertMode Config
config
      }

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

    Format
format <- (Format -> Format)
-> (Int -> Format -> Format) -> Maybe Int -> Format -> Format
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Format -> Format
forall a. a -> a
id Int -> Format -> Format
printSlowSpecItems (Config -> Maybe Int
configPrintSlowItems Config
config) (Format -> Format) -> IO Format -> IO Format
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
      , evalConfigColorMode :: ColorMode
evalConfigColorMode = ColorMode -> ColorMode -> Bool -> ColorMode
forall a. a -> a -> Bool -> a
bool ColorMode
Eval.ColorDisabled ColorMode
Eval.ColorEnabled (UseColor -> Bool
shouldUseColor UseColor
colorMode)
      }
    EvalConfig -> [EvalTree] -> IO [(Path, Item)]
runFormatter EvalConfig
evalConfig [EvalTree]
filteredSpec

  let
    failures :: [Path]
    failures :: [Path]
failures = (ResultItem -> Path) -> [ResultItem] -> [Path]
forall a b. (a -> b) -> [a] -> [b]
map ResultItem -> Path
resultItemPath ([ResultItem] -> [Path]) -> [ResultItem] -> [Path]
forall a b. (a -> b) -> a -> b
$ (ResultItem -> Bool) -> [ResultItem] -> [ResultItem]
forall a. (a -> Bool) -> [a] -> [a]
filter ResultItem -> Bool
resultItemIsFailure ([ResultItem] -> [ResultItem]) -> [ResultItem] -> [ResultItem]
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

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

specToEvalForest :: Integer -> Config -> [SpecTree ()] -> [EvalTree]
specToEvalForest :: Integer -> Config -> [SpecTree ()] -> [EvalTree]
specToEvalForest Integer
seed Config
config =
      Config -> [SpecTree ()] -> [SpecTree ()]
forall a. Config -> [SpecTree a] -> [SpecTree a]
failItemsWithEmptyDescription Config
config
  ([SpecTree ()] -> [SpecTree ()])
-> ([SpecTree ()] -> [EvalTree]) -> [SpecTree ()] -> [EvalTree]
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> [SpecTree ()] -> [SpecTree ()]
forall a. [SpecTree a] -> [SpecTree a]
addDefaultDescriptions
  ([SpecTree ()] -> [SpecTree ()])
-> ([SpecTree ()] -> [EvalTree]) -> [SpecTree ()] -> [EvalTree]
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Config -> [SpecTree ()] -> [SpecTree ()]
forall a. Config -> [SpecTree a] -> [SpecTree a]
failFocusedItems Config
config
  ([SpecTree ()] -> [SpecTree ()])
-> ([SpecTree ()] -> [EvalTree]) -> [SpecTree ()] -> [EvalTree]
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Config -> [SpecTree ()] -> [SpecTree ()]
forall a. Config -> [SpecTree a] -> [SpecTree a]
failPendingItems Config
config
  ([SpecTree ()] -> [SpecTree ()])
-> ([SpecTree ()] -> [EvalTree]) -> [SpecTree ()] -> [EvalTree]
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Config -> [SpecTree ()] -> [SpecTree ()]
forall a. Config -> [SpecTree a] -> [SpecTree a]
focusSpec Config
config
  ([SpecTree ()] -> [SpecTree ()])
-> ([SpecTree ()] -> [EvalTree]) -> [SpecTree ()] -> [EvalTree]
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
  ([SpecTree ()] -> [EvalItemTree])
-> ([EvalItemTree] -> [EvalTree]) -> [SpecTree ()] -> [EvalTree]
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
  ([EvalItemTree] -> [EvalItemTree])
-> ([EvalItemTree] -> [EvalTree]) -> [EvalItemTree] -> [EvalTree]
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]
forall c. Config -> [Tree c EvalItem] -> [Tree c EvalItem]
applyFilterPredicates Config
config
  ([EvalItemTree] -> [EvalItemTree])
-> ([EvalItemTree] -> [EvalTree]) -> [EvalItemTree] -> [EvalTree]
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> [EvalItemTree] -> [EvalItemTree]
forall c a. [Tree c a] -> [Tree c a]
randomize
  ([EvalItemTree] -> [EvalItemTree])
-> ([EvalItemTree] -> [EvalTree]) -> [EvalItemTree] -> [EvalTree]
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> [EvalItemTree] -> [EvalTree]
forall c a. [Tree c a] -> [Tree c a]
pruneForest
  where
    params :: Params
    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 :: forall c a. [Tree c a] -> [Tree c a]
randomize
      | Config -> Bool
configRandomize Config
config = Integer -> [Tree c a] -> [Tree c a]
forall c a. Integer -> [Tree c a] -> [Tree c a]
randomizeForest Integer
seed
      | Bool
otherwise = [Tree c a] -> [Tree c a]
forall a. a -> a
id

pruneForest :: [Tree c a] -> [Eval.Tree c a]
pruneForest :: forall c a. [Tree c a] -> [Tree c a]
pruneForest = (Tree c a -> Maybe (Tree c a)) -> [Tree c a] -> [Tree c a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Tree c a -> Maybe (Tree c a)
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 -> String -> NonEmpty (Tree c a) -> Tree c a
forall c a. String -> NonEmpty (Tree c a) -> Tree c a
Eval.Node String
group (NonEmpty (Tree c a) -> Tree c a)
-> Maybe (NonEmpty (Tree c a)) -> Maybe (Tree c a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tree c a] -> Maybe (NonEmpty (Tree c a))
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 -> Maybe (String, Location) -> c -> NonEmpty (Tree c a) -> Tree c a
forall c a.
Maybe (String, Location) -> c -> NonEmpty (Tree c a) -> Tree c a
Eval.NodeWithCleanup Maybe (String, Location)
loc c
action (NonEmpty (Tree c a) -> Tree c a)
-> Maybe (NonEmpty (Tree c a)) -> Maybe (Tree c a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tree c a] -> Maybe (NonEmpty (Tree c a))
forall {c} {a}. [Tree c a] -> Maybe (NonEmpty (Tree c a))
prune [Tree c a]
xs
  Leaf a
item -> Tree c a -> Maybe (Tree c a)
forall a. a -> Maybe a
Just (a -> Tree c a
forall c a. a -> Tree c a
Eval.Leaf a
item)
  where
    prune :: [Tree c a] -> Maybe (NonEmpty (Tree c a))
prune = [Tree c a] -> Maybe (NonEmpty (Tree c a))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([Tree c a] -> Maybe (NonEmpty (Tree c a)))
-> ([Tree c a] -> [Tree c a])
-> [Tree c a]
-> Maybe (NonEmpty (Tree c a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tree c a] -> [Tree c a]
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 = (IO () -> IO ())
-> (Item () -> EvalItem) -> [SpecTree ()] -> [EvalItemTree]
forall a b c d. (a -> b) -> (c -> d) -> [Tree a c] -> [Tree b d]
bimapForest IO () -> IO ()
forall a. a -> a
id Item () -> EvalItem
toEvalItem ([SpecTree ()] -> [EvalItemTree])
-> ([SpecTree ()] -> [SpecTree ()])
-> [SpecTree ()]
-> [EvalItemTree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Item () -> Bool) -> [SpecTree ()] -> [SpecTree ()]
forall a c. (a -> Bool) -> [Tree c a] -> [Tree c a]
filterForest Item () -> Bool
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) = EvalItem {
      evalItemDescription :: String
evalItemDescription = String
requirement
    , evalItemLocation :: Maybe Location
evalItemLocation = Maybe Location
loc
    , evalItemConcurrency :: Concurrency
evalItemConcurrency = if Maybe Bool
isParallelizable Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True then Concurrency
Concurrent else Concurrency
Sequential
    , evalItemAction :: ProgressCallback -> IO (Seconds, Result)
evalItemAction = \ ProgressCallback
progress -> IO Result -> IO (Seconds, Result)
forall a. IO a -> IO (Seconds, a)
measure (IO Result -> IO (Seconds, Result))
-> IO Result -> IO (Seconds, Result)
forall a b. (a -> b) -> a -> b
$ Params -> (ActionWith () -> IO ()) -> ProgressCallback -> IO Result
e Params
params ActionWith () -> IO ()
withUnit ProgressCallback
progress
    }

    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 = [String] -> IO a -> IO a
forall a. [String] -> IO a -> IO a
withArgs []

withHiddenCursor :: ProgressReporting -> Handle -> IO a -> IO a
withHiddenCursor :: forall a. ProgressReporting -> Handle -> IO a -> IO a
withHiddenCursor ProgressReporting
progress Handle
h = case ProgressReporting
progress of
  ProgressReporting
ProgressReportingDisabled -> IO a -> IO a
forall a. a -> a
id
  ProgressReporting
ProgressReportingEnabled -> IO () -> IO () -> IO a -> IO a
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (Handle -> IO ()
hHideCursor Handle
h) (Handle -> IO ()
hShowCursor Handle
h)

data UseColor = ColorDisabled | ColorEnabled ProgressReporting
  deriving (UseColor -> UseColor -> Bool
(UseColor -> UseColor -> Bool)
-> (UseColor -> UseColor -> Bool) -> Eq UseColor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UseColor -> UseColor -> Bool
== :: UseColor -> UseColor -> Bool
$c/= :: UseColor -> UseColor -> Bool
/= :: UseColor -> UseColor -> Bool
Eq, Int -> UseColor -> ShowS
[UseColor] -> ShowS
UseColor -> String
(Int -> UseColor -> ShowS)
-> (UseColor -> String) -> ([UseColor] -> ShowS) -> Show UseColor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UseColor -> ShowS
showsPrec :: Int -> UseColor -> ShowS
$cshow :: UseColor -> String
show :: UseColor -> String
$cshowList :: [UseColor] -> ShowS
showList :: [UseColor] -> ShowS
Show)

data ProgressReporting = ProgressReportingDisabled | ProgressReportingEnabled
  deriving (ProgressReporting -> ProgressReporting -> Bool
(ProgressReporting -> ProgressReporting -> Bool)
-> (ProgressReporting -> ProgressReporting -> Bool)
-> Eq ProgressReporting
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProgressReporting -> ProgressReporting -> Bool
== :: ProgressReporting -> ProgressReporting -> Bool
$c/= :: ProgressReporting -> ProgressReporting -> Bool
/= :: ProgressReporting -> ProgressReporting -> Bool
Eq, Int -> ProgressReporting -> ShowS
[ProgressReporting] -> ShowS
ProgressReporting -> String
(Int -> ProgressReporting -> ShowS)
-> (ProgressReporting -> String)
-> ([ProgressReporting] -> ShowS)
-> Show ProgressReporting
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProgressReporting -> ShowS
showsPrec :: Int -> ProgressReporting -> ShowS
$cshow :: ProgressReporting -> String
show :: ProgressReporting -> String
$cshowList :: [ProgressReporting] -> ShowS
showList :: [ProgressReporting] -> ShowS
Show)

shouldUseColor :: UseColor -> Bool
shouldUseColor :: UseColor -> Bool
shouldUseColor UseColor
c = case UseColor
c of
  UseColor
ColorDisabled -> Bool
False
  ColorEnabled ProgressReporting
_ -> Bool
True

progressReporting :: UseColor -> ProgressReporting
progressReporting :: UseColor -> ProgressReporting
progressReporting UseColor
c = case UseColor
c of
  UseColor
ColorDisabled -> ProgressReporting
ProgressReportingDisabled
  ColorEnabled ProgressReporting
r -> ProgressReporting
r

colorOutputSupported :: ColorMode -> IO Bool -> IO UseColor
colorOutputSupported :: ColorMode -> IO Bool -> IO UseColor
colorOutputSupported ColorMode
mode IO Bool
isTerminalDevice = do
  Bool
github <- IO Bool
githubActions
  Bool
buildkite <- String -> IO (Maybe String)
lookupEnv String
"BUILDKITE" IO (Maybe String) -> (Maybe String -> Bool) -> IO Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just String
"true")
  let
    progress :: ProgressReporting
    progress :: ProgressReporting
progress
      | Bool
github Bool -> Bool -> Bool
|| Bool
buildkite = ProgressReporting
ProgressReportingDisabled
      | Bool
otherwise = ProgressReporting
ProgressReportingEnabled

    colorEnabled :: UseColor
    colorEnabled :: UseColor
colorEnabled = ProgressReporting -> UseColor
ColorEnabled ProgressReporting
progress
  case ColorMode
mode of
    ColorMode
ColorAuto -> UseColor -> UseColor -> Bool -> UseColor
forall a. a -> a -> Bool -> a
bool UseColor
ColorDisabled UseColor
colorEnabled (Bool -> UseColor) -> (Bool -> Bool) -> Bool -> UseColor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool
github Bool -> Bool -> Bool
||) (Bool -> UseColor) -> IO Bool -> IO UseColor
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Bool
colorTerminal
    ColorMode
ColorNever -> UseColor -> IO UseColor
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return UseColor
ColorDisabled
    ColorMode
ColorAlways -> UseColor -> IO UseColor
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return UseColor
colorEnabled
  where
    githubActions :: IO Bool
    githubActions :: IO Bool
githubActions = String -> IO (Maybe String)
lookupEnv String
"GITHUB_ACTIONS" IO (Maybe String) -> (Maybe String -> Bool) -> IO Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just String
"true")

    colorTerminal :: IO Bool
    colorTerminal :: IO Bool
colorTerminal = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool) -> IO Bool -> IO (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Bool
noColor) IO (Bool -> Bool) -> IO Bool -> IO Bool
forall a b. IO (a -> b) -> IO a -> IO b
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" IO (Maybe String) -> (Maybe String -> Bool) -> IO Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe String
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 -> (Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just String
"UTF-8") (Maybe String -> Bool)
-> (Maybe TextEncoding -> Maybe String)
-> Maybe TextEncoding
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TextEncoding -> String) -> Maybe TextEncoding -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TextEncoding -> String
forall a. Show a => a -> String
show (Maybe TextEncoding -> Bool) -> IO (Maybe TextEncoding) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO (Maybe TextEncoding)
hGetEncoding Handle
h
  UnicodeMode
UnicodeNever -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  UnicodeMode
UnicodeAlways -> Bool -> IO Bool
forall a. a -> IO a
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 (Bool -> Bool) -> ([Path] -> Bool) -> [Path] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Path] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (FailureReport -> [Path]
failureReportPaths FailureReport
oldFailureReport)

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

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

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