{-# 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 Tuple
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
  List TestSuite
results <- SuiteResult -> IO (List TestSuite)
testResults SuiteResult
result
  FilePath -> List TestSuite -> IO ()
JUnit.writeXmlReport FilePath
path List TestSuite
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 (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
    Internal.OnlysPassed [SingleTest TracingSpan]
passed [SingleTest NotRan]
skipped ->
      List TestSuite -> IO (List TestSuite)
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 (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 (TracingSpan, Failure)]
failed -> do
      [Maybe (SrcLoc, ByteString)]
srcLocs <-
        (SingleTest (TracingSpan, Failure) -> SingleTest Failure)
-> [SingleTest (TracingSpan, Failure)] -> List (SingleTest Failure)
forall a b. (a -> b) -> List a -> List b
List.map (((TracingSpan, Failure) -> Failure)
-> SingleTest (TracingSpan, Failure) -> SingleTest Failure
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map (TracingSpan, Failure) -> Failure
forall a b. (a, b) -> b
Tuple.second) [SingleTest (TracingSpan, Failure)]
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)
Prelude.traverse SingleTest Failure -> IO (Maybe (SrcLoc, ByteString))
Test.Reporter.Internal.readSrcLoc
      let renderedFailed :: List TestSuite
renderedFailed = (SingleTest (TracingSpan, Failure)
 -> Maybe (SrcLoc, ByteString) -> TestSuite)
-> [SingleTest (TracingSpan, Failure)]
-> [Maybe (SrcLoc, ByteString)]
-> List TestSuite
forall a b result.
(a -> b -> result) -> List a -> List b -> List result
List.map2 SingleTest (TracingSpan, Failure)
-> Maybe (SrcLoc, ByteString) -> TestSuite
renderFailed [SingleTest (TracingSpan, Failure)]
failed [Maybe (SrcLoc, ByteString)]
srcLocs
      List TestSuite -> IO (List TestSuite)
forall (f :: * -> *) a. Applicative f => a -> f a
Prelude.pure
        ( List TestSuite
renderedFailed
            List TestSuite -> List TestSuite -> List TestSuite
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ (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
        )
    SuiteResult
Internal.NoTestsInSuite -> List TestSuite -> IO (List TestSuite)
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
|> Double -> TestReport Passed -> TestReport Passed
forall outcome. Double -> TestReport outcome -> TestReport outcome
JUnit.time (TracingSpan -> Double
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 (Platform.TracingSpan, Internal.Failure) ->
  Maybe (Stack.SrcLoc, BS.ByteString) ->
  JUnit.TestSuite
renderFailed :: SingleTest (TracingSpan, Failure)
-> Maybe (SrcLoc, ByteString) -> TestSuite
renderFailed SingleTest (TracingSpan, Failure)
test Maybe (SrcLoc, ByteString)
maybeSrcLoc =
  case SingleTest (TracingSpan, Failure) -> (TracingSpan, Failure)
forall a. SingleTest a -> a
Internal.body SingleTest (TracingSpan, Failure)
test of
    (TracingSpan
tracingSpan, Internal.FailedAssertion Text
msg Maybe 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.renderChunksBS 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 (TracingSpan, Failure) -> Text
forall a. SingleTest a -> Text
Internal.name SingleTest (TracingSpan, Failure)
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
|> ( case SingleTest (TracingSpan, Failure) -> Maybe Text
forall a. SingleTest a -> Maybe Text
stackFrame SingleTest (TracingSpan, Failure)
test of
                   Maybe Text
Nothing -> TestReport Failed -> TestReport Failed
forall a. a -> a
identity
                   Just Text
frame -> [Text] -> TestReport Failed -> TestReport Failed
JUnit.failureStackTrace [Text
frame]
               )
            TestReport Failed
-> (TestReport Failed -> TestReport Failed) -> TestReport Failed
forall a b. a -> (a -> b) -> b
|> Double -> TestReport Failed -> TestReport Failed
forall outcome. Double -> TestReport outcome -> TestReport outcome
JUnit.time (TracingSpan -> Double
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 (TracingSpan, Failure) -> Text
forall a. SingleTest a -> Text
suiteName SingleTest (TracingSpan, Failure)
test)
    (TracingSpan
tracingSpan, Internal.ThrewException SomeException
err) ->
      Text -> TestReport Errored
JUnit.errored (SingleTest (TracingSpan, Failure) -> Text
forall a. SingleTest a -> Text
Internal.name SingleTest (TracingSpan, Failure)
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
|> ( case SingleTest (TracingSpan, Failure) -> Maybe Text
forall a. SingleTest a -> Maybe Text
stackFrame SingleTest (TracingSpan, Failure)
test of
               Maybe Text
Nothing -> TestReport Errored -> TestReport Errored
forall a. a -> a
identity
               Just Text
frame -> [Text] -> TestReport Errored -> TestReport Errored
JUnit.errorStackTrace [Text
frame]
           )
        TestReport Errored
-> (TestReport Errored -> TestReport Errored) -> TestReport Errored
forall a b. a -> (a -> b) -> b
|> Double -> TestReport Errored -> TestReport Errored
forall outcome. Double -> TestReport outcome -> TestReport outcome
JUnit.time (TracingSpan -> Double
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 (TracingSpan, Failure) -> Text
forall a. SingleTest a -> Text
suiteName SingleTest (TracingSpan, Failure)
test)
    (TracingSpan
tracingSpan, Failure
Internal.TookTooLong) ->
      Text -> TestReport Errored
JUnit.errored (SingleTest (TracingSpan, Failure) -> Text
forall a. SingleTest a -> Text
Internal.name SingleTest (TracingSpan, Failure)
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
|> ( case SingleTest (TracingSpan, Failure) -> Maybe Text
forall a. SingleTest a -> Maybe Text
stackFrame SingleTest (TracingSpan, Failure)
test of
               Maybe Text
Nothing -> TestReport Errored -> TestReport Errored
forall a. a -> a
identity
               Just Text
frame -> [Text] -> TestReport Errored -> TestReport Errored
JUnit.errorStackTrace [Text
frame]
           )
        TestReport Errored
-> (TestReport Errored -> TestReport Errored) -> TestReport Errored
forall a b. a -> (a -> b) -> b
|> Double -> TestReport Errored -> TestReport Errored
forall outcome. Double -> TestReport outcome -> TestReport outcome
JUnit.time (TracingSpan -> Double
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 (TracingSpan, Failure) -> Text
forall a. SingleTest a -> Text
suiteName SingleTest (TracingSpan, Failure)
test)
    (TracingSpan
tracingSpan, Internal.TestRunnerMessedUp Text
msg) ->
      Text -> TestReport Errored
JUnit.errored (SingleTest (TracingSpan, Failure) -> Text
forall a. SingleTest a -> Text
Internal.name SingleTest (TracingSpan, Failure)
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
|> ( case SingleTest (TracingSpan, Failure) -> Maybe Text
forall a. SingleTest a -> Maybe Text
stackFrame SingleTest (TracingSpan, Failure)
test of
               Maybe Text
Nothing -> TestReport Errored -> TestReport Errored
forall a. a -> a
identity
               Just Text
frame -> [Text] -> TestReport Errored -> TestReport Errored
JUnit.errorStackTrace [Text
frame]
           )
        TestReport Errored
-> (TestReport Errored -> TestReport Errored) -> TestReport Errored
forall a b. a -> (a -> b) -> b
|> Double -> TestReport Errored -> TestReport Errored
forall outcome. Double -> TestReport outcome -> TestReport outcome
JUnit.time (TracingSpan -> Double
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 (TracingSpan, Failure) -> Text
forall a. SingleTest a -> Text
suiteName SingleTest (TracingSpan, Failure)
test)

suiteName :: Internal.SingleTest a -> Text
suiteName :: 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 -> Maybe Text
stackFrame :: SingleTest a -> Maybe Text
stackFrame SingleTest a
test =
  SingleTest a -> Maybe SrcLoc
forall a. SingleTest a -> Maybe SrcLoc
Internal.loc SingleTest a
test
    Maybe SrcLoc -> (Maybe SrcLoc -> Maybe Text) -> Maybe Text
forall a b. a -> (a -> b) -> b
|> (SrcLoc -> Text) -> Maybe SrcLoc -> Maybe Text
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map
      ( \SrcLoc
loc ->
          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 -> Double
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 -> Double
forall a b. (Integral a, Num b) => a -> b
Prelude.fromIntegral (MonotonicTime -> Word64
Platform.inMicroseconds MonotonicTime
duration') Double -> Double -> Double
/ Double
1000_000

createPathDirIfMissing :: FilePath.FilePath -> Prelude.IO ()
createPathDirIfMissing :: FilePath -> IO ()
createPathDirIfMissing FilePath
path = do
  FilePath
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)
  Bool -> FilePath -> IO ()
Directory.createDirectoryIfMissing Bool
True FilePath
dirPath