From 701414fdc2ade9bf074aae7c2097f4d1d78c5bdc Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Thu, 14 Nov 2024 18:11:26 +0100 Subject: [PATCH] Frontmatter: add support for `@short_title` --- src/model/frontmatter.ml | 52 +++++++-- src/model/frontmatter.mli | 14 ++- src/model/semantics.ml | 104 ++++++++++-------- src/model/semantics.mli | 5 + src/model_desc/comment_desc.ml | 8 ++ src/model_desc/comment_desc.mli | 9 +- src/model_desc/lang_desc.ml | 6 + src/odoc/compile.ml | 2 +- src/parser/ast.ml | 4 +- src/parser/lexer.mll | 3 + src/parser/syntax.ml | 4 +- src/parser/test/test.ml | 8 +- src/parser/token.ml | 3 + .../frontmatter.t/one_frontmatter.mld | 1 + test/frontmatter/frontmatter.t/run.t | 13 ++- test/frontmatter/short_title.t/run.t | 65 +++++++++++ test/frontmatter/toc_order.t/run.t | 3 +- 17 files changed, 239 insertions(+), 65 deletions(-) create mode 100644 test/frontmatter/short_title.t/run.t diff --git a/src/model/frontmatter.ml b/src/model/frontmatter.ml index 79542be3e9..00c4e9497c 100644 --- 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 index 61f2e5d704..8cf0f715c0 100644 --- 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 index 072b338882..ad70ad0d89 100644 --- 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 f = function warn_unexpected_tag hd; find_tags acc f 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 [] - (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 [] + (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 index 48105dbe20..fea10ac04f 100644 --- 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 index eaade4d676..4964b8c79f 100644 --- 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 index 91e438e35c..707b5bf49c 100644 --- 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 index 02f8ef1d86..eb32d6a9c0 100644 --- 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 index cf30247825..ee61392078 100644 --- 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 index c8533dca91..29f7eba660 100644 --- 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 index 5a71b48836..1a795edd6d 100644 --- 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 index 5d4445543a..086610c530 100644 --- 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 index ef438ee366..866bfc1a1d 100644 --- a/src/parser/test/test.ml +++ b/src/parser/test/test.ml @@ -144,7 +144,13 @@ module Ast_to_sexp = struct | `Return es -> List (Atom "@return" :: List.map (at.at (nestable_block_element at)) es) | `Children_order es -> - List (Atom "@return" :: List.map (at.at (nestable_block_element at)) es) + 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 index 6d298b8e4b..8b9330f3f3 100644 --- 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 index fa90306d98..5c69bf0d88 100644 --- a/test/frontmatter/frontmatter.t/one_frontmatter.mld +++ b/test/frontmatter/frontmatter.t/one_frontmatter.mld @@ -1,3 +1,4 @@ @children_order page1 page2 +@short_title yes! {0 One frontmatter} diff --git a/test/frontmatter/frontmatter.t/run.t b/test/frontmatter/frontmatter.t/run.t index 4bdb9baac7..00c752e4d1 100644 --- a/test/frontmatter/frontmatter.t/run.t +++ b/test/frontmatter/frontmatter.t/run.t @@ -3,7 +3,8 @@ When there is no frontmatter, everything is normal $ odoc compile zero_frontmatter.mld $ odoc_print page-zero_frontmatter.odoc | jq '.frontmatter' { - "children": "None" + "children": "None", + "short_title": "None" } When there is one frontmatter, it is extracted from the content: @@ -22,6 +23,13 @@ When there is one frontmatter, it is extracted from the content: "Page": "page2" } ] + }, + "short_title": { + "Some": [ + { + "`Word": "yes!" + } + ] } } $ odoc_print page-one_frontmatter.odoc | jq '.content' @@ -74,7 +82,8 @@ When there is more than one children order, we raise a warning and keep only the "Page": "bli2" } ] - } + }, + "short_title": "None" } $ odoc_print page-two_frontmatters.odoc | jq '.content' [ diff --git a/test/frontmatter/short_title.t/run.t b/test/frontmatter/short_title.t/run.t new file mode 100644 index 0000000000..67f3a0e3b6 --- /dev/null +++ b/test/frontmatter/short_title.t/run.t @@ -0,0 +1,65 @@ +Normal use + + $ cat << EOF > index.mld + > @short_title First try + > {0 Test1} + > EOF + $ odoc compile --parent-id pkg --output-dir _odoc index.mld + $ odoc_print _odoc/pkg/page-index.odoc | jq .frontmatter.short_title -c + {"Some":[{"`Word":"First"},"`Space",{"`Word":"try"}]} + +With inline content + + $ cat << EOF > index.mld + > @short_title with [code] and {e emphasized} content + > {0 Test1} + > EOF + $ odoc compile --parent-id pkg --output-dir _odoc index.mld + $ odoc_print _odoc/pkg/page-index.odoc | jq .frontmatter.short_title -c + {"Some":[{"`Word":"with"},"`Space",{"`Code_span":"code"},"`Space",{"`Word":"and"},"`Space",{"`Styled":["`Emphasis",[{"`Word":"emphasized"}]]},"`Space",{"`Word":"content"}]} + +With reference or link + + $ cat << EOF > index.mld + > @short_title with {:link} and {!ref} + > {0 Test1} + > EOF + $ odoc compile --parent-id pkg --output-dir _odoc index.mld + $ odoc_print _odoc/pkg/page-index.odoc | jq .frontmatter.short_title -c + {"Some":[{"`Word":"with"},"`Space","`Space",{"`Word":"and"},"`Space"]} + +With other block + + $ cat << EOF > index.mld + > @short_title {[code block]} + > {0 Test1} + > EOF + $ odoc compile --parent-id pkg --output-dir _odoc index.mld + File "index.mld", line 1, characters 0-27: + Warning: Short titles cannot contain other block than a single paragraph + $ odoc_print _odoc/pkg/page-index.odoc | jq .frontmatter.short_title -c + "None" + + $ cat << EOF > index.mld + > @short_title paragraph + > {ul {li yo}} + > {0 Test1} + > EOF + $ odoc compile --parent-id pkg --output-dir _odoc index.mld + File "index.mld", line 1, character 0 to line 2, character 12: + Warning: Short titles cannot contain other block than a single paragraph + $ odoc_print _odoc/pkg/page-index.odoc | jq .frontmatter.short_title -c + "None" + +Multiple occurrence + + $ cat << EOF > index.mld + > @short_title yay + > @short_title yo + > {0 Test1} + > EOF + $ odoc compile --parent-id pkg --output-dir _odoc index.mld + File "index.mld", line 2, characters 0-15: + Warning: Duplicated @short_title entry + $ odoc_print _odoc/pkg/page-index.odoc | jq .frontmatter.short_title -c + {"Some":[{"`Word":"yay"}]} diff --git a/test/frontmatter/toc_order.t/run.t b/test/frontmatter/toc_order.t/run.t index 754cdd0257..66c86dce58 100644 --- a/test/frontmatter/toc_order.t/run.t +++ b/test/frontmatter/toc_order.t/run.t @@ -45,7 +45,8 @@ "Page": "typo" } ] - } + }, + "short_title": "None" }