Represent sidebar TOC as a Tree

src/document/dune

@@ -14,4 +14,10 @@
   (backend bisect_ppx))
  (instrumentation
   (backend landmarks --auto))
- (libraries odoc_model fpath astring syntax_highlighter odoc_utils))
+ (libraries
+  odoc_model
+  fpath
+  astring
+  syntax_highlighter
+  odoc_utils
+  odoc_index))

src/document/renderer.ml

@@ -6,6 +6,7 @@ let string_of_syntax = function OCaml -> "ml" | Reason -> "re"
 
 type page = {
   filename : Fpath.t;
+  path : Url.Path.t;
   content : Format.formatter -> unit;
   children : page list;
 }
@@ -23,7 +24,7 @@ type input =
 
 type 'a t = {
   name : string;
-  render : 'a -> Types.Block.t option -> Types.Document.t -> page list;
+  render : 'a -> Sidebar.t option -> Types.Document.t -> page list;
   filepath : 'a -> Url.Path.t -> Fpath.t;
 }
 

src/document/sidebar.ml

@@ -1,57 +1,36 @@
 open Odoc_utils
 open Types
+module Id = Odoc_model.Paths.Identifier
 
-let sidebar_toc_entry id content =
-  let href = id |> Url.Path.from_identifier |> Url.from_path in
-  let target = Target.Internal (Resolved href) in
+let sidebar_toc_entry href content =
+  let target = Target.(Internal (Resolved href)) in
   inline @@ Inline.Link { target; content; tooltip = None }
 
 module Toc : sig
   type t
 
-  val of_lang : Odoc_model.Sidebar.PageToc.t -> t
+  val of_page_hierarchy : Odoc_index.Page_hierarchy.t -> t
 
   val to_sidebar :
-    ?fallback:string -> (Url.Path.t * Inline.one -> Block.one) -> t -> Block.t
+    ?fallback:string -> (Url.t * Inline.one -> Block.one) -> t -> Block.t
 end = struct
-  type t = (Url.Path.t * Inline.one) option Tree.t
+  type t = (Url.t * Inline.one) option Tree.t
 
-  open Odoc_model.Sidebar
-  open Odoc_model.Paths.Identifier
-
-  let of_lang (dir : PageToc.t) =
-    let rec of_lang ~parent_id ((content, index) : PageToc.t) =
-      let title, parent_id =
-        match index with
-        | Some (index_id, title) -> (Some title, Some (index_id :> Page.t))
-        | None -> (None, (parent_id :> Page.t option))
-      in
-      let entries =
-        List.filter_map
-          (fun id ->
-            match id with
-            | id, PageToc.Entry title ->
-                (* TODO warn on non empty children order if not index page somewhere *)
-                let payload =
-                  let path = Url.Path.from_identifier id in
-                  let content = Comment.link_content title in
-                  Some (path, sidebar_toc_entry id content)
-                in
-                Some { Tree.node = payload; children = [] }
-            | id, PageToc.Dir dir -> Some (of_lang ~parent_id:(Some id) dir))
-          content
-      in
-      let payload =
-        match (title, parent_id) with
-        | None, _ | _, None -> None
-        | Some title, Some parent_id ->
-            let path = Url.Path.from_identifier parent_id in
-            let content = Comment.link_content title in
-            Some (path, sidebar_toc_entry parent_id content)
-      in
-      { Tree.node = payload; children = entries }
+  let of_page_hierarchy (dir : Odoc_index.Page_hierarchy.t) =
+    let f index =
+      match index with
+      | None -> None
+      | Some (index_id, title) ->
+          let path =
+            match Url.from_identifier ~stop_before:false (index_id :> Id.t) with
+            | Ok r -> r
+            | Error _ -> assert false
+            (* This error case should never happen since [stop_before] is false, and even less since it's a page id *)
+          in
+          let content = Comment.link_content title in
+          Some (path, sidebar_toc_entry path content)
     in
-    of_lang ~parent_id:None dir
+    Tree.map ~f dir
 
   let rec to_sidebar ?(fallback = "root") convert
       { Tree.node = name; children = content } =
@@ -70,29 +49,33 @@ end = struct
     name :: content
 end
 type pages = { name : string; pages : Toc.t }
-type library = { name : string; units : (Url.Path.t * Inline.one) list }
+type library = { name : string; units : (Url.t * Inline.one) list }
 
 type t = { pages : pages list; libraries : library list }
 
-let of_lang (v : Odoc_model.Sidebar.t) =
+let of_lang (v : Odoc_index.sidebar) =
   let pages =
-    let page_hierarchy { Odoc_model.Sidebar.hierarchy_name; pages } =
-      let hierarchy = Toc.of_lang pages in
-      Some { name = hierarchy_name; pages = hierarchy }
+    let page_hierarchy { Odoc_index.p_name; p_hierarchy } =
+      let hierarchy = Toc.of_page_hierarchy p_hierarchy in
+      Some { name = p_name; pages = hierarchy }
     in
     Odoc_utils.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)
+      let path = Url.from_identifier ~stop_before:false (id :> Id.t) in
+      match path with
+      | Ok path -> Some (path, sidebar_toc_entry path content)
+      | Error _ -> None
+      (* This error case should never happen since [stop_before] is false *)
     in
     let units =
       List.map
-        (fun { Odoc_model.Sidebar.units; name } ->
-          let units = List.map item units in
+        (fun { Odoc_index.units; name } ->
+          let units = List.filter_map item units in
           { name; units })
-        v.libraries
+        v.libs
     in
     units
   in
@@ -106,7 +89,8 @@ let to_block (sidebar : t) url =
   in
   let render_entry (entry_path, b) =
     let link =
-      if entry_path = url then { b with Inline.attr = [ "current_unit" ] }
+      if entry_path = Url.from_path url then
+        { b with Inline.attr = [ "current_unit" ] }
       else b
     in
     Types.block @@ Inline [ link ]

src/document/sidebar.mli

@@ -1,6 +1,6 @@
 type t
 
-val of_lang : Odoc_model.Sidebar.t -> t
+val of_lang : Odoc_index.sidebar -> t
 
 val to_block : t -> Url.Path.t -> Types.Block.t
 (** Generates the sidebar document given a global sidebar and the path at which

src/html/generator.ml

@@ -542,7 +542,7 @@ module Page = struct
       match sidebar with
       | None -> None
       | Some sidebar ->
-          (* let sidebar = Odoc_document.Sidebar.to_block sidebar p in *)
+          let sidebar = Odoc_document.Sidebar.to_block sidebar url in
           (Some (block ~config ~resolve sidebar) :> any Html.elt list option)
     in
     let i = Doctree.Shift.compute ~on_sub i in

src/html/generator.mli

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

src/html/html_fragment_json.ml

@@ -62,7 +62,7 @@ let make ~config ~preamble ~url ~breadcrumbs ~sidebar ~toc ~uses_katex
              ("content", `String (json_of_html content));
            ]))
   in
-  { Odoc_document.Renderer.filename; content; children }
+  { Odoc_document.Renderer.filename; content; children; path = url }
 
 let make_src ~config ~url ~breadcrumbs content =
   let filename = Link.Path.as_filename ~config url in
@@ -82,4 +82,4 @@ let make_src ~config ~url ~breadcrumbs content =
                     (List.map (Format.asprintf "%a" htmlpp) content)) );
            ]))
   in
-  { Odoc_document.Renderer.filename; content; children = [] }
+  { Odoc_document.Renderer.filename; content; children = []; path = url }

src/html/html_page.ml

@@ -249,7 +249,7 @@ let make ~config ~url ~header ~breadcrumbs ~sidebar ~toc ~uses_katex content
     page_creator ~config ~url ~uses_katex ~global_toc:sidebar header breadcrumbs
       toc content
   in
-  { Odoc_document.Renderer.filename; content; children }
+  { Odoc_document.Renderer.filename; content; children; path = url }
 
 let path_of_module_of_source ppf url =
   match url.Url.Path.parent with
@@ -289,4 +289,4 @@ let make_src ~config ~url ~breadcrumbs ~header title content =
   let content =
     src_page_creator ~breadcrumbs ~config ~url ~header title content
   in
-  { Odoc_document.Renderer.filename; content; children = [] }
+  { Odoc_document.Renderer.filename; content; children = []; path = url }

src/index/dune

@@ -0,0 +1,4 @@
+(library
+ (name odoc_index)
+ (public_name odoc.index)
+ (libraries odoc_model odoc_html_frontend tyxml odoc_utils))

src/search/entry.ml → src/index/entry.ml

@@ -139,7 +139,7 @@ and entries_of_doc id d =
   | `Table _ -> []
   | `Media _ -> []
 
-let entries_of_item (x : Odoc_model.Fold.item) =
+let entries_of_item (x : Fold.item) =
   match x with
   | CompilationUnit u -> (
       match u.content with

src/search/entry.mli → src/index/entry.mli

@@ -61,4 +61,4 @@ type t = {
   kind : kind;
 }
 
-val entries_of_item : Odoc_model.Fold.item -> t list
+val entries_of_item : Fold.item -> t list

src/model/fold.ml → src/index/fold.ml

@@ -1,3 +1,4 @@
+open Odoc_model
 open Lang
 
 type item =

src/model/fold.mli → src/index/fold.mli

@@ -3,6 +3,7 @@
     in reality it is quite specialized to fold over searchable items, and not
     every kind of odoc value you could fold over.*)
 
+open Odoc_model
 open Lang
 
 (** The type of items you can fold over *)

src/index/odoc_index.ml

@@ -0,0 +1,17 @@
+module Entry = Entry
+module Fold = Fold
+module Page_hierarchy = Page_hierarchy
+
+type page = { p_name : string; p_hierarchy : Page_hierarchy.t }
+
+type library = {
+  name : string;
+  units : Odoc_model.Paths.Identifier.RootModule.t list;
+}
+
+type sidebar = { pages : page list; libs : library list }
+
+type 'a t = {
+  sidebar : sidebar;
+  index : 'a Odoc_model.Paths.Identifier.Hashtbl.Any.t;
+}