diff --git a/CHANGES.md b/CHANGES.md index 9ab5191c07..5b127e8266 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -5,6 +5,7 @@ - Improve jump to implementation in rendered source code, and add a `count-occurrences` flag and command to count occurrences of every identifiers (@panglesd, #976) +- Add ability to reference assets (@panglesd, #1002) # 2.4.0 diff --git a/doc/ocamldoc_differences.mld b/doc/ocamldoc_differences.mld index 507ea754f6..ab26a19bac 100644 --- a/doc/ocamldoc_differences.mld +++ b/doc/ocamldoc_differences.mld @@ -30,9 +30,11 @@ 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. +- [odoc] support the inclusion of assets in the structured directory tree. - A few extra tags are supported: + [@returns] is a synonym for [@return] + [@raises] is a synonym for [@raise] @@ -56,6 +58,7 @@ Additionally we support extra annotations: - [instance-variable] refers to instance variables - [label] refers to labels introduced in anchors - [page] refers to [.mld] pages as outlined above +- [asset] refers assets as outlined above - [value] is recognised as [val] {3 Referencing items containing hyphens or dots} diff --git a/doc/odoc_for_authors.mld b/doc/odoc_for_authors.mld index 11d32bbbd2..2931e152d3 100644 --- a/doc/odoc_for_authors.mld +++ b/doc/odoc_for_authors.mld @@ -393,13 +393,14 @@ The prefixes supported are: - [instance-variable] - [section] (and the equivalent deprecated prefix [label]) - for referring to headings - [page] - for referring to [.mld] pages +- [asset] - for referring to assets In some cases the element being referenced might have a hyphen, a dot or a space in the name, e.g. if trying to refer to a page from a [.mld] file "1.2.3.mld". In this case, the element name should be quoted with double quote marks: {v -{!page-"1.2.3"} +{!page-"1.2.3"}, {!asset-"file.txt"} v} @@ -610,6 +611,33 @@ 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 2.4 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 is [{:link}], [{!ref}], +[{{:link}Replacement text}] and [{{:ref}Replacement text}], +where [] is either [image], [video] or [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 links 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/doc/parent_child_spec.mld b/doc/parent_child_spec.mld index ec76c03400..e4981940e1 100644 --- a/doc/parent_child_spec.mld +++ b/doc/parent_child_spec.mld @@ -175,9 +175,9 @@ installed and might be used by a different driver. In order for drivers to build consistent documentation for a package, the following convention should be followed. -- [.mld] pages are installed in a package's [share] directory, under the +- [.mld] pages and assets are installed in a package's [share] directory, under the [odoc-pages] sub-directory. -- A page is the parent of every installed pages. The driver can freely name this +- A page is the parent of every installed pages and assets. The driver can freely name this page, for example it can be named after the package. In what follows, we refer to this page as the [pkg] page. - If there is an installed [index.mld] file, the driver has to use it as @@ -185,7 +185,7 @@ following convention should be followed. - If there is no installed [index.mld] page, the driver has to generate some content for the [pkg] page. -This convention is followed by the +This convention (excluding assets) is followed by the {{:https://github.com/ocaml-doc/voodoo}driver for ocaml.org}, by the driver {{:https://erratique.ch/software/odig/doc/packaging.html}Odig} and by the build system {{:https://github.com/ocaml/dune}Dune}. diff --git a/src/document/comment.ml b/src/document/comment.ml index 5fc683423d..d04c2e5a6e 100644 --- a/src/document/comment.ml +++ b/src/document/comment.ml @@ -88,6 +88,7 @@ module Reference = struct | `InstanceVariable (p, f) -> render_unresolved (p :> t) ^ "." ^ InstanceVariableName.to_string f | `Label (p, f) -> render_unresolved (p :> t) ^ "." ^ LabelName.to_string f + | `Asset (p, f) -> render_unresolved (p :> t) ^ "." ^ AssetName.to_string f (* This is the entry point. *) let to_ir : ?text:Inline.t -> Reference.t -> Inline.t = @@ -107,9 +108,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 *) @@ -123,9 +124,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 @@ -170,7 +171,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 @@ -263,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); _ } ] -> @@ -308,7 +341,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 cc95eed9f8..23c3b80271 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) @@ -382,6 +380,9 @@ end = struct fun x -> match x.desc with | Inline x -> inline x + | Audio (_, x) -> inline x + | Video (_, x) -> inline x + | Image (_, x) -> inline x | Paragraph x -> inline x | List (_, x) -> List.exists block x | Table { data; align = _ } -> @@ -400,8 +401,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 f6df604d3b..28fd0333f5 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -39,14 +39,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 @@ -1868,8 +1868,7 @@ module Make (Syntax : SYNTAX) = struct let li ?(attr = []) name url = let link url desc = let content = [ Inline.{ attr = []; desc } ] and tooltip = None in - Inline.InternalLink - { InternalLink.target = Resolved url; content; tooltip } + Inline.Link { target = Internal (Resolved url); content; tooltip } in [ block ~attr @@ Block.Inline (inline @@ link url (Text name)) ] in diff --git a/src/document/types.ml b/src/document/types.ml index 34e9b502d9..959e004563 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 * Inline.t + | Video of Target.t * Inline.t + | Audio of Target.t * Inline.t and list_type = Ordered | Unordered end = 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 1322fd38de..dc77c4e517 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 @@ -206,6 +207,26 @@ let text_align = function let cell_kind = function `Header -> Html.th | `Data -> Html.td +(* Turns an inline into a string, for use as alternative text in + images *) +let rec alt_of_inline (i : Inline.t) = + let rec alt_of_source s = + List.map + (function + | Source.Elt i -> alt_of_inline i | Tag (_, t) -> alt_of_source t) + s + |> String.concat "" + in + let alt_of_one (o : Inline.one) = + match o.desc with + | Text t | Math t | Entity t -> t + | Linebreak -> "\n" + | Styled (_, i) | Link { content = i; _ } -> alt_of_inline i + | Source s -> alt_of_source s + | Raw_markup _ -> "" + in + List.map alt_of_one i |> String.concat "" + let rec block ~config ~resolve (l : Block.t) : flow Html.elt list = let as_flow x = (x : phrasing Html.elt list :> flow Html.elt list) in let one (t : Block.one) = @@ -243,6 +264,55 @@ 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, content) -> + let content = inline ~config ~resolve content in + let audio src = [ Html.audio ~src ~a:[ Html.a_controls () ] [] ] in + let block = + match target with + | External url -> audio url + | Internal (Resolved uri) -> + let url = Link.href ~config ~resolve uri in + audio url + | Internal Unresolved -> + let a = Html.a_class [ "xref-unresolved" ] :: [] in + [ Html.span ~a content ] + in + mk_block Html.div block + | Video (target, content) -> + let content = inline ~config ~resolve content in + let video src = [ Html.video ~src ~a:[ Html.a_controls () ] [] ] in + let block = + match target with + | External url -> video url + | Internal (Resolved uri) -> + let url = Link.href ~config ~resolve uri in + video url + | Internal Unresolved -> + let a = [ Html.a_class [ "xref-unresolved" ] ] in + [ Html.span ~a content ] + in + mk_block Html.div block + | Image (target, alt) -> + let image src = + let alt = alt_of_inline alt in + let img = + Html.a + ~a:[ Html.a_href src; Html.a_class [ "img-link" ] ] + [ Html.img ~src ~alt () ] + in + [ img ] + in + let block = + match target with + | External url -> image url + | Internal (Resolved uri) -> + let url = Link.href ~config ~resolve uri in + image url + | Internal Unresolved -> + let a = [ Html.a_class [ "xref-unresolved" ] ] in + [ Html.span ~a (inline ~config ~resolve alt) ] + in + mk_block Html.div block in Utils.list_concat_map l ~f:one 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 db5a6b112a..dc2d7fdcf0 100644 --- a/src/html_support_files/odoc.css +++ b/src/html_support_files/odoc.css @@ -385,7 +385,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 db5d7a3030..33d0416723 100644 --- a/src/latex/generator.ml +++ b/src/latex/generator.ml @@ -231,13 +231,13 @@ let source k (t : Source.t) = and tokens t = 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 } @@ -247,10 +247,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) ] @@ -292,6 +293,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) -> + inline ~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 ccb98f618e..761611aa98 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) -> + inline 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 f9659607c0..0178b57fa4 100644 --- a/src/model/comment.ml +++ b/src/model/comment.ml @@ -8,6 +8,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 = @@ -52,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 @@ -64,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 diff --git a/src/model/names.ml b/src/model/names.ml index 9ae4701b2c..ddcd350902 100644 --- a/src/model/names.ml +++ b/src/model/names.ml @@ -138,3 +138,4 @@ module LabelName = SimpleName module PageName = SimpleName module DefName = SimpleName module LocalName = SimpleName +module AssetName = SimpleName diff --git a/src/model/names.mli b/src/model/names.mli index 7854988977..c13d16e99d 100644 --- a/src/model/names.mli +++ b/src/model/names.mli @@ -101,3 +101,5 @@ module PageName : SimpleName module DefName : SimpleName module LocalName : SimpleName + +module AssetName : SimpleName diff --git a/src/model/paths.ml b/src/model/paths.ml index f2d814d698..13079dd417 100644 --- a/src/model/paths.ml +++ b/src/model/paths.ml @@ -1058,6 +1058,10 @@ module Reference = struct module Page = struct type t = Paths_types.Resolved_reference.page end + + module Asset = struct + type t = Paths_types.Resolved_reference.asset + end end type t = Paths_types.Reference.any @@ -1143,4 +1147,8 @@ module Reference = struct module Page = struct type t = Paths_types.Reference.page end + + module Asset = struct + type t = Paths_types.Reference.asset + end end diff --git a/src/model/paths.mli b/src/model/paths.mli index 2105b8b210..1e1021b6c7 100644 --- a/src/model/paths.mli +++ b/src/model/paths.mli @@ -546,6 +546,10 @@ module rec Reference : sig type t = Paths_types.Resolved_reference.page end + module Asset : sig + type t = Paths_types.Resolved_reference.asset + end + type t = Paths_types.Resolved_reference.any val identifier : t -> Identifier.t @@ -631,6 +635,10 @@ module rec Reference : sig type t = Paths_types.Reference.page end + module Asset : sig + type t = Paths_types.Reference.asset + end + type t = Paths_types.Reference.any type tag_any = Paths_types.Reference.tag_any diff --git a/src/model/paths_types.ml b/src/model/paths_types.ml index bf306203d4..3ba482cb4f 100644 --- a/src/model/paths_types.ml +++ b/src/model/paths_types.ml @@ -310,6 +310,8 @@ module Identifier = struct type reference_label = label type reference_page = page + + type reference_asset = asset_file end module rec Path : sig @@ -548,6 +550,7 @@ module rec Reference : sig | `TInstanceVariable | `TLabel | `TPage + | `TAsset | `TChildPage | `TChildModule | `TUnknown ] @@ -742,8 +745,16 @@ module rec Reference : sig | `ClassType of signature * ClassTypeName.t | `Method of class_signature * MethodName.t | `InstanceVariable of class_signature * InstanceVariableName.t - | `Label of label_parent * LabelName.t ] + | `Label of label_parent * LabelName.t + | `Asset of page * AssetName.t ] (** @canonical Odoc_model.Paths.Reference.t *) + + type asset = + [ `Resolved of Resolved_reference.asset + | `Root of string * [ `TAsset ] + | `Dot of label_parent * string + | `Asset of page * AssetName.t ] + (** @canonical Odoc_model.Paths.Reference.Asset.t *) end = Reference @@ -908,5 +919,8 @@ and Resolved_reference : sig | `InstanceVariable of class_signature * InstanceVariableName.t | `Label of label_parent * LabelName.t ] (** @canonical Odoc_model.Paths.Reference.Resolved.t *) + + type asset = [ `Identifier of Identifier.reference_asset ] + (** @canonical Odoc_model.Paths.Reference.Resolved.Asset.t *) end = Resolved_reference diff --git a/src/model/reference.ml b/src/model/reference.ml index 1f9b98c5a6..ad0dbba4c3 100644 --- a/src/model/reference.ml +++ b/src/model/reference.ml @@ -76,6 +76,7 @@ let match_extra_odoc_reference_kind (_location as loc) s : Some `TLabel | Some "module-type" -> Some `TModuleType | Some "page" -> Some `TPage + | Some "asset" -> Some `TAsset | Some "value" -> d loc "value" "val"; Some `TValue @@ -298,6 +299,26 @@ let parse whole_reference_location s : |> Error.raise_exception) in + let page (kind, identifier, location) tokens : Page.t = + let kind = match_reference_kind location kind in + match tokens with + | [] -> ( + match kind with + | (`TUnknown | `TPage) as kind -> `Root (identifier, kind) + | _ -> expected [ "page" ] location |> Error.raise_exception) + | next_token :: tokens -> ( + match kind with + | `TUnknown -> `Dot (label_parent next_token tokens, identifier) + | _ -> + let suggestion = + Printf.sprintf "'page-%s' should be first." identifier + in + not_allowed ~what:"Page label" + ~in_what:"the last component of a reference path" ~suggestion + location + |> Error.raise_exception) + in + let start_from_last_component (kind, identifier, location) old_kind tokens = let new_kind = match_reference_kind location kind in let kind = @@ -363,6 +384,8 @@ let parse whole_reference_location s : | `TLabel -> `Label (label_parent next_token tokens, LabelName.make_std identifier) + | `TAsset -> + `Asset (page next_token tokens, AssetName.make_std identifier) | `TChildPage | `TChildModule -> let suggestion = Printf.sprintf "'child-%s' should be first." identifier diff --git a/src/model/semantics.ml b/src/model/semantics.ml index f9c296493d..0acdc79308 100644 --- a/src/model/semantics.ml +++ b/src/model/semantics.ml @@ -4,6 +4,11 @@ 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 + * Ast.inline_element Ast.with_location list + * Ast.media | Ast.nestable_block_element ] (** {!Ast.block_element} without internal tags. *) @@ -106,7 +111,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 @@ -271,6 +276,47 @@ 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; + } -> ( + let fallback 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 + in + match Error.raise_warnings (Reference.parse href_location href) with + | Result.Ok target -> ( + let text = inline_elements status content in + let asset_ref_of_ref : + Paths.Reference.t -> (Paths.Reference.Asset.t, _) Result.result = + function + | `Asset _ as a -> Result.Ok a + | `Root (_, `TAsset) as a -> Ok a + | `Root (s, `TUnknown) -> Ok (`Root (s, `TAsset)) + | `Dot (p, s) -> Ok (`Dot (p, s)) + | _ -> + Error + (not_allowed ~suggestion:"Use a reference to an asset" + href_location ~what:"Non-asset reference" + ~in_what:"media target") + in + match asset_ref_of_ref target with + | Error error -> fallback error + | Ok target -> + `Media (`Reference target, m, text) |> Location.at location) + | Result.Error error -> fallback error) and nestable_block_elements status elements = List.map (nestable_block_element status) elements @@ -355,12 +401,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)) @@ -510,7 +551,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..a339caf212 100644 --- a/src/model_desc/comment_desc.ml +++ b/src/model_desc/comment_desc.ml @@ -31,7 +31,12 @@ 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 + * general_link_content + | `MediaLink of string * media * general_link_content ] and general_tag = [ `Author of string @@ -50,6 +55,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 +115,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 +153,14 @@ 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, link_content) ) + | `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/model_desc/paths_desc.ml b/src/model_desc/paths_desc.ml index 03b0d816ca..10adb778c4 100644 --- a/src/model_desc/paths_desc.ml +++ b/src/model_desc/paths_desc.ml @@ -34,6 +34,8 @@ module Names = struct let labelname = To_string LabelName.to_string + let assetname = To_string AssetName.to_string + let pagename = To_string PageName.to_string let parametername = To_string ModuleName.to_string @@ -200,6 +202,7 @@ module General_paths = struct | `TType -> C0 "`TType" | `TUnknown -> C0 "`TUnknown" | `TValue -> C0 "`TValue" + | `TAsset -> C0 "`TAsset" | `TChildPage -> C0 "`TChildPage" | `TChildModule -> C0 "`TChildModule") @@ -329,7 +332,9 @@ module General_paths = struct ((x1 :> r), x2), Pair (reference, Names.instancevariablename) ) | `Label (x1, x2) -> - C ("`Label", ((x1 :> r), x2), Pair (reference, Names.labelname))) + C ("`Label", ((x1 :> r), x2), Pair (reference, Names.labelname)) + | `Asset (x1, x2) -> + C ("`Asset", ((x1 :> r), x2), Pair (reference, Names.assetname))) and resolved_reference : rr t = Variant diff --git a/src/parser/ast.ml b/src/parser/ast.ml index 85c38931f1..2053c7113b 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,13 @@ 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.5.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 0cde0b4343..54d299848c 100644 --- a/src/parser/lexer.mll +++ b/src/parser/lexer.mll @@ -185,8 +185,23 @@ let reference_token start target = match start with | "{!" -> `Simple_reference target | "{{!" -> `Begin_reference_with_replacement_text target - | "{:" -> `Simple_link target - | "{{:" -> `Begin_link_with_replacement_text target + | "{:" -> `Simple_link (target) + | "{{:" -> `Begin_link_with_replacement_text (target) + + | "{image!" -> `Simple_media (`Reference target, `Image) + | "{{image!" -> `Begin_media_with_replacement_text (`Reference target, `Image) + | "{image:" -> `Simple_media (`Link target, `Image) + | "{{image:" -> `Begin_media_with_replacement_text (`Link target, `Image) + + | "{audio!" -> `Simple_media (`Reference target, `Audio) + | "{{audio!" -> `Begin_media_with_replacement_text (`Reference target, `Audio) + | "{audio:" -> `Simple_media (`Link target, `Audio) + | "{{audio:" -> `Begin_media_with_replacement_text (`Link target, `Audio) + + | "{video!" -> `Simple_media (`Reference target, `Video) + | "{{video!" -> `Begin_media_with_replacement_text (`Reference target, `Video) + | "{video:" -> `Simple_media (`Link target, `Video) + | "{{video:" -> `Begin_media_with_replacement_text (`Link target, `Video) | _ -> assert false let trim_leading_space_or_accept_whitespace input start_offset text = @@ -264,8 +279,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,7 +420,7 @@ 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 = diff --git a/src/parser/syntax.ml b/src/parser/syntax.ml index 293682ded6..365dfae7d4 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,52 @@ let rec block_element_list : |> Loc.at location in consume_block_elements ~parsed_a_tag `At_start_of_line (paragraph :: acc) + | { + location; + value = `Begin_media_with_replacement_text (href, media) as token; + } as next_token -> + warn_if_after_tags next_token; + + junk input; + + let content, brace_location = + delimited_inline_element_list ~parent_markup:token + ~parent_markup_location:location ~requires_leading_whitespace:false + input + in + let r_location = + Loc.nudge_start + (String.length @@ Token.s_of_media `Replaced media) + location + in + let href = href |> Loc.at r_location in + + if content = [] then + Parse_error.should_not_be_empty ~what:(Token.describe token) location + |> add_warning input; + + let location = Loc.span [ location; brace_location ] in + let block = `Media (`Simple, href, content, media) in + let block = accepted_in_all_contexts context block in + let block = Loc.at location block in + 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 `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 = @@ -1187,7 +1234,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 _ | `Begin_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 caed0e7f6e..9b4efe2f6e 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,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 ] diff --git a/src/parser/token.ml b/src/parser/token.ml index 83181fe455..f874d61706 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 + | `Begin_media_with_replacement_text of media_href * media ] + +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:...}" + | `Begin_media_with_replacement_text (`Reference _, `Image) -> + "{{image!...} ...}" + | `Begin_media_with_replacement_text (`Reference _, `Audio) -> + "{{audio!...} ...}" + | `Begin_media_with_replacement_text (`Reference _, `Video) -> + "{{video!...} ...}" + | `Begin_media_with_replacement_text (`Link _, `Image) -> "{{image:...} ...}" + | `Begin_media_with_replacement_text (`Link _, `Audio) -> "{{audio:...} ...}" + | `Begin_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)" + | `Begin_media_with_replacement_text (`Reference _, `Image) -> + "'{{image!...} ...}' (image-reference)" + | `Begin_media_with_replacement_text (`Reference _, `Audio) -> + "'{{audio!...} ...}' (audio-reference)" + | `Begin_media_with_replacement_text (`Reference _, `Video) -> + "'{{video!...} ...}' (video-reference)" + | `Begin_media_with_replacement_text (`Link _, `Image) -> + "'{{image:...} ...}' (image-link)" + | `Begin_media_with_replacement_text (`Link _, `Audio) -> + "'{{audio:...} ...}' (audio-link)" + | `Begin_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 0fd9e1c8f7..31ea5c3740 100644 --- a/src/search/entry.ml +++ b/src/search/entry.ml @@ -145,6 +145,8 @@ 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 (_, _, content) -> + entries_of_doc id { d with value = `Paragraph content } let entries_of_item id (x : Odoc_model.Fold.item) = match x with diff --git a/src/search/text.ml b/src/search/text.ml index 228157e40b..39fa8f4345 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) -> inlines 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 6406a9c76a..dc90537b44 100644 --- a/src/xref2/component.ml +++ b/src/xref2/component.ml @@ -471,7 +471,11 @@ 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 + * Odoc_model.Comment.paragraph ] type docs = block_element Odoc_model.Comment.with_location list @@ -527,6 +531,8 @@ module Element = struct (* No component for pages yet *) type page = [ `Page of Identifier.Page.t * Odoc_model.Lang.Page.t ] + type asset = [ `Asset of Identifier.AssetFile.t ] + type label_parent = [ signature | type_ | page ] type fragment_type_parent = [ signature | datatype ] @@ -543,7 +549,8 @@ module Element = struct | extension | extension_decl | field - | page ] + | page + | asset ] let identifier : [< any ] -> Odoc_model.Paths.Identifier.t = let open Odoc_model.Paths.Identifier in @@ -561,6 +568,7 @@ module Element = struct | `Extension (id, _, _) -> (id :> t) | `ExtensionDecl (id, _) -> (id :> t) | `Page (id, _) -> (id :> t) + | `Asset id -> (id :> t) end module Fmt = struct @@ -1499,6 +1507,11 @@ module Fmt = struct (parent :> t) (LabelName.to_string name) + and model_resolved_asset_reference ppf + (`Identifier id : Odoc_model.Paths.Reference.Resolved.Asset.t) = + Format.fprintf ppf "%a" model_identifier + (id :> Odoc_model.Paths.Identifier.t) + and model_reference ppf (r : Odoc_model.Paths.Reference.t) = let open Odoc_model.Paths.Reference in match r with @@ -1562,6 +1575,23 @@ module Fmt = struct Format.fprintf ppf "%a.%s" model_reference (parent :> t) (LabelName.to_string name) + | `Asset (parent, name) -> + Format.fprintf ppf "%a.%s" model_reference + (parent :> t) + (AssetName.to_string name) + + and model_asset_reference ppf (r : Odoc_model.Paths.Reference.Asset.t) = + let open Odoc_model.Paths.Reference in + match r with + | `Resolved r' -> + Format.fprintf ppf "r(%a)" model_resolved_asset_reference r' + | `Root (name, _) -> Format.fprintf ppf "unresolvedroot(%s)" name + | `Dot (parent, str) -> + Format.fprintf ppf "%a.%s" model_reference (parent :> t) str + | `Asset (parent, name) -> + Format.fprintf ppf "%a.%s" model_reference + (parent :> t) + (AssetName.to_string name) end module LocalIdents = struct @@ -2507,7 +2537,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 beb42738c0..ef20e8af35 100644 --- a/src/xref2/component.mli +++ b/src/xref2/component.mli @@ -437,7 +437,11 @@ 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 + * Odoc_model.Comment.paragraph ] type docs = block_element Odoc_model.Comment.with_location list @@ -491,6 +495,8 @@ module Element : sig (* No component for pages yet *) type page = [ `Page of Identifier.Page.t * Odoc_model.Lang.Page.t ] + type asset = [ `Asset of Identifier.AssetFile.t ] + type label_parent = [ signature | type_ | page ] type fragment_type_parent = [ signature | datatype ] @@ -507,7 +513,8 @@ module Element : sig | extension | extension_decl | field - | page ] + | page + | asset ] val identifier : [< any ] -> Identifier.t end @@ -636,7 +643,13 @@ module Fmt : sig val model_resolved_reference : Format.formatter -> Odoc_model.Paths.Reference.Resolved.t -> unit + val model_resolved_asset_reference : + Format.formatter -> Odoc_model.Paths.Reference.Resolved.Asset.t -> unit + val model_reference : Format.formatter -> Odoc_model.Paths.Reference.t -> unit + + val model_asset_reference : + Format.formatter -> Odoc_model.Paths.Reference.Asset.t -> unit end module Of_Lang : sig diff --git a/src/xref2/env.ml b/src/xref2/env.ml index 73de06de0b..faa38cc9ae 100644 --- a/src/xref2/env.ml +++ b/src/xref2/env.ml @@ -84,6 +84,7 @@ type kind = | Kind_Exception | Kind_Extension | Kind_Field + | Kind_asset module ElementsByName : sig type t @@ -356,6 +357,10 @@ let add_extension_constructor identifier add_to_elts Kind_Extension identifier (`Extension (identifier, ec, te)) env |> add_cdocs identifier ec.doc +let add_asset identifier env = + if env.linking then add_to_elts Kind_asset identifier (`Asset identifier) env + else env + let module_of_unit : Lang.Compilation_unit.t -> Component.Module.t = fun unit -> let id = (unit.id :> Paths.Identifier.Module.t) in @@ -595,6 +600,9 @@ let s_fragment_type_parent : Component.Element.fragment_type_parent scope = | #Component.Element.fragment_type_parent as r -> Some r | _ -> None) +let s_asset : Component.Element.asset scope = + make_scope (function #Component.Element.asset as r -> Some r | _ -> None) + let len = ref 0 let n = ref 0 @@ -804,6 +812,29 @@ let open_units resolver env = | _ -> env) env resolver.open_units +let rec collect_assets env (page : Lang.Page.t) = + let env = + match page.name with + | { iv = `Page (Some parent, _); _ } + | { iv = `LeafPage (Some parent, _); _ } -> ( + let parent_name = match parent.iv with `Page (_, name) -> name in + match lookup_page (PageName.to_string parent_name) env with + | None -> env + | Some parent_page -> collect_assets env parent_page) + | _ -> env + in + let env = + List.fold_left + (fun env new_asset -> + let id = Identifier.Mk.asset_file (page.name, new_asset) in + add_asset id env) + env + (Utils.filter_map [] + (function Lang.Page.Asset_child c -> Some c | _ -> None) + page.children) + in + env + let env_of_unit t ~linking resolver = let open Lang.Compilation_unit in let initial_env = @@ -812,13 +843,25 @@ let env_of_unit t ~linking resolver = let env = { empty with linking } in env |> add_module (t.id :> Identifier.Path.Module.t) dm m.doc in - set_resolver initial_env resolver |> open_units resolver + let initial_env = set_resolver initial_env resolver |> open_units resolver in + let initial_env = + match t.id.iv with + | `Root (None, _) -> initial_env + | `Root (Some parent, _) -> ( + let parent_name = match parent.iv with `Page (_, name) -> name in + match lookup_page (PageName.to_string parent_name) initial_env with + | None -> initial_env + | Some parent_page -> collect_assets initial_env parent_page) + in + initial_env let open_page page env = add_docs page.Lang.Page.content env let env_of_page page resolver = let initial_env = open_page page empty in - set_resolver initial_env resolver |> open_units resolver + let initial_env = set_resolver initial_env resolver |> open_units resolver in + let initial_env = collect_assets initial_env page in + initial_env let env_for_reference resolver = set_resolver empty resolver |> open_units resolver diff --git a/src/xref2/env.mli b/src/xref2/env.mli index 8be6e82135..870e775b66 100644 --- a/src/xref2/env.mli +++ b/src/xref2/env.mli @@ -146,6 +146,8 @@ val s_label_parent : Component.Element.label_parent scope val s_fragment_type_parent : Component.Element.fragment_type_parent scope +val s_asset : Component.Element.asset scope + (* val open_component_signature : Paths_types.Identifier.signature -> Component.Signature.t -> t -> t *) diff --git a/src/xref2/errors.ml b/src/xref2/errors.ml index f5044308be..77a03d0efe 100644 --- a/src/xref2/errors.ml +++ b/src/xref2/errors.ml @@ -9,7 +9,17 @@ module Tools_error = struct [ `Module of Cpath.module_ ] (* Failed to resolve a module path when applying a fragment item *) ] - type reference_kind = [ `S | `T | `C | `CT | `Page | `Cons | `Field | `Label ] + type reference_kind = + [ `S + | `T + | `C + | `CT + | `Page + | `Cons + | `Field + | `Label + | `Asset + | `Asset_or_label ] type expansion_of_module_error = [ `OpaqueModule (* The module does not have an expansion *) @@ -127,6 +137,8 @@ module Tools_error = struct | `Cons -> "constructor" | `Field -> "field" | `Label -> "label" + | `Asset -> "asset" + | `Asset_or_label -> "asset or label" in Format.pp_print_string fmt k @@ -312,7 +324,8 @@ type what = | `Module_type_u_expr of Component.ModuleType.U.expr | `Child_module of string | `Child_page of string - | `Reference of Reference.t ] + | `Reference of Reference.t + | `Asset_reference of Reference.Asset.t ] let report ~(what : what) ?tools_error action = let action = @@ -362,6 +375,7 @@ let report ~(what : what) ?tools_error action = | `Child_module rf -> r "child module" Astring.String.pp rf | `Child_page rf -> r "child page" Astring.String.pp rf | `Reference ref -> r "reference" model_reference ref + | `Asset_reference ref -> r "asset reference" model_asset_reference ref in match kind_of_error ~what tools_error with | Some (`Root name) -> Lookup_failures.report_root ~name diff --git a/src/xref2/lang_of.ml b/src/xref2/lang_of.ml index 91f07c62f1..e5d56aabaa 100644 --- a/src/xref2/lang_of.ml +++ b/src/xref2/lang_of.ml @@ -1069,7 +1069,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 fa9c45a287..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) = diff --git a/src/xref2/ref_tools.ml b/src/xref2/ref_tools.ml index 850f82982f..e5fea6fedd 100644 --- a/src/xref2/ref_tools.ml +++ b/src/xref2/ref_tools.ml @@ -74,6 +74,7 @@ let ref_kind_of_element = function | `ExtensionDecl _ -> "extension-decl" | `Field _ -> "field" | `Page _ -> "page" + | `Asset _ -> "asset" let ref_kind_of_find = function | `FModule _ | `FModule_subst _ -> "module" @@ -354,7 +355,7 @@ module L = struct when name = LabelName.to_string name' -> Ok (`Identifier label) | _ -> find tl) - | [] -> Error (`Find_by_name (`Page, name)) + | [] -> Error (`Find_by_name (`Label, name)) in find p.Odoc_model.Lang.Page.content @@ -569,9 +570,48 @@ module Page = struct | Some p -> Ok (`Identifier p.Odoc_model.Lang.Page.name, p) | None -> Error (`Lookup_by_name (`Page, name)) + let in_env_from_id env (id : Identifier.Page.t) = + match id with + | { iv = `Page (_, parent_name) | `LeafPage (_, parent_name); _ } -> + in_env env (PageName.to_string parent_name) + let of_element _env (`Page (id, page)) : t = (`Identifier id, page) end +module A = struct + (** Assets *) + + let in_env env name = + env_lookup_by_name ~kind:`Asset Env.s_asset name env >>= fun (`Asset id) -> + Ok (`Identifier id) + + let rec in_page env (page : Odoc_model.Lang.Page.t) (asset_name : string) : + (Reference.Resolved.Asset.t, _) result = + let has_asset children asset = + List.exists + (function + | Odoc_model.Lang.Page.Asset_child a -> a = asset | _ -> false) + children + in + let parent_id + { + Odoc_model.Lang.Page.name = + { iv = `Page (parent, _) | `LeafPage (parent, _); _ }; + _; + } = + parent + in + if has_asset page.children asset_name then + Ok (`Identifier (Identifier.Mk.asset_file (page.name, asset_name))) + else + let parent = (parent_id page :> Identifier.Page.t option) in + match parent with + | Some parent -> + Page.in_env_from_id env parent >>= fun (_, p) -> + in_page env p asset_name + | None -> Error (`Lookup_by_name (`Asset, asset_name)) +end + module LP = struct (** Label parent *) @@ -784,7 +824,12 @@ let resolve_reference_dot_sg env ~parent_path ~parent_ref ~parent_sg name = Error (`Find_by_name (`Any, name)) let resolve_reference_dot_page env page name = - L.in_page env page name >>= resolved1 + match (L.in_page env page name, page) with + | Ok e, _ -> resolved1 e + | Error _, `P (_, p) -> ( + match A.in_page env p name with + | Ok e -> resolved1 e + | Error _ -> Error (`Find_by_name (`Asset_or_label, name))) let resolve_reference_dot_type env ~parent_ref t name = find Find.any_in_type t name >>= function @@ -806,10 +851,30 @@ let resolve_reference_dot env parent name = | (`C _ | `CT _) as p -> resolve_reference_dot_class env p name | `P _ as page -> resolve_reference_dot_page env page name +let resolve_page_reference env (r : Reference.Page.t) = + match r with + | `Resolved _ -> failwith "unimplemented" + | `Dot (_, name) | `Root (name, _) -> Page.in_env env name + +let resolve_asset_reference env (m : Reference.Asset.t) = + match m with + | `Resolved r -> Ok r + | `Root (name, _) -> A.in_env env name + | `Dot (parent, name) -> + let x = + resolve_label_parent_reference env parent >>= function + | (`S _ | `T _ | `C _ | `CT _) as c -> wrong_kind_error [ `Page ] c + | `P _ as page -> Ok page + in + x >>= fun (`P (_, p)) -> A.in_page env p name + | `Asset (parent_page, name) -> + resolve_page_reference env parent_page >>= fun (_, p) -> + A.in_page env p (AssetName.to_string name) + (** Warnings may be generated with [Error.implicit_warning] *) let resolve_reference = let resolved = resolved3 in - fun env r -> + fun env (r : t) -> match r with | `Root (name, `TUnknown) -> ( let identifier id = Ok (`Identifier (id :> Identifier.t)) in @@ -826,7 +891,8 @@ let resolve_reference = | `Extension (id, _, _) -> identifier id | `ExtensionDecl (id, _) -> identifier id | `Field (id, _) -> identifier id - | `Page (id, _) -> identifier id) + | `Page (id, _) -> identifier id + | `Asset id -> identifier id) | `Resolved r -> Ok r | `Root (name, (`TModule | `TChildModule)) -> M.in_env env name >>= resolved | `Module (parent, name) -> @@ -885,6 +951,8 @@ let resolve_reference = resolve_class_signature_reference env parent >>= fun p -> MM.in_class_signature env p name >>= resolved1 | `Root (name, `TInstanceVariable) -> MV.in_env env name >>= resolved1 + | (`Asset _ | `Root (_, `TAsset)) as t -> + resolve_asset_reference env t >>= resolved1 | `InstanceVariable (parent, name) -> resolve_class_signature_reference env parent >>= fun p -> MV.in_class_signature env p name >>= resolved1 @@ -892,5 +960,10 @@ let resolve_reference = let resolve_module_reference env m = Odoc_model.Error.catch_warnings (fun () -> resolve_module_reference env m) -let resolve_reference env m = +let resolve_reference : + Env.t -> t -> Resolved.t ref_result Odoc_model.Error.with_warnings = + fun env m -> Odoc_model.Error.catch_warnings (fun () -> resolve_reference env m) + +let resolve_asset_reference env m = + Odoc_model.Error.catch_warnings (fun () -> resolve_asset_reference env m) diff --git a/src/xref2/ref_tools.mli b/src/xref2/ref_tools.mli index c6608379e1..ba2a0eb275 100644 --- a/src/xref2/ref_tools.mli +++ b/src/xref2/ref_tools.mli @@ -13,3 +13,6 @@ val resolve_module_reference : val resolve_reference : Env.t -> t -> Resolved.t ref_result Odoc_model.Error.with_warnings + +val resolve_asset_reference : + Env.t -> Asset.t -> Resolved.Asset.t ref_result Odoc_model.Error.with_warnings diff --git a/test/pages/medias.t/Cri_du_chameau.ogg b/test/pages/medias.t/Cri_du_chameau.ogg new file mode 100644 index 0000000000..f506cf736d Binary files /dev/null and b/test/pages/medias.t/Cri_du_chameau.ogg differ diff --git a/test/pages/medias.t/caml.gif b/test/pages/medias.t/caml.gif new file mode 100644 index 0000000000..69ab3901db Binary files /dev/null and b/test/pages/medias.t/caml.gif differ diff --git a/test/pages/medias.t/index.mld b/test/pages/medias.t/index.mld new file mode 100644 index 0000000000..1a7bbceb36 --- /dev/null +++ b/test/pages/medias.t/index.mld @@ -0,0 +1,33 @@ +{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 Links} + +{audio:https://upload.wikimedia.org/wikipedia/commons/f/f1/Cri_du_chameau.ogg} + +{1 Video} + +{2 Links} + +{video:https://interactive-examples.mdn.mozilla.net/media/cc0-videos/flower.webm} + +{1 Errors} + +- Wrong qualification:{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..49e7b77cd2 --- /dev/null +++ b/test/pages/medias.t/run.t @@ -0,0 +1,72 @@ +We need to odoc-compile the package mld file, listing its children + + $ odoc compile index.mld --child asset-caml.gif + File "index.mld", line 33, characters 30-38: + Warning: Non-asset reference is not allowed in media target. + Suggestion: Use a reference to an asset + +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 12, characters 28-85: + Warning: Failed to resolve reference unresolvedroot(camezfzeffl.gif) Couldn't find asset "camezfzeffl.gif" + 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 + +Testing the working references: + + $ cat html/index/index.html | grep img + + caml.gif + + With alt text and emphasis + + reference + + Video +

Video

+