diff --git a/CHANGES.md b/CHANGES.md index 3dd23e125c..cc27ee3abc 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -31,6 +31,7 @@ - Add a 'remap' option to HTML generation for partial docsets (@jonludlam, #1189) - Added an `html-generate-asset` command (@panglesd, #1185) - Added syntax for images, videos, audio (@panglesd, #1184) +- Added the ability to order pages in the table of content (@panglesd, #1193) ### Changed diff --git a/src/document/sidebar.ml b/src/document/sidebar.ml index 15f0a96145..5122b0f90e 100644 --- a/src/document/sidebar.ml +++ b/src/document/sidebar.ml @@ -1,91 +1,83 @@ +open Odoc_utils open Types -module Hierarchy : sig - type 'a dir - (** Directory in a filesystem-like abstraction, where files have a ['a] - payload and directory can also have a ['a] payload. *) +let sidebar_toc_entry id content = + let href = id |> Url.Path.from_identifier |> Url.from_path in + let target = Target.Internal (Resolved href) in + inline @@ Inline.Link { target; content; tooltip = None } - val make : ('a * string list) list -> 'a dir - (** Create a directory from a list of payload and file path (given as a - string list). Files named ["index"] give their payload to their - containing directory. *) +module Toc : sig + type t - val remove_common_root : 'a dir -> 'a dir - (** Returns the deepest subdir containing all files. *) + val of_lang : Odoc_model.Sidebar.PageToc.t -> t - val to_sidebar : ?fallback:string -> ('a -> Block.one) -> 'a dir -> Block.t + val to_sidebar : + ?fallback:string -> (Url.Path.t * Inline.one -> Block.one) -> t -> Block.t end = struct - type 'a dir = 'a option * (string * 'a t) list - and 'a t = Leaf of 'a | Dir of 'a dir + type t = Item of (Url.Path.t * Inline.one) option * t list - let rec add_entry_to_dir (dir : 'a dir) payload path = - match (path, dir) with - | [], _ -> assert false - | [ "index" ], (None, l) -> (Some payload, l) - | [ name ], (p, l) -> (p, (name, Leaf payload) :: l) - | name :: rest, (p, l) -> - let rec add_to_dir (l : (string * 'a t) list) = - match l with - | [] -> [ (name, Dir (add_entry_to_dir (None, []) payload rest)) ] - | (name2, Dir d) :: q when name = name2 -> - (name2, Dir (add_entry_to_dir d payload rest)) :: q - | d :: q -> d :: add_to_dir q - in - (p, add_to_dir l) + open Odoc_model.Sidebar + open Odoc_model.Paths.Identifier - let make l = - let empty = (None, []) in - let add_entry_to_dir acc (path, payload) = - add_entry_to_dir acc path payload + let of_lang (dir : PageToc.t) = + let rec of_lang ~parent_id ((content, index) : PageToc.t) = + let title, parent_id = + match index with + | Some (index_id, title) -> (Some title, Some (index_id :> Page.t)) + | None -> (None, (parent_id :> Page.t option)) + in + let entries = + List.filter_map + (fun id -> + match id with + | id, PageToc.Entry title -> + (* TODO warn on non empty children order if not index page somewhere *) + let payload = + let path = Url.Path.from_identifier id in + let content = Comment.link_content title in + Some (path, sidebar_toc_entry id content) + in + Some (Item (payload, [])) + | id, PageToc.Dir dir -> Some (of_lang ~parent_id:(Some id) dir)) + content + in + let payload = + match (title, parent_id) with + | None, _ | _, None -> None + | Some title, Some parent_id -> + let path = Url.Path.from_identifier parent_id in + let content = Comment.link_content title in + Some (path, sidebar_toc_entry parent_id content) + in + Item (payload, entries) in - List.fold_left add_entry_to_dir empty l + of_lang ~parent_id:None dir - let rec remove_common_root = function - | None, [ (_, Dir d) ] -> remove_common_root d - | x -> x - - let rec to_sidebar ?(fallback = "root") convert (name, content) = + let rec to_sidebar ?(fallback = "root") convert (Item (name, content)) = let name = match name with | Some v -> convert v | None -> block (Block.Inline [ inline (Text fallback) ]) in let content = - let content = List.map (t_to_sidebar convert) content in - block (Block.List (Block.Unordered, content)) + match content with + | [] -> [] + | _ :: _ -> + let content = List.map (to_sidebar convert) content in + [ block (Block.List (Block.Unordered, content)) ] in - [ name; content ] - - and t_to_sidebar convert = function - | _, Leaf payload -> [ convert payload ] - | fallback, Dir d -> to_sidebar ~fallback convert d + name :: content end -type pages = { name : string; pages : (Url.Path.t * Inline.one) Hierarchy.dir } +type pages = { name : string; pages : Toc.t } type library = { name : string; units : (Url.Path.t * Inline.one) list } type t = { pages : pages list; libraries : library list } -let of_lang (v : Odoc_model.Lang.Sidebar.t) = - let sidebar_toc_entry id content = - let href = id |> Url.Path.from_identifier |> Url.from_path in - let target = Target.Internal (Resolved href) in - inline @@ Inline.Link { target; content; tooltip = None } - in +let of_lang (v : Odoc_model.Sidebar.t) = let pages = - let page_hierarchy { Odoc_model.Lang.Sidebar.page_name; pages } = - if pages = [] then None - else - let prepare_for_hierarchy (link_content, id) = - let path = Url.Path.from_identifier id in - let payload = - let content = Comment.link_content link_content in - (path, sidebar_toc_entry id content) - in - (payload, path |> Url.Path.to_list |> List.map snd) - in - let pages = List.map prepare_for_hierarchy pages in - let hierarchy = Hierarchy.make pages |> Hierarchy.remove_common_root in - Some { name = page_name; pages = hierarchy } + let page_hierarchy { Odoc_model.Sidebar.hierarchy_name; pages } = + let hierarchy = Toc.of_lang pages in + Some { name = hierarchy_name; pages = hierarchy } in Odoc_utils.List.filter_map page_hierarchy v.pages in @@ -96,7 +88,7 @@ let of_lang (v : Odoc_model.Lang.Sidebar.t) = in let units = List.map - (fun { Odoc_model.Lang.Sidebar.units; name } -> + (fun { Odoc_model.Sidebar.units; name } -> let units = List.map item units in { name; units }) v.libraries @@ -121,7 +113,7 @@ let to_block (sidebar : t) url = let pages = Odoc_utils.List.concat_map ~f:(fun (p : pages) -> - let pages = Hierarchy.to_sidebar render_entry p.pages in + let pages = Toc.to_sidebar render_entry p.pages in let pages = [ block (Block.List (Block.Unordered, [ pages ])) ] in let pages = [ title @@ p.name ^ "'s Pages" ] @ pages in pages) diff --git a/src/document/sidebar.mli b/src/document/sidebar.mli index 3eab9b64cb..6c926ad1fc 100644 --- a/src/document/sidebar.mli +++ b/src/document/sidebar.mli @@ -1,6 +1,6 @@ type t -val of_lang : Odoc_model.Lang.Sidebar.t -> t +val of_lang : Odoc_model.Sidebar.t -> t val to_block : t -> Url.Path.t -> Types.Block.t (** Generates the sidebar document given a global sidebar and the path at which diff --git a/src/driver/cmd_outputs.ml b/src/driver/cmd_outputs.ml index f6bce2666e..f9d2be4ff0 100644 --- a/src/driver/cmd_outputs.ml +++ b/src/driver/cmd_outputs.ml @@ -11,6 +11,8 @@ let link_output = ref [ "" ] let generate_output = ref [ "" ] +let index_output = ref [ "" ] + let source_tree_output = ref [ "" ] let add_prefixed_output cmd list prefix lines = diff --git a/src/driver/odoc.ml b/src/driver/odoc.ml index 03edd03bc2..9fe020cab3 100644 --- a/src/driver/odoc.ml +++ b/src/driver/odoc.ml @@ -152,7 +152,7 @@ let compile_index ?(ignore_output = false) ~output_file ~json ~docs ~libs () = let lines = Cmd_outputs.submit desc cmd (Some output_file) in if not ignore_output then Cmd_outputs.( - add_prefixed_output cmd link_output (Fpath.to_string output_file) lines) + add_prefixed_output cmd index_output (Fpath.to_string output_file) lines) let html_generate ~output_dir ?index ?(ignore_output = false) ?(search_uris = []) ~input_file:file () = diff --git a/src/model/comment.ml b/src/model/comment.ml index b1204ac303..b1c808a85e 100644 --- a/src/model/comment.ml +++ b/src/model/comment.ml @@ -147,20 +147,13 @@ let find_zero_heading docs : link_content option = docs let extract_frontmatter docs : _ = - let parse_frontmatter s = - let lines = Astring.String.cuts ~sep:"\n" s in - List.filter_map (fun line -> Astring.String.cut ~sep:":" line) lines + let fm, rev_content = + List.fold_left + (fun (fm_acc, content_acc) doc -> + match doc.Location_.value with + | `Code_block (Some "meta", content, None) -> + (Frontmatter.parse content, content_acc) + | _ -> (fm_acc, doc :: content_acc)) + (Frontmatter.empty, []) docs in - let fm, content = - let fm, rev_content = - List.fold_left - (fun (fm_acc, content_acc) doc -> - match doc.Location_.value with - | `Code_block (Some "meta", content, None) -> - (parse_frontmatter content.Location_.value :: fm_acc, content_acc) - | _ -> (fm_acc, doc :: content_acc)) - ([], []) docs - in - (List.concat fm, List.rev rev_content) - in - (fm, content) + (fm, List.rev rev_content) diff --git a/src/model/frontmatter.ml b/src/model/frontmatter.ml index f50e98da1b..700fce09a4 100644 --- a/src/model/frontmatter.ml +++ b/src/model/frontmatter.ml @@ -1 +1,48 @@ -type t = (string * string) list +type child = Page of string | Dir of string + +type line = + | Children_order of child Location_.with_location list + | KV of string * string + | V of string + +type children_order = child Location_.with_location list Location_.with_location + +type t = { children_order : children_order option } + +let empty = { children_order = None } + +let apply fm line = + match (line.Location_.value, fm) with + | Children_order children_order, { children_order = None } -> + { children_order = Some (Location_.same line children_order) } + | Children_order _, { children_order = Some _ } -> + (* TODO raise warning about duplicate children field *) fm + | KV _, _ | V _, _ -> (* TODO raise warning *) fm + +let parse_child c = + if Astring.String.is_suffix ~affix:"/" c then + let c = String.sub c 0 (String.length c - 1) in + Dir c + else Page c + +let parse s = + let entries = + s.Location_.value + |> Astring.String.cuts ~sep:"\n" + |> List.map (fun l -> + let v = + Astring.String.cut ~sep:":" l |> function + | Some ("children", v) -> + let refs = + v + |> Astring.String.fields ~empty:false + |> List.map parse_child + |> List.map (Location_.same s) + in + Children_order refs + | Some (k, v) -> KV (k, v) + | None -> V l + in + Location_.same s v) + in + List.fold_left apply empty entries diff --git a/src/model/frontmatter.mli b/src/model/frontmatter.mli new file mode 100644 index 0000000000..a8c3cbc657 --- /dev/null +++ b/src/model/frontmatter.mli @@ -0,0 +1,9 @@ +type child = Page of string | Dir of string + +type children_order = child Location_.with_location list Location_.with_location + +type t = { children_order : children_order option } + +val empty : t + +val parse : string Location_.with_location -> t diff --git a/src/model/lang.ml b/src/model/lang.ml index 4715481536..e1184c3b40 100644 --- a/src/model/lang.ml +++ b/src/model/lang.ml @@ -539,20 +539,8 @@ module rec Page : sig end = Page -module rec Sidebar : sig - type library = { name : string; units : Paths.Identifier.RootModule.t list } - - type pages = { - page_name : string; - pages : (Comment.link_content * Paths.Identifier.Page.t) list; - } - - type t = { pages : pages list; libraries : library list } -end = - Sidebar - module rec Index : sig - type 'a t = Sidebar.t * 'a Paths.Identifier.Hashtbl.Any.t + type 'a t = { sidebar : Sidebar.t; index : 'a Paths.Identifier.Hashtbl.Any.t } end = Index diff --git a/src/model/odoc_model.ml b/src/model/odoc_model.ml index f81a5fe1a7..cfbc5969b0 100644 --- a/src/model/odoc_model.ml +++ b/src/model/odoc_model.ml @@ -1,4 +1,5 @@ module Lang = Lang +module Sidebar = Sidebar module Fold = Fold module Comment = Comment module Paths = Paths @@ -10,3 +11,4 @@ module Location_ = Location_ module Compat = Compat module Semantics = Semantics module Reference = Reference +module Frontmatter = Frontmatter diff --git a/src/model/paths.ml b/src/model/paths.ml index e055b0202e..be120e4484 100644 --- a/src/model/paths.ml +++ b/src/model/paths.ml @@ -363,14 +363,27 @@ module Identifier = struct type t_pv = Id.page_pv end + module LeafPage = struct + type t = Id.leaf_page + type t_pv = Id.leaf_page_pv + let equal = equal + let hash = hash + end + module ContainerPage = struct type t = Id.container_page type t_pv = Id.container_page_pv + let equal = equal + let hash = hash end module NonSrc = struct type t = Paths_types.Identifier.non_src type t_pv = Paths_types.Identifier.non_src_pv + + let equal x y = x.ihash = y.ihash && x.ikey = y.ikey + + let hash x = x.ihash end module SourcePage = struct @@ -623,6 +636,8 @@ module Identifier = struct module Hashtbl = struct module Any = Hashtbl.Make (Any) + module ContainerPage = Hashtbl.Make (ContainerPage) + module LeafPage = Hashtbl.Make (LeafPage) end end diff --git a/src/model/paths.mli b/src/model/paths.mli index bca68307d2..f1abf58777 100644 --- a/src/model/paths.mli +++ b/src/model/paths.mli @@ -139,6 +139,11 @@ module Identifier : sig type t_pv = Id.page_pv end + module LeafPage : sig + type t = Id.leaf_page + type t_pv = Id.leaf_page_pv + end + module ContainerPage : sig type t = Id.container_page type t_pv = Id.container_page_pv @@ -147,6 +152,8 @@ module Identifier : sig module NonSrc : sig type t = Id.non_src type t_pv = Id.non_src_pv + val hash : t -> int + val equal : ([< t_pv ] id as 'a) -> 'a -> bool end module SourcePage : sig @@ -235,6 +242,8 @@ module Identifier : sig module Hashtbl : 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 end module Mk : sig diff --git a/src/model/paths_types.ml b/src/model/paths_types.ml index 77cad0bdca..0da86d1554 100644 --- a/src/model/paths_types.ml +++ b/src/model/paths_types.ml @@ -11,8 +11,13 @@ module Identifier = struct and container_page = container_page_pv id (** @canonical Odoc_model.Paths.Identifier.ContainerPage.t *) - type page_pv = - [ container_page_pv | `LeafPage of container_page option * PageName.t ] + type leaf_page_pv = [ `LeafPage of container_page option * PageName.t ] + (** @canonical Odoc_model.Paths.Identifier.LeafPage.t_pv *) + + and leaf_page = leaf_page_pv id + (** @canonical Odoc_model.Paths.Identifier.LeafPage.t *) + + type page_pv = [ container_page_pv | leaf_page_pv ] (** @canonical Odoc_model.Paths.Identifier.Page.t_pv *) and page = page_pv id @@ -756,7 +761,6 @@ module rec Reference : sig type page = [ `Resolved of Resolved_reference.page | `Root of string * [ `TPage | `TUnknown ] - | `Dot of label_parent * string | `Page_path of hierarchy ] (** @canonical Odoc_model.Paths.Reference.Page.t *) diff --git a/src/model/sidebar.ml b/src/model/sidebar.ml new file mode 100644 index 0000000000..4780cb9ba1 --- /dev/null +++ b/src/model/sidebar.ml @@ -0,0 +1,200 @@ +open Odoc_utils +module Id = Paths.Identifier + +module CPH = Id.Hashtbl.ContainerPage +module LPH = Id.Hashtbl.LeafPage + +type page = Id.Page.t +type leaf_page = Id.LeafPage.t +type container_page = Id.ContainerPage.t + +open Astring + +module PageToc = struct + type title = Comment.link_content + + type payload = { + title : title; + children_order : Frontmatter.children_order option; + } + + type dir_content = { leafs : payload LPH.t; dirs : in_progress CPH.t } + and in_progress = container_page option * dir_content + + let empty_t dir_id = (dir_id, { leafs = LPH.create 10; dirs = CPH.create 10 }) + + let get_parent id : container_page option = + let id :> page = id in + match id.iv with + | `Page (Some parent, _) -> Some parent + | `LeafPage (Some parent, _) -> Some parent + | `Page (None, _) | `LeafPage (None, _) -> None + + let find_leaf ((_, dir_content) : in_progress) leaf_page = + try Some (LPH.find dir_content.leafs leaf_page) with Not_found -> None + + let leafs (_, dir_content) = + LPH.fold + (fun id { title = payload; _ } acc -> + if String.equal "index" (Paths.Identifier.name id) then acc + else (id, payload) :: acc) + dir_content.leafs [] + + let dirs (_, dir_content) = + CPH.fold (fun id payload acc -> (id, payload) :: acc) dir_content.dirs [] + + let rec get_or_create (dir : in_progress) (id : container_page) : in_progress + = + let _, { dirs = parent_dirs; _ } = + match get_parent id with + | Some parent -> get_or_create dir parent + | None -> dir + in + let current_item = + try Some (CPH.find parent_dirs id) with Not_found -> None + in + match current_item with + | Some item -> item + | None -> + let new_ = empty_t (Some id) in + CPH.add parent_dirs id new_; + new_ + + let add (dir : in_progress) ((id : leaf_page), title, children_order) = + let _, dir_content = + match get_parent id with + | Some parent -> get_or_create dir parent + | None -> dir + in + LPH.replace dir_content.leafs id { title; children_order } + + let dir_index ((parent_id, _) as dir) = + let index_id = + Paths.Identifier.Mk.leaf_page (parent_id, Names.PageName.make_std "index") + in + match find_leaf dir index_id with + | Some payload -> Some (payload, index_id, payload.title) + | None -> None + + type index = Id.Page.t * title + type t = (Id.Page.t * content) list * index option + and content = Entry of title | Dir of t + + let rec t_of_in_progress (dir : in_progress) = + let children_order, index = + match dir_index dir with + | Some ({ children_order; _ }, index_id, index_title) -> + (children_order, Some (index_id, index_title)) + | None -> (None, None) + in + let pp_content fmt (id, _) = + match id.Id.iv with + | `LeafPage (_, name) -> + Format.fprintf fmt "'%s'" (Names.PageName.to_string name) + | `Page (_, name) -> + Format.fprintf fmt "'%s/'" (Names.PageName.to_string name) + in + let pp_children fmt c = + match c.Location_.value with + | Frontmatter.Page s -> Format.fprintf fmt "'%s'" s + | Dir s -> Format.fprintf fmt "'%s/'" s + in + let ordered, unordered = + let contents = + let leafs = + leafs dir + |> List.map (fun (id, payload) -> ((id :> Id.Page.t), Entry payload)) + in + let dirs = + dirs dir + |> List.map (fun (id, payload) -> + ((id :> Id.Page.t), Dir (t_of_in_progress payload))) + in + leafs @ dirs + in + match children_order with + | None -> ([], contents) + | Some children_order -> + let children_indexes = + List.mapi (fun i x -> (i, x)) children_order.value + in + let equal id ch = + match (ch, id.Id.iv) with + | (_, { Location_.value = Frontmatter.Dir c; _ }), `Page (_, name) + -> + String.equal (Names.PageName.to_string name) c + | (_, { Location_.value = Page c; _ }), `LeafPage (_, name) -> + String.equal (Names.PageName.to_string name) c + | _ -> false + in + let children_indexes, indexed_content, unindexed_content = + List.fold_left + (fun (children_indexes, indexed_content, unindexed_content) + (((id : Id.Page.t), _) as entry) -> + let indexes_for_entry, children_indexes = + List.partition (equal id) children_indexes + in + match indexes_for_entry with + | [] -> + ( children_indexes, + indexed_content, + entry :: unindexed_content ) + | (i, _) :: rest -> + List.iter + (fun (_, c) -> + Error.raise_warning + (Error.make "Duplicate %a in (children)." pp_children + c (Location_.location c))) + rest; + ( children_indexes, + (i, entry) :: indexed_content, + unindexed_content )) + (children_indexes, [], []) contents + in + List.iter + (fun (_, c) -> + Error.raise_warning + (Error.make "%a in (children) does not correspond to anything." + pp_children c (Location_.location c))) + children_indexes; + (indexed_content, unindexed_content) + in + let () = + match (children_order, unordered) with + | Some x, (_ :: _ as l) -> + Error.raise_warning + (Error.make "(children) doesn't include %a." + (Format.pp_print_list pp_content) + l (Location_.location x)) + | _ -> () + in + let ordered = + ordered + |> List.sort (fun (i, _) (j, _) -> (compare : int -> int -> int) i j) + |> List.map snd + in + let unordered = + List.sort + (fun (x, _) (y, _) -> + String.compare (Paths.Identifier.name x) (Paths.Identifier.name y)) + unordered + in + let contents = ordered @ unordered in + (contents, index) + + let rec remove_common_root (v : t) = + match v with [ (_, Dir v) ], None -> remove_common_root v | _ -> v + + let of_list l = + let dir = empty_t None in + List.iter (add dir) l; + t_of_in_progress dir |> remove_common_root +end + +type toc = PageToc.t + +type library = { name : string; units : Paths.Identifier.RootModule.t list } + +type page_hierarchy = { hierarchy_name : string; pages : toc } + +type t = { pages : page_hierarchy list; libraries : library list } diff --git a/src/model/sidebar.mli b/src/model/sidebar.mli new file mode 100644 index 0000000000..838061c96c --- /dev/null +++ b/src/model/sidebar.mli @@ -0,0 +1,20 @@ +open Paths.Identifier + +module PageToc : sig + type title = Comment.link_content + + type index = Page.t * title + type t = (Page.t * content) list * index option + and content = Entry of title | Dir of t + + val of_list : + (LeafPage.t * title * Frontmatter.children_order option) list -> t + (** Uses the convention that the [index] children passes its payload to the + container directory to output a payload *) +end + +type library = { name : string; units : RootModule.t list } + +type page_hierarchy = { hierarchy_name : string; pages : PageToc.t } + +type t = { pages : page_hierarchy list; libraries : library list } diff --git a/src/model_desc/lang_desc.ml b/src/model_desc/lang_desc.ml index 93b5ea8335..02f8ef1d86 100644 --- a/src/model_desc/lang_desc.ml +++ b/src/model_desc/lang_desc.ml @@ -1,5 +1,6 @@ open Type_desc open Odoc_model +open Odoc_utils open Paths_desc open Comment_desc module T = Type_desc @@ -697,11 +698,29 @@ and page_t = [ F ("name", (fun t -> t.name), identifier); F ("root", (fun t -> t.root), root); - F ("frontmatter", (fun t -> t.frontmatter), List (Pair (string, string))); + F ("frontmatter", (fun t -> t.frontmatter), frontmatter); F ("content", (fun t -> t.content), docs); F ("digest", (fun t -> t.digest), Digest.t); ] +and frontmatter = + let open Odoc_model.Frontmatter in + let ignore_loc x = x.Location_.value in + Record + [ + F + ( "children", + (fun t -> Option.map ignore_loc t.children_order), + Option (List child) ); + ] + +and child = + let open Odoc_model.Frontmatter in + Variant + (function + | { Location_.value = Page s; _ } -> C ("Page", s, string) + | { Location_.value = Dir s; _ } -> C ("Dir", s, string)) + and implementation_t = let open Lang.Implementation in Record diff --git a/src/odoc/compile.ml b/src/odoc/compile.ml index 92cf62bc85..9c2bf5fcb8 100644 --- a/src/odoc/compile.ml +++ b/src/odoc/compile.ml @@ -2,6 +2,7 @@ open Astring open Odoc_model open Odoc_model.Names open Or_error +open Odoc_utils (* * Copyright (c) 2014 Leo White @@ -201,6 +202,14 @@ let name_of_output ~prefix output = 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" + +let has_children_order { Frontmatter.children_order } = + Option.is_some children_order + let mld ~parent_id ~parents_children ~output ~children ~warnings_options input = List.fold_left (fun acc child_str -> @@ -239,6 +248,11 @@ let mld ~parent_id ~parents_children ~output ~children ~warnings_options input = let resolve content = let zero_heading = Comment.find_zero_heading content in let frontmatter, content = Comment.extract_frontmatter content in + if (not (is_index_page name)) && has_children_order frontmatter then + Error.raise_warning + (Error.filename_only + "Non-index page cannot specify (children _) in the frontmatter." + input_s); let root = let file = Root.Odoc_file.create_page root_name zero_heading frontmatter @@ -250,12 +264,15 @@ let mld ~parent_id ~parents_children ~output ~children ~warnings_options input = { name; root; children; content; digest; linked = false; frontmatter } in Odoc_file.save_page output ~warnings:[] page; - Ok () + () in Fs.File.read input >>= fun str -> + Error.handle_errors_and_warnings ~warnings_options + @@ Error.catch_errors_and_warnings + @@ fun () -> Odoc_loader.read_string (name :> Paths.Identifier.LabelParent.t) input_s str - |> Error.handle_errors_and_warnings ~warnings_options - >>= function + |> Error.raise_errors_and_warnings + |> function | `Stop -> resolve [] (* TODO: Error? *) | `Docs content -> resolve content diff --git a/src/odoc/indexing.ml b/src/odoc/indexing.ml index 086315f96f..6f9a3dc515 100644 --- a/src/odoc/indexing.ml +++ b/src/odoc/indexing.ml @@ -1,3 +1,4 @@ +open Odoc_utils open Astring open Odoc_json_index open Or_error @@ -8,7 +9,7 @@ module H = Odoc_model.Paths.Identifier.Hashtbl.Any 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 (_sidebar, index) -> Ok (occ index) + Odoc_file.load_index file >>= fun { index; _ } -> Ok (occ index) | _ -> ( Odoc_file.load file >>= fun unit' -> match unit' with @@ -40,7 +41,7 @@ let parse_input_files input = (Ok []) input >>= fun files -> Ok (List.concat files) -let compile_to_json ~output ~warnings_options ~occurrences files = +let compile_to_json ~output ~occurrences files = let output_channel = Fs.Directory.mkdir_p (Fs.File.dirname output); open_out_bin (Fs.File.to_string output) @@ -52,7 +53,7 @@ let compile_to_json ~output ~warnings_options ~occurrences files = false in Format.fprintf output "["; - let index () = + let _ : bool = List.fold_left (fun acc file -> match @@ -69,12 +70,10 @@ let compile_to_json ~output ~warnings_options ~occurrences files = acc) true files in - let result = Error.catch_warnings index in - result |> Error.handle_warnings ~warnings_options >>= fun (_ : bool) -> Format.fprintf output "]"; Ok () -let compile_to_marshall ~output ~warnings_options sidebar files = +let compile_to_marshall ~output sidebar files = let final_index = H.create 10 in let unit u = Odoc_model.Fold.unit @@ -95,7 +94,7 @@ let compile_to_marshall ~output ~warnings_options sidebar files = () p in let index i = H.iter (H.add final_index) i in - let index () = + let () = List.fold_left (fun acc file -> match handle_file ~unit ~page ~occ:index file with @@ -106,19 +105,22 @@ let compile_to_marshall ~output ~warnings_options sidebar files = acc) () files in - let result = Error.catch_warnings index in - result |> Error.handle_warnings ~warnings_options >>= fun () -> - Ok (Odoc_file.save_index output (sidebar, final_index)) + Ok (Odoc_file.save_index output { index = final_index; sidebar }) let read_occurrences file = let ic = open_in_bin file in let htbl : Odoc_occurrences.Table.t = Marshal.from_channel ic in htbl -open Odoc_model.Lang.Sidebar +open Odoc_model.Sidebar let compile out_format ~output ~warnings_options ~occurrences ~lib_roots ~page_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 @@ -147,22 +149,30 @@ let compile out_format ~output ~warnings_options ~occurrences ~lib_roots (fun (page_root, _) -> let pages = Resolver.all_pages ~root:page_root resolver in let pages = - List.map - (fun (page_id, title) -> - let title = - match title with - | None -> - [ - Odoc_model.Location_.at - (Odoc_model.Location_.span []) - (`Word (Odoc_model.Paths.Identifier.name page_id)); - ] - | Some x -> x - in - (title, page_id)) + let pages = pages + |> List.filter_map + Paths.Identifier.( + function + | ({ iv = #LeafPage.t_pv; _ } as id), pl, fm -> + Some (id, pl, fm) + | _ -> None) + |> List.map (fun (id, title, fm) -> + let title = + match title with + | None -> + [ + Location_.at (Location_.span []) + (`Word (Paths.Identifier.name id)); + ] + | Some x -> x + in + let children_order = fm.Frontmatter.children_order in + (id, title, children_order)) + in + PageToc.of_list pages in - { page_name = page_root; pages }) + { hierarchy_name = page_root; pages }) page_roots in let libraries = @@ -185,5 +195,5 @@ let compile out_format ~output ~warnings_options ~occurrences ~lib_roots in let content = { pages; libraries } in match out_format with - | `JSON -> compile_to_json ~output ~warnings_options ~occurrences files - | `Marshall -> compile_to_marshall ~output ~warnings_options content files + | `JSON -> compile_to_json ~output ~occurrences files + | `Marshall -> compile_to_marshall ~output content files diff --git a/src/odoc/rendering.ml b/src/odoc/rendering.ml index b373203b4e..a13deef882 100644 --- a/src/odoc/rendering.ml +++ b/src/odoc/rendering.ml @@ -79,7 +79,7 @@ let generate_odoc ~syntax ~warnings_options:_ ~renderer ~output ~extra_suffix (match sidebar with | None -> Ok None | Some x -> - Odoc_file.load_index x >>= fun (sidebar, _) -> + Odoc_file.load_index x >>= fun { sidebar; index = _ } -> Ok (Some (Odoc_document.Sidebar.of_lang sidebar))) >>= fun sidebar -> document_of_odocl ~syntax file >>= fun doc -> diff --git a/src/odoc/resolver.ml b/src/odoc/resolver.ml index ad780a1100..347ad0e18e 100644 --- a/src/odoc/resolver.ml +++ b/src/odoc/resolver.ml @@ -82,8 +82,11 @@ end = struct pkglist; let current_root_dir = match current_root with - | Some root -> ( - try Some (List.assq root pkglist) with Not_found -> None) + | Some root -> + List.fold_left + (fun acc (x, dir) -> + if Astring.String.equal x root then Some dir else acc) + None pkglist | None -> None in { current_root; table = cache; current_root_dir } @@ -499,11 +502,11 @@ let all_pages ?root ({ pages; _ } : t) = let filter (root : Odoc_model.Root.t) = match root with | { - file = Page { title; _ }; + file = Page { title; frontmatter; _ }; id = { iv = #Odoc_model.Paths.Identifier.Page.t_pv; _ } as id; _; } -> - Some (id, title) + Some (id, title, frontmatter) | _ -> None in match pages with diff --git a/src/odoc/resolver.mli b/src/odoc/resolver.mli index 0cc5472829..b63cb16782 100644 --- a/src/odoc/resolver.mli +++ b/src/odoc/resolver.mli @@ -19,6 +19,8 @@ This is the module which does the link between packages, directories and {!Odoc_xref2}'s needs. *) +open Odoc_model + type t type roots = { @@ -42,13 +44,12 @@ val create : @param important_digests indicate whether digests should be compared when odoc_xref2 tries to lookup or fetch a unit. It defaults to [true]. *) -val lookup_page : t -> string -> Odoc_model.Lang.Page.t option +val lookup_page : t -> string -> Lang.Page.t option val all_pages : ?root:string -> t -> - (Odoc_model.Paths.Identifier.Page.t * Odoc_model.Comment.link_content option) - list + (Paths.Identifier.Page.t * Comment.link_content option * Frontmatter.t) list val all_units : library:string -> t -> Odoc_model.Paths.Identifier.RootModule.t list @@ -56,28 +57,25 @@ val all_units : (** Helpers for creating xref2 env. *) val build_compile_env_for_unit : - t -> Odoc_model.Lang.Compilation_unit.t -> Odoc_xref2.Env.t + t -> Lang.Compilation_unit.t -> Odoc_xref2.Env.t (** Initialize the environment for compiling the given module. *) -val build_link_env_for_unit : - t -> Odoc_model.Lang.Compilation_unit.t -> Odoc_xref2.Env.t +val build_link_env_for_unit : t -> Lang.Compilation_unit.t -> Odoc_xref2.Env.t (** Initialize the environment for linking the given module. *) -val build_env_for_page : t -> Odoc_model.Lang.Page.t -> Odoc_xref2.Env.t +val build_env_for_page : t -> Lang.Page.t -> Odoc_xref2.Env.t (** Initialize the environment for the given page. *) -val build_compile_env_for_impl : - t -> Odoc_model.Lang.Implementation.t -> Odoc_xref2.Env.t +val build_compile_env_for_impl : t -> Lang.Implementation.t -> Odoc_xref2.Env.t (** Initialize the environment for the given implementation. *) -val build_link_env_for_impl : - t -> Odoc_model.Lang.Implementation.t -> Odoc_xref2.Env.t +val build_link_env_for_impl : t -> Lang.Implementation.t -> Odoc_xref2.Env.t (** Initialize the environment for the given implementation. *) val build_env_for_reference : t -> Odoc_xref2.Env.t (** Initialize the environment for a reference. *) -val resolve_import : t -> string -> Odoc_model.Root.t option +val resolve_import : t -> string -> Root.t option (** Similar to {!Odoc_xref2.Env.lookup_root_module} but save work by loading only the root. Only used when resolving imports, which are needed for the [link-deps] command. *) diff --git a/src/utils/odoc_utils.ml b/src/utils/odoc_utils.ml index d3654cab29..a574797f75 100644 --- a/src/utils/odoc_utils.ml +++ b/src/utils/odoc_utils.ml @@ -79,6 +79,14 @@ end module Option = struct let map f = function None -> None | Some x -> Some (f x) + + let is_some = function None -> false | Some _ -> true +end + +module Result = struct + include Result + + let join = function Ok r -> r | Error _ as e -> e end module Fun = struct diff --git a/test/pages/frontmatter.t/one_frontmatter.mld b/test/pages/frontmatter.t/one_frontmatter.mld index 034fa592a6..e7f571eb11 100644 --- a/test/pages/frontmatter.t/one_frontmatter.mld +++ b/test/pages/frontmatter.t/one_frontmatter.mld @@ -1,6 +1,5 @@ {0 One frontmatter} {@meta[ -bli1: bloblobloblo1 -bli2: bloblobloblo2 +children: page1 page2 ]} \ No newline at end of file diff --git a/test/pages/frontmatter.t/run.t b/test/pages/frontmatter.t/run.t index 7e0c8a57c1..7286500afa 100644 --- a/test/pages/frontmatter.t/run.t +++ b/test/pages/frontmatter.t/run.t @@ -2,22 +2,28 @@ When there is no frontmatter, everything is normal $ odoc compile zero_frontmatter.mld $ odoc_print page-zero_frontmatter.odoc | jq '.frontmatter' - [] + { + "children": "None" + } When there is one frontmatter, it is extracted from the content: $ odoc compile one_frontmatter.mld + File "one_frontmatter.mld": + Warning: Non-index page cannot specify (children _) in the frontmatter. $ odoc_print page-one_frontmatter.odoc | jq '.frontmatter' - [ - [ - "bli1", - " bloblobloblo1" - ], - [ - "bli2", - " bloblobloblo2" - ] - ] + { + "children": { + "Some": [ + { + "Page": "page1" + }, + { + "Page": "page2" + } + ] + } + } $ odoc_print page-one_frontmatter.odoc | jq '.content' [ { @@ -54,20 +60,9 @@ When there is more than one frontmatter, they are all extracted from the content $ odoc compile two_frontmatters.mld $ odoc_print page-two_frontmatters.odoc | jq '.frontmatter' - [ - [ - "bli3", - " bloblobloblo1" - ], - [ - "bli1", - " bloblobloblo1" - ], - [ - "bli2", - " bloblobloblo2" - ] - ] + { + "children": "None" + } $ odoc_print page-two_frontmatters.odoc | jq '.content' [ { diff --git a/test/pages/toc_order.t/content.mld b/test/pages/toc_order.t/content.mld new file mode 100644 index 0000000000..0dce221fa2 --- /dev/null +++ b/test/pages/toc_order.t/content.mld @@ -0,0 +1 @@ +{0 This is top level content} \ No newline at end of file diff --git a/test/pages/toc_order.t/dir1/content_in_dir.mld b/test/pages/toc_order.t/dir1/content_in_dir.mld new file mode 100644 index 0000000000..40855f02c7 --- /dev/null +++ b/test/pages/toc_order.t/dir1/content_in_dir.mld @@ -0,0 +1 @@ +{0 This is some content in dir1} diff --git a/test/pages/toc_order.t/dir1/dontent.mld b/test/pages/toc_order.t/dir1/dontent.mld new file mode 100644 index 0000000000..cc754c0084 --- /dev/null +++ b/test/pages/toc_order.t/dir1/dontent.mld @@ -0,0 +1 @@ +{0 The name is dontent} \ No newline at end of file diff --git a/test/pages/toc_order.t/dir1/index.mld b/test/pages/toc_order.t/dir1/index.mld new file mode 100644 index 0000000000..2fdb6505b8 --- /dev/null +++ b/test/pages/toc_order.t/dir1/index.mld @@ -0,0 +1 @@ +{0 This is dir1's index} diff --git a/test/pages/toc_order.t/index.mld b/test/pages/toc_order.t/index.mld new file mode 100644 index 0000000000..fbae568947 --- /dev/null +++ b/test/pages/toc_order.t/index.mld @@ -0,0 +1,7 @@ +{0 This is the main index} + +Hello + +{@meta[ +children: content dir1/ dir1/ typo +]} \ No newline at end of file diff --git a/test/pages/toc_order.t/omitted.mld b/test/pages/toc_order.t/omitted.mld new file mode 100644 index 0000000000..faa39b1d93 --- /dev/null +++ b/test/pages/toc_order.t/omitted.mld @@ -0,0 +1 @@ +{0 This one is omitted} \ No newline at end of file diff --git a/test/pages/toc_order.t/run.t b/test/pages/toc_order.t/run.t new file mode 100644 index 0000000000..a1ae9ec046 --- /dev/null +++ b/test/pages/toc_order.t/run.t @@ -0,0 +1,72 @@ + $ odoc compile --parent-id pkg/doc --output-dir _odoc index.mld + $ odoc compile --parent-id pkg/doc --output-dir _odoc content.mld + $ odoc compile --parent-id pkg/doc --output-dir _odoc omitted.mld + $ odoc compile --parent-id pkg/doc/dir1 --output-dir _odoc dir1/index.mld + $ odoc compile --parent-id pkg/doc/dir1 --output-dir _odoc dir1/content_in_dir.mld + $ odoc compile --parent-id pkg/doc/dir1 --output-dir _odoc dir1/dontent.mld + + $ odoc link _odoc/pkg/doc/page-index.odoc + $ odoc link _odoc/pkg/doc/page-content.odoc + $ odoc link _odoc/pkg/doc/page-omitted.odoc + $ odoc link _odoc/pkg/doc/dir1/page-index.odoc + $ odoc link _odoc/pkg/doc/dir1/page-content_in_dir.odoc + $ odoc link _odoc/pkg/doc/dir1/page-dontent.odoc + + $ odoc compile-index -P test:_odoc/pkg/doc + File "index.mld", line 5, character 7 to line 7, character 0: + Warning: Duplicate 'dir1/' in (children). + File "index.mld", line 5, character 7 to line 7, character 0: + Warning: 'typo' in (children) does not correspond to anything. + File "index.mld", line 5, character 7 to line 7, character 0: + Warning: (children) doesn't include 'omitted'. + + $ odoc html-generate --indent --index index.odoc-index -o _html _odoc/pkg/doc/page-index.odocl + $ odoc html-generate --index index.odoc-index -o _html _odoc/pkg/doc/page-content.odocl + $ odoc html-generate --index index.odoc-index -o _html _odoc/pkg/doc/page-omitted.odocl + $ odoc html-generate --index index.odoc-index -o _html _odoc/pkg/doc/dir1/page-index.odocl + $ odoc html-generate --index index.odoc-index -o _html _odoc/pkg/doc/dir1/page-content_in_dir.odocl + $ odoc html-generate --index index.odoc-index -o _html _odoc/pkg/doc/dir1/page-dontent.odocl + $ odoc support-files -o _html + + $ odoc_print _odoc/pkg/doc/page-index.odocl | jq .frontmatter + { + "children": { + "Some": [ + { + "Page": "content" + }, + { + "Dir": "dir1" + }, + { + "Dir": "dir1" + }, + { + "Page": "typo" + } + ] + } + } + + +$ cp -r _html /tmp/html + +The order in toplevel should be as given by the children field, and by +alphabetical order on the filename in dir1. +Omitted has been added in the children of index, after the ones that were ordered. +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/doc/index.html | grep odoc-global-toc -A 11 +