Use a tag to define short titles

CHANGES.md

@@ -29,6 +29,8 @@
 - Added a `--asset-path` arg to `html-generate` (@panglesd, #1185)
 - Add a `@children_order` tag to specify the order in the sidebar (@panglesd,
   #1187, #1243)
+- Add a `@short_title` tag to specify the short title of a page for use in
+  the sidebar / breadcrumbs (@panglesd, #1246)
 - 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

@@ -114,7 +114,7 @@ let pad_loc loc =
   { loc.Location.loc_start with pos_cnum = loc.loc_start.pos_cnum + 3 }
 
 let ast_to_comment ~internal_tags parent ast_docs alerts =
-  Odoc_model.Semantics.ast_to_comment ~internal_tags ~sections_allowed:`All
+  Odoc_model.Semantics.ast_to_comment ~internal_tags
     ~tags_allowed:true ~parent_of_sections:parent ast_docs alerts
   |> Error.raise_warnings
 
@@ -150,7 +150,6 @@ let attached_no_tag parent attrs =
 let read_string ~tags_allowed internal_tags parent location str =
   Odoc_model.Semantics.parse_comment
     ~internal_tags
-    ~sections_allowed:`All
     ~tags_allowed
     ~containing_definition:parent
     ~location

src/markdown/odoc_md.ml

@@ -13,8 +13,7 @@ let parse id input_s =
     Doc_of_md.parse_comment ~location ~text:str ()
   in
   let (content, ()), semantics_warnings =
-    Semantics.ast_to_comment ~internal_tags:Expect_none ~sections_allowed:`All
-      ~tags_allowed:false
+    Semantics.ast_to_comment ~internal_tags:Expect_none ~tags_allowed:false
       ~parent_of_sections:(id :> Paths.Identifier.LabelParent.t)
       content []
     |> Error.unpack_warnings

src/model/frontmatter.ml

@@ -1,21 +1,41 @@
 type child = Page of string | Dir of string
 
-type line = Children_order of child Location_.with_location list
+type short_title = Comment.link_content
+
+type line =
+  | Children_order of child Location_.with_location list
+  | Short_title of short_title
 
 type children_order = child Location_.with_location list Location_.with_location
 
-type t = { children_order : children_order option }
+type t = {
+  children_order : children_order option;
+  short_title : short_title option;
+}
+
+let empty = { children_order = None; short_title = None }
 
-let empty = { children_order = None }
+let update ~tag_name ~loc v new_v =
+  match v with
+  | None -> Some new_v
+  | Some _ ->
+      Error.raise_warning (Error.make "Duplicated @%s entry" tag_name loc);
+      v
 
 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 _ } ->
-      Error.raise_warning
-        (Error.make "Duplicated @children_order entry" line.location);
-      fm
+  match line.Location_.value with
+  | Short_title t ->
+      let short_title =
+        update ~tag_name:"short_title" ~loc:line.location fm.short_title t
+      in
+      { fm with short_title }
+  | Children_order children_order ->
+      let children_order = Location_.same line children_order in
+      let children_order =
+        update ~tag_name:"children_order" ~loc:line.location fm.children_order
+          children_order
+      in
+      { fm with children_order }
 
 let parse_child c =
   if Astring.String.is_suffix ~affix:"/" c then
@@ -29,7 +49,7 @@ let parse_children_order loc co =
     | [] -> 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_.value = `Space; _ } :: tl -> parse_words acc tl
     | { location; _ } :: _ ->
         Error
           (Error.make "Only words are accepted when specifying children order"
@@ -41,5 +61,15 @@ let parse_children_order loc co =
       Error
         (Error.make "Only words are accepted when specifying children order" loc)
 
+let parse_short_title loc t =
+  match t with
+  | [ { Location_.value = `Paragraph words; _ } ] ->
+      let short_title = Comment.link_content_of_inline_elements words in
+      Result.Ok (Location_.at loc (Short_title short_title))
+  | _ ->
+      Error
+        (Error.make
+           "Short titles cannot contain other block than a single paragraph" loc)
+
 let of_lines lines =
   Error.catch_warnings @@ fun () -> List.fold_left apply empty lines

src/model/frontmatter.mli

@@ -1,16 +1,26 @@
 type child = Page of string | Dir of string
 
+type short_title = Comment.link_content
+
 type line
 
 type children_order = child Location_.with_location list Location_.with_location
 
-type t = { children_order : children_order option }
+type t = {
+  children_order : children_order option;
+  short_title : short_title option;
+}
 
 val empty : t
 
 val parse_children_order :
   Location_.span ->
-  Odoc_parser.Ast.nestable_block_element Location_.with_location list ->
+  Comment.nestable_block_element Location_.with_location list ->
+  (line Location_.with_location, Error.t) Result.result
+
+val parse_short_title :
+  Location_.span ->
+  Comment.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