From ee44e6e30a2074849af51199f99813141454e89c Mon Sep 17 00:00:00 2001
From: Eric Timmons <etimmons@mit.edu>
Date: Thu, 24 Feb 2022 13:26:25 -0500
Subject: [PATCH] Make junit reporting a bit better

---
 test/report.lisp | 62 ++++++++++++++++++++++++++++++++++++++++++------
 1 file changed, 55 insertions(+), 7 deletions(-)

diff --git a/test/report.lisp b/test/report.lisp
index 977681c..46086f2 100644
--- a/test/report.lisp
+++ b/test/report.lisp
@@ -12,6 +12,19 @@
 (defun duration-to-xml (duration)
   (format nil "~f" duration))
 
+(defgeneric failed-p (result)
+  (:method ((result para:result))
+    (eql :failed (para:status result)))
+  (:method ((result para:controlling-result))
+    (eql :failed (para:child-status result))))
+
+(defgeneric skipped-p (result)
+  (:method ((result para:result))
+    (eql :skipped (para:status result)))
+  (:method ((result para:controlling-result))
+    (eql :skipped (para:child-status result))))
+
+
 (defgeneric make-junit-node (result &key class-name))
 
 (defmethod make-junit-node ((result para:test-result) &key class-name)
@@ -20,8 +33,8 @@
          (child-results (remove-if (lambda (x) (typep x 'para:test-result))
                                    (para:results result)))
          (num-tests (length child-results))
-         (num-failures (count :failed child-results :key 'para:status))
-         (num-skipped (count :skipped child-results :key 'para:status))
+         (num-failures (count-if #'failed-p child-results))
+         (num-skipped (count-if #'skipped-p child-results))
          (name (result-name result))
          (class-name (format nil "~@[~a.~]~a" class-name name)))
     (xmls:make-node
@@ -42,9 +55,25 @@
 
 (defun result-name (result)
   (let ((expression (para:expression result)))
-    (if (typep expression 'para:test)
-        (para:name expression)
-        (format nil "~a" expression))))
+    (cond
+      ((typep expression 'para:test)
+       (para:name expression))
+      ;; ((typep result 'para:controlling-result)
+      ;;  (format nil "~a" (para:body result)))
+      (t
+       (or (para:description result)
+           (format nil "~a" expression))))))
+
+;; (defgeneric reason (result))
+
+;; (defmethod reason ((result para:test-result))
+;;   (para:description result))
+
+;; (defmethod reason ((result para:controlling-result))
+;;   (para:description result))
+
+;; (defmethod reason ((result para:result))
+;;   )
 
 (defmethod make-junit-node ((result para:result) &key class-name)
   (xmls:make-node
@@ -56,9 +85,27 @@
             (:passed
              nil)
             (:skipped
-             (xmls:make-node :name "skipped"))
+             (xmls:make-node :name "skipped"
+                             :child (para:format-result result :extensive)))
+            (:failure
+             (xmls:make-node :name "failure"
+                             :child (para:format-result result :extensive))))))
+
+(defmethod make-junit-node ((result para:controlling-result) &key class-name)
+  (xmls:make-node
+   :name "testcase"
+   :attrs `(("classname" ,class-name)
+            ("name" ,(result-name result))
+            ("time" ,(duration-to-xml (para:duration result))))
+   :child (ecase (para:child-status result)
+            (:passed
+             nil)
+            (:skipped
+             (xmls:make-node :name "skipped"
+                             :child (para:format-result result :extensive)))
             (:failure
-             (xmls:make-node :name "failure")))))
+             (xmls:make-node :name "failure"
+                             :child (para:format-result result :extensive))))))
 
 (defmethod make-junit-node :after (result &key class-name)
   (declare (ignore class-name))
@@ -71,6 +118,7 @@
 
 (defmethod para:summarize ((report junit-report))
   (let ((*processed-results* (make-hash-table))
+        (*print-case* :downcase)
         (pathname (slot-value report 'pathname)))
     (ensure-directories-exist pathname)
     (with-open-file (s pathname :direction :output :if-exists :supersede)
-- 
GitLab