Breadcrumbs: use sidebar index if possible

src/document/sidebar.ml

@@ -3,7 +3,8 @@ open Types
 module Id = Odoc_model.Paths.Identifier
 
 type entry = {
-  url : Url.t option;
+  url : Url.t;
+  valid_link : bool;
   content : Inline.t;
   toc_status : [ `Open ] option;
 }
@@ -19,44 +20,30 @@ module Toc : sig
 end = struct
   type t = entry Tree.t
 
-  let rec is_prefix (url1 : Url.Path.t) (url2 : Url.Path.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)
-
   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_entry { url; content; _ } =
+      let convert_entry { url; valid_link; content; _ } =
         let link =
-          match url with
-          | Some url ->
-              let target = Target.Internal (Target.Resolved url) in
-              let attr =
-                if url.page = current_url && Astring.String.equal url.anchor ""
-                then [ "current_unit" ]
-                else []
-              in
-              [
-                inline ~attr @@ Inline.Link { target; content; tooltip = None };
-              ]
-          | None -> content
+          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 [ "current_unit" ]
+              else []
+            in
+            [ inline ~attr @@ Inline.Link { target; content; tooltip = None } ]
+          else content
         in
         Types.block @@ Inline link
       in
       let rec convert n =
         let children =
           match n.Tree.node with
-          | { url = Some url; toc_status = None; _ }
-            when not (is_prefix url.Url.Anchor.page current_url) ->
+          | { 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
@@ -81,8 +68,10 @@ end = struct
     let map_entry entry =
       match entry.Entry.kind with
       | Dir ->
+          let url = Url.from_identifier ~stop_before:false (entry.id :> Id.t) in
           {
-            url = None;
+            url;
+            valid_link = false;
             content = [ inline @@ Text (Id.name entry.id) ];
             toc_status = None;
           }
@@ -93,7 +82,7 @@ end = struct
                 not has_expansion
             | _ -> false
           in
-          let path = Url.from_identifier ~stop_before (entry.id :> Id.t) 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
@@ -124,7 +113,7 @@ end = struct
                 let name = Odoc_model.Paths.Identifier.name entry.id in
                 [ inline (Text name) ]
           in
-          { url = Some path; content; toc_status }
+          { url; content; toc_status; valid_link = true }
     in
     let f x =
       match x.Entry.kind with

src/document/sidebar.mli

@@ -2,12 +2,13 @@ open Odoc_utils
 open Types
 
 type entry = {
-  url : Url.t option;
+  url : Url.t;
+  valid_link : bool;
   content : Inline.t;
   toc_status : [ `Open ] option;
 }
 
-type t = entry Tree.t list
+type t = entry Tree.forest
 
 val of_index : Odoc_index.t -> t
 

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/html/generator.ml

@@ -497,8 +497,7 @@ end
 
 module Breadcrumbs = struct
   open Types
-
-  let gen_breadcrumbs ~config ~url =
+  let gen_breadcrumbs_no_sidebar ~config ~url =
     let rec get_parent_paths x =
       match x with
       | [] -> []
@@ -509,13 +508,50 @@ module Breadcrumbs = struct
     in
     let to_breadcrumb path =
       let href =
-        Link.href ~config ~resolve:(Current url)
-          (Odoc_document.Url.from_path path)
+        Some
+          (Link.href ~config ~resolve:(Current url)
+             (Odoc_document.Url.from_path path))
       in
-      { href; name = path.name; kind = path.kind }
+      { href; name = [ Html.txt path.name ]; kind = path.kind }
     in
     get_parent_paths (List.rev (Odoc_document.Url.Path.to_list url))
     |> List.rev |> List.map to_breadcrumb
+
+  let gen_breadcrumbs ~config ~sidebar ~url:current_url =
+    match sidebar with
+    | None -> gen_breadcrumbs_no_sidebar ~config ~url:current_url
+    | Some sidebar ->
+        let rec extract acc (tree : Odoc_document.Sidebar.t) =
+          match
+            List.find_map
+              (function
+                | ({
+                     node =
+                       {
+                         url = { page; anchor = ""; _ } as url;
+                         valid_link;
+                         content;
+                         _;
+                       };
+                     children;
+                   } :
+                    Odoc_document.Sidebar.entry Odoc_utils.Tree.t)
+                  when Url.Path.is_prefix page current_url ->
+                    let href =
+                      if valid_link then
+                        Some
+                          (Link.href ~config ~resolve:(Current current_url) url)
+                      else None
+                    in
+                    let name = inline_nolink content in
+                    Some ({ href; name; kind = page.kind }, children)
+                | _ -> None)
+              tree
+          with
+          | None -> List.rev acc
+          | Some (bc, children) -> extract (bc :: acc) children
+        in
+        extract [] sidebar
 end
 
 module Page = struct
@@ -538,6 +574,7 @@ module Page = struct
     in
     let subpages = subpages ~config ~sidebar @@ Doctree.Subpages.compute p in
     let resolve = Link.Current url in
+    let breadcrumbs = Breadcrumbs.gen_breadcrumbs ~config ~sidebar ~url in
     let sidebar =
       match sidebar with
       | None -> None
@@ -548,7 +585,6 @@ 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 content = (items ~config ~resolve i :> any Html.elt list) in
     if Config.as_json config then
       let source_anchor =
@@ -570,6 +606,7 @@ module Page = struct
   and source_page ~config ~sidebar sp =
     let { Source_page.url; contents } = sp in
     let resolve = Link.Current sp.url in
+    let breadcrumbs = Breadcrumbs.gen_breadcrumbs ~config ~sidebar ~url in
     let sidebar =
       match sidebar with
       | None -> None
@@ -579,7 +616,6 @@ module Page = struct
     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 header =
       items ~config ~resolve (Doctree.PageTitle.render_src_title sp)
     in

src/html/html_fragment_json.ml

@@ -6,12 +6,17 @@ open Odoc_utils
 module Html = Tyxml.Html
 module Url = Odoc_document.Url
 
-let json_of_breadcrumbs (breadcrumbs : Types.breadcrumb list) : Json.json =
+let json_of_html config h =
+  let htmlpp = Html.pp_elt ~indent:(Config.indent config) () in
+  String.concat "" (List.map (Format.asprintf "%a" htmlpp) h)
+
+let json_of_breadcrumbs config (breadcrumbs : Types.breadcrumb list) : Json.json
+    =
   let breadcrumb (b : Types.breadcrumb) =
     `Object
       [
-        ("name", `String b.name);
-        ("href", `String b.href);
+        ("name", `String (json_of_html config b.name));
+        ("href", match b.href with None -> `Null | Some href -> `String href);
         ("kind", `String (Url.Path.string_of_kind b.kind));
       ]
   in
@@ -30,10 +35,6 @@ let json_of_toc (toc : Types.toc list) : Json.json =
   let toc_json_list = toc |> List.map section in
   `Array toc_json_list
 
-let json_of_html config h =
-  let htmlpp = Html.pp_elt ~indent:(Config.indent config) () in
-  String.concat "" (List.map (Format.asprintf "%a" htmlpp) h)
-
 let json_of_sidebar config sidebar =
   match sidebar with
   | None -> `Null
@@ -55,7 +56,7 @@ let make ~config ~preamble ~url ~breadcrumbs ~sidebar ~toc ~uses_katex
            [
              ("type", `String "documentation");
              ("uses_katex", `Bool uses_katex);
-             ("breadcrumbs", json_of_breadcrumbs breadcrumbs);
+             ("breadcrumbs", json_of_breadcrumbs config breadcrumbs);
              ("toc", json_of_toc toc);
              ("global_toc", global_toc);
              ("source_anchor", source_anchor);
@@ -77,7 +78,7 @@ let make_src ~config ~url ~breadcrumbs ~sidebar content =
          (`Object
            [
              ("type", `String "source");
-             ("breadcrumbs", json_of_breadcrumbs breadcrumbs);
+             ("breadcrumbs", json_of_breadcrumbs config breadcrumbs);
              ("global_toc", global_toc);
              ( "content",
                `String

src/html/html_page.ml

@@ -64,42 +64,52 @@ let sidebars ~global_toc ~local_toc =
 
 let html_of_breadcrumbs (breadcrumbs : Types.breadcrumb list) =
   let make_navigation ~up_url rest =
-    [
-      Html.nav
-        ~a:[ Html.a_class [ "odoc-nav" ] ]
-        ([ Html.a ~a:[ Html.a_href up_url ] [ Html.txt "Up" ]; Html.txt " – " ]
-        @ rest);
-    ]
+    let up =
+      match up_url with
+      | None -> []
+      | Some up_url ->
+          [ Html.a ~a:[ Html.a_href up_url ] [ Html.txt "Up" ]; Html.txt " – " ]
+    in
+    [ Html.nav ~a:[ Html.a_class [ "odoc-nav" ] ] (up @ rest) ]
   in
   match List.rev breadcrumbs with
-  | [] -> [] (* Can't happen - there's always the current page's breadcrumb. *)
-  | [ _ ] -> [] (* No parents *)
-  | [ { name = "index"; _ }; x ] ->
-      (* Special case leaf pages called 'index' with one parent. This is for files called
-          index.mld that would otherwise clash with their parent. In particular,
-          dune and odig both cause this situation right now. *)
-      let up_url = "../index.html" in
-      let parent_name = x.name in
-      make_navigation ~up_url [ Html.txt parent_name ]
-  | current :: up :: bs ->
+  | [] ->
+      [ Html.nav ~a:[ Html.a_class [ "odoc-nav" ] ] [ Html.txt "yooooooo" ] ]
+      (* Can't happen - there's always the current page's breadcrumb. *)
+  | current :: rest ->
       let space = Html.txt " " in
-      let sep = [ space; Html.entity "#x00BB"; space ] in
+      let sep :> Html_types.nav_content_fun Html.elt list =
+        [ space; Html.entity "#x00BB"; space ]
+      in
       let html =
         (* Create breadcrumbs *)
-        Odoc_utils.List.concat_map ?sep:(Some sep)
+        Odoc_utils.List.concat_map ~sep
           ~f:(fun (breadcrumb : Types.breadcrumb) ->
-            [
-              [
-                Html.a
-                  ~a:[ Html.a_href breadcrumb.href ]
-                  [ Html.txt breadcrumb.name ];
-              ];
-            ])
-          (up :: bs)
+            match breadcrumb.href with
+            | Some href ->
+                [
+                  [
+                    Html.a
+                      ~a:[ Html.a_href href ]
+                      (breadcrumb.name
+                        :> Html_types.flow5_without_interactive Html.elt list);
+                  ];
+                ]
+            | None ->
+                [
+                  (breadcrumb.name :> Html_types.nav_content_fun Html.elt list);
+                ])
+          rest
         |> List.flatten
       in
-      make_navigation ~up_url:up.href
-        (List.rev html @ sep @ [ Html.txt current.name ])
+      let current_name :> Html_types.nav_content_fun Html.elt list =
+        current.name
+      in
+      let up_url = List.find_map (fun (b : Types.breadcrumb) -> b.href) rest in
+      let rest = List.rev html @ sep @ current_name in
+      make_navigation ~up_url
+        (rest
+          :> [< Html_types.nav_content_fun > `A `PCDATA `Wbr ] Html.elt list)
 
 let file_uri ~config ~url (base : Types.uri) file =
   match base with

src/html/types.ml

@@ -12,7 +12,7 @@ type toc = {
 }
 
 type breadcrumb = {
-  href : string;
-  name : string;
+  href : string option;
+  name : Html_types.phrasing_without_interactive Tyxml.Html.elt list;
   kind : Odoc_document.Url.Path.kind;
 }