0 | module Evince.Reporter.JUnit
  1 |
  2 | import Data.IORef
  3 | import Data.List
  4 | import Data.SnocList
  5 | import Data.String
  6 | import System.File
  7 | import Evince.Core
  8 | import Evince.Diff
  9 | import Evince.Report
 10 | import Evince.Reporter
 11 |
 12 | escape : String -> String
 13 | escape = concatMap escChar . unpack
 14 |   where
 15 |     escChar : Char -> String
 16 |     escChar '&'  = "&"
 17 |     escChar '<'  = "&lt;"
 18 |     escChar '>'  = "&gt;"
 19 |     escChar '"'  = "&quot;"
 20 |     escChar '\'' = "&apos;"
 21 |     escChar c    = singleton c
 22 |
 23 | splitLast : List String -> (List String, String)
 24 | splitLast [] = ([], "")
 25 | splitLast [x] = ([], x)
 26 | splitLast (x :: xs) = let (pre, l) = splitLast xs in (x :: pre, l)
 27 |
 28 | classname : List String -> String
 29 | classname path = concat (intersperse "." (fst (splitLast path)))
 30 |
 31 | testName : List String -> String
 32 | testName path = snd (splitLast path)
 33 |
 34 | locAttrs : Maybe SrcLoc -> String
 35 | locAttrs Nothing = ""
 36 | locAttrs (Just loc) = " file=\"" ++ escape loc.file ++ "\" line=\"" ++ show (loc.line + 1) ++ "\""
 37 |
 38 | renderTestCase : TestReport -> String
 39 | renderTestCase report =
 40 |   let cn   = escape (classname report.path)
 41 |       name = escape (testName report.path)
 42 |       loc  = locAttrs report.loc
 43 |   in case report.outcome of
 44 |        Passed elapsed =>
 45 |          "    <testcase name=\"" ++ name ++ "\" classname=\"" ++ cn
 46 |            ++ "\"" ++ loc ++ " time=\"" ++ nanosToSeconds elapsed ++ "\"/>\n"
 47 |        Failed info elapsed =>
 48 |          let msg = case failureDiff info of
 49 |                Just (reason, diffs) =>
 50 |                  reason ++ "\n" ++ unlines (map renderLineDiffPlain diffs)
 51 |                Nothing => show info
 52 |          in "    <testcase name=\"" ++ name ++ "\" classname=\"" ++ cn
 53 |            ++ "\"" ++ loc ++ " time=\"" ++ nanosToSeconds elapsed ++ "\">\n"
 54 |            ++ "      <failure message=\"" ++ escape msg ++ "\"/>\n"
 55 |            ++ "    </testcase>\n"
 56 |        Skipped reason =>
 57 |          "    <testcase name=\"" ++ name ++ "\" classname=\"" ++ cn ++ "\"" ++ loc ++ ">\n"
 58 |            ++ "      <skipped"
 59 |            ++ maybe "/>\n" (\r => " message=\"" ++ escape r ++ "\"/>\n") reason
 60 |            ++ "    </testcase>\n"
 61 |
 62 | countFailures : List TestReport -> Nat
 63 | countFailures = foldl (\acc, r => case r.outcome of Failed _ _ => S acc; _ => acc) 0
 64 |
 65 | countSkipped : List TestReport -> Nat
 66 | countSkipped = foldl (\acc, r => case r.outcome of Skipped _ => S acc; _ => acc) 0
 67 |
 68 | totalTime : List TestReport -> Integer
 69 | totalTime = foldl (\acc, r => case r.outcome of
 70 |   Passed e => acc + e; Failed _ e => acc + e; Skipped _ => acc) 0
 71 |
 72 | ||| Render test reports as a JUnit XML string.
 73 | export
 74 | renderXml : List TestReport -> String
 75 | renderXml reports =
 76 |   "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"
 77 |     ++ "<testsuites>\n"
 78 |     ++ "  <testsuite name=\"evince\" tests=\"" ++ show (length reports)
 79 |     ++ "\" failures=\"" ++ show (countFailures reports)
 80 |     ++ "\" skipped=\"" ++ show (countSkipped reports)
 81 |     ++ "\" time=\"" ++ nanosToSeconds (totalTime reports) ++ "\">\n"
 82 |     ++ concatMap renderTestCase reports
 83 |     ++ "  </testsuite>\n"
 84 |     ++ "</testsuites>\n"
 85 |
 86 | writeJUnitXml : String -> List TestReport -> IO ()
 87 | writeJUnitXml filepath reports = do
 88 |   Right () <- writeFile filepath (renderXml reports)
 89 |     | Left err => putStrLn $ "Error writing JUnit XML: " ++ show err
 90 |   pure ()
 91 |
 92 | ||| Create a JUnit XML reporter that accumulates test results and writes
 93 | ||| them to the given file path when the suite completes.
 94 | export
 95 | junitReporter : String -> IO Reporter
 96 | junitReporter filepath = do
 97 |   ref <- newIORef {a = SnocList TestReport} [<]
 98 |   pure $ MkReporter $ \case
 99 |     TestDone report _ => modifyIORef ref (:< report)
100 |     SuiteDone _       => do
101 |       reports <- readIORef ref
102 |       writeJUnitXml filepath (reports <>> [])
103 |     _                 => pure ()
104 |