diff --git a/CHANGES.md b/CHANGES.md index 6ca6220f00..97c35479ec 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -17,8 +17,10 @@ Absolute (`{!/foo}`), relative (`{!./foo}`) and package-local (`{!//foo}`) are added. - Add a marshalled search index consumable by sherlodoc (@EmileTrotignon, @panglesd, #1084) -- Add a `--index` argument to pass indexes to the document generation, currently - used for sidebar (@panglesd, #1145) +- Add a `odoc sidebar-generate` command to generate a sidebar file (@panglesd, + #1250) +- Add a `--sidebar` argument to pass sidebars to the document generation + (@panglesd, #1145, #1250) - Allow referencing of polymorphic constructors in polymorphic variant type aliases (@panglesd, #1115) - Added a `--occurrences` argument to the `compile-index` command to output the diff --git a/doc/odoc.mld b/doc/odoc.mld index baff53dfec..c294450102 100644 --- a/doc/odoc.mld +++ b/doc/odoc.mld @@ -1,8 +1,6 @@ -{0 [odoc]} +@children_order dune odoc_for_authors cheatsheet features ocamldoc_differences interface parent_child_spec driver -{@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/src/document/sidebar.ml b/src/document/sidebar.ml index f1d69e1429..bffa98e0d7 100644 --- a/src/document/sidebar.ml +++ b/src/document/sidebar.ml @@ -2,70 +2,54 @@ open Odoc_utils open Types module Id = Odoc_model.Paths.Identifier -module Toc : sig - type t +type entry = { + url : Url.t; + valid_link : bool; + content : Inline.t; + toc_status : [ `Open ] option; +} + +open Odoc_index - val of_page_hierarchy : Odoc_index.Page_hierarchy.t -> t +module Toc : sig + type t = entry Tree.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 = (Url.t option * Inline.one) 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 + type t = entry Tree.t - 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 = @@ -80,27 +64,62 @@ 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 + { url; content; toc_status; valid_link = true } 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 @@ -108,67 +127,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 eecb0c8c15..e6f8837263 100644 --- a/src/document/sidebar.mli +++ b/src/document/sidebar.mli @@ -1,6 +1,16 @@ -type t +open Odoc_utils +open Types -val of_lang : Odoc_index.t -> t +type entry = { + url : Url.t; + valid_link : bool; + content : Inline.t; + toc_status : [ `Open ] option; +} + +type t = entry Tree.forest + +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 1aea27f7e4..a291dc47fc 100644 --- a/src/driver/common_args.ml +++ b/src/driver/common_args.ml @@ -52,6 +52,10 @@ let generate_grep = let doc = "Show html-generate commands containing the string" in Arg.(value & opt (some string) None & info [ "html-grep" ] ~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; @@ -65,6 +69,7 @@ type t = { compile_grep : string option; link_grep : string option; generate_grep : string option; + index_grep : string option; } let term = @@ -82,6 +87,7 @@ let term = and+ odoc_bin = odoc_bin and+ compile_grep = compile_grep and+ link_grep = link_grep + and+ index_grep = index_grep and+ generate_grep = generate_grep in { verbose; @@ -96,4 +102,5 @@ let term = compile_grep; link_grep; generate_grep; + index_grep; } diff --git a/src/driver/compile.ml b/src/driver/compile.ml index e8d184771b..b25c952d42 100644 --- a/src/driver/compile.ml +++ b/src/driver/compile.ml @@ -269,15 +269,19 @@ let html_generate ~occurrence_file output_dir linked = let compile_index : Odoc_unit.index -> _ = fun index -> let compile_index_one - ({ pkg_args; output_file; json; search_dir = _ } 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 - sherlodoc_index_one ~output_dir index + let sidebar = + match sidebar with + | None -> None + | Some { output_file; json } -> + Odoc.sidebar_generate ~output_file ~json index.output_file (); + Some output_file + in + (sherlodoc_index_one ~output_dir index, sidebar) in match Hashtbl.find_opt tbl index.output_file with | None -> @@ -296,26 +300,33 @@ let html_generate ~occurrence_file output_dir linked = match l.kind with | `Intf { hidden = true; _ } -> () | `Impl { src_path; _ } -> - Odoc.html_generate_source ~search_uris:[] ~output_dir ~input_file + 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:[] ~output_dir ~input_file + 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 ~asset_path:l.input_file () | _ -> - let search_uris, index = + let search_uris, sidebar = match l.index with | None -> (None, None) | Some index -> - let db_path = compile_index index in + let db_path, sidebar = compile_index index in let search_uris = [ db_path; Sherlodoc.js_file ] in - let index = index.output_file in - (Some search_uris, Some index) + (Some search_uris, sidebar) in - Odoc.html_generate ?search_uris ?index ~output_dir ~input_file (); - Odoc.html_generate ?search_uris ?index ~output_dir ~input_file + Odoc.html_generate ?search_uris ?sidebar ~output_dir ~input_file (); + Odoc.html_generate ?search_uris ?sidebar ~output_dir ~input_file ~as_json:true (); Atomic.incr Stats.stats.generated_units in diff --git a/src/driver/landing_pages.ml b/src/driver/landing_pages.ml index f122265ddd..ada399ff8f 100644 --- a/src/driver/landing_pages.ml +++ b/src/driver/landing_pages.ml @@ -24,7 +24,8 @@ let make_index ~dirs ~rel_dir ?index ~content () = let library ~dirs ~pkg ~index lib = let content ppf = - Format.fprintf ppf "{0 Library %s}@\n" lib.Packages.lib_name; + Format.fprintf ppf "%@toc_status open\n"; + 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 @@ -41,6 +42,13 @@ let package ~dirs ~pkg ~index = let rel_dir = doc_dir pkg in make_index ~dirs ~rel_dir ~index ~content () +let src ~dirs ~pkg ~index = + let content ppf = + Format.fprintf ppf "{0 Sources}@\nUse sidebar to navigate." + 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 = 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 14f72f505f..244206628a 100644 --- a/src/driver/odoc.ml +++ b/src/driver/odoc.ml @@ -18,6 +18,8 @@ end let index_filename = "index.odoc-index" +let sidebar_filename = "sidebar.odoc-sidebar" + type compile_deps = { digest : Digest.t; deps : (string * Digest.t) list } let odoc = ref (Cmd.v "odoc") @@ -157,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 @@ -168,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) @@ -179,11 +181,26 @@ let compile_index ?(ignore_output = false) ~output_file ?occurrence_file ~json in ignore @@ Cmd_outputs.submit log desc cmd (Some output_file) -let html_generate ~output_dir ?index ?(ignore_output = false) +let sidebar_generate ?(ignore_output = false) ~output_file ~json input_file () = + let json = if json then Cmd.v "--json" else Cmd.empty in + let cmd = + Cmd.( + !odoc % "sidebar-generate" %% json %% v "-o" % p output_file + % p input_file) + in + let desc = + Printf.sprintf "Generating sidebar for %s" (Fpath.to_string output_file) + in + let log = + if ignore_output then None else Some (`Generate, Fpath.to_string output_file) + in + ignore @@ Cmd_outputs.submit log desc cmd (Some output_file) + +let html_generate ~output_dir ?sidebar ?(ignore_output = false) ?(search_uris = []) ?(as_json = false) ~input_file:file () = let open Cmd in let index = - match index with None -> empty | Some idx -> v "--index" % p idx + match sidebar with None -> empty | Some idx -> v "--sidebar" % p idx in let search_uris = List.fold_left @@ -213,18 +230,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 @@ -249,18 +269,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 f1a201f0a7..73b3b5936a 100644 --- a/src/driver/odoc.mli +++ b/src/driver/odoc.mli @@ -6,6 +6,7 @@ module Id : sig end val index_filename : string +val sidebar_filename : string val odoc : Bos.Cmd.t ref @@ -45,14 +46,21 @@ 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 + +val sidebar_generate : + ?ignore_output:bool -> + output_file:Fpath.t -> + json:bool -> + Fpath.t -> unit -> unit val html_generate : output_dir:string -> - ?index:Fpath.t -> + ?sidebar:Fpath.t -> ?ignore_output:bool -> ?search_uris:Fpath.t list -> ?as_json:bool -> @@ -72,6 +80,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 -> @@ -81,5 +90,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 eaad6e4d62..4d5e72a730 100644 --- a/src/driver/odoc_driver.ml +++ b/src/driver/odoc_driver.ml @@ -133,6 +133,7 @@ let run mode compile_grep; link_grep; generate_grep; + index_grep; } = Option.iter (fun odoc_bin -> Odoc.odoc := Bos.Cmd.v odoc_bin) odoc_bin; let _ = Voodoo.find_universe_and_version "foo" in @@ -238,30 +239,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 3409f8377c..0298d4da31 100644 --- a/src/driver/odoc_unit.ml +++ b/src/driver/odoc_unit.ml @@ -36,17 +36,21 @@ module Pkg_args = struct x.odoc_dir Fpath.pp x.odocl_dir sfp_pp x.pages sfp_pp x.libs 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; + sidebar : sidebar option; } 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; @@ -115,6 +119,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 dc0e2f306b..a126337a2b 100644 --- a/src/driver/odoc_unit.mli +++ b/src/driver/odoc_unit.mli @@ -16,11 +16,13 @@ module Pkg_args : sig val pp : t Fmt.t 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; + sidebar : sidebar option; } type 'a unit = { @@ -52,6 +54,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 02e4b7b73a..c26372bcf3 100644 --- a/src/driver/odoc_units_of.ml +++ b/src/driver/odoc_units_of.ml @@ -78,13 +78,19 @@ let packages ~dirs ~extra_paths (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 - { pkg_args; output_file; json = false; search_dir = pkg.pkg_dir } + let sidebar = + let output_file = Fpath.(index_dir / pkg.name / Odoc.sidebar_filename) in + { output_file; json = false } + in + { + roots; + output_file; + json = false; + search_dir = pkg.pkg_dir; + sidebar = Some sidebar; + } in let make_unit ~name ~kind ~rel_dir ~input_file ~pkg ~lib_deps ~enable_warnings @@ -159,8 +165,7 @@ let packages ~dirs ~extra_paths (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 @@ -257,7 +262,15 @@ let packages ~dirs ~extra_paths (pkgs : Packages.t list) : t list = 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 List.length pkg.libraries > 0 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 9bfaa24933..fbc9add191 100644 --- a/src/driver/packages.ml +++ b/src/driver/packages.ml @@ -396,15 +396,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; @@ -413,7 +404,7 @@ let of_libs ~packages_dir libs = mlds; assets; enable_warnings = false; - other_docs; + other_docs = []; pkg_dir; config; }) @@ -463,15 +454,7 @@ 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 enable_warnings = List.mem pkg.name packages in - let other_docs = Fpath.Set.elements other_docs in Util.StringMap.add pkg.name { name = pkg.name; @@ -480,7 +463,7 @@ let of_packages ~packages_dir packages = mlds; assets; enable_warnings; - 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/generator.ml b/src/html/generator.ml index ab1c5da09e..c8538607ae 100644 --- a/src/html/generator.ml +++ b/src/html/generator.ml @@ -497,8 +497,7 @@ end module Breadcrumbs = struct open Types - - let gen_breadcrumbs ~config ~url = + let gen_breadcrumbs_no_sidebar ~config ~url = let rec get_parent_paths x = match x with | [] -> [] @@ -509,13 +508,50 @@ module Breadcrumbs = struct in let to_breadcrumb path = let href = - Link.href ~config ~resolve:(Current url) - (Odoc_document.Url.from_path path) + Some + (Link.href ~config ~resolve:(Current url) + (Odoc_document.Url.from_path path)) in - { href; name = path.name; kind = path.kind } + { href; name = [ Html.txt path.name ]; kind = path.kind } in get_parent_paths (List.rev (Odoc_document.Url.Path.to_list url)) |> List.rev |> List.map to_breadcrumb + + let gen_breadcrumbs ~config ~sidebar ~url:current_url = + match sidebar with + | None -> gen_breadcrumbs_no_sidebar ~config ~url:current_url + | Some sidebar -> + let rec extract acc (tree : Odoc_document.Sidebar.t) = + match + List.find_map + (function + | ({ + node = + { + url = { page; anchor = ""; _ } as url; + valid_link; + content; + _; + }; + children; + } : + Odoc_document.Sidebar.entry Odoc_utils.Tree.t) + when Url.Path.is_prefix page current_url -> + let href = + if valid_link then + Some + (Link.href ~config ~resolve:(Current current_url) url) + else None + in + let name = inline_nolink content in + Some ({ href; name; kind = page.kind }, children) + | _ -> None) + tree + with + | None -> List.rev acc + | Some (bc, children) -> extract (bc :: acc) children + in + extract [] sidebar end module Page = struct @@ -538,6 +574,7 @@ module Page = struct in let subpages = subpages ~config ~sidebar @@ Doctree.Subpages.compute p in let resolve = Link.Current url in + let breadcrumbs = Breadcrumbs.gen_breadcrumbs ~config ~sidebar ~url in let sidebar = match sidebar with | None -> None @@ -548,7 +585,6 @@ module Page = struct let i = Doctree.Shift.compute ~on_sub i in let uses_katex = Doctree.Math.has_math_elements p in let toc = Toc.gen_toc ~config ~resolve ~path:url i in - let breadcrumbs = Breadcrumbs.gen_breadcrumbs ~config ~url in let content = (items ~config ~resolve i :> any Html.elt list) in if Config.as_json config then let source_anchor = @@ -567,26 +603,39 @@ 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 let doc ~config ~xref_base_uri b = let resolve = Link.Base xref_base_uri in block ~config ~resolve b + +let inline ~config ~xref_base_uri b = + let resolve = Link.Base xref_base_uri in + inline ~config ~resolve b diff --git a/src/html/generator.mli b/src/html/generator.mli index fa95d3249b..1474390ce8 100644 --- a/src/html/generator.mli +++ b/src/html/generator.mli @@ -11,3 +11,9 @@ val doc : xref_base_uri:string -> Odoc_document.Types.Block.t -> Html_types.flow5_without_sectioning_heading_header_footer Tyxml.Html.elt list + +val inline : + config:Config.t -> + xref_base_uri:string -> + Odoc_document.Types.Inline.t -> + Html_types.phrasing Tyxml.Html.elt list diff --git a/src/html/html_fragment_json.ml b/src/html/html_fragment_json.ml index 54dac13473..39c9b28031 100644 --- a/src/html/html_fragment_json.ml +++ b/src/html/html_fragment_json.ml @@ -1,24 +1,29 @@ (* Rendering of HTML fragments together with metadata. For embedding the generated documentation in existing websites. *) +open Odoc_utils module Html = Tyxml.Html module Url = Odoc_document.Url -let json_of_breadcrumbs (breadcrumbs : Types.breadcrumb list) : Utils.Json.json +let json_of_html config h = + let htmlpp = Html.pp_elt ~indent:(Config.indent config) () in + String.concat "" (List.map (Format.asprintf "%a" htmlpp) h) + +let json_of_breadcrumbs config (breadcrumbs : Types.breadcrumb list) : Json.json = let breadcrumb (b : Types.breadcrumb) = `Object [ - ("name", `String b.name); - ("href", `String b.href); + ("name", `String (json_of_html config b.name)); + ("href", match b.href with None -> `Null | Some href -> `String href); ("kind", `String (Url.Path.string_of_kind b.kind)); ] in let json_breadcrumbs = breadcrumbs |> List.map breadcrumb in `Array json_breadcrumbs -let json_of_toc (toc : Types.toc list) : Utils.Json.json = +let json_of_toc (toc : Types.toc list) : Json.json = let rec section (s : Types.toc) = `Object [ @@ -30,23 +35,20 @@ let json_of_toc (toc : Types.toc list) : Utils.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 let filename = Fpath.add_ext ".json" filename in - let json_to_string json = Utils.Json.to_string json in + let json_to_string json = Json.to_string json in 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 +56,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 = Utils.Json.to_string json 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..d3e0527e8d 100644 --- a/src/html/html_fragment_json.mli +++ b/src/html/html_fragment_json.mli @@ -17,5 +17,6 @@ val make_src : config:Config.t -> url:Odoc_document.Url.Path.t -> breadcrumbs:Types.breadcrumb list -> + 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..a4e971fb2f 100644 --- a/src/html/html_page.ml +++ b/src/html/html_page.ml @@ -64,42 +64,52 @@ let sidebars ~global_toc ~local_toc = let html_of_breadcrumbs (breadcrumbs : Types.breadcrumb list) = let make_navigation ~up_url rest = - [ - Html.nav - ~a:[ Html.a_class [ "odoc-nav" ] ] - ([ Html.a ~a:[ Html.a_href up_url ] [ Html.txt "Up" ]; Html.txt " – " ] - @ rest); - ] + let up = + match up_url with + | None -> [] + | Some up_url -> + [ Html.a ~a:[ Html.a_href up_url ] [ Html.txt "Up" ]; Html.txt " – " ] + in + [ Html.nav ~a:[ Html.a_class [ "odoc-nav" ] ] (up @ rest) ] in match List.rev breadcrumbs with - | [] -> [] (* Can't happen - there's always the current page's breadcrumb. *) - | [ _ ] -> [] (* No parents *) - | [ { name = "index"; _ }; x ] -> - (* Special case leaf pages called 'index' with one parent. This is for files called - index.mld that would otherwise clash with their parent. In particular, - dune and odig both cause this situation right now. *) - let up_url = "../index.html" in - let parent_name = x.name in - make_navigation ~up_url [ Html.txt parent_name ] - | current :: up :: bs -> + | [] -> + [ Html.nav ~a:[ Html.a_class [ "odoc-nav" ] ] [ Html.txt "yooooooo" ] ] + (* Can't happen - there's always the current page's breadcrumb. *) + | current :: rest -> let space = Html.txt " " in - let sep = [ space; Html.entity "#x00BB"; space ] in + let sep :> Html_types.nav_content_fun Html.elt list = + [ space; Html.entity "#x00BB"; space ] + in let html = (* Create breadcrumbs *) - Odoc_utils.List.concat_map ?sep:(Some sep) + Odoc_utils.List.concat_map ~sep ~f:(fun (breadcrumb : Types.breadcrumb) -> - [ - [ - Html.a - ~a:[ Html.a_href breadcrumb.href ] - [ Html.txt breadcrumb.name ]; - ]; - ]) - (up :: bs) + match breadcrumb.href with + | Some href -> + [ + [ + Html.a + ~a:[ Html.a_href href ] + (breadcrumb.name + :> Html_types.flow5_without_interactive Html.elt list); + ]; + ] + | None -> + [ + (breadcrumb.name :> Html_types.nav_content_fun Html.elt list); + ]) + rest |> List.flatten in - make_navigation ~up_url:up.href - (List.rev html @ sep @ [ Html.txt current.name ]) + let current_name :> Html_types.nav_content_fun Html.elt list = + current.name + in + let up_url = List.find_map (fun (b : Types.breadcrumb) -> b.href) rest in + let rest = List.rev html @ sep @ current_name in + make_navigation ~up_url + (rest + :> [< Html_types.nav_content_fun > `A `PCDATA `Wbr ] Html.elt list) let file_uri ~config ~url (base : Types.uri) file = match base with @@ -258,7 +268,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 +279,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 +295,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..f327091447 100644 --- a/src/html/html_page.mli +++ b/src/html/html_page.mli @@ -40,6 +40,7 @@ val make_src : url:Odoc_document.Url.Path.t -> breadcrumbs:Types.breadcrumb list -> 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/odoc_html.ml b/src/html/odoc_html.ml index e7150f71e5..c05911dcb2 100644 --- a/src/html/odoc_html.ml +++ b/src/html/odoc_html.ml @@ -9,4 +9,4 @@ module Html_page = Html_page module Generator = Generator module Link = Link -module Json = Utils.Json +module Json = Odoc_utils.Json diff --git a/src/html/types.ml b/src/html/types.ml index 31e7801c3c..82e6672d1f 100644 --- a/src/html/types.ml +++ b/src/html/types.ml @@ -12,7 +12,7 @@ type toc = { } type breadcrumb = { - href : string; - name : string; + href : string option; + name : Html_types.phrasing_without_interactive Tyxml.Html.elt list; kind : Odoc_document.Url.Path.kind; } diff --git a/src/html/utils.ml b/src/html/utils.ml index 99281c0cb6..c575214450 100644 --- a/src/html/utils.ml +++ b/src/html/utils.ml @@ -1,87 +1,3 @@ (* Shared utility functions *) let optional_elt f ?a = function [] -> [] | l -> [ f ?a l ] - -module Json = struct - type json = - [ `Null - | `Bool of bool - | `Float of float - | `String of string - | `Array of json list - | `Object of (string * json) list ] - - let rec buffer_add_json b = function - | `Null -> Buffer.add_string b "null" - | `Bool bool -> Buffer.add_string b (if bool then "true" else "false") - | `Float f -> Buffer.add_string b (Printf.sprintf "%.16g" f) - | `String s -> buffer_add_json_string b s - | `Array els -> ( - match els with - | [] -> Buffer.add_string b "[]" - | el :: els -> - let add_sep_el b e = - Buffer.add_char b ','; - buffer_add_json b e - in - Buffer.add_char b '['; - buffer_add_json b el; - List.iter (add_sep_el b) els; - Buffer.add_char b ']') - | `Object mems -> ( - match mems with - | [] -> Buffer.add_string b "{}" - | mem :: mems -> - let add_mem b (k, v) = - buffer_add_json_string b k; - Buffer.add_char b ':'; - buffer_add_json b v - in - let add_sep_mem b mem = - Buffer.add_char b ','; - add_mem b mem - in - Buffer.add_char b '{'; - add_mem b mem; - List.iter (add_sep_mem b) mems; - Buffer.add_char b '}') - - and buffer_add_json_string b s = - let is_control = function - | '\x00' .. '\x1F' | '\x7F' -> true - | _ -> false - in - let len = String.length s in - let max_idx = len - 1 in - let flush b start i = - if start < len then Buffer.add_substring b s start (i - start) - in - let rec loop start i = - match i > max_idx with - | true -> flush b start i - | false -> ( - let next = i + 1 in - match String.get s i with - | '"' -> - flush b start i; - Buffer.add_string b "\\\""; - loop next next - | '\\' -> - flush b start i; - Buffer.add_string b "\\\\"; - loop next next - | c when is_control c -> - flush b start i; - Buffer.add_string b (Printf.sprintf "\\u%04X" (Char.code c)); - loop next next - | _c -> loop start next) - in - Buffer.add_char b '"'; - loop 0 0; - Buffer.add_char b '"' - - let to_string json = - let b = Buffer.create 1024 in - buffer_add_json b json; - Buffer.contents b -end diff --git a/src/html_support_files/odoc.css b/src/html_support_files/odoc.css index f9a207132c..b5b63b3e7f 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,27 @@ 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 > a { + font-weight: 500; + font-size: 500; +} + +.odoc-toc.odoc-global-toc > ul > li > a { + font-size: 2em; +} + .current_unit { background-color: var(--anchor-color); } @@ -1341,6 +1369,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.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..56f95075a3 100644 --- a/src/index/skeleton.ml +++ b/src/index/skeleton.ml @@ -118,6 +118,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 +146,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 @@ -249,7 +268,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/page_hierarchy.ml b/src/index/skeleton_of.ml similarity index 51% rename from src/index/page_hierarchy.ml rename to src/index/skeleton_of.ml index 1784f4c03a..103c5f7120 100644 --- a/src/index/page_hierarchy.ml +++ b/src/index/skeleton_of.ml @@ -4,115 +4,85 @@ open Odoc_model (* Selective opens *) module Id = Odoc_model.Paths.Identifier module PageName = Odoc_model.Names.PageName +module ModuleName = Odoc_model.Names.ModuleName -module CPH = Id.Hashtbl.ContainerPage -module LPH = Id.Hashtbl.LeafPage +type t = Entry.t Tree.t -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 +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 current_item = - try Some (CPH.find parent_dirs id) with Not_found -> None + let entry_of_impl id = + let kind = Entry.Impl in + let doc = [] in + Entry.entry ~kind ~doc ~id 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)) + 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 = - leafs dir - |> List.map (fun (id, payload) -> - let id :> Id.Page.t = id in - (id, Tree.leaf (Page (id, payload)))) + 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 = - dirs dir + In_progress.dirs dir |> List.map (fun (id, payload) -> - let id :> Id.Page.t = id in + let id :> Id.t = id in (id, t_of_in_progress payload)) in - leafs @ dirs + 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) @@ -123,15 +93,17 @@ let rec t_of_in_progress (dir : in_progress) : t = let equal id ch = match (ch, id.Id.iv) with | (_, { Location_.value = Frontmatter.Dir c; _ }), `Page (_, name) -> - String.equal (PageName.to_string name) c + Astring.String.equal (PageName.to_string name) c | (_, { Location_.value = Page c; _ }), `LeafPage (_, name) -> - String.equal (PageName.to_string name) c + 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 : Id.Page.t), _) as entry) -> + ((id, _) as entry) -> let indexes_for_entry, children_indexes = List.partition (equal id) children_indexes in @@ -183,10 +155,12 @@ let rec t_of_in_progress (dir : in_progress) : t = let rec remove_common_root (v : t) = match v with - | { Tree.children = [ v ]; node = Missing_index _ } -> remove_common_root v + | { Tree.children = [ v ]; node = { kind = Dir; _ } } -> remove_common_root v | _ -> v -let of_list l = - let dir = empty_t None in - List.iter (add dir) l; +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/frontmatter.ml b/src/model/frontmatter.ml index 00c4e9497c..7be901b1ac 100644 --- a/src/model/frontmatter.ml +++ b/src/model/frontmatter.ml @@ -1,19 +1,21 @@ -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 ] 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 ] option; } -let empty = { children_order = None; short_title = None } +let empty = { children_order = None; short_title = None; toc_status = None } let update ~tag_name ~loc v new_v = match v with @@ -24,6 +26,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 @@ -38,12 +45,19 @@ let apply fm line = { fm with children_order } 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 +75,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 +85,13 @@ 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)) + | _ -> Error (Error.make "@toc_status can only take the 'open' 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..a60ec026a2 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,26 @@ 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 ] 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 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..c50b38e73f 100644 --- a/src/model/semantics.ml +++ b/src/model/semantics.ml @@ -25,6 +25,7 @@ let describe_internal_tag = function | `Closed -> "@closed" | `Hidden -> "@hidden" | `Children_order _ -> "@children_order" + | `Toc_status _ -> "@toc_status" | `Short_title _ -> "@short_title" let warn_unexpected_tag { Location.value; location } = @@ -485,7 +486,7 @@ 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 _) as tag -> let tag_name = describe_internal_tag tag in if not start then Error.raise_warning @@ -553,7 +554,9 @@ 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 _) as p -> + Some p + | _ -> None) tags in let lines = @@ -569,6 +572,7 @@ 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 + | `Toc_status co, loc -> do_ Frontmatter.parse_toc_status loc co | `Short_title t, loc -> do_ Frontmatter.parse_short_title loc t) unparsed_lines in diff --git a/src/model_desc/lang_desc.ml b/src/model_desc/lang_desc.ml index eb32d6a9c0..70f2d6d1b3 100644 --- a/src/model_desc/lang_desc.ml +++ b/src/model_desc/lang_desc.ml @@ -725,7 +725,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 2549eb3ce2..10e612d056 100644 --- a/src/odoc/bin/main.ml +++ b/src/odoc/bin/main.ml @@ -468,14 +468,12 @@ 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 = let doc = @@ -510,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 = @@ -544,6 +531,59 @@ module Indexing = struct Term.info "compile-index" ~docs ~doc end +module Sidebar = struct + open Or_error + + let output_file ~dst marshall = + match (dst, marshall) with + | Some file, `JSON when not (Fpath.has_ext "json" (Fpath.v file)) -> + Error + (`Msg + "When generating a sidebar with --json, the output must have a \ + .json file extension") + | Some file, `Marshall + when not (Fpath.has_ext "odoc-sidebar" (Fpath.v file)) -> + Error + (`Msg + "When generating sidebar, the output must have a .odoc-sidebar \ + file extension") + | Some file, _ -> Ok (Fs.File.of_string file) + | None, `JSON -> Ok (Fs.File.of_string "sidebar.json") + | None, `Marshall -> Ok (Fs.File.of_string "sidebar.odoc-sidebar") + + let generate dst json warnings_options input = + let marshall = if json then `JSON else `Marshall in + output_file ~dst marshall >>= fun output -> + Sidebar.generate ~marshall ~output ~warnings_options ~index:input + + let cmd = + let dst = + let doc = + "Output file path. Non-existing intermediate directories are created. \ + Defaults to sidebar.odoc-sidebar, or sidebar.json if --json is \ + passed." + in + Arg.( + value & opt (some string) None & info ~docs ~docv:"PATH" ~doc [ "o" ]) + in + let json = + let doc = "whether to output a json file, or a binary .odoc-index file" in + Arg.(value & flag & info ~doc [ "json" ]) + in + let inputs = + let doc = ".odoc-index file to generate a value from" in + Arg.( + required & pos 0 (some convert_fpath) None & info ~doc ~docv:"FILE" []) + in + Term.( + const handle_error + $ (const generate $ dst $ json $ warnings_options $ inputs)) + + let info ~docs = + let doc = "Generate a sidebar from an index file." in + Term.info "sidebar-generate" ~docs ~doc +end + module Support_files_command = struct let support_files without_theme output_dir = Support_files.write ~without_theme output_dir @@ -809,7 +849,7 @@ end = struct Arg.( value & opt (some convert_fpath) None - & info [ "index" ] ~doc ~docv:"FILE.odoc-index") + & info [ "sidebar" ] ~doc ~docv:"FILE.odoc-sidebar") let cmd = let syntax = @@ -836,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 @@ -863,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 = @@ -1554,6 +1597,7 @@ let () = Support_files_command.(cmd, info ~docs:section_pipeline); Compile_impl.(cmd, info ~docs:section_pipeline); Indexing.(cmd, info ~docs:section_pipeline); + Sidebar.(cmd, info ~docs:section_pipeline); Odoc_manpage.generate ~docs:section_generators; Odoc_latex.generate ~docs:section_generators; Odoc_html_url.(cmd, info ~docs:section_support); 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..f7490d85bb 100644 --- a/src/odoc/indexing.ml +++ b/src/odoc/indexing.ml @@ -10,16 +10,13 @@ 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_index file >>= fun index -> Ok (occ index) | _ -> ( 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 = Unit_content unit'; _ } -> Ok (unit unit') | { Odoc_file.content = Page_content page'; _ } -> Ok (page page') | _ -> Error @@ -43,7 +40,7 @@ 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) @@ -55,101 +52,36 @@ let compile_to_json ~output ~occurrences files = false in Format.fprintf output "["; - let _ : bool = + let _first = 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 first hierarchy -> + Tree.fold_left + ~f:(fun first entry -> + print (Json_search.of_entry ?occurrences) first entry) + first hierarchy) + true hierarchies in Format.fprintf output "]"; 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 +89,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..ebe59dabc3 100644 --- a/src/odoc/indexing.mli +++ b/src/odoc/indexing.mli @@ -14,8 +14,7 @@ val compile : 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.ml b/src/odoc/odoc_file.ml index 8a531eaa3c..732994f9a6 100644 --- a/src/odoc/odoc_file.ml +++ b/src/odoc/odoc_file.ml @@ -116,3 +116,7 @@ let load_root file = let save_index dst idx = save_ dst (fun oc -> Marshal.to_channel oc idx []) let load_index file = load_ file (fun ic -> Ok (Marshal.from_channel ic)) + +let save_sidebar dst idx = save_ dst (fun oc -> Marshal.to_channel oc idx []) + +let load_sidebar file = load_ file (fun ic -> Ok (Marshal.from_channel ic)) diff --git a/src/odoc/odoc_file.mli b/src/odoc/odoc_file.mli index 0f6c076efe..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 : @@ -56,4 +55,9 @@ val save_index : Fs.File.t -> Odoc_index.t -> unit val load_index : Fs.File.t -> (Odoc_index.t, [> msg ]) result (** Load a [.odoc-index] file. *) +val save_sidebar : Fs.File.t -> Odoc_document.Sidebar.t -> unit + +val load_sidebar : Fs.File.t -> (Odoc_document.Sidebar.t, [> msg ]) result +(** Load a [.odoc-index] file. *) + val save_asset : Fpath.t -> warnings:Error.t list -> Lang.Asset.t -> unit diff --git a/src/odoc/rendering.ml b/src/odoc/rendering.ml index 173562805f..bda6a47188 100644 --- a/src/odoc/rendering.ml +++ b/src/odoc/rendering.ml @@ -68,9 +68,7 @@ let generate_odoc ~syntax ~warnings_options:_ ~renderer ~output ~extra_suffix ~sidebar extra file = (match sidebar with | None -> Ok None - | Some x -> - Odoc_file.load_index x >>= fun index -> - Ok (Some (Odoc_document.Sidebar.of_lang index))) + | Some x -> Odoc_file.load_sidebar x >>= fun sidebar -> Ok (Some sidebar)) >>= fun sidebar -> document_of_odocl ~syntax file >>= fun doc -> render_document renderer ~output ~sidebar ~extra_suffix ~extra doc; @@ -95,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 new file mode 100644 index 0000000000..0e9a4c7c58 --- /dev/null +++ b/src/odoc/sidebar.ml @@ -0,0 +1,52 @@ +open Or_error +open Odoc_utils + +let toc_to_json + ({ url; valid_link; content = inline; _ } : Odoc_document.Sidebar.entry) : + Json.json = + let config = + Odoc_html.Config.v ~semantic_uris:true ~indent:true ~flat:false + ~open_details:false ~as_json:true ~remap:[] () + in + let url, kind = + match valid_link with + | false -> (`Null, `Null) + | true -> + let href = + Odoc_html.Link.href ~config ~resolve:(Odoc_html.Link.Base "") url + in + let kind = + Format.asprintf "%a" Odoc_document.Url.Anchor.pp_kind url.kind + in + + (`String href, `String kind) + in + let inline = + let inline = Odoc_html.Generator.inline ~config ~xref_base_uri:"" inline in + let inline = + String.concat "" + @@ List.map (Format.asprintf "%a" (Tyxml.Html.pp_elt ())) inline + in + `String inline + in + `Object [ ("url", url); ("kind", kind); ("content", inline) ] + +let sidebar_to_json (sidebar : Odoc_document.Sidebar.t) = + `Array (List.map (Tree.to_json toc_to_json) sidebar) + +let compile_to_json ~output sidebar = + let json = sidebar_to_json sidebar in + let text = Json.to_string json in + 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 + Format.fprintf output "%s" text + +let generate ~marshall ~output ~warnings_options:_ ~index = + Odoc_file.load_index index >>= fun index -> + 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..462a8953a1 100644 --- a/src/parser/ast.ml +++ b/src/parser/ast.ml @@ -78,6 +78,7 @@ type internal_tag = | `Closed | `Hidden | `Children_order of nestable_block_element with_location list + | `Toc_status 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..8bc28aee22 100644 --- a/src/parser/lexer.mll +++ b/src/parser/lexer.mll @@ -543,6 +543,9 @@ and token input = parse | ("@children_order") { emit input (`Tag `Children_order) } + | ("@toc_status") + { emit input (`Tag `Toc_status) } + | ("@short_title") { emit input (`Tag `Short_title) } diff --git a/src/parser/syntax.ml b/src/parser/syntax.ml index 086610c530..234f4c1301 100644 --- a/src/parser/syntax.ml +++ b/src/parser/syntax.ml @@ -618,6 +618,7 @@ 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" ] | `Short_title -> [ `Word "@short_title" ] (* {3 Block element lists} *) @@ -819,7 +820,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 ) as tag -> let content, _stream_head, where_in_line = block_element_list (In_implicitly_ended `Tag) ~parent_markup:token input @@ -827,6 +829,7 @@ 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 diff --git a/src/parser/test/test.ml b/src/parser/test/test.ml index 866bfc1a1d..759256883c 100644 --- a/src/parser/test/test.ml +++ b/src/parser/test/test.ml @@ -147,6 +147,9 @@ 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) | `Short_title es -> List (Atom "@short_title" diff --git a/src/parser/token.ml b/src/parser/token.ml index 8b9330f3f3..e1d0552e7a 100644 --- a/src/parser/token.ml +++ b/src/parser/token.ml @@ -19,6 +19,7 @@ type tag = | `Version of string | `Canonical of string | `Children_order + | `Toc_status | `Short_title | `Inline | `Open @@ -133,6 +134,7 @@ let print : [< t ] -> string = function | `Tag (`Raise _) -> "'@raise'" | `Tag `Return -> "'@return'" | `Tag `Children_order -> "'@children_order'" + | `Tag `Toc_status -> "'@toc_status'" | `Tag `Short_title -> "'@short_title'" | `Tag (`See _) -> "'@see'" | `Tag (`Since _) -> "'@since'" @@ -239,6 +241,7 @@ let describe : [< t | `Comment ] -> string = function | `Tag `Closed -> "'@closed'" | `Tag `Hidden -> "'@hidden" | `Tag `Children_order -> "'@children_order" + | `Tag `Toc_status -> "'@toc_status" | `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..63e69c0eb7 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 @@ -220,6 +223,22 @@ let page ppf (page : Odoc_model.Lang.Page.t) = let _first = Odoc_utils.Tree.fold_left ~f true skel in () +let of_entry ?occurrences ppf entry = + 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 entry = + let occ = get_occ entry.Entry.id in + (entry, Html.of_entry entry, occ) + in + let _ = output_json ppf true entry in + () + let index ?occurrences ppf (index : Skeleton.t list) = let get_occ id = match occurrences with diff --git a/src/search/json_index/json_search.mli b/src/search/json_index/json_search.mli index 2a5184ada5..8e1035e848 100644 --- a/src/search/json_index/json_search.mli +++ b/src/search/json_index/json_search.mli @@ -11,3 +11,9 @@ val index : Format.formatter -> Odoc_index.Skeleton.t list -> unit + +val of_entry : + ?occurrences:Odoc_occurrences.Table.t -> + Format.formatter -> + Odoc_index.Entry.t -> + unit diff --git a/src/utils/json.ml b/src/utils/json.ml new file mode 100644 index 0000000000..33b7d37093 --- /dev/null +++ b/src/utils/json.ml @@ -0,0 +1,78 @@ +type json = + [ `Null + | `Bool of bool + | `Float of float + | `String of string + | `Array of json list + | `Object of (string * json) list ] + +let rec buffer_add_json b = function + | `Null -> Buffer.add_string b "null" + | `Bool bool -> Buffer.add_string b (if bool then "true" else "false") + | `Float f -> Buffer.add_string b (Printf.sprintf "%.16g" f) + | `String s -> buffer_add_json_string b s + | `Array els -> ( + match els with + | [] -> Buffer.add_string b "[]" + | el :: els -> + let add_sep_el b e = + Buffer.add_char b ','; + buffer_add_json b e + in + Buffer.add_char b '['; + buffer_add_json b el; + List.iter (add_sep_el b) els; + Buffer.add_char b ']') + | `Object mems -> ( + match mems with + | [] -> Buffer.add_string b "{}" + | mem :: mems -> + let add_mem b (k, v) = + buffer_add_json_string b k; + Buffer.add_char b ':'; + buffer_add_json b v + in + let add_sep_mem b mem = + Buffer.add_char b ','; + add_mem b mem + in + Buffer.add_char b '{'; + add_mem b mem; + List.iter (add_sep_mem b) mems; + Buffer.add_char b '}') + +and buffer_add_json_string b s = + let is_control = function '\x00' .. '\x1F' | '\x7F' -> true | _ -> false in + let len = String.length s in + let max_idx = len - 1 in + let flush b start i = + if start < len then Buffer.add_substring b s start (i - start) + in + let rec loop start i = + match i > max_idx with + | true -> flush b start i + | false -> ( + let next = i + 1 in + match String.get s i with + | '"' -> + flush b start i; + Buffer.add_string b "\\\""; + loop next next + | '\\' -> + flush b start i; + Buffer.add_string b "\\\\"; + loop next next + | c when is_control c -> + flush b start i; + Buffer.add_string b (Printf.sprintf "\\u%04X" (Char.code c)); + loop next next + | _c -> loop start next) + in + Buffer.add_char b '"'; + loop 0 0; + Buffer.add_char b '"' + +let to_string json = + let b = Buffer.create 1024 in + buffer_add_json b json; + Buffer.contents b diff --git a/src/utils/odoc_utils.ml b/src/utils/odoc_utils.ml index 41294e1785..dab50a7f3e 100644 --- a/src/utils/odoc_utils.ml +++ b/src/utils/odoc_utils.ml @@ -77,3 +77,4 @@ end module Tree = Tree module Forest = Tree.Forest +module Json = Json diff --git a/src/utils/tree.ml b/src/utils/tree.ml index 2bbc78a141..da9bb9c3bf 100644 --- a/src/utils/tree.ml +++ b/src/utils/tree.ml @@ -9,10 +9,16 @@ module type S = sig val fold_left : f:('acc -> 'a -> 'acc) -> 'acc -> 'a t -> 'acc val iter : f:('a -> unit) -> 'a t -> unit val map : f:('a -> 'b) -> 'a t -> 'b t + val to_json : ('a -> Json.json) -> 'a t -> Json.json end type 'a t = 'a tree +let rec to_json json_of { node; children } : Json.json = + `Object [ ("node", json_of node); ("children", to_json_f json_of children) ] + +and to_json_f json_of f = `Array (List.map (to_json json_of) f) + let leaf node = { node; children = [] } let rec fold_left ~f acc { node; children } = @@ -50,4 +56,5 @@ module Forest = struct let iter = iter_forest let map = map_forest let filter_map = filter_map_forest + let to_json = to_json_f end diff --git a/src/utils/tree.mli b/src/utils/tree.mli index 8f3e558dd1..7dc5c68628 100644 --- a/src/utils/tree.mli +++ b/src/utils/tree.mli @@ -9,6 +9,7 @@ module type S = sig val fold_left : f:('acc -> 'a -> 'acc) -> 'acc -> 'a t -> 'acc val iter : f:('a -> unit) -> 'a t -> unit val map : f:('a -> 'b) -> 'a t -> 'b t + val to_json : ('a -> Json.json) -> 'a t -> Json.json end include S with type 'a t = 'a tree 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 8c0ee1d01b..97e290f38c 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,26 +9,30 @@ $ 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'. - $ odoc html-generate --indent --index index.odoc-index -o _html _odoc/pkg/page-index.odocl - $ odoc html-generate --index index.odoc-index -o _html _odoc/pkg/page-content.odocl - $ odoc html-generate --index index.odoc-index -o _html _odoc/pkg/page-omitted.odocl - $ odoc html-generate --index index.odoc-index -o _html _odoc/pkg/dir1/page-index.odocl - $ odoc html-generate --index index.odoc-index -o _html _odoc/pkg/dir1/page-content_in_dir.odocl - $ odoc html-generate --index index.odoc-index -o _html _odoc/pkg/dir1/page-dontent.odocl +Turn the index into a sidebar (removes all unnecessary entries) + $ odoc sidebar-generate index.odoc-index + + $ odoc html-generate --indent --sidebar sidebar.odoc-sidebar -o _html _odoc/pkg/page-index.odocl + $ odoc html-generate --sidebar sidebar.odoc-sidebar -o _html _odoc/pkg/page-content.odocl + $ odoc html-generate --sidebar sidebar.odoc-sidebar -o _html _odoc/pkg/page-omitted.odocl + $ odoc html-generate --sidebar sidebar.odoc-sidebar -o _html _odoc/pkg/dir1/page-index.odocl + $ odoc html-generate --sidebar sidebar.odoc-sidebar -o _html _odoc/pkg/dir1/page-content_in_dir.odocl + $ odoc html-generate --sidebar sidebar.odoc-sidebar -o _html _odoc/pkg/dir1/page-dontent.odocl $ odoc support-files -o _html $ odoc_print _odoc/pkg/page-index.odocl | jq .frontmatter @@ -35,6 +42,9 @@ { "Page": "content" }, + { + "Module": "Unit" + }, { "Dir": "dir1" }, @@ -59,18 +69,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 -