Add standard output to the JUnit report

3 files changed, 75 insertions, 27 deletions

diff --git a/src/JUnit.hs b/src/JUnit.hs
index 71fe3c1..03e07ec 100644
--- a/src/JUnit.hs
+++ b/src/JUnit.hs
@@ -9,6 +9,7 @@ import Data.ByteString.Char8 qualified as BC
 import Data.Function
 import Data.List.NonEmpty qualified as NE
 import Data.Scientific
+import Data.Text qualified as T
 import Data.Text.Encoding
 
 import System.Directory
@@ -34,15 +35,26 @@ writeJUnitReport path Report {..} = do
                 B.hPutStr h $ B.concat
                     [ "<testcase name=\"", encodeUtf8 (testNameBase reportTestName), "\""
                     , " classname=\"", encodeUtf8 (textModuleName $ testNameModule reportTestName), "\""
-                    , " time=\"", showTime reportTime, "\""
+                    , " time=\"", showTime reportTime, "\">"
+                    , "<system-out>"
+                    , encodeUtf8 $ escape reportOutput
+                    , "</system-out>"
                     , case reportTestFailed of
                         Nothing -> do
-                            " />"
+                            ""
                         Just Failed -> do
-                            "><failure message=\"Test failed\"></failure></testcase>"
+                            "<failure message=\"Test failed\">" <> encodeUtf8 (escape reportOutputError) <> "</failure>"
                         Just (ProcessCrashed _) -> do
-                            "><error message=\"Process crashed\"></error></testcase>"
+                            "<error message=\"Process crashed\">" <> encodeUtf8 (escape reportOutputError) <> "</error>"
+                    , "</testcase>"
                     ]
 
             B.hPutStr h $ "</testsuite>"
         B.hPutStr h $ "</testsuites>\n"
+
+  where
+    escape = T.concatMap $ \case
+        '&' -> "&amp;"
+        '<' -> "&lt;"
+        '>' -> "&gt;"
+        c -> T.singleton c
diff --git a/src/Output.hs b/src/Output.hs
index 962a594..b0744d4 100644
--- a/src/Output.hs
+++ b/src/Output.hs
@@ -8,6 +8,8 @@ module Output (
     outLineF,
     outPromptGetLine,
     outPromptGetLineCompletion,
+    collectOutput,
+    collectErrorOutput,
 ) where
 
 import Control.Concurrent.MVar
@@ -48,6 +50,8 @@ data OutputConfig = OutputConfig
 data OutputState = OutputState
     { outPrint :: TL.Text -> IO ()
     , outHistory :: History
+    , outLines :: [ Text ]
+    , outErrLines :: [ Text ]
     }
 
 data OutputStyle
@@ -81,7 +85,12 @@ instance MonadIO m => MonadOutput (ReaderT Output m) where
 
 startOutput :: OutputStyle -> Bool -> IO Output
 startOutput outStyle outUseColor = do
-    outState <- newMVar OutputState { outPrint = TL.putStrLn, outHistory = emptyHistory }
+    outState <- newMVar OutputState
+        { outPrint = TL.putStrLn
+        , outHistory = emptyHistory
+        , outLines = []
+        , outErrLines = []
+        }
     outConfig <- pure OutputConfig {..}
     outStartedAt <- newMVar =<< getTime Monotonic
     hSetBuffering stdout LineBuffering
@@ -161,13 +170,17 @@ outTestLabel = \case
 
 printWhenQuiet :: OutputType -> Bool
 printWhenQuiet = \case
-    OutputGlobalError -> True
     OutputGlobalSummary -> True
+    OutputAlways -> True
+    t -> printIsError t
+
+printIsError :: OutputType -> Bool
+printIsError = \case
+    OutputGlobalError -> True
     OutputChildStderr -> True
     OutputChildFail -> True
     OutputMatchFail {} -> True
     OutputError -> True
-    OutputAlways -> True
     _ -> False
 
 includeTestTime :: OutputType -> Bool
@@ -186,29 +199,37 @@ outLine otype prompt line = outLineF otype prompt (plainText line)
 outLineF :: MonadOutput m => OutputType -> Maybe Text -> FormattedText -> m ()
 outLineF otype prompt line = ioWithOutput $ \out ->
     case outStyle (outConfig out) of
-        OutputStyleQuiet
-            | printWhenQuiet otype -> normalOutput out
-            | otherwise -> return ()
-        OutputStyleVerbose -> normalOutput out
+        OutputStyleQuiet -> normalOutput (printWhenQuiet otype) out
+        OutputStyleVerbose -> normalOutput True out
         OutputStyleTest -> testOutput out
   where
-    normalOutput out = do
+    normalOutput normal out = do
         secs <- getElapsedTime out
-        withMVar (outState out) $ \st -> do
-            forM_ (normalOutputLines otype $ renderLine out line) $ \line' -> do
-                outPrint st $ TL.fromChunks $ concat
-                    [ if includeTestTime otype
-                        then [ T.pack $ printf "[% 2d.%03d] " (floor secs :: Integer) (floor (secs * 1000) `rem` 1000 :: Integer) ]
-                        else []
-                    , if outUseColor (outConfig out)
-                        then [ T.pack "\ESC[", outColor otype, T.pack "m" ]
-                        else []
-                    , [ maybe "" (<> outSign otype <> outArr otype <> " ") prompt ]
-                    , [ line' ]
-                    , if outUseColor (outConfig out)
-                        then [ T.pack "\ESC[0m" ]
-                        else []
-                    ]
+
+        let formatLine color line' = T.concat $ concat
+                [ if includeTestTime otype
+                    then [ T.pack $ printf "[% 2d.%03d] " (floor secs :: Integer) (floor (secs * 1000) `rem` 1000 :: Integer) ]
+                    else []
+                , if color
+                    then [ T.pack "\ESC[", outColor otype, T.pack "m" ]
+                    else []
+                , [ maybe "" (<> outSign otype <> outArr otype <> " ") prompt ]
+                , [ line' ]
+                , if color
+                    then [ T.pack "\ESC[0m" ]
+                    else []
+                ]
+
+        modifyMVar_ (outState out) $ \ost -> do
+            (\f -> foldM f ost (normalOutputLines otype $ renderLine out line)) $ \st line' -> do
+                when normal $ do
+                    outPrint st $ TL.fromStrict $ formatLine (outUseColor (outConfig out)) line'
+                return st
+                    { outLines = formatLine False line' : outLines st
+                    , outErrLines = (if printIsError otype
+                                      then (formatLine False line' :)
+                                      else id) $ outErrLines st
+                    }
 
     renderLine out
         | outUseColor (outConfig out) = fromAnsiText . renderAnsiText
@@ -273,3 +294,14 @@ outPromptGetLineCompletion compl prompt = ioWithOutput $ \out -> do
         return (x, st' { outPrint = outPrint st, outHistory = hist' })
     putMVar (outState out) st'
     return $ fmap T.pack x
+
+
+collectOutput :: Output -> IO Text
+collectOutput Output {..} = do
+    modifyMVar outState $ \st -> do
+        return ( st { outLines = [] }, T.unlines $ reverse $ outLines st )
+
+collectErrorOutput :: Output -> IO Text
+collectErrorOutput Output {..} = do
+    modifyMVar outState $ \st -> do
+        return ( st { outErrLines = [] }, T.unlines $ reverse $ outErrLines st )
diff --git a/src/Run.hs b/src/Run.hs
index 7e61c1f..1d637d3 100644
--- a/src/Run.hs
+++ b/src/Run.hs
@@ -75,6 +75,8 @@ data SingleTestReport = SingleTestReport
     { reportTestName :: TestName
     , reportTestFailed :: Maybe Failed
     , reportTime :: Scientific
+    , reportOutput :: Text
+    , reportOutputError :: Text
     }
 
 runTests :: Output -> TestOptions -> GlobalDefs -> [ Test ] -> IO Report
@@ -187,6 +189,8 @@ runTest out opts gdefs test = do
 
     ( res, [] ) <- takeMVar testRunResult
     reportTime <- getElapsedTime out
+    reportOutput <- collectOutput out
+    reportOutputError <- collectErrorOutput out
 
     void $ installHandler processStatusChanged oldHandler Nothing