{-# LANGUAGE OverloadedStrings #-}
--
-- Copyright (c) 2005-2022   Stefan Wehr - http://www.stefanwehr.de
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
--
{-|

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
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
           { tr_id :: [Char]
tr_id = [Char]
"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
           { tr_id :: [Char]
tr_id = [Char]
"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
           { tr_id :: [Char]
tr_id = [Char]
"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
           { tr_id :: [Char]
tr_id = [Char]
"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 -> [([Char] -> TestReporter
emptyTestReporter [Char]
"rep_xml") {
                            tr_reportGlobalResults = reportGlobalResultsXml
                          }]

--
-- output for humans
--

humanTestName :: GenFlatTest a -> String
humanTestName :: forall a. GenFlatTest a -> [Char]
humanTestName GenFlatTest a
ft =
    TestPath -> [Char]
flatName (GenFlatTest a -> TestPath
forall a. GenFlatTest a -> TestPath
ft_path GenFlatTest a
ft) [Char] -> [Char] -> [Char]
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 -> [Char]
""
      Just Location
loc -> [Char]
" (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Location -> [Char]
showLoc Location
loc [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"

reportHumanTestStartMessage :: ReportLevel -> GenFlatTest a -> TR ()
reportHumanTestStartMessage :: forall a. ReportLevel -> GenFlatTest a -> TR ()
reportHumanTestStartMessage ReportLevel
level GenFlatTest a
ft =
    do let t :: ColorString
t = Color -> [Char] -> ColorString
colorize Color
testStartColor [Char]
"[TEST] "
       ReportLevel -> ColorString -> TR ()
reportTR ReportLevel
level (ColorString
t ColorString -> ColorString -> ColorString
+++ [Char] -> ColorString
noColor (GenFlatTest a -> [Char]
forall a. GenFlatTest a -> [Char]
humanTestName GenFlatTest a
ft))

-- sequential
reportGlobalStartHS :: ReportGlobalStart
reportGlobalStartHS :: ReportAllTests
reportGlobalStartHS [FlatTest]
_ = () -> TR ()
forall a. a -> RWST TestConfig () TestState IO a
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 -> HtfStack -> ColorString
attachCallStack (RunResult -> ColorString
rr_message (FlatTestResult -> RunResult
forall a. GenFlatTest a -> a
ft_payload FlatTestResult
ftr)) (RunResult -> HtfStack
rr_stack (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
+++ [Char] -> ColorString
noColor [Char]
timeStr)
     timeStr :: [Char]
timeStr = [Char]
" (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (RunResult -> Int
rr_wallTimeMs (FlatTestResult -> RunResult
forall a. GenFlatTest a -> a
ft_payload FlatTestResult
ftr)) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"ms)\n"
     failureSuffix :: ColorString
failureSuffix = Color -> [Char] -> ColorString
colorize Color
warningColor [Char]
"*** Failed!"
     errorSuffix :: ColorString
errorSuffix = Color -> [Char] -> ColorString
colorize Color
warningColor [Char]
"@@@ Error!"
     pendingSuffix :: ColorString
pendingSuffix = Color -> [Char] -> ColorString
colorize Color
pendingColor [Char]
"^^^ Pending!"
     okSuffix :: ColorString
okSuffix = Color -> [Char] -> ColorString
colorize Color
testOkColor  [Char]
"+++ OK"

-- parallel
reportGlobalStartHP :: ReportGlobalStart
reportGlobalStartHP :: ReportAllTests
reportGlobalStartHP [FlatTest]
_ = () -> TR ()
forall a. a -> RWST TestConfig () TestState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

reportTestStartHP :: ReportTestStart
reportTestStartHP :: ReportTestStart
reportTestStartHP FlatTest
ft =
     do ReportLevel -> [Char] -> TR ()
reportStringTR ReportLevel
Debug ([Char]
"Starting " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (FlatTest -> [Char]
forall a. GenFlatTest a -> [Char]
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 -> [Char] -> TR ()
reportStringTR ReportLevel
Info (Doc -> [Char]
render ([FlatTest] -> Doc
forall a. [GenFlatTest a] -> Doc
renderTestNames [FlatTest]
l))

reportGlobalResultsH :: ReportGlobalResults
reportGlobalResultsH :: ReportGlobalResults
reportGlobalResultsH ReportGlobalResultsArg
arg =
    do let passed :: Int
passed = [FlatTestResult] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ReportGlobalResultsArg -> [FlatTestResult]
rgra_passed ReportGlobalResultsArg
arg)
           pending :: Int
pending = [FlatTestResult] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ReportGlobalResultsArg -> [FlatTestResult]
rgra_pending ReportGlobalResultsArg
arg)
           failed :: Int
failed = [FlatTestResult] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ReportGlobalResultsArg -> [FlatTestResult]
rgra_failed ReportGlobalResultsArg
arg)
           error :: Int
error = [FlatTestResult] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ReportGlobalResultsArg -> [FlatTestResult]
rgra_errors ReportGlobalResultsArg
arg)
           timedOut :: Int
timedOut = [FlatTestResult] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ReportGlobalResultsArg -> [FlatTestResult]
rgra_timedOut ReportGlobalResultsArg
arg)
           filtered :: Int
filtered = [FlatTest] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ReportGlobalResultsArg -> [FlatTest]
rgra_filtered ReportGlobalResultsArg
arg)
           total :: Int
total = Int
passed Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
failed Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
error Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
pending
       let pendings :: ColorString
pendings = (if Int
pending Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Color -> [Char] -> ColorString
colorize Color
pendingColor else [Char] -> ColorString
noColor) [Char]
"* Pending:"
           failures :: ColorString
failures = (if Int
failed Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Color -> [Char] -> ColorString
colorize Color
warningColor else [Char] -> ColorString
noColor) [Char]
"* Failures:"
           errors :: ColorString
errors = (if Int
error Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Color -> [Char] -> ColorString
colorize Color
warningColor else [Char] -> ColorString
noColor) [Char]
"* Errors:"
       ReportLevel -> ColorString -> TR ()
reportTR ReportLevel
Info (ColorString
"* Tests:     " ColorString -> ColorString -> ColorString
+++ Int -> ColorString
forall {a}. Show a => a -> ColorString
showC Int
total ColorString -> ColorString -> ColorString
+++ ColorString
"\n" ColorString -> ColorString -> ColorString
+++
                      ColorString
"* Passed:    " ColorString -> ColorString -> ColorString
+++ Int -> ColorString
forall {a}. Show a => a -> ColorString
showC Int
passed ColorString -> ColorString -> ColorString
+++ ColorString
"\n" ColorString -> ColorString -> ColorString
+++
                      ColorString
pendings ColorString -> ColorString -> ColorString
+++ ColorString
"   " ColorString -> ColorString -> ColorString
+++ Int -> ColorString
forall {a}. Show a => a -> ColorString
showC Int
pending ColorString -> ColorString -> ColorString
+++ ColorString
"\n" ColorString -> ColorString -> ColorString
+++
                      ColorString
failures ColorString -> ColorString -> ColorString
+++ ColorString
"  " ColorString -> ColorString -> ColorString
+++ Int -> ColorString
forall {a}. Show a => a -> ColorString
showC Int
failed ColorString -> ColorString -> ColorString
+++ ColorString
"\n" ColorString -> ColorString -> ColorString
+++
                      ColorString
errors ColorString -> ColorString -> ColorString
+++ ColorString
"    " ColorString -> ColorString -> ColorString
+++ Int -> ColorString
forall {a}. Show a => a -> ColorString
showC Int
error ColorString -> ColorString -> ColorString
+++ ColorString
"\n" ColorString -> ColorString -> ColorString
+++
                      ColorString
"* Timed out: " ColorString -> ColorString -> ColorString
+++ Int -> ColorString
forall {a}. Show a => a -> ColorString
showC Int
timedOut ColorString -> ColorString -> ColorString
+++ ColorString
"\n" ColorString -> ColorString -> ColorString
+++
                      ColorString
"* Filtered:  " ColorString -> ColorString -> ColorString
+++ Int -> ColorString
forall {a}. Show a => a -> ColorString
showC Int
filtered)
       Bool -> TR () -> TR ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
timedOut Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (TR () -> TR ()) -> TR () -> TR ()
forall a b. (a -> b) -> a -> b
$
            if Int
timedOut Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
10
            then
                ReportLevel -> ColorString -> TR ()
reportTR ReportLevel
Info
                    (ColorString
"\n" ColorString -> ColorString -> ColorString
+++ [Char] -> ColorString
noColor [Char]
"* 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
+++ [Char] -> ColorString
noColor [Char]
"* Timed out: (" ColorString -> ColorString -> ColorString
+++ Int -> ColorString
forall {a}. Show a => a -> ColorString
showC Int
timedOut ColorString -> ColorString -> ColorString
+++ [Char] -> ColorString
noColor [Char]
", too many to list)")
       Bool -> TR () -> TR ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
filtered Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (TR () -> TR ()) -> TR () -> TR ()
forall a b. (a -> b) -> a -> b
$
            if Int
filtered Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
10
            then
                ReportLevel -> ColorString -> TR ()
reportTR ReportLevel
Info
                  (ColorString
"\n" ColorString -> ColorString -> ColorString
+++ [Char] -> ColorString
noColor [Char]
"* 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
+++ [Char] -> ColorString
noColor [Char]
"* Filtered: (" ColorString -> ColorString -> ColorString
+++ Int -> ColorString
forall {a}. Show a => a -> ColorString
showC Int
filtered ColorString -> ColorString -> ColorString
+++ [Char] -> ColorString
noColor [Char]
", too many to list)")
       Bool -> TR () -> TR ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
pending Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
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 (Int
failed Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
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 (Int
error Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
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 -> [Char] -> TR ()
reportStringTR ReportLevel
Info ([Char]
"\nTotal execution time: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (ReportGlobalResultsArg -> Int
rgra_timeMs ReportGlobalResultsArg
arg) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"ms")
    where
      showC :: a -> ColorString
showC a
x = [Char] -> ColorString
noColor (a -> [Char]
forall a. Show a => a -> [Char]
show a
x)
      renderTestNames' :: [GenFlatTest a] -> ColorString
renderTestNames' [GenFlatTest a]
rrs =
          [Char] -> ColorString
noColor ([Char] -> ColorString) -> [Char] -> ColorString
forall a b. (a -> b) -> a -> b
$ Doc -> [Char]
render (Doc -> [Char]) -> Doc -> [Char]
forall a b. (a -> b) -> a -> b
$ Int -> Doc -> Doc
nest Int
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 :: forall a. [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 -> [Char] -> Doc
text [Char]
"*" Doc -> Doc -> Doc
<+>
                      [Char] -> Doc
text (GenFlatTest a -> [Char]
forall a. GenFlatTest a -> [Char]
humanTestName GenFlatTest a
ft)) [GenFlatTest a]
l)

--
-- output for machines
--

-- sequential
reportGlobalStartMS :: ReportGlobalStart
reportGlobalStartMS :: ReportAllTests
reportGlobalStartMS [FlatTest]
_ = () -> TR ()
forall a. a -> RWST TestConfig () TestState IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

reportTestStartMS :: ReportTestStart
reportTestStartMS :: ReportTestStart
reportTestStartMS FlatTest
ft =
    let json :: TestStartEventObj
json = FlatTest -> [Char] -> TestStartEventObj
mkTestStartEventObj FlatTest
ft (TestPath -> [Char]
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 -> [Char] -> TestEndEventObj
mkTestEndEventObj FlatTestResult
ftr (TestPath -> [Char]
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 a. a -> RWST TestConfig () TestState IO a
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, [Char])] -> TestListObj
mkTestListObj ((FlatTest -> (FlatTest, [Char]))
-> [FlatTest] -> [(FlatTest, [Char])]
forall a b. (a -> b) -> [a] -> [b]
map (\FlatTest
ft -> (FlatTest
ft, TestPath -> [Char]
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 [Char]
tc_outputXml TestConfig
tc of
         Just [Char]
fname -> IO () -> TR ()
forall a. IO a -> RWST TestConfig () TestState IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TR ()) -> IO () -> TR ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withFile [Char]
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 [Char]
Nothing -> IO () -> TR ()
forall a. IO a -> RWST TestConfig () TestState IO a
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 -> [Char] -> TR ()
reportStringTR ReportLevel
level [Char]
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 -> [Char] -> IO ()
hPutStrLn Handle
h [Char]
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 :: forall a. HTFJsonObj a => 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
$c== :: ReportLevel -> ReportLevel -> Bool
== :: ReportLevel -> ReportLevel -> Bool
$c/= :: ReportLevel -> ReportLevel -> Bool
/= :: 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
$ccompare :: ReportLevel -> ReportLevel -> Ordering
compare :: ReportLevel -> ReportLevel -> Ordering
$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
>= :: ReportLevel -> ReportLevel -> Bool
$cmax :: ReportLevel -> ReportLevel -> ReportLevel
max :: ReportLevel -> ReportLevel -> ReportLevel
$cmin :: ReportLevel -> ReportLevel -> ReportLevel
min :: ReportLevel -> ReportLevel -> 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 a. IO a -> RWST TestConfig () TestState IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> IO ()
fun Handle
h)
      TestOutputSplitted [Char]
fp ->
          do -- split mode: one file for each result to avoid locking on windows
             Int
ix <- (TestState -> Int) -> RWST TestConfig () TestState IO Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets TestState -> Int
ts_index
             let realFp :: [Char]
realFp = [Char]
fp [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
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 = ts_index x + 1 })
             IO () -> TR ()
forall a. IO a -> RWST TestConfig () TestState IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TR ()) -> IO () -> TR ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. [Char] -> IOMode -> (Handle -> IO r) -> IO r
withFile [Char]
realFp IOMode
WriteMode Handle -> IO ()
fun