Uniform treatment of sidebar

CHANGES.md

@@ -17,8 +17,10 @@
   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 `odoc sidebar-generate` command to generate a sidebar file (@panglesd,
+  #1250)
+- Add a `--sidebar` argument to pass sidebars to the document generation
+  (@panglesd, #1145, #1250)
 - Allow referencing of polymorphic constructors in polymorphic variant type
   aliases (@panglesd, #1115)
 - Added a `--occurrences` argument to the `compile-index` command to output the

doc/odoc.mld

@@ -1,8 +1,6 @@
-{0 [odoc]}
+@children_order dune odoc_for_authors cheatsheet features ocamldoc_differences interface parent_child_spec driver
 
-{@meta[
-  children: dune odoc_for_authors cheatsheet features ocamldoc_differences interface parent_child_spec driver
-]}
+{0 The [odoc] documentation generator}
 
 {b For a quick look at the [odoc] syntax, see the {{!cheatsheet}cheatsheet}!}
 

src/document/sidebar.ml

@@ -2,70 +2,54 @@ open Odoc_utils
 open Types
 module Id = Odoc_model.Paths.Identifier
 
-module Toc : sig
-  type t
+type entry = {
+  url : Url.t;
+  valid_link : bool;
+  content : Inline.t;
+  toc_status : [ `Open ] option;
+}
+
+open Odoc_index
 
-  val of_page_hierarchy : Odoc_index.Page_hierarchy.t -> t
+module Toc : sig
+  type t = entry Tree.t
 
-  val of_skeleton : Odoc_index.Skeleton.t -> t
+  val of_page_hierarchy : Skeleton.t -> t
 
   val to_block : prune:bool -> Url.Path.t -> t -> Block.t
 end = struct
-  type t = (Url.t option * Inline.one) Tree.t
-
-  let of_page_hierarchy (dir : Odoc_index.Page_hierarchy.t) : t =
-    let f index =
-      match index with
-      | 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
-          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 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
+  type t = entry Tree.t
 
-  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 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 convert_entry { url; valid_link; content; _ } =
         let link =
-          match url with
-          | Some url ->
+          if valid_link then
+            let target = Target.Internal (Target.Resolved url) in
+            let attr =
               if url.page = current_url && Astring.String.equal url.anchor ""
-              then { b with Inline.attr = [ "current_unit" ] }
-              else b
-          | None -> b
+              then [ "current_unit" ]
+              else []
+            in
+            [ inline ~attr @@ Inline.Link { target; content; tooltip = None } ]
+          else content
         in
-        Types.block @@ Inline [ link ]
+        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)
+      let rec convert n =
+        let children =
+          match n.Tree.node with
+          | { url; valid_link = true; toc_status = None; _ }
+            when not (Url.Path.is_prefix url.Url.Anchor.page current_url) ->
+              []
+          | _ -> List.map convert n.children
+        in
+        { Tree.node = convert_entry n.node; children }
       in
-      let root_entry = convert tree.Tree.node in
-      { Tree.node = root_entry; children = Forest.filter_map ~f tree.children }
+      convert tree
     in
     let rec block_of_block_tree { Tree.node = name; children = content } =
       let content =
@@ -80,95 +64,73 @@ end = struct
     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 of_page_hierarchy ({ node = entry; children } : 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)
+      match entry.Entry.kind with
+      | Dir ->
+          let url = Url.from_identifier ~stop_before:false (entry.id :> Id.t) in
+          {
+            url;
+            valid_link = false;
+            content = [ inline @@ Text (Id.name entry.id) ];
+            toc_status = None;
+          }
+      | _ ->
+          let stop_before =
+            match entry.Entry.kind with
+            | ModuleType { has_expansion } | Module { has_expansion } ->
+                not has_expansion
+            | _ -> false
+          in
+          let url = Url.from_identifier ~stop_before (entry.id :> Id.t) in
+          let toc_status =
+            match entry.kind with
+            | Page { toc_status; _ } -> toc_status
+            | _ -> None
+          in
+          let content =
+            match entry.kind with
+            | Page { short_title = Some st; _ } -> Comment.link_content st
+            | Page { short_title = None; _ } ->
+                let title =
+                  let open Odoc_model in
+                  match Comment.find_zero_heading entry.doc with
+                  | Some t -> t
+                  | None ->
+                      let name =
+                        match entry.id.iv with
+                        | `LeafPage (Some parent, name)
+                          when Astring.String.equal
+                                 (Names.PageName.to_string name)
+                                 "index" ->
+                            Id.name parent
+                        | _ -> Id.name entry.id
+                      in
+                      Location_.[ at (span []) (`Word name) ]
+                in
+                Comment.link_content title
+            | _ ->
+                let name = Odoc_model.Paths.Identifier.name entry.id in
+                [ inline (Text name) ]
+          in
+          { url; content; toc_status; valid_link = true }
     in
-    let f entry =
-      match entry.Odoc_index.Entry.kind with
-      | Module _ | Class_type _ | Class _ | ModuleType _ ->
-          Some (map_entry entry)
+    let f x =
+      match x.Entry.kind with
+      | Dir | Page _ | Module _ | Class_type _ | Class _ | ModuleType _ | Impl
+        ->
+          Some (map_entry x)
       | _ -> None
     in
     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 : Toc.t list }
+type t = Toc.t list
 
-type t = { pages : pages list; libraries : library list }
-
-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
-      { name = p_name; pages = hierarchy }
-    in
-    Odoc_utils.List.map page_hierarchy pages
-  in
-  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
-    Odoc_utils.List.map lib_hierarchies libs
-  in
-  { pages; libraries }
+let of_index (v : Odoc_index.t) = List.map Toc.of_page_hierarchy v
 
 let to_block (sidebar : t) path =
-  let { pages; libraries } = sidebar in
-  let title t = block (Inline [ inline (Inline.Styled (`Bold, t)) ]) in
-  let 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
-            @@ [
-                 inline (Inline.Text "Library ");
-                 inline (Inline.Source [ Elt [ inline @@ Text name ] ]);
-               ];
-          ]
-          @ units)
-        libraries
-    in
-    let units =
-      block ~attr:[ "odoc-modules" ] (Block.List (Block.Unordered, units))
-    in
-    [ units ]
-  in
-  units @ pages
+  let sb = List.map (Toc.to_block ~prune:true path) sidebar in
+  [ block (Block.List (Block.Unordered, sb)) ]

src/document/sidebar.mli

@@ -1,6 +1,16 @@
-type t
+open Odoc_utils
+open Types
 
-val of_lang : Odoc_index.t -> t
+type entry = {
+  url : Url.t;
+  valid_link : bool;
+  content : Inline.t;
+  toc_status : [ `Open ] option;
+}
+
+type t = entry Tree.forest
+
+val of_index : 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

src/document/url.ml

@@ -206,6 +206,17 @@ module Path = struct
       | xs -> (List.rev dirs, xs)
     in
     inner [] l
+
+  let rec is_prefix (url1 : t) (url2 : t) =
+    match url1 with
+    | { kind = `LeafPage; parent = None; name = "index" } -> true
+    | { kind = `LeafPage; parent = Some p; name = "index" } -> is_prefix p url2
+    | _ -> (
+        if url1 = url2 then true
+        else
+          match url2 with
+          | { parent = Some parent; _ } -> is_prefix url1 parent
+          | { parent = None; _ } -> false)
 end
 
 module Anchor = struct

src/document/url.mli

@@ -50,6 +50,11 @@ module Path : sig
       of directory-type elements and filename-type elements. If the
       [is_dir] function can return [`Always], the caller must be prepared
       to handle the case where the filename part is empty. *)
+
+  val is_prefix : t -> t -> bool
+  (** [is_prefix p1 p2] tells whether [p1] is a prefix of [p2]. It considers
+      [index] pages as their parent: [dir/page-index] is a prefix of
+      [dir/foo/module-bar]. *)
 end
 
 module Anchor : sig

src/driver/cmd_outputs.ml

@@ -5,18 +5,17 @@ type log_dest =
   | `Count_occurrences
   | `Generate
   | `Index
-  | `Source_tree
   | `Sherlodoc
   | `Classify ]
 
-let outputs : (log_dest * [ `Out | `Err ] * string * string) list ref = ref []
+type log_line = { log_dest : log_dest; prefix : string; run : Run.t }
 
-let maybe_log log_dest r =
+let outputs : log_line list ref = ref []
+
+let maybe_log log_dest run =
   match log_dest with
-  | Some (dest, prefix) ->
-      let add ty s = outputs := !outputs @ [ (dest, ty, prefix, s) ] in
-      add `Out r.Run.output;
-      add `Err r.Run.errors
+  | Some (log_dest, prefix) ->
+      outputs := !outputs @ [ { log_dest; run; prefix } ]
   | None -> ()
 
 let submit log_dest desc cmd output_file =

src/driver/common_args.ml

@@ -52,6 +52,10 @@ let generate_grep =
   let doc = "Show html-generate commands containing the string" in
   Arg.(value & opt (some string) None & info [ "html-grep" ] ~doc)
 
+let index_grep =
+  let doc = "Show compile-index commands containing the string" in
+  Arg.(value & opt (some string) None & info [ "index-grep" ] ~doc)
+
 type t = {
   verbose : bool;
   odoc_dir : Fpath.t;
@@ -65,6 +69,7 @@ type t = {
   compile_grep : string option;
   link_grep : string option;
   generate_grep : string option;
+  index_grep : string option;
 }
 
 let term =
@@ -82,6 +87,7 @@ let term =
   and+ odoc_bin = odoc_bin
   and+ compile_grep = compile_grep
   and+ link_grep = link_grep
+  and+ index_grep = index_grep
   and+ generate_grep = generate_grep in
   {
     verbose;
@@ -96,4 +102,5 @@ let term =
     compile_grep;
     link_grep;
     generate_grep;
+    index_grep;
   }