Frontmatter: add support for @short_title

panglesd · panglesd · commit 111eb881817d · 2024-11-15T15:00:33.000+01:00
diff --git a/src/model/frontmatter.ml b/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
diff --git a/src/model/frontmatter.mli b/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
diff --git 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"
+  | `Short_title _ -> "@short_title"
 
 let warn_unexpected_tag { Location.value; location } =
   Error.raise_warning
@@ -54,45 +55,6 @@ let rec find_tags acc ~filter = function
           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)
-          tags
-      with
-      | Some (status, _) -> status
-      | None -> `Default)
-  | Expect_canonical -> (
-      match find_tag (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);
-      ()
-
 (* Errors *)
 let invalid_raw_markup_target : string -> Location.span -> Error.t =
   Error.make ~suggestion:"try '{%html:...%}'."
@@ -135,6 +97,7 @@ let describe_element = function
   | `Link (_, _) -> "'{{:...} ...}' (external link)"
   | `Heading (level, _, _) ->
       Printf.sprintf "'{%i ...}' (section heading)" level
+  | `Specific s -> s
 
 (* End of errors *)
 
@@ -185,7 +148,8 @@ type surrounding =
   | `Reference of
     [ `Simple | `With_text ]
     * string Location_.with_location
-    * Odoc_parser.Ast.inline_element Location_.with_location list ]
+    * Odoc_parser.Ast.inline_element Location_.with_location list
+  | `Specific of string ]
 
 let rec non_link_inline_element :
     surrounding:surrounding ->
@@ -521,12 +485,13 @@ 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 co ->
+        | (`Children_order _ | `Short_title _) as tag ->
+            let tag_name = describe_internal_tag tag in
             if not start then
               Error.raise_warning
-                (Error.make "@children_order tag has to be before any content"
+                (Error.make "%s tag has to be before any content" tag_name
                    wloc.location);
-            next (`Children_order co)
+            next tag
         | `Canonical { Location.value = s; location = r_location } -> (
             match
               Error.raise_warnings (Reference.read_path_longident r_location s)
@@ -565,6 +530,51 @@ let append_alerts_to_comment alerts
   in
   comment @ (alerts : alerts :> Comment.docs)
 
+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)
+          tags
+      with
+      | Some (status, _) -> status
+      | None -> `Default)
+  | Expect_canonical -> (
+      match find_tag (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 _ | `Short_title _) as p -> Some p | _ -> None)
+          tags
+      in
+      let lines =
+        let do_ parse loc els =
+          let els = nestable_block_elements els in
+          match parse loc els with
+          | Ok res -> Some res
+          | Error e ->
+              Error.raise_warning e;
+              None
+        in
+        List.filter_map
+          (function
+            | `Children_order co, loc ->
+                do_ Frontmatter.parse_children_order loc co
+            | `Short_title t, loc -> do_ Frontmatter.parse_short_title loc t)
+          unparsed_lines
+      in
+      Frontmatter.of_lines lines |> Error.raise_warnings
+  | Expect_none ->
+      (* Will raise warnings. *)
+      ignore (find_tag (fun _ -> None) tags);
+      ()
+
 let ast_to_comment ~internal_tags ~tags_allowed ~parent_of_sections
     (ast : Ast.t) alerts =
   Error.catch_warnings (fun () ->
@@ -595,3 +605,11 @@ let parse_reference text =
       }
   in
   Reference.parse location text
+
+let non_link_inline_element :
+    context:string ->
+    Odoc_parser.Ast.inline_element with_location list ->
+    Comment.non_link_inline_element with_location list =
+ fun ~context elements ->
+  let surrounding = `Specific context in
+  non_link_inline_elements ~surrounding elements
diff --git a/src/model/semantics.mli b/src/model/semantics.mli
@@ -19,6 +19,11 @@ val ast_to_comment :
   alerts ->
   (Comment.docs * 'tags) Error.with_warnings
 
+val non_link_inline_element :
+  context:string ->
+  Odoc_parser.Ast.inline_element Location_.with_location list ->
+  Comment.non_link_inline_element Location_.with_location list
+
 val parse_comment :
   internal_tags:'tags handle_internal_tags ->
   tags_allowed:bool ->
diff --git a/src/model_desc/comment_desc.ml b/src/model_desc/comment_desc.ml
@@ -187,3 +187,11 @@ let docs = Indirect ((fun n -> ((n :> docs) :> general_docs)), docs)
 
 let docs_or_stop : docs_or_stop t =
   Variant (function `Docs x -> C ("`Docs", x, docs) | `Stop -> C0 "`Stop")
+
+let inline_element : inline_element Location_.with_location list Type_desc.t =
+  List
+    (Indirect
+       ( (fun x ->
+           let x :> general_inline_element Location_.with_location = x in
+           ignore_loc x),
+         inline_element ))
diff --git a/src/model_desc/comment_desc.mli b/src/model_desc/comment_desc.mli
@@ -1,3 +1,8 @@
-val docs : Odoc_model.Comment.docs Type_desc.t
+open Odoc_model
+open Odoc_model.Comment
 
-val docs_or_stop : Odoc_model.Comment.docs_or_stop Type_desc.t
+val docs : docs Type_desc.t
+
+val inline_element : inline_element Location_.with_location list Type_desc.t
+
+val docs_or_stop : docs_or_stop Type_desc.t
diff --git a/src/model_desc/lang_desc.ml b/src/model_desc/lang_desc.ml
@@ -712,6 +712,12 @@ and frontmatter =
         ( "children",
           (fun t -> Option.map ignore_loc t.children_order),
           Option (List child) );
+      F
+        ( "short_title",
+          (fun t ->
+            (t.short_title
+              :> Comment.inline_element Location_.with_location list option)),
+          Option Comment_desc.inline_element );
     ]
 
 and child =
diff --git a/src/odoc/compile.ml b/src/odoc/compile.ml
@@ -207,7 +207,7 @@ let is_index_page = function
   | { iv = `LeafPage (_, p); _ } ->
       String.equal (Names.PageName.to_string p) "index"
 
-let has_children_order { Frontmatter.children_order } =
+let has_children_order { Frontmatter.children_order; _ } =
   Option.is_some children_order
 
 let mld ~parent_id ~parents_children ~output ~children ~warnings_options input =
diff --git a/src/parser/ast.ml b/src/parser/ast.ml
@@ -77,7 +77,9 @@ type internal_tag =
   | `Open
   | `Closed
   | `Hidden
-  | `Children_order of nestable_block_element with_location list ]
+  | `Children_order 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
     are never rendered in the output *)
 
diff --git 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) }
 
+  | ("@short_title")
+    { emit input (`Tag `Short_title) }
+
   | "@see" horizontal_space* '<' ([^ '>']* as url) '>'
     { emit input (`Tag (`See (`Url, url))) }
 
diff --git 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" ]
+  | `Short_title -> [ `Word "@short_title" ]
 
 (* {3 Block element lists} *)
 
@@ -818,7 +819,7 @@ let rec block_element_list :
 
                 let tag = Loc.at location (`Tag tag) in
                 consume_block_elements `After_text (tag :: acc)
-            | (`Deprecated | `Return | `Children_order) as tag ->
+            | (`Deprecated | `Return | `Children_order | `Short_title) as tag ->
                 let content, _stream_head, where_in_line =
                   block_element_list (In_implicitly_ended `Tag)
                     ~parent_markup:token input
@@ -828,6 +829,7 @@ let rec block_element_list :
                   | `Deprecated -> `Deprecated content
                   | `Return -> `Return content
                   | `Children_order -> `Children_order content
+                  | `Short_title -> `Short_title content
                 in
                 let location =
                   location :: List.map Loc.location content |> Loc.span
diff --git a/src/parser/test/test.ml b/src/parser/test/test.ml
@@ -147,6 +147,10 @@ module Ast_to_sexp = struct
         List
           (Atom "@children_order"
           :: List.map (at.at (nestable_block_element at)) es)
+    | `Short_title es ->
+        List
+          (Atom "@short_title"
+          :: List.map (at.at (nestable_block_element at)) es)
     | `See (kind, s, es) ->
         let kind =
           match kind with
diff --git a/src/parser/token.ml b/src/parser/token.ml
@@ -19,6 +19,7 @@ type tag =
     | `Version of string
     | `Canonical of string
     | `Children_order
+    | `Short_title
     | `Inline
     | `Open
     | `Closed
@@ -132,6 +133,7 @@ let print : [< t ] -> string = function
   | `Tag (`Raise _) -> "'@raise'"
   | `Tag `Return -> "'@return'"
   | `Tag `Children_order -> "'@children_order'"
+  | `Tag `Short_title -> "'@short_title'"
   | `Tag (`See _) -> "'@see'"
   | `Tag (`Since _) -> "'@since'"
   | `Tag (`Before _) -> "'@before'"
@@ -237,6 +239,7 @@ let describe : [< t | `Comment ] -> string = function
   | `Tag `Closed -> "'@closed'"
   | `Tag `Hidden -> "'@hidden"
   | `Tag `Children_order -> "'@children_order"
+  | `Tag `Short_title -> "'@short_title"
   | `Comment -> "top-level text"
 
 let describe_element = function
diff --git a/test/frontmatter/frontmatter.t/one_frontmatter.mld b/test/frontmatter/frontmatter.t/one_frontmatter.mld
diff --git a/test/frontmatter/frontmatter.t/run.t b/test/frontmatter/frontmatter.t/run.t
diff --git a/test/frontmatter/short_title.t/run.t b/test/frontmatter/short_title.t/run.t
diff --git a/test/frontmatter/toc_order.t/run.t b/test/frontmatter/toc_order.t/run.t
