{-# LANGUAGE OverloadedStrings #-}
module Test.Framework.TestReporter (
IsParallel(..), isParallelFromBool, IsJsonOutput(..), IsXmlOutput(..),
reportAllTests, reportGlobalStart, reportTestStart, reportTestResult,
reportGlobalResults, defaultTestReporters
) where
import Test.Framework.TestTypes
import Test.Framework.Location
import Test.Framework.Colors
import Test.Framework.JsonOutput
import Test.Framework.XmlOutput
import System.IO
import Control.Monad.RWS
import Text.PrettyPrint
import qualified Data.Text.IO as T
import qualified Data.ByteString.Lazy as BSL
reportAllTests :: ReportAllTests
reportAllTests :: ReportAllTests
reportAllTests [FlatTest]
tests =
do [TestReporter]
reps <- (TestConfig -> [TestReporter])
-> RWST TestConfig () TestState IO [TestReporter]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks TestConfig -> [TestReporter]
tc_reporters
(TestReporter -> TR ()) -> [TestReporter] -> TR ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\TestReporter
r -> TestReporter -> ReportAllTests
tr_reportAllTests TestReporter
r [FlatTest]
tests) [TestReporter]
reps
reportGlobalStart :: ReportGlobalStart
reportGlobalStart :: ReportAllTests
reportGlobalStart [FlatTest]
tests =
do [TestReporter]
reps <- (TestConfig -> [TestReporter])
-> RWST TestConfig () TestState IO [TestReporter]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks TestConfig -> [TestReporter]
tc_reporters
(TestReporter -> TR ()) -> [TestReporter] -> TR ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\TestReporter
r -> TestReporter -> ReportAllTests
tr_reportGlobalStart TestReporter
r [FlatTest]
tests) [TestReporter]
reps
reportTestStart :: ReportTestStart
reportTestStart :: ReportTestStart
reportTestStart FlatTest
t =
do [TestReporter]
reps <- (TestConfig -> [TestReporter])
-> RWST TestConfig () TestState IO [TestReporter]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks TestConfig -> [TestReporter]
tc_reporters
(TestReporter -> TR ()) -> [TestReporter] -> TR ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\TestReporter
r -> TestReporter -> ReportTestStart
tr_reportTestStart TestReporter
r FlatTest
t) [TestReporter]
reps
reportTestResult :: ReportTestResult
reportTestResult :: ReportTestResult
reportTestResult FlatTestResult
t =
do [TestReporter]
reps <- (TestConfig -> [TestReporter])
-> RWST TestConfig () TestState IO [TestReporter]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks TestConfig -> [TestReporter]
tc_reporters
(TestReporter -> TR ()) -> [TestReporter] -> TR ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\TestReporter
r -> TestReporter -> ReportTestResult
tr_reportTestResult TestReporter
r FlatTestResult
t) [TestReporter]
reps
reportGlobalResults :: ReportGlobalResults
reportGlobalResults :: ReportGlobalResults
reportGlobalResults ReportGlobalResultsArg
arg =
do [TestReporter]
reps <- (TestConfig -> [TestReporter])
-> RWST TestConfig () TestState IO [TestReporter]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks TestConfig -> [TestReporter]
tc_reporters
(TestReporter -> TR ()) -> [TestReporter] -> TR ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\TestReporter
r -> TestReporter -> ReportGlobalResults
tr_reportGlobalResults TestReporter
r ReportGlobalResultsArg
arg) [TestReporter]
reps
data IsParallel = Parallel | NonParallel
isParallelFromBool :: Bool -> IsParallel
isParallelFromBool :: Bool -> IsParallel
isParallelFromBool Bool
True = IsParallel
Parallel
isParallelFromBool Bool
False = IsParallel
NonParallel
data IsJsonOutput = JsonOutput | NoJsonOutput
data IsXmlOutput = XmlOutput | NoXmlOutput
defaultTestReporters :: IsParallel
-> IsJsonOutput
-> IsXmlOutput
-> [TestReporter]
defaultTestReporters :: IsParallel -> IsJsonOutput -> IsXmlOutput -> [TestReporter]
defaultTestReporters IsParallel
inParallel IsJsonOutput
forMachine IsXmlOutput
doXml =
case (IsParallel
inParallel, IsJsonOutput
forMachine) of
(IsParallel
NonParallel, IsJsonOutput
NoJsonOutput) ->
[TestReporter :: String
-> ReportAllTests
-> ReportAllTests
-> ReportTestStart
-> ReportTestResult
-> ReportGlobalResults
-> TestReporter
TestReporter
{ tr_id :: String
tr_id = String
"rep_seq_human"
, tr_reportAllTests :: ReportAllTests
tr_reportAllTests = ReportAllTests
reportAllTestsH
, tr_reportGlobalStart :: ReportAllTests
tr_reportGlobalStart = ReportAllTests
reportGlobalStartHS
, tr_reportTestStart :: ReportTestStart
tr_reportTestStart = ReportTestStart
reportTestStartHS
, tr_reportTestResult :: ReportTestResult
tr_reportTestResult = ReportTestResult
reportTestResultHS
, tr_reportGlobalResults :: ReportGlobalResults
tr_reportGlobalResults = ReportGlobalResults
reportGlobalResultsH
}] [TestReporter] -> [TestReporter] -> [TestReporter]
forall a. [a] -> [a] -> [a]
++ [TestReporter]
xmlReporters
(IsParallel
Parallel, IsJsonOutput
NoJsonOutput) ->
[TestReporter :: String
-> ReportAllTests
-> ReportAllTests
-> ReportTestStart
-> ReportTestResult
-> ReportGlobalResults
-> TestReporter
TestReporter
{ tr_id :: String
tr_id = String
"rep_par_human"
, tr_reportAllTests :: ReportAllTests
tr_reportAllTests = ReportAllTests
reportAllTestsH
, tr_reportGlobalStart :: ReportAllTests
tr_reportGlobalStart = ReportAllTests
reportGlobalStartHP
, tr_reportTestStart :: ReportTestStart
tr_reportTestStart = ReportTestStart
reportTestStartHP
, tr_reportTestResult :: ReportTestResult
tr_reportTestResult = ReportTestResult
reportTestResultHP
, tr_reportGlobalResults :: ReportGlobalResults
tr_reportGlobalResults = ReportGlobalResults
reportGlobalResultsH
}] [TestReporter] -> [TestReporter] -> [TestReporter]
forall a. [a] -> [a] -> [a]
++ [TestReporter]
xmlReporters
(IsParallel
NonParallel, IsJsonOutput
JsonOutput) ->
[TestReporter :: String
-> ReportAllTests
-> ReportAllTests
-> ReportTestStart
-> ReportTestResult
-> ReportGlobalResults
-> TestReporter
TestReporter
{ tr_id :: String
tr_id = String
"rep_seq_machine"
, tr_reportAllTests :: ReportAllTests
tr_reportAllTests = ReportAllTests
reportAllTestsM
, tr_reportGlobalStart :: ReportAllTests
tr_reportGlobalStart = ReportAllTests
reportGlobalStartMS
, tr_reportTestStart :: ReportTestStart
tr_reportTestStart = ReportTestStart
reportTestStartMS
, tr_reportTestResult :: ReportTestResult
tr_reportTestResult = ReportTestResult
reportTestResultMS
, tr_reportGlobalResults :: ReportGlobalResults
tr_reportGlobalResults = ReportGlobalResults
reportGlobalResultsM
}] [TestReporter] -> [TestReporter] -> [TestReporter]
forall a. [a] -> [a] -> [a]
++ [TestReporter]
xmlReporters
(IsParallel
Parallel, IsJsonOutput
JsonOutput) ->
[TestReporter :: String
-> ReportAllTests
-> ReportAllTests
-> ReportTestStart
-> ReportTestResult
-> ReportGlobalResults
-> TestReporter
TestReporter
{ tr_id :: String
tr_id = String
"rep_par_machine"
, tr_reportAllTests :: ReportAllTests
tr_reportAllTests = ReportAllTests
reportAllTestsM
, tr_reportGlobalStart :: ReportAllTests
tr_reportGlobalStart = ReportAllTests
reportGlobalStartMP
, tr_reportTestStart :: ReportTestStart
tr_reportTestStart = ReportTestStart
reportTestStartMP
, tr_reportTestResult :: ReportTestResult
tr_reportTestResult = ReportTestResult
reportTestResultMP
, tr_reportGlobalResults :: ReportGlobalResults
tr_reportGlobalResults = ReportGlobalResults
reportGlobalResultsM
}] [TestReporter] -> [TestReporter] -> [TestReporter]
forall a. [a] -> [a] -> [a]
++ [TestReporter]
xmlReporters
where
xmlReporters :: [TestReporter]
xmlReporters =
case IsXmlOutput
doXml of
IsXmlOutput
NoXmlOutput -> []
IsXmlOutput
XmlOutput -> [(String -> TestReporter
emptyTestReporter String
"rep_xml") {
tr_reportGlobalResults :: ReportGlobalResults
tr_reportGlobalResults = ReportGlobalResults
reportGlobalResultsXml
}]
humanTestName :: GenFlatTest a -> String
humanTestName :: GenFlatTest a -> String
humanTestName GenFlatTest a
ft =
TestPath -> String
flatName (GenFlatTest a -> TestPath
forall a. GenFlatTest a -> TestPath
ft_path GenFlatTest a
ft) String -> String -> String
forall a. [a] -> [a] -> [a]
++
case GenFlatTest a -> Maybe Location
forall a. GenFlatTest a -> Maybe Location
ft_location GenFlatTest a
ft of
Maybe Location
Nothing -> String
""
Just Location
loc -> String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Location -> String
showLoc Location
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
reportHumanTestStartMessage :: ReportLevel -> GenFlatTest a -> TR ()
reportHumanTestStartMessage :: ReportLevel -> GenFlatTest a -> TR ()
reportHumanTestStartMessage ReportLevel
level GenFlatTest a
ft =
do let t :: ColorString
t = Color -> String -> ColorString
colorize Color
testStartColor String
"[TEST] "
ReportLevel -> ColorString -> TR ()
reportTR ReportLevel
level (ColorString
t ColorString -> ColorString -> ColorString
+++ String -> ColorString
noColor (GenFlatTest a -> String
forall a. GenFlatTest a -> String
humanTestName GenFlatTest a
ft))
reportGlobalStartHS :: ReportGlobalStart
reportGlobalStartHS :: ReportAllTests
reportGlobalStartHS [FlatTest]
_ = () -> TR ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
reportTestStartHS :: ReportTestStart
reportTestStartHS :: ReportTestStart
reportTestStartHS FlatTest
ft = ReportLevel -> ReportTestStart
forall a. ReportLevel -> GenFlatTest a -> TR ()
reportHumanTestStartMessage ReportLevel
Debug FlatTest
ft
reportTestResultHS :: ReportTestResult
reportTestResultHS :: ReportTestResult
reportTestResultHS FlatTestResult
ftr =
let res :: TestResult
res = RunResult -> TestResult
rr_result (FlatTestResult -> RunResult
forall a. GenFlatTest a -> a
ft_payload FlatTestResult
ftr)
msg :: ColorString
msg = ColorString -> CallStack -> ColorString
attachCallStack (RunResult -> ColorString
rr_message (FlatTestResult -> RunResult
forall a. GenFlatTest a -> a
ft_payload FlatTestResult
ftr)) (RunResult -> CallStack
rr_callers (FlatTestResult -> RunResult
forall a. GenFlatTest a -> a
ft_payload FlatTestResult
ftr))
in case TestResult
res of
TestResult
Pass ->
ReportLevel -> ColorString -> ColorString -> TR ()
reportMessage ReportLevel
Debug ColorString
msg ColorString
okSuffix
TestResult
Pending ->
do TR ()
reportHumanTestStartMessageIfNeeded
ReportLevel -> ColorString -> ColorString -> TR ()
reportMessage ReportLevel
Info ColorString
msg ColorString
pendingSuffix
TestResult
Fail ->
do TR ()
reportHumanTestStartMessageIfNeeded
ReportLevel -> ColorString -> ColorString -> TR ()
reportMessage ReportLevel
Info ColorString
msg ColorString
failureSuffix
TestResult
Error ->
do TR ()
reportHumanTestStartMessageIfNeeded
ReportLevel -> ColorString -> ColorString -> TR ()
reportMessage ReportLevel
Info ColorString
msg ColorString
errorSuffix
where
reportHumanTestStartMessageIfNeeded :: TR ()
reportHumanTestStartMessageIfNeeded =
do TestConfig
tc <- RWST TestConfig () TestState IO TestConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
Bool -> TR () -> TR ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TestConfig -> Bool
tc_quiet TestConfig
tc) (ReportLevel -> ReportTestResult
forall a. ReportLevel -> GenFlatTest a -> TR ()
reportHumanTestStartMessage ReportLevel
Info FlatTestResult
ftr)
reportMessage :: ReportLevel -> ColorString -> ColorString -> TR ()
reportMessage ReportLevel
level ColorString
msg ColorString
suffix =
ReportLevel -> ColorString -> TR ()
reportTR ReportLevel
level (ColorString -> ColorString
ensureNewlineColorString ColorString
msg ColorString -> ColorString -> ColorString
+++ ColorString
suffix ColorString -> ColorString -> ColorString
+++ String -> ColorString
noColor String
timeStr)
timeStr :: String
timeStr = String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Milliseconds -> String
forall a. Show a => a -> String
show (RunResult -> Milliseconds
rr_wallTimeMs (FlatTestResult -> RunResult
forall a. GenFlatTest a -> a
ft_payload FlatTestResult
ftr)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"ms)\n"
failureSuffix :: ColorString
failureSuffix = Color -> String -> ColorString
colorize Color
warningColor String
"*** Failed!"
errorSuffix :: ColorString
errorSuffix = Color -> String -> ColorString
colorize Color
warningColor String
"@@@ Error!"
pendingSuffix :: ColorString
pendingSuffix = Color -> String -> ColorString
colorize Color
pendingColor String
"^^^ Pending!"
okSuffix :: ColorString
okSuffix = Color -> String -> ColorString
colorize Color
testOkColor String
"+++ OK"
reportGlobalStartHP :: ReportGlobalStart
reportGlobalStartHP :: ReportAllTests
reportGlobalStartHP [FlatTest]
_ = () -> TR ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
reportTestStartHP :: ReportTestStart
reportTestStartHP :: ReportTestStart
reportTestStartHP FlatTest
ft =
do ReportLevel -> String -> TR ()
reportStringTR ReportLevel
Debug (String
"Starting " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (FlatTest -> String
forall a. GenFlatTest a -> String
humanTestName FlatTest
ft))
reportTestResultHP :: ReportTestResult
reportTestResultHP :: ReportTestResult
reportTestResultHP FlatTestResult
ftr =
do ReportLevel -> ReportTestResult
forall a. ReportLevel -> GenFlatTest a -> TR ()
reportHumanTestStartMessage ReportLevel
Debug FlatTestResult
ftr
ReportTestResult
reportTestResultHS FlatTestResult
ftr
reportAllTestsH :: ReportAllTests
reportAllTestsH :: ReportAllTests
reportAllTestsH [FlatTest]
l =
ReportLevel -> String -> TR ()
reportStringTR ReportLevel
Info (Doc -> String
render ([FlatTest] -> Doc
forall a. [GenFlatTest a] -> Doc
renderTestNames [FlatTest]
l))
reportGlobalResultsH :: ReportGlobalResults
reportGlobalResultsH :: ReportGlobalResults
reportGlobalResultsH ReportGlobalResultsArg
arg =
do let passed :: Milliseconds
passed = [FlatTestResult] -> Milliseconds
forall (t :: * -> *) a. Foldable t => t a -> Milliseconds
length (ReportGlobalResultsArg -> [FlatTestResult]
rgra_passed ReportGlobalResultsArg
arg)
pending :: Milliseconds
pending = [FlatTestResult] -> Milliseconds
forall (t :: * -> *) a. Foldable t => t a -> Milliseconds
length (ReportGlobalResultsArg -> [FlatTestResult]
rgra_pending ReportGlobalResultsArg
arg)
failed :: Milliseconds
failed = [FlatTestResult] -> Milliseconds
forall (t :: * -> *) a. Foldable t => t a -> Milliseconds
length (ReportGlobalResultsArg -> [FlatTestResult]
rgra_failed ReportGlobalResultsArg
arg)
error :: Milliseconds
error = [FlatTestResult] -> Milliseconds
forall (t :: * -> *) a. Foldable t => t a -> Milliseconds
length (ReportGlobalResultsArg -> [FlatTestResult]
rgra_errors ReportGlobalResultsArg
arg)
timedOut :: Milliseconds
timedOut = [FlatTestResult] -> Milliseconds
forall (t :: * -> *) a. Foldable t => t a -> Milliseconds
length (ReportGlobalResultsArg -> [FlatTestResult]
rgra_timedOut ReportGlobalResultsArg
arg)
filtered :: Milliseconds
filtered = [FlatTest] -> Milliseconds
forall (t :: * -> *) a. Foldable t => t a -> Milliseconds
length (ReportGlobalResultsArg -> [FlatTest]
rgra_filtered ReportGlobalResultsArg
arg)
total :: Milliseconds
total = Milliseconds
passed Milliseconds -> Milliseconds -> Milliseconds
forall a. Num a => a -> a -> a
+ Milliseconds
failed Milliseconds -> Milliseconds -> Milliseconds
forall a. Num a => a -> a -> a
+ Milliseconds
error Milliseconds -> Milliseconds -> Milliseconds
forall a. Num a => a -> a -> a
+ Milliseconds
pending
let pendings :: ColorString
pendings = (if Milliseconds
pending Milliseconds -> Milliseconds -> Bool
forall a. Ord a => a -> a -> Bool
> Milliseconds
0 then Color -> String -> ColorString
colorize Color
pendingColor else String -> ColorString
noColor) String
"* Pending:"
failures :: ColorString
failures = (if Milliseconds
failed Milliseconds -> Milliseconds -> Bool
forall a. Ord a => a -> a -> Bool
> Milliseconds
0 then Color -> String -> ColorString
colorize Color
warningColor else String -> ColorString
noColor) String
"* Failures:"
errors :: ColorString
errors = (if Milliseconds
error Milliseconds -> Milliseconds -> Bool
forall a. Ord a => a -> a -> Bool
> Milliseconds
0 then Color -> String -> ColorString
colorize Color
warningColor else String -> ColorString
noColor) String
"* Errors:"
ReportLevel -> ColorString -> TR ()
reportTR ReportLevel
Info (ColorString
"* Tests: " ColorString -> ColorString -> ColorString
+++ Milliseconds -> ColorString
forall a. Show a => a -> ColorString
showC Milliseconds
total ColorString -> ColorString -> ColorString
+++ ColorString
"\n" ColorString -> ColorString -> ColorString
+++
ColorString
"* Passed: " ColorString -> ColorString -> ColorString
+++ Milliseconds -> ColorString
forall a. Show a => a -> ColorString
showC Milliseconds
passed ColorString -> ColorString -> ColorString
+++ ColorString
"\n" ColorString -> ColorString -> ColorString
+++
ColorString
pendings ColorString -> ColorString -> ColorString
+++ ColorString
" " ColorString -> ColorString -> ColorString
+++ Milliseconds -> ColorString
forall a. Show a => a -> ColorString
showC Milliseconds
pending ColorString -> ColorString -> ColorString
+++ ColorString
"\n" ColorString -> ColorString -> ColorString
+++
ColorString
failures ColorString -> ColorString -> ColorString
+++ ColorString
" " ColorString -> ColorString -> ColorString
+++ Milliseconds -> ColorString
forall a. Show a => a -> ColorString
showC Milliseconds
failed ColorString -> ColorString -> ColorString
+++ ColorString
"\n" ColorString -> ColorString -> ColorString
+++
ColorString
errors ColorString -> ColorString -> ColorString
+++ ColorString
" " ColorString -> ColorString -> ColorString
+++ Milliseconds -> ColorString
forall a. Show a => a -> ColorString
showC Milliseconds
error ColorString -> ColorString -> ColorString
+++ ColorString
"\n" ColorString -> ColorString -> ColorString
+++
ColorString
"* Timed out: " ColorString -> ColorString -> ColorString
+++ Milliseconds -> ColorString
forall a. Show a => a -> ColorString
showC Milliseconds
timedOut ColorString -> ColorString -> ColorString
+++ ColorString
"\n" ColorString -> ColorString -> ColorString
+++
ColorString
"* Filtered: " ColorString -> ColorString -> ColorString
+++ Milliseconds -> ColorString
forall a. Show a => a -> ColorString
showC Milliseconds
filtered)
Bool -> TR () -> TR ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Milliseconds
timedOut Milliseconds -> Milliseconds -> Bool
forall a. Ord a => a -> a -> Bool
> Milliseconds
0) (TR () -> TR ()) -> TR () -> TR ()
forall a b. (a -> b) -> a -> b
$
if Milliseconds
timedOut Milliseconds -> Milliseconds -> Bool
forall a. Ord a => a -> a -> Bool
< Milliseconds
10
then
ReportLevel -> ColorString -> TR ()
reportTR ReportLevel
Info
(ColorString
"\n" ColorString -> ColorString -> ColorString
+++ String -> ColorString
noColor String
"* Timed out:" ColorString -> ColorString -> ColorString
+++ ColorString
"\n" ColorString -> ColorString -> ColorString
+++ [FlatTestResult] -> ColorString
forall a. [GenFlatTest a] -> ColorString
renderTestNames' ([FlatTestResult] -> [FlatTestResult]
forall a. [a] -> [a]
reverse (ReportGlobalResultsArg -> [FlatTestResult]
rgra_timedOut ReportGlobalResultsArg
arg)))
else
ReportLevel -> ColorString -> TR ()
reportTR ReportLevel
Info
(ColorString
"\n" ColorString -> ColorString -> ColorString
+++ String -> ColorString
noColor String
"* Timed out: (" ColorString -> ColorString -> ColorString
+++ Milliseconds -> ColorString
forall a. Show a => a -> ColorString
showC Milliseconds
timedOut ColorString -> ColorString -> ColorString
+++ String -> ColorString
noColor String
", too many to list)")
Bool -> TR () -> TR ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Milliseconds
filtered Milliseconds -> Milliseconds -> Bool
forall a. Ord a => a -> a -> Bool
> Milliseconds
0) (TR () -> TR ()) -> TR () -> TR ()
forall a b. (a -> b) -> a -> b
$
if Milliseconds
filtered Milliseconds -> Milliseconds -> Bool
forall a. Ord a => a -> a -> Bool
< Milliseconds
10
then
ReportLevel -> ColorString -> TR ()
reportTR ReportLevel
Info
(ColorString
"\n" ColorString -> ColorString -> ColorString
+++ String -> ColorString
noColor String
"* Filtered:" ColorString -> ColorString -> ColorString
+++ ColorString
"\n" ColorString -> ColorString -> ColorString
+++ [FlatTest] -> ColorString
forall a. [GenFlatTest a] -> ColorString
renderTestNames' ([FlatTest] -> [FlatTest]
forall a. [a] -> [a]
reverse (ReportGlobalResultsArg -> [FlatTest]
rgra_filtered ReportGlobalResultsArg
arg)))
else
ReportLevel -> ColorString -> TR ()
reportTR ReportLevel
Info
(ColorString
"\n" ColorString -> ColorString -> ColorString
+++ String -> ColorString
noColor String
"* Filtered: (" ColorString -> ColorString -> ColorString
+++ Milliseconds -> ColorString
forall a. Show a => a -> ColorString
showC Milliseconds
filtered ColorString -> ColorString -> ColorString
+++ String -> ColorString
noColor String
", too many to list)")
Bool -> TR () -> TR ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Milliseconds
pending Milliseconds -> Milliseconds -> Bool
forall a. Ord a => a -> a -> Bool
> Milliseconds
0) (TR () -> TR ()) -> TR () -> TR ()
forall a b. (a -> b) -> a -> b
$
ReportLevel -> ColorString -> TR ()
reportTR ReportLevel
Info
(ColorString
"\n" ColorString -> ColorString -> ColorString
+++ ColorString
pendings ColorString -> ColorString -> ColorString
+++ ColorString
"\n" ColorString -> ColorString -> ColorString
+++ [FlatTestResult] -> ColorString
forall a. [GenFlatTest a] -> ColorString
renderTestNames' ([FlatTestResult] -> [FlatTestResult]
forall a. [a] -> [a]
reverse (ReportGlobalResultsArg -> [FlatTestResult]
rgra_pending ReportGlobalResultsArg
arg)))
Bool -> TR () -> TR ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Milliseconds
failed Milliseconds -> Milliseconds -> Bool
forall a. Ord a => a -> a -> Bool
> Milliseconds
0) (TR () -> TR ()) -> TR () -> TR ()
forall a b. (a -> b) -> a -> b
$
ReportLevel -> ColorString -> TR ()
reportTR ReportLevel
Info
(ColorString
"\n" ColorString -> ColorString -> ColorString
+++ ColorString
failures ColorString -> ColorString -> ColorString
+++ ColorString
"\n" ColorString -> ColorString -> ColorString
+++ [FlatTestResult] -> ColorString
forall a. [GenFlatTest a] -> ColorString
renderTestNames' ([FlatTestResult] -> [FlatTestResult]
forall a. [a] -> [a]
reverse (ReportGlobalResultsArg -> [FlatTestResult]
rgra_failed ReportGlobalResultsArg
arg)))
Bool -> TR () -> TR ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Milliseconds
error Milliseconds -> Milliseconds -> Bool
forall a. Ord a => a -> a -> Bool
> Milliseconds
0) (TR () -> TR ()) -> TR () -> TR ()
forall a b. (a -> b) -> a -> b
$
ReportLevel -> ColorString -> TR ()
reportTR ReportLevel
Info
(ColorString
"\n" ColorString -> ColorString -> ColorString
+++ ColorString
errors ColorString -> ColorString -> ColorString
+++ ColorString
"\n" ColorString -> ColorString -> ColorString
+++ [FlatTestResult] -> ColorString
forall a. [GenFlatTest a] -> ColorString
renderTestNames' ([FlatTestResult] -> [FlatTestResult]
forall a. [a] -> [a]
reverse (ReportGlobalResultsArg -> [FlatTestResult]
rgra_errors ReportGlobalResultsArg
arg)))
ReportLevel -> String -> TR ()
reportStringTR ReportLevel
Info (String
"\nTotal execution time: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Milliseconds -> String
forall a. Show a => a -> String
show (ReportGlobalResultsArg -> Milliseconds
rgra_timeMs ReportGlobalResultsArg
arg) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"ms")
where
showC :: a -> ColorString
showC a
x = String -> ColorString
noColor (a -> String
forall a. Show a => a -> String
show a
x)
renderTestNames' :: [GenFlatTest a] -> ColorString
renderTestNames' [GenFlatTest a]
rrs =
String -> ColorString
noColor (String -> ColorString) -> String -> ColorString
forall a b. (a -> b) -> a -> b
$ Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ Milliseconds -> Doc -> Doc
nest Milliseconds
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [GenFlatTest a] -> Doc
forall a. [GenFlatTest a] -> Doc
renderTestNames [GenFlatTest a]
rrs
renderTestNames :: [GenFlatTest a] -> Doc
renderTestNames :: [GenFlatTest a] -> Doc
renderTestNames [GenFlatTest a]
l =
[Doc] -> Doc
vcat ((GenFlatTest a -> Doc) -> [GenFlatTest a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\GenFlatTest a
ft -> String -> Doc
text String
"*" Doc -> Doc -> Doc
<+>
String -> Doc
text (GenFlatTest a -> String
forall a. GenFlatTest a -> String
humanTestName GenFlatTest a
ft)) [GenFlatTest a]
l)
reportGlobalStartMS :: ReportGlobalStart
reportGlobalStartMS :: ReportAllTests
reportGlobalStartMS [FlatTest]
_ = () -> TR ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
reportTestStartMS :: ReportTestStart
reportTestStartMS :: ReportTestStart
reportTestStartMS FlatTest
ft =
let json :: TestStartEventObj
json = FlatTest -> String -> TestStartEventObj
mkTestStartEventObj FlatTest
ft (TestPath -> String
flatName (FlatTest -> TestPath
forall a. GenFlatTest a -> TestPath
ft_path FlatTest
ft))
in TestStartEventObj -> TR ()
forall a. HTFJsonObj a => a -> TR ()
reportJsonTR TestStartEventObj
json
reportTestResultMS :: ReportTestResult
reportTestResultMS :: ReportTestResult
reportTestResultMS FlatTestResult
ftr =
let json :: TestEndEventObj
json = FlatTestResult -> String -> TestEndEventObj
mkTestEndEventObj FlatTestResult
ftr (TestPath -> String
flatName (FlatTestResult -> TestPath
forall a. GenFlatTest a -> TestPath
ft_path FlatTestResult
ftr))
in TestEndEventObj -> TR ()
forall a. HTFJsonObj a => a -> TR ()
reportJsonTR TestEndEventObj
json
reportGlobalStartMP :: ReportGlobalStart
reportGlobalStartMP :: ReportAllTests
reportGlobalStartMP [FlatTest]
_ = () -> TR ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
reportTestStartMP :: ReportTestStart
reportTestStartMP :: ReportTestStart
reportTestStartMP = ReportTestStart
reportTestStartMS
reportTestResultMP :: ReportTestResult
reportTestResultMP :: ReportTestResult
reportTestResultMP = ReportTestResult
reportTestResultMS
reportAllTestsM :: ReportAllTests
reportAllTestsM :: ReportAllTests
reportAllTestsM [FlatTest]
l =
let json :: TestListObj
json = [(FlatTest, String)] -> TestListObj
mkTestListObj ((FlatTest -> (FlatTest, String))
-> [FlatTest] -> [(FlatTest, String)]
forall a b. (a -> b) -> [a] -> [b]
map (\FlatTest
ft -> (FlatTest
ft, TestPath -> String
flatName (FlatTest -> TestPath
forall a. GenFlatTest a -> TestPath
ft_path FlatTest
ft))) [FlatTest]
l)
in TestListObj -> TR ()
forall a. HTFJsonObj a => a -> TR ()
reportJsonTR TestListObj
json
reportGlobalResultsM :: ReportGlobalResults
reportGlobalResultsM :: ReportGlobalResults
reportGlobalResultsM ReportGlobalResultsArg
arg =
let json :: TestResultsObj
json = ReportGlobalResultsArg -> TestResultsObj
mkTestResultsObj ReportGlobalResultsArg
arg
in TestResultsObj -> TR ()
forall a. HTFJsonObj a => a -> TR ()
reportJsonTR TestResultsObj
json
reportGlobalResultsXml :: ReportGlobalResults
reportGlobalResultsXml :: ReportGlobalResults
reportGlobalResultsXml ReportGlobalResultsArg
arg =
do let xml :: ByteString
xml = ReportGlobalResultsArg -> ByteString
mkGlobalResultsXml ReportGlobalResultsArg
arg
TestConfig
tc <- RWST TestConfig () TestState IO TestConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
case TestConfig -> Maybe String
tc_outputXml TestConfig
tc of
Just String
fname -> IO () -> TR ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TR ()) -> IO () -> TR ()
forall a b. (a -> b) -> a -> b
$ String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
fname IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> Handle -> ByteString -> IO ()
BSL.hPut Handle
h ByteString
xml
Maybe String
Nothing -> IO () -> TR ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TR ()) -> IO () -> TR ()
forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
BSL.putStr ByteString
xml
reportTR :: ReportLevel -> ColorString -> TR ()
reportTR :: ReportLevel -> ColorString -> TR ()
reportTR ReportLevel
level ColorString
msg =
do TestConfig
tc <- RWST TestConfig () TestState IO TestConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
let s :: Text
s = ColorString -> Bool -> Text
renderColorString ColorString
msg (TestConfig -> Bool
tc_useColors TestConfig
tc)
TestConfig -> ReportLevel -> (Handle -> IO ()) -> TR ()
reportGen TestConfig
tc ReportLevel
level (\Handle
h -> Handle -> Text -> IO ()
T.hPutStrLn Handle
h Text
s)
reportStringTR :: ReportLevel -> String -> TR ()
reportStringTR :: ReportLevel -> String -> TR ()
reportStringTR ReportLevel
level String
msg =
do TestConfig
tc <- RWST TestConfig () TestState IO TestConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
TestConfig -> ReportLevel -> (Handle -> IO ()) -> TR ()
reportGen TestConfig
tc ReportLevel
level (\Handle
h -> Handle -> String -> IO ()
hPutStrLn Handle
h String
msg)
reportLazyBytesTR :: ReportLevel -> BSL.ByteString -> TR ()
reportLazyBytesTR :: ReportLevel -> ByteString -> TR ()
reportLazyBytesTR ReportLevel
level ByteString
msg =
do TestConfig
tc <- RWST TestConfig () TestState IO TestConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
TestConfig -> ReportLevel -> (Handle -> IO ()) -> TR ()
reportGen TestConfig
tc ReportLevel
level (\Handle
h -> Handle -> ByteString -> IO ()
BSL.hPut Handle
h ByteString
msg)
reportJsonTR :: HTFJsonObj a => a -> TR ()
reportJsonTR :: a -> TR ()
reportJsonTR a
x = ReportLevel -> ByteString -> TR ()
reportLazyBytesTR ReportLevel
Info (a -> ByteString
forall a. HTFJsonObj a => a -> ByteString
decodeObj a
x)
data ReportLevel = Debug | Info
deriving (ReportLevel -> ReportLevel -> Bool
(ReportLevel -> ReportLevel -> Bool)
-> (ReportLevel -> ReportLevel -> Bool) -> Eq ReportLevel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReportLevel -> ReportLevel -> Bool
$c/= :: ReportLevel -> ReportLevel -> Bool
== :: ReportLevel -> ReportLevel -> Bool
$c== :: ReportLevel -> ReportLevel -> Bool
Eq,Eq ReportLevel
Eq ReportLevel
-> (ReportLevel -> ReportLevel -> Ordering)
-> (ReportLevel -> ReportLevel -> Bool)
-> (ReportLevel -> ReportLevel -> Bool)
-> (ReportLevel -> ReportLevel -> Bool)
-> (ReportLevel -> ReportLevel -> Bool)
-> (ReportLevel -> ReportLevel -> ReportLevel)
-> (ReportLevel -> ReportLevel -> ReportLevel)
-> Ord ReportLevel
ReportLevel -> ReportLevel -> Bool
ReportLevel -> ReportLevel -> Ordering
ReportLevel -> ReportLevel -> ReportLevel
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 :: ReportLevel -> ReportLevel -> ReportLevel
$cmin :: ReportLevel -> ReportLevel -> ReportLevel
max :: ReportLevel -> ReportLevel -> ReportLevel
$cmax :: ReportLevel -> ReportLevel -> ReportLevel
>= :: ReportLevel -> ReportLevel -> Bool
$c>= :: ReportLevel -> ReportLevel -> Bool
> :: ReportLevel -> ReportLevel -> Bool
$c> :: ReportLevel -> ReportLevel -> Bool
<= :: ReportLevel -> ReportLevel -> Bool
$c<= :: ReportLevel -> ReportLevel -> Bool
< :: ReportLevel -> ReportLevel -> Bool
$c< :: ReportLevel -> ReportLevel -> Bool
compare :: ReportLevel -> ReportLevel -> Ordering
$ccompare :: ReportLevel -> ReportLevel -> Ordering
$cp1Ord :: Eq ReportLevel
Ord)
reportGen :: TestConfig -> ReportLevel -> (Handle -> IO ()) -> TR ()
reportGen :: TestConfig -> ReportLevel -> (Handle -> IO ()) -> TR ()
reportGen TestConfig
tc ReportLevel
level Handle -> IO ()
fun =
Bool -> TR () -> TR ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TestConfig -> Bool
tc_quiet TestConfig
tc Bool -> Bool -> Bool
&& ReportLevel
level ReportLevel -> ReportLevel -> Bool
forall a. Ord a => a -> a -> Bool
< ReportLevel
Info) (TR () -> TR ()) -> TR () -> TR ()
forall a b. (a -> b) -> a -> b
$
case TestConfig -> TestOutput
tc_output TestConfig
tc of
TestOutputHandle Handle
h Bool
_ -> IO () -> TR ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> IO ()
fun Handle
h)
TestOutputSplitted String
fp ->
do
Milliseconds
ix <- (TestState -> Milliseconds)
-> RWST TestConfig () TestState IO Milliseconds
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TestState -> Milliseconds
ts_index
let realFp :: String
realFp = String
fp String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Milliseconds -> String
forall a. Show a => a -> String
show Milliseconds
ix)
(TestState -> TestState) -> TR ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\TestState
x -> TestState
x { ts_index :: Milliseconds
ts_index = TestState -> Milliseconds
ts_index TestState
x Milliseconds -> Milliseconds -> Milliseconds
forall a. Num a => a -> a -> a
+ Milliseconds
1 })
IO () -> TR ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TR ()) -> IO () -> TR ()
forall a b. (a -> b) -> a -> b
$ String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
realFp IOMode
WriteMode Handle -> IO ()
fun