{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Text.XML.JUnit
(
writeXmlReport,
passed,
skipped,
failed,
errored,
inSuite,
stdout,
stderr,
time,
failureMessage,
failureStackTrace,
errorMessage,
errorStackTrace,
TestReport,
TestSuite,
)
where
import Data.Function ((&))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (fromMaybe)
import Data.Maybe (catMaybes)
import qualified Data.Text as T
import qualified Data.Text.Lazy.IO
import GHC.Exts (fromList)
import qualified Text.XML as XML
writeXmlReport :: FilePath -> [TestSuite] -> IO ()
writeXmlReport :: FilePath -> [TestSuite] -> IO ()
writeXmlReport FilePath
out =
FilePath -> Text -> IO ()
Data.Text.Lazy.IO.writeFile FilePath
out (Text -> IO ()) -> ([TestSuite] -> Text) -> [TestSuite] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderSettings -> Document -> Text
XML.renderText RenderSettings
forall a. Default a => a
XML.def (Document -> Text)
-> ([TestSuite] -> Document) -> [TestSuite] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TestSuite] -> Document
encode
data TestReport outcome where
TestReport ::
Outcome outcome =>
{ forall outcome. TestReport outcome -> Text
testName' :: T.Text,
forall outcome. TestReport outcome -> outcome
outcome' :: outcome,
forall outcome. TestReport outcome -> Maybe Text
stdout' :: Maybe T.Text,
forall outcome. TestReport outcome -> Maybe Text
stderr' :: Maybe T.Text,
forall outcome. TestReport outcome -> Maybe Double
time' :: Maybe Double
} ->
TestReport
outcome
data TestSuite
= TestSuite
{ TestSuite -> Text
suiteName :: T.Text,
TestSuite -> Element
testReport :: XML.Element,
TestSuite -> Counts
counts :: Counts
}
inSuite :: T.Text -> TestReport outcome -> TestSuite
inSuite :: forall outcome. Text -> TestReport outcome -> TestSuite
inSuite Text
name test :: TestReport outcome
test@TestReport {outcome
outcome' :: forall outcome. TestReport outcome -> outcome
outcome' :: outcome
outcome', Maybe Double
time' :: forall outcome. TestReport outcome -> Maybe Double
time' :: Maybe Double
time'} =
TestSuite
{ suiteName :: Text
suiteName = Text
name,
testReport :: Element
testReport = TestReport outcome -> Element
forall a. TestReport a -> Element
encodeTestCase TestReport outcome
test,
counts :: Counts
counts = (outcome -> Counts
forall a. Outcome a => a -> Counts
outcomeCounter outcome
outcome') {cumTime :: Double
cumTime = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
0 Maybe Double
time'}
}
mapTest :: (a -> a) -> TestReport a -> TestReport a
mapTest :: forall a. (a -> a) -> TestReport a -> TestReport a
mapTest a -> a
f TestReport a
test = TestReport a
test {outcome' :: a
outcome' = a -> a
f (TestReport a -> a
forall outcome. TestReport outcome -> outcome
outcome' TestReport a
test)}
stdout :: T.Text -> TestReport outcome -> TestReport outcome
stdout :: forall outcome. Text -> TestReport outcome -> TestReport outcome
stdout Text
log TestReport outcome
test = TestReport outcome
test {stdout' :: Maybe Text
stdout' = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
log}
stderr :: T.Text -> TestReport outcome -> TestReport outcome
stderr :: forall outcome. Text -> TestReport outcome -> TestReport outcome
stderr Text
log TestReport outcome
test = TestReport outcome
test {stderr' :: Maybe Text
stderr' = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
log}
time :: Double -> TestReport outcome -> TestReport outcome
time :: forall outcome. Double -> TestReport outcome -> TestReport outcome
time Double
seconds TestReport outcome
test = TestReport outcome
test {time' :: Maybe Double
time' = Double -> Maybe Double
forall a. a -> Maybe a
Just Double
seconds}
passed :: T.Text -> TestReport Passed
passed :: Text -> TestReport Passed
passed Text
name =
TestReport
{ testName' :: Text
testName' = Text
name,
outcome' :: Passed
outcome' = Passed
Passed,
stdout' :: Maybe Text
stdout' = Maybe Text
forall a. Maybe a
Nothing,
stderr' :: Maybe Text
stderr' = Maybe Text
forall a. Maybe a
Nothing,
time' :: Maybe Double
time' = Maybe Double
forall a. Maybe a
Nothing
}
skipped :: T.Text -> TestReport Skipped
skipped :: Text -> TestReport Skipped
skipped Text
name =
TestReport
{ testName' :: Text
testName' = Text
name,
outcome' :: Skipped
outcome' = Skipped
Skipped,
stdout' :: Maybe Text
stdout' = Maybe Text
forall a. Maybe a
Nothing,
stderr' :: Maybe Text
stderr' = Maybe Text
forall a. Maybe a
Nothing,
time' :: Maybe Double
time' = Maybe Double
forall a. Maybe a
Nothing
}
failed :: T.Text -> TestReport Failed
failed :: Text -> TestReport Failed
failed Text
name =
TestReport
{ testName' :: Text
testName' = Text
name,
outcome' :: Failed
outcome' = Maybe Text -> [Text] -> Failed
Failure Maybe Text
forall a. Maybe a
Nothing [],
stdout' :: Maybe Text
stdout' = Maybe Text
forall a. Maybe a
Nothing,
stderr' :: Maybe Text
stderr' = Maybe Text
forall a. Maybe a
Nothing,
time' :: Maybe Double
time' = Maybe Double
forall a. Maybe a
Nothing
}
errored :: T.Text -> TestReport Errored
errored :: Text -> TestReport Errored
errored Text
name =
TestReport
{ testName' :: Text
testName' = Text
name,
outcome' :: Errored
outcome' = Maybe Text -> [Text] -> Errored
Error Maybe Text
forall a. Maybe a
Nothing [],
stdout' :: Maybe Text
stdout' = Maybe Text
forall a. Maybe a
Nothing,
stderr' :: Maybe Text
stderr' = Maybe Text
forall a. Maybe a
Nothing,
time' :: Maybe Double
time' = Maybe Double
forall a. Maybe a
Nothing
}
class Outcome a where
outcomeToXML :: a -> Maybe XML.Element
outcomeCounter :: a -> Counts
data Passed = Passed
instance Outcome Passed where
outcomeToXML :: Passed -> Maybe Element
outcomeToXML Passed
_ = Maybe Element
forall a. Maybe a
Nothing
outcomeCounter :: Passed -> Counts
outcomeCounter Passed
_ = Counts
forall a. Monoid a => a
mempty {cumTests :: Int
cumTests = Int
1}
data Skipped = Skipped
instance Outcome Skipped where
outcomeToXML :: Skipped -> Maybe Element
outcomeToXML Skipped
_ = Element -> Maybe Element
forall a. a -> Maybe a
Just (Element -> Maybe Element) -> Element -> Maybe Element
forall a b. (a -> b) -> a -> b
$ Name -> Map Name Text -> [Node] -> Element
XML.Element Name
"skipped" Map Name Text
forall a. Monoid a => a
mempty []
outcomeCounter :: Skipped -> Counts
outcomeCounter Skipped
_ = Counts
forall a. Monoid a => a
mempty {cumSkipped :: Int
cumSkipped = Int
1, cumTests :: Int
cumTests = Int
1}
data Failed
= Failure
{
Failed -> Maybe Text
failureMessage' :: Maybe T.Text,
Failed -> [Text]
failureStackTrace' :: [T.Text]
}
instance Outcome Failed where
outcomeToXML :: Failed -> Maybe Element
outcomeToXML = Element -> Maybe Element
forall a. a -> Maybe a
Just (Element -> Maybe Element)
-> (Failed -> Element) -> Failed -> Maybe Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Failed -> Element
encodeFailure
outcomeCounter :: Failed -> Counts
outcomeCounter Failed
_ = Counts
forall a. Monoid a => a
mempty {cumFailed :: Int
cumFailed = Int
1, cumTests :: Int
cumTests = Int
1}
failureMessage :: T.Text -> TestReport Failed -> TestReport Failed
failureMessage :: Text -> TestReport Failed -> TestReport Failed
failureMessage Text
msg TestReport Failed
test =
(Failed -> Failed) -> TestReport Failed -> TestReport Failed
forall a. (a -> a) -> TestReport a -> TestReport a
mapTest (\Failed
outcome -> Failed
outcome {failureMessage' :: Maybe Text
failureMessage' = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
msg}) TestReport Failed
test
failureStackTrace :: [T.Text] -> TestReport Failed -> TestReport Failed
failureStackTrace :: [Text] -> TestReport Failed -> TestReport Failed
failureStackTrace [Text]
trace TestReport Failed
test =
(Failed -> Failed) -> TestReport Failed -> TestReport Failed
forall a. (a -> a) -> TestReport a -> TestReport a
mapTest (\Failed
outcome -> Failed
outcome {failureStackTrace' :: [Text]
failureStackTrace' = [Text]
trace}) TestReport Failed
test
data Errored
= Error
{
Errored -> Maybe Text
errorMessage' :: Maybe T.Text,
Errored -> [Text]
errorStackTrace' :: [T.Text]
}
instance Outcome Errored where
outcomeToXML :: Errored -> Maybe Element
outcomeToXML = Element -> Maybe Element
forall a. a -> Maybe a
Just (Element -> Maybe Element)
-> (Errored -> Element) -> Errored -> Maybe Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Errored -> Element
encodeError
outcomeCounter :: Errored -> Counts
outcomeCounter Errored
_ = Counts
forall a. Monoid a => a
mempty {cumErrored :: Int
cumErrored = Int
1, cumTests :: Int
cumTests = Int
1}
errorMessage :: T.Text -> TestReport Errored -> TestReport Errored
errorMessage :: Text -> TestReport Errored -> TestReport Errored
errorMessage Text
msg TestReport Errored
test =
(Errored -> Errored) -> TestReport Errored -> TestReport Errored
forall a. (a -> a) -> TestReport a -> TestReport a
mapTest (\Errored
outcome -> Errored
outcome {errorMessage' :: Maybe Text
errorMessage' = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
msg}) TestReport Errored
test
errorStackTrace :: [T.Text] -> TestReport Errored -> TestReport Errored
errorStackTrace :: [Text] -> TestReport Errored -> TestReport Errored
errorStackTrace [Text]
trace TestReport Errored
test =
(Errored -> Errored) -> TestReport Errored -> TestReport Errored
forall a. (a -> a) -> TestReport a -> TestReport a
mapTest (\Errored
outcome -> Errored
outcome {errorStackTrace' :: [Text]
errorStackTrace' = [Text]
trace}) TestReport Errored
test
data Counts
= Counts
{ Counts -> Int
cumTests :: Int,
Counts -> Int
cumFailed :: Int,
Counts -> Int
cumErrored :: Int,
Counts -> Int
cumSkipped :: Int,
Counts -> Double
cumTime :: Double
}
instance Semigroup Counts where
Counts
c1 <> :: Counts -> Counts -> Counts
<> Counts
c2 =
Counts
{ cumTests :: Int
cumTests = Counts -> Int
cumTests Counts
c1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Counts -> Int
cumTests Counts
c2,
cumFailed :: Int
cumFailed = Counts -> Int
cumFailed Counts
c1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Counts -> Int
cumFailed Counts
c2,
cumErrored :: Int
cumErrored = Counts -> Int
cumErrored Counts
c1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Counts -> Int
cumErrored Counts
c2,
cumSkipped :: Int
cumSkipped = Counts -> Int
cumSkipped Counts
c1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Counts -> Int
cumSkipped Counts
c2,
cumTime :: Double
cumTime = Counts -> Double
cumTime Counts
c1 Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Counts -> Double
cumTime Counts
c2
}
instance Monoid Counts where
mempty :: Counts
mempty = Int -> Int -> Int -> Int -> Double -> Counts
Counts Int
0 Int
0 Int
0 Int
0 Double
0
encode :: [TestSuite] -> XML.Document
encode :: [TestSuite] -> Document
encode [TestSuite]
suites =
Prologue -> Element -> [Miscellaneous] -> Document
XML.Document Prologue
prologue Element
element []
where
prologue :: Prologue
prologue = [Miscellaneous] -> Maybe Doctype -> [Miscellaneous] -> Prologue
XML.Prologue [] Maybe Doctype
forall a. Maybe a
Nothing []
(Counts
totalCounts, [Node]
suiteElements) =
(NonEmpty TestSuite -> (Counts, [Node]))
-> [NonEmpty TestSuite] -> (Counts, [Node])
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
((Element -> [Node]) -> (Counts, Element) -> (Counts, [Node])
forall a b. (a -> b) -> (Counts, a) -> (Counts, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Node -> [Node]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Node -> [Node]) -> (Element -> Node) -> Element -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Node
XML.NodeElement) ((Counts, Element) -> (Counts, [Node]))
-> (NonEmpty TestSuite -> (Counts, Element))
-> NonEmpty TestSuite
-> (Counts, [Node])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty TestSuite -> (Counts, Element)
encodeSuite)
((TestSuite -> Text) -> [TestSuite] -> [NonEmpty TestSuite]
forall b a. Ord b => (a -> b) -> [a] -> [NonEmpty a]
NonEmpty.groupAllWith TestSuite -> Text
suiteName [TestSuite]
suites)
element :: Element
element =
Name -> Map Name Text -> [Node] -> Element
XML.Element
Name
"testsuites"
([Item (Map Name Text)] -> Map Name Text
forall l. IsList l => [Item l] -> l
fromList (Counts -> [(Name, Text)]
countAttributes Counts
totalCounts))
[Node]
suiteElements
encodeSuite :: NonEmpty.NonEmpty TestSuite -> (Counts, XML.Element)
encodeSuite :: NonEmpty TestSuite -> (Counts, Element)
encodeSuite NonEmpty TestSuite
suite =
(Counts
suiteCounts, Element
element)
where
suiteCounts :: Counts
suiteCounts = (TestSuite -> Counts) -> NonEmpty TestSuite -> Counts
forall m a. Monoid m => (a -> m) -> NonEmpty a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TestSuite -> Counts
counts NonEmpty TestSuite
suite
element :: Element
element =
Name -> Map Name Text -> [Node] -> Element
XML.Element
Name
"testsuite"
([Item (Map Name Text)] -> Map Name Text
forall l. IsList l => [Item l] -> l
fromList ([Item (Map Name Text)] -> Map Name Text)
-> [Item (Map Name Text)] -> Map Name Text
forall a b. (a -> b) -> a -> b
$ (Name
"name", TestSuite -> Text
suiteName (NonEmpty TestSuite -> TestSuite
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty TestSuite
suite)) (Name, Text) -> [(Name, Text)] -> [(Name, Text)]
forall a. a -> [a] -> [a]
: Counts -> [(Name, Text)]
countAttributes Counts
suiteCounts)
(NonEmpty Node -> [Node]
forall a. NonEmpty a -> [a]
NonEmpty.toList (Element -> Node
XML.NodeElement (Element -> Node) -> (TestSuite -> Element) -> TestSuite -> Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSuite -> Element
testReport (TestSuite -> Node) -> NonEmpty TestSuite -> NonEmpty Node
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty TestSuite
suite))
encodeTestCase :: TestReport a -> XML.Element
encodeTestCase :: forall a. TestReport a -> Element
encodeTestCase TestReport {Text
testName' :: forall outcome. TestReport outcome -> Text
testName' :: Text
testName', a
outcome' :: forall outcome. TestReport outcome -> outcome
outcome' :: a
outcome', Maybe Text
stdout' :: forall outcome. TestReport outcome -> Maybe Text
stdout' :: Maybe Text
stdout', Maybe Text
stderr' :: forall outcome. TestReport outcome -> Maybe Text
stderr' :: Maybe Text
stderr', Maybe Double
time' :: forall outcome. TestReport outcome -> Maybe Double
time' :: Maybe Double
time'} =
Name -> Map Name Text -> [Node] -> Element
XML.Element Name
"testcase" Map Name Text
attributes [Node]
children
where
attributes :: Map Name Text
attributes =
[Item (Map Name Text)] -> Map Name Text
forall l. IsList l => [Item l] -> l
fromList ([Item (Map Name Text)] -> Map Name Text)
-> [Item (Map Name Text)] -> Map Name Text
forall a b. (a -> b) -> a -> b
$
[Maybe (Name, Text)] -> [(Name, Text)]
forall a. [Maybe a] -> [a]
catMaybes
[ (Name, Text) -> Maybe (Name, Text)
forall a. a -> Maybe a
Just ((Name, Text) -> Maybe (Name, Text))
-> (Name, Text) -> Maybe (Name, Text)
forall a b. (a -> b) -> a -> b
$ (Name
"name", Text
testName'),
(,) Name
"time" (Text -> (Name, Text))
-> (Double -> Text) -> Double -> (Name, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack (FilePath -> Text) -> (Double -> FilePath) -> Double -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> FilePath
forall a. Show a => a -> FilePath
show (Double -> (Name, Text)) -> Maybe Double -> Maybe (Name, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Double
time'
]
children :: [Node]
children =
Element -> Node
XML.NodeElement
(Element -> Node) -> [Element] -> [Node]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Maybe Element] -> [Element]
forall a. [Maybe a] -> [a]
catMaybes
[ a -> Maybe Element
forall a. Outcome a => a -> Maybe Element
outcomeToXML a
outcome',
Name -> Map Name Text -> [Node] -> Element
XML.Element Name
"system-out" Map Name Text
forall a. Monoid a => a
mempty ([Node] -> Element) -> (Text -> [Node]) -> Text -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> [Node]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Node -> [Node]) -> (Text -> Node) -> Text -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Node
XML.NodeContent (Text -> Element) -> Maybe Text -> Maybe Element
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
stdout',
Name -> Map Name Text -> [Node] -> Element
XML.Element Name
"system-err" Map Name Text
forall a. Monoid a => a
mempty ([Node] -> Element) -> (Text -> [Node]) -> Text -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> [Node]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Node -> [Node]) -> (Text -> Node) -> Text -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Node
XML.NodeContent (Text -> Element) -> Maybe Text -> Maybe Element
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
stderr'
]
encodeFailure :: Failed -> XML.Element
encodeFailure :: Failed -> Element
encodeFailure Failed
failure =
Name -> Map Name Text -> [Node] -> Element
XML.Element
Name
"failure"
(Map Name Text
-> (Text -> Map Name Text) -> Maybe Text -> Map Name Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map Name Text
forall a. Monoid a => a
mempty (\Text
v -> [Item (Map Name Text)] -> Map Name Text
forall l. IsList l => [Item l] -> l
fromList [(Name
"message", Text
v)]) (Failed -> Maybe Text
failureMessage' Failed
failure))
[Text -> Node
XML.NodeContent ([Text] -> Text
T.unlines (Failed -> [Text]
failureStackTrace' Failed
failure))]
encodeError :: Errored -> XML.Element
encodeError :: Errored -> Element
encodeError Errored
err =
Name -> Map Name Text -> [Node] -> Element
XML.Element
Name
"error"
(Map Name Text
-> (Text -> Map Name Text) -> Maybe Text -> Map Name Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map Name Text
forall a. Monoid a => a
mempty (\Text
v -> [Item (Map Name Text)] -> Map Name Text
forall l. IsList l => [Item l] -> l
fromList [(Name
"message", Text
v)]) (Errored -> Maybe Text
errorMessage' Errored
err))
[Text -> Node
XML.NodeContent ([Text] -> Text
T.unlines (Errored -> [Text]
errorStackTrace' Errored
err))]
countAttributes :: Counts -> [(XML.Name, T.Text)]
countAttributes :: Counts -> [(Name, Text)]
countAttributes Counts
counts =
[ (Name
"tests", FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show (Counts -> Int
cumTests Counts
counts))),
(Name
"failures", FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show (Counts -> Int
cumFailed Counts
counts))),
(Name
"errors", FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show (Counts -> Int
cumErrored Counts
counts))),
(Name
"skipped", FilePath -> Text
T.pack (Int -> FilePath
forall a. Show a => a -> FilePath
show (Counts -> Int
cumSkipped Counts
counts))),
(Name
"time", FilePath -> Text
T.pack (Double -> FilePath
forall a. Show a => a -> FilePath
show (Counts -> Double
cumTime Counts
counts)))
]