Anchors (with self-links if inner is non-empty)

.ocamlformat

@@ -1,4 +1,4 @@
-version = 0.24.1
+version = 0.26.1
 profile=conventional
 margin=80
 if-then-else=k-r

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 ]

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 "<a>" 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

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 ] ]

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
+      (* <a id="ID"></a> *)
+      | _ -> (2 * String.length id) + 22
+      (* <a id="ID" href="#ID">INNER</a> *)
+    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 {|<a id="%s">|} id
+      | _ -> fprintf out {|<a id="%s" href="#%s">|} id id);
+      loop ~no_block:true ~no_md ~prefix:(prefix ^ " ") inner;
+      pp_print_string out "</a>"
   in
   pp_open_vbox out 0;
   loop ~no_block:false ~no_md:false ~prefix:"" 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:
+<a id="TreeAnchor" href="#TreeAnchor">Trees</a> &nbsp; are rendered as:
 - The head element
 - > followed by
 - a list of the child elements.
 
-<details><summary>Trees can be made foldable:</summary>
+<details><summary><a id="FoldableTreeAnchor"></a> &nbsp; Trees can be made foldable:</summary>
 
 - The head element
 - > is the summary

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";

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

test/test_html.expected

@@ -1,2 +1,2 @@
-<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>
+<div><details><summary><span style="border:thin solid"><span>root</span></span></summary><ul><li><div><a href="#HiddenAnchor"><div>link to a hidden anchor</div></a></div></li><li><table class="framed"><tr><td><div>1</div></td></tr><tr><td><div>2</div></td></tr><tr><td><div>3</div></td></tr><tr><td><div>4</div></td></tr><tr><td><div>5</div></td></tr></table></li><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><a id="VisibleAnchor" href="#VisibleAnchor"><div>anchor (visible)</div></a></li><li><details><summary><span><span style="border:thin dotted"><span style="border:thin dotted"><a id="HiddenAnchor"></a></span>&nbsp;<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 after hidden anchor</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

@@ -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 () =