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

import Prelude

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

renderJUnit :: MonadThrow m => Bool -> ConduitT Suites Event m ()
renderJUnit :: forall (m :: * -> *).
MonadThrow m =>
Bool -> ConduitT Suites Event m ()
renderJUnit Bool
shouldDropConsoleFormatting = (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
suitesName :: Text
suitesSuites :: [Suite]
suitesName :: Suites -> Text
suitesSuites :: Suites -> [Suite]
..} ->
  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 ()
-> ConduitT Suite Event m () -> ConduitT Suites Event m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT () Int m () -> ConduitT Suite (Int, Suite) m ()
forall (m :: * -> *) i a.
Monad m =>
ConduitT () i m () -> ConduitT a (i, a) m ()
mergeSource ConduitT () Int m ()
forall {m :: * -> *} {a} {i}. (Monad m, Num a) => ConduitT i a m ()
idStream
      ConduitT Suite (Int, Suite) m ()
-> ConduitT (Int, Suite) Event m () -> ConduitT Suite Event m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| Bool -> ConduitT (Int, Suite) Event m ()
forall (m :: * -> *).
MonadThrow m =>
Bool -> ConduitT (Int, Suite) Event m ()
suite Bool
shouldDropConsoleFormatting
 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 => Bool -> ConduitT (Int, Suite) Event m ()
suite :: forall (m :: * -> *).
MonadThrow m =>
Bool -> ConduitT (Int, Suite) Event m ()
suite Bool
shouldDropConsoleFormatting = ((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
suiteName :: Text
suiteTimestamp :: UTCTime
suiteCases :: [TestCase]
suiteName :: Suite -> Text
suiteTimestamp :: Suite -> UTCTime
suiteCases :: Suite -> [TestCase]
..}) ->
  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 ()
-> ConduitT TestCase Event m () -> ConduitT (Int, Suite) Event m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| do
      (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
x -> TestCase -> ConduitT TestCase TestCase m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield TestCase
x ConduitT TestCase TestCase m ()
-> ConduitT TestCase Event m () -> ConduitT TestCase Event m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| Bool -> ConduitT TestCase Event m ()
forall (m :: * -> *).
MonadThrow m =>
Bool -> ConduitT TestCase Event m ()
testCase Bool
shouldDropConsoleFormatting
 where
  -- TODO these need to be made real values
  attributes :: a -> Suite -> Attributes
attributes a
i Suite {[TestCase]
Text
UTCTime
suiteName :: Suite -> Text
suiteTimestamp :: Suite -> UTCTime
suiteCases :: Suite -> [TestCase]
suiteName :: Text
suiteTimestamp :: UTCTime
suiteCases :: [TestCase]
..} =
    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 a. [a] -> 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 a. [a] -> 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 a. [a] -> 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 :: forall a. Show a => 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 => Bool -> ConduitT TestCase Event m ()
testCase :: forall (m :: * -> *).
MonadThrow m =>
Bool -> ConduitT TestCase Event m ()
testCase Bool
shouldDropConsoleFormatting =
  (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 ()
-> ConduitT Result Event m () -> ConduitT TestCase Event m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| Bool -> ConduitT Result Event m ()
forall (m :: * -> *).
MonadThrow m =>
Bool -> ConduitT Result Event m ()
result Bool
shouldDropConsoleFormatting
 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 => Bool -> ConduitT Result Event m ()
result :: forall (m :: * -> *).
MonadThrow m =>
Bool -> ConduitT Result Event m ()
result Bool
shouldDropConsoleFormatting = (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 -> ConduitT i Event m ()) -> Text -> ConduitT i Event m ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
dropConsoleFormatting 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 -> ConduitT i Event m ()) -> Text -> ConduitT i Event m ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
dropConsoleFormatting Text
contents

  -- Drops ANSI control characters which might be used to set colors.
  -- Including these breaks XML, there is not much point encoding them.
  dropConsoleFormatting :: Text -> Text
  dropConsoleFormatting :: Text -> Text
dropConsoleFormatting Text
input
    | Bool
shouldDropConsoleFormatting =
        let
          regex :: Regex
regex = Text -> Regex
forall regex compOpt execOpt source.
RegexMaker regex compOpt execOpt source =>
source -> regex
Regex.makeRegex (String -> Text
pack String
"\x1b\\[[0-9;]*[mGKHF]") :: Regex.Regex
          matches :: [MatchArray]
matches = Regex -> Text -> [MatchArray]
forall regex source.
RegexLike regex source =>
regex -> source -> [MatchArray]
Regex.matchAll Regex
regex Text
input
          dropMatch :: (Int, Int) -> Text -> Text
dropMatch (Int
offset, Int
len) Text
input' =
            let
              (Text
begining, Text
rest) = Int -> Text -> (Text, Text)
Text.splitAt Int
offset Text
input'
              (Text
_, Text
end) = Int -> Text -> (Text, Text)
Text.splitAt Int
len Text
rest
            in
              Text
begining Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
end
          matchTuples :: [(Int, Int)]
matchTuples = (MatchArray -> (Int, Int)) -> [MatchArray] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (MatchArray -> Int -> (Int, Int)
forall i e. Ix i => Array i e -> i -> e
Array.! Int
0) [MatchArray]
matches
        in
          ((Int, Int) -> Text -> Text) -> Text -> [(Int, Int)] -> Text
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Int, Int) -> Text -> Text
dropMatch Text
input [(Int, Int)]
matchTuples
    | Bool
otherwise = Text
input

sumDurations :: [TestCase] -> Double
sumDurations :: [TestCase] -> Double
sumDurations [TestCase]
cases = [Double] -> Double
forall a. Num a => [a] -> a
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 :: forall a. PrintfArg a => 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"