diff --git a/CHANGES.md b/CHANGES.md index d663aec353..4db107788a 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -28,10 +28,15 @@ - Added a `compile-asset` command (@EmileTrotignon, @panglesd, #1170) - Allow referencing assets (@panglesd, #1171) - Added a `--asset-path` arg to `html-generate` (@panglesd, #1185) -- Add a `@children_order` tag to specify the order in the sidebar (@panglesd, - #1187, #1243) +- Added a `@children_order` and an `@order_category` tags to specify the order + in the sidebar (@panglesd, #1187, #1243, #1251) - Add a `@short_title` tag to specify the short title of a page for use in the sidebar / breadcrumbs (@panglesd, #1246) +- Added a home icon in the breacrumbs (@panglesd, #1251) +- Added a CLI option to add or disable the home icon (@panglesd, #1251) +- Add sidebar to the implementation pages (@panglesd, #1251) +- Added a `@toc_status` tag, with possible values `open` and `hidden`, to define + the behavior of the entry in the sidebar and breadcrumbs (@panglesd, #1251) - Add a frontmatter syntax for mld pages (@panglesd, #1187) - Add 'remap' and 'remap-file' options to HTML generation for partial docsets (@jonludlam, #1189, #1248) diff --git a/doc/driver.mld b/doc/driver.mld index f5fd38cd7e..775ec8c3b7 100644 --- a/doc/driver.mld +++ b/doc/driver.mld @@ -124,16 +124,16 @@ A concrete example for such command would be: $ odoc compile ~/.opam/5.2.0/lib/ppxlib/ppxlib__Extension.cmti --output-dir _odoc/ - -I _odoc/ocaml-base-compiler/lib/compiler-libs.common - -I _odoc/ocaml-base-compiler/lib/stdlib - -I _odoc/ocaml-compiler-libs/lib/ocaml-compiler-libs.common - -I _odoc/ppxlib/lib/ppxlib - -I _odoc/ppxlib/lib/ppxlib.ast - -I _odoc/ppxlib/lib/ppxlib.astlib - -I _odoc/ppxlib/lib/ppxlib.stdppx - -I _odoc/ppxlib/lib/ppxlib.traverse_builtins - -I _odoc/sexplib0/lib/sexplib0 - --parent-id ppxlib/lib/ppxlib + -I _odoc/ocaml-base-compiler/compiler-libs.common + -I _odoc/ocaml-base-compiler/stdlib + -I _odoc/ocaml-compiler-libs/ocaml-compiler-libs.common + -I _odoc/ppxlib/ppxlib + -I _odoc/ppxlib/ppxlib.ast + -I _odoc/ppxlib/ppxlib.astlib + -I _odoc/ppxlib/ppxlib.stdppx + -I _odoc/ppxlib/ppxlib.traverse_builtins + -I _odoc/sexplib0/sexplib0 + --parent-id ppxlib/ppxlib ]} {3 Compiling implementations} @@ -164,16 +164,16 @@ A concrete example for such command would be: $ odoc compile-impl ~/.opam/5.2.0/lib/ppxlib/ppxlib__Spellcheck.cmt --output-dir _odoc/ - -I _odoc/ocaml-base-compiler/lib/compiler-libs.common - -I _odoc/ocaml-base-compiler/lib/stdlib - -I _odoc/ocaml-compiler-libs/lib/ocaml-compiler-libs.common - -I _odoc/ppxlib/lib/ppxlib - -I _odoc/ppxlib/lib/ppxlib.ast - -I _odoc/ppxlib/lib/ppxlib.astlib - -I _odoc/ppxlib/lib/ppxlib.stdppx - -I _odoc/sexplib0/lib/sexplib0 + -I _odoc/ocaml-base-compiler/compiler-libs.common + -I _odoc/ocaml-base-compiler/stdlib + -I _odoc/ocaml-compiler-libs/ocaml-compiler-libs.common + -I _odoc/ppxlib/ppxlib + -I _odoc/ppxlib/ppxlib.ast + -I _odoc/ppxlib/ppxlib.astlib + -I _odoc/ppxlib/ppxlib.stdppx + -I _odoc/sexplib0/sexplib0 --enable-missing-root-warning - --parent-id ppxlib/lib/ppxlib + --parent-id ppxlib/ppxlib --source-id ppxlib/src/ppxlib/spellcheck.ml ]} @@ -274,18 +274,18 @@ An example of such command: {@shell[ $ odoc compile-index -o _odoc/ppxlib/index.odoc-index - -P ppxlib:_odoc/ppxlib/doc - -L ppxlib:_odoc/ppxlib/lib/ppxlib - -L ppxlib.ast:_odoc/ppxlib/lib/ppxlib.ast - -L ppxlib.astlib:_odoc/ppxlib/lib/ppxlib.astlib - -L ppxlib.metaquot:_odoc/ppxlib/lib/ppxlib.metaquot - -L ppxlib.metaquot_lifters:_odoc/ppxlib/lib/ppxlib.metaquot_lifters - -L ppxlib.print_diff:_odoc/ppxlib/lib/ppxlib.print_diff - -L ppxlib.runner:_odoc/ppxlib/lib/ppxlib.runner - -L ppxlib.runner_as_ppx:_odoc/ppxlib/lib/ppxlib.runner_as_ppx - -L ppxlib.stdppx:_odoc/ppxlib/lib/ppxlib.stdppx - -L ppxlib.traverse:_odoc/ppxlib/lib/ppxlib.traverse - -L ppxlib.traverse_builtins:_odoc/ppxlib/lib/ppxlib.traverse_builtins + -P ppxlib:_odoc/ppxlib + -L ppxlib:_odoc/ppxlib/ppxlib + -L ppxlib.ast:_odoc/ppxlib/ppxlib.ast + -L ppxlib.astlib:_odoc/ppxlib/ppxlib.astlib + -L ppxlib.metaquot:_odoc/ppxlib/ppxlib.metaquot + -L ppxlib.metaquot_lifters:_odoc/ppxlib/ppxlib.metaquot_lifters + -L ppxlib.print_diff:_odoc/ppxlib/ppxlib.print_diff + -L ppxlib.runner:_odoc/ppxlib/ppxlib.runner + -L ppxlib.runner_as_ppx:_odoc/ppxlib/ppxlib.runner_as_ppx + -L ppxlib.stdppx:_odoc/ppxlib/ppxlib.stdppx + -L ppxlib.traverse:_odoc/ppxlib/ppxlib.traverse + -L ppxlib.traverse_builtins:_odoc/ppxlib/ppxlib.traverse_builtins --occurrences _odoc/occurrences-all.odoc-occurrences ]} @@ -354,7 +354,7 @@ An example of such command is: {@shell[ $ odoc html-generate - _odoc/ppxlib/doc/page-index.odocl + _odoc/ppxlib/page-index.odocl --index _odoc/ppxlib/index.odoc-index --search-uri ppxlib/sherlodoc_db.js --search-uri sherlodoc.js @@ -380,7 +380,7 @@ An example of such command is: {@shell[ $ odoc html-generate-source - --impl _odoc/ppxlib/lib/ppxlib/impl-ppxlib__Reconcile.odocl + --impl _odoc/ppxlib/ppxlib/impl-ppxlib__Reconcile.odocl /home/panglesd/.opam/5.2.0/lib/ppxlib/reconcile.ml -o _html/ ]} @@ -413,27 +413,27 @@ will be used in [--parent-id] and in [-P] and [-L]. The driver can decide any set of mutually disjoint set of roots, without posing problem to the reference resolution. For instance, both [-P -pkg:/pkg/doc] and [-P pkg:/pkg/version/doc] are +pkg:/pkg] and [-P pkg:/pkg/version] are acceptable versions. However, we define here "canonical" roots: -Each installed package [

] defines a single page root id: [

/doc]. +Each installed package [

] defines a single page root id: [

]. For each package [

], each library [] defines a library root id: -[

/lib/]. +[

/]. For instance, a package [foo] with two libraries: [foo] and [foo.bar] will define three trees: -- A documentation tree named [foo], with root id [foo/doc]. When referred - from other trees, a [-P foo:/foo/doc] argument needs to be added +- A documentation tree named [foo], with root id [foo]. When referred + from other trees, a [-P foo:/foo] argument needs to be added at the link phase. -- A module tree named [foo], with root id [foo/lib/foo]. When referred from - other trees, a [-L foo:/foo/lib/foo] argument needs to be added +- A module tree named [foo], with root id [foo/foo]. When referred from + other trees, a [-L foo:/foo/foo] argument needs to be added at the link phase. -- A module tree named [foo.bar], with root id [foo/lib/foo.bar]. When referred from - other trees, a [-L foo.bar:/foo/lib/foo.bar] argument needs to be +- A module tree named [foo.bar], with root id [foo/foo.bar]. When referred from + other trees, a [-L foo.bar:/foo/foo.bar] argument needs to be added at the link phase. {2 Link-time dependencies} @@ -449,11 +449,11 @@ An installed package [

] specifies its tree dependencies in a file at Stanzas of the form [(packages p1 p2 ...)] specifies that page trees [p1], [p2], ..., should be added using the [-P] argument: with the canonical roots, it -would be [-P p1:/p1/doc -P p2:/p2/doc -P ...]. +would be [-P p1:/p1 -P p2:/p2 -P ...]. Stanzas of the form [(libraries l1 l2 ...)] specifies that module trees [l1], [l2], ..., should be added using the [-L] argument: with the canonical roots, it -would be [-L l1:/p1/lib/l1 -L l2/p2/lib/l2 -L ...], +would be [-L l1:/p1/l1 -L l2/p2/l2 -L ...], where [p1] is the package [l1] is in, etc. {2 The units} @@ -472,24 +472,46 @@ root>/doc/odoc-assets/]. {2 The [--parent-id] arguments} Interface and implementation units have as parent id the root of the library -tree they belong to: with "canonical" roots, [/lib/]. +tree they belong to: with "canonical" roots, [/]. Page units that are found in [/doc//odoc-pages//.mld] have the parent id from their page tree, followed by []. So, with canonical roots, -[/doc/]. +[/]. Asset units that are found in [/doc//odoc-pages//.] have the parent id from their page tree, followed by []. With canonical roots, -[/doc/]. +[/]. Asset units that are found in [/doc//odoc-assets/] have the parent id from their page tree, followed by [_asset/] -[

/doc/_assets/]. +[

/_assets/]. {2 The [--source-id] arguments} The driver could choose the source id without breaking references. However, following the canonical roots convention, implementation units must have as source id: [/src//.ml]. + +{2 Ordering the generated pages} + +The canonical hierarchy introduces directories (one per library) that may not be +ordered by the author, either by omitting it in the [@children_order] tag or by +not specifying any [@children_order] tag. In this case, [odoc] needs to come up +with a reasonable default order, which may not be easy without some help from +the driver. + +In auto-generated pages (either [index.mld] in a directory, or [page.mld]), +[odoc] supports the [@order_category ] tag, to help sorting the +pages, if it is not sorted by the parent's [@children_order]. The resulting +order is: + +- First, pages in the order given in their parent's [@children_order], +- Then, pages ordered lexicographically by their [@order_category]. An undefined + category comes before a defined one. +- Inside a category, pages are ordered lexicographically by their first title, +- Two pages with the same name will be ordered using their file name! + +Note that [@order_category] is not suitable for author use, as it may change in +the future. Use this tag only in the driver's autogenerated pages! \ No newline at end of file diff --git a/doc/odoc.mld b/doc/odoc.mld index baff53dfec..b900b605fa 100644 --- a/doc/odoc.mld +++ b/doc/odoc.mld @@ -1,8 +1,7 @@ -{0 [odoc]} +@children_order dune odoc_for_authors cheatsheet features ocamldoc_differences interface parent_child_spec driver +@short_title [odoc] -{@meta[ - children: dune odoc_for_authors cheatsheet features ocamldoc_differences interface parent_child_spec driver -]} +{0 The [odoc] documentation generator} {b For a quick look at the [odoc] syntax, see the {{!cheatsheet}cheatsheet}!} diff --git a/doc/odoc_for_authors.mld b/doc/odoc_for_authors.mld index 3c875e0a57..07703ab865 100644 --- a/doc/odoc_for_authors.mld +++ b/doc/odoc_for_authors.mld @@ -500,6 +500,9 @@ There are three types of tags. Those with: - a single line of text (line tags), and - a block of marked-up text (block tags). +Some tags can only be used on specific contexts: specific items ([include]s, +[module]s, ...) or pages. + {3 Simple Tags} The three tags without data are hints to the HTML renderer to do with [include]s. @@ -535,6 +538,8 @@ and other tags. Note that compared to ocamldoc, block tags do not extend to the end of the docstring. Instead, they are ended by a blank line, or a block that cannot be included in (a heading or another tag). +{4 Signature tags} + - [@deprecated ] - marks the element as deprecated. [text] should describe when the element was deprecated, what to use as a replacement, and possibly the reason for the deprecation. @@ -555,6 +560,25 @@ doesn't turn this into a link in the output HTML. (written between double quotes), with the given text as comment. {e Note:} As with the file reference, [odoc] doesn't turn this into a link. +{4 Page tags} + +These tags are the only tags that can be used on pages. + +- [@children_order ] - defines the order, in the sidebar, of the content + of a directory. It can only be used on [index.mld] pages. [] must be a + space-separated list of content. Pages are referred by filename, and modules + are prefixed with [module-]. Directories are suffixed with a [/]. Here is an + example: + {[ + @children_order content module-Unit dir1/ + ]} + +- [@toc_status ] determines the behaviour of the entry in the sidebar + and breadcrumbs. It can only be used on [index.mld] pages. [] can be + either [open] or [hidden]. If it is [open], the content of the directory will + always be displayed in the sidebar. If it is [hidden], it will be [opened] but + the directory entry, in the sidebar and breadcrumbs, will not be clickable. + {2:math Mathematics} [odoc] 2.2 introduced new markup for maths, available both for inline and block diff --git a/src/document/sidebar.ml b/src/document/sidebar.ml index 38895dceff..98eed7e9af 100644 --- a/src/document/sidebar.ml +++ b/src/document/sidebar.ml @@ -2,72 +2,54 @@ open Odoc_utils open Types module Id = Odoc_model.Paths.Identifier -type entry = Url.t option * Inline.one +type entry = { + url : Url.t; + valid_link : bool; + content : Inline.t; + toc_status : [ `Open | `Hidden ] option; +} + +open Odoc_index module Toc : sig type t = entry Tree.t - val of_page_hierarchy : Odoc_index.Page_hierarchy.t -> t - - val of_skeleton : Odoc_index.Skeleton.t -> t + val of_page_hierarchy : Skeleton.t -> t val to_block : prune:bool -> Url.Path.t -> t -> Block.t end = struct type t = entry Tree.t - let of_page_hierarchy (dir : Odoc_index.Page_hierarchy.t) : t = - let f index = - match index with - | Odoc_index.Page_hierarchy.Missing_index None -> - (None, inline @@ Text "Root") - | Odoc_index.Page_hierarchy.Missing_index (Some id) -> - let path = Url.from_identifier ~stop_before:false (id :> Id.t) in - (Some path, inline @@ Text (Id.name id)) - | Page (id, title) -> - let path = Url.from_identifier ~stop_before:false (id :> Id.t) in - let content = Comment.link_content title in - let target = Target.Internal (Target.Resolved path) in - let i = inline @@ Inline.Link { target; content; tooltip = None } in - (Some path, i) - in - Tree.map ~f dir - - let rec is_prefix (url1 : Url.Path.t) (url2 : Url.Path.t) = - if url1 = url2 then true - else - match url2 with - | { parent = Some parent; _ } -> is_prefix url1 parent - | { parent = None; _ } -> false - - let parent (url : Url.t) = - match url with - | { anchor = ""; page = { parent = Some parent; _ }; _ } -> parent - | { page; _ } -> page - - let to_block ~prune (current_url : Url.Path.t) (tree : t) = + let to_block ~prune:_ (current_url : Url.Path.t) (tree : t) = let block_tree_of_t (current_url : Url.Path.t) (tree : t) = (* When transforming the tree, we use a filter_map to remove the nodes that are irrelevant for the current url. However, we always want to keep the root. So we apply the filter_map starting from the first children. *) - let convert ((url : Url.t option), b) = + let convert_entry { url; valid_link; content; _ } = let link = - match url with - | Some url -> + if valid_link then + let target = Target.Internal (Target.Resolved url) in + let attr = if url.page = current_url && Astring.String.equal url.anchor "" - then { b with Inline.attr = [ "current_unit" ] } - else b - | None -> b + then [ "current_unit" ] + else [] + in + [ inline ~attr @@ Inline.Link { target; content; tooltip = None } ] + else content in - Types.block @@ Inline [ link ] + Types.block @@ Inline link in - let f name = - match name with - | Some url, _ when prune && not (is_prefix (parent url) current_url) -> - None - | v -> Some (convert v) + let rec convert n = + let children = + match n.Tree.node with + | { url; valid_link = true; toc_status = None; _ } + when not (Url.Path.is_prefix url.Url.Anchor.page current_url) -> + [] + | _ -> List.map convert n.children + in + { Tree.node = convert_entry n.node; children } in - let root_entry = convert tree.Tree.node in - { Tree.node = root_entry; children = Forest.filter_map ~f tree.children } + convert tree in let rec block_of_block_tree { Tree.node = name; children = content } = let content = @@ -82,27 +64,67 @@ end = struct let block_tree = block_tree_of_t current_url tree in block_of_block_tree block_tree - let of_skeleton ({ node = entry; children } : Odoc_index.Entry.t Tree.t) : t = + let of_page_hierarchy ({ node = entry; children } : Entry.t Tree.t) : t = let map_entry entry = - let stop_before = - match entry.Odoc_index.Entry.kind with - | ModuleType { has_expansion } | Module { has_expansion } -> - not has_expansion - | _ -> false - in - let name = Odoc_model.Paths.Identifier.name entry.id in - let path = Url.from_identifier ~stop_before entry.id in - let content = - let target = Target.Internal (Resolved path) in - inline - (Link { target; content = [ inline (Text name) ]; tooltip = None }) - in - (Some path, content) + match entry.Entry.kind with + | Dir -> + let url = Url.from_identifier ~stop_before:false (entry.id :> Id.t) in + { + url; + valid_link = false; + content = [ inline @@ Text (Id.name entry.id) ]; + toc_status = None; + } + | _ -> + let stop_before = + match entry.Entry.kind with + | ModuleType { has_expansion } | Module { has_expansion } -> + not has_expansion + | _ -> false + in + let url = Url.from_identifier ~stop_before (entry.id :> Id.t) in + let toc_status = + match entry.kind with + | Page { toc_status; _ } -> toc_status + | _ -> None + in + let content = + match entry.kind with + | Page { short_title = Some st; _ } -> Comment.link_content st + | Page { short_title = None; _ } -> + let title = + let open Odoc_model in + match Comment.find_zero_heading entry.doc with + | Some t -> t + | None -> + let name = + match entry.id.iv with + | `LeafPage (Some parent, name) + when Astring.String.equal + (Names.PageName.to_string name) + "index" -> + Id.name parent + | _ -> Id.name entry.id + in + Location_.[ at (span []) (`Word name) ] + in + Comment.link_content title + | _ -> + let name = Odoc_model.Paths.Identifier.name entry.id in + [ inline (Text name) ] + in + let valid_link = + match entry.kind with + | Page { toc_status = Some `Hidden; _ } -> false + | _ -> true + in + { url; content; toc_status; valid_link } in - let f entry = - match entry.Odoc_index.Entry.kind with - | Module _ | Class_type _ | Class _ | ModuleType _ -> - Some (map_entry entry) + let f x = + match x.Entry.kind with + | Dir | Page _ | Module _ | Class_type _ | Class _ | ModuleType _ | Impl + -> + Some (map_entry x) | _ -> None in let entry = map_entry entry in @@ -110,67 +132,10 @@ end = struct { Tree.node = entry; children } end -type pages = { name : string; pages : Toc.t } -type library = { name : string; units : Toc.t list } +type t = Toc.t list -type t = { pages : pages list; libraries : library list } - -let of_lang (v : Odoc_index.t) = - let { Odoc_index.pages; libs; extra = _ } = v in - let pages = - let page_hierarchy { Odoc_index.p_name; p_hierarchy } = - let hierarchy = Toc.of_page_hierarchy p_hierarchy in - { name = p_name; pages = hierarchy } - in - Odoc_utils.List.map page_hierarchy pages - in - let libraries = - let lib_hierarchies { Odoc_index.l_name; l_hierarchies } = - let hierarchies = List.map Toc.of_skeleton l_hierarchies in - { units = hierarchies; name = l_name } - in - Odoc_utils.List.map lib_hierarchies libs - in - { pages; libraries } +let of_index (v : Odoc_index.t) = List.map Toc.of_page_hierarchy v let to_block (sidebar : t) path = - let { pages; libraries } = sidebar in - let title t = block (Inline [ inline (Inline.Styled (`Bold, t)) ]) in - let pages = - let pages = - Odoc_utils.List.concat_map - ~f:(fun (p : pages) -> - let () = ignore p.name in - let pages = Toc.to_block ~prune:false path p.pages in - [ - block ~attr:[ "odoc-pages" ] - (Block.List (Block.Unordered, [ pages ])); - ]) - pages - in - [ title @@ [ inline (Inline.Text "Documentation") ] ] @ pages - in - let units = - let units = - List.map - (fun { units; name } -> - let units = - List.concat_map ~f:(Toc.to_block ~prune:true path) units - in - let units = [ block (Block.List (Block.Unordered, [ units ])) ] in - [ - title - @@ [ - inline (Inline.Text "Library "); - inline (Inline.Source [ Elt [ inline @@ Text name ] ]); - ]; - ] - @ units) - libraries - in - let units = - block ~attr:[ "odoc-modules" ] (Block.List (Block.Unordered, units)) - in - [ units ] - in - units @ pages + let sb = List.map (Toc.to_block ~prune:true path) sidebar in + [ block (Block.List (Block.Unordered, sb)) ] diff --git a/src/document/sidebar.mli b/src/document/sidebar.mli index c42e32ec5b..d5156a97ac 100644 --- a/src/document/sidebar.mli +++ b/src/document/sidebar.mli @@ -1,14 +1,16 @@ open Odoc_utils open Types -type entry = Url.t option * Inline.one +type entry = { + url : Url.t; + valid_link : bool; + content : Inline.t; + toc_status : [ `Open | `Hidden ] option; +} -type pages = { name : string; pages : entry Tree.t } -type library = { name : string; units : entry Tree.t list } +type t = entry Tree.forest -type t = { pages : pages list; libraries : library list } - -val of_lang : Odoc_index.t -> t +val of_index : Odoc_index.t -> t val to_block : t -> Url.Path.t -> Types.Block.t (** Generates the sidebar document given a global sidebar and the path at which 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/driver/cmd_outputs.ml b/src/driver/cmd_outputs.ml index 9541e9a8de..95b00d17f8 100644 --- a/src/driver/cmd_outputs.ml +++ b/src/driver/cmd_outputs.ml @@ -5,18 +5,17 @@ type log_dest = | `Count_occurrences | `Generate | `Index - | `Source_tree | `Sherlodoc | `Classify ] -let outputs : (log_dest * [ `Out | `Err ] * string * string) list ref = ref [] +type log_line = { log_dest : log_dest; prefix : string; run : Run.t } -let maybe_log log_dest r = +let outputs : log_line list ref = ref [] + +let maybe_log log_dest run = match log_dest with - | Some (dest, prefix) -> - let add ty s = outputs := !outputs @ [ (dest, ty, prefix, s) ] in - add `Out r.Run.output; - add `Err r.Run.errors + | Some (log_dest, prefix) -> + outputs := !outputs @ [ { log_dest; run; prefix } ] | None -> () let submit log_dest desc cmd output_file = diff --git a/src/driver/common_args.ml b/src/driver/common_args.ml index d58149c77c..f6565f5074 100644 --- a/src/driver/common_args.ml +++ b/src/driver/common_args.ml @@ -56,6 +56,10 @@ let remap = let doc = "Remap paths in non-selected packages to ocaml.org" in Arg.(value & flag & info [ "remap" ] ~doc) +let index_grep = + let doc = "Show compile-index commands containing the string" in + Arg.(value & opt (some string) None & info [ "index-grep" ] ~doc) + type t = { verbose : bool; odoc_dir : Fpath.t; @@ -70,6 +74,7 @@ type t = { link_grep : string option; generate_grep : string option; remap : bool; + index_grep : string option; } let term = @@ -88,6 +93,7 @@ let term = and+ compile_grep = compile_grep and+ link_grep = link_grep and+ generate_grep = generate_grep + and+ index_grep = index_grep and+ remap = remap in { verbose; @@ -103,4 +109,5 @@ let term = link_grep; generate_grep; remap; + index_grep; } diff --git a/src/driver/compile.ml b/src/driver/compile.ml index c26f20e285..482fd4a887 100644 --- a/src/driver/compile.ml +++ b/src/driver/compile.ml @@ -269,13 +269,10 @@ let html_generate ~occurrence_file ~remaps output_dir linked = let compile_index : Odoc_unit.index -> _ = fun index -> let compile_index_one - ({ pkg_args; output_file; json; search_dir = _; sidebar } as index : + ({ roots; output_file; json; search_dir = _; sidebar } as index : Odoc_unit.index) = - let libs_linked = Odoc_unit.Pkg_args.linked_libs pkg_args in - let pages_linked = Odoc_unit.Pkg_args.linked_pages pkg_args in let () = - Odoc.compile_index ~json ~occurrence_file ~output_file ~libs:libs_linked - ~docs:pages_linked () + Odoc.compile_index ~json ~occurrence_file ~output_file ~roots () in let sidebar = match sidebar with @@ -304,10 +301,18 @@ let html_generate ~occurrence_file ~remaps output_dir linked = match l.kind with | `Intf { hidden = true; _ } -> () | `Impl { src_path; _ } -> - Odoc.html_generate_source ~search_uris:[] ~output_dir ~input_file - ~source:src_path (); - Odoc.html_generate_source ~search_uris:[] ~output_dir ~input_file - ~source:src_path ~as_json:true (); + let search_uris, sidebar = + match l.index with + | None -> (None, None) + | Some index -> + let db_path, sidebar = compile_index index in + let search_uris = [ db_path; Sherlodoc.js_file ] in + (Some search_uris, sidebar) + in + Odoc.html_generate_source ?search_uris ?sidebar ~output_dir + ~input_file ~source:src_path (); + Odoc.html_generate_source ?search_uris ?sidebar ~output_dir + ~input_file ~source:src_path ~as_json:true (); Atomic.incr Stats.stats.generated_units | `Asset -> Odoc.html_generate_asset ~output_dir ~input_file:l.odoc_file diff --git a/src/driver/landing_pages.ml b/src/driver/landing_pages.ml index 45f35b5e5b..c07d389b52 100644 --- a/src/driver/landing_pages.ml +++ b/src/driver/landing_pages.ml @@ -1,18 +1,30 @@ open Odoc_unit +open Packages -let make_index ~dirs ~rel_dir ?index ~content () = +let fpf = Format.fprintf + +let make_index ~dirs ?pkg ~rel_dir ?index ~content () = + let pages, libs = + match pkg with + | None -> ([], []) + | Some pkg -> + let lib_args = + List.map (fun lib -> (lib.lib_name, lib_dir pkg lib)) pkg.libraries + in + ([ (pkg.name, doc_dir pkg) ], lib_args) + in let { odoc_dir; odocl_dir; mld_dir; _ } = dirs in let input_file = Fpath.(mld_dir // rel_dir / "index.mld") in let odoc_file = Fpath.(odoc_dir // rel_dir / "page-index.odoc") in let odocl_file = Fpath.(odocl_dir // rel_dir / "page-index.odocl") in let parent_id = rel_dir |> Odoc.Id.of_fpath in Util.with_out_to input_file (fun oc -> - Format.fprintf (Format.formatter_of_out_channel oc) "%t@?" content) + fpf (Format.formatter_of_out_channel oc) "%t@?" content) |> Result.get_ok; { output_dir = dirs.odoc_dir; pkgname = None; - pkg_args = { Pkg_args.pages = []; libs = []; odoc_dir; odocl_dir }; + pkg_args = { Pkg_args.pages; libs; odoc_dir; odocl_dir }; parent_id; input_file; odoc_file; @@ -23,36 +35,73 @@ let make_index ~dirs ~rel_dir ?index ~content () = index; } +let module_list ppf lib = + let modules = List.filter (fun m -> not m.m_hidden) lib.modules in + match modules with + | [] -> fpf ppf "No module." + | _ :: _ -> + let modules = + List.sort (fun m m' -> String.compare m.m_name m'.m_name) modules + in + fpf ppf "{!modules:"; + List.iter (fun m -> fpf ppf " %s" m.m_name) modules; + fpf ppf "}@\n" + let library ~dirs ~pkg ~index lib = let content ppf = - Format.fprintf ppf "{0 Library %s}@\n" lib.Packages.lib_name; - let print_module m = - if not m.Packages.m_hidden then - Format.fprintf ppf "- {!%s}@\n" m.Packages.m_name - in - List.iter print_module lib.modules + fpf ppf "%@toc_status hidden\n"; + fpf ppf "%@order_category libraries\n"; + fpf ppf "{0 Library [%s]}@\n" lib.lib_name; + fpf ppf "%a@\n" module_list lib in let rel_dir = lib_dir pkg lib in - make_index ~dirs ~rel_dir ~index ~content () + make_index ~dirs ~rel_dir ~pkg ~index ~content () let package ~dirs ~pkg ~index = - let content ppf = - Format.fprintf ppf "{0 %s}@\nUse sidebar to navigate." pkg.Packages.name + let library_list ppf pkg = + let print_lib lib = + fpf ppf "{2 Library %s}@\n%a@\n" lib.lib_name module_list lib + in + let libraries = + List.sort + (fun lib lib' -> String.compare lib.lib_name lib'.lib_name) + pkg.libraries + in + List.iter print_lib libraries + in + let content pkg ppf = + fpf ppf "{0 %s}@\n@\n@\n" pkg.name; + List.iter + (fun { mld_rel_path; _ } -> + let page = mld_rel_path |> Fpath.rem_ext |> Fpath.to_string in + fpf ppf "@\n{!/%s/doc/%s}@\n" pkg.name page) + pkg.mlds; + if not (List.is_empty pkg.libraries) then + fpf ppf "{1 API}@\n@\n%a@\n" library_list pkg in + let content = content pkg in let rel_dir = doc_dir pkg in + make_index ~dirs ~rel_dir ~index ~content ~pkg () + +let src ~dirs ~pkg ~index = + let content ppf = + fpf ppf "%@order_category source\n"; + fpf ppf + "{0 Sources}@\n\ + This contains the rendered source for [%s]. Use the sidebar to navigate \ + them." + pkg.name + in + let rel_dir = src_dir pkg in make_index ~dirs ~rel_dir ~index ~content () let package_list ~dirs all = let content all ppf = let sorted_packages = - all - |> List.sort (fun n1 n2 -> - String.compare n1.Packages.name n2.Packages.name) - in - Format.fprintf ppf "{0 List of all packages}@\n"; - let print_pkg pkg = - Format.fprintf ppf "- {{:%s/index.html}%s}@\n" pkg.Packages.name pkg.name + all |> List.sort (fun n1 n2 -> String.compare n1.name n2.name) in + fpf ppf "{0 List of all packages}@\n"; + let print_pkg pkg = fpf ppf "- {{:%s/index.html}%s}@\n" pkg.name pkg.name in List.iter print_pkg sorted_packages in let content = content all in diff --git a/src/driver/landing_pages.mli b/src/driver/landing_pages.mli index c50814c3c8..378ab6e731 100644 --- a/src/driver/landing_pages.mli +++ b/src/driver/landing_pages.mli @@ -5,4 +5,6 @@ val library : val package : dirs:dirs -> pkg:Packages.t -> index:index -> mld unit +val src : dirs:dirs -> pkg:Packages.t -> index:index -> mld unit + val package_list : dirs:dirs -> Packages.t list -> mld unit diff --git a/src/driver/odoc.ml b/src/driver/odoc.ml index 61980645bc..965a8471c2 100644 --- a/src/driver/odoc.ml +++ b/src/driver/odoc.ml @@ -159,9 +159,10 @@ let link ?(ignore_output = false) ~input_file:file ?output_file ~docs ~libs ignore @@ Cmd_outputs.submit log desc cmd (Some output_file) let compile_index ?(ignore_output = false) ~output_file ?occurrence_file ~json - ~docs ~libs () = - let docs = doc_args docs in - let libs = lib_args libs in + ~roots () = + let roots = + List.fold_left (fun c r -> Cmd.(c % "--root" % p r)) Cmd.empty roots + in let json = if json then Cmd.v "--json" else Cmd.empty in let occ = match occurrence_file with @@ -170,8 +171,7 @@ let compile_index ?(ignore_output = false) ~output_file ?occurrence_file ~json in let cmd = Cmd.( - !odoc % "compile-index" %% json %% v "-o" % p output_file %% docs %% libs - %% occ) + !odoc % "compile-index" %% json %% v "-o" % p output_file %% roots %% occ) in let desc = Printf.sprintf "Generating index for %s" (Fpath.to_string output_file) @@ -208,7 +208,8 @@ let html_generate ~output_dir ?sidebar ?(ignore_output = false) empty search_uris in let cmd = - !odoc % "html-generate" % p file %% index %% search_uris % "-o" % output_dir + !odoc % "html-generate" % "--escape-breadcrumb" % p file %% index + %% search_uris % "-o" % output_dir in let cmd = match remap with None -> cmd | Some f -> cmd % "--remap-file" % p f @@ -233,18 +234,21 @@ let html_generate_asset ~output_dir ?(ignore_output = false) ~input_file:file in ignore @@ Cmd_outputs.submit log desc cmd None -let html_generate_source ~output_dir ?(ignore_output = false) ~source +let html_generate_source ~output_dir ?(ignore_output = false) ~source ?sidebar ?(search_uris = []) ?(as_json = false) ~input_file:file () = let open Cmd in let file = v "--impl" % p file in + let sidebar = + match sidebar with None -> empty | Some idx -> v "--sidebar" % p idx + in let search_uris = List.fold_left (fun acc filename -> acc % "--search-uri" % p filename) empty search_uris in let cmd = - !odoc % "html-generate-source" %% file % p source %% search_uris % "-o" - % output_dir + !odoc % "html-generate-source" %% file %% sidebar % p source %% search_uris + % "-o" % output_dir in let cmd = if as_json then cmd % "--as-json" else cmd in @@ -269,18 +273,6 @@ let count_occurrences ~input ~output = let log = Some (`Count_occurrences, Fpath.to_string output) in ignore @@ Cmd_outputs.submit log desc cmd None -let source_tree ?(ignore_output = false) ~parent ~output file = - let open Cmd in - let parent = v "--parent" % ("page-\"" ^ parent ^ "\"") in - let cmd = - !odoc % "source-tree" % "-I" % "." %% parent % "-o" % p output % p file - in - let desc = Printf.sprintf "Source tree for %s" (Fpath.to_string file) in - let log = - if ignore_output then None else Some (`Source_tree, Fpath.to_string file) - in - ignore @@ Cmd_outputs.submit log desc cmd None - let classify dirs = let open Cmd in let cmd = List.fold_left (fun cmd d -> cmd % p d) (!odoc % "classify") dirs in diff --git a/src/driver/odoc.mli b/src/driver/odoc.mli index 4b62f65106..11e769b9a9 100644 --- a/src/driver/odoc.mli +++ b/src/driver/odoc.mli @@ -46,8 +46,7 @@ val compile_index : output_file:Fpath.t -> ?occurrence_file:Fpath.t -> json:bool -> - docs:(string * Fpath.t) list -> - libs:(string * Fpath.t) list -> + roots:Fpath.t list -> unit -> unit @@ -82,6 +81,7 @@ val html_generate_source : output_dir:string -> ?ignore_output:bool -> source:Fpath.t -> + ?sidebar:Fpath.t -> ?search_uris:Fpath.t list -> ?as_json:bool -> input_file:Fpath.t -> @@ -91,5 +91,3 @@ val html_generate_source : val support_files : Fpath.t -> string list val count_occurrences : input:Fpath.t list -> output:Fpath.t -> unit -val source_tree : - ?ignore_output:bool -> parent:string -> output:Fpath.t -> Fpath.t -> unit diff --git a/src/driver/odoc_driver.ml b/src/driver/odoc_driver.ml index bb0f21cda8..74d7496248 100644 --- a/src/driver/odoc_driver.ml +++ b/src/driver/odoc_driver.ml @@ -134,6 +134,7 @@ let run mode link_grep; generate_grep; remap; + index_grep; } = Option.iter (fun odoc_bin -> Odoc.odoc := Bos.Cmd.v odoc_bin) odoc_bin; let _ = Voodoo.find_universe_and_version "foo" in @@ -249,30 +250,37 @@ let run mode let grep_log ty s = let open Astring in let do_ affix = - let grep (dst, _err, prefix, content) = - if dst = ty then - let lines = String.cuts ~sep:"\n" content in - List.iter - (fun l -> - if String.is_infix ~affix l then Format.printf "%s: %s\n" prefix l) - lines + let grep { Cmd_outputs.log_dest; prefix; run } = + if log_dest = ty then + let l = run.Run.cmd |> String.concat ~sep:" " in + if String.is_infix ~affix l then Format.printf "%s: %s\n" prefix l in List.iter grep !Cmd_outputs.outputs in Option.iter do_ s in + (* Grep log compile and compile_src commands *) grep_log `Compile compile_grep; + grep_log `Compile_src compile_grep; + (* Grep log link commands *) grep_log `Link link_grep; + (* Grep log generate commands *) grep_log `Generate generate_grep; + (* Grep log index and co commands *) + grep_log `Count_occurrences index_grep; + grep_log `Count_occurrences index_grep; + grep_log `Index index_grep; List.iter - (fun (dst, _err, prefix, content) -> - match dst with + (fun { Cmd_outputs.log_dest; prefix; run } -> + match log_dest with | `Link -> - if String.length content = 0 then () - else - let lines = String.split_on_char '\n' content in - List.iter (fun l -> Format.printf "%s: %s\n" prefix l) lines + [ run.Run.output; run.Run.errors ] + |> List.iter @@ fun content -> + if String.length content = 0 then () + else + let lines = String.split_on_char '\n' content in + List.iter (fun l -> Format.printf "%s: %s\n" prefix l) lines | _ -> ()) !Cmd_outputs.outputs; diff --git a/src/driver/odoc_unit.ml b/src/driver/odoc_unit.ml index ad5d0735f0..bb47b86dc5 100644 --- a/src/driver/odoc_unit.ml +++ b/src/driver/odoc_unit.ml @@ -39,7 +39,7 @@ end type sidebar = { output_file : Fpath.t; json : bool } type index = { - pkg_args : Pkg_args.t; + roots : Fpath.t list; output_file : Fpath.t; json : bool; search_dir : Fpath.t; @@ -48,8 +48,9 @@ type index = { let pp_index fmt x = Format.fprintf fmt - "@[pkg_args: %a@;output_file: %a@;json: %b@;search_dir: %a@]" - Pkg_args.pp x.pkg_args Fpath.pp x.output_file x.json Fpath.pp x.search_dir + "@[roots: %a@;output_file: %a@;json: %b@;search_dir: %a@]" + (Fmt.list Fpath.pp) x.roots Fpath.pp x.output_file x.json Fpath.pp + x.search_dir type 'a unit = { parent_id : Odoc.Id.t; @@ -119,6 +120,8 @@ and pp : all_kinds unit Fmt.t = let doc_dir pkg = pkg.Packages.pkg_dir let lib_dir pkg lib = Fpath.(pkg.Packages.pkg_dir / lib.Packages.lib_name) +let src_dir pkg = Fpath.(pkg.Packages.pkg_dir / "src") +let src_lib_dir pkg lib = Fpath.(src_dir pkg / lib.Packages.lib_name) type dirs = { odoc_dir : Fpath.t; diff --git a/src/driver/odoc_unit.mli b/src/driver/odoc_unit.mli index 1717166af4..1f9d505c58 100644 --- a/src/driver/odoc_unit.mli +++ b/src/driver/odoc_unit.mli @@ -18,7 +18,7 @@ end type sidebar = { output_file : Fpath.t; json : bool } type index = { - pkg_args : Pkg_args.t; + roots : Fpath.t list; output_file : Fpath.t; json : bool; search_dir : Fpath.t; @@ -55,6 +55,8 @@ val pp : t Fmt.t val lib_dir : Packages.t -> Packages.libty -> Fpath.t val doc_dir : Packages.t -> Fpath.t +val src_lib_dir : Packages.t -> Packages.libty -> Fpath.t +val src_dir : Packages.t -> Fpath.t type dirs = { odoc_dir : Fpath.t; diff --git a/src/driver/odoc_units_of.ml b/src/driver/odoc_units_of.ml index e572b1846c..df21fada32 100644 --- a/src/driver/odoc_units_of.ml +++ b/src/driver/odoc_units_of.ml @@ -78,18 +78,14 @@ let packages ~dirs ~extra_paths ~remap (pkgs : Packages.t list) : t list = in let index_of pkg = - let pkg_libs = - List.map (fun l -> l.Packages.lib_name) pkg.Packages.libraries - |> Util.StringSet.of_list - in - let pkg_args = base_args pkg pkg_libs in + let roots = [ Fpath.( // ) odocl_dir (doc_dir pkg) ] in let output_file = Fpath.(index_dir / pkg.name / Odoc.index_filename) in let sidebar = let output_file = Fpath.(index_dir / pkg.name / Odoc.sidebar_filename) in { output_file; json = false } in { - pkg_args; + roots; output_file; json = false; search_dir = pkg.pkg_dir; @@ -172,8 +168,7 @@ let packages ~dirs ~extra_paths ~remap (pkgs : Packages.t list) : t list = let kind = let src_name = Fpath.filename src_path in let src_id = - Fpath.(pkg.pkg_dir / "src" / lib.lib_name / src_name) - |> Odoc.Id.of_fpath + Fpath.(src_lib_dir pkg lib / src_name) |> Odoc.Id.of_fpath in `Impl { src_id; src_path } in @@ -198,13 +193,11 @@ let packages ~dirs ~extra_paths ~remap (pkgs : Packages.t list) : t list = in let of_lib pkg (lib : Packages.libty) = let lib_deps = Util.StringSet.add lib.lib_name lib.lib_deps in - let landing_page :> t list = - if pkg.Packages.selected then - let index = index_of pkg in - [ Landing_pages.library ~dirs ~pkg ~index lib ] - else [] + let landing_page :> t = + let index = index_of pkg in + Landing_pages.library ~dirs ~pkg ~index lib in - landing_page @ List.concat_map (of_module pkg lib lib_deps) lib.modules + landing_page :: List.concat_map (of_module pkg lib lib_deps) lib.modules in let of_mld pkg (mld : Packages.mld) : mld unit list = let open Fpath in @@ -269,12 +262,31 @@ let packages ~dirs ~extra_paths ~remap (pkgs : Packages.t list) : t list = (Fpath.normalize (Fpath.v "./index.mld"))) pkg.mlds in - if has_index_page || not pkg.selected then [] + if has_index_page then [] else let index = index_of pkg in [ Landing_pages.package ~dirs ~pkg ~index ] in - List.concat ((pkg_index :: lib_units) @ mld_units @ asset_units @ md_units) + let src_index :> t list = + if + (* Some library has a module which has an implementation which has a source *) + List.exists + (fun lib -> + List.exists + (fun m -> + match m.Packages.m_impl with + | Some { mip_src_info = Some _; _ } -> true + | _ -> false) + lib.Packages.modules) + pkg.libraries + then + let index = index_of pkg in + [ Landing_pages.src ~dirs ~pkg ~index ] + else [] + in + List.concat + ((pkg_index :: src_index :: lib_units) + @ mld_units @ asset_units @ md_units) in let pkg_list :> t = Landing_pages.package_list ~dirs pkgs in diff --git a/src/driver/packages.ml b/src/driver/packages.ml index 6c05b0c0c8..9217c94d19 100644 --- a/src/driver/packages.ml +++ b/src/driver/packages.ml @@ -397,15 +397,6 @@ let of_libs ~packages_dir libs = opam_map in let mlds, assets = mk_mlds docs in - let other_docs = - List.filter_map - (function - | { Opam.kind = `Other; file; _ } -> Some file - | _ -> None) - docs - |> Fpath.Set.of_list - in - let other_docs = Fpath.Set.elements other_docs in Some { name = pkg.name; @@ -415,7 +406,7 @@ let of_libs ~packages_dir libs = assets; selected = false; remaps = []; - other_docs; + other_docs = []; pkg_dir; config; }) @@ -465,13 +456,6 @@ let of_packages ~packages_dir packages = let pkg_dir = pkg_dir packages_dir pkg.name in let config = Global_config.load pkg.name in let mlds, assets = mk_mlds files.docs in - let other_docs = - List.filter_map - (function - | { Opam.kind = `Other; file; _ } -> Some file | _ -> None) - files.docs - |> Fpath.Set.of_list - in let selected = List.mem pkg.name packages in let remaps = if selected then [] @@ -494,7 +478,6 @@ let of_packages ~packages_dir packages = in (local_pkg_path, pkg_path) :: lib_paths in - let other_docs = Fpath.Set.elements other_docs in Util.StringMap.add pkg.name { name = pkg.name; @@ -504,7 +487,7 @@ let of_packages ~packages_dir packages = assets; selected; remaps; - other_docs; + other_docs = []; pkg_dir; config; } diff --git a/src/driver/run.ml b/src/driver/run.ml index ea1c13a26d..6749157971 100644 --- a/src/driver/run.ml +++ b/src/driver/run.ml @@ -68,8 +68,12 @@ let run env cmd output_file = Logs.err (fun m -> m "%d - Process exitted %d: stderr=%s" myn n err); failwith "Error" | `Signaled n -> - Logs.err (fun m -> m "%d - Signalled %d: stderr=%s" myn n err); - failwith ("Signaled " ^ string_of_int n) + let err = + Format.sprintf "Error from %s\n%d - Signalled %d: stderr=%s" + (String.concat " " cmd) myn n err + in + Logs.err (fun m -> m "%s" err); + failwith err with Eio.Exn.Io _ as ex -> let bt = Printexc.get_raw_backtrace () in Eio.Exn.reraise_with_context ex bt "%d - running command: %a" myn diff --git a/src/html/config.ml b/src/html/config.ml index 587f84298a..e953348a2a 100644 --- a/src/html/config.ml +++ b/src/html/config.ml @@ -12,10 +12,12 @@ type t = { flat : bool; open_details : bool; as_json : bool; + home_breadcrumb : bool; } let v ?(search_result = false) ?theme_uri ?support_uri ?(search_uris = []) - ~semantic_uris ~indent ~flat ~open_details ~as_json ~remap () = + ~semantic_uris ~indent ~flat ~open_details ~as_json ~remap + ?(home_breadcrumb = true) () = { semantic_uris; indent; @@ -27,6 +29,7 @@ let v ?(search_result = false) ?theme_uri ?support_uri ?(search_uris = []) as_json; search_result; remap; + home_breadcrumb; } let theme_uri config : Types.uri = @@ -50,3 +53,5 @@ let as_json config = config.as_json let search_result config = config.search_result let remap config = config.remap + +let home_breadcrumb config = config.home_breadcrumb diff --git a/src/html/config.mli b/src/html/config.mli index 493833410f..e0ecacfce0 100644 --- a/src/html/config.mli +++ b/src/html/config.mli @@ -13,6 +13,7 @@ val v : open_details:bool -> as_json:bool -> remap:(string * string) list -> + ?home_breadcrumb:bool -> unit -> t (** [search_result] indicates whether this is a summary for a search result. In @@ -37,3 +38,5 @@ val as_json : t -> bool val search_result : t -> bool val remap : t -> (string * string) list + +val home_breadcrumb : t -> bool diff --git a/src/html/generator.ml b/src/html/generator.ml index 2eaf198a65..5a555b45f5 100644 --- a/src/html/generator.ml +++ b/src/html/generator.ml @@ -13,6 +13,8 @@ * 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 @@ -85,7 +87,7 @@ and source k ?a (t : Source.t) = if content = [] then [] else [ Html.span content ] | Tag (Some s, l) -> [ Html.span ~a:[ Html.a_class [ s ] ] (tokens l) ] and tokens t = Odoc_utils.List.concat_map t ~f:token in - Utils.optional_elt Html.code ?a (tokens t) + match tokens t with [] -> [] | l -> [ Html.code ?a l ] and styled style ~emph_level = match style with @@ -498,24 +500,133 @@ 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 page_parent (page : Url.Path.t) = + let page = + match page with + | { parent = Some parent; name = "index"; kind = `LeafPage } -> parent + | _ -> page + in + match page with + | { parent = None; name = "index"; kind = `LeafPage } -> None + | { parent = Some parent; _ } -> Some parent + | { parent = None; _ } -> + Some { Url.Path.parent = None; name = "index"; kind = `LeafPage } + + let home_breadcrumb config current_url parent = + let href = + Some + (Link.href ~config ~resolve:(Current current_url) + (Odoc_document.Url.from_path parent)) + in + { href; name = [ Html.txt "🏠" ]; kind = `LeafPage } + + let gen_breadcrumbs_no_sidebar ~config ~url = + let url = + match url with + | { Url.Path.name = "index"; parent = Some parent; kind = `LeafPage } -> + parent + | _ -> url + in + match url with + | { Url.Path.name = "index"; parent = None; kind = `LeafPage } -> + let kind = `LeafPage in + let current = { href = None; name = [ Html.txt "" ]; kind } in + { parents = []; up_url = None; current } + | url -> ( + (* This is the pre 3.0 way of computing the breadcrumbs *) + 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) + in + let to_breadcrumb path = + let href = + Some + (Link.href ~config ~resolve:(Current url) + (Odoc_document.Url.from_path path)) + in + { href; name = [ Html.txt path.name ]; kind = path.kind } + in + let parent_paths = + get_parent_paths (List.rev (Odoc_document.Url.Path.to_list url)) + |> List.rev + in + match List.rev parent_paths with + | [] -> assert false + | current :: parents -> + let up_url = + match page_parent current with + | None -> None + | Some up -> + Some + (Link.href ~config ~resolve:(Current url) + (Odoc_document.Url.from_path up)) + in + let current = to_breadcrumb current in + let parents = List.map to_breadcrumb parents |> List.rev in + let home = + home_breadcrumb config url + { Url.Path.name = "index"; parent = None; kind = `LeafPage } + in + { current; parents = home :: parents; up_url }) + + let gen_breadcrumbs_with_sidebar ~config ~sidebar ~url:current_url = + let find_parent = + List.find_opt (function + | ({ node = { url = { page; anchor = ""; _ }; _ }; _ } : + Odoc_document.Sidebar.entry Odoc_utils.Tree.t) + when Url.Path.is_prefix page current_url -> + true + | _ -> false) in - let to_breadcrumb path = - let href = - Link.href ~config ~resolve:(Current url) - (Odoc_document.Url.from_path path) + let rec extract acc (tree : Odoc_document.Sidebar.t) = + let parent = + match find_parent tree with + | Some { node = { url; valid_link; content; _ }; children } -> + let href = + if valid_link then + Some (Link.href ~config ~resolve:(Current current_url) url) + else None + in + let name = inline_nolink content in + let breadcrumb = { href; name; kind = url.page.kind } in + if url.page = current_url then Some (`Current breadcrumb) + else Some (`Parent (breadcrumb, children)) + | _ -> None in - { href; name = path.name; kind = path.kind } + match parent with + | Some (`Parent (bc, children)) -> extract (bc :: acc) children + | Some (`Current current) -> + let up_url = + List.find_map (fun (b : Types.breadcrumb) -> b.href) acc + in + { Types.current; parents = List.rev acc; up_url } + | None -> + let kind = current_url.kind and name = current_url.name in + let current = { href = None; name = [ Html.txt name ]; kind } in + let up_url = + List.find_map (fun (b : Types.breadcrumb) -> b.href) acc + in + let parents = List.rev acc in + { Types.current; parents; up_url } + in + let escape = + match (Config.home_breadcrumb config, find_parent sidebar) with + | true, Some { node; _ } -> ( + match page_parent node.url.page with + | None -> [] + | Some parent -> [ home_breadcrumb config parent current_url ]) + | _ -> [] in - get_parent_paths (List.rev (Odoc_document.Url.Path.to_list url)) - |> List.rev |> List.map to_breadcrumb + extract escape sidebar + + let gen_breadcrumbs ~config ~sidebar ~url = + match sidebar with + | None -> gen_breadcrumbs_no_sidebar ~config ~url + | Some sidebar -> gen_breadcrumbs_with_sidebar ~config ~sidebar ~url end module Page = struct @@ -538,6 +649,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 +660,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 = @@ -567,23 +678,32 @@ 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 ~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 + | Some sidebar -> + let sidebar = Odoc_document.Sidebar.to_block sidebar url in + (Some (block ~config ~resolve sidebar) :> any Html.elt list option) + 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 if Config.as_json config then - Html_fragment_json.make_src ~config ~url ~breadcrumbs [ doc ] - else Html_page.make_src ~breadcrumbs ~header ~config ~url title [ doc ] + Html_fragment_json.make_src ~config ~url ~breadcrumbs ~sidebar [ doc ] + else + Html_page.make_src ~breadcrumbs ~header ~config ~url ~sidebar title + [ doc ] end let render ~config ~sidebar = function | Document.Page page -> [ Page.page ~config ~sidebar page ] - | Source_page src -> [ Page.source_page ~config src ] + | Source_page src -> [ Page.source_page ~config ~sidebar src ] let filepath ~config url = Link.Path.as_filename ~config url diff --git a/src/html/html_fragment_json.ml b/src/html/html_fragment_json.ml index 3fe6a9bdbb..0fc2fdd4f9 100644 --- a/src/html/html_fragment_json.ml +++ b/src/html/html_fragment_json.ml @@ -6,16 +6,22 @@ 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.breadcrumbs) : 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 - let json_breadcrumbs = breadcrumbs |> List.map breadcrumb in + let json_breadcrumbs = + breadcrumbs.parents @ [ breadcrumbs.current ] |> List.map breadcrumb + in `Array json_breadcrumbs let json_of_toc (toc : Types.toc list) : Json.json = @@ -30,6 +36,11 @@ 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_sidebar config sidebar = + match sidebar with + | None -> `Null + | Some sidebar -> `String (json_of_html config sidebar) + let make ~config ~preamble ~url ~breadcrumbs ~sidebar ~toc ~uses_katex ~source_anchor content children = let filename = Link.Path.as_filename ~config url in @@ -38,15 +49,7 @@ let make ~config ~preamble ~url ~breadcrumbs ~sidebar ~toc ~uses_katex let source_anchor = match source_anchor with Some url -> `String url | None -> `Null in - let json_of_html h = - let htmlpp = Html.pp_elt ~indent:(Config.indent config) () in - String.concat "" (List.map (Format.asprintf "%a" htmlpp) h) - in - let global_toc = - match sidebar with - | None -> `Null - | Some sidebar -> `String (json_of_html sidebar) - in + let global_toc = json_of_sidebar config sidebar in let content ppf = Format.pp_print_string ppf (json_to_string @@ -54,28 +57,30 @@ 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); - ("preamble", `String (json_of_html preamble)); - ("content", `String (json_of_html content)); + ("preamble", `String (json_of_html config preamble)); + ("content", `String (json_of_html config content)); ])) in { Odoc_document.Renderer.filename; content; children; path = url } -let make_src ~config ~url ~breadcrumbs content = +let make_src ~config ~url ~breadcrumbs ~sidebar content = let filename = Link.Path.as_filename ~config url in let filename = Fpath.add_ext ".json" filename in let htmlpp = Html.pp_elt ~indent:(Config.indent config) () in let json_to_string json = Json.to_string json in + let global_toc = json_of_sidebar config sidebar in let content ppf = Format.pp_print_string ppf (json_to_string (`Object [ ("type", `String "source"); - ("breadcrumbs", json_of_breadcrumbs breadcrumbs); + ("breadcrumbs", json_of_breadcrumbs config breadcrumbs); + ("global_toc", global_toc); ( "content", `String (String.concat "" diff --git a/src/html/html_fragment_json.mli b/src/html/html_fragment_json.mli index eda81b53c0..bfedee616b 100644 --- a/src/html/html_fragment_json.mli +++ b/src/html/html_fragment_json.mli @@ -4,7 +4,7 @@ val make : config:Config.t -> preamble:Html_types.div_content Html.elt list -> url:Odoc_document.Url.Path.t -> - breadcrumbs:Types.breadcrumb list -> + breadcrumbs:Types.breadcrumbs -> sidebar:Html_types.div_content Html.elt list option -> toc:Types.toc list -> uses_katex:bool -> @@ -16,6 +16,7 @@ val make : val make_src : config:Config.t -> url:Odoc_document.Url.Path.t -> - breadcrumbs:Types.breadcrumb list -> + breadcrumbs:Types.breadcrumbs -> + sidebar:Html_types.div_content Html.elt list option -> Html_types.div_content Html.elt list -> Odoc_document.Renderer.page diff --git a/src/html/html_page.ml b/src/html/html_page.ml index 54f02f727d..4de996913c 100644 --- a/src/html/html_page.ml +++ b/src/html/html_page.ml @@ -14,6 +14,8 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) +open Odoc_utils + module Url = Odoc_document.Url module Html = Tyxml.Html @@ -62,44 +64,46 @@ let sidebars ~global_toc ~local_toc = | [] -> [] | tocs -> [ Html.div ~a:[ Html.a_class [ "odoc-tocs" ] ] tocs ] -let html_of_breadcrumbs (breadcrumbs : Types.breadcrumb list) = +let html_of_breadcrumbs (breadcrumbs : Types.breadcrumbs) = 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 -> - let space = Html.txt " " in - let sep = [ space; Html.entity "#x00BB"; space ] in - let html = - (* Create breadcrumbs *) - Odoc_utils.List.concat_map ?sep:(Some sep) - ~f:(fun (breadcrumb : Types.breadcrumb) -> + let space = Html.txt " " in + let sep = [ space; Html.entity "#x00BB"; space ] in + let html = + (* Create breadcrumbs *) + Odoc_utils.List.concat_map ~sep + ~f:(fun (breadcrumb : Types.breadcrumb) -> + match breadcrumb.href with + | Some href -> [ [ Html.a - ~a:[ Html.a_href breadcrumb.href ] - [ Html.txt breadcrumb.name ]; + ~a:[ Html.a_href href ] + (breadcrumb.name + :> Html_types.flow5_without_interactive Html.elt list); ]; - ]) - (up :: bs) - |> List.flatten - in - make_navigation ~up_url:up.href - (List.rev html @ sep @ [ Html.txt current.name ]) + ] + | None -> + [ (breadcrumb.name :> Html_types.nav_content_fun Html.elt list) ]) + breadcrumbs.parents + |> List.flatten + in + let current_name :> Html_types.nav_content_fun Html.elt list = + breadcrumbs.current.name + in + let rest = + if List.is_empty breadcrumbs.parents then current_name + else html @ sep @ current_name + in + make_navigation ~up_url:breadcrumbs.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 @@ -258,7 +262,7 @@ let path_of_module_of_source ppf url = Format.fprintf ppf " (%s)" (String.concat "." path) | None -> () -let src_page_creator ~breadcrumbs ~config ~url ~header name content = +let src_page_creator ~breadcrumbs ~config ~url ~header ~sidebar name content = let head : Html_types.head Html.elt = let title_string = Format.asprintf "Source: %s%a" name path_of_module_of_source url @@ -269,6 +273,7 @@ let src_page_creator ~breadcrumbs ~config ~url ~header name content = let body = html_of_breadcrumbs breadcrumbs @ [ Html.header ~a:[ Html.a_class [ "odoc-preamble" ] ] header ] + @ sidebars ~global_toc:sidebar ~local_toc:[] @ content in (* We never indent as there is a bug in tyxml and it would break lines inside @@ -284,9 +289,9 @@ let src_page_creator ~breadcrumbs ~config ~url ~header name content = in content -let make_src ~config ~url ~breadcrumbs ~header title content = +let make_src ~config ~url ~breadcrumbs ~header ~sidebar title content = let filename = Link.Path.as_filename ~config url in let content = - src_page_creator ~breadcrumbs ~config ~url ~header title content + src_page_creator ~breadcrumbs ~config ~url ~header ~sidebar title content in { Odoc_document.Renderer.filename; content; children = []; path = url } diff --git a/src/html/html_page.mli b/src/html/html_page.mli index b085675793..f8397499a1 100644 --- a/src/html/html_page.mli +++ b/src/html/html_page.mli @@ -24,7 +24,7 @@ val make : config:Config.t -> url:Odoc_document.Url.Path.t -> header:Html_types.flow5_without_header_footer Html.elt list -> - breadcrumbs:Types.breadcrumb list -> + breadcrumbs:Types.breadcrumbs -> sidebar:Html_types.div_content Html.elt list option -> toc:Types.toc list -> uses_katex:bool -> @@ -38,8 +38,9 @@ val make : val make_src : config:Config.t -> url:Odoc_document.Url.Path.t -> - breadcrumbs:Types.breadcrumb list -> + breadcrumbs:Types.breadcrumbs -> header:Html_types.flow5_without_header_footer Html.elt list -> + sidebar:Html_types.div_content Html.elt list option -> string -> Html_types.div_content Html.elt list -> Odoc_document.Renderer.page diff --git a/src/html/sidebar.ml b/src/html/sidebar.ml index 8ae7f99af2..63f734039e 100644 --- a/src/html/sidebar.ml +++ b/src/html/sidebar.ml @@ -1,14 +1,16 @@ open Odoc_utils -let toc_to_json ((url, inline) : Odoc_document.Sidebar.entry) : Json.json = +let toc_to_json + ({ url; valid_link; content = inline; _ } : Odoc_document.Sidebar.entry) : + Json.json = let config = 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 = Link.href ~config ~resolve:(Link.Base "") url in let kind = Format.asprintf "%a" Odoc_document.Url.Anchor.pp_kind url.kind @@ -17,7 +19,7 @@ let toc_to_json ((url, inline) : Odoc_document.Sidebar.entry) : Json.json = (`String href, `String kind) in let inline = - let inline = Generator.inline ~config ~xref_base_uri:"" [ inline ] in + let inline = Generator.inline ~config ~xref_base_uri:"" inline in let inline = String.concat "" @@ List.map (Format.asprintf "%a" (Tyxml.Html.pp_elt ())) inline @@ -26,17 +28,5 @@ let toc_to_json ((url, inline) : Odoc_document.Sidebar.entry) : Json.json = in `Object [ ("url", url); ("kind", kind); ("content", inline) ] -let pages_to_json ({ name; pages } : Odoc_document.Sidebar.pages) = - `Object [ ("name", `String name); ("pages", Tree.to_json toc_to_json pages) ] - -let libs_to_json ({ name; units } : Odoc_document.Sidebar.library) = - `Object - [ - ("name", `String name); - ("modules", `Array (List.map (Tree.to_json toc_to_json) units)); - ] - -let to_json ({ pages; libraries } : Odoc_document.Sidebar.t) = - let pages = List.map pages_to_json pages in - let libraries = List.map libs_to_json libraries in - `Object [ ("pages", `Array pages); ("libraries", `Array libraries) ] +let to_json (sidebar : Odoc_document.Sidebar.t) = + `Array (List.map (Tree.to_json toc_to_json) sidebar) diff --git a/src/html/types.ml b/src/html/types.ml index 31e7801c3c..73699470f6 100644 --- a/src/html/types.ml +++ b/src/html/types.ml @@ -12,7 +12,13 @@ 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; } + +type breadcrumbs = { + parents : breadcrumb list; + current : breadcrumb; + up_url : string option; +} diff --git a/src/html/utils.ml b/src/html/utils.ml deleted file mode 100644 index c575214450..0000000000 --- a/src/html/utils.ml +++ /dev/null @@ -1,3 +0,0 @@ -(* Shared utility functions *) - -let optional_elt f ?a = function [] -> [] | l -> [ f ?a l ] diff --git a/src/html_support_files/odoc.css b/src/html_support_files/odoc.css index f9a207132c..2f0dd6c741 100644 --- a/src/html_support_files/odoc.css +++ b/src/html_support_files/odoc.css @@ -297,7 +297,7 @@ body { } body.odoc { - max-width: 160ex; + max-width: 181ex; display: grid; grid-template-columns: min-content 1fr min-content; grid-template-areas: @@ -340,7 +340,14 @@ nav.odoc-nav:has(+ .odoc-search:focus-within) { } body.odoc-src { - margin-right: calc(10vw + 20ex); + display: grid; + grid-template-columns: min-content 1fr; + grid-template-areas: + "search-bar nav " + "toc-global preamble" + "toc-global content "; + column-gap: 4ex; + grid-template-rows: auto auto 1fr; } .odoc-content { @@ -886,7 +893,7 @@ body.odoc:has( .odoc-search) .odoc-toc { .odoc-toc { --toc-top: 20px; - width: 28ex; + width: 42ex; background: var(--toc-background); overflow: auto; color: var(--toc-color); @@ -909,6 +916,32 @@ body.odoc:has( .odoc-search) .odoc-toc { display: block; } +.odoc-toc.odoc-global-toc > ul > li { + margin-left:0; +} + +.odoc-toc.odoc-global-toc > ul > li > ul > li { + margin-left:0; + padding-left:0; + border: 0; + margin-top: 10px; + margin-bottom: 10px; +} + +.odoc-toc.odoc-global-toc > ul > li > ul > li { + font-weight: 500; + font-size: 500; +} + +.odoc-toc.odoc-global-toc > ul > li > ul > li > a { + font-weight: inherit; + font-size: inherit; +} + +.odoc-toc.odoc-global-toc > ul > li > a { + font-size: 2em; +} + .current_unit { background-color: var(--anchor-color); } @@ -1341,6 +1374,7 @@ body.odoc:has( .odoc-search) .odoc-toc { .source_container { display: flex; + grid-area: content; } .source_line_column { diff --git a/src/index/entry.ml b/src/index/entry.ml index 601af8daf5..fb746e920b 100644 --- a/src/index/entry.ml +++ b/src/index/entry.ml @@ -56,6 +56,9 @@ type kind = | ModuleType of module_entry | Constructor of constructor_entry | Field of field_entry + | Page of Odoc_model.Frontmatter.t + | Impl + | Dir type t = { id : Odoc_model.Paths.Identifier.Any.t; diff --git a/src/index/entry.mli b/src/index/entry.mli index 198c8fc68e..bd51cf742e 100644 --- a/src/index/entry.mli +++ b/src/index/entry.mli @@ -54,6 +54,9 @@ type kind = | ModuleType of module_entry | Constructor of constructor_entry | Field of field_entry + | Page of Odoc_model.Frontmatter.t + | Impl + | Dir type t = { id : Odoc_model.Paths.Identifier.Any.t; diff --git a/src/index/in_progress.ml b/src/index/in_progress.ml new file mode 100644 index 0000000000..6946bd78a2 --- /dev/null +++ b/src/index/in_progress.ml @@ -0,0 +1,113 @@ +open Odoc_model + +module Id = Odoc_model.Paths.Identifier +module PageName = Odoc_model.Names.PageName + +module CPH = Id.Hashtbl.ContainerPage +module LPH = Id.Hashtbl.LeafPage +module RMH = Id.Hashtbl.RootModule +module SPH = Id.Hashtbl.SourcePage + +type page = Id.Page.t +type container_page = Id.ContainerPage.t + +type payload = Lang.Page.t + +type dir_content = { + leafs : payload LPH.t; + dirs : in_progress CPH.t; + modules : Skeleton.t RMH.t; + implementations : Lang.Implementation.t SPH.t; +} +and in_progress = container_page option * dir_content + +let empty_t dir_id = + ( dir_id, + { + leafs = LPH.create 10; + dirs = CPH.create 10; + modules = RMH.create 10; + implementations = SPH.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 page acc -> + if Astring.String.equal "index" (Id.name id) then acc + else (id, page) :: acc) + dir_content.leafs [] + +let dirs (_, dir_content) = + CPH.fold (fun id payload acc -> (id, payload) :: acc) dir_content.dirs [] + +let modules (_, dir_content) = + RMH.fold (fun id payload acc -> (id, payload) :: acc) dir_content.modules [] + +let implementations (_, dir_content) = + SPH.fold + (fun id payload acc -> (id, payload) :: acc) + dir_content.implementations [] + +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_page (dir : in_progress) page = + let id = + match page.Lang.Page.name with + | { iv = #Id.ContainerPage.t_pv; _ } as id -> + Id.Mk.leaf_page (Some id, PageName.make_std "index") + | { iv = #Id.LeafPage.t_pv; _ } as id -> id + in + let _, dir_content = + match get_parent id with + | Some parent -> get_or_create dir parent + | None -> dir + in + LPH.replace dir_content.leafs id page + +let add_module (dir : in_progress) m = + let _, dir_content = + match m.Lang.Compilation_unit.id.iv with + | `Root (Some parent, _) -> get_or_create dir parent + | `Root (None, _) -> dir + in + let skel = Skeleton.from_unit m in + RMH.replace dir_content.modules m.id skel + +let add_implementation (dir : in_progress) (i : Lang.Implementation.t) = + match i.id with + | None -> () + | Some ({ iv = `SourcePage (parent, _); _ } as id) -> + let _, dir_content = get_or_create dir parent in + SPH.replace dir_content.implementations id i + +let 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 (index_id, payload) + | None -> None + +let root_dir (parent_id, _) = parent_id diff --git a/src/index/in_progress.mli b/src/index/in_progress.mli new file mode 100644 index 0000000000..cee38d66d9 --- /dev/null +++ b/src/index/in_progress.mli @@ -0,0 +1,44 @@ +(** Intermediate representation for pages hierarchies to be able to add pages before *) + +module Id = Odoc_model.Paths.Identifier +open Odoc_model + +type in_progress +(** A directory *) + +(** {1 Initial value} *) + +val empty_t : Id.ContainerPage.t option -> in_progress +(** Start a hierarchy for a parent ID ([None] is for the absolute root) *) + +(** {1 Add to the initial value} *) + +val add_page : in_progress -> Lang.Page.t -> unit +(** Add a leaf pages in the given dir *) + +val add_module : in_progress -> Lang.Compilation_unit.t -> unit +(** Add a mpodule in the given dir *) + +val add_implementation : in_progress -> Lang.Implementation.t -> unit +(** Add a mpodule in the given dir *) + +(** {1 Getters} *) + +val root_dir : in_progress -> Id.ContainerPage.t option +(** [root dir] is the parent ID represented by [dir] *) + +val leafs : in_progress -> (Id.LeafPage.t * Lang.Page.t) list +(** [leafs dir] returns the leaf pages in [dir] *) + +val dirs : in_progress -> (Id.ContainerPage.t * in_progress) list +(** [dirs dir] returns the intermediate directories in [dir] *) + +val modules : in_progress -> (Id.RootModule.t * Skeleton.t) list +(** [modules dir] returns the modules in [dir] *) + +val implementations : + in_progress -> (Id.SourcePage.t * Lang.Implementation.t) list +(** [implementations dir] returns the implementations in [dir] *) + +val index : in_progress -> (Id.LeafPage.t * Lang.Page.t) option +(** [index dir] returns the potential [index] leaf page in [dir] *) diff --git a/src/index/odoc_index.ml b/src/index/odoc_index.ml index 2ba4634479..ac28d1e4ad 100644 --- a/src/index/odoc_index.ml +++ b/src/index/odoc_index.ml @@ -1,16 +1,5 @@ module Skeleton = Skeleton module Entry = Entry -module Page_hierarchy = Page_hierarchy +module Skeleton_of = Skeleton_of -type page = { p_name : string; p_hierarchy : Page_hierarchy.t } - -type lib_hierarchies = Skeleton.t list -type lib = { l_name : string; l_hierarchies : lib_hierarchies } - -type t = { - pages : page list; - libs : lib list; - extra : Skeleton.t list; - (** This extra table is used only for search. It was introduced before - Odoc 3 *) -} +type t = Skeleton.t list diff --git a/src/index/page_hierarchy.ml b/src/index/page_hierarchy.ml deleted file mode 100644 index 1784f4c03a..0000000000 --- a/src/index/page_hierarchy.ml +++ /dev/null @@ -1,192 +0,0 @@ -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 = - | Page of Id.Page.t * title - | Missing_index of Id.ContainerPage.t option - -type t = index 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, Page (index_id, index_title)) - | None -> (None, Missing_index (fst dir)) - 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 (Page (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 = Missing_index _ } -> 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 deleted file mode 100644 index d24f8287bc..0000000000 --- a/src/index/page_hierarchy.mli +++ /dev/null @@ -1,18 +0,0 @@ -open Odoc_model -open Odoc_model.Paths -open Odoc_utils - -(** Page hierarchies represent a hierarchy of pages. *) - -type title = Comment.link_content - -type index = - | Page of Paths.Identifier.Page.t * title - | Missing_index of Paths.Identifier.ContainerPage.t option - -type t = index 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/skeleton.ml b/src/index/skeleton.ml index cf1c946293..01dc6ab078 100644 --- a/src/index/skeleton.ml +++ b/src/index/skeleton.ml @@ -41,8 +41,7 @@ module Entry = struct representation = td.representation; } in - let td_entry = Entry.entry ~id:td.id ~doc:td.doc ~kind in - td_entry + Entry.entry ~id:td.id ~doc:td.doc ~kind let varify_params = List.mapi (fun i param -> @@ -95,6 +94,17 @@ module Entry = struct let kind = Entry.Value { value = v.value; type_ = v.type_ } in Entry.entry ~id:v.id ~doc:v.doc ~kind + let of_extension_constructor type_path params (v : Extension.Constructor.t) = + let res = + match v.res with + | Some res -> res + | None -> + let params = varify_params params in + TypeExpr.Constr (type_path, params) + in + let kind = Entry.ExtensionConstructor { args = v.args; res } in + Entry.entry ~id:v.id ~doc:v.doc ~kind + let of_class (cl : Class.t) = let kind = Entry.Class { virtual_ = cl.virtual_; params = cl.params } in Entry.entry ~id:cl.id ~doc:cl.doc ~kind @@ -118,6 +128,24 @@ end let if_non_hidden id f = if Identifier.is_hidden (id :> Identifier.t) then [] else f () +let filter_signature items = + List.fold_left + (fun (keep, acc) item -> + match item with + | Signature.Comment `Stop -> (not keep, acc) + | _ -> if keep then (keep, item :: acc) else (keep, acc)) + (true, []) items + |> snd |> List.rev + +let filter_class_signature items = + List.fold_left + (fun (keep, acc) item -> + match item with + | ClassSignature.Comment `Stop -> (not keep, acc) + | _ -> if keep then (keep, item :: acc) else (keep, acc)) + (true, []) items + |> snd |> List.rev + let rec unit (u : Compilation_unit.t) = let entry = Entry.of_comp_unit u in let children = @@ -128,7 +156,8 @@ let rec unit (u : Compilation_unit.t) = { Tree.node = entry; children } and signature id (s : Signature.t) = - List.concat_map ~f:(signature_item (id :> Identifier.LabelParent.t)) s.items + let items = filter_signature s.items in + List.concat_map ~f:(signature_item (id :> Identifier.LabelParent.t)) items and signature_item id s_item = match s_item with @@ -139,7 +168,7 @@ and signature_item id s_item = | Open _ -> [] | Type (_, t_decl) -> type_decl t_decl | TypeSubstitution _ -> [] - | TypExt _te -> [] + | TypExt te -> type_ext te | Exception exc -> exception_ exc | Value v -> value v | Class (_, cl) -> class_ (cl.id :> Identifier.LabelParent.t) cl @@ -147,6 +176,12 @@ and signature_item id s_item = | Include i -> include_ id i | Comment d -> docs id d +and type_ext te = + List.map (constructor_extension te.type_path te.type_params) te.constructors + +and constructor_extension type_path params ec = + Tree.leaf @@ Entry.of_extension_constructor type_path params ec + and module_ id m = if_non_hidden m.id @@ fun () -> let entry = Entry.of_module m in @@ -189,8 +224,6 @@ and field type_id params f = let entry = Entry.of_field type_id params f in [ Tree.leaf entry ] -and _type_extension _te = [] - and exception_ exc = if_non_hidden exc.id @@ fun () -> let entry = Entry.of_exception exc in @@ -249,7 +282,8 @@ and module_type_expr id mte = | TypeOf { t_expansion = None; _ } -> [] and class_signature id ct_expr = - List.concat_map ~f:(class_signature_item id) ct_expr.items + let items = filter_class_signature ct_expr.items in + List.concat_map ~f:(class_signature_item id) items and class_signature_item id item = match item with diff --git a/src/index/skeleton_of.ml b/src/index/skeleton_of.ml new file mode 100644 index 0000000000..247609f8e3 --- /dev/null +++ b/src/index/skeleton_of.ml @@ -0,0 +1,193 @@ +open Odoc_utils +open Odoc_model + +(* Selective opens *) +module Id = Odoc_model.Paths.Identifier +module PageName = Odoc_model.Names.PageName +module ModuleName = Odoc_model.Names.ModuleName + +type t = Entry.t Tree.t + +let compare_entry (t1 : t) (t2 : t) = + let by_kind (t : t) = + match t.node.kind with + | Page _ | Dir -> 0 + | Module _ -> 10 + | Impl -> 20 + | _ -> 30 + in + let by_category (t : t) = + match t.node.kind with + | Page { order_category = Some o; _ } -> o + | _ -> "default" + in + let by_name (t : t) = + match t.node.kind with + | Page { short_title = Some title; _ } -> Comment.to_string title + | _ -> ( + match t.node.id.iv with + | `LeafPage (Some parent, name) + when Names.PageName.to_string name = "index" -> + Id.name parent + | _ -> Id.name t.node.id) + in + let try_ comp f fallback = + match comp (f t1) (f t2) with 0 -> fallback () | i -> i + in + try_ (compare : int -> int -> int) by_kind @@ fun () -> + try_ Astring.String.compare by_category @@ fun () -> + try_ Astring.String.compare by_name @@ fun () -> 0 + +let rec t_of_in_progress (dir : In_progress.in_progress) : t = + let entry_of_page page = + let kind = Entry.Page page.Lang.Page.frontmatter in + let doc = page.content in + let id = page.name in + Entry.entry ~kind ~doc ~id + in + let entry_of_impl id = + let kind = Entry.Impl in + let doc = [] in + Entry.entry ~kind ~doc ~id + in + let children_order, index = + match In_progress.index dir with + | Some (_, page) -> + let children_order = page.frontmatter.children_order in + let entry = entry_of_page page in + (children_order, entry) + | None -> + let entry = + match In_progress.root_dir dir with + | Some id -> + let kind = Entry.Dir in + let doc = [] in + Entry.entry ~kind ~doc ~id + | None -> + let id = + (* root dir must have an index page *) + Id.Mk.leaf_page (None, Names.PageName.make_std "index") + in + let kind = Entry.Dir in + let doc = [] in + Entry.entry ~kind ~doc ~id + in + (None, entry) + 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) + | `Root (_, name) -> + Format.fprintf fmt "'module-%s'" (ModuleName.to_string name) + | _ -> Format.fprintf fmt "'unsupported'" + 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 + | Module s -> Format.fprintf fmt "'module-%s'" s + in + let ordered, unordered = + let contents = + let leafs = + In_progress.leafs dir + |> List.map (fun (_, page) -> + let id :> Id.t = page.Lang.Page.name in + let entry = entry_of_page page in + (id, Tree.leaf entry)) + in + let dirs = + In_progress.dirs dir + |> List.map (fun (id, payload) -> + let id :> Id.t = id in + (id, t_of_in_progress payload)) + in + let modules = + In_progress.modules dir + |> List.map (fun (id, payload) -> ((id :> Id.t), payload)) + in + let implementations = + In_progress.implementations dir + |> List.map (fun (id, _impl) -> + ((id :> Id.t), Tree.leaf @@ entry_of_impl id)) + in + leafs @ dirs @ modules @ implementations + 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) -> + Astring.String.equal (PageName.to_string name) c + | (_, { Location_.value = Page c; _ }), `LeafPage (_, name) -> + Astring.String.equal (PageName.to_string name) c + | (_, { Location_.value = Module c; _ }), `Root (_, name) -> + Astring.String.equal (ModuleName.to_string name) c + | _ -> false + in + let children_indexes, indexed_content, unindexed_content = + List.fold_left + (fun (children_indexes, indexed_content, unindexed_content) + ((id, _) 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) -> compare_entry x 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 = { kind = Dir; _ } } -> remove_common_root v + | _ -> v + +let lang ~pages ~modules ~implementations = + let dir = In_progress.empty_t None in + List.iter (In_progress.add_page dir) pages; + List.iter (In_progress.add_module dir) modules; + List.iter (In_progress.add_implementation dir) implementations; + t_of_in_progress dir |> remove_common_root diff --git a/src/index/skeleton_of.mli b/src/index/skeleton_of.mli new file mode 100644 index 0000000000..8cc66c44d0 --- /dev/null +++ b/src/index/skeleton_of.mli @@ -0,0 +1,11 @@ +open Odoc_model + +(** Page hierarchies represent a hierarchy of pages. *) + +val lang : + pages:Lang.Page.t list -> + modules:Lang.Compilation_unit.t list -> + implementations:Lang.Implementation.t list -> + Skeleton.t +(** Uses the convention that the [index] children passes its payload to the + container directory to output a payload *) diff --git a/src/model/comment.ml b/src/model/comment.ml index 929ba1bfe3..53260cf311 100644 --- a/src/model/comment.ml +++ b/src/model/comment.ml @@ -145,3 +145,20 @@ let find_zero_heading docs : link_content option = Some (link_content_of_inline_elements h_content) | _ -> None) docs + +(* Used in particular to sort the title names *) +let to_string (l : link_content) = + let rec s_of_i (i : non_link_inline_element) = + match i with + | `Code_span s -> s + | `Word w -> w + | `Math_span m -> m + | `Space -> " " + | `Styled (_, is) -> s_of_is is + | `Raw_markup (_, r) -> r + and s_of_is is = + is + |> List.map (fun { Location_.value; _ } -> s_of_i value) + |> String.concat "" + in + s_of_is l diff --git a/src/model/frontmatter.ml b/src/model/frontmatter.ml index 00c4e9497c..408873a202 100644 --- a/src/model/frontmatter.ml +++ b/src/model/frontmatter.ml @@ -1,19 +1,29 @@ -type child = Page of string | Dir of string +type child = Page of string | Dir of string | Module of string type short_title = Comment.link_content type line = | Children_order of child Location_.with_location list | Short_title of short_title + | Toc_status of [ `Open | `Hidden ] + | Order_category of string type children_order = child Location_.with_location list Location_.with_location type t = { children_order : children_order option; short_title : short_title option; + toc_status : [ `Open | `Hidden ] option; + order_category : string option; } -let empty = { children_order = None; short_title = None } +let empty = + { + children_order = None; + short_title = None; + toc_status = None; + order_category = None; + } let update ~tag_name ~loc v new_v = match v with @@ -24,6 +34,11 @@ let update ~tag_name ~loc v new_v = let apply fm line = match line.Location_.value with + | Toc_status x -> + let toc_status = + update ~tag_name:"short_title" ~loc:line.location fm.toc_status x + in + { fm with toc_status } | Short_title t -> let short_title = update ~tag_name:"short_title" ~loc:line.location fm.short_title t @@ -36,14 +51,27 @@ let apply fm line = children_order in { fm with children_order } + | Order_category name -> + let order_category = + update ~tag_name:"order_category" ~loc:line.location fm.order_category + name + in + { fm with order_category } let parse_child c = + let mod_prefix = "module-" in if Astring.String.is_suffix ~affix:"/" c then let c = String.sub c 0 (String.length c - 1) in Dir c + else if Astring.String.is_prefix ~affix:mod_prefix c then + let l = String.length mod_prefix in + let c = String.sub c l (String.length c - l) in + Module c else Page c -let parse_children_order loc co = +type tag_payload = Comment.nestable_block_element Location_.with_location list + +let parse_children_order loc (co : tag_payload) = let rec parse_words acc words = match words with | [] -> Result.Ok (Location_.at loc (Children_order (List.rev acc))) @@ -61,7 +89,7 @@ let parse_children_order loc co = Error (Error.make "Only words are accepted when specifying children order" loc) -let parse_short_title loc t = +let parse_short_title loc (t : tag_payload) = match t with | [ { Location_.value = `Paragraph words; _ } ] -> let short_title = Comment.link_content_of_inline_elements words in @@ -71,5 +99,32 @@ let parse_short_title loc t = (Error.make "Short titles cannot contain other block than a single paragraph" loc) +let parse_toc_status loc (t : tag_payload) = + match t with + | [ + { Location_.value = `Paragraph [ { Location_.value = `Word "open"; _ } ]; _ }; + ] -> + Result.Ok (Location_.at loc (Toc_status `Open)) + | [ + { + Location_.value = `Paragraph [ { Location_.value = `Word "hidden"; _ } ]; + _; + }; + ] -> + Result.Ok (Location_.at loc (Toc_status `Hidden)) + | _ -> + Error + (Error.make "@toc_status can only take the 'open' and 'hidden' value" + loc) + +let parse_order_category loc (t : tag_payload) = + match t with + | [ { Location_.value = `Paragraph [ { Location_.value = `Word w; _ } ]; _ } ] + -> + Result.Ok (Location_.at loc (Order_category w)) + | _ -> + Error + (Error.make "@order_category can only take a single word as value" loc) + let of_lines lines = Error.catch_warnings @@ fun () -> List.fold_left apply empty lines diff --git a/src/model/frontmatter.mli b/src/model/frontmatter.mli index 8cf0f715c0..900179b530 100644 --- a/src/model/frontmatter.mli +++ b/src/model/frontmatter.mli @@ -1,4 +1,4 @@ -type child = Page of string | Dir of string +type child = Page of string | Dir of string | Module of string type short_title = Comment.link_content @@ -9,18 +9,32 @@ type children_order = child Location_.with_location list Location_.with_location type t = { children_order : children_order option; short_title : short_title option; + toc_status : [ `Open | `Hidden ] option; + order_category : string option; } val empty : t +type tag_payload = Comment.nestable_block_element Location_.with_location list + val parse_children_order : Location_.span -> - Comment.nestable_block_element Location_.with_location list -> + tag_payload -> (line Location_.with_location, Error.t) Result.result val parse_short_title : Location_.span -> - Comment.nestable_block_element Location_.with_location list -> + tag_payload -> + (line Location_.with_location, Error.t) Result.result + +val parse_toc_status : + Location_.span -> + tag_payload -> + (line Location_.with_location, Error.t) Result.result + +val parse_order_category : + Location_.span -> + tag_payload -> (line Location_.with_location, Error.t) Result.result val of_lines : line Location_.with_location list -> t Error.with_warnings diff --git a/src/model/paths.ml b/src/model/paths.ml index bb1bdf213d..6f71bfa074 100644 --- a/src/model/paths.ml +++ b/src/model/paths.ml @@ -50,7 +50,7 @@ module Identifier = struct | `Method (_, name) -> MethodName.to_string name | `InstanceVariable (_, name) -> InstanceVariableName.to_string name | `Label (_, name) -> LabelName.to_string name - | `SourcePage (dir, name) -> name_aux (dir :> t) ^ name + | `SourcePage (_, name) -> name | `SourceLocation (x, anchor) -> name_aux (x :> t) ^ "#" ^ DefName.to_string anchor | `SourceLocationMod x -> name_aux (x :> t) @@ -382,6 +382,9 @@ module Identifier = struct module SourcePage = struct type t = Id.source_page type t_pv = Id.source_page_pv + + let equal = equal + let hash = hash end module SourceLocation = struct @@ -625,6 +628,8 @@ module Identifier = struct module Any = Hashtbl.Make (Any) module ContainerPage = Hashtbl.Make (ContainerPage) module LeafPage = Hashtbl.Make (LeafPage) + module RootModule = Hashtbl.Make (RootModule) + module SourcePage = Hashtbl.Make (SourcePage) end end diff --git a/src/model/paths.mli b/src/model/paths.mli index e19dcae21f..5c2ae595c2 100644 --- a/src/model/paths.mli +++ b/src/model/paths.mli @@ -244,6 +244,8 @@ module Identifier : sig module Any : Hashtbl.S with type key = Any.t module ContainerPage : Hashtbl.S with type key = ContainerPage.t module LeafPage : Hashtbl.S with type key = LeafPage.t + module RootModule : Hashtbl.S with type key = RootModule.t + module SourcePage : Hashtbl.S with type key = SourcePage.t end module Mk : sig diff --git a/src/model/semantics.ml b/src/model/semantics.ml index dec78e65ee..e7b79cfcf6 100644 --- a/src/model/semantics.ml +++ b/src/model/semantics.ml @@ -25,7 +25,9 @@ let describe_internal_tag = function | `Closed -> "@closed" | `Hidden -> "@hidden" | `Children_order _ -> "@children_order" + | `Toc_status _ -> "@toc_status" | `Short_title _ -> "@short_title" + | `Order_category _ -> "@order_category" let warn_unexpected_tag { Location.value; location } = Error.raise_warning @@ -485,7 +487,8 @@ let strip_internal_tags ast : internal_tags_removed with_location list * _ = in match tag with | (`Inline | `Open | `Closed | `Hidden) as tag -> next tag - | (`Children_order _ | `Short_title _) as tag -> + | ( `Children_order _ | `Short_title _ | `Toc_status _ + | `Order_category _ ) as tag -> let tag_name = describe_internal_tag tag in if not start then Error.raise_warning @@ -553,7 +556,10 @@ let handle_internal_tags (type a) tags : a handle_internal_tags -> a = function let unparsed_lines = find_tags [] ~filter:(function - | (`Children_order _ | `Short_title _) as p -> Some p | _ -> None) + | ( `Children_order _ | `Toc_status _ | `Short_title _ + | `Order_category _ ) as p -> + Some p + | _ -> None) tags in let lines = @@ -569,7 +575,10 @@ let handle_internal_tags (type a) tags : a handle_internal_tags -> a = function (function | `Children_order co, loc -> do_ Frontmatter.parse_children_order loc co - | `Short_title t, loc -> do_ Frontmatter.parse_short_title loc t) + | `Toc_status co, loc -> do_ Frontmatter.parse_toc_status loc co + | `Short_title t, loc -> do_ Frontmatter.parse_short_title loc t + | `Order_category t, loc -> + do_ Frontmatter.parse_order_category loc t) unparsed_lines in Frontmatter.of_lines lines |> Error.raise_warnings diff --git a/src/model_desc/lang_desc.ml b/src/model_desc/lang_desc.ml index eb32d6a9c0..ec5d0c2bfb 100644 --- a/src/model_desc/lang_desc.ml +++ b/src/model_desc/lang_desc.ml @@ -718,6 +718,14 @@ and frontmatter = (t.short_title :> Comment.inline_element Location_.with_location list option)), Option Comment_desc.inline_element ); + F + ( "toc_status", + (fun t -> + Option.map + (function `Hidden -> "hidden" | `Open -> "open") + t.toc_status), + Option string ); + F ("order_category", (fun t -> t.order_category), Option string); ] and child = @@ -725,7 +733,8 @@ and child = Variant (function | { Location_.value = Page s; _ } -> C ("Page", s, string) - | { Location_.value = Dir s; _ } -> C ("Dir", s, string)) + | { Location_.value = Dir s; _ } -> C ("Dir", s, string) + | { Location_.value = Module s; _ } -> C ("Module", s, string)) and implementation_t = let open Lang.Implementation in diff --git a/src/odoc/bin/main.ml b/src/odoc/bin/main.ml index 27e1b54ec4..46635ea5cd 100644 --- a/src/odoc/bin/main.ml +++ b/src/odoc/bin/main.ml @@ -468,14 +468,11 @@ module Indexing = struct | None, `JSON -> Ok (Fs.File.of_string "index.json") | None, `Marshall -> Ok (Fs.File.of_string "index.odoc-index") - let index dst json warnings_options page_roots lib_roots inputs_in_file inputs - occurrences = + let index dst json warnings_options roots inputs_in_file inputs occurrences = let marshall = if json then `JSON else `Marshall in output_file ~dst marshall >>= fun output -> - Antichain.check (page_roots |> List.map ~f:snd) ~opt:"-P" >>= fun () -> - Antichain.check (lib_roots |> List.map ~f:snd) ~opt:"-L" >>= fun () -> - Indexing.compile marshall ~output ~warnings_options ~occurrences ~lib_roots - ~page_roots ~inputs_in_file ~odocls:inputs + Indexing.compile marshall ~output ~warnings_options ~roots ~occurrences + ~inputs_in_file ~odocls:inputs let cmd = let dst = @@ -511,31 +508,20 @@ module Indexing = struct let doc = ".odocl file to index" in Arg.(value & pos_all convert_fpath [] & info ~doc ~docv:"FILE" []) in - let page_roots = - let doc = - "Specifies a directory PATH containing pages that should be included \ - in the sidebar, under the NAME section." - in - Arg.( - value - & opt_all convert_named_root [] - & info ~docs ~docv:"NAME:PATH" ~doc [ "P" ]) - in - let lib_roots = + let roots = let doc = - "Specifies a directory PATH containing units that should be included \ - in the sidebar, as part of the LIBNAME library." + "Specifies a directory PATH containing pages or units that should be \ + included in the sidebar." in - Arg.( value - & opt_all convert_named_root [] - & info ~docs ~docv:"LIBNAME:PATH" ~doc [ "L" ]) + & opt_all (convert_directory ()) [] + & info ~docs ~docv:"NAME:PATH" ~doc [ "root" ]) in Term.( const handle_error - $ (const index $ dst $ json $ warnings_options $ page_roots $ lib_roots - $ inputs_in_file $ inputs $ occurrences)) + $ (const index $ dst $ json $ warnings_options $ roots $ inputs_in_file + $ inputs $ occurrences)) let info ~docs = let doc = @@ -863,7 +849,7 @@ end = struct Arg.( value & opt (some convert_fpath) None - & info [ "sidebar" ] ~doc ~docv:"FILE.odoc-index") + & info [ "sidebar" ] ~doc ~docv:"FILE.odoc-sidebar") let cmd = let syntax = @@ -890,9 +876,10 @@ end = struct module Generate_source = struct let generate extra output_dir syntax extra_suffix input_file - warnings_options source_file = + warnings_options source_file sidebar = Rendering.generate_source_odoc ~renderer:R.renderer ~warnings_options - ~syntax ~output:output_dir ~extra_suffix ~source_file extra input_file + ~syntax ~output:output_dir ~extra_suffix ~source_file ~sidebar extra + input_file let input_odocl = let doc = "Linked implementation file." in @@ -917,10 +904,12 @@ end = struct & opt (pconv convert_syntax) Odoc_document.Renderer.OCaml @@ info ~docv:"SYNTAX" ~doc ~env [ "syntax" ]) in + let sidebar = Generate.sidebar in Term.( const handle_error $ (const generate $ R.extra_args $ dst ~create:true () $ syntax - $ extra_suffix $ input_odocl $ warnings_options $ source_file)) + $ extra_suffix $ input_odocl $ warnings_options $ source_file $ sidebar + )) let info ~docs = let doc = @@ -1143,6 +1132,13 @@ module Odoc_html_args = struct (parser, printer) end + let home_breadcrumb = + let doc = + "Wether to add a 'Home' breadcrumb to go up the root of the given \ + sidebar." + in + Arg.(value & flag & info ~docv:"escape" ~doc [ "home-breadcrumb" ]) + let theme_uri = let doc = "Where to look for theme files (e.g. `URI/odoc.css'). Relative URIs are \ @@ -1211,7 +1207,7 @@ module Odoc_html_args = struct let extra_args = let config semantic_uris closed_details indent theme_uri support_uri - search_uris flat as_json remap remap_file = + search_uris flat as_json remap remap_file home_breadcrumb = let open_details = not closed_details in let remap = match remap_file with @@ -1232,13 +1228,14 @@ module Odoc_html_args = struct in let html_config = Odoc_html.Config.v ~theme_uri ~support_uri ~search_uris ~semantic_uris - ~indent ~flat ~open_details ~as_json ~remap () + ~indent ~flat ~open_details ~as_json ~remap ~home_breadcrumb () in { Html_page.html_config } in Term.( const config $ semantic_uris $ closed_details $ indent $ theme_uri - $ support_uri $ search_uri $ flat $ as_json $ remap $ remap_file) + $ support_uri $ search_uri $ flat $ as_json $ remap $ remap_file + $ home_breadcrumb) end module Odoc_html = Make_renderer (Odoc_html_args) diff --git a/src/odoc/compile.ml b/src/odoc/compile.ml index ee61392078..7a626a143f 100644 --- a/src/odoc/compile.ml +++ b/src/odoc/compile.ml @@ -205,7 +205,7 @@ let page_name_of_output output = name_of_output ~prefix:"page-" output let is_index_page = function | { Paths.Identifier.iv = `Page _; _ } -> false | { iv = `LeafPage (_, p); _ } -> - String.equal (Names.PageName.to_string p) "index" + Astring.String.equal (Names.PageName.to_string p) "index" let has_children_order { Frontmatter.children_order; _ } = Option.is_some children_order diff --git a/src/odoc/indexing.ml b/src/odoc/indexing.ml index efb848912b..65fb95fc48 100644 --- a/src/odoc/indexing.ml +++ b/src/odoc/indexing.ml @@ -7,26 +7,6 @@ open Odoc_model module H = Odoc_model.Paths.Identifier.Hashtbl.Any module Id = Odoc_model.Paths.Identifier -let handle_file file ~unit ~page ~occ = - match Fpath.basename file with - | s when String.is_prefix ~affix:"index-" s -> - Odoc_file.load_index file >>= fun { extra (* libs *); _ } -> - Ok (occ extra) - | _ -> ( - Odoc_file.load file >>= fun unit' -> - match unit' with - | { Odoc_file.content = Unit_content unit'; _ } when unit'.hidden -> - Error (`Msg "Hidden units are ignored when generating an index") - | { Odoc_file.content = Unit_content unit'; _ } - (* when not unit'.hidden *) -> - Ok (unit unit') - | { Odoc_file.content = Page_content page'; _ } -> Ok (page page') - | _ -> - Error - (`Msg - "Only pages and unit are allowed as input when generating an \ - index")) - let parse_input_file input = let is_sep = function '\n' | '\r' -> true | _ -> false in Fs.File.read input >>= fun content -> @@ -43,113 +23,41 @@ let parse_input_files input = (Ok []) input >>= fun files -> Ok (List.concat files) -let compile_to_json ~output ~occurrences files = +let compile_to_json ~output ~occurrences hierarchies = let output_channel = Fs.Directory.mkdir_p (Fs.File.dirname output); open_out_bin (Fs.File.to_string output) in let output = Format.formatter_of_out_channel output_channel in - let print f first up = - if not first then Format.fprintf output ","; - f output up; - false - in - Format.fprintf output "["; - let _ : bool = + let all = List.fold_left - (fun acc file -> - match - handle_file - ~unit:(print (Json_search.unit ?occurrences) acc) - ~page:(print Json_search.page acc) - ~occ:(print (Json_search.index ?occurrences) acc) - file - with - | Ok acc -> acc - | Error (`Msg m) -> - Error.raise_warning ~non_fatal:true - (Error.filename_only "%s" m (Fs.File.to_string file)); - acc) - true files + (fun acc hierarchy -> + Tree.fold_left + ~f:(fun acc entry -> Json_search.of_entry ?occurrences entry :: acc) + acc hierarchy) + [] hierarchies in - Format.fprintf output "]"; + Format.fprintf output "%s" (Odoc_utils.Json.to_string (`Array (List.rev all))); Ok () -let compile_to_marshall ~output (pages, libs) files = - let unit u = [ Odoc_index.Skeleton.from_unit u ] in - let page p = [ Odoc_index.Skeleton.from_page p ] in - let index i = i in - let extra = - List.concat_map - ~f:(fun file -> - match handle_file ~unit ~page ~occ:index file with - | Ok l -> l - | Error (`Msg m) -> - Error.raise_warning ~non_fatal:true - (Error.filename_only "%s" m (Fs.File.to_string file)); - []) - files - in - let content = { Odoc_index.pages; libs; extra } in - Ok (Odoc_file.save_index output content) - let read_occurrences file = let ic = open_in_bin file in let htbl : Odoc_occurrences.Table.t = Marshal.from_channel ic in htbl -let pages resolver page_roots = - List.map - (fun (page_root, _) -> - let pages = Resolver.all_pages ~root:page_root resolver in - let p_hierarchy = - let page_toc_input = - (* To create a page toc, we need a list with id, title and children - order. We generate this list from *) - let prepare_input (id, title, frontmatter) = - (* We filter non-leaf pages *) - match id with - | { Id.iv = #Id.LeafPage.t_pv; _ } as id -> - (* We generate a title if needed *) - let title = - match title with - | None -> Location_.[ at (span []) (`Word (Id.name id)) ] - | Some x -> x - in - let children_order = frontmatter.Frontmatter.children_order in - Some (id, title, children_order) - | _ -> None - in - List.filter_map prepare_input pages - in - Odoc_index.Page_hierarchy.of_list page_toc_input - in - { Odoc_index.p_name = page_root; p_hierarchy }) - page_roots - -let libs resolver lib_roots = - List.map - (fun (library, _) -> - let units = Resolver.all_units ~library resolver in - let l_hierarchies = - List.filter_map - (fun (file, _id) -> - match file () with - | Some unit -> Some (Odoc_index.Skeleton.from_unit unit) - | None -> None) - units - in - { Odoc_index.l_name = library; l_hierarchies }) - lib_roots +let absolute_normalization p = + let p = + if Fpath.is_rel p then Fpath.( // ) (Fpath.v (Sys.getcwd ())) p else p + in + Fpath.normalize p -let compile out_format ~output ~warnings_options ~occurrences ~lib_roots - ~page_roots ~inputs_in_file ~odocls = +let compile out_format ~output ~warnings_options ~occurrences ~roots + ~inputs_in_file ~odocls = let handle_warnings f = let res = Error.catch_warnings f in Error.handle_warnings ~warnings_options res |> Result.join in handle_warnings @@ fun () -> - let current_dir = Fs.File.dirname output in parse_input_files inputs_in_file >>= fun files -> let files = List.rev_append odocls files in let occurrences = @@ -157,34 +65,66 @@ let compile out_format ~output ~warnings_options ~occurrences ~lib_roots | None -> None | Some occurrences -> Some (read_occurrences (Fpath.to_string occurrences)) in - let includes_rec = - List.rev_append (List.map snd page_roots) (List.map snd lib_roots) + let all_files = + roots + |> List.fold_left + (fun set include_rec -> + Fs.Directory.fold_files_rec ~ext:"odocl" + (fun files file -> + Fpath.Set.add (absolute_normalization file) files) + set include_rec) + Fpath.Set.empty + |> fun set -> Fpath.Set.fold (fun a l -> a :: l) set [] in - let files = - List.rev_append files - (includes_rec - |> List.map (fun include_rec -> - Fs.Directory.fold_files_rec ~ext:"odocl" - (fun files file -> file :: files) - [] include_rec) - |> List.concat) + (* let () = List.iter (Format.printf "%a\n" Fpath.pp) all_files in *) + let root_groups = + (* We group the files we have found by root. + + Some files may belong to multiple roots. In this case, we associate the + file to the root that is the deepest in the hierarchy. + *) + let roots = List.map Fs.Directory.to_fpath roots in + let roots = List.map absolute_normalization roots in + (* Add an index to keep the original order *) + let roots = List.mapi (fun i c -> (i, c)) roots in + let roots = + (* Make sure that we treat first the "deepest" one *) + List.sort + (fun (_, p1) (_, p2) -> if Fpath.is_prefix p1 p2 then 1 else -1) + roots + in + let groups, _ = + List.fold_left + (fun (acc, remaining_files) (i, root) -> + let root_files, remaining_files = + List.partition (Fpath.is_prefix root) remaining_files + in + ((i, root_files) :: acc, remaining_files)) + ([], all_files) roots + in + let root_groups = + List.sort (fun (i, _) (j, _) -> compare i j) groups |> List.map snd + in + (* Files given without [--root] are grouped together *) + match files with _ :: _ -> files :: root_groups | [] -> root_groups in - match out_format with - | `JSON -> compile_to_json ~output ~occurrences files - | `Marshall -> - let resolver = - Resolver.create ~important_digests:false ~directories:[] - ~roots: - (Some - { - page_roots; - lib_roots; - current_lib = None; - current_package = None; - current_dir; - }) - ~open_modules:[] + let hierarchies = + (* For each group, we create a hierarchy. *) + let hierarchy_of_group g = + let pages, modules, implementations = + let read (pages, modules, impls) f = + match Odoc_file.load f with + | Ok { content = Page_content p; _ } -> (p :: pages, modules, impls) + | Ok { content = Unit_content m; _ } -> (pages, m :: modules, impls) + | Ok { content = Impl_content i; _ } -> (pages, modules, i :: impls) + | _ -> (pages, modules, impls) + in + List.fold_left read ([], [], []) g in - let pages = pages resolver page_roots in - let libs = libs resolver lib_roots in - compile_to_marshall ~output (pages, libs) files + Odoc_index.Skeleton_of.lang ~pages ~modules ~implementations + in + List.map hierarchy_of_group root_groups + in + match out_format with + | `JSON -> compile_to_json ~output ~occurrences hierarchies + | `Marshall -> Ok (Odoc_file.save_index output hierarchies) diff --git a/src/odoc/indexing.mli b/src/odoc/indexing.mli index 2103b58f6a..342e5e03d3 100644 --- a/src/odoc/indexing.mli +++ b/src/odoc/indexing.mli @@ -1,21 +1,11 @@ open Or_error -val handle_file : - Fpath.t -> - unit:(Odoc_model.Lang.Compilation_unit.t -> 'a) -> - page:(Odoc_model.Lang.Page.t -> 'a) -> - occ:(Odoc_index.Skeleton.t list -> 'a) -> - ('a, [> msg ]) result -(** This function is exposed for custom indexers that uses [odoc] as a library - to generate their search index *) - val compile : [ `JSON | `Marshall ] -> output:Fs.file -> warnings_options:Odoc_model.Error.warnings_options -> occurrences:Fs.file option -> - lib_roots:(string * Fs.directory) list -> - page_roots:(string * Fs.directory) list -> + roots:Fs.Directory.t list -> inputs_in_file:Fs.file list -> odocls:Fs.file list -> (unit, [> msg ]) result diff --git a/src/odoc/odoc_file.mli b/src/odoc/odoc_file.mli index 79e6c14dbf..6f2c39ed58 100644 --- a/src/odoc/odoc_file.mli +++ b/src/odoc/odoc_file.mli @@ -19,13 +19,11 @@ open Odoc_model open Or_error -type unit_content = Lang.Compilation_unit.t - -(** Either a page or a module. *) +(** Either a page or a module or something else. *) type content = | Page_content of Lang.Page.t | Impl_content of Lang.Implementation.t - | Unit_content of unit_content + | Unit_content of Lang.Compilation_unit.t | Asset_content of Lang.Asset.t type t = { content : content; warnings : Error.t list } @@ -35,7 +33,8 @@ type t = { content : content; warnings : Error.t list } val save_page : Fs.File.t -> warnings:Error.t list -> Lang.Page.t -> unit (** Save a page. The [page-] prefix is added to the file name if missing. *) -val save_unit : Fs.File.t -> warnings:Error.t list -> unit_content -> unit +val save_unit : + Fs.File.t -> warnings:Error.t list -> Lang.Compilation_unit.t -> unit (** Save a module. *) val save_impl : diff --git a/src/odoc/rendering.ml b/src/odoc/rendering.ml index a1652f8d76..bda6a47188 100644 --- a/src/odoc/rendering.ml +++ b/src/odoc/rendering.ml @@ -93,14 +93,18 @@ let documents_of_implementation ~warnings_options:_ ~syntax impl source_file = Error (`Msg "The implementation unit was not compiled with --source-id.") let generate_source_odoc ~syntax ~warnings_options ~renderer ~output - ~source_file ~extra_suffix extra file = + ~source_file ~extra_suffix ~sidebar extra file = Odoc_file.load file >>= fun unit -> + (match sidebar with + | None -> Ok None + | Some x -> Odoc_file.load_sidebar x >>= fun sidebar -> Ok (Some sidebar)) + >>= fun sidebar -> match unit.content with | Odoc_file.Impl_content impl -> documents_of_implementation ~warnings_options ~syntax impl source_file >>= fun docs -> List.iter - (render_document renderer ~output ~sidebar:None ~extra_suffix ~extra) + (render_document renderer ~output ~sidebar ~extra_suffix ~extra) docs; Ok () | Page_content _ | Unit_content _ | Asset_content _ -> diff --git a/src/odoc/rendering.mli b/src/odoc/rendering.mli index 1d274d3c76..69c7baa704 100644 --- a/src/odoc/rendering.mli +++ b/src/odoc/rendering.mli @@ -29,6 +29,7 @@ val generate_source_odoc : output:Fs.directory -> source_file:Fpath.t -> extra_suffix:string option -> + sidebar:Fpath.t option -> 'a -> Fpath.t -> (unit, [> msg ]) result diff --git a/src/odoc/resolver.ml b/src/odoc/resolver.ml index 6420e2350e..63335f182b 100644 --- a/src/odoc/resolver.ml +++ b/src/odoc/resolver.ml @@ -40,16 +40,10 @@ module Named_roots : sig type error = NoPackage | NoRoot - type input = { - name : string; - dir : Fs.Directory.t; - omit : Fs.Directory.t list; - } + type input = { name : string; dir : Fs.Directory.t } val create : input list -> current_root:named_root option -> t - val all_of : ?root:string -> ext:string -> t -> (Fs.File.t list, error) result - val current_root : t -> Fs.Directory.t option val find_by_path : @@ -64,19 +58,11 @@ end = struct type hierarchical = (Fs.File.t, Fs.File.t) Hashtbl.t * Fs.Directory.t - type pkg = { - flat : flat; - hierarchical : hierarchical; - omit : Fs.Directory.t list; - } + type pkg = { flat : flat; hierarchical : hierarchical } type t = { table : (string, pkg) Hashtbl.t; current_root : named_root option } - type input = { - name : string; - dir : Fs.Directory.t; - omit : Fs.Directory.t list; - } + type input = { name : string; dir : Fs.Directory.t } type error = NoPackage | NoRoot @@ -88,20 +74,15 @@ end = struct let create (pkglist : input list) ~current_root = let cache = Hashtbl.create 42 in List.iter - (fun { name = pkgname; dir = root; omit } -> + (fun { name = pkgname; dir = root } -> let flat = Unvisited root and hierarchical = (Hashtbl.create 42, root) in - Hashtbl.add cache pkgname { flat; hierarchical; omit }) + Hashtbl.add cache pkgname { flat; hierarchical }) pkglist; { current_root; table = cache } let current_root t = Option.map snd t.current_root - let check_omit ~omit path = - List.for_all - (fun omit -> not @@ Fs.Directory.contains ~parentdir:omit path) - omit - let find_by_path ?root { table = cache; current_root; _ } ~path = let path = Fpath.normalize path in let root = @@ -111,27 +92,25 @@ end = struct in root >>= fun root -> match hashtbl_find_opt cache root with - | Some { hierarchical = cache, root; omit; _ } -> ( + | Some { hierarchical = cache, root; _ } -> ( match hashtbl_find_opt cache path with | Some x -> Ok (Some x) | None -> let full_path = Fpath.( // ) (Fs.Directory.to_fpath root) path in - if Fs.File.exists full_path && check_omit ~omit full_path then ( + if Fs.File.exists full_path then ( Hashtbl.add cache path full_path; Ok (Some full_path)) else Ok None) | None -> Error NoPackage - let populate_flat_namespace ~root ~omit = + let populate_flat_namespace ~root = let flat_namespace = Hashtbl.create 42 in let () = match Fs.Directory.fold_files_rec_result (fun () path -> let name = Fpath.filename path in - if check_omit ~omit path then - Ok (Hashtbl.add flat_namespace name path) - else Ok ()) + Ok (Hashtbl.add flat_namespace name path)) () root with | Ok () -> () @@ -149,30 +128,11 @@ end = struct package >>= fun package -> match hashtbl_find_opt cache package with | Some { flat = Visited flat; _ } -> Ok (Hashtbl.find_all flat name) - | Some ({ flat = Unvisited root; omit; _ } as p) -> - let flat = populate_flat_namespace ~omit ~root in + | Some ({ flat = Unvisited root; _ } as p) -> + let flat = populate_flat_namespace ~root in Hashtbl.replace cache package { p with flat = Visited flat }; Ok (Hashtbl.find_all flat name) | None -> Error NoPackage - - let all_of ?root ~ext { table; current_root; _ } = - (match (root, current_root) with - | None, Some (current_root, _) -> Ok current_root - | Some pkg, _ -> Ok pkg - | None, None -> Error NoRoot) - >>= fun my_root -> - let return flat = - let values = Hashtbl.fold (fun _ v acc -> v :: acc) flat [] in - let values = List.filter (Fpath.has_ext ext) values in - Ok values - in - match Hashtbl.find table my_root with - | { flat = Visited flat; _ } -> return flat - | { flat = Unvisited root; omit; _ } as p -> - let flat = populate_flat_namespace ~omit ~root in - Hashtbl.replace table my_root { p with flat = Visited flat }; - return flat - | exception Not_found -> Error NoPackage end let () = (ignore Named_roots.find_by_name [@warning "-5"]) @@ -498,57 +458,6 @@ type t = { current_dir : Fs.Directory.t option; } -let all_roots ?root named_roots = - let all_files = - match Named_roots.all_of ?root named_roots ~ext:"odocl" with - | Ok x -> x - | Error (NoPackage | NoRoot) -> [] - in - let load file = - match Odoc_file.load_root file with - | Error _ -> None - | Ok root -> Some (file, root) - in - Odoc_utils.List.filter_map load all_files - -let all_pages ?root ({ pages; _ } : t) = - let filter (root : _ * Odoc_model.Root.t) = - match snd root with - | { - file = Page { title; frontmatter; _ }; - id = { iv = #Odoc_model.Paths.Identifier.Page.t_pv; _ } as id; - _; - } -> - Some (id, title, frontmatter) - | _ -> None - in - match pages with - | None -> [] - | Some pages -> Odoc_utils.List.filter_map filter @@ all_roots ?root pages - -let all_units ~library ({ libs; _ } : t) = - let filter (root : _ * Odoc_model.Root.t) = - match root with - | ( file, - { - file = Compilation_unit _; - id = { iv = #Odoc_model.Paths.Identifier.RootModule.t_pv; _ } as id; - _; - } ) -> - let file () = - match Odoc_file.load file with - | Ok { content = Odoc_file.Unit_content u; _ } -> Some u - | Ok { content = _; _ } -> assert false - | Error _ -> (* TODO: Report as warning or propagate error *) None - in - Some (file, id) - | _ -> None - in - match libs with - | None -> [] - | Some libs -> - Odoc_utils.List.filter_map filter @@ all_roots ~root:library libs - type roots = { page_roots : named_root list; lib_roots : named_root list; @@ -563,27 +472,16 @@ let create ~important_digests ~directories ~open_modules ~roots = | None -> (None, None, None, directories) | Some { page_roots; lib_roots; current_lib; current_package; current_dir } -> - let prepare roots omit = - List.map - (fun (name, dir) -> - let omit = - List.filter - (fun o -> - Fs.Directory.contains ~parentdir:dir - (Fs.Directory.to_fpath o)) - omit - in - { Named_roots.name; dir; omit }) - roots + let prepare roots = + List.map (fun (name, dir) -> { Named_roots.name; dir }) roots in let directories = match current_package with | None -> directories | Some (_pkg, dir) -> dir :: directories in - let omit = List.map snd lib_roots in - let lib_roots = prepare lib_roots [] in - let page_roots = prepare page_roots omit in + let lib_roots = prepare lib_roots in + let page_roots = prepare page_roots in let pages = Named_roots.create ~current_root:current_package page_roots and libs = Named_roots.create ~current_root:current_lib lib_roots in (Some pages, Some libs, Some current_dir, directories) diff --git a/src/odoc/resolver.mli b/src/odoc/resolver.mli index 7e48a7e7c8..2d9030299f 100644 --- a/src/odoc/resolver.mli +++ b/src/odoc/resolver.mli @@ -48,17 +48,6 @@ val create : val lookup_page : t -> string -> Lang.Page.t option -val all_pages : - ?root:string -> - t -> - (Paths.Identifier.Page.t * Comment.link_content option * Frontmatter.t) list - -val all_units : - library:string -> - t -> - ((unit -> Lang.Compilation_unit.t option) * Paths.Identifier.RootModule.t) - list - (** Helpers for creating xref2 env. *) val build_compile_env_for_unit : diff --git a/src/odoc/sidebar.ml b/src/odoc/sidebar.ml index 73d73144d8..f69eda5561 100644 --- a/src/odoc/sidebar.ml +++ b/src/odoc/sidebar.ml @@ -13,7 +13,7 @@ let compile_to_json ~output sidebar = let generate ~marshall ~output ~warnings_options:_ ~index = Odoc_file.load_index index >>= fun index -> - let sidebar = Odoc_document.Sidebar.of_lang index in + let sidebar = Odoc_document.Sidebar.of_index index in match marshall with | `JSON -> Ok (compile_to_json ~output sidebar) | `Marshall -> Ok (Odoc_file.save_sidebar output sidebar) diff --git a/src/parser/ast.ml b/src/parser/ast.ml index 29f7eba660..ed214dd8ec 100644 --- a/src/parser/ast.ml +++ b/src/parser/ast.ml @@ -78,6 +78,8 @@ type internal_tag = | `Closed | `Hidden | `Children_order of nestable_block_element with_location list + | `Toc_status of nestable_block_element with_location list + | `Order_category of nestable_block_element with_location list | `Short_title of nestable_block_element with_location list ] (** Internal tags are used to exercise fine control over the output of odoc. They diff --git a/src/parser/lexer.mll b/src/parser/lexer.mll index 1a795edd6d..91267bd79b 100644 --- a/src/parser/lexer.mll +++ b/src/parser/lexer.mll @@ -543,6 +543,12 @@ and token input = parse | ("@children_order") { emit input (`Tag `Children_order) } + | ("@toc_status") + { emit input (`Tag `Toc_status) } + + | ("@order_category") + { emit input (`Tag `Order_category) } + | ("@short_title") { emit input (`Tag `Short_title) } diff --git a/src/parser/syntax.ml b/src/parser/syntax.ml index 086610c530..74ecf88a34 100644 --- a/src/parser/syntax.ml +++ b/src/parser/syntax.ml @@ -618,6 +618,8 @@ let tag_to_words = function | `Since s -> [ `Word "@since"; `Space " "; `Word s ] | `Version s -> [ `Word "@version"; `Space " "; `Word s ] | `Children_order -> [ `Word "@children_order" ] + | `Toc_status -> [ `Word "@toc_status" ] + | `Order_category -> [ `Word "@order_category" ] | `Short_title -> [ `Word "@short_title" ] (* {3 Block element lists} *) @@ -819,7 +821,8 @@ let rec block_element_list : let tag = Loc.at location (`Tag tag) in consume_block_elements `After_text (tag :: acc) - | (`Deprecated | `Return | `Children_order | `Short_title) as tag -> + | ( `Deprecated | `Return | `Children_order | `Short_title + | `Toc_status | `Order_category ) as tag -> let content, _stream_head, where_in_line = block_element_list (In_implicitly_ended `Tag) ~parent_markup:token input @@ -827,9 +830,11 @@ let rec block_element_list : let tag = match tag with | `Deprecated -> `Deprecated content + | `Toc_status -> `Toc_status content | `Return -> `Return content | `Children_order -> `Children_order content | `Short_title -> `Short_title content + | `Order_category -> `Order_category content in let location = location :: List.map Loc.location content |> Loc.span diff --git a/src/parser/test/test.ml b/src/parser/test/test.ml index 866bfc1a1d..fcda47cc80 100644 --- a/src/parser/test/test.ml +++ b/src/parser/test/test.ml @@ -147,6 +147,13 @@ module Ast_to_sexp = struct List (Atom "@children_order" :: List.map (at.at (nestable_block_element at)) es) + | `Toc_status es -> + List + (Atom "@toc_status" :: List.map (at.at (nestable_block_element at)) es) + | `Order_category es -> + List + (Atom "@order_category" + :: List.map (at.at (nestable_block_element at)) es) | `Short_title es -> List (Atom "@short_title" diff --git a/src/parser/token.ml b/src/parser/token.ml index 8b9330f3f3..ac23cd76ba 100644 --- a/src/parser/token.ml +++ b/src/parser/token.ml @@ -19,6 +19,8 @@ type tag = | `Version of string | `Canonical of string | `Children_order + | `Toc_status + | `Order_category | `Short_title | `Inline | `Open @@ -133,6 +135,8 @@ let print : [< t ] -> string = function | `Tag (`Raise _) -> "'@raise'" | `Tag `Return -> "'@return'" | `Tag `Children_order -> "'@children_order'" + | `Tag `Order_category -> "'@order_category'" + | `Tag `Toc_status -> "'@toc_status'" | `Tag `Short_title -> "'@short_title'" | `Tag (`See _) -> "'@see'" | `Tag (`Since _) -> "'@since'" @@ -239,6 +243,8 @@ let describe : [< t | `Comment ] -> string = function | `Tag `Closed -> "'@closed'" | `Tag `Hidden -> "'@hidden" | `Tag `Children_order -> "'@children_order" + | `Tag `Toc_status -> "'@toc_status" + | `Tag `Order_category -> "'@order_category" | `Tag `Short_title -> "'@short_title" | `Comment -> "top-level text" diff --git a/src/search/html.ml b/src/search/html.ml index 7e9619e43f..54763bdd59 100644 --- a/src/search/html.ml +++ b/src/search/html.ml @@ -126,6 +126,12 @@ let constructor_rhs ({ args; res } : Entry.constructor_entry) = let kind_doc = "doc" +let kind_page = "page" + +let kind_dir = "dir" + +let kind_impl = "impl" + let kind_typedecl = "type" let kind_module = "mod" @@ -165,6 +171,9 @@ let string_of_kind = | TypeExtension _ -> kind_extension | ModuleType _ -> kind_module_type | Doc -> kind_doc + | Page _ -> kind_page + | Impl -> kind_impl + | Dir -> kind_dir let value_rhs (t : Entry.value_entry) = " : " ^ Text.of_type t.type_ @@ -182,7 +191,7 @@ let rhs_of_kind (entry : Entry.kind) = Some (constructor_rhs t) | Field f -> Some (field_rhs f) | Module _ | Class_type _ | Method _ | Class _ | TypeExtension _ - | ModuleType _ | Doc -> + | ModuleType _ | Doc | Page _ | Impl | Dir -> None let names_of_id id = diff --git a/src/search/json_index/json_search.ml b/src/search/json_index/json_search.ml index 6b8b2f3c53..ec2a9a4a92 100644 --- a/src/search/json_index/json_search.ml +++ b/src/search/json_index/json_search.ml @@ -161,6 +161,9 @@ let of_entry ({ Entry.id; doc; kind } as entry) html occurrences = ("type", `String (Text.of_type type_)); ("parent_type", `String (Text.of_type parent_type)); ] + | Page _ -> return "Page" [] + | Impl -> return "Impl" [] + | Dir -> return "Dir" [] in let occurrences = match occurrences with @@ -180,47 +183,7 @@ let of_entry ({ Entry.id; doc; kind } as entry) html occurrences = ([ ("id", j_id); ("doc", doc); ("kind", kind); ("display", display) ] @ occurrences) -let output_json ppf first (entry, html, occurrences) = - let output_json json = - let str = Odoc_html.Json.to_string json in - Format.fprintf ppf "%s\n" str - in - let json = of_entry entry html occurrences in - if not first then Format.fprintf ppf ","; - output_json json; - false - -let unit ?occurrences ppf u = - 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 f first entry = - let entry = - let occ = get_occ entry.Entry.id in - (entry, Html.of_entry entry, occ) - in - let first = output_json ppf first entry in - first - in - let skel = Odoc_index.Skeleton.from_unit u in - let _first = Odoc_utils.Tree.fold_left ~f true skel in - () - -let page ppf (page : Odoc_model.Lang.Page.t) = - let f first entry = - let entry = (entry, Html.of_entry entry, None) in - output_json ppf first entry - in - let skel = Odoc_index.Skeleton.from_page page in - let _first = Odoc_utils.Tree.fold_left ~f true skel in - () - -let index ?occurrences ppf (index : Skeleton.t list) = +let of_entry ?occurrences entry = let get_occ id = match occurrences with | None -> None @@ -229,10 +192,8 @@ let index ?occurrences ppf (index : Skeleton.t list) = | Some x -> Some x | None -> Some { direct = 0; indirect = 0 }) in - let _first = - Odoc_utils.Forest.fold_left true index ~f:(fun first entry -> - let occ = get_occ entry.Entry.id in - let entry = (entry, Html.of_entry entry, occ) in - output_json ppf first entry) + let entry, html, occurrences = + let occ = get_occ entry.Entry.id in + (entry, Html.of_entry entry, occ) in - () + of_entry entry html occurrences diff --git a/src/search/json_index/json_search.mli b/src/search/json_index/json_search.mli index 2a5184ada5..20f0ea0f23 100644 --- a/src/search/json_index/json_search.mli +++ b/src/search/json_index/json_search.mli @@ -1,13 +1,6 @@ (** This module generates json intended to be consumed by search engines. *) -val unit : +val of_entry : ?occurrences:Odoc_occurrences.Table.t -> - Format.formatter -> - Odoc_model.Lang.Compilation_unit.t -> - unit -val page : Format.formatter -> Odoc_model.Lang.Page.t -> unit -val index : - ?occurrences:Odoc_occurrences.Table.t -> - Format.formatter -> - Odoc_index.Skeleton.t list -> - unit + Odoc_index.Entry.t -> + Odoc_utils.Json.json diff --git a/src/utils/odoc_list.ml b/src/utils/odoc_list.ml index 53ddf484c7..a571bb9241 100644 --- a/src/utils/odoc_list.ml +++ b/src/utils/odoc_list.ml @@ -27,3 +27,9 @@ let rec find_map f = function | [] -> None | x :: l -> ( match f x with Some _ as result -> result | None -> find_map f l) + +let rec find_opt p = function + | [] -> None + | x :: l -> if p x then Some x else find_opt p l + +let is_empty = function [] -> true | _ :: _ -> false diff --git a/test/frontmatter/frontmatter.t/run.t b/test/frontmatter/frontmatter.t/run.t index 00c752e4d1..e9a4bffc86 100644 --- a/test/frontmatter/frontmatter.t/run.t +++ b/test/frontmatter/frontmatter.t/run.t @@ -4,7 +4,9 @@ When there is no frontmatter, everything is normal $ odoc_print page-zero_frontmatter.odoc | jq '.frontmatter' { "children": "None", - "short_title": "None" + "short_title": "None", + "toc_status": "None", + "order_category": "None" } When there is one frontmatter, it is extracted from the content: @@ -30,7 +32,9 @@ When there is one frontmatter, it is extracted from the content: "`Word": "yes!" } ] - } + }, + "toc_status": "None", + "order_category": "None" } $ odoc_print page-one_frontmatter.odoc | jq '.content' [ @@ -83,7 +87,9 @@ When there is more than one children order, we raise a warning and keep only the } ] }, - "short_title": "None" + "short_title": "None", + "toc_status": "None", + "order_category": "None" } $ odoc_print page-two_frontmatters.odoc | jq '.content' [ diff --git a/test/frontmatter/toc_order.t/index.mld b/test/frontmatter/toc_order.t/index.mld index 30817cc9f1..388bdfac93 100644 --- a/test/frontmatter/toc_order.t/index.mld +++ b/test/frontmatter/toc_order.t/index.mld @@ -1,4 +1,4 @@ -@children_order content dir1/ dir1/ typo +@children_order content module-Unit dir1/ dir1/ typo {0 This is the main index} diff --git a/test/frontmatter/toc_order.t/run.t b/test/frontmatter/toc_order.t/run.t index 74f42bdf9d..4d66f17d08 100644 --- a/test/frontmatter/toc_order.t/run.t +++ b/test/frontmatter/toc_order.t/run.t @@ -1,3 +1,6 @@ + $ ocamlc -c -bin-annot unit.ml + + $ odoc compile --parent-id pkg --output-dir _odoc unit.cmt $ odoc compile --parent-id pkg --output-dir _odoc index.mld $ odoc compile --parent-id pkg --output-dir _odoc content.mld $ odoc compile --parent-id pkg --output-dir _odoc omitted.mld @@ -6,18 +9,19 @@ $ odoc compile --parent-id pkg/dir1 --output-dir _odoc dir1/dontent.mld $ odoc link _odoc/pkg/page-index.odoc + $ odoc link _odoc/pkg/unit.odoc $ odoc link _odoc/pkg/page-content.odoc $ odoc link _odoc/pkg/page-omitted.odoc $ odoc link _odoc/pkg/dir1/page-index.odoc $ odoc link _odoc/pkg/dir1/page-content_in_dir.odoc $ odoc link _odoc/pkg/dir1/page-dontent.odoc - $ odoc compile-index -P test:_odoc/pkg - File "index.mld", line 1, characters 30-35: + $ odoc compile-index --root _odoc/pkg + File "index.mld", line 1, characters 42-47: Warning: Duplicate 'dir1/' in (children). - File "index.mld", line 1, characters 36-40: + File "index.mld", line 1, characters 48-52: Warning: 'typo' in (children) does not correspond to anything. - File "index.mld", line 1, characters 0-40: + File "index.mld", line 1, characters 0-52: Warning: (children) doesn't include 'omitted'. Turn the index into a sidebar (removes all unnecessary entries) @@ -38,6 +42,9 @@ Turn the index into a sidebar (removes all unnecessary entries) { "Page": "content" }, + { + "Module": "Unit" + }, { "Dir": "dir1" }, @@ -49,7 +56,9 @@ Turn the index into a sidebar (removes all unnecessary entries) } ] }, - "short_title": "None" + "short_title": "None", + "toc_status": "None", + "order_category": "None" } @@ -62,18 +71,18 @@ Typo is in the children field of index, but does not exist. It is omitted to, but this should be a warning! $ cat _html/pkg/index.html | grep odoc-global-toc -A 11 -