From 4ac36f1d8d2dc846d272ae29e5d5391b332f68ea Mon Sep 17 00:00:00 2001 From: Guillaume Petiot Date: Thu, 31 Oct 2024 17:08:52 +0000 Subject: [PATCH 01/11] Represent sidebar TOC as a Tree Co-authored-by: Paul-Elliot --- src/document/sidebar.ml | 19 +++++++++++-------- src/model/sidebar.ml | 20 ++++++++++++-------- src/model/sidebar.mli | 3 +-- 3 files changed, 24 insertions(+), 18 deletions(-) diff --git a/src/document/sidebar.ml b/src/document/sidebar.ml index a0bf8050aa..5c3a3edadf 100644 --- a/src/document/sidebar.ml +++ b/src/document/sidebar.ml @@ -20,26 +20,29 @@ end = struct open Odoc_model.Paths.Identifier let of_lang (dir : PageToc.t) = - let rec of_lang ~parent_id ((content, index) : PageToc.t) = + let rec of_lang ~parent_id (toc : PageToc.t) = let title, parent_id = - match index with + match toc.node with | Some (index_id, title) -> (Some title, Some (index_id :> Page.t)) | None -> (None, (parent_id :> Page.t option)) in let entries = List.filter_map - (fun id -> - match id with - | id, PageToc.Entry title -> + (fun tree -> + match tree.Tree.node with + | Some (id, title) -> (* TODO warn on non empty children order if not index page somewhere *) let payload = let path = Url.Path.from_identifier id in let content = Comment.link_content title in Some (path, sidebar_toc_entry id content) in - Some { Tree.node = payload; children = [] } - | id, PageToc.Dir dir -> Some (of_lang ~parent_id:(Some id) dir)) - content + let children = + List.map (of_lang ~parent_id:(Some id)) tree.children + in + Some { Tree.node = payload; children } + | None -> None) + toc.children in let payload = match (title, parent_id) with diff --git a/src/model/sidebar.ml b/src/model/sidebar.ml index 4780cb9ba1..41dcffdf58 100644 --- a/src/model/sidebar.ml +++ b/src/model/sidebar.ml @@ -77,10 +77,9 @@ module PageToc = struct | None -> None type index = Id.Page.t * title - type t = (Id.Page.t * content) list * index option - and content = Entry of title | Dir of t + type t = index option Odoc_utils.Tree.t - let rec t_of_in_progress (dir : in_progress) = + let rec t_of_in_progress (dir : in_progress) : t = let children_order, index = match dir_index dir with | Some ({ children_order; _ }, index_id, index_title) -> @@ -103,12 +102,15 @@ module PageToc = struct let contents = let leafs = leafs dir - |> List.map (fun (id, payload) -> ((id :> Id.Page.t), Entry payload)) + |> List.map (fun (id, payload) -> + let id :> Id.Page.t = id in + (id, Tree.leaf (Some (id, payload)))) in let dirs = dirs dir |> List.map (fun (id, payload) -> - ((id :> Id.Page.t), Dir (t_of_in_progress payload))) + let id :> Id.Page.t = id in + (id, t_of_in_progress payload)) in leafs @ dirs in @@ -179,11 +181,13 @@ module PageToc = struct String.compare (Paths.Identifier.name x) (Paths.Identifier.name y)) unordered in - let contents = ordered @ unordered in - (contents, index) + let contents = ordered @ unordered |> List.map snd in + { Tree.node = index; children = contents } let rec remove_common_root (v : t) = - match v with [ (_, Dir v) ], None -> remove_common_root v | _ -> v + match v with + | { Tree.children = [ v ]; node = None } -> remove_common_root v + | _ -> v let of_list l = let dir = empty_t None in diff --git a/src/model/sidebar.mli b/src/model/sidebar.mli index 838061c96c..d6d54befaa 100644 --- a/src/model/sidebar.mli +++ b/src/model/sidebar.mli @@ -4,8 +4,7 @@ module PageToc : sig type title = Comment.link_content type index = Page.t * title - type t = (Page.t * content) list * index option - and content = Entry of title | Dir of t + type t = index option Odoc_utils.Tree.t val of_list : (LeafPage.t * title * Frontmatter.children_order option) list -> t From c7f7125b89a3b414f7ff47a4a90dd9ef5263efd0 Mon Sep 17 00:00:00 2001 From: Guillaume Petiot Date: Mon, 4 Nov 2024 11:02:38 +0000 Subject: [PATCH 02/11] Simplify Toc.of_lang Co-authored-by: Paul-Elliot --- src/document/sidebar.ml | 20 ++++++-------------- 1 file changed, 6 insertions(+), 14 deletions(-) diff --git a/src/document/sidebar.ml b/src/document/sidebar.ml index 5c3a3edadf..a790a7a925 100644 --- a/src/document/sidebar.ml +++ b/src/document/sidebar.ml @@ -17,15 +17,9 @@ end = struct type t = (Url.Path.t * Inline.one) option Tree.t open Odoc_model.Sidebar - open Odoc_model.Paths.Identifier let of_lang (dir : PageToc.t) = - let rec of_lang ~parent_id (toc : PageToc.t) = - let title, parent_id = - match toc.node with - | Some (index_id, title) -> (Some title, Some (index_id :> Page.t)) - | None -> (None, (parent_id :> Page.t option)) - in + let rec of_lang (toc : PageToc.t) = let entries = List.filter_map (fun tree -> @@ -37,24 +31,22 @@ end = struct let content = Comment.link_content title in Some (path, sidebar_toc_entry id content) in - let children = - List.map (of_lang ~parent_id:(Some id)) tree.children - in + let children = List.map of_lang tree.children in Some { Tree.node = payload; children } | None -> None) toc.children in let payload = - match (title, parent_id) with - | None, _ | _, None -> None - | Some title, Some parent_id -> + match toc.node with + | None -> None + | Some (parent_id, title) -> let path = Url.Path.from_identifier parent_id in let content = Comment.link_content title in Some (path, sidebar_toc_entry parent_id content) in { Tree.node = payload; children = entries } in - of_lang ~parent_id:None dir + of_lang dir let rec to_sidebar ?(fallback = "root") convert { Tree.node = name; children = content } = From 66194847159ccb8d74bc45aec1b0d5bd7692fd43 Mon Sep 17 00:00:00 2001 From: Guillaume Petiot Date: Mon, 4 Nov 2024 11:06:46 +0000 Subject: [PATCH 03/11] Simplify Toc.of_lang Co-authored-by: Paul-Elliot --- src/document/sidebar.ml | 34 ++++++---------------------------- 1 file changed, 6 insertions(+), 28 deletions(-) diff --git a/src/document/sidebar.ml b/src/document/sidebar.ml index a790a7a925..5894aa6106 100644 --- a/src/document/sidebar.ml +++ b/src/document/sidebar.ml @@ -19,34 +19,12 @@ end = struct open Odoc_model.Sidebar let of_lang (dir : PageToc.t) = - let rec of_lang (toc : PageToc.t) = - let entries = - List.filter_map - (fun tree -> - match tree.Tree.node with - | Some (id, title) -> - (* TODO warn on non empty children order if not index page somewhere *) - let payload = - let path = Url.Path.from_identifier id in - let content = Comment.link_content title in - Some (path, sidebar_toc_entry id content) - in - let children = List.map of_lang tree.children in - Some { Tree.node = payload; children } - | None -> None) - toc.children - in - let payload = - match toc.node with - | None -> None - | Some (parent_id, title) -> - let path = Url.Path.from_identifier parent_id in - let content = Comment.link_content title in - Some (path, sidebar_toc_entry parent_id content) - in - { Tree.node = payload; children = entries } - in - of_lang dir + Tree.map dir ~f:(function + | None -> None + | Some (parent_id, title) -> + let path = Url.Path.from_identifier parent_id in + let content = Comment.link_content title in + Some (path, sidebar_toc_entry parent_id content)) let rec to_sidebar ?(fallback = "root") convert { Tree.node = name; children = content } = From 70ae5b3ba294994985326518e7144a577f2afb0c Mon Sep 17 00:00:00 2001 From: Guillaume Petiot Date: Mon, 4 Nov 2024 14:34:30 +0000 Subject: [PATCH 04/11] Move relevant files to index/ Co-authored-by: Paul-Elliot --- src/document/dune | 8 +++++++- src/document/sidebar.ml | 10 +++++----- src/document/sidebar.mli | 2 +- src/index/dune | 4 ++++ src/{search => index}/entry.ml | 2 +- src/{search => index}/entry.mli | 2 +- src/{model => index}/fold.ml | 1 + src/{model => index}/fold.mli | 1 + src/index/odoc_index.ml | 8 ++++++++ src/{model => index}/sidebar.ml | 1 + src/{model => index}/sidebar.mli | 1 + src/model/lang.ml | 5 ----- src/model/odoc_model.ml | 2 -- src/odoc/indexing.ml | 14 +++++++------- src/odoc/indexing.mli | 2 +- src/odoc/odoc_file.mli | 6 ++---- src/search/html.ml | 1 + src/search/html.mli | 1 + src/search/json_index/json_display.mli | 2 +- src/search/json_index/json_search.ml | 5 +++-- src/search/json_index/json_search.mli | 2 +- 21 files changed, 48 insertions(+), 32 deletions(-) create mode 100644 src/index/dune rename src/{search => index}/entry.ml (99%) rename src/{search => index}/entry.mli (96%) rename src/{model => index}/fold.ml (99%) rename src/{model => index}/fold.mli (99%) create mode 100644 src/index/odoc_index.ml rename src/{model => index}/sidebar.ml (99%) rename src/{model => index}/sidebar.mli (97%) diff --git a/src/document/dune b/src/document/dune index b94949c4e2..33fcac7e05 100644 --- a/src/document/dune +++ b/src/document/dune @@ -14,4 +14,10 @@ (backend bisect_ppx)) (instrumentation (backend landmarks --auto)) - (libraries odoc_model fpath astring syntax_highlighter odoc_utils)) + (libraries + odoc_model + fpath + astring + syntax_highlighter + odoc_utils + odoc_index)) diff --git a/src/document/sidebar.ml b/src/document/sidebar.ml index 5894aa6106..cf28e74956 100644 --- a/src/document/sidebar.ml +++ b/src/document/sidebar.ml @@ -9,14 +9,14 @@ let sidebar_toc_entry id content = module Toc : sig type t - val of_lang : Odoc_model.Sidebar.PageToc.t -> t + val of_lang : Odoc_index.Sidebar.PageToc.t -> t val to_sidebar : ?fallback:string -> (Url.Path.t * Inline.one -> Block.one) -> t -> Block.t end = struct type t = (Url.Path.t * Inline.one) option Tree.t - open Odoc_model.Sidebar + open Odoc_index.Sidebar let of_lang (dir : PageToc.t) = Tree.map dir ~f:(function @@ -47,9 +47,9 @@ type library = { name : string; units : (Url.Path.t * Inline.one) list } type t = { pages : pages list; libraries : library list } -let of_lang (v : Odoc_model.Sidebar.t) = +let of_lang (v : Odoc_index.Sidebar.t) = let pages = - let page_hierarchy { Odoc_model.Sidebar.hierarchy_name; pages } = + let page_hierarchy { Odoc_index.Sidebar.hierarchy_name; pages } = let hierarchy = Toc.of_lang pages in Some { name = hierarchy_name; pages = hierarchy } in @@ -62,7 +62,7 @@ let of_lang (v : Odoc_model.Sidebar.t) = in let units = List.map - (fun { Odoc_model.Sidebar.units; name } -> + (fun { Odoc_index.Sidebar.units; name } -> let units = List.map item units in { name; units }) v.libraries diff --git a/src/document/sidebar.mli b/src/document/sidebar.mli index 6c926ad1fc..eff30b6c80 100644 --- a/src/document/sidebar.mli +++ b/src/document/sidebar.mli @@ -1,6 +1,6 @@ type t -val of_lang : Odoc_model.Sidebar.t -> t +val of_lang : Odoc_index.Sidebar.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 diff --git a/src/index/dune b/src/index/dune new file mode 100644 index 0000000000..c5de6df7a4 --- /dev/null +++ b/src/index/dune @@ -0,0 +1,4 @@ +(library + (name odoc_index) + (public_name odoc.index) + (libraries odoc_model odoc_html_frontend tyxml odoc_utils)) diff --git a/src/search/entry.ml b/src/index/entry.ml similarity index 99% rename from src/search/entry.ml rename to src/index/entry.ml index 055f8ec813..86dea01015 100644 --- a/src/search/entry.ml +++ b/src/index/entry.ml @@ -139,7 +139,7 @@ and entries_of_doc id d = | `Table _ -> [] | `Media _ -> [] -let entries_of_item (x : Odoc_model.Fold.item) = +let entries_of_item (x : Fold.item) = match x with | CompilationUnit u -> ( match u.content with diff --git a/src/search/entry.mli b/src/index/entry.mli similarity index 96% rename from src/search/entry.mli rename to src/index/entry.mli index b44a0b98af..4415a0d49e 100644 --- a/src/search/entry.mli +++ b/src/index/entry.mli @@ -61,4 +61,4 @@ type t = { kind : kind; } -val entries_of_item : Odoc_model.Fold.item -> t list +val entries_of_item : Fold.item -> t list diff --git a/src/model/fold.ml b/src/index/fold.ml similarity index 99% rename from src/model/fold.ml rename to src/index/fold.ml index 2ee46ea6b9..9fa77dc003 100644 --- a/src/model/fold.ml +++ b/src/index/fold.ml @@ -1,3 +1,4 @@ +open Odoc_model open Lang type item = diff --git a/src/model/fold.mli b/src/index/fold.mli similarity index 99% rename from src/model/fold.mli rename to src/index/fold.mli index e5fc4a1473..2df70e3a29 100644 --- a/src/model/fold.mli +++ b/src/index/fold.mli @@ -3,6 +3,7 @@ in reality it is quite specialized to fold over searchable items, and not every kind of odoc value you could fold over.*) +open Odoc_model open Lang (** The type of items you can fold over *) diff --git a/src/index/odoc_index.ml b/src/index/odoc_index.ml new file mode 100644 index 0000000000..821332f993 --- /dev/null +++ b/src/index/odoc_index.ml @@ -0,0 +1,8 @@ +module Entry = Entry +module Fold = Fold +module Sidebar = Sidebar + +type 'a t = { + sidebar : Sidebar.t; + index : 'a Odoc_model.Paths.Identifier.Hashtbl.Any.t; +} diff --git a/src/model/sidebar.ml b/src/index/sidebar.ml similarity index 99% rename from src/model/sidebar.ml rename to src/index/sidebar.ml index 41dcffdf58..c277be5573 100644 --- a/src/model/sidebar.ml +++ b/src/index/sidebar.ml @@ -1,4 +1,5 @@ open Odoc_utils +open Odoc_model module Id = Paths.Identifier module CPH = Id.Hashtbl.ContainerPage diff --git a/src/model/sidebar.mli b/src/index/sidebar.mli similarity index 97% rename from src/model/sidebar.mli rename to src/index/sidebar.mli index d6d54befaa..80abe7d264 100644 --- a/src/model/sidebar.mli +++ b/src/index/sidebar.mli @@ -1,3 +1,4 @@ +open Odoc_model open Paths.Identifier module PageToc : sig diff --git a/src/model/lang.ml b/src/model/lang.ml index e1184c3b40..8dc917a407 100644 --- a/src/model/lang.ml +++ b/src/model/lang.ml @@ -539,11 +539,6 @@ module rec Page : sig end = Page -module rec Index : sig - type 'a t = { sidebar : Sidebar.t; index : 'a Paths.Identifier.Hashtbl.Any.t } -end = - Index - module rec Asset : sig type t = { name : Identifier.AssetFile.t; root : Root.t } end = diff --git a/src/model/odoc_model.ml b/src/model/odoc_model.ml index cfbc5969b0..0bf1becc3a 100644 --- a/src/model/odoc_model.ml +++ b/src/model/odoc_model.ml @@ -1,6 +1,4 @@ module Lang = Lang -module Sidebar = Sidebar -module Fold = Fold module Comment = Comment module Paths = Paths module Names = Names diff --git a/src/odoc/indexing.ml b/src/odoc/indexing.ml index 6f9a3dc515..2e830325f4 100644 --- a/src/odoc/indexing.ml +++ b/src/odoc/indexing.ml @@ -76,20 +76,20 @@ let compile_to_json ~output ~occurrences files = let compile_to_marshall ~output sidebar files = let final_index = H.create 10 in let unit u = - Odoc_model.Fold.unit + Odoc_index.Fold.unit ~f:(fun () item -> - let entries = Odoc_search.Entry.entries_of_item item in + let entries = Odoc_index.Entry.entries_of_item item in List.iter - (fun entry -> H.add final_index entry.Odoc_search.Entry.id entry) + (fun entry -> H.add final_index entry.Odoc_index.Entry.id entry) entries) () u in let page p = - Odoc_model.Fold.page + Odoc_index.Fold.page ~f:(fun () item -> - let entries = Odoc_search.Entry.entries_of_item item in + let entries = Odoc_index.Entry.entries_of_item item in List.iter - (fun entry -> H.add final_index entry.Odoc_search.Entry.id entry) + (fun entry -> H.add final_index entry.Odoc_index.Entry.id entry) entries) () p in @@ -112,7 +112,7 @@ let read_occurrences file = let htbl : Odoc_occurrences.Table.t = Marshal.from_channel ic in htbl -open Odoc_model.Sidebar +open Odoc_index.Sidebar let compile out_format ~output ~warnings_options ~occurrences ~lib_roots ~page_roots ~inputs_in_file ~odocls = diff --git a/src/odoc/indexing.mli b/src/odoc/indexing.mli index 104a6e5aa5..d484fbd730 100644 --- a/src/odoc/indexing.mli +++ b/src/odoc/indexing.mli @@ -4,7 +4,7 @@ val handle_file : Fpath.t -> unit:(Odoc_model.Lang.Compilation_unit.t -> 'a) -> page:(Odoc_model.Lang.Page.t -> 'a) -> - occ:(Odoc_search.Entry.t Odoc_model.Paths.Identifier.Hashtbl.Any.t -> 'a) -> + occ:(Odoc_index.Entry.t Odoc_model.Paths.Identifier.Hashtbl.Any.t -> 'a) -> ('a, [> msg ]) result (** This function is exposed for custom indexers that uses [odoc] as a library to generate their search index *) diff --git a/src/odoc/odoc_file.mli b/src/odoc/odoc_file.mli index 02ab278ed2..5bd610f921 100644 --- a/src/odoc/odoc_file.mli +++ b/src/odoc/odoc_file.mli @@ -51,11 +51,9 @@ val load : Fs.File.t -> (t, [> msg ]) result val load_root : Fs.File.t -> (Root.t, [> msg ]) result (** Only load the root. Faster than {!load}, used for looking up imports. *) -val save_index : - Fs.File.t -> Odoc_search.Entry.t Odoc_model.Lang.Index.t -> unit +val save_index : Fs.File.t -> Odoc_index.Entry.t Odoc_index.t -> unit -val load_index : - Fs.File.t -> (Odoc_search.Entry.t Odoc_model.Lang.Index.t, [> msg ]) result +val load_index : Fs.File.t -> (Odoc_index.Entry.t Odoc_index.t, [> msg ]) result (** Load a [.odoc-index] file. *) val save_asset : Fpath.t -> warnings:Error.t list -> Lang.Asset.t -> unit diff --git a/src/search/html.ml b/src/search/html.ml index 2f1db78e03..9e47a02b9e 100644 --- a/src/search/html.ml +++ b/src/search/html.ml @@ -2,6 +2,7 @@ type html = Html_types.div_content Tyxml.Html.elt open Odoc_model open Lang +open Odoc_index let url { Entry.id; kind; doc = _ } = let open Entry in diff --git a/src/search/html.mli b/src/search/html.mli index dd66127908..2134584808 100644 --- a/src/search/html.mli +++ b/src/search/html.mli @@ -1,4 +1,5 @@ open Odoc_model +open Odoc_index type html = Html_types.div_content Tyxml.Html.elt diff --git a/src/search/json_index/json_display.mli b/src/search/json_index/json_display.mli index 0140744f8b..df72e9d198 100644 --- a/src/search/json_index/json_display.mli +++ b/src/search/json_index/json_display.mli @@ -1,6 +1,6 @@ open Odoc_search val of_entry : - Entry.t -> + Odoc_index.Entry.t -> Html.html list -> (Odoc_html.Json.json, Odoc_document.Url.Error.t) Result.result diff --git a/src/search/json_index/json_search.ml b/src/search/json_index/json_search.ml index 0301e4039e..e1e11b1687 100644 --- a/src/search/json_index/json_search.ml +++ b/src/search/json_index/json_search.ml @@ -1,4 +1,5 @@ open Odoc_search +open Odoc_index let json_of_args (args : Odoc_model.Lang.TypeDecl.Constructor.argument) = match args with @@ -228,7 +229,7 @@ let unit ?occurrences ppf u = let first = output_json ppf first entries in first in - let _first = Odoc_model.Fold.unit ~f true u in + let _first = Fold.unit ~f true u in () let page ppf (page : Odoc_model.Lang.Page.t) = @@ -239,7 +240,7 @@ let page ppf (page : Odoc_model.Lang.Page.t) = in output_json ppf first entries in - let _first = Odoc_model.Fold.page ~f true page in + let _first = Fold.page ~f true page in () let index ppf (index : Entry.t Odoc_model.Paths.Identifier.Hashtbl.Any.t) = diff --git a/src/search/json_index/json_search.mli b/src/search/json_index/json_search.mli index 89d9e2e9d6..e469be5c30 100644 --- a/src/search/json_index/json_search.mli +++ b/src/search/json_index/json_search.mli @@ -8,5 +8,5 @@ val unit : val page : Format.formatter -> Odoc_model.Lang.Page.t -> unit val index : Format.formatter -> - Odoc_search.Entry.t Odoc_model.Paths.Identifier.Hashtbl.Any.t -> + Odoc_index.Entry.t Odoc_model.Paths.Identifier.Hashtbl.Any.t -> unit From 06897bc5c73d57671c9675871d33dca867c491c8 Mon Sep 17 00:00:00 2001 From: Guillaume Petiot Date: Mon, 4 Nov 2024 16:56:54 +0000 Subject: [PATCH 05/11] Handle occurrences in Json_search.index Co-authored-by: Paul-Elliot --- src/odoc/indexing.ml | 2 +- src/search/json_index/json_search.ml | 14 ++++++++++++-- src/search/json_index/json_search.mli | 1 + 3 files changed, 14 insertions(+), 3 deletions(-) diff --git a/src/odoc/indexing.ml b/src/odoc/indexing.ml index 2e830325f4..d0d3a41ce1 100644 --- a/src/odoc/indexing.ml +++ b/src/odoc/indexing.ml @@ -60,7 +60,7 @@ let compile_to_json ~output ~occurrences files = handle_file ~unit:(print (Json_search.unit ?occurrences) acc) ~page:(print Json_search.page acc) - ~occ:(print Json_search.index acc) + ~occ:(print (Json_search.index ?occurrences) acc) file with | Ok acc -> acc diff --git a/src/search/json_index/json_search.ml b/src/search/json_index/json_search.ml index e1e11b1687..386a5d5739 100644 --- a/src/search/json_index/json_search.ml +++ b/src/search/json_index/json_search.ml @@ -243,11 +243,21 @@ let page ppf (page : Odoc_model.Lang.Page.t) = let _first = Fold.page ~f true page in () -let index ppf (index : Entry.t Odoc_model.Paths.Identifier.Hashtbl.Any.t) = +let index ?occurrences ppf + (index : Entry.t Odoc_model.Paths.Identifier.Hashtbl.Any.t) = + let get_occ id = + match occurrences with + | None -> None + | Some occurrences -> ( + match Odoc_occurrences.Table.get occurrences id with + | Some x -> Some x + | None -> Some { direct = 0; indirect = 0 }) + in let _first = Odoc_model.Paths.Identifier.Hashtbl.Any.fold (fun _id entry first -> - let entry = (entry, Html.of_entry entry, None) in + let occ = get_occ entry.Entry.id in + let entry = (entry, Html.of_entry entry, occ) in output_json ppf first [ entry ]) index true in diff --git a/src/search/json_index/json_search.mli b/src/search/json_index/json_search.mli index e469be5c30..95d8014c29 100644 --- a/src/search/json_index/json_search.mli +++ b/src/search/json_index/json_search.mli @@ -7,6 +7,7 @@ val unit : unit val page : Format.formatter -> Odoc_model.Lang.Page.t -> unit val index : + ?occurrences:Odoc_occurrences.Table.t -> Format.formatter -> Odoc_index.Entry.t Odoc_model.Paths.Identifier.Hashtbl.Any.t -> unit From 2c5498d4e2493b321b6b23d65fad9f42e518de74 Mon Sep 17 00:00:00 2001 From: Guillaume Petiot Date: Mon, 4 Nov 2024 17:18:53 +0000 Subject: [PATCH 06/11] Move Sidebar.Toc into Page_hierarchy Co-authored-by: Paul-Elliot --- src/document/sidebar.ml | 6 +- src/index/odoc_index.ml | 1 + src/index/page_hierarchy.ml | 190 +++++++++++++++++++++++++++++++++ src/index/page_hierarchy.mli | 16 +++ src/index/sidebar.ml | 199 +---------------------------------- src/index/sidebar.mli | 14 +-- src/odoc/indexing.ml | 2 +- 7 files changed, 212 insertions(+), 216 deletions(-) create mode 100644 src/index/page_hierarchy.ml create mode 100644 src/index/page_hierarchy.mli diff --git a/src/document/sidebar.ml b/src/document/sidebar.ml index cf28e74956..c88ccab971 100644 --- a/src/document/sidebar.ml +++ b/src/document/sidebar.ml @@ -9,16 +9,14 @@ let sidebar_toc_entry id content = module Toc : sig type t - val of_lang : Odoc_index.Sidebar.PageToc.t -> t + val of_lang : Odoc_index.Page_hierarchy.t -> t val to_sidebar : ?fallback:string -> (Url.Path.t * Inline.one -> Block.one) -> t -> Block.t end = struct type t = (Url.Path.t * Inline.one) option Tree.t - open Odoc_index.Sidebar - - let of_lang (dir : PageToc.t) = + let of_lang (dir : Odoc_index.Page_hierarchy.t) = Tree.map dir ~f:(function | None -> None | Some (parent_id, title) -> diff --git a/src/index/odoc_index.ml b/src/index/odoc_index.ml index 821332f993..30b0599915 100644 --- a/src/index/odoc_index.ml +++ b/src/index/odoc_index.ml @@ -1,5 +1,6 @@ module Entry = Entry module Fold = Fold +module Page_hierarchy = Page_hierarchy module Sidebar = Sidebar type 'a t = { diff --git a/src/index/page_hierarchy.ml b/src/index/page_hierarchy.ml new file mode 100644 index 0000000000..2d6d65ee6a --- /dev/null +++ b/src/index/page_hierarchy.ml @@ -0,0 +1,190 @@ +open Odoc_utils +open Odoc_model + +(* Selective opens *) +module Id = Odoc_model.Paths.Identifier +module PageName = Odoc_model.Names.PageName + +module CPH = Id.Hashtbl.ContainerPage +module LPH = Id.Hashtbl.LeafPage + +type page = Id.Page.t +type leaf_page = Id.LeafPage.t +type container_page = Id.ContainerPage.t + +open Astring + +type title = Comment.link_content + +type payload = { + title : title; + children_order : Frontmatter.children_order option; +} + +type dir_content = { leafs : payload LPH.t; dirs : in_progress CPH.t } +and in_progress = container_page option * dir_content + +let empty_t dir_id = (dir_id, { leafs = LPH.create 10; dirs = CPH.create 10 }) + +let get_parent id : container_page option = + let id :> page = id in + match id.iv with + | `Page (Some parent, _) -> Some parent + | `LeafPage (Some parent, _) -> Some parent + | `Page (None, _) | `LeafPage (None, _) -> None + +let find_leaf ((_, dir_content) : in_progress) leaf_page = + try Some (LPH.find dir_content.leafs leaf_page) with Not_found -> None + +let leafs (_, dir_content) = + LPH.fold + (fun id { title = payload; _ } acc -> + if String.equal "index" (Id.name id) then acc else (id, payload) :: acc) + dir_content.leafs [] + +let dirs (_, dir_content) = + CPH.fold (fun id payload acc -> (id, payload) :: acc) dir_content.dirs [] + +let rec get_or_create (dir : in_progress) (id : container_page) : in_progress = + let _, { dirs = parent_dirs; _ } = + match get_parent id with + | Some parent -> get_or_create dir parent + | None -> dir + in + let current_item = + try Some (CPH.find parent_dirs id) with Not_found -> None + in + match current_item with + | Some item -> item + | None -> + let new_ = empty_t (Some id) in + CPH.add parent_dirs id new_; + new_ + +let add (dir : in_progress) ((id : leaf_page), title, children_order) = + let _, dir_content = + match get_parent id with + | Some parent -> get_or_create dir parent + | None -> dir + in + LPH.replace dir_content.leafs id { title; children_order } + +let dir_index ((parent_id, _) as dir) = + let index_id = Id.Mk.leaf_page (parent_id, PageName.make_std "index") in + match find_leaf dir index_id with + | Some payload -> Some (payload, index_id, payload.title) + | None -> None + +type index = Id.Page.t * title + +type t = index option Odoc_utils.Tree.t + +let rec t_of_in_progress (dir : in_progress) : t = + let children_order, index = + match dir_index dir with + | Some ({ children_order; _ }, index_id, index_title) -> + (children_order, Some (index_id, index_title)) + | None -> (None, None) + in + let pp_content fmt (id, _) = + match id.Id.iv with + | `LeafPage (_, name) -> Format.fprintf fmt "'%s'" (PageName.to_string name) + | `Page (_, name) -> Format.fprintf fmt "'%s/'" (PageName.to_string name) + in + let pp_children fmt c = + match c.Location_.value with + | Frontmatter.Page s -> Format.fprintf fmt "'%s'" s + | Dir s -> Format.fprintf fmt "'%s/'" s + in + let ordered, unordered = + let contents = + let leafs = + leafs dir + |> List.map (fun (id, payload) -> + let id :> Id.Page.t = id in + (id, Tree.leaf (Some (id, payload)))) + in + let dirs = + dirs dir + |> List.map (fun (id, payload) -> + let id :> Id.Page.t = id in + (id, t_of_in_progress payload)) + in + leafs @ dirs + in + match children_order with + | None -> ([], contents) + | Some children_order -> + let children_indexes = + List.mapi (fun i x -> (i, x)) children_order.value + in + let equal id ch = + match (ch, id.Id.iv) with + | (_, { Location_.value = Frontmatter.Dir c; _ }), `Page (_, name) -> + String.equal (PageName.to_string name) c + | (_, { Location_.value = Page c; _ }), `LeafPage (_, name) -> + String.equal (PageName.to_string name) c + | _ -> false + in + let children_indexes, indexed_content, unindexed_content = + List.fold_left + (fun (children_indexes, indexed_content, unindexed_content) + (((id : Id.Page.t), _) as entry) -> + let indexes_for_entry, children_indexes = + List.partition (equal id) children_indexes + in + match indexes_for_entry with + | [] -> + (children_indexes, indexed_content, entry :: unindexed_content) + | (i, _) :: rest -> + List.iter + (fun (_, c) -> + Error.raise_warning + (Error.make "Duplicate %a in (children)." pp_children c + (Location_.location c))) + rest; + ( children_indexes, + (i, entry) :: indexed_content, + unindexed_content )) + (children_indexes, [], []) contents + in + List.iter + (fun (_, c) -> + Error.raise_warning + (Error.make "%a in (children) does not correspond to anything." + pp_children c (Location_.location c))) + children_indexes; + (indexed_content, unindexed_content) + in + let () = + match (children_order, unordered) with + | Some x, (_ :: _ as l) -> + Error.raise_warning + (Error.make "(children) doesn't include %a." + (Format.pp_print_list pp_content) + l (Location_.location x)) + | _ -> () + in + let ordered = + ordered + |> List.sort (fun (i, _) (j, _) -> (compare : int -> int -> int) i j) + |> List.map snd + in + let unordered = + List.sort + (fun (x, _) (y, _) -> + String.compare (Paths.Identifier.name x) (Paths.Identifier.name y)) + unordered + in + let contents = ordered @ unordered |> List.map snd in + { Tree.node = index; children = contents } + +let rec remove_common_root (v : t) = + match v with + | { Tree.children = [ v ]; node = None } -> remove_common_root v + | _ -> v + +let of_list l = + let dir = empty_t None in + List.iter (add dir) l; + t_of_in_progress dir |> remove_common_root diff --git a/src/index/page_hierarchy.mli b/src/index/page_hierarchy.mli new file mode 100644 index 0000000000..21cc2077c4 --- /dev/null +++ b/src/index/page_hierarchy.mli @@ -0,0 +1,16 @@ +open Odoc_model +open Odoc_model.Paths +open Odoc_utils + +(** Page hierarchies represent a hierarchy of pages. *) + +type title = Comment.link_content + +type index = Identifier.Page.t * title + +type t = index option Tree.t + +val of_list : + (Identifier.LeafPage.t * title * Frontmatter.children_order option) list -> t +(** Uses the convention that the [index] children passes its payload to the + container directory to output a payload *) diff --git a/src/index/sidebar.ml b/src/index/sidebar.ml index c277be5573..c93d4298ae 100644 --- a/src/index/sidebar.ml +++ b/src/index/sidebar.ml @@ -1,205 +1,8 @@ -open Odoc_utils open Odoc_model module Id = Paths.Identifier -module CPH = Id.Hashtbl.ContainerPage -module LPH = Id.Hashtbl.LeafPage - -type page = Id.Page.t -type leaf_page = Id.LeafPage.t -type container_page = Id.ContainerPage.t - -open Astring - -module PageToc = struct - type title = Comment.link_content - - type payload = { - title : title; - children_order : Frontmatter.children_order option; - } - - type dir_content = { leafs : payload LPH.t; dirs : in_progress CPH.t } - and in_progress = container_page option * dir_content - - let empty_t dir_id = (dir_id, { leafs = LPH.create 10; dirs = CPH.create 10 }) - - let get_parent id : container_page option = - let id :> page = id in - match id.iv with - | `Page (Some parent, _) -> Some parent - | `LeafPage (Some parent, _) -> Some parent - | `Page (None, _) | `LeafPage (None, _) -> None - - let find_leaf ((_, dir_content) : in_progress) leaf_page = - try Some (LPH.find dir_content.leafs leaf_page) with Not_found -> None - - let leafs (_, dir_content) = - LPH.fold - (fun id { title = payload; _ } acc -> - if String.equal "index" (Paths.Identifier.name id) then acc - else (id, payload) :: acc) - dir_content.leafs [] - - let dirs (_, dir_content) = - CPH.fold (fun id payload acc -> (id, payload) :: acc) dir_content.dirs [] - - let rec get_or_create (dir : in_progress) (id : container_page) : in_progress - = - let _, { dirs = parent_dirs; _ } = - match get_parent id with - | Some parent -> get_or_create dir parent - | None -> dir - in - let current_item = - try Some (CPH.find parent_dirs id) with Not_found -> None - in - match current_item with - | Some item -> item - | None -> - let new_ = empty_t (Some id) in - CPH.add parent_dirs id new_; - new_ - - let add (dir : in_progress) ((id : leaf_page), title, children_order) = - let _, dir_content = - match get_parent id with - | Some parent -> get_or_create dir parent - | None -> dir - in - LPH.replace dir_content.leafs id { title; children_order } - - let dir_index ((parent_id, _) as dir) = - let index_id = - Paths.Identifier.Mk.leaf_page (parent_id, Names.PageName.make_std "index") - in - match find_leaf dir index_id with - | Some payload -> Some (payload, index_id, payload.title) - | None -> None - - type index = Id.Page.t * title - type t = index option Odoc_utils.Tree.t - - let rec t_of_in_progress (dir : in_progress) : t = - let children_order, index = - match dir_index dir with - | Some ({ children_order; _ }, index_id, index_title) -> - (children_order, Some (index_id, index_title)) - | None -> (None, None) - in - let pp_content fmt (id, _) = - match id.Id.iv with - | `LeafPage (_, name) -> - Format.fprintf fmt "'%s'" (Names.PageName.to_string name) - | `Page (_, name) -> - Format.fprintf fmt "'%s/'" (Names.PageName.to_string name) - in - let pp_children fmt c = - match c.Location_.value with - | Frontmatter.Page s -> Format.fprintf fmt "'%s'" s - | Dir s -> Format.fprintf fmt "'%s/'" s - in - let ordered, unordered = - let contents = - let leafs = - leafs dir - |> List.map (fun (id, payload) -> - let id :> Id.Page.t = id in - (id, Tree.leaf (Some (id, payload)))) - in - let dirs = - dirs dir - |> List.map (fun (id, payload) -> - let id :> Id.Page.t = id in - (id, t_of_in_progress payload)) - in - leafs @ dirs - in - match children_order with - | None -> ([], contents) - | Some children_order -> - let children_indexes = - List.mapi (fun i x -> (i, x)) children_order.value - in - let equal id ch = - match (ch, id.Id.iv) with - | (_, { Location_.value = Frontmatter.Dir c; _ }), `Page (_, name) - -> - String.equal (Names.PageName.to_string name) c - | (_, { Location_.value = Page c; _ }), `LeafPage (_, name) -> - String.equal (Names.PageName.to_string name) c - | _ -> false - in - let children_indexes, indexed_content, unindexed_content = - List.fold_left - (fun (children_indexes, indexed_content, unindexed_content) - (((id : Id.Page.t), _) as entry) -> - let indexes_for_entry, children_indexes = - List.partition (equal id) children_indexes - in - match indexes_for_entry with - | [] -> - ( children_indexes, - indexed_content, - entry :: unindexed_content ) - | (i, _) :: rest -> - List.iter - (fun (_, c) -> - Error.raise_warning - (Error.make "Duplicate %a in (children)." pp_children - c (Location_.location c))) - rest; - ( children_indexes, - (i, entry) :: indexed_content, - unindexed_content )) - (children_indexes, [], []) contents - in - List.iter - (fun (_, c) -> - Error.raise_warning - (Error.make "%a in (children) does not correspond to anything." - pp_children c (Location_.location c))) - children_indexes; - (indexed_content, unindexed_content) - in - let () = - match (children_order, unordered) with - | Some x, (_ :: _ as l) -> - Error.raise_warning - (Error.make "(children) doesn't include %a." - (Format.pp_print_list pp_content) - l (Location_.location x)) - | _ -> () - in - let ordered = - ordered - |> List.sort (fun (i, _) (j, _) -> (compare : int -> int -> int) i j) - |> List.map snd - in - let unordered = - List.sort - (fun (x, _) (y, _) -> - String.compare (Paths.Identifier.name x) (Paths.Identifier.name y)) - unordered - in - let contents = ordered @ unordered |> List.map snd in - { Tree.node = index; children = contents } - - let rec remove_common_root (v : t) = - match v with - | { Tree.children = [ v ]; node = None } -> remove_common_root v - | _ -> v - - let of_list l = - let dir = empty_t None in - List.iter (add dir) l; - t_of_in_progress dir |> remove_common_root -end - -type toc = PageToc.t - type library = { name : string; units : Paths.Identifier.RootModule.t list } -type page_hierarchy = { hierarchy_name : string; pages : toc } +type page_hierarchy = { hierarchy_name : string; pages : Page_hierarchy.t } type t = { pages : page_hierarchy list; libraries : library list } diff --git a/src/index/sidebar.mli b/src/index/sidebar.mli index 80abe7d264..3f362d1765 100644 --- a/src/index/sidebar.mli +++ b/src/index/sidebar.mli @@ -1,20 +1,8 @@ open Odoc_model open Paths.Identifier -module PageToc : sig - type title = Comment.link_content - - type index = Page.t * title - type t = index option Odoc_utils.Tree.t - - val of_list : - (LeafPage.t * title * Frontmatter.children_order option) list -> t - (** Uses the convention that the [index] children passes its payload to the - container directory to output a payload *) -end - type library = { name : string; units : RootModule.t list } -type page_hierarchy = { hierarchy_name : string; pages : PageToc.t } +type page_hierarchy = { hierarchy_name : string; pages : Page_hierarchy.t } type t = { pages : page_hierarchy list; libraries : library list } diff --git a/src/odoc/indexing.ml b/src/odoc/indexing.ml index d0d3a41ce1..83f4e22b2c 100644 --- a/src/odoc/indexing.ml +++ b/src/odoc/indexing.ml @@ -170,7 +170,7 @@ let compile out_format ~output ~warnings_options ~occurrences ~lib_roots let children_order = fm.Frontmatter.children_order in (id, title, children_order)) in - PageToc.of_list pages + Odoc_index.Page_hierarchy.of_list pages in { hierarchy_name = page_root; pages }) page_roots From 3377d4db22bf805731a8f6c4592be1cd5b47b85f Mon Sep 17 00:00:00 2001 From: Guillaume Petiot Date: Mon, 4 Nov 2024 22:23:26 +0000 Subject: [PATCH 07/11] Toc.t handles Url.t instead of Url.Path.t Co-authored-by: Paul-Elliot --- src/document/sidebar.ml | 38 +++++++++++++++++++++++++++++--------- 1 file changed, 29 insertions(+), 9 deletions(-) diff --git a/src/document/sidebar.ml b/src/document/sidebar.ml index c88ccab971..400475d904 100644 --- a/src/document/sidebar.ml +++ b/src/document/sidebar.ml @@ -1,9 +1,18 @@ open Odoc_utils open Types +module Id = Odoc_model.Paths.Identifier let sidebar_toc_entry id content = - let href = id |> Url.Path.from_identifier |> Url.from_path in - let target = Target.Internal (Resolved href) in + let target = + match + (id :> Odoc_model.Paths.Identifier.t) + |> Url.from_identifier ~stop_before:false + with + | Ok href -> Target.Resolved href + | Error _ -> Target.Unresolved + (* This error case should never happen since [stop_before] is false *) + in + let target = Target.Internal target in inline @@ Inline.Link { target; content; tooltip = None } module Toc : sig @@ -12,15 +21,22 @@ module Toc : sig val of_lang : Odoc_index.Page_hierarchy.t -> t val to_sidebar : - ?fallback:string -> (Url.Path.t * Inline.one -> Block.one) -> t -> Block.t + ?fallback:string -> (Url.t * Inline.one -> Block.one) -> t -> Block.t end = struct - type t = (Url.Path.t * Inline.one) option Tree.t + type t = (Url.t * Inline.one) option Tree.t let of_lang (dir : Odoc_index.Page_hierarchy.t) = Tree.map dir ~f:(function | None -> None | Some (parent_id, title) -> - let path = Url.Path.from_identifier parent_id in + let path = + match + Url.from_identifier ~stop_before:false (parent_id :> Id.t) + with + | Ok r -> r + | Error _ -> assert false + (* This error case should never happen since [stop_before] is false, and even less since it's a page id *) + in let content = Comment.link_content title in Some (path, sidebar_toc_entry parent_id content)) @@ -41,7 +57,7 @@ end = struct name :: content end type pages = { name : string; pages : Toc.t } -type library = { name : string; units : (Url.Path.t * Inline.one) list } +type library = { name : string; units : (Url.t * Inline.one) list } type t = { pages : pages list; libraries : library list } @@ -56,12 +72,15 @@ let of_lang (v : Odoc_index.Sidebar.t) = let units = let item id = let content = [ inline @@ Text (Odoc_model.Paths.Identifier.name id) ] in - (Url.Path.from_identifier id, sidebar_toc_entry id content) + let path = Url.from_identifier ~stop_before:false (id :> Id.t) in + match path with + | Ok path -> Some (path, sidebar_toc_entry id content) + | Error _ -> None in let units = List.map (fun { Odoc_index.Sidebar.units; name } -> - let units = List.map item units in + let units = List.filter_map item units in { name; units }) v.libraries in @@ -77,7 +96,8 @@ let to_block (sidebar : t) url = in let render_entry (entry_path, b) = let link = - if entry_path = url then { b with Inline.attr = [ "current_unit" ] } + if entry_path = Url.from_path url then + { b with Inline.attr = [ "current_unit" ] } else b in Types.block @@ Inline [ link ] From fd8d89865ea82a1cf401334e6a8c0e0d5a57415c Mon Sep 17 00:00:00 2001 From: Guillaume Petiot Date: Mon, 4 Nov 2024 20:17:50 +0000 Subject: [PATCH 08/11] Move Sidebar types into Odoc_index and rename Toc.of_lang into Toc_of_page_hierarchy Co-authored-by: Paul-Elliot --- src/document/sidebar.ml | 48 ++++++++++++++++++++++------------------ src/document/sidebar.mli | 2 +- src/index/odoc_index.ml | 12 ++++++++-- src/index/sidebar.ml | 8 ------- src/index/sidebar.mli | 8 ------- src/odoc/indexing.ml | 13 +++++------ 6 files changed, 44 insertions(+), 47 deletions(-) delete mode 100644 src/index/sidebar.ml delete mode 100644 src/index/sidebar.mli diff --git a/src/document/sidebar.ml b/src/document/sidebar.ml index 400475d904..8bf1d0217b 100644 --- a/src/document/sidebar.ml +++ b/src/document/sidebar.ml @@ -18,27 +18,33 @@ let sidebar_toc_entry id content = module Toc : sig type t - val of_lang : Odoc_index.Page_hierarchy.t -> 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 end = struct type t = (Url.t * Inline.one) option Tree.t - let of_lang (dir : Odoc_index.Page_hierarchy.t) = - Tree.map dir ~f:(function - | None -> None - | Some (parent_id, title) -> - let path = - match - Url.from_identifier ~stop_before:false (parent_id :> Id.t) - with - | Ok r -> r - | Error _ -> assert false - (* This error case should never happen since [stop_before] is false, and even less since it's a page id *) - in - let content = Comment.link_content title in - Some (path, sidebar_toc_entry parent_id content)) + let of_page_hierarchy (dir : Odoc_index.Page_hierarchy.t) = + let f index = + let payload = + match index with + | None -> None + | Some (index_id, title) -> + let path = + match + Url.from_identifier ~stop_before:false (index_id :> Id.t) + with + | Ok r -> r + | Error _ -> assert false + (* This error case should never happen since [stop_before] is false, and even less since it's a page id *) + in + let content = Comment.link_content title in + Some (path, sidebar_toc_entry index_id content) + in + payload + in + Tree.map ~f dir let rec to_sidebar ?(fallback = "root") convert { Tree.node = name; children = content } = @@ -61,11 +67,11 @@ type library = { name : string; units : (Url.t * Inline.one) list } type t = { pages : pages list; libraries : library list } -let of_lang (v : Odoc_index.Sidebar.t) = +let of_lang (v : Odoc_index.sidebar) = let pages = - let page_hierarchy { Odoc_index.Sidebar.hierarchy_name; pages } = - let hierarchy = Toc.of_lang pages in - Some { name = hierarchy_name; pages = hierarchy } + let page_hierarchy { Odoc_index.p_name; p_hierarchy } = + let hierarchy = Toc.of_page_hierarchy p_hierarchy in + Some { name = p_name; pages = hierarchy } in Odoc_utils.List.filter_map page_hierarchy v.pages in @@ -79,10 +85,10 @@ let of_lang (v : Odoc_index.Sidebar.t) = in let units = List.map - (fun { Odoc_index.Sidebar.units; name } -> + (fun { Odoc_index.units; name } -> let units = List.filter_map item units in { name; units }) - v.libraries + v.libs in units in diff --git a/src/document/sidebar.mli b/src/document/sidebar.mli index eff30b6c80..20b1fe6714 100644 --- a/src/document/sidebar.mli +++ b/src/document/sidebar.mli @@ -1,6 +1,6 @@ type t -val of_lang : Odoc_index.Sidebar.t -> t +val of_lang : Odoc_index.sidebar -> t val to_block : t -> Url.Path.t -> Types.Block.t (** Generates the sidebar document given a global sidebar and the path at which diff --git a/src/index/odoc_index.ml b/src/index/odoc_index.ml index 30b0599915..5fac95548f 100644 --- a/src/index/odoc_index.ml +++ b/src/index/odoc_index.ml @@ -1,9 +1,17 @@ module Entry = Entry module Fold = Fold module Page_hierarchy = Page_hierarchy -module Sidebar = Sidebar + +type page = { p_name : string; p_hierarchy : Page_hierarchy.t } + +type library = { + name : string; + units : Odoc_model.Paths.Identifier.RootModule.t list; +} + +type sidebar = { pages : page list; libs : library list } type 'a t = { - sidebar : Sidebar.t; + sidebar : sidebar; index : 'a Odoc_model.Paths.Identifier.Hashtbl.Any.t; } diff --git a/src/index/sidebar.ml b/src/index/sidebar.ml deleted file mode 100644 index c93d4298ae..0000000000 --- a/src/index/sidebar.ml +++ /dev/null @@ -1,8 +0,0 @@ -open Odoc_model -module Id = Paths.Identifier - -type library = { name : string; units : Paths.Identifier.RootModule.t list } - -type page_hierarchy = { hierarchy_name : string; pages : Page_hierarchy.t } - -type t = { pages : page_hierarchy list; libraries : library list } diff --git a/src/index/sidebar.mli b/src/index/sidebar.mli deleted file mode 100644 index 3f362d1765..0000000000 --- a/src/index/sidebar.mli +++ /dev/null @@ -1,8 +0,0 @@ -open Odoc_model -open Paths.Identifier - -type library = { name : string; units : RootModule.t list } - -type page_hierarchy = { hierarchy_name : string; pages : Page_hierarchy.t } - -type t = { pages : page_hierarchy list; libraries : library list } diff --git a/src/odoc/indexing.ml b/src/odoc/indexing.ml index 83f4e22b2c..c643b631bb 100644 --- a/src/odoc/indexing.ml +++ b/src/odoc/indexing.ml @@ -112,8 +112,6 @@ let read_occurrences file = let htbl : Odoc_occurrences.Table.t = Marshal.from_channel ic in htbl -open Odoc_index.Sidebar - let compile out_format ~output ~warnings_options ~occurrences ~lib_roots ~page_roots ~inputs_in_file ~odocls = let handle_warnings f = @@ -148,7 +146,7 @@ let compile out_format ~output ~warnings_options ~occurrences ~lib_roots List.map (fun (page_root, _) -> let pages = Resolver.all_pages ~root:page_root resolver in - let pages = + let p_hierarchy = let pages = pages |> List.filter_map @@ -172,13 +170,14 @@ let compile out_format ~output ~warnings_options ~occurrences ~lib_roots in Odoc_index.Page_hierarchy.of_list pages in - { hierarchy_name = page_root; pages }) + { Odoc_index.p_name = page_root; p_hierarchy }) page_roots in - let libraries = + let libs = List.map (fun (library, _) -> - { name = library; units = Resolver.all_units ~library resolver }) + let units = Resolver.all_units ~library resolver in + { Odoc_index.name = library; units }) lib_roots in let includes_rec = @@ -193,7 +192,7 @@ let compile out_format ~output ~warnings_options ~occurrences ~lib_roots [] include_rec) |> List.concat) in - let content = { pages; libraries } in + let content = { Odoc_index.pages; libs } in match out_format with | `JSON -> compile_to_json ~output ~occurrences files | `Marshall -> compile_to_marshall ~output content files From f093b7fc387266ceeb0916a97a6aab48242cbd67 Mon Sep 17 00:00:00 2001 From: Guillaume Petiot Date: Tue, 5 Nov 2024 11:35:59 +0000 Subject: [PATCH 09/11] Pass the sidebar to Rendering Co-authored-by: Paul-Elliot --- src/document/renderer.ml | 3 ++- src/html/generator.ml | 2 +- src/html/generator.mli | 2 +- src/html/html_fragment_json.ml | 4 ++-- src/html/html_page.ml | 4 ++-- src/latex/generator.ml | 2 +- src/manpage/generator.ml | 2 +- src/odoc/rendering.ml | 10 ---------- 8 files changed, 10 insertions(+), 19 deletions(-) diff --git a/src/document/renderer.ml b/src/document/renderer.ml index 270f70292d..f6f0fb4453 100644 --- a/src/document/renderer.ml +++ b/src/document/renderer.ml @@ -6,6 +6,7 @@ let string_of_syntax = function OCaml -> "ml" | Reason -> "re" type page = { filename : Fpath.t; + path : Url.Path.t; content : Format.formatter -> unit; children : page list; } @@ -23,7 +24,7 @@ type input = type 'a t = { name : string; - render : 'a -> Types.Block.t option -> Types.Document.t -> page list; + render : 'a -> Sidebar.t option -> Types.Document.t -> page list; filepath : 'a -> Url.Path.t -> Fpath.t; } diff --git a/src/html/generator.ml b/src/html/generator.ml index b40f90b16d..ab1c5da09e 100644 --- a/src/html/generator.ml +++ b/src/html/generator.ml @@ -542,7 +542,7 @@ module Page = struct match sidebar with | None -> None | Some sidebar -> - (* let sidebar = Odoc_document.Sidebar.to_block sidebar p in *) + let sidebar = Odoc_document.Sidebar.to_block sidebar url in (Some (block ~config ~resolve sidebar) :> any Html.elt list option) in let i = Doctree.Shift.compute ~on_sub i in diff --git a/src/html/generator.mli b/src/html/generator.mli index 446d2346f7..fa95d3249b 100644 --- a/src/html/generator.mli +++ b/src/html/generator.mli @@ -1,6 +1,6 @@ val render : config:Config.t -> - sidebar:Odoc_document.Types.Block.t option -> + sidebar:Odoc_document.Sidebar.t option -> Odoc_document.Types.Document.t -> Odoc_document.Renderer.page list diff --git a/src/html/html_fragment_json.ml b/src/html/html_fragment_json.ml index 1deffdecf8..54dac13473 100644 --- a/src/html/html_fragment_json.ml +++ b/src/html/html_fragment_json.ml @@ -62,7 +62,7 @@ let make ~config ~preamble ~url ~breadcrumbs ~sidebar ~toc ~uses_katex ("content", `String (json_of_html content)); ])) in - { Odoc_document.Renderer.filename; content; children } + { Odoc_document.Renderer.filename; content; children; path = url } let make_src ~config ~url ~breadcrumbs content = let filename = Link.Path.as_filename ~config url in @@ -82,4 +82,4 @@ let make_src ~config ~url ~breadcrumbs content = (List.map (Format.asprintf "%a" htmlpp) content)) ); ])) in - { Odoc_document.Renderer.filename; content; children = [] } + { Odoc_document.Renderer.filename; content; children = []; path = url } diff --git a/src/html/html_page.ml b/src/html/html_page.ml index 3430c76348..54f02f727d 100644 --- a/src/html/html_page.ml +++ b/src/html/html_page.ml @@ -249,7 +249,7 @@ let make ~config ~url ~header ~breadcrumbs ~sidebar ~toc ~uses_katex content page_creator ~config ~url ~uses_katex ~global_toc:sidebar header breadcrumbs toc content in - { Odoc_document.Renderer.filename; content; children } + { Odoc_document.Renderer.filename; content; children; path = url } let path_of_module_of_source ppf url = match url.Url.Path.parent with @@ -289,4 +289,4 @@ let make_src ~config ~url ~breadcrumbs ~header title content = let content = src_page_creator ~breadcrumbs ~config ~url ~header title content in - { Odoc_document.Renderer.filename; content; children = [] } + { Odoc_document.Renderer.filename; content; children = []; path = url } diff --git a/src/latex/generator.ml b/src/latex/generator.ml index 515a6cbe32..58cd5c57d9 100644 --- a/src/latex/generator.ml +++ b/src/latex/generator.ml @@ -457,7 +457,7 @@ module Doc = struct if with_children then link_children ppf children else () in let content ppf = Fmt.pf ppf "@[%a@,%t@]@." pp content children_input in - { Odoc_document.Renderer.filename; content; children } + { Odoc_document.Renderer.filename; content; children; path = url } end module Page = struct diff --git a/src/manpage/generator.ml b/src/manpage/generator.ml index f18f3e70ee..ea39f2fd41 100644 --- a/src/manpage/generator.ml +++ b/src/manpage/generator.ml @@ -562,7 +562,7 @@ and render_page (p : Page.t) = and children = Utils.flatmap ~f:subpage @@ Subpages.compute p in let content ppf = Format.fprintf ppf "%a@." Roff.pp (page p) in let filename = Link.as_filename p.url in - { Renderer.filename; content; children } + { Renderer.filename; content; children; path = p.url } let render = function | Document.Page page -> [ render_page page ] diff --git a/src/odoc/rendering.ml b/src/odoc/rendering.ml index a13deef882..2cb9208772 100644 --- a/src/odoc/rendering.ml +++ b/src/odoc/rendering.ml @@ -49,16 +49,6 @@ let document_of_input ~resolver ~warnings_options ~syntax input = let render_document renderer ~sidebar ~output:root_dir ~extra_suffix ~extra doc = - let url = - match doc with - | Odoc_document.Types.Document.Page { url; _ } -> url - | Source_page { url; _ } -> url - in - let sidebar = - Odoc_utils.Option.map - (fun sb -> Odoc_document.Sidebar.to_block sb url) - sidebar - in let pages = renderer.Renderer.render extra sidebar doc in Renderer.traverse pages ~f:(fun filename content -> let filename = prepare ~extra_suffix ~output_dir:root_dir filename in From 268cf90db691bbc5309fb9740ba259a5900f8f15 Mon Sep 17 00:00:00 2001 From: Guillaume Petiot Date: Tue, 5 Nov 2024 14:01:46 +0000 Subject: [PATCH 10/11] Simplify Toc.of_page_hierarchy Co-authored-by: Paul-Elliot --- src/document/sidebar.ml | 27 +++++++++++---------------- 1 file changed, 11 insertions(+), 16 deletions(-) diff --git a/src/document/sidebar.ml b/src/document/sidebar.ml index 8bf1d0217b..e4a2624eef 100644 --- a/src/document/sidebar.ml +++ b/src/document/sidebar.ml @@ -27,22 +27,17 @@ end = struct let of_page_hierarchy (dir : Odoc_index.Page_hierarchy.t) = let f index = - let payload = - match index with - | None -> None - | Some (index_id, title) -> - let path = - match - Url.from_identifier ~stop_before:false (index_id :> Id.t) - with - | Ok r -> r - | Error _ -> assert false - (* This error case should never happen since [stop_before] is false, and even less since it's a page id *) - in - let content = Comment.link_content title in - Some (path, sidebar_toc_entry index_id content) - in - payload + match index with + | None -> None + | Some (index_id, title) -> + let path = + match Url.from_identifier ~stop_before:false (index_id :> Id.t) with + | Ok r -> r + | Error _ -> assert false + (* This error case should never happen since [stop_before] is false, and even less since it's a page id *) + in + let content = Comment.link_content title in + Some (path, sidebar_toc_entry index_id content) in Tree.map ~f dir From c03805864e8ea5eb2a6e425034b3e1b21ece4567 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Thu, 7 Nov 2024 14:58:55 +0100 Subject: [PATCH 11/11] Refactor: avoid recomputing url in `sidebar_toc_entry` --- src/document/sidebar.ml | 18 +++++------------- 1 file changed, 5 insertions(+), 13 deletions(-) diff --git a/src/document/sidebar.ml b/src/document/sidebar.ml index e4a2624eef..3ce033d323 100644 --- a/src/document/sidebar.ml +++ b/src/document/sidebar.ml @@ -2,17 +2,8 @@ open Odoc_utils open Types module Id = Odoc_model.Paths.Identifier -let sidebar_toc_entry id content = - let target = - match - (id :> Odoc_model.Paths.Identifier.t) - |> Url.from_identifier ~stop_before:false - with - | Ok href -> Target.Resolved href - | Error _ -> Target.Unresolved - (* This error case should never happen since [stop_before] is false *) - in - let target = Target.Internal target in +let sidebar_toc_entry href content = + let target = Target.(Internal (Resolved href)) in inline @@ Inline.Link { target; content; tooltip = None } module Toc : sig @@ -37,7 +28,7 @@ end = struct (* This error case should never happen since [stop_before] is false, and even less since it's a page id *) in let content = Comment.link_content title in - Some (path, sidebar_toc_entry index_id content) + Some (path, sidebar_toc_entry path content) in Tree.map ~f dir @@ -75,8 +66,9 @@ let of_lang (v : Odoc_index.sidebar) = let content = [ inline @@ Text (Odoc_model.Paths.Identifier.name id) ] in let path = Url.from_identifier ~stop_before:false (id :> Id.t) in match path with - | Ok path -> Some (path, sidebar_toc_entry id content) + | Ok path -> Some (path, sidebar_toc_entry path content) | Error _ -> None + (* This error case should never happen since [stop_before] is false *) in let units = List.map