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
  -- TODO these need to be made real values
  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
  -- TODO these need to be made real values
  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