diff --git a/src/document/sidebar.ml b/src/document/sidebar.ml
index ae342aff69..c4bf2e420c 100644
--- a/src/document/sidebar.ml
+++ b/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
diff --git a/src/document/sidebar.mli b/src/document/sidebar.mli
index 6e5fdf72f2..e6f8837263 100644
--- a/src/document/sidebar.mli
+++ b/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
diff --git a/src/document/url.ml b/src/document/url.ml
index 57864ee175..b53bc32f37 100644
--- a/src/document/url.ml
+++ b/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
diff --git a/src/document/url.mli b/src/document/url.mli
index b7361e9cc4..191f11ef1c 100644
--- a/src/document/url.mli
+++ b/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
diff --git a/src/html/generator.ml b/src/html/generator.ml
index d79ed41c42..12a3f1a417 100644
--- a/src/html/generator.ml
+++ b/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
@@ -543,6 +579,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
@@ -553,7 +590,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
let title = inline ~config ~resolve (title_of_page p) in
@@ -577,6 +613,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
@@ -586,7 +623,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
diff --git a/src/html/html_fragment_json.ml b/src/html/html_fragment_json.ml
index f33c85af53..c03a3f1586 100644
--- a/src/html/html_fragment_json.ml
+++ b/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
@@ -57,7 +58,7 @@ let make ~config ~title ~preamble ~url ~breadcrumbs ~sidebar ~toc ~uses_katex
("type", `String "documentation");
("title", `String title);
("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);
@@ -79,7 +80,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
diff --git a/src/html/html_page.ml b/src/html/html_page.ml
index 0c6adedb4f..a4e971fb2f 100644
--- a/src/html/html_page.ml
+++ b/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
diff --git a/src/html/types.ml b/src/html/types.ml
index 31e7801c3c..82e6672d1f 100644
--- a/src/html/types.ml
+++ b/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;
}
diff --git a/src/odoc/sidebar.ml b/src/odoc/sidebar.ml
index 75c4f97aca..0e9a4c7c58 100644
--- a/src/odoc/sidebar.ml
+++ b/src/odoc/sidebar.ml
@@ -1,16 +1,17 @@
open Or_error
open Odoc_utils
-let toc_to_json ({ url; content = inline; _ } : Odoc_document.Sidebar.entry) :
+let toc_to_json
+ ({ url; valid_link; content = inline; _ } : Odoc_document.Sidebar.entry) :
Json.json =
let config =
Odoc_html.Config.v ~semantic_uris:true ~indent:true ~flat:false
~open_details:false ~as_json:true ~remap:[] ()
in
let url, kind =
- match url with
- | None -> (`Null, `Null)
- | Some url ->
+ match valid_link with
+ | false -> (`Null, `Null)
+ | true ->
let href =
Odoc_html.Link.href ~config ~resolve:(Odoc_html.Link.Base "") url
in
diff --git a/test/parent_id/missing_indexes.t/run.t b/test/parent_id/missing_indexes.t/run.t
index 8bab67887d..7d47640fa1 100644
--- a/test/parent_id/missing_indexes.t/run.t
+++ b/test/parent_id/missing_indexes.t/run.t
@@ -25,6 +25,7 @@ Root is used for the missing index in the unnamed root directory. TODO
+
diff --git a/test/roots_and_hierarchy/sidebar.t/run.t b/test/roots_and_hierarchy/sidebar.t/run.t
index 4f63288c36..4c06828dd1 100644
--- a/test/roots_and_hierarchy/sidebar.t/run.t
+++ b/test/roots_and_hierarchy/sidebar.t/run.t
@@ -22,6 +22,7 @@
$ odoc html-generate --indent --sidebar sidebar.odoc-sidebar -o html _odoc/pkg/dir1/page-index.odocl
$ odoc html-generate --indent --sidebar sidebar.odoc-sidebar -o html _odoc/pkg/page-index.odocl
$ odoc html-generate --indent --sidebar sidebar.odoc-sidebar -o html _odoc/pkg/libname/unit.odocl
+ $ odoc html-generate-source --indent --impl _odoc/pkg/libname/impl-unit.odocl --sidebar sidebar.odoc-sidebar -o html unit.ml
A json version of a sidebar can be obtained using the sidebar-generate command: