OCaml HTML5 parser/serialiser based on Python's JustHTML
anil.recoil.org
1(*---------------------------------------------------------------------------
2 Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3 SPDX-License-Identifier: MIT
4 ---------------------------------------------------------------------------*)
5
6open Brr
7open Htmlrw_js_types
8
9module Data_attr = struct
10 let severity = Jstr.v "data-html5rw-severity"
11 let message = Jstr.v "data-html5rw-message"
12 let code = Jstr.v "data-html5rw-code"
13 let count = Jstr.v "data-html5rw-count"
14end
15
16module Css_class = struct
17 let error = Jstr.v "html5rw-error"
18 let warning = Jstr.v "html5rw-warning"
19 let info = Jstr.v "html5rw-info"
20 let has_issues = Jstr.v "html5rw-has-issues"
21 let highlighted = Jstr.v "html5rw-highlighted"
22 let tooltip = Jstr.v "html5rw-tooltip"
23 let tooltip_visible = Jstr.v "html5rw-tooltip-visible"
24end
25
26type tooltip = {
27 container : El.t;
28 _target : El.t;
29}
30
31let severity_class = function
32 | Htmlrw_check.Error -> Css_class.error
33 | Htmlrw_check.Warning -> Css_class.warning
34 | Htmlrw_check.Info -> Css_class.info
35
36let annotate_element ~config el msg =
37 if config.add_data_attrs then begin
38 El.set_at Data_attr.severity
39 (Some (Jstr.v (Htmlrw_check.severity_to_string msg.Htmlrw_check.severity))) el;
40 El.set_at Data_attr.message (Some (Jstr.v msg.Htmlrw_check.text)) el;
41 El.set_at Data_attr.code
42 (Some (Jstr.v (Htmlrw_check.error_code_to_string msg.Htmlrw_check.error_code))) el
43 end;
44 if config.add_classes then begin
45 El.set_class (severity_class msg.Htmlrw_check.severity) true el;
46 El.set_class Css_class.has_issues true el
47 end
48
49let rec create_tooltip ~position target messages =
50 let doc = El.document target in
51
52 (* Create tooltip container *)
53 let container = El.v (Jstr.v "div") ~at:[At.class' Css_class.tooltip] [] in
54
55 (* Add messages to tooltip *)
56 let msg_els = List.map (fun msg ->
57 let sev = Htmlrw_check.severity_to_string msg.Htmlrw_check.severity in
58 let sev_class = Jstr.v ("html5rw-tooltip-" ^ sev) in
59 El.v (Jstr.v "div") ~at:[At.class' sev_class] [
60 El.v (Jstr.v "span") ~at:[At.class' (Jstr.v "html5rw-tooltip-severity")] [
61 El.txt' (String.uppercase_ascii sev)
62 ];
63 El.v (Jstr.v "span") ~at:[At.class' (Jstr.v "html5rw-tooltip-text")] [
64 El.txt' msg.Htmlrw_check.text
65 ]
66 ]
67 ) messages in
68 El.set_children container msg_els;
69
70 (* Position the tooltip *)
71 let pos_class = match position with
72 | `Above -> "html5rw-tooltip-above"
73 | `Below -> "html5rw-tooltip-below"
74 | `Auto -> "html5rw-tooltip-auto"
75 in
76 El.set_class (Jstr.v pos_class) true container;
77
78 (* Add to body for proper z-index handling *)
79 El.append_children (Document.body doc) [container];
80
81 (* Set up hover events *)
82 let hide () =
83 El.set_class Css_class.tooltip_visible false container
84 in
85 let show () =
86 (* Hide any other visible tooltips first *)
87 let doc = El.document target in
88 let visible = El.fold_find_by_selector (fun el acc -> el :: acc)
89 (Jstr.v ".html5rw-tooltip-visible") [] ~root:(Document.body doc) in
90 List.iter (fun el -> El.set_class Css_class.tooltip_visible false el) visible;
91 (* Position and show this tooltip *)
92 let x = El.bound_x target in
93 let y = El.bound_y target in
94 let h = El.bound_h target in
95 let tooltip_y = match position with
96 | `Below | `Auto -> y +. h +. 4.0
97 | `Above -> y -. 4.0
98 in
99 El.set_inline_style (Jstr.v "left") (Jstr.v (Printf.sprintf "%.0fpx" x)) container;
100 El.set_inline_style (Jstr.v "top") (Jstr.v (Printf.sprintf "%.0fpx" tooltip_y)) container;
101 El.set_class Css_class.tooltip_visible true container
102 in
103
104 ignore (Ev.listen Ev.mouseenter (fun _ -> show ()) (El.as_target target));
105 ignore (Ev.listen Ev.mouseleave (fun _ -> hide ()) (El.as_target target));
106 (* Also hide on mouseout for better reliability *)
107 ignore (Ev.listen Ev.mouseout (fun ev ->
108 let related = Jv.get (Ev.to_jv ev) "relatedTarget" in
109 (* Hide if mouse moved to something outside the target *)
110 if Jv.is_null related then hide ()
111 else
112 (* Use JS contains method directly *)
113 let contains = Jv.call (El.to_jv target) "contains" [| related |] |> Jv.to_bool in
114 if not contains then hide ()
115 ) (El.as_target target));
116
117 { container; _target = target }
118
119and annotate ~config ~root:_ messages =
120 (* Group messages by element - use a list since we can't hash elements *)
121 let el_messages : (El.t * Htmlrw_check.message list) list ref = ref [] in
122 List.iter (fun bm ->
123 match bm.element_ref with
124 | Some { element = Some el; _ } ->
125 let found = ref false in
126 el_messages := List.map (fun (e, msgs) ->
127 if Jv.strict_equal (El.to_jv e) (El.to_jv el) then begin
128 found := true;
129 (e, bm.message :: msgs)
130 end else (e, msgs)
131 ) !el_messages;
132 if not !found then
133 el_messages := (el, [bm.message]) :: !el_messages
134 | _ -> ()
135 ) messages;
136
137 (* Annotate each element *)
138 List.iter (fun (el, msgs) ->
139 (* Use highest severity *)
140 let highest = List.fold_left (fun acc msg ->
141 match acc, msg.Htmlrw_check.severity with
142 | Htmlrw_check.Error, _ -> Htmlrw_check.Error
143 | _, Htmlrw_check.Error -> Htmlrw_check.Error
144 | Htmlrw_check.Warning, _ -> Htmlrw_check.Warning
145 | _, Htmlrw_check.Warning -> Htmlrw_check.Warning
146 | _ -> Htmlrw_check.Info
147 ) Htmlrw_check.Info msgs in
148
149 let primary_msg = {
150 Htmlrw_check.severity = highest;
151 text = (match msgs with m :: _ -> m.Htmlrw_check.text | [] -> "");
152 error_code = (match msgs with m :: _ -> m.Htmlrw_check.error_code
153 | [] -> Htmlrw_check.Conformance (`Misc `Multiple_h1));
154 location = None;
155 element = None;
156 attribute = None;
157 extract = None;
158 } in
159 annotate_element ~config el primary_msg;
160
161 if config.add_data_attrs then
162 El.set_at Data_attr.count (Some (Jstr.v (string_of_int (List.length msgs)))) el;
163
164 if config.show_tooltips then
165 ignore (create_tooltip ~position:config.tooltip_position el msgs)
166 ) !el_messages
167
168let show_tooltip t =
169 El.set_class Css_class.tooltip_visible true t.container
170
171let hide_tooltip t =
172 El.set_class Css_class.tooltip_visible false t.container
173
174let remove_tooltip t =
175 El.remove t.container
176
177let tooltips_in root =
178 let doc = El.document root in
179 let tooltip_els = El.fold_find_by_selector (fun el acc -> el :: acc)
180 (Jstr.v ".html5rw-tooltip") [] ~root:(Document.body doc) in
181 List.map (fun container -> { container; _target = root }) tooltip_els
182
183let clear_element el =
184 El.set_at Data_attr.severity None el;
185 El.set_at Data_attr.message None el;
186 El.set_at Data_attr.code None el;
187 El.set_at Data_attr.count None el;
188 El.set_class Css_class.error false el;
189 El.set_class Css_class.warning false el;
190 El.set_class Css_class.info false el;
191 El.set_class Css_class.has_issues false el;
192 El.set_class Css_class.highlighted false el
193
194let clear root =
195 Htmlrw_js_dom.iter_elements clear_element root;
196 List.iter remove_tooltip (tooltips_in root)
197
198let highlight_element el =
199 El.set_class Css_class.highlighted true el;
200 (* Call scrollIntoView directly with options object *)
201 let opts = Jv.obj [|
202 "behavior", Jv.of_string "smooth";
203 "block", Jv.of_string "center"
204 |] in
205 ignore (Jv.call (El.to_jv el) "scrollIntoView" [| opts |])
206
207let unhighlight_element el =
208 El.set_class Css_class.highlighted false el
209
210let _highlighted_elements : El.t list ref = ref []
211
212let clear_highlights () =
213 List.iter unhighlight_element !_highlighted_elements;
214 _highlighted_elements := []
215
216let inject_default_styles ~theme =
217 let theme_vars = match theme with
218 | `Light -> {|
219 --html5rw-error-color: #e74c3c;
220 --html5rw-warning-color: #f39c12;
221 --html5rw-info-color: #3498db;
222 --html5rw-bg: #ffffff;
223 --html5rw-text: #333333;
224 --html5rw-border: #dddddd;
225 |}
226 | `Dark -> {|
227 --html5rw-error-color: #ff6b6b;
228 --html5rw-warning-color: #feca57;
229 --html5rw-info-color: #54a0ff;
230 --html5rw-bg: #2d3436;
231 --html5rw-text: #dfe6e9;
232 --html5rw-border: #636e72;
233 |}
234 | `Auto -> {|
235 --html5rw-error-color: #e74c3c;
236 --html5rw-warning-color: #f39c12;
237 --html5rw-info-color: #3498db;
238 --html5rw-bg: #ffffff;
239 --html5rw-text: #333333;
240 --html5rw-border: #dddddd;
241 |}
242 in
243 let css = Printf.sprintf {|
244 :root { %s }
245
246 @media (prefers-color-scheme: dark) {
247 :root {
248 --html5rw-error-color: #ff6b6b;
249 --html5rw-warning-color: #feca57;
250 --html5rw-info-color: #54a0ff;
251 --html5rw-bg: #2d3436;
252 --html5rw-text: #dfe6e9;
253 --html5rw-border: #636e72;
254 }
255 }
256
257 .html5rw-error {
258 outline: 2px solid var(--html5rw-error-color) !important;
259 outline-offset: 2px;
260 }
261
262 .html5rw-warning {
263 outline: 2px solid var(--html5rw-warning-color) !important;
264 outline-offset: 2px;
265 }
266
267 .html5rw-info {
268 outline: 2px solid var(--html5rw-info-color) !important;
269 outline-offset: 2px;
270 }
271
272 .html5rw-highlighted {
273 background-color: rgba(52, 152, 219, 0.3) !important;
274 animation: html5rw-pulse 1s ease-in-out;
275 }
276
277 @keyframes html5rw-pulse {
278 0%%, 100%% { background-color: rgba(52, 152, 219, 0.3); }
279 50%% { background-color: rgba(52, 152, 219, 0.5); }
280 }
281
282 .html5rw-tooltip {
283 position: fixed;
284 z-index: 100000;
285 background: var(--html5rw-bg);
286 border: 1px solid var(--html5rw-border);
287 border-radius: 6px;
288 padding: 8px 12px;
289 box-shadow: 0 4px 12px rgba(0, 0, 0, 0.15);
290 max-width: 400px;
291 font-family: system-ui, -apple-system, sans-serif;
292 font-size: 13px;
293 color: var(--html5rw-text);
294 opacity: 0;
295 visibility: hidden;
296 transition: opacity 0.2s, visibility 0.2s;
297 pointer-events: none;
298 }
299
300 .html5rw-tooltip-visible {
301 opacity: 1;
302 visibility: visible;
303 }
304
305 .html5rw-tooltip-error .html5rw-tooltip-severity {
306 color: var(--html5rw-error-color);
307 font-weight: 600;
308 margin-right: 8px;
309 }
310
311 .html5rw-tooltip-warning .html5rw-tooltip-severity {
312 color: var(--html5rw-warning-color);
313 font-weight: 600;
314 margin-right: 8px;
315 }
316
317 .html5rw-tooltip-info .html5rw-tooltip-severity {
318 color: var(--html5rw-info-color);
319 font-weight: 600;
320 margin-right: 8px;
321 }
322
323 .html5rw-tooltip > div {
324 margin-bottom: 4px;
325 }
326
327 .html5rw-tooltip > div:last-child {
328 margin-bottom: 0;
329 }
330 |} theme_vars in
331
332 let doc = G.document in
333 let style_el = El.v (Jstr.v "style") [] in
334 El.set_children style_el [El.txt' css];
335 El.set_at (Jstr.v "data-html5rw-styles") (Some (Jstr.v "true")) style_el;
336 El.append_children (Document.head doc) [style_el];
337 style_el
338
339let remove_injected_styles style_el =
340 El.remove style_el