Sidebar and index overhaul (2)

src/document/sidebar.ml

@@ -2,113 +2,173 @@ open Odoc_utils
 open Types
 module Id = Odoc_model.Paths.Identifier
 
-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_page_hierarchy : Odoc_index.Page_hierarchy.t -> t
 
-  val to_sidebar :
-    ?fallback:string -> (Url.t * Inline.one -> Block.one) -> t -> Block.t
+  val of_skeleton : Odoc_index.Skeleton.t -> t
+
+  val to_block : prune:bool -> Url.Path.t -> t -> Block.t
 end = struct
-  type t = (Url.t * Inline.one) option Tree.t
+  type t = (Url.t option * Inline.one) Tree.t
 
-  let of_page_hierarchy (dir : Odoc_index.Page_hierarchy.t) =
+  let of_page_hierarchy (dir : Odoc_index.Page_hierarchy.t) : t =
     let f index =
       match index with
-      | None -> None
-      | Some (index_id, title) ->
-          let path =
-            Url.from_identifier ~stop_before:false (index_id :> Id.t)
-          in
+      | Odoc_index.Page_hierarchy.Missing_index None ->
+          (None, inline @@ Text "Root")
+      | Odoc_index.Page_hierarchy.Missing_index (Some id) ->
+          let path = Url.from_identifier ~stop_before:false (id :> Id.t) in
+          (Some path, inline @@ Text (Id.name id))
+      | Page (id, title) ->
+          let path = Url.from_identifier ~stop_before:false (id :> Id.t) in
           let content = Comment.link_content title in
-          Some (path, sidebar_toc_entry path content)
+          let target = Target.Internal (Target.Resolved path) in
+          let i = inline @@ Inline.Link { target; content; tooltip = None } in
+          (Some path, i)
     in
     Tree.map ~f dir
 
-  let rec to_sidebar ?(fallback = "root") convert
-      { Tree.node = name; children = content } =
-    let name =
-      match name with
-      | Some v -> convert v
-      | None -> block (Block.Inline [ inline (Text fallback) ])
+  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 : t) =
+    let block_tree_of_t (current_url : Url.Path.t) (tree : t) =
+      (* 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 option), b) =
+        let link =
+          match url with
+          | Some url ->
+              if url.page = current_url && Astring.String.equal url.anchor ""
+              then { b with Inline.attr = [ "current_unit" ] }
+              else b
+          | None -> b
+        in
+        Types.block @@ Inline [ link ]
+      in
+      let f name =
+        match name with
+        | Some url, _ when prune && not (is_prefix (parent url) current_url) ->
+            None
+        | v -> Some (convert v)
+      in
+      let root_entry = convert tree.Tree.node in
+      { Tree.node = root_entry; children = Forest.filter_map ~f tree.children }
+    in
+    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 of_skeleton ({ node = entry; children } : Odoc_index.Entry.t Tree.t) : 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 name = Odoc_model.Paths.Identifier.name entry.id in
+      let path = Url.from_identifier ~stop_before entry.id in
+      let content =
+        let target = Target.Internal (Resolved path) in
+        inline
+          (Link { target; content = [ inline (Text name) ]; tooltip = None })
+      in
+      (Some path, content)
     in
-    let content =
-      match content with
-      | [] -> []
-      | _ :: _ ->
-          let content = List.map (to_sidebar convert) content in
-          [ block (Block.List (Block.Unordered, content)) ]
+    let f 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 = Forest.filter_map ~f children in
+    { Tree.node = entry; children }
 end
+
 type pages = { name : string; pages : Toc.t }
-type library = { name : string; units : (Url.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_index.sidebar) =
+let of_lang (v : Odoc_index.t) =
+  let { Odoc_index.pages; libs; extra = _ } = v in
   let pages =
     let page_hierarchy { Odoc_index.p_name; p_hierarchy } =
       let hierarchy = Toc.of_page_hierarchy p_hierarchy in
-      Some { name = p_name; pages = hierarchy }
+      { 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
-      let path = Url.from_identifier ~stop_before:false (id :> Id.t) in
-      (path, sidebar_toc_entry path 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_index.units; name } ->
-          let units = List.map item units in
-          { name; units })
-        v.libs
-    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.from_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_index.sidebar -> 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