Specify breadcrumbs titles

src/document/breadcrumbs.ml

@@ -0,0 +1,40 @@
+open Odoc_model
+open Names
+module Id = Paths.Identifier
+
+type t = (string * Url.Path.t) list
+
+let empty = []
+
+let of_lang ~index id =
+  let module H = Id.Hashtbl.Page in
+  let mk_seg id title =
+    (title, Url.Path.from_identifier (id :> Url.Path.any))
+  in
+  let mk_page_seg id title =
+    let title =
+      match index with
+      | Some index -> (
+          try H.find index.Lang.Index.pages_short_title (id :> Id.Page.t)
+          with Not_found -> title)
+      | None -> title
+    in
+    mk_seg id title
+  in
+  let rec of_page acc id =
+    match id.Id.iv with
+    | `Page (parent, pname) ->
+        of_parent (mk_page_seg id (PageName.to_string pname) :: acc) parent
+  and of_parent acc = function Some p -> of_page acc p | None -> acc in
+  let of_odocid (id : Id.OdocId.t) =
+    match id with
+    | { Id.iv = #Id.ContainerPage.t_pv; _ } as id -> of_page [] id
+    | { iv = `LeafPage (parent, pname); _ } as id ->
+        of_parent [ mk_page_seg id (PageName.to_string pname) ] parent
+    | { iv = `Root (parent, mname); _ } as id ->
+        of_parent [ mk_seg id (ModuleName.to_string mname) ] parent
+    | { iv = `SourcePage (parent, name); _ } as id ->
+        of_page [ mk_seg id ("Source " ^ name) ] parent
+    | { iv = `Implementation _ | `AssetFile _; _ } -> []
+  in
+  of_odocid id

src/document/breadcrumbs.mli

@@ -0,0 +1,10 @@
+open Odoc_model
+module Id = Paths.Identifier
+
+type t = (string * Url.Path.t) list
+
+val empty : t
+
+val of_lang : index:'a Lang.Index.t option -> Id.OdocId.t -> t
+(** Compute the breadcrumbs for the current unit. If [index] is not [None],
+    it's used to retrieve the short titles of pages. *)

src/document/renderer.ml

@@ -23,7 +23,12 @@ type input =
 
 type 'a t = {
   name : string;
-  render : 'a -> Types.Block.t option -> Types.Document.t -> page list;
+  render :
+    'a ->
+    sidebar:Types.Block.t option ->
+    breadcrumbs:Breadcrumbs.t ->
+    Types.Document.t ->
+    page list;
   filepath : 'a -> Url.Path.t -> Fpath.t;
 }
 

src/html/generator.ml

@@ -13,6 +13,7 @@
  * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  *)
+open Odoc_utils
 module HLink = Link
 open Odoc_document.Types
 module Html = Tyxml.Html
@@ -498,24 +499,30 @@ end
 module Breadcrumbs = struct
   open Types
 
-  let gen_breadcrumbs ~config ~url =
-    let rec get_parent_paths x =
-      match x with
-      | [] -> []
-      | x :: xs -> (
-          match Odoc_document.Url.Path.of_list (List.rev (x :: xs)) with
-          | Some x -> x :: get_parent_paths xs
-          | None -> get_parent_paths xs)
+  let gen_breadcrumbs ~config ~current_url breadcrumbs =
+    let resolve = Link.Current current_url in
+    let mk url name =
+      let href = Link.href ~config ~resolve (Url.from_path url) in
+      { href; name; kind = url.kind }
     in
-    let to_breadcrumb path =
-      let href =
-        Link.href ~config ~resolve:(Current url)
-          (Odoc_document.Url.from_path path)
-      in
-      { href; name = path.name; kind = path.kind }
+    let is_local_breadcrumb =
+      match breadcrumbs with
+      | [] -> fun _ -> true
+      | _ :: _ ->
+          let _, last_page_seg = List.last breadcrumbs in
+          ( <> ) last_page_seg
+    in
+    let rec local_breadcrumbs acc url =
+      if is_local_breadcrumb url then parent (mk url url.name :: acc) url.parent
+      else acc
+    and parent acc = function
+      | Some p -> local_breadcrumbs acc p
+      | None -> acc
+    in
+    let page_breadcrumbs =
+      List.rev_map (fun (title, url) -> mk url title) breadcrumbs
     in
-    get_parent_paths (List.rev (Odoc_document.Url.Path.to_list url))
-    |> List.rev |> List.map to_breadcrumb
+    List.rev_append page_breadcrumbs (local_breadcrumbs [] current_url)
 end
 
 module Page = struct
@@ -526,17 +533,19 @@ module Page = struct
         | `Closed | `Open | `Default -> None
         | `Inline -> Some 0)
 
-  let rec include_ ~config ~sidebar { Subpage.content; _ } =
-    page ~config ~sidebar content
+  let rec include_ ~config ~sidebar ~breadcrumbs { Subpage.content; _ } =
+    page ~config ~sidebar ~breadcrumbs content
 
-  and subpages ~config ~sidebar subpages =
-    List.map (include_ ~config ~sidebar) subpages
+  and subpages ~config ~sidebar ~breadcrumbs subpages =
+    List.map (include_ ~config ~sidebar ~breadcrumbs) subpages
 
-  and page ~config ~sidebar p : Odoc_document.Renderer.page =
+  and page ~config ~sidebar ~breadcrumbs p : Odoc_document.Renderer.page =
     let { Page.preamble; items = i; url; source_anchor } =
       Doctree.Labels.disambiguate_page ~enter_subpages:false p
     in
-    let subpages = subpages ~config ~sidebar @@ Doctree.Subpages.compute p in
+    let subpages =
+      subpages ~config ~sidebar ~breadcrumbs @@ Doctree.Subpages.compute p
+    in
     let resolve = Link.Current url in
     let sidebar =
       match sidebar with
@@ -548,7 +557,9 @@ module Page = struct
     let i = Doctree.Shift.compute ~on_sub i in
     let uses_katex = Doctree.Math.has_math_elements p in
     let toc = Toc.gen_toc ~config ~resolve ~path:url i in
-    let breadcrumbs = Breadcrumbs.gen_breadcrumbs ~config ~url in
+    let breadcrumbs =
+      Breadcrumbs.gen_breadcrumbs ~config ~current_url:url breadcrumbs
+    in
     let content = (items ~config ~resolve i :> any Html.elt list) in
     if Config.as_json config then
       let source_anchor =
@@ -567,12 +578,14 @@ module Page = struct
       Html_page.make ~sidebar ~config ~header ~toc ~breadcrumbs ~url ~uses_katex
         content subpages
 
-  and source_page ~config sp =
+  and source_page ~config ~breadcrumbs sp =
     let { Source_page.url; contents } = sp in
     let resolve = Link.Current sp.url in
     let title = url.Url.Path.name
     and doc = Html_source.html_of_doc ~config ~resolve contents in
-    let breadcrumbs = Breadcrumbs.gen_breadcrumbs ~config ~url in
+    let breadcrumbs =
+      Breadcrumbs.gen_breadcrumbs ~config ~current_url:url breadcrumbs
+    in
     let header =
       items ~config ~resolve (Doctree.PageTitle.render_src_title sp)
     in
@@ -581,9 +594,9 @@ module Page = struct
     else Html_page.make_src ~breadcrumbs ~header ~config ~url title [ doc ]
 end
 
-let render ~config ~sidebar = function
-  | Document.Page page -> [ Page.page ~config ~sidebar page ]
-  | Source_page src -> [ Page.source_page ~config src ]
+let render ~config ~sidebar ~breadcrumbs = function
+  | Document.Page page -> [ Page.page ~config ~sidebar ~breadcrumbs page ]
+  | Source_page src -> [ Page.source_page ~config ~breadcrumbs src ]
 
 let filepath ~config url = Link.Path.as_filename ~config url
 

src/html/generator.mli

@@ -1,13 +1,16 @@
+open Odoc_document
+
 val render :
   config:Config.t ->
-  sidebar:Odoc_document.Types.Block.t option ->
-  Odoc_document.Types.Document.t ->
-  Odoc_document.Renderer.page list
+  sidebar:Types.Block.t option ->
+  breadcrumbs:Breadcrumbs.t ->
+  Types.Document.t ->
+  Renderer.page list
 
-val filepath : config:Config.t -> Odoc_document.Url.Path.t -> Fpath.t
+val filepath : config:Config.t -> Url.Path.t -> Fpath.t
 
 val doc :
   config:Config.t ->
   xref_base_uri:string ->
-  Odoc_document.Types.Block.t ->
+  Types.Block.t ->
   Html_types.flow5_without_sectioning_heading_header_footer Tyxml.Html.elt list

src/model/frontmatter.ml

@@ -1 +1,3 @@
 type t = (string * string) list
+
+let get = List.assoc_opt

src/model/lang.ml

@@ -551,10 +551,13 @@ module rec Sidebar : sig
 end =
   Sidebar
 
-module rec Index : sig
-  type 'a t = Sidebar.t * 'a Paths.Identifier.Hashtbl.Any.t
-end =
-  Index
+module Index = struct
+  type 'a t = {
+    sidebar : Sidebar.t;
+    entries : 'a Paths.Identifier.Hashtbl.Any.t;
+    pages_short_title : string Paths.Identifier.Hashtbl.Page.t;
+  }
+end
 
 module rec Asset : sig
   type t = { name : Identifier.AssetFile.t; root : Root.t }

src/model/odoc_model.ml

@@ -10,3 +10,4 @@ module Location_ = Location_
 module Compat = Compat
 module Semantics = Semantics
 module Reference = Reference
+module Frontmatter = Frontmatter

src/model/paths.ml

@@ -361,6 +361,8 @@ module Identifier = struct
   module Page = struct
     type t = Id.page
     type t_pv = Id.page_pv
+    let equal = equal
+    let hash = hash
   end
 
   module ContainerPage = struct
@@ -623,6 +625,7 @@ module Identifier = struct
 
   module Hashtbl = struct
     module Any = Hashtbl.Make (Any)
+    module Page = Hashtbl.Make (Page)
   end
 end
 

src/model/paths.mli

@@ -235,6 +235,7 @@ module Identifier : sig
 
   module Hashtbl : sig
     module Any : Hashtbl.S with type key = Any.t
+    module Page : Hashtbl.S with type key = Page.t
   end
 
   module Mk : sig

src/odoc/bin/main.ml

@@ -644,11 +644,13 @@ end = struct
     | None -> Ok detected_package
 
   let current_package_of_page ~current_package page_roots input =
-    match find_root_of_input page_roots input with
-    | Ok detected_package ->
-        validate_current_package ?detected_package page_roots current_package
-    | Error `Not_found ->
-        Error (`Msg "The output file must be part of a directory passed as -P")
+    let detected_package =
+      (* Driver generated pages might not belong to a doc hierarchy. *)
+      match find_root_of_input page_roots input with
+      | Ok p -> p
+      | Error `Not_found -> None
+    in
+    validate_current_package ?detected_package page_roots current_package
 
   let is_page input =
     input |> Fpath.filename |> Astring.String.is_prefix ~affix:"page-"

src/odoc/html_page.ml

@@ -16,8 +16,8 @@
 
 type args = { html_config : Odoc_html.Config.t }
 
-let render { html_config } sidebar page =
-  Odoc_html.Generator.render ~config:html_config ~sidebar page
+let render { html_config } ~sidebar ~breadcrumbs page =
+  Odoc_html.Generator.render ~config:html_config ~sidebar ~breadcrumbs page
 
 let filepath { html_config } url =
   Odoc_html.Generator.filepath ~config:html_config url