Skip to content

Commit 3fb728f

Browse files
JulowJulow
authored
Merge pull request #945 from Julow/tooltip-refs
Add a tooltip to references with text
2 parents 7e01c74 + 4bc9254 commit 3fb728f

File tree

13 files changed

+139
-104
lines changed

13 files changed

+139
-104
lines changed

‎src/document/comment.ml

Lines changed: 48 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -57,6 +57,34 @@ module Reference = struct
5757
render_resolved (r :> t) ^ "." ^ InstanceVariableName.to_string s
5858
| `Label (_, s) -> LabelName.to_string s
5959

60+
let rec render_unresolved : Reference.t -> string =
61+
let open Reference in
62+
function
63+
| `Resolved r -> render_resolved r
64+
| `Root (n, _) -> n
65+
| `Dot (p, f) -> render_unresolved (p :> t) ^ "." ^ f
66+
| `Module (p, f) ->
67+
render_unresolved (p :> t) ^ "." ^ ModuleName.to_string f
68+
| `ModuleType (p, f) ->
69+
render_unresolved (p :> t) ^ "." ^ ModuleTypeName.to_string f
70+
| `Type (p, f) -> render_unresolved (p :> t) ^ "." ^ TypeName.to_string f
71+
| `Constructor (p, f) ->
72+
render_unresolved (p :> t) ^ "." ^ ConstructorName.to_string f
73+
| `Field (p, f) -> render_unresolved (p :> t) ^ "." ^ FieldName.to_string f
74+
| `Extension (p, f) ->
75+
render_unresolved (p :> t) ^ "." ^ ExtensionName.to_string f
76+
| `Exception (p, f) ->
77+
render_unresolved (p :> t) ^ "." ^ ExceptionName.to_string f
78+
| `Value (p, f) -> render_unresolved (p :> t) ^ "." ^ ValueName.to_string f
79+
| `Class (p, f) -> render_unresolved (p :> t) ^ "." ^ ClassName.to_string f
80+
| `ClassType (p, f) ->
81+
render_unresolved (p :> t) ^ "." ^ ClassTypeName.to_string f
82+
| `Method (p, f) ->
83+
render_unresolved (p :> t) ^ "." ^ MethodName.to_string f
84+
| `InstanceVariable (p, f) ->
85+
render_unresolved (p :> t) ^ "." ^ InstanceVariableName.to_string f
86+
| `Label (p, f) -> render_unresolved (p :> t) ^ "." ^ LabelName.to_string f
87+
6088
(* This is the entry point. stop_before is false on entry, true on recursive
6189
call. *)
6290
let rec to_ir : ?text:Inline.t -> stop_before:bool -> Reference.t -> Inline.t
@@ -69,8 +97,11 @@ module Reference = struct
6997
| None ->
7098
let s = source_of_code s in
7199
[ inline @@ Inline.Source s ]
72-
| Some s ->
73-
[ inline @@ Inline.InternalLink (InternalLink.Unresolved s) ])
100+
| Some content ->
101+
let link =
102+
{ InternalLink.target = Unresolved; content; tooltip = Some s }
103+
in
104+
[ inline @@ Inline.InternalLink link ])
74105
| `Dot (parent, s) -> unresolved ?text (parent :> t) s
75106
| `Module (parent, s) ->
76107
unresolved ?text (parent :> t) (ModuleName.to_string s)
@@ -100,25 +131,33 @@ module Reference = struct
100131
| `Resolved r -> (
101132
(* IDENTIFIER MUST BE RENAMED TO DEFINITION. *)
102133
let id = Reference.Resolved.identifier r in
103-
let txt =
134+
let rendered = render_resolved r in
135+
let content =
104136
match text with
105-
| None ->
106-
[ inline @@ Inline.Source (source_of_code (render_resolved r)) ]
137+
| None -> [ inline @@ Inline.Source (source_of_code rendered) ]
107138
| Some s -> s
139+
and tooltip =
140+
(* Add a tooltip if the content is not the rendered reference. *)
141+
match text with None -> None | Some _ -> Some rendered
108142
in
109143
match Url.from_identifier ~stop_before id with
110144
| Ok url ->
111-
[ inline @@ Inline.InternalLink (InternalLink.Resolved (url, txt)) ]
112-
| Error (Not_linkable _) -> txt
145+
let target = InternalLink.Resolved url in
146+
let link = { InternalLink.target; content; tooltip } in
147+
[ inline @@ Inline.InternalLink link ]
148+
| Error (Not_linkable _) -> content
113149
| Error exn ->
114150
(* FIXME: better error message *)
115151
Printf.eprintf "Id.href failed: %S\n%!" (Url.Error.to_string exn);
116-
txt)
152+
content)
117153

118154
and unresolved : ?text:Inline.t -> Reference.t -> string -> Inline.t =
119155
fun ?text parent field ->
120156
match text with
121-
| Some s -> [ inline @@ InternalLink (InternalLink.Unresolved s) ]
157+
| Some content ->
158+
let tooltip = Some (render_unresolved parent ^ "." ^ field) in
159+
let link = { InternalLink.target = Unresolved; content; tooltip } in
160+
[ inline @@ InternalLink link ]
122161
| None ->
123162
let tail = [ inline @@ Text ("." ^ field) ] in
124163
let content = to_ir ~stop_before:true parent in

‎src/document/doctree.ml

Lines changed: 1 addition & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -377,16 +377,12 @@ end = struct
377377
match x.desc with
378378
| Styled (_, x) -> inline x
379379
| Link (_, x) -> inline x
380-
| InternalLink x -> internallink x
380+
| InternalLink x -> inline x.content
381381
| Math _ -> true
382382
| Text _ | Entity _ | Linebreak | Source _ | Raw_markup _ -> false
383383
in
384384
List.exists inline_ x
385385

386-
and internallink : InternalLink.t -> bool = function
387-
| Resolved (_, x) -> inline x
388-
| Unresolved x -> inline x
389-
390386
and description : Description.t -> bool =
391387
fun x ->
392388
let description_ : Description.one -> bool =

‎src/document/generator.ml

Lines changed: 9 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -32,15 +32,15 @@ let type_var tv = tag "type-var" (O.txt tv)
3232

3333
let enclose ~l ~r x = O.span (O.txt l ++ x ++ O.txt r)
3434

35-
let path p txt =
36-
O.elt
37-
[ inline @@ InternalLink (InternalLink.Resolved (Url.from_path p, txt)) ]
35+
let resolved p content =
36+
let link = { InternalLink.target = Resolved p; content; tooltip = None } in
37+
O.elt [ inline @@ InternalLink link ]
3838

39-
let resolved p txt =
40-
O.elt [ inline @@ InternalLink (InternalLink.Resolved (p, txt)) ]
39+
let path p content = resolved (Url.from_path p) content
4140

42-
let unresolved txt =
43-
O.elt [ inline @@ InternalLink (InternalLink.Unresolved txt) ]
41+
let unresolved content =
42+
let link = { InternalLink.target = Unresolved; content; tooltip = None } in
43+
O.elt [ inline @@ InternalLink link ]
4444

4545
let path_to_id path =
4646
match Url.Anchor.from_identifier (path :> Paths.Identifier.t) with
@@ -1814,8 +1814,9 @@ module Make (Syntax : SYNTAX) = struct
18141814
in
18151815
let li ?(attr = []) name url =
18161816
let link url desc =
1817+
let content = [ Inline.{ attr = []; desc } ] and tooltip = None in
18171818
Inline.InternalLink
1818-
InternalLink.(Resolved (url, [ Inline.{ attr = []; desc } ]))
1819+
{ InternalLink.target = Resolved url; content; tooltip }
18191820
in
18201821
[ block ~attr @@ Block.Inline (inline @@ link url (Text name)) ]
18211822
in

‎src/document/types.ml

Lines changed: 2 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -6,11 +6,9 @@ end =
66
Class
77

88
and InternalLink : sig
9-
type resolved = Url.t * Inline.t
9+
type target = Resolved of Url.t | Unresolved
1010

11-
type unresolved = Inline.t
12-
13-
type t = Resolved of resolved | Unresolved of Inline.t
11+
type t = { target : target; content : Inline.t; tooltip : string option }
1412
end =
1513
InternalLink
1614

‎src/document/utils.ml

Lines changed: 1 addition & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -33,10 +33,7 @@ and compute_length_inline (t : Types.Inline.t) : int =
3333
| Text s -> acc + String.length s
3434
| Entity _e -> acc + 1
3535
| Linebreak -> 0 (* TODO *)
36-
| Styled (_, t)
37-
| Link (_, t)
38-
| InternalLink (Resolved (_, t))
39-
| InternalLink (Unresolved t) ->
36+
| Styled (_, t) | Link (_, t) | InternalLink { content = t; _ } ->
4037
acc + compute_length_inline t
4138
| Source s -> acc + compute_length_source s
4239
| Math _ -> assert false

‎src/html/generator.ml

Lines changed: 17 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -92,26 +92,24 @@ and styled style ~emph_level =
9292
| `Superscript -> (emph_level, Html.sup ~a:[])
9393
| `Subscript -> (emph_level, Html.sub ~a:[])
9494

95-
let rec internallink ~config ~emph_level ~resolve ?(a = []) (t : InternalLink.t)
96-
=
97-
match t with
98-
| Resolved (uri, content) ->
99-
let href = Link.href ~config ~resolve uri in
100-
let a = (a :> Html_types.a_attrib Html.attrib list) in
101-
let elt =
95+
let rec internallink ~config ~emph_level ~resolve ?(a = [])
96+
{ InternalLink.target; content; tooltip } =
97+
let a = match tooltip with Some s -> Html.a_title s :: a | None -> a in
98+
let elt =
99+
match target with
100+
| Resolved uri ->
101+
let href = Link.href ~config ~resolve uri in
102+
let a = (a :> Html_types.a_attrib Html.attrib list) in
102103
Html.a ~a:(Html.a_href href :: a) (inline_nolink ~emph_level content)
103-
in
104-
let elt = (elt :> phrasing Html.elt) in
105-
[ elt ]
106-
| Unresolved content ->
107-
(* let title =
108-
* Html.a_title (Printf.sprintf "unresolved reference to %S"
109-
* (ref_to_string ref)
110-
* in *)
111-
let a = Html.a_class [ "xref-unresolved" ] :: a in
112-
let elt = Html.span ~a (inline ~config ~emph_level ~resolve content) in
113-
let elt = (elt :> phrasing Html.elt) in
114-
[ elt ]
104+
| Unresolved ->
105+
(* let title =
106+
* Html.a_title (Printf.sprintf "unresolved reference to %S"
107+
* (ref_to_string ref)
108+
* in *)
109+
let a = Html.a_class [ "xref-unresolved" ] :: a in
110+
Html.span ~a (inline ~config ~emph_level ~resolve content)
111+
in
112+
[ (elt :> phrasing Html.elt) ]
115113

116114
and inline ~config ?(emph_level = 0) ~resolve (l : Inline.t) :
117115
phrasing Html.elt list =

‎src/latex/generator.ml

Lines changed: 8 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -231,17 +231,14 @@ let source k (t : Source.t) =
231231
tokens t
232232

233233
let rec internalref ~verbatim ~in_source (t : InternalLink.t) =
234-
match t with
235-
| Resolved (uri, content) ->
236-
let target = Link.label uri in
237-
let text = Some (inline ~verbatim ~in_source content) in
238-
let short = in_source in
239-
Internal_ref { short; text; target }
240-
| Unresolved content ->
241-
let target = "xref-unresolved" in
242-
let text = Some (inline ~verbatim ~in_source content) in
243-
let short = in_source in
244-
Internal_ref { short; target; text }
234+
let target =
235+
match t.target with
236+
| InternalLink.Resolved uri -> Link.label uri
237+
| Unresolved -> "xref-unresolved"
238+
in
239+
let text = Some (inline ~verbatim ~in_source t.content) in
240+
let short = in_source in
241+
Internal_ref { short; target; text }
245242

246243
and inline ~in_source ~verbatim (l : Inline.t) =
247244
let one (t : Inline.one) =

‎src/manpage/generator.ml

Lines changed: 2 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -238,9 +238,7 @@ let strip l =
238238
{ h with desc = Styled (sty, List.rev @@ loop [] content) }
239239
in
240240
loop (h :: acc) t
241-
| Link (_, content)
242-
| InternalLink (Resolved (_, content))
243-
| InternalLink (Unresolved content) ->
241+
| Link (_, content) | InternalLink { content; _ } ->
244242
let acc = loop acc content in
245243
loop acc t
246244
| Source code ->
@@ -298,7 +296,7 @@ and inline (l : Inline.t) =
298296
| Styled (sty, content) -> style sty (inline content) ++ inline rest
299297
| Link (href, content) ->
300298
env "UR" "UE" href (inline @@ strip content) ++ inline rest
301-
| InternalLink (Resolved (_, content) | Unresolved content) ->
299+
| InternalLink { content; _ } ->
302300
font "CI" (inline @@ strip content) ++ inline rest
303301
| Source content -> source_code content ++ inline rest
304302
| Math s -> math s ++ inline rest

‎test/generators/html/Labels.html

Lines changed: 14 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -178,20 +178,20 @@ <h2 id="L2"><a href="#L2" class="anchor"></a>Attached to nothing</h2>
178178
</ol><code><span>}</span></code>
179179
</div>
180180
</div><p>Testing that labels can be referenced</p>
181-
<ul><li><a href="#L1">Attached to unit</a></li>
182-
<li><a href="#L2">Attached to nothing</a></li>
183-
<li><a href="#L3">Attached to module</a></li>
184-
<li><a href="#L4">Attached to type</a></li>
185-
<li><a href="#L5">Attached to value</a></li>
186-
<li><a href="#L6">Attached to module type</a></li>
187-
<li><a href="#L7">Attached to class</a></li>
188-
<li><a href="#L8">Attached to class type</a></li>
189-
<li><a href="#L9">Attached to exception</a></li>
190-
<li><a href="#L10">Attached to extension</a></li>
191-
<li><a href="#L11">Attached to module subst</a></li>
192-
<li><a href="#L12">Attached to type subst</a></li>
193-
<li><a href="#L13">Attached to constructor</a></li>
194-
<li><a href="#L14">Attached to field</a></li>
181+
<ul><li><a href="#L1" title="L1">Attached to unit</a></li>
182+
<li><a href="#L2" title="L2">Attached to nothing</a></li>
183+
<li><a href="#L3" title="L3">Attached to module</a></li>
184+
<li><a href="#L4" title="L4">Attached to type</a></li>
185+
<li><a href="#L5" title="L5">Attached to value</a></li>
186+
<li><a href="#L6" title="L6">Attached to module type</a></li>
187+
<li><a href="#L7" title="L7">Attached to class</a></li>
188+
<li><a href="#L8" title="L8">Attached to class type</a></li>
189+
<li><a href="#L9" title="L9">Attached to exception</a></li>
190+
<li><a href="#L10" title="L10">Attached to extension</a></li>
191+
<li><a href="#L11" title="L11">Attached to module subst</a></li>
192+
<li><a href="#L12" title="L12">Attached to type subst</a></li>
193+
<li><a href="#L13" title="L13">Attached to constructor</a></li>
194+
<li><a href="#L14" title="L14">Attached to field</a></li>
195195
</ul>
196196
</div>
197197
</body>

‎test/generators/html/Markup.html

Lines changed: 17 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -76,9 +76,10 @@ <h4 id="sub-subsection-headings">
7676
<p>but odoc has banned deeper headings. There are also title headings,
7777
but they are only allowed in mld files.
7878
</p><h4 id="anchors"><a href="#anchors" class="anchor"></a>Anchors</h4>
79-
<p>Sections can have attached <a href="#anchors">Anchors</a>, and
80-
it is possible to <a href="#anchors">link</a> to them. Links to section
81-
headers should not be set in source code style.
79+
<p>Sections can have attached
80+
<a href="#anchors" title="anchors">Anchors</a>, and it is possible
81+
to <a href="#anchors" title="anchors">link</a> to them. Links to
82+
section headers should not be set in source code style.
8283
</p>
8384
<h5 id="paragraph"><a href="#paragraph" class="anchor"></a>Paragraph</h5>
8485
<p>Individual paragraphs can have a heading.</p>
@@ -137,17 +138,19 @@ <h2 id="links-and-references">
137138
</p>
138139
<p>This is a reference to <a href="#val-foo"><code>foo</code></a>.
139140
References can have replacement text:
140-
<a href="#val-foo">the value foo</a>. Except for the special lookup
141-
support, references are pretty much just like links. The replacement
142-
text can have nested styles: <a href="#val-foo"><b>bold</b></a>,
143-
<a href="#val-foo"><i>italic</i></a>,
144-
<a href="#val-foo"><em>emphasis</em></a>,
145-
<a href="#val-foo">super<sup>script</sup></a>,
146-
<a href="#val-foo">sub<sub>script</sub></a>, and
147-
<a href="#val-foo"><code>code</code></a>. It's also possible to surround
148-
a reference in a style: <b><a href="#val-foo"><code>foo</code></a></b>
149-
. References can't be nested inside references, and links and references
150-
can't be nested inside each other.
141+
<a href="#val-foo" title="foo">the value foo</a>. Except for the
142+
special lookup support, references are pretty much just like links.
143+
The replacement text can have nested styles:
144+
<a href="#val-foo" title="foo"><b>bold</b></a>,
145+
<a href="#val-foo" title="foo"><i>italic</i></a>,
146+
<a href="#val-foo" title="foo"><em>emphasis</em></a>,
147+
<a href="#val-foo" title="foo">super<sup>script</sup></a>,
148+
<a href="#val-foo" title="foo">sub<sub>script</sub></a>, and
149+
<a href="#val-foo" title="foo"><code>code</code></a>. It's also possible
150+
to surround a reference in a style:
151+
<b><a href="#val-foo"><code>foo</code></a></b>. References can't
152+
be nested inside references, and links and references can't be nested
153+
inside each other.
151154
</p>
152155
<h2 id="preformatted-text">
153156
<a href="#preformatted-text" class="anchor"></a>Preformatted text

0 commit comments

Comments
 (0)