OCaml HTML5 parser/serialiser based on Python's JustHTML
anil.recoil.org
1(*---------------------------------------------------------------------------
2 Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3 SPDX-License-Identifier: MIT
4 ---------------------------------------------------------------------------*)
5
6open Brr
7open Htmlrw_js_types
8
9let console_log msg =
10 ignore (Jv.call (Jv.get Jv.global "console") "log" [| Jv.of_string ("[html5rw-ui] " ^ msg) |])
11
12module Css_class = struct
13 let panel = Jstr.v "html5rw-panel"
14 let panel_header = Jstr.v "html5rw-panel-header"
15 let panel_content = Jstr.v "html5rw-panel-content"
16 let panel_collapsed = Jstr.v "html5rw-panel-collapsed"
17 let panel_dragging = Jstr.v "html5rw-panel-dragging"
18 let warning_list = Jstr.v "html5rw-warning-list"
19 let warning_row = Jstr.v "html5rw-warning-row"
20 let warning_row_error = Jstr.v "html5rw-warning-row-error"
21 let warning_row_warning = Jstr.v "html5rw-warning-row-warning"
22 let warning_row_info = Jstr.v "html5rw-warning-row-info"
23 let severity_badge = Jstr.v "html5rw-severity-badge"
24 let message_text = Jstr.v "html5rw-message-text"
25 let selector_path = Jstr.v "html5rw-selector-path"
26 let collapse_btn = Jstr.v "html5rw-collapse-btn"
27 let close_btn = Jstr.v "html5rw-close-btn"
28 let summary_badge = Jstr.v "html5rw-summary-badge"
29 let error_count = Jstr.v "html5rw-error-count"
30 let warning_count = Jstr.v "html5rw-warning-count"
31 let theme_light = Jstr.v "html5rw-theme-light"
32 let theme_dark = Jstr.v "html5rw-theme-dark"
33end
34
35type t = {
36 root : El.t;
37 header : El.t;
38 content : El.t;
39 badge : El.t;
40 config : panel_config;
41 mutable result : result;
42 mutable collapsed : bool;
43 mutable highlighted : El.t option;
44 mutable on_warning_click : (browser_message -> unit) option;
45 mutable on_collapse_toggle : (bool -> unit) option;
46 mutable on_close : (unit -> unit) option;
47 mutable on_move : (int * int -> unit) option;
48}
49
50let _current_panel : t option ref = ref None
51
52let current () = !_current_panel
53let root_element t = t.root
54let header_element t = t.header
55let content_element t = t.content
56let badge_element t = t.badge
57
58let is_visible t =
59 let display = El.computed_style (Jstr.v "display") t.root in
60 not (Jstr.equal display (Jstr.v "none"))
61
62let is_collapsed t = t.collapsed
63
64let position t =
65 let x = int_of_float (El.bound_x t.root) in
66 let y = int_of_float (El.bound_y t.root) in
67 (x, y)
68
69let set_position t x y =
70 El.set_inline_style (Jstr.v "left") (Jstr.v (Printf.sprintf "%dpx" x)) t.root;
71 El.set_inline_style (Jstr.v "top") (Jstr.v (Printf.sprintf "%dpx" y)) t.root;
72 El.set_inline_style (Jstr.v "right") (Jstr.v "auto") t.root
73
74let highlighted_element t = t.highlighted
75
76let clear_highlight t =
77 console_log (Printf.sprintf "clear_highlight: highlighted is %s"
78 (if t.highlighted = None then "None" else "Some"));
79 match t.highlighted with
80 | Some el ->
81 console_log "clear_highlight: unhighlighting element";
82 Htmlrw_js_annotate.unhighlight_element el;
83 t.highlighted <- None;
84 console_log "clear_highlight: done"
85 | None ->
86 console_log "clear_highlight: nothing to clear"
87
88let navigate_to_element t bm =
89 clear_highlight t;
90 match bm.element_ref with
91 | Some { element = Some el; _ } ->
92 Htmlrw_js_annotate.highlight_element el;
93 t.highlighted <- Some el
94 | _ -> ()
95
96let severity_row_class = function
97 | Htmlrw_check.Error -> Css_class.warning_row_error
98 | Htmlrw_check.Warning -> Css_class.warning_row_warning
99 | Htmlrw_check.Info -> Css_class.warning_row_info
100
101let create_warning_row ~config t bm =
102 let msg = bm.message in
103 let sev = Htmlrw_check.severity_to_string msg.Htmlrw_check.severity in
104
105 let badge = El.v (Jstr.v "span") ~at:[At.class' Css_class.severity_badge] [
106 El.txt' (String.uppercase_ascii sev)
107 ] in
108
109 let text = El.v (Jstr.v "span") ~at:[At.class' Css_class.message_text] [
110 El.txt' msg.Htmlrw_check.text
111 ] in
112
113 let children = [badge; text] in
114 let children =
115 if config.show_selector_path then
116 match bm.element_ref with
117 | Some ref ->
118 let path = El.v (Jstr.v "span") ~at:[At.class' Css_class.selector_path] [
119 El.txt' ref.selector
120 ] in
121 children @ [path]
122 | None -> children
123 else
124 children
125 in
126
127 let row = El.v (Jstr.v "div") ~at:[
128 At.class' Css_class.warning_row;
129 At.class' (severity_row_class msg.Htmlrw_check.severity);
130 ] children in
131
132 if config.click_to_highlight then begin
133 ignore (Ev.listen Ev.click (fun _ ->
134 navigate_to_element t bm;
135 match t.on_warning_click with
136 | Some f -> f bm
137 | None -> ()
138 ) (El.as_target row))
139 end;
140
141 row
142
143let build_content ~config t =
144 let messages =
145 if config.group_by_severity then
146 let errors, warnings, infos = List.fold_left (fun (e, w, i) bm ->
147 match bm.message.Htmlrw_check.severity with
148 | Htmlrw_check.Error -> (bm :: e, w, i)
149 | Htmlrw_check.Warning -> (e, bm :: w, i)
150 | Htmlrw_check.Info -> (e, w, bm :: i)
151 ) ([], [], []) t.result.messages in
152 List.rev errors @ List.rev warnings @ List.rev infos
153 else
154 t.result.messages
155 in
156
157 let rows = List.map (create_warning_row ~config t) messages in
158 let list = El.v (Jstr.v "div") ~at:[At.class' Css_class.warning_list] rows in
159
160 (match config.max_height with
161 | Some h ->
162 El.set_inline_style (Jstr.v "maxHeight") (Jstr.v (Printf.sprintf "%dpx" h)) list;
163 El.set_inline_style (Jstr.v "overflowY") (Jstr.v "auto") list
164 | None -> ());
165 list
166
167let update t result =
168 t.result <- result;
169 let list = build_content ~config:t.config t in
170 El.set_children t.content [list];
171 let error_count = List.length (List.filter (fun bm ->
172 bm.message.Htmlrw_check.severity = Htmlrw_check.Error
173 ) result.messages) in
174 let warning_count = List.length (List.filter (fun bm ->
175 bm.message.Htmlrw_check.severity = Htmlrw_check.Warning
176 ) result.messages) in
177 El.set_children t.badge [
178 El.txt' (Printf.sprintf "%d errors, %d warnings" error_count warning_count)
179 ]
180
181let collapse t =
182 t.collapsed <- true;
183 El.set_class Css_class.panel_collapsed true t.root;
184 match t.on_collapse_toggle with Some f -> f true | None -> ()
185
186let expand t =
187 t.collapsed <- false;
188 El.set_class Css_class.panel_collapsed false t.root;
189 match t.on_collapse_toggle with Some f -> f false | None -> ()
190
191let toggle_collapsed t =
192 if t.collapsed then expand t else collapse t
193
194let show t =
195 El.set_inline_style (Jstr.v "display") (Jstr.v "block") t.root
196
197let hide t =
198 El.set_inline_style (Jstr.v "display") (Jstr.v "none") t.root
199
200let destroy t =
201 console_log "destroy: starting";
202 clear_highlight t;
203 console_log "destroy: cleared highlight";
204 (* Clear _current_panel before removing element to avoid comparison issues *)
205 (match !_current_panel with
206 | Some p when p.root == t.root -> _current_panel := None
207 | _ -> ());
208 console_log "destroy: cleared current_panel ref";
209 El.remove t.root;
210 console_log "destroy: removed root element, done"
211
212let hide_current () =
213 console_log (Printf.sprintf "hide_current: current_panel is %s"
214 (if !_current_panel = None then "None" else "Some"));
215 match !_current_panel with
216 | Some t ->
217 console_log "hide_current: destroying existing panel";
218 destroy t
219 | None ->
220 console_log "hide_current: no panel to destroy"
221
222let create ~config result =
223 console_log (Printf.sprintf "create: starting with %d messages" (List.length result.messages));
224 hide_current ();
225 console_log "create: hide_current done";
226
227 let _doc = G.document in
228
229 let title = El.v (Jstr.v "span") [El.txt' "HTML5 Validation"] in
230
231 let close_btn = El.v (Jstr.v "button") ~at:[At.class' Css_class.close_btn] [
232 El.txt' "x"
233 ] in
234
235 let header = El.v (Jstr.v "div") ~at:[At.class' Css_class.panel_header] [
236 title; close_btn
237 ] in
238
239 let error_count = List.length (List.filter (fun bm ->
240 bm.message.Htmlrw_check.severity = Htmlrw_check.Error
241 ) result.messages) in
242 let warning_count = List.length (List.filter (fun bm ->
243 bm.message.Htmlrw_check.severity = Htmlrw_check.Warning
244 ) result.messages) in
245
246 let badge = El.v (Jstr.v "div") ~at:[At.class' Css_class.summary_badge] [
247 El.txt' (Printf.sprintf "%d errors, %d warnings" error_count warning_count)
248 ] in
249
250 let content = El.v (Jstr.v "div") ~at:[At.class' Css_class.panel_content] [] in
251
252 let theme_class = match config.theme with
253 | `Light -> Css_class.theme_light
254 | `Dark -> Css_class.theme_dark
255 | `Auto -> Css_class.theme_light
256 in
257
258 let root = El.v (Jstr.v "div") ~at:[
259 At.class' Css_class.panel;
260 At.class' theme_class;
261 ] [header; badge; content] in
262
263 (match config.initial_position with
264 | `TopRight ->
265 El.set_inline_style (Jstr.v "top") (Jstr.v "20px") root;
266 El.set_inline_style (Jstr.v "right") (Jstr.v "20px") root
267 | `TopLeft ->
268 El.set_inline_style (Jstr.v "top") (Jstr.v "20px") root;
269 El.set_inline_style (Jstr.v "left") (Jstr.v "20px") root
270 | `BottomRight ->
271 El.set_inline_style (Jstr.v "bottom") (Jstr.v "20px") root;
272 El.set_inline_style (Jstr.v "right") (Jstr.v "20px") root
273 | `BottomLeft ->
274 El.set_inline_style (Jstr.v "bottom") (Jstr.v "20px") root;
275 El.set_inline_style (Jstr.v "left") (Jstr.v "20px") root
276 | `Custom (x, y) ->
277 El.set_inline_style (Jstr.v "left") (Jstr.v (Printf.sprintf "%dpx" x)) root;
278 El.set_inline_style (Jstr.v "top") (Jstr.v (Printf.sprintf "%dpx" y)) root);
279
280 let t = {
281 root; header; content; badge; config; result;
282 collapsed = config.start_collapsed;
283 highlighted = None;
284 on_warning_click = None;
285 on_collapse_toggle = None;
286 on_close = None;
287 on_move = None;
288 } in
289
290 update t result;
291
292 (* Stop mousedown from bubbling to header (prevents drag interference) *)
293 ignore (Ev.listen Ev.mousedown (fun ev ->
294 console_log "close_btn: mousedown, stopping propagation";
295 Ev.stop_propagation ev
296 ) (El.as_target close_btn));
297
298 ignore (Ev.listen Ev.click (fun ev ->
299 console_log "close_btn: click handler starting";
300 Ev.stop_propagation ev;
301 console_log "close_btn: stopped propagation, calling destroy";
302 destroy t;
303 console_log "close_btn: destroy done, checking on_close callback";
304 (match t.on_close with Some f -> f () | None -> ());
305 console_log "close_btn: click handler done"
306 ) (El.as_target close_btn));
307
308 if config.draggable then begin
309 let dragging = ref false in
310 let offset_x = ref 0.0 in
311 let offset_y = ref 0.0 in
312
313 ignore (Ev.listen Ev.mousedown (fun ev ->
314 let m = Ev.as_type ev in
315 dragging := true;
316 offset_x := Ev.Mouse.client_x m -. El.bound_x root;
317 offset_y := Ev.Mouse.client_y m -. El.bound_y root;
318 El.set_class Css_class.panel_dragging true root
319 ) (El.as_target header));
320
321 ignore (Ev.listen Ev.mousemove (fun ev ->
322 if !dragging then begin
323 let m = Ev.as_type ev in
324 let x = int_of_float (Ev.Mouse.client_x m -. !offset_x) in
325 let y = int_of_float (Ev.Mouse.client_y m -. !offset_y) in
326 set_position t x y;
327 match t.on_move with Some f -> f (x, y) | None -> ()
328 end
329 ) (Window.as_target G.window));
330
331 ignore (Ev.listen Ev.mouseup (fun _ ->
332 dragging := false;
333 El.set_class Css_class.panel_dragging false root
334 ) (Window.as_target G.window))
335 end;
336
337 if config.start_collapsed then
338 El.set_class Css_class.panel_collapsed true root;
339
340 console_log "create: appending panel to document body";
341 El.append_children (Document.body G.document) [root];
342
343 _current_panel := Some t;
344 console_log "create: panel creation complete";
345 t
346
347let on_warning_click t f = t.on_warning_click <- Some f
348let on_collapse_toggle t f = t.on_collapse_toggle <- Some f
349let on_close t f = t.on_close <- Some f
350let on_move t f = t.on_move <- Some f
351
352let inject_default_styles ~theme =
353 let theme_vars = match theme with
354 | `Light -> {|
355 --html5rw-panel-bg: #ffffff;
356 --html5rw-panel-text: #333333;
357 --html5rw-panel-border: #dddddd;
358 --html5rw-panel-header-bg: #f5f5f5;
359 |}
360 | `Dark -> {|
361 --html5rw-panel-bg: #2d3436;
362 --html5rw-panel-text: #dfe6e9;
363 --html5rw-panel-border: #636e72;
364 --html5rw-panel-header-bg: #1e272e;
365 |}
366 | `Auto -> {|
367 --html5rw-panel-bg: #ffffff;
368 --html5rw-panel-text: #333333;
369 --html5rw-panel-border: #dddddd;
370 --html5rw-panel-header-bg: #f5f5f5;
371 |}
372 in
373
374 let css = Printf.sprintf {|
375 :root { %s }
376
377 @media (prefers-color-scheme: dark) {
378 :root {
379 --html5rw-panel-bg: #2d3436;
380 --html5rw-panel-text: #dfe6e9;
381 --html5rw-panel-border: #636e72;
382 --html5rw-panel-header-bg: #1e272e;
383 }
384 }
385
386 .html5rw-panel {
387 position: fixed;
388 z-index: 99999;
389 width: 400px;
390 background: var(--html5rw-panel-bg);
391 border: 1px solid var(--html5rw-panel-border);
392 border-radius: 8px;
393 box-shadow: 0 4px 20px rgba(0, 0, 0, 0.15);
394 font-family: system-ui, -apple-system, sans-serif;
395 font-size: 13px;
396 color: var(--html5rw-panel-text);
397 }
398
399 .html5rw-panel-header {
400 display: flex;
401 align-items: center;
402 padding: 12px 16px;
403 background: var(--html5rw-panel-header-bg);
404 border-bottom: 1px solid var(--html5rw-panel-border);
405 border-radius: 8px 8px 0 0;
406 cursor: move;
407 user-select: none;
408 }
409
410 .html5rw-panel-header span { flex: 1; font-weight: 600; }
411
412 .html5rw-panel-header button {
413 width: 24px; height: 24px; margin-left: 8px;
414 border: none; border-radius: 4px;
415 background: transparent; color: var(--html5rw-panel-text);
416 cursor: pointer; font-size: 14px;
417 display: flex; align-items: center; justify-content: center;
418 }
419
420 .html5rw-panel-header button:hover { background: rgba(0, 0, 0, 0.1); }
421 .html5rw-panel-content { padding: 0; }
422 .html5rw-panel-collapsed .html5rw-panel-content { display: none; }
423 .html5rw-panel-collapsed .html5rw-summary-badge { display: block; }
424 .html5rw-summary-badge { display: none; padding: 12px 16px; text-align: center; font-weight: 500; }
425 .html5rw-warning-list { max-height: 400px; overflow-y: auto; }
426
427 .html5rw-warning-row {
428 display: flex; flex-direction: column;
429 padding: 10px 16px;
430 border-bottom: 1px solid var(--html5rw-panel-border);
431 cursor: pointer; transition: background 0.15s;
432 }
433
434 .html5rw-warning-row:hover { background: rgba(0, 0, 0, 0.05); }
435 .html5rw-warning-row:last-child { border-bottom: none; }
436
437 .html5rw-severity-badge {
438 display: inline-block; padding: 2px 6px; border-radius: 3px;
439 font-size: 10px; font-weight: 600; text-transform: uppercase; margin-right: 8px;
440 }
441
442 .html5rw-warning-row-error .html5rw-severity-badge { background: #e74c3c; color: white; }
443 .html5rw-warning-row-warning .html5rw-severity-badge { background: #f39c12; color: white; }
444 .html5rw-warning-row-info .html5rw-severity-badge { background: #3498db; color: white; }
445 .html5rw-message-text { flex: 1; line-height: 1.4; }
446
447 .html5rw-selector-path {
448 display: block; margin-top: 4px; font-size: 11px; color: #888;
449 font-family: monospace; overflow: hidden; text-overflow: ellipsis; white-space: nowrap;
450 }
451
452 .html5rw-panel-dragging { opacity: 0.9; }
453 |} theme_vars in
454
455 let doc = G.document in
456 let style_el = El.v (Jstr.v "style") [El.txt' css] in
457 El.set_at (Jstr.v "data-html5rw-panel-styles") (Some (Jstr.v "true")) style_el;
458 El.append_children (Document.head doc) [style_el];
459 style_el