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 | firstLine : String -> String
 24 | firstLine s = case lines s of
 25 |   (l :: _) => l
 26 |   []       => s
 27 |
 28 | splitLast : List String -> (List String, String)
 29 | splitLast [] = ([], "")
 30 | splitLast [x] = ([], x)
 31 | splitLast (x :: xs) = let (pre, l) = splitLast xs in (x :: pre, l)
 32 |
 33 | classname : List String -> String
 34 | classname path = concat (intersperse "." (fst (splitLast path)))
 35 |
 36 | testName : List String -> String
 37 | testName path = snd (splitLast path)
 38 |
 39 | locAttrs : Maybe SrcLoc -> String
 40 | locAttrs Nothing = ""
 41 | locAttrs (Just loc) = " file=\"" ++ escape loc.file ++ "\" line=\"" ++ show (loc.line + 1) ++ "\""
 42 |
 43 | renderTestCase : TestReport -> String
 44 | renderTestCase report =
 45 |   let cn   = escape (classname report.path)
 46 |       name = escape (testName report.path)
 47 |       loc  = locAttrs report.loc
 48 |   in case report.outcome of
 49 |        Passed elapsed =>
 50 |          "    <testcase name=\"" ++ name ++ "\" classname=\"" ++ cn
 51 |            ++ "\"" ++ loc ++ " time=\"" ++ nanosToSeconds elapsed ++ "\"/>\n"
 52 |        Failed info elapsed =>
 53 |          let (msg, detail) = case failureDiff info of
 54 |                Just (reason, diffs) =>
 55 |                  (reason, reason ++ "\n" ++ unlines (map renderLineDiffPlain diffs))
 56 |                Nothing => (firstLine (show info), show info)
 57 |          in "    <testcase name=\"" ++ name ++ "\" classname=\"" ++ cn
 58 |            ++ "\"" ++ loc ++ " time=\"" ++ nanosToSeconds elapsed ++ "\">\n"
 59 |            ++ "      <failure message=\"" ++ escape msg ++ "\">"
 60 |            ++ escape detail ++ "</failure>\n"
 61 |            ++ "    </testcase>\n"
 62 |        Skipped reason =>
 63 |          "    <testcase name=\"" ++ name ++ "\" classname=\"" ++ cn ++ "\"" ++ loc ++ ">\n"
 64 |            ++ "      <skipped"
 65 |            ++ maybe "/>\n" (\r => " message=\"" ++ escape r ++ "\"/>\n") reason
 66 |            ++ "    </testcase>\n"
 67 |
 68 | countFailures : List TestReport -> Nat
 69 | countFailures = foldl (\acc, r => case r.outcome of Failed _ _ => S acc; _ => acc) 0
 70 |
 71 | countSkipped : List TestReport -> Nat
 72 | countSkipped = foldl (\acc, r => case r.outcome of Skipped _ => S acc; _ => acc) 0
 73 |
 74 | totalTime : List TestReport -> Integer
 75 | totalTime = foldl (\acc, r => case r.outcome of
 76 |   Passed e => acc + e; Failed _ e => acc + e; Skipped _ => acc) 0
 77 |
 78 | ||| Render test reports as a JUnit XML string.
 79 | export
 80 | renderXml : List TestReport -> String
 81 | renderXml reports =
 82 |   "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"
 83 |     ++ "<testsuites>\n"
 84 |     ++ "  <testsuite name=\"evince\" tests=\"" ++ show (length reports)
 85 |     ++ "\" failures=\"" ++ show (countFailures reports)
 86 |     ++ "\" errors=\"0"
 87 |     ++ "\" skipped=\"" ++ show (countSkipped reports)
 88 |     ++ "\" time=\"" ++ nanosToSeconds (totalTime reports) ++ "\">\n"
 89 |     ++ concatMap renderTestCase reports
 90 |     ++ "  </testsuite>\n"
 91 |     ++ "</testsuites>\n"
 92 |
 93 | writeJUnitXml : String -> List TestReport -> IO ()
 94 | writeJUnitXml filepath reports = do
 95 |   Right () <- writeFile filepath (renderXml reports)
 96 |     | Left err => ignore $ fPutStrLn stderr ("Error writing JUnit XML: " ++ show err)
 97 |   pure ()
 98 |
 99 | ||| Create a JUnit XML reporter that accumulates test results and writes
100 | ||| them to the given file path when the suite completes.
101 | export
102 | junitReporter : HasIO m => String -> m (Reporter m)
103 | junitReporter filepath = do
104 |   ref <- newIORef {a = SnocList TestReport} [<]
105 |   pure $ MkReporter $ \e => liftIO $ case e of
106 |     TestDone report _ => modifyIORef ref (:< report)
107 |     SuiteDone _       => do
108 |       reports <- readIORef ref
109 |       writeJUnitXml filepath (reports <>> [])
110 |     _                 => pure ()
111 |