module Test.Hspec.JUnit.Render
  ( renderJUnit
  ) where

import Prelude

import Control.Monad.Catch (MonadThrow)
import Data.Conduit (ConduitT, awaitForever, mergeSource, yield, (.|))
import qualified Data.Conduit.List as CL
import Data.Foldable (traverse_)
import Data.Text (Text, pack)
import Data.Time.ISO8601 (formatISO8601)
import Data.XML.Types (Event)
import Test.Hspec.JUnit.Schema
  (Location(..), Result(..), Suite(..), Suites(..), TestCase(..))
import Text.Printf
import Text.XML.Stream.Render (attr, content, tag)

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 {[Suite]
Text
suitesSuites :: Suites -> [Suite]
suitesName :: Suites -> Text
suitesSuites :: [Suite]
suitesName :: Text
..} ->
  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
suitesName)
    (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]
suitesSuites
    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
.| Source m Int -> Conduit Suite m (Int, Suite)
forall (m :: * -> *) i a.
Monad m =>
Source m i -> Conduit a m (i, a)
mergeSource Source m Int
forall (m :: * -> *) a i. (Monad m, Num a) => ConduitT i a m ()
idStream
    Conduit Suite m (Int, Suite)
-> ConduitM (Int, Suite) Event m () -> ConduitM 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
.| ConduitM (Int, Suite) Event m ()
forall (m :: * -> *).
MonadThrow m =>
ConduitT (Int, Suite) Event m ()
suite
  where idStream :: ConduitT i a m ()
idStream = (a -> a) -> a -> ConduitT i a m ()
forall (m :: * -> *) a i.
Monad m =>
(a -> a) -> a -> ConduitT i a m ()
CL.iterate (a -> a -> a
forall a. Num a => a -> a -> a
+ a
1) a
0

suite :: MonadThrow m => ConduitT (Int, Suite) Event m ()
suite :: ConduitT (Int, Suite) Event m ()
suite = ((Int, Suite) -> ConduitT (Int, Suite) Event m ())
-> ConduitT (Int, Suite) Event m ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever (((Int, Suite) -> ConduitT (Int, Suite) Event m ())
 -> ConduitT (Int, Suite) Event m ())
-> ((Int, Suite) -> ConduitT (Int, Suite) Event m ())
-> ConduitT (Int, Suite) Event m ()
forall a b. (a -> b) -> a -> b
$ \(Int
i, theSuite :: Suite
theSuite@Suite {[TestCase]
Text
UTCTime
suiteCases :: Suite -> [TestCase]
suiteTimestamp :: Suite -> UTCTime
suiteName :: Suite -> Text
suiteCases :: [TestCase]
suiteTimestamp :: UTCTime
suiteName :: Text
..}) ->
  Name
-> Attributes
-> ConduitT (Int, Suite) Event m ()
-> ConduitT (Int, Suite) Event m ()
forall (m :: * -> *) i.
Monad m =>
Name
-> Attributes -> ConduitT i Event m () -> ConduitT i Event m ()
tag Name
"testsuite" (Int -> Suite -> Attributes
forall a. Show a => a -> Suite -> Attributes
attributes Int
i Suite
theSuite) (ConduitT (Int, Suite) Event m ()
 -> ConduitT (Int, Suite) Event m ())
-> ConduitT (Int, Suite) Event m ()
-> ConduitT (Int, Suite) Event m ()
forall a b. (a -> b) -> a -> b
$ do
    Name
-> Attributes
-> ConduitT (Int, Suite) Event m ()
-> ConduitT (Int, 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 (Int, Suite) Event m ()
forall a. Monoid a => a
mempty
    [TestCase] -> ConduitT (Int, Suite) TestCase m ()
forall (m :: * -> *) a i. Monad m => [a] -> ConduitT i a m ()
CL.sourceList [TestCase]
suiteCases ConduitT (Int, Suite) TestCase m ()
-> ConduitM TestCase Event m () -> ConduitT (Int, 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
      (TestCase -> ConduitM TestCase Event m ())
-> ConduitM TestCase Event m ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever ((TestCase -> ConduitM TestCase Event m ())
 -> ConduitM TestCase Event m ())
-> (TestCase -> ConduitM TestCase Event m ())
-> ConduitM TestCase Event m ()
forall a b. (a -> b) -> a -> b
$ \TestCase
x -> TestCase -> ConduitT TestCase TestCase m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield TestCase
x ConduitT TestCase TestCase m ()
-> ConduitM TestCase Event m () -> ConduitM 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 :: a -> Suite -> Attributes
attributes a
i Suite {[TestCase]
Text
UTCTime
suiteCases :: [TestCase]
suiteTimestamp :: UTCTime
suiteName :: Text
suiteCases :: Suite -> [TestCase]
suiteTimestamp :: Suite -> UTCTime
suiteName :: Suite -> Text
..} =
    Name -> Text -> Attributes
attr Name
"name" Text
suiteName
      Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Name -> Text -> Attributes
attr Name
"package" Text
suiteName
      Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Name -> Text -> Attributes
attr Name
"id" (a -> Text
forall a. Show a => a -> Text
tshow a
i)
      Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Name -> Text -> Attributes
attr Name
"time" (Double -> Text
forall a. PrintfArg a => a -> Text
roundToStr (Double -> Text) -> Double -> Text
forall a b. (a -> b) -> a -> b
$ [TestCase] -> Double
sumDurations [TestCase]
suiteCases)
      Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Name -> Text -> Attributes
attr Name
"timestamp" (String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ UTCTime -> String
formatISO8601 UTCTime
suiteTimestamp)
      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
$ [TestCase] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TestCase]
suiteCases)
      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 [ () | Just Failure{} <- TestCase -> Maybe Result
testCaseResult (TestCase -> Maybe Result) -> [TestCase] -> [Maybe Result]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TestCase]
suiteCases ]
           )
      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 [ () | Just Skipped{} <- TestCase -> Maybe Result
testCaseResult (TestCase -> Maybe Result) -> [TestCase] -> [Maybe Result]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TestCase]
suiteCases ]
           )

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 Maybe Location
mLocation Text
className Text
name Double
duration 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" (Maybe Location -> Text -> Text -> Double -> Attributes
forall a.
PrintfArg a =>
Maybe Location -> Text -> Text -> a -> Attributes
attributes Maybe Location
mLocation Text
className Text
name Double
duration)
      (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 :: Maybe Location -> Text -> Text -> a -> Attributes
attributes Maybe Location
mLocation Text
className Text
name a
duration =
    Attributes
-> (Location -> Attributes) -> Maybe Location -> Attributes
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Attributes
forall a. Monoid a => a
mempty (Name -> Text -> Attributes
attr Name
"file" (Text -> Attributes)
-> (Location -> Text) -> Location -> Attributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> Text) -> (Location -> String) -> Location -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Location -> String
locationFile) Maybe Location
mLocation
      Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> Attributes
-> (Location -> Attributes) -> Maybe Location -> Attributes
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Attributes
forall a. Monoid a => a
mempty (Name -> Text -> Attributes
attr Name
"line" (Text -> Attributes)
-> (Location -> Text) -> Location -> Attributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> Text) -> (Location -> String) -> Location -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> String
forall a. Show a => a -> String
show (Natural -> String) -> (Location -> Natural) -> Location -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Location -> Natural
locationLine) Maybe Location
mLocation
      Attributes -> Attributes -> Attributes
forall a. Semigroup a => a -> a -> a
<> 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" (a -> Text
forall a. PrintfArg a => a -> Text
roundToStr a
duration)

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

sumDurations :: [TestCase] -> Double
sumDurations :: [TestCase] -> Double
sumDurations [TestCase]
cases = [Double] -> Double
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Double] -> Double) -> [Double] -> Double
forall a b. (a -> b) -> a -> b
$ TestCase -> Double
testCaseDuration (TestCase -> Double) -> [TestCase] -> [Double]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TestCase]
cases

roundToStr :: (PrintfArg a) => a -> Text
roundToStr :: a -> Text
roundToStr = String -> Text
pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> a -> String
forall r. PrintfType r => String -> r
printf String
"%0.9f"