Support hlist and vlist inside summaries

Implemented as poor-man's support of arbitrary grids.

src/printbox-html/PrintBox_html.ml

@@ -105,25 +105,29 @@ module Config = struct
   let tree_summary x c = { c with tree_summary = x }
 end
 
-let br_lines ~bold l =
-  let l =
-    List.map H.txt @@ List.concat @@ List.map (String.split_on_char '\n') l
-  in
+let sep_spans sep l =
   let len = List.length l in
   List.concat
   @@ List.mapi
        (fun i x ->
-         (if bold then
-            H.b [ x ]
-          else
-            x)
+         x
          ::
          (if i < len - 1 then
-            [ H.br () ]
+            [ sep () ]
           else
             []))
        l
 
+let br_lines ~bold l =
+  sep_spans (H.br ?a:None)
+  @@ List.map (fun x ->
+         if bold then
+           H.b [ H.txt x ]
+         else
+           H.txt x)
+  @@ List.concat
+  @@ List.map (String.split_on_char '\n') l
+
 let to_html_rec ~config (b : B.t) =
   let open Config in
   let br_text_to_html ?(border = false) ~l ~style () =
@@ -155,6 +159,46 @@ let to_html_rec ~config (b : B.t) =
       H.div ~a:(a_class config.cls_text @ a_border @ a @ config.a_text) l
     )
   in
+  let exception Summary_not_supported in
+  let rec to_html_summary b =
+    match B.view b with
+    | B.Empty ->
+      (* Not really a case of unsupported summarization,
+         but rather a request to not summarize. *)
+      raise Summary_not_supported
+    | B.Text { l; style } -> br_text_to_html ~l ~style ()
+    | B.Pad (_, b) ->
+      (* FIXME: not implemented yet *)
+      to_html_summary b
+    | B.Frame b ->
+      H.span ~a:[ H.a_style "border:thin solid" ] [ to_html_summary b ]
+    | B.Align { h = `Right; inner = b; v = _ } ->
+      H.span ~a:[ H.a_class [ "align-right" ] ] [ to_html_summary b ]
+    | B.Align { h = `Center; inner = b; v = _ } ->
+      H.span ~a:[ H.a_class [ "center" ] ] [ to_html_summary b ]
+    | B.Align { inner = b; _ } -> to_html_summary b
+    | B.Grid (bars, a) ->
+      (* TODO: support selected table styles. *)
+      let a_border =
+        if bars = `Bars then
+          [ H.a_style "border:thin dotted" ]
+        else
+          []
+      in
+      let to_row a =
+        let cols =
+          Array.to_list a
+          |> List.map (fun b ->
+                 H.span
+                   ~a:(a_class config.cls_col @ config.a_col @ a_border)
+                   [ to_html_summary b ])
+        in
+        H.span ~a:a_border @@ sep_spans H.space cols
+      in
+      let rows = Array.to_list a |> List.map to_row in
+      H.span @@ sep_spans (H.br ?a:None) rows
+    | B.Tree _ | B.Link _ -> raise Summary_not_supported
+  in
   let loop :
         'tags.
         (B.t ->
@@ -168,7 +212,9 @@ let to_html_rec ~config (b : B.t) =
     | B.Text { l; style } when style.B.Style.preformatted ->
       v_text_to_html ~l ~style ()
     | B.Text { l; style } -> v_text_to_html ~l ~style ()
-    | B.Pad (_, b) -> fix b
+    | B.Pad (_, b) ->
+      (* FIXME: not implemented yet *)
+      fix b
     | B.Frame b -> H.div ~a:[ H.a_style "border:thin solid" ] [ fix b ]
     | B.Align { h = `Right; inner = b; v = _ } ->
       H.div ~a:[ H.a_class [ "align-right" ] ] [ fix b ]
@@ -198,25 +244,15 @@ let to_html_rec ~config (b : B.t) =
     match B.view b with
     | B.Tree (_, b, l) when config.tree_summary ->
       let l = Array.to_list l in
-      (match B.view b with
-      | B.Text { l = tl; style } ->
-        H.details
-          (H.summary [ br_text_to_html ~l:tl ~style () ])
-          [ H.ul (List.map (fun x -> H.li [ to_html_rec x ]) l) ]
-      | B.Frame b ->
-        (match B.view b with
-        | B.Text { l = tl; style } ->
-          H.details
-            (H.summary [ br_text_to_html ~border:true ~l:tl ~style () ])
-            [ H.ul (List.map (fun x -> H.li [ to_html_rec x ]) l) ]
-        | _ ->
-          H.div
-            [
-              to_html_rec b; H.ul (List.map (fun x -> H.li [ to_html_rec x ]) l);
-            ])
-      | _ ->
-        H.div
-          [ to_html_rec b; H.ul (List.map (fun x -> H.li [ to_html_rec x ]) l) ])
+      (try
+         H.details
+           (H.summary [ to_html_summary b ])
+           [ H.ul (List.map (fun x -> H.li [ to_html_rec x ]) l) ]
+       with Summary_not_supported ->
+         H.div
+           [
+             to_html_rec b; H.ul (List.map (fun x -> H.li [ to_html_rec x ]) l);
+           ])
     | B.Link { uri; inner } ->
       H.div [ H.a ~a:[ H.a_href uri ] [ to_html_nondet_rec inner ] ]
     | _ -> loop to_html_rec b

test/test_html.expected

@@ -1,2 +1,2 @@
-<div><details><summary><span style="border:thin solid">root</span></summary><ul><li><div style="border:thin solid"><div>child 1</div></div></li><li><div>child 2</div></li><li><div style="border:thin solid"><div><div></div><ul><li><details><summary><span style="border:thin solid">header 3</span></summary><ul><li><div style="border:thin solid"><div>subchild 3</div></div></li></ul></details></li></ul></div></div></li><li><div><div></div><ul><li><details><summary><span style="border:thin solid">header 4</span></summary><ul><li><div>subchild 4</div></li></ul></details></li></ul></div></li><li><div style="border:thin solid"><details><summary><span>header 5</span></summary><ul><li><div>subchild 5</div></li></ul></details></div></li><li><div style="border:thin solid"><div>child 5</div></div></li></ul></details></div>
+<div><details><summary><span style="border:thin solid"><span>root</span></span></summary><ul><li><div style="border:thin solid"><div>child 1</div></div></li><li><div>child 2</div></li><li><div style="border:thin solid"><div><div></div><ul><li><details><summary><span style="border:thin solid"><span>header 3</span></span></summary><ul><li><div style="border:thin solid"><div>subchild 3</div></div></li></ul></details></li></ul></div></div></li><li><div><div></div><ul><li><details><summary><span style="border:thin solid"><span>header 4</span></span></summary><ul><li><div>subchild 4</div></li></ul></details></li></ul></div></li><li><div style="border:thin solid"><details><summary><span>header 5</span></summary><ul><li><div>subchild 5</div></li></ul></details></div></li><li><div style="border:thin solid"><div>child 5</div></div></li><li><div>separator</div></li><li><details><summary><span><span><span><span>entry 0.1</span></span>&nbsp;<span><span>entry 0.2</span></span></span></span></summary><ul><li><div>child 5.5</div></li></ul></details></li><li><div>separator</div></li><li><details><summary><span><span><span><span>entry 1</span></span>&nbsp;<span><span style="border:thin solid"><span>entry 2</span></span></span></span></span></summary><ul><li><div>child 6</div></li></ul></details></li><li><div>separator</div></li><li><details><summary><span><span style="border:thin dotted"><span style="border:thin dotted"><span>entry 3</span></span>&nbsp;<span style="border:thin dotted"><span style="border:thin solid"><span>entry 4</span></span></span></span></span></summary><ul><li><div>child 7</div></li></ul></details></li><li><div>separator</div></li><li><details><summary><span><span><span><span>entry 5</span></span></span><br/><span><span><span style="border:thin solid"><span>entry 6</span></span></span></span></span></summary><ul><li><div>child 8</div></li></ul></details></li><li><div>separator</div></li><li><details><summary><span><span style="border:thin dotted"><span style="border:thin dotted"><span>entry 7</span></span></span><br/><span style="border:thin dotted"><span style="border:thin dotted"><span style="border:thin solid"><span>entry 8</span></span></span></span></span></summary><ul><li><div>child 9</div></li></ul></details></li></ul></details></div>
 

test/test_html.ml

@@ -11,6 +11,16 @@ let b =
       tree empty [ tree (frame @@ text "header 4") [ text "subchild 4" ] ];
       frame @@ tree (text "header 5") [ text "subchild 5" ];
       frame @@ text "child 5";
+      text "separator";
+      tree (hlist ~bars:false [text "entry 0.1"; text "entry 0.2"]) [text "child 5.5"];
+      text "separator";
+      tree (hlist ~bars:false [text "entry 1"; frame @@ text "entry 2"]) [text "child 6"];
+      text "separator";
+      tree (hlist ~bars:true [text "entry 3"; frame @@ text "entry 4"]) [text "child 7"];
+      text "separator";
+      tree (vlist ~bars:false [text "entry 5"; frame @@ text "entry 6"]) [text "child 8"];
+      text "separator";
+      tree (vlist ~bars:true [text "entry 7"; frame @@ text "entry 8"]) [text "child 9"];
     ]
 
 let () =