OCaml HTML5 parser/serialiser based on Python's JustHTML
anil.recoil.org
1(** Typed error codes for HTML5 validation messages. *)
2
3type severity = Error | Warning | Info
4
5type attr_error = [
6 | `Not_allowed of [`Attr of string] * [`Elem of string]
7 | `Not_allowed_here of [`Attr of string]
8 | `Not_allowed_when of [`Attr of string] * [`Elem of string] * [`Condition of string]
9 | `Missing of [`Elem of string] * [`Attr of string]
10 | `Missing_one_of of [`Elem of string] * [`Attrs of string list]
11 | `Bad_value of [`Elem of string] * [`Attr of string] * [`Value of string] * [`Reason of string]
12 | `Bad_value_generic of [`Message of string]
13 | `Duplicate_id of [`Id of string]
14 | `Data_invalid_name of [`Reason of string]
15 | `Data_uppercase
16]
17
18type element_error = [
19 | `Obsolete of [`Elem of string] * [`Suggestion of string]
20 | `Obsolete_attr of [`Elem of string] * [`Attr of string] * [`Suggestion of string option]
21 | `Obsolete_global_attr of [`Attr of string] * [`Suggestion of string]
22 | `Not_allowed_as_child of [`Child of string] * [`Parent of string]
23 | `Unknown of [`Elem of string]
24 | `Must_not_descend of [`Elem of string] * [`Attr of string option] * [`Ancestor of string]
25 | `Missing_child of [`Parent of string] * [`Child of string]
26 | `Missing_child_one_of of [`Parent of string] * [`Children of string list]
27 | `Missing_child_generic of [`Parent of string]
28 | `Must_not_be_empty of [`Elem of string]
29 | `Text_not_allowed of [`Parent of string]
30]
31
32type tag_error = [
33 | `Stray_start of [`Tag of string]
34 | `Stray_end of [`Tag of string]
35 | `End_for_void of [`Tag of string]
36 | `Self_closing_non_void
37 | `Not_in_scope of [`Tag of string]
38 | `End_implied_open of [`Tag of string]
39 | `Start_in_table of [`Tag of string]
40 | `Bad_start_in of [`Tag of string] * [`Context of string]
41 | `Eof_with_open
42]
43
44type char_ref_error = [
45 | `Forbidden_codepoint of [`Codepoint of int]
46 | `Control_char of [`Codepoint of int]
47 | `Non_char of [`Codepoint of int] * [`Astral of bool]
48 | `Unassigned
49 | `Zero
50 | `Out_of_range
51 | `Carriage_return
52]
53
54type aria_error = [
55 | `Unnecessary_role of [`Role of string] * [`Elem of string] * [`Reason of string]
56 | `Bad_role of [`Elem of string] * [`Role of string]
57 | `Must_not_specify of [`Attr of string] * [`Elem of string] * [`Condition of string]
58 | `Must_not_use of [`Attr of string] * [`Elem of string] * [`Condition of string]
59 | `Should_not_use of [`Attr of string] * [`Role of string]
60 | `Hidden_on_body
61 | `Unrecognized_role of [`Token of string]
62 | `Tab_without_tabpanel
63 | `Multiple_main
64 | `Accessible_name_prohibited of [`Attr of string] * [`Elem of string]
65]
66
67type li_role_error = [
68 | `Div_in_dl_bad_role
69 | `Li_bad_role_in_menu
70 | `Li_bad_role_in_tablist
71 | `Li_bad_role_in_list
72]
73
74type table_error = [
75 | `Row_no_cells of [`Row of int]
76 | `Cell_overlap
77 | `Cell_spans_rowgroup
78 | `Column_no_cells of [`Column of int] * [`Elem of string]
79]
80
81type i18n_error = [
82 | `Missing_lang
83 | `Wrong_lang of [`Detected of string] * [`Declared of string] * [`Suggested of string]
84 | `Missing_dir_rtl of [`Language of string]
85 | `Wrong_dir of [`Language of string] * [`Declared of string]
86 | `Xml_lang_without_lang
87 | `Xml_lang_mismatch
88 | `Not_nfc of [`Replacement of string]
89]
90
91type importmap_error = [
92 | `Invalid_json
93 | `Invalid_root
94 | `Imports_not_object
95 | `Empty_key
96 | `Non_string_value
97 | `Key_trailing_slash
98 | `Scopes_not_object
99 | `Scopes_values_not_object
100 | `Scopes_invalid_url
101 | `Scopes_value_invalid_url
102]
103
104type img_error = [
105 | `Missing_alt
106 | `Missing_src_or_srcset
107 | `Empty_alt_with_role
108 | `Ismap_needs_href
109]
110
111type link_error = [
112 | `Missing_href
113 | `As_requires_preload
114 | `Imagesrcset_requires_as_image
115]
116
117type label_error = [
118 | `Too_many_labelable
119 | `For_id_mismatch
120 | `Role_on_ancestor
121 | `Role_on_for
122 | `Aria_label_on_ancestor
123 | `Aria_label_on_for
124]
125
126type input_error = [
127 | `Checkbox_needs_aria_pressed
128 | `Value_constraint of [`Constraint of string]
129 | `List_not_allowed
130 | `List_requires_datalist
131]
132
133type srcset_error = [
134 | `Sizes_without_srcset
135 | `Imagesizes_without_imagesrcset
136 | `W_without_sizes
137 | `Source_missing_srcset
138 | `Source_needs_media_or_type
139 | `Picture_missing_img
140]
141
142type svg_error = [
143 | `Deprecated_attr of [`Attr of string] * [`Elem of string]
144 | `Missing_attr of [`Elem of string] * [`Attr of string]
145]
146
147type misc_error = [
148 | `Option_empty_without_label
149 | `Bdo_missing_dir
150 | `Bdo_dir_auto
151 | `Base_missing_href_or_target
152 | `Base_after_link_script
153 | `Map_id_name_mismatch
154 | `Summary_missing_role
155 | `Summary_missing_attrs
156 | `Summary_role_not_allowed
157 | `Autocomplete_webauthn_on_select
158 | `Commandfor_invalid_target
159 | `Style_type_invalid
160 | `Headingoffset_invalid
161 | `Media_empty
162 | `Media_all
163 | `Multiple_h1
164 | `Multiple_autofocus
165]
166
167type t = [
168 | `Attr of attr_error
169 | `Element of element_error
170 | `Tag of tag_error
171 | `Char_ref of char_ref_error
172 | `Aria of aria_error
173 | `Li_role of li_role_error
174 | `Table of table_error
175 | `I18n of i18n_error
176 | `Importmap of importmap_error
177 | `Img of img_error
178 | `Link of link_error
179 | `Label of label_error
180 | `Input of input_error
181 | `Srcset of srcset_error
182 | `Svg of svg_error
183 | `Misc of misc_error
184 | `Generic of string
185]
186
187(** Get the severity level for an error code *)
188let severity : t -> severity = function
189 (* Info level *)
190 | `I18n `Missing_lang -> Info
191 | `Misc `Multiple_h1 -> Info
192
193 (* Warning level *)
194 | `I18n (`Wrong_lang _) -> Warning
195 | `I18n (`Missing_dir_rtl _) -> Warning
196 | `I18n (`Wrong_dir _) -> Warning
197 | `I18n (`Not_nfc _) -> Warning
198 | `Aria (`Unnecessary_role _) -> Warning
199 | `Aria (`Should_not_use _) -> Warning
200 | `Element (`Unknown _) -> Warning
201
202 (* Everything else is Error *)
203 | _ -> Error
204
205(** Get a short code string for categorization *)
206let code_string : t -> string = function
207 (* Attribute errors *)
208 | `Attr (`Not_allowed _) -> "disallowed-attribute"
209 | `Attr (`Not_allowed_here _) -> "disallowed-attribute"
210 | `Attr (`Not_allowed_when _) -> "disallowed-attribute"
211 | `Attr (`Missing _) -> "missing-required-attribute"
212 | `Attr (`Missing_one_of _) -> "missing-required-attribute"
213 | `Attr (`Bad_value _) -> "bad-attribute-value"
214 | `Attr (`Bad_value_generic _) -> "bad-attribute-value"
215 | `Attr (`Duplicate_id _) -> "duplicate-id"
216 | `Attr (`Data_invalid_name _) -> "bad-attribute-name"
217 | `Attr `Data_uppercase -> "bad-attribute-name"
218
219 (* Element errors *)
220 | `Element (`Obsolete _) -> "obsolete-element"
221 | `Element (`Obsolete_attr _) -> "obsolete-attribute"
222 | `Element (`Obsolete_global_attr _) -> "obsolete-attribute"
223 | `Element (`Not_allowed_as_child _) -> "disallowed-child"
224 | `Element (`Unknown _) -> "unknown-element"
225 | `Element (`Must_not_descend _) -> "prohibited-ancestor"
226 | `Element (`Missing_child _) -> "missing-required-child"
227 | `Element (`Missing_child_one_of _) -> "missing-required-child"
228 | `Element (`Missing_child_generic _) -> "missing-required-child"
229 | `Element (`Must_not_be_empty _) -> "empty-element"
230 | `Element (`Text_not_allowed _) -> "text-not-allowed"
231
232 (* Tag errors *)
233 | `Tag (`Stray_start _) -> "stray-tag"
234 | `Tag (`Stray_end _) -> "stray-tag"
235 | `Tag (`End_for_void _) -> "end-tag-void"
236 | `Tag `Self_closing_non_void -> "self-closing-non-void"
237 | `Tag (`Not_in_scope _) -> "no-element-in-scope"
238 | `Tag (`End_implied_open _) -> "end-tag-implied"
239 | `Tag (`Start_in_table _) -> "start-tag-in-table"
240 | `Tag (`Bad_start_in _) -> "bad-start-tag"
241 | `Tag `Eof_with_open -> "eof-open-elements"
242
243 (* Character reference errors *)
244 | `Char_ref (`Forbidden_codepoint _) -> "forbidden-codepoint"
245 | `Char_ref (`Control_char _) -> "char-ref-control"
246 | `Char_ref (`Non_char _) -> "char-ref-non-char"
247 | `Char_ref `Unassigned -> "char-ref-unassigned"
248 | `Char_ref `Zero -> "char-ref-zero"
249 | `Char_ref `Out_of_range -> "char-ref-range"
250 | `Char_ref `Carriage_return -> "numeric-char-ref"
251
252 (* ARIA errors *)
253 | `Aria (`Unnecessary_role _) -> "unnecessary-role"
254 | `Aria (`Bad_role _) -> "bad-role"
255 | `Aria (`Must_not_specify _) -> "aria-not-allowed"
256 | `Aria (`Must_not_use _) -> "aria-not-allowed"
257 | `Aria (`Should_not_use _) -> "aria-not-allowed"
258 | `Aria `Hidden_on_body -> "aria-not-allowed"
259 | `Aria (`Unrecognized_role _) -> "unrecognized-role"
260 | `Aria `Tab_without_tabpanel -> "tab-without-tabpanel"
261 | `Aria `Multiple_main -> "multiple-main"
262 | `Aria (`Accessible_name_prohibited _) -> "aria-not-allowed"
263
264 (* List item role errors *)
265 | `Li_role `Div_in_dl_bad_role -> "invalid-role"
266 | `Li_role `Li_bad_role_in_menu -> "invalid-role"
267 | `Li_role `Li_bad_role_in_tablist -> "invalid-role"
268 | `Li_role `Li_bad_role_in_list -> "invalid-role"
269
270 (* Table errors *)
271 | `Table (`Row_no_cells _) -> "table-row"
272 | `Table `Cell_overlap -> "table-overlap"
273 | `Table `Cell_spans_rowgroup -> "table-span"
274 | `Table (`Column_no_cells _) -> "table-column"
275
276 (* I18n errors *)
277 | `I18n `Missing_lang -> "missing-lang"
278 | `I18n (`Wrong_lang _) -> "wrong-lang"
279 | `I18n (`Missing_dir_rtl _) -> "missing-dir"
280 | `I18n (`Wrong_dir _) -> "wrong-dir"
281 | `I18n `Xml_lang_without_lang -> "xml-lang"
282 | `I18n `Xml_lang_mismatch -> "xml-lang-mismatch"
283 | `I18n (`Not_nfc _) -> "unicode-normalization"
284
285 (* Import map errors *)
286 | `Importmap `Invalid_json -> "importmap"
287 | `Importmap `Invalid_root -> "importmap"
288 | `Importmap `Imports_not_object -> "importmap"
289 | `Importmap `Empty_key -> "importmap"
290 | `Importmap `Non_string_value -> "importmap"
291 | `Importmap `Key_trailing_slash -> "importmap"
292 | `Importmap `Scopes_not_object -> "importmap"
293 | `Importmap `Scopes_values_not_object -> "importmap"
294 | `Importmap `Scopes_invalid_url -> "importmap"
295 | `Importmap `Scopes_value_invalid_url -> "importmap"
296
297 (* Image errors *)
298 | `Img `Missing_alt -> "missing-alt"
299 | `Img `Missing_src_or_srcset -> "missing-src"
300 | `Img `Empty_alt_with_role -> "img-alt-role"
301 | `Img `Ismap_needs_href -> "ismap-needs-href"
302
303 (* Link errors *)
304 | `Link `Missing_href -> "missing-href"
305 | `Link `As_requires_preload -> "link-as-preload"
306 | `Link `Imagesrcset_requires_as_image -> "link-imagesrcset"
307
308 (* Label errors *)
309 | `Label `Too_many_labelable -> "label-multiple"
310 | `Label `For_id_mismatch -> "label-for-mismatch"
311 | `Label `Role_on_ancestor -> "role-on-label"
312 | `Label `Role_on_for -> "role-on-label"
313 | `Label `Aria_label_on_ancestor -> "aria-label-on-label"
314 | `Label `Aria_label_on_for -> "aria-label-on-label"
315
316 (* Input errors *)
317 | `Input `Checkbox_needs_aria_pressed -> "missing-aria-pressed"
318 | `Input (`Value_constraint _) -> "input-value"
319 | `Input `List_not_allowed -> "list-not-allowed"
320 | `Input `List_requires_datalist -> "list-datalist"
321
322 (* Srcset errors *)
323 | `Srcset `Sizes_without_srcset -> "sizes-without-srcset"
324 | `Srcset `Imagesizes_without_imagesrcset -> "imagesizes-without-srcset"
325 | `Srcset `W_without_sizes -> "srcset-needs-sizes"
326 | `Srcset `Source_missing_srcset -> "missing-srcset"
327 | `Srcset `Source_needs_media_or_type -> "source-needs-media"
328 | `Srcset `Picture_missing_img -> "picture-missing-img"
329
330 (* SVG errors *)
331 | `Svg (`Deprecated_attr _) -> "svg-deprecated"
332 | `Svg (`Missing_attr _) -> "missing-required-attribute"
333
334 (* Misc errors *)
335 | `Misc `Option_empty_without_label -> "empty-option"
336 | `Misc `Bdo_missing_dir -> "missing-dir"
337 | `Misc `Bdo_dir_auto -> "bdo-dir-auto"
338 | `Misc `Base_missing_href_or_target -> "missing-required-attribute"
339 | `Misc `Base_after_link_script -> "base-position"
340 | `Misc `Map_id_name_mismatch -> "map-id-name"
341 | `Misc `Summary_missing_role -> "summary-role"
342 | `Misc `Summary_missing_attrs -> "summary-attrs"
343 | `Misc `Summary_role_not_allowed -> "summary-role"
344 | `Misc `Autocomplete_webauthn_on_select -> "autocomplete"
345 | `Misc `Commandfor_invalid_target -> "commandfor"
346 | `Misc `Style_type_invalid -> "style-type"
347 | `Misc `Headingoffset_invalid -> "headingoffset"
348 | `Misc `Media_empty -> "media-empty"
349 | `Misc `Media_all -> "media-all"
350 | `Misc `Multiple_h1 -> "multiple-h1"
351 | `Misc `Multiple_autofocus -> "multiple-autofocus"
352
353 (* Generic *)
354 | `Generic _ -> "generic"
355
356(** Format using curly quotes (Unicode) *)
357let q s = "\xe2\x80\x9c" ^ s ^ "\xe2\x80\x9d"
358
359(** Convert error code to exact Nu validator message string *)
360let to_message : t -> string = function
361 (* Attribute errors *)
362 | `Attr (`Not_allowed (`Attr attr, `Elem element)) ->
363 Printf.sprintf "Attribute %s not allowed on element %s at this point."
364 (q attr) (q element)
365 | `Attr (`Not_allowed_here (`Attr attr)) ->
366 Printf.sprintf "Attribute %s not allowed here." (q attr)
367 | `Attr (`Not_allowed_when (`Attr attr, `Elem _, `Condition condition)) ->
368 Printf.sprintf "The %s attribute must not be used on any element which has %s." (q attr) condition
369 | `Attr (`Missing (`Elem element, `Attr attr)) ->
370 Printf.sprintf "Element %s is missing required attribute %s."
371 (q element) (q attr)
372 | `Attr (`Missing_one_of (`Elem element, `Attrs attrs)) ->
373 let attrs_str = String.concat ", " attrs in
374 Printf.sprintf "Element %s is missing one or more of the following attributes: [%s]."
375 (q element) attrs_str
376 | `Attr (`Bad_value (`Elem element, `Attr attr, `Value value, `Reason reason)) ->
377 if reason = "" then
378 Printf.sprintf "Bad value %s for attribute %s on element %s."
379 (q value) (q attr) (q element)
380 else
381 Printf.sprintf "Bad value %s for attribute %s on element %s: %s"
382 (q value) (q attr) (q element) reason
383 | `Attr (`Bad_value_generic (`Message message)) -> message
384 | `Attr (`Duplicate_id (`Id id)) ->
385 Printf.sprintf "Duplicate ID %s." (q id)
386 | `Attr (`Data_invalid_name (`Reason reason)) ->
387 Printf.sprintf "%s attribute names %s." (q "data-*") reason
388 | `Attr `Data_uppercase ->
389 Printf.sprintf "%s attributes must not have characters from the range %s\xe2\x80\xa6%s in the name."
390 (q "data-*") (q "A") (q "Z")
391
392 (* Element errors *)
393 | `Element (`Obsolete (`Elem element, `Suggestion suggestion)) ->
394 if suggestion = "" then
395 Printf.sprintf "The %s element is obsolete." (q element)
396 else
397 Printf.sprintf "The %s element is obsolete. %s" (q element) suggestion
398 | `Element (`Obsolete_attr (`Elem element, `Attr attr, `Suggestion suggestion)) ->
399 let base = Printf.sprintf "The %s attribute on the %s element is obsolete."
400 (q attr) (q element) in
401 (match suggestion with Some s -> base ^ " " ^ s | None -> base)
402 | `Element (`Obsolete_global_attr (`Attr attr, `Suggestion suggestion)) ->
403 Printf.sprintf "The %s attribute is obsolete. %s" (q attr) suggestion
404 | `Element (`Not_allowed_as_child (`Child child, `Parent parent)) ->
405 Printf.sprintf "Element %s not allowed as child of element %s in this context. (Suppressing further errors from this subtree.)"
406 (q child) (q parent)
407 | `Element (`Unknown (`Elem name)) ->
408 Printf.sprintf "Unknown element %s." (q name)
409 | `Element (`Must_not_descend (`Elem element, `Attr attr, `Ancestor ancestor)) ->
410 (match attr with
411 | Some a ->
412 Printf.sprintf "The element %s with the attribute %s must not appear as a descendant of the %s element."
413 (q element) (q a) (q ancestor)
414 | None ->
415 Printf.sprintf "The element %s must not appear as a descendant of the %s element."
416 (q element) (q ancestor))
417 | `Element (`Missing_child (`Parent parent, `Child child)) ->
418 Printf.sprintf "Element %s is missing required child element %s."
419 (q parent) (q child)
420 | `Element (`Missing_child_one_of (`Parent parent, `Children children)) ->
421 let children_str = String.concat ", " children in
422 Printf.sprintf "Element %s is missing one or more of the following child elements: [%s]."
423 (q parent) children_str
424 | `Element (`Missing_child_generic (`Parent parent)) ->
425 Printf.sprintf "Element %s is missing a required child element." (q parent)
426 | `Element (`Must_not_be_empty (`Elem element)) ->
427 Printf.sprintf "Element %s must not be empty." (q element)
428 | `Element (`Text_not_allowed (`Parent parent)) ->
429 Printf.sprintf "Text not allowed in element %s in this context." (q parent)
430
431 (* Tag errors *)
432 | `Tag (`Stray_start (`Tag tag)) ->
433 Printf.sprintf "Stray start tag %s." (q tag)
434 | `Tag (`Stray_end (`Tag tag)) ->
435 Printf.sprintf "Stray end tag %s." (q tag)
436 | `Tag (`End_for_void (`Tag tag)) ->
437 Printf.sprintf "End tag %s." (q tag)
438 | `Tag `Self_closing_non_void ->
439 Printf.sprintf "Self-closing syntax (%s) used on a non-void HTML element. Ignoring the slash and treating as a start tag."
440 (q "/>")
441 | `Tag (`Not_in_scope (`Tag tag)) ->
442 Printf.sprintf "No %s element in scope but a %s end tag seen."
443 (q tag) (q tag)
444 | `Tag (`End_implied_open (`Tag tag)) ->
445 Printf.sprintf "End tag %s implied, but there were open elements."
446 (q tag)
447 | `Tag (`Start_in_table (`Tag tag)) ->
448 Printf.sprintf "Start tag %s seen in %s." (q tag) (q "table")
449 | `Tag (`Bad_start_in (`Tag tag, `Context _)) ->
450 Printf.sprintf "Bad start tag in %s in %s in %s."
451 (q tag) (q "noscript") (q "head")
452 | `Tag `Eof_with_open ->
453 "End of file seen and there were open elements."
454
455 (* Character reference errors *)
456 | `Char_ref (`Forbidden_codepoint (`Codepoint codepoint)) ->
457 Printf.sprintf "Forbidden code point U+%04x." codepoint
458 | `Char_ref (`Control_char (`Codepoint codepoint)) ->
459 Printf.sprintf "Character reference expands to a control character (U+%04x)." codepoint
460 | `Char_ref (`Non_char (`Codepoint codepoint, `Astral astral)) ->
461 if astral then
462 Printf.sprintf "Character reference expands to an astral non-character (U+%05x)." codepoint
463 else
464 Printf.sprintf "Character reference expands to a non-character (U+%04x)." codepoint
465 | `Char_ref `Unassigned ->
466 "Character reference expands to a permanently unassigned code point."
467 | `Char_ref `Zero ->
468 "Character reference expands to zero."
469 | `Char_ref `Out_of_range ->
470 "Character reference outside the permissible Unicode range."
471 | `Char_ref `Carriage_return ->
472 "A numeric character reference expanded to carriage return."
473
474 (* ARIA errors *)
475 | `Aria (`Unnecessary_role (`Role role, `Elem _, `Reason reason)) ->
476 Printf.sprintf "The %s role is unnecessary %s."
477 (q role) reason
478 | `Aria (`Bad_role (`Elem element, `Role role)) ->
479 Printf.sprintf "Bad value %s for attribute %s on element %s."
480 (q role) (q "role") (q element)
481 | `Aria (`Must_not_specify (`Attr attr, `Elem element, `Condition condition)) ->
482 Printf.sprintf "The %s attribute must not be specified on any %s element unless %s."
483 (q attr) (q element) condition
484 | `Aria (`Must_not_use (`Attr attr, `Elem element, `Condition condition)) ->
485 Printf.sprintf "The %s attribute must not be used on an %s element which has %s."
486 (q attr) (q element) condition
487 | `Aria (`Should_not_use (`Attr attr, `Role role)) ->
488 Printf.sprintf "The %s attribute should not be used on any element which has %s."
489 (q attr) (q ("role=" ^ role))
490 | `Aria `Hidden_on_body ->
491 Printf.sprintf "%s must not be used on the %s element."
492 (q "aria-hidden=true") (q "body")
493 | `Aria (`Unrecognized_role (`Token token)) ->
494 Printf.sprintf "Discarding unrecognized token %s from value of attribute %s. Browsers ignore any token that is not a defined ARIA non-abstract role."
495 (q token) (q "role")
496 | `Aria `Tab_without_tabpanel ->
497 Printf.sprintf "Every active %s element must have a corresponding %s element."
498 (q "role=tab") (q "role=tabpanel")
499 | `Aria `Multiple_main ->
500 Printf.sprintf "A document should not include more than one visible element with %s."
501 (q "role=main")
502 | `Aria (`Accessible_name_prohibited (`Attr attr, `Elem element)) ->
503 (* Roles that prohibit accessible names - defined by ARIA spec *)
504 let prohibited_roles = [
505 "caption"; "code"; "deletion"; "emphasis"; "generic"; "insertion";
506 "paragraph"; "presentation"; "strong"; "subscript"; "superscript"
507 ] in
508 let roles_str = String.concat ", " (List.map q (List.rev (List.tl (List.rev prohibited_roles)))) ^
509 ", or " ^ q (List.hd (List.rev prohibited_roles)) in
510 Printf.sprintf "The %s attribute must not be specified on any %s element unless the element has a %s value other than %s."
511 (q attr) (q element) (q "role") roles_str
512
513 (* List item role errors *)
514 | `Li_role `Div_in_dl_bad_role ->
515 Printf.sprintf "A %s child of a %s element must not have any %s value other than %s or %s."
516 (q "div") (q "dl") (q "role") (q "presentation") (q "none")
517 | `Li_role `Li_bad_role_in_menu ->
518 Printf.sprintf "An %s element that is a descendant of a %s element or %s element must not have any %s value other than %s, %s, %s, %s, or %s."
519 (q "li") (q "role=menu") (q "role=menubar") (q "role")
520 (q "group") (q "menuitem") (q "menuitemcheckbox") (q "menuitemradio") (q "separator")
521 | `Li_role `Li_bad_role_in_tablist ->
522 Printf.sprintf "An %s element that is a descendant of a %s element must not have any %s value other than %s."
523 (q "li") (q "role=tablist") (q "role") (q "tab")
524 | `Li_role `Li_bad_role_in_list ->
525 Printf.sprintf "An %s element that is a descendant of a %s, %s, or %s element with no explicit %s value, or a descendant of a %s element, must not have any %s value other than %s."
526 (q "li") (q "ul") (q "ol") (q "menu") (q "role") (q "role=list") (q "role") (q "listitem")
527
528 (* Table errors *)
529 | `Table (`Row_no_cells (`Row row)) ->
530 Printf.sprintf "Row %d of an implicit row group has no cells beginning on it." row
531 | `Table `Cell_overlap ->
532 "Table cell is overlapped by later table cell."
533 | `Table `Cell_spans_rowgroup ->
534 Printf.sprintf "Table cell spans past the end of its row group established by a %s element; clipped to the end of the row group."
535 (q "tbody")
536 | `Table (`Column_no_cells (`Column column, `Elem element)) ->
537 Printf.sprintf "Table column %d established by element %s has no cells beginning in it."
538 column (q element)
539
540 (* I18n errors *)
541 | `I18n `Missing_lang ->
542 Printf.sprintf "Consider adding a %s attribute to the %s start tag to declare the language of this document."
543 (q "lang") (q "html")
544 | `I18n (`Wrong_lang (`Detected detected, `Declared declared, `Suggested suggested)) ->
545 Printf.sprintf "This document appears to be written in %s but the %s start tag has %s. Consider using %s (or variant) instead."
546 detected (q "html") (q ("lang=\"" ^ declared ^ "\"")) (q ("lang=\"" ^ suggested ^ "\""))
547 | `I18n (`Missing_dir_rtl (`Language language)) ->
548 Printf.sprintf "This document appears to be written in %s. Consider adding %s to the %s start tag."
549 language (q "dir=\"rtl\"") (q "html")
550 | `I18n (`Wrong_dir (`Language language, `Declared declared)) ->
551 Printf.sprintf "This document appears to be written in %s but the %s start tag has %s. Consider using %s instead."
552 language (q "html") (q ("dir=\"" ^ declared ^ "\"")) (q "dir=\"rtl\"")
553 | `I18n `Xml_lang_without_lang ->
554 Printf.sprintf "When the attribute %s in no namespace is specified, the element must also have the attribute %s present with the same value."
555 (q "xml:lang") (q "lang")
556 | `I18n `Xml_lang_mismatch ->
557 Printf.sprintf "The %s and %s attributes must have the same value."
558 (q "xml:lang") (q "lang")
559 | `I18n (`Not_nfc (`Replacement replacement)) ->
560 Printf.sprintf "Text run is not in Unicode Normalization Form C. Should instead be %s. (Copy and paste that into your source document to replace the un-normalized text.)"
561 (q replacement)
562
563 (* Import map errors *)
564 | `Importmap `Invalid_json ->
565 Printf.sprintf "A script %s with a %s attribute whose value is %s must have valid JSON content."
566 (q "script") (q "type") (q "importmap")
567 | `Importmap `Invalid_root ->
568 Printf.sprintf "A %s element with a %s attribute whose value is %s must contain a JSON object with no properties other than %s, %s, and %s."
569 (q "script") (q "type") (q "importmap") (q "imports") (q "scopes") (q "integrity")
570 | `Importmap `Imports_not_object ->
571 Printf.sprintf "The value of the %s property within the content of a %s element with a %s attribute whose value is %s must be a JSON object."
572 (q "imports") (q "script") (q "type") (q "importmap")
573 | `Importmap `Empty_key ->
574 Printf.sprintf "A specifier map defined in a %s property within the content of a %s element with a %s attribute whose value is %s must only contain non-empty keys."
575 (q "imports") (q "script") (q "type") (q "importmap")
576 | `Importmap `Non_string_value ->
577 Printf.sprintf "A specifier map defined in a %s property within the content of a %s element with a %s attribute whose value is %s must only contain string values."
578 (q "imports") (q "script") (q "type") (q "importmap")
579 | `Importmap `Key_trailing_slash ->
580 Printf.sprintf "A specifier map defined in a %s property within the content of a %s element with a %s attribute whose value is %s must have values that end with %s when its corresponding key ends with %s."
581 (q "imports") (q "script") (q "type") (q "importmap") (q "/") (q "/")
582 | `Importmap `Scopes_not_object ->
583 Printf.sprintf "The value of the %s property within the content of a %s element with a %s attribute whose value is %s must be a JSON object whose keys are valid URL strings."
584 (q "scopes") (q "script") (q "type") (q "importmap")
585 | `Importmap `Scopes_values_not_object ->
586 Printf.sprintf "The value of the %s property within the content of a %s element with a %s attribute whose value is %s must be a JSON object whose values are also JSON objects."
587 (q "scopes") (q "script") (q "type") (q "importmap")
588 | `Importmap `Scopes_invalid_url ->
589 Printf.sprintf "The value of the %s property within the content of a %s element with a %s attribute whose value is %s must be a JSON object whose keys are valid URL strings."
590 (q "scopes") (q "script") (q "type") (q "importmap")
591 | `Importmap `Scopes_value_invalid_url ->
592 Printf.sprintf "A specifier map defined in a %s property within the content of a %s element with a %s attribute whose value is %s must only contain valid URL values."
593 (q "scopes") (q "script") (q "type") (q "importmap")
594
595 (* Image errors *)
596 | `Img `Missing_alt ->
597 Printf.sprintf "An %s element must have an %s attribute, except under certain conditions. For details, consult guidance on providing text alternatives for images."
598 (q "img") (q "alt")
599 | `Img `Missing_src_or_srcset ->
600 Printf.sprintf "Element %s is missing one or more of the following attributes: [src, srcset]."
601 (q "img")
602 | `Img `Empty_alt_with_role ->
603 Printf.sprintf "An %s element which has an %s attribute whose value is the empty string must not have a %s attribute."
604 (q "img") (q "alt") (q "role")
605 | `Img `Ismap_needs_href ->
606 Printf.sprintf "The %s element with the %s attribute set must have an %s ancestor with the %s attribute."
607 (q "img") (q "ismap") (q "a") (q "href")
608
609 (* Link errors *)
610 | `Link `Missing_href ->
611 Printf.sprintf "A %s element must have an %s or %s attribute, or both."
612 (q "link") (q "href") (q "imagesrcset")
613 | `Link `As_requires_preload ->
614 Printf.sprintf "A %s element with an %s attribute must have a %s attribute that contains the value %s or the value %s."
615 (q "link") (q "as") (q "rel") (q "preload") (q "modulepreload")
616 | `Link `Imagesrcset_requires_as_image ->
617 Printf.sprintf "A %s element with an %s attribute must have an %s attribute with value %s."
618 (q "link") (q "imagesrcset") (q "as") (q "image")
619
620 (* Label errors *)
621 | `Label `Too_many_labelable ->
622 Printf.sprintf "The %s element may contain at most one %s, %s, %s, %s, %s, %s, or %s descendant."
623 (q "label") (q "button") (q "input") (q "meter") (q "output") (q "progress") (q "select") (q "textarea")
624 | `Label `For_id_mismatch ->
625 Printf.sprintf "Any %s descendant of a %s element with a %s attribute must have an ID value that matches that %s attribute."
626 (q "input") (q "label") (q "for") (q "for")
627 | `Label `Role_on_ancestor ->
628 Printf.sprintf "The %s attribute must not be used on any %s element that is an ancestor of a labelable element."
629 (q "role") (q "label")
630 | `Label `Role_on_for ->
631 Printf.sprintf "The %s attribute must not be used on any %s element that is associated with a labelable element."
632 (q "role") (q "label")
633 | `Label `Aria_label_on_ancestor ->
634 Printf.sprintf "The %s attribute must not be used on any %s element that is an ancestor of a labelable element."
635 (q "aria-label") (q "label")
636 | `Label `Aria_label_on_for ->
637 Printf.sprintf "The %s attribute must not be used on any %s element that is associated with a labelable element."
638 (q "aria-label") (q "label")
639
640 (* Input errors *)
641 | `Input `Checkbox_needs_aria_pressed ->
642 Printf.sprintf "An %s element with a %s attribute whose value is %s and with a %s attribute whose value is %s must have an %s attribute."
643 (q "input") (q "type") (q "checkbox") (q "role") (q "button") (q "aria-pressed")
644 | `Input (`Value_constraint (`Constraint constraint_type)) -> constraint_type
645 | `Input `List_not_allowed ->
646 Printf.sprintf "Attribute %s is only allowed when the input type is %s, %s, %s, %s, %s, %s, %s, %s, %s, %s, %s, %s, or %s."
647 (q "list") (q "color") (q "date") (q "datetime-local") (q "email") (q "month")
648 (q "number") (q "range") (q "search") (q "tel") (q "text") (q "time") (q "url") (q "week")
649 | `Input `List_requires_datalist ->
650 Printf.sprintf "The %s attribute of the %s element must refer to a %s element."
651 (q "list") (q "input") (q "datalist")
652
653 (* Srcset errors *)
654 | `Srcset `Sizes_without_srcset ->
655 Printf.sprintf "The %s attribute must only be specified if the %s attribute is also specified."
656 (q "sizes") (q "srcset")
657 | `Srcset `Imagesizes_without_imagesrcset ->
658 Printf.sprintf "The %s attribute must only be specified if the %s attribute is also specified."
659 (q "imagesizes") (q "imagesrcset")
660 | `Srcset `W_without_sizes ->
661 Printf.sprintf "When the %s attribute has any image candidate string with a width descriptor, the %s attribute must also be specified."
662 (q "srcset") (q "sizes")
663 | `Srcset `Source_missing_srcset ->
664 Printf.sprintf "Element %s is missing required attribute %s."
665 (q "source") (q "srcset")
666 | `Srcset `Source_needs_media_or_type ->
667 Printf.sprintf "A %s element that has a following sibling %s element or %s element with a %s attribute must have a %s attribute and/or %s attribute."
668 (q "source") (q "source") (q "img") (q "srcset") (q "media") (q "type")
669 | `Srcset `Picture_missing_img ->
670 Printf.sprintf "Element %s is missing required child element %s."
671 (q "picture") (q "img")
672
673 (* SVG errors *)
674 | `Svg (`Deprecated_attr (`Attr attr, `Elem element)) ->
675 Printf.sprintf "Attribute %s not allowed on element %s at this point."
676 (q attr) (q element)
677 | `Svg (`Missing_attr (`Elem element, `Attr attr)) ->
678 Printf.sprintf "Element %s is missing required attribute %s."
679 (q element) (q attr)
680
681 (* Misc errors *)
682 | `Misc `Option_empty_without_label ->
683 Printf.sprintf "Element %s without attribute %s must not be empty."
684 (q "option") (q "label")
685 | `Misc `Bdo_missing_dir ->
686 Printf.sprintf "Element %s must have attribute %s." (q "bdo") (q "dir")
687 | `Misc `Bdo_dir_auto ->
688 Printf.sprintf "The value of %s attribute for the %s element must not be %s."
689 (q "dir") (q "bdo") (q "auto")
690 | `Misc `Base_missing_href_or_target ->
691 Printf.sprintf "Element %s is missing one or more of the following attributes: [href, target]."
692 (q "base")
693 | `Misc `Base_after_link_script ->
694 Printf.sprintf "The %s element must come before any %s or %s elements in the document."
695 (q "base") (q "link") (q "script")
696 | `Misc `Map_id_name_mismatch ->
697 Printf.sprintf "The %s attribute on a %s element must have an the same value as the %s attribute."
698 (q "id") (q "map") (q "name")
699 | `Misc `Summary_missing_role ->
700 Printf.sprintf "Element %s is missing required attribute %s."
701 (q "summary") (q "role")
702 | `Misc `Summary_missing_attrs ->
703 Printf.sprintf "Element %s is missing one or more of the following attributes: [aria-checked, aria-level, role]."
704 (q "summary")
705 | `Misc `Summary_role_not_allowed ->
706 Printf.sprintf "The %s attribute must not be used on any %s element that is a summary for its parent %s element."
707 (q "role") (q "summary") (q "details")
708 | `Misc `Autocomplete_webauthn_on_select ->
709 Printf.sprintf "The value of the %s attribute for the %s element must not contain %s."
710 (q "autocomplete") (q "select") (q "webauthn")
711 | `Misc `Commandfor_invalid_target ->
712 Printf.sprintf "The value of the %s attribute of the %s element must be the ID of an element in the same tree as the %s with the %s attribute."
713 (q "commandfor") (q "button") (q "button") (q "commandfor")
714 | `Misc `Style_type_invalid ->
715 Printf.sprintf "The only allowed value for the %s attribute for the %s element is %s (with no parameters). (But the attribute is not needed and should be omitted altogether.)"
716 (q "type") (q "style") (q "text/css")
717 | `Misc `Headingoffset_invalid ->
718 Printf.sprintf "The value of the %s attribute must be a number between %s and %s."
719 (q "headingoffset") (q "0") (q "8")
720 | `Misc `Media_empty ->
721 Printf.sprintf "Value of %s attribute here must not be empty." (q "media")
722 | `Misc `Media_all ->
723 Printf.sprintf "Value of %s attribute here must not be %s." (q "media") (q "all")
724 | `Misc `Multiple_h1 ->
725 Printf.sprintf "Consider using only one %s element per document (or, if using %s elements multiple times is required, consider using the %s attribute to indicate that these %s elements are not all top-level headings)."
726 (q "h1") (q "h1") (q "headingoffset") (q "h1")
727 | `Misc `Multiple_autofocus ->
728 Printf.sprintf "There must not be two elements with the same %s that both have the %s attribute specified."
729 (q "nearest ancestor autofocus scoping root element") (q "autofocus")
730
731 (* Generic *)
732 | `Generic message -> message
733
734(** {2 Error Construction Helpers} *)
735
736(** Create a bad attribute value error with element, attribute, value, and reason. *)
737let bad_value ~element ~attr ~value ~reason : t =
738 `Attr (`Bad_value (`Elem element, `Attr attr, `Value value, `Reason reason))
739
740(** Create a bad attribute value error with just a message. *)
741let bad_value_msg msg : t =
742 `Attr (`Bad_value_generic (`Message msg))
743
744(** Create a missing required attribute error. *)
745let missing_attr ~element ~attr : t =
746 `Attr (`Missing (`Elem element, `Attr attr))
747
748(** Create an attribute not allowed error. *)
749let attr_not_allowed ~element ~attr : t =
750 `Attr (`Not_allowed (`Attr attr, `Elem element))
751
752(** Create an element not allowed as child error. *)
753let not_allowed_as_child ~child ~parent : t =
754 `Element (`Not_allowed_as_child (`Child child, `Parent parent))
755
756(** Create a must not be empty error. *)
757let must_not_be_empty ~element : t =
758 `Element (`Must_not_be_empty (`Elem element))