Sidebar and index overhaul

This commit includes multiple modifications:

Trees
----------

Odoc used to have several representations of trees: one for the page sidebar in
the model, one for the document sidebar, and (in a squashed commit) one for the
unit sidebar.

All trees now have the same type, making the different passes (eg model ->
document for pages and units) much easier, at a small cost (the type is less
tailored to the usecase, eg the payload cannot be different in leafs than in
node, which was the case before in the page hierarchy).

Trees (and forests) have basic iterators defined.

The index for units
------------------------

The index for the units values used to be a hashtable from ID to entry. The
problem was that you cannot rebuild a sidebar from that: you lose the order
between children.

The index for units now is a tree of index entries.

The sidebar for units
-------------------------

The sidebar for units finally shows more than just the root module.

However, it does not show the full hierarchy either, as that would be
overwhelming in the case of big modules.

The sidebar shows:
- Only entries that could have had an expansion: modules, modules types, classes
  and class types.
- The current page (highlighted),
- The children of the current page, (highlighted differently),
- The ancestors of the current page,
- The children of the ancestors of the current page,
- Nothing else.

If you allow me, I like to use the github syntax for mathematics 😄. The
sidebar has the property that it displays the smallest set $S$ that:
- Contains only modules, modules types, classes and class types.
- Contains the current page: $current\_page\in S$,
- Is ancestor-closed: if $e\in S$ then $parent(e)\in S$,
- Is sibling-closed: if $e\in S$ and $parent(e)=parent(f)$, then $f\in S$

The last property is important to avoid displaying only part of the children of
a parent, requiring to display some `...` to show that some entries were
omitted.

Organization in directories and libraries
-----------------------------------------------------

The `search/` folder and its associated `odoc_search` library was separated in
two: the original one and the new `index/` and `odoc_index` which contains
everything that an index should contain: both the info for the sidebar and for
the search index.

src/document/dune

@@ -14,4 +14,4 @@
   (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

@@ -2,118 +2,163 @@ open Odoc_utils
 open Types
 
 let sidebar_toc_entry id content =
-  let href = id |> Url.Path.from_identifier |> Url.from_path in
+  let href =
+    (id :> Odoc_model.Paths.Identifier.t)
+    |> Url.from_identifier ~stop_before:false
+    |> Result.get_ok
+  in
   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 of_skeleton : Odoc_index.Skeleton.t -> t
 
-  val to_sidebar :
-    ?fallback:string -> (Url.Path.t * Inline.one -> Block.one) -> t -> Block.t
+  val to_block : prune:bool -> Url.Path.t -> t -> Block.t
 end = struct
-  type t = Item of (Url.Path.t * Inline.one) option * t list
+  type t = (Url.t * Inline.one) option Tree.t
 
-  open Odoc_model.Sidebar
-  open Odoc_model.Paths.Identifier
+  module Id = Odoc_model.Paths.Identifier
 
-  let of_lang (dir : PageToc.t) =
-    let rec of_lang ~parent_id ((content, index) : PageToc.t) =
-      let title, parent_id =
+  let of_page_hierarchy (dir : Odoc_index.Page_hierarchy.t) =
+    let fun_ index =
+      let payload =
         match index with
-        | Some (index_id, title) -> (Some title, Some (index_id :> Page.t))
-        | None -> (None, (parent_id :> Page.t option))
+        | None -> None
+        | Some (index_id, title) ->
+            let path =
+              Url.from_identifier ~stop_before:false (index_id :> Id.t)
+              |> Result.get_ok
+            in
+            let content = Comment.link_content title in
+            Some (path, sidebar_toc_entry index_id content)
       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 (Item (payload, []))
-            | id, PageToc.Dir dir -> Some (of_lang ~parent_id:(Some id) dir))
-          content
+      payload
+    in
+    Tree.map_t fun_ dir
+
+  let rec is_prefix (url1 : Url.Path.t) (url2 : Url.Path.t) =
+    if url1 = url2 then true
+    else
+      match url2 with
+      | { parent = Some parent; _ } -> is_prefix url1 parent
+      | { parent = None; _ } -> false
+
+  let parent (url : Url.t) =
+    match url with
+    | { anchor = ""; page = { parent = Some parent; _ }; _ } -> parent
+    | { page; _ } -> page
+
+  let to_block ~prune (current_url : Url.Path.t) tree =
+    let block_tree_of_t (current_url : Url.Path.t) tree =
+      (* When transforming the tree, we use a filter_map to remove the nodes that
+         are irrelevant for the current url. However, we always want to keep the
+         root. So we apply the filter_map starting from the first children. *)
+      let convert ((url : Url.t), b) =
+        let link =
+          if url.page = current_url && String.equal url.anchor "" then
+            { b with Inline.attr = [ "current_unit" ] }
+          else b
+        in
+        Types.block @@ Inline [ link ]
       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)
+      let fun_ name =
+        match name with
+        | Some ((url, _) as v)
+          when (not prune) || is_prefix (parent url) current_url ->
+            Some (convert v)
+        | _ -> None
+      in
+      let root_entry =
+        match tree.Tree.node with
+        | Some v -> convert v
+        | None -> block (Block.Inline [ inline (Text "root") ])
       in
-      Item (payload, entries)
+      {
+        Tree.node = root_entry;
+        children = Tree.filter_map_f fun_ tree.children;
+      }
     in
-    of_lang ~parent_id:None dir
+    let rec block_of_block_tree { Tree.node = name; children = content } =
+      let content =
+        match content with
+        | [] -> []
+        | _ :: _ ->
+            let content = List.map block_of_block_tree content in
+            [ block (Block.List (Block.Unordered, content)) ]
+      in
+      name :: content
+    in
+    let block_tree = block_tree_of_t current_url tree in
+    block_of_block_tree block_tree
 
-  let rec to_sidebar ?(fallback = "root") convert (Item (name, content)) =
-    let name =
-      match name with
-      | Some v -> convert v
-      | None -> block (Block.Inline [ inline (Text fallback) ])
+  let of_skeleton ({ node = entry; children } : Odoc_index.Entry.t Tree.t) =
+    let map_entry entry =
+      let stop_before =
+        match entry.Odoc_index.Entry.kind with
+        | ModuleType { has_expansion } | Module { has_expansion } ->
+            not has_expansion
+        | _ -> false
+      in
+      let path = Url.from_identifier ~stop_before entry.id in
+      let name = Odoc_model.Paths.Identifier.name entry.id in
+      match path with
+      | Ok path ->
+          let content =
+            let target = Target.Internal (Resolved path) in
+            inline
+              (Link { target; content = [ inline (Text name) ]; tooltip = None })
+          in
+          Some (path, content)
+      | Error _ -> None
     in
-    let content =
-      match content with
-      | [] -> []
-      | _ :: _ ->
-          let content = List.map (to_sidebar convert) content in
-          [ block (Block.List (Block.Unordered, content)) ]
+    let fun_ entry =
+      match entry.Odoc_index.Entry.kind with
+      | Module _ | Class_type _ | Class _ | ModuleType _ ->
+          Some (map_entry entry)
+      | _ -> None
     in
-    name :: content
+    let entry = map_entry entry in
+    let children = Tree.filter_map_f fun_ children in
+    { Tree.node = entry; children }
 end
+
 type pages = { name : string; pages : Toc.t }
-type library = { name : string; units : (Url.Path.t * Inline.one) list }
+type library = { name : string; units : Toc.t list }
 
 type t = { pages : pages list; libraries : library list }
 
-let of_lang (v : Odoc_model.Sidebar.t) =
+let of_lang (v : Odoc_index.t) =
+  let { Odoc_index.pages; libs; extra = _ } = v in
   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
+      { name = p_name; pages = hierarchy }
     in
-    Odoc_utils.List.filter_map page_hierarchy v.pages
+    Odoc_utils.List.map page_hierarchy 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 libraries =
+    let lib_hierarchies { Odoc_index.l_name; l_hierarchies } =
+      let hierarchies = List.map Toc.of_skeleton l_hierarchies in
+      { units = hierarchies; name = l_name }
     in
-    let units =
-      List.map
-        (fun { Odoc_model.Sidebar.units; name } ->
-          let units = List.map item units in
-          { name; units })
-        v.libraries
-    in
-    units
+    Odoc_utils.List.map lib_hierarchies libs
   in
-  { pages; libraries = units }
+  { pages; libraries }
 
-let to_block (sidebar : t) url =
+let to_block (sidebar : t) path =
   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 =
     Odoc_utils.List.concat_map
       ~f:(fun (p : pages) ->
-        let pages = Toc.to_sidebar render_entry p.pages in
+        let pages = Toc.to_block ~prune:false path p.pages in
         let pages = [ block (Block.List (Block.Unordered, [ pages ])) ] in
         let pages = [ title @@ p.name ^ "'s Pages" ] @ pages in
         pages)
@@ -123,10 +168,12 @@ let to_block (sidebar : t) url =
     let units =
       List.map
         (fun { units; name } ->
-          [
-            title name;
-            block (List (Block.Unordered, [ List.map render_entry units ]));
-          ])
+          let units =
+            List.concat_map ~f:(Toc.to_block ~prune:true path) units
+          in
+          let units = [ block (Block.List (Block.Unordered, [ units ])) ] in
+          let units = [ title @@ name ^ "'s Units" ] @ units in
+          units)
         libraries
     in
     let units = block (Block.List (Block.Unordered, units)) in

src/document/sidebar.mli

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