Use a tag to declare the order of children

CHANGES.md

@@ -27,7 +27,8 @@
 - Added a `compile-asset` command (@EmileTrotignon, @panglesd, #1170)
 - Allow referencing assets (@panglesd, #1171)
 - Added a `--asset-path` arg to `html-generate` (@panglesd, #1185)
-- Add a frontmatter syntax for mld pages (@panglesd, #1187)
+- Add a `@children_order` tag to specify the order in the sidebar (@panglesd,
+  #1187, #1243)
 - 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)

src/loader/doc_attr.ml

@@ -161,11 +161,8 @@ let read_string_comment internal_tags parent loc str =
   read_string ~tags_allowed:true internal_tags parent (pad_loc loc) str
 
 let page parent loc str =
-  let doc, () =
-    read_string ~tags_allowed:false Odoc_model.Semantics.Expect_none parent loc.Location.loc_start
+    read_string ~tags_allowed:false Odoc_model.Semantics.Expect_page_tags parent loc.Location.loc_start
       str
-  in
-  `Docs doc
 
 let standalone parent (attr : Parsetree.attribute) :
     Odoc_model.Comment.docs_or_stop option =

src/loader/doc_attr.mli

@@ -37,7 +37,7 @@ val page :
   Paths.Identifier.LabelParent.t ->
   Location.t ->
   string ->
-  Odoc_model.Comment.docs_or_stop
+  Odoc_model.Comment.docs * Frontmatter.t
 (** The parent identifier is used to define labels in the given string (i.e.
     for things like [{1:some_section Some title}]) and the location is used for
     error messages.

src/loader/odoc_loader.mli

@@ -11,7 +11,7 @@ val read_string :
   Paths.Identifier.LabelParent.t ->
   string ->
   string ->
-  (Comment.docs_or_stop, Error.t) result Error.with_warnings
+  (Comment.docs * Frontmatter.t, Error.t) result Error.with_warnings
 
 val read_cmti :
   make_root:make_root ->

src/markdown/odoc_md.ml

@@ -24,7 +24,7 @@ let parse id input_s =
 let mk_page input_s id content =
   (* Construct the output file representation *)
   let zero_heading = Comment.find_zero_heading content in
-  let frontmatter, content = Comment.extract_frontmatter content in
+  let frontmatter = Frontmatter.empty in
   let digest = Digest.file input_s in
   let root =
     let file = Root.Odoc_file.create_page input_s zero_heading frontmatter in

src/model/comment.ml

@@ -145,15 +145,3 @@ let find_zero_heading docs : link_content option =
           Some (link_content_of_inline_elements h_content)
       | _ -> None)
     docs
-
-let extract_frontmatter docs : _ =
-  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
-  (fm, List.rev rev_content)

src/model/frontmatter.ml

@@ -1,9 +1,6 @@
 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 line = Children_order of child Location_.with_location list
 
 type children_order = child Location_.with_location list Location_.with_location
 
@@ -16,33 +13,33 @@ let apply fm line =
   | 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
+      Error.raise_warning
+        (Error.make "Duplicated @children_order entry" line.location);
+      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)
+let parse_children_order loc co =
+  let rec parse_words acc words =
+    match words with
+    | [] -> Result.Ok (Location_.at loc (Children_order (List.rev acc)))
+    | ({ Location_.value = `Word word; _ } as w) :: tl ->
+        parse_words ({ w with value = parse_child word } :: acc) tl
+    | { Location_.value = `Space _; _ } :: tl -> parse_words acc tl
+    | { location; _ } :: _ ->
+        Error
+          (Error.make "Only words are accepted when specifying children order"
+             location)
   in
-  List.fold_left apply empty entries
+  match co with
+  | [ { Location_.value = `Paragraph words; _ } ] -> parse_words [] words
+  | _ ->
+      Error
+        (Error.make "Only words are accepted when specifying children order" loc)
+
+let of_lines lines =
+  Error.catch_warnings @@ fun () -> List.fold_left apply empty lines

src/model/frontmatter.mli

@@ -1,9 +1,16 @@
 type child = Page of string | Dir of string
 
+type line
+
 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
+val parse_children_order :
+  Location_.span ->
+  Odoc_parser.Ast.nestable_block_element Location_.with_location list ->
+  (line Location_.with_location, Error.t) Result.result
+
+val of_lines : line Location_.with_location list -> t Error.with_warnings

src/model/semantics.ml

@@ -1,3 +1,5 @@
+open Odoc_utils
+
 module Location = Location_
 module Ast = Odoc_parser.Ast
 
@@ -14,13 +16,15 @@ type _ handle_internal_tags =
       : [ `Default | `Inline | `Open | `Closed ] handle_internal_tags
   | Expect_canonical : Reference.path option handle_internal_tags
   | Expect_none : unit handle_internal_tags
+  | Expect_page_tags : Frontmatter.t handle_internal_tags
 
 let describe_internal_tag = function
   | `Canonical _ -> "@canonical"
   | `Inline -> "@inline"
   | `Open -> "@open"
   | `Closed -> "@closed"
   | `Hidden -> "@hidden"
+  | `Children_order _ -> "@children_order"
 
 let warn_unexpected_tag { Location.value; location } =
   Error.raise_warning
@@ -32,34 +36,64 @@ let warn_root_canonical location =
   Error.raise_warning
   @@ Error.make "Canonical paths must contain a dot, eg. X.Y." location
 
-let rec find_tag f = function
+let rec find_tag ~filter = function
   | [] -> None
   | hd :: tl -> (
-      match f hd.Location.value with
+      match filter hd.Location.value with
       | Some x -> Some (x, hd.location)
       | None ->
           warn_unexpected_tag hd;
-          find_tag f tl)
+          find_tag ~filter tl)
+
+let rec find_tags acc ~filter = function
+  | [] -> List.rev acc
+  | hd :: tl -> (
+      match filter hd.Location.value with
+      | Some x -> find_tags ((x, hd.location) :: acc) ~filter tl
+      | None ->
+          warn_unexpected_tag hd;
+          find_tags acc ~filter tl)
 
 let handle_internal_tags (type a) tags : a handle_internal_tags -> a = function
   | Expect_status -> (
       match
         find_tag
-          (function (`Inline | `Open | `Closed) as t -> Some t | _ -> None)
+          ~filter:(function
+            | (`Inline | `Open | `Closed) as t -> Some t | _ -> None)
           tags
       with
       | Some (status, _) -> status
       | None -> `Default)
   | Expect_canonical -> (
-      match find_tag (function `Canonical p -> Some p | _ -> None) tags with
+      match
+        find_tag ~filter:(function `Canonical p -> Some p | _ -> None) tags
+      with
       | Some (`Root _, location) ->
           warn_root_canonical location;
           None
       | Some ((`Dot _ as p), _) -> Some p
       | None -> None)
+  | Expect_page_tags ->
+      let unparsed_lines =
+        find_tags []
+          ~filter:(function `Children_order _ as p -> Some p | _ -> None)
+          tags
+      in
+      let lines =
+        List.filter_map
+          (function
+            | `Children_order co, loc -> (
+                match Frontmatter.parse_children_order loc co with
+                | Ok co -> Some co
+                | Error e ->
+                    Error.raise_warning e;
+                    None))
+          unparsed_lines
+      in
+      Frontmatter.of_lines lines |> Error.raise_warnings
   | Expect_none ->
       (* Will raise warnings. *)
-      ignore (find_tag (fun _ -> None) tags);
+      ignore (find_tag ~filter:(fun _ -> None) tags);
       ()
 
 (* Errors *)
@@ -514,20 +548,28 @@ let top_level_block_elements status ast_elements =
   traverse ~top_heading_level [] ast_elements
 
 let strip_internal_tags ast : internal_tags_removed with_location list * _ =
-  let rec loop tags ast' = function
+  let rec loop ~start tags ast' = function
     | ({ Location.value = `Tag (#Ast.internal_tag as tag); _ } as wloc) :: tl
       -> (
-        let next tag = loop ({ wloc with value = tag } :: tags) ast' tl in
+        let next tag =
+          loop ~start ({ wloc with value = tag } :: tags) ast' tl
+        in
         match tag with
         | (`Inline | `Open | `Closed | `Hidden) as tag -> next tag
+        | `Children_order co ->
+            if not start then
+              Error.raise_warning
+                (Error.make "@children_order tag has to be before any content"
+                   wloc.location);
+            next (`Children_order co)
         | `Canonical { Location.value = s; location = r_location } -> (
             match
               Error.raise_warnings (Reference.read_path_longident r_location s)
             with
             | Result.Ok path -> next (`Canonical path)
             | Result.Error e ->
                 Error.raise_warning e;
-                loop tags ast' tl))
+                loop ~start tags ast' tl))
     | ({
          value =
            ( `Tag #Ast.ocamldoc_tag
@@ -536,10 +578,10 @@ let strip_internal_tags ast : internal_tags_removed with_location list * _ =
          _;
        } as hd)
       :: tl ->
-        loop tags (hd :: ast') tl
+        loop ~start:false tags (hd :: ast') tl
     | [] -> (List.rev ast', List.rev tags)
   in
-  loop [] [] ast
+  loop ~start:true [] [] ast
 
 (** Append alerts at the end of the comment. Tags are favoured in case of alerts of the same name. *)
 let append_alerts_to_comment alerts
@@ -559,7 +601,7 @@ let append_alerts_to_comment alerts
   comment @ (alerts : alerts :> Comment.docs)
 
 let ast_to_comment ~internal_tags ~sections_allowed ~tags_allowed
-    ~parent_of_sections ast alerts =
+    ~parent_of_sections (ast : Ast.t) alerts =
   Error.catch_warnings (fun () ->
       let status = { sections_allowed; tags_allowed; parent_of_sections } in
       let ast, tags = strip_internal_tags ast in

src/model/semantics.mli

@@ -4,6 +4,7 @@ type _ handle_internal_tags =
       : [ `Default | `Inline | `Open | `Closed ] handle_internal_tags
   | Expect_canonical : Reference.path option handle_internal_tags
   | Expect_none : unit handle_internal_tags
+  | Expect_page_tags : Frontmatter.t handle_internal_tags
 
 type sections_allowed = [ `All | `No_titles | `None ]
 

src/odoc/compile.ml

@@ -245,13 +245,11 @@ let mld ~parent_id ~parents_children ~output ~children ~warnings_options input =
      | None -> Ok (Paths.Identifier.Mk.page (parent_id, page_name)))
      >>= fun id -> Ok (id :> Paths.Identifier.Page.t))
   >>= fun id ->
-  let resolve content =
+  let resolve content frontmatter =
     let zero_heading = Comment.find_zero_heading content in
-    let frontmatter, content = Comment.extract_frontmatter content in
     if (not (is_index_page id)) && has_children_order frontmatter then
       Error.raise_warning
-        (Error.filename_only
-           "Non-index page cannot specify (children _) in the frontmatter."
+        (Error.filename_only "Non-index page cannot specify @children_order."
            input_s);
     let root =
       let file =
@@ -281,8 +279,7 @@ let mld ~parent_id ~parents_children ~output ~children ~warnings_options input =
   Odoc_loader.read_string (id :> Paths.Identifier.LabelParent.t) input_s str
   |> Error.raise_errors_and_warnings
   |> function
-  | `Stop -> resolve [] (* TODO: Error? *)
-  | `Docs content -> resolve content
+  | content, page_tags -> resolve content page_tags
 
 let handle_file_ext ext =
   match ext with

src/odoc/html_fragment.ml

@@ -9,12 +9,12 @@ let from_mld ~xref_base_uri ~resolver ~output ~warnings_options input =
   in
   let input_s = Fs.File.to_string input in
   let digest = Digest.file input_s in
-  let to_html content =
+  let to_html content frontmatter =
     (* This is a mess. *)
-    let frontmatter, content = Odoc_model.Comment.extract_frontmatter content in
     let root =
       let file =
-        Odoc_model.Root.Odoc_file.create_page page_name None frontmatter
+        Odoc_model.Root.Odoc_file.create_page page_name None
+          Odoc_model.Frontmatter.empty
       in
       { Odoc_model.Root.id; file; digest }
     in
@@ -53,7 +53,6 @@ let from_mld ~xref_base_uri ~resolver ~output ~warnings_options input =
       Odoc_loader.read_string id input_s str
       |> Odoc_model.Error.handle_errors_and_warnings ~warnings_options
       >>= function
-      | `Docs content -> to_html content
-      | `Stop -> to_html [])
+      | content, frontmatter -> to_html content frontmatter)
 
 (* TODO: Error? *)

src/parser/ast.ml

@@ -72,7 +72,12 @@ and nestable_block_element =
 and table = nestable_block_element abstract_table * [ `Light | `Heavy ]
 
 type internal_tag =
-  [ `Canonical of string with_location | `Inline | `Open | `Closed | `Hidden ]
+  [ `Canonical of string with_location
+  | `Inline
+  | `Open
+  | `Closed
+  | `Hidden
+  | `Children_order of nestable_block_element with_location list ]
 (** Internal tags are used to exercise fine control over the output of odoc. They
     are never rendered in the output *)
 

src/parser/lexer.mll

@@ -540,6 +540,9 @@ and token input = parse
   | ("@return" | "@returns")
     { emit input (`Tag `Return) }
 
+  | ("@children_order")
+    { emit input (`Tag `Children_order) }
+
   | "@see" horizontal_space* '<' ([^ '>']* as url) '>'
     { emit input (`Tag (`See (`Url, url))) }