From 43a98f7d583798a8c0c09e94f59a91104cfbf380 Mon Sep 17 00:00:00 2001 From: Lukasz Stafiniak Date: Fri, 1 Mar 2024 22:50:10 +0100 Subject: [PATCH 1/6] 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 () = From 7fbb75b809f32b2cff9be06f0ede93bcf32a7d17 Mon Sep 17 00:00:00 2001 From: Lukasz Stafiniak Date: Mon, 4 Mar 2024 21:48:26 +0100 Subject: [PATCH 2/6] Anchors (with self-links if inner is non-empty) --- .ocamlformat | 2 +- src/PrintBox.ml | 6 +++ src/PrintBox.mli | 13 ++++++ src/printbox-html/PrintBox_html.ml | 14 +++++- src/printbox-md/PrintBox_md.ml | 18 +++++++- src/printbox-md/README.md | 7 +-- src/printbox-md/readme.ml | 23 ++++++++-- src/printbox-text/PrintBox_text.ml | 74 ++++++++++++++++++++---------- test/test_html.expected | 2 +- test/test_html.ml | 31 ++++++++++--- test/test_text_uri.expected | 21 +++++++-- test/test_text_uri.ml | 34 ++++++++++---- 12 files changed, 188 insertions(+), 57 deletions(-) diff --git a/.ocamlformat b/.ocamlformat index 2124d7d..9a14905 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version = 0.24.1 +version = 0.26.1 profile=conventional margin=80 if-then-else=k-r diff --git a/src/PrintBox.ml b/src/PrintBox.ml index b02e421..161c335 100644 --- a/src/PrintBox.ml +++ b/src/PrintBox.ml @@ -57,6 +57,10 @@ type view = uri: string; inner: t; } + | Anchor of { + id: string; + inner: t; + } and t = view @@ -196,6 +200,8 @@ let mk_tree ?indent f root = let link ~uri inner : t = Link { uri; inner } +let anchor ~id inner : t = Anchor { id; inner } + (** {2 Simple Structural Interface} *) type 'a ktree = unit -> [ `Nil | `Node of 'a * 'a ktree list ] diff --git a/src/PrintBox.mli b/src/PrintBox.mli index fbb8b25..0782a4a 100644 --- a/src/PrintBox.mli +++ b/src/PrintBox.mli @@ -108,6 +108,7 @@ type t @since 0.3 added [Align] @since 0.5 added [Link] + @since 0.11 added [Anchor] *) type view = private | Empty @@ -128,6 +129,10 @@ type view = private uri: string; inner: t; } + | Anchor of { + id: string; + inner: t; + } val view : t -> view (** Observe the content of the box. @@ -298,6 +303,14 @@ val link : uri:string -> t -> t @since 0.5 *) +val anchor : id:string -> t -> t +(** [anchor ~id inner] provides an anchor with the given ID, with the visible hyperlink description + being [inner]. + Will render in HTML as an "" element, and as a link in ANSI stylized text. + If [inner] is non-empty, the rendered link URI is ["#" ^ id]. + @since 0.11 +*) + (** {2 Styling combinators} *) val line_with_style : Style.t -> string -> t diff --git a/src/printbox-html/PrintBox_html.ml b/src/printbox-html/PrintBox_html.ml index 297ede5..d7b722a 100644 --- a/src/printbox-html/PrintBox_html.ml +++ b/src/printbox-html/PrintBox_html.ml @@ -197,6 +197,10 @@ let to_html_rec ~config (b : B.t) = in let rows = Array.to_list a |> List.map to_row in H.span @@ sep_spans (H.br ?a:None) rows + | B.Anchor { id; inner } -> + (match B.view inner with + | B.Empty -> H.a ~a:[ H.a_id id ] [] + | _ -> raise Summary_not_supported) | B.Tree _ | B.Link _ -> raise Summary_not_supported in let loop : @@ -238,7 +242,7 @@ let to_html_rec ~config (b : B.t) = | B.Tree (_, b, l) -> let l = Array.to_list l in H.div [ fix b; H.ul (List.map (fun x -> H.li [ fix x ]) l) ] - | B.Link _ -> assert false + | B.Anchor _ | B.Link _ -> assert false in let rec to_html_rec b = match B.view b with @@ -255,9 +259,17 @@ let to_html_rec ~config (b : B.t) = ]) | B.Link { uri; inner } -> H.div [ H.a ~a:[ H.a_href uri ] [ to_html_nondet_rec inner ] ] + | B.Anchor { id; inner } -> + let opt_link = + match B.view b with + | B.Empty -> [] + | _ -> [ H.a_href @@ "#" ^ id ] + in + H.a ~a:(H.a_id id :: opt_link) [ to_html_nondet_rec inner ] | _ -> loop to_html_rec b and to_html_nondet_rec b = match B.view b with + | B.Empty -> H.span [] | B.Text { l; style } -> v_text_to_html ~l ~style () | B.Link { uri; inner } -> H.div [ H.a ~a:[ H.a_href uri ] [ to_html_nondet_rec inner ] ] diff --git a/src/printbox-md/PrintBox_md.ml b/src/printbox-md/PrintBox_md.ml index 0ea6ffd..a63a21b 100644 --- a/src/printbox-md/PrintBox_md.ml +++ b/src/printbox-md/PrintBox_md.ml @@ -250,7 +250,7 @@ let rec multiline_heuristic c b = || Array.exists (Array.exists @@ multiline_heuristic c) rows | B.Tree (_, header, children) -> Array.length children > 0 || multiline_heuristic c header - | B.Link { inner; _ } -> multiline_heuristic c inner + | B.Link { inner; _ } | B.Anchor { inner; _ } -> multiline_heuristic c inner let rec line_of_length_heuristic_exn c b = match B.view b with @@ -296,6 +296,15 @@ let rec line_of_length_heuristic_exn c b = | B.Tree _ -> raise Not_found | B.Link { inner; uri } -> line_of_length_heuristic_exn c inner + String.length uri + 4 + | B.Anchor { inner; id } -> + let link_len = + match B.view inner with + | B.Empty -> String.length id + 13 + (* *) + | _ -> (2 * String.length id) + 22 + (* INNER *) + in + line_of_length_heuristic_exn c inner + link_len let is_native_table c rows = let rec header h = @@ -320,6 +329,7 @@ let rec remove_bold b = | B.Tree (_, header, [||]) -> remove_bold header | B.Tree _ -> assert false | B.Link { inner; uri } -> B.link ~uri @@ remove_bold inner + | B.Anchor { inner; id } -> B.anchor ~id @@ remove_bold inner let pp c out b = let open Format in @@ -502,6 +512,12 @@ let pp c out b = pp_print_string out "["; loop ~no_block:true ~no_md ~prefix:(prefix ^ " ") inner; fprintf out "](%s)" uri + | B.Anchor { id; inner } -> + (match B.view inner with + | B.Empty -> fprintf out {||} id + | _ -> fprintf out {||} id id); + loop ~no_block:true ~no_md ~prefix:(prefix ^ " ") inner; + pp_print_string out "" in pp_open_vbox out 0; loop ~no_block:false ~no_md:false ~prefix:"" b; diff --git a/src/printbox-md/README.md b/src/printbox-md/README.md index a615dc7..bde9aa1 100644 --- a/src/printbox-md/README.md +++ b/src/printbox-md/README.md @@ -1,6 +1,7 @@ # PrintBox-md: a Markdown backend for PrintBox -[This file was generated by the readme executable.](readme.ml) +- [This file was generated by the readme executable.](readme.ml) +- [(Link to the foldable trees example.)](#FoldableTreeAnchor) ## Coverage of Markdown and `PrintBox` constructions @@ -107,12 +108,12 @@ to separate the entries (here with style \`Line_break). ### Trees -Trees are rendered as: +Trees   are rendered as: - The head element - > followed by - a list of the child elements. -
Trees can be made foldable: +
  Trees can be made foldable: - The head element - > is the summary diff --git a/src/printbox-md/readme.ml b/src/printbox-md/readme.ml index 22c168f..19d57e8 100644 --- a/src/printbox-md/readme.ml +++ b/src/printbox-md/readme.ml @@ -9,8 +9,15 @@ let () = print_endline {|# PrintBox-md: a Markdown backend for PrintBox let () = print_endline MD.( - to_string Config.default @@ B.link ~uri:"readme.ml" - @@ B.line "This file was generated by the readme executable.") + to_string Config.default + @@ B.vlist ~bars:false + B. + [ + link ~uri:"readme.ml" + @@ line "This file was generated by the readme executable."; + link ~uri:"#FoldableTreeAnchor" + @@ line "(Link to the foldable trees example.)"; + ]) let () = print_endline @@ -236,7 +243,11 @@ let () = to_string Config.default @@ B.( tree - (line "Trees are rendered as:") + (hlist ~bars:false + [ + anchor ~id:"TreeAnchor" @@ line "Trees"; + line "are rendered as:"; + ]) [ line "The head element"; frame @@ line "followed by"; @@ -249,7 +260,11 @@ let () = to_string Config.(foldable_trees default) @@ B.( tree - (line "Trees can be made foldable:") + (hlist ~bars:false + [ + anchor ~id:"FoldableTreeAnchor" @@ empty; + line "Trees can be made foldable:"; + ]) [ line "The head element"; frame @@ line "is the summary"; diff --git a/src/printbox-text/PrintBox_text.ml b/src/printbox-text/PrintBox_text.ml index edd3dd2..74f2104 100644 --- a/src/printbox-text/PrintBox_text.ml +++ b/src/printbox-text/PrintBox_text.ml @@ -28,9 +28,9 @@ end = struct let codes_of_style (self : t) : int list = let { bold; fg_color; bg_color; preformatted = _ } = self in (if bold then - [ 1 ] - else - []) + [ 1 ] + else + []) @ (match bg_color with | None -> [] | Some c -> [ 40 + int_of_color_ c ]) @@ -512,6 +512,11 @@ end = struct lines_ s2 0 k; List.iter (fun s -> lines_ s 0 k) tl + let is_empty b = + match B.view b with + | B.Empty -> true + | _ -> false + let rec of_box ~ansi (b : B.t) : t = let shape = match B.view b with @@ -526,27 +531,48 @@ end = struct | B.Align { h; v; inner } -> Align { h; v; inner = of_box ~ansi inner } | B.Grid (bars, m) -> Grid (bars, B.map_matrix (of_box ~ansi) m) | B.Tree (i, b, l) -> Tree (i, of_box ~ansi b, Array.map (of_box ~ansi) l) - | B.Link { inner; uri } when ansi -> + | B.Anchor { id; inner } when is_empty inner -> + Text + { l = []; style = B.Style.default; link_with_uri = Some ("#" ^ id) } + | (B.Link { inner; uri } | B.Anchor { inner; id = uri }) as b when ansi -> + let uri = + match b with + | B.Link _ -> uri + | B.Anchor _ -> "#" ^ uri + | _ -> assert false + in + let loop = B.link ~uri in (match B.view inner with - | B.Empty -> Empty - | B.Frame t -> Frame (of_box ~ansi (B.link ~uri t)) - | B.Pad (dim, t) -> Pad (dim, of_box ~ansi (B.link ~uri t)) - | B.Align { h; v; inner } -> Align { h; v; inner = of_box ~ansi (B.link ~uri inner)} - | B.Grid (bars, m) -> Grid (bars, B.map_matrix (of_box ~ansi) m) - | B.Tree (i, b, l) -> - Tree (i, of_box ~ansi (B.link ~uri b), - Array.map (fun b -> of_box ~ansi @@ B.link ~uri b) l) - | B.Link _ -> - (* Inner links override outer links. *) - (of_box ~ansi inner).shape - | B.Text _ -> - (match of_box ~ansi inner with - | {shape = Text { l; style; link_with_uri = _ }; size = _ } -> - Text { l; style; link_with_uri = Some uri } - | _ -> assert false)) + | B.Empty -> Empty + | B.Frame t -> Frame (of_box ~ansi (loop t)) + | B.Pad (dim, t) -> Pad (dim, of_box ~ansi (loop t)) + | B.Align { h; v; inner } -> + Align { h; v; inner = of_box ~ansi (loop inner) } + | B.Grid (bars, m) -> Grid (bars, B.map_matrix (of_box ~ansi) m) + | B.Tree (i, b, l) -> + Tree + ( i, + of_box ~ansi (loop b), + Array.map (fun b -> of_box ~ansi @@ loop b) l ) + | B.Link _ | B.Anchor _ -> + (* Inner links override outer links. *) + (of_box ~ansi inner).shape + | B.Text _ -> + (match of_box ~ansi inner with + | { shape = Text { l; style; link_with_uri = _ }; size = _ } -> + Text { l; style; link_with_uri = Some uri } + | _ -> assert false)) | B.Link { inner; uri } -> (* just encode as a record *) - let self = of_box ~ansi (B.v_record [ "uri", B.text uri; "inner", inner ]) in + let self = + of_box ~ansi (B.v_record [ "uri", B.text uri; "inner", inner ]) + in + self.shape + | B.Anchor { inner; id } -> + (* just encode as a tag: {#ID} INNER. *) + let self = + of_box ~ansi (B.hlist ~bars:false [ B.line ("{#" ^ id ^ "}"); inner ]) + in self.shape in { shape; size = lazy (size_of_shape shape) } @@ -585,9 +611,9 @@ end = struct | Text { l; style; link_with_uri } -> let ansi_prelude, ansi_suffix = match ansi, link_with_uri with - | false, _ -> "", "" - | true, None -> Style_ansi.brackets style - | true, Some uri -> Style_ansi.hyperlink ~uri style + | false, _ -> "", "" + | true, None -> Style_ansi.brackets style + | true, Some uri -> Style_ansi.hyperlink ~uri style in let has_style = ansi_prelude <> "" || ansi_suffix <> "" in List.iteri diff --git a/test/test_html.expected b/test/test_html.expected index c0a5286..5172a81 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
  • 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
+
root
  • 1
    2
    3
    4
    5
  • 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
  • anchor (visible)
  •  entry 3 entry 4
    • child 7
  • separator after hidden anchor
  • 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 6bcb0e3..7aeef81 100644 --- a/test/test_html.ml +++ b/test/test_html.ml @@ -3,6 +3,8 @@ let b = tree (frame @@ text "root") [ + link ~uri:"#HiddenAnchor" @@ text "link to a hidden anchor"; + vlist ~bars:true [ text "1"; text "2"; text "3"; text "4"; text "5" ]; frame @@ text "child 1"; text "child 2"; frame @@ -12,15 +14,30 @@ let b = 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"]; + 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"]; + tree + (hlist ~bars:false [ text "entry 1"; frame @@ text "entry 2" ]) + [ text "child 6" ]; + anchor ~id:"VisibleAnchor" @@ text "anchor (visible)"; + tree + (hlist ~bars:true + [ + anchor ~id:"HiddenAnchor" empty; + text "entry 3"; + frame @@ text "entry 4"; + ]) + [ text "child 7" ]; + text "separator after hidden anchor"; + tree + (vlist ~bars:false [ text "entry 5"; frame @@ text "entry 6" ]) + [ text "child 8" ]; 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"]; + tree + (vlist ~bars:true [ text "entry 7"; frame @@ text "entry 8" ]) + [ text "child 9" ]; ] let () = diff --git a/test/test_text_uri.expected b/test/test_text_uri.expected index ec5e878..015a4d0 100644 --- a/test/test_text_uri.expected +++ b/test/test_text_uri.expected @@ -1,9 +1,13 @@ +┌────────────────────────────────┐ +│]8;;#SecondAnchor\Link to a within-document anchor]8;;\│ +└────────────────────────────────┘ +────────────────────────────────── ┌───────┐ │]8;;https://example.com/1\child 1]8;;\│ └───────┘ -──────────────────── +────────────────────────────────── ]8;;https://example.com/2\child 2]8;;\ -──────────────────── +────────────────────────────────── ┌──────────────────┐ │──┬────────┐ │ │ │]8;;https://example.com/4\header 3]8;;\│ │ @@ -12,18 +16,18 @@ │ │]8;;https://example.com/4\subchild 3]8;;\│ │ │ └──────────┘ │ └──────────────────┘ -──────────────────── +────────────────────────────────── ──┬────────┐ │]8;;https://example.com/5\header 4]8;;\│ ├────────┘ └─┬──────────┐ │]8;;https://example.com/5\subchild 4]8;;\│ └──────────┘ -──────────────────── +────────────────────────────────── ┌───────┐ │child 5│ └───────┘ -──────────────────── +────────────────────────────────── ┌──────────────────┐ │┌────────┐ │ ││]8;;https://example.com/6\header 6]8;;\│ │ @@ -35,3 +39,10 @@ │ │]8;;https://example.com/7\subchild 6]8;;\│ │ │ └──────────┘ │ └──────────────────┘ +────────────────────────────────── +┌──────────────────┐ +│]8;;#FirstAnchor\anchor self-link 1]8;;\│ +└──────────────────┘ +────────────────────────────────── +silent anchor +└─subchild 7 diff --git a/test/test_text_uri.ml b/test/test_text_uri.ml index 4fdb683..9ff9907 100644 --- a/test/test_text_uri.ml +++ b/test/test_text_uri.ml @@ -2,22 +2,36 @@ let b = let open PrintBox in vlist [ + link ~uri:"#SecondAnchor" @@ frame @@ text "Link to a within-document anchor"; link ~uri:"https://example.com/1" @@ frame @@ text "child 1"; link ~uri:"https://example.com/2" @@ text "child 2"; frame - @@ tree (link ~uri:"https://example.com/3" empty) - [ link ~uri:"https://example.com/4" @@ - tree (frame @@ text "header 3") [ frame @@ text "subchild 3" ] ]; - link ~uri:"https://example.com/5" @@ - tree empty - [ tree (frame @@ text "header 4") [ frame @@ text "subchild 4" ] ]; + @@ tree + (link ~uri:"https://example.com/3" empty) + [ + link ~uri:"https://example.com/4" + @@ tree (frame @@ text "header 3") [ frame @@ text "subchild 3" ]; + ]; + link ~uri:"https://example.com/5" + @@ tree empty + [ tree (frame @@ text "header 4") [ frame @@ text "subchild 4" ] ]; frame @@ text "child 5"; - link ~uri:"https://example.com/6" @@ - frame + link ~uri:"https://example.com/6" + @@ frame @@ tree (frame @@ text "header 6") - [ tree (frame @@ text "child 6") - [ link ~uri:"https://example.com/7" @@ frame @@ text "subchild 6" ] ]; + [ + tree + (frame @@ text "child 6") + [ + link ~uri:"https://example.com/7" @@ frame @@ text "subchild 6"; + ]; + ]; + anchor ~id:"FirstAnchor" @@ frame @@ text "anchor self-link 1"; + tree + (hlist ~bars:false + [ anchor ~id:"SecondAnchor" empty; text "silent anchor" ]) + [ text "subchild 7" ]; ] let () = print_endline @@ PrintBox_text.to_string b From 2f878728a0189180a3b07cf0357e8d17fe4d5edc Mon Sep 17 00:00:00 2001 From: Lukasz Stafiniak Date: Wed, 6 Mar 2024 14:31:14 +0100 Subject: [PATCH 3/6] Perf bug fix (exploding complexity) --- .ocamlformat | 2 +- src/printbox-html/PrintBox_html.ml | 30 ++++++++++++------------------ 2 files changed, 13 insertions(+), 19 deletions(-) diff --git a/.ocamlformat b/.ocamlformat index 9a14905..2124d7d 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version = 0.26.1 +version = 0.24.1 profile=conventional margin=80 if-then-else=k-r diff --git a/src/printbox-html/PrintBox_html.ml b/src/printbox-html/PrintBox_html.ml index d7b722a..dc4bcb6 100644 --- a/src/printbox-html/PrintBox_html.ml +++ b/src/printbox-html/PrintBox_html.ml @@ -113,9 +113,9 @@ let sep_spans sep l = x :: (if i < len - 1 then - [ sep () ] - else - [])) + [ sep () ] + else + [])) l let br_lines ~bold l = @@ -203,12 +203,12 @@ let to_html_rec ~config (b : B.t) = | _ -> raise Summary_not_supported) | B.Tree _ | B.Link _ -> raise Summary_not_supported in - let loop : - 'tags. - (B.t -> - ([< Html_types.flow5 > `Pre `Span `Div `Ul `Table `P ] as 'tags) html) -> - B.t -> - 'tags html = + let loop + : 'tags. + (B.t -> + ([< Html_types.flow5 > `Pre `Span `Div `Ul `Table `P ] as 'tags) html) -> + B.t -> + 'tags html = fun fix b -> match B.view b with | B.Empty -> @@ -248,15 +248,9 @@ 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 - (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); - ]) + let body = H.ul (List.map (fun x -> H.li [ to_html_rec x ]) l) in + (try H.details (H.summary [ to_html_summary b ]) [ body ] + with Summary_not_supported -> H.div [ to_html_rec b; body ]) | B.Link { uri; inner } -> H.div [ H.a ~a:[ H.a_href uri ] [ to_html_nondet_rec inner ] ] | B.Anchor { id; inner } -> From 67dc1cfd21160215dabd02cfa0786e9cb1a616bb Mon Sep 17 00:00:00 2001 From: Lukasz Stafiniak Date: Thu, 7 Mar 2024 12:02:22 +0100 Subject: [PATCH 4/6] Fix: empty-body anchors (not in summary headers) --- src/printbox-html/PrintBox_html.ml | 10 ++++------ test/test_html.expected | 2 +- test/test_html.ml | 1 + 3 files changed, 6 insertions(+), 7 deletions(-) diff --git a/src/printbox-html/PrintBox_html.ml b/src/printbox-html/PrintBox_html.ml index dc4bcb6..4419841 100644 --- a/src/printbox-html/PrintBox_html.ml +++ b/src/printbox-html/PrintBox_html.ml @@ -254,12 +254,10 @@ let to_html_rec ~config (b : B.t) = | B.Link { uri; inner } -> H.div [ H.a ~a:[ H.a_href uri ] [ to_html_nondet_rec inner ] ] | B.Anchor { id; inner } -> - let opt_link = - match B.view b with - | B.Empty -> [] - | _ -> [ H.a_href @@ "#" ^ id ] - in - H.a ~a:(H.a_id id :: opt_link) [ to_html_nondet_rec inner ] + (match B.view inner with + | B.Empty -> H.a ~a:[ H.a_id id ] [] + | _ -> + H.a ~a:[ H.a_id id; H.a_href @@ "#" ^ id ] [ to_html_nondet_rec inner ]) | _ -> loop to_html_rec b and to_html_nondet_rec b = match B.view b with diff --git a/test/test_html.expected b/test/test_html.expected index 5172a81..7f35f02 100644 --- a/test/test_html.expected +++ b/test/test_html.expected @@ -1,2 +1,2 @@ -
root
  • 1
    2
    3
    4
    5
  • 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
  • anchor (visible)
  •  entry 3 entry 4
    • child 7
  • separator after hidden anchor
  • entry 5
    entry 6
    • child 8
  • separator
  • entry 7
    entry 8
    • child 9
+
root
  • 1
    2
    3
    4
    5
  • 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
  • anchor (visible)
  •  entry 3 entry 4
    • child 7
  • separator after hidden anchor
  • 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 7aeef81..db26c5d 100644 --- a/test/test_html.ml +++ b/test/test_html.ml @@ -31,6 +31,7 @@ let b = ]) [ text "child 7" ]; text "separator after hidden anchor"; + anchor ~id:"HiddenAnchor2" empty; tree (vlist ~bars:false [ text "entry 5"; frame @@ text "entry 6" ]) [ text "child 8" ]; From 3b314dd32e0e3d7b2a0ac42bc3f86b64ec928d0f Mon Sep 17 00:00:00 2001 From: Lukasz Stafiniak Date: Thu, 7 Mar 2024 17:44:27 +0100 Subject: [PATCH 5/6] Don't output anchor self-links for ANSI text output. More tests. --- src/printbox-text/PrintBox_text.ml | 33 ++++----- test/test_text_uri.expected | 103 +++++++++++++++++++++++++---- test/test_text_uri.ml | 18 ++++- 3 files changed, 122 insertions(+), 32 deletions(-) diff --git a/src/printbox-text/PrintBox_text.ml b/src/printbox-text/PrintBox_text.ml index 74f2104..3a00fe2 100644 --- a/src/printbox-text/PrintBox_text.ml +++ b/src/printbox-text/PrintBox_text.ml @@ -28,9 +28,9 @@ end = struct let codes_of_style (self : t) : int list = let { bold; fg_color; bg_color; preformatted = _ } = self in (if bold then - [ 1 ] - else - []) + [ 1 ] + else + []) @ (match bg_color with | None -> [] | Some c -> [ 40 + int_of_color_ c ]) @@ -512,11 +512,6 @@ end = struct lines_ s2 0 k; List.iter (fun s -> lines_ s 0 k) tl - let is_empty b = - match B.view b with - | B.Empty -> true - | _ -> false - let rec of_box ~ansi (b : B.t) : t = let shape = match B.view b with @@ -531,10 +526,7 @@ end = struct | B.Align { h; v; inner } -> Align { h; v; inner = of_box ~ansi inner } | B.Grid (bars, m) -> Grid (bars, B.map_matrix (of_box ~ansi) m) | B.Tree (i, b, l) -> Tree (i, of_box ~ansi b, Array.map (of_box ~ansi) l) - | B.Anchor { id; inner } when is_empty inner -> - Text - { l = []; style = B.Style.default; link_with_uri = Some ("#" ^ id) } - | (B.Link { inner; uri } | B.Anchor { inner; id = uri }) as b when ansi -> + | B.Link { inner; uri } as b when ansi -> let uri = match b with | B.Link _ -> uri @@ -557,11 +549,11 @@ end = struct | B.Link _ | B.Anchor _ -> (* Inner links override outer links. *) (of_box ~ansi inner).shape - | B.Text _ -> - (match of_box ~ansi inner with - | { shape = Text { l; style; link_with_uri = _ }; size = _ } -> - Text { l; style; link_with_uri = Some uri } - | _ -> assert false)) + | B.Text { l; style } -> + (* split into lines *) + let acc = ref [] in + lines_l_ l (fun s i len -> acc := (s, i, len) :: !acc); + Text { l = List.rev !acc; style; link_with_uri = Some uri }) | B.Link { inner; uri } -> (* just encode as a record *) let self = @@ -569,9 +561,12 @@ end = struct in self.shape | B.Anchor { inner; id } -> - (* just encode as a tag: {#ID} INNER. *) + (* Note: no support for self-links for now; just encode as a tag: {#ID} INNER. *) + let uri = "{#" ^ id ^ "}" in let self = - of_box ~ansi (B.hlist ~bars:false [ B.line ("{#" ^ id ^ "}"); inner ]) + match B.view inner with + | B.Text { l = [ s ]; _ } when s = uri -> of_box ~ansi @@ B.line uri + | _ -> of_box ~ansi (B.hlist ~bars:false [ B.line uri; inner ]) in self.shape in diff --git a/test/test_text_uri.expected b/test/test_text_uri.expected index 015a4d0..c1a8e17 100644 --- a/test/test_text_uri.expected +++ b/test/test_text_uri.expected @@ -1,13 +1,14 @@ +Output with ANSI styling: ┌────────────────────────────────┐ │]8;;#SecondAnchor\Link to a within-document anchor]8;;\│ └────────────────────────────────┘ -────────────────────────────────── +──────────────────────────────────────────────────── ┌───────┐ │]8;;https://example.com/1\child 1]8;;\│ └───────┘ -────────────────────────────────── +──────────────────────────────────────────────────── ]8;;https://example.com/2\child 2]8;;\ -────────────────────────────────── +──────────────────────────────────────────────────── ┌──────────────────┐ │──┬────────┐ │ │ │]8;;https://example.com/4\header 3]8;;\│ │ @@ -16,18 +17,18 @@ │ │]8;;https://example.com/4\subchild 3]8;;\│ │ │ └──────────┘ │ └──────────────────┘ -────────────────────────────────── +──────────────────────────────────────────────────── ──┬────────┐ │]8;;https://example.com/5\header 4]8;;\│ ├────────┘ └─┬──────────┐ │]8;;https://example.com/5\subchild 4]8;;\│ └──────────┘ -────────────────────────────────── +──────────────────────────────────────────────────── ┌───────┐ │child 5│ └───────┘ -────────────────────────────────── +──────────────────────────────────────────────────── ┌──────────────────┐ │┌────────┐ │ ││]8;;https://example.com/6\header 6]8;;\│ │ @@ -39,10 +40,88 @@ │ │]8;;https://example.com/7\subchild 6]8;;\│ │ │ └──────────┘ │ └──────────────────┘ -────────────────────────────────── -┌──────────────────┐ -│]8;;#FirstAnchor\anchor self-link 1]8;;\│ -└──────────────────┘ -────────────────────────────────── -silent anchor +──────────────────────────────────────────────────── +{#FirstAnchor}┌──────────────────┐ + │anchor self-link 1│ + └──────────────────┘ +──────────────────────────────────────────────────── +{#SecondAnchor}silent anchor +└─subchild 7 +──────────────────────────────────────────────────── +{#ThirdAnchor}anchor self-link 2 after anchor link 2 +└─subchild 8 +──────────────────────────────────────────────────── +]8;;https://example.com/8\external link 8]8;;\ after external link 8 +Output without ANSI styling: +uri │#SecondAnchor +─────┼────────────────────────────────────────────── +inner│┌────────────────────────────────┐ + ││Link to a within-document anchor│ + │└────────────────────────────────┘ +─────┼────────────────────────────────────────────── +uri │https://example.com/1 +─────┼────────────────────────────────────────────── +inner│┌───────┐ + ││child 1│ + │└───────┘ +─────┼────────────────────────────────────────────── +uri │https://example.com/2 +─────┼────────────────────────────────────────────── +inner│child 2 +─────┴────────────────────────────────────────────── +┌─────┬────────────────────────┐ +│uri │https://example.com/3 │ +├─────┼───────────────────── │ +│inner│ │ +│└─uri │https://example.com/4 │ +│ ─────┼───────────────────── │ +│ inner│┌────────┐ │ +│ ││header 3│ │ +│ │├────────┘ │ +│ │└─┬──────────┐ │ +│ │ │subchild 3│ │ +│ │ └──────────┘ │ +└───────┴──────────────────────┘ +─────┬────────────────────────────────────────────── +uri │https://example.com/5 +─────┼────────────────────────────────────────────── +inner│──┬────────┐ + │ │header 4│ + │ ├────────┘ + │ └─┬──────────┐ + │ │subchild 4│ + │ └──────────┘ +─────┴────────────────────────────────────────────── +┌───────┐ +│child 5│ +└───────┘ +─────┬────────────────────────────────────────────── +uri │https://example.com/6 +─────┼────────────────────────────────────────────── +inner│┌─────────────────────────────────┐ + ││┌────────┐ │ + │││header 6│ │ + ││├────────┘ │ + ││└─┬───────┐ │ + ││ │child 6│ │ + ││ ├──────┬┘ │ + ││ └─uri │https://example.com/7 │ + ││ ─────┼───────────────────── │ + ││ inner│┌──────────┐ │ + ││ ││subchild 6│ │ + ││ │└──────────┘ │ + │└─────────┴───────────────────────┘ +─────┴────────────────────────────────────────────── +{#FirstAnchor}┌──────────────────┐ + │anchor self-link 1│ + └──────────────────┘ +──────────────────────────────────────────────────── +{#SecondAnchor}silent anchor └─subchild 7 +──────────────────────────────────────────────────── +{#ThirdAnchor}anchor self-link 2 after anchor link 2 +└─subchild 8 +─────┬────────────────────────────────────────────── +uri │https://example.com/8 after external link 8 +─────┼───────────────────── +inner│external link 8 diff --git a/test/test_text_uri.ml b/test/test_text_uri.ml index 9ff9907..ec652e7 100644 --- a/test/test_text_uri.ml +++ b/test/test_text_uri.ml @@ -2,7 +2,8 @@ let b = let open PrintBox in vlist [ - link ~uri:"#SecondAnchor" @@ frame @@ text "Link to a within-document anchor"; + link ~uri:"#SecondAnchor" @@ frame + @@ text "Link to a within-document anchor"; link ~uri:"https://example.com/1" @@ frame @@ text "child 1"; link ~uri:"https://example.com/2" @@ text "child 2"; frame @@ -32,6 +33,21 @@ let b = (hlist ~bars:false [ anchor ~id:"SecondAnchor" empty; text "silent anchor" ]) [ text "subchild 7" ]; + tree + (hlist ~bars:false + [ + anchor ~id:"ThirdAnchor" @@ text "anchor self-link 2"; + text " after anchor link 2"; + ]) + [ text "subchild 8" ]; + hlist ~bars:false + [ + link ~uri:"https://example.com/8" @@ text "external link 8"; + text " after external link 8"; + ]; ] +let () = print_endline "Output with ANSI styling:" let () = print_endline @@ PrintBox_text.to_string b +let () = print_endline "Output without ANSI styling:" +let () = print_endline @@ PrintBox_text.to_string_with ~style:false b From 3acba91705f1ed5ef9f0f0e82af1c46ba40f640a Mon Sep 17 00:00:00 2001 From: Lukasz Stafiniak Date: Thu, 7 Mar 2024 18:25:36 +0100 Subject: [PATCH 6/6] Anchors: a tiny cleanup. --- src/printbox-text/PrintBox_text.ml | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/src/printbox-text/PrintBox_text.ml b/src/printbox-text/PrintBox_text.ml index 3a00fe2..12a1d7c 100644 --- a/src/printbox-text/PrintBox_text.ml +++ b/src/printbox-text/PrintBox_text.ml @@ -526,13 +526,7 @@ end = struct | B.Align { h; v; inner } -> Align { h; v; inner = of_box ~ansi inner } | B.Grid (bars, m) -> Grid (bars, B.map_matrix (of_box ~ansi) m) | B.Tree (i, b, l) -> Tree (i, of_box ~ansi b, Array.map (of_box ~ansi) l) - | B.Link { inner; uri } as b when ansi -> - let uri = - match b with - | B.Link _ -> uri - | B.Anchor _ -> "#" ^ uri - | _ -> assert false - in + | B.Link { inner; uri } when ansi -> let loop = B.link ~uri in (match B.view inner with | B.Empty -> Empty