From dd74d4b7140d3984e95a682a9de08146b9d60426 Mon Sep 17 00:00:00 2001
From: Max Lang <17551908+just-max@users.noreply.github.com>
Date: Mon, 9 Oct 2023 07:32:34 +0200
Subject: [PATCH] grading: show messages in attributes

---
 src/test-lib/grading.ml | 31 +++++++++++++++++++++++--------
 1 file changed, 23 insertions(+), 8 deletions(-)

diff --git a/src/test-lib/grading.ml b/src/test-lib/grading.ml
index 4eb4d80..d27256f 100644
--- a/src/test-lib/grading.ml
+++ b/src/test-lib/grading.ml
@@ -112,14 +112,24 @@ let out_tree o t =
   Xmlm.output_doc_tree frag o t
 
 let map_tree f tree =
-  let rec map tree = match f tree with Data d -> Data d | El (tag, childs) -> El (tag, List.map map childs) in
+  let rec map tree =
+    match f tree with
+    | Data d -> Data d
+    | El (tag, childs) -> El (tag, List.map map childs)
+  in
   map tree
 
-(* currently unused *)
-let[@warning "-32"] map_tree_data f tree =
-  let rec map tree = match tree with Data d -> Data (f d) | El (tag, childs) -> El (tag, List.map map childs) in
+let map_tree_data f tree =
+  let rec map = function
+    | Data d -> Data (f d)
+    | El (tag, childs) -> El (tag, List.map map childs)
+  in
   map tree
 
+let rec tree_has_data = function
+  | Data _ -> true
+  | El (_, childs) -> List.exists tree_has_data childs
+
 let fold_tree_down f acc tree =
   let rec map acc tree =
     match f acc tree with
@@ -254,10 +264,15 @@ let prettify_results ?(grading : grading option) ?(points_step_count = 1) fn =
   in
   map_xml fn (function[@warning "-4"]
     | El (((("", ("failure" | "error")) as name), attrs), content) ->
-        El ((name, keep_attribute_keys [ "type" ] attrs), content)
-    | El (((("", "testcase") as name), attrs), content) ->
-        let content = List.map (map_tree (function Data d -> Data (trim_message d) | v -> v)) content in
-        El ((name, attrs), content)
+        let content' =
+          if List.exists tree_has_data content then
+            List.map (map_tree_data trim_message) content
+          else
+            match List.assoc_opt ("", "message") attrs with
+              | None | Some "" -> []
+              | Some msg -> [Data msg]
+        in
+        El ((name, keep_attribute_keys [ "type" ] attrs), content')
     | El (((("", "testsuite") as name), attrs), content) as el ->
         let tests, _ =
           fold_tree_down