module Test.HSpec.JUnit.Render
( renderJUnit
) where
import Prelude
import Control.Monad.Catch (MonadThrow)
import Data.Conduit (ConduitT, awaitForever, yield, (.|))
import qualified Data.Conduit.List as CL
import Data.Foldable (traverse_)
import Data.Text (Text, pack)
import Data.XML.Types (Event)
import Test.HSpec.JUnit.Schema (Result(..), TestCase(..), Suite(..), Suites(..))
import Text.XML.Stream.Render (attr, content, tag)
import Data.Hashable (hash)
renderJUnit :: MonadThrow m => ConduitT Suites Event m ()
renderJUnit :: ConduitT Suites Event m ()
renderJUnit = (Suites -> ConduitT Suites Event m ())
-> ConduitT Suites Event m ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever ((Suites -> ConduitT Suites Event m ())
-> ConduitT Suites Event m ())
-> (Suites -> ConduitT Suites Event m ())
-> ConduitT Suites Event m ()
forall a b. (a -> b) -> a -> b
$ \(Suites Text
name [Suite]
suites) ->
Name
-> Attributes
-> ConduitT Suites Event m ()
-> ConduitT Suites Event m ()
forall (m :: * -> *) i.
Monad m =>
Name
-> Attributes -> ConduitT i Event m () -> ConduitT i Event m ()
tag Name
"testsuites" (Name -> Text -> Attributes
attr Name
"name" Text
name) (ConduitT Suites Event m () -> ConduitT Suites Event m ())
-> ConduitT Suites Event m () -> ConduitT Suites Event m ()
forall a b. (a -> b) -> a -> b
$ [Suite] -> ConduitT Suites Suite m ()
forall (m :: * -> *) a i. Monad m => [a] -> ConduitT i a m ()
CL.sourceList [Suite]
suites ConduitT Suites Suite m ()
-> ConduitM Suite Event m () -> ConduitT Suites Event m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM Suite Event m ()
forall (m :: * -> *). MonadThrow m => ConduitT Suite Event m ()
suite
suite :: MonadThrow m => ConduitT Suite Event m ()
suite :: ConduitT Suite Event m ()
suite =
(Suite -> ConduitT Suite Event m ()) -> ConduitT Suite Event m ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever
((Suite -> ConduitT Suite Event m ()) -> ConduitT Suite Event m ())
-> (Suite -> ConduitT Suite Event m ())
-> ConduitT Suite Event m ()
forall a b. (a -> b) -> a -> b
$ \(Suite Text
name [Either Suite TestCase]
cases) -> Name
-> Attributes
-> ConduitT Suite Event m ()
-> ConduitT Suite Event m ()
forall (m :: * -> *) i.
Monad m =>
Name
-> Attributes -> ConduitT i Event m () -> ConduitT i Event m ()
tag Name
"testsuite" (Text -> [Either Suite TestCase] -> Attributes
forall a. Text -> [Either a TestCase] -> Attributes
attributes Text
name [Either Suite TestCase]
cases) (ConduitT Suite Event m () -> ConduitT Suite Event m ())
-> ConduitT Suite Event m () -> ConduitT Suite Event m ()
forall a b. (a -> b) -> a -> b
$ do
Name
-> Attributes
-> ConduitT Suite Event m ()
-> ConduitT Suite Event m ()
forall (m :: * -> *) i.
Monad m =>
Name
-> Attributes -> ConduitT i Event m () -> ConduitT i Event m ()
tag Name
"properties" Attributes
forall a. Monoid a => a
mempty ConduitT Suite Event m ()
forall a. Monoid a => a
mempty
[Either Suite TestCase]
-> ConduitT Suite (Either Suite TestCase) m ()
forall (m :: * -> *) a i. Monad m => [a] -> ConduitT i a m ()
CL.sourceList [Either Suite TestCase]
cases ConduitT Suite (Either Suite TestCase) m ()
-> ConduitM (Either Suite TestCase) Event m ()
-> ConduitT Suite Event m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| do
(Either Suite TestCase
-> ConduitM (Either Suite TestCase) Event m ())
-> ConduitM (Either Suite TestCase) Event m ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever ((Either Suite TestCase
-> ConduitM (Either Suite TestCase) Event m ())
-> ConduitM (Either Suite TestCase) Event m ())
-> (Either Suite TestCase
-> ConduitM (Either Suite TestCase) Event m ())
-> ConduitM (Either Suite TestCase) Event m ()
forall a b. (a -> b) -> a -> b
$ \case
Left Suite
x -> Suite -> ConduitT (Either Suite TestCase) Suite m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield Suite
x ConduitT (Either Suite TestCase) Suite m ()
-> ConduitT Suite Event m ()
-> ConduitM (Either Suite TestCase) Event m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitT Suite Event m ()
forall (m :: * -> *). MonadThrow m => ConduitT Suite Event m ()
suite
Right TestCase
x -> TestCase -> ConduitT (Either Suite TestCase) TestCase m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield TestCase
x ConduitT (Either Suite TestCase) TestCase m ()
-> ConduitM TestCase Event m ()
-> ConduitM (Either Suite TestCase) Event m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM TestCase Event m ()
forall (m :: * -> *). MonadThrow m => ConduitT TestCase Event m ()
testCase
where
attributes :: Text -> [Either a TestCase] -> Attributes
attributes Text
name [Either a TestCase]
cases =
Name -> Text -> Attributes
attr Name
"name" Text
name
Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Name -> Text -> Attributes
attr Name
"package" Text
name
Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Name -> Text -> Attributes
attr Name
"id" (Int -> Text
forall a. Show a => a -> Text
tshow (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Int
forall a. Hashable a => a -> Int
hash Text
name)
Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Name -> Text -> Attributes
attr Name
"time" Text
"0"
Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Name -> Text -> Attributes
attr Name
"timestamp" Text
"1979-01-01T01:01:01"
Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Name -> Text -> Attributes
attr Name
"hostname" Text
"localhost"
Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Name -> Text -> Attributes
attr Name
"tests" (Int -> Text
forall a. Show a => a -> Text
tshow (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ [Either a TestCase] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either a TestCase]
cases)
Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Name -> Text -> Attributes
attr
Name
"failures"
(Int -> Text
forall a. Show a => a -> Text
tshow (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ [()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
[ () | Right (TestCase Text
_ Text
_ (Just (Failure Text
_ Text
_))) <- [Either a TestCase]
cases ]
)
Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Name -> Text -> Attributes
attr Name
"errors" Text
"0"
Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Name -> Text -> Attributes
attr
Name
"skipped"
(Int -> Text
forall a. Show a => a -> Text
tshow (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ [()] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
[ () | Right (TestCase Text
_ Text
_ (Just (Skipped Text
_))) <- [Either a TestCase]
cases ]
)
tshow :: Show a => a -> Text
tshow :: a -> Text
tshow = String -> Text
pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show
testCase :: MonadThrow m => ConduitT TestCase Event m ()
testCase :: ConduitT TestCase Event m ()
testCase = (TestCase -> ConduitT TestCase Event m ())
-> ConduitT TestCase Event m ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever ((TestCase -> ConduitT TestCase Event m ())
-> ConduitT TestCase Event m ())
-> (TestCase -> ConduitT TestCase Event m ())
-> ConduitT TestCase Event m ()
forall a b. (a -> b) -> a -> b
$ \(TestCase Text
className Text
name Maybe Result
mResult) ->
Name
-> Attributes
-> ConduitT TestCase Event m ()
-> ConduitT TestCase Event m ()
forall (m :: * -> *) i.
Monad m =>
Name
-> Attributes -> ConduitT i Event m () -> ConduitT i Event m ()
tag Name
"testcase" (Text -> Text -> Attributes
attributes Text
className Text
name) (ConduitT TestCase Event m () -> ConduitT TestCase Event m ())
-> ConduitT TestCase Event m () -> ConduitT TestCase Event m ()
forall a b. (a -> b) -> a -> b
$ (Result -> ConduitT TestCase Result m ())
-> Maybe Result -> ConduitT TestCase Result m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Result -> ConduitT TestCase Result m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield Maybe Result
mResult ConduitT TestCase Result m ()
-> ConduitM Result Event m () -> ConduitT TestCase Event m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM Result Event m ()
forall (m :: * -> *). MonadThrow m => ConduitT Result Event m ()
result
where
attributes :: Text -> Text -> Attributes
attributes Text
className Text
name =
Name -> Text -> Attributes
attr Name
"name" Text
name Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Name -> Text -> Attributes
attr Name
"classname" Text
className Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Name -> Text -> Attributes
attr Name
"time" Text
"0"
result :: MonadThrow m => ConduitT Result Event m ()
result :: ConduitT Result Event m ()
result = (Result -> ConduitT Result Event m ())
-> ConduitT Result Event m ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever Result -> ConduitT Result Event m ()
forall (m :: * -> *) i. Monad m => Result -> ConduitT i Event m ()
go
where
go :: Result -> ConduitT i Event m ()
go (Failure Text
fType Text
contents) =
Name
-> Attributes -> ConduitT i Event m () -> ConduitT i Event m ()
forall (m :: * -> *) i.
Monad m =>
Name
-> Attributes -> ConduitT i Event m () -> ConduitT i Event m ()
tag Name
"failure" (Name -> Text -> Attributes
attr Name
"type" Text
fType) (ConduitT i Event m () -> ConduitT i Event m ())
-> ConduitT i Event m () -> ConduitT i Event m ()
forall a b. (a -> b) -> a -> b
$ Text -> ConduitT i Event m ()
forall (m :: * -> *) i. Monad m => Text -> ConduitT i Event m ()
content Text
contents
go (Skipped Text
contents) = Name
-> Attributes -> ConduitT i Event m () -> ConduitT i Event m ()
forall (m :: * -> *) i.
Monad m =>
Name
-> Attributes -> ConduitT i Event m () -> ConduitT i Event m ()
tag Name
"skipped" Attributes
forall a. Monoid a => a
mempty (ConduitT i Event m () -> ConduitT i Event m ())
-> ConduitT i Event m () -> ConduitT i Event m ()
forall a b. (a -> b) -> a -> b
$ Text -> ConduitT i Event m ()
forall (m :: * -> *) i. Monad m => Text -> ConduitT i Event m ()
content Text
contents