content: {-# 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)
  