{-# LANGUAGE BangPatterns, ImplicitParams, MultiParamTypeClasses, DeriveDataTypeable, FlexibleContexts #-}
module Test.Tasty.Ingredients.ConsoleReporter
( consoleTestReporter
, consoleTestReporterWithHook
, Quiet(..)
, HideSuccesses(..)
, AnsiTricks(..)
, UseColor(..)
, useColor
, Statistics(..)
, computeStatistics
, printStatistics
, printStatisticsNoTime
, 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 Data.Char
#ifdef VERSION_wcwidth
import Data.Char.WCWidth (wcwidth)
#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
data TestOutput
= PrintTest
String
(IO ())
(Result -> IO ())
| PrintHeading String (IO ()) TestOutput
| Skip
| Seq TestOutput TestOutput
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 hook :: [TestName] -> Result -> IO Result
hook = [TestName] -> TestOutput -> TestOutput
go []
where
go :: [TestName] -> TestOutput -> TestOutput
go path :: [TestName]
path (PrintTest name :: TestName
name printName :: IO ()
printName printResult :: Result -> IO ()
printResult) =
TestName -> IO () -> (Result -> IO ()) -> TestOutput
PrintTest TestName
name IO ()
printName (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 path :: [TestName]
path (PrintHeading name :: TestName
name printName :: IO ()
printName printBody :: 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 path :: [TestName]
path (Seq a :: TestOutput
a b :: TestOutput
b) = TestOutput -> TestOutput -> TestOutput
Seq ([TestName] -> TestOutput -> TestOutput
go [TestName]
path TestOutput
a) ([TestName] -> TestOutput -> TestOutput
go [TestName]
path TestOutput
b)
go _ Skip = TestOutput
forall a. Monoid a => a
mempty
type Level = Int
buildTestOutput :: (?colors :: Bool) => OptionSet -> TestTree -> TestOutput
buildTestOutput :: OptionSet -> TestTree -> TestOutput
buildTestOutput opts :: OptionSet
opts tree :: TestTree
tree =
let
!alignment :: Int
alignment = OptionSet -> TestTree -> Int
computeAlignment OptionSet
opts TestTree
tree
runSingleTest
:: (IsTest t, ?colors :: Bool)
=> OptionSet -> TestName -> t -> Ap (Reader Level) TestOutput
runSingleTest :: OptionSet -> TestName -> t -> Ap (Reader Int) TestOutput
runSingleTest _opts :: OptionSet
_opts name :: TestName
name _test :: t
_test = ReaderT Int Identity TestOutput -> Ap (Reader Int) TestOutput
forall (f :: * -> *) a. f a -> Ap f a
Ap (ReaderT Int Identity TestOutput -> Ap (Reader Int) TestOutput)
-> ReaderT Int Identity TestOutput -> Ap (Reader Int) 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
printTestName :: IO ()
printTestName = do
TestName -> TestName -> TestName -> TestName -> IO ()
forall r. PrintfType r => TestName -> r
printf "%s%s: %s" (Int -> TestName
indent Int
level) TestName
name
(Int -> Char -> TestName
forall a. Int -> a -> [a]
replicate (Int
alignment Int -> Int -> Int
forall a. Num a => a -> a -> a
- 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) ' ')
Handle -> IO ()
hFlush Handle
stdout
printTestResult :: Result -> IO ()
printTestResult result :: 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
let
printFn :: TestName -> IO ()
printFn =
case Result -> Outcome
resultOutcome Result
result of
Success -> (?colors::Bool) => TestName -> IO ()
TestName -> IO ()
ok
Failure TestDepFailed -> (?colors::Bool) => TestName -> IO ()
TestName -> IO ()
skipped
_ -> (?colors::Bool) => TestName -> IO ()
TestName -> IO ()
fail
time :: Time
time = Result -> Time
resultTime Result
result
TestName -> IO ()
printFn (Result -> TestName
resultShortDescription Result
result)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Time
time Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= 0.01) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
TestName -> IO ()
printFn (TestName -> Time -> TestName
forall r. PrintfType r => TestName -> r
printf " (%.2fs)" Time
time)
TestName -> IO ()
printFn "\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 (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 "%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
+ 1) (Int -> TestName -> TestName
formatDesc (Int
levelInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) TestName
rDesc)
case Result -> ResultDetailsPrinter
resultDetailsPrinter Result
result of
ResultDetailsPrinter action :: Int -> ConsoleFormatPrinter -> IO ()
action -> Int -> ConsoleFormatPrinter -> IO ()
action Int
level (?colors::Bool) => ConsoleFormatPrinter
ConsoleFormatPrinter
withConsoleFormat
TestOutput -> ReaderT Int Identity TestOutput
forall (m :: * -> *) a. Monad m => a -> m a
return (TestOutput -> ReaderT Int Identity TestOutput)
-> TestOutput -> ReaderT Int Identity TestOutput
forall a b. (a -> b) -> a -> b
$ TestName -> IO () -> (Result -> IO ()) -> TestOutput
PrintTest TestName
name IO ()
printTestName (?colors::Bool) => Result -> IO ()
Result -> IO ()
printTestResult
runGroup :: OptionSet -> TestName -> Ap (Reader Level) TestOutput -> Ap (Reader Level) TestOutput
runGroup :: OptionSet
-> TestName
-> Ap (Reader Int) TestOutput
-> Ap (Reader Int) TestOutput
runGroup _opts :: OptionSet
_opts name :: TestName
name grp :: Ap (Reader Int) TestOutput
grp = ReaderT Int Identity TestOutput -> Ap (Reader Int) TestOutput
forall (f :: * -> *) a. f a -> Ap f a
Ap (ReaderT Int Identity TestOutput -> Ap (Reader Int) TestOutput)
-> ReaderT Int Identity TestOutput -> Ap (Reader Int) 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 "%s%s\n" (Int -> TestName
indent Int
level) TestName
name
printBody :: TestOutput
printBody = ReaderT Int Identity TestOutput -> Int -> TestOutput
forall r a. Reader r a -> r -> a
runReader (Ap (Reader Int) TestOutput -> ReaderT Int Identity TestOutput
forall (f :: * -> *) a. Ap f a -> f a
getApp Ap (Reader Int) TestOutput
grp) (Int
level Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
TestOutput -> ReaderT Int Identity TestOutput
forall (m :: * -> *) a. Monad m => a -> m a
return (TestOutput -> ReaderT Int Identity TestOutput)
-> TestOutput -> ReaderT Int Identity TestOutput
forall a b. (a -> b) -> a -> b
$ TestName -> IO () -> TestOutput -> TestOutput
PrintHeading TestName
name IO ()
printHeading TestOutput
printBody
in
(ReaderT Int Identity TestOutput -> Int -> TestOutput)
-> Int -> ReaderT Int Identity TestOutput -> TestOutput
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT Int Identity TestOutput -> Int -> TestOutput
forall r a. Reader r a -> r -> a
runReader 0 (ReaderT Int Identity TestOutput -> TestOutput)
-> ReaderT Int Identity TestOutput -> TestOutput
forall a b. (a -> b) -> a -> b
$ Ap (Reader Int) TestOutput -> ReaderT Int Identity TestOutput
forall (f :: * -> *) a. Ap f a -> f a
getApp (Ap (Reader Int) TestOutput -> ReaderT Int Identity TestOutput)
-> Ap (Reader Int) TestOutput -> ReaderT Int Identity TestOutput
forall a b. (a -> b) -> a -> b
$
TreeFold (Ap (Reader Int) TestOutput)
-> OptionSet -> TestTree -> Ap (Reader Int) TestOutput
forall b. Monoid b => TreeFold b -> OptionSet -> TestTree -> b
foldTestTree
TreeFold (Ap (Reader Int) TestOutput)
forall b. Monoid b => TreeFold b
trivialFold
{ foldSingle :: forall t.
IsTest t =>
OptionSet -> TestName -> t -> Ap (Reader Int) TestOutput
foldSingle = forall t.
(IsTest t, ?colors::Bool) =>
OptionSet -> TestName -> t -> Ap (Reader Int) TestOutput
forall t.
IsTest t =>
OptionSet -> TestName -> t -> Ap (Reader Int) TestOutput
runSingleTest
, foldGroup :: OptionSet
-> TestName
-> Ap (Reader Int) TestOutput
-> Ap (Reader Int) TestOutput
foldGroup = OptionSet
-> TestName
-> Ap (Reader Int) TestOutput
-> Ap (Reader Int) TestOutput
runGroup
}
OptionSet
opts TestTree
tree
foldTestOutput
:: Monoid b
=> (String -> IO () -> IO Result -> (Result -> IO ()) -> b)
-> (String -> IO () -> b -> b)
-> TestOutput
-> StatusMap
-> b
foldTestOutput :: (TestName -> IO () -> IO Result -> (Result -> IO ()) -> b)
-> (TestName -> IO () -> b -> b) -> TestOutput -> StatusMap -> b
foldTestOutput foldTest :: TestName -> IO () -> IO Result -> (Result -> IO ()) -> b
foldTest foldHeading :: TestName -> IO () -> b -> b
foldHeading outputTree :: TestOutput
outputTree smap :: 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 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 name :: TestName
name printName :: IO ()
printName printResult :: 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
+ 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 "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
readStatusVar :: IO Result
readStatusVar = TVar Status -> IO Result
getResultFromTVar TVar Status
statusVar
b -> StateT Int m b
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 IO Result
readStatusVar Result -> IO ()
printResult
go (PrintHeading name :: TestName
name printName :: IO ()
printName printBody :: 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 a :: TestOutput
a b :: 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 Skip = Ap (StateT Int m) b
forall a. Monoid a => a
mempty
consoleOutput :: (?colors :: Bool) => TestOutput -> StatusMap -> IO ()
consoleOutput :: TestOutput -> StatusMap -> IO ()
consoleOutput toutput :: TestOutput
toutput smap :: 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 _name :: p
_name printName :: IO ()
printName getResult :: IO t
getResult printResult :: 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 _name :: p
_name printHeading :: IO ()
printHeading (printBody :: Traversal IO
printBody, Any nonempty :: 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 :: TestOutput -> StatusMap -> IO ()
consoleOutputHidingSuccesses toutput :: TestOutput
toutput smap :: 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 _name :: p
_name printName :: IO ()
printName getResult :: IO Result
getResult printResult :: 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 (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 (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 _name :: p
_name printHeading :: IO ()
printHeading printBody :: 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 :: 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 (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 1; IO ()
clearThisLine
clearThisLine :: IO ()
clearThisLine = do IO ()
clearLine; Int -> IO ()
setCursorColumn 0
streamOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> IO ()
streamOutputHidingSuccesses :: TestOutput -> StatusMap -> IO ()
streamOutputHidingSuccesses toutput :: TestOutput
toutput smap :: 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 _name :: p
_name printName :: IO ()
printName getResult :: IO Result
getResult printResult :: 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 (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 (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 (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 (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 _name :: p
_name printHeading :: a
printHeading printBody :: 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 :: 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
$ \stack :: [a]
stack ->
case [a]
stack of
_:rest :: [a]
rest -> [a]
rest
[] -> []
Any -> StateT [a] m Any
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
data Statistics = Statistics
{ Statistics -> Int
statTotal :: !Int
, Statistics -> Int
statFailures :: !Int
}
instance Sem.Semigroup Statistics where
Statistics t1 :: Int
t1 f1 :: Int
f1 <> :: Statistics -> Statistics -> Statistics
<> Statistics t2 :: Int
t2 f2 :: 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 0 0
#if !MIN_VERSION_base(4,11,0)
mappend = (Sem.<>)
#endif
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 (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\var :: 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
$
(\r :: Result
r -> Int -> Int -> Statistics
Statistics 1 (if Result -> Bool
resultSuccessful Result
r then 0 else 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 :: Statistics -> IO ()
reportStatistics st :: Statistics
st = case Statistics -> Int
statFailures Statistics
st of
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 "All %d tests passed" (Statistics -> Int
statTotal Statistics
st)
fs :: 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 "%d out of %d tests failed" Int
fs (Statistics -> Int
statTotal Statistics
st)
printStatistics :: (?colors :: Bool) => Statistics -> Time -> IO ()
printStatistics :: Statistics -> Time -> IO ()
printStatistics st :: Statistics
st time :: Time
time = do
TestName -> IO ()
forall r. PrintfType r => TestName -> r
printf "\n"
(?colors::Bool) => Statistics -> IO ()
Statistics -> IO ()
reportStatistics Statistics
st
case Statistics -> Int
statFailures Statistics
st of
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 " (%.2fs)\n" Time
time
_ -> (?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 " (%.2fs)\n" Time
time
printStatisticsNoTime :: (?colors :: Bool) => Statistics -> IO ()
printStatisticsNoTime :: Statistics -> IO ()
printStatisticsNoTime st :: Statistics
st = (?colors::Bool) => Statistics -> IO ()
Statistics -> IO ()
reportStatistics Statistics
st IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TestName -> IO ()
forall r. PrintfType r => TestName -> r
printf "\n"
statusMapResult
:: Int
-> StatusMap
-> IO Bool
statusMapResult :: Int -> StatusMap -> IO Bool
statusMapResult lookahead0 :: Int
lookahead0 smap :: StatusMap
smap
| StatusMap -> Bool
forall a. IntMap a -> Bool
IntMap.null StatusMap
smap = Bool -> IO Bool
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
-> (IntMap () -> Int -> STM (IO Bool))
-> IntMap ()
-> Int
-> STM (IO Bool))
-> (IntMap () -> Int -> STM (IO Bool))
-> StatusMap
-> IntMap ()
-> Int
-> STM (IO Bool)
forall a b. (Int -> a -> b -> b) -> b -> IntMap a -> b
IntMap.foldrWithKey Int
-> TVar Status
-> (IntMap () -> Int -> STM (IO Bool))
-> IntMap ()
-> Int
-> STM (IO Bool)
f IntMap () -> Int -> STM (IO Bool)
finish StatusMap
smap IntMap ()
forall a. Monoid a => a
mempty Int
lookahead0
where
f :: Int
-> TVar Status
-> (IntMap.IntMap () -> Int -> STM (IO Bool))
-> (IntMap.IntMap () -> Int -> STM (IO Bool))
f :: Int
-> TVar Status
-> (IntMap () -> Int -> STM (IO Bool))
-> IntMap ()
-> Int
-> STM (IO Bool)
f key :: Int
key tvar :: TVar Status
tvar k :: IntMap () -> Int -> STM (IO Bool)
k ok_tests :: IntMap ()
ok_tests lookahead :: Int
lookahead
| Int
lookahead Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 =
IntMap () -> STM (IO Bool)
next_iter IntMap ()
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 r :: Result
r ->
if Result -> Bool
resultSuccessful Result
r
then IntMap () -> Int -> STM (IO Bool)
k (Int -> () -> IntMap () -> IntMap ()
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
key () IntMap ()
ok_tests) Int
lookahead
else IO Bool -> STM (IO Bool)
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 (m :: * -> *) a. Monad m => a -> m a
return Bool
False
_ -> IntMap () -> Int -> STM (IO Bool)
k IntMap ()
ok_tests (Int
lookaheadInt -> Int -> Int
forall a. Num a => a -> a -> a
-1)
next_iter :: IntMap.IntMap () -> STM (IO Bool)
next_iter :: IntMap () -> STM (IO Bool)
next_iter ok_tests :: IntMap ()
ok_tests =
if IntMap () -> Bool
forall a. IntMap a -> Bool
IntMap.null IntMap ()
ok_tests
then STM (IO Bool)
forall a. STM a
retry
else IO Bool -> STM (IO Bool)
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 -> IntMap () -> StatusMap
forall a b. IntMap a -> IntMap b -> IntMap a
IntMap.difference StatusMap
smap IntMap ()
ok_tests)
finish :: IntMap.IntMap () -> Int -> STM (IO Bool)
finish :: IntMap () -> Int -> STM (IO Bool)
finish ok_tests :: IntMap ()
ok_tests _ = IntMap () -> STM (IO Bool)
next_iter IntMap ()
ok_tests
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
$ \opts :: OptionSet
opts tree :: TestTree
tree ->
let
TestPattern pattern :: 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 (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 _ cb :: 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]
-> Maybe Expr
-> [TestName]
-> Result
-> Result
appendPatternIfTestFailed :: [TestName] -> Maybe Expr -> [TestName] -> Result -> Result
appendPatternIfTestFailed [_] _ _ res :: Result
res = Result
res
appendPatternIfTestFailed _ _ [] res :: Result
res = Result
res
appendPatternIfTestFailed tests :: [TestName]
tests currentPattern :: Maybe Expr
currentPattern (name :: TestName
name : names :: [TestName]
names) res :: Result
res = case Result -> Outcome
resultOutcome Result
res of
Success -> Result
res
Failure{} -> Result
res { resultDescription :: TestName
resultDescription = Result -> TestName
resultDescription Result
res TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
msg }
where
msg :: TestName
msg = "\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]
++ "' 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
$ \c :: Char
c -> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\'' then "'\\''" else [Char
c]
findPattern :: [TestName] -> TestName -> [TestName] -> Expr
findPattern [_] pat :: TestName
pat _ = TestName -> Expr
ERE TestName
pat
findPattern _ pat :: TestName
pat [] = Expr -> Expr -> Expr
EQ (Expr -> Expr
Field (Int -> Expr
IntLit 0)) (TestName -> Expr
StringLit TestName
pat)
findPattern ts :: [TestName]
ts pat :: TestName
pat (n :: TestName
n : ns :: [TestName]
ns) = let pat' :: TestName
pat' = TestName
n TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ '.' 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 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)
]
consoleTestReporterWithHook :: ([TestName] -> Result -> IO Result) -> Ingredient
consoleTestReporterWithHook :: ([TestName] -> Result -> IO Result) -> Ingredient
consoleTestReporterWithHook hook :: [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
$
\opts :: OptionSet
opts tree :: 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
$ \smap :: StatusMap
smap -> do
let
whenColor :: UseColor
whenColor = OptionSet -> UseColor
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
Quiet quiet :: Bool
quiet = OptionSet -> Quiet
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
HideSuccesses hideSuccesses :: Bool
hideSuccesses = OptionSet -> HideSuccesses
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
NumThreads numThreads :: Int
numThreads = OptionSet -> NumThreads
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
AnsiTricks 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 (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
_time -> Bool -> IO Bool
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
(\k :: 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 whenColor isTermColor
let
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 (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
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 (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
== 0
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
/= :: Quiet -> Quiet -> Bool
$c/= :: Quiet -> Quiet -> Bool
== :: Quiet -> Quiet -> Bool
$c== :: 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
min :: Quiet -> Quiet -> Quiet
$cmin :: Quiet -> Quiet -> Quiet
max :: Quiet -> Quiet -> Quiet
$cmax :: Quiet -> Quiet -> Quiet
>= :: Quiet -> Quiet -> Bool
$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
compare :: Quiet -> Quiet -> Ordering
$ccompare :: Quiet -> Quiet -> Ordering
$cp1Ord :: Eq 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 (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 (m :: * -> *) a. Monad m => a -> m a
return "quiet"
optionHelp :: Tagged Quiet TestName
optionHelp = TestName -> Tagged Quiet TestName
forall (m :: * -> *) a. Monad m => a -> m a
return "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 'q') (Bool -> Quiet
Quiet Bool
True)
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
/= :: HideSuccesses -> HideSuccesses -> Bool
$c/= :: HideSuccesses -> HideSuccesses -> Bool
== :: HideSuccesses -> HideSuccesses -> Bool
$c== :: 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
min :: HideSuccesses -> HideSuccesses -> HideSuccesses
$cmin :: HideSuccesses -> HideSuccesses -> HideSuccesses
max :: HideSuccesses -> HideSuccesses -> HideSuccesses
$cmax :: HideSuccesses -> HideSuccesses -> HideSuccesses
>= :: HideSuccesses -> HideSuccesses -> Bool
$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
compare :: HideSuccesses -> HideSuccesses -> Ordering
$ccompare :: HideSuccesses -> HideSuccesses -> Ordering
$cp1Ord :: Eq 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 (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 (m :: * -> *) a. Monad m => a -> m a
return "hide-successes"
optionHelp :: Tagged HideSuccesses TestName
optionHelp = TestName -> Tagged HideSuccesses TestName
forall (m :: * -> *) a. Monad m => a -> m a
return "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)
data UseColor
= Never
| Always
| Auto
deriving (UseColor -> UseColor -> Bool
(UseColor -> UseColor -> Bool)
-> (UseColor -> UseColor -> Bool) -> Eq UseColor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UseColor -> UseColor -> Bool
$c/= :: UseColor -> UseColor -> Bool
== :: UseColor -> UseColor -> Bool
$c== :: 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
min :: UseColor -> UseColor -> UseColor
$cmin :: UseColor -> UseColor -> UseColor
max :: UseColor -> UseColor -> UseColor
$cmax :: UseColor -> UseColor -> UseColor
>= :: UseColor -> UseColor -> Bool
$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
compare :: UseColor -> UseColor -> Ordering
$ccompare :: UseColor -> UseColor -> Ordering
$cp1Ord :: Eq UseColor
Ord, Typeable)
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 (m :: * -> *) a. Monad m => a -> m a
return "color"
optionHelp :: Tagged UseColor TestName
optionHelp = TestName -> Tagged UseColor TestName
forall (m :: * -> *) a. Monad m => a -> m a
return "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 "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
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 (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 (m :: * -> *) a. Monad m => a -> m a
return "ansi-tricks"
optionHelp :: Tagged AnsiTricks TestName
optionHelp = TestName -> Tagged AnsiTricks TestName
forall (m :: * -> *) a. Monad m => a -> m a
return (TestName -> Tagged AnsiTricks TestName)
-> TestName -> Tagged AnsiTricks TestName
forall a b. (a -> b) -> a -> b
$
"Enable various ANSI terminal tricks. " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++
"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 b :: Bool
b =
case Bool
b of
False -> "false"
True -> "true"
useColor :: UseColor -> Bool -> Bool
useColor :: UseColor -> Bool -> Bool
useColor when_ :: UseColor
when_ isTerm :: Bool
isTerm =
case UseColor
when_ of
Never -> Bool
False
Always -> Bool
True
Auto -> Bool
isTerm
parseUseColor :: String -> Maybe UseColor
parseUseColor :: TestName -> Maybe UseColor
parseUseColor s :: TestName
s =
case (Char -> Char) -> TestName -> TestName
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower TestName
s of
"never" -> UseColor -> Maybe UseColor
forall (m :: * -> *) a. Monad m => a -> m a
return UseColor
Never
"always" -> UseColor -> Maybe UseColor
forall (m :: * -> *) a. Monad m => a -> m a
return UseColor
Always
"auto" -> UseColor -> Maybe UseColor
forall (m :: * -> *) a. Monad m => a -> m a
return UseColor
Auto
_ -> Maybe UseColor
forall a. Maybe a
Nothing
displayUseColor :: UseColor -> String
displayUseColor :: UseColor -> TestName
displayUseColor uc :: UseColor
uc =
case UseColor
uc of
Never -> "never"
Always -> "always"
Auto -> "auto"
getResultFromTVar :: TVar Status -> IO Result
getResultFromTVar :: TVar Status -> IO Result
getResultFromTVar var :: 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 r :: Result
r -> Result -> STM Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
r
_ -> STM Result
forall a. STM a
retry
indentSize :: Int
indentSize :: Int
indentSize = 2
indent :: Int -> String
indent :: Int -> TestName
indent n :: 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) ' '
formatDesc
:: Int
-> String
-> String
formatDesc :: Int -> TestName -> TestName
formatDesc n :: Int
n desc :: TestName
desc =
let
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
== '\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 = '\n' Char -> TestName -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` TestName
chomped
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
$ \c :: Char
c ->
if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\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
data Maximum a
= Maximum a
| MinusInfinity
instance Ord a => Sem.Semigroup (Maximum a) where
Maximum a :: a
a <> :: Maximum a -> Maximum a -> Maximum a
<> Maximum b :: a
b = a -> Maximum a
forall a. a -> Maximum a
Maximum (a
a a -> a -> a
forall a. Ord a => a -> a -> a
`max` a
b)
MinusInfinity <> a :: Maximum a
a = Maximum a
a
a :: Maximum a
a <> MinusInfinity = Maximum a
a
instance Ord a => Monoid (Maximum a) where
mempty :: Maximum a
mempty = Maximum a
forall a. Maximum a
MinusInfinity
#if !MIN_VERSION_base(4,11,0)
mappend = (Sem.<>)
#endif
computeAlignment :: OptionSet -> TestTree -> Int
computeAlignment :: OptionSet -> TestTree -> Int
computeAlignment opts :: OptionSet
opts =
(Int -> Maximum Int) -> Int
forall t p. (Num t, Num p) => (t -> Maximum p) -> p
fromMonoid ((Int -> Maximum Int) -> Int)
-> (TestTree -> Int -> Maximum Int) -> TestTree -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
TreeFold (Int -> Maximum Int)
-> OptionSet -> TestTree -> Int -> Maximum Int
forall b. Monoid b => TreeFold b -> OptionSet -> TestTree -> b
foldTestTree
TreeFold (Int -> Maximum Int)
forall b. Monoid b => TreeFold b
trivialFold
{ foldSingle :: forall t.
IsTest t =>
OptionSet -> TestName -> t -> Int -> Maximum Int
foldSingle = \_ name :: TestName
name _ level :: Int
level -> Int -> Maximum Int
forall a. a -> Maximum a
Maximum (TestName -> Int
stringWidth TestName
name Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
level)
, foldGroup :: OptionSet -> TestName -> (Int -> Maximum Int) -> Int -> Maximum Int
foldGroup = \_opts :: OptionSet
_opts _ m :: Int -> Maximum Int
m -> Int -> Maximum Int
m (Int -> Maximum Int) -> (Int -> Int) -> Int -> Maximum Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
indentSize)
}
OptionSet
opts
where
fromMonoid :: (t -> Maximum p) -> p
fromMonoid m :: t -> Maximum p
m =
case t -> Maximum p
m 0 of
MinusInfinity -> 0
Maximum x :: p
x -> p
x
stringWidth :: String -> Int
#ifdef VERSION_wcwidth
stringWidth :: TestName -> Int
stringWidth = [Int] -> Int
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
charWidth
where charWidth :: Char -> Int
charWidth c :: Char
c = case Char -> Int
wcwidth Char
c of
-1 -> 1
w :: Int
w -> Int
w
#else
stringWidth = length
#endif
ok, fail, skipped, infoOk, infoFail :: (?colors :: Bool) => String -> IO ()
fail :: TestName -> IO ()
fail = (?colors::Bool) => ConsoleFormat -> TestName -> IO ()
ConsoleFormat -> TestName -> IO ()
output ConsoleFormat
failFormat
ok :: TestName -> IO ()
ok = (?colors::Bool) => ConsoleFormat -> TestName -> IO ()
ConsoleFormat -> TestName -> IO ()
output ConsoleFormat
okFormat
skipped :: TestName -> IO ()
skipped = (?colors::Bool) => ConsoleFormat -> TestName -> IO ()
ConsoleFormat -> TestName -> IO ()
output ConsoleFormat
skippedFormat
infoOk :: TestName -> IO ()
infoOk = (?colors::Bool) => ConsoleFormat -> TestName -> IO ()
ConsoleFormat -> TestName -> IO ()
output ConsoleFormat
infoOkFormat
infoFail :: TestName -> IO ()
infoFail = (?colors::Bool) => ConsoleFormat -> TestName -> IO ()
ConsoleFormat -> TestName -> IO ()
output ConsoleFormat
infoFailFormat
output
:: (?colors :: Bool)
=> ConsoleFormat
-> String
-> IO ()
output :: ConsoleFormat -> TestName -> IO ()
output format :: 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
withConsoleFormat :: (?colors :: Bool) => ConsoleFormatPrinter
withConsoleFormat :: ConsoleFormatPrinter
withConsoleFormat format :: ConsoleFormat
format action :: 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