{-# 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.Text
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 Text
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
  FilePath -> [TestSuite] -> IO ()
JUnit.writeXmlReport FilePath
path (SuiteResult -> [TestSuite]
testResults SuiteResult
result)

testResults :: Internal.SuiteResult -> List JUnit.TestSuite
testResults :: SuiteResult -> [TestSuite]
testResults SuiteResult
result =
  case SuiteResult
result of
    Internal.AllPassed [SingleTest TracingSpan]
passed ->
      (SingleTest TracingSpan -> TestSuite)
-> [SingleTest TracingSpan] -> [TestSuite]
forall a b. (a -> b) -> List a -> List b
List.map SingleTest TracingSpan -> TestSuite
renderPassed [SingleTest TracingSpan]
passed
    Internal.OnlysPassed [SingleTest TracingSpan]
passed [SingleTest NotRan]
skipped ->
      (SingleTest NotRan -> TestSuite)
-> [SingleTest NotRan] -> [TestSuite]
forall a b. (a -> b) -> List a -> List b
List.map SingleTest NotRan -> TestSuite
renderSkipped [SingleTest NotRan]
skipped
        [TestSuite] -> [TestSuite] -> [TestSuite]
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ (SingleTest TracingSpan -> TestSuite)
-> [SingleTest TracingSpan] -> [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 ->
      (SingleTest NotRan -> TestSuite)
-> [SingleTest NotRan] -> [TestSuite]
forall a b. (a -> b) -> List a -> List b
List.map SingleTest NotRan -> TestSuite
renderSkipped [SingleTest NotRan]
skipped
        [TestSuite] -> [TestSuite] -> [TestSuite]
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ (SingleTest TracingSpan -> TestSuite)
-> [SingleTest TracingSpan] -> [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 ->
      (SingleTest (TracingSpan, Failure) -> TestSuite)
-> [SingleTest (TracingSpan, Failure)] -> [TestSuite]
forall a b. (a -> b) -> List a -> List b
List.map SingleTest (TracingSpan, Failure) -> TestSuite
renderFailed [SingleTest (TracingSpan, Failure)]
failed
        [TestSuite] -> [TestSuite] -> [TestSuite]
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ (SingleTest NotRan -> TestSuite)
-> [SingleTest NotRan] -> [TestSuite]
forall a b. (a -> b) -> List a -> List b
List.map SingleTest NotRan -> TestSuite
renderSkipped [SingleTest NotRan]
skipped
        [TestSuite] -> [TestSuite] -> [TestSuite]
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ (SingleTest TracingSpan -> TestSuite)
-> [SingleTest TracingSpan] -> [TestSuite]
forall a b. (a -> b) -> List a -> List b
List.map SingleTest TracingSpan -> TestSuite
renderPassed [SingleTest TracingSpan]
passed
    SuiteResult
Internal.NoTestsInSuite -> []

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) -> JUnit.TestSuite
renderFailed :: SingleTest (TracingSpan, Failure) -> TestSuite
renderFailed SingleTest (TracingSpan, Failure)
test =
  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
_) ->
      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