diff --git a/CHANGES.md b/CHANGES.md index 63213caf87..f784df393a 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -29,6 +29,8 @@ - Added a `--asset-path` arg to `html-generate` (@panglesd, #1185) - Add a frontmatter syntax for mld pages (@panglesd, #1187) - 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) ### Changed diff --git a/doc/ocamldoc_differences.mld b/doc/ocamldoc_differences.mld index 238da13004..5992517b37 100644 --- a/doc/ocamldoc_differences.mld +++ b/doc/ocamldoc_differences.mld @@ -30,6 +30,7 @@ The following describes the changes between what [odoc] understands and what’s {3 Improvements} - [odoc] supports writing mathematics and tables with a specific syntax. +- [odoc] supports the inclusion of medias such as audio, video and image. - [odoc] has a better mechanism for disambiguating references in comments. See 'reference syntax' later in this document. - Built-in support for standalone [.mld] files. These are documents using the OCamldoc markup, but they’re rendered as distinct pages. - Structured output: [odoc] can produce output in a structured directory tree rather a set of files. diff --git a/doc/odoc_for_authors.mld b/doc/odoc_for_authors.mld index f0801f89cf..e595d76de5 100644 --- a/doc/odoc_for_authors.mld +++ b/doc/odoc_for_authors.mld @@ -629,6 +629,37 @@ would render as The light syntax has the advantages of being arguably more readable for small tables when viewing the source file directly. However, its content is restricted (for instance, no new line is allowed). The heavy syntax is easier to write, can be more readable for big tables, and supports having any kind of content inside. It does not support alignment (yet). +{2 Medias} + +Odoc 3.0 introduced new markup for medias. Medias are nestable blocks, +so they can be put inside lists and tables, but they cannot be +inlined, for instance in a link. + +There are currently three kinds of medias: image, audio, and +video. Each of them can refer to the file either using an asset +reference, or a direct link. + +The markup for images is [{image:}], [{image!}], +[{{image:}Replacement text}] and [{{image!}Replacement text}], where +[] is a link and [] is a path to an asset. This path can be either +relative or absolute. + +The markup for videos and audios is similar, replacing [image] by respectively +[video] and [audio]. + +The replacement text is used for backends that do not support medias +(latex and man), and for when a reference is unresolved. In the case +of an image, it is also used to generate an alternative text. + +Images are clickable and link to the image file. + +The following source: + +{[ + renders as: {image:https://picsum.photos/200/300} +]} + +renders as: {image:https://picsum.photos/200/300} {2 Stop Comments} diff --git a/src/document/comment.ml b/src/document/comment.ml index 397156747b..9522ec7f6f 100644 --- a/src/document/comment.ml +++ b/src/document/comment.ml @@ -121,9 +121,9 @@ module Reference = struct in match Url.from_identifier ~stop_before:false id with | Ok url -> - let target = InternalLink.Resolved url in - let link = { InternalLink.target; content; tooltip } in - [ inline @@ Inline.InternalLink link ] + let target = Target.Internal (Resolved url) in + let link = { Link.target; content; tooltip } in + [ inline @@ Inline.Link link ] | Error (Not_linkable _) -> content | Error exn -> (* FIXME: better error message *) @@ -137,9 +137,9 @@ module Reference = struct [ inline @@ Inline.Source s ] | Some content -> let link = - { InternalLink.target = Unresolved; content; tooltip = Some s } + { Link.target = Internal Unresolved; content; tooltip = Some s } in - [ inline @@ Inline.InternalLink link ]) + [ inline @@ Inline.Link link ]) end let leaf_inline_element : Comment.leaf_inline_element -> Inline.one = function @@ -184,7 +184,7 @@ let rec inline_element : Comment.inline_element -> Inline.t = function | [] -> [ inline @@ Text target ] | _ -> non_link_inline_element_list content in - [ inline @@ Link (target, content) ] + [ inline @@ Link { target = External target; content; tooltip = None } ] and inline_element_list elements = List.concat @@ -277,6 +277,32 @@ 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 -> + Reference.render_unresolved (path :> Comment.Reference.t) + | "", `Link href -> href + | _ -> content + in + let url = + match href with + | `Reference (`Resolved r) -> ( + let id = + Odoc_model.Paths.Reference.Resolved.Asset.(identifier (r :> t)) + in + match Url.from_asset_identifier id with + | url -> Target.Internal (Resolved url)) + | `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); _ } ] -> @@ -322,7 +348,14 @@ let tag : Comment.tag -> Description.one = | `See (kind, target, content) -> let value = match kind with - | `Url -> mk_value (Inline.Link (target, [ inline @@ Text target ])) + | `Url -> + mk_value + (Inline.Link + { + target = External target; + content = [ inline @@ Text target ]; + tooltip = None; + }) | `File -> mk_value (Inline.Source (source_of_code target)) | `Document -> mk_value (Inline.Text target) in diff --git a/src/document/doctree.ml b/src/document/doctree.ml index 28310df8a4..cfdd2cfa4f 100644 --- a/src/document/doctree.ml +++ b/src/document/doctree.ml @@ -65,9 +65,7 @@ end = struct | Entity _ as t -> return t | Linebreak as t -> return t | Styled (st, content) -> return (Styled (st, remove_links content)) - | Link (_, t) -> t - | InternalLink { target = Resolved _; content = t; _ } -> t - | InternalLink { target = Unresolved; content = t; _ } -> t + | Link { target = _; content = t; _ } -> t | Source l -> let rec f = function | Source.Elt t -> Source.Elt (remove_links t) @@ -388,7 +386,11 @@ end = struct 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 @@ -400,8 +402,7 @@ end = struct fun x -> match x.desc with | Styled (_, x) -> inline x - | Link (_, x) -> inline x - | InternalLink x -> inline x.content + | Link { content = t; _ } -> inline t | Math _ -> true | Text _ | Entity _ | Linebreak | Source _ | Raw_markup _ -> false in diff --git a/src/document/generator.ml b/src/document/generator.ml index f5b7b974ec..c8850dd266 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -33,14 +33,14 @@ let type_var tv = tag "type-var" (O.txt tv) let enclose ~l ~r x = O.span (O.txt l ++ x ++ O.txt r) let resolved p content = - let link = { InternalLink.target = Resolved p; content; tooltip = None } in - O.elt [ inline @@ InternalLink link ] + let link = { Link.target = Internal (Resolved p); content; tooltip = None } in + O.elt [ inline @@ Link link ] let path p content = resolved (Url.from_path p) content let unresolved content = - let link = { InternalLink.target = Unresolved; content; tooltip = None } in - O.elt [ inline @@ InternalLink link ] + let link = { Link.target = Internal Unresolved; content; tooltip = None } in + O.elt [ inline @@ Link link ] let path_to_id path = match Url.Anchor.from_identifier (path :> Paths.Identifier.t) with diff --git a/src/document/sidebar.ml b/src/document/sidebar.ml index 1c081d387c..15f0a96145 100644 --- a/src/document/sidebar.ml +++ b/src/document/sidebar.ml @@ -68,9 +68,8 @@ type t = { pages : pages list; libraries : library list } let of_lang (v : Odoc_model.Lang.Sidebar.t) = let sidebar_toc_entry id content = let href = id |> Url.Path.from_identifier |> Url.from_path in - let target = InternalLink.Resolved href in - let link = { InternalLink.target; content; tooltip = None } in - inline @@ Inline.InternalLink link + let target = Target.Internal (Resolved href) in + inline @@ Inline.Link { target; content; tooltip = None } in let pages = let page_hierarchy { Odoc_model.Lang.Sidebar.page_name; pages } = diff --git a/src/document/types.ml b/src/document/types.ml index 6ab49a3bfe..0a4a4d42e5 100644 --- a/src/document/types.ml +++ b/src/document/types.ml @@ -5,12 +5,19 @@ module rec Class : sig end = Class -and InternalLink : sig - type target = Resolved of Url.t | Unresolved +and Link : sig + type t = { target : Target.t; content : Inline.t; tooltip : string option } +end = + Link + +and Target : sig + type internal = Resolved of Url.t | Unresolved + + type href = string - type t = { target : target; content : Inline.t; tooltip : string option } + type t = Internal of internal | External of href end = - InternalLink + Target and Raw_markup : sig type target = Odoc_model.Comment.raw_markup_target @@ -36,8 +43,6 @@ end = and Inline : sig type entity = string - type href = string - type t = one list and one = { attr : Class.t; desc : desc } @@ -47,8 +52,7 @@ and Inline : sig | Entity of entity | Linebreak | Styled of style * t - | Link of href * t - | InternalLink of InternalLink.t + | Link of Link.t | Source of Source.t | Math of Math.t | Raw_markup of Raw_markup.t @@ -90,6 +94,9 @@ and Block : sig | Verbatim of string | Raw_markup of Raw_markup.t | Table of t Table.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/document/url.ml b/src/document/url.ml index 1dd12f3e35..5fbb47463c 100644 --- a/src/document/url.ml +++ b/src/document/url.ml @@ -455,6 +455,8 @@ let from_identifier ~stop_before = function Ok (from_path @@ Path.from_identifier p) | p -> Anchor.from_identifier p +let from_asset_identifier p = from_path @@ Path.from_identifier p + let kind id = match Anchor.from_identifier id with | Error e -> failwith (Error.to_string e) diff --git a/src/document/url.mli b/src/document/url.mli index 05736d6512..a6c0863a6f 100644 --- a/src/document/url.mli +++ b/src/document/url.mli @@ -108,6 +108,8 @@ val from_path : Path.t -> t val from_identifier : stop_before:bool -> Identifier.t -> (t, Error.t) result +val from_asset_identifier : Identifier.AssetFile.t -> t + val kind : Identifier.t -> kind val render_path : Odoc_model.Paths.Path.t -> string diff --git a/src/document/utils.ml b/src/document/utils.ml index e3b5d861e4..49286b8cb2 100644 --- a/src/document/utils.ml +++ b/src/document/utils.ml @@ -33,8 +33,7 @@ and compute_length_inline (t : Types.Inline.t) : int = | Text s -> acc + String.length s | Entity _e -> acc + 1 | Linebreak -> 0 (* TODO *) - | Styled (_, t) | Link (_, t) | InternalLink { content = t; _ } -> - acc + compute_length_inline t + | Styled (_, t) | Link { content = t; _ } -> acc + compute_length_inline t | Source s -> acc + compute_length_source s | Math _ -> assert false | Raw_markup _ -> assert false diff --git a/src/html/generator.ml b/src/html/generator.ml index a0e332bea9..b40f90b16d 100644 --- a/src/html/generator.ml +++ b/src/html/generator.ml @@ -13,11 +13,12 @@ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) - +module HLink = Link open Odoc_document.Types module Html = Tyxml.Html module Doctree = Odoc_document.Doctree module Url = Odoc_document.Url +module Link = HLink type any = Html_types.flow5 @@ -96,12 +97,12 @@ and styled style ~emph_level = | `Superscript -> (emph_level, Html.sup ~a:[]) | `Subscript -> (emph_level, Html.sub ~a:[]) -let rec internallink ~config ~emph_level ~resolve ?(a = []) - { InternalLink.target; content; tooltip } = +let rec internallink ~config ~emph_level ~resolve ?(a = []) target content + tooltip = let a = match tooltip with Some s -> Html.a_title s :: a | None -> a in let elt = match target with - | Resolved uri -> + | Target.Resolved uri -> let href = Link.href ~config ~resolve uri in let content = inline_nolink ~emph_level content in if Config.search_result config then @@ -137,16 +138,17 @@ and inline ~config ?(emph_level = 0) ~resolve (l : Inline.t) : | Styled (style, c) -> let emph_level, app_style = styled style ~emph_level in [ app_style @@ inline ~config ~emph_level ~resolve c ] - | Link (_, c) when Config.search_result config -> + | Link { content = c; _ } when Config.search_result config -> (* When displaying for a search result, links are displayed as regular text. *) let content = inline_nolink ~emph_level c in [ Html.span ~a content ] - | Link (href, c) -> + | Link { target = External href; content = c; _ } -> let a = (a :> Html_types.a_attrib Html.attrib list) in let content = inline_nolink ~emph_level c in [ Html.a ~a:(Html.a_href href :: a) content ] - | InternalLink c -> internallink ~config ~emph_level ~resolve ~a c + | Link { target = Internal t; content; tooltip } -> + internallink ~config ~emph_level ~resolve ~a t content tooltip | Source c -> source (inline ~config ~emph_level ~resolve) ~a c | Math s -> [ inline_math s ] | Raw_markup r -> raw_markup r @@ -168,7 +170,6 @@ and inline_nolink ?(emph_level = 0) (l : Inline.t) : let emph_level, app_style = styled style ~emph_level in [ app_style @@ inline_nolink ~emph_level c ] | Link _ -> assert false - | InternalLink _ -> assert false | Source c -> source (inline_nolink ~emph_level) ~a c | Math s -> [ inline_math s ] | Raw_markup r -> raw_markup r @@ -213,6 +214,20 @@ let rec block ~config ~resolve (l : Block.t) : flow Html.elt list = let a = Some (class_ (extra_class @ t.attr)) in [ mk ?a content ] in + let mk_media_block media_block target alt = + let block = + match target with + | Target.External url -> media_block url alt + | Internal (Resolved uri) -> + let url = Link.href ~config ~resolve uri in + media_block url alt + | Internal Unresolved -> + let content = [ Html.txt alt ] in + let a = Html.a_class [ "xref-unresolved" ] :: [] in + [ Html.span ~a content ] + in + mk_block Html.div block + in match t.desc with | Inline i -> if t.attr = [] then as_flow @@ inline ~config ~resolve i @@ -243,7 +258,36 @@ let rec block ~config ~resolve (l : Block.t) : flow Html.elt list = let extra_class = [ "language-" ^ lang_tag ] in mk_block ~extra_class Html.pre (source (inline ~config ~resolve) c) | Math s -> mk_block Html.div [ block_math s ] + | Audio (target, alt) -> + let audio src alt = + [ + Html.audio ~src + ~a:[ Html.a_controls (); Html.a_aria "label" [ alt ] ] + []; + ] + in + mk_media_block audio target alt + | Video (target, alt) -> + let video src alt = + [ + Html.video ~src + ~a:[ Html.a_controls (); Html.a_aria "label" [ alt ] ] + []; + ] + in + mk_media_block video target alt + | Image (target, alt) -> + let image src alt = + let img = + Html.a + ~a:[ Html.a_href src; Html.a_class [ "img-link" ] ] + [ Html.img ~src ~alt () ] + in + [ img ] + in + mk_media_block image target alt in + Odoc_utils.List.concat_map l ~f:one and mk_rows ~config ~resolve { align; data } = diff --git a/src/html/html_source.ml b/src/html/html_source.ml index 4a859369d4..9e067d18f9 100644 --- a/src/html/html_source.ml +++ b/src/html/html_source.ml @@ -1,5 +1,7 @@ +module HLink = Link open Odoc_document.Types open Tyxml +module Link = HLink let html_of_doc ~config ~resolve docs = let open Html in diff --git a/src/html_support_files/odoc.css b/src/html_support_files/odoc.css index 23cd23672c..f9a207132c 100644 --- a/src/html_support_files/odoc.css +++ b/src/html_support_files/odoc.css @@ -448,7 +448,7 @@ a { color: inherit; } -a:hover { +a:hover:not(.img-link) { box-shadow: 0 1px 0 0 var(--link-color); } diff --git a/src/latex/generator.ml b/src/latex/generator.ml index 470edec96d..b4cd596b10 100644 --- a/src/latex/generator.ml +++ b/src/latex/generator.ml @@ -219,13 +219,13 @@ let source k (t : Source.t) = and tokens t = Odoc_utils.List.concat_map t ~f:token in tokens t -let rec internalref ~verbatim ~in_source (t : InternalLink.t) = +let rec internalref ~verbatim ~in_source (t : Target.internal) (c : Inline.t) = let target = - match t.target with - | InternalLink.Resolved uri -> Link.label uri + match t with + | Target.Resolved uri -> Link.label uri | Unresolved -> "xref-unresolved" in - let text = Some (inline ~verbatim ~in_source t.content) in + let text = Some (inline ~verbatim ~in_source c) in let short = in_source in Internal_ref { short; target; text } @@ -235,10 +235,11 @@ and inline ~in_source ~verbatim (l : Inline.t) = | Text _s -> assert false | Linebreak -> [ Break Line ] | Styled (style, c) -> [ Style (style, inline ~verbatim ~in_source c) ] - | Link (ext, c) -> + | Link { target = External ext; content = c; _ } -> let content = inline ~verbatim:false ~in_source:false c in [ External_ref (ext, Some content) ] - | InternalLink c -> [ internalref ~in_source ~verbatim c ] + | Link { target = Internal ref_; content = c; _ } -> + [ internalref ~in_source ~verbatim ref_ c ] | Source c -> [ Inlined_code (source (inline ~verbatim:false ~in_source:true) c) ] | Math s -> [ Raw (Format.asprintf "%a" Raw.math s) ] @@ -280,6 +281,9 @@ let rec block ~in_source (l : Block.t) = let one (t : Block.one) = match t.desc with | Inline i -> inline ~verbatim:false ~in_source:false i + | Audio (_, content) | Video (_, content) | Image (_, content) -> + txt ~verbatim:false ~in_source:false [ content ] + @ if in_source then [] else [ Break Paragraph ] | Paragraph i -> inline ~in_source:false ~verbatim:false i @ if in_source then [] else [ Break Paragraph ] diff --git a/src/manpage/generator.ml b/src/manpage/generator.ml index bee3f87751..f18f3e70ee 100644 --- a/src/manpage/generator.ml +++ b/src/manpage/generator.ml @@ -1,6 +1,8 @@ +module ManLink = Link open Odoc_document open Types open Doctree +module Link = ManLink (* Manpages relies on the (g|t|n)roff document language. @@ -247,7 +249,7 @@ let strip l = { h with desc = Styled (sty, List.rev @@ loop [] content) } in loop (h :: acc) t - | Link (_, content) | InternalLink { content; _ } -> + | Link { content; _ } -> let acc = loop acc content in loop acc t | Source code -> @@ -303,9 +305,9 @@ and inline (l : Inline.t) = x ++ inline rest | Linebreak -> break ++ inline rest | Styled (sty, content) -> style sty (inline content) ++ inline rest - | Link (href, content) -> + | Link { target = External href; content; _ } -> env "UR" "UE" href (inline @@ strip content) ++ inline rest - | InternalLink { content; _ } -> + | Link { content; _ } -> font "CI" (inline @@ strip content) ++ inline rest | Source content -> source_code content ++ inline rest | Math s -> math s ++ inline rest @@ -365,6 +367,8 @@ let rec block (l : Block.t) = let continue r = if r = [] then noop else vspace ++ block r in match b.desc with | Inline i -> inline i ++ continue rest + | Video (_, content) | Audio (_, content) | Image (_, content) -> + 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 index 1cbb83b299..b1204ac303 100644 --- a/src/model/comment.ml +++ b/src/model/comment.ml @@ -10,6 +10,8 @@ type style = [ `Bold | `Italic | `Emphasis | `Superscript | `Subscript ] type alignment = [ `Left | `Center | `Right ] +type media = [ `Image | `Audio | `Video ] + type raw_markup_target = string type leaf_inline_element = @@ -54,6 +56,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 * string ] + type nestable_block_element = [ `Paragraph of paragraph | `Code_block of @@ -66,7 +72,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 diff --git a/src/model/paths.ml b/src/model/paths.ml index dc94916282..e055b0202e 100644 --- a/src/model/paths.ml +++ b/src/model/paths.ml @@ -1073,6 +1073,8 @@ module Reference = struct end module Asset = struct + let identifier = function `Identifier id -> id + type t = Paths_types.Resolved_reference.asset end end @@ -1162,6 +1164,10 @@ module Reference = struct type t = Paths_types.Reference.page end + module Asset = struct + type t = Paths_types.Reference.asset + end + module Hierarchy = struct type t = Paths_types.Reference.hierarchy end diff --git a/src/model/paths.mli b/src/model/paths.mli index 95137c5469..bca68307d2 100644 --- a/src/model/paths.mli +++ b/src/model/paths.mli @@ -550,6 +550,8 @@ module rec Reference : sig module Asset : sig type t = Paths_types.Resolved_reference.asset + + val identifier : t -> Identifier.AssetFile.t end type t = Paths_types.Resolved_reference.any @@ -637,6 +639,10 @@ module rec Reference : sig type t = Paths_types.Reference.page end + module Asset : sig + type t = Paths_types.Reference.asset + end + module Hierarchy : sig type t = Paths_types.Reference.hierarchy end diff --git a/src/model/paths_types.ml b/src/model/paths_types.ml index ade1ae8bb7..77cad0bdca 100644 --- a/src/model/paths_types.ml +++ b/src/model/paths_types.ml @@ -645,7 +645,8 @@ module rec Reference : sig | `Type of signature * TypeName.t ] (** @canonical Odoc_model.Paths.Reference.LabelParent.t *) - type asset = [ `Asset_path of hierarchy ] + type asset = + [ `Resolved of Resolved_reference.asset | `Asset_path of hierarchy ] type module_ = [ `Resolved of Resolved_reference.module_ diff --git a/src/model/reference.ml b/src/model/reference.ml index 80c726fa0e..052a2c90bd 100644 --- a/src/model/reference.ml +++ b/src/model/reference.ml @@ -98,7 +98,7 @@ let match_extra_odoc_reference_kind (_location as loc) s : Some `TValue | _ -> None -type reference_kind = [ Paths.Reference.tag_any | `TPathComponent ] +type reference_kind = Paths.Reference.tag_any (* Ideally, [tokenize] would call this on every reference kind annotation during tokenization, when generating the token list. However, that constrains the @@ -121,24 +121,25 @@ let match_reference_kind location s : reference_kind = match result with | Some kind -> kind | None -> unknown_reference_qualifier s location |> Error.raise_exception) - | `End_in_slash -> `TPathComponent type token = { - kind : [ `None | `Prefixed of string | `End_in_slash ]; + kind : [ `None | `Prefixed of string ]; identifier : string; location : Location_.span; } +type path_prefix = Path_prefix of string * Location_.span + (* The string is scanned right-to-left, because we are interested in right-most hyphens. The tokens are also returned in right-to-left order, because the traversals that consume them prefer to look at the deepest identifier first. *) -let tokenize location s : token list = +let tokenize location s : token list * path_prefix option = let rec scan_identifier started_at open_parenthesis_count index tokens = match s.[index] with | exception Invalid_argument _ -> let identifier, location = identifier_ended started_at index in - { kind = `None; identifier; location } :: tokens + ({ kind = `None; identifier; location } :: tokens, None) | '-' when open_parenthesis_count = 0 -> let identifier, location = identifier_ended started_at index in scan_kind identifier location index (index - 1) tokens @@ -148,8 +149,7 @@ let tokenize location s : token list = ({ kind = `None; identifier; location } :: tokens) | '/' when open_parenthesis_count = 0 -> let identifier, location = identifier_ended started_at index in - scan_path index (index - 1) - ({ kind = `None; identifier; location } :: tokens) + scan_path index ({ kind = `None; identifier; location } :: tokens) | ')' -> scan_identifier started_at (open_parenthesis_count + 1) @@ -189,14 +189,14 @@ let tokenize location s : token list = match s.[index] with | exception Invalid_argument _ -> let kind, location = kind_ended identifier_location started_at index in - { kind; identifier; location } :: tokens + ({ kind; identifier; location } :: tokens, None) | '.' -> let kind, location = kind_ended identifier_location started_at index in scan_identifier index 0 (index - 1) ({ kind; identifier; location } :: tokens) | '/' -> let kind, location = kind_ended identifier_location started_at index in - scan_path index (index - 1) ({ kind; identifier; location } :: tokens) + scan_path index ({ kind; identifier; location } :: tokens) | _ -> scan_kind identifier identifier_location started_at (index - 1) tokens and kind_ended identifier_location started_at index = @@ -206,22 +206,15 @@ let tokenize location s : token list = let location = Location_.in_string s ~offset ~length location in let location = Location_.span [ location; identifier_location ] in (kind, location) - and scan_path started_at index tokens = - (* The parsing rules are different for [/]-separated components. [-"".()] are - no longer meaningful. *) - match s.[index] with - | exception Invalid_argument _ -> path_ended started_at index :: tokens - | '/' -> scan_path index (index - 1) (path_ended started_at index :: tokens) - | _ -> scan_path started_at (index - 1) tokens - and path_ended started_at index = - let offset = index + 1 in - let length = started_at - offset in - let identifier = String.sub s offset length in - let location = Location_.in_string s ~offset ~length location in - { kind = `End_in_slash; identifier; location } + and scan_path started_at tokens = + let location = + Location_.in_string s ~offset:0 ~length:(started_at + 1) location + in + (tokens, Some (Path_prefix (String.sub s 0 (started_at + 1), location))) in - scan_identifier (String.length s) 0 (String.length s - 1) [] |> List.rev + scan_identifier (String.length s) 0 (String.length s - 1) [] + |> fun (toks, p) -> (List.rev toks, p) let expected ?(expect_paths = false) allowed location = let unqualified = [ "an unqualified reference" ] in @@ -231,341 +224,355 @@ let expected ?(expect_paths = false) allowed location = let allowed = List.map (Printf.sprintf "'%s-'") allowed @ unqualified in expected_err (pp_hum_comma_separated Format.pp_print_string) allowed location +let parse_path whole_path_location p = + let segs = Astring.String.cuts ~sep:"/" p in + let check segs start = + let _finish = + List.fold_left + (fun offset seg -> + match seg with + | "" -> + let location = + Location_.in_string p ~offset ~length:0 whole_path_location + in + should_not_be_empty ~what:"Identifier in path reference" location + |> Error.raise_exception + | seg -> offset + String.length seg + 1) + start segs + in + () + in + match segs with + | "." :: segs -> + check segs 2; + (`TRelativePath, segs) + | "" :: "" :: segs -> + check segs 2; + (`TCurrentPackage, segs) + | "" :: segs -> + check segs 1; + (`TAbsolutePath, segs) + | segs -> + check segs 0; + (`TRelativePath, segs) + +let parse_path_prefix (Path_prefix (p, path_location)) identifier + prefix_location = + parse_path (Location_.span [ path_location; prefix_location ]) (p ^ identifier) + (* Parse references that do not contain a [/]. Raises errors and warnings. *) let parse whole_reference_location s : Paths.Reference.t Error.with_errors_and_warnings = let open Paths.Reference in let open Names in - let rec path components next_token tokens : Hierarchy.t = - match (next_token, tokens) with - | { kind = `End_in_slash; identifier; _ }, [] -> ( - match identifier with - | "" -> - (* {!/identifier} *) - (`TAbsolutePath, components) - | "." -> - (* {!./identifier} *) - (`TRelativePath, components) - | c -> - (* {!identifier'/identifier} *) - (`TRelativePath, c :: components)) - | ( { kind = `End_in_slash; identifier = ""; _ }, - [ { kind = `End_in_slash; identifier = ""; _ } ] ) -> - (* {!//identifier} *) - (`TCurrentPackage, components) - | { kind = `End_in_slash; identifier; location }, next_token' :: tokens' -> - if identifier = "" then - should_not_be_empty ~what:"Identifier in path reference" location - |> Error.raise_exception; - (* {!path/identifier} *) - path (identifier :: components) next_token' tokens' - | { kind = `None | `Prefixed _; _ }, _ -> - (* Cannot be outputed by the lexer. *) - assert false - in - - let ends_in_slash next_token = - match next_token.kind with `End_in_slash -> true | _ -> false - in - - let rec signature { kind; identifier; location } tokens : Signature.t = - let kind = match_reference_kind location kind in - match tokens with - | [] -> ( - match kind with - | (`TUnknown | `TModule | `TModuleType) as kind -> - `Root (identifier, kind) - | `TPathComponent -> assert false - | _ -> - expected ~expect_paths:true [ "module"; "module-type" ] location - |> Error.raise_exception) - | next_token :: tokens when ends_in_slash next_token -> ( - match kind with - | `TUnknown | `TModule -> - `Module_path (path [ identifier ] next_token tokens) - | _ -> - expected ~expect_paths:true [ "module" ] location - |> Error.raise_exception) - | next_token :: tokens -> ( - match kind with - | `TUnknown -> - `Dot ((parent next_token tokens :> LabelParent.t), identifier) - | `TModule -> - `Module (signature next_token tokens, ModuleName.make_std identifier) - | `TModuleType -> - `ModuleType - (signature next_token tokens, ModuleTypeName.make_std identifier) - | `TPathComponent -> assert false - | _ -> - expected ~expect_paths:true [ "module"; "module-type" ] location - |> Error.raise_exception) - and parent { kind; identifier; location } tokens : FragmentTypeParent.t = - let kind = match_reference_kind location kind in - match tokens with - | [] -> ( - match kind with - | (`TUnknown | `TModule | `TModuleType | `TType) as kind -> - `Root (identifier, kind) - | _ -> - expected [ "module"; "module-type"; "type" ] location - |> Error.raise_exception) - | next_token :: tokens when ends_in_slash next_token -> ( - match kind with - | `TUnknown | `TModule -> - `Module_path (path [ identifier ] next_token tokens) - | _ -> - expected ~expect_paths:true [ "module" ] location - |> Error.raise_exception) - | next_token :: tokens -> ( - match kind with - | `TUnknown -> - `Dot ((parent next_token tokens :> LabelParent.t), identifier) - | `TModule -> - `Module (signature next_token tokens, ModuleName.make_std identifier) - | `TModuleType -> - `ModuleType - (signature next_token tokens, ModuleTypeName.make_std identifier) - | `TType -> - `Type (signature next_token tokens, TypeName.make_std identifier) - | _ -> - expected [ "module"; "module-type"; "type" ] location - |> Error.raise_exception) - in - - let class_signature { kind; identifier; location } tokens : ClassSignature.t = - let kind = match_reference_kind location kind in - match tokens with - | [] -> ( - match kind with - | (`TUnknown | `TClass | `TClassType) as kind -> `Root (identifier, kind) - | _ -> - expected [ "class"; "class-type" ] location |> Error.raise_exception - ) - | next_token :: tokens -> ( - match kind with - | `TUnknown -> - `Dot ((parent next_token tokens :> LabelParent.t), identifier) - | `TClass -> - `Class (signature next_token tokens, TypeName.make_std identifier) - | `TClassType -> - `ClassType - (signature next_token tokens, TypeName.make_std identifier) - | _ -> - expected [ "class"; "class-type" ] location |> Error.raise_exception - ) - in + let parse_from_last_component { kind; identifier; location } old_kind tokens + path_prefix = + let rec signature { kind; identifier; location } tokens : Signature.t = + let kind = match_reference_kind location kind in + match tokens with + | [] -> ( + match path_prefix with + | None -> ( + match kind with + | (`TUnknown | `TModule | `TModuleType) as kind -> + `Root (identifier, kind) + | _ -> + expected ~expect_paths:true + [ "module"; "module-type" ] + location + |> Error.raise_exception) + | Some p -> ( + match kind with + | `TUnknown | `TModule -> + `Module_path (parse_path_prefix p identifier location) + | _ -> + expected ~expect_paths:true [ "module" ] location + |> Error.raise_exception)) + | next_token :: tokens -> ( + match kind with + | `TUnknown -> + `Dot ((parent next_token tokens :> LabelParent.t), identifier) + | `TModule -> + `Module + (signature next_token tokens, ModuleName.make_std identifier) + | `TModuleType -> + `ModuleType + (signature next_token tokens, ModuleTypeName.make_std identifier) + | _ -> + expected ~expect_paths:true [ "module"; "module-type" ] location + |> Error.raise_exception) + and parent { kind; identifier; location } tokens : FragmentTypeParent.t = + let kind = match_reference_kind location kind in + match tokens with + | [] -> ( + match path_prefix with + | None -> ( + match kind with + | (`TUnknown | `TModule | `TModuleType | `TType) as kind -> + `Root (identifier, kind) + | _ -> + expected [ "module"; "module-type"; "type" ] location + |> Error.raise_exception) + | Some p -> ( + match kind with + | `TUnknown | `TModule -> + `Module_path (parse_path_prefix p identifier location) + | _ -> + expected ~expect_paths:true [ "module" ] location + |> Error.raise_exception)) + | next_token :: tokens -> ( + match kind with + | `TUnknown -> + `Dot ((parent next_token tokens :> LabelParent.t), identifier) + | `TModule -> + `Module + (signature next_token tokens, ModuleName.make_std identifier) + | `TModuleType -> + `ModuleType + (signature next_token tokens, ModuleTypeName.make_std identifier) + | `TType -> + `Type (signature next_token tokens, TypeName.make_std identifier) + | _ -> + expected [ "module"; "module-type"; "type" ] location + |> Error.raise_exception) + in - let label_parent_path { identifier; location; _ } kind next_token tokens = - let path () = path [ identifier ] next_token tokens in - match kind with - | `TUnknown -> `Any_path (path ()) - | `TModule -> `Module_path (path ()) - | `TPage -> `Page_path (path ()) - | _ -> - expected ~expect_paths:true [ "module"; "page" ] location - |> Error.raise_exception - in + let class_signature { kind; identifier; location } tokens : ClassSignature.t + = + let kind = match_reference_kind location kind in + match tokens with + | [] -> ( + match kind with + | (`TUnknown | `TClass | `TClassType) as kind -> + `Root (identifier, kind) + | _ -> + expected [ "class"; "class-type" ] location + |> Error.raise_exception) + | next_token :: tokens -> ( + match kind with + | `TUnknown -> + `Dot ((parent next_token tokens :> LabelParent.t), identifier) + | `TClass -> + `Class (signature next_token tokens, TypeName.make_std identifier) + | `TClassType -> + `ClassType + (signature next_token tokens, TypeName.make_std identifier) + | _ -> + expected [ "class"; "class-type" ] location + |> Error.raise_exception) + in - let any_path { identifier; location; _ } kind next_token tokens = - let path () = path [ identifier ] next_token tokens in - match kind with - | `TUnknown -> `Any_path (path ()) - | `TModule -> `Module_path (path ()) - | `TPage -> `Page_path (path ()) - | `TAsset -> `Asset_path (path ()) - | _ -> - expected ~expect_paths:true [ "module"; "page" ] location - |> Error.raise_exception - in + let label_parent_path kind path_prefix identifier location = + match kind with + | `TUnknown -> + `Any_path (parse_path_prefix path_prefix identifier location) + | `TModule -> + `Module_path (parse_path_prefix path_prefix identifier location) + | `TPage -> `Page_path (parse_path_prefix path_prefix identifier location) + | _ -> + expected ~expect_paths:true [ "module"; "page" ] location + |> Error.raise_exception + in - let rec label_parent ({ kind; identifier; location } as token) tokens : - LabelParent.t = - let kind = match_reference_kind location kind in - match tokens with - | [] -> ( - match kind with - | ( `TUnknown | `TModule | `TModuleType | `TType | `TClass | `TClassType - | `TPage ) as kind -> - `Root (identifier, kind) - | `TPathComponent -> assert false - | _ -> - expected ~expect_paths:true - [ "module"; "module-type"; "type"; "class"; "class-type"; "page" ] - location - |> Error.raise_exception) - | next_token :: tokens when ends_in_slash next_token -> - label_parent_path token kind next_token tokens - | next_token :: tokens -> ( - match kind with - | `TUnknown -> `Dot (label_parent next_token tokens, identifier) - | `TModule -> - `Module (signature next_token tokens, ModuleName.make_std identifier) - | `TModuleType -> - `ModuleType - (signature next_token tokens, ModuleTypeName.make_std identifier) - | `TType -> - `Type (signature next_token tokens, TypeName.make_std identifier) - | `TClass -> - `Class (signature next_token tokens, TypeName.make_std identifier) - | `TClassType -> - `ClassType - (signature next_token tokens, TypeName.make_std identifier) - | `TPathComponent -> assert false - | _ -> - expected ~expect_paths:true - [ "module"; "module-type"; "type"; "class"; "class-type" ] - location - |> Error.raise_exception) - in + let any_path kind path_prefix identifier location = + match kind with + | `TUnknown -> + `Any_path (parse_path_prefix path_prefix identifier location) + | `TModule -> + `Module_path (parse_path_prefix path_prefix identifier location) + | `TPage -> `Page_path (parse_path_prefix path_prefix identifier location) + | `TAsset -> + `Asset_path (parse_path_prefix path_prefix identifier location) + | _ -> + expected ~expect_paths:true [ "module"; "page" ] location + |> Error.raise_exception + in - let start_from_last_component ({ kind; identifier; location } as token) - old_kind tokens = - let new_kind = match_reference_kind location kind in - let kind = - match old_kind with - | None -> new_kind - | Some (old_kind_string, old_kind_location) -> ( - let old_kind = - match_reference_kind old_kind_location (`Old_prefix old_kind_string) - in - match new_kind with - | `TUnknown -> old_kind + let rec label_parent { kind; identifier; location } tokens : LabelParent.t = + let kind = match_reference_kind location kind in + match tokens with + | [] -> ( + match path_prefix with + | None -> ( + match kind with + | ( `TUnknown | `TModule | `TModuleType | `TType | `TClass + | `TClassType | `TPage ) as kind -> + `Root (identifier, kind) + | _ -> + expected ~expect_paths:true + [ + "module"; + "module-type"; + "type"; + "class"; + "class-type"; + "page"; + ] + location + |> Error.raise_exception) + | Some p -> label_parent_path kind p identifier location) + | next_token :: tokens -> ( + match kind with + | `TUnknown -> `Dot (label_parent next_token tokens, identifier) + | `TModule -> + `Module + (signature next_token tokens, ModuleName.make_std identifier) + | `TModuleType -> + `ModuleType + (signature next_token tokens, ModuleTypeName.make_std identifier) + | `TType -> + `Type (signature next_token tokens, TypeName.make_std identifier) + | `TClass -> + `Class (signature next_token tokens, TypeName.make_std identifier) + | `TClassType -> + `ClassType + (signature next_token tokens, TypeName.make_std identifier) | _ -> - (if old_kind <> new_kind then - let new_kind_string = - match kind with - | `None | `End_in_slash -> "" - | `Prefixed s -> s - in - reference_kinds_do_not_match old_kind_string new_kind_string - whole_reference_location - |> Error.raise_warning); - new_kind) + expected ~expect_paths:true + [ "module"; "module-type"; "type"; "class"; "class-type" ] + location + |> Error.raise_exception) in - match tokens with - | [] -> ( - match kind with - | #Paths.Reference.tag_any as kind -> `Root (identifier, kind) - | `TPathComponent -> assert false) - | next_token :: tokens when ends_in_slash next_token -> - any_path token kind next_token tokens - | next_token :: tokens -> ( - match kind with - | `TUnknown -> `Dot (label_parent next_token tokens, identifier) - | `TModule -> - `Module (signature next_token tokens, ModuleName.make_std identifier) - | `TModuleType -> - `ModuleType - (signature next_token tokens, ModuleTypeName.make_std identifier) - | `TType -> - `Type (signature next_token tokens, TypeName.make_std identifier) - | `TConstructor -> - `Constructor - (parent next_token tokens, ConstructorName.make_std identifier) - | `TField -> - `Field (parent next_token tokens, FieldName.make_std identifier) - | `TExtension -> - `Extension - (signature next_token tokens, ExtensionName.make_std identifier) - | `TExtensionDecl -> - `ExtensionDecl - (signature next_token tokens, ExtensionName.make_std identifier) - | `TException -> - `Exception - (signature next_token tokens, ExceptionName.make_std identifier) - | `TValue -> - `Value (signature next_token tokens, ValueName.make_std identifier) - | `TClass -> - `Class (signature next_token tokens, TypeName.make_std identifier) - | `TClassType -> - `ClassType - (signature next_token tokens, TypeName.make_std identifier) - | `TMethod -> - `Method - (class_signature next_token tokens, MethodName.make_std identifier) - | `TInstanceVariable -> - `InstanceVariable - ( class_signature next_token tokens, - InstanceVariableName.make_std identifier ) - | `TLabel -> - `Label - (label_parent next_token tokens, LabelName.make_std identifier) - | `TChildPage | `TChildModule -> - let suggestion = - Printf.sprintf "'child-%s' should be first." identifier - in - not_allowed ~what:"Child label" - ~in_what:"the last component of a reference path" ~suggestion - location - |> Error.raise_exception - | `TPage -> - let () = - match next_token.kind with - | `End_in_slash -> () - | `None | `Prefixed _ -> - let suggestion = - Printf.sprintf "Reference pages as '/%s'." - identifier - in - not_allowed ~what:"Page label" - ~in_what:"on the right side of a dot" ~suggestion location - |> Error.raise_exception + let start_from_last_component { kind; identifier; location } old_kind tokens + = + let new_kind = match_reference_kind location kind in + let kind = + match old_kind with + | None -> new_kind + | Some (old_kind_string, old_kind_location) -> ( + let old_kind = + match_reference_kind old_kind_location + (`Old_prefix old_kind_string) in - (* Prefixed pages are not differentiated. *) - `Page_path (path [ identifier ] next_token tokens) - | `TAsset -> - let () = - match next_token.kind with - | `End_in_slash -> () - | `None | `Prefixed _ -> - let suggestion = - Printf.sprintf "Reference assets as '/%s'." - identifier - in - not_allowed ~what:"Asset label" - ~in_what:"on the right side of a dot" ~suggestion location - |> Error.raise_exception - in - (* Prefixed assets are not differentiated. *) - `Asset_path (path [ identifier ] next_token tokens) - | `TPathComponent -> assert false) - in + match new_kind with + | `TUnknown -> old_kind + | _ -> + (if old_kind <> new_kind then + let new_kind_string = + match kind with `None -> "" | `Prefixed s -> s + in + reference_kinds_do_not_match old_kind_string new_kind_string + whole_reference_location + |> Error.raise_warning); + new_kind) + in - let old_kind, s, location = - let rec find_old_reference_kind_separator index = - if index < 0 then raise Not_found - else - match s.[index] with - | ':' -> index - | ')' -> ( - match String.rindex_from s index '(' with - | index -> find_old_reference_kind_separator (index - 1) - | exception (Not_found as exn) -> raise exn) - | _ -> find_old_reference_kind_separator (index - 1) + match tokens with + | [] -> ( + match path_prefix with + | None -> `Root (identifier, kind) + | Some p -> any_path kind p identifier location) + | next_token :: tokens -> ( + match kind with + | `TUnknown -> `Dot (label_parent next_token tokens, identifier) + | `TModule -> + `Module + (signature next_token tokens, ModuleName.make_std identifier) + | `TModuleType -> + `ModuleType + (signature next_token tokens, ModuleTypeName.make_std identifier) + | `TType -> + `Type (signature next_token tokens, TypeName.make_std identifier) + | `TConstructor -> + `Constructor + (parent next_token tokens, ConstructorName.make_std identifier) + | `TField -> + `Field (parent next_token tokens, FieldName.make_std identifier) + | `TExtension -> + `Extension + (signature next_token tokens, ExtensionName.make_std identifier) + | `TExtensionDecl -> + `ExtensionDecl + (signature next_token tokens, ExtensionName.make_std identifier) + | `TException -> + `Exception + (signature next_token tokens, ExceptionName.make_std identifier) + | `TValue -> + `Value (signature next_token tokens, ValueName.make_std identifier) + | `TClass -> + `Class (signature next_token tokens, TypeName.make_std identifier) + | `TClassType -> + `ClassType + (signature next_token tokens, TypeName.make_std identifier) + | `TMethod -> + `Method + ( class_signature next_token tokens, + MethodName.make_std identifier ) + | `TInstanceVariable -> + `InstanceVariable + ( class_signature next_token tokens, + InstanceVariableName.make_std identifier ) + | `TLabel -> + `Label + (label_parent next_token tokens, LabelName.make_std identifier) + | `TChildPage | `TChildModule -> + let suggestion = + Printf.sprintf "'child-%s' should be first." identifier + in + not_allowed ~what:"Child label" + ~in_what:"the last component of a reference path" ~suggestion + location + |> Error.raise_exception + | `TPage -> + let suggestion = + Printf.sprintf "Reference pages as '/%s'." + identifier + in + not_allowed ~what:"Page label" + ~in_what:"on the right side of a dot" ~suggestion location + |> Error.raise_exception + | `TAsset -> + let suggestion = + Printf.sprintf "Reference assets as '/%s'." + identifier + in + not_allowed ~what:"Asset label" + ~in_what:"on the right side of a dot" ~suggestion location + |> Error.raise_exception) in - match find_old_reference_kind_separator (String.length s - 1) with - | index -> - let old_kind = String.trim (String.sub s 0 index) in - let old_kind_location = - Location_.set_end_as_offset_from_start index whole_reference_location - in - let s = String.sub s (index + 1) (String.length s - (index + 1)) in - let location = - Location_.nudge_start (index + 1) whole_reference_location - in - (Some (old_kind, old_kind_location), s, location) - | exception Not_found -> (None, s, whole_reference_location) + start_from_last_component { kind; identifier; location } old_kind tokens in - Error.catch_errors_and_warnings (fun () -> + let old_kind, s, location = + let rec find_old_reference_kind_separator index = + if index < 0 then raise Not_found + else + match s.[index] with + | ':' -> index + | ')' -> ( + match String.rindex_from s index '(' with + | index -> find_old_reference_kind_separator (index - 1) + | exception (Not_found as exn) -> raise exn) + | _ -> find_old_reference_kind_separator (index - 1) + in + match find_old_reference_kind_separator (String.length s - 1) with + | index -> + let old_kind = String.trim (String.sub s 0 index) in + let old_kind_location = + Location_.set_end_as_offset_from_start index + whole_reference_location + in + let s = String.sub s (index + 1) (String.length s - (index + 1)) in + let location = + Location_.nudge_start (index + 1) whole_reference_location + in + (Some (old_kind, old_kind_location), s, location) + | exception Not_found -> (None, s, whole_reference_location) + in match tokenize location s with - | last_token :: tokens -> - start_from_last_component last_token old_kind tokens - | [] -> + | last_token :: tokens, path_prefix -> + parse_from_last_component last_token old_kind tokens path_prefix + | [], _ -> should_not_be_empty ~what:"Reference target" whole_reference_location |> Error.raise_exception) +(* Parse references that do not contain a [/]. Raises errors and warnings. *) +let parse_asset whole_reference_location s : + Paths.Reference.Asset.t Error.with_errors_and_warnings = + let path = parse_path whole_reference_location s in + Error.catch_errors_and_warnings (fun () -> `Asset_path path) + let read_path_longident location s = let rec loop : string -> int -> path option = fun s pos -> diff --git a/src/model/reference.mli b/src/model/reference.mli index 4dae92c326..62586a2af9 100644 --- a/src/model/reference.mli +++ b/src/model/reference.mli @@ -3,6 +3,11 @@ type path = [ `Root of string | `Dot of path * string ] val parse : Location_.span -> string -> Paths.Reference.t Error.with_errors_and_warnings +val parse_asset : + Location_.span -> + string -> + Paths.Reference.Asset.t Error.with_errors_and_warnings + val read_path_longident : Location_.span -> string -> path Error.with_errors_and_warnings diff --git a/src/model/semantics.ml b/src/model/semantics.ml index cc6b14ce60..5f079b7352 100644 --- a/src/model/semantics.ml +++ b/src/model/semantics.ml @@ -4,6 +4,8 @@ module Ast = Odoc_parser.Ast type internal_tags_removed = [ `Tag of Ast.ocamldoc_tag | `Heading of Ast.heading + | `Media of + Ast.reference_kind * Ast.media_href Ast.with_location * string * Ast.media | Ast.nestable_block_element ] (** {!Ast.block_element} without internal tags. *) @@ -105,7 +107,7 @@ let not_allowed : let describe_element = function | `Reference (`Simple, _, _) -> "'{!...}' (cross-reference)" | `Reference (`With_text, _, _) -> "'{{!...} ...}' (cross-reference)" - | `Link _ -> "'{{:...} ...}' (external link)" + | `Link (_, _) -> "'{{:...} ...}' (external link)" | `Heading (level, _, _) -> Printf.sprintf "'{%i ...}' (section heading)" level @@ -270,6 +272,30 @@ let rec nestable_block_element : grid in `Table { Comment.data; align } |> Location.at location + | { value = `Media (_, { value = `Link href; _ }, content, m); location } -> + `Media (`Link href, m, content) |> Location.at location + | { + value = + `Media + (kind, { value = `Reference href; location = href_location }, content, m); + location; + } -> ( + let fallback error = + Error.raise_warning error; + let placeholder = + match kind with + | `Simple -> `Code_span href + | `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 -> + `Media (`Reference target, m, content) |> Location.at location + | Result.Error error -> fallback error) and nestable_block_elements status elements = List.map (nestable_block_element status) elements @@ -354,12 +380,7 @@ let generate_heading_label : Comment.inline_element with_location list -> string anchor | `Styled (_, content) -> content |> strip_locs |> scan_inline_elements anchor - | `Reference (_, content) -> - content |> strip_locs - |> List.map (fun (ele : Comment.non_link_inline_element) -> - (ele :> Comment.inline_element)) - |> scan_inline_elements anchor - | `Link (_, content) -> + | `Reference (_, content) | `Link (_, content) -> content |> strip_locs |> List.map (fun (ele : Comment.non_link_inline_element) -> (ele :> Comment.inline_element)) @@ -509,7 +530,9 @@ let strip_internal_tags ast : internal_tags_removed with_location list * _ = loop tags ast' tl)) | ({ value = - `Tag #Ast.ocamldoc_tag | `Heading _ | #Ast.nestable_block_element; + ( `Tag #Ast.ocamldoc_tag + | `Heading _ | `Media _ + | #Ast.nestable_block_element ); _; } as hd) :: tl -> diff --git a/src/model_desc/comment_desc.ml b/src/model_desc/comment_desc.ml index fb52478369..eaade4d676 100644 --- a/src/model_desc/comment_desc.ml +++ b/src/model_desc/comment_desc.ml @@ -31,7 +31,10 @@ type general_block_element = | `Table of general_block_element abstract_table | `Heading of Comment.heading_attrs * Identifier.Label.t * general_link_content - | `Tag of general_tag ] + | `Tag of general_tag + | `Media of + [ `Reference of Paths.Reference.t | `Link of string ] * media * string + | `MediaLink of string * media * general_link_content ] and general_tag = [ `Author of string @@ -50,6 +53,14 @@ and general_tag = and general_docs = general_block_element with_location list +let media = + Variant + (function + | `Link -> C0 "`Link" + | `Audio -> C0 "`Audio" + | `Video -> C0 "`Video" + | `Image -> C0 "`Image") + let rec inline_element : general_inline_element t = let style = Variant @@ -102,6 +113,12 @@ let heading = in Triple (heading_attrs, identifier, link_content) +let media_href = + Variant + (function + | `Reference r -> C ("`Reference", r, reference) + | `Link l -> C ("`Link", l, string)) + let rec block_element : general_block_element t = let list_kind = Variant @@ -134,7 +151,11 @@ let rec block_element : general_block_element t = let table_desc = Pair (data_desc, Option align_desc) in C ("`Table", (data, align), table_desc) | `Heading h -> C ("`Heading", h, heading) - | `Tag x -> C ("`Tag", x, tag)) + | `Tag x -> C ("`Tag", x, tag) + | `Media (x1, m, x2) -> + C ("`MediaReference", (x1, m, x2), Triple (media_href, media, string)) + | `MediaLink (x1, m, x2) -> + C ("`MediaLink", (x1, m, x2), Triple (string, media, link_content))) and tag : general_tag t = let url_kind = diff --git a/src/parser/ast.ml b/src/parser/ast.ml index 85c38931f1..8662f68e8a 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,9 @@ 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 * 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\]]. This corresponds to the syntactic constructor used (see the diff --git a/src/parser/lexer.mll b/src/parser/lexer.mll index b9352cc968..864c32c25b 100644 --- a/src/parser/lexer.mll +++ b/src/parser/lexer.mll @@ -181,13 +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 - | _ -> assert false + | "{:" -> `Simple_link (target) + | "{{:" -> `Begin_link_with_replacement_text (target) + + | "{image!" -> `Simple_media (`Reference target, `Image) + | "{image:" -> `Simple_media (`Link target, `Image) + | "{audio!" -> `Simple_media (`Reference target, `Audio) + | "{audio:" -> `Simple_media (`Link target, `Audio) + | "{video!" -> `Simple_media (`Reference target, `Video) + | "{video:" -> `Simple_media (`Link target, `Video) + + | _ -> + 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 @@ -264,8 +285,11 @@ let horizontal_space = let newline = '\n' | "\r\n" -let reference_start = - "{!" | "{{!" | "{:" | "{{:" +let media_start = + "{!" | "{{!" | "{:" | "{{:" + | "{image!" | "{{image!" | "{image:" | "{{image:" + | "{video!" | "{{video!" | "{video:" | "{{video:" + | "{audio!" | "{{audio!" | "{audio:" | "{{audio:" let raw_markup = ([^ '%'] | '%'+ [^ '%' '}'])* '%'* @@ -402,13 +426,13 @@ and token input = parse | "{!modules:" ([^ '}']* as modules) '}' { emit input (`Modules modules) } - | (reference_start as start) + | (media_start as start) { let start_offset = Lexing.lexeme_start lexbuf in 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 } | "{[" @@ -684,6 +708,35 @@ 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} + | (newline) + { Buffer.add_char buffer ' '; + media tok_descr buffer nesting_level start_offset input lexbuf } + | _ 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/loc.ml b/src/parser/loc.ml index 0316fa270c..46875a1f6f 100644 --- a/src/parser/loc.ml +++ b/src/parser/loc.ml @@ -23,6 +23,9 @@ let span spans = let nudge_start offset span = { span with start = { span.start with column = span.start.column + offset } } +let nudge_end offset span = + { span with end_ = { span.end_ with column = span.end_.column - offset } } + let spans_multiple_lines = function | { location = diff --git a/src/parser/loc.mli b/src/parser/loc.mli index 135ba0358e..ad8dedb77a 100644 --- a/src/parser/loc.mli +++ b/src/parser/loc.mli @@ -19,6 +19,10 @@ val nudge_start : int -> span -> span (** This adjusts only the column number, implicitly assuming that the offset does not move the location across a newline character. *) +val nudge_end : int -> span -> span +(** This adjusts only the column number, implicitly assuming that the offset does + not move the location across a newline character. *) + (** {2 Located values} *) type +'a with_location = { location : span; value : 'a } diff --git a/src/parser/syntax.ml b/src/parser/syntax.ml index 293682ded6..8d8c490400 100644 --- a/src/parser/syntax.ml +++ b/src/parser/syntax.ml @@ -533,7 +533,7 @@ type where_in_line = When it is called inside a shorthand list item ([- foo]), it stops on end of input, right brace, a blank line (indicating end of shorthand list), plus or - minus (indicating the start of the next liste item), or a section heading or + minus (indicating the start of the next list item), or a section heading or tag, which cannot be nested in list markup. The block parser [block_element_list] explicitly returns the token that @@ -554,6 +554,7 @@ type stopped_implicitly = | `Minus | `Plus | Token.section_heading + | Token.media_markup | Token.tag ] (* Ensure that the above two types are really subsets of [Token.t]. *) @@ -1146,6 +1147,58 @@ let rec block_element_list : |> Loc.at location in consume_block_elements ~parsed_a_tag `At_start_of_line (paragraph :: acc) + | { + location; + value = `Media_with_replacement_text (href, media, content) as token; + } as next_token -> + warn_if_after_tags next_token; + + junk input; + + let r_location = + Loc.nudge_start + (String.length @@ Token.s_of_media `Replaced media) + location + |> Loc.nudge_end (String.length content + 1) + (* +1 for closing character *) + in + let c_location = + Loc.nudge_start + (String.length (Token.s_of_media `Replaced media) + + String.length (match href with `Reference s | `Link s -> s)) + location + |> Loc.nudge_end 1 + in + let content = String.trim content in + let href = href |> Loc.at r_location in + + if content = "" then + Parse_error.should_not_be_empty ~what:(Token.describe token) + c_location + |> add_warning input; + + 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; + + junk input; + + let r_location = + Loc.nudge_start + (String.length @@ Token.s_of_media `Simple media) + location + |> Loc.nudge_end 1 + 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 = @@ -1187,7 +1240,8 @@ and shorthand_list_items : Ast.nestable_block_element with_location list list * where_in_line = fun next_token where_in_line acc -> match next_token.value with - | `End | `Right_brace | `Blank_line _ | `Tag _ | `Begin_section_heading _ -> + | `End | `Right_brace | `Blank_line _ | `Tag _ | `Begin_section_heading _ + | `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 index 1b6cb98140..175828dc67 100644 --- a/src/parser/test/test.ml +++ b/src/parser/test/test.ml @@ -39,6 +39,11 @@ module Ast_to_sexp = struct | `Simple -> Atom "simple" | `With_text -> Atom "with_text" + let media : Ast.media -> sexp = function + | `Image -> Atom "image" + | `Video -> Atom "video" + | `Audio -> Atom "audio" + let rec inline_element at : Ast.inline_element -> sexp = function | `Space _ -> Atom "space" | `Word w -> List [ Atom "word"; Atom w ] @@ -61,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 -> @@ -116,6 +125,8 @@ 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; Atom c; media m ] let tag at : Ast.tag -> sexp = function | `Author s -> List [ Atom "@author"; Atom s ] @@ -1962,6 +1973,205 @@ let%expect_test _ = end in () +let%expect_test _ = + let module Medias = struct + let basic_simple = + test + "{image!foo}\n\n\ + {audio!foo}\n\n\ + {video!foo}\n\n\ + {image:foo}\n\n\ + {audio:foo}\n\n\ + {video:foo}"; + [%expect + {| + ((output + (((f.ml (1 0) (1 11)) + (simple ((f.ml (1 7) (1 10)) (Reference foo)) "" image)) + ((f.ml (3 0) (3 11)) + (simple ((f.ml (3 7) (3 10)) (Reference foo)) "" audio)) + ((f.ml (5 0) (5 11)) + (simple ((f.ml (5 7) (5 10)) (Reference foo)) "" video)) + ((f.ml (7 0) (7 11)) (simple ((f.ml (7 7) (7 10)) (Link foo)) "" image)) + ((f.ml (9 0) (9 11)) (simple ((f.ml (9 7) (9 10)) (Link foo)) "" audio)) + ((f.ml (11 0) (11 11)) + (simple ((f.ml (11 7) (11 10)) (Link foo)) "" video)))) + (warnings ())) |}] + + let basic = + test + "{{image!foo}bar}\n\n\ + {{audio!foo}bar}\n\n\ + {{video!foo}bar}\n\n\ + {{image:foo}bar}\n\n\ + {{audio:foo}bar}\n\n\ + {{video:foo}bar}"; + [%expect + {| + ((output + (((f.ml (1 0) (1 16)) + (simple ((f.ml (1 8) (1 12)) (Reference foo)) bar image)) + ((f.ml (3 0) (3 16)) + (simple ((f.ml (3 8) (3 12)) (Reference foo)) bar audio)) + ((f.ml (5 0) (5 16)) + (simple ((f.ml (5 8) (5 12)) (Reference foo)) bar video)) + ((f.ml (7 0) (7 16)) (simple ((f.ml (7 8) (7 12)) (Link foo)) bar image)) + ((f.ml (9 0) (9 16)) (simple ((f.ml (9 8) (9 12)) (Link foo)) bar audio)) + ((f.ml (11 0) (11 16)) + (simple ((f.ml (11 8) (11 12)) (Link foo)) bar video)))) + (warnings ())) |}] + + let empty = + test "{{image!foo}}"; + [%expect + {| + ((output + (((f.ml (1 0) (1 13)) + (simple ((f.ml (1 8) (1 12)) (Reference foo)) "" image)))) + (warnings + ( "File \"f.ml\", line 1, characters 11-12:\ + \n'{{image!...} ...}' (image-reference) should not be empty."))) |}] + + let whitespace = + test "{{image!foo} }"; + [%expect + {| + ((output + (((f.ml (1 0) (1 16)) + (simple ((f.ml (1 8) (1 12)) (Reference foo)) "" image)))) + (warnings + ( "File \"f.ml\", line 1, characters 11-15:\ + \n'{{image!...} ...}' (image-reference) should not be empty."))) |}] + + let trimming = + test "{{image!foo} hello }"; + [%expect + {| + ((output + (((f.ml (1 0) (1 27)) + (simple ((f.ml (1 8) (1 12)) (Reference foo)) hello image)))) + (warnings ())) |}] + + let nested_markup_is_uninterpreted = + test "{{image!foo}{b bar}}"; + [%expect + {| + ((output + (((f.ml (1 0) (1 20)) + (simple ((f.ml (1 8) (1 12)) (Reference foo)) "{b bar}" image)))) + (warnings ())) |}] + + let in_markup = + test "{ul {li {{image!foo}bar}}}"; + [%expect + {| + ((output + (((f.ml (1 0) (1 26)) + (unordered heavy + ((((f.ml (1 8) (1 24)) + (simple ((f.ml (1 16) (1 20)) (Reference foo)) bar image)))))))) + (warnings ())) |}] + + let unterminated_image = + test "{{image!foo"; + [%expect + {| + ((output + (((f.ml (1 0) (1 11)) + (simple ((f.ml (1 8) (1 10)) (Reference foo)) "" image)))) + (warnings + ( "File \"f.ml\", line 1, characters 0-11:\ + \nOpen bracket '{{image!' is never closed." + "File \"f.ml\", line 1, characters 11-11:\ + \nEnd of text is not allowed in '{{image!...} ...}' (image-reference)." + "File \"f.ml\", line 1, characters 11-10:\ + \n'{{image!...} ...}' (image-reference) should not be empty."))) |}] + + let unterminated_image_simple = + test "{image!foo"; + [%expect + {| + ((output + (((f.ml (1 0) (1 10)) + (simple ((f.ml (1 7) (1 9)) (Reference foo)) "" image)))) + (warnings + ( "File \"f.ml\", line 1, characters 0-10:\ + \nOpen bracket '{image!' is never closed."))) |}] + + let unterminated_video = + test "{{video!foo"; + [%expect + {| + ((output + (((f.ml (1 0) (1 11)) + (simple ((f.ml (1 8) (1 10)) (Reference foo)) "" video)))) + (warnings + ( "File \"f.ml\", line 1, characters 0-11:\ + \nOpen bracket '{{video!' is never closed." + "File \"f.ml\", line 1, characters 11-11:\ + \nEnd of text is not allowed in '{{video!...} ...}' (video-reference)." + "File \"f.ml\", line 1, characters 11-10:\ + \n'{{video!...} ...}' (video-reference) should not be empty."))) |}] + + let unterminated_video_simple = + test "{video!foo"; + [%expect + {| + ((output + (((f.ml (1 0) (1 10)) + (simple ((f.ml (1 7) (1 9)) (Reference foo)) "" video)))) + (warnings + ( "File \"f.ml\", line 1, characters 0-10:\ + \nOpen bracket '{video!' is never closed."))) |}] + + let unterminated_audio = + test "{{audio!foo"; + [%expect + {| + ((output + (((f.ml (1 0) (1 11)) + (simple ((f.ml (1 8) (1 10)) (Reference foo)) "" audio)))) + (warnings + ( "File \"f.ml\", line 1, characters 0-11:\ + \nOpen bracket '{{audio!' is never closed." + "File \"f.ml\", line 1, characters 11-11:\ + \nEnd of text is not allowed in '{{audio!...} ...}' (audio-reference)." + "File \"f.ml\", line 1, characters 11-10:\ + \n'{{audio!...} ...}' (audio-reference) should not be empty."))) |}] + + let unterminated_audio_simple = + test "{audio!foo"; + [%expect + {| + ((output + (((f.ml (1 0) (1 10)) + (simple ((f.ml (1 7) (1 9)) (Reference foo)) "" audio)))) + (warnings + ( "File \"f.ml\", line 1, characters 0-10:\ + \nOpen bracket '{audio!' is never closed."))) |}] + + let unterminated_content = + test "{{image!foo} bar"; + [%expect + {| + ((output + (((f.ml (1 0) (1 16)) + (simple ((f.ml (1 8) (1 11)) (Reference foo)) bar image)))) + (warnings + ( "File \"f.ml\", line 1, characters 16-16:\ + \nEnd of text is not allowed in '{{image!...} ...}' (image-reference)."))) |}] + + let newline_in_content = + test "{{image!foo} bar \n baz}"; + [%expect + {| + ((output + (((f.ml (1 0) (2 5)) + (simple ((f.ml (1 8) (2 -6)) (Reference foo)) "bar baz" image)))) + (warnings ())) |}] + end in + () + let%expect_test _ = let module Link = struct let basic = diff --git a/src/parser/token.ml b/src/parser/token.ml index 83181fe455..4db3b14eb5 100644 --- a/src/parser/token.ml +++ b/src/parser/token.ml @@ -23,6 +23,22 @@ type tag = | `Closed | `Hidden ] ] +type media = [ `Audio | `Video | `Image ] +type media_href = [ `Reference of string | `Link of string ] + +type media_markup = + [ `Simple_media of media_href * media + | `Media_with_replacement_text of media_href * media * string ] + +let s_of_media kind media = + match (kind, media) with + | `Simple, `Audio -> "{audio!" + | `Simple, `Video -> "{video!" + | `Simple, `Image -> "{image!" + | `Replaced, `Audio -> "{{audio!" + | `Replaced, `Video -> "{{video!" + | `Replaced, `Image -> "{{image!" + type t = [ (* End of input. *) `End @@ -62,6 +78,7 @@ type t = | `Begin_reference_with_replacement_text of string | `Simple_link of string | `Begin_link_with_replacement_text of string + | media_markup | (* Leaf block element markup. *) `Code_block of (string Loc.with_location * string Loc.with_location option) option @@ -124,6 +141,21 @@ let print : [< t ] -> string = function | `Tag `Hidden -> "'@hidden" | `Raw_markup (None, _) -> "'{%...%}'" | `Raw_markup (Some target, _) -> "'{%" ^ target ^ ":...%}'" + | `Simple_media (`Reference _, `Image) -> "{image!...}" + | `Simple_media (`Reference _, `Audio) -> "{audio!...}" + | `Simple_media (`Reference _, `Video) -> "{video!...}" + | `Simple_media (`Link _, `Image) -> "{image:...}" + | `Simple_media (`Link _, `Audio) -> "{audio:...}" + | `Simple_media (`Link _, `Video) -> "{video:...}" + | `Media_with_replacement_text (`Reference _, `Image, _) -> + "{{image!...} ...}" + | `Media_with_replacement_text (`Reference _, `Audio, _) -> + "{{audio!...} ...}" + | `Media_with_replacement_text (`Reference _, `Video, _) -> + "{{video!...} ...}" + | `Media_with_replacement_text (`Link _, `Image, _) -> "{{image:...} ...}" + | `Media_with_replacement_text (`Link _, `Audio, _) -> "{{audio:...} ...}" + | `Media_with_replacement_text (`Link _, `Video, _) -> "{{video:...} ...}" (* [`Minus] and [`Plus] are interpreted as if they start list items. Therefore, for error messages based on [Token.describe] to be accurate, formatted @@ -145,6 +177,24 @@ let describe : [< t | `Comment ] -> string = function | `Simple_reference _ -> "'{!...}' (cross-reference)" | `Begin_reference_with_replacement_text _ -> "'{{!...} ...}' (cross-reference)" + | `Simple_media (`Reference _, `Image) -> "'{image!...}' (image-reference)" + | `Simple_media (`Reference _, `Audio) -> "'{audio!...}' (audio-reference)" + | `Simple_media (`Reference _, `Video) -> "'{video!...}' (video-reference)" + | `Simple_media (`Link _, `Image) -> "'{image:...}' (image-link)" + | `Simple_media (`Link _, `Audio) -> "'{audio:...}' (audio-link)" + | `Simple_media (`Link _, `Video) -> "'{video:...}' (video-link)" + | `Media_with_replacement_text (`Reference _, `Image, _) -> + "'{{image!...} ...}' (image-reference)" + | `Media_with_replacement_text (`Reference _, `Audio, _) -> + "'{{audio!...} ...}' (audio-reference)" + | `Media_with_replacement_text (`Reference _, `Video, _) -> + "'{{video!...} ...}' (video-reference)" + | `Media_with_replacement_text (`Link _, `Image, _) -> + "'{{image:...} ...}' (image-link)" + | `Media_with_replacement_text (`Link _, `Audio, _) -> + "'{{audio:...} ...}' (audio-link)" + | `Media_with_replacement_text (`Link _, `Video, _) -> + "'{{video:...} ...}' (video-link)" | `Simple_link _ -> "'{:...} (external link)'" | `Begin_link_with_replacement_text _ -> "'{{:...} ...}' (external link)" | `End -> "end of text" diff --git a/src/search/entry.ml b/src/search/entry.ml index 0c7ace8ef3..055f8ec813 100644 --- a/src/search/entry.ml +++ b/src/search/entry.ml @@ -137,6 +137,7 @@ and entries_of_doc id d = | `Verbatim _ -> [ entry ~id ~doc:[ d ] ~kind:(Doc Verbatim) ] | `Math_block _ -> [ entry ~id ~doc:[ d ] ~kind:(Doc MathBlock) ] | `Table _ -> [] + | `Media _ -> [] let entries_of_item (x : Odoc_model.Fold.item) = match x with diff --git a/src/search/text.ml b/src/search/text.ml index 228157e40b..189c72dcd8 100644 --- a/src/search/text.ml +++ b/src/search/text.ml @@ -17,8 +17,7 @@ module Of_document = struct | Entity e -> "&" ^ e | Linebreak -> "\n" | Styled (_, t) -> inline t - | Link (_, t) -> inline t - | InternalLink { content; _ } -> inline content + | Link { content; _ } -> inline content | Source s -> source s | Math m -> m | Raw_markup _ -> "" @@ -59,6 +58,7 @@ module Of_comments = struct | `Code_block (_, s, _todo) -> s |> get_value | `Verbatim v -> v | `Math_block m -> m + | `Media (_, _, is) -> is | `Table _ -> (* TODO *) "" and nestable (n : Odoc_model.Comment.nestable_block_element) = diff --git a/src/xref2/component.ml b/src/xref2/component.ml index c72c5b94a1..d3eb1e2bca 100644 --- a/src/xref2/component.ml +++ b/src/xref2/component.ml @@ -452,7 +452,9 @@ and CComment : sig type block_element = [ Odoc_model.Comment.nestable_block_element | `Heading of Label.t - | `Tag of Odoc_model.Comment.tag ] + | `Tag of Odoc_model.Comment.tag + | `Media of + Odoc_model.Comment.media_href * Odoc_model.Comment.media * string ] type docs = block_element Odoc_model.Comment.with_location list @@ -2699,7 +2701,7 @@ module Of_Lang = struct let label = Ident.Of_Identifier.label label in Odoc_model.Location_.same b (`Heading { Label.attrs; label; text; location }) - | { value = `Tag _; _ } as t -> t + | { value = `Tag _ | `Media _; _ } as t -> t | { value = #Odoc_model.Comment.nestable_block_element; _ } as n -> n and docs ident_map d = List.map (block_element ident_map) d diff --git a/src/xref2/component.mli b/src/xref2/component.mli index 1b53a9f5f2..5e009dc2d6 100644 --- a/src/xref2/component.mli +++ b/src/xref2/component.mli @@ -429,7 +429,9 @@ and CComment : sig type block_element = [ Odoc_model.Comment.nestable_block_element | `Heading of Label.t - | `Tag of Odoc_model.Comment.tag ] + | `Tag of Odoc_model.Comment.tag + | `Media of + Odoc_model.Comment.media_href * Odoc_model.Comment.media * string ] type docs = block_element Odoc_model.Comment.with_location list diff --git a/src/xref2/lang_of.ml b/src/xref2/lang_of.ml index 4260ef893c..5b35fec06f 100644 --- a/src/xref2/lang_of.ml +++ b/src/xref2/lang_of.ml @@ -1080,7 +1080,7 @@ and block_element parent raise Not_found in `Heading (attrs, label, text) - | `Tag t -> `Tag t + | (`Tag _ | `Media _) as orig -> orig | #Odoc_model.Comment.nestable_block_element as n -> n in { d with Odoc_model.Location_.value } diff --git a/src/xref2/link.ml b/src/xref2/link.ml index e4e0aafeea..e61f4958ba 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -293,6 +293,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) = diff --git a/src/xref2/ref_tools.ml b/src/xref2/ref_tools.ml index d56d0d8788..f41da8c2d5 100644 --- a/src/xref2/ref_tools.ml +++ b/src/xref2/ref_tools.ml @@ -21,7 +21,7 @@ type class_type_lookup_result = Resolved.ClassType.t * Component.ClassType.t type page_lookup_result = Resolved.Page.t * Odoc_model.Lang.Page.t -type asset_lookup_result = Resolved.Asset.t * Odoc_model.Lang.Asset.t +type asset_lookup_result = Resolved.Asset.t type type_lookup_result = [ `T of datatype_lookup_result @@ -241,7 +241,7 @@ module Path = struct let asset_in_env env p : asset_lookup_result ref_result = Env.lookup_asset_by_path p env |> handle_lookup_error p >>= fun p -> - Ok (`Identifier p.name, p) + Ok (`Identifier p.name) let module_in_env env p : module_lookup_result ref_result = Env.lookup_unit_by_path p env |> handle_lookup_error p >>= fun m -> @@ -643,7 +643,7 @@ module Asset = struct let in_env env name : t ref_result = match Env.lookup_asset_by_name name env with - | Ok p -> Ok (`Identifier p.Odoc_model.Lang.Asset.name, p) + | Ok p -> Ok (`Identifier p.Odoc_model.Lang.Asset.name) | Error `Not_found -> Error (`Lookup_by_name (`Page (* TODO *), name)) end @@ -833,6 +833,9 @@ let resolved3 (r, _, _) = resolved1 r and resolved2 (r, _) = resolved1 r +let resolve_asset_reference env (r : Reference.Asset.t) : Asset.t ref_result = + match r with `Resolved r -> Ok r | `Asset_path p -> Path.asset_in_env env p + let resolved_type_lookup = function | `T (r, _) -> resolved1 r | `C (r, _) -> resolved1 r @@ -960,7 +963,7 @@ let resolve_reference : resolve_label_parent_reference env parent >>= fun p -> L.in_label_parent env p name >>= resolved_with_text | `Root (name, (`TPage | `TChildPage)) -> Page.in_env env name >>= resolved2 - | `Root (name, `TAsset) -> Asset.in_env env name >>= resolved2 + | `Root (name, `TAsset) -> Asset.in_env env name >>= resolved1 | `Dot (parent, name) -> resolve_reference_dot env parent name | `Root (name, `TConstructor) -> CS.in_env env name >>= resolved1 | `Constructor (parent, name) -> @@ -991,7 +994,7 @@ let resolve_reference : resolve_class_signature_reference env parent >>= fun p -> MV.in_class_signature env p name >>= resolved1 | `Page_path p -> Path.page_in_env env p >>= resolved2 - | `Asset_path a -> Path.asset_in_env env a >>= resolved2 + | `Asset_path a -> Path.asset_in_env env a >>= resolved1 | `Module_path p -> Path.module_in_env env p >>= module_lookup_to_signature_lookup env @@ -1001,5 +1004,8 @@ let resolve_reference : let resolve_module_reference env m = Odoc_model.Error.catch_warnings (fun () -> resolve_module_reference env m) +let resolve_asset_reference env m = + Odoc_model.Error.catch_warnings (fun () -> resolve_asset_reference env m) + let resolve_reference env m = Odoc_model.Error.catch_warnings (fun () -> resolve_reference env m) diff --git a/src/xref2/ref_tools.mli b/src/xref2/ref_tools.mli index dd9b15b9fe..5b0924641f 100644 --- a/src/xref2/ref_tools.mli +++ b/src/xref2/ref_tools.mli @@ -3,6 +3,8 @@ open Odoc_model.Paths.Reference type module_lookup_result = Resolved.Module.t * Cpath.Resolved.module_ * Component.Module.t +type asset_lookup_result = Resolved.Asset.t + type 'a ref_result = ('a, Errors.Tools_error.reference_lookup_error) Result.result @@ -11,6 +13,11 @@ val resolve_module_reference : Module.t -> module_lookup_result ref_result Odoc_model.Error.with_warnings +val resolve_asset_reference : + Env.t -> + Asset.t -> + asset_lookup_result ref_result Odoc_model.Error.with_warnings + val resolve_reference : Env.t -> t -> diff --git a/test/pages/dune b/test/pages/dune index c72425b3db..23c38b0724 100644 --- a/test/pages/dune +++ b/test/pages/dune @@ -7,3 +7,8 @@ (enabled_if (>= %{ocaml_version} 4.04.1)) (deps %{bin:odoc} %{bin:odoc_print})) + +(cram + (applies_to medias) + (enabled_if + (>= %{ocaml_version} 4.07.0))) diff --git a/test/pages/medias.t/index.mld b/test/pages/medias.t/index.mld new file mode 100644 index 0000000000..6ee04f217f --- /dev/null +++ b/test/pages/medias.t/index.mld @@ -0,0 +1,43 @@ +{0 Package page} + +{1 Images} + +{2 References} + +Some image: + +- 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} + +{1 Audio} + +{2 References} + +{audio!Cri_du_chameau.ogg} + +{2 Links} + +{audio:https://upload.wikimedia.org/wikipedia/commons/f/f1/Cri_du_chameau.ogg} +{{audio:https://upload.wikimedia.org/wikipedia/commons/f/f1/Cri_du_chameau.ogg}The sound of a caml} + +{1 Video} + +{2 References} + +{video:flower.webm} +{{video:flower.webm}A video of a blossoming flower} + +{2 Links} + +{video:https://interactive-examples.mdn.mozilla.net/media/cc0-videos/flower.webm} + +{1 Errors} + +- This will be considered as a path to an asset:{image!module-x} diff --git a/test/pages/medias.t/run.t b/test/pages/medias.t/run.t new file mode 100644 index 0000000000..1e680632e3 --- /dev/null +++ b/test/pages/medias.t/run.t @@ -0,0 +1,81 @@ +We need to odoc-compile the package mld file, listing its children + + $ odoc compile index.mld --parent-id pkg1/doc/ --output-dir _odoc + + $ odoc compile-asset --parent-id pkg1/doc/ --output-dir _odoc --name caml.gif + $ odoc compile-asset --parent-id pkg1/doc/ --output-dir _odoc --name Cri_du_chameau.ogg + $ odoc compile-asset --parent-id pkg1/doc/ --output-dir _odoc --name flower.webm + +This will have produced a file called 'page-index.odoc'. + +Link (and generate the HTML): + $ odoc link -P pkg1:_odoc/pkg1/doc _odoc/pkg1/doc/page-index.odoc + File "index.mld", line 43, characters 48-64: + Warning: Failed to resolve reference ./module-x Path 'module-x' not found + File "index.mld", line 12, characters 28-83: + Warning: Failed to resolve reference ./camezfzeffl.gif Path 'camezfzeffl.gif' not found + File "index.mld", line 11, characters 31-53: + Warning: Failed to resolve reference ./caqzdqzdml.gif Path 'caqzdqzdml.gif' not found + $ odoc html-generate -o html --indent _odoc/pkg1/doc/page-index.odocl + $ odoc support-files -o html + +To test visually, indent: + $ cp -r html /tmp/ + $ firefox /tmp/html/index/index.html + +Testing the working references: + + $ cat html/pkg1/doc/index.html | grep img + + caml.gif + + With alt text and {b emphasis} + + reference + + Video +

Video

+ + +