Specify children order in frontmatter

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
 

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)

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

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 =

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 () =

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)

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

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

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
 

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

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
 

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