OCaml HTML5 parser/serialiser based on Python's JustHTML
1(*---------------------------------------------------------------------------
2 Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3 SPDX-License-Identifier: MIT
4 ---------------------------------------------------------------------------*)
5
6open Brr
7open Htmlrw_js_types
8
9module 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"
30end
31
32type 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
47let _current_panel : t option ref = ref None
48
49let current () = !_current_panel
50let root_element t = t.root
51let header_element t = t.header
52let content_element t = t.content
53let badge_element t = t.badge
54
55let is_visible t =
56 let display = El.computed_style (Jstr.v "display") t.root in
57 not (Jstr.equal display (Jstr.v "none"))
58
59let is_collapsed t = t.collapsed
60
61let 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
66let 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
71let highlighted_element t = t.highlighted
72
73let 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
80let 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
88let 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
93let 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
135let 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
159let 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
173let 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
178let 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
183let toggle_collapsed t =
184 if t.collapsed then expand t else collapse t
185
186let show t =
187 El.set_inline_style (Jstr.v "display") (Jstr.v "block") t.root
188
189let hide t =
190 El.set_inline_style (Jstr.v "display") (Jstr.v "none") t.root
191
192let destroy t =
193 El.remove t.root;
194 if !_current_panel = Some t then _current_panel := None
195
196let hide_current () =
197 match !_current_panel with Some t -> destroy t | None -> ()
198
199let 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
315let on_warning_click t f = t.on_warning_click <- Some f
316let on_collapse_toggle t f = t.on_collapse_toggle <- Some f
317let on_close t f = t.on_close <- Some f
318let on_move t f = t.on_move <- Some f
319
320let 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