WIP: integration: Allow generating tests results in ant xml format

integration/test/Testlib/Run.hs

@@ -28,17 +28,19 @@ import Text.Printf
 import UnliftIO.Async
 import Prelude
 
-data TestReport = TestReport
-  { count :: Int,
-    failures :: [String]
-  }
+newtype TestSuiteReport = TestSuiteReport {cases :: [TestCaseReport]}
   deriving (Eq, Show)
+  deriving newtype (Semigroup, Monoid)
 
-instance Semigroup TestReport where
-  TestReport s1 f1 <> TestReport s2 f2 = TestReport (s1 + s2) (f1 <> f2)
+data TestCaseReport = TestCaseReport
+  { name :: String,
+    result :: TestResult,
+    time :: NominalDiffTime
+  }
+  deriving (Eq, Show)
 
-instance Monoid TestReport where
-  mempty = TestReport 0 mempty
+data TestResult = Success | Failure String
+  deriving (Eq, Show)
 
 runTest :: GlobalEnv -> App a -> IO (Either String a)
 runTest ge action = lowerCodensity $ do
@@ -55,16 +57,18 @@ pluralise :: Int -> String -> String
 pluralise 1 x = x
 pluralise _ x = x <> "s"
 
-printReport :: TestReport -> IO ()
+printReport :: TestSuiteReport -> IO ()
 printReport report = do
-  unless (null report.failures) $ putStrLn $ "----------"
-  putStrLn $ show report.count <> " " <> pluralise report.count "test" <> " run."
-  unless (null report.failures) $ do
+  let numTests = length report.cases
+      failures = filter (\c -> c.result /= Success) report.cases
+      numFailures = length failures
+  when (numFailures > 0) $ putStrLn $ "----------"
+  putStrLn $ show numTests <> " " <> pluralise numTests "test" <> " run."
+  when (numFailures > 0) $ do
     putStrLn ""
-    let numFailures = length report.failures
     putStrLn $ colored red (show numFailures <> " failed " <> pluralise numFailures "test" <> ": ")
-    for_ report.failures $ \name ->
-      putStrLn $ " - " <> name
+    for_ failures $ \c ->
+      putStrLn $ " - " <> c.name
 
 testFilter :: TestOptions -> String -> Bool
 testFilter opts n = included n && not (excluded n)
@@ -149,14 +153,14 @@ runTests tests cfg = do
                 <> ") -----\n"
                 <> err
                 <> "\n"
-            pure (TestReport 1 [qname])
+            pure (TestSuiteReport [TestCaseReport qname (Failure err) tm])
           Right _ -> do
             writeOutput $ qname <> colored green " OK" <> " (" <> printTime tm <> ")" <> "\n"
-            pure (TestReport 1 [])
+            pure (TestSuiteReport [TestCaseReport qname Success tm])
     writeChan output Nothing
     wait displayThread
     printReport report
-    unless (null report.failures) $
+    unless (any (\c -> c.result /= Success) report.cases) $
       exitFailure
 
 doListTests :: [(String, String, String, x)] -> IO ()