module Test.HSpec.JUnit.Parse
  ( parseJUnit
  , denormalize
  ) where

import Prelude

import Control.Monad.Catch (MonadThrow)
import Data.Conduit (ConduitT, awaitForever, yield)
import Data.XML.Types (Event)
import Test.HSpec.JUnit.Schema
import Text.XML.Stream.Parse
  (choose, content, many, requireAttr, tag', tagNoAttr)

denormalize' :: Suite -> [Suite]
denormalize' :: Suite -> [Suite]
denormalize' (Suite Text
name [Either Suite TestCase]
xs) = [Suite] -> [Suite]
collapse ([Suite] -> [Suite]) -> [Suite] -> [Suite]
forall a b. (a -> b) -> a -> b
$ (Either Suite TestCase -> [Suite])
-> [Either Suite TestCase] -> [Suite]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Either Suite TestCase -> [Suite]
suiteOrCase [Either Suite TestCase]
xs
 where
  suiteOrCase :: Either Suite TestCase -> [Suite]
suiteOrCase = \case
    Right TestCase
x -> [Text -> [Either Suite TestCase] -> Suite
Suite Text
name [TestCase -> Either Suite TestCase
forall a b. b -> Either a b
Right TestCase
x]]
    Left (Suite Text
name' [Either Suite TestCase]
ys) -> Suite -> [Suite]
denormalize' (Suite -> [Suite]) -> Suite -> [Suite]
forall a b. (a -> b) -> a -> b
$ Text -> [Either Suite TestCase] -> Suite
Suite (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name') [Either Suite TestCase]
ys

collapse :: [Suite] -> [Suite]
collapse :: [Suite] -> [Suite]
collapse [] = []
collapse (Suite
x : Suite
y : [Suite]
xs)
  | Suite -> Text
suiteName Suite
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Suite -> Text
suiteName Suite
y
  = [Suite] -> [Suite]
collapse ([Suite] -> [Suite]) -> [Suite] -> [Suite]
forall a b. (a -> b) -> a -> b
$ Text -> [Either Suite TestCase] -> Suite
Suite (Suite -> Text
suiteName Suite
x) (Suite -> [Either Suite TestCase]
suiteCases Suite
x [Either Suite TestCase]
-> [Either Suite TestCase] -> [Either Suite TestCase]
forall a. Semigroup a => a -> a -> a
<> Suite -> [Either Suite TestCase]
suiteCases Suite
y) Suite -> [Suite] -> [Suite]
forall a. a -> [a] -> [a]
: [Suite]
xs
  | Bool
otherwise
  = Suite
x Suite -> [Suite] -> [Suite]
forall a. a -> [a] -> [a]
: [Suite] -> [Suite]
collapse (Suite
y Suite -> [Suite] -> [Suite]
forall a. a -> [a] -> [a]
: [Suite]
xs)
collapse xs :: [Suite]
xs@(Suite
_ : [Suite]
_) = [Suite]
xs

-- | Denormalize nested <testsuite /> elements
--
-- HSpec's formatter cannot correctly output JUnit, so we must denormalize
-- nested <testsuite /> elements. Nested elements have their names collapsed
-- into `hspec` style paths.
--
denormalize :: MonadThrow m => ConduitT Suites Suites m ()
denormalize :: ConduitT Suites Suites m ()
denormalize = (Suites -> ConduitT Suites Suites m ())
-> ConduitT Suites Suites m ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever ((Suites -> ConduitT Suites Suites m ())
 -> ConduitT Suites Suites m ())
-> (Suites -> ConduitT Suites Suites m ())
-> ConduitT Suites Suites m ()
forall a b. (a -> b) -> a -> b
$ \(Suites Text
name [Suite]
children) ->
  Suites -> ConduitT Suites Suites m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Suites -> ConduitT Suites Suites m ())
-> ([Suite] -> Suites) -> [Suite] -> ConduitT Suites Suites m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Suite] -> Suites
Suites Text
name ([Suite] -> ConduitT Suites Suites m ())
-> [Suite] -> ConduitT Suites Suites m ()
forall a b. (a -> b) -> a -> b
$ (Suite -> [Suite]) -> [Suite] -> [Suite]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Suite -> [Suite]
denormalize' [Suite]
children

parseJUnit :: MonadThrow m => ConduitT Event Suites m ()
parseJUnit :: ConduitT Event Suites m ()
parseJUnit = ConduitT Event Suites m ()
-> (Suites -> ConduitT Event Suites m ())
-> Maybe Suites
-> ConduitT Event Suites m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> ConduitT Event Suites m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Suites -> ConduitT Event Suites m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Maybe Suites -> ConduitT Event Suites m ())
-> ConduitT Event Suites m (Maybe Suites)
-> ConduitT Event Suites m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ConduitT Event Suites m (Maybe Suites)
forall (m :: * -> *) o.
MonadThrow m =>
ConduitT Event o m (Maybe Suites)
parseSuite
 where
  parseSuite :: ConduitT Event o m (Maybe Suites)
parseSuite =
    NameMatcher Name
-> AttrParser Text
-> (Text -> ConduitT Event o m Suites)
-> ConduitT Event o m (Maybe Suites)
forall (m :: * -> *) a b o c.
MonadThrow m =>
NameMatcher a
-> AttrParser b
-> (b -> ConduitT Event o m c)
-> ConduitT Event o m (Maybe c)
tag' NameMatcher Name
"testsuites" (Name -> AttrParser Text
requireAttr Name
"name") ((Text -> ConduitT Event o m Suites)
 -> ConduitT Event o m (Maybe Suites))
-> (Text -> ConduitT Event o m Suites)
-> ConduitT Event o m (Maybe Suites)
forall a b. (a -> b) -> a -> b
$ \Text
name -> Text -> [Suite] -> Suites
Suites Text
name ([Suite] -> Suites)
-> ConduitT Event o m [Suite] -> ConduitT Event o m Suites
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT Event o m (Maybe Suite) -> ConduitT Event o m [Suite]
forall (m :: * -> *) o a.
Monad m =>
ConduitT Event o m (Maybe a) -> ConduitT Event o m [a]
many ConduitT Event o m (Maybe Suite)
forall (m :: * -> *) o.
MonadThrow m =>
ConduitT Event o m (Maybe Suite)
suite

suite :: MonadThrow m => ConduitT Event o m (Maybe Suite)
suite :: ConduitT Event o m (Maybe Suite)
suite = NameMatcher Name
-> AttrParser Text
-> (Text -> ConduitT Event o m Suite)
-> ConduitT Event o m (Maybe Suite)
forall (m :: * -> *) a b o c.
MonadThrow m =>
NameMatcher a
-> AttrParser b
-> (b -> ConduitT Event o m c)
-> ConduitT Event o m (Maybe c)
tag' NameMatcher Name
"testsuite" (Name -> AttrParser Text
requireAttr Name
"name") ((Text -> ConduitT Event o m Suite)
 -> ConduitT Event o m (Maybe Suite))
-> (Text -> ConduitT Event o m Suite)
-> ConduitT Event o m (Maybe Suite)
forall a b. (a -> b) -> a -> b
$ \Text
name ->
  Text -> [Either Suite TestCase] -> Suite
Suite Text
name ([Either Suite TestCase] -> Suite)
-> ConduitT Event o m [Either Suite TestCase]
-> ConduitT Event o m Suite
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT Event o m (Maybe (Either Suite TestCase))
-> ConduitT Event o m [Either Suite TestCase]
forall (m :: * -> *) o a.
Monad m =>
ConduitT Event o m (Maybe a) -> ConduitT Event o m [a]
many ([ConduitT Event o m (Maybe (Either Suite TestCase))]
-> ConduitT Event o m (Maybe (Either Suite TestCase))
forall (m :: * -> *) o a.
Monad m =>
[ConduitT Event o m (Maybe a)] -> ConduitT Event o m (Maybe a)
choose [(TestCase -> Either Suite TestCase)
-> Maybe TestCase -> Maybe (Either Suite TestCase)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TestCase -> Either Suite TestCase
forall a b. b -> Either a b
Right (Maybe TestCase -> Maybe (Either Suite TestCase))
-> ConduitT Event o m (Maybe TestCase)
-> ConduitT Event o m (Maybe (Either Suite TestCase))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT Event o m (Maybe TestCase)
forall (m :: * -> *) o.
MonadThrow m =>
ConduitT Event o m (Maybe TestCase)
testCase, (Suite -> Either Suite TestCase)
-> Maybe Suite -> Maybe (Either Suite TestCase)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Suite -> Either Suite TestCase
forall a b. a -> Either a b
Left (Maybe Suite -> Maybe (Either Suite TestCase))
-> ConduitT Event o m (Maybe Suite)
-> ConduitT Event o m (Maybe (Either Suite TestCase))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT Event o m (Maybe Suite)
forall (m :: * -> *) o.
MonadThrow m =>
ConduitT Event o m (Maybe Suite)
suite])

testCase :: MonadThrow m => ConduitT Event o m (Maybe TestCase)
testCase :: ConduitT Event o m (Maybe TestCase)
testCase =
  NameMatcher Name
-> AttrParser (Text, Text)
-> ((Text, Text) -> ConduitT Event o m TestCase)
-> ConduitT Event o m (Maybe TestCase)
forall (m :: * -> *) a b o c.
MonadThrow m =>
NameMatcher a
-> AttrParser b
-> (b -> ConduitT Event o m c)
-> ConduitT Event o m (Maybe c)
tag' NameMatcher Name
"testcase" ((,) (Text -> Text -> (Text, Text))
-> AttrParser Text -> AttrParser (Text -> (Text, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> AttrParser Text
requireAttr Name
"name" AttrParser (Text -> (Text, Text))
-> AttrParser Text -> AttrParser (Text, Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Name -> AttrParser Text
requireAttr Name
"classname")
    (((Text, Text) -> ConduitT Event o m TestCase)
 -> ConduitT Event o m (Maybe TestCase))
-> ((Text, Text) -> ConduitT Event o m TestCase)
-> ConduitT Event o m (Maybe TestCase)
forall a b. (a -> b) -> a -> b
$ \(Text
name, Text
className) -> Text -> Text -> Maybe Result -> TestCase
TestCase Text
className Text
name (Maybe Result -> TestCase)
-> ConduitT Event o m (Maybe Result) -> ConduitT Event o m TestCase
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT Event o m (Maybe Result)
forall (m :: * -> *) o.
MonadThrow m =>
ConduitT Event o m (Maybe Result)
result

result :: MonadThrow m => ConduitT Event o m (Maybe Result)
result :: ConduitT Event o m (Maybe Result)
result = [ConduitT Event o m (Maybe Result)]
-> ConduitT Event o m (Maybe Result)
forall (m :: * -> *) o a.
Monad m =>
[ConduitT Event o m (Maybe a)] -> ConduitT Event o m (Maybe a)
choose
  [ NameMatcher Name
-> AttrParser Text
-> (Text -> ConduitT Event o m Result)
-> ConduitT Event o m (Maybe Result)
forall (m :: * -> *) a b o c.
MonadThrow m =>
NameMatcher a
-> AttrParser b
-> (b -> ConduitT Event o m c)
-> ConduitT Event o m (Maybe c)
tag' NameMatcher Name
"failure" (Name -> AttrParser Text
requireAttr Name
"type") ((Text -> ConduitT Event o m Result)
 -> ConduitT Event o m (Maybe Result))
-> (Text -> ConduitT Event o m Result)
-> ConduitT Event o m (Maybe Result)
forall a b. (a -> b) -> a -> b
$ \Text
fType -> Text -> Text -> Result
Failure Text
fType (Text -> Result)
-> ConduitT Event o m Text -> ConduitT Event o m Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT Event o m Text
forall (m :: * -> *) o. MonadThrow m => ConduitT Event o m Text
content
  , NameMatcher Name
-> ConduitT Event o m Result -> ConduitT Event o m (Maybe Result)
forall (m :: * -> *) a o b.
MonadThrow m =>
NameMatcher a
-> ConduitT Event o m b -> ConduitT Event o m (Maybe b)
tagNoAttr NameMatcher Name
"skipped" (ConduitT Event o m Result -> ConduitT Event o m (Maybe Result))
-> ConduitT Event o m Result -> ConduitT Event o m (Maybe Result)
forall a b. (a -> b) -> a -> b
$ Text -> Result
Skipped (Text -> Result)
-> ConduitT Event o m Text -> ConduitT Event o m Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT Event o m Text
forall (m :: * -> *) o. MonadThrow m => ConduitT Event o m Text
content
  ]