1 files changed, 134 insertions, 0 deletions
diff --git a/third_party/bazel/rules_haskell/tools/coverage-reports/Main.hs b/third_party/bazel/rules_haskell/tools/coverage-reports/Main.hs
new file mode 100644
index 0000000000..5ab4dafdef
--- /dev/null
+++ b/third_party/bazel/rules_haskell/tools/coverage-reports/Main.hs
@@ -0,0 +1,134 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+import Control.Monad (forM_)
+
+import Control.Arrow.ListArrow (runLA)
+import Data.Either.Utils (maybeToEither)
+import Data.List (find)
+import Data.List.Safe (head, tail)
+import Data.List.Utils (split)
+import Data.Tree.NTree.TypeDefs (NTree(..))
+import Prelude hiding (head, tail)
+import System.Console.CmdArgs.Implicit (Data, Typeable, cmdArgs)
+import System.Directory (createDirectoryIfMissing)
+import System.Exit (exitFailure)
+import System.FilePath (FilePath, (</>), takeDirectory)
+import qualified Text.XML.HXT.Arrow.ReadDocument as XML
+import Text.XML.HXT.DOM.QualifiedName (localPart)
+import Text.XML.HXT.DOM.TypeDefs (XNode(..), XmlTree)
+import Text.XML.HXT.XPath.XPathEval (getXPath, getXPathSubTrees)
+
+data Args = Args
+  { testlog :: FilePath
+  , destdir :: FilePath
+  } deriving (Data, Typeable)
+
+data ReportFile = ReportFile
+  { content :: String
+  , filename :: FilePath
+  } deriving (Show)
+
+main :: IO ()
+main = do
+  Args {testlog, destdir} <- cmdArgs $ Args {testlog = "", destdir = ""}
+  if testlog == ""
+    then putStrLn noTestlogError >> exitFailure
+    else do
+      fileContents <- readFile testlog
+      let xmlTrees = runLA XML.xreadDoc fileContents
+      let rootTree = find isRoot xmlTrees
+      case rootTree of
+        Nothing -> do
+          putStrLn "Invalid XML format for testlog."
+          exitFailure
+        Just tree -> do
+          let reportFiles = generateReportFiles tree
+          case reportFiles of
+            Right reports ->
+              forM_ reports $ \ReportFile {content, filename} -> do
+                putStrLn $ concat ["Creating ", show $ destdir </> filename]
+                createDirectoryIfMissing
+                  True
+                  (destdir </> takeDirectory filename)
+                writeFile (destdir </> filename) content
+            Left err -> do
+              putStrLn err
+              exitFailure
+
+generateReportFiles :: XmlTree -> Either String [ReportFile]
+generateReportFiles doc =
+  let testSuites = getXPath "/testsuites/testsuite" doc
+   in concat <$> sequence (reportsForTestCase <$> testSuites)
+
+reportsForTestCase :: XmlTree -> Either String [ReportFile]
+reportsForTestCase testSuite = do
+  caseName <-
+    extractAttr =<<
+    maybeToEither
+      "Couldn't find testcase name."
+      (head (getXPathSubTrees "/testsuite/testcase/@name" testSuite))
+  let coverageOutputDirectory = takeDirectory caseName
+  testOutput <-
+    extractText =<<
+    maybeToEither
+      "Couldn't find system output."
+      (head (getXPathSubTrees "/testsuite/system-out" testSuite))
+  htmlPortion <-
+    maybeToEither
+      ("Couldn't find HTML report section in test case " ++ caseName ++ ".")
+      (head =<< tail (split testOutputSeparator testOutput))
+  let coverageReportPartXmlTrees = runLA XML.hreadDoc htmlPortion
+  traverse
+    (coveragePartToReportFile coverageOutputDirectory)
+    coverageReportPartXmlTrees
+
+coveragePartToReportFile :: FilePath -> XmlTree -> Either String ReportFile
+coveragePartToReportFile parentDirectory reportPart = do
+  filename <-
+    extractAttr =<<
+    maybeToEither
+      "Couldn't find report part name."
+      (head (getXPathSubTrees "/coverage-report-part/@name" reportPart))
+  content <- extractText reportPart
+  return $
+    ReportFile
+      { content = content
+      , filename = "coverage-reports" </> parentDirectory </> filename
+      }
+
+noTestlogError :: String
+noTestlogError =
+  unlines
+    [ "ERROR: You must specify the testlog XML file location with --testlog."
+    , "It is found inside the bazel-testlog, in the respective"
+    , "folder for the test you're interested in."
+    , "This must be after having run 'bazel coverage'."
+    ]
+
+isRoot :: XmlTree -> Bool
+isRoot tree =
+  case tree of
+    NTree (XTag name _) _ -> localPart name == "testsuites"
+    _ -> False
+
+extractAttr :: XmlTree -> Either String String
+extractAttr tree =
+  case tree of
+    NTree (XAttr _) [NTree (XText value) []] -> pure value
+    _ -> Left "Couldn't extract attribute from test XML."
+
+extractText :: XmlTree -> Either String String
+extractText tree =
+  let treeToText :: XmlTree -> String -> String
+      treeToText textTree acc =
+        case textTree of
+          (NTree (XText value) _) -> acc ++ value
+          _ -> ""
+   in case tree of
+        NTree (XTag _ _) textTree -> pure $ foldr treeToText "" textTree
+        _ -> Left "Couldn't extract text from test XML."
+
+testOutputSeparator :: String
+testOutputSeparator = "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"