From 43a98f7d583798a8c0c09e94f59a91104cfbf380 Mon Sep 17 00:00:00 2001 From: Lukasz Stafiniak Date: Fri, 1 Mar 2024 22:50:10 +0100 Subject: [PATCH] Support `hlist` and `vlist` inside summaries Implemented as poor-man's support of arbitrary grids. --- src/printbox-html/PrintBox_html.ml | 94 +++++++++++++++++++++--------- test/test_html.expected | 2 +- test/test_html.ml | 10 ++++ 3 files changed, 76 insertions(+), 30 deletions(-) diff --git a/src/printbox-html/PrintBox_html.ml b/src/printbox-html/PrintBox_html.ml index c745751..297ede5 100644 --- a/src/printbox-html/PrintBox_html.ml +++ b/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 diff --git a/test/test_html.expected b/test/test_html.expected index 3bb5c37..c0a5286 100644 --- a/test/test_html.expected +++ b/test/test_html.expected @@ -1,2 +1,2 @@ -
root
  • child 1
  • child 2
    • header 3
      • subchild 3
    • header 4
      • subchild 4
  • header 5
    • subchild 5
  • child 5
+
root
  • child 1
  • child 2
    • header 3
      • subchild 3
    • header 4
      • subchild 4
  • header 5
    • subchild 5
  • child 5
  • separator
  • entry 0.1 entry 0.2
    • child 5.5
  • separator
  • entry 1 entry 2
    • child 6
  • separator
  • entry 3 entry 4
    • child 7
  • separator
  • entry 5
    entry 6
    • child 8
  • separator
  • entry 7
    entry 8
    • child 9
diff --git a/test/test_html.ml b/test/test_html.ml index e0bf080..6bcb0e3 100644 --- a/test/test_html.ml +++ b/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 () =