{-# LANGUAGE NumericUnderscores #-}

-- | Module for presenting test results as a Junit XML file.
--
-- Lifted in large part from: https://github.com/stoeffel/tasty-test-reporter
module Test.Reporter.Junit
  ( report,
  )
where

import qualified Control.Exception.Safe as Exception
import qualified Data.ByteString as BS
import qualified Data.Text
import qualified Data.Text.Encoding as TE
import qualified GHC.Stack as Stack
import qualified List
import NriPrelude
import qualified Platform
import qualified System.Directory as Directory
import qualified System.FilePath as FilePath
import qualified Test.Internal as Internal
import qualified Test.Reporter.Internal
import qualified Text
import qualified Text.Colour
import qualified Text.XML.JUnit as JUnit
import qualified Prelude

report :: FilePath.FilePath -> Internal.SuiteResult -> Prelude.IO ()
report :: FilePath -> SuiteResult -> IO ()
report FilePath
path SuiteResult
result = do
  FilePath -> IO ()
createPathDirIfMissing FilePath
path
  results <- SuiteResult -> IO (List TestSuite)
testResults SuiteResult
result
  JUnit.writeXmlReport path results

testResults :: Internal.SuiteResult -> Prelude.IO (List JUnit.TestSuite)
testResults :: SuiteResult -> IO (List TestSuite)
testResults SuiteResult
result =
  case SuiteResult
result of
    Internal.AllPassed [SingleTest TracingSpan]
passed ->
      (SingleTest TracingSpan -> TestSuite)
-> [SingleTest TracingSpan] -> List TestSuite
forall a b. (a -> b) -> List a -> List b
List.map SingleTest TracingSpan -> TestSuite
renderPassed [SingleTest TracingSpan]
passed
        List TestSuite
-> (List TestSuite -> IO (List TestSuite)) -> IO (List TestSuite)
forall a b. a -> (a -> b) -> b
|> List TestSuite -> IO (List TestSuite)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
    Internal.OnlysPassed [SingleTest TracingSpan]
passed [SingleTest NotRan]
skipped ->
      List TestSuite -> IO (List TestSuite)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
        ( (SingleTest NotRan -> TestSuite)
-> [SingleTest NotRan] -> List TestSuite
forall a b. (a -> b) -> List a -> List b
List.map SingleTest NotRan -> TestSuite
renderSkipped [SingleTest NotRan]
skipped
            List TestSuite -> List TestSuite -> List TestSuite
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ (SingleTest TracingSpan -> TestSuite)
-> [SingleTest TracingSpan] -> List TestSuite
forall a b. (a -> b) -> List a -> List b
List.map SingleTest TracingSpan -> TestSuite
renderPassed [SingleTest TracingSpan]
passed
        )
    Internal.PassedWithSkipped [SingleTest TracingSpan]
passed [SingleTest NotRan]
skipped ->
      List TestSuite -> IO (List TestSuite)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
        ( (SingleTest NotRan -> TestSuite)
-> [SingleTest NotRan] -> List TestSuite
forall a b. (a -> b) -> List a -> List b
List.map SingleTest NotRan -> TestSuite
renderSkipped [SingleTest NotRan]
skipped
            List TestSuite -> List TestSuite -> List TestSuite
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ (SingleTest TracingSpan -> TestSuite)
-> [SingleTest TracingSpan] -> List TestSuite
forall a b. (a -> b) -> List a -> List b
List.map SingleTest TracingSpan -> TestSuite
renderPassed [SingleTest TracingSpan]
passed
        )
    Internal.TestsFailed [SingleTest TracingSpan]
passed [SingleTest NotRan]
skipped [SingleTest FailedSpan]
failed -> do
      srcLocs <-
        (SingleTest FailedSpan -> SingleTest Failure)
-> [SingleTest FailedSpan] -> List (SingleTest Failure)
forall a b. (a -> b) -> List a -> List b
List.map ((FailedSpan -> Failure)
-> SingleTest FailedSpan -> SingleTest Failure
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map (\(Internal.FailedSpan TracingSpan
_ Failure
failure) -> Failure
failure)) [SingleTest FailedSpan]
failed
          List (SingleTest Failure)
-> (List (SingleTest Failure) -> IO [Maybe (SrcLoc, ByteString)])
-> IO [Maybe (SrcLoc, ByteString)]
forall a b. a -> (a -> b) -> b
|> (SingleTest Failure -> IO (Maybe (SrcLoc, ByteString)))
-> List (SingleTest Failure) -> IO [Maybe (SrcLoc, ByteString)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
Prelude.traverse SingleTest Failure -> IO (Maybe (SrcLoc, ByteString))
Test.Reporter.Internal.readSrcLoc
      let renderedFailed = (SingleTest FailedSpan -> Maybe (SrcLoc, ByteString) -> TestSuite)
-> [SingleTest FailedSpan]
-> [Maybe (SrcLoc, ByteString)]
-> List TestSuite
forall a b result.
(a -> b -> result) -> List a -> List b -> List result
List.map2 SingleTest FailedSpan -> Maybe (SrcLoc, ByteString) -> TestSuite
renderFailed [SingleTest FailedSpan]
failed [Maybe (SrcLoc, ByteString)]
srcLocs
      Prelude.pure
        ( renderedFailed
            ++ List.map renderSkipped skipped
            ++ List.map renderPassed passed
        )
    SuiteResult
Internal.NoTestsInSuite -> List TestSuite -> IO (List TestSuite)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure []

renderPassed :: Internal.SingleTest Platform.TracingSpan -> JUnit.TestSuite
renderPassed :: SingleTest TracingSpan -> TestSuite
renderPassed SingleTest TracingSpan
test =
  Text -> TestReport Passed
JUnit.passed (SingleTest TracingSpan -> Text
forall a. SingleTest a -> Text
Internal.name SingleTest TracingSpan
test)
    TestReport Passed
-> (TestReport Passed -> TestReport Passed) -> TestReport Passed
forall a b. a -> (a -> b) -> b
|> Float -> TestReport Passed -> TestReport Passed
forall outcome. Float -> TestReport outcome -> TestReport outcome
JUnit.time (TracingSpan -> Float
duration (SingleTest TracingSpan -> TracingSpan
forall a. SingleTest a -> a
Internal.body SingleTest TracingSpan
test))
    TestReport Passed -> (TestReport Passed -> TestSuite) -> TestSuite
forall a b. a -> (a -> b) -> b
|> Text -> TestReport Passed -> TestSuite
forall outcome. Text -> TestReport outcome -> TestSuite
JUnit.inSuite (SingleTest TracingSpan -> Text
forall a. SingleTest a -> Text
suiteName SingleTest TracingSpan
test)

renderSkipped :: Internal.SingleTest Internal.NotRan -> JUnit.TestSuite
renderSkipped :: SingleTest NotRan -> TestSuite
renderSkipped SingleTest NotRan
test =
  Text -> TestReport Skipped
JUnit.skipped (SingleTest NotRan -> Text
forall a. SingleTest a -> Text
Internal.name SingleTest NotRan
test)
    TestReport Skipped
-> (TestReport Skipped -> TestSuite) -> TestSuite
forall a b. a -> (a -> b) -> b
|> Text -> TestReport Skipped -> TestSuite
forall outcome. Text -> TestReport outcome -> TestSuite
JUnit.inSuite (SingleTest NotRan -> Text
forall a. SingleTest a -> Text
suiteName SingleTest NotRan
test)

renderFailed ::
  Internal.SingleTest Internal.FailedSpan ->
  Maybe (Stack.SrcLoc, BS.ByteString) ->
  JUnit.TestSuite
renderFailed :: SingleTest FailedSpan -> Maybe (SrcLoc, ByteString) -> TestSuite
renderFailed SingleTest FailedSpan
test Maybe (SrcLoc, ByteString)
maybeSrcLoc =
  case SingleTest FailedSpan -> FailedSpan
forall a. SingleTest a -> a
Internal.body SingleTest FailedSpan
test of
    Internal.FailedSpan TracingSpan
tracingSpan (Internal.FailedAssertion Text
msg SrcLoc
_) ->
      let msg' :: Text
msg' = case Maybe (SrcLoc, ByteString)
maybeSrcLoc of
            Maybe (SrcLoc, ByteString)
Nothing -> Text
msg
            Just (SrcLoc
loc, ByteString
src) ->
              SrcLoc -> ByteString -> List Chunk
Test.Reporter.Internal.renderSrcLoc SrcLoc
loc ByteString
src
                List Chunk -> (List Chunk -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
|> TerminalCapabilities -> List Chunk -> ByteString
forall (f :: * -> *).
Foldable f =>
TerminalCapabilities -> f Chunk -> ByteString
Text.Colour.renderChunksUtf8BS TerminalCapabilities
Text.Colour.WithoutColours
                ByteString -> (ByteString -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> ByteString -> Text
TE.decodeUtf8
                Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> (\Text
srcStr -> Text
srcStr Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"\n" Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
msg)
       in Text -> TestReport Failed
JUnit.failed (SingleTest FailedSpan -> Text
forall a. SingleTest a -> Text
Internal.name SingleTest FailedSpan
test)
            TestReport Failed
-> (TestReport Failed -> TestReport Failed) -> TestReport Failed
forall a b. a -> (a -> b) -> b
|> Text -> TestReport Failed -> TestReport Failed
forall outcome. Text -> TestReport outcome -> TestReport outcome
JUnit.stderr Text
msg'
            TestReport Failed
-> (TestReport Failed -> TestReport Failed) -> TestReport Failed
forall a b. a -> (a -> b) -> b
|> [Text] -> TestReport Failed -> TestReport Failed
JUnit.failureStackTrace [SingleTest FailedSpan -> Text
forall a. SingleTest a -> Text
stackFrame SingleTest FailedSpan
test]
            TestReport Failed
-> (TestReport Failed -> TestReport Failed) -> TestReport Failed
forall a b. a -> (a -> b) -> b
|> Float -> TestReport Failed -> TestReport Failed
forall outcome. Float -> TestReport outcome -> TestReport outcome
JUnit.time (TracingSpan -> Float
duration TracingSpan
tracingSpan)
            TestReport Failed -> (TestReport Failed -> TestSuite) -> TestSuite
forall a b. a -> (a -> b) -> b
|> Text -> TestReport Failed -> TestSuite
forall outcome. Text -> TestReport outcome -> TestSuite
JUnit.inSuite (SingleTest FailedSpan -> Text
forall a. SingleTest a -> Text
suiteName SingleTest FailedSpan
test)
    Internal.FailedSpan TracingSpan
tracingSpan (Internal.ThrewException SomeException
err) ->
      Text -> TestReport Errored
JUnit.errored (SingleTest FailedSpan -> Text
forall a. SingleTest a -> Text
Internal.name SingleTest FailedSpan
test)
        TestReport Errored
-> (TestReport Errored -> TestReport Errored) -> TestReport Errored
forall a b. a -> (a -> b) -> b
|> Text -> TestReport Errored -> TestReport Errored
JUnit.errorMessage Text
"This test threw an exception."
        TestReport Errored
-> (TestReport Errored -> TestReport Errored) -> TestReport Errored
forall a b. a -> (a -> b) -> b
|> Text -> TestReport Errored -> TestReport Errored
forall outcome. Text -> TestReport outcome -> TestReport outcome
JUnit.stderr (FilePath -> Text
Data.Text.pack (SomeException -> FilePath
forall e. Exception e => e -> FilePath
Exception.displayException SomeException
err))
        TestReport Errored
-> (TestReport Errored -> TestReport Errored) -> TestReport Errored
forall a b. a -> (a -> b) -> b
|> [Text] -> TestReport Errored -> TestReport Errored
JUnit.errorStackTrace [SingleTest FailedSpan -> Text
forall a. SingleTest a -> Text
stackFrame SingleTest FailedSpan
test]
        TestReport Errored
-> (TestReport Errored -> TestReport Errored) -> TestReport Errored
forall a b. a -> (a -> b) -> b
|> Float -> TestReport Errored -> TestReport Errored
forall outcome. Float -> TestReport outcome -> TestReport outcome
JUnit.time (TracingSpan -> Float
duration TracingSpan
tracingSpan)
        TestReport Errored
-> (TestReport Errored -> TestSuite) -> TestSuite
forall a b. a -> (a -> b) -> b
|> Text -> TestReport Errored -> TestSuite
forall outcome. Text -> TestReport outcome -> TestSuite
JUnit.inSuite (SingleTest FailedSpan -> Text
forall a. SingleTest a -> Text
suiteName SingleTest FailedSpan
test)
    Internal.FailedSpan TracingSpan
tracingSpan (Failure
Internal.TookTooLong) ->
      Text -> TestReport Errored
JUnit.errored (SingleTest FailedSpan -> Text
forall a. SingleTest a -> Text
Internal.name SingleTest FailedSpan
test)
        TestReport Errored
-> (TestReport Errored -> TestReport Errored) -> TestReport Errored
forall a b. a -> (a -> b) -> b
|> Text -> TestReport Errored -> TestReport Errored
JUnit.errorMessage Text
"This test timed out."
        TestReport Errored
-> (TestReport Errored -> TestReport Errored) -> TestReport Errored
forall a b. a -> (a -> b) -> b
|> [Text] -> TestReport Errored -> TestReport Errored
JUnit.errorStackTrace [SingleTest FailedSpan -> Text
forall a. SingleTest a -> Text
stackFrame SingleTest FailedSpan
test]
        TestReport Errored
-> (TestReport Errored -> TestReport Errored) -> TestReport Errored
forall a b. a -> (a -> b) -> b
|> Float -> TestReport Errored -> TestReport Errored
forall outcome. Float -> TestReport outcome -> TestReport outcome
JUnit.time (TracingSpan -> Float
duration TracingSpan
tracingSpan)
        TestReport Errored
-> (TestReport Errored -> TestSuite) -> TestSuite
forall a b. a -> (a -> b) -> b
|> Text -> TestReport Errored -> TestSuite
forall outcome. Text -> TestReport outcome -> TestSuite
JUnit.inSuite (SingleTest FailedSpan -> Text
forall a. SingleTest a -> Text
suiteName SingleTest FailedSpan
test)
    Internal.FailedSpan TracingSpan
tracingSpan (Internal.TestRunnerMessedUp Text
msg) ->
      Text -> TestReport Errored
JUnit.errored (SingleTest FailedSpan -> Text
forall a. SingleTest a -> Text
Internal.name SingleTest FailedSpan
test)
        TestReport Errored
-> (TestReport Errored -> TestReport Errored) -> TestReport Errored
forall a b. a -> (a -> b) -> b
|> Text -> TestReport Errored -> TestReport Errored
JUnit.errorMessage
          ( Text -> [Text] -> Text
Text.join
              Text
"\n"
              [ Text
"Test runner encountered an unexpected error:",
                Text
msg,
                Text
"",
                Text
"This is a bug.",
                Text
"If you have some time to report the bug it would be much appreciated!",
                Text
"You can do so here: https://github.com/NoRedInk/haskell-libraries/issues"
              ]
          )
        TestReport Errored
-> (TestReport Errored -> TestReport Errored) -> TestReport Errored
forall a b. a -> (a -> b) -> b
|> [Text] -> TestReport Errored -> TestReport Errored
JUnit.errorStackTrace [SingleTest FailedSpan -> Text
forall a. SingleTest a -> Text
stackFrame SingleTest FailedSpan
test]
        TestReport Errored
-> (TestReport Errored -> TestReport Errored) -> TestReport Errored
forall a b. a -> (a -> b) -> b
|> Float -> TestReport Errored -> TestReport Errored
forall outcome. Float -> TestReport outcome -> TestReport outcome
JUnit.time (TracingSpan -> Float
duration TracingSpan
tracingSpan)
        TestReport Errored
-> (TestReport Errored -> TestSuite) -> TestSuite
forall a b. a -> (a -> b) -> b
|> Text -> TestReport Errored -> TestSuite
forall outcome. Text -> TestReport outcome -> TestSuite
JUnit.inSuite (SingleTest FailedSpan -> Text
forall a. SingleTest a -> Text
suiteName SingleTest FailedSpan
test)

suiteName :: Internal.SingleTest a -> Text
suiteName :: forall a. SingleTest a -> Text
suiteName SingleTest a
test =
  SingleTest a -> [Text]
forall a. SingleTest a -> [Text]
Internal.describes SingleTest a
test
    [Text] -> ([Text] -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> Text -> [Text] -> Text
Text.join Text
" - "

stackFrame :: Internal.SingleTest a -> Text
stackFrame :: forall a. SingleTest a -> Text
stackFrame SingleTest a
test =
  let loc :: SrcLoc
loc = SingleTest a -> SrcLoc
forall a. SingleTest a -> SrcLoc
Internal.loc SingleTest a
test
   in FilePath -> Text
Data.Text.pack
        ( SrcLoc -> FilePath
Stack.srcLocFile SrcLoc
loc
            FilePath -> FilePath -> FilePath
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ FilePath
":"
            FilePath -> FilePath -> FilePath
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Int -> FilePath
forall a. Show a => a -> FilePath
Prelude.show (SrcLoc -> Int
Stack.srcLocStartLine SrcLoc
loc)
        )

duration :: Platform.TracingSpan -> Float
duration :: TracingSpan -> Float
duration TracingSpan
test =
  let duration' :: MonotonicTime
duration' = TracingSpan -> MonotonicTime
Platform.finished TracingSpan
test MonotonicTime -> MonotonicTime -> MonotonicTime
forall number. Num number => number -> number -> number
- TracingSpan -> MonotonicTime
Platform.started TracingSpan
test
   in Word64 -> Float
forall a b. (Integral a, Num b) => a -> b
Prelude.fromIntegral (MonotonicTime -> Word64
Platform.inMicroseconds MonotonicTime
duration') Float -> Float -> Float
/ Float
1000_000

createPathDirIfMissing :: FilePath.FilePath -> Prelude.IO ()
createPathDirIfMissing :: FilePath -> IO ()
createPathDirIfMissing FilePath
path = do
  dirPath <- (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map FilePath -> FilePath
FilePath.takeDirectory (FilePath -> IO FilePath
Directory.canonicalizePath FilePath
path)
  Directory.createDirectoryIfMissing True dirPath