{-# LANGUAGE OverloadedStrings #-}
{-|

This module defines functions for notifying all test reporters registered about
particular events in the lifecycle of a test run.

Further, it defines the standard test reporters for HTF's various output formats.

-}
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

-- | Invokes 'tr_reportAllTests' on all test reporters registered.
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

-- | Invokes 'tr_reportGlobalStart' on all test reporters registered.
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

-- | Invokes 'tr_reportTestStart' on all test reporters registered.
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

-- | Invokes 'tr_reportTestResult' on all test reporters registered.
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

-- | Invokes 'tr_reportGlobalResults' on all test reporters registered.
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

-- | The default test reporters for HTF.
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
                          }]

--
-- output for humans
--

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

-- sequential
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"

-- parallel
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

-- results and all tests
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)

--
-- output for machines
--

-- sequential
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

-- parallel
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

-- results and all tests
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

--
-- General reporting routines
--

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 -- split mode: one file for each result to avoid locking on windows
             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) -- just append the index at the end of the file given as output parameter
             (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