Merge pull request #44 from lukstafi/anchors

Anchors

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

@@ -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,20 +159,66 @@ 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 ->
       (H.div [] :> [< Html_types.flow5 > `Pre `Span `Div `P `Table `Ul ] html)
     | 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 ] ]

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