From eb67d4e76f75f6ccd9ce9df8187b311910d2d352 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Thu, 28 Sep 2023 16:32:42 +0200 Subject: [PATCH] Medias: make them nestable blocks Signed-off-by: Paul-Elliot --- src/document/comment.ml | 64 ++++++++--------- src/model/comment.ml | 16 ++--- src/model/semantics.ml | 90 +++++++++-------------- src/parser/ast.ml | 20 +++--- src/parser/syntax.ml | 130 +++++++++------------------------- src/parser/test/test.ml | 24 +++---- src/xref2/link.ml | 18 ++--- test/pages/medias.t/index.mld | 26 ++----- test/pages/medias.t/run.t | 29 ++++---- 9 files changed, 160 insertions(+), 257 deletions(-) diff --git a/src/document/comment.ml b/src/document/comment.ml index c989675562..d04c2e5a6e 100644 --- a/src/document/comment.ml +++ b/src/document/comment.ml @@ -264,6 +264,38 @@ let rec nestable_block_element : and raise warnings *) in [ block @@ Table { data; align } ] + | `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 + in + let url = + match href with + | `Reference (`Resolved r) -> ( + let id = + Odoc_model.Paths.Reference.Resolved.(identifier (r :> t)) + in + match Url.from_identifier ~stop_before:false id with + | Ok url -> Target.Internal (Resolved url) + | Error exn -> + (* FIXME: better error message *) + Printf.eprintf "Id.href failed: %S\n%!" + (Url.Error.to_string exn); + Internal Unresolved) + | `Reference _ -> Internal Unresolved + | `Link href -> External href + in + let i = + match media with + | `Audio -> Block.Audio (url, content) + | `Video -> Video (url, content) + | `Image -> Image (url, content) + in + [ block i ] and paragraph : Comment.paragraph -> Block.one = function | [ { value = `Raw_markup (target, s); _ } ] -> @@ -338,38 +370,6 @@ let attached_block_element : Comment.attached_block_element -> Block.t = function | #Comment.nestable_block_element as e -> nestable_block_element e | `Tag t -> [ block ~attr:[ "at-tags" ] @@ Description [ tag t ] ] - | `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 - in - let url = - match href with - | `Reference (`Resolved r) -> ( - let id = - Odoc_model.Paths.Reference.Resolved.(identifier (r :> t)) - in - match Url.from_identifier ~stop_before:false id with - | Ok url -> Target.Internal (Resolved url) - | Error exn -> - (* FIXME: better error message *) - Printf.eprintf "Id.href failed: %S\n%!" - (Url.Error.to_string exn); - Internal Unresolved) - | `Reference _ -> Internal Unresolved - | `Link href -> External href - in - let i = - match media with - | `Audio -> Block.Audio (url, content) - | `Video -> Video (url, content) - | `Image -> Image (url, content) - in - [ block i ] (* TODO collaesce tags *) diff --git a/src/model/comment.ml b/src/model/comment.ml index e08ee976e4..0178b57fa4 100644 --- a/src/model/comment.ml +++ b/src/model/comment.ml @@ -54,6 +54,10 @@ type 'a abstract_table = { align : alignment option list option; } +type media_href = [ `Link of string | `Reference of Reference.Asset.t ] + +type media_element = [ `Media of media_href * media * paragraph ] + type nestable_block_element = [ `Paragraph of paragraph | `Code_block of @@ -66,7 +70,7 @@ type nestable_block_element = | `Table of nestable_block_element abstract_table | `List of [ `Unordered | `Ordered ] * nestable_block_element with_location list list - ] + | media_element ] type tag = [ `Author of string @@ -93,12 +97,7 @@ type heading_level = | `Paragraph | `Subparagraph ] -type media_href = [ `Link of string | `Reference of Reference.Asset.t ] - -type media_element = [ `Media of media_href * media * paragraph ] - -type attached_block_element = - [ nestable_block_element | media_element | `Tag of tag ] +type attached_block_element = [ nestable_block_element | `Tag of tag ] type heading_attrs = { heading_level : heading_level; @@ -110,8 +109,7 @@ type block_element = [ nestable_block_element | `Heading of heading_attrs * Identifier.Label.t * inline_element with_location list - | `Tag of tag - | media_element ] + | `Tag of tag ] type docs = block_element with_location list diff --git a/src/model/semantics.ml b/src/model/semantics.ml index 78c3cd157b..b9caae91ad 100644 --- a/src/model/semantics.ml +++ b/src/model/semantics.ml @@ -276,6 +276,39 @@ let rec nestable_block_element : grid 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 + | { + value = + `Media + (kind, { value = `Reference href; location = href_location }, content, m); + location; + } -> ( + match Error.raise_warnings (Reference.parse href_location href) with + | Result.Ok target -> + let text = inline_elements status content in + let target = + match target with + | `Asset _ as a -> a + | `Root (_, `TAsset) as a -> a + | `Root (s, `TUnknown) -> `Root (s, `TAsset) + | `Root _ -> failwith "a" + | `Dot (_, s) -> failwith s + | `Resolved _ -> failwith "todo2" + | _ -> failwith "todo" + in + `Media (`Reference target, m, text) |> Location.at location + | Result.Error error -> + Error.raise_warning error; + let placeholder = + match kind with + | `Simple -> `Code_span href + | `With_text -> `Styled (`Emphasis, content) + in + `Paragraph + (inline_elements status [ placeholder |> Location.at location ]) + |> Location.at location) and nestable_block_elements status elements = List.map (nestable_block_element status) elements @@ -483,62 +516,7 @@ let top_level_block_elements status ast_elements = in traverse ~top_heading_level (element :: comment_elements_acc) - ast_elements - | { - value = `Media (_, { value = `Link href; _ }, content, m); - location; - } -> - let text = inline_elements status content in - let element = - `Media (`Link href, m, text) |> Location.at location - in - traverse ~top_heading_level - (element :: comment_elements_acc) - ast_elements - | { - value = - `Media - ( kind, - { value = `Reference href; location = href_location }, - content, - m ); - location; - } -> ( - match Error.raise_warnings (Reference.parse href_location href) with - | Result.Ok target -> - let text = inline_elements status content in - let target = - match target with - | `Asset _ as a -> a - | `Root (_, `TAsset) as a -> a - | `Root (s, `TUnknown) -> `Root (s, `TAsset) - | `Root _ -> failwith "a" - | `Dot (_, s) -> failwith s - | `Resolved _ -> failwith "todo2" - | _ -> failwith "todo" - in - let element = - `Media (`Reference target, m, text) |> Location.at location - in - traverse ~top_heading_level - (element :: comment_elements_acc) - ast_elements - | Result.Error error -> - Error.raise_warning error; - let placeholder = - match kind with - | `Simple -> `Code_span href - | `With_text -> `Styled (`Emphasis, content) - in - let placeholder = - `Paragraph - (inline_elements status - [ placeholder |> Location.at location ]) - |> Location.at location - in - traverse ~top_heading_level - (placeholder :: comment_elements_acc) - ast_elements)) + ast_elements) in let top_heading_level = (* Non-page documents have a generated title. *) diff --git a/src/parser/ast.ml b/src/parser/ast.ml index fdcac90370..f3386a308f 100644 --- a/src/parser/ast.ml +++ b/src/parser/ast.ml @@ -40,6 +40,9 @@ type code_block_meta = { tags : string with_location option; } +type media = Token.media +type media_href = Token.media_href + type code_block = { meta : code_block_meta option; delimiter : string option; @@ -57,7 +60,12 @@ and nestable_block_element = * [ `Light | `Heavy ] * nestable_block_element with_location list list | `Table of table - | `Math_block of string (** @since 2.0.0 *) ] + | `Math_block of string (** @since 2.0.0 *) + | `Media of + reference_kind + * media_href with_location + * inline_element with_location list + * media (** @since 2.3.0 *)] (** Some block elements may be nested within lists or tags, but not all. The [`List] constructor has a parameter of type [\[`Light | `Heavy\]]. This corresponds to the syntactic constructor used (see the @@ -89,17 +97,9 @@ type ocamldoc_tag = type tag = [ ocamldoc_tag | internal_tag ] type heading = int * string option * inline_element with_location list -type media = Token.media -type media_href = Token.media_href - type block_element = [ nestable_block_element | `Heading of heading - | `Tag of tag - | `Media of - reference_kind - * media_href with_location - * inline_element with_location list - * media ] + | `Tag of tag ] type t = block_element with_location list diff --git a/src/parser/syntax.ml b/src/parser/syntax.ml index b864c84f8c..365dfae7d4 100644 --- a/src/parser/syntax.ml +++ b/src/parser/syntax.ml @@ -1150,109 +1150,49 @@ let rec block_element_list : | { location; value = `Begin_media_with_replacement_text (href, media) as token; - } as next_token -> ( + } as next_token -> warn_if_after_tags next_token; - let recover_when_not_at_top_level context = - warn_because_not_at_top_level next_token; - junk input; - let content, brace_location = - delimited_inline_element_list ~parent_markup:token - ~parent_markup_location:location ~requires_leading_whitespace:true - input - in - let location = Loc.span [ location; brace_location ] in - let paragraph = - `Paragraph content - |> accepted_in_all_contexts context - |> Loc.at location - in - consume_block_elements ~parsed_a_tag `At_start_of_line - (paragraph :: acc) - in - - match context with - | In_shorthand_list -> - if where_in_line = `At_start_of_line then - (List.rev acc, next_token, where_in_line) - else recover_when_not_at_top_level context - | In_explicit_list -> recover_when_not_at_top_level context - | In_table_cell -> recover_when_not_at_top_level context - | In_tag -> recover_when_not_at_top_level context - | In_code_results -> recover_when_not_at_top_level context - | Top_level -> - if where_in_line <> `At_start_of_line then - Parse_error.should_begin_on_its_own_line - ~what:(Token.describe token) location - |> add_warning input; + junk input; - 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 - let content, brace_location = - delimited_inline_element_list ~parent_markup:token - ~parent_markup_location:location - ~requires_leading_whitespace:false input - in + if content = [] then + Parse_error.should_not_be_empty ~what:(Token.describe token) location + |> add_warning input; - let r_location = - Loc.nudge_start - (String.length @@ Token.s_of_media `Replaced media) - location - in - let href = href |> Loc.at r_location in - let location = Loc.span [ location; brace_location ] in - let heading = `Media (`Simple, href, content, media) in - let heading = Loc.at location heading in - let acc = heading :: acc in - consume_block_elements ~parsed_a_tag `After_text acc) - | { location; value = `Simple_media (href, media) as token } as next_token - -> ( + 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 + let acc = block :: acc in + consume_block_elements ~parsed_a_tag `After_text acc + | { location; value = `Simple_media (href, media) } as next_token -> warn_if_after_tags next_token; - let recover_when_not_at_top_level context = - warn_because_not_at_top_level next_token; - junk input; - let content = - match href with - | `Link href -> [ `Word href |> Loc.at location ] - | `Reference href -> [ `Word href |> Loc.at location ] - in - let paragraph = - `Paragraph content - |> accepted_in_all_contexts context - |> Loc.at location - in - consume_block_elements ~parsed_a_tag `At_start_of_line - (paragraph :: acc) - in - - match context with - | In_shorthand_list -> - if where_in_line = `At_start_of_line then - (List.rev acc, next_token, where_in_line) - else recover_when_not_at_top_level context - | In_explicit_list -> recover_when_not_at_top_level context - | In_table_cell -> recover_when_not_at_top_level context - | In_tag -> recover_when_not_at_top_level context - | In_code_results -> recover_when_not_at_top_level context - | Top_level -> - if where_in_line <> `At_start_of_line then - Parse_error.should_begin_on_its_own_line - ~what:(Token.describe token) location - |> add_warning input; - - junk input; + junk input; - let r_location = - Loc.nudge_start - (String.length @@ Token.s_of_media `Replaced media) - location - in - let href = href |> Loc.at r_location in - let heading = `Media (`Simple, href, [], media) in - let heading = Loc.at location heading in - let acc = heading :: acc in - consume_block_elements ~parsed_a_tag `After_text acc) + let r_location = + Loc.nudge_start + (String.length @@ Token.s_of_media `Replaced media) + location + in + let href = href |> Loc.at r_location 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 + consume_block_elements ~parsed_a_tag `After_text acc in let where_in_line = diff --git a/src/parser/test/test.ml b/src/parser/test/test.ml index 6a801c8146..9b4efe2f6e 100644 --- a/src/parser/test/test.ml +++ b/src/parser/test/test.ml @@ -66,6 +66,10 @@ module Ast_to_sexp = struct let code_block_lang at { Ast.language; tags } = List [ at.at str language; opt (at.at str) tags ] + let media_href = function + | `Reference href -> List [ Atom "Reference"; Atom href ] + | `Link href -> List [ Atom "Link"; Atom href ] + let rec nestable_block_element at : Ast.nestable_block_element -> sexp = function | `Paragraph es -> @@ -121,6 +125,14 @@ module Ast_to_sexp = struct map (kind k) cell @@ at.at (nestable_block_element at) ); 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; + ] let tag at : Ast.tag -> sexp = function | `Author s -> List [ Atom "@author"; Atom s ] @@ -159,10 +171,6 @@ module Ast_to_sexp = struct | `Closed -> Atom "@closed" | `Hidden -> Atom "@hidden" - let media_href = function - | `Reference href -> List [ Atom "Reference"; Atom href ] - | `Link href -> List [ Atom "Link"; Atom href ] - let block_element at : Ast.block_element -> sexp = function | #Ast.nestable_block_element as e -> nestable_block_element at e | `Heading (level, label, es) -> @@ -171,14 +179,6 @@ module Ast_to_sexp = struct List [ Atom level; label; List (List.map (at.at (inline_element at)) es) ] | `Tag t -> tag at t - | `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; - ] let docs at : Ast.t -> sexp = fun f -> List (List.map (at.at (block_element at)) f) diff --git a/src/xref2/link.ml b/src/xref2/link.ml index b7a254bd4e..0fe8aa1767 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -297,6 +297,15 @@ and comment_nestable_block_element env parent ~loc:_ |> List.rev in `Modules refs + | `Media (`Reference r, m, content) as orig -> ( + match Ref_tools.resolve_asset_reference env r |> Error.raise_warnings with + | Ok x -> `Media (`Reference (`Resolved x), m, content) + | Error e -> + Errors.report + ~what:(`Reference (r :> Paths.Reference.t)) + ~tools_error:(`Reference e) `Resolve; + orig) + | `Media _ as orig -> orig and comment_nestable_block_element_list env parent (xs : Comment.nestable_block_element Comment.with_location list) = @@ -344,15 +353,6 @@ and comment_block_element env parent ~loc (x : Comment.block_element) = check_ambiguous_label ~loc env h; `Heading h | `Tag t -> `Tag (comment_tag env parent ~loc t) - | `Media (`Reference r, m, content) as orig -> ( - match Ref_tools.resolve_asset_reference env r |> Error.raise_warnings with - | Ok x -> `Media (`Reference (`Resolved x), m, content) - | Error e -> - Errors.report - ~what:(`Reference (r :> Paths.Reference.t)) - ~tools_error:(`Reference e) `Resolve; - orig) - | `Media _ as orig -> orig and with_location : type a. diff --git a/test/pages/medias.t/index.mld b/test/pages/medias.t/index.mld index 641f13225b..32b5ae2573 100644 --- a/test/pages/medias.t/index.mld +++ b/test/pages/medias.t/index.mld @@ -6,29 +6,15 @@ Some image: -{image!"caml.gif"} - -With an alt text: - -{{image!"caml.gif"}With alt text and {b emphasis}} - -Unresolved without alt text: - -{image!"caqzdqzdml.gif"} - -Unresolved with alt text: - -{{image!"camezfzeffl.gif"}With alt text and {b emphasis}} +- Without alt text:{image!"caml.gif"} +- With an alt text: {{image!"caml.gif"}With alt text and {b emphasis}} +- Unresolved without alt text: {image!"caqzdqzdml.gif"} +- Unresolved with alt text: {{image!"camezfzeffl.gif"}With alt text and {b emphasis}} {2 Links} -- Alt text: - -{{image:https://picsum.photos/200/300}reference} - -- No alt text: - -{image:https://picsum.photos/200/300} +- Alt text: {{image:https://picsum.photos/200/300}reference} +- No alt text: {image:https://picsum.photos/200/300} {1 Audio} diff --git a/test/pages/medias.t/run.t b/test/pages/medias.t/run.t index 7febf0eff6..f475c5d631 100644 --- a/test/pages/medias.t/run.t +++ b/test/pages/medias.t/run.t @@ -7,27 +7,28 @@ This will have produced a file called 'page-index.odoc'. Link and generate the HTML (forgetting the asset!): $ odoc link page-index.odoc - File "index.mld", line 21, characters 0-57: + File "index.mld", line 12, characters 28-85: Warning: Failed to resolve reference unresolvedroot(camezfzeffl.gif) Couldn't find asset "camezfzeffl.gif" - File "index.mld", line 17, characters 0-24: + File "index.mld", line 11, characters 31-55: Warning: Failed to resolve reference unresolvedroot(caqzdqzdml.gif) Couldn't find asset "caqzdqzdml.gif" $ odoc html-generate -o html --indent --asset caml.gif page-index.odocl $ odoc support-files -o html To test visually, indent: - $ cp -r html /tmp/ - $ firefox /tmp/html/index/index.html + $ cp -r html /tmp/ + $ firefox /tmp/html/index/index.html Testing the working references: $ cat html/index/index.html | grep img - caml.gif - - With alt text and emphasis - - reference - - + caml.gif + + With alt text and emphasis + + reference + + Video @@ -38,15 +39,15 @@ Testing the working references: $ cat html/index/index.html | grep audio
  • Audio -

    Audio

    +

    Audio