-- 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
    AnsiTricks{Bool
getAnsiTricks :: Bool
getAnsiTricks :: AnsiTricks -> Bool
getAnsiTricks} = OptionSet -> AnsiTricks
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
      Int
level <- ReaderT Int Identity Int
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask

      let
        indentedNameWidth :: Int
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
postNamePadding = Int
alignment Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
indentedNameWidth

        testNamePadded :: TestName
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 :: IO ()
printTestName = do
          TestName -> IO ()
putStr TestName
testNamePadded
          Handle -> IO ()
hFlush Handle
stdout

        printTestProgress :: Progress -> IO ()
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
              TestName -> IO ()
putStr TestName
testNamePadded
              (?colors::Bool) => TestName -> IO ()
TestName -> IO ()
infoOk TestName
msg
              Handle -> IO ()
hFlush Handle
stdout

        printTestResult :: Result -> IO ()
printTestResult Result
result = do
          TestName
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 :: TestName -> IO ()
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 :: Time
time = Result -> Time
resultTime Result
result

          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
getAnsiTricks (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Char -> IO ()
putChar Char
'\r'
            IO ()
clearLine
            TestName -> IO ()
putStr TestName
testNamePadded

          TestName -> IO ()
printFn (Result -> TestName
resultShortDescription Result
result)
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Time -> Integer
forall b. Integral b => Time -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Time
time Time -> Time -> Time
forall a. Num a => a -> a -> a
* Time
1e6) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
minDurationMicros) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            TestName -> IO ()
printFn (TestName -> Time -> TestName
forall r. PrintfType r => TestName -> r
printf TestName
" (%.2fs)" Time
time)
          TestName -> IO ()
printFn TestName
"\n"

          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ TestName -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null TestName
rDesc) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            (if Result -> Bool
resultSuccessful Result
result then (?colors::Bool) => TestName -> IO ()
TestName -> IO ()
infoOk else (?colors::Bool) => TestName -> IO ()
TestName -> IO ()
infoFail) (TestName -> IO ()) -> TestName -> IO ()
forall a b. (a -> b) -> a -> b
$
              TestName -> TestName -> TestName -> TestName
forall r. PrintfType r => TestName -> r
printf TestName
"%s%s\n" (Int -> TestName
indent (Int -> TestName) -> Int -> TestName
forall a b. (a -> b) -> a -> b
$ Int
level Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> TestName -> TestName
formatDesc (Int
levelInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) TestName
rDesc)
          case Result -> ResultDetailsPrinter
resultDetailsPrinter Result
result of
            ResultDetailsPrinter Int -> ConsoleFormatPrinter -> IO ()
action -> Int -> ConsoleFormatPrinter -> IO ()
action Int
level (?colors::Bool) => ConsoleFormatPrinter
ConsoleFormatPrinter
withConsoleFormat

      TestOutput -> Reader Int TestOutput
forall a. a -> ReaderT Int Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (TestOutput -> Reader Int TestOutput)
-> TestOutput -> Reader Int TestOutput
forall a b. (a -> b) -> a -> b
$ TestName
-> IO () -> (Progress -> IO ()) -> (Result -> IO ()) -> TestOutput
PrintTest TestName
name IO ()
printTestName (?colors::Bool) => Progress -> IO ()
Progress -> IO ()
printTestProgress (?colors::Bool) => Result -> IO ()
Result -> IO ()
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
      Int
level <- ReaderT Int Identity Int
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
      let
        printHeading :: IO ()
printHeading = TestName -> TestName -> TestName -> IO ()
forall r. PrintfType r => TestName -> r
printf TestName
"%s%s\n" (Int -> TestName
indent Int
level) TestName
name
        printBody :: TestOutput
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)
      TestOutput -> Reader Int TestOutput
forall a. a -> ReaderT Int Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (TestOutput -> Reader Int TestOutput)
-> TestOutput -> Reader Int TestOutput
forall a b. (a -> b) -> a -> b
$ TestName -> IO () -> TestOutput -> TestOutput
PrintHeading TestName
name IO ()
printHeading TestOutput
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

-- | 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
    Int
ix <- StateT Int m Int
forall (m :: * -> *) s. Monad m => StateT s m s
get
    Int -> StateT Int m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Int -> StateT Int m ()) -> Int -> StateT Int m ()
forall a b. (a -> b) -> a -> b
$! Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    let
      statusVar :: TVar Status
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

    b -> StateT Int m b
forall a. a -> StateT Int m a
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> StateT Int m b) -> b -> StateT Int m b
forall a b. (a -> b) -> a -> b
$ TestName -> IO () -> IO Result -> (Result -> IO ()) -> b
foldTest TestName
name IO ()
printName (TVar Status -> (Progress -> IO ()) -> IO Result
ppProgressOrResult TVar Status
statusVar Progress -> IO ()
printProgress) Result -> IO ()
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
status <- TVar Status -> STM Status
forall a. TVar a -> STM a
readTVar TVar Status
statusVar
    case Status
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 ()
          t
r <- IO t
getResult
          t -> IO ()
printResult t
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 ()
          Result
r <- IO Result
getResult
          if Result -> Bool
resultSuccessful Result
r
            then do IO ()
clearThisLine; Any -> IO Any
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Any -> IO Any) -> Any -> IO Any
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
False
            else do Result -> IO ()
printResult Result
r :: IO (); Any -> IO Any
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Any -> IO Any) -> Any -> IO Any
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
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 Bool
failed <- Ap IO Any -> IO Any
forall (f :: * -> *) a. Ap f a -> f a
getApp Ap IO Any
printBody
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
failed IO ()
clearAboveLine
        Any -> IO Any
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Any -> IO Any) -> Any -> IO Any
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
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
          Result
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 Result -> Bool
resultSuccessful Result
r
            then Any -> StateT [IO a] m Any
forall a. a -> StateT [IO a] m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Any -> StateT [IO a] m Any) -> Any -> StateT [IO a] m Any
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
False
            else do
              [IO a]
stack <- StateT [IO a] m [IO a]
forall (m :: * -> *) s. Monad m => StateT s m s
get
              [IO a] -> StateT [IO a] m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put []

              IO () -> StateT [IO a] m ()
forall a. IO a -> StateT [IO a] m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> StateT [IO a] m ()) -> IO () -> StateT [IO a] m ()
forall a b. (a -> b) -> a -> b
$ do
                [IO a] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([IO a] -> IO ()) -> [IO a] -> IO ()
forall a b. (a -> b) -> a -> b
$ [IO a] -> [IO a]
forall a. [a] -> [a]
reverse [IO a]
stack
                IO ()
printName :: IO ()
                Result -> IO ()
printResult Result
r :: IO ()

              Any -> StateT [IO a] m Any
forall a. a -> StateT [IO a] m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Any -> StateT [IO a] m Any) -> Any -> StateT [IO a] m Any
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
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 Bool
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
        Bool -> StateT [a] m () -> StateT [a] m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
failed (StateT [a] m () -> StateT [a] m ())
-> StateT [a] m () -> StateT [a] m ()
forall a b. (a -> b) -> a -> b
$
          ([a] -> [a]) -> StateT [a] m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify (([a] -> [a]) -> StateT [a] m ())
-> ([a] -> [a]) -> StateT [a] m ()
forall a b. (a -> b) -> a -> b
$ \[a]
stack ->
            case [a]
stack of
              a
_:[a]
rest -> [a]
rest
              [] -> [] -- shouldn't happen anyway
        Any -> StateT [a] m Any
forall a. a -> StateT [a] m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Any -> StateT [a] m Any) -> Any -> StateT [a] m Any
forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
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
          Status
this_status <- TVar Status -> STM Status
forall a. TVar a -> STM a
readTVar TVar Status
tvar
          case Status
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
      Bool
b <- Int -> StatusMap -> IO Bool
statusMapResult Int
numThreads StatusMap
smap
      (Time -> IO Bool) -> IO (Time -> IO Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Time -> IO Bool) -> IO (Time -> IO Bool))
-> (Time -> IO Bool) -> IO (Time -> IO Bool)
forall a b. (a -> b) -> a -> b
$ \Time
_time -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
b
    else

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

      (\IO (Time -> IO Bool)
k -> if Bool
isTerm
        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` IO ()
showCursor
        else IO (Time -> IO Bool)
k) (IO (Time -> IO Bool) -> IO (Time -> IO Bool))
-> IO (Time -> IO Bool) -> IO (Time -> IO Bool)
forall a b. (a -> b) -> a -> b
$ do

          Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
LineBuffering

          let
            ?colors = UseColor -> Bool -> Bool
useColor UseColor
whenColor Bool
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' :: OptionSet
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 :: TestOutput
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
          }

          (Time -> IO Bool) -> IO (Time -> IO Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Time -> IO Bool) -> IO (Time -> IO Bool))
-> (Time -> IO Bool) -> IO (Time -> IO Bool)
forall a b. (a -> b) -> a -> b
$ \Time
time -> do
            Statistics
stats <- StatusMap -> IO Statistics
computeStatistics StatusMap
smap
            (?colors::Bool) => Statistics -> Time -> IO ()
Statistics -> Time -> IO ()
printStatistics Statistics
stats Time
time
            Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Statistics -> Int
statFailures Statistics
stats Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
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
status <- TVar Status -> STM Status
forall a. TVar a -> STM a
readTVar TVar Status
var
    case Status
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. 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

-- }}}