{-# LANGUAGE CPP #-}

-- |
-- Stability: provisional
module Test.Hspec.Core.Runner (
-- * Running a spec
  hspec
, runSpec

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

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

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

#ifdef TEST
, rerunAll
, specToEvalForest
#endif
) where

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

import           Data.Maybe
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 (hHideCursor, hShowCursor)
import qualified Test.QuickCheck as QC

import           Test.Hspec.Core.Util (Path)
import           Test.Hspec.Core.Spec
import           Test.Hspec.Core.Config
import           Test.Hspec.Core.Formatters
import           Test.Hspec.Core.Formatters.Internal
import           Test.Hspec.Core.FailureReport
import           Test.Hspec.Core.QuickCheckUtil
import           Test.Hspec.Core.Shuffle

import           Test.Hspec.Core.Runner.Eval

applyFilterPredicates :: Config -> [EvalTree] -> [EvalTree]
applyFilterPredicates :: Config -> [EvalTree] -> [EvalTree]
applyFilterPredicates Config
c = ([String] -> EvalItem -> Bool) -> [EvalTree] -> [EvalTree]
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 -> [EvalTree] -> [EvalTree]
applyDryRun :: Config -> [EvalTree] -> [EvalTree]
applyDryRun Config
c
  | Config -> Bool
configDryRun Config
c = (IO () -> IO ())
-> (EvalItem -> EvalItem) -> [EvalTree] -> [EvalTree]
forall a b c d. (a -> b) -> (c -> d) -> [Tree a c] -> [Tree b d]
bimapForest IO () -> IO ()
removeCleanup EvalItem -> EvalItem
markSuccess
  | Bool
otherwise = [EvalTree] -> [EvalTree]
forall a. a -> a
id
  where
    removeCleanup :: IO () -> IO ()
    removeCleanup :: IO () -> IO ()
removeCleanup IO ()
_ = () -> 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
_ -> Result -> IO Result
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
"" 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 desired.  Use `runSpec` if you need more control over these
-- aspects.
hspec :: Spec -> IO ()
hspec :: Spec -> IO ()
hspec Spec
spec =
      IO [String]
getArgs
  IO [String] -> ([String] -> IO Config) -> IO Config
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Config -> [String] -> IO Config
readConfig Config
defaultConfig
  IO Config -> (Config -> IO Summary) -> IO Summary
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Summary -> IO Summary
forall a. IO a -> IO a
doNotLeakCommandLineArgumentsToExamples (IO Summary -> IO Summary)
-> (Config -> IO Summary) -> Config -> IO Summary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Spec -> Config -> IO Summary
runSpec Spec
spec
  IO Summary -> (Summary -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Summary -> IO ()
evaluateSummary

-- 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
    Config -> IO Config
forall (m :: * -> *) a. Monad m => a -> m a
return Config
c {configQuickCheckSeed :: Maybe Integer
configQuickCheckSeed = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
seed)}
  Maybe Integer
_       -> Config -> IO Config
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
config Spec
spec = IO [String]
getArgs IO [String] -> ([String] -> IO Config) -> IO Config
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Config -> [String] -> IO Config
readConfig Config
config IO Config -> (Config -> IO Summary) -> IO Summary
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Summary -> IO Summary
forall a. IO a -> IO a
doNotLeakCommandLineArgumentsToExamples (IO Summary -> IO Summary)
-> (Config -> IO Summary) -> Config -> IO Summary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Spec -> Config -> IO Summary
runSpec Spec
spec IO Summary -> (Summary -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Summary -> IO ()
evaluateSummary

-- | `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 Int -> Int -> Bool
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 = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Summary -> Bool
isSuccess Summary
summary) 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 Spec
spec = IO [String]
getArgs IO [String] -> ([String] -> IO Config) -> IO Config
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Config -> [String] -> IO Config
readConfig Config
defaultConfig IO Config -> (Config -> IO Summary) -> IO Summary
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Summary -> IO Summary
forall a. IO a -> IO a
doNotLeakCommandLineArgumentsToExamples (IO Summary -> IO Summary)
-> (Config -> IO Summary) -> Config -> IO Summary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Spec -> Config -> IO Summary
runSpec Spec
spec

-- | 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 Spec
spec = IO [String]
getArgs IO [String] -> ([String] -> IO Config) -> IO Config
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Config -> [String] -> IO Config
readConfig Config
config IO Config -> (Config -> IO Summary) -> IO Summary
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Summary -> IO Summary
forall a. IO a -> IO a
doNotLeakCommandLineArgumentsToExamples (IO Summary -> IO Summary)
-> (Config -> IO Summary) -> Config -> IO Summary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Spec -> Config -> IO Summary
runSpec Spec
spec

-- |
-- `runSpec` is the most basic primitive to run a spec. `hspec` is defined in
-- terms of @runSpec@:
--
-- @
-- hspec spec =
--       `getArgs`
--   >>= `readConfig` `defaultConfig`
--   >>= `withArgs` [] . runSpec spec
--   >>= `evaluateSummary`
-- @
runSpec :: Spec -> Config -> IO Summary
runSpec :: Spec -> Config -> IO Summary
runSpec Spec
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 Summary
rerunAllMode Config
c Maybe FailureReport
oldFailureReport
    else Config -> IO Summary
normalMode Config
c
  where
    normalMode :: Config -> IO Summary
normalMode Config
c = Config -> Spec -> IO Summary
runSpec_ Config
c Spec
spec
    rerunAllMode :: Config -> Maybe FailureReport -> IO Summary
rerunAllMode Config
c Maybe FailureReport
oldFailureReport = do
      Summary
summary <- Config -> Spec -> IO Summary
runSpec_ Config
c Spec
spec
      if Config -> Maybe FailureReport -> Summary -> Bool
rerunAll Config
c Maybe FailureReport
oldFailureReport Summary
summary
        then Spec -> Config -> IO Summary
runSpec Spec
spec Config
c_
        else Summary -> IO Summary
forall (m :: * -> *) a. Monad m => a -> m a
return Summary
summary

failFocused :: Item a -> Item a
failFocused :: 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 Maybe Location
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
      | Item a -> Bool
forall a. Item a -> Bool
itemIsFocused Item a
item = \ 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 (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
      | Bool
otherwise = Item a
-> Params
-> (ActionWith a -> IO ())
-> ProgressCallback
-> IO Result
forall a.
Item a
-> Params
-> (ActionWith a -> IO ())
-> ProgressCallback
-> IO Result
itemExample Item a
item

failFocusedItems :: Config -> Spec -> Spec
failFocusedItems :: Config -> Spec -> Spec
failFocusedItems Config
config Spec
spec
  | Config -> Bool
configFailOnFocused Config
config = (Item () -> Item ()) -> Spec -> Spec
forall a. (Item a -> Item a) -> SpecWith a -> SpecWith a
mapSpecItem_ Item () -> Item ()
forall a. Item a -> Item a
failFocused Spec
spec
  | Bool
otherwise = Spec
spec

focusSpec :: Config -> Spec -> Spec
focusSpec :: Config -> Spec -> Spec
focusSpec Config
config Spec
spec
  | Config -> Bool
configFocusedOnly Config
config = Spec
spec
  | Bool
otherwise = Spec -> Spec
forall a. SpecWith a -> SpecWith a
focus Spec
spec

runSpec_ :: Config -> Spec -> IO Summary
runSpec_ :: Config -> Spec -> IO Summary
runSpec_ Config
config Spec
spec = do
  [EvalTree]
filteredSpec <- Config -> Spec -> IO [EvalTree]
specToEvalForest Config
config Spec
spec
  Config -> (Handle -> IO Summary) -> IO Summary
forall a. Config -> (Handle -> IO a) -> IO a
withHandle Config
config ((Handle -> IO Summary) -> IO Summary)
-> (Handle -> IO Summary) -> IO Summary
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
    let formatter :: Formatter
formatter = Formatter -> Maybe Formatter -> Formatter
forall a. a -> Maybe a -> a
fromMaybe Formatter
specdoc (Config -> Maybe Formatter
configFormatter Config
config)
        seed :: Integer
seed = (Maybe Integer -> Integer
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Integer -> Integer)
-> (Config -> Maybe Integer) -> Config -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Maybe Integer
configQuickCheckSeed) Config
config
        qcArgs :: Args
qcArgs = Config -> Args
configQuickCheckArgs Config
config

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

    Bool
useColor <- Handle -> Config -> IO Bool
doesUseColor Handle
h Config
config

    [(Path, Item)]
results <- Bool -> Handle -> IO [(Path, Item)] -> IO [(Path, Item)]
forall a. Bool -> Handle -> IO a -> IO a
withHiddenCursor Bool
useColor Handle
h (IO [(Path, Item)] -> IO [(Path, Item)])
-> IO [(Path, Item)] -> IO [(Path, Item)]
forall a b. (a -> b) -> a -> b
$ do
      let
        formatConfig :: FormatConfig
formatConfig = FormatConfig :: Handle -> Bool -> Bool -> Bool -> Bool -> Integer -> FormatConfig
FormatConfig {
          formatConfigHandle :: Handle
formatConfigHandle = Handle
h
        , formatConfigUseColor :: Bool
formatConfigUseColor = Bool
useColor
        , formatConfigUseDiff :: Bool
formatConfigUseDiff = Config -> Bool
configDiff Config
config
        , formatConfigHtmlOutput :: Bool
formatConfigHtmlOutput = Config -> Bool
configHtmlOutput Config
config
        , formatConfigPrintCpuTime :: Bool
formatConfigPrintCpuTime = Config -> Bool
configPrintCpuTime Config
config
        , formatConfigUsedSeed :: Integer
formatConfigUsedSeed =  Integer
seed
        }
        evalConfig :: EvalConfig FormatM
evalConfig = EvalConfig :: forall (m :: * -> *). Format m -> Int -> Bool -> EvalConfig m
EvalConfig {
          evalConfigFormat :: Format FormatM
evalConfigFormat = Formatter -> FormatConfig -> Format FormatM
formatterToFormat Formatter
formatter FormatConfig
formatConfig
        , evalConfigConcurrentJobs :: Int
evalConfigConcurrentJobs = Int
concurrentJobs
        , evalConfigFastFail :: Bool
evalConfigFastFail = Config -> Bool
configFastFail Config
config
        }
      EvalConfig FormatM -> [EvalTree] -> IO [(Path, Item)]
forall (m :: * -> *).
MonadIO m =>
EvalConfig m -> [EvalTree] -> IO [(Path, Item)]
runFormatter EvalConfig FormatM
evalConfig [EvalTree]
filteredSpec

    let failures :: [(Path, Item)]
failures = ((Path, Item) -> Bool) -> [(Path, Item)] -> [(Path, Item)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Path, Item) -> Bool
resultItemIsFailure [(Path, Item)]
results

    Config -> Integer -> Args -> [Path] -> IO ()
dumpFailureReport Config
config Integer
seed Args
qcArgs (((Path, Item) -> Path) -> [(Path, Item)] -> [Path]
forall a b. (a -> b) -> [a] -> [b]
map (Path, Item) -> Path
forall a b. (a, b) -> a
fst [(Path, Item)]
failures)

    Summary -> IO Summary
forall (m :: * -> *) a. Monad m => a -> m a
return Summary :: Int -> Int -> Summary
Summary {
      summaryExamples :: Int
summaryExamples = [(Path, Item)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Path, Item)]
results
    , summaryFailures :: Int
summaryFailures = [(Path, Item)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Path, Item)]
failures
    }

specToEvalForest :: Config -> Spec -> IO [EvalTree]
specToEvalForest :: Config -> Spec -> IO [EvalTree]
specToEvalForest Config
config Spec
spec = do
  let
    seed :: Integer
seed = (Maybe Integer -> Integer
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Integer -> Integer)
-> (Config -> Maybe Integer) -> Config -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Maybe Integer
configQuickCheckSeed) Config
config
    focusedSpec :: Spec
focusedSpec = Config -> Spec -> Spec
focusSpec Config
config (Config -> Spec -> Spec
failFocusedItems Config
config Spec
spec)
    params :: Params
params = Args -> Int -> Params
Params (Config -> Args
configQuickCheckArgs Config
config) (Config -> Int
configSmallCheckDepth Config
config)
    randomize :: [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
  [EvalTree] -> [EvalTree]
forall c a. [Tree c a] -> [Tree c a]
randomize ([EvalTree] -> [EvalTree])
-> ([SpecTree ()] -> [EvalTree]) -> [SpecTree ()] -> [EvalTree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [EvalTree] -> [EvalTree]
forall c a. [Tree c a] -> [Tree c a]
pruneForest ([EvalTree] -> [EvalTree])
-> ([SpecTree ()] -> [EvalTree]) -> [SpecTree ()] -> [EvalTree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> [EvalTree] -> [EvalTree]
applyFilterPredicates Config
config ([EvalTree] -> [EvalTree])
-> ([SpecTree ()] -> [EvalTree]) -> [SpecTree ()] -> [EvalTree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> [EvalTree] -> [EvalTree]
applyDryRun Config
config ([EvalTree] -> [EvalTree])
-> ([SpecTree ()] -> [EvalTree]) -> [SpecTree ()] -> [EvalTree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Params -> [SpecTree ()] -> [EvalTree]
toEvalForest Params
params ([SpecTree ()] -> [EvalTree]) -> IO [SpecTree ()] -> IO [EvalTree]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Spec -> IO [SpecTree ()]
forall a. SpecWith a -> IO [SpecTree a]
runSpecM Spec
focusedSpec

toEvalForest :: Params -> [SpecTree ()] -> [EvalTree]
toEvalForest :: Params -> [SpecTree ()] -> [EvalTree]
toEvalForest Params
params = ((() -> IO ()) -> IO ())
-> (Item () -> EvalItem) -> [SpecTree ()] -> [EvalTree]
forall a b c d. (a -> b) -> (c -> d) -> [Tree a c] -> [Tree b d]
bimapForest (() -> IO ()) -> IO ()
withUnit Item () -> EvalItem
toEvalItem ([SpecTree ()] -> [EvalTree])
-> ([SpecTree ()] -> [SpecTree ()]) -> [SpecTree ()] -> [EvalTree]
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 -> ((() -> IO ()) -> IO ()) -> ProgressCallback -> IO Result
e) = String
-> Maybe Location
-> Bool
-> (ProgressCallback -> IO Result)
-> EvalItem
EvalItem String
requirement Maybe Location
loc (Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
isParallelizable) (Params -> ((() -> IO ()) -> IO ()) -> ProgressCallback -> IO Result
e Params
params (() -> IO ()) -> IO ()
withUnit)

    withUnit :: ActionWith () -> IO ()
    withUnit :: (() -> IO ()) -> IO ()
withUnit () -> IO ()
action = () -> IO ()
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 :: Integer -> Int -> Int -> Int -> [Path] -> FailureReport
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 :: IO a -> IO a
doNotLeakCommandLineArgumentsToExamples = [String] -> IO a -> IO a
forall a. [String] -> IO a -> IO a
withArgs []

withHiddenCursor :: Bool -> Handle -> IO a -> IO a
withHiddenCursor :: Bool -> Handle -> IO a -> IO a
withHiddenCursor Bool
useColor Handle
h
  | Bool
useColor  = IO () -> IO () -> IO a -> IO a
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 = IO a -> IO a
forall a. a -> a
id

doesUseColor :: Handle -> Config -> IO Bool
doesUseColor :: Handle -> Config -> IO Bool
doesUseColor Handle
h Config
c = case Config -> ColorMode
configColorMode Config
c of
  ColorMode
ColorAuto  -> Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool) -> IO Bool -> IO (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO Bool
hIsTerminalDevice Handle
h IO (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Applicative f => 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
isDumb)
  ColorMode
ColorNever -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  ColorMode
ColorAlways -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

withHandle :: Config -> (Handle -> IO a) -> IO a
withHandle :: Config -> (Handle -> IO a) -> IO a
withHandle Config
c Handle -> IO a
action = case Config -> Either Handle String
configOutputFile Config
c of
  Left Handle
h -> Handle -> IO a
action Handle
h
  Right String
path -> String -> IOMode -> (Handle -> IO a) -> IO a
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
path IOMode
WriteMode Handle -> IO a
action

rerunAll :: Config -> Maybe FailureReport -> Summary -> Bool
rerunAll :: Config -> Maybe FailureReport -> Summary -> Bool
rerunAll Config
_ Maybe FailureReport
Nothing Summary
_ = Bool
False
rerunAll Config
config (Just FailureReport
oldFailureReport) Summary
summary =
     Config -> Bool
configRerunAllOnSuccess Config
config
  Bool -> Bool -> Bool
&& Config -> Bool
configRerun Config
config
  Bool -> Bool -> Bool
&& Summary -> Bool
isSuccess Summary
summary
  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 (t :: * -> *) a. Foldable t => t a -> Bool
null) (FailureReport -> [Path]
failureReportPaths FailureReport
oldFailureReport)

isDumb :: IO Bool
isDumb :: IO Bool
isDumb = Bool -> (String -> Bool) -> Maybe String -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"dumb") (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"TERM"

-- | Summary of a test run.
data Summary = Summary {
  Summary -> Int
summaryExamples :: Int
, Summary -> Int
summaryFailures :: Int
} deriving (Summary -> Summary -> Bool
(Summary -> Summary -> Bool)
-> (Summary -> Summary -> Bool) -> Eq Summary
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
(Int -> Summary -> ShowS)
-> (Summary -> String) -> ([Summary] -> ShowS) -> Show Summary
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)
  (Summary x1 x2) `mappend` (Summary y1 y2) = Summary (x1 + y1) (x2 + y2)
#else
instance Semigroup Summary where
  (Summary Int
x1 Int
x2) <> :: Summary -> Summary -> Summary
<> (Summary Int
y1 Int
y2) = Int -> Int -> Summary
Summary (Int
x1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y1) (Int
x2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y2)
#endif

randomizeForest :: Integer -> [Tree c a] -> [Tree c a]
randomizeForest :: 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 s c a. STRef s StdGen -> [Tree c a] -> ST s [Tree c a]
shuffleForest STRef s StdGen
ref [Tree c a]
t