{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Test.Framework.XmlOutput (
mkGlobalResultsXml
) where
import qualified Data.ByteString.Lazy as BSL
import qualified Data.List as List
#ifndef MIN_VERSION_containers
#define MIN_VERSION_containers(a,b,c) 1
#endif
#if MIN_VERSION_containers(0,5,0)
import qualified Data.Map.Strict as Map
#else
import qualified Data.Map as Map
#endif
import qualified Data.Text as T
import Text.Printf
import Text.XML.Generator
import Test.Framework.TestTypes
import Test.Framework.Colors
data JunitXmlOutput = JunitXmlOutput Testsuites
type Seconds = Double
data Testsuites
= Testsuites
{ Testsuites -> Int
tss_tests :: Int
, Testsuites -> Int
tss_failures :: Int
, Testsuites -> Int
tss_errors :: Int
, Testsuites -> Seconds
tss_time :: Seconds
, Testsuites -> [Testsuite]
tss_suites :: [Testsuite] }
data Testsuite
= Testsuite
{ Testsuite -> Int
ts_tests :: Int
, Testsuite -> Int
ts_failures :: Int
, Testsuite -> Int
ts_errors :: Int
, Testsuite -> Seconds
ts_time :: Seconds
, Testsuite -> Int
ts_id :: Int
, Testsuite -> String
ts_name :: String
, Testsuite -> String
ts_package :: String
, Testsuite -> [Testcase]
ts_testcases :: [Testcase] }
data Testcase
= Testcase
{ Testcase -> String
tc_classname :: String
, Testcase -> String
tc_name :: String
, Testcase -> Seconds
tc_time :: Seconds
, Testcase -> Maybe Result
tc_result :: Maybe Result }
data Result
= Result
{ Result -> String
r_elemName :: String
, Result -> Text
r_message :: T.Text
, Result -> String
r_type :: String
, Result -> Text
r_textContent :: T.Text }
renderAsXml :: JunitXmlOutput -> BSL.ByteString
renderAsXml :: JunitXmlOutput -> ByteString
renderAsXml (JunitXmlOutput Testsuites
suites) =
Xml Doc -> ByteString
forall r t. (Renderable r, XmlOutput t) => Xml r -> t
xrender (Xml Doc -> ByteString) -> Xml Doc -> ByteString
forall a b. (a -> b) -> a -> b
$
DocInfo -> Xml Elem -> Xml Doc
doc DocInfo
defaultDocInfo (Xml Elem -> Xml Doc) -> Xml Elem -> Xml Doc
forall a b. (a -> b) -> a -> b
$
Text -> (Xml Attr, [Xml Elem]) -> Xml Elem
forall c. AddChildren c => Text -> c -> Xml Elem
xelem Text
"testsuites" ((Xml Attr, [Xml Elem]) -> Xml Elem)
-> (Xml Attr, [Xml Elem]) -> Xml Elem
forall a b. (a -> b) -> a -> b
$
Text -> Text -> Xml Attr
xattr Text
"tests" (Int -> Text
showT (Testsuites -> Int
tss_tests Testsuites
suites)) Xml Attr -> Xml Attr -> Xml Attr
forall a. Semigroup a => a -> a -> a
<>
Text -> Text -> Xml Attr
xattr Text
"failures" (Int -> Text
showT (Testsuites -> Int
tss_failures Testsuites
suites)) Xml Attr -> Xml Attr -> Xml Attr
forall a. Semigroup a => a -> a -> a
<>
Text -> Text -> Xml Attr
xattr Text
"errors" (Int -> Text
showT (Testsuites -> Int
tss_errors Testsuites
suites)) Xml Attr -> Xml Attr -> Xml Attr
forall a. Semigroup a => a -> a -> a
<>
Text -> Text -> Xml Attr
xattr Text
"time" (Seconds -> Text
showTime (Testsuites -> Seconds
tss_time Testsuites
suites)) Xml Attr -> [Xml Elem] -> (Xml Attr, [Xml Elem])
forall a b. a -> b -> (a, b)
<#>
((Testsuite -> Xml Elem) -> [Testsuite] -> [Xml Elem]
forall a b. (a -> b) -> [a] -> [b]
map Testsuite -> Xml Elem
testsuiteXml (Testsuites -> [Testsuite]
tss_suites Testsuites
suites))
where
testsuiteXml :: Testsuite -> Xml Elem
testsuiteXml Testsuite
suite =
Text -> (Xml Attr, [Xml Elem]) -> Xml Elem
forall c. AddChildren c => Text -> c -> Xml Elem
xelem Text
"testsuite" ((Xml Attr, [Xml Elem]) -> Xml Elem)
-> (Xml Attr, [Xml Elem]) -> Xml Elem
forall a b. (a -> b) -> a -> b
$
Text -> Text -> Xml Attr
xattr Text
"id" (Int -> Text
showT (Testsuite -> Int
ts_id Testsuite
suite)) Xml Attr -> Xml Attr -> Xml Attr
forall a. Semigroup a => a -> a -> a
<>
Text -> Text -> Xml Attr
xattr Text
"tests" (Int -> Text
showT (Testsuite -> Int
ts_tests Testsuite
suite)) Xml Attr -> Xml Attr -> Xml Attr
forall a. Semigroup a => a -> a -> a
<>
Text -> Text -> Xml Attr
xattr Text
"failures" (Int -> Text
showT (Testsuite -> Int
ts_failures Testsuite
suite)) Xml Attr -> Xml Attr -> Xml Attr
forall a. Semigroup a => a -> a -> a
<>
Text -> Text -> Xml Attr
xattr Text
"errors" (Int -> Text
showT (Testsuite -> Int
ts_errors Testsuite
suite)) Xml Attr -> Xml Attr -> Xml Attr
forall a. Semigroup a => a -> a -> a
<>
Text -> Text -> Xml Attr
xattr Text
"time" (Seconds -> Text
showTime (Testsuite -> Seconds
ts_time Testsuite
suite)) Xml Attr -> Xml Attr -> Xml Attr
forall a. Semigroup a => a -> a -> a
<>
Text -> Text -> Xml Attr
xattr Text
"name" (String -> Text
T.pack (Testsuite -> String
ts_name Testsuite
suite)) Xml Attr -> Xml Attr -> Xml Attr
forall a. Semigroup a => a -> a -> a
<>
Text -> Text -> Xml Attr
xattr Text
"package" (String -> Text
T.pack (Testsuite -> String
ts_package Testsuite
suite)) Xml Attr -> [Xml Elem] -> (Xml Attr, [Xml Elem])
forall a b. a -> b -> (a, b)
<#>
((Testcase -> Xml Elem) -> [Testcase] -> [Xml Elem]
forall a b. (a -> b) -> [a] -> [b]
map Testcase -> Xml Elem
testcaseXml (Testsuite -> [Testcase]
ts_testcases Testsuite
suite))
testcaseXml :: Testcase -> Xml Elem
testcaseXml Testcase
tc =
Text -> (Xml Attr, Xml Elem) -> Xml Elem
forall c. AddChildren c => Text -> c -> Xml Elem
xelem Text
"testcase" ((Xml Attr, Xml Elem) -> Xml Elem)
-> (Xml Attr, Xml Elem) -> Xml Elem
forall a b. (a -> b) -> a -> b
$
Text -> Text -> Xml Attr
xattr Text
"classname" (String -> Text
T.pack (Testcase -> String
tc_classname Testcase
tc)) Xml Attr -> Xml Attr -> Xml Attr
forall a. Semigroup a => a -> a -> a
<>
Text -> Text -> Xml Attr
xattr Text
"name" (String -> Text
T.pack (Testcase -> String
tc_name Testcase
tc)) Xml Attr -> Xml Attr -> Xml Attr
forall a. Semigroup a => a -> a -> a
<>
Text -> Text -> Xml Attr
xattr Text
"time" (Seconds -> Text
showTime (Testcase -> Seconds
tc_time Testcase
tc)) Xml Attr -> Xml Elem -> (Xml Attr, Xml Elem)
forall a b. a -> b -> (a, b)
<#>
Maybe Result -> Xml Elem
resultXml (Testcase -> Maybe Result
tc_result Testcase
tc)
resultXml :: Maybe Result -> Xml Elem
resultXml Maybe Result
Nothing = Xml Elem
forall t. Renderable t => Xml t
xempty
resultXml (Just Result
res) =
Text -> (Xml Attr, Xml Elem) -> Xml Elem
forall c. AddChildren c => Text -> c -> Xml Elem
xelem (String -> Text
T.pack (Result -> String
r_elemName Result
res)) ((Xml Attr, Xml Elem) -> Xml Elem)
-> (Xml Attr, Xml Elem) -> Xml Elem
forall a b. (a -> b) -> a -> b
$
Text -> Text -> Xml Attr
xattr Text
"type" (String -> Text
T.pack (Result -> String
r_type Result
res)) Xml Attr -> Xml Attr -> Xml Attr
forall a. Semigroup a => a -> a -> a
<>
Text -> Text -> Xml Attr
xattr Text
"message" (Result -> Text
r_message Result
res) Xml Attr -> Xml Elem -> (Xml Attr, Xml Elem)
forall a b. a -> b -> (a, b)
<#>
Text -> Xml Elem
xtext (Result -> Text
r_textContent Result
res)
showT :: Int -> Text
showT = String -> Text
T.pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show
showTime :: Seconds -> Text
showTime = String -> Text
T.pack (String -> Text) -> (Seconds -> String) -> Seconds -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Seconds -> String
forall r. PrintfType r => String -> r
printf String
"%.3f"
groupByModule :: [FlatTestResult] -> [(String, [FlatTestResult])]
groupByModule :: [FlatTestResult] -> [(String, [FlatTestResult])]
groupByModule [FlatTestResult]
l =
let m :: Map String [FlatTestResult]
m = (Map String [FlatTestResult]
-> FlatTestResult -> Map String [FlatTestResult])
-> Map String [FlatTestResult]
-> [FlatTestResult]
-> Map String [FlatTestResult]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (\Map String [FlatTestResult]
m FlatTestResult
r -> ([FlatTestResult] -> [FlatTestResult] -> [FlatTestResult])
-> String
-> [FlatTestResult]
-> Map String [FlatTestResult]
-> Map String [FlatTestResult]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [FlatTestResult] -> [FlatTestResult] -> [FlatTestResult]
forall a. [a] -> [a] -> [a]
(++) (TestPath -> String
prefixName (FlatTestResult -> TestPath
forall a. GenFlatTest a -> TestPath
ft_path FlatTestResult
r)) [FlatTestResult
r] Map String [FlatTestResult]
m) Map String [FlatTestResult]
forall k a. Map k a
Map.empty [FlatTestResult]
l
in Map String [FlatTestResult] -> [(String, [FlatTestResult])]
forall k a. Map k a -> [(k, a)]
Map.toList Map String [FlatTestResult]
m
mkTestSuite :: (Int, (String, [FlatTestResult])) -> Testsuite
mkTestSuite :: (Int, (String, [FlatTestResult])) -> Testsuite
mkTestSuite (Int
id, (String
modName, [FlatTestResult]
results)) =
Testsuite :: Int
-> Int
-> Int
-> Seconds
-> Int
-> String
-> String
-> [Testcase]
-> Testsuite
Testsuite
{ ts_tests :: Int
ts_tests = Int
nTests
, ts_failures :: Int
ts_failures = Int
nFailures
, ts_errors :: Int
ts_errors = Int
nErrors
, ts_time :: Seconds
ts_time = Int -> Seconds
millisToSeconds Int
millis
, ts_id :: Int
ts_id = Int
id
, ts_name :: String
ts_name = String
modName
, ts_package :: String
ts_package = String
modName
, ts_testcases :: [Testcase]
ts_testcases = (FlatTestResult -> Testcase) -> [FlatTestResult] -> [Testcase]
forall a b. (a -> b) -> [a] -> [b]
map FlatTestResult -> Testcase
mkTestCase [FlatTestResult]
results }
where
(Int
nTests, Int
nFailures, Int
nErrors, Int
millis) =
((Int, Int, Int, Int) -> FlatTestResult -> (Int, Int, Int, Int))
-> (Int, Int, Int, Int) -> [FlatTestResult] -> (Int, Int, Int, Int)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (\(Int
t, Int
f, Int
e, Int
m) FlatTestResult
r -> (Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
f Int -> Int -> Int
forall a. Num a => a -> a -> a
+ FlatTestResult -> Int
forall p. Num p => FlatTestResult -> p
failureInc FlatTestResult
r, Int
e Int -> Int -> Int
forall a. Num a => a -> a -> a
+ FlatTestResult -> Int
forall p. Num p => FlatTestResult -> p
errorInc FlatTestResult
r,
Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (RunResult -> Int
rr_wallTimeMs (RunResult -> Int)
-> (FlatTestResult -> RunResult) -> FlatTestResult -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlatTestResult -> RunResult
forall a. GenFlatTest a -> a
ft_payload) FlatTestResult
r))
(Int
0, Int
0, Int
0, Int
0) [FlatTestResult]
results
failureInc :: FlatTestResult -> p
failureInc FlatTestResult
r = if FlatTestResult -> Bool
isFailure FlatTestResult
r then p
1 else p
0
errorInc :: FlatTestResult -> p
errorInc FlatTestResult
r = if FlatTestResult -> Bool
isError FlatTestResult
r then p
1 else p
0
isFailure :: FlatTestResult -> Bool
isFailure :: FlatTestResult -> Bool
isFailure FlatTestResult
r = TestResult
Fail TestResult -> TestResult -> Bool
forall a. Eq a => a -> a -> Bool
== (RunResult -> TestResult
rr_result (RunResult -> TestResult)
-> (FlatTestResult -> RunResult) -> FlatTestResult -> TestResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlatTestResult -> RunResult
forall a. GenFlatTest a -> a
ft_payload) FlatTestResult
r
isError :: FlatTestResult -> Bool
isError :: FlatTestResult -> Bool
isError FlatTestResult
r = TestResult
Error TestResult -> TestResult -> Bool
forall a. Eq a => a -> a -> Bool
== (RunResult -> TestResult
rr_result (RunResult -> TestResult)
-> (FlatTestResult -> RunResult) -> FlatTestResult -> TestResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlatTestResult -> RunResult
forall a. GenFlatTest a -> a
ft_payload) FlatTestResult
r
mkTestCase :: FlatTestResult -> Testcase
mkTestCase :: FlatTestResult -> Testcase
mkTestCase FlatTestResult
r =
Testcase :: String -> String -> Seconds -> Maybe Result -> Testcase
Testcase
{ tc_classname :: String
tc_classname = String
modName
, tc_name :: String
tc_name = String
simpleName
, tc_time :: Seconds
tc_time = Int -> Seconds
millisToSeconds (RunResult -> Int
rr_wallTimeMs RunResult
payload)
, tc_result :: Maybe Result
tc_result = Maybe Result
result }
where
payload :: RunResult
payload = FlatTestResult -> RunResult
forall a. GenFlatTest a -> a
ft_payload FlatTestResult
r
simpleName :: String
simpleName = String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ TestPath -> String
finalName (FlatTestResult -> TestPath
forall a. GenFlatTest a -> TestPath
ft_path FlatTestResult
r)
modName :: String
modName = TestPath -> String
prefixName (FlatTestResult -> TestPath
forall a. GenFlatTest a -> TestPath
ft_path FlatTestResult
r)
prefix :: String
prefix = case FlatTestResult -> TestSort
forall a. GenFlatTest a -> TestSort
ft_sort FlatTestResult
r of
TestSort
UnitTest -> String
"test_"
TestSort
QuickCheckTest -> String
"prop_"
TestSort
BlackBoxTest -> String
"bbt_"
result :: Maybe Result
result =
if FlatTestResult -> Bool
isFailure FlatTestResult
r
then Result -> Maybe Result
forall a. a -> Maybe a
Just (String -> Result
mkResult String
"failure")
else if FlatTestResult -> Bool
isError FlatTestResult
r
then Result -> Maybe Result
forall a. a -> Maybe a
Just (String -> Result
mkResult String
"error")
else Maybe Result
forall a. Maybe a
Nothing
mkResult :: String -> Result
mkResult String
elemName =
Result :: String -> Text -> String -> Text -> Result
Result
{ r_elemName :: String
r_elemName = String
elemName
, r_message :: Text
r_message = (Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') Text
msg
, r_type :: String
r_type = String
elemName
, r_textContent :: Text
r_textContent = Text
msg }
msg :: Text
msg = ColorString -> Bool -> Text
renderColorString (ColorString -> CallStack -> ColorString
attachCallStack (RunResult -> ColorString
rr_message RunResult
payload) (RunResult -> CallStack
rr_callers RunResult
payload)) Bool
False
millisToSeconds :: Milliseconds -> Seconds
millisToSeconds :: Int -> Seconds
millisToSeconds Int
millis =
Integer -> Seconds
forall a. Num a => Integer -> a
fromInteger (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
millis) Seconds -> Seconds -> Seconds
forall a. Fractional a => a -> a -> a
/ Seconds
1000.0
mkGlobalResultsXml :: ReportGlobalResultsArg -> BSL.ByteString
mkGlobalResultsXml :: ReportGlobalResultsArg -> ByteString
mkGlobalResultsXml ReportGlobalResultsArg
arg =
let nPassed :: Int
nPassed = [FlatTestResult] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ReportGlobalResultsArg -> [FlatTestResult]
rgra_passed ReportGlobalResultsArg
arg)
nPending :: Int
nPending = [FlatTestResult] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ReportGlobalResultsArg -> [FlatTestResult]
rgra_pending ReportGlobalResultsArg
arg)
nFailed :: Int
nFailed = [FlatTestResult] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ReportGlobalResultsArg -> [FlatTestResult]
rgra_failed ReportGlobalResultsArg
arg)
nErrors :: Int
nErrors = [FlatTestResult] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ReportGlobalResultsArg -> [FlatTestResult]
rgra_errors ReportGlobalResultsArg
arg)
byModules :: [(String, [FlatTestResult])]
byModules = [FlatTestResult] -> [(String, [FlatTestResult])]
groupByModule (ReportGlobalResultsArg -> [FlatTestResult]
rgra_passed ReportGlobalResultsArg
arg [FlatTestResult] -> [FlatTestResult] -> [FlatTestResult]
forall a. [a] -> [a] -> [a]
++ ReportGlobalResultsArg -> [FlatTestResult]
rgra_pending ReportGlobalResultsArg
arg [FlatTestResult] -> [FlatTestResult] -> [FlatTestResult]
forall a. [a] -> [a] -> [a]
++
ReportGlobalResultsArg -> [FlatTestResult]
rgra_failed ReportGlobalResultsArg
arg [FlatTestResult] -> [FlatTestResult] -> [FlatTestResult]
forall a. [a] -> [a] -> [a]
++ ReportGlobalResultsArg -> [FlatTestResult]
rgra_errors ReportGlobalResultsArg
arg)
suites :: [Testsuite]
suites = ((Int, (String, [FlatTestResult])) -> Testsuite)
-> [(Int, (String, [FlatTestResult]))] -> [Testsuite]
forall a b. (a -> b) -> [a] -> [b]
map (Int, (String, [FlatTestResult])) -> Testsuite
mkTestSuite ([Int]
-> [(String, [FlatTestResult])]
-> [(Int, (String, [FlatTestResult]))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [(String, [FlatTestResult])]
byModules)
root :: Testsuites
root = Testsuites :: Int -> Int -> Int -> Seconds -> [Testsuite] -> Testsuites
Testsuites
{ tss_tests :: Int
tss_tests = Int
nPassed Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nPending Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nFailed Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nErrors
, tss_failures :: Int
tss_failures = Int
nFailed
, tss_errors :: Int
tss_errors = Int
nErrors
, tss_time :: Seconds
tss_time = Int -> Seconds
millisToSeconds (ReportGlobalResultsArg -> Int
rgra_timeMs ReportGlobalResultsArg
arg)
, tss_suites :: [Testsuite]
tss_suites = [Testsuite]
suites }
in JunitXmlOutput -> ByteString
renderAsXml (Testsuites -> JunitXmlOutput
JunitXmlOutput Testsuites
root)