From dc3aeb81800c8cbf762e7d4e54203af0faec4269 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Wed, 31 Jul 2024 17:41:36 +0200 Subject: [PATCH 01/17] Add support for medias (images, audio and video) --- src/document/comment.ml | 53 ++- src/document/doctree.ml | 10 +- src/document/generator.ml | 8 +- src/document/sidebar.ml | 5 +- src/document/types.ml | 23 +- src/document/utils.ml | 3 +- src/html/generator.ml | 86 ++++- src/html/html_source.ml | 2 + src/html_support_files/odoc.css | 2 +- src/latex/generator.ml | 16 +- src/manpage/generator.ml | 10 +- src/model/comment.ml | 8 +- src/model/paths.ml | 4 + src/model/paths.mli | 4 + src/model/paths_types.ml | 3 +- src/model/reference.ml | 647 +++++++++++++++----------------- src/model/reference.mli | 5 + src/model/semantics.ml | 61 ++- src/model_desc/comment_desc.ml | 30 +- src/parser/ast.ml | 11 +- src/parser/lexer.mll | 28 +- src/parser/syntax.ml | 52 ++- src/parser/test/test.ml | 17 + src/parser/token.ml | 50 +++ src/search/entry.ml | 1 + src/search/text.ml | 4 +- src/xref2/component.ml | 8 +- src/xref2/component.mli | 6 +- src/xref2/lang_of.ml | 2 +- src/xref2/link.ml | 9 + src/xref2/ref_tools.ml | 8 + src/xref2/ref_tools.mli | 7 + test/model/semantics/test.ml | 4 +- test/pages/medias.t/index.mld | 33 ++ test/pages/medias.t/run.t | 65 ++++ 35 files changed, 873 insertions(+), 412 deletions(-) create mode 100644 test/pages/medias.t/index.mld create mode 100644 test/pages/medias.t/run.t diff --git a/src/document/comment.ml b/src/document/comment.ml index 397156747b..1b41a40e5b 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,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); _ } ] -> @@ -322,7 +354,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..54dad7ad1d 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 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..4c40c8f1f6 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 a0e332bea9..da6efa598d 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 Odoc_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 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..a4aa45c58f 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) -> + 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 bee3f87751..d69f7ad505 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 1cbb83b299..83c0a0580e 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 * paragraph ] + 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..1daae413cb 100644 --- a/src/model/paths.ml +++ b/src/model/paths.ml @@ -1162,6 +1162,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..ed9af40981 100644 --- a/src/model/paths.mli +++ b/src/model/paths.mli @@ -637,6 +637,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..9692691d84 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 + (* 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,12 @@ 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 = + (tokens, Some (Path_prefix (String.sub s 0 (started_at + 1)))) 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 +221,324 @@ 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 p = + let segs = String.split_on_char '/' p in + match segs with + | "." :: segs -> (`TRelativePath, segs) + | "" :: "" :: segs -> (`TCurrentPackage, segs) + | "" :: segs -> (`TAbsolutePath, segs) + | segs -> (`TRelativePath, segs) + +let parse_path_prefix (Path_prefix p) identifier = parse_path (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) + | _ -> + 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) + | _ -> + 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) + | `TModule -> `Module_path (parse_path_prefix path_prefix identifier) + | `TPage -> `Page_path (parse_path_prefix path_prefix identifier) + | _ -> + 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) + | `TModule -> `Module_path (parse_path_prefix path_prefix identifier) + | `TPage -> `Page_path (parse_path_prefix path_prefix identifier) + | `TAsset -> `Asset_path (parse_path_prefix path_prefix identifier) + | _ -> + 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 - 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 + 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 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 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..71d72bf23b 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..5bbdc17a0b 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. *) @@ -105,7 +110,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 +275,49 @@ 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_asset (* 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_path _ 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 @@ -354,12 +402,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 +552,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/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 b9352cc968..36a6d3a1de 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 1b6cb98140..aa6864db8e 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 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..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 c72c5b94a1..6f7980f4d3 100644 --- a/src/xref2/component.ml +++ b/src/xref2/component.ml @@ -452,7 +452,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 @@ -2699,7 +2703,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..8eca78a9c6 100644 --- a/src/xref2/component.mli +++ b/src/xref2/component.mli @@ -429,7 +429,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 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..ae6908253b 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..a700579c21 100644 --- a/src/xref2/ref_tools.ml +++ b/src/xref2/ref_tools.ml @@ -833,6 +833,11 @@ 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 -> failwith "What's going on!?" + | `Asset_path p -> Path.asset_in_env env p + let resolved_type_lookup = function | `T (r, _) -> resolved1 r | `C (r, _) -> resolved1 r @@ -1001,5 +1006,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..bb8c81d128 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 * Odoc_model.Lang.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/model/semantics/test.ml b/test/model/semantics/test.ml index b3dcd83878..aaa2a2e00a 100644 --- a/test/model/semantics/test.ml +++ b/test/model/semantics/test.ml @@ -2858,12 +2858,12 @@ let%expect_test _ = let err_relative_empty_component = test "{!foo//bar}"; [%expect - {| {"value":[{"`Paragraph":[{"`Code_span":"foo//bar"}]}],"warnings":["File \"f.ml\", line 1, characters 6-6:\nIdentifier in path reference should not be empty."]} |}] + {| {"value":[{"`Paragraph":[{"`Reference":[{"`Any_path":["`TRelativePath",["foo","","bar"]]},[]]}]}],"warnings":[]} |}] let err_current_package_empty_component = test "{!///bar}"; [%expect - {| {"value":[{"`Paragraph":[{"`Code_span":"///bar"}]}],"warnings":["File \"f.ml\", line 1, characters 4-4:\nIdentifier in path reference should not be empty."]} |}] + {| {"value":[{"`Paragraph":[{"`Reference":[{"`Any_path":["`TCurrentPackage",["","bar"]]},[]]}]}],"warnings":[]} |}] let err_last_empty_component = test "{!foo/}"; diff --git a/test/pages/medias.t/index.mld b/test/pages/medias.t/index.mld new file mode 100644 index 0000000000..fe8f47d59b --- /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} + +- 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..711b90e2d6 --- /dev/null +++ b/test/pages/medias.t/run.t @@ -0,0 +1,65 @@ +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 + +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 33, 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/index/index.html | grep img + cat: html/index/index.html: No such file or directory + [1] + + $ cat html/index/index.html | grep video + cat: html/index/index.html: No such file or directory + [1] + + $ cat html/index/index.html | grep audio + cat: html/index/index.html: No such file or directory + [1] + +Testing the unresolved references: + + $ cat html/index/index.html | grep xref-unresolved + cat: html/index/index.html: No such file or directory + [1] + +Testing latex and manpages + + $ odoc latex-generate -o latex page-index.odocl + odoc: FILE.odocl argument: no 'page-index.odocl' file or directory + Usage: odoc latex-generate [OPTION]… FILE.odocl + Try 'odoc latex-generate --help' or 'odoc --help' for more information. + [2] + $ cat latex/index.tex | grep ocamlinlinecode + cat: latex/index.tex: No such file or directory + [1] + + $ odoc man-generate -o man page-index.odocl + odoc: FILE.odocl argument: no 'page-index.odocl' file or directory + Usage: odoc man-generate [OPTION]… FILE.odocl + Try 'odoc man-generate --help' or 'odoc --help' for more information. + [2] + $ cat man/index.3o | grep gif + cat: man/index.3o: No such file or directory + [1] + $ cat man/index.3o | grep "With alt text" + cat: man/index.3o: No such file or directory + [1] From e0f5ad5e93847df112e1e26b41646949151e2ee7 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Thu, 1 Aug 2024 14:07:05 +0200 Subject: [PATCH 02/17] Reintroduce emptyness check in path components of references --- src/model/reference.ml | 74 ++++++++++++++++++++++++++---------- src/model/reference.mli | 2 +- src/model/semantics.ml | 22 +---------- test/model/semantics/test.ml | 4 +- 4 files changed, 59 insertions(+), 43 deletions(-) diff --git a/src/model/reference.ml b/src/model/reference.ml index 9692691d84..195b7bbd38 100644 --- a/src/model/reference.ml +++ b/src/model/reference.ml @@ -128,7 +128,7 @@ type token = { location : Location_.span; } -type path_prefix = Path_prefix of string +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 @@ -207,7 +207,10 @@ let tokenize location s : token list * path_prefix option = let location = Location_.span [ location; identifier_location ] in (kind, location) and scan_path started_at tokens = - (tokens, Some (Path_prefix (String.sub s 0 (started_at + 1)))) + 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) [] @@ -221,15 +224,41 @@ 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 p = +let parse_path whole_path_location p = let segs = String.split_on_char '/' 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 -> (`TRelativePath, segs) - | "" :: "" :: segs -> (`TCurrentPackage, segs) - | "" :: segs -> (`TAbsolutePath, segs) - | segs -> (`TRelativePath, segs) - -let parse_path_prefix (Path_prefix p) identifier = parse_path (p ^ identifier) + | "." :: 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 : @@ -255,7 +284,7 @@ let parse whole_reference_location s : | Some p -> ( match kind with | `TUnknown | `TModule -> - `Module_path (parse_path_prefix p identifier) + `Module_path (parse_path_prefix p identifier location) | _ -> expected ~expect_paths:true [ "module" ] location |> Error.raise_exception)) @@ -287,7 +316,7 @@ let parse whole_reference_location s : | Some p -> ( match kind with | `TUnknown | `TModule -> - `Module_path (parse_path_prefix p identifier) + `Module_path (parse_path_prefix p identifier location) | _ -> expected ~expect_paths:true [ "module" ] location |> Error.raise_exception)) @@ -335,9 +364,11 @@ let parse whole_reference_location s : let label_parent_path kind path_prefix identifier location = match kind with - | `TUnknown -> `Any_path (parse_path_prefix path_prefix identifier) - | `TModule -> `Module_path (parse_path_prefix path_prefix identifier) - | `TPage -> `Page_path (parse_path_prefix path_prefix identifier) + | `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 @@ -345,10 +376,13 @@ let parse whole_reference_location s : let any_path kind path_prefix identifier location = match kind with - | `TUnknown -> `Any_path (parse_path_prefix path_prefix identifier) - | `TModule -> `Module_path (parse_path_prefix path_prefix identifier) - | `TPage -> `Page_path (parse_path_prefix path_prefix identifier) - | `TAsset -> `Asset_path (parse_path_prefix path_prefix identifier) + | `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 @@ -534,9 +568,9 @@ let parse whole_reference_location s : |> Error.raise_exception) (* Parse references that do not contain a [/]. Raises errors and warnings. *) -let parse_asset (* whole_reference_location *) s : +let parse_asset whole_reference_location s : Paths.Reference.Asset.t Error.with_errors_and_warnings = - let path = parse_path s in + let path = parse_path whole_reference_location s in Error.catch_errors_and_warnings (fun () -> `Asset_path path) let read_path_longident location s = diff --git a/src/model/reference.mli b/src/model/reference.mli index 71d72bf23b..62586a2af9 100644 --- a/src/model/reference.mli +++ b/src/model/reference.mli @@ -4,7 +4,7 @@ val parse : Location_.span -> string -> Paths.Reference.t Error.with_errors_and_warnings val parse_asset : - (* Location_.span -> *) + Location_.span -> string -> Paths.Reference.Asset.t Error.with_errors_and_warnings diff --git a/src/model/semantics.ml b/src/model/semantics.ml index 5bbdc17a0b..5746b23347 100644 --- a/src/model/semantics.ml +++ b/src/model/semantics.ml @@ -281,7 +281,7 @@ let rec nestable_block_element : | { value = `Media - (kind, { value = `Reference href; location = _href_location }, content, m); + (kind, { value = `Reference href; location = href_location }, content, m); location; } -> ( let fallback error = @@ -295,27 +295,9 @@ let rec nestable_block_element : (inline_elements status [ placeholder |> Location.at location ]) |> Location.at location in - match - Error.raise_warnings (Reference.parse_asset (* href_location *) href) - with + match Error.raise_warnings (Reference.parse_asset 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_path _ 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) diff --git a/test/model/semantics/test.ml b/test/model/semantics/test.ml index aaa2a2e00a..b3dcd83878 100644 --- a/test/model/semantics/test.ml +++ b/test/model/semantics/test.ml @@ -2858,12 +2858,12 @@ let%expect_test _ = let err_relative_empty_component = test "{!foo//bar}"; [%expect - {| {"value":[{"`Paragraph":[{"`Reference":[{"`Any_path":["`TRelativePath",["foo","","bar"]]},[]]}]}],"warnings":[]} |}] + {| {"value":[{"`Paragraph":[{"`Code_span":"foo//bar"}]}],"warnings":["File \"f.ml\", line 1, characters 6-6:\nIdentifier in path reference should not be empty."]} |}] let err_current_package_empty_component = test "{!///bar}"; [%expect - {| {"value":[{"`Paragraph":[{"`Reference":[{"`Any_path":["`TCurrentPackage",["","bar"]]},[]]}]}],"warnings":[]} |}] + {| {"value":[{"`Paragraph":[{"`Code_span":"///bar"}]}],"warnings":["File \"f.ml\", line 1, characters 4-4:\nIdentifier in path reference should not be empty."]} |}] let err_last_empty_component = test "{!foo/}"; From c5aa489790f7096b470b71a0294c2a0b8072de3a Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Thu, 1 Aug 2024 14:10:29 +0200 Subject: [PATCH 03/17] Media: fix @since tag for media in parser's ast --- src/parser/ast.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parser/ast.ml b/src/parser/ast.ml index 2053c7113b..a00fbd5ad9 100644 --- a/src/parser/ast.ml +++ b/src/parser/ast.ml @@ -66,7 +66,7 @@ and nestable_block_element = * media_href with_location * inline_element with_location list * media - (** @since 2.5.0 *) ] + (** @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 From fe7aebd945d8603ec956ee69e8c014bd0dc8a757 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Thu, 1 Aug 2024 14:12:01 +0200 Subject: [PATCH 04/17] Media: add documentation --- doc/ocamldoc_differences.mld | 1 + doc/odoc_for_authors.mld | 27 +++++++++++++++++++++++++++ 2 files changed, 28 insertions(+) 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..5ab9c52ca5 100644 --- a/doc/odoc_for_authors.mld +++ b/doc/odoc_for_authors.mld @@ -629,6 +629,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 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 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} From 6a8caf5b436e5f9feb903a969c67bab4015a0fd3 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Thu, 1 Aug 2024 14:23:01 +0200 Subject: [PATCH 05/17] Added change entry for medias --- CHANGES.md | 2 ++ 1 file changed, 2 insertions(+) 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 From f9e016c6545acd78d2cbe7fec870a79816d21efa Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Thu, 1 Aug 2024 14:48:34 +0200 Subject: [PATCH 06/17] Disable media test on OCaml < 4.07 Due to difference in cmdliner output. --- test/pages/dune | 5 +++++ 1 file changed, 5 insertions(+) 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))) From 9c7c123a7e69ac4260313cbeea70a036047d180d Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Thu, 1 Aug 2024 15:16:00 +0200 Subject: [PATCH 07/17] Compatibility --- src/model/reference.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/model/reference.ml b/src/model/reference.ml index 195b7bbd38..052a2c90bd 100644 --- a/src/model/reference.ml +++ b/src/model/reference.ml @@ -225,7 +225,7 @@ let expected ?(expect_paths = false) allowed location = expected_err (pp_hum_comma_separated Format.pp_print_string) allowed location let parse_path whole_path_location p = - let segs = String.split_on_char '/' p in + let segs = Astring.String.cuts ~sep:"/" p in let check segs start = let _finish = List.fold_left From bd3a857287d542c86a251b2be6ddb0cc913ced5f Mon Sep 17 00:00:00 2001 From: panglesd Date: Mon, 19 Aug 2024 16:56:17 +0200 Subject: [PATCH 08/17] Typos in documentation Co-authored-by: Jules Aguillon --- doc/odoc_for_authors.mld | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/odoc_for_authors.mld b/doc/odoc_for_authors.mld index 5ab9c52ca5..00b57e7651 100644 --- a/doc/odoc_for_authors.mld +++ b/doc/odoc_for_authors.mld @@ -633,7 +633,7 @@ The heavy syntax is easier to write, can be more readable for big tables, and su 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.. +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 @@ -647,7 +647,7 @@ 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. +Images are clickable and link to the image file. The following source: From b6ff7bb03f48d12e50f2ec3edfd325594802a126 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Mon, 19 Aug 2024 17:20:18 +0200 Subject: [PATCH 09/17] Medias: improve test --- test/pages/medias.t/index.mld | 8 ++++ test/pages/medias.t/run.t | 72 +++++++++++++++++++---------------- 2 files changed, 48 insertions(+), 32 deletions(-) diff --git a/test/pages/medias.t/index.mld b/test/pages/medias.t/index.mld index fe8f47d59b..32ac14447f 100644 --- a/test/pages/medias.t/index.mld +++ b/test/pages/medias.t/index.mld @@ -18,12 +18,20 @@ Some image: {1 Audio} +{2 References} + +{audio!Cri_du_chameau.ogg} + {2 Links} {audio:https://upload.wikimedia.org/wikipedia/commons/f/f1/Cri_du_chameau.ogg} {1 Video} +{2 References} + +{video:flower.webm} + {2 Links} {video:https://interactive-examples.mdn.mozilla.net/media/cc0-videos/flower.webm} diff --git a/test/pages/medias.t/run.t b/test/pages/medias.t/run.t index 711b90e2d6..124ecafddf 100644 --- a/test/pages/medias.t/run.t +++ b/test/pages/medias.t/run.t @@ -3,12 +3,14 @@ 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 33, characters 48-64: + File "index.mld", line 41, 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 @@ -23,43 +25,49 @@ To test visually, indent: Testing the working references: - $ cat html/index/index.html | grep img - cat: html/index/index.html: No such file or directory - [1] + $ cat html/pkg1/doc/index.html | grep img + + caml.gif + + With alt text and emphasis + + reference + + Video +

Video

+
+