HTF-0.15.0.0: Test/Framework/XmlOutput.hs
{-# LANGUAGE CPP #-}
--
-- 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
--
{- |
XML-output following the JUnit output format.
The data types exposed by this module give a rough specification of
the output format.
Here is a sample ouput:
@
\<?xml version="1.0" encoding="UTF-8" standalone="yes"?\>
\<testsuites tests="6" failures="2" errors="0" time="0.705"\>
\<testsuite id="0" tests="2" failures="0" errors="0" time="0.000" name="MyPkg.A" package="MyPkg.A"\>
\<testcase classname="MyPkg.A" name="test_funA2" time="0.000"/\>
\<testcase classname="MyPkg.A" name="test_funA1" time="0.000"/\>
\</testsuite\>
\<testsuite id="1" tests="2" failures="0" errors="0" time="0.000" name="MyPkg.B" package="MyPkg.B"\>
\<testcase classname="MyPkg.B" name="test_funB2" time="0.000"/\>
\<testcase classname="MyPkg.B" name="test_funB1" time="0.000"/\>
\</testsuite\>
\<testsuite id="2" tests="2" failures="2" errors="0" time="0.703" name="bbts" package="bbts"\>
\<testcase classname="bbts" name="bbt_bbt-dir/should-pass/x.num" time="0.230"\>
\<failure type="failure" message="test is supposed to succeed but failed with exit code 255"\>test is supposed to succeed but failed with exit code 255\</failure\>
\</testcase\>
\<testcase classname="bbts" name="bbt_bbt-dir/should-fail/z.num" time="0.473"\>
\<failure type="failure" message="Mismatch on stderr:"\>Mismatch on stderr:
--- bbt-dir/should-fail/z.err 2015-09-05 18:37:30.000000000 +0200
+++ - 2022-03-06 09:49:55.480265000 +0100
\@\@ -1 +1 \@\@
-invalid input
+sample[88331]: [fatal] unable to read input graph: The data couldn’t be read because it isn’t in the correct format.
[end of diff output]
\</failure\>
\</testcase\>
\</testsuite\>
\</testsuites\>
@
-}
{-# LANGUAGE OverloadedStrings #-}
module Test.Framework.XmlOutput (
JunitXmlOutput(..), Testsuites(..), Testsuite(..), Testcase(..), Result(..)
, 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
-- | A "specification" of the output format in terms of haskell data types:
-- The name of each data type corresponds to the name of an XML element
-- (lowercase first letter).
-- The name of a field with a primitive corresponds to an attribute with
-- then same name as the field (without the prefix up to the first @_@).
--
-- The root element is @testsuites@
data JunitXmlOutput = JunitXmlOutput Testsuites
type Seconds = Double
data Testsuites
= Testsuites
{ tss_tests :: Int
, tss_failures :: Int
, tss_errors :: Int
, tss_time :: Seconds
, tss_suites :: [Testsuite] }
data Testsuite
= Testsuite
{ ts_tests :: Int
, ts_failures :: Int
, ts_errors :: Int
, ts_time :: Seconds
, ts_id :: Int
, ts_name :: String
, ts_package :: String
, ts_testcases :: [Testcase] }
data Testcase
= Testcase
{ tc_classname :: String
, tc_name :: String
, tc_time :: Seconds
, tc_result :: Maybe Result }
-- For this datatype, the elemName field specifies the name of the element
data Result
= Result
{ r_elemName :: String
, r_message :: T.Text
, r_type :: String
, r_textContent :: T.Text }
renderAsXml :: JunitXmlOutput -> BSL.ByteString
renderAsXml (JunitXmlOutput suites) =
xrender $
doc defaultDocInfo $
xelem "testsuites" $
xattr "tests" (showT (tss_tests suites)) <>
xattr "failures" (showT (tss_failures suites)) <>
xattr "errors" (showT (tss_errors suites)) <>
xattr "time" (showTime (tss_time suites)) <#>
(map testsuiteXml (tss_suites suites))
where
testsuiteXml suite =
xelem "testsuite" $
xattr "id" (showT (ts_id suite)) <>
xattr "tests" (showT (ts_tests suite)) <>
xattr "failures" (showT (ts_failures suite)) <>
xattr "errors" (showT (ts_errors suite)) <>
xattr "time" (showTime (ts_time suite)) <>
xattr "name" (T.pack (ts_name suite)) <>
xattr "package" (T.pack (ts_package suite)) <#>
(map testcaseXml (ts_testcases suite))
testcaseXml tc =
xelem "testcase" $
xattr "classname" (T.pack (tc_classname tc)) <>
xattr "name" (T.pack (tc_name tc)) <>
xattr "time" (showTime (tc_time tc)) <#>
resultXml (tc_result tc)
resultXml Nothing = xempty
resultXml (Just res) =
xelem (T.pack (r_elemName res)) $
xattr "type" (T.pack (r_type res)) <>
xattr "message" (r_message res) <#>
xtext (r_textContent res)
showT = T.pack . show
showTime = T.pack . printf "%.3f"
groupByModule :: [FlatTestResult] -> [(String, [FlatTestResult])]
groupByModule l =
let m = List.foldl' (\m r -> Map.insertWith (++) (prefixName (ft_path r)) [r] m) Map.empty l
in Map.toList m
mkTestSuite :: (Int, (String, [FlatTestResult])) -> Testsuite
mkTestSuite (id, (modName, results)) =
Testsuite
{ ts_tests = nTests
, ts_failures = nFailures
, ts_errors = nErrors
, ts_time = millisToSeconds millis
, ts_id = id
, ts_name = modName
, ts_package = modName
, ts_testcases = map mkTestCase results }
where
(nTests, nFailures, nErrors, millis) =
List.foldl' (\(t, f, e, m) r -> (t + 1, f + failureInc r, e + errorInc r,
m + (rr_wallTimeMs . ft_payload) r))
(0, 0, 0, 0) results
failureInc r = if isFailure r then 1 else 0
errorInc r = if isError r then 1 else 0
isFailure :: FlatTestResult -> Bool
isFailure r = Fail == (rr_result . ft_payload) r
isError :: FlatTestResult -> Bool
isError r = Error == (rr_result . ft_payload) r
mkTestCase :: FlatTestResult -> Testcase
mkTestCase r =
Testcase
{ tc_classname = modName
, tc_name = simpleName
, tc_time = millisToSeconds (rr_wallTimeMs payload)
, tc_result = result }
where
payload = ft_payload r
simpleName = prefix ++ finalName (ft_path r)
modName = prefixName (ft_path r)
prefix = case ft_sort r of
UnitTest -> "test_"
QuickCheckTest -> "prop_"
BlackBoxTest -> "bbt_"
result =
if isFailure r
then Just (mkResult "failure")
else if isError r
then Just (mkResult "error")
else Nothing
mkResult elemName =
Result
{ r_elemName = elemName
, r_message = T.takeWhile (/= '\n') msg
, r_type = elemName
, r_textContent = msg }
msg = renderColorString (attachCallStack (rr_message payload) (rr_stack payload)) False
millisToSeconds :: Milliseconds -> Seconds
millisToSeconds millis =
fromInteger (toInteger millis) / 1000.0
mkGlobalResultsXml :: ReportGlobalResultsArg -> BSL.ByteString
mkGlobalResultsXml arg =
let nPassed = length (rgra_passed arg)
nPending = length (rgra_pending arg)
nFailed = length (rgra_failed arg)
nErrors = length (rgra_errors arg)
byModules = groupByModule (rgra_passed arg ++ rgra_pending arg ++
rgra_failed arg ++ rgra_errors arg)
suites = map mkTestSuite (zip [0..] byModules)
root = Testsuites
{ tss_tests = nPassed + nPending + nFailed + nErrors
, tss_failures = nFailed
, tss_errors = nErrors
, tss_time = millisToSeconds (rgra_timeMs arg)
, tss_suites = suites }
in renderAsXml (JunitXmlOutput root)