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 c745751..4419841 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 () ] - else - [])) + [ 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,12 +159,56 @@ 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 loop : - 'tags. - (B.t -> - ([< Html_types.flow5 > `Pre `Span `Div `Ul `Table `P ] as 'tags) html) -> - B.t -> - 'tags html = + 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.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 + : '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 -> @@ -168,7 +216,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 ] @@ -192,36 +242,26 @@ 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 | 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) ]) + 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 } -> + (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 + | 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..12a1d7c 100644 --- a/src/printbox-text/PrintBox_text.ml +++ b/src/printbox-text/PrintBox_text.ml @@ -527,26 +527,41 @@ end = struct | 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 -> + 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 { 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 = 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 } -> + (* Note: no support for self-links for now; just encode as a tag: {#ID} INNER. *) + let uri = "{#" ^ id ^ "}" in + let self = + 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 { shape; size = lazy (size_of_shape shape) } @@ -585,9 +600,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 3bb5c37..7f35f02 100644 --- a/test/test_html.expected +++ b/test/test_html.expected @@ -1,2 +1,2 @@ -rootchild 1child 2header 3subchild 3header 4subchild 4header 5subchild 5child 5 +rootlink to a hidden anchor12345child 1child 2header 3subchild 3header 4subchild 4header 5subchild 5child 5separatorentry 0.1 entry 0.2child 5.5separatorentry 1 entry 2child 6anchor (visible) entry 3 entry 4child 7separator after hidden anchorentry 5entry 6child 8separatorentry 7entry 8child 9 diff --git a/test/test_html.ml b/test/test_html.ml index e0bf080..db26c5d 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 @@ -11,6 +13,32 @@ 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" ]; + 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"; + anchor ~id:"HiddenAnchor2" empty; + 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 () = diff --git a/test/test_text_uri.expected b/test/test_text_uri.expected index ec5e878..c1a8e17 100644 --- a/test/test_text_uri.expected +++ b/test/test_text_uri.expected @@ -1,9 +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;;\│ │ @@ -12,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;;\│ │ @@ -35,3 +40,88 @@ │ │]8;;https://example.com/7\subchild 6]8;;\│ │ │ └──────────┘ │ └──────────────────┘ +──────────────────────────────────────────────────── +{#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 4fdb683..ec652e7 100644 --- a/test/test_text_uri.ml +++ b/test/test_text_uri.ml @@ -2,22 +2,52 @@ 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" ]; + 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