{-# 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
#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.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.Runner.Eval

-- | Filter specs by given predicate.
--
-- The predicate takes a list of "describe" labels and a "requirement".
filterSpecs :: Config -> [EvalTree] -> [EvalTree]
filterSpecs :: Config -> [EvalTree] -> [EvalTree]
filterSpecs c :: Config
c = [String] -> [EvalTree] -> [EvalTree]
go []
  where
    p :: Path -> Bool
    p :: Path -> Bool
p path :: Path
path = ((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) Path
path) Bool -> Bool -> Bool
&&
               Bool -> Bool
not ((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) Path
path)

    go :: [String] -> [EvalTree] -> [EvalTree]
    go :: [String] -> [EvalTree] -> [EvalTree]
go groups :: [String]
groups = (EvalTree -> Maybe EvalTree) -> [EvalTree] -> [EvalTree]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([String] -> EvalTree -> Maybe EvalTree
goSpec [String]
groups)

    goSpecs :: [String] -> [EvalTree] -> ([EvalTree] -> b) -> Maybe b
    goSpecs :: [String] -> [EvalTree] -> ([EvalTree] -> b) -> Maybe b
goSpecs groups :: [String]
groups specs :: [EvalTree]
specs ctor :: [EvalTree] -> b
ctor = case [String] -> [EvalTree] -> [EvalTree]
go [String]
groups [EvalTree]
specs of
      [] -> Maybe b
forall a. Maybe a
Nothing
      xs :: [EvalTree]
xs -> b -> Maybe b
forall a. a -> Maybe a
Just ([EvalTree] -> b
ctor [EvalTree]
xs)

    goSpec :: [String] -> EvalTree -> Maybe (EvalTree)
    goSpec :: [String] -> EvalTree -> Maybe EvalTree
goSpec groups :: [String]
groups spec :: EvalTree
spec = case EvalTree
spec of
      Leaf item :: EvalItem
item -> Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Path -> Bool
p ([String]
groups, EvalItem -> String
evalItemDescription EvalItem
item)) Maybe () -> Maybe EvalTree -> Maybe EvalTree
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> EvalTree -> Maybe EvalTree
forall (m :: * -> *) a. Monad m => a -> m a
return EvalTree
spec
      Node group :: String
group specs :: [EvalTree]
specs -> [String]
-> [EvalTree] -> ([EvalTree] -> EvalTree) -> Maybe EvalTree
forall b. [String] -> [EvalTree] -> ([EvalTree] -> b) -> Maybe b
goSpecs ([String]
groups [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
group]) [EvalTree]
specs (String -> [EvalTree] -> EvalTree
forall c a. String -> [Tree c a] -> Tree c a
Node String
group)
      NodeWithCleanup action :: IO ()
action specs :: [EvalTree]
specs -> [String]
-> [EvalTree] -> ([EvalTree] -> EvalTree) -> Maybe EvalTree
forall b. [String] -> [EvalTree] -> ([EvalTree] -> b) -> Maybe b
goSpecs [String]
groups [EvalTree]
specs (IO () -> [EvalTree] -> EvalTree
forall c a. c -> [Tree c a] -> Tree c a
NodeWithCleanup IO ()
action)

applyDryRun :: Config -> [SpecTree ()] -> [SpecTree ()]
applyDryRun :: Config -> [SpecTree ()] -> [SpecTree ()]
applyDryRun c :: Config
c
  | Config -> Bool
configDryRun Config
c = (SpecTree () -> SpecTree ()) -> [SpecTree ()] -> [SpecTree ()]
forall a b. (a -> b) -> [a] -> [b]
map (SpecTree () -> SpecTree ()
removeCleanup (SpecTree () -> SpecTree ())
-> (SpecTree () -> SpecTree ()) -> SpecTree () -> SpecTree ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Item () -> Item ()) -> SpecTree () -> SpecTree ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Item () -> Item ()
markSuccess)
  | Bool
otherwise = [SpecTree ()] -> [SpecTree ()]
forall a. a -> a
id
  where
    markSuccess :: Item () -> Item ()
    markSuccess :: Item () -> Item ()
markSuccess item :: Item ()
item = Item ()
item {itemExample :: Params -> (ActionWith () -> IO ()) -> ProgressCallback -> IO Result
itemExample = Result
-> Params
-> (ActionWith (Arg Result) -> IO ())
-> ProgressCallback
-> IO Result
forall e.
Example e =>
e
-> Params
-> (ActionWith (Arg e) -> IO ())
-> ProgressCallback
-> IO Result
safeEvaluateExample (String -> ResultStatus -> Result
Result "" ResultStatus
Success)}

    removeCleanup :: SpecTree () -> SpecTree ()
    removeCleanup :: SpecTree () -> SpecTree ()
removeCleanup spec :: SpecTree ()
spec = case SpecTree ()
spec of
      Node x :: String
x xs :: [SpecTree ()]
xs -> String -> [SpecTree ()] -> SpecTree ()
forall c a. String -> [Tree c a] -> Tree c a
Node String
x ((SpecTree () -> SpecTree ()) -> [SpecTree ()] -> [SpecTree ()]
forall a b. (a -> b) -> [a] -> [b]
map SpecTree () -> SpecTree ()
removeCleanup [SpecTree ()]
xs)
      NodeWithCleanup _ xs :: [SpecTree ()]
xs -> ActionWith () -> [SpecTree ()] -> SpecTree ()
forall c a. c -> [Tree c a] -> Tree c a
NodeWithCleanup (\() -> ActionWith ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ((SpecTree () -> SpecTree ()) -> [SpecTree ()] -> [SpecTree ()]
forall a b. (a -> b) -> [a] -> [b]
map SpecTree () -> SpecTree ()
removeCleanup [SpecTree ()]
xs)
      leaf :: SpecTree ()
leaf@(Leaf _) -> SpecTree ()
leaf

-- | 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
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 c :: Config
c = case Config -> Maybe Integer
configQuickCheckSeed Config
c of
  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)}
  _       -> 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
config spec :: 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 = Summary -> Int
summaryFailures Summary
summary Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 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
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
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
config spec :: 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
spec c_ :: 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 c :: Config
c = Config -> Spec -> IO Summary
runSpec_ Config
c Spec
spec
    rerunAllMode :: Config -> Maybe FailureReport -> IO Summary
rerunAllMode c :: Config
c oldFailureReport :: 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 :: 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 "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
params hook :: ActionWith a -> IO ()
hook p :: ProgressCallback
p -> do
          Result info :: String
info status :: 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
            Success -> ResultStatus
failure
            Pending _ _ -> 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
config spec :: 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
config spec :: 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
config spec :: Spec
spec = do
  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
$ \h :: 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
      Nothing -> IO Int
getDefaultConcurrentJobs
      Just n :: 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

    let
      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)

    [EvalTree]
filteredSpec <- Config -> [EvalTree] -> [EvalTree]
filterSpecs Config
config ([EvalTree] -> [EvalTree])
-> ([SpecTree ()] -> [EvalTree]) -> [SpecTree ()] -> [EvalTree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SpecTree () -> Maybe EvalTree) -> [SpecTree ()] -> [EvalTree]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Params -> SpecTree () -> Maybe EvalTree
toEvalTree Params
params) ([SpecTree ()] -> [EvalTree])
-> ([SpecTree ()] -> [SpecTree ()]) -> [SpecTree ()] -> [EvalTree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> [SpecTree ()] -> [SpecTree ()]
applyDryRun Config
config ([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

    (total :: Int
total, failures :: [Path]
failures) <- Bool -> Handle -> IO (Int, [Path]) -> IO (Int, [Path])
forall a. Bool -> Handle -> IO a -> IO a
withHiddenCursor Bool
useColor Handle
h (IO (Int, [Path]) -> IO (Int, [Path]))
-> IO (Int, [Path]) -> IO (Int, [Path])
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 (Int, [Path])
forall (m :: * -> *).
MonadIO m =>
EvalConfig m -> [EvalTree] -> IO (Int, [Path])
runFormatter EvalConfig FormatM
evalConfig [EvalTree]
filteredSpec

    Config -> Integer -> Args -> [Path] -> IO ()
dumpFailureReport Config
config Integer
seed Args
qcArgs [Path]
failures
    Summary -> IO Summary
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Int -> Summary
Summary Int
total ([Path] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Path]
failures))

toEvalTree :: Params -> SpecTree () -> Maybe EvalTree
toEvalTree :: Params -> SpecTree () -> Maybe EvalTree
toEvalTree params :: Params
params = SpecTree () -> Maybe EvalTree
forall c. Tree (() -> c) (Item ()) -> Maybe (Tree c EvalItem)
go
  where
    go :: Tree (() -> c) (Item ()) -> Maybe (Tree c EvalItem)
    go :: Tree (() -> c) (Item ()) -> Maybe (Tree c EvalItem)
go t :: Tree (() -> c) (Item ())
t = case Tree (() -> c) (Item ())
t of
      Node s :: String
s xs :: [Tree (() -> c) (Item ())]
xs -> Tree c EvalItem -> Maybe (Tree c EvalItem)
forall a. a -> Maybe a
Just (Tree c EvalItem -> Maybe (Tree c EvalItem))
-> Tree c EvalItem -> Maybe (Tree c EvalItem)
forall a b. (a -> b) -> a -> b
$ String -> [Tree c EvalItem] -> Tree c EvalItem
forall c a. String -> [Tree c a] -> Tree c a
Node String
s ((Tree (() -> c) (Item ()) -> Maybe (Tree c EvalItem))
-> [Tree (() -> c) (Item ())] -> [Tree c EvalItem]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Tree (() -> c) (Item ()) -> Maybe (Tree c EvalItem)
forall c. Tree (() -> c) (Item ()) -> Maybe (Tree c EvalItem)
go [Tree (() -> c) (Item ())]
xs)
      NodeWithCleanup c :: () -> c
c xs :: [Tree (() -> c) (Item ())]
xs -> Tree c EvalItem -> Maybe (Tree c EvalItem)
forall a. a -> Maybe a
Just (Tree c EvalItem -> Maybe (Tree c EvalItem))
-> Tree c EvalItem -> Maybe (Tree c EvalItem)
forall a b. (a -> b) -> a -> b
$ c -> [Tree c EvalItem] -> Tree c EvalItem
forall c a. c -> [Tree c a] -> Tree c a
NodeWithCleanup (() -> c
c ()) ((Tree (() -> c) (Item ()) -> Maybe (Tree c EvalItem))
-> [Tree (() -> c) (Item ())] -> [Tree c EvalItem]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Tree (() -> c) (Item ()) -> Maybe (Tree c EvalItem)
forall c. Tree (() -> c) (Item ()) -> Maybe (Tree c EvalItem)
go [Tree (() -> c) (Item ())]
xs)
      Leaf (Item requirement :: String
requirement loc :: Maybe Location
loc isParallelizable :: Maybe Bool
isParallelizable isFocused :: Bool
isFocused e :: Params -> (ActionWith () -> IO ()) -> ProgressCallback -> IO Result
e) ->
        Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
isFocused Maybe () -> Maybe (Tree c EvalItem) -> Maybe (Tree c EvalItem)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Tree c EvalItem -> Maybe (Tree c EvalItem)
forall (m :: * -> *) a. Monad m => a -> m a
return (EvalItem -> Tree c EvalItem
forall c a. a -> Tree c a
Leaf (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 -> (ActionWith () -> IO ()) -> ProgressCallback -> IO Result
e Params
params ((ActionWith () -> IO ()) -> ProgressCallback -> IO Result)
-> (ActionWith () -> IO ()) -> ProgressCallback -> IO Result
forall a b. (a -> b) -> a -> b
$ (ActionWith () -> ActionWith ()
forall a b. (a -> b) -> a -> b
$ ()))))

dumpFailureReport :: Config -> Integer -> QC.Args -> [Path] -> IO ()
dumpFailureReport :: Config -> Integer -> Args -> [Path] -> IO ()
dumpFailureReport config :: Config
config seed :: Integer
seed qcArgs :: Args
qcArgs xs :: [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 useColor :: Bool
useColor h :: 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 h :: Handle
h c :: Config
c = case Config -> ColorMode
configColorMode Config
c of
  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)
  ColorNever -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  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 c :: Config
c action :: Handle -> IO a
action = case Config -> Either Handle String
configOutputFile Config
c of
  Left h :: Handle
h -> Handle -> IO a
action Handle
h
  Right path :: 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 _ Nothing _ = Bool
False
rerunAll config :: Config
config (Just oldFailureReport :: FailureReport
oldFailureReport) summary :: 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
== "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 "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 0 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 x1 :: Int
x1 x2 :: Int
x2) <> :: Summary -> Summary -> Summary
<> (Summary y1 :: Int
y1 y2 :: 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