module Test.Hspec.JUnit
( configWithJUnit
, junitFormat
, module Test.Hspec.JUnit.Config
) where
import Prelude
import Data.Conduit (runConduitRes, (.|))
import Data.Conduit.Combinators (sinkFile)
import Data.Conduit.List (sourceList)
import Data.Functor ((<&>))
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Text (Text, pack, unpack)
import qualified Data.Text as T
import Data.Time (getCurrentTime)
import System.Directory (createDirectoryIfMissing)
import System.FilePath (splitFileName)
import Test.Hspec.Core.Format
import Test.Hspec.Core.Runner
import Test.Hspec.JUnit.Config
import Test.Hspec.JUnit.Render (renderJUnit)
import qualified Test.Hspec.JUnit.Schema as Schema
import Text.XML.Stream.Render (def, renderBytes)
configWithJUnit :: JUnitConfig -> Config -> Config
configWithJUnit :: JUnitConfig -> Config -> Config
configWithJUnit JUnitConfig
junitConfig Config
config =
Config
config { configFormat :: Maybe (FormatConfig -> IO Format)
configFormat = (FormatConfig -> IO Format) -> Maybe (FormatConfig -> IO Format)
forall a. a -> Maybe a
Just ((FormatConfig -> IO Format) -> Maybe (FormatConfig -> IO Format))
-> (FormatConfig -> IO Format) -> Maybe (FormatConfig -> IO Format)
forall a b. (a -> b) -> a -> b
$ JUnitConfig -> FormatConfig -> IO Format
junitFormat JUnitConfig
junitConfig }
junitFormat :: JUnitConfig -> FormatConfig -> IO Format
junitFormat :: JUnitConfig -> FormatConfig -> IO Format
junitFormat JUnitConfig
junitConfig FormatConfig
_config = Format -> IO Format
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Format -> IO Format) -> Format -> IO Format
forall a b. (a -> b) -> a -> b
$ \case
Event
Started -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
GroupStarted Path
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
GroupDone Path
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Progress Path
_ Progress
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
ItemStarted Path
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
ItemDone Path
_ Item
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Done [(Path, Item)]
paths -> do
UTCTime
time <- IO UTCTime
getCurrentTime
let (String
directory, String
_) = String -> (String, String)
splitFileName String
file
Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
directory
let
groups :: [(Text, [(Text, Item)])]
groups = [(Path, Item)] -> [(Text, [(Text, Item)])]
groupItems [(Path, Item)]
paths
output :: Suites
output = Suites :: Text -> [Suite] -> Suites
Schema.Suites
{ suitesName :: Text
suitesName = Text
suiteName
, suitesSuites :: [Suite]
suitesSuites = [(Text, [(Text, Item)])]
groups [(Text, [(Text, Item)])]
-> ((Text, [(Text, Item)]) -> Suite) -> [Suite]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Text
group, [(Text, Item)]
items) -> do
let
suite :: [TestCase] -> Suite
suite [TestCase]
xs = Suite :: Text -> UTCTime -> [TestCase] -> Suite
Schema.Suite
{ suiteName :: Text
suiteName = Text
group
, suiteTimestamp :: UTCTime
suiteTimestamp = UTCTime
time
, suiteCases :: [TestCase]
suiteCases = [TestCase]
xs
}
[TestCase] -> Suite
suite ([TestCase] -> Suite) -> [TestCase] -> Suite
forall a b. (a -> b) -> a -> b
$ (Text -> Item -> TestCase) -> (Text, Item) -> TestCase
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((String -> String) -> Text -> Text -> Item -> TestCase
itemToTestCase String -> String
applyPrefix Text
group) ((Text, Item) -> TestCase) -> [(Text, Item)] -> [TestCase]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Item)]
items
}
ConduitT () Void (ResourceT IO) () -> IO ()
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes
(ConduitT () Void (ResourceT IO) () -> IO ())
-> ConduitT () Void (ResourceT IO) () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Suites] -> ConduitT () Suites (ResourceT IO) ()
forall (m :: * -> *) a i. Monad m => [a] -> ConduitT i a m ()
sourceList [Suites
output]
ConduitT () Suites (ResourceT IO) ()
-> ConduitM Suites Void (ResourceT IO) ()
-> ConduitT () Void (ResourceT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitT Suites Event (ResourceT IO) ()
forall (m :: * -> *). MonadThrow m => ConduitT Suites Event m ()
renderJUnit
ConduitT Suites Event (ResourceT IO) ()
-> ConduitM Event Void (ResourceT IO) ()
-> ConduitM Suites Void (ResourceT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| RenderSettings -> ConduitT Event ByteString (ResourceT IO) ()
forall (m :: * -> *).
PrimMonad m =>
RenderSettings -> ConduitT Event ByteString m ()
renderBytes RenderSettings
forall a. Default a => a
def
ConduitT Event ByteString (ResourceT IO) ()
-> ConduitM ByteString Void (ResourceT IO) ()
-> ConduitM Event Void (ResourceT IO) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| String -> ConduitM ByteString Void (ResourceT IO) ()
forall (m :: * -> *) o.
MonadResource m =>
String -> ConduitT ByteString o m ()
sinkFile String
file
where
file :: String
file = JUnitConfig -> String
getJUnitConfigOutputFile JUnitConfig
junitConfig
suiteName :: Text
suiteName = JUnitConfig -> Text
getJUnitConfigSuiteName JUnitConfig
junitConfig
applyPrefix :: String -> String
applyPrefix = JUnitConfig -> String -> String
getJUnitPrefixSourcePath JUnitConfig
junitConfig
groupItems :: [(Path, Item)] -> [(Text, [(Text, Item)])]
groupItems :: [(Path, Item)] -> [(Text, [(Text, Item)])]
groupItems = Map Text [(Text, Item)] -> [(Text, [(Text, Item)])]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Text [(Text, Item)] -> [(Text, [(Text, Item)])])
-> ([(Path, Item)] -> Map Text [(Text, Item)])
-> [(Path, Item)]
-> [(Text, [(Text, Item)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(Text, Item)] -> [(Text, Item)] -> [(Text, Item)])
-> [(Text, [(Text, Item)])] -> Map Text [(Text, Item)]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [(Text, Item)] -> [(Text, Item)] -> [(Text, Item)]
forall a. Semigroup a => a -> a -> a
(<>) ([(Text, [(Text, Item)])] -> Map Text [(Text, Item)])
-> ([(Path, Item)] -> [(Text, [(Text, Item)])])
-> [(Path, Item)]
-> Map Text [(Text, Item)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Path, Item) -> (Text, [(Text, Item)]))
-> [(Path, Item)] -> [(Text, [(Text, Item)])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Path, Item) -> (Text, [(Text, Item)])
forall b. (Path, b) -> (Text, [(Text, b)])
group
where
group :: (Path, b) -> (Text, [(Text, b)])
group (([String]
path, String
name), b
item) =
(Text -> [Text] -> Text
T.intercalate Text
"/" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
path, [(String -> Text
pack String
name, b
item)])
itemToTestCase
:: (FilePath -> FilePath) -> Text -> Text -> Item -> Schema.TestCase
itemToTestCase :: (String -> String) -> Text -> Text -> Item -> TestCase
itemToTestCase String -> String
applyPrefix Text
group Text
name Item
item = TestCase :: Text -> Text -> Double -> Maybe Result -> TestCase
Schema.TestCase
{ testCaseClassName :: Text
testCaseClassName = Text
group
, testCaseName :: Text
testCaseName = Text
name
, testCaseDuration :: Double
testCaseDuration = Seconds -> Double
unSeconds (Seconds -> Double) -> Seconds -> Double
forall a b. (a -> b) -> a -> b
$ Item -> Seconds
itemDuration Item
item
, testCaseResult :: Maybe Result
testCaseResult = case Item -> Result
itemResult Item
item of
Result
Success -> Maybe Result
forall a. Maybe a
Nothing
Pending Maybe Location
mLocation Maybe String
mMessage ->
Result -> Maybe Result
forall a. a -> Maybe a
Just (Result -> Maybe Result) -> Result -> Maybe Result
forall a b. (a -> b) -> a -> b
$ Text -> Result
Schema.Skipped (Text -> Result) -> Text -> Result
forall a b. (a -> b) -> a -> b
$ Maybe Location -> Text -> Text
prefixLocation Maybe Location
mLocation (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
prefixInfo (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> (String -> Text) -> Maybe String -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
Text
""
String -> Text
pack
Maybe String
mMessage
Failure Maybe Location
mLocation FailureReason
reason ->
Result -> Maybe Result
forall a. a -> Maybe a
Just
(Result -> Maybe Result) -> Result -> Maybe Result
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Result
Schema.Failure Text
"error"
(Text -> Result) -> Text -> Result
forall a b. (a -> b) -> a -> b
$ Maybe Location -> Text -> Text
prefixLocation Maybe Location
mLocation
(Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
prefixInfo
(Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ case FailureReason
reason of
Error Maybe String
_ SomeException
err -> String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
err
FailureReason
NoReason -> Text
"no reason"
Reason String
err -> String -> Text
pack String
err
ExpectedButGot Maybe String
preface String
expected String
actual ->
Text -> Text
prefixInfo
(Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines
([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
pack
(String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
preface
String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Text -> String -> [String]
forall a. Show a => Text -> a -> [String]
foundLines Text
"expected" String
expected
[String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> Text -> String -> [String]
forall a. Show a => Text -> a -> [String]
foundLines Text
" but got" String
actual
)
}
where
prefixLocation :: Maybe Location -> Text -> Text
prefixLocation Maybe Location
mLocation Text
str = case Maybe Location
mLocation of
Maybe Location
Nothing -> Text
str
Just Location {Int
String
locationFile :: Location -> String
locationLine :: Location -> Int
locationColumn :: Location -> Int
locationColumn :: Int
locationLine :: Int
locationFile :: String
..} ->
[Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
[ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> String
applyPrefix String
locationFile
, Text
":"
, String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
locationLine
, Text
":"
, String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
locationColumn
, Text
"\n"
]
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
str
prefixInfo :: Text -> Text
prefixInfo Text
str
| Text -> Bool
T.null (Text -> Bool) -> Text -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.strip (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Item -> String
itemInfo Item
item = Text
str
| Bool
otherwise = String -> Text
pack (Item -> String
itemInfo Item
item) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
str
unSeconds :: Seconds -> Double
unSeconds :: Seconds -> Double
unSeconds (Seconds Double
x) = Double
x
foundLines :: Show a => Text -> a -> [String]
foundLines :: Text -> a -> [String]
foundLines Text
msg a
found = case [Text]
lines' of
[] -> []
Text
first : [Text]
rest ->
Text -> String
unpack (Text
msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
first) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Text -> String
unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Text -> Text
T.replicate Int
9 Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> String) -> [Text] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
rest)
where lines' :: [Text]
lines' = Text -> [Text]
T.lines (Text -> [Text]) -> (String -> Text) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> [Text]) -> String -> [Text]
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
found