Sidebar and index overhaul

CHANGES.md

@@ -17,8 +17,8 @@
   Absolute (`{!/foo}`), relative (`{!./foo}`) and package-local (`{!//foo}`)
   are added.
 - Add a marshalled search index consumable by sherlodoc (@EmileTrotignon, @panglesd, #1084)
-- Add a `--index` argument to pass indexes to the document generation, currently
-  used for sidebar (@panglesd, #1145)
+- Add a `--index` argument to pass indexes to the document generation. Generate
+  a full sidebar for pages and values (@panglesd, #1145, #1220)
 - Allow referencing of polymorphic constructors in polymorphic variant type
   aliases (@panglesd, #1115)
 - Added a `--occurrences` argument to the `compile-index` command to output the

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

@@ -2,134 +2,199 @@ open Odoc_utils
 open Types
 
 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 target =
+    match
+      (id :> Odoc_model.Paths.Identifier.t)
+      |> Url.from_identifier ~stop_before:false
+    with
+    | Ok href -> Target.Resolved href
+    | Error _ -> Target.Unresolved
+    (* This error case should never happen since [stop_before] is false *)
+  in
+  let target = Target.Internal target 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 =
+              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 index_id content)
+      in
+      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 && Astring.String.equal url.anchor "" then
+            { b with Inline.attr = [ "current_unit" ] }
+          else b
+        in
+        Types.block @@ Inline [ link ]
       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
+      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 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 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 title t = block (Inline [ inline (Inline.Styled (`Bold, t)) ]) in
   let pages =
-    Odoc_utils.List.concat_map
-      ~f:(fun (p : pages) ->
-        let pages = Toc.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
+    let pages =
+      Odoc_utils.List.concat_map
+        ~f:(fun (p : pages) ->
+          let () = ignore p.name in
+          let pages = Toc.to_block ~prune:false path p.pages in
+          [
+            block ~attr:[ "odoc-pages" ]
+              (Block.List (Block.Unordered, [ pages ]));
+          ])
+        pages
+    in
+    [ title @@ [ inline (Inline.Text "Documentation") ] ] @ pages
   in
   let units =
     let units =
       List.map
         (fun { units; name } ->
+          let units =
+            List.concat_map ~f:(Toc.to_block ~prune:true path) units
+          in
+          let units = [ block (Block.List (Block.Unordered, [ units ])) ] in
           [
-            title name;
-            block (List (Block.Unordered, [ List.map render_entry units ]));
-          ])
+            title
+            @@ [
+                 inline (Inline.Text "Library ");
+                 inline (Inline.Source [ Elt [ inline @@ Text name ] ]);
+               ];
+          ]
+          @ units)
         libraries
     in
-    let units = block (Block.List (Block.Unordered, units)) in
-    [ title "Libraries"; units ]
+    let units =
+      block ~attr:[ "odoc-modules" ] (Block.List (Block.Unordered, units))
+    in
+    [ units ]
   in
-  pages @ units
+  units @ pages

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