Media: Do not interpret markup in replacement text

panglesd · jonludlam · commit 4625765e812f · 2024-08-27T13:15:45.000+01:00
diff --git a/src/document/comment.ml b/src/document/comment.ml
@@ -280,11 +280,10 @@ let rec nestable_block_element :
   | `Media (href, media, content) ->
       let content =
         match (content, href) with
-        | [], `Reference path ->
-            let s = Reference.render_unresolved (path :> Comment.Reference.t) in
-            [ inline @@ Inline.Source (source_of_code s) ]
-        | [], `Link href -> [ inline @@ Inline.Source (source_of_code href) ]
-        | _ -> inline_element_list content
+        | "", `Reference path ->
+            Reference.render_unresolved (path :> Comment.Reference.t)
+        | "", `Link href -> href
+        | _ -> content
       in
       let url =
         match href with
diff --git a/src/document/doctree.ml b/src/document/doctree.ml
@@ -380,16 +380,17 @@ end = struct
      fun x ->
       match x.desc with
       | Inline x -> inline x
-      | Audio (_, x) -> inline x
-      | Video (_, x) -> inline x
-      | Image (_, x) -> inline x
       | Paragraph x -> inline x
       | List (_, x) -> List.exists block x
       | Table { data; align = _ } ->
           List.exists (List.exists (fun (cell, _) -> block cell)) data
       | Description x -> description x
       | Math _ -> true
-      | Source _ | Verbatim _ | Raw_markup _ -> false
+      | Audio (_, _)
+      | Video (_, _)
+      | Image (_, _)
+      | Source _ | Verbatim _ | Raw_markup _ ->
+          false
     in
     List.exists block_ x
 
diff --git a/src/document/types.ml b/src/document/types.ml
@@ -94,9 +94,9 @@ and Block : sig
     | Verbatim of string
     | Raw_markup of Raw_markup.t
     | Table of t Table.t
-    | Image of Target.t * Inline.t
-    | Video of Target.t * Inline.t
-    | Audio of Target.t * Inline.t
+    | Image of Target.t * string
+    | Video of Target.t * string
+    | Audio of Target.t * string
 
   and list_type = Ordered | Unordered
 end =
diff --git a/src/html/generator.ml b/src/html/generator.ml
@@ -207,26 +207,6 @@ let text_align = function
 
 let cell_kind = function `Header -> Html.th | `Data -> Html.td
 
-(* Turns an inline into a string, for use as alternative text in
-   images *)
-let rec alt_of_inline (i : Inline.t) =
-  let rec alt_of_source s =
-    List.map
-      (function
-        | Source.Elt i -> alt_of_inline i | Tag (_, t) -> alt_of_source t)
-      s
-    |> String.concat ""
-  in
-  let alt_of_one (o : Inline.one) =
-    match o.desc with
-    | Text t | Math t | Entity t -> t
-    | Linebreak -> "\n"
-    | Styled (_, i) | Link { content = i; _ } -> alt_of_inline i
-    | Source s -> alt_of_source s
-    | Raw_markup _ -> ""
-  in
-  List.map alt_of_one i |> String.concat ""
-
 let rec block ~config ~resolve (l : Block.t) : flow Html.elt list =
   let as_flow x = (x : phrasing Html.elt list :> flow Html.elt list) in
   let one (t : Block.one) =
@@ -242,7 +222,7 @@ let rec block ~config ~resolve (l : Block.t) : flow Html.elt list =
             let url = Link.href ~config ~resolve uri in
             media_block url
         | Internal Unresolved ->
-            let content = inline ~config ~resolve content in
+            let content = [ Html.txt content ] in
             let a = Html.a_class [ "xref-unresolved" ] :: [] in
             [ Html.span ~a content ]
       in
@@ -286,7 +266,6 @@ let rec block ~config ~resolve (l : Block.t) : flow Html.elt list =
         mk_media_block video target content
     | Image (target, alt) ->
         let image src =
-          let alt = alt_of_inline alt in
           let img =
             Html.a
               ~a:[ Html.a_href src; Html.a_class [ "img-link" ] ]
diff --git a/src/latex/generator.ml b/src/latex/generator.ml
@@ -282,7 +282,7 @@ let rec block ~in_source (l : Block.t) =
     match t.desc with
     | Inline i -> inline ~verbatim:false ~in_source:false i
     | Audio (_, content) | Video (_, content) | Image (_, content) ->
-        inline ~verbatim:false ~in_source:false content
+        txt ~verbatim:false ~in_source:false [ content ]
         @ if in_source then [] else [ Break Paragraph ]
     | Paragraph i ->
         inline ~in_source:false ~verbatim:false i
diff --git a/src/manpage/generator.ml b/src/manpage/generator.ml
@@ -368,7 +368,7 @@ let rec block (l : Block.t) =
       match b.desc with
       | Inline i -> inline i ++ continue rest
       | Video (_, content) | Audio (_, content) | Image (_, content) ->
-          inline content ++ continue rest
+          str "%s" content ++ continue rest
       | Paragraph i -> inline i ++ continue rest
       | List (list_typ, l) ->
           let f n b =
diff --git a/src/model/comment.ml b/src/model/comment.ml
@@ -58,7 +58,7 @@ type 'a abstract_table = {
 
 type media_href = [ `Link of string | `Reference of Reference.Asset.t ]
 
-type media_element = [ `Media of media_href * media * paragraph ]
+type media_element = [ `Media of media_href * media * string ]
 
 type nestable_block_element =
   [ `Paragraph of paragraph
diff --git a/src/model/semantics.ml b/src/model/semantics.ml
@@ -5,10 +5,7 @@ type internal_tags_removed =
   [ `Tag of Ast.ocamldoc_tag
   | `Heading of Ast.heading
   | `Media of
-    Ast.reference_kind
-    * Ast.media_href Ast.with_location
-    * Ast.inline_element Ast.with_location list
-    * Ast.media
+    Ast.reference_kind * Ast.media_href Ast.with_location * string * Ast.media
   | Ast.nestable_block_element ]
 (** {!Ast.block_element} without internal tags. *)
 
@@ -277,8 +274,7 @@ let rec nestable_block_element :
       in
       `Table { Comment.data; align } |> Location.at location
   | { value = `Media (_, { value = `Link href; _ }, content, m); location } ->
-      let text = inline_elements status content in
-      `Media (`Link href, m, text) |> Location.at location
+      `Media (`Link href, m, content) |> Location.at location
   | {
    value =
      `Media
@@ -290,16 +286,16 @@ let rec nestable_block_element :
         let placeholder =
           match kind with
           | `Simple -> `Code_span href
-          | `With_text -> `Styled (`Emphasis, content)
+          | `With_text ->
+              `Styled (`Emphasis, [ `Word content |> Location.at location ])
         in
         `Paragraph
           (inline_elements status [ placeholder |> Location.at location ])
         |> Location.at location
       in
       match Error.raise_warnings (Reference.parse_asset href_location href) with
       | Result.Ok target ->
-          let text = inline_elements status content in
-          `Media (`Reference target, m, text) |> Location.at location
+          `Media (`Reference target, m, content) |> Location.at location
       | Result.Error error -> fallback error)
 
 and nestable_block_elements status elements =
diff --git a/src/model_desc/comment_desc.ml b/src/model_desc/comment_desc.ml
@@ -33,9 +33,7 @@ type general_block_element =
     Comment.heading_attrs * Identifier.Label.t * general_link_content
   | `Tag of general_tag
   | `Media of
-    [ `Reference of Paths.Reference.t | `Link of string ]
-    * media
-    * general_link_content
+    [ `Reference of Paths.Reference.t | `Link of string ] * media * string
   | `MediaLink of string * media * general_link_content ]
 
 and general_tag =
@@ -155,10 +153,7 @@ let rec block_element : general_block_element t =
     | `Heading h -> C ("`Heading", h, heading)
     | `Tag x -> C ("`Tag", x, tag)
     | `Media (x1, m, x2) ->
-        C
-          ( "`MediaReference",
-            (x1, m, x2),
-            Triple (media_href, media, link_content) )
+        C ("`MediaReference", (x1, m, x2), Triple (media_href, media, string))
     | `MediaLink (x1, m, x2) ->
         C ("`MediaLink", (x1, m, x2), Triple (string, media, link_content)))
 
diff --git a/src/parser/ast.ml b/src/parser/ast.ml
@@ -61,11 +61,7 @@ and nestable_block_element =
     * nestable_block_element with_location list list
   | `Table of table
   | `Math_block of string  (** @since 2.0.0 *)
-  | `Media of
-    reference_kind
-    * media_href with_location
-    * inline_element with_location list
-    * media
+  | `Media of reference_kind * media_href with_location * string * media
     (** @since 3.0.0 *) ]
 (** Some block elements may be nested within lists or tags, but not all.
     The [`List] constructor has a parameter of type [\[`Light | `Heavy\]].
diff --git a/src/parser/lexer.mll b/src/parser/lexer.mll
@@ -181,28 +181,34 @@ let warning =
   with_location_adjustments (fun input location error ->
     input.warnings := (error location) :: !(input.warnings))
 
-let reference_token start target =
+let reference_token media start target input lexbuf =
   match start with
   | "{!" -> `Simple_reference target
   | "{{!" -> `Begin_reference_with_replacement_text target
   | "{:" -> `Simple_link (target)
   | "{{:" -> `Begin_link_with_replacement_text (target)
 
   | "{image!" -> `Simple_media (`Reference target, `Image)
-  | "{{image!" -> `Begin_media_with_replacement_text (`Reference target, `Image)
   | "{image:" -> `Simple_media (`Link target, `Image)
-  | "{{image:" -> `Begin_media_with_replacement_text (`Link target, `Image)
-
   | "{audio!" -> `Simple_media (`Reference target, `Audio)
-  | "{{audio!" -> `Begin_media_with_replacement_text (`Reference target, `Audio)
   | "{audio:" -> `Simple_media (`Link target, `Audio)
-  | "{{audio:" -> `Begin_media_with_replacement_text (`Link target, `Audio)
-
   | "{video!" -> `Simple_media (`Reference target, `Video)
-  | "{{video!" -> `Begin_media_with_replacement_text (`Reference target, `Video)
   | "{video:" -> `Simple_media (`Link target, `Video)
-  | "{{video:" -> `Begin_media_with_replacement_text (`Link target, `Video)
-  | _ -> assert false
+
+  | _ ->
+     let target, kind =
+       match start with
+       | "{{image!" -> `Reference target, `Image
+       | "{{image:" -> `Link target, `Image
+       | "{{audio!" -> `Reference target, `Audio
+       | "{{audio:" -> `Link target, `Audio
+       | "{{video!" -> `Reference target, `Video
+       | "{{video:" -> `Link target, `Video
+       | _ -> assert false
+     in
+     let token_descr = Token.describe (`Media_with_replacement_text (target, kind, "")) in
+     let content = media token_descr (Buffer.create 1024) 0 (Lexing.lexeme_start lexbuf) input lexbuf in
+     `Media_with_replacement_text (target, kind, content)
 
 let trim_leading_space_or_accept_whitespace input start_offset text =
   match text.[0] with
@@ -426,7 +432,7 @@ and token input = parse
       let target =
         reference_content input start start_offset (Buffer.create 16) lexbuf
       in
-      let token = (reference_token start target) in
+      let token = reference_token media start target input lexbuf in
       emit ~start_offset input token }
 
   | "{["
@@ -702,6 +708,32 @@ and math kind buffer nesting_level start_offset input = parse
     { Buffer.add_char buffer c;
       math kind buffer nesting_level start_offset input lexbuf }
 
+and media tok_descr buffer nesting_level start_offset input = parse
+  | '}'
+    { if nesting_level == 0 then
+        Buffer.contents buffer
+      else begin
+        Buffer.add_char buffer '}';
+        media tok_descr buffer (nesting_level - 1) start_offset input lexbuf
+      end
+      }
+  | '{'
+    { Buffer.add_char buffer '{';
+      media tok_descr buffer (nesting_level + 1) start_offset input lexbuf }
+  | ("\\{" | "\\}") as s
+    { Buffer.add_string buffer s;
+      media tok_descr buffer nesting_level start_offset input lexbuf }
+  | eof
+    { warning
+        input
+        (Parse_error.not_allowed
+          ~what:(Token.describe `End)
+          ~in_what:tok_descr);
+      Buffer.contents buffer}
+  | _ as c
+    { Buffer.add_char buffer c;
+      media tok_descr buffer nesting_level start_offset input lexbuf }
+
 and verbatim buffer last_false_terminator start_offset input = parse
   | (space_char as c) "v}"
     { Buffer.add_char buffer c;
diff --git a/src/parser/syntax.ml b/src/parser/syntax.ml
@@ -1149,29 +1149,23 @@ let rec block_element_list :
         consume_block_elements ~parsed_a_tag `At_start_of_line (paragraph :: acc)
     | {
         location;
-        value = `Begin_media_with_replacement_text (href, media) as token;
+        value = `Media_with_replacement_text (href, media, content) as token;
       } as next_token ->
         warn_if_after_tags next_token;
 
         junk input;
 
-        let content, brace_location =
-          delimited_inline_element_list ~parent_markup:token
-            ~parent_markup_location:location ~requires_leading_whitespace:false
-            input
-        in
         let r_location =
           Loc.nudge_start
             (String.length @@ Token.s_of_media `Replaced media)
             location
         in
         let href = href |> Loc.at r_location in
 
-        if content = [] then
+        if content = "" then
           Parse_error.should_not_be_empty ~what:(Token.describe token) location
           |> add_warning input;
 
-        let location = Loc.span [ location; brace_location ] in
         let block = `Media (`Simple, href, content, media) in
         let block = accepted_in_all_contexts context block in
         let block = Loc.at location block in
@@ -1188,7 +1182,7 @@ let rec block_element_list :
             location
         in
         let href = href |> Loc.at r_location in
-        let block = `Media (`Simple, href, [], media) in
+        let block = `Media (`Simple, href, "", media) in
         let block = accepted_in_all_contexts context block in
         let block = Loc.at location block in
         let acc = block :: acc in
@@ -1235,7 +1229,7 @@ and shorthand_list_items :
    fun next_token where_in_line acc ->
     match next_token.value with
     | `End | `Right_brace | `Blank_line _ | `Tag _ | `Begin_section_heading _
-    | `Simple_media _ | `Begin_media_with_replacement_text _ ->
+    | `Simple_media _ | `Media_with_replacement_text _ ->
         (List.rev acc, where_in_line)
     | (`Minus | `Plus) as bullet ->
         if bullet = bullet_token then (
diff --git a/src/parser/test/test.ml b/src/parser/test/test.ml
@@ -126,13 +126,7 @@ module Ast_to_sexp = struct
             alignment;
           ]
     | `Media (kind, href, c, m) ->
-        List
-          [
-            reference_kind kind;
-            at.at media_href href;
-            List (List.map (at.at (inline_element at)) c);
-            media m;
-          ]
+        List [ reference_kind kind; at.at media_href href; Atom c; media m ]
 
   let tag at : Ast.tag -> sexp = function
     | `Author s -> List [ Atom "@author"; Atom s ]
diff --git a/src/parser/token.ml b/src/parser/token.ml
diff --git a/src/search/text.ml b/src/search/text.ml
diff --git a/src/xref2/component.ml b/src/xref2/component.ml
diff --git a/src/xref2/component.mli b/src/xref2/component.mli
