anil.recoil.org
OCaml HTML5 parser/serialiser based on Python's JustHTML
js
-1
bin/html5check/html5check.ml
-1
bin/html5check/html5check.ml
+49
lib/js/dune
+49
lib/js/dune
···
···
1
+
; HTML5rw JavaScript Validator Library
2
+
; Compiled with js_of_ocaml for browser use
3
+
4
+
(library
5
+
(name htmlrw_js)
6
+
(public_name html5rw.js)
7
+
(libraries
8
+
html5rw
9
+
htmlrw_check
10
+
bytesrw
11
+
brr)
12
+
(modes byte) ; js_of_ocaml requires bytecode
13
+
(modules
14
+
htmlrw_js_types
15
+
htmlrw_js_dom
16
+
htmlrw_js_annotate
17
+
htmlrw_js_ui
18
+
htmlrw_js))
19
+
20
+
; Standalone JavaScript file for direct browser use
21
+
; This compiles the library entry point to a .js file
22
+
(executable
23
+
(name htmlrw_js_main)
24
+
(libraries htmlrw_js)
25
+
(js_of_ocaml
26
+
(javascript_files))
27
+
(modes js)
28
+
(modules htmlrw_js_main))
29
+
30
+
; Web Worker for background validation
31
+
; Runs validation in a separate thread to avoid blocking the UI
32
+
(executable
33
+
(name htmlrw_js_worker)
34
+
(libraries html5rw htmlrw_check bytesrw brr)
35
+
(js_of_ocaml
36
+
(javascript_files))
37
+
(modes js)
38
+
(modules htmlrw_js_worker))
39
+
40
+
; Copy to nice filenames
41
+
(rule
42
+
(targets htmlrw.js)
43
+
(deps htmlrw_js_main.bc.js)
44
+
(action (copy %{deps} %{targets})))
45
+
46
+
(rule
47
+
(targets htmlrw-worker.js)
48
+
(deps htmlrw_js_worker.bc.js)
49
+
(action (copy %{deps} %{targets})))
+576
lib/js/htmlrw_js.ml
+576
lib/js/htmlrw_js.ml
···
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open Brr
7
+
open Htmlrw_js_types
8
+
9
+
let ensure_doctype html =
10
+
let lower = String.lowercase_ascii html in
11
+
if String.length lower >= 9 && String.sub lower 0 9 = "<!doctype" then
12
+
html
13
+
else
14
+
"<!DOCTYPE html>" ^ html
15
+
16
+
let validate_string raw_html =
17
+
let html = ensure_doctype raw_html in
18
+
try
19
+
let core_result = Htmlrw_check.check_string html in
20
+
let messages = List.map (fun msg ->
21
+
{ message = msg; element_ref = None }
22
+
) (Htmlrw_check.messages core_result) in
23
+
{ messages; core_result; source_element = None }
24
+
with exn ->
25
+
(* Return empty result with error message on parse failure *)
26
+
let error_msg = {
27
+
Htmlrw_check.severity = Htmlrw_check.Error;
28
+
text = Printf.sprintf "Parse error: %s" (Printexc.to_string exn);
29
+
error_code = Htmlrw_check.Conformance (`Misc `Multiple_h1);
30
+
location = None;
31
+
element = None;
32
+
attribute = None;
33
+
extract = None;
34
+
} in
35
+
let core_result = Htmlrw_check.check_string "" in
36
+
{ messages = [{ message = error_msg; element_ref = None }];
37
+
core_result;
38
+
source_element = None }
39
+
40
+
let validate_element el =
41
+
try
42
+
let el_map, html = Htmlrw_js_dom.create el in
43
+
let core_result = Htmlrw_check.check_string html in
44
+
let messages = List.map (fun msg ->
45
+
let element_ref =
46
+
match Htmlrw_js_dom.find_for_message el_map msg with
47
+
| Some browser_el ->
48
+
Some {
49
+
element = Some browser_el;
50
+
selector = Htmlrw_js_dom.selector_path browser_el;
51
+
}
52
+
| None ->
53
+
(* No direct mapping found - try to find by element name *)
54
+
match msg.Htmlrw_check.element with
55
+
| Some tag ->
56
+
let matches = Htmlrw_js_dom.filter_elements (fun e ->
57
+
String.lowercase_ascii (Jstr.to_string (El.tag_name e)) =
58
+
String.lowercase_ascii tag
59
+
) el in
60
+
(match matches with
61
+
| browser_el :: _ ->
62
+
Some {
63
+
element = Some browser_el;
64
+
selector = Htmlrw_js_dom.selector_path browser_el;
65
+
}
66
+
| [] -> None)
67
+
| None -> None
68
+
in
69
+
{ message = msg; element_ref }
70
+
) (Htmlrw_check.messages core_result) in
71
+
{ messages; core_result; source_element = Some el }
72
+
with exn ->
73
+
(* Return error result on parse failure *)
74
+
let error_msg = {
75
+
Htmlrw_check.severity = Htmlrw_check.Error;
76
+
text = Printf.sprintf "Parse error: %s" (Printexc.to_string exn);
77
+
error_code = Htmlrw_check.Conformance (`Misc `Multiple_h1);
78
+
location = None;
79
+
element = None;
80
+
attribute = None;
81
+
extract = None;
82
+
} in
83
+
let core_result = Htmlrw_check.check_string "" in
84
+
{ messages = [{ message = error_msg; element_ref = None }];
85
+
core_result;
86
+
source_element = Some el }
87
+
88
+
let validate_and_annotate ?(config = default_annotation_config) el =
89
+
let result = validate_element el in
90
+
(* Inject styles if not already present *)
91
+
let doc = El.document el in
92
+
let existing = El.find_first_by_selector (Jstr.v "[data-html5rw-styles]")
93
+
~root:(Document.head doc) in
94
+
if Option.is_none existing then
95
+
ignore (Htmlrw_js_annotate.inject_default_styles ~theme:`Auto);
96
+
(* Annotate elements *)
97
+
Htmlrw_js_annotate.annotate ~config ~root:el result.messages;
98
+
result
99
+
100
+
let validate_and_show_panel
101
+
?(annotation_config = default_annotation_config)
102
+
?(panel_config = default_panel_config)
103
+
el =
104
+
let result = validate_and_annotate ~config:annotation_config el in
105
+
(* Inject panel styles if not already present *)
106
+
let doc = El.document el in
107
+
let existing = El.find_first_by_selector (Jstr.v "[data-html5rw-panel-styles]")
108
+
~root:(Document.head doc) in
109
+
if Option.is_none existing then
110
+
ignore (Htmlrw_js_ui.inject_default_styles ~theme:panel_config.theme);
111
+
(* Create and show panel *)
112
+
ignore (Htmlrw_js_ui.create ~config:panel_config result);
113
+
result
114
+
115
+
let errors result =
116
+
List.filter (fun bm ->
117
+
bm.message.Htmlrw_check.severity = Htmlrw_check.Error
118
+
) result.messages
119
+
120
+
let warnings_only result =
121
+
List.filter (fun bm ->
122
+
bm.message.Htmlrw_check.severity = Htmlrw_check.Warning
123
+
) result.messages
124
+
125
+
let infos result =
126
+
List.filter (fun bm ->
127
+
bm.message.Htmlrw_check.severity = Htmlrw_check.Info
128
+
) result.messages
129
+
130
+
let has_errors result =
131
+
Htmlrw_check.has_errors result.core_result
132
+
133
+
let has_issues result =
134
+
Htmlrw_check.has_errors result.core_result ||
135
+
Htmlrw_check.has_warnings result.core_result
136
+
137
+
let message_count result =
138
+
List.length result.messages
139
+
140
+
let element_map result =
141
+
match result.source_element with
142
+
| Some el -> Some (fst (Htmlrw_js_dom.create el))
143
+
| None -> None
144
+
145
+
(* JavaScript API registration *)
146
+
147
+
let register_api_on obj =
148
+
(* validateString(html) -> result *)
149
+
Jv.set obj "validateString" (Jv.callback ~arity:1 (fun html ->
150
+
let html_str = Jv.to_string html in
151
+
let result = validate_string html_str in
152
+
result_to_jv result
153
+
));
154
+
155
+
(* validateElement(el) -> result *)
156
+
Jv.set obj "validateElement" (Jv.callback ~arity:1 (fun el_jv ->
157
+
let el = El.of_jv el_jv in
158
+
let result = validate_element el in
159
+
result_to_jv result
160
+
));
161
+
162
+
(* validateAndAnnotate(el, config?) -> result *)
163
+
Jv.set obj "validateAndAnnotate" (Jv.callback ~arity:2 (fun el_jv config_jv ->
164
+
let el = El.of_jv el_jv in
165
+
let config =
166
+
if Jv.is_none config_jv then
167
+
default_annotation_config
168
+
else
169
+
{
170
+
add_data_attrs = Jv.to_bool (Jv.get config_jv "addDataAttrs");
171
+
add_classes = Jv.to_bool (Jv.get config_jv "addClasses");
172
+
show_tooltips = Jv.to_bool (Jv.get config_jv "showTooltips");
173
+
tooltip_position = `Auto;
174
+
highlight_on_hover = Jv.to_bool (Jv.get config_jv "highlightOnHover");
175
+
}
176
+
in
177
+
let result = validate_and_annotate ~config el in
178
+
result_to_jv result
179
+
));
180
+
181
+
(* validateAndShowPanel(el, config?) -> result *)
182
+
Jv.set obj "validateAndShowPanel" (Jv.callback ~arity:2 (fun el_jv config_jv ->
183
+
let el = El.of_jv el_jv in
184
+
let annotation_config, panel_config =
185
+
if Jv.is_none config_jv then
186
+
default_annotation_config, default_panel_config
187
+
else
188
+
let ann_jv = Jv.get config_jv "annotation" in
189
+
let panel_jv = Jv.get config_jv "panel" in
190
+
let ann_config =
191
+
if Jv.is_none ann_jv then default_annotation_config
192
+
else {
193
+
add_data_attrs =
194
+
(let v = Jv.get ann_jv "addDataAttrs" in
195
+
if Jv.is_none v then true else Jv.to_bool v);
196
+
add_classes =
197
+
(let v = Jv.get ann_jv "addClasses" in
198
+
if Jv.is_none v then true else Jv.to_bool v);
199
+
show_tooltips =
200
+
(let v = Jv.get ann_jv "showTooltips" in
201
+
if Jv.is_none v then true else Jv.to_bool v);
202
+
tooltip_position = `Auto;
203
+
highlight_on_hover =
204
+
(let v = Jv.get ann_jv "highlightOnHover" in
205
+
if Jv.is_none v then true else Jv.to_bool v);
206
+
}
207
+
in
208
+
let panel_config =
209
+
if Jv.is_none panel_jv then default_panel_config
210
+
else {
211
+
initial_position =
212
+
(let v = Jv.get panel_jv "initialPosition" in
213
+
if Jv.is_none v then `TopRight
214
+
else match Jv.to_string v with
215
+
| "topRight" -> `TopRight
216
+
| "topLeft" -> `TopLeft
217
+
| "bottomRight" -> `BottomRight
218
+
| "bottomLeft" -> `BottomLeft
219
+
| _ -> `TopRight);
220
+
draggable =
221
+
(let v = Jv.get panel_jv "draggable" in
222
+
if Jv.is_none v then true else Jv.to_bool v);
223
+
resizable =
224
+
(let v = Jv.get panel_jv "resizable" in
225
+
if Jv.is_none v then true else Jv.to_bool v);
226
+
collapsible =
227
+
(let v = Jv.get panel_jv "collapsible" in
228
+
if Jv.is_none v then true else Jv.to_bool v);
229
+
start_collapsed =
230
+
(let v = Jv.get panel_jv "startCollapsed" in
231
+
if Jv.is_none v then false else Jv.to_bool v);
232
+
max_height =
233
+
(let v = Jv.get panel_jv "maxHeight" in
234
+
if Jv.is_none v then Some 400 else Some (Jv.to_int v));
235
+
group_by_severity =
236
+
(let v = Jv.get panel_jv "groupBySeverity" in
237
+
if Jv.is_none v then true else Jv.to_bool v);
238
+
click_to_highlight =
239
+
(let v = Jv.get panel_jv "clickToHighlight" in
240
+
if Jv.is_none v then true else Jv.to_bool v);
241
+
show_selector_path =
242
+
(let v = Jv.get panel_jv "showSelectorPath" in
243
+
if Jv.is_none v then true else Jv.to_bool v);
244
+
theme =
245
+
(let v = Jv.get panel_jv "theme" in
246
+
if Jv.is_none v then `Auto
247
+
else match Jv.to_string v with
248
+
| "light" -> `Light
249
+
| "dark" -> `Dark
250
+
| _ -> `Auto);
251
+
}
252
+
in
253
+
ann_config, panel_config
254
+
in
255
+
let result = validate_and_show_panel ~annotation_config ~panel_config el in
256
+
result_to_jv result
257
+
));
258
+
259
+
(* clearAnnotations(el) *)
260
+
Jv.set obj "clearAnnotations" (Jv.callback ~arity:1 (fun el_jv ->
261
+
let el = El.of_jv el_jv in
262
+
Htmlrw_js_annotate.clear el;
263
+
Jv.undefined
264
+
));
265
+
266
+
(* hidePanel() *)
267
+
Jv.set obj "hidePanel" (Jv.callback ~arity:0 (fun () ->
268
+
Htmlrw_js_ui.hide_current ();
269
+
Jv.undefined
270
+
));
271
+
272
+
(* showPanel(result, config?) *)
273
+
Jv.set obj "showPanel" (Jv.callback ~arity:2 (fun result_jv config_jv ->
274
+
(* This expects a previously returned result object *)
275
+
(* For now, just create a panel with the warnings from the result *)
276
+
let warnings_jv = Jv.get result_jv "warnings" in
277
+
let warnings = Jv.to_list (fun w_jv ->
278
+
let msg = {
279
+
Htmlrw_check.severity =
280
+
(match Jv.to_string (Jv.get w_jv "severity") with
281
+
| "error" -> Htmlrw_check.Error
282
+
| "warning" -> Htmlrw_check.Warning
283
+
| _ -> Htmlrw_check.Info);
284
+
text = Jv.to_string (Jv.get w_jv "message");
285
+
error_code = Htmlrw_check.Conformance (`Misc `Multiple_h1);
286
+
location = None;
287
+
element = None;
288
+
attribute = None;
289
+
extract = None;
290
+
} in
291
+
let element_ref =
292
+
let sel_jv = Jv.get w_jv "selector" in
293
+
let el_jv = Jv.get w_jv "element" in
294
+
if Jv.is_none sel_jv then None
295
+
else Some {
296
+
selector = Jv.to_string sel_jv;
297
+
element = if Jv.is_none el_jv then None else Some (El.of_jv el_jv);
298
+
}
299
+
in
300
+
{ message = msg; element_ref }
301
+
) warnings_jv in
302
+
let result = {
303
+
messages = warnings;
304
+
core_result = Htmlrw_check.check_string "";
305
+
source_element = None;
306
+
} in
307
+
let config =
308
+
if Jv.is_none config_jv then default_panel_config
309
+
else default_panel_config (* TODO: parse config *)
310
+
in
311
+
ignore (Htmlrw_js_ui.create ~config result);
312
+
Jv.undefined
313
+
))
314
+
315
+
(* Async/Worker support *)
316
+
317
+
let console_log msg =
318
+
ignore (Jv.call (Jv.get Jv.global "console") "log" [| Jv.of_string msg |])
319
+
320
+
let console_log_result prefix result =
321
+
let error_count = List.length (List.filter (fun bm ->
322
+
bm.message.Htmlrw_check.severity = Htmlrw_check.Error
323
+
) result.messages) in
324
+
let warning_count = List.length (List.filter (fun bm ->
325
+
bm.message.Htmlrw_check.severity = Htmlrw_check.Warning
326
+
) result.messages) in
327
+
let msg = Printf.sprintf "[html5rw] %s: %d errors, %d warnings, %d total issues"
328
+
prefix error_count warning_count (List.length result.messages) in
329
+
console_log msg
330
+
331
+
let _worker : Jv.t option ref = ref None
332
+
let _pending_callbacks : (int, Jv.t -> unit) Hashtbl.t = Hashtbl.create 16
333
+
let _next_id = ref 0
334
+
335
+
let init_worker worker_url =
336
+
console_log (Printf.sprintf "[html5rw] Initializing web worker from %s" worker_url);
337
+
let worker = Jv.new' (Jv.get Jv.global "Worker") [| Jv.of_string worker_url |] in
338
+
339
+
(* Error handler for worker-level errors *)
340
+
let error_handler = Jv.callback ~arity:1 (fun ev ->
341
+
let msg = Jv.get ev "message" in
342
+
let filename = Jv.get ev "filename" in
343
+
let lineno = Jv.get ev "lineno" in
344
+
console_log (Printf.sprintf "[html5rw] Worker error: %s at %s:%d"
345
+
(if Jv.is_undefined msg then "unknown" else Jv.to_string msg)
346
+
(if Jv.is_undefined filename then "unknown" else Jv.to_string filename)
347
+
(if Jv.is_undefined lineno then 0 else Jv.to_int lineno))
348
+
) in
349
+
ignore (Jv.call worker "addEventListener" [| Jv.of_string "error"; error_handler |]);
350
+
351
+
let handler = Jv.callback ~arity:1 (fun ev ->
352
+
let data = Jv.get ev "data" in
353
+
let id = Jv.get data "id" |> Jv.to_int in
354
+
let error_count = Jv.get data "errorCount" |> Jv.to_int in
355
+
let warning_count = Jv.get data "warningCount" |> Jv.to_int in
356
+
let total = Jv.get data "warnings" |> Jv.to_list (fun _ -> ()) |> List.length in
357
+
console_log (Printf.sprintf "[html5rw] Worker validation complete: %d errors, %d warnings, %d total issues"
358
+
error_count warning_count total);
359
+
match Hashtbl.find_opt _pending_callbacks id with
360
+
| Some callback ->
361
+
Hashtbl.remove _pending_callbacks id;
362
+
callback data
363
+
| None -> ()
364
+
) in
365
+
ignore (Jv.call worker "addEventListener" [| Jv.of_string "message"; handler |]);
366
+
_worker := Some worker;
367
+
console_log "[html5rw] Web worker ready";
368
+
worker
369
+
370
+
let validate_string_async ~callback html =
371
+
match !_worker with
372
+
| None -> failwith "Worker not initialized. Call html5rw.initWorker(url) first."
373
+
| Some worker ->
374
+
console_log (Printf.sprintf "[html5rw] Sending %d bytes to worker for validation..." (String.length html));
375
+
let id = !_next_id in
376
+
incr _next_id;
377
+
Hashtbl.add _pending_callbacks id callback;
378
+
let msg = Jv.obj [|
379
+
"id", Jv.of_int id;
380
+
"html", Jv.of_string html
381
+
|] in
382
+
ignore (Jv.call worker "postMessage" [| msg |])
383
+
384
+
let _validate_element_async ~callback el =
385
+
let html = Htmlrw_js_dom.outer_html el in
386
+
validate_string_async ~callback html
387
+
388
+
let validate_after_load callback el =
389
+
(* Use requestIdleCallback if available, otherwise setTimeout *)
390
+
console_log "[html5rw] Waiting for page load...";
391
+
let run () =
392
+
console_log "[html5rw] Starting validation...";
393
+
let result = validate_element el in
394
+
console_log_result "Validation complete" result;
395
+
callback result
396
+
in
397
+
let request_idle = Jv.get Jv.global "requestIdleCallback" in
398
+
if not (Jv.is_undefined request_idle) then
399
+
ignore (Jv.apply request_idle [| Jv.callback ~arity:1 (fun _ -> run ()) |])
400
+
else
401
+
ignore (Jv.call Jv.global "setTimeout" [|
402
+
Jv.callback ~arity:0 run;
403
+
Jv.of_int 0
404
+
|])
405
+
406
+
let validate_on_idle ?(timeout=5000) callback el =
407
+
(* Wait for page load, then use requestIdleCallback with timeout *)
408
+
console_log "[html5rw] Scheduling validation for idle time...";
409
+
let run_when_ready () =
410
+
let request_idle = Jv.get Jv.global "requestIdleCallback" in
411
+
if not (Jv.is_undefined request_idle) then begin
412
+
let opts = Jv.obj [| "timeout", Jv.of_int timeout |] in
413
+
ignore (Jv.call Jv.global "requestIdleCallback" [|
414
+
Jv.callback ~arity:1 (fun _ ->
415
+
console_log "[html5rw] Browser idle, starting validation...";
416
+
let result = validate_element el in
417
+
console_log_result "Validation complete" result;
418
+
callback result
419
+
);
420
+
opts
421
+
|])
422
+
end else begin
423
+
ignore (Jv.call Jv.global "setTimeout" [|
424
+
Jv.callback ~arity:0 (fun () ->
425
+
console_log "[html5rw] Starting validation...";
426
+
let result = validate_element el in
427
+
console_log_result "Validation complete" result;
428
+
callback result
429
+
);
430
+
Jv.of_int 100
431
+
|])
432
+
end
433
+
in
434
+
let ready_state = Jv.get (Jv.get Jv.global "document") "readyState" |> Jv.to_string in
435
+
if ready_state = "complete" then
436
+
run_when_ready ()
437
+
else
438
+
ignore (Jv.call Jv.global "addEventListener" [|
439
+
Jv.of_string "load";
440
+
Jv.callback ~arity:1 (fun _ -> run_when_ready ())
441
+
|])
442
+
443
+
let register_global_api () =
444
+
let api = Jv.obj [||] in
445
+
register_api_on api;
446
+
447
+
(* Add async functions *)
448
+
449
+
(* initWorker(url) - initialize web worker *)
450
+
Jv.set api "initWorker" (Jv.callback ~arity:1 (fun url_jv ->
451
+
let url = Jv.to_string url_jv in
452
+
init_worker url
453
+
));
454
+
455
+
(* validateStringAsync(html, callback) - validate in worker *)
456
+
Jv.set api "validateStringAsync" (Jv.callback ~arity:2 (fun html_jv callback_jv ->
457
+
let html = Jv.to_string html_jv in
458
+
let callback result = ignore (Jv.apply callback_jv [| result |]) in
459
+
validate_string_async ~callback html;
460
+
Jv.undefined
461
+
));
462
+
463
+
(* validateElementAsync(el, callback) - validate element in worker *)
464
+
Jv.set api "validateElementAsync" (Jv.callback ~arity:2 (fun el_jv callback_jv ->
465
+
let el = El.of_jv el_jv in
466
+
let html = Htmlrw_js_dom.outer_html el in
467
+
let callback result = ignore (Jv.apply callback_jv [| result |]) in
468
+
validate_string_async ~callback html;
469
+
Jv.undefined
470
+
));
471
+
472
+
(* validateAfterLoad(el, callback) - validate after page load *)
473
+
Jv.set api "validateAfterLoad" (Jv.callback ~arity:2 (fun el_jv callback_jv ->
474
+
let el = El.of_jv el_jv in
475
+
let callback result = ignore (Jv.apply callback_jv [| result_to_jv result |]) in
476
+
validate_after_load callback el;
477
+
Jv.undefined
478
+
));
479
+
480
+
(* validateOnIdle(el, callback, timeout?) - validate when browser is idle *)
481
+
Jv.set api "validateOnIdle" (Jv.callback ~arity:3 (fun el_jv callback_jv timeout_jv ->
482
+
let el = El.of_jv el_jv in
483
+
let timeout = if Jv.is_undefined timeout_jv then 5000 else Jv.to_int timeout_jv in
484
+
let callback result = ignore (Jv.apply callback_jv [| result_to_jv result |]) in
485
+
validate_on_idle ~timeout callback el;
486
+
Jv.undefined
487
+
));
488
+
489
+
(* validateAndShowPanelAsync(el, config?) - non-blocking panel display *)
490
+
Jv.set api "validateAndShowPanelAsync" (Jv.callback ~arity:2 (fun el_jv config_jv ->
491
+
let el = El.of_jv el_jv in
492
+
validate_on_idle ~timeout:3000 (fun result ->
493
+
let annotation_config, panel_config =
494
+
if Jv.is_none config_jv then
495
+
default_annotation_config, default_panel_config
496
+
else
497
+
(* Parse config same as validateAndShowPanel *)
498
+
default_annotation_config, default_panel_config
499
+
in
500
+
(* Inject styles if needed *)
501
+
let doc = El.document el in
502
+
let existing = El.find_first_by_selector (Jstr.v "[data-html5rw-styles]")
503
+
~root:(Document.head doc) in
504
+
if Option.is_none existing then
505
+
ignore (Htmlrw_js_annotate.inject_default_styles ~theme:`Auto);
506
+
let existing_panel = El.find_first_by_selector (Jstr.v "[data-html5rw-panel-styles]")
507
+
~root:(Document.head doc) in
508
+
if Option.is_none existing_panel then
509
+
ignore (Htmlrw_js_ui.inject_default_styles ~theme:panel_config.theme);
510
+
(* Annotate and show panel *)
511
+
Htmlrw_js_annotate.annotate ~config:annotation_config ~root:el result.messages;
512
+
ignore (Htmlrw_js_ui.create ~config:panel_config result)
513
+
) el;
514
+
Jv.undefined
515
+
));
516
+
517
+
(* showPanelFromWorkerResult(result) - show panel from worker validation result *)
518
+
Jv.set api "showPanelFromWorkerResult" (Jv.callback ~arity:1 (fun result_jv ->
519
+
console_log "[html5rw] Showing panel from worker result";
520
+
(* Convert worker result format to internal format *)
521
+
let warnings_jv = Jv.get result_jv "warnings" in
522
+
let messages = Jv.to_list (fun w_jv ->
523
+
let severity_str = Jv.to_string (Jv.get w_jv "severity") in
524
+
let msg = {
525
+
Htmlrw_check.severity =
526
+
(match severity_str with
527
+
| "error" -> Htmlrw_check.Error
528
+
| "warning" -> Htmlrw_check.Warning
529
+
| _ -> Htmlrw_check.Info);
530
+
text = Jv.to_string (Jv.get w_jv "message");
531
+
error_code = Htmlrw_check.Conformance (`Misc `Multiple_h1);
532
+
location = (
533
+
let line_jv = Jv.get w_jv "line" in
534
+
let col_jv = Jv.get w_jv "column" in
535
+
if Jv.is_undefined line_jv then None
536
+
else Some {
537
+
Htmlrw_check.line = Jv.to_int line_jv;
538
+
column = (if Jv.is_undefined col_jv then 1 else Jv.to_int col_jv);
539
+
end_line = None;
540
+
end_column = None;
541
+
system_id = None;
542
+
}
543
+
);
544
+
element = (
545
+
let el_jv = Jv.get w_jv "elementName" in
546
+
if Jv.is_undefined el_jv then None else Some (Jv.to_string el_jv)
547
+
);
548
+
attribute = (
549
+
let attr_jv = Jv.get w_jv "attribute" in
550
+
if Jv.is_undefined attr_jv then None else Some (Jv.to_string attr_jv)
551
+
);
552
+
extract = None;
553
+
} in
554
+
{ message = msg; element_ref = None }
555
+
) warnings_jv in
556
+
557
+
let result = {
558
+
messages;
559
+
core_result = Htmlrw_check.check_string "";
560
+
source_element = None;
561
+
} in
562
+
563
+
(* Inject panel styles *)
564
+
let doc = Document.of_jv (Jv.get Jv.global "document") in
565
+
let existing_panel = El.find_first_by_selector (Jstr.v "[data-html5rw-panel-styles]")
566
+
~root:(Document.head doc) in
567
+
if Option.is_none existing_panel then
568
+
ignore (Htmlrw_js_ui.inject_default_styles ~theme:`Auto);
569
+
570
+
(* Create and show panel *)
571
+
console_log (Printf.sprintf "[html5rw] Creating panel with %d messages" (List.length messages));
572
+
ignore (Htmlrw_js_ui.create ~config:default_panel_config result);
573
+
Jv.undefined
574
+
));
575
+
576
+
Jv.set Jv.global "html5rw" api
+153
lib/js/htmlrw_js.mli
+153
lib/js/htmlrw_js.mli
···
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** JavaScript API for HTML5 validation in the browser.
7
+
8
+
This module provides the main entry points for validating HTML in a
9
+
browser environment. It wraps the core {!Htmlrw_check} validator and
10
+
adds browser-specific functionality for element mapping and annotation.
11
+
12
+
{2 JavaScript Usage}
13
+
14
+
After loading the compiled JavaScript, the API is available on [window]:
15
+
16
+
{v
17
+
// Validate an element (recommended)
18
+
const result = html5rw.validateElement(document.body);
19
+
console.log(result.errorCount, "errors found");
20
+
21
+
// Validate with annotation
22
+
html5rw.validateAndAnnotate(document.body, {
23
+
showTooltips: true,
24
+
showPanel: true
25
+
});
26
+
27
+
// Validate a raw HTML string
28
+
const result = html5rw.validateString("<div><p>Hello</div>");
29
+
result.warnings.forEach(w => console.log(w.message));
30
+
v}
31
+
32
+
{2 OCaml Usage}
33
+
34
+
{[
35
+
let result = Htmlrw_js.validate_element (Brr.Document.body G.document) in
36
+
List.iter (fun bm ->
37
+
Brr.Console.log [Jstr.v bm.Htmlrw_js_types.message.text]
38
+
) result.messages
39
+
]} *)
40
+
41
+
42
+
open Htmlrw_js_types
43
+
44
+
45
+
(** {1 Validation} *)
46
+
47
+
(** Validate an HTML string.
48
+
49
+
This is the simplest form of validation. Since there's no source element,
50
+
the returned {!browser_message}s will not have element references.
51
+
52
+
{[
53
+
let result = validate_string "<html><body><img></body></html>" in
54
+
if Htmlrw_check.has_errors result.core_result then
55
+
(* handle errors *)
56
+
]} *)
57
+
val validate_string : string -> result
58
+
59
+
(** Validate a DOM element's HTML.
60
+
61
+
Serializes the element to HTML, validates it, and maps the results
62
+
back to the live DOM elements.
63
+
64
+
{[
65
+
let result = validate_element (Document.body G.document) in
66
+
List.iter (fun bm ->
67
+
match bm.element_ref with
68
+
| Some { element = Some el; _ } ->
69
+
El.set_class (Jstr.v "has-error") true el
70
+
| _ -> ()
71
+
) result.messages
72
+
]} *)
73
+
val validate_element : Brr.El.t -> result
74
+
75
+
76
+
(** {1 Validation with Annotation}
77
+
78
+
These functions validate and immediately annotate the DOM with results. *)
79
+
80
+
(** Validate and annotate an element.
81
+
82
+
This combines validation with DOM annotation. The element and its
83
+
descendants are annotated with data attributes, classes, and optionally
84
+
tooltips based on the validation results.
85
+
86
+
@param config Annotation configuration. Defaults to {!default_annotation_config}. *)
87
+
val validate_and_annotate :
88
+
?config:annotation_config -> Brr.El.t -> result
89
+
90
+
(** Validate, annotate, and show the warning panel.
91
+
92
+
The all-in-one function for browser validation with full UI.
93
+
94
+
@param annotation_config How to annotate elements.
95
+
@param panel_config How to display the warning panel. *)
96
+
val validate_and_show_panel :
97
+
?annotation_config:annotation_config ->
98
+
?panel_config:panel_config ->
99
+
Brr.El.t ->
100
+
result
101
+
102
+
103
+
(** {1 Result Inspection} *)
104
+
105
+
(** Get messages filtered by severity. *)
106
+
val errors : result -> browser_message list
107
+
val warnings_only : result -> browser_message list
108
+
val infos : result -> browser_message list
109
+
110
+
(** Check if there are any errors. *)
111
+
val has_errors : result -> bool
112
+
113
+
(** Check if there are any warnings or errors. *)
114
+
val has_issues : result -> bool
115
+
116
+
(** Get total count of all messages. *)
117
+
val message_count : result -> int
118
+
119
+
120
+
(** {1 JavaScript Export}
121
+
122
+
These functions register the API on the JavaScript global object. *)
123
+
124
+
(** Register the validation API on [window.html5rw].
125
+
126
+
Call this from your main entry point to expose the JavaScript API:
127
+
128
+
{[
129
+
let () = Htmlrw_js.register_global_api ()
130
+
]}
131
+
132
+
This exposes:
133
+
- [html5rw.validateString(html)] -> result object
134
+
- [html5rw.validateElement(el)] -> result object
135
+
- [html5rw.validateAndAnnotate(el, config?)] -> result object
136
+
- [html5rw.validateAndShowPanel(el, config?)] -> result object
137
+
- [html5rw.clearAnnotations(el)] -> void
138
+
- [html5rw.hidePanel()] -> void *)
139
+
val register_global_api : unit -> unit
140
+
141
+
(** Register the API on a custom object instead of [window.html5rw].
142
+
143
+
Useful for module bundlers or when you want to control the namespace. *)
144
+
val register_api_on : Jv.t -> unit
145
+
146
+
147
+
(** {1 Low-level Access} *)
148
+
149
+
(** Access the element map from a validation result.
150
+
151
+
Useful for custom element lookup logic. Returns [None] if the result
152
+
was from {!validate_string} (no source element). *)
153
+
val element_map : result -> Htmlrw_js_dom.t option
+340
lib/js/htmlrw_js_annotate.ml
+340
lib/js/htmlrw_js_annotate.ml
···
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open Brr
7
+
open Htmlrw_js_types
8
+
9
+
module 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"
14
+
end
15
+
16
+
module 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"
24
+
end
25
+
26
+
type tooltip = {
27
+
container : El.t;
28
+
_target : El.t;
29
+
}
30
+
31
+
let 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
+
36
+
let 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
+
49
+
let 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
+
119
+
and 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
+
168
+
let show_tooltip t =
169
+
El.set_class Css_class.tooltip_visible true t.container
170
+
171
+
let hide_tooltip t =
172
+
El.set_class Css_class.tooltip_visible false t.container
173
+
174
+
let remove_tooltip t =
175
+
El.remove t.container
176
+
177
+
let 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
+
183
+
let 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
+
194
+
let clear root =
195
+
Htmlrw_js_dom.iter_elements clear_element root;
196
+
List.iter remove_tooltip (tooltips_in root)
197
+
198
+
let 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
+
207
+
let unhighlight_element el =
208
+
El.set_class Css_class.highlighted false el
209
+
210
+
let _highlighted_elements : El.t list ref = ref []
211
+
212
+
let clear_highlights () =
213
+
List.iter unhighlight_element !_highlighted_elements;
214
+
_highlighted_elements := []
215
+
216
+
let 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
+
339
+
let remove_injected_styles style_el =
340
+
El.remove style_el
+166
lib/js/htmlrw_js_annotate.mli
+166
lib/js/htmlrw_js_annotate.mli
···
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** DOM annotation for validation warnings.
7
+
8
+
This module applies validation results to the live DOM by adding
9
+
data attributes, CSS classes, and tooltip overlays to elements
10
+
that have warnings. *)
11
+
12
+
open Htmlrw_js_types
13
+
14
+
15
+
(** {1 Annotation} *)
16
+
17
+
(** Annotate elements in a subtree based on validation results.
18
+
19
+
For each message with an element reference, this function:
20
+
1. Adds data attributes ([data-html5rw-severity], etc.) if configured
21
+
2. Adds CSS classes ([html5rw-error], etc.) if configured
22
+
3. Creates tooltip elements if configured
23
+
24
+
@param config Annotation configuration.
25
+
@param root The root element to annotate within.
26
+
@param messages The validation messages with element references. *)
27
+
val annotate :
28
+
config:annotation_config ->
29
+
root:Brr.El.t ->
30
+
browser_message list ->
31
+
unit
32
+
33
+
(** Annotate a single element with a message.
34
+
35
+
Lower-level function for custom annotation logic. *)
36
+
val annotate_element :
37
+
config:annotation_config ->
38
+
Brr.El.t ->
39
+
Htmlrw_check.message ->
40
+
unit
41
+
42
+
43
+
(** {1 Clearing Annotations} *)
44
+
45
+
(** Remove all annotations from a subtree.
46
+
47
+
This removes:
48
+
- All [data-html5rw-*] attributes
49
+
- All [html5rw-*] CSS classes
50
+
- All tooltip elements created by this module *)
51
+
val clear : Brr.El.t -> unit
52
+
53
+
(** Remove annotations from a single element (not descendants). *)
54
+
val clear_element : Brr.El.t -> unit
55
+
56
+
57
+
(** {1 Tooltips} *)
58
+
59
+
(** Tooltip state for an element. *)
60
+
type tooltip
61
+
62
+
(** Create a tooltip for an element.
63
+
64
+
The tooltip is not immediately visible; it appears on hover
65
+
if CSS is set up correctly, or can be shown programmatically.
66
+
67
+
@param position Where to position the tooltip.
68
+
@param el The element to attach the tooltip to.
69
+
@param messages All messages for this element (may be multiple). *)
70
+
val create_tooltip :
71
+
position:[ `Above | `Below | `Auto ] ->
72
+
Brr.El.t ->
73
+
Htmlrw_check.message list ->
74
+
tooltip
75
+
76
+
(** Show a tooltip immediately. *)
77
+
val show_tooltip : tooltip -> unit
78
+
79
+
(** Hide a tooltip. *)
80
+
val hide_tooltip : tooltip -> unit
81
+
82
+
(** Remove a tooltip from the DOM. *)
83
+
val remove_tooltip : tooltip -> unit
84
+
85
+
(** Get all tooltips created in a subtree. *)
86
+
val tooltips_in : Brr.El.t -> tooltip list
87
+
88
+
89
+
(** {1 Highlighting} *)
90
+
91
+
(** Highlight an element (for click-to-navigate in the panel).
92
+
93
+
Adds a temporary visual highlight and scrolls the element into view. *)
94
+
val highlight_element : Brr.El.t -> unit
95
+
96
+
(** Remove highlight from an element. *)
97
+
val unhighlight_element : Brr.El.t -> unit
98
+
99
+
(** Remove all highlights. *)
100
+
val clear_highlights : unit -> unit
101
+
102
+
103
+
(** {1 Data Attributes}
104
+
105
+
Constants for the data attributes used by annotation. *)
106
+
107
+
module Data_attr : sig
108
+
(** [data-html5rw-severity] - "error", "warning", or "info" *)
109
+
val severity : Jstr.t
110
+
111
+
(** [data-html5rw-message] - The warning message text *)
112
+
val message : Jstr.t
113
+
114
+
(** [data-html5rw-code] - The error code *)
115
+
val code : Jstr.t
116
+
117
+
(** [data-html5rw-count] - Number of warnings on this element *)
118
+
val count : Jstr.t
119
+
end
120
+
121
+
122
+
(** {1 CSS Classes}
123
+
124
+
Constants for the CSS classes used by annotation. *)
125
+
126
+
module Css_class : sig
127
+
(** [html5rw-error] - Element has at least one error *)
128
+
val error : Jstr.t
129
+
130
+
(** [html5rw-warning] - Element has warnings but no errors *)
131
+
val warning : Jstr.t
132
+
133
+
(** [html5rw-info] - Element has only info messages *)
134
+
val info : Jstr.t
135
+
136
+
(** [html5rw-has-issues] - Element has any validation messages *)
137
+
val has_issues : Jstr.t
138
+
139
+
(** [html5rw-highlighted] - Element is currently highlighted *)
140
+
val highlighted : Jstr.t
141
+
142
+
(** [html5rw-tooltip] - The tooltip container element *)
143
+
val tooltip : Jstr.t
144
+
145
+
(** [html5rw-tooltip-visible] - Tooltip is currently visible *)
146
+
val tooltip_visible : Jstr.t
147
+
end
148
+
149
+
150
+
(** {1 CSS Injection}
151
+
152
+
Optionally inject default styles for annotations. *)
153
+
154
+
(** Inject default CSS styles for annotations and tooltips.
155
+
156
+
Adds a [<style>] element to the document head with styles for:
157
+
- Annotation classes (outlines, backgrounds)
158
+
- Tooltip positioning and appearance
159
+
- Highlight animation
160
+
161
+
@param theme Light or dark theme. [`Auto] uses [prefers-color-scheme].
162
+
@return The injected style element (can be removed later). *)
163
+
val inject_default_styles : theme:[ `Light | `Dark | `Auto ] -> Brr.El.t
164
+
165
+
(** Remove the injected style element. *)
166
+
val remove_injected_styles : Brr.El.t -> unit
+208
lib/js/htmlrw_js_dom.ml
+208
lib/js/htmlrw_js_dom.ml
···
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open Brr
7
+
8
+
(* Helper to compare elements using JavaScript strict equality *)
9
+
let el_equal a b =
10
+
Jv.strict_equal (El.to_jv a) (El.to_jv b)
11
+
12
+
(* A location-keyed map for finding elements by line/column *)
13
+
module LocMap = Map.Make(struct
14
+
type t = int * int
15
+
let compare = compare
16
+
end)
17
+
18
+
type t = {
19
+
root : El.t;
20
+
html_source : string;
21
+
loc_to_el : El.t LocMap.t;
22
+
(* Mapping from (line, column) to browser elements *)
23
+
}
24
+
25
+
let outer_html el =
26
+
Jstr.to_string (Jv.get (El.to_jv el) "outerHTML" |> Jv.to_jstr)
27
+
28
+
let inner_html el =
29
+
Jstr.to_string (Jv.get (El.to_jv el) "innerHTML" |> Jv.to_jstr)
30
+
31
+
let iter_elements f root =
32
+
let rec walk el =
33
+
f el;
34
+
List.iter walk (El.children ~only_els:true el)
35
+
in
36
+
walk root
37
+
38
+
let fold_elements f acc root =
39
+
let rec walk acc el =
40
+
let acc = f acc el in
41
+
List.fold_left walk acc (El.children ~only_els:true el)
42
+
in
43
+
walk acc root
44
+
45
+
let filter_elements pred root =
46
+
fold_elements (fun acc el ->
47
+
if pred el then el :: acc else acc
48
+
) [] root |> List.rev
49
+
50
+
(* Build element map by walking browser DOM and parsed DOM in parallel *)
51
+
let create root =
52
+
let raw_html = outer_html root in
53
+
(* Prepend DOCTYPE if not present - outerHTML doesn't include it *)
54
+
let html =
55
+
let lower = String.lowercase_ascii raw_html in
56
+
if String.length lower >= 9 && String.sub lower 0 9 = "<!doctype" then
57
+
raw_html
58
+
else
59
+
"<!DOCTYPE html>" ^ raw_html
60
+
in
61
+
62
+
(* Parse the HTML to get a tree with locations *)
63
+
let reader = Bytesrw.Bytes.Reader.of_string html in
64
+
let parsed = Html5rw.parse ~collect_errors:false reader in
65
+
66
+
(* Walk both trees in parallel to build the mapping.
67
+
Browser elements are in document order, and so are Html5rw nodes. *)
68
+
let browser_elements = fold_elements (fun acc el -> el :: acc) [] root |> List.rev in
69
+
70
+
(* Extract elements from Html5rw DOM in document order *)
71
+
let rec extract_html5rw_elements acc node =
72
+
if Html5rw.is_element node then
73
+
let children = node.Html5rw.Dom.children in
74
+
let acc = node :: acc in
75
+
List.fold_left extract_html5rw_elements acc children
76
+
else
77
+
let children = node.Html5rw.Dom.children in
78
+
List.fold_left extract_html5rw_elements acc children
79
+
in
80
+
let html5rw_elements = extract_html5rw_elements [] (Html5rw.root parsed) |> List.rev in
81
+
82
+
(* Build the location map by matching elements *)
83
+
let loc_to_el =
84
+
let rec match_elements loc_map browser_els html5rw_els =
85
+
match browser_els, html5rw_els with
86
+
| [], _ | _, [] -> loc_map
87
+
| b_el :: b_rest, h_el :: h_rest ->
88
+
let b_tag = String.lowercase_ascii (Jstr.to_string (El.tag_name b_el)) in
89
+
let h_tag = String.lowercase_ascii h_el.Html5rw.Dom.name in
90
+
if b_tag = h_tag then
91
+
(* Tags match - record the mapping if we have a location *)
92
+
let loc_map =
93
+
match h_el.Html5rw.Dom.location with
94
+
| Some loc -> LocMap.add (loc.line, loc.column) b_el loc_map
95
+
| None -> loc_map
96
+
in
97
+
match_elements loc_map b_rest h_rest
98
+
else
99
+
(* Tags don't match - try to resync by skipping one side *)
100
+
(* This handles cases where browser might have implicit elements *)
101
+
match_elements loc_map b_rest html5rw_els
102
+
in
103
+
match_elements LocMap.empty browser_elements html5rw_elements
104
+
in
105
+
106
+
{ root; html_source = html; loc_to_el }, html
107
+
108
+
let find_by_location t ~line ~column =
109
+
LocMap.find_opt (line, column) t.loc_to_el
110
+
111
+
let find_by_location_and_tag t ~line ~column ~tag =
112
+
match LocMap.find_opt (line, column) t.loc_to_el with
113
+
| Some el when String.lowercase_ascii (Jstr.to_string (El.tag_name el)) =
114
+
String.lowercase_ascii tag ->
115
+
Some el
116
+
| _ -> None
117
+
118
+
let find_for_message t msg =
119
+
(* Try to find element by location first *)
120
+
match msg.Htmlrw_check.location with
121
+
| Some loc ->
122
+
(match msg.Htmlrw_check.element with
123
+
| Some tag -> find_by_location_and_tag t ~line:loc.line ~column:loc.column ~tag
124
+
| None -> find_by_location t ~line:loc.line ~column:loc.column)
125
+
| None ->
126
+
(* No location - try to find by element name if we have one *)
127
+
match msg.Htmlrw_check.element with
128
+
| Some tag ->
129
+
(* Find first element with this tag *)
130
+
let matches = filter_elements (fun el ->
131
+
String.lowercase_ascii (Jstr.to_string (El.tag_name el)) =
132
+
String.lowercase_ascii tag
133
+
) t.root in
134
+
(match matches with
135
+
| el :: _ -> Some el
136
+
| [] -> None)
137
+
| None -> None
138
+
139
+
let html_source t = t.html_source
140
+
141
+
let root_element t = t.root
142
+
143
+
let selector_path ?root el =
144
+
let stop_at = match root with
145
+
| Some r -> Some r
146
+
| None -> None
147
+
in
148
+
let rec build_path el acc =
149
+
(* Stop if we've reached the root *)
150
+
let should_stop = match stop_at with
151
+
| Some r -> el_equal el r
152
+
| None -> String.lowercase_ascii (Jstr.to_string (El.tag_name el)) = "body"
153
+
in
154
+
if should_stop then
155
+
acc
156
+
else
157
+
let tag = String.lowercase_ascii (Jstr.to_string (El.tag_name el)) in
158
+
let segment =
159
+
match El.parent el with
160
+
| None -> tag
161
+
| Some parent ->
162
+
let siblings = El.children ~only_els:true parent in
163
+
let same_tag = List.filter (fun sib ->
164
+
String.lowercase_ascii (Jstr.to_string (El.tag_name sib)) = tag
165
+
) siblings in
166
+
if List.length same_tag <= 1 then
167
+
tag
168
+
else
169
+
let idx =
170
+
let rec find_idx i = function
171
+
| [] -> 1
172
+
| sib :: rest ->
173
+
if el_equal sib el then i
174
+
else find_idx (i + 1) rest
175
+
in
176
+
find_idx 1 same_tag
177
+
in
178
+
Printf.sprintf "%s:nth-of-type(%d)" tag idx
179
+
in
180
+
let new_acc = segment :: acc in
181
+
match El.parent el with
182
+
| None -> new_acc
183
+
| Some parent -> build_path parent new_acc
184
+
in
185
+
String.concat " > " (build_path el [])
186
+
187
+
let short_selector ?root el =
188
+
(* Try ID first *)
189
+
match El.at (Jstr.v "id") el with
190
+
| Some id when not (Jstr.is_empty id) ->
191
+
"#" ^ Jstr.to_string id
192
+
| _ ->
193
+
(* Try parent ID + short path *)
194
+
let rec find_id_ancestor el depth =
195
+
if depth > 3 then None
196
+
else match El.parent el with
197
+
| None -> None
198
+
| Some parent ->
199
+
match El.at (Jstr.v "id") parent with
200
+
| Some id when not (Jstr.is_empty id) -> Some (parent, id)
201
+
| _ -> find_id_ancestor parent (depth + 1)
202
+
in
203
+
match find_id_ancestor el 0 with
204
+
| Some (ancestor, id) ->
205
+
let path = selector_path ~root:ancestor el in
206
+
"#" ^ Jstr.to_string id ^ " > " ^ path
207
+
| None ->
208
+
selector_path ?root el
+111
lib/js/htmlrw_js_dom.mli
+111
lib/js/htmlrw_js_dom.mli
···
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Browser DOM utilities for mapping validation results to live elements.
7
+
8
+
This module bridges the gap between HTML string validation (which produces
9
+
line/column locations) and live DOM manipulation (which needs element
10
+
references). It builds mappings between source positions and DOM elements
11
+
by walking both the serialized HTML and the DOM tree in parallel. *)
12
+
13
+
14
+
(** {1 Element Mapping}
15
+
16
+
When we validate [element.outerHTML], we get messages with line/column
17
+
positions. To annotate the original DOM, we need to map those positions
18
+
back to the live elements. *)
19
+
20
+
(** An element map associates source locations with DOM elements. *)
21
+
type t
22
+
23
+
(** Build an element map by walking a DOM element and its serialization.
24
+
25
+
This function:
26
+
1. Serializes the element to HTML via [outerHTML]
27
+
2. Parses that HTML with Html5rw to get the parse tree with locations
28
+
3. Walks both trees in parallel to build a bidirectional mapping
29
+
30
+
@param root The DOM element to map.
31
+
@return The element map and the HTML source string. *)
32
+
val create : Brr.El.t -> t * string
33
+
34
+
(** Find the DOM element corresponding to a source location.
35
+
36
+
@param line 1-indexed line number
37
+
@param column 1-indexed column number
38
+
@return The element at or containing that position, or [None]. *)
39
+
val find_by_location : t -> line:int -> column:int -> Brr.El.t option
40
+
41
+
(** Find the DOM element corresponding to an element name at a location.
42
+
43
+
More precise than {!find_by_location} when the validator provides
44
+
the element name along with the location.
45
+
46
+
@param line 1-indexed line number
47
+
@param column 1-indexed column number
48
+
@param tag Element tag name (lowercase)
49
+
@return The matching element, or [None]. *)
50
+
val find_by_location_and_tag :
51
+
t -> line:int -> column:int -> tag:string -> Brr.El.t option
52
+
53
+
(** Find the DOM element for a validation message.
54
+
55
+
Uses the message's location and element fields to find the best match.
56
+
This is the primary function used by the annotation system. *)
57
+
val find_for_message : t -> Htmlrw_check.message -> Brr.El.t option
58
+
59
+
(** The HTML source string that was used to build this map. *)
60
+
val html_source : t -> string
61
+
62
+
(** The root element this map was built from. *)
63
+
val root_element : t -> Brr.El.t
64
+
65
+
66
+
(** {1 CSS Selector Generation} *)
67
+
68
+
(** Build a CSS selector path that uniquely identifies an element.
69
+
70
+
The selector uses child combinators and [:nth-child] to be specific:
71
+
["body > div.main:nth-child(2) > p > img:nth-child(1)"]
72
+
73
+
@param root Optional root element; selector will be relative to this.
74
+
Defaults to [document.body].
75
+
@param el The element to build a selector for.
76
+
@return A CSS selector string. *)
77
+
val selector_path : ?root:Brr.El.t -> Brr.El.t -> string
78
+
79
+
(** Build a shorter selector using IDs and classes when available.
80
+
81
+
Tries to find the shortest unique selector:
82
+
1. If element has an ID: ["#myId"]
83
+
2. If parent has ID: ["#parentId > .myClass"]
84
+
3. Falls back to full path from {!selector_path}
85
+
86
+
@param root Optional root element.
87
+
@param el The element to build a selector for. *)
88
+
val short_selector : ?root:Brr.El.t -> Brr.El.t -> string
89
+
90
+
91
+
(** {1 DOM Iteration} *)
92
+
93
+
(** Iterate over all elements in document order (depth-first pre-order). *)
94
+
val iter_elements : (Brr.El.t -> unit) -> Brr.El.t -> unit
95
+
96
+
(** Fold over all elements in document order. *)
97
+
val fold_elements : ('a -> Brr.El.t -> 'a) -> 'a -> Brr.El.t -> 'a
98
+
99
+
(** Find all elements matching a predicate. *)
100
+
val filter_elements : (Brr.El.t -> bool) -> Brr.El.t -> Brr.El.t list
101
+
102
+
103
+
(** {1 Serialization} *)
104
+
105
+
(** Get the outer HTML of an element.
106
+
107
+
This is a wrapper around the browser's [outerHTML] property. *)
108
+
val outer_html : Brr.El.t -> string
109
+
110
+
(** Get the inner HTML of an element. *)
111
+
val inner_html : Brr.El.t -> string
+9
lib/js/htmlrw_js_main.ml
+9
lib/js/htmlrw_js_main.ml
···
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(* Entry point for the standalone JavaScript build.
7
+
This registers the API on window.html5rw when the script loads. *)
8
+
9
+
let () = Htmlrw_js.register_global_api ()
+56
lib/js/htmlrw_js_main.mli
+56
lib/js/htmlrw_js_main.mli
···
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Entry point for the standalone JavaScript build.
7
+
8
+
This module is compiled to [htmlrw.js] and automatically registers
9
+
the validation API on [window.html5rw] when loaded.
10
+
11
+
{2 Browser Usage}
12
+
13
+
{v
14
+
<script src="htmlrw.js"></script>
15
+
<script>
16
+
// API is available immediately after loading
17
+
const result = html5rw.validateElement(document.body);
18
+
19
+
if (result.errorCount > 0) {
20
+
console.log("Found", result.errorCount, "errors");
21
+
22
+
// Show the warning panel
23
+
html5rw.showPanel(result);
24
+
}
25
+
</script>
26
+
v}
27
+
28
+
{2 Module Bundler Usage}
29
+
30
+
If using a bundler that supports CommonJS or ES modules, you can
31
+
import the module instead:
32
+
33
+
{v
34
+
import { validateElement, showPanel } from './htmlrw.js';
35
+
36
+
const result = validateElement(document.body);
37
+
if (result.hasErrors) {
38
+
showPanel(result);
39
+
}
40
+
v}
41
+
42
+
The module exports are set up to work with both import styles.
43
+
44
+
{2 API Reference}
45
+
46
+
See {!Htmlrw_js} for the full API documentation. The JavaScript API
47
+
mirrors the OCaml API with camelCase naming:
48
+
49
+
- [html5rw.validateString(html)] - Validate an HTML string
50
+
- [html5rw.validateElement(el)] - Validate a DOM element
51
+
- [html5rw.validateAndAnnotate(el, config?)] - Validate and annotate
52
+
- [html5rw.showPanel(result, config?)] - Show the warning panel
53
+
- [html5rw.hidePanel()] - Hide the warning panel
54
+
- [html5rw.clearAnnotations(el)] - Clear annotations from an element *)
55
+
56
+
(* This module has no values; its side effect is registering the API *)
+172
lib/js/htmlrw_js_types.ml
+172
lib/js/htmlrw_js_types.ml
···
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open Brr
7
+
8
+
(* Helper to compare elements using JavaScript strict equality *)
9
+
let el_equal a b =
10
+
Jv.strict_equal (El.to_jv a) (El.to_jv b)
11
+
12
+
type element_ref = {
13
+
element : El.t option;
14
+
selector : string;
15
+
}
16
+
17
+
type browser_message = {
18
+
message : Htmlrw_check.message;
19
+
element_ref : element_ref option;
20
+
}
21
+
22
+
type result = {
23
+
messages : browser_message list;
24
+
core_result : Htmlrw_check.t;
25
+
source_element : El.t option;
26
+
}
27
+
28
+
type annotation_config = {
29
+
add_data_attrs : bool;
30
+
add_classes : bool;
31
+
show_tooltips : bool;
32
+
tooltip_position : [ `Above | `Below | `Auto ];
33
+
highlight_on_hover : bool;
34
+
}
35
+
36
+
let default_annotation_config = {
37
+
add_data_attrs = true;
38
+
add_classes = true;
39
+
show_tooltips = true;
40
+
tooltip_position = `Auto;
41
+
highlight_on_hover = true;
42
+
}
43
+
44
+
type panel_config = {
45
+
initial_position : [ `TopRight | `TopLeft | `BottomRight | `BottomLeft | `Custom of int * int ];
46
+
draggable : bool;
47
+
resizable : bool;
48
+
collapsible : bool;
49
+
start_collapsed : bool;
50
+
max_height : int option;
51
+
group_by_severity : bool;
52
+
click_to_highlight : bool;
53
+
show_selector_path : bool;
54
+
theme : [ `Light | `Dark | `Auto ];
55
+
}
56
+
57
+
let default_panel_config = {
58
+
initial_position = `TopRight;
59
+
draggable = true;
60
+
resizable = true;
61
+
collapsible = true;
62
+
start_collapsed = false;
63
+
max_height = Some 400;
64
+
group_by_severity = true;
65
+
click_to_highlight = true;
66
+
show_selector_path = true;
67
+
theme = `Auto;
68
+
}
69
+
70
+
let selector_of_element el =
71
+
let rec build_path el acc =
72
+
let tag = Jstr.to_string (El.tag_name el) in
73
+
let id = El.at (Jstr.v "id") el in
74
+
let segment =
75
+
match id with
76
+
| Some id_val when not (Jstr.is_empty id_val) ->
77
+
(* If element has an ID, use it directly *)
78
+
"#" ^ Jstr.to_string id_val
79
+
| _ ->
80
+
(* Otherwise use tag name with nth-child if needed *)
81
+
match El.parent el with
82
+
| None -> tag
83
+
| Some parent ->
84
+
let siblings = El.children ~only_els:true parent in
85
+
let same_tag = List.filter (fun sib ->
86
+
String.lowercase_ascii (Jstr.to_string (El.tag_name sib)) =
87
+
String.lowercase_ascii tag
88
+
) siblings in
89
+
if List.length same_tag <= 1 then
90
+
tag
91
+
else
92
+
let idx =
93
+
let rec find_idx i = function
94
+
| [] -> 1
95
+
| sib :: rest ->
96
+
if el_equal sib el then i
97
+
else find_idx (i + 1) rest
98
+
in
99
+
find_idx 1 same_tag
100
+
in
101
+
Printf.sprintf "%s:nth-of-type(%d)" tag idx
102
+
in
103
+
let new_acc = segment :: acc in
104
+
(* Stop if we hit an ID (absolute reference) or no parent *)
105
+
if String.length segment > 0 && segment.[0] = '#' then
106
+
new_acc
107
+
else
108
+
match El.parent el with
109
+
| None -> new_acc
110
+
| Some parent ->
111
+
if String.lowercase_ascii (Jstr.to_string (El.tag_name parent)) = "html" then
112
+
new_acc
113
+
else
114
+
build_path parent new_acc
115
+
in
116
+
String.concat " > " (build_path el [])
117
+
118
+
let browser_message_to_jv bm =
119
+
let msg = bm.message in
120
+
let obj = Jv.obj [||] in
121
+
Jv.set obj "severity" (Jv.of_string (Htmlrw_check.severity_to_string msg.severity));
122
+
Jv.set obj "message" (Jv.of_string msg.text);
123
+
Jv.set obj "errorCode" (Jv.of_string (Htmlrw_check.error_code_to_string msg.error_code));
124
+
(match msg.element with
125
+
| Some el -> Jv.set obj "elementName" (Jv.of_string el)
126
+
| None -> ());
127
+
(match msg.attribute with
128
+
| Some attr -> Jv.set obj "attribute" (Jv.of_string attr)
129
+
| None -> ());
130
+
(match msg.location with
131
+
| Some loc ->
132
+
Jv.set obj "line" (Jv.of_int loc.line);
133
+
Jv.set obj "column" (Jv.of_int loc.column)
134
+
| None -> ());
135
+
(match bm.element_ref with
136
+
| Some ref ->
137
+
Jv.set obj "selector" (Jv.of_string ref.selector);
138
+
(match ref.element with
139
+
| Some el -> Jv.set obj "element" (El.to_jv el)
140
+
| None -> ())
141
+
| None -> ());
142
+
obj
143
+
144
+
let result_to_jv result =
145
+
let warnings_arr =
146
+
Jv.of_list browser_message_to_jv result.messages
147
+
in
148
+
let error_count =
149
+
List.length (List.filter (fun bm ->
150
+
bm.message.severity = Htmlrw_check.Error
151
+
) result.messages)
152
+
in
153
+
let warning_count =
154
+
List.length (List.filter (fun bm ->
155
+
bm.message.severity = Htmlrw_check.Warning
156
+
) result.messages)
157
+
in
158
+
let info_count =
159
+
List.length (List.filter (fun bm ->
160
+
bm.message.severity = Htmlrw_check.Info
161
+
) result.messages)
162
+
in
163
+
let obj = Jv.obj [||] in
164
+
Jv.set obj "warnings" warnings_arr;
165
+
Jv.set obj "errorCount" (Jv.of_int error_count);
166
+
Jv.set obj "warningCount" (Jv.of_int warning_count);
167
+
Jv.set obj "infoCount" (Jv.of_int info_count);
168
+
Jv.set obj "hasErrors" (Jv.of_bool (error_count > 0));
169
+
(match result.source_element with
170
+
| Some el -> Jv.set obj "sourceElement" (El.to_jv el)
171
+
| None -> ());
172
+
obj
+125
lib/js/htmlrw_js_types.mli
+125
lib/js/htmlrw_js_types.mli
···
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Browser-specific types for HTML5rw JavaScript validation.
7
+
8
+
Core validation types ({!Htmlrw_check.severity}, {!Htmlrw_check.message}, etc.)
9
+
are reused from the main library. This module adds only the browser-specific
10
+
types needed for DOM element references, annotation, and UI. *)
11
+
12
+
13
+
(** {1 Element References}
14
+
15
+
Since we validate HTML strings but want to annotate live DOM elements,
16
+
we need to map validation messages back to browser elements. *)
17
+
18
+
(** A reference to a DOM element, providing both programmatic access
19
+
and a serializable CSS selector. *)
20
+
type element_ref = {
21
+
element : Brr.El.t option;
22
+
(** The live DOM element, if still attached to the document.
23
+
May be [None] if validation was performed on a raw HTML string
24
+
without a source element. *)
25
+
26
+
selector : string;
27
+
(** A CSS selector path that uniquely identifies this element.
28
+
Format: ["body > div.container > p:nth-child(3) > img"]
29
+
Useful for logging and re-finding elements. *)
30
+
}
31
+
32
+
(** A validation message paired with its DOM element reference. *)
33
+
type browser_message = {
34
+
message : Htmlrw_check.message;
35
+
(** The core validation message with severity, text, error code, etc. *)
36
+
37
+
element_ref : element_ref option;
38
+
(** Reference to the problematic DOM element, if identifiable.
39
+
[None] for document-level issues like missing DOCTYPE. *)
40
+
}
41
+
42
+
(** Browser validation result. *)
43
+
type result = {
44
+
messages : browser_message list;
45
+
(** All validation messages with element references. *)
46
+
47
+
core_result : Htmlrw_check.t;
48
+
(** The underlying validation result from the core library.
49
+
Use for access to {!Htmlrw_check.errors}, {!Htmlrw_check.has_errors}, etc. *)
50
+
51
+
source_element : Brr.El.t option;
52
+
(** The root element that was validated, if validation started from an element. *)
53
+
}
54
+
55
+
56
+
(** {1 Annotation Configuration} *)
57
+
58
+
(** Configuration for how warnings are displayed on annotated elements. *)
59
+
type annotation_config = {
60
+
add_data_attrs : bool;
61
+
(** Add [data-html5rw-*] attributes to elements:
62
+
- [data-html5rw-severity]: ["error"], ["warning"], or ["info"]
63
+
- [data-html5rw-message]: The warning message text
64
+
- [data-html5rw-code]: The error code *)
65
+
66
+
add_classes : bool;
67
+
(** Add CSS classes: [html5rw-error], [html5rw-warning], [html5rw-info],
68
+
and [html5rw-has-issues] on any element with warnings. *)
69
+
70
+
show_tooltips : bool;
71
+
(** Create tooltip overlays that appear on hover. *)
72
+
73
+
tooltip_position : [ `Above | `Below | `Auto ];
74
+
(** Tooltip position. [`Auto] chooses based on viewport. *)
75
+
76
+
highlight_on_hover : bool;
77
+
(** Highlight elements when hovering over warnings in the panel. *)
78
+
}
79
+
80
+
(** Default: all annotation features enabled, tooltips auto-positioned. *)
81
+
val default_annotation_config : annotation_config
82
+
83
+
84
+
(** {1 Panel Configuration} *)
85
+
86
+
(** Configuration for the floating warning panel. *)
87
+
type panel_config = {
88
+
initial_position : [ `TopRight | `TopLeft | `BottomRight | `BottomLeft | `Custom of int * int ];
89
+
(** Where the panel appears initially. *)
90
+
91
+
draggable : bool;
92
+
resizable : bool;
93
+
collapsible : bool;
94
+
start_collapsed : bool;
95
+
96
+
max_height : int option;
97
+
(** Maximum height in pixels before scrolling. *)
98
+
99
+
group_by_severity : bool;
100
+
(** Group warnings: errors first, then warnings, then info. *)
101
+
102
+
click_to_highlight : bool;
103
+
(** Clicking a warning scrolls to and highlights the element. *)
104
+
105
+
show_selector_path : bool;
106
+
(** Show the CSS selector path in each warning row. *)
107
+
108
+
theme : [ `Light | `Dark | `Auto ];
109
+
(** Color scheme. [`Auto] follows [prefers-color-scheme]. *)
110
+
}
111
+
112
+
(** Default panel configuration. *)
113
+
val default_panel_config : panel_config
114
+
115
+
116
+
(** {1 Conversions} *)
117
+
118
+
(** Build a CSS selector path for an element. *)
119
+
val selector_of_element : Brr.El.t -> string
120
+
121
+
(** Convert a browser message to a JavaScript object. *)
122
+
val browser_message_to_jv : browser_message -> Jv.t
123
+
124
+
(** Convert a result to a JavaScript object. *)
125
+
val result_to_jv : result -> Jv.t
+426
lib/js/htmlrw_js_ui.ml
+426
lib/js/htmlrw_js_ui.ml
···
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open Brr
7
+
open Htmlrw_js_types
8
+
9
+
module Css_class = struct
10
+
let panel = Jstr.v "html5rw-panel"
11
+
let panel_header = Jstr.v "html5rw-panel-header"
12
+
let panel_content = Jstr.v "html5rw-panel-content"
13
+
let panel_collapsed = Jstr.v "html5rw-panel-collapsed"
14
+
let panel_dragging = Jstr.v "html5rw-panel-dragging"
15
+
let warning_list = Jstr.v "html5rw-warning-list"
16
+
let warning_row = Jstr.v "html5rw-warning-row"
17
+
let warning_row_error = Jstr.v "html5rw-warning-row-error"
18
+
let warning_row_warning = Jstr.v "html5rw-warning-row-warning"
19
+
let warning_row_info = Jstr.v "html5rw-warning-row-info"
20
+
let severity_badge = Jstr.v "html5rw-severity-badge"
21
+
let message_text = Jstr.v "html5rw-message-text"
22
+
let selector_path = Jstr.v "html5rw-selector-path"
23
+
let collapse_btn = Jstr.v "html5rw-collapse-btn"
24
+
let close_btn = Jstr.v "html5rw-close-btn"
25
+
let summary_badge = Jstr.v "html5rw-summary-badge"
26
+
let error_count = Jstr.v "html5rw-error-count"
27
+
let warning_count = Jstr.v "html5rw-warning-count"
28
+
let theme_light = Jstr.v "html5rw-theme-light"
29
+
let theme_dark = Jstr.v "html5rw-theme-dark"
30
+
end
31
+
32
+
type t = {
33
+
root : El.t;
34
+
header : El.t;
35
+
content : El.t;
36
+
badge : El.t;
37
+
config : panel_config;
38
+
mutable result : result;
39
+
mutable collapsed : bool;
40
+
mutable highlighted : El.t option;
41
+
mutable on_warning_click : (browser_message -> unit) option;
42
+
mutable on_collapse_toggle : (bool -> unit) option;
43
+
mutable on_close : (unit -> unit) option;
44
+
mutable on_move : (int * int -> unit) option;
45
+
}
46
+
47
+
let _current_panel : t option ref = ref None
48
+
49
+
let current () = !_current_panel
50
+
let root_element t = t.root
51
+
let header_element t = t.header
52
+
let content_element t = t.content
53
+
let badge_element t = t.badge
54
+
55
+
let is_visible t =
56
+
let display = El.computed_style (Jstr.v "display") t.root in
57
+
not (Jstr.equal display (Jstr.v "none"))
58
+
59
+
let is_collapsed t = t.collapsed
60
+
61
+
let position t =
62
+
let x = int_of_float (El.bound_x t.root) in
63
+
let y = int_of_float (El.bound_y t.root) in
64
+
(x, y)
65
+
66
+
let set_position t x y =
67
+
El.set_inline_style (Jstr.v "left") (Jstr.v (Printf.sprintf "%dpx" x)) t.root;
68
+
El.set_inline_style (Jstr.v "top") (Jstr.v (Printf.sprintf "%dpx" y)) t.root;
69
+
El.set_inline_style (Jstr.v "right") (Jstr.v "auto") t.root
70
+
71
+
let highlighted_element t = t.highlighted
72
+
73
+
let clear_highlight t =
74
+
match t.highlighted with
75
+
| Some el ->
76
+
Htmlrw_js_annotate.unhighlight_element el;
77
+
t.highlighted <- None
78
+
| None -> ()
79
+
80
+
let navigate_to_element t bm =
81
+
clear_highlight t;
82
+
match bm.element_ref with
83
+
| Some { element = Some el; _ } ->
84
+
Htmlrw_js_annotate.highlight_element el;
85
+
t.highlighted <- Some el
86
+
| _ -> ()
87
+
88
+
let severity_row_class = function
89
+
| Htmlrw_check.Error -> Css_class.warning_row_error
90
+
| Htmlrw_check.Warning -> Css_class.warning_row_warning
91
+
| Htmlrw_check.Info -> Css_class.warning_row_info
92
+
93
+
let create_warning_row ~config t bm =
94
+
let msg = bm.message in
95
+
let sev = Htmlrw_check.severity_to_string msg.Htmlrw_check.severity in
96
+
97
+
let badge = El.v (Jstr.v "span") ~at:[At.class' Css_class.severity_badge] [
98
+
El.txt' (String.uppercase_ascii sev)
99
+
] in
100
+
101
+
let text = El.v (Jstr.v "span") ~at:[At.class' Css_class.message_text] [
102
+
El.txt' msg.Htmlrw_check.text
103
+
] in
104
+
105
+
let children = [badge; text] in
106
+
let children =
107
+
if config.show_selector_path then
108
+
match bm.element_ref with
109
+
| Some ref ->
110
+
let path = El.v (Jstr.v "span") ~at:[At.class' Css_class.selector_path] [
111
+
El.txt' ref.selector
112
+
] in
113
+
children @ [path]
114
+
| None -> children
115
+
else
116
+
children
117
+
in
118
+
119
+
let row = El.v (Jstr.v "div") ~at:[
120
+
At.class' Css_class.warning_row;
121
+
At.class' (severity_row_class msg.Htmlrw_check.severity);
122
+
] children in
123
+
124
+
if config.click_to_highlight then begin
125
+
ignore (Ev.listen Ev.click (fun _ ->
126
+
navigate_to_element t bm;
127
+
match t.on_warning_click with
128
+
| Some f -> f bm
129
+
| None -> ()
130
+
) (El.as_target row))
131
+
end;
132
+
133
+
row
134
+
135
+
let build_content ~config t =
136
+
let messages =
137
+
if config.group_by_severity then
138
+
let errors, warnings, infos = List.fold_left (fun (e, w, i) bm ->
139
+
match bm.message.Htmlrw_check.severity with
140
+
| Htmlrw_check.Error -> (bm :: e, w, i)
141
+
| Htmlrw_check.Warning -> (e, bm :: w, i)
142
+
| Htmlrw_check.Info -> (e, w, bm :: i)
143
+
) ([], [], []) t.result.messages in
144
+
List.rev errors @ List.rev warnings @ List.rev infos
145
+
else
146
+
t.result.messages
147
+
in
148
+
149
+
let rows = List.map (create_warning_row ~config t) messages in
150
+
let list = El.v (Jstr.v "div") ~at:[At.class' Css_class.warning_list] rows in
151
+
152
+
(match config.max_height with
153
+
| Some h ->
154
+
El.set_inline_style (Jstr.v "maxHeight") (Jstr.v (Printf.sprintf "%dpx" h)) list;
155
+
El.set_inline_style (Jstr.v "overflowY") (Jstr.v "auto") list
156
+
| None -> ());
157
+
list
158
+
159
+
let update t result =
160
+
t.result <- result;
161
+
let list = build_content ~config:t.config t in
162
+
El.set_children t.content [list];
163
+
let error_count = List.length (List.filter (fun bm ->
164
+
bm.message.Htmlrw_check.severity = Htmlrw_check.Error
165
+
) result.messages) in
166
+
let warning_count = List.length (List.filter (fun bm ->
167
+
bm.message.Htmlrw_check.severity = Htmlrw_check.Warning
168
+
) result.messages) in
169
+
El.set_children t.badge [
170
+
El.txt' (Printf.sprintf "%d errors, %d warnings" error_count warning_count)
171
+
]
172
+
173
+
let collapse t =
174
+
t.collapsed <- true;
175
+
El.set_class Css_class.panel_collapsed true t.root;
176
+
match t.on_collapse_toggle with Some f -> f true | None -> ()
177
+
178
+
let expand t =
179
+
t.collapsed <- false;
180
+
El.set_class Css_class.panel_collapsed false t.root;
181
+
match t.on_collapse_toggle with Some f -> f false | None -> ()
182
+
183
+
let toggle_collapsed t =
184
+
if t.collapsed then expand t else collapse t
185
+
186
+
let show t =
187
+
El.set_inline_style (Jstr.v "display") (Jstr.v "block") t.root
188
+
189
+
let hide t =
190
+
El.set_inline_style (Jstr.v "display") (Jstr.v "none") t.root
191
+
192
+
let destroy t =
193
+
El.remove t.root;
194
+
if !_current_panel = Some t then _current_panel := None
195
+
196
+
let hide_current () =
197
+
match !_current_panel with Some t -> destroy t | None -> ()
198
+
199
+
let create ~config result =
200
+
hide_current ();
201
+
202
+
let _doc = G.document in
203
+
204
+
let title = El.v (Jstr.v "span") [El.txt' "HTML5 Validation"] in
205
+
206
+
let collapse_btn = El.v (Jstr.v "button") ~at:[At.class' Css_class.collapse_btn] [
207
+
El.txt' "_"
208
+
] in
209
+
210
+
let close_btn = El.v (Jstr.v "button") ~at:[At.class' Css_class.close_btn] [
211
+
El.txt' "x"
212
+
] in
213
+
214
+
let header = El.v (Jstr.v "div") ~at:[At.class' Css_class.panel_header] [
215
+
title; collapse_btn; close_btn
216
+
] in
217
+
218
+
let error_count = List.length (List.filter (fun bm ->
219
+
bm.message.Htmlrw_check.severity = Htmlrw_check.Error
220
+
) result.messages) in
221
+
let warning_count = List.length (List.filter (fun bm ->
222
+
bm.message.Htmlrw_check.severity = Htmlrw_check.Warning
223
+
) result.messages) in
224
+
225
+
let badge = El.v (Jstr.v "div") ~at:[At.class' Css_class.summary_badge] [
226
+
El.txt' (Printf.sprintf "%d errors, %d warnings" error_count warning_count)
227
+
] in
228
+
229
+
let content = El.v (Jstr.v "div") ~at:[At.class' Css_class.panel_content] [] in
230
+
231
+
let theme_class = match config.theme with
232
+
| `Light -> Css_class.theme_light
233
+
| `Dark -> Css_class.theme_dark
234
+
| `Auto -> Css_class.theme_light
235
+
in
236
+
237
+
let root = El.v (Jstr.v "div") ~at:[
238
+
At.class' Css_class.panel;
239
+
At.class' theme_class;
240
+
] [header; badge; content] in
241
+
242
+
(match config.initial_position with
243
+
| `TopRight ->
244
+
El.set_inline_style (Jstr.v "top") (Jstr.v "20px") root;
245
+
El.set_inline_style (Jstr.v "right") (Jstr.v "20px") root
246
+
| `TopLeft ->
247
+
El.set_inline_style (Jstr.v "top") (Jstr.v "20px") root;
248
+
El.set_inline_style (Jstr.v "left") (Jstr.v "20px") root
249
+
| `BottomRight ->
250
+
El.set_inline_style (Jstr.v "bottom") (Jstr.v "20px") root;
251
+
El.set_inline_style (Jstr.v "right") (Jstr.v "20px") root
252
+
| `BottomLeft ->
253
+
El.set_inline_style (Jstr.v "bottom") (Jstr.v "20px") root;
254
+
El.set_inline_style (Jstr.v "left") (Jstr.v "20px") root
255
+
| `Custom (x, y) ->
256
+
El.set_inline_style (Jstr.v "left") (Jstr.v (Printf.sprintf "%dpx" x)) root;
257
+
El.set_inline_style (Jstr.v "top") (Jstr.v (Printf.sprintf "%dpx" y)) root);
258
+
259
+
let t = {
260
+
root; header; content; badge; config; result;
261
+
collapsed = config.start_collapsed;
262
+
highlighted = None;
263
+
on_warning_click = None;
264
+
on_collapse_toggle = None;
265
+
on_close = None;
266
+
on_move = None;
267
+
} in
268
+
269
+
update t result;
270
+
271
+
ignore (Ev.listen Ev.click (fun _ -> toggle_collapsed t) (El.as_target collapse_btn));
272
+
273
+
ignore (Ev.listen Ev.click (fun _ ->
274
+
destroy t;
275
+
match t.on_close with Some f -> f () | None -> ()
276
+
) (El.as_target close_btn));
277
+
278
+
if config.draggable then begin
279
+
let dragging = ref false in
280
+
let offset_x = ref 0.0 in
281
+
let offset_y = ref 0.0 in
282
+
283
+
ignore (Ev.listen Ev.mousedown (fun ev ->
284
+
let m = Ev.as_type ev in
285
+
dragging := true;
286
+
offset_x := Ev.Mouse.client_x m -. El.bound_x root;
287
+
offset_y := Ev.Mouse.client_y m -. El.bound_y root;
288
+
El.set_class Css_class.panel_dragging true root
289
+
) (El.as_target header));
290
+
291
+
ignore (Ev.listen Ev.mousemove (fun ev ->
292
+
if !dragging then begin
293
+
let m = Ev.as_type ev in
294
+
let x = int_of_float (Ev.Mouse.client_x m -. !offset_x) in
295
+
let y = int_of_float (Ev.Mouse.client_y m -. !offset_y) in
296
+
set_position t x y;
297
+
match t.on_move with Some f -> f (x, y) | None -> ()
298
+
end
299
+
) (Window.as_target G.window));
300
+
301
+
ignore (Ev.listen Ev.mouseup (fun _ ->
302
+
dragging := false;
303
+
El.set_class Css_class.panel_dragging false root
304
+
) (Window.as_target G.window))
305
+
end;
306
+
307
+
if config.start_collapsed then
308
+
El.set_class Css_class.panel_collapsed true root;
309
+
310
+
El.append_children (Document.body G.document) [root];
311
+
312
+
_current_panel := Some t;
313
+
t
314
+
315
+
let on_warning_click t f = t.on_warning_click <- Some f
316
+
let on_collapse_toggle t f = t.on_collapse_toggle <- Some f
317
+
let on_close t f = t.on_close <- Some f
318
+
let on_move t f = t.on_move <- Some f
319
+
320
+
let inject_default_styles ~theme =
321
+
let theme_vars = match theme with
322
+
| `Light -> {|
323
+
--html5rw-panel-bg: #ffffff;
324
+
--html5rw-panel-text: #333333;
325
+
--html5rw-panel-border: #dddddd;
326
+
--html5rw-panel-header-bg: #f5f5f5;
327
+
|}
328
+
| `Dark -> {|
329
+
--html5rw-panel-bg: #2d3436;
330
+
--html5rw-panel-text: #dfe6e9;
331
+
--html5rw-panel-border: #636e72;
332
+
--html5rw-panel-header-bg: #1e272e;
333
+
|}
334
+
| `Auto -> {|
335
+
--html5rw-panel-bg: #ffffff;
336
+
--html5rw-panel-text: #333333;
337
+
--html5rw-panel-border: #dddddd;
338
+
--html5rw-panel-header-bg: #f5f5f5;
339
+
|}
340
+
in
341
+
342
+
let css = Printf.sprintf {|
343
+
:root { %s }
344
+
345
+
@media (prefers-color-scheme: dark) {
346
+
:root {
347
+
--html5rw-panel-bg: #2d3436;
348
+
--html5rw-panel-text: #dfe6e9;
349
+
--html5rw-panel-border: #636e72;
350
+
--html5rw-panel-header-bg: #1e272e;
351
+
}
352
+
}
353
+
354
+
.html5rw-panel {
355
+
position: fixed;
356
+
z-index: 99999;
357
+
width: 400px;
358
+
background: var(--html5rw-panel-bg);
359
+
border: 1px solid var(--html5rw-panel-border);
360
+
border-radius: 8px;
361
+
box-shadow: 0 4px 20px rgba(0, 0, 0, 0.15);
362
+
font-family: system-ui, -apple-system, sans-serif;
363
+
font-size: 13px;
364
+
color: var(--html5rw-panel-text);
365
+
}
366
+
367
+
.html5rw-panel-header {
368
+
display: flex;
369
+
align-items: center;
370
+
padding: 12px 16px;
371
+
background: var(--html5rw-panel-header-bg);
372
+
border-bottom: 1px solid var(--html5rw-panel-border);
373
+
border-radius: 8px 8px 0 0;
374
+
cursor: move;
375
+
user-select: none;
376
+
}
377
+
378
+
.html5rw-panel-header span { flex: 1; font-weight: 600; }
379
+
380
+
.html5rw-panel-header button {
381
+
width: 24px; height: 24px; margin-left: 8px;
382
+
border: none; border-radius: 4px;
383
+
background: transparent; color: var(--html5rw-panel-text);
384
+
cursor: pointer; font-size: 14px; line-height: 1;
385
+
}
386
+
387
+
.html5rw-panel-header button:hover { background: rgba(0, 0, 0, 0.1); }
388
+
.html5rw-panel-content { padding: 0; }
389
+
.html5rw-panel-collapsed .html5rw-panel-content { display: none; }
390
+
.html5rw-panel-collapsed .html5rw-summary-badge { display: block; }
391
+
.html5rw-summary-badge { display: none; padding: 12px 16px; text-align: center; font-weight: 500; }
392
+
.html5rw-warning-list { max-height: 400px; overflow-y: auto; }
393
+
394
+
.html5rw-warning-row {
395
+
display: flex; flex-direction: column;
396
+
padding: 10px 16px;
397
+
border-bottom: 1px solid var(--html5rw-panel-border);
398
+
cursor: pointer; transition: background 0.15s;
399
+
}
400
+
401
+
.html5rw-warning-row:hover { background: rgba(0, 0, 0, 0.05); }
402
+
.html5rw-warning-row:last-child { border-bottom: none; }
403
+
404
+
.html5rw-severity-badge {
405
+
display: inline-block; padding: 2px 6px; border-radius: 3px;
406
+
font-size: 10px; font-weight: 600; text-transform: uppercase; margin-right: 8px;
407
+
}
408
+
409
+
.html5rw-warning-row-error .html5rw-severity-badge { background: #e74c3c; color: white; }
410
+
.html5rw-warning-row-warning .html5rw-severity-badge { background: #f39c12; color: white; }
411
+
.html5rw-warning-row-info .html5rw-severity-badge { background: #3498db; color: white; }
412
+
.html5rw-message-text { flex: 1; line-height: 1.4; }
413
+
414
+
.html5rw-selector-path {
415
+
display: block; margin-top: 4px; font-size: 11px; color: #888;
416
+
font-family: monospace; overflow: hidden; text-overflow: ellipsis; white-space: nowrap;
417
+
}
418
+
419
+
.html5rw-panel-dragging { opacity: 0.9; }
420
+
|} theme_vars in
421
+
422
+
let doc = G.document in
423
+
let style_el = El.v (Jstr.v "style") [El.txt' css] in
424
+
El.set_at (Jstr.v "data-html5rw-panel-styles") (Some (Jstr.v "true")) style_el;
425
+
El.append_children (Document.head doc) [style_el];
426
+
style_el
+169
lib/js/htmlrw_js_ui.mli
+169
lib/js/htmlrw_js_ui.mli
···
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Floating warning panel UI.
7
+
8
+
This module creates and manages a draggable, floating panel that displays
9
+
validation warnings. The panel supports:
10
+
- Grouping by severity (errors first)
11
+
- Click-to-navigate to problematic elements
12
+
- Collapse/expand functionality
13
+
- Light/dark themes *)
14
+
15
+
open Htmlrw_js_types
16
+
17
+
18
+
(** {1 Panel Management} *)
19
+
20
+
(** The warning panel. *)
21
+
type t
22
+
23
+
(** Create and display a warning panel.
24
+
25
+
The panel is appended to [document.body] and positioned according
26
+
to the configuration.
27
+
28
+
@param config Panel configuration.
29
+
@param result Validation result to display. *)
30
+
val create : config:panel_config -> result -> t
31
+
32
+
(** Update the panel with new validation results.
33
+
34
+
Use this to re-validate and refresh the panel without destroying it. *)
35
+
val update : t -> result -> unit
36
+
37
+
(** Show the panel if hidden. *)
38
+
val show : t -> unit
39
+
40
+
(** Hide the panel (but keep it in the DOM). *)
41
+
val hide : t -> unit
42
+
43
+
(** Remove the panel from the DOM entirely. *)
44
+
val destroy : t -> unit
45
+
46
+
(** Check if the panel is currently visible. *)
47
+
val is_visible : t -> bool
48
+
49
+
(** Check if the panel is currently collapsed. *)
50
+
val is_collapsed : t -> bool
51
+
52
+
53
+
(** {1 Panel State} *)
54
+
55
+
(** Collapse the panel to just show the summary badge. *)
56
+
val collapse : t -> unit
57
+
58
+
(** Expand the panel to show the full warning list. *)
59
+
val expand : t -> unit
60
+
61
+
(** Toggle collapsed state. *)
62
+
val toggle_collapsed : t -> unit
63
+
64
+
(** Get the current position of the panel. *)
65
+
val position : t -> int * int
66
+
67
+
(** Move the panel to a new position. *)
68
+
val set_position : t -> int -> int -> unit
69
+
70
+
71
+
(** {1 Interaction} *)
72
+
73
+
(** Scroll to and highlight an element from a warning row.
74
+
75
+
This is called internally when clicking a warning, but can be
76
+
invoked programmatically. *)
77
+
val navigate_to_element : t -> browser_message -> unit
78
+
79
+
(** Get the currently highlighted element, if any. *)
80
+
val highlighted_element : t -> Brr.El.t option
81
+
82
+
(** Clear the current highlight. *)
83
+
val clear_highlight : t -> unit
84
+
85
+
86
+
(** {1 Event Callbacks}
87
+
88
+
Register callbacks for panel events. *)
89
+
90
+
(** Called when a warning row is clicked. *)
91
+
val on_warning_click : t -> (browser_message -> unit) -> unit
92
+
93
+
(** Called when the panel is collapsed or expanded. *)
94
+
val on_collapse_toggle : t -> (bool -> unit) -> unit
95
+
96
+
(** Called when the panel is closed. *)
97
+
val on_close : t -> (unit -> unit) -> unit
98
+
99
+
(** Called when the panel is dragged to a new position. *)
100
+
val on_move : t -> (int * int -> unit) -> unit
101
+
102
+
103
+
(** {1 Global Panel State}
104
+
105
+
For convenience, there's a single "current" panel that the
106
+
JavaScript API manages. *)
107
+
108
+
(** Get the current panel, if one exists. *)
109
+
val current : unit -> t option
110
+
111
+
(** Hide and destroy the current panel. *)
112
+
val hide_current : unit -> unit
113
+
114
+
115
+
(** {1 Panel Elements}
116
+
117
+
Access to the panel's DOM structure for custom styling. *)
118
+
119
+
(** The root panel element. *)
120
+
val root_element : t -> Brr.El.t
121
+
122
+
(** The header element (contains title and controls). *)
123
+
val header_element : t -> Brr.El.t
124
+
125
+
(** The content element (contains warning list). *)
126
+
val content_element : t -> Brr.El.t
127
+
128
+
(** The summary badge element (shown when collapsed). *)
129
+
val badge_element : t -> Brr.El.t
130
+
131
+
132
+
(** {1 CSS Classes}
133
+
134
+
Classes used by the panel for custom styling. *)
135
+
136
+
module Css_class : sig
137
+
val panel : Jstr.t
138
+
val panel_header : Jstr.t
139
+
val panel_content : Jstr.t
140
+
val panel_collapsed : Jstr.t
141
+
val panel_dragging : Jstr.t
142
+
val warning_list : Jstr.t
143
+
val warning_row : Jstr.t
144
+
val warning_row_error : Jstr.t
145
+
val warning_row_warning : Jstr.t
146
+
val warning_row_info : Jstr.t
147
+
val severity_badge : Jstr.t
148
+
val message_text : Jstr.t
149
+
val selector_path : Jstr.t
150
+
val collapse_btn : Jstr.t
151
+
val close_btn : Jstr.t
152
+
val summary_badge : Jstr.t
153
+
val error_count : Jstr.t
154
+
val warning_count : Jstr.t
155
+
val theme_light : Jstr.t
156
+
val theme_dark : Jstr.t
157
+
end
158
+
159
+
160
+
(** {1 CSS Injection} *)
161
+
162
+
(** Inject default CSS styles for the panel.
163
+
164
+
Styles include layout, colors, shadows, and animations.
165
+
The styles are scoped to the panel's CSS classes.
166
+
167
+
@param theme Color scheme to use.
168
+
@return The injected style element. *)
169
+
val inject_default_styles : theme:[ `Light | `Dark | `Auto ] -> Brr.El.t
+151
lib/js/htmlrw_js_worker.ml
+151
lib/js/htmlrw_js_worker.ml
···
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(* Web Worker entry point for background HTML validation.
7
+
8
+
This runs in a separate thread and communicates via postMessage.
9
+
It only does string-based validation since workers can't access the DOM.
10
+
*)
11
+
12
+
[@@@warning "-33"] (* Suppress unused open - we only need Jv from Brr *)
13
+
open Brr
14
+
15
+
let console_log msg =
16
+
ignore (Jv.call (Jv.get Jv.global "console") "log" [| Jv.of_string msg |])
17
+
18
+
let console_error msg =
19
+
ignore (Jv.call (Jv.get Jv.global "console") "error" [| Jv.of_string msg |])
20
+
21
+
let ensure_doctype html =
22
+
let lower = String.lowercase_ascii html in
23
+
if String.length lower >= 9 && String.sub lower 0 9 = "<!doctype" then
24
+
html
25
+
else
26
+
"<!DOCTYPE html>" ^ html
27
+
28
+
(* Debug: dump tree structure to see what parser built *)
29
+
let dump_tree_structure html =
30
+
let doc = Html5rw.parse (Bytesrw.Bytes.Reader.of_string html) in
31
+
let root = Html5rw.root doc in
32
+
let buf = Buffer.create 1024 in
33
+
let rec dump indent node =
34
+
let prefix = String.make (indent * 2) ' ' in
35
+
let name = node.Html5rw.Dom.name in
36
+
if name = "#text" then begin
37
+
let text = String.trim node.Html5rw.Dom.data in
38
+
if String.length text > 0 then
39
+
Buffer.add_string buf (Printf.sprintf "%s#text: \"%s\"\n" prefix
40
+
(if String.length text > 30 then String.sub text 0 30 ^ "..." else text))
41
+
end else if name = "#comment" then
42
+
()
43
+
else begin
44
+
Buffer.add_string buf (Printf.sprintf "%s<%s>\n" prefix name);
45
+
if indent < 5 then (* only show first 5 levels *)
46
+
List.iter (dump (indent + 1)) node.Html5rw.Dom.children
47
+
end
48
+
in
49
+
dump 0 root;
50
+
Buffer.contents buf
51
+
52
+
let handle_message msg_data =
53
+
console_log "[html5rw worker] Message received";
54
+
let response = Jv.obj [||] in
55
+
try
56
+
let id = Jv.get msg_data "id" |> Jv.to_int in
57
+
let raw_html = Jv.get msg_data "html" |> Jv.to_string in
58
+
let html = ensure_doctype raw_html in
59
+
console_log (Printf.sprintf "[html5rw worker] Validating %d bytes (id=%d)" (String.length html) id);
60
+
(* Log first 500 chars of HTML for debugging *)
61
+
let preview = if String.length html > 500 then String.sub html 0 500 ^ "..." else html in
62
+
console_log (Printf.sprintf "[html5rw worker] HTML preview:\n%s" preview);
63
+
64
+
Jv.set response "id" (Jv.of_int id);
65
+
66
+
(try
67
+
(* Run validation *)
68
+
let core_result = Htmlrw_check.check_string html in
69
+
let messages = Htmlrw_check.messages core_result in
70
+
71
+
(* Convert messages to JS-friendly format *)
72
+
let warnings = Jv.of_list (fun msg ->
73
+
let obj = Jv.obj [||] in
74
+
Jv.set obj "severity" (Jv.of_string (Htmlrw_check.severity_to_string msg.Htmlrw_check.severity));
75
+
Jv.set obj "message" (Jv.of_string msg.Htmlrw_check.text);
76
+
Jv.set obj "errorCode" (Jv.of_string (Htmlrw_check.error_code_to_string msg.Htmlrw_check.error_code));
77
+
(match msg.Htmlrw_check.element with
78
+
| Some el -> Jv.set obj "elementName" (Jv.of_string el)
79
+
| None -> ());
80
+
(match msg.Htmlrw_check.attribute with
81
+
| Some attr -> Jv.set obj "attribute" (Jv.of_string attr)
82
+
| None -> ());
83
+
(match msg.Htmlrw_check.location with
84
+
| Some loc ->
85
+
Jv.set obj "line" (Jv.of_int loc.line);
86
+
Jv.set obj "column" (Jv.of_int loc.column)
87
+
| None -> ());
88
+
obj
89
+
) messages in
90
+
91
+
let error_count = List.length (List.filter (fun m ->
92
+
m.Htmlrw_check.severity = Htmlrw_check.Error) messages) in
93
+
let warning_count = List.length (List.filter (fun m ->
94
+
m.Htmlrw_check.severity = Htmlrw_check.Warning) messages) in
95
+
let info_count = List.length (List.filter (fun m ->
96
+
m.Htmlrw_check.severity = Htmlrw_check.Info) messages) in
97
+
98
+
Jv.set response "warnings" warnings;
99
+
Jv.set response "errorCount" (Jv.of_int error_count);
100
+
Jv.set response "warningCount" (Jv.of_int warning_count);
101
+
Jv.set response "infoCount" (Jv.of_int info_count);
102
+
Jv.set response "hasErrors" (Jv.of_bool (error_count > 0));
103
+
(* Add tree structure for debugging *)
104
+
let tree_dump = dump_tree_structure html in
105
+
Jv.set response "treeStructure" (Jv.of_string tree_dump);
106
+
Jv.set response "htmlPreview" (Jv.of_string preview);
107
+
console_log (Printf.sprintf "[html5rw worker] Tree structure:\n%s" tree_dump)
108
+
with exn ->
109
+
(* Return error on parse failure *)
110
+
let error_obj = Jv.obj [||] in
111
+
Jv.set error_obj "severity" (Jv.of_string "error");
112
+
Jv.set error_obj "message" (Jv.of_string (Printf.sprintf "Parse error: %s" (Printexc.to_string exn)));
113
+
Jv.set error_obj "errorCode" (Jv.of_string "parse-error");
114
+
Jv.set response "warnings" (Jv.of_list Fun.id [error_obj]);
115
+
Jv.set response "errorCount" (Jv.of_int 1);
116
+
Jv.set response "warningCount" (Jv.of_int 0);
117
+
Jv.set response "infoCount" (Jv.of_int 0);
118
+
Jv.set response "hasErrors" (Jv.of_bool true);
119
+
Jv.set response "parseError" (Jv.of_string (Printexc.to_string exn)));
120
+
121
+
console_log "[html5rw worker] Validation complete, posting response";
122
+
(* Post result back to main thread *)
123
+
let self = Jv.get Jv.global "self" in
124
+
ignore (Jv.call self "postMessage" [| response |])
125
+
with exn ->
126
+
(* Outer error handler - catches message parsing errors *)
127
+
console_error (Printf.sprintf "[html5rw worker] Fatal error: %s" (Printexc.to_string exn));
128
+
let error_obj = Jv.obj [||] in
129
+
Jv.set error_obj "severity" (Jv.of_string "error");
130
+
Jv.set error_obj "message" (Jv.of_string (Printf.sprintf "Worker error: %s" (Printexc.to_string exn)));
131
+
Jv.set error_obj "errorCode" (Jv.of_string "worker-error");
132
+
Jv.set response "id" (Jv.of_int (-1));
133
+
Jv.set response "warnings" (Jv.of_list Fun.id [error_obj]);
134
+
Jv.set response "errorCount" (Jv.of_int 1);
135
+
Jv.set response "warningCount" (Jv.of_int 0);
136
+
Jv.set response "infoCount" (Jv.of_int 0);
137
+
Jv.set response "hasErrors" (Jv.of_bool true);
138
+
Jv.set response "fatalError" (Jv.of_string (Printexc.to_string exn));
139
+
let self = Jv.get Jv.global "self" in
140
+
ignore (Jv.call self "postMessage" [| response |])
141
+
142
+
let () =
143
+
console_log "[html5rw worker] Worker script starting...";
144
+
(* Set up message handler *)
145
+
let self = Jv.get Jv.global "self" in
146
+
let handler = Jv.callback ~arity:1 (fun ev ->
147
+
let data = Jv.get ev "data" in
148
+
handle_message data
149
+
) in
150
+
ignore (Jv.call self "addEventListener" [| Jv.of_string "message"; handler |]);
151
+
console_log "[html5rw worker] Message handler registered, ready for messages"