Sidebar: separate its generation pipeline from main doc

Signed-off-by: Paul-Elliot <[email protected]>

src/document/ML.mli

@@ -16,10 +16,9 @@
 
 open Odoc_model
 
-val compilation_unit :
-  ?sidebar:Lang.Sidebar.t -> Lang.Compilation_unit.t -> Types.Document.t
+val compilation_unit : Lang.Compilation_unit.t -> Types.Document.t
 
-val page : ?sidebar:Lang.Sidebar.t -> Lang.Page.t -> Types.Document.t
+val page : Lang.Page.t -> Types.Document.t
 (** Convert compilation unit or page models into a document *)
 
 val source_tree : Lang.SourceTree.t -> Types.Document.t list

src/document/generator_signatures.ml

@@ -102,10 +102,9 @@ module type SYNTAX = sig
 end
 
 module type GENERATOR = sig
-  val compilation_unit :
-    ?sidebar:Lang.Sidebar.t -> Lang.Compilation_unit.t -> Document.t
+  val compilation_unit : Lang.Compilation_unit.t -> Document.t
 
-  val page : ?sidebar:Lang.Sidebar.t -> Lang.Page.t -> Document.t
+  val page : Lang.Page.t -> Document.t
 
   val source_tree : Lang.SourceTree.t -> Document.t list
 

src/document/reason.mli

@@ -16,10 +16,9 @@
 
 open Odoc_model
 
-val compilation_unit :
-  ?sidebar:Lang.Sidebar.t -> Lang.Compilation_unit.t -> Types.Document.t
+val compilation_unit : Lang.Compilation_unit.t -> Types.Document.t
 
-val page : ?sidebar:Lang.Sidebar.t -> Lang.Page.t -> Types.Document.t
+val page : Lang.Page.t -> Types.Document.t
 (** Convert compilation unit or page models into a document *)
 
 val source_tree : Lang.SourceTree.t -> Types.Document.t list

src/document/renderer.ml

@@ -23,14 +23,12 @@ type input =
 
 type 'a t = {
   name : string;
-  render : 'a -> Types.Document.t -> page list;
+  render : 'a -> Types.Block.t option -> Types.Document.t -> page list;
   extra_documents : 'a -> input -> Types.Document.t list;
 }
 
-let document_of_page ~syntax ?sidebar v =
-  match syntax with
-  | Reason -> Reason.page ?sidebar v
-  | OCaml -> ML.page ?sidebar v
+let document_of_page ~syntax v =
+  match syntax with Reason -> Reason.page v | OCaml -> ML.page v
 
 let documents_of_source_tree ~syntax v =
   match syntax with Reason -> Reason.source_tree v | OCaml -> ML.source_tree v
@@ -40,7 +38,7 @@ let documents_of_implementation ~syntax v =
   | Reason -> Reason.implementation v
   | OCaml -> ML.implementation v
 
-let document_of_compilation_unit ~syntax ?sidebar v =
+let document_of_compilation_unit ~syntax v =
   match syntax with
-  | Reason -> Reason.compilation_unit ?sidebar v
-  | OCaml -> ML.compilation_unit ?sidebar v
+  | Reason -> Reason.compilation_unit v
+  | OCaml -> ML.compilation_unit v

src/document/sidebar.ml

@@ -0,0 +1,144 @@
+open Types
+
+module Hierarchy : sig
+  type 'a dir
+  (** Directory in a filesystem-like abstraction, where files have a ['a]
+      payload and directory can also have a ['a] payload. *)
+
+  val make : ('a * string list) list -> 'a dir
+  (** Create a directory from a list of payload and file path (given as a
+      string list). Files named ["index"] give their payload to their
+      containing directory. *)
+
+  val remove_common_root : 'a dir -> 'a dir
+  (** Returns the deepest subdir containing all files. *)
+
+  val to_sidebar : ?fallback:string -> ('a -> Block.one) -> 'a dir -> Block.t
+end = struct
+  type 'a dir = 'a option * (string * 'a t) list
+  and 'a t = Leaf of 'a | Dir of 'a dir
+
+  let rec add_entry_to_dir (dir : 'a dir) payload path =
+    match (path, dir) with
+    | [], _ -> assert false
+    | [ "index" ], (None, l) -> (Some payload, l)
+    | [ name ], (p, l) -> (p, (name, Leaf payload) :: l)
+    | name :: rest, (p, l) ->
+        let rec add_to_dir (l : (string * 'a t) list) =
+          match l with
+          | [] -> [ (name, Dir (add_entry_to_dir (None, []) payload rest)) ]
+          | (name2, Dir d) :: q when name = name2 ->
+              (name2, Dir (add_entry_to_dir d payload rest)) :: q
+          | d :: q -> d :: add_to_dir q
+        in
+        (p, add_to_dir l)
+
+  let make l =
+    let empty = (None, []) in
+    let add_entry_to_dir acc (path, payload) =
+      add_entry_to_dir acc path payload
+    in
+    List.fold_left add_entry_to_dir empty l
+
+  let rec remove_common_root = function
+    | None, [ (_, Dir d) ] -> remove_common_root d
+    | x -> x
+
+  let rec to_sidebar ?(fallback = "root") convert (name, content) =
+    let name =
+      match name with
+      | Some v -> convert v
+      | None -> block (Block.Inline [ inline (Text fallback) ])
+    in
+    let content =
+      let content = List.map (t_to_sidebar convert) content in
+      block (Block.List (Block.Unordered, content))
+    in
+    [ name; content ]
+
+  and t_to_sidebar convert = function
+    | _, Leaf payload -> [ convert payload ]
+    | fallback, Dir d -> to_sidebar ~fallback convert d
+end
+type pages = { name : string; pages : (Url.Path.t * Inline.one) Hierarchy.dir }
+type library = { name : string; units : (Url.Path.t * Inline.one) list }
+
+type t = { pages : pages list; libraries : library list }
+
+let of_lang (v : Odoc_model.Lang.Sidebar.t) =
+  let sidebar_toc_entry id content =
+    let href = id |> Url.Path.from_identifier |> Url.from_path in
+    let target = InternalLink.Resolved href in
+    let link = { InternalLink.target; content; tooltip = None } in
+    inline @@ Inline.InternalLink link
+  in
+  let pages =
+    let page_hierarchy { Odoc_model.Lang.Sidebar.page_name; pages } =
+      if pages = [] then None
+      else
+        let prepare_for_hierarchy (link_content, id) =
+          let path = Url.Path.from_identifier id in
+          let payload =
+            let content = Comment.link_content link_content in
+            (path, sidebar_toc_entry id content)
+          in
+          (payload, path |> Url.Path.to_list |> List.map snd)
+        in
+        let pages = List.map prepare_for_hierarchy pages in
+        let hierarchy = Hierarchy.make pages |> Hierarchy.remove_common_root in
+        Some { name = page_name; pages = hierarchy }
+    in
+    List.filter_map page_hierarchy v.pages
+  in
+  let units =
+    let item id =
+      let content = [ inline @@ Text (Odoc_model.Paths.Identifier.name id) ] in
+      (Url.Path.from_identifier id, sidebar_toc_entry id content)
+    in
+    let units =
+      List.map
+        (fun { Odoc_model.Lang.Sidebar.units; name } ->
+          let units = List.map item units in
+          { name; units })
+        v.libraries
+    in
+    units
+  in
+  { pages; libraries = units }
+
+let to_block (sidebar : t) url =
+  let { pages; libraries } = sidebar in
+  let title t =
+    block
+      (Inline [ inline (Inline.Styled (`Bold, [ inline (Inline.Text t) ])) ])
+  in
+  let render_entry (entry_path, b) =
+    let link =
+      if entry_path = url then { b with Inline.attr = [ "current_unit" ] }
+      else b
+    in
+    Types.block @@ Inline [ link ]
+  in
+  let pages =
+    List.concat_map
+      (fun (p : pages) ->
+        let pages = Hierarchy.to_sidebar render_entry p.pages in
+        let pages = [ block (Block.List (Block.Unordered, [ pages ])) ] in
+        let pages = [ title @@ p.name ^ "'s Pages" ] @ pages in
+        pages)
+      pages
+  in
+  let units =
+    let units =
+      List.map
+        (fun { units; name } ->
+          [
+            title name;
+            block (List (Block.Unordered, [ List.map render_entry units ]));
+          ])
+        libraries
+    in
+    let units = block (Block.List (Block.Unordered, units)) in
+    [ title "Libraries"; units ]
+  in
+  pages @ units

src/document/types.ml

@@ -174,7 +174,6 @@ and Page : sig
   type t = {
     preamble : Item.t list;
     items : Item.t list;
-    sidebar : Block.t option;
     url : Url.Path.t;
     source_anchor : Url.t option;
         (** Url to the corresponding source code. Might be a whole source file

src/html/generator.ml

@@ -482,20 +482,24 @@ module Page = struct
         | `Closed | `Open | `Default -> None
         | `Inline -> Some 0)
 
-  let rec include_ ~config { Subpage.content; _ } = page ~config content
+  let rec include_ ~config ~sidebar { Subpage.content; _ } =
+    page ~config ~sidebar content
 
-  and subpages ~config subpages = List.map (include_ ~config) subpages
+  and subpages ~config ~sidebar subpages =
+    List.map (include_ ~config ~sidebar) subpages
 
-  and page ~config p : Odoc_document.Renderer.page =
-    let { Page.preamble; items = i; url; source_anchor; sidebar } =
+  and page ~config ~sidebar p : Odoc_document.Renderer.page =
+    let { Page.preamble; items = i; url; source_anchor } =
       Doctree.Labels.disambiguate_page ~enter_subpages:false p
     in
-    let subpages = subpages ~config @@ Doctree.Subpages.compute p in
+    let subpages = subpages ~config ~sidebar @@ Doctree.Subpages.compute p in
     let resolve = Link.Current url in
     let sidebar =
       match sidebar with
       | None -> None
-      | Some x -> (Some (block ~config ~resolve x) :> any Html.elt list option)
+      | Some sidebar ->
+          (* let sidebar = Odoc_document.Sidebar.to_block sidebar p in *)
+          (Some (block ~config ~resolve sidebar) :> any Html.elt list option)
     in
     let i = Doctree.Shift.compute ~on_sub i in
     let uses_katex = Doctree.Math.has_math_elements p in
@@ -553,8 +557,8 @@ module Page = struct
     { Odoc_document.Renderer.filename; content; children = [] }
 end
 
-let render ~config = function
-  | Document.Page page -> [ Page.page ~config page ]
+let render ~config ~sidebar = function
+  | Document.Page page -> [ Page.page ~config ~sidebar page ]
   | Source_page src -> [ Page.source_page ~config src ]
   | Asset asset -> [ Page.asset ~config asset ]
 

src/html/generator.mli

@@ -1,5 +1,6 @@
 val render :
   config:Config.t ->
+  sidebar:Odoc_document.Types.Block.t option ->
   Odoc_document.Types.Document.t ->
   Odoc_document.Renderer.page list
 

src/odoc/html_page.ml

@@ -18,8 +18,8 @@ open Odoc_model
 
 type args = { html_config : Odoc_html.Config.t; assets : Fpath.t list }
 
-let render { html_config; assets = _ } page =
-  Odoc_html.Generator.render ~config:html_config page
+let render { html_config; assets = _ } sidebar page =
+  Odoc_html.Generator.render ~config:html_config ~sidebar page
 
 let list_filter_map f lst =
   List.rev

src/odoc/latex.ml

@@ -2,7 +2,7 @@ open Odoc_document
 
 type args = { with_children : bool }
 
-let render args page =
+let render args _sidebar page =
   Odoc_latex.Generator.render ~with_children:args.with_children page
 
 let extra_documents _args _unit = []

src/odoc/man_page.ml

@@ -1,6 +1,6 @@
 open Odoc_document
 
-let render _ page = Odoc_manpage.Generator.render page
+let render _ _sidebar page = Odoc_manpage.Generator.render page
 
 let extra_documents _args _unit = []