Add support for medias (images, audio and video)

Author: panglesd

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

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

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
@@ -1841,8 +1841,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

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 } =

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 =

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

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
 

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

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);
 }