Experimental --as-json option for the HTML renderer

CHANGES.md

@@ -1,3 +1,8 @@
+Additions
+- New (experimental!) option `--as-json` for the HTML renderer that emits HTML
+  fragments (preamble, content) together with metadata (table of contents,
+  breadcrumbs, whether katex is used) in JSON format.
+
 2.1.0
 -----
 

src/html/config.ml

@@ -7,24 +7,12 @@ type t = {
   indent : bool;
   flat : bool;
   open_details : bool;
-  omit_breadcrumbs : bool;
-  omit_toc : bool;
-  content_only : bool;
+  as_json : bool;
 }
 
 let v ?theme_uri ?support_uri ~semantic_uris ~indent ~flat ~open_details
-    ~omit_breadcrumbs ~omit_toc ~content_only () =
-  {
-    theme_uri;
-    support_uri;
-    semantic_uris;
-    indent;
-    flat;
-    open_details;
-    omit_breadcrumbs;
-    omit_toc;
-    content_only;
-  }
+    ~as_json () =
+  { semantic_uris; indent; flat; open_details; theme_uri; support_uri; as_json }
 
 let theme_uri config =
   match config.theme_uri with None -> Types.Relative None | Some uri -> uri
@@ -40,8 +28,4 @@ let flat config = config.flat
 
 let open_details config = config.open_details
 
-let omit_breadcrumbs config = config.omit_breadcrumbs
-
-let omit_toc config = config.omit_toc
-
-let content_only config = config.content_only
+let as_json config = config.as_json

src/html/config.mli

@@ -9,9 +9,7 @@ val v :
   indent:bool ->
   flat:bool ->
   open_details:bool ->
-  omit_breadcrumbs:bool ->
-  omit_toc:bool ->
-  content_only:bool ->
+  as_json:bool ->
   unit ->
   t
 
@@ -27,8 +25,4 @@ val flat : t -> bool
 
 val open_details : t -> bool
 
-val omit_breadcrumbs : t -> bool
-
-val omit_toc : t -> bool
-
-val content_only : t -> bool
+val as_json : t -> bool

src/html/generator.ml

@@ -375,6 +375,29 @@ module Toc = struct
     List.map section toc
 end
 
+module Breadcrumbs = struct
+  open Types
+
+  let gen_breadcrumbs ~config ~url =
+    let rec get_parent_paths x =
+      match x with
+      | [] -> []
+      | x :: xs -> (
+          match Odoc_document.Url.Path.of_list (List.rev (x :: xs)) with
+          | Some x -> x :: get_parent_paths xs
+          | None -> get_parent_paths xs)
+    in
+    let to_breadcrumb path =
+      let href =
+        Link.href ~config ~resolve:(Current url)
+          (Odoc_document.Url.from_path path)
+      in
+      { href; name = path.name; kind = path.kind }
+    in
+    get_parent_paths (List.rev (Odoc_document.Url.Path.to_list url))
+    |> List.rev |> List.map to_breadcrumb
+end
+
 module Page = struct
   let on_sub = function
     | `Page _ -> None
@@ -399,11 +422,18 @@ module Page = struct
     let i = Doctree.Shift.compute ~on_sub i in
     let uses_katex = Doctree.Math.has_math_elements p in
     let toc = Toc.gen_toc ~config ~resolve ~path:url i in
+    let breadcrumbs = Breadcrumbs.gen_breadcrumbs ~config ~url in
     let header =
       items ~config ~resolve (Doctree.PageTitle.render_title p @ preamble)
     in
     let content = (items ~config ~resolve i :> any Html.elt list) in
-    Tree.make ~config ~header ~toc ~url ~uses_katex url.name content subpages
+    if Config.as_json config then
+      Html_fragment_json.make ~config
+        ~preamble:(items ~config ~resolve preamble :> any Html.elt list)
+        ~breadcrumbs ~toc ~url ~uses_katex content subpages
+    else
+      Html_page.make ~config ~header ~toc ~breadcrumbs ~url ~uses_katex content
+        subpages
 end
 
 let render ~config page = Page.page ~config page

src/html/html_fragment_json.ml

@@ -0,0 +1,55 @@
+(* Rendering of HTML fragments together with metadata. For embedding the
+   generated documentation in existing websites.
+*)
+
+module Html = Tyxml.Html
+
+let json_of_breadcrumbs (breadcrumbs : Types.breadcrumb list) : Utils.Json.json
+    =
+  let breadcrumb (b : Types.breadcrumb) =
+    `Object
+      [
+        ("name", `String b.name);
+        ("href", `String b.href);
+        ("kind", `String (Odoc_document.Url.Path.string_of_kind b.kind));
+      ]
+  in
+  let json_breadcrumbs = breadcrumbs |> List.map breadcrumb in
+  `Array json_breadcrumbs
+
+let json_of_toc (toc : Types.toc list) : Utils.Json.json =
+  let rec section (s : Types.toc) =
+    `Object
+      [
+        ("title", `String s.title_str);
+        ("href", `String s.href);
+        ("children", `Array (List.map section s.children));
+      ]
+  in
+  let toc_json_list = toc |> List.map section in
+  `Array toc_json_list
+
+let make ~config ~preamble ~url ~breadcrumbs ~toc ~uses_katex content children =
+  let filename = Link.Path.as_filename ~is_flat:(Config.flat config) url in
+  let filename = Fpath.add_ext ".json" filename in
+  let htmlpp = Html.pp_elt ~indent:(Config.indent config) () in
+  let json_to_string json = Utils.Json.to_string json in
+  let content ppf =
+    Format.pp_print_string ppf
+      (json_to_string
+         (`Object
+           [
+             ("uses_katex", `Bool uses_katex);
+             ("breadcrumbs", json_of_breadcrumbs breadcrumbs);
+             ("toc", json_of_toc toc);
+             ( "preamble",
+               `String
+                 (String.concat ""
+                    (List.map (Format.asprintf "%a" htmlpp) preamble)) );
+             ( "content",
+               `String
+                 (String.concat ""
+                    (List.map (Format.asprintf "%a" htmlpp) content)) );
+           ]))
+  in
+  [ { Odoc_document.Renderer.filename; content; children } ]

src/html/html_fragment_json.mli

@@ -0,0 +1,12 @@
+module Html = Tyxml.Html
+
+val make :
+  config:Config.t ->
+  preamble:Html_types.div_content Html.elt list ->
+  url:Odoc_document.Url.Path.t ->
+  breadcrumbs:Types.breadcrumb list ->
+  toc:Types.toc list ->
+  uses_katex:bool ->
+  Html_types.div_content Html.elt list ->
+  Odoc_document.Renderer.page list ->
+  Odoc_document.Renderer.page list

src/html/tree.ml → src/html/html_page.ml

@@ -18,7 +18,7 @@ module Html = Tyxml.Html
 
 let html_of_toc toc =
   let open Types in
-  let rec section section =
+  let rec section (section : toc) =
     let link = Html.a ~a:[ Html.a_href section.href ] section.title in
     match section.children with [] -> [ link ] | cs -> [ link; sections cs ]
   and sections the_sections =
@@ -30,13 +30,54 @@ let html_of_toc toc =
   | [] -> []
   | _ -> [ Html.nav ~a:[ Html.a_class [ "odoc-toc" ] ] [ sections toc ] ]
 
-let page_creator ~config ~url ~uses_katex name header toc content =
+let html_of_breadcrumbs (breadcrumbs : Types.breadcrumb list) =
+  let make_navigation ~up_url rest =
+    [
+      Html.nav
+        ~a:[ Html.a_class [ "odoc-nav" ] ]
+        ([ Html.a ~a:[ Html.a_href up_url ] [ Html.txt "Up" ]; Html.txt " – " ]
+        @ rest);
+    ]
+  in
+  match List.rev breadcrumbs with
+  | [] -> [] (* Can't happen - there's always the current page's breadcrumb. *)
+  | [ _ ] -> [] (* No parents *)
+  | [ { name = "index"; _ }; x ] ->
+      (* Special case leaf pages called 'index' with one parent. This is for files called
+          index.mld that would otherwise clash with their parent. In particular,
+          dune and odig both cause this situation right now. *)
+      let up_url = "../index.html" in
+      let parent_name = x.name in
+      make_navigation ~up_url [ Html.txt parent_name ]
+  | current :: up :: bs ->
+      let space = Html.txt " " in
+      let sep = [ space; Html.entity "#x00BB"; space ] in
+      let html =
+        (* Create breadcrumbs *)
+        Utils.list_concat_map ?sep:(Some sep)
+          ~f:(fun (breadcrumb : Types.breadcrumb) ->
+            [
+              [
+                Html.a
+                  ~a:[ Html.a_href breadcrumb.href ]
+                  [ Html.txt breadcrumb.name ];
+              ];
+            ])
+          (up :: bs)
+        |> List.flatten
+      in
+      make_navigation ~up_url:up.href
+        (List.rev html @ sep @ [ Html.txt current.name ])
+
+let page_creator ~config ~url ~uses_katex header breadcrumbs toc content =
   let theme_uri = Config.theme_uri config in
   let support_uri = Config.support_uri config in
   let path = Link.Path.for_printing url in
 
   let head : Html_types.head Html.elt =
-    let title_string = Printf.sprintf "%s (%s)" name (String.concat "." path) in
+    let title_string =
+      Printf.sprintf "%s (%s)" url.name (String.concat "." path)
+    in
 
     let file_uri base file =
       match base with
@@ -99,89 +140,20 @@ let page_creator ~config ~url ~uses_katex name header toc content =
     Html.head (Html.title (Html.txt title_string)) meta_elements
   in
 
-  let gen_breadcrumbs () =
-    let rec get_parents x =
-      match x with
-      | [] -> []
-      | x :: xs -> (
-          match Odoc_document.Url.Path.of_list (List.rev (x :: xs)) with
-          | Some x -> x :: get_parents xs
-          | None -> get_parents xs)
-    in
-    let parents =
-      get_parents (List.rev (Odoc_document.Url.Path.to_list url)) |> List.rev
-    in
-    let href page =
-      Link.href ~resolve:(Current url) (Odoc_document.Url.from_path page)
-    in
-    let make_navigation ~up_url breadcrumbs =
-      [
-        Html.nav
-          ~a:[ Html.a_class [ "odoc-nav" ] ]
-          ([
-             Html.a ~a:[ Html.a_href up_url ] [ Html.txt "Up" ]; Html.txt " – ";
-           ]
-          @ breadcrumbs);
-      ]
-    in
-    match parents with
-    | [] -> [] (* Can't happen - Url.Path.to_list returns a non-empty list *)
-    | [ _ ] -> [] (* No parents *)
-    | [ x; { name = "index"; _ } ] ->
-        (* Special case leaf pages called 'index' with one parent. This is for files called
-           index.mld that would otherwise clash with their parent. In particular,
-           dune and odig both cause this situation right now. *)
-        let up_url = "../index.html" in
-        let parent_name = x.name in
-        make_navigation ~up_url [ Html.txt parent_name ]
-    | _ ->
-        let up_url = href ~config (List.hd (List.tl (List.rev parents))) in
-        let l =
-          (* Create breadcrumbs *)
-          let space = Html.txt " " in
-          parents
-          |> Utils.list_concat_map
-               ?sep:(Some [ space; Html.entity "#x00BB"; space ])
-               ~f:(fun url' ->
-                 [
-                   [
-                     (if url = url' then Html.txt url.name
-                     else
-                       Html.a
-                         ~a:[ Html.a_href (href ~config url') ]
-                         [ Html.txt url'.name ]);
-                   ];
-                 ])
-          |> List.flatten
-        in
-        make_navigation ~up_url l
-  in
-
-  let breadcrumbs =
-    if Config.omit_breadcrumbs config then [] else gen_breadcrumbs ()
-  in
-  let toc = if Config.omit_toc config then [] else html_of_toc toc in
   let body =
-    breadcrumbs
+    html_of_breadcrumbs breadcrumbs
     @ [ Html.header ~a:[ Html.a_class [ "odoc-preamble" ] ] header ]
-    @ toc
+    @ html_of_toc toc
     @ [ Html.div ~a:[ Html.a_class [ "odoc-content" ] ] content ]
   in
-  let htmlpp_elt = Html.pp_elt ~indent:(Config.indent config) () in
   let htmlpp = Html.pp ~indent:(Config.indent config) () in
-  if Config.content_only config then
-    let content ppf =
-      htmlpp_elt ppf (Html.div ~a:[ Html.a_class [ "odoc" ] ] body)
-    in
-    content
-  else
-    let html = Html.html head (Html.body ~a:[ Html.a_class [ "odoc" ] ] body) in
-    let content ppf = htmlpp ppf html in
-    content
+  let html = Html.html head (Html.body ~a:[ Html.a_class [ "odoc" ] ] body) in
+  let content ppf = htmlpp ppf html in
+  content
 
-let make ~config ~url ~header ~toc ~uses_katex title content children =
+let make ~config ~url ~header ~breadcrumbs ~toc ~uses_katex content children =
   let filename = Link.Path.as_filename ~is_flat:(Config.flat config) url in
   let content =
-    page_creator ~config ~url ~uses_katex title header toc content
+    page_creator ~config ~url ~uses_katex header breadcrumbs toc content
   in
   [ { Odoc_document.Renderer.filename; content; children } ]

src/html/tree.mli → src/html/html_page.mli

@@ -24,9 +24,9 @@ val make :
   config:Config.t ->
   url:Odoc_document.Url.Path.t ->
   header:Html_types.flow5_without_header_footer Html.elt list ->
+  breadcrumbs:Types.breadcrumb list ->
   toc:Types.toc list ->
   uses_katex:bool ->
-  string ->
   Html_types.div_content Html.elt list ->
   Odoc_document.Renderer.page list ->
   Odoc_document.Renderer.page list

src/html/link.ml

@@ -45,7 +45,7 @@ let rec drop_shared_prefix l1 l2 =
   | l1 :: l1s, l2 :: l2s when l1 = l2 -> drop_shared_prefix l1s l2s
   | _, _ -> (l1, l2)
 
-let href ~(config : Config.t) ~resolve t =
+let href ~config ~resolve t =
   let { Url.Anchor.page; anchor; _ } = t in
 
   let target_loc = Path.for_linking ~is_flat:(Config.flat config) page in

src/html/odoc_html.ml

@@ -1,8 +1,11 @@
 module Types = Types
 module Config = Config
 
-module Tree = Tree
-(** @canonical Odoc_html.Tree *)
+module Html_fragment_json = Html_fragment_json
+(** @canonical Odoc_html.Html_fragment_json *)
+
+module Html_page = Html_page
+(** @canonical Odoc_html.Html_page *)
 
 module Generator = Generator
 module Link = Link

src/html/types.ml

@@ -8,3 +8,9 @@ type toc = {
   href : string;
   children : toc list;
 }
+
+type breadcrumb = {
+  href : string;
+  name : string;
+  kind : Odoc_document.Url.Path.kind;
+}