Add a tooltip to references with text

The tooltip shows what would be rendered instead if no text was written.
This is currently the original reference.

This is most useful for references that do not resolve, because the
original reference is not visible at all.

The tooltip is generally easier to read than the target URL shown by the
browser on hover and might benefit from smarter rendering of references
in the future.

Author: Julow

src/document/comment.ml

@@ -57,6 +57,34 @@ module Reference = struct
         render_resolved (r :> t) ^ "." ^ InstanceVariableName.to_string s
     | `Label (_, s) -> LabelName.to_string s
 
+  let rec render_unresolved : Reference.t -> string =
+    let open Reference in
+    function
+    | `Resolved r -> render_resolved r
+    | `Root (n, _) -> n
+    | `Dot (p, f) -> render_unresolved (p :> t) ^ "." ^ f
+    | `Module (p, f) ->
+        render_unresolved (p :> t) ^ "." ^ ModuleName.to_string f
+    | `ModuleType (p, f) ->
+        render_unresolved (p :> t) ^ "." ^ ModuleTypeName.to_string f
+    | `Type (p, f) -> render_unresolved (p :> t) ^ "." ^ TypeName.to_string f
+    | `Constructor (p, f) ->
+        render_unresolved (p :> t) ^ "." ^ ConstructorName.to_string f
+    | `Field (p, f) -> render_unresolved (p :> t) ^ "." ^ FieldName.to_string f
+    | `Extension (p, f) ->
+        render_unresolved (p :> t) ^ "." ^ ExtensionName.to_string f
+    | `Exception (p, f) ->
+        render_unresolved (p :> t) ^ "." ^ ExceptionName.to_string f
+    | `Value (p, f) -> render_unresolved (p :> t) ^ "." ^ ValueName.to_string f
+    | `Class (p, f) -> render_unresolved (p :> t) ^ "." ^ ClassName.to_string f
+    | `ClassType (p, f) ->
+        render_unresolved (p :> t) ^ "." ^ ClassTypeName.to_string f
+    | `Method (p, f) ->
+        render_unresolved (p :> t) ^ "." ^ MethodName.to_string f
+    | `InstanceVariable (p, f) ->
+        render_unresolved (p :> t) ^ "." ^ InstanceVariableName.to_string f
+    | `Label (p, f) -> render_unresolved (p :> t) ^ "." ^ LabelName.to_string f
+
   (* This is the entry point. stop_before is false on entry, true on recursive
      call. *)
   let rec to_ir : ?text:Inline.t -> stop_before:bool -> Reference.t -> Inline.t
@@ -70,7 +98,9 @@ module Reference = struct
             let s = source_of_code s in
             [ inline @@ Inline.Source s ]
         | Some content ->
-            let link = { InternalLink.target = Unresolved; content } in
+            let link =
+              { InternalLink.target = Unresolved; content; tooltip = Some s }
+            in
             [ inline @@ Inline.InternalLink link ])
     | `Dot (parent, s) -> unresolved ?text (parent :> t) s
     | `Module (parent, s) ->
@@ -101,16 +131,20 @@ module Reference = struct
     | `Resolved r -> (
         (* IDENTIFIER MUST BE RENAMED TO DEFINITION. *)
         let id = Reference.Resolved.identifier r in
+        let rendered = render_resolved r in
         let content =
           match text with
-          | None ->
-              [ inline @@ Inline.Source (source_of_code (render_resolved r)) ]
+          | None -> [ inline @@ Inline.Source (source_of_code rendered) ]
           | Some s -> s
+        and tooltip =
+          (* Add a tooltip if the content is not the rendered reference. *)
+          match text with None -> None | Some _ -> Some rendered
         in
         match Url.from_identifier ~stop_before id with
         | Ok url ->
             let target = InternalLink.Resolved url in
-            [ inline @@ Inline.InternalLink { InternalLink.target; content } ]
+            let link = { InternalLink.target; content; tooltip } in
+            [ inline @@ Inline.InternalLink link ]
         | Error (Not_linkable _) -> content
         | Error exn ->
             (* FIXME: better error message *)
@@ -121,7 +155,8 @@ module Reference = struct
    fun ?text parent field ->
     match text with
     | Some content ->
-        let link = { InternalLink.target = Unresolved; content } in
+        let tooltip = Some (render_unresolved parent ^ "." ^ field) in
+        let link = { InternalLink.target = Unresolved; content; tooltip } in
         [ inline @@ InternalLink link ]
     | None ->
         let tail = [ inline @@ Text ("." ^ field) ] in

src/document/generator.ml

@@ -33,13 +33,13 @@ 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 } in
+  let link = { InternalLink.target = Resolved p; content; tooltip = None } in
   O.elt [ inline @@ InternalLink link ]
 
 let path p content = resolved (Url.from_path p) content
 
 let unresolved content =
-  let link = { InternalLink.target = Unresolved; content } in
+  let link = { InternalLink.target = Unresolved; content; tooltip = None } in
   O.elt [ inline @@ InternalLink link ]
 
 let path_to_id path =
@@ -1814,8 +1814,9 @@ module Make (Syntax : SYNTAX) = struct
         in
         let li ?(attr = []) name url =
           let link url desc =
-            let content = [ Inline.{ attr = []; desc } ] in
-            Inline.InternalLink { InternalLink.target = Resolved url; content }
+            let content = [ Inline.{ attr = []; desc } ] and tooltip = None in
+            Inline.InternalLink
+              { InternalLink.target = Resolved url; content; tooltip }
           in
           [ block ~attr @@ Block.Inline (inline @@ link url (Text name)) ]
         in

src/document/types.ml

@@ -8,7 +8,7 @@ end =
 and InternalLink : sig
   type target = Resolved of Url.t | Unresolved
 
-  type t = { target : target; content : Inline.t }
+  type t = { target : target; content : Inline.t; tooltip : string option }
 end =
   InternalLink
 

src/html/generator.ml

@@ -92,21 +92,22 @@ 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 = []) (t : InternalLink.t)
-    =
+let rec internallink ~config ~emph_level ~resolve ?(a = [])
+    { InternalLink.target; content; tooltip } =
+  let a = match tooltip with Some s -> Html.a_title s :: a | None -> a in
   let elt =
-    match t.target with
+    match target with
     | Resolved uri ->
         let href = Link.href ~config ~resolve uri in
         let a = (a :> Html_types.a_attrib Html.attrib list) in
-        Html.a ~a:(Html.a_href href :: a) (inline_nolink ~emph_level t.content)
+        Html.a ~a:(Html.a_href href :: a) (inline_nolink ~emph_level content)
     | Unresolved ->
         (* let title =
          *   Html.a_title (Printf.sprintf "unresolved reference to %S"
          *       (ref_to_string ref)
          * in *)
         let a = Html.a_class [ "xref-unresolved" ] :: a in
-        Html.span ~a (inline ~config ~emph_level ~resolve t.content)
+        Html.span ~a (inline ~config ~emph_level ~resolve content)
   in
   [ (elt :> phrasing Html.elt) ]
 

test/generators/html/Labels.html

@@ -178,20 +178,20 @@ <h2 id="L2"><a href="#L2" class="anchor"></a>Attached to nothing</h2>
      </ol><code><span>}</span></code>
     </div>
    </div><p>Testing that labels can be referenced</p>
-   <ul><li><a href="#L1">Attached to unit</a></li>
-    <li><a href="#L2">Attached to nothing</a></li>
-    <li><a href="#L3">Attached to module</a></li>
-    <li><a href="#L4">Attached to type</a></li>
-    <li><a href="#L5">Attached to value</a></li>
-    <li><a href="#L6">Attached to module type</a></li>
-    <li><a href="#L7">Attached to class</a></li>
-    <li><a href="#L8">Attached to class type</a></li>
-    <li><a href="#L9">Attached to exception</a></li>
-    <li><a href="#L10">Attached to extension</a></li>
-    <li><a href="#L11">Attached to module subst</a></li>
-    <li><a href="#L12">Attached to type subst</a></li>
-    <li><a href="#L13">Attached to constructor</a></li>
-    <li><a href="#L14">Attached to field</a></li>
+   <ul><li><a href="#L1" title="L1">Attached to unit</a></li>
+    <li><a href="#L2" title="L2">Attached to nothing</a></li>
+    <li><a href="#L3" title="L3">Attached to module</a></li>
+    <li><a href="#L4" title="L4">Attached to type</a></li>
+    <li><a href="#L5" title="L5">Attached to value</a></li>
+    <li><a href="#L6" title="L6">Attached to module type</a></li>
+    <li><a href="#L7" title="L7">Attached to class</a></li>
+    <li><a href="#L8" title="L8">Attached to class type</a></li>
+    <li><a href="#L9" title="L9">Attached to exception</a></li>
+    <li><a href="#L10" title="L10">Attached to extension</a></li>
+    <li><a href="#L11" title="L11">Attached to module subst</a></li>
+    <li><a href="#L12" title="L12">Attached to type subst</a></li>
+    <li><a href="#L13" title="L13">Attached to constructor</a></li>
+    <li><a href="#L14" title="L14">Attached to field</a></li>
    </ul>
   </div>
  </body>

test/generators/html/Markup.html

@@ -76,9 +76,10 @@ <h4 id="sub-subsection-headings">
    <p>but odoc has banned deeper headings. There are also title headings,
      but they are only allowed in mld files.
    </p><h4 id="anchors"><a href="#anchors" class="anchor"></a>Anchors</h4>
-   <p>Sections can have attached <a href="#anchors">Anchors</a>, and 
-    it is possible to <a href="#anchors">link</a> to them. Links to section
-     headers should not be set in source code style.
+   <p>Sections can have attached 
+    <a href="#anchors" title="anchors">Anchors</a>, and it is possible
+     to <a href="#anchors" title="anchors">link</a> to them. Links to
+     section headers should not be set in source code style.
    </p>
    <h5 id="paragraph"><a href="#paragraph" class="anchor"></a>Paragraph</h5>
    <p>Individual paragraphs can have a heading.</p>
@@ -137,17 +138,19 @@ <h2 id="links-and-references">
    </p>
    <p>This is a reference to <a href="#val-foo"><code>foo</code></a>.
      References can have replacement text: 
-    <a href="#val-foo">the value foo</a>. Except for the special lookup
-     support, references are pretty much just like links. The replacement
-     text can have nested styles: <a href="#val-foo"><b>bold</b></a>,
-     <a href="#val-foo"><i>italic</i></a>, 
-    <a href="#val-foo"><em>emphasis</em></a>, 
-    <a href="#val-foo">super<sup>script</sup></a>, 
-    <a href="#val-foo">sub<sub>script</sub></a>, and 
-    <a href="#val-foo"><code>code</code></a>. It's also possible to surround
-     a reference in a style: <b><a href="#val-foo"><code>foo</code></a></b>
-    . References can't be nested inside references, and links and references
-     can't be nested inside each other.
+    <a href="#val-foo" title="foo">the value foo</a>. Except for the 
+    special lookup support, references are pretty much just like links.
+     The replacement text can have nested styles: 
+    <a href="#val-foo" title="foo"><b>bold</b></a>, 
+    <a href="#val-foo" title="foo"><i>italic</i></a>, 
+    <a href="#val-foo" title="foo"><em>emphasis</em></a>, 
+    <a href="#val-foo" title="foo">super<sup>script</sup></a>, 
+    <a href="#val-foo" title="foo">sub<sub>script</sub></a>, and 
+    <a href="#val-foo" title="foo"><code>code</code></a>. It's also possible
+     to surround a reference in a style: 
+    <b><a href="#val-foo"><code>foo</code></a></b>. References can't 
+    be nested inside references, and links and references can't be nested
+     inside each other.
    </p>
    <h2 id="preformatted-text">
     <a href="#preformatted-text" class="anchor"></a>Preformatted text

test/generators/html/Ocamlary.html

@@ -266,8 +266,9 @@ <h4 id="emptySig"><a href="#emptySig" class="anchor"></a>EmptySig</h4>
     </a> or 
     <a href="Ocamlary-module-type-SuperSig-module-type-EmptySig.html">
      <code>SuperSig.EmptySig</code>
-    </a>. Section <a href="#s9000">Section 9000</a> is also interesting.
-     <a href="#emptySig">EmptySig</a> is the section and 
+    </a>. Section <a href="#s9000" title="s9000">Section 9000</a> is 
+    also interesting. <a href="#emptySig" title="emptySig">EmptySig</a>
+     is the section and 
     <a href="Ocamlary-module-type-EmptySig.html"><code>EmptySig</code></a>
      is the module signature.
    </p>
@@ -2764,9 +2765,13 @@ <h2 id="section-title-splicing">
    </h2><p>I can refer to</p>
    <ul>
     <li><code>{!section:indexmodules}</code> : 
-     <a href="#indexmodules">Trying the {!modules: ...} command.</a>
+     <a href="#indexmodules" title="indexmodules">Trying the {!modules:
+       ...} command.
+     </a>
+    </li>
+    <li><code>{!aliases}</code> : 
+     <a href="#aliases" title="aliases">Aliases again</a>
     </li>
-    <li><code>{!aliases}</code> : <a href="#aliases">Aliases again</a></li>
    </ul><p>But also to things in submodules:</p>
    <ul>
     <li><code>{!section:SuperSig.SubSigA.subSig}</code> : 
@@ -2780,15 +2785,17 @@ <h2 id="section-title-splicing">
    </ul><p>And just to make sure we do not mess up:</p>
    <ul>
     <li><code>{{!section:indexmodules}A}</code> : 
-     <a href="#indexmodules">A</a>
-    </li><li><code>{{!aliases}B}</code> : <a href="#aliases">B</a></li>
+     <a href="#indexmodules" title="indexmodules">A</a>
+    </li>
+    <li><code>{{!aliases}B}</code> : <a href="#aliases" title="aliases">B</a>
+    </li>
     <li><code>{{!section:SuperSig.SubSigA.subSig}C}</code> : 
-     <a href="Ocamlary-module-type-SuperSig-module-type-SubSigA.html#subSig">
-      C
+     <a href="Ocamlary-module-type-SuperSig-module-type-SubSigA.html#subSig"
+      title="subSig">C
      </a>
     </li>
     <li><code>{{!Aliases.incl}D}</code> : 
-     <a href="Ocamlary-Aliases.html#incl">D</a>
+     <a href="Ocamlary-Aliases.html#incl" title="incl">D</a>
     </li>
    </ul>
    <h2 id="new-reference-syntax">

test/generators/html/Toplevel_comments-Comments_on_open.html

@@ -32,7 +32,7 @@ <h1>Module <code><span>Toplevel_comments.Comments_on_open</span></code>
     </div>
    </div><h3 id="sec"><a href="#sec" class="anchor"></a>Section</h3>
    <p>Comments attached to open are treated as floating comments. Referencing
-     <a href="#sec">Section</a> 
+     <a href="#sec" title="sec">Section</a> 
     <a href="Toplevel_comments-Comments_on_open-M.html#type-t">
      <code>M.t</code>
     </a> works

test/xref2/labels/labels.t/run.t

@@ -63,7 +63,7 @@ There are two references in N, one should point to a local label and the other t
     </nav>
     <div class="odoc-content">
      <h2 id="B"><a href="#B" class="anchor"></a>An other conflicting label</h2>
-     <p><a href="#B">An other conflicting label</a> 
+     <p><a href="#B" title="B">An other conflicting label</a> 
       <a href="../M/index.html#B"><code>B</code></a>
      </p>
     </div>
@@ -125,7 +125,8 @@ The second occurence of 'B' in the main page should be disambiguated
      </div><h2 id="B_2"><a href="#B_2" class="anchor"></a>Dupplicate B</h2>
      <p>Define <code>B</code> again in the same scope.</p>
      <p>References to the labels:</p>
-     <p><a href="#A">First label</a> <a href="#B">Dupplicate B</a> 
+     <p><a href="#A" title="A">First label</a> 
+      <a href="#B" title="B">Dupplicate B</a> 
       <a href="M/index.html#C"><code>C</code></a> 
       <a href="M/index.html#D"><code>D</code></a> 
       <a href="M/index.html#B"><code>B</code></a>