    -- vim:fdm=marker
    {-# LANGUAGE BangPatterns, ImplicitParams, MultiParamTypeClasses, DeriveDataTypeable, FlexibleContexts, CApiFFI, NamedFieldPuns #-}
    -- | Console reporter ingredient.
    --
    -- @since 0.11.3
    module Test.Tasty.Ingredients.ConsoleReporter
      ( consoleTestReporter
      , consoleTestReporterWithHook
      , Quiet(..)
      , HideSuccesses(..)
      , MinDurationToReport(..)
      , AnsiTricks(..)
      -- * Internals
      -- | The following functions and datatypes are internals that are exposed to
      -- simplify the task of rolling your own custom console reporter UI.

      -- ** Output colouring
      , UseColor(..)
      , useColor
      -- ** Test failure statistics
      , Statistics(..)
      , computeStatistics
      , printStatistics
      , printStatisticsNoTime
      -- ** Outputting results
      , TestOutput(..)
      , buildTestOutput
      , foldTestOutput
      , withConsoleFormat
      ) where

    import Prelude hiding (fail, EQ)
    import Control.Monad (join, unless, void, when, (<=<))
    import Control.Monad.IO.Class (liftIO)
    import Control.Monad.Trans.Reader (Reader, runReader, ask)
    import Control.Monad.Trans.State (evalState, evalStateT, get, modify, put)
    import Control.Concurrent.STM
    import Control.Exception
    import Test.Tasty.Core
    import Test.Tasty.Providers.ConsoleFormat
    import Test.Tasty.Run
    import Test.Tasty.Ingredients
    import Test.Tasty.Ingredients.ListTests
    import Test.Tasty.Options
    import Test.Tasty.Options.Core
    import Test.Tasty.Patterns
    import Test.Tasty.Patterns.Printer
    import Test.Tasty.Patterns.Types
    import Test.Tasty.Runners.Reducers
    import Test.Tasty.Runners.Utils
    import Text.Printf
    import qualified Data.IntMap as IntMap
    import qualified Data.IntSet as IntSet
    import Data.Char
    #ifdef USE_WCWIDTH
    import Foreign.C.Types (CInt(..), CWchar(..))
    #endif
    import Data.List (isInfixOf)
    import Data.Maybe
    import Data.Monoid (Any(..))
    import qualified Data.Semigroup as Sem
    import Data.Typeable
    import Options.Applicative hiding (action, str, Success, Failure)
    import System.IO
    import System.Console.ANSI
    #if !MIN_VERSION_base(4,11,0)
    import Data.Foldable (foldMap)
    #endif

    --------------------------------------------------
    -- TestOutput base definitions
    --------------------------------------------------
    -- {{{
    -- | 'TestOutput' is an intermediary between output formatting and output
    -- printing. It lets us have several different printing modes (normal; print
    -- failures only; quiet).
    --
    -- @since 0.12
    data TestOutput
      = -- | Printing a test.
        PrintTest
          String
            -- ^ Name of the test.
          (IO ())
            -- ^ Action that prints the test name.
          (Progress -> IO ())
            -- ^ Action that prints the progress of the test.  /Since: 1.5/
          (Result -> IO ())
            -- ^ Action that renders the result of the test.
      | -- | Printing a test group.
        PrintHeading
          String
            -- ^ Name of the test group
          (IO ())
            -- ^ Action that prints the heading of a test group.
          TestOutput
            -- ^ The 'TestOutput' for that test group.
      | -- | Inactive test (e.g. not matching the current pattern).
        Skip
      | -- | Two sets of 'TestOutput' on the same level.
        Seq TestOutput TestOutput

    -- The monoid laws should hold observationally w.r.t. the semantics defined
    -- in this module.
    --
    -- @since 0.12.0.1
    instance Sem.Semigroup TestOutput where
      <> :: TestOutput -> TestOutput -> TestOutput
    (<>) = TestOutput -> TestOutput -> TestOutput
    Seq
    instance Monoid TestOutput where
      mempty :: TestOutput
    mempty = TestOutput
    Skip
    #if !MIN_VERSION_base(4,11,0)
      mappend = (Sem.<>)
    #endif

    applyHook :: ([TestName] -> Result -> IO Result) -> TestOutput -> TestOutput
    applyHook :: ([TestName] -> Result -> IO Result) -> TestOutput -> TestOutput
    applyHook [TestName] -> Result -> IO Result
    hook = [TestName] -> TestOutput -> TestOutput
    go []
      where
        go :: [TestName] -> TestOutput -> TestOutput
    go [TestName]
    path (PrintTest TestName
    name IO ()
    printName Progress -> IO ()
    printProgress Result -> IO ()
    printResult) =
          TestName
    -> IO () -> (Progress -> IO ()) -> (Result -> IO ()) -> TestOutput
    PrintTest TestName
    name IO ()
    printName Progress -> IO ()
    printProgress (Result -> IO ()
    printResult (Result -> IO ()) -> (Result -> IO Result) -> Result -> IO ()
    forall (m :: * -> *) b c a.
    Monad m =>
    (b -> m c) -> (a -> m b) -> a -> m c
    <=< [TestName] -> Result -> IO Result
    hook (TestName
    name TestName -> [TestName] -> [TestName]
    forall a. a -> [a] -> [a]
    : [TestName]
    path))
        go [TestName]
    path (PrintHeading TestName
    name IO ()
    printName TestOutput
    printBody) =
          TestName -> IO () -> TestOutput -> TestOutput
    PrintHeading TestName
    name IO ()
    printName ([TestName] -> TestOutput -> TestOutput
    go (TestName
    name TestName -> [TestName] -> [TestName]
    forall a. a -> [a] -> [a]
    : [TestName]
    path) TestOutput
    printBody)
        go [TestName]
    path (Seq TestOutput
    a TestOutput
    b) = TestOutput -> TestOutput -> TestOutput
    Seq ([TestName] -> TestOutput -> TestOutput
    go [TestName]
    path TestOutput
    a) ([TestName] -> TestOutput -> TestOutput
    go [TestName]
    path TestOutput
    b)
        go [TestName]
    _ TestOutput
    Skip = TestOutput
    forall a. Monoid a => a
    mempty

    type Level = Int

    -- | Build the 'TestOutput' for a 'TestTree' and 'OptionSet'. The @colors@
    -- ImplicitParam controls whether the output is colored.
    --
    -- @since 0.11.3
    buildTestOutput :: (?colors :: Bool) => OptionSet -> TestTree -> TestOutput
    buildTestOutput :: (?colors::Bool) => OptionSet -> TestTree -> TestOutput
    buildTestOutput OptionSet
    opts TestTree
    tree =
      let
        -- Do not retain the reference to the tree more than necessary
        !alignment :: Int
    alignment = OptionSet -> TestTree -> Int
    computeAlignment OptionSet
    opts TestTree
    tree

        MinDurationToReport{Integer
    minDurationMicros :: Integer
    minDurationMicros :: MinDurationToReport -> Integer
    minDurationMicros} = OptionSet -> MinDurationToReport
    forall v. IsOption v => OptionSet -> v
    lookupOption OptionSet
    opts

        runSingleTest
          :: (IsTest t, ?colors :: Bool)
          => OptionSet -> TestName -> t -> Ap (Reader Level) TestOutput
        runSingleTest :: forall t.
    (IsTest t, ?colors::Bool) =>
    OptionSet -> TestName -> t -> Ap (ReaderT Int Identity) TestOutput
    runSingleTest OptionSet
    _opts TestName
    name t
    _test = Reader Int TestOutput -> Ap (ReaderT Int Identity) TestOutput
    forall (f :: * -> *) a. f a -> Ap f a
    Ap (Reader Int TestOutput -> Ap (ReaderT Int Identity) TestOutput)
    -> Reader Int TestOutput -> Ap (ReaderT Int Identity) TestOutput
    forall a b. (a -> b) -> a -> b
    $ do
          level <- ReaderT Int Identity Int
    forall (m :: * -> *) r. Monad m => ReaderT r m r
    ask

          let
            indentedNameWidth = Int
    indentSize Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    level Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + TestName -> Int
    stringWidth TestName
    name
            postNamePadding = Int
    alignment Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    indentedNameWidth

            testNamePadded = TestName -> TestName -> TestName -> TestName -> TestName
    forall r. PrintfType r => TestName -> r
    printf TestName
    "%s%s: %s"
              (Int -> TestName
    indent Int
    level)
              TestName
    name
              (Int -> Char -> TestName
    forall a. Int -> a -> [a]
    replicate Int
    postNamePadding Char
    ' ')

            printTestName = do
              IO () -> IO ()
    withoutLineWrap (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ TestName -> IO ()
    putStr TestName
    testNamePadded
              Handle -> IO ()
    hFlush Handle
    stdout

            printTestProgress Progress
    progress
              -- We cannot display progress properly if a terminal
              -- does not support manipulations with cursor position.
              | Bool -> Bool
    not Bool
    getAnsiTricks = () -> IO ()
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()

              | Progress
    progress Progress -> Progress -> Bool
    forall a. Eq a => a -> a -> Bool
    == Progress
    emptyProgress = () -> IO ()
    forall a. a -> IO a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ()

              | Bool
    otherwise = do
                  let
                    msg :: TestName
    msg = case (TestName -> TestName
    cleanupProgressText (TestName -> TestName) -> TestName -> TestName
    forall a b. (a -> b) -> a -> b
    $ Progress -> TestName
    progressText Progress
    progress, Float
    100 Float -> Float -> Float
    forall a. Num a => a -> a -> a
    * Progress -> Float
    progressPercent Progress
    progress) of
                            (TestName
    "",  Float
    pct) -> TestName -> Float -> TestName
    forall r. PrintfType r => TestName -> r
    printf TestName
    "%.0f%% " Float
    pct
                            (TestName
    txt, Float
    0.0) -> TestName -> TestName -> TestName
    forall r. PrintfType r => TestName -> r
    printf TestName
    "%s" TestName
    txt
                            (TestName
    txt, Float
    pct) -> TestName -> TestName -> Float -> TestName
    forall r. PrintfType r => TestName -> r
    printf TestName
    "%s: %.0f%% " TestName
    txt Float
    pct
                  Char -> IO ()
    putChar Char
    '\r'
                  -- A new progress message may be shorter than the previous one
                  -- so we must clean whole line and print anew.
                  IO ()
    clearLine
                  IO () -> IO ()
    withoutLineWrap (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
                    TestName -> IO ()
    putStr TestName
    testNamePadded
                    (?colors::Bool) => TestName -> IO ()
    TestName -> IO ()
    infoOk TestName
    msg
                  Handle -> IO ()
    hFlush Handle
    stdout

            printTestResult Result
    result = do
              rDesc <- TestName -> IO TestName
    formatMessage (TestName -> IO TestName) -> TestName -> IO TestName
    forall a b. (a -> b) -> a -> b
    $ Result -> TestName
    resultDescription Result
    result

              -- use an appropriate printing function
              let
                printFn =
                  case Result -> Outcome
    resultOutcome Result
    result of
                    Outcome
    Success -> (?colors::Bool) => TestName -> IO ()
    TestName -> IO ()
    ok
                    Failure FailureReason
    TestDepFailed -> (?colors::Bool) => TestName -> IO ()
    TestName -> IO ()
    skipped
                    Outcome
    _ -> (?colors::Bool) => TestName -> IO ()
    TestName -> IO ()
    fail
                time = Result -> Time
    resultTime Result
    result

              withoutLineWrap $ do
                when getAnsiTricks $ do
                  putChar '\r'
                  clearLine
                  putStr testNamePadded

              printFn (resultShortDescription result)
              when (floor (time * 1e6) >= minDurationMicros) $
                printFn (printf " (%.2fs)" time)
              printFn "\n"

              when (not $ null rDesc) $
                (if resultSuccessful result then infoOk else infoFail) $
                  printf "%s%s\n" (indent $ level + 1) (formatDesc (level+1) rDesc)
              case resultDetailsPrinter result of
                ResultDetailsPrinter Int -> ConsoleFormatPrinter -> IO ()
    action -> Int -> ConsoleFormatPrinter -> IO ()
    action Int
    level (?colors::Bool) => ConsoleFormatPrinter
    ConsoleFormatPrinter
    withConsoleFormat

          return $ PrintTest name printTestName printTestProgress printTestResult

        runGroup :: OptionSet -> TestName -> [Ap (Reader Level) TestOutput] -> Ap (Reader Level) TestOutput
        runGroup :: OptionSet
    -> TestName
    -> [Ap (ReaderT Int Identity) TestOutput]
    -> Ap (ReaderT Int Identity) TestOutput
    runGroup OptionSet
    _opts TestName
    name [Ap (ReaderT Int Identity) TestOutput]
    grp = Reader Int TestOutput -> Ap (ReaderT Int Identity) TestOutput
    forall (f :: * -> *) a. f a -> Ap f a
    Ap (Reader Int TestOutput -> Ap (ReaderT Int Identity) TestOutput)
    -> Reader Int TestOutput -> Ap (ReaderT Int Identity) TestOutput
    forall a b. (a -> b) -> a -> b
    $ do
          level <- ReaderT Int Identity Int
    forall (m :: * -> *) r. Monad m => ReaderT r m r
    ask
          let
            printHeading = IO () -> IO ()
    withoutLineWrap (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ TestName -> TestName -> TestName -> IO ()
    forall r. PrintfType r => TestName -> r
    printf TestName
    "%s%s\n" (Int -> TestName
    indent Int
    level) TestName
    name
            printBody = Reader Int TestOutput -> Int -> TestOutput
    forall r a. Reader r a -> r -> a
    runReader (Ap (ReaderT Int Identity) TestOutput -> Reader Int TestOutput
    forall (f :: * -> *) a. Ap f a -> f a
    getApp ([Ap (ReaderT Int Identity) TestOutput]
    -> Ap (ReaderT Int Identity) TestOutput
    forall a. Monoid a => [a] -> a
    mconcat [Ap (ReaderT Int Identity) TestOutput]
    grp)) (Int
    level Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1)
          return $ PrintHeading name printHeading printBody

      in
        (Reader Int TestOutput -> Int -> TestOutput)
    -> Int -> Reader Int TestOutput -> TestOutput
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip Reader Int TestOutput -> Int -> TestOutput
    forall r a. Reader r a -> r -> a
    runReader Int
    0 (Reader Int TestOutput -> TestOutput)
    -> Reader Int TestOutput -> TestOutput
    forall a b. (a -> b) -> a -> b
    $ Ap (ReaderT Int Identity) TestOutput -> Reader Int TestOutput
    forall (f :: * -> *) a. Ap f a -> f a
    getApp (Ap (ReaderT Int Identity) TestOutput -> Reader Int TestOutput)
    -> Ap (ReaderT Int Identity) TestOutput -> Reader Int TestOutput
    forall a b. (a -> b) -> a -> b
    $
          TreeFold (Ap (ReaderT Int Identity) TestOutput)
    -> OptionSet -> TestTree -> Ap (ReaderT Int Identity) TestOutput
    forall b. Monoid b => TreeFold b -> OptionSet -> TestTree -> b
    foldTestTree
            TreeFold (Ap (ReaderT Int Identity) TestOutput)
    forall b. Monoid b => TreeFold b
    trivialFold
              { foldSingle = runSingleTest
              , foldGroup = runGroup
              }
              OptionSet
    opts TestTree
    tree
      where
        AnsiTricks{Bool
    getAnsiTricks :: Bool
    getAnsiTricks :: AnsiTricks -> Bool
    getAnsiTricks} = OptionSet -> AnsiTricks
    forall v. IsOption v => OptionSet -> v
    lookupOption OptionSet
    opts
        -- We must ensure these lines don't wrap, otherwise the wrong
        -- line will be cleared later or the test tree printing will
        -- itself wrap.
        withoutLineWrap :: IO () -> IO ()
    #if MIN_VERSION_ansi_terminal(1,1,2)
        withoutLineWrap :: IO () -> IO ()
    withoutLineWrap IO ()
    m | Bool
    getAnsiTricks =
          IO () -> IO () -> IO () -> IO ()
    forall a b c. IO a -> IO b -> IO c -> IO c
    bracket_ IO ()
    disableLineWrap IO ()
    enableLineWrap IO ()
    m
    #endif
        withoutLineWrap IO ()
    m = IO ()
    m

    -- | Make sure the progress text does not contain any newlines or line feeds,
    -- lest our ANSI magic breaks. Since the progress text is expected to be short,
    -- we simply drop anything after a newline.
    cleanupProgressText :: String -> String
    cleanupProgressText :: TestName -> TestName
    cleanupProgressText = (Char -> Char) -> TestName -> TestName
    forall a b. (a -> b) -> [a] -> [b]
    map (\Char
    c -> if Char -> Bool
    isSpace Char
    c then Char
    ' ' else Char
    c)
                        (TestName -> TestName)
    -> (TestName -> TestName) -> TestName -> TestName
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char -> Bool) -> TestName -> TestName
    forall a. (a -> Bool) -> [a] -> [a]
    takeWhile (\Char
    c -> Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Char
    '\n' Bool -> Bool -> Bool
    && Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Char
    '\r' Bool -> Bool -> Bool
    && Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Char
    '\t')

    -- | Fold function for the 'TestOutput' tree into a 'Monoid'.
    --
    -- @since 0.12
    foldTestOutput
      :: Monoid b
      => (String -> IO () -> IO Result -> (Result -> IO ()) -> b)
      -- ^ Eliminator for test cases. The @IO ()@ prints the testname. The
      -- @IO Result@ blocks until the test is finished, returning it's 'Result'.
      -- The @Result -> IO ()@ function prints the formatted output.
      -> (String -> IO () -> b -> b)
      -- ^ Eliminator for test groups. The @IO ()@ prints the test group's name.
      -- The @b@ is the result of folding the test group.
      -> TestOutput -- ^ The @TestOutput@ being rendered.
      -> StatusMap -- ^ The @StatusMap@ received by the 'TestReporter'
      -> b
    foldTestOutput :: forall b.
    Monoid b =>
    (TestName -> IO () -> IO Result -> (Result -> IO ()) -> b)
    -> (TestName -> IO () -> b -> b) -> TestOutput -> StatusMap -> b
    foldTestOutput TestName -> IO () -> IO Result -> (Result -> IO ()) -> b
    foldTest TestName -> IO () -> b -> b
    foldHeading TestOutput
    outputTree StatusMap
    smap =
      (State Int b -> Int -> b) -> Int -> State Int b -> b
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip State Int b -> Int -> b
    forall s a. State s a -> s -> a
    evalState Int
    0 (State Int b -> b) -> State Int b -> b
    forall a b. (a -> b) -> a -> b
    $ Ap (StateT Int Identity) b -> State Int b
    forall (f :: * -> *) a. Ap f a -> f a
    getApp (Ap (StateT Int Identity) b -> State Int b)
    -> Ap (StateT Int Identity) b -> State Int b
    forall a b. (a -> b) -> a -> b
    $ TestOutput -> Ap (StateT Int Identity) b
    forall {m :: * -> *}. Monad m => TestOutput -> Ap (StateT Int m) b
    go TestOutput
    outputTree where

      go :: TestOutput -> Ap (StateT Int m) b
    go (PrintTest TestName
    name IO ()
    printName Progress -> IO ()
    printProgress Result -> IO ()
    printResult) = StateT Int m b -> Ap (StateT Int m) b
    forall (f :: * -> *) a. f a -> Ap f a
    Ap (StateT Int m b -> Ap (StateT Int m) b)
    -> StateT Int m b -> Ap (StateT Int m) b
    forall a b. (a -> b) -> a -> b
    $ do
        ix <- StateT Int m Int
    forall (m :: * -> *) s. Monad m => StateT s m s
    get
        put $! ix + 1
        let
          statusVar =
            TVar Status -> Maybe (TVar Status) -> TVar Status
    forall a. a -> Maybe a -> a
    fromMaybe (TestName -> TVar Status
    forall a. HasCallStack => TestName -> a
    error TestName
    "internal error: index out of bounds") (Maybe (TVar Status) -> TVar Status)
    -> Maybe (TVar Status) -> TVar Status
    forall a b. (a -> b) -> a -> b
    $
            Int -> StatusMap -> Maybe (TVar Status)
    forall a. Int -> IntMap a -> Maybe a
    IntMap.lookup Int
    ix StatusMap
    smap

        return $ foldTest name printName (ppProgressOrResult statusVar printProgress) printResult

      go (PrintHeading TestName
    name IO ()
    printName TestOutput
    printBody) = StateT Int m b -> Ap (StateT Int m) b
    forall (f :: * -> *) a. f a -> Ap f a
    Ap (StateT Int m b -> Ap (StateT Int m) b)
    -> StateT Int m b -> Ap (StateT Int m) b
    forall a b. (a -> b) -> a -> b
    $
        TestName -> IO () -> b -> b
    foldHeading TestName
    name IO ()
    printName (b -> b) -> StateT Int m b -> StateT Int m b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Ap (StateT Int m) b -> StateT Int m b
    forall (f :: * -> *) a. Ap f a -> f a
    getApp (TestOutput -> Ap (StateT Int m) b
    go TestOutput
    printBody)
      go (Seq TestOutput
    a TestOutput
    b) = Ap (StateT Int m) b -> Ap (StateT Int m) b -> Ap (StateT Int m) b
    forall a. Monoid a => a -> a -> a
    mappend (TestOutput -> Ap (StateT Int m) b
    go TestOutput
    a) (TestOutput -> Ap (StateT Int m) b
    go TestOutput
    b)
      go TestOutput
    Skip = Ap (StateT Int m) b
    forall a. Monoid a => a
    mempty

    -- }}}

    --------------------------------------------------
    -- TestOutput modes
    --------------------------------------------------

    ppProgressOrResult :: TVar Status -> (Progress -> IO ()) -> IO Result
    ppProgressOrResult :: TVar Status -> (Progress -> IO ()) -> IO Result
    ppProgressOrResult TVar Status
    statusVar Progress -> IO ()
    ppProgress = Progress -> IO Result
    go Progress
    emptyProgress where
      go :: Progress -> IO Result
    go Progress
    old_p = (Progress -> IO Result)
    -> (Result -> IO Result) -> Either Progress Result -> IO Result
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either (\Progress
    p -> Progress -> IO ()
    ppProgress Progress
    p IO () -> IO Result -> IO Result
    forall a b. IO a -> IO b -> IO b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> Progress -> IO Result
    go Progress
    p) Result -> IO Result
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Either Progress Result -> IO Result)
    -> IO (Either Progress Result) -> IO Result
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< (STM (Either Progress Result) -> IO (Either Progress Result)
    forall a. STM a -> IO a
    atomically (STM (Either Progress Result) -> IO (Either Progress Result))
    -> STM (Either Progress Result) -> IO (Either Progress Result)
    forall a b. (a -> b) -> a -> b
    $ do
        status <- TVar Status -> STM Status
    forall a. TVar a -> STM a
    readTVar TVar Status
    statusVar
        case status of
          Executing Progress
    p
            | Progress
    p Progress -> Progress -> Bool
    forall a. Eq a => a -> a -> Bool
    == Progress
    old_p -> STM (Either Progress Result)
    forall a. STM a
    retry
            | Bool
    otherwise -> Either Progress Result -> STM (Either Progress Result)
    forall a. a -> STM a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Either Progress Result -> STM (Either Progress Result))
    -> Either Progress Result -> STM (Either Progress Result)
    forall a b. (a -> b) -> a -> b
    $ Progress -> Either Progress Result
    forall a b. a -> Either a b
    Left Progress
    p
          Done Result
    r      -> Either Progress Result -> STM (Either Progress Result)
    forall a. a -> STM a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (Either Progress Result -> STM (Either Progress Result))
    -> Either Progress Result -> STM (Either Progress Result)
    forall a b. (a -> b) -> a -> b
    $ Result -> Either Progress Result
    forall a b. b -> Either a b
    Right Result
    r
          Status
    _           -> STM (Either Progress Result)
    forall a. STM a
    retry
        )

    -- {{{
    consoleOutput :: (?colors :: Bool) => TestOutput -> StatusMap -> IO ()
    consoleOutput :: (?colors::Bool) => TestOutput -> StatusMap -> IO ()
    consoleOutput TestOutput
    toutput StatusMap
    smap =
      Traversal IO -> IO ()
    forall (f :: * -> *). Traversal f -> f ()
    getTraversal (Traversal IO -> IO ())
    -> ((Traversal IO, Any) -> Traversal IO)
    -> (Traversal IO, Any)
    -> IO ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Traversal IO, Any) -> Traversal IO
    forall a b. (a, b) -> a
    fst ((Traversal IO, Any) -> IO ()) -> (Traversal IO, Any) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ (TestName
     -> IO () -> IO Result -> (Result -> IO ()) -> (Traversal IO, Any))
    -> (TestName
        -> IO () -> (Traversal IO, Any) -> (Traversal IO, Any))
    -> TestOutput
    -> StatusMap
    -> (Traversal IO, Any)
    forall b.
    Monoid b =>
    (TestName -> IO () -> IO Result -> (Result -> IO ()) -> b)
    -> (TestName -> IO () -> b -> b) -> TestOutput -> StatusMap -> b
    foldTestOutput TestName
    -> IO () -> IO Result -> (Result -> IO ()) -> (Traversal IO, Any)
    forall {p} {t}.
    p -> IO () -> IO t -> (t -> IO ()) -> (Traversal IO, Any)
    foldTest TestName -> IO () -> (Traversal IO, Any) -> (Traversal IO, Any)
    forall {p}.
    p -> IO () -> (Traversal IO, Any) -> (Traversal IO, Any)
    foldHeading TestOutput
    toutput StatusMap
    smap
      where
        foldTest :: p -> IO () -> IO t -> (t -> IO ()) -> (Traversal IO, Any)
    foldTest p
    _name IO ()
    printName IO t
    getResult t -> IO ()
    printResult =
          ( IO () -> Traversal IO
    forall (f :: * -> *). f () -> Traversal f
    Traversal (IO () -> Traversal IO) -> IO () -> Traversal IO
    forall a b. (a -> b) -> a -> b
    $ do
              IO ()
    printName :: IO ()
              r <- IO t
    getResult
              printResult r
          , Bool -> Any
    Any Bool
    True)
        foldHeading :: p -> IO () -> (Traversal IO, Any) -> (Traversal IO, Any)
    foldHeading p
    _name IO ()
    printHeading (Traversal IO
    printBody, Any Bool
    nonempty) =
          ( IO () -> Traversal IO
    forall (f :: * -> *). f () -> Traversal f
    Traversal (IO () -> Traversal IO) -> IO () -> Traversal IO
    forall a b. (a -> b) -> a -> b
    $ do
              Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    nonempty (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
                IO ()
    printHeading :: IO ()
                Traversal IO -> IO ()
    forall (f :: * -> *). Traversal f -> f ()
    getTraversal Traversal IO
    printBody
          , Bool -> Any
    Any Bool
    nonempty
          )

    consoleOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> IO ()
    consoleOutputHidingSuccesses :: (?colors::Bool) => TestOutput -> StatusMap -> IO ()
    consoleOutputHidingSuccesses TestOutput
    toutput StatusMap
    smap =
      IO Any -> IO ()
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void (IO Any -> IO ()) -> (Ap IO Any -> IO Any) -> Ap IO Any -> IO ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Ap IO Any -> IO Any
    forall (f :: * -> *) a. Ap f a -> f a
    getApp (Ap IO Any -> IO ()) -> Ap IO Any -> IO ()
    forall a b. (a -> b) -> a -> b
    $ (TestName -> IO () -> IO Result -> (Result -> IO ()) -> Ap IO Any)
    -> (TestName -> IO () -> Ap IO Any -> Ap IO Any)
    -> TestOutput
    -> StatusMap
    -> Ap IO Any
    forall b.
    Monoid b =>
    (TestName -> IO () -> IO Result -> (Result -> IO ()) -> b)
    -> (TestName -> IO () -> b -> b) -> TestOutput -> StatusMap -> b
    foldTestOutput TestName -> IO () -> IO Result -> (Result -> IO ()) -> Ap IO Any
    forall {p}.
    p -> IO () -> IO Result -> (Result -> IO ()) -> Ap IO Any
    foldTest TestName -> IO () -> Ap IO Any -> Ap IO Any
    forall {p}. p -> IO () -> Ap IO Any -> Ap IO Any
    foldHeading TestOutput
    toutput StatusMap
    smap
      where
        foldTest :: p -> IO () -> IO Result -> (Result -> IO ()) -> Ap IO Any
    foldTest p
    _name IO ()
    printName IO Result
    getResult Result -> IO ()
    printResult =
          IO Any -> Ap IO Any
    forall (f :: * -> *) a. f a -> Ap f a
    Ap (IO Any -> Ap IO Any) -> IO Any -> Ap IO Any
    forall a b. (a -> b) -> a -> b
    $ do
              IO ()
    printName :: IO ()
              r <- IO Result
    getResult
              if resultSuccessful r
                then do clearThisLine; return $ Any False
                else do printResult r :: IO (); return $ Any True

        foldHeading :: p -> IO () -> Ap IO Any -> Ap IO Any
    foldHeading p
    _name IO ()
    printHeading Ap IO Any
    printBody =
          IO Any -> Ap IO Any
    forall (f :: * -> *) a. f a -> Ap f a
    Ap (IO Any -> Ap IO Any) -> IO Any -> Ap IO Any
    forall a b. (a -> b) -> a -> b
    $ do
            IO ()
    printHeading :: IO ()
            Any failed <- Ap IO Any -> IO Any
    forall (f :: * -> *) a. Ap f a -> f a
    getApp Ap IO Any
    printBody
            unless failed clearAboveLine
            return $ Any failed

        clearAboveLine :: IO ()
    clearAboveLine = do Int -> IO ()
    cursorUpLine Int
    1; IO ()
    clearThisLine
        clearThisLine :: IO ()
    clearThisLine = do IO ()
    clearLine; Int -> IO ()
    setCursorColumn Int
    0

    streamOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> IO ()
    streamOutputHidingSuccesses :: (?colors::Bool) => TestOutput -> StatusMap -> IO ()
    streamOutputHidingSuccesses TestOutput
    toutput StatusMap
    smap =
      IO Any -> IO ()
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void (IO Any -> IO ())
    -> (Ap (StateT [IO ()] IO) Any -> IO Any)
    -> Ap (StateT [IO ()] IO) Any
    -> IO ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (StateT [IO ()] IO Any -> [IO ()] -> IO Any)
    -> [IO ()] -> StateT [IO ()] IO Any -> IO Any
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip StateT [IO ()] IO Any -> [IO ()] -> IO Any
    forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
    evalStateT [] (StateT [IO ()] IO Any -> IO Any)
    -> (Ap (StateT [IO ()] IO) Any -> StateT [IO ()] IO Any)
    -> Ap (StateT [IO ()] IO) Any
    -> IO Any
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Ap (StateT [IO ()] IO) Any -> StateT [IO ()] IO Any
    forall (f :: * -> *) a. Ap f a -> f a
    getApp (Ap (StateT [IO ()] IO) Any -> IO ())
    -> Ap (StateT [IO ()] IO) Any -> IO ()
    forall a b. (a -> b) -> a -> b
    $
        (TestName
     -> IO ()
     -> IO Result
     -> (Result -> IO ())
     -> Ap (StateT [IO ()] IO) Any)
    -> (TestName
        -> IO ()
        -> Ap (StateT [IO ()] IO) Any
        -> Ap (StateT [IO ()] IO) Any)
    -> TestOutput
    -> StatusMap
    -> Ap (StateT [IO ()] IO) Any
    forall b.
    Monoid b =>
    (TestName -> IO () -> IO Result -> (Result -> IO ()) -> b)
    -> (TestName -> IO () -> b -> b) -> TestOutput -> StatusMap -> b
    foldTestOutput TestName
    -> IO ()
    -> IO Result
    -> (Result -> IO ())
    -> Ap (StateT [IO ()] IO) Any
    forall {m :: * -> *} {p} {a}.
    MonadIO m =>
    p
    -> IO ()
    -> IO Result
    -> (Result -> IO ())
    -> Ap (StateT [IO a] m) Any
    foldTest TestName
    -> IO ()
    -> Ap (StateT [IO ()] IO) Any
    -> Ap (StateT [IO ()] IO) Any
    forall {m :: * -> *} {p} {a}.
    Monad m =>
    p -> a -> Ap (StateT [a] m) Any -> Ap (StateT [a] m) Any
    foldHeading TestOutput
    toutput StatusMap
    smap
      where
        foldTest :: p
    -> IO ()
    -> IO Result
    -> (Result -> IO ())
    -> Ap (StateT [IO a] m) Any
    foldTest p
    _name IO ()
    printName IO Result
    getResult Result -> IO ()
    printResult =
          StateT [IO a] m Any -> Ap (StateT [IO a] m) Any
    forall (f :: * -> *) a. f a -> Ap f a
    Ap (StateT [IO a] m Any -> Ap (StateT [IO a] m) Any)
    -> StateT [IO a] m Any -> Ap (StateT [IO a] m) Any
    forall a b. (a -> b) -> a -> b
    $ do
              r <- IO Result -> StateT [IO a] m Result
    forall a. IO a -> StateT [IO a] m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO Result -> StateT [IO a] m Result)
    -> IO Result -> StateT [IO a] m Result
    forall a b. (a -> b) -> a -> b
    $ IO Result
    getResult
              if resultSuccessful r
                then return $ Any False
                else do
                  stack <- get
                  put []

                  liftIO $ do
                    sequence_ $ reverse stack
                    printName :: IO ()
                    printResult r :: IO ()

                  return $ Any True

        foldHeading :: p -> a -> Ap (StateT [a] m) Any -> Ap (StateT [a] m) Any
    foldHeading p
    _name a
    printHeading Ap (StateT [a] m) Any
    printBody =
          StateT [a] m Any -> Ap (StateT [a] m) Any
    forall (f :: * -> *) a. f a -> Ap f a
    Ap (StateT [a] m Any -> Ap (StateT [a] m) Any)
    -> StateT [a] m Any -> Ap (StateT [a] m) Any
    forall a b. (a -> b) -> a -> b
    $ do
            ([a] -> [a]) -> StateT [a] m ()
    forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
    modify (a
    printHeading a -> [a] -> [a]
    forall a. a -> [a] -> [a]
    :)
            Any failed <- Ap (StateT [a] m) Any -> StateT [a] m Any
    forall (f :: * -> *) a. Ap f a -> f a
    getApp Ap (StateT [a] m) Any
    printBody
            unless failed $
              modify $ \[a]
    stack ->
                case [a]
    stack of
                  a
    _:[a]
    rest -> [a]
    rest
                  [] -> [] -- shouldn't happen anyway
            return $ Any failed

    -- }}}

    --------------------------------------------------
    -- Statistics
    --------------------------------------------------
    -- {{{

    -- | Track the number of tests that were run and failures of a 'TestTree' or
    -- sub-tree.
    --
    -- @since 0.11.3
    data Statistics = Statistics
      { Statistics -> Int
    statTotal :: !Int -- ^ Number of active tests (e.g., that match the
                          -- pattern specified on the commandline), inactive tests
                          -- are not counted.
      , Statistics -> Int
    statFailures :: !Int -- ^ Number of active tests that failed.
      }

    -- | @since 0.12.0.1
    instance Sem.Semigroup Statistics where
      Statistics Int
    t1 Int
    f1 <> :: Statistics -> Statistics -> Statistics
    <> Statistics Int
    t2 Int
    f2 = Int -> Int -> Statistics
    Statistics (Int
    t1 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    t2) (Int
    f1 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    f2)
    instance Monoid Statistics where
      mempty :: Statistics
    mempty = Int -> Int -> Statistics
    Statistics Int
    0 Int
    0
    #if !MIN_VERSION_base(4,11,0)
      mappend = (Sem.<>)
    #endif

    -- | @computeStatistics@ computes a summary 'Statistics' for
    -- a given state of the 'StatusMap'.
    -- Useful in combination with 'printStatistics'.
    --
    -- @since 1.2.3
    computeStatistics :: StatusMap -> IO Statistics
    computeStatistics :: StatusMap -> IO Statistics
    computeStatistics = Ap IO Statistics -> IO Statistics
    forall (f :: * -> *) a. Ap f a -> f a
    getApp (Ap IO Statistics -> IO Statistics)
    -> (StatusMap -> Ap IO Statistics) -> StatusMap -> IO Statistics
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (TVar Status -> Ap IO Statistics) -> StatusMap -> Ap IO Statistics
    forall m a. Monoid m => (a -> m) -> IntMap a -> m
    forall (t :: * -> *) m a.
    (Foldable t, Monoid m) =>
    (a -> m) -> t a -> m
    foldMap (\TVar Status
    var -> IO Statistics -> Ap IO Statistics
    forall (f :: * -> *) a. f a -> Ap f a
    Ap (IO Statistics -> Ap IO Statistics)
    -> IO Statistics -> Ap IO Statistics
    forall a b. (a -> b) -> a -> b
    $
      (\Result
    r -> Int -> Int -> Statistics
    Statistics Int
    1 (if Result -> Bool
    resultSuccessful Result
    r then Int
    0 else Int
    1))
        (Result -> Statistics) -> IO Result -> IO Statistics
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> TVar Status -> IO Result
    getResultFromTVar TVar Status
    var)

    reportStatistics :: (?colors :: Bool) => Statistics -> IO ()
    reportStatistics :: (?colors::Bool) => Statistics -> IO ()
    reportStatistics Statistics
    st = case Statistics -> Int
    statFailures Statistics
    st of
        Int
    0 -> (?colors::Bool) => TestName -> IO ()
    TestName -> IO ()
    ok (TestName -> IO ()) -> TestName -> IO ()
    forall a b. (a -> b) -> a -> b
    $ TestName -> Int -> TestName
    forall r. PrintfType r => TestName -> r
    printf TestName
    "All %d tests passed" (Statistics -> Int
    statTotal Statistics
    st)
        Int
    fs -> (?colors::Bool) => TestName -> IO ()
    TestName -> IO ()
    fail (TestName -> IO ()) -> TestName -> IO ()
    forall a b. (a -> b) -> a -> b
    $ TestName -> Int -> Int -> TestName
    forall r. PrintfType r => TestName -> r
    printf TestName
    "%d out of %d tests failed" Int
    fs (Statistics -> Int
    statTotal Statistics
    st)

    -- | @printStatistics@ reports test success/failure statistics and time it took
    -- to run. The 'Time' results is intended to be filled in by the 'TestReporter'
    -- callback. The @colors@ ImplicitParam controls whether coloured output is
    -- used.
    --
    -- @since 0.11.3
    printStatistics :: (?colors :: Bool) => Statistics -> Time -> IO ()
    printStatistics :: (?colors::Bool) => Statistics -> Time -> IO ()
    printStatistics Statistics
    st Time
    time = do
      TestName -> IO ()
    forall r. PrintfType r => TestName -> r
    printf TestName
    "\n"
      (?colors::Bool) => Statistics -> IO ()
    Statistics -> IO ()
    reportStatistics Statistics
    st
      case Statistics -> Int
    statFailures Statistics
    st of
        Int
    0 -> (?colors::Bool) => TestName -> IO ()
    TestName -> IO ()
    ok (TestName -> IO ()) -> TestName -> IO ()
    forall a b. (a -> b) -> a -> b
    $ TestName -> Time -> TestName
    forall r. PrintfType r => TestName -> r
    printf TestName
    " (%.2fs)\n" Time
    time
        Int
    _ -> (?colors::Bool) => TestName -> IO ()
    TestName -> IO ()
    fail (TestName -> IO ()) -> TestName -> IO ()
    forall a b. (a -> b) -> a -> b
    $ TestName -> Time -> TestName
    forall r. PrintfType r => TestName -> r
    printf TestName
    " (%.2fs)\n" Time
    time

    -- | @printStatisticsNoTime@ reports test success/failure statistics
    -- The @colors@ ImplicitParam controls whether coloured output is used.
    --
    -- @since 0.12
    printStatisticsNoTime :: (?colors :: Bool) => Statistics -> IO ()
    printStatisticsNoTime :: (?colors::Bool) => Statistics -> IO ()
    printStatisticsNoTime Statistics
    st = (?colors::Bool) => Statistics -> IO ()
    Statistics -> IO ()
    reportStatistics Statistics
    st IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> TestName -> IO ()
    forall r. PrintfType r => TestName -> r
    printf TestName
    "\n"

    -- | Wait until
    --
    -- * all tests have finished successfully, and return 'True', or
    --
    -- * at least one test has failed, and return 'False'
    statusMapResult
      :: Int -- ^ lookahead
      -> StatusMap
      -> IO Bool
    statusMapResult :: Int -> StatusMap -> IO Bool
    statusMapResult Int
    lookahead0 StatusMap
    smap
      | StatusMap -> Bool
    forall a. IntMap a -> Bool
    IntMap.null StatusMap
    smap = Bool -> IO Bool
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    True
      | Bool
    otherwise =
          IO (IO Bool) -> IO Bool
    forall (m :: * -> *) a. Monad m => m (m a) -> m a
    join (IO (IO Bool) -> IO Bool)
    -> (STM (IO Bool) -> IO (IO Bool)) -> STM (IO Bool) -> IO Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . STM (IO Bool) -> IO (IO Bool)
    forall a. STM a -> IO a
    atomically (STM (IO Bool) -> IO Bool) -> STM (IO Bool) -> IO Bool
    forall a b. (a -> b) -> a -> b
    $
            (Int
     -> TVar Status
     -> (IntSet -> Int -> STM (IO Bool))
     -> IntSet
     -> Int
     -> STM (IO Bool))
    -> (IntSet -> Int -> STM (IO Bool))
    -> StatusMap
    -> IntSet
    -> Int
    -> STM (IO Bool)
    forall a b. (Int -> a -> b -> b) -> b -> IntMap a -> b
    IntMap.foldrWithKey Int
    -> TVar Status
    -> (IntSet -> Int -> STM (IO Bool))
    -> IntSet
    -> Int
    -> STM (IO Bool)
    f IntSet -> Int -> STM (IO Bool)
    finish StatusMap
    smap IntSet
    forall a. Monoid a => a
    mempty Int
    lookahead0
      where
        f :: Int
          -> TVar Status
          -> (IntSet.IntSet -> Int -> STM (IO Bool))
          -> (IntSet.IntSet -> Int -> STM (IO Bool))
        -- ok_tests is a set of tests that completed successfully
        -- lookahead is the number of unfinished tests that we are allowed to
        -- look at
        f :: Int
    -> TVar Status
    -> (IntSet -> Int -> STM (IO Bool))
    -> IntSet
    -> Int
    -> STM (IO Bool)
    f Int
    key TVar Status
    tvar IntSet -> Int -> STM (IO Bool)
    k IntSet
    ok_tests Int
    lookahead
          | Int
    lookahead Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Int
    0 =
              -- We looked at too many unfinished tests.
              IntSet -> STM (IO Bool)
    next_iter IntSet
    ok_tests
          | Bool
    otherwise = do
              this_status <- TVar Status -> STM Status
    forall a. TVar a -> STM a
    readTVar TVar Status
    tvar
              case this_status of
                Done Result
    r ->
                  if Result -> Bool
    resultSuccessful Result
    r
                    then IntSet -> Int -> STM (IO Bool)
    k (Int -> IntSet -> IntSet
    IntSet.insert Int
    key IntSet
    ok_tests) Int
    lookahead
                    else IO Bool -> STM (IO Bool)
    forall a. a -> STM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (IO Bool -> STM (IO Bool)) -> IO Bool -> STM (IO Bool)
    forall a b. (a -> b) -> a -> b
    $ Bool -> IO Bool
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False
                Status
    _ -> IntSet -> Int -> STM (IO Bool)
    k IntSet
    ok_tests (Int
    lookaheadInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    1)

        -- next_iter is called when we end the current iteration,
        -- either because we reached the end of the test tree
        -- or because we exhausted the lookahead
        next_iter :: IntSet.IntSet -> STM (IO Bool)
        next_iter :: IntSet -> STM (IO Bool)
    next_iter IntSet
    ok_tests =
          -- If we made no progress at all, wait until at least some tests
          -- complete.
          -- Otherwise, reduce the set of tests we are looking at.
          if IntSet -> Bool
    IntSet.null IntSet
    ok_tests
            then STM (IO Bool)
    forall a. STM a
    retry
            else IO Bool -> STM (IO Bool)
    forall a. a -> STM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (IO Bool -> STM (IO Bool)) -> IO Bool -> STM (IO Bool)
    forall a b. (a -> b) -> a -> b
    $ Int -> StatusMap -> IO Bool
    statusMapResult Int
    lookahead0 (StatusMap -> IntSet -> StatusMap
    forall a. IntMap a -> IntSet -> IntMap a
    IntMap.withoutKeys StatusMap
    smap IntSet
    ok_tests)

        finish :: IntSet.IntSet -> Int -> STM (IO Bool)
        finish :: IntSet -> Int -> STM (IO Bool)
    finish IntSet
    ok_tests Int
    _ = IntSet -> STM (IO Bool)
    next_iter IntSet
    ok_tests

    -- }}}

    --------------------------------------------------
    -- Console test reporter
    --------------------------------------------------
    -- {{{

    -- | A simple console UI.
    --
    -- @since 0.4
    consoleTestReporter :: Ingredient
    consoleTestReporter :: Ingredient
    consoleTestReporter = [OptionDescription]
    -> (OptionSet
        -> TestTree -> Maybe (StatusMap -> IO (Time -> IO Bool)))
    -> Ingredient
    TestReporter [OptionDescription]
    consoleTestReporterOptions ((OptionSet
      -> TestTree -> Maybe (StatusMap -> IO (Time -> IO Bool)))
     -> Ingredient)
    -> (OptionSet
        -> TestTree -> Maybe (StatusMap -> IO (Time -> IO Bool)))
    -> Ingredient
    forall a b. (a -> b) -> a -> b
    $ \OptionSet
    opts TestTree
    tree ->
      let
        TestPattern Maybe Expr
    pattern = OptionSet -> TestPattern
    forall v. IsOption v => OptionSet -> v
    lookupOption OptionSet
    opts
        tests :: [TestName]
    tests = OptionSet -> TestTree -> [TestName]
    testsNames OptionSet
    opts TestTree
    tree
        hook :: [TestName] -> Result -> IO Result
    hook = (Result -> IO Result
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Result -> IO Result) -> (Result -> Result) -> Result -> IO Result
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .) ((Result -> Result) -> Result -> IO Result)
    -> ([TestName] -> Result -> Result)
    -> [TestName]
    -> Result
    -> IO Result
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [TestName] -> Maybe Expr -> [TestName] -> Result -> Result
    appendPatternIfTestFailed [TestName]
    tests Maybe Expr
    pattern
        TestReporter [OptionDescription]
    _ OptionSet -> TestTree -> Maybe (StatusMap -> IO (Time -> IO Bool))
    cb = ([TestName] -> Result -> IO Result) -> Ingredient
    consoleTestReporterWithHook [TestName] -> Result -> IO Result
    hook
      in OptionSet -> TestTree -> Maybe (StatusMap -> IO (Time -> IO Bool))
    cb OptionSet
    opts TestTree
    tree

    appendPatternIfTestFailed
      :: [TestName] -- ^ list of (pre-intercalated) test names
      -> Maybe Expr -- ^ current pattern, if any
      -> [TestName] -- ^ name of current test, represented as a list of group names
      -> Result     -- ^ vanilla result
      -> Result
    appendPatternIfTestFailed :: [TestName] -> Maybe Expr -> [TestName] -> Result -> Result
    appendPatternIfTestFailed [TestName
    _] Maybe Expr
    _ [TestName]
    _ Result
    res = Result
    res -- if there is only one test, nothing to refine
    appendPatternIfTestFailed [TestName]
    _ Maybe Expr
    _ [] Result
    res  = Result
    res -- should be impossible
    appendPatternIfTestFailed [TestName]
    tests Maybe Expr
    currentPattern (TestName
    name : [TestName]
    names) Result
    res = case Result -> Outcome
    resultOutcome Result
    res of
      Outcome
    Success -> Result
    res
      Failure{} -> Result
    res { resultDescription = resultDescription res ++ msg }
      where
        msg :: TestName
    msg = TestName
    "\nUse -p '" TestName -> TestName -> TestName
    forall a. [a] -> [a] -> [a]
    ++ TestName -> TestName
    escapeQuotes (Expr -> TestName
    printAwkExpr Expr
    pattern) TestName -> TestName -> TestName
    forall a. [a] -> [a] -> [a]
    ++ TestName
    "' to rerun this test only."

        escapeQuotes :: TestName -> TestName
    escapeQuotes = (Char -> TestName) -> TestName -> TestName
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap ((Char -> TestName) -> TestName -> TestName)
    -> (Char -> TestName) -> TestName -> TestName
    forall a b. (a -> b) -> a -> b
    $ \Char
    c -> if Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '\'' then TestName
    "'\\''" else [Char
    c]

        findPattern :: [TestName] -> TestName -> [TestName] -> Expr
    findPattern [TestName
    _] TestName
    pat [TestName]
    _ = TestName -> Expr
    ERE TestName
    pat
        findPattern [TestName]
    _  TestName
    pat [] = Expr -> Expr -> Expr
    EQ (Expr -> Expr
    Field (Int -> Expr
    IntLit Int
    0)) (TestName -> Expr
    StringLit TestName
    pat)
        findPattern [TestName]
    ts TestName
    pat (TestName
    n : [TestName]
    ns) = let pat' :: TestName
    pat' = TestName
    n TestName -> TestName -> TestName
    forall a. [a] -> [a] -> [a]
    ++ Char
    '.' Char -> TestName -> TestName
    forall a. a -> [a] -> [a]
    : TestName
    pat in
          [TestName] -> TestName -> [TestName] -> Expr
    findPattern ((TestName -> Bool) -> [TestName] -> [TestName]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (TestName
    pat' TestName -> TestName -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isInfixOf`) [TestName]
    ts) TestName
    pat' [TestName]
    ns

        individualPattern :: Expr
    individualPattern = [TestName] -> TestName -> [TestName] -> Expr
    findPattern ((TestName -> Bool) -> [TestName] -> [TestName]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (TestName
    name TestName -> TestName -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isInfixOf`) [TestName]
    tests) TestName
    name [TestName]
    names

        pattern :: Expr
    pattern = (Expr -> Expr)
    -> (Expr -> Expr -> Expr) -> Maybe Expr -> Expr -> Expr
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Expr -> Expr
    forall a. a -> a
    id Expr -> Expr -> Expr
    And Maybe Expr
    currentPattern Expr
    individualPattern

    consoleTestReporterOptions :: [OptionDescription]
    consoleTestReporterOptions :: [OptionDescription]
    consoleTestReporterOptions =
      [ Proxy Quiet -> OptionDescription
    forall v. IsOption v => Proxy v -> OptionDescription
    Option (Proxy Quiet
    forall {k} (t :: k). Proxy t
    Proxy :: Proxy Quiet)
      , Proxy HideSuccesses -> OptionDescription
    forall v. IsOption v => Proxy v -> OptionDescription
    Option (Proxy HideSuccesses
    forall {k} (t :: k). Proxy t
    Proxy :: Proxy HideSuccesses)
      , Proxy MinDurationToReport -> OptionDescription
    forall v. IsOption v => Proxy v -> OptionDescription
    Option (Proxy MinDurationToReport
    forall {k} (t :: k). Proxy t
    Proxy :: Proxy MinDurationToReport)
      , Proxy UseColor -> OptionDescription
    forall v. IsOption v => Proxy v -> OptionDescription
    Option (Proxy UseColor
    forall {k} (t :: k). Proxy t
    Proxy :: Proxy UseColor)
      , Proxy AnsiTricks -> OptionDescription
    forall v. IsOption v => Proxy v -> OptionDescription
    Option (Proxy AnsiTricks
    forall {k} (t :: k). Proxy t
    Proxy :: Proxy AnsiTricks)
      ]

    -- | A simple console UI with a hook to postprocess results,
    -- depending on their names and external conditions
    -- (e. g., its previous outcome, stored in a file).
    -- Names are listed in reverse order:
    -- from test's own name to a name of the outermost test group.
    --
    -- @since 1.4.2
    consoleTestReporterWithHook :: ([TestName] -> Result -> IO Result) -> Ingredient
    consoleTestReporterWithHook :: ([TestName] -> Result -> IO Result) -> Ingredient
    consoleTestReporterWithHook [TestName] -> Result -> IO Result
    hook = [OptionDescription]
    -> (OptionSet
        -> TestTree -> Maybe (StatusMap -> IO (Time -> IO Bool)))
    -> Ingredient
    TestReporter [OptionDescription]
    consoleTestReporterOptions ((OptionSet
      -> TestTree -> Maybe (StatusMap -> IO (Time -> IO Bool)))
     -> Ingredient)
    -> (OptionSet
        -> TestTree -> Maybe (StatusMap -> IO (Time -> IO Bool)))
    -> Ingredient
    forall a b. (a -> b) -> a -> b
    $
      \OptionSet
    opts TestTree
    tree -> (StatusMap -> IO (Time -> IO Bool))
    -> Maybe (StatusMap -> IO (Time -> IO Bool))
    forall a. a -> Maybe a
    Just ((StatusMap -> IO (Time -> IO Bool))
     -> Maybe (StatusMap -> IO (Time -> IO Bool)))
    -> (StatusMap -> IO (Time -> IO Bool))
    -> Maybe (StatusMap -> IO (Time -> IO Bool))
    forall a b. (a -> b) -> a -> b
    $ \StatusMap
    smap -> do

      let
        whenColor :: UseColor
    whenColor = OptionSet -> UseColor
    forall v. IsOption v => OptionSet -> v
    lookupOption OptionSet
    opts
        Quiet Bool
    quiet = OptionSet -> Quiet
    forall v. IsOption v => OptionSet -> v
    lookupOption OptionSet
    opts
        HideSuccesses Bool
    hideSuccesses = OptionSet -> HideSuccesses
    forall v. IsOption v => OptionSet -> v
    lookupOption OptionSet
    opts
        NumThreads Int
    numThreads = OptionSet -> NumThreads
    forall v. IsOption v => OptionSet -> v
    lookupOption OptionSet
    opts
        AnsiTricks Bool
    ansiTricks = OptionSet -> AnsiTricks
    forall v. IsOption v => OptionSet -> v
    lookupOption OptionSet
    opts

      if Bool
    quiet
        then do
          b <- Int -> StatusMap -> IO Bool
    statusMapResult Int
    numThreads StatusMap
    smap
          return $ \Time
    _time -> Bool -> IO Bool
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    b
        else

          do
          isTerm <- Handle -> IO Bool
    hSupportsANSI Handle
    stdout
          isTermColor <- hSupportsANSIColor stdout

          (\IO (Time -> IO Bool)
    k -> if Bool
    isTerm
            -- When killing with Ctrl+C 'showCursor' can fail
            -- to restore terminal cursor if not flushed explicitly
            then (do IO ()
    hideCursor; IO (Time -> IO Bool)
    k) IO (Time -> IO Bool) -> IO () -> IO (Time -> IO Bool)
    forall a b. IO a -> IO b -> IO a
    `finally` (do IO ()
    showCursor; Handle -> IO ()
    hFlush Handle
    stdout)
            else IO (Time -> IO Bool)
    k) $ do

              hSetBuffering stdout LineBuffering

              let
                ?colors = useColor whenColor isTermColor

              let
                -- 'buildTestOutput' is a pure function and cannot query 'hSupportsANSI' itself.
                -- We also would rather not pass @isTerm@ as an extra argument,
                -- since it's a breaking change, thus resorting to tweaking @opts@.
                opts' = (AnsiTricks -> AnsiTricks) -> OptionSet -> OptionSet
    forall v. IsOption v => (v -> v) -> OptionSet -> OptionSet
    changeOption (\(AnsiTricks Bool
    x) -> Bool -> AnsiTricks
    AnsiTricks (Bool
    x Bool -> Bool -> Bool
    && Bool
    isTerm)) OptionSet
    opts
                toutput = ([TestName] -> Result -> IO Result) -> TestOutput -> TestOutput
    applyHook [TestName] -> Result -> IO Result
    hook (TestOutput -> TestOutput) -> TestOutput -> TestOutput
    forall a b. (a -> b) -> a -> b
    $ (?colors::Bool) => OptionSet -> TestTree -> TestOutput
    OptionSet -> TestTree -> TestOutput
    buildTestOutput OptionSet
    opts' TestTree
    tree

              case () of { ()
    _
                | Bool
    hideSuccesses Bool -> Bool -> Bool
    && Bool
    isTerm Bool -> Bool -> Bool
    && Bool
    ansiTricks ->
                    (?colors::Bool) => TestOutput -> StatusMap -> IO ()
    TestOutput -> StatusMap -> IO ()
    consoleOutputHidingSuccesses TestOutput
    toutput StatusMap
    smap
                | Bool
    hideSuccesses ->
                    (?colors::Bool) => TestOutput -> StatusMap -> IO ()
    TestOutput -> StatusMap -> IO ()
    streamOutputHidingSuccesses TestOutput
    toutput StatusMap
    smap
                | Bool
    otherwise -> (?colors::Bool) => TestOutput -> StatusMap -> IO ()
    TestOutput -> StatusMap -> IO ()
    consoleOutput TestOutput
    toutput StatusMap
    smap
              }

              return $ \Time
    time -> do
                stats <- StatusMap -> IO Statistics
    computeStatistics StatusMap
    smap
                printStatistics stats time
                return $ statFailures stats == 0

    -- | Do not print test results (see README for details).
    --
    -- @since 0.8
    newtype Quiet = Quiet Bool
      deriving (Quiet -> Quiet -> Bool
    (Quiet -> Quiet -> Bool) -> (Quiet -> Quiet -> Bool) -> Eq Quiet
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: Quiet -> Quiet -> Bool
    == :: Quiet -> Quiet -> Bool
    $c/= :: Quiet -> Quiet -> Bool
    /= :: Quiet -> Quiet -> Bool
    Eq, Eq Quiet
    Eq Quiet =>
    (Quiet -> Quiet -> Ordering)
    -> (Quiet -> Quiet -> Bool)
    -> (Quiet -> Quiet -> Bool)
    -> (Quiet -> Quiet -> Bool)
    -> (Quiet -> Quiet -> Bool)
    -> (Quiet -> Quiet -> Quiet)
    -> (Quiet -> Quiet -> Quiet)
    -> Ord Quiet
    Quiet -> Quiet -> Bool
    Quiet -> Quiet -> Ordering
    Quiet -> Quiet -> Quiet
    forall a.
    Eq a =>
    (a -> a -> Ordering)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> a)
    -> (a -> a -> a)
    -> Ord a
    $ccompare :: Quiet -> Quiet -> Ordering
    compare :: Quiet -> Quiet -> Ordering
    $c< :: Quiet -> Quiet -> Bool
    < :: Quiet -> Quiet -> Bool
    $c<= :: Quiet -> Quiet -> Bool
    <= :: Quiet -> Quiet -> Bool
    $c> :: Quiet -> Quiet -> Bool
    > :: Quiet -> Quiet -> Bool
    $c>= :: Quiet -> Quiet -> Bool
    >= :: Quiet -> Quiet -> Bool
    $cmax :: Quiet -> Quiet -> Quiet
    max :: Quiet -> Quiet -> Quiet
    $cmin :: Quiet -> Quiet -> Quiet
    min :: Quiet -> Quiet -> Quiet
    Ord, Typeable)
    instance IsOption Quiet where
      defaultValue :: Quiet
    defaultValue = Bool -> Quiet
    Quiet Bool
    False
      parseValue :: TestName -> Maybe Quiet
    parseValue = (Bool -> Quiet) -> Maybe Bool -> Maybe Quiet
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Bool -> Quiet
    Quiet (Maybe Bool -> Maybe Quiet)
    -> (TestName -> Maybe Bool) -> TestName -> Maybe Quiet
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . TestName -> Maybe Bool
    safeReadBool
      optionName :: Tagged Quiet TestName
    optionName = TestName -> Tagged Quiet TestName
    forall a. a -> Tagged Quiet a
    forall (m :: * -> *) a. Monad m => a -> m a
    return TestName
    "quiet"
      optionHelp :: Tagged Quiet TestName
    optionHelp = TestName -> Tagged Quiet TestName
    forall a. a -> Tagged Quiet a
    forall (m :: * -> *) a. Monad m => a -> m a
    return TestName
    "Do not produce any output; indicate success only by the exit code"
      optionCLParser :: Parser Quiet
    optionCLParser = Mod FlagFields Quiet -> Quiet -> Parser Quiet
    forall v. IsOption v => Mod FlagFields v -> v -> Parser v
    mkFlagCLParser (Char -> Mod FlagFields Quiet
    forall (f :: * -> *) a. HasName f => Char -> Mod f a
    short Char
    'q') (Bool -> Quiet
    Quiet Bool
    True)

    -- | Report only failed tests.
    --
    -- At the moment, this option only works globally. As an argument
    -- to 'Test.Tasty.localOption', it does nothing.
    --
    -- @since 0.8
    newtype HideSuccesses = HideSuccesses Bool
      deriving (HideSuccesses -> HideSuccesses -> Bool
    (HideSuccesses -> HideSuccesses -> Bool)
    -> (HideSuccesses -> HideSuccesses -> Bool) -> Eq HideSuccesses
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: HideSuccesses -> HideSuccesses -> Bool
    == :: HideSuccesses -> HideSuccesses -> Bool
    $c/= :: HideSuccesses -> HideSuccesses -> Bool
    /= :: HideSuccesses -> HideSuccesses -> Bool
    Eq, Eq HideSuccesses
    Eq HideSuccesses =>
    (HideSuccesses -> HideSuccesses -> Ordering)
    -> (HideSuccesses -> HideSuccesses -> Bool)
    -> (HideSuccesses -> HideSuccesses -> Bool)
    -> (HideSuccesses -> HideSuccesses -> Bool)
    -> (HideSuccesses -> HideSuccesses -> Bool)
    -> (HideSuccesses -> HideSuccesses -> HideSuccesses)
    -> (HideSuccesses -> HideSuccesses -> HideSuccesses)
    -> Ord HideSuccesses
    HideSuccesses -> HideSuccesses -> Bool
    HideSuccesses -> HideSuccesses -> Ordering
    HideSuccesses -> HideSuccesses -> HideSuccesses
    forall a.
    Eq a =>
    (a -> a -> Ordering)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> a)
    -> (a -> a -> a)
    -> Ord a
    $ccompare :: HideSuccesses -> HideSuccesses -> Ordering
    compare :: HideSuccesses -> HideSuccesses -> Ordering
    $c< :: HideSuccesses -> HideSuccesses -> Bool
    < :: HideSuccesses -> HideSuccesses -> Bool
    $c<= :: HideSuccesses -> HideSuccesses -> Bool
    <= :: HideSuccesses -> HideSuccesses -> Bool
    $c> :: HideSuccesses -> HideSuccesses -> Bool
    > :: HideSuccesses -> HideSuccesses -> Bool
    $c>= :: HideSuccesses -> HideSuccesses -> Bool
    >= :: HideSuccesses -> HideSuccesses -> Bool
    $cmax :: HideSuccesses -> HideSuccesses -> HideSuccesses
    max :: HideSuccesses -> HideSuccesses -> HideSuccesses
    $cmin :: HideSuccesses -> HideSuccesses -> HideSuccesses
    min :: HideSuccesses -> HideSuccesses -> HideSuccesses
    Ord, Typeable)
    instance IsOption HideSuccesses where
      defaultValue :: HideSuccesses
    defaultValue = Bool -> HideSuccesses
    HideSuccesses Bool
    False
      parseValue :: TestName -> Maybe HideSuccesses
    parseValue = (Bool -> HideSuccesses) -> Maybe Bool -> Maybe HideSuccesses
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Bool -> HideSuccesses
    HideSuccesses (Maybe Bool -> Maybe HideSuccesses)
    -> (TestName -> Maybe Bool) -> TestName -> Maybe HideSuccesses
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . TestName -> Maybe Bool
    safeReadBool
      optionName :: Tagged HideSuccesses TestName
    optionName = TestName -> Tagged HideSuccesses TestName
    forall a. a -> Tagged HideSuccesses a
    forall (m :: * -> *) a. Monad m => a -> m a
    return TestName
    "hide-successes"
      optionHelp :: Tagged HideSuccesses TestName
    optionHelp = TestName -> Tagged HideSuccesses TestName
    forall a. a -> Tagged HideSuccesses a
    forall (m :: * -> *) a. Monad m => a -> m a
    return TestName
    "Do not print tests that passed successfully"
      optionCLParser :: Parser HideSuccesses
    optionCLParser = Mod FlagFields HideSuccesses
    -> HideSuccesses -> Parser HideSuccesses
    forall v. IsOption v => Mod FlagFields v -> v -> Parser v
    mkFlagCLParser Mod FlagFields HideSuccesses
    forall a. Monoid a => a
    mempty (Bool -> HideSuccesses
    HideSuccesses Bool
    True)

    -- | The minimum amount of time a test can take before tasty
    -- prints timing information.
    --
    -- @since 1.5
    newtype MinDurationToReport = MinDurationToReport { MinDurationToReport -> Integer
    minDurationMicros :: Integer }
      deriving (MinDurationToReport -> MinDurationToReport -> Bool
    (MinDurationToReport -> MinDurationToReport -> Bool)
    -> (MinDurationToReport -> MinDurationToReport -> Bool)
    -> Eq MinDurationToReport
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: MinDurationToReport -> MinDurationToReport -> Bool
    == :: MinDurationToReport -> MinDurationToReport -> Bool
    $c/= :: MinDurationToReport -> MinDurationToReport -> Bool
    /= :: MinDurationToReport -> MinDurationToReport -> Bool
    Eq, Eq MinDurationToReport
    Eq MinDurationToReport =>
    (MinDurationToReport -> MinDurationToReport -> Ordering)
    -> (MinDurationToReport -> MinDurationToReport -> Bool)
    -> (MinDurationToReport -> MinDurationToReport -> Bool)
    -> (MinDurationToReport -> MinDurationToReport -> Bool)
    -> (MinDurationToReport -> MinDurationToReport -> Bool)
    -> (MinDurationToReport
        -> MinDurationToReport -> MinDurationToReport)
    -> (MinDurationToReport
        -> MinDurationToReport -> MinDurationToReport)
    -> Ord MinDurationToReport
    MinDurationToReport -> MinDurationToReport -> Bool
    MinDurationToReport -> MinDurationToReport -> Ordering
    MinDurationToReport -> MinDurationToReport -> MinDurationToReport
    forall a.
    Eq a =>
    (a -> a -> Ordering)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> a)
    -> (a -> a -> a)
    -> Ord a
    $ccompare :: MinDurationToReport -> MinDurationToReport -> Ordering
    compare :: MinDurationToReport -> MinDurationToReport -> Ordering
    $c< :: MinDurationToReport -> MinDurationToReport -> Bool
    < :: MinDurationToReport -> MinDurationToReport -> Bool
    $c<= :: MinDurationToReport -> MinDurationToReport -> Bool
    <= :: MinDurationToReport -> MinDurationToReport -> Bool
    $c> :: MinDurationToReport -> MinDurationToReport -> Bool
    > :: MinDurationToReport -> MinDurationToReport -> Bool
    $c>= :: MinDurationToReport -> MinDurationToReport -> Bool
    >= :: MinDurationToReport -> MinDurationToReport -> Bool
    $cmax :: MinDurationToReport -> MinDurationToReport -> MinDurationToReport
    max :: MinDurationToReport -> MinDurationToReport -> MinDurationToReport
    $cmin :: MinDurationToReport -> MinDurationToReport -> MinDurationToReport
    min :: MinDurationToReport -> MinDurationToReport -> MinDurationToReport
    Ord, Typeable)
    instance IsOption MinDurationToReport where
      defaultValue :: MinDurationToReport
    defaultValue = Integer -> MinDurationToReport
    MinDurationToReport Integer
    10000
      parseValue :: TestName -> Maybe MinDurationToReport
    parseValue = (Integer -> MinDurationToReport)
    -> Maybe Integer -> Maybe MinDurationToReport
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Integer -> MinDurationToReport
    MinDurationToReport (Maybe Integer -> Maybe MinDurationToReport)
    -> (TestName -> Maybe Integer)
    -> TestName
    -> Maybe MinDurationToReport
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . TestName -> Maybe Integer
    parseDuration
      optionName :: Tagged MinDurationToReport TestName
    optionName = TestName -> Tagged MinDurationToReport TestName
    forall a. a -> Tagged MinDurationToReport a
    forall (m :: * -> *) a. Monad m => a -> m a
    return TestName
    "min-duration-to-report"
      optionHelp :: Tagged MinDurationToReport TestName
    optionHelp =
        TestName -> Tagged MinDurationToReport TestName
    forall a. a -> Tagged MinDurationToReport a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TestName -> Tagged MinDurationToReport TestName)
    -> ([TestName] -> TestName)
    -> [TestName]
    -> Tagged MinDurationToReport TestName
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [TestName] -> TestName
    unwords ([TestName] -> Tagged MinDurationToReport TestName)
    -> [TestName] -> Tagged MinDurationToReport TestName
    forall a b. (a -> b) -> a -> b
    $
          [ TestName
    "The minimum amount of time a test can take before tasty prints timing information"
          , TestName
    "(suffixes: ms,s,m,h; default: s)"
          ]
      optionCLParser :: Parser MinDurationToReport
    optionCLParser = Mod OptionFields MinDurationToReport -> Parser MinDurationToReport
    forall v. IsOption v => Mod OptionFields v -> Parser v
    mkOptionCLParser (TestName -> Mod OptionFields MinDurationToReport
    forall (f :: * -> *) a. HasMetavar f => TestName -> Mod f a
    metavar TestName
    "DURATION")

    -- | When to use color on the output
    --
    -- @since 0.11.3
    data UseColor
      = Never
      | Always
      | Auto -- ^ Only if stdout is an ANSI color supporting terminal
      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, Eq UseColor
    Eq UseColor =>
    (UseColor -> UseColor -> Ordering)
    -> (UseColor -> UseColor -> Bool)
    -> (UseColor -> UseColor -> Bool)
    -> (UseColor -> UseColor -> Bool)
    -> (UseColor -> UseColor -> Bool)
    -> (UseColor -> UseColor -> UseColor)
    -> (UseColor -> UseColor -> UseColor)
    -> Ord UseColor
    UseColor -> UseColor -> Bool
    UseColor -> UseColor -> Ordering
    UseColor -> UseColor -> UseColor
    forall a.
    Eq a =>
    (a -> a -> Ordering)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> a)
    -> (a -> a -> a)
    -> Ord a
    $ccompare :: UseColor -> UseColor -> Ordering
    compare :: UseColor -> UseColor -> Ordering
    $c< :: UseColor -> UseColor -> Bool
    < :: UseColor -> UseColor -> Bool
    $c<= :: UseColor -> UseColor -> Bool
    <= :: UseColor -> UseColor -> Bool
    $c> :: UseColor -> UseColor -> Bool
    > :: UseColor -> UseColor -> Bool
    $c>= :: UseColor -> UseColor -> Bool
    >= :: UseColor -> UseColor -> Bool
    $cmax :: UseColor -> UseColor -> UseColor
    max :: UseColor -> UseColor -> UseColor
    $cmin :: UseColor -> UseColor -> UseColor
    min :: UseColor -> UseColor -> UseColor
    Ord, Typeable)

    -- | Control color output
    instance IsOption UseColor where
      defaultValue :: UseColor
    defaultValue = UseColor
    Auto
      parseValue :: TestName -> Maybe UseColor
    parseValue = TestName -> Maybe UseColor
    parseUseColor
      optionName :: Tagged UseColor TestName
    optionName = TestName -> Tagged UseColor TestName
    forall a. a -> Tagged UseColor a
    forall (m :: * -> *) a. Monad m => a -> m a
    return TestName
    "color"
      optionHelp :: Tagged UseColor TestName
    optionHelp = TestName -> Tagged UseColor TestName
    forall a. a -> Tagged UseColor a
    forall (m :: * -> *) a. Monad m => a -> m a
    return TestName
    "When to use colored output"
      optionCLParser :: Parser UseColor
    optionCLParser = Mod OptionFields UseColor -> Parser UseColor
    forall v. IsOption v => Mod OptionFields v -> Parser v
    mkOptionCLParser (Mod OptionFields UseColor -> Parser UseColor)
    -> Mod OptionFields UseColor -> Parser UseColor
    forall a b. (a -> b) -> a -> b
    $ TestName -> Mod OptionFields UseColor
    forall (f :: * -> *) a. HasMetavar f => TestName -> Mod f a
    metavar TestName
    "never|always|auto"
      showDefaultValue :: UseColor -> Maybe TestName
    showDefaultValue = TestName -> Maybe TestName
    forall a. a -> Maybe a
    Just (TestName -> Maybe TestName)
    -> (UseColor -> TestName) -> UseColor -> Maybe TestName
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . UseColor -> TestName
    displayUseColor

    -- | By default, when the option @--hide-successes@ is given and the output
    -- goes to an ANSI-capable terminal, we employ some ANSI terminal tricks to
    -- display the name of the currently running test and then erase it if it
    -- succeeds.
    --
    -- These tricks sometimes fail, however—in particular, when the test names
    -- happen to be longer than the width of the terminal window. See
    --
    -- * <https://github.com/UnkindPartition/tasty/issues/152>
    --
    -- * <https://github.com/UnkindPartition/tasty/issues/250>
    --
    -- When that happens, this option can be used to disable the tricks. In
    -- that case, the test name will be printed only once the test fails.
    --
    -- @since 1.3
    newtype AnsiTricks = AnsiTricks { AnsiTricks -> Bool
    getAnsiTricks :: Bool }
      deriving Typeable

    instance IsOption AnsiTricks where
      defaultValue :: AnsiTricks
    defaultValue = Bool -> AnsiTricks
    AnsiTricks Bool
    True
      parseValue :: TestName -> Maybe AnsiTricks
    parseValue = (Bool -> AnsiTricks) -> Maybe Bool -> Maybe AnsiTricks
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Bool -> AnsiTricks
    AnsiTricks (Maybe Bool -> Maybe AnsiTricks)
    -> (TestName -> Maybe Bool) -> TestName -> Maybe AnsiTricks
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . TestName -> Maybe Bool
    safeReadBool
      optionName :: Tagged AnsiTricks TestName
    optionName = TestName -> Tagged AnsiTricks TestName
    forall a. a -> Tagged AnsiTricks a
    forall (m :: * -> *) a. Monad m => a -> m a
    return TestName
    "ansi-tricks"
      optionHelp :: Tagged AnsiTricks TestName
    optionHelp = TestName -> Tagged AnsiTricks TestName
    forall a. a -> Tagged AnsiTricks a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TestName -> Tagged AnsiTricks TestName)
    -> TestName -> Tagged AnsiTricks TestName
    forall a b. (a -> b) -> a -> b
    $
        -- Multiline literals don't work because of -XCPP.
        TestName
    "Enable various ANSI terminal tricks. " TestName -> TestName -> TestName
    forall a. [a] -> [a] -> [a]
    ++
        TestName
    "Can be set to 'true' or 'false'."
      showDefaultValue :: AnsiTricks -> Maybe TestName
    showDefaultValue = TestName -> Maybe TestName
    forall a. a -> Maybe a
    Just (TestName -> Maybe TestName)
    -> (AnsiTricks -> TestName) -> AnsiTricks -> Maybe TestName
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Bool -> TestName
    displayBool (Bool -> TestName)
    -> (AnsiTricks -> Bool) -> AnsiTricks -> TestName
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . AnsiTricks -> Bool
    getAnsiTricks

    displayBool :: Bool -> String
    displayBool :: Bool -> TestName
    displayBool Bool
    b =
      case Bool
    b of
        Bool
    False -> TestName
    "false"
        Bool
    True  -> TestName
    "true"

    -- | @useColor when isTerm@ decides if colors should be used,
    --   where @isTerm@ indicates whether @stdout@ is a terminal device.
    --
    --   @since 0.11.3
    useColor :: UseColor -> Bool -> Bool
    useColor :: UseColor -> Bool -> Bool
    useColor UseColor
    when_ Bool
    isTerm =
      case UseColor
    when_ of
        UseColor
    Never  -> Bool
    False
        UseColor
    Always -> Bool
    True
        UseColor
    Auto   -> Bool
    isTerm

    parseUseColor :: String -> Maybe UseColor
    parseUseColor :: TestName -> Maybe UseColor
    parseUseColor TestName
    s =
      case (Char -> Char) -> TestName -> TestName
    forall a b. (a -> b) -> [a] -> [b]
    map Char -> Char
    toLower TestName
    s of
        TestName
    "never"  -> UseColor -> Maybe UseColor
    forall a. a -> Maybe a
    forall (m :: * -> *) a. Monad m => a -> m a
    return UseColor
    Never
        TestName
    "always" -> UseColor -> Maybe UseColor
    forall a. a -> Maybe a
    forall (m :: * -> *) a. Monad m => a -> m a
    return UseColor
    Always
        TestName
    "auto"   -> UseColor -> Maybe UseColor
    forall a. a -> Maybe a
    forall (m :: * -> *) a. Monad m => a -> m a
    return UseColor
    Auto
        TestName
    _        -> Maybe UseColor
    forall a. Maybe a
    Nothing

    displayUseColor :: UseColor -> String
    displayUseColor :: UseColor -> TestName
    displayUseColor UseColor
    uc =
      case UseColor
    uc of
        UseColor
    Never  -> TestName
    "never"
        UseColor
    Always -> TestName
    "always"
        UseColor
    Auto   -> TestName
    "auto"

    -- }}}

    --------------------------------------------------
    -- Various utilities
    --------------------------------------------------
    -- {{{
    getResultFromTVar :: TVar Status -> IO Result
    getResultFromTVar :: TVar Status -> IO Result
    getResultFromTVar TVar Status
    var =
      STM Result -> IO Result
    forall a. STM a -> IO a
    atomically (STM Result -> IO Result) -> STM Result -> IO Result
    forall a b. (a -> b) -> a -> b
    $ do
        status <- TVar Status -> STM Status
    forall a. TVar a -> STM a
    readTVar TVar Status
    var
        case status of
          Done Result
    r -> Result -> STM Result
    forall a. a -> STM a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Result
    r
          Status
    _ -> STM Result
    forall a. STM a
    retry

    -- }}}

    --------------------------------------------------
    -- Formatting
    --------------------------------------------------
    -- {{{

    indentSize :: Int
    indentSize :: Int
    indentSize = Int
    2

    indent :: Int -> String
    indent :: Int -> TestName
    indent Int
    n = Int -> Char -> TestName
    forall a. Int -> a -> [a]
    replicate (Int
    indentSize Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * Int
    n) Char
    ' '

    -- handle multi-line result descriptions properly
    formatDesc
      :: Int -- indent
      -> String
      -> String
    formatDesc :: Int -> TestName -> TestName
    formatDesc Int
    n TestName
    desc =
      let
        -- remove all trailing linebreaks
        chomped :: TestName
    chomped = TestName -> TestName
    forall a. [a] -> [a]
    reverse (TestName -> TestName)
    -> (TestName -> TestName) -> TestName -> TestName
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char -> Bool) -> TestName -> TestName
    forall a. (a -> Bool) -> [a] -> [a]
    dropWhile (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '\n') (TestName -> TestName)
    -> (TestName -> TestName) -> TestName -> TestName
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . TestName -> TestName
    forall a. [a] -> [a]
    reverse (TestName -> TestName) -> TestName -> TestName
    forall a b. (a -> b) -> a -> b
    $ TestName
    desc

        multiline :: Bool
    multiline = Char
    '\n' Char -> TestName -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` TestName
    chomped

        -- we add a leading linebreak to the description, to start it on a new
        -- line and add an indentation
        paddedDesc :: TestName
    paddedDesc = ((Char -> TestName) -> TestName -> TestName)
    -> TestName -> (Char -> TestName) -> TestName
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip (Char -> TestName) -> TestName -> TestName
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap TestName
    chomped ((Char -> TestName) -> TestName) -> (Char -> TestName) -> TestName
    forall a b. (a -> b) -> a -> b
    $ \Char
    c ->
          if Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '\n'
            then Char
    c Char -> TestName -> TestName
    forall a. a -> [a] -> [a]
    : Int -> TestName
    indent Int
    n
            else [Char
    c]
      in
        if Bool
    multiline
          then TestName
    paddedDesc
          else TestName
    chomped

    -- | Compute the amount of space needed to align \"OK\"s and \"FAIL\"s
    computeAlignment :: OptionSet -> TestTree -> Int
    computeAlignment :: OptionSet -> TestTree -> Int
    computeAlignment OptionSet
    opts =
      Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    max Int
    0 (Int -> Int) -> (TestTree -> Int) -> TestTree -> Int
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .
      Int -> TreeFold Int -> OptionSet -> TestTree -> Int
    forall b. b -> TreeFold b -> OptionSet -> TestTree -> b
    foldTestTree0
        Int
    forall a. Bounded a => a
    minBound
        TreeFold
          { foldSingle :: forall t. IsTest t => OptionSet -> TestName -> t -> Int
    foldSingle = \OptionSet
    _ TestName
    name t
    _ -> TestName -> Int
    stringWidth TestName
    name
          , foldGroup :: OptionSet -> TestName -> [Int] -> Int
    foldGroup = \OptionSet
    _ TestName
    _ [Int]
    m -> if [Int] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Int]
    m then Int
    forall a. Bounded a => a
    minBound else [Int] -> Int
    forall a. Ord a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
    maximum [Int]
    m Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    indentSize
          , foldResource :: forall a. OptionSet -> ResourceSpec a -> (IO a -> Int) -> Int
    foldResource = \OptionSet
    _ ResourceSpec a
    _ IO a -> Int
    f -> IO a -> Int
    f (IO a -> Int) -> IO a -> Int
    forall a b. (a -> b) -> a -> b
    $ ResourceError -> IO a
    forall e a. (HasCallStack, Exception e) => e -> IO a
    throwIO ResourceError
    NotRunningTests
          , foldAfter :: OptionSet -> DependencyType -> Expr -> Int -> Int
    foldAfter = \OptionSet
    _ DependencyType
    _ Expr
    _ Int
    b -> Int
    b
          }
        OptionSet
    opts

    -- | Compute the length/width of the string as it would appear in a monospace
    --   terminal. This takes into account that even in a “mono”space font, not
    --   all characters actually have the same width, in particular, most CJK
    --   characters have twice the same as Western characters.
    --
    --   (This only works properly on Unix at the moment; on Windows, the function
    --   treats every character as width-1 like 'Data.List.length' does.)
    stringWidth :: String -> Int
    #ifdef USE_WCWIDTH
    stringWidth :: TestName -> Int
    stringWidth = [Int] -> Int
    forall a. Num a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
    Prelude.sum ([Int] -> Int) -> (TestName -> [Int]) -> TestName -> Int
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char -> Int) -> TestName -> [Int]
    forall a b. (a -> b) -> [a] -> [b]
    map Char -> Int
    forall {a}. Num a => Char -> a
    charWidth
     where charWidth :: Char -> a
    charWidth Char
    c = case CWchar -> CInt
    wcwidth (Int -> CWchar
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (Char -> Int
    ord Char
    c)) of
            -1 -> a
    1  -- many chars have "undefined" width; default to 1 for these.
            CInt
    w  -> CInt -> a
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral CInt
    w
    foreign import capi safe "wchar.h wcwidth" wcwidth :: CWchar -> CInt
    #else
    stringWidth = length
    #endif

    -- (Potentially) colorful output
    ok, fail, skipped, infoOk, infoFail :: (?colors :: Bool) => String -> IO ()
    fail :: (?colors::Bool) => TestName -> IO ()
    fail     = (?colors::Bool) => ConsoleFormat -> TestName -> IO ()
    ConsoleFormat -> TestName -> IO ()
    output ConsoleFormat
    failFormat
    ok :: (?colors::Bool) => TestName -> IO ()
    ok       = (?colors::Bool) => ConsoleFormat -> TestName -> IO ()
    ConsoleFormat -> TestName -> IO ()
    output ConsoleFormat
    okFormat
    skipped :: (?colors::Bool) => TestName -> IO ()
    skipped  = (?colors::Bool) => ConsoleFormat -> TestName -> IO ()
    ConsoleFormat -> TestName -> IO ()
    output ConsoleFormat
    skippedFormat
    -- Just default foreground color for 'infoOk'; do not apply 'infoOkFormat',
    -- because terminal's background could be white itself. See #298.
    infoOk :: (?colors::Bool) => TestName -> IO ()
    infoOk   = TestName -> IO ()
    putStr
    infoFail :: (?colors::Bool) => TestName -> IO ()
    infoFail = (?colors::Bool) => ConsoleFormat -> TestName -> IO ()
    ConsoleFormat -> TestName -> IO ()
    output ConsoleFormat
    infoFailFormat

    output
      :: (?colors :: Bool)
      => ConsoleFormat
      -> String
      -> IO ()
    output :: (?colors::Bool) => ConsoleFormat -> TestName -> IO ()
    output ConsoleFormat
    format = (?colors::Bool) => ConsoleFormatPrinter
    ConsoleFormatPrinter
    withConsoleFormat ConsoleFormat
    format (IO () -> IO ()) -> (TestName -> IO ()) -> TestName -> IO ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . TestName -> IO ()
    putStr

    -- | Run action with console configured for a specific output format
    --
    -- This function does not apply any output formats if colors are disabled at command
    -- line or console detection.
    --
    -- Can be used by providers that wish to provider specific result details printing,
    -- while re-using the tasty formats and coloring logic.
    --
    -- @since 1.3.1
    withConsoleFormat :: (?colors :: Bool) => ConsoleFormatPrinter
    withConsoleFormat :: (?colors::Bool) => ConsoleFormatPrinter
    withConsoleFormat ConsoleFormat
    format IO ()
    action
      | ?colors::Bool
    Bool
    ?colors =
        (do
          [SGR] -> IO ()
    setSGR
            [ ConsoleLayer -> ColorIntensity -> Color -> SGR
    SetColor ConsoleLayer
    Foreground (ConsoleFormat -> ColorIntensity
    colorIntensity ConsoleFormat
    format) (ConsoleFormat -> Color
    color ConsoleFormat
    format)
            , ConsoleIntensity -> SGR
    SetConsoleIntensity (ConsoleFormat -> ConsoleIntensity
    consoleIntensity ConsoleFormat
    format)
            ]
          IO ()
    action
        ) IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO a
    `finally` [SGR] -> IO ()
    setSGR []
      | Bool
    otherwise = IO ()
    action

    -- }}}