anil.recoil.org
+683
lib/html5_checker/error_code.ml
+683
lib/html5_checker/error_code.ml
···
1
+
(** Typed error codes for HTML5 validation messages.
2
+
3
+
This module defines a comprehensive variant type for all validation errors,
4
+
ensuring exact message matching with the Nu HTML Validator test suite. *)
5
+
6
+
(** Severity level of a validation message *)
7
+
type severity = Error | Warning | Info
8
+
9
+
(** Typed error codes with associated data *)
10
+
type t =
11
+
(* ===== Attribute Errors ===== *)
12
+
| Attr_not_allowed_on_element of { attr: string; element: string }
13
+
(** Attribute "X" not allowed on element "Y" at this point. *)
14
+
| Attr_not_allowed_here of { attr: string }
15
+
(** Attribute "X" not allowed here. *)
16
+
| Attr_not_allowed_when of { attr: string; element: string; condition: string }
17
+
(** Attribute "X" is only allowed when ... *)
18
+
| Missing_required_attr of { element: string; attr: string }
19
+
(** Element "X" is missing required attribute "Y". *)
20
+
| Missing_required_attr_one_of of { element: string; attrs: string list }
21
+
(** Element "X" is missing one or more of the following attributes: [A, B]. *)
22
+
| Bad_attr_value of { element: string; attr: string; value: string; reason: string }
23
+
(** Bad value "X" for attribute "Y" on element "Z". *)
24
+
| Bad_attr_value_generic of { message: string }
25
+
(** Generic bad attribute value message *)
26
+
| Duplicate_id of { id: string }
27
+
(** Duplicate ID "X". *)
28
+
| Data_attr_invalid_name of { reason: string }
29
+
(** "data-*" attribute names must be XML 1.0 4th ed. plus Namespaces NCNames. *)
30
+
| Data_attr_uppercase
31
+
(** "data-*" attributes must not have characters from the range "A"…"Z" in the name. *)
32
+
33
+
(* ===== Element Errors ===== *)
34
+
| Obsolete_element of { element: string; suggestion: string }
35
+
(** The "X" element is obsolete. Y *)
36
+
| Obsolete_attr of { element: string; attr: string; suggestion: string option }
37
+
(** The "X" attribute on the "Y" element is obsolete. *)
38
+
| Element_not_allowed_as_child of { child: string; parent: string }
39
+
(** Element "X" not allowed as child of element "Y" in this context. *)
40
+
| Element_must_not_be_descendant of { element: string; attr: string option; ancestor: string }
41
+
(** The element "X" [with attribute "A"] must not appear as a descendant of the "Y" element. *)
42
+
| Missing_required_child of { parent: string; child: string }
43
+
(** Element "X" is missing required child element "Y". *)
44
+
| Missing_required_child_one_of of { parent: string; children: string list }
45
+
(** Element "X" is missing one or more of the following child elements: [A, B]. *)
46
+
| Missing_required_child_generic of { parent: string }
47
+
(** Element "X" is missing a required child element. *)
48
+
| Element_must_not_be_empty of { element: string }
49
+
(** Element "X" must not be empty. *)
50
+
| Stray_start_tag of { tag: string }
51
+
(** Stray start tag "X". *)
52
+
| Stray_end_tag of { tag: string }
53
+
(** Stray end tag "X". *)
54
+
| End_tag_for_void_element of { tag: string }
55
+
(** End tag "X". (for void elements like br) *)
56
+
| Self_closing_non_void
57
+
(** Self-closing syntax used on a non-void HTML element. *)
58
+
| Text_not_allowed of { parent: string }
59
+
(** Text not allowed in element "X" in this context. *)
60
+
61
+
(* ===== Child Restrictions ===== *)
62
+
| Div_child_of_dl_bad_role
63
+
(** A "div" child of a "dl" element must not have any "role" value other than "presentation" or "none". *)
64
+
| Li_bad_role_in_menu
65
+
(** An "li" element descendant of role=menu/menubar must have specific roles. *)
66
+
| Li_bad_role_in_tablist
67
+
(** An "li" element descendant of role=tablist must have role=tab. *)
68
+
| Li_bad_role_in_list
69
+
(** An "li" element descendant of ul/ol/menu or role=list must have role=listitem. *)
70
+
71
+
(* ===== ARIA Errors ===== *)
72
+
| Unnecessary_role of { role: string; element: string; reason: string }
73
+
(** The "X" role is unnecessary for Y. *)
74
+
| Bad_role of { element: string; role: string }
75
+
(** Bad value "X" for attribute "role" on element "Y". *)
76
+
| Aria_must_not_be_specified of { attr: string; element: string; condition: string }
77
+
(** The "X" attribute must not be specified on any "Y" element unless... *)
78
+
| Aria_must_not_be_used of { attr: string; element: string; condition: string }
79
+
(** The "X" attribute must not be used on an "Y" element which has... *)
80
+
| Aria_should_not_be_used of { attr: string; role: string }
81
+
(** The "X" attribute should not be used on any element which has "role=Y". *)
82
+
| Img_empty_alt_with_role
83
+
(** An "img" element with empty alt must not have a role attribute. *)
84
+
| Checkbox_button_needs_aria_pressed
85
+
(** An "input" type="checkbox" with role="button" must have aria-pressed. *)
86
+
| Tab_without_tabpanel
87
+
(** Every active "role=tab" element must have a corresponding "role=tabpanel" element. *)
88
+
| Multiple_main_visible
89
+
(** A document should not include more than one visible element with "role=main". *)
90
+
| Discarding_unrecognized_role of { token: string }
91
+
(** Discarding unrecognized token "X" from value of attribute "role". *)
92
+
93
+
(* ===== Required Attribute/Element Conditions ===== *)
94
+
| Img_missing_alt
95
+
(** An "img" element must have an "alt" attribute. *)
96
+
| Img_missing_src_or_srcset
97
+
(** Element "img" is missing one or more of the following attributes: [src, srcset]. *)
98
+
| Option_empty_without_label
99
+
(** Element "option" without attribute "label" must not be empty. *)
100
+
| Bdo_missing_dir
101
+
(** Element "bdo" must have attribute "dir". *)
102
+
| Bdo_dir_auto
103
+
(** The value of "dir" attribute for the "bdo" element must not be "auto". *)
104
+
| Base_missing_href_or_target
105
+
(** Element "base" is missing one or more of the following attributes: [href, target]. *)
106
+
| Base_after_link_script
107
+
(** The "base" element must come before any "link" or "script" elements. *)
108
+
| Link_missing_href
109
+
(** A "link" element must have an "href" or "imagesrcset" attribute. *)
110
+
| Link_as_requires_preload
111
+
(** A "link" element with an "as" attribute must have rel="preload" or "modulepreload". *)
112
+
| Link_imagesrcset_requires_as_image
113
+
(** A "link" element with "imagesrcset" must have as="image". *)
114
+
| Img_ismap_needs_a_href
115
+
(** The "img" element with "ismap" must have an "a" ancestor with "href". *)
116
+
| Sizes_without_srcset
117
+
(** The "sizes" attribute must only be specified if "srcset" is also specified. *)
118
+
| Imagesizes_without_imagesrcset
119
+
(** The "imagesizes" attribute must only be specified if "imagesrcset" is also specified. *)
120
+
| Srcset_w_without_sizes
121
+
(** When the "srcset" attribute has width descriptors, "sizes" must also be specified. *)
122
+
| Source_missing_srcset
123
+
(** Element "source" is missing required attribute "srcset". *)
124
+
| Source_needs_media_or_type
125
+
(** A "source" element with following source/img[srcset] must have media/type. *)
126
+
| Picture_missing_img
127
+
(** Element "picture" is missing required child element "img". *)
128
+
| Map_id_name_mismatch
129
+
(** The "id" attribute on a "map" element must have the same value as the "name" attribute. *)
130
+
| List_attr_requires_datalist
131
+
(** The "list" attribute of "input" must refer to a "datalist" element. *)
132
+
| Label_too_many_labelable
133
+
(** The "label" element may contain at most one labelable descendant. *)
134
+
| Label_for_id_mismatch
135
+
(** Any "input" descendant of a "label" with "for" must have matching ID. *)
136
+
| Input_value_constraint of { constraint_type: string }
137
+
(** The value of the "value" attribute must be... *)
138
+
| Summary_missing_role
139
+
(** Element "summary" is missing required attribute "role". *)
140
+
| Summary_missing_attrs
141
+
(** Element "summary" is missing one or more of [aria-checked, aria-level, role]. *)
142
+
| Autocomplete_webauthn_on_select
143
+
(** The value of "autocomplete" for "select" must not contain "webauthn". *)
144
+
| Commandfor_invalid_target
145
+
(** The value of "commandfor" must be the ID of an element in the same tree. *)
146
+
147
+
(* ===== Parse Errors ===== *)
148
+
| Forbidden_codepoint of { codepoint: int }
149
+
(** Forbidden code point U+XXXX. *)
150
+
| Char_ref_control of { codepoint: int }
151
+
(** Character reference expands to a control character (U+XXXX). *)
152
+
| Char_ref_non_char of { codepoint: int; astral: bool }
153
+
(** Character reference expands to a [astral] non-character (U+XXXX). *)
154
+
| Char_ref_unassigned
155
+
(** Character reference expands to a permanently unassigned code point. *)
156
+
| Char_ref_zero
157
+
(** Character reference expands to zero. *)
158
+
| Char_ref_out_of_range
159
+
(** Character reference outside the permissible Unicode range. *)
160
+
| Numeric_char_ref_carriage_return
161
+
(** A numeric character reference expanded to carriage return. *)
162
+
| End_of_file_with_open_elements
163
+
(** End of file seen and there were open elements. *)
164
+
| No_element_in_scope of { tag: string }
165
+
(** No "X" element in scope but a "X" end tag seen. *)
166
+
| End_tag_implied_open_elements of { tag: string }
167
+
(** End tag "X" implied, but there were open elements. *)
168
+
| Start_tag_in_table of { tag: string }
169
+
(** Start tag "X" seen in "table". *)
170
+
| Bad_start_tag_in of { tag: string; context: string }
171
+
(** Bad start tag in "X" in "noscript" in "head". *)
172
+
173
+
(* ===== Table Errors ===== *)
174
+
| Table_row_no_cells of { row: int }
175
+
(** Row N of an implicit row group has no cells beginning on it. *)
176
+
| Table_cell_overlap
177
+
(** Table cell is overlapped by later table cell. *)
178
+
| Table_cell_spans_rowgroup
179
+
(** Table cell spans past the end of its row group. *)
180
+
| Table_column_no_cells of { column: int; element: string }
181
+
(** Table column N established by element "X" has no cells beginning in it. *)
182
+
183
+
(* ===== Language/Internationalization ===== *)
184
+
| Missing_lang_attr
185
+
(** Consider adding a "lang" attribute to the "html" start tag. *)
186
+
| Wrong_lang of { detected: string; declared: string; suggested: string }
187
+
(** This document appears to be written in X but has lang="Y". Consider using "Z". *)
188
+
| Missing_dir_rtl of { language: string }
189
+
(** This document appears to be written in X. Consider adding dir="rtl". *)
190
+
| Wrong_dir of { language: string; declared: string }
191
+
(** This document appears to be written in X but has dir="Y". Consider dir="rtl". *)
192
+
| Xml_lang_without_lang
193
+
(** When xml:lang is specified, lang must also be present with the same value. *)
194
+
| Xml_lang_lang_mismatch
195
+
(** xml:lang and lang must have the same value. *)
196
+
197
+
(* ===== Unicode Normalization ===== *)
198
+
| Not_nfc of { replacement: string }
199
+
(** Text run is not in Unicode Normalization Form C. *)
200
+
201
+
(* ===== Multiple h1 ===== *)
202
+
| Multiple_h1
203
+
(** Consider using only one "h1" element per document. *)
204
+
| Multiple_autofocus
205
+
(** There must not be two elements with autofocus in the same scoping root. *)
206
+
207
+
(* ===== Import Maps ===== *)
208
+
| Importmap_invalid_json
209
+
(** A "script" type="importmap" must have valid JSON content. *)
210
+
| Importmap_invalid_root
211
+
(** A "script" type="importmap" must contain a JSON object with only imports/scopes/integrity. *)
212
+
| Importmap_imports_not_object
213
+
(** The value of "imports" property must be a JSON object. *)
214
+
| Importmap_empty_key
215
+
(** Specifier map must only contain non-empty keys. *)
216
+
| Importmap_non_string_value
217
+
(** Specifier map must only contain string values. *)
218
+
| Importmap_key_trailing_slash
219
+
(** Specifier map values must end with "/" when key ends with "/". *)
220
+
| Importmap_scopes_not_object
221
+
(** The value of "scopes" property must be a JSON object with valid URL keys. *)
222
+
| Importmap_scopes_values_not_object
223
+
(** The value of "scopes" property values must also be JSON objects. *)
224
+
| Importmap_scopes_invalid_url
225
+
(** The "scopes" property must only contain valid URL values. *)
226
+
227
+
(* ===== Style Element ===== *)
228
+
| Style_type_invalid
229
+
(** The only allowed value for "type" on "style" is "text/css". *)
230
+
231
+
(* ===== Headingoffset ===== *)
232
+
| Headingoffset_invalid
233
+
(** The value of "headingoffset" must be a number between "0" and "8". *)
234
+
235
+
(* ===== Media Attribute ===== *)
236
+
| Media_empty
237
+
(** Value of "media" attribute here must not be empty. *)
238
+
| Media_all
239
+
(** Value of "media" attribute here must not be "all". *)
240
+
241
+
(* ===== SVG/MathML specific ===== *)
242
+
| Svg_deprecated_attr of { attr: string; element: string }
243
+
(** SVG deprecated attribute *)
244
+
| Missing_required_svg_attr of { element: string; attr: string }
245
+
(** Element "X" is missing required attribute "Y". (SVG) *)
246
+
247
+
(* ===== Generic/Fallback ===== *)
248
+
| Generic of { message: string }
249
+
(** For messages that don't fit any specific pattern *)
250
+
251
+
(** Get the severity level for an error code *)
252
+
let severity = function
253
+
| Missing_lang_attr -> Info
254
+
| Multiple_h1 -> Info
255
+
| Wrong_lang _ -> Warning
256
+
| Missing_dir_rtl _ -> Warning
257
+
| Wrong_dir _ -> Warning
258
+
| Unnecessary_role _ -> Warning
259
+
| Aria_should_not_be_used _ -> Warning
260
+
| _ -> Error
261
+
262
+
(** Get a short code string for categorization *)
263
+
let code_string = function
264
+
| Attr_not_allowed_on_element _ -> "disallowed-attribute"
265
+
| Attr_not_allowed_here _ -> "disallowed-attribute"
266
+
| Attr_not_allowed_when _ -> "disallowed-attribute"
267
+
| Missing_required_attr _ -> "missing-required-attribute"
268
+
| Missing_required_attr_one_of _ -> "missing-required-attribute"
269
+
| Bad_attr_value _ -> "bad-attribute-value"
270
+
| Bad_attr_value_generic _ -> "bad-attribute-value"
271
+
| Duplicate_id _ -> "duplicate-id"
272
+
| Data_attr_invalid_name _ -> "bad-attribute-name"
273
+
| Data_attr_uppercase -> "bad-attribute-name"
274
+
| Obsolete_element _ -> "obsolete-element"
275
+
| Obsolete_attr _ -> "obsolete-attribute"
276
+
| Element_not_allowed_as_child _ -> "disallowed-child"
277
+
| Element_must_not_be_descendant _ -> "prohibited-ancestor"
278
+
| Missing_required_child _ -> "missing-required-child"
279
+
| Missing_required_child_one_of _ -> "missing-required-child"
280
+
| Missing_required_child_generic _ -> "missing-required-child"
281
+
| Element_must_not_be_empty _ -> "empty-element"
282
+
| Stray_start_tag _ -> "stray-tag"
283
+
| Stray_end_tag _ -> "stray-tag"
284
+
| End_tag_for_void_element _ -> "end-tag-void"
285
+
| Self_closing_non_void -> "self-closing-non-void"
286
+
| Text_not_allowed _ -> "text-not-allowed"
287
+
| Div_child_of_dl_bad_role -> "invalid-role"
288
+
| Li_bad_role_in_menu -> "invalid-role"
289
+
| Li_bad_role_in_tablist -> "invalid-role"
290
+
| Li_bad_role_in_list -> "invalid-role"
291
+
| Unnecessary_role _ -> "unnecessary-role"
292
+
| Bad_role _ -> "bad-role"
293
+
| Aria_must_not_be_specified _ -> "aria-not-allowed"
294
+
| Aria_must_not_be_used _ -> "aria-not-allowed"
295
+
| Aria_should_not_be_used _ -> "aria-not-allowed"
296
+
| Img_empty_alt_with_role -> "img-alt-role"
297
+
| Checkbox_button_needs_aria_pressed -> "missing-aria-pressed"
298
+
| Tab_without_tabpanel -> "tab-without-tabpanel"
299
+
| Multiple_main_visible -> "multiple-main"
300
+
| Discarding_unrecognized_role _ -> "unrecognized-role"
301
+
| Img_missing_alt -> "missing-alt"
302
+
| Img_missing_src_or_srcset -> "missing-src"
303
+
| Option_empty_without_label -> "empty-option"
304
+
| Bdo_missing_dir -> "missing-dir"
305
+
| Bdo_dir_auto -> "bdo-dir-auto"
306
+
| Base_missing_href_or_target -> "missing-required-attribute"
307
+
| Base_after_link_script -> "base-position"
308
+
| Link_missing_href -> "missing-href"
309
+
| Link_as_requires_preload -> "link-as-preload"
310
+
| Link_imagesrcset_requires_as_image -> "link-imagesrcset"
311
+
| Img_ismap_needs_a_href -> "ismap-needs-href"
312
+
| Sizes_without_srcset -> "sizes-without-srcset"
313
+
| Imagesizes_without_imagesrcset -> "imagesizes-without-srcset"
314
+
| Srcset_w_without_sizes -> "srcset-needs-sizes"
315
+
| Source_missing_srcset -> "missing-srcset"
316
+
| Source_needs_media_or_type -> "source-needs-media"
317
+
| Picture_missing_img -> "picture-missing-img"
318
+
| Map_id_name_mismatch -> "map-id-name"
319
+
| List_attr_requires_datalist -> "list-datalist"
320
+
| Label_too_many_labelable -> "label-multiple"
321
+
| Label_for_id_mismatch -> "label-for-mismatch"
322
+
| Input_value_constraint _ -> "input-value"
323
+
| Summary_missing_role -> "summary-role"
324
+
| Summary_missing_attrs -> "summary-attrs"
325
+
| Autocomplete_webauthn_on_select -> "autocomplete"
326
+
| Commandfor_invalid_target -> "commandfor"
327
+
| Forbidden_codepoint _ -> "forbidden-codepoint"
328
+
| Char_ref_control _ -> "char-ref-control"
329
+
| Char_ref_non_char _ -> "char-ref-non-char"
330
+
| Char_ref_unassigned -> "char-ref-unassigned"
331
+
| Char_ref_zero -> "char-ref-zero"
332
+
| Char_ref_out_of_range -> "char-ref-range"
333
+
| Numeric_char_ref_carriage_return -> "numeric-char-ref"
334
+
| End_of_file_with_open_elements -> "eof-open-elements"
335
+
| No_element_in_scope _ -> "no-element-in-scope"
336
+
| End_tag_implied_open_elements _ -> "end-tag-implied"
337
+
| Start_tag_in_table _ -> "start-tag-in-table"
338
+
| Bad_start_tag_in _ -> "bad-start-tag"
339
+
| Table_row_no_cells _ -> "table-row"
340
+
| Table_cell_overlap -> "table-overlap"
341
+
| Table_cell_spans_rowgroup -> "table-span"
342
+
| Table_column_no_cells _ -> "table-column"
343
+
| Missing_lang_attr -> "missing-lang"
344
+
| Wrong_lang _ -> "wrong-lang"
345
+
| Missing_dir_rtl _ -> "missing-dir"
346
+
| Wrong_dir _ -> "wrong-dir"
347
+
| Xml_lang_without_lang -> "xml-lang"
348
+
| Xml_lang_lang_mismatch -> "xml-lang-mismatch"
349
+
| Not_nfc _ -> "unicode-normalization"
350
+
| Multiple_h1 -> "multiple-h1"
351
+
| Multiple_autofocus -> "multiple-autofocus"
352
+
| Importmap_invalid_json -> "importmap"
353
+
| Importmap_invalid_root -> "importmap"
354
+
| Importmap_imports_not_object -> "importmap"
355
+
| Importmap_empty_key -> "importmap"
356
+
| Importmap_non_string_value -> "importmap"
357
+
| Importmap_key_trailing_slash -> "importmap"
358
+
| Importmap_scopes_not_object -> "importmap"
359
+
| Importmap_scopes_values_not_object -> "importmap"
360
+
| Importmap_scopes_invalid_url -> "importmap"
361
+
| Style_type_invalid -> "style-type"
362
+
| Headingoffset_invalid -> "headingoffset"
363
+
| Media_empty -> "media-empty"
364
+
| Media_all -> "media-all"
365
+
| Svg_deprecated_attr _ -> "svg-deprecated"
366
+
| Missing_required_svg_attr _ -> "missing-required-attribute"
367
+
| Generic _ -> "generic"
368
+
369
+
(** Format using curly quotes (Unicode) *)
370
+
let q s = "\xe2\x80\x9c" ^ s ^ "\xe2\x80\x9d"
371
+
372
+
(** Convert error code to exact Nu validator message string *)
373
+
let to_message = function
374
+
| Attr_not_allowed_on_element { attr; element } ->
375
+
Printf.sprintf "Attribute %s not allowed on element %s at this point."
376
+
(q attr) (q element)
377
+
| Attr_not_allowed_here { attr } ->
378
+
Printf.sprintf "Attribute %s not allowed here." (q attr)
379
+
| Attr_not_allowed_when { attr; element = _; condition } ->
380
+
Printf.sprintf "Attribute %s is only allowed when %s." (q attr) condition
381
+
| Missing_required_attr { element; attr } ->
382
+
Printf.sprintf "Element %s is missing required attribute %s."
383
+
(q element) (q attr)
384
+
| Missing_required_attr_one_of { element; attrs } ->
385
+
let attrs_str = String.concat ", " (List.map q attrs) in
386
+
Printf.sprintf "Element %s is missing one or more of the following attributes: [%s]."
387
+
(q element) attrs_str
388
+
| Bad_attr_value { element; attr; value; reason } ->
389
+
Printf.sprintf "Bad value %s for attribute %s on element %s: %s"
390
+
(q value) (q attr) (q element) reason
391
+
| Bad_attr_value_generic { message } -> message
392
+
| Duplicate_id { id } ->
393
+
Printf.sprintf "Duplicate ID %s." (q id)
394
+
| Data_attr_invalid_name { reason } -> reason
395
+
| Data_attr_uppercase ->
396
+
Printf.sprintf "%s attributes must not have characters from the range %s\xe2\x80\xa6%s in the name."
397
+
(q "data-*") (q "A") (q "Z")
398
+
399
+
| Obsolete_element { element; suggestion } ->
400
+
if suggestion = "" then
401
+
Printf.sprintf "The %s element is obsolete." (q element)
402
+
else
403
+
Printf.sprintf "The %s element is obsolete. %s" (q element) suggestion
404
+
| Obsolete_attr { element; attr; suggestion } ->
405
+
let base = Printf.sprintf "The %s attribute on the %s element is obsolete."
406
+
(q attr) (q element) in
407
+
(match suggestion with Some s -> base ^ " " ^ s | None -> base)
408
+
| Element_not_allowed_as_child { child; parent } ->
409
+
Printf.sprintf "Element %s not allowed as child of element %s in this context. (Suppressing further errors from this subtree.)"
410
+
(q child) (q parent)
411
+
| Element_must_not_be_descendant { element; attr; ancestor } ->
412
+
(match attr with
413
+
| Some a ->
414
+
Printf.sprintf "The element %s with the attribute %s must not appear as a descendant of the %s element."
415
+
(q element) (q a) (q ancestor)
416
+
| None ->
417
+
Printf.sprintf "The element %s must not appear as a descendant of the %s element."
418
+
(q element) (q ancestor))
419
+
| Missing_required_child { parent; child } ->
420
+
Printf.sprintf "Element %s is missing required child element %s."
421
+
(q parent) (q child)
422
+
| Missing_required_child_one_of { parent; children } ->
423
+
let children_str = String.concat ", " (List.map q children) in
424
+
Printf.sprintf "Element %s is missing one or more of the following child elements: [%s]."
425
+
(q parent) children_str
426
+
| Missing_required_child_generic { parent } ->
427
+
Printf.sprintf "Element %s is missing a required child element." (q parent)
428
+
| Element_must_not_be_empty { element } ->
429
+
Printf.sprintf "Element %s must not be empty." (q element)
430
+
| Stray_start_tag { tag } ->
431
+
Printf.sprintf "Stray start tag %s." (q tag)
432
+
| Stray_end_tag { tag } ->
433
+
Printf.sprintf "Stray end tag %s." (q tag)
434
+
| End_tag_for_void_element { tag } ->
435
+
Printf.sprintf "End tag %s." (q tag)
436
+
| Self_closing_non_void ->
437
+
Printf.sprintf "Self-closing syntax (%s) used on a non-void HTML element. Ignoring the slash and treating as a start tag."
438
+
(q "/>")
439
+
| Text_not_allowed { parent } ->
440
+
Printf.sprintf "Text not allowed in element %s in this context." (q parent)
441
+
442
+
| Div_child_of_dl_bad_role ->
443
+
Printf.sprintf "A %s child of a %s element must not have any %s value other than %s or %s."
444
+
(q "div") (q "dl") (q "role") (q "presentation") (q "none")
445
+
| Li_bad_role_in_menu ->
446
+
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."
447
+
(q "li") (q "role=menu") (q "role=menubar") (q "role")
448
+
(q "group") (q "menuitem") (q "menuitemcheckbox") (q "menuitemradio") (q "separator")
449
+
| Li_bad_role_in_tablist ->
450
+
Printf.sprintf "An %s element that is a descendant of a %s element must not have any %s value other than %s."
451
+
(q "li") (q "role=tablist") (q "role") (q "tab")
452
+
| Li_bad_role_in_list ->
453
+
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."
454
+
(q "li") (q "ul") (q "ol") (q "menu") (q "role") (q "role=list") (q "role") (q "listitem")
455
+
456
+
| Unnecessary_role { role; element = _; reason } ->
457
+
Printf.sprintf "The %s role is unnecessary for %s."
458
+
(q role) reason
459
+
| Bad_role { element; role } ->
460
+
Printf.sprintf "Bad value %s for attribute %s on element %s."
461
+
(q role) (q "role") (q element)
462
+
| Aria_must_not_be_specified { attr; element; condition } ->
463
+
Printf.sprintf "The %s attribute must not be specified on any %s element unless %s."
464
+
(q attr) (q element) condition
465
+
| Aria_must_not_be_used { attr; element; condition } ->
466
+
Printf.sprintf "The %s attribute must not be used on an %s element which has %s."
467
+
(q attr) (q element) condition
468
+
| Aria_should_not_be_used { attr; role } ->
469
+
Printf.sprintf "The %s attribute should not be used on any element which has %s."
470
+
(q attr) (q ("role=" ^ role))
471
+
| Img_empty_alt_with_role ->
472
+
Printf.sprintf "An %s element which has an %s attribute whose value is the empty string must not have a %s attribute."
473
+
(q "img") (q "alt") (q "role")
474
+
| Checkbox_button_needs_aria_pressed ->
475
+
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."
476
+
(q "input") (q "type") (q "checkbox") (q "role") (q "button") (q "aria-pressed")
477
+
| Tab_without_tabpanel ->
478
+
Printf.sprintf "Every active %s element must have a corresponding %s element."
479
+
(q "role=tab") (q "role=tabpanel")
480
+
| Multiple_main_visible ->
481
+
Printf.sprintf "A document should not include more than one visible element with %s."
482
+
(q "role=main")
483
+
| Discarding_unrecognized_role { token } ->
484
+
Printf.sprintf "Discarding unrecognized token %s from value of attribute %s. Browsers ignore any token that is not a defined ARIA non-abstract role."
485
+
(q token) (q "role")
486
+
487
+
| Img_missing_alt ->
488
+
Printf.sprintf "An %s element must have an %s attribute, except under certain conditions. For details, consult guidance on providing text alternatives for images."
489
+
(q "img") (q "alt")
490
+
| Img_missing_src_or_srcset ->
491
+
Printf.sprintf "Element %s is missing one or more of the following attributes: [%s, %s]."
492
+
(q "img") (q "src") (q "srcset")
493
+
| Option_empty_without_label ->
494
+
Printf.sprintf "Element %s without attribute %s must not be empty."
495
+
(q "option") (q "label")
496
+
| Bdo_missing_dir ->
497
+
Printf.sprintf "Element %s must have attribute %s." (q "bdo") (q "dir")
498
+
| Bdo_dir_auto ->
499
+
Printf.sprintf "The value of %s attribute for the %s element must not be %s."
500
+
(q "dir") (q "bdo") (q "auto")
501
+
| Base_missing_href_or_target ->
502
+
Printf.sprintf "Element %s is missing one or more of the following attributes: [%s, %s]."
503
+
(q "base") (q "href") (q "target")
504
+
| Base_after_link_script ->
505
+
Printf.sprintf "The %s element must come before any %s or %s elements in the document."
506
+
(q "base") (q "link") (q "script")
507
+
| Link_missing_href ->
508
+
Printf.sprintf "A %s element must have an %s or %s attribute, or both."
509
+
(q "link") (q "href") (q "imagesrcset")
510
+
| Link_as_requires_preload ->
511
+
Printf.sprintf "A %s element with an %s attribute must have a %s attribute that contains the value %s or the value %s."
512
+
(q "link") (q "as") (q "rel") (q "preload") (q "modulepreload")
513
+
| Link_imagesrcset_requires_as_image ->
514
+
Printf.sprintf "A %s element with an %s attribute must have an %s attribute with value %s."
515
+
(q "link") (q "imagesrcset") (q "as") (q "image")
516
+
| Img_ismap_needs_a_href ->
517
+
Printf.sprintf "The %s element with the %s attribute set must have an %s ancestor with the %s attribute."
518
+
(q "img") (q "ismap") (q "a") (q "href")
519
+
| Sizes_without_srcset ->
520
+
Printf.sprintf "The %s attribute must only be specified if the %s attribute is also specified."
521
+
(q "sizes") (q "srcset")
522
+
| Imagesizes_without_imagesrcset ->
523
+
Printf.sprintf "The %s attribute must only be specified if the %s attribute is also specified."
524
+
(q "imagesizes") (q "imagesrcset")
525
+
| Srcset_w_without_sizes ->
526
+
Printf.sprintf "When the %s attribute has any image candidate string with a width descriptor, the %s attribute must also be specified."
527
+
(q "srcset") (q "sizes")
528
+
| Source_missing_srcset ->
529
+
Printf.sprintf "Element %s is missing required attribute %s."
530
+
(q "source") (q "srcset")
531
+
| Source_needs_media_or_type ->
532
+
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."
533
+
(q "source") (q "source") (q "img") (q "srcset") (q "media") (q "type")
534
+
| Picture_missing_img ->
535
+
Printf.sprintf "Element %s is missing required child element %s."
536
+
(q "picture") (q "img")
537
+
| Map_id_name_mismatch ->
538
+
Printf.sprintf "The %s attribute on a %s element must have an the same value as the %s attribute."
539
+
(q "id") (q "map") (q "name")
540
+
| List_attr_requires_datalist ->
541
+
Printf.sprintf "The %s attribute of the %s element must refer to a %s element."
542
+
(q "list") (q "input") (q "datalist")
543
+
| Label_too_many_labelable ->
544
+
Printf.sprintf "The %s element may contain at most one %s, %s, %s, %s, %s, %s, or %s descendant."
545
+
(q "label") (q "button") (q "input") (q "meter") (q "output") (q "progress") (q "select") (q "textarea")
546
+
| Label_for_id_mismatch ->
547
+
Printf.sprintf "Any %s descendant of a %s element with a %s attribute must have an ID value that matches that %s attribute."
548
+
(q "input") (q "label") (q "for") (q "for")
549
+
| Input_value_constraint { constraint_type } -> constraint_type
550
+
| Summary_missing_role ->
551
+
Printf.sprintf "Element %s is missing required attribute %s."
552
+
(q "summary") (q "role")
553
+
| Summary_missing_attrs ->
554
+
Printf.sprintf "Element %s is missing one or more of the following attributes: [%s, %s, %s]."
555
+
(q "summary") (q "aria-checked") (q "aria-level") (q "role")
556
+
| Autocomplete_webauthn_on_select ->
557
+
Printf.sprintf "The value of the %s attribute for the %s element must not contain %s."
558
+
(q "autocomplete") (q "select") (q "webauthn")
559
+
| Commandfor_invalid_target ->
560
+
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."
561
+
(q "commandfor") (q "button") (q "button") (q "commandfor")
562
+
563
+
| Forbidden_codepoint { codepoint } ->
564
+
Printf.sprintf "Forbidden code point U+%04x." codepoint
565
+
| Char_ref_control { codepoint } ->
566
+
Printf.sprintf "Character reference expands to a control character (U+%04x)." codepoint
567
+
| Char_ref_non_char { codepoint; astral } ->
568
+
if astral then
569
+
Printf.sprintf "Character reference expands to an astral non-character (U+%05x)." codepoint
570
+
else
571
+
Printf.sprintf "Character reference expands to a non-character (U+%04x)." codepoint
572
+
| Char_ref_unassigned ->
573
+
"Character reference expands to a permanently unassigned code point."
574
+
| Char_ref_zero ->
575
+
"Character reference expands to zero."
576
+
| Char_ref_out_of_range ->
577
+
"Character reference outside the permissible Unicode range."
578
+
| Numeric_char_ref_carriage_return ->
579
+
"A numeric character reference expanded to carriage return."
580
+
| End_of_file_with_open_elements ->
581
+
"End of file seen and there were open elements."
582
+
| No_element_in_scope { tag } ->
583
+
Printf.sprintf "No %s element in scope but a %s end tag seen."
584
+
(q tag) (q tag)
585
+
| End_tag_implied_open_elements { tag } ->
586
+
Printf.sprintf "End tag %s implied, but there were open elements."
587
+
(q tag)
588
+
| Start_tag_in_table { tag } ->
589
+
Printf.sprintf "Start tag %s seen in %s." (q tag) (q "table")
590
+
| Bad_start_tag_in { tag; context = _ } ->
591
+
Printf.sprintf "Bad start tag in %s in %s in %s."
592
+
(q tag) (q "noscript") (q "head")
593
+
594
+
| Table_row_no_cells { row } ->
595
+
Printf.sprintf "Row %d of an implicit row group has no cells beginning on it." row
596
+
| Table_cell_overlap ->
597
+
"Table cell is overlapped by later table cell."
598
+
| Table_cell_spans_rowgroup ->
599
+
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."
600
+
(q "tbody")
601
+
| Table_column_no_cells { column; element } ->
602
+
Printf.sprintf "Table column %d established by element %s has no cells beginning in it."
603
+
column (q element)
604
+
605
+
| Missing_lang_attr ->
606
+
Printf.sprintf "Consider adding a %s attribute to the %s start tag to declare the language of this document."
607
+
(q "lang") (q "html")
608
+
| Wrong_lang { detected; declared; suggested } ->
609
+
Printf.sprintf "This document appears to be written in %s but the %s start tag has %s. Consider using %s (or variant) instead."
610
+
detected (q "html") (q ("lang=\"" ^ declared ^ "\"")) (q ("lang=\"" ^ suggested ^ "\""))
611
+
| Missing_dir_rtl { language } ->
612
+
Printf.sprintf "This document appears to be written in %s. Consider adding %s to the %s start tag."
613
+
language (q "dir=\"rtl\"") (q "html")
614
+
| Wrong_dir { language; declared } ->
615
+
Printf.sprintf "This document appears to be written in %s but the %s start tag has %s. Consider using %s instead."
616
+
language (q "html") (q ("dir=\"" ^ declared ^ "\"")) (q "dir=\"rtl\"")
617
+
| Xml_lang_without_lang ->
618
+
Printf.sprintf "When the attribute %s in no namespace is specified, the element must also have the attribute %s present with the same value."
619
+
(q "xml:lang") (q "lang")
620
+
| Xml_lang_lang_mismatch ->
621
+
Printf.sprintf "The %s and %s attributes must have the same value."
622
+
(q "xml:lang") (q "lang")
623
+
624
+
| Not_nfc { replacement } ->
625
+
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.)"
626
+
(q replacement)
627
+
628
+
| Multiple_h1 ->
629
+
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)."
630
+
(q "h1") (q "h1") (q "headingoffset") (q "h1")
631
+
| Multiple_autofocus ->
632
+
Printf.sprintf "There must not be two elements with the same %s that both have the %s attribute specified."
633
+
(q "nearest ancestor autofocus scoping root element") (q "autofocus")
634
+
635
+
| Importmap_invalid_json ->
636
+
Printf.sprintf "A script %s with a %s attribute whose value is %s must have valid JSON content."
637
+
(q "script") (q "type") (q "importmap")
638
+
| Importmap_invalid_root ->
639
+
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."
640
+
(q "script") (q "type") (q "importmap") (q "imports") (q "scopes") (q "integrity")
641
+
| Importmap_imports_not_object ->
642
+
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."
643
+
(q "imports") (q "script") (q "type") (q "importmap")
644
+
| Importmap_empty_key ->
645
+
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."
646
+
(q "imports") (q "script") (q "type") (q "importmap")
647
+
| Importmap_non_string_value ->
648
+
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."
649
+
(q "imports") (q "script") (q "type") (q "importmap")
650
+
| Importmap_key_trailing_slash ->
651
+
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."
652
+
(q "imports") (q "script") (q "type") (q "importmap") (q "/") (q "/")
653
+
| Importmap_scopes_not_object ->
654
+
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."
655
+
(q "scopes") (q "script") (q "type") (q "importmap")
656
+
| Importmap_scopes_values_not_object ->
657
+
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."
658
+
(q "scopes") (q "script") (q "type") (q "importmap")
659
+
| Importmap_scopes_invalid_url ->
660
+
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."
661
+
(q "scopes") (q "script") (q "type") (q "importmap")
662
+
663
+
| Style_type_invalid ->
664
+
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.)"
665
+
(q "type") (q "style") (q "text/css")
666
+
667
+
| Headingoffset_invalid ->
668
+
Printf.sprintf "The value of the %s attribute must be a number between %s and %s."
669
+
(q "headingoffset") (q "0") (q "8")
670
+
671
+
| Media_empty ->
672
+
Printf.sprintf "Value of %s attribute here must not be empty." (q "media")
673
+
| Media_all ->
674
+
Printf.sprintf "Value of %s attribute here must not be %s." (q "media") (q "all")
675
+
676
+
| Svg_deprecated_attr { attr; element } ->
677
+
Printf.sprintf "Attribute %s not allowed on element %s at this point."
678
+
(q attr) (q element)
679
+
| Missing_required_svg_attr { element; attr } ->
680
+
Printf.sprintf "Element %s is missing required attribute %s."
681
+
(q element) (q attr)
682
+
683
+
| Generic { message } -> message
+157
lib/html5_checker/error_code.mli
+157
lib/html5_checker/error_code.mli
···
1
+
(** Typed error codes for HTML5 validation messages.
2
+
3
+
This module defines a comprehensive variant type for all validation errors,
4
+
ensuring exact message matching with the Nu HTML Validator test suite. *)
5
+
6
+
(** Severity level of a validation message *)
7
+
type severity = Error | Warning | Info
8
+
9
+
(** Typed error codes with associated data *)
10
+
type t =
11
+
(* Attribute Errors *)
12
+
| Attr_not_allowed_on_element of { attr: string; element: string }
13
+
| Attr_not_allowed_here of { attr: string }
14
+
| Attr_not_allowed_when of { attr: string; element: string; condition: string }
15
+
| Missing_required_attr of { element: string; attr: string }
16
+
| Missing_required_attr_one_of of { element: string; attrs: string list }
17
+
| Bad_attr_value of { element: string; attr: string; value: string; reason: string }
18
+
| Bad_attr_value_generic of { message: string }
19
+
| Duplicate_id of { id: string }
20
+
| Data_attr_invalid_name of { reason: string }
21
+
| Data_attr_uppercase
22
+
23
+
(* Element Errors *)
24
+
| Obsolete_element of { element: string; suggestion: string }
25
+
| Obsolete_attr of { element: string; attr: string; suggestion: string option }
26
+
| Element_not_allowed_as_child of { child: string; parent: string }
27
+
| Element_must_not_be_descendant of { element: string; attr: string option; ancestor: string }
28
+
| Missing_required_child of { parent: string; child: string }
29
+
| Missing_required_child_one_of of { parent: string; children: string list }
30
+
| Missing_required_child_generic of { parent: string }
31
+
| Element_must_not_be_empty of { element: string }
32
+
| Stray_start_tag of { tag: string }
33
+
| Stray_end_tag of { tag: string }
34
+
| End_tag_for_void_element of { tag: string }
35
+
| Self_closing_non_void
36
+
| Text_not_allowed of { parent: string }
37
+
38
+
(* Child Restrictions *)
39
+
| Div_child_of_dl_bad_role
40
+
| Li_bad_role_in_menu
41
+
| Li_bad_role_in_tablist
42
+
| Li_bad_role_in_list
43
+
44
+
(* ARIA Errors *)
45
+
| Unnecessary_role of { role: string; element: string; reason: string }
46
+
| Bad_role of { element: string; role: string }
47
+
| Aria_must_not_be_specified of { attr: string; element: string; condition: string }
48
+
| Aria_must_not_be_used of { attr: string; element: string; condition: string }
49
+
| Aria_should_not_be_used of { attr: string; role: string }
50
+
| Img_empty_alt_with_role
51
+
| Checkbox_button_needs_aria_pressed
52
+
| Tab_without_tabpanel
53
+
| Multiple_main_visible
54
+
| Discarding_unrecognized_role of { token: string }
55
+
56
+
(* Required Attribute/Element Conditions *)
57
+
| Img_missing_alt
58
+
| Img_missing_src_or_srcset
59
+
| Option_empty_without_label
60
+
| Bdo_missing_dir
61
+
| Bdo_dir_auto
62
+
| Base_missing_href_or_target
63
+
| Base_after_link_script
64
+
| Link_missing_href
65
+
| Link_as_requires_preload
66
+
| Link_imagesrcset_requires_as_image
67
+
| Img_ismap_needs_a_href
68
+
| Sizes_without_srcset
69
+
| Imagesizes_without_imagesrcset
70
+
| Srcset_w_without_sizes
71
+
| Source_missing_srcset
72
+
| Source_needs_media_or_type
73
+
| Picture_missing_img
74
+
| Map_id_name_mismatch
75
+
| List_attr_requires_datalist
76
+
| Label_too_many_labelable
77
+
| Label_for_id_mismatch
78
+
| Input_value_constraint of { constraint_type: string }
79
+
| Summary_missing_role
80
+
| Summary_missing_attrs
81
+
| Autocomplete_webauthn_on_select
82
+
| Commandfor_invalid_target
83
+
84
+
(* Parse Errors *)
85
+
| Forbidden_codepoint of { codepoint: int }
86
+
| Char_ref_control of { codepoint: int }
87
+
| Char_ref_non_char of { codepoint: int; astral: bool }
88
+
| Char_ref_unassigned
89
+
| Char_ref_zero
90
+
| Char_ref_out_of_range
91
+
| Numeric_char_ref_carriage_return
92
+
| End_of_file_with_open_elements
93
+
| No_element_in_scope of { tag: string }
94
+
| End_tag_implied_open_elements of { tag: string }
95
+
| Start_tag_in_table of { tag: string }
96
+
| Bad_start_tag_in of { tag: string; context: string }
97
+
98
+
(* Table Errors *)
99
+
| Table_row_no_cells of { row: int }
100
+
| Table_cell_overlap
101
+
| Table_cell_spans_rowgroup
102
+
| Table_column_no_cells of { column: int; element: string }
103
+
104
+
(* Language/Internationalization *)
105
+
| Missing_lang_attr
106
+
| Wrong_lang of { detected: string; declared: string; suggested: string }
107
+
| Missing_dir_rtl of { language: string }
108
+
| Wrong_dir of { language: string; declared: string }
109
+
| Xml_lang_without_lang
110
+
| Xml_lang_lang_mismatch
111
+
112
+
(* Unicode Normalization *)
113
+
| Not_nfc of { replacement: string }
114
+
115
+
(* Multiple h1 *)
116
+
| Multiple_h1
117
+
| Multiple_autofocus
118
+
119
+
(* Import Maps *)
120
+
| Importmap_invalid_json
121
+
| Importmap_invalid_root
122
+
| Importmap_imports_not_object
123
+
| Importmap_empty_key
124
+
| Importmap_non_string_value
125
+
| Importmap_key_trailing_slash
126
+
| Importmap_scopes_not_object
127
+
| Importmap_scopes_values_not_object
128
+
| Importmap_scopes_invalid_url
129
+
130
+
(* Style Element *)
131
+
| Style_type_invalid
132
+
133
+
(* Headingoffset *)
134
+
| Headingoffset_invalid
135
+
136
+
(* Media Attribute *)
137
+
| Media_empty
138
+
| Media_all
139
+
140
+
(* SVG/MathML specific *)
141
+
| Svg_deprecated_attr of { attr: string; element: string }
142
+
| Missing_required_svg_attr of { element: string; attr: string }
143
+
144
+
(* Generic/Fallback *)
145
+
| Generic of { message: string }
146
+
147
+
(** Get the severity level for an error code *)
148
+
val severity : t -> severity
149
+
150
+
(** Get a short code string for categorization *)
151
+
val code_string : t -> string
152
+
153
+
(** Convert error code to exact Nu validator message string *)
154
+
val to_message : t -> string
155
+
156
+
(** Format a string with curly quotes *)
157
+
val q : string -> string
+36
-17
lib/html5_checker/message.ml
+36
-17
lib/html5_checker/message.ml
···
1
+
(** Validation messages with typed error codes. *)
2
+
1
3
type severity = Error | Warning | Info
2
4
3
5
type location = {
···
11
13
type t = {
12
14
severity : severity;
13
15
message : string;
14
-
code : string option;
16
+
code : string;
17
+
error_code : Error_code.t option;
15
18
location : location option;
16
19
element : string option;
17
20
attribute : string option;
18
21
extract : string option;
19
22
}
20
23
21
-
let make ~severity ~message ?code ?location ?element ?attribute ?extract () =
22
-
{ severity; message; code; location; element; attribute; extract }
24
+
let make_location ~line ~column ?end_line ?end_column ?system_id () =
25
+
{ line; column; end_line; end_column; system_id }
26
+
27
+
(** Create a message from a typed error code *)
28
+
let of_error_code ?location ?element ?attribute ?extract error_code =
29
+
let severity = match Error_code.severity error_code with
30
+
| Error_code.Error -> Error
31
+
| Error_code.Warning -> Warning
32
+
| Error_code.Info -> Info
33
+
in
34
+
{
35
+
severity;
36
+
message = Error_code.to_message error_code;
37
+
code = Error_code.code_string error_code;
38
+
error_code = Some error_code;
39
+
location;
40
+
element;
41
+
attribute;
42
+
extract;
43
+
}
23
44
24
-
let error ~message ?code ?location ?element ?attribute ?extract () =
25
-
make ~severity:Error ~message ?code ?location ?element ?attribute ?extract ()
45
+
(** Create a message with manual message text (for backwards compatibility during migration) *)
46
+
let make ~severity ~message ?(code="generic") ?location ?element ?attribute ?extract () =
47
+
{ severity; message; code; error_code = None; location; element; attribute; extract }
26
48
27
-
let warning ~message ?code ?location ?element ?attribute ?extract () =
28
-
make ~severity:Warning ~message ?code ?location ?element ?attribute ?extract
29
-
()
49
+
let error ~message ?(code="generic") ?location ?element ?attribute ?extract () =
50
+
make ~severity:Error ~message ~code ?location ?element ?attribute ?extract ()
30
51
31
-
let info ~message ?code ?location ?element ?attribute ?extract () =
32
-
make ~severity:Info ~message ?code ?location ?element ?attribute ?extract ()
52
+
let warning ~message ?(code="generic") ?location ?element ?attribute ?extract () =
53
+
make ~severity:Warning ~message ~code ?location ?element ?attribute ?extract ()
33
54
34
-
let make_location ~line ~column ?end_line ?end_column ?system_id () =
35
-
{ line; column; end_line; end_column; system_id }
55
+
let info ~message ?(code="generic") ?location ?element ?attribute ?extract () =
56
+
make ~severity:Info ~message ~code ?location ?element ?attribute ?extract ()
36
57
37
58
let severity_to_string = function
38
59
| Error -> "error"
···
43
64
Format.pp_print_string fmt (severity_to_string severity)
44
65
45
66
let pp_location fmt loc =
46
-
match loc.system_id with
67
+
(match loc.system_id with
47
68
| Some sid -> Format.fprintf fmt "%s:" sid
48
-
| None -> ();
69
+
| None -> ());
49
70
Format.fprintf fmt "%d:%d" loc.line loc.column;
50
71
match (loc.end_line, loc.end_column) with
51
72
| Some el, Some ec when el = loc.line && ec > loc.column ->
···
61
82
Format.fprintf fmt ": "
62
83
| None -> ());
63
84
pp_severity fmt msg.severity;
64
-
(match msg.code with
65
-
| Some code -> Format.fprintf fmt " [%s]" code
66
-
| None -> ());
85
+
Format.fprintf fmt " [%s]" msg.code;
67
86
Format.fprintf fmt ": %s" msg.message;
68
87
(match msg.element with
69
88
| Some elem -> Format.fprintf fmt " (element: %s)" elem
+15
-5
lib/html5_checker/message.mli
+15
-5
lib/html5_checker/message.mli
···
22
22
type t = {
23
23
severity : severity;
24
24
message : string; (** Human-readable description *)
25
-
code : string option; (** Machine-readable error code *)
25
+
code : string; (** Machine-readable error code *)
26
+
error_code : Error_code.t option; (** Typed error code if available *)
26
27
location : location option;
27
28
element : string option; (** Element name if relevant *)
28
29
attribute : string option; (** Attribute name if relevant *)
···
31
32
32
33
(** {1 Constructors} *)
33
34
34
-
(** Create a validation message with specified severity. *)
35
+
(** Create a message from a typed error code (preferred method). *)
36
+
val of_error_code :
37
+
?location:location ->
38
+
?element:string ->
39
+
?attribute:string ->
40
+
?extract:string ->
41
+
Error_code.t ->
42
+
t
43
+
44
+
(** Create a validation message with specified severity (legacy). *)
35
45
val make :
36
46
severity:severity ->
37
47
message:string ->
···
43
53
unit ->
44
54
t
45
55
46
-
(** Create an error message. *)
56
+
(** Create an error message (legacy). *)
47
57
val error :
48
58
message:string ->
49
59
?code:string ->
···
54
64
unit ->
55
65
t
56
66
57
-
(** Create a warning message. *)
67
+
(** Create a warning message (legacy). *)
58
68
val warning :
59
69
message:string ->
60
70
?code:string ->
···
65
75
unit ->
66
76
t
67
77
68
-
(** Create an informational message. *)
78
+
(** Create an informational message (legacy). *)
69
79
val info :
70
80
message:string ->
71
81
?code:string ->
+14
lib/html5_checker/message_collector.ml
+14
lib/html5_checker/message_collector.ml
···
1
+
(** Message collector for accumulating validation messages. *)
2
+
1
3
type t = { mutable messages : Message.t list }
2
4
3
5
let create () = { messages = [] }
4
6
5
7
let add t msg = t.messages <- msg :: t.messages
6
8
9
+
(** Add a message from a typed error code *)
10
+
let add_typed t ?location ?element ?attribute ?extract error_code =
11
+
let msg = Message.of_error_code ?location ?element ?attribute ?extract error_code in
12
+
add t msg
13
+
14
+
(** Add an error from a typed error code *)
15
+
let add_error_code t ?location ?element ?attribute ?extract error_code =
16
+
add_typed t ?location ?element ?attribute ?extract error_code
17
+
18
+
(** Legacy: Add an error with manual message text *)
7
19
let add_error t ~message ?code ?location ?element ?attribute ?extract () =
8
20
let msg =
9
21
Message.error ~message ?code ?location ?element ?attribute ?extract ()
10
22
in
11
23
add t msg
12
24
25
+
(** Legacy: Add a warning with manual message text *)
13
26
let add_warning t ~message ?code ?location ?element ?attribute ?extract () =
14
27
let msg =
15
28
Message.warning ~message ?code ?location ?element ?attribute ?extract ()
16
29
in
17
30
add t msg
18
31
32
+
(** Legacy: Add an info message with manual message text *)
19
33
let add_info t ~message ?code ?location ?element ?attribute ?extract () =
20
34
let msg =
21
35
Message.info ~message ?code ?location ?element ?attribute ?extract ()
+26
-4
lib/html5_checker/message_collector.mli
+26
-4
lib/html5_checker/message_collector.mli
···
8
8
(** Create a new empty message collector. *)
9
9
val create : unit -> t
10
10
11
-
(** {1 Adding Messages} *)
11
+
(** {1 Adding Messages - Typed Error Codes (Preferred)} *)
12
+
13
+
(** Add a message from a typed error code. *)
14
+
val add_typed :
15
+
t ->
16
+
?location:Message.location ->
17
+
?element:string ->
18
+
?attribute:string ->
19
+
?extract:string ->
20
+
Error_code.t ->
21
+
unit
22
+
23
+
(** Add an error from a typed error code. Alias for add_typed. *)
24
+
val add_error_code :
25
+
t ->
26
+
?location:Message.location ->
27
+
?element:string ->
28
+
?attribute:string ->
29
+
?extract:string ->
30
+
Error_code.t ->
31
+
unit
32
+
33
+
(** {1 Adding Messages - Legacy (for migration)} *)
12
34
13
35
(** Add a message to the collector. *)
14
36
val add : t -> Message.t -> unit
15
37
16
-
(** Add an error message to the collector. *)
38
+
(** Add an error message to the collector (legacy). *)
17
39
val add_error :
18
40
t ->
19
41
message:string ->
···
25
47
unit ->
26
48
unit
27
49
28
-
(** Add a warning message to the collector. *)
50
+
(** Add a warning message to the collector (legacy). *)
29
51
val add_warning :
30
52
t ->
31
53
message:string ->
···
37
59
unit ->
38
60
unit
39
61
40
-
(** Add an info message to the collector. *)
62
+
(** Add an info message to the collector (legacy). *)
41
63
val add_info :
42
64
t ->
43
65
message:string ->
+3
-9
lib/html5_checker/message_format.ml
+3
-9
lib/html5_checker/message_format.ml
···
24
24
match system_id with Some s -> s | None -> "input")
25
25
in
26
26
let severity_str = Message.severity_to_string msg.Message.severity in
27
-
let code_str =
28
-
match msg.Message.code with Some c -> " [" ^ c ^ "]" | None -> ""
29
-
in
27
+
let code_str = " [" ^ msg.Message.code ^ "]" in
30
28
let elem_str =
31
29
match msg.Message.element with
32
30
| Some e -> " (element: " ^ e ^ ")"
···
61
59
match system_id with Some s -> s ^ ":0:0" | None -> "input:0:0")
62
60
in
63
61
let severity_str = Message.severity_to_string msg.Message.severity in
64
-
let code_str =
65
-
match msg.Message.code with Some c -> " [" ^ c ^ "]" | None -> ""
66
-
in
62
+
let code_str = " [" ^ msg.Message.code ^ "]" in
67
63
Buffer.add_string buf
68
64
(Printf.sprintf "%s: %s%s: %s\n" loc_str severity_str code_str
69
65
msg.Message.message))
···
76
72
let message_text = String (msg.Message.message, Meta.none) in
77
73
let base = [ (("type", Meta.none), severity); (("message", Meta.none), message_text) ] in
78
74
let with_code =
79
-
match msg.Message.code with
80
-
| Some c -> (("subType", Meta.none), String (c, Meta.none)) :: base
81
-
| None -> base
75
+
(("subType", Meta.none), String (msg.Message.code, Meta.none)) :: base
82
76
in
83
77
let with_location =
84
78
match msg.Message.location with
+1
-9
lib/html5_checker/semantic/autofocus_checker.ml
+1
-9
lib/html5_checker/semantic/autofocus_checker.ml
···
69
69
| ctx :: _ ->
70
70
ctx.autofocus_count <- ctx.autofocus_count + 1;
71
71
if ctx.autofocus_count > 1 then
72
-
let context_name = match ctx.context_type with
73
-
| Dialog -> "dialog"
74
-
| Popover -> "popover"
75
-
in
76
-
Message_collector.add_error collector
77
-
~message:(Printf.sprintf "A document must not include more than one visible element with the \xe2\x80\x9cautofocus\xe2\x80\x9d attribute inside a %s."
78
-
context_name)
79
-
~code:"multiple-autofocus"
80
-
~element:name ~attribute:"autofocus" ()
72
+
Message_collector.add_typed collector Error_code.Multiple_autofocus
81
73
| [] -> ()
82
74
end
83
75
end
+8
-12
lib/html5_checker/semantic/form_checker.ml
+8
-12
lib/html5_checker/semantic/form_checker.ml
···
26
26
let check_autocomplete_value value element_name collector =
27
27
(* webauthn is not allowed on select, only on input and textarea *)
28
28
if element_name = "select" && contains_webauthn value then begin
29
-
Message_collector.add_error collector
30
-
~message:(Printf.sprintf "The value of the \xe2\x80\x9cautocomplete\xe2\x80\x9d attribute for the \xe2\x80\x9c%s\xe2\x80\x9d element must not contain \xe2\x80\x9cwebauthn\xe2\x80\x9d."
31
-
element_name)
32
-
~code:"bad-attribute-value"
33
-
~element:element_name
34
-
~attribute:"autocomplete" ()
29
+
Message_collector.add_typed collector Error_code.Autocomplete_webauthn_on_select
35
30
end else begin
36
31
(* Use the proper autocomplete validator from dt_autocomplete *)
37
32
match Dt_autocomplete.validate_autocomplete value with
38
33
| Ok () -> ()
39
34
| Error msg ->
40
-
Message_collector.add_error collector
41
-
~message:(Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9cautocomplete\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: %s"
42
-
value element_name msg)
43
-
~code:"bad-attribute-value"
44
-
~element:element_name
45
-
~attribute:"autocomplete" ()
35
+
Message_collector.add_typed collector
36
+
(Error_code.Bad_attr_value {
37
+
element = element_name;
38
+
attr = "autocomplete";
39
+
value;
40
+
reason = msg
41
+
})
46
42
end
47
43
48
44
let start_element _state ~name ~namespace:_ ~attrs collector =
+44
-51
lib/html5_checker/semantic/id_checker.ml
+44
-51
lib/html5_checker/semantic/id_checker.ml
···
13
13
referring_element : string;
14
14
attribute : string;
15
15
referenced_id : string;
16
-
location : Message.location option;
16
+
_location : Message.location option; [@warning "-69"]
17
17
}
18
18
19
19
(** Checker state tracking IDs, map names, and references. *)
···
96
96
]
97
97
98
98
(** Check and store an ID attribute. *)
99
-
let check_id state ~element ~id ~location collector =
99
+
let check_id state ~element:_ ~id ~location:_ collector =
100
100
(* Check for empty ID *)
101
101
if String.length id = 0 then
102
-
Message_collector.add_error collector
103
-
~message:"ID attribute must not be empty"
104
-
~code:"empty-id"
105
-
?location
106
-
~element
107
-
~attribute:"id"
108
-
()
102
+
Message_collector.add_typed collector
103
+
(Error_code.Bad_attr_value_generic {
104
+
message = "Bad value \"\" for attribute \"id\": An ID must not be the empty string."
105
+
})
109
106
(* Check for whitespace in ID *)
110
107
else if contains_whitespace id then
111
-
Message_collector.add_error collector
112
-
~message:(Printf.sprintf "ID attribute value '%s' must not contain whitespace" id)
113
-
~code:"id-whitespace"
114
-
?location
115
-
~element
116
-
~attribute:"id"
117
-
()
108
+
Message_collector.add_typed collector
109
+
(Error_code.Bad_attr_value_generic {
110
+
message = Printf.sprintf "Bad value %s for attribute \"id\": An ID must not contain whitespace."
111
+
(Error_code.q id)
112
+
})
118
113
(* Check for duplicate ID *)
119
114
else if Hashtbl.mem state.ids id then
120
-
Message_collector.add_error collector
121
-
~message:(Printf.sprintf "Duplicate ID \xe2\x80\x9c%s\xe2\x80\x9d." id)
122
-
~code:"duplicate-id"
123
-
?location
124
-
~element
125
-
~attribute:"id"
126
-
()
115
+
Message_collector.add_typed collector (Error_code.Duplicate_id { id })
127
116
else
128
117
(* Store the ID *)
129
118
Hashtbl.add state.ids id ()
···
135
124
referring_element;
136
125
attribute;
137
126
referenced_id;
138
-
location;
127
+
_location = location;
139
128
} :: state.references
140
129
141
130
(** Process attributes to check IDs and collect references. *)
···
154
143
referring_element = element;
155
144
attribute = name;
156
145
referenced_id = map_name;
157
-
location;
146
+
_location = location;
158
147
} :: state.usemap_references
148
+
else
149
+
(* Empty hash name: "#" *)
150
+
Message_collector.add_typed collector
151
+
(Error_code.Bad_attr_value {
152
+
element;
153
+
attr = name;
154
+
value;
155
+
reason = Printf.sprintf "Bad hash-name reference: A hash-name reference must have at least one character after %s."
156
+
(Error_code.q "#")
157
+
})
159
158
| None ->
160
159
if String.length value > 0 then
161
-
Message_collector.add_error collector
162
-
~message:(Printf.sprintf
163
-
"usemap attribute value '%s' must start with '#'" value)
164
-
~code:"invalid-usemap"
165
-
?location
166
-
~element
167
-
~attribute:name
168
-
()
160
+
(* Missing # prefix *)
161
+
Message_collector.add_typed collector
162
+
(Error_code.Bad_attr_value {
163
+
element;
164
+
attr = name;
165
+
value;
166
+
reason = Printf.sprintf "Bad hash-name reference: A hash-name reference must start with %s."
167
+
(Error_code.q "#")
168
+
})
169
169
end
170
170
171
171
| "name" when element = "map" ->
···
205
205
(* Check all ID references point to existing IDs *)
206
206
List.iter (fun ref ->
207
207
if not (Hashtbl.mem state.ids ref.referenced_id) then
208
-
Message_collector.add_error collector
209
-
~message:(Printf.sprintf
210
-
"The '%s' attribute on <%s> refers to ID '%s' which does not exist"
211
-
ref.attribute ref.referring_element ref.referenced_id)
212
-
~code:"dangling-id-reference"
213
-
?location:ref.location
214
-
~element:ref.referring_element
215
-
~attribute:ref.attribute
216
-
()
208
+
(* Use generic for dangling references - format may vary *)
209
+
Message_collector.add_typed collector
210
+
(Error_code.Generic {
211
+
message = Printf.sprintf "The %s attribute on the %s element refers to ID %s which does not exist in the document."
212
+
(Error_code.q ref.attribute) (Error_code.q ref.referring_element) (Error_code.q ref.referenced_id)
213
+
})
217
214
) state.references;
218
215
219
216
(* Check all usemap references point to existing map names *)
220
217
List.iter (fun ref ->
221
218
if not (Hashtbl.mem state.map_names ref.referenced_id) then
222
-
Message_collector.add_error collector
223
-
~message:(Printf.sprintf
224
-
"The '%s' attribute on <%s> refers to map name '%s' which does not exist"
225
-
ref.attribute ref.referring_element ref.referenced_id)
226
-
~code:"dangling-usemap-reference"
227
-
?location:ref.location
228
-
~element:ref.referring_element
229
-
~attribute:ref.attribute
230
-
()
219
+
Message_collector.add_typed collector
220
+
(Error_code.Generic {
221
+
message = Printf.sprintf "The %s attribute on the %s element refers to map name %s which does not exist in the document."
222
+
(Error_code.q ref.attribute) (Error_code.q ref.referring_element) (Error_code.q ref.referenced_id)
223
+
})
231
224
) state.usemap_references
232
225
233
226
let checker = (module struct
+16
-28
lib/html5_checker/semantic/lang_detecting_checker.ml
+16
-28
lib/html5_checker/semantic/lang_detecting_checker.ml
···
236
236
let base_detected = get_lang_code detected_code in
237
237
if original_declared = "" then begin
238
238
(* No lang attribute - suggest adding one *)
239
-
Message_collector.add_warning collector
240
-
~message:(Printf.sprintf
241
-
"This document appears to be written in %s. Consider adding \xe2\x80\x9clang=\"%s\"\xe2\x80\x9d (or variant) to the \xe2\x80\x9chtml\xe2\x80\x9d start tag."
242
-
detected_name suggested_code)
243
-
~code:"missing-lang"
244
-
~element:"html"
245
-
()
239
+
Message_collector.add_typed collector
240
+
(Error_code.Wrong_lang {
241
+
detected = detected_name;
242
+
declared = "";
243
+
suggested = suggested_code
244
+
})
246
245
end
247
246
else if base_declared <> base_detected &&
248
247
(* Don't warn for zh variants *)
249
248
not (base_declared = "zh" && base_detected = "zh") then begin
250
-
Message_collector.add_warning collector
251
-
~message:(Printf.sprintf
252
-
"This document appears to be written in %s but the \xe2\x80\x9chtml\xe2\x80\x9d start tag has \xe2\x80\x9clang=\"%s\"\xe2\x80\x9d. Consider using \xe2\x80\x9clang=\"%s\"\xe2\x80\x9d (or variant) instead."
253
-
detected_name original_declared suggested_code)
254
-
~code:"wrong-lang"
255
-
~element:"html"
256
-
()
249
+
Message_collector.add_typed collector
250
+
(Error_code.Wrong_lang {
251
+
detected = detected_name;
252
+
declared = original_declared;
253
+
suggested = suggested_code
254
+
})
257
255
end;
258
256
259
257
(* Check dir attribute for RTL languages *)
260
258
if List.mem base_detected rtl_langs then begin
261
259
match state.html_dir with
262
260
| None ->
263
-
Message_collector.add_warning collector
264
-
~message:(Printf.sprintf
265
-
"This document appears to be written in %s. Consider adding \xe2\x80\x9cdir=\"rtl\"\xe2\x80\x9d to the \xe2\x80\x9chtml\xe2\x80\x9d start tag."
266
-
detected_name)
267
-
~code:"missing-dir"
268
-
~element:"html"
269
-
()
261
+
Message_collector.add_typed collector
262
+
(Error_code.Missing_dir_rtl { language = detected_name })
270
263
| Some dir when String.lowercase_ascii dir <> "rtl" ->
271
-
Message_collector.add_warning collector
272
-
~message:(Printf.sprintf
273
-
"This document appears to be written in %s but the \xe2\x80\x9chtml\xe2\x80\x9d start tag has \xe2\x80\x9cdir=\"%s\"\xe2\x80\x9d. Consider using \xe2\x80\x9cdir=\"rtl\"\xe2\x80\x9d instead."
274
-
detected_name dir)
275
-
~code:"wrong-dir"
276
-
~element:"html"
277
-
()
264
+
Message_collector.add_typed collector
265
+
(Error_code.Wrong_dir { language = detected_name; declared = dir })
278
266
| _ -> ()
279
267
end
280
268
| _ -> ()
+21
-27
lib/html5_checker/semantic/nesting_checker.ml
+21
-27
lib/html5_checker/semantic/nesting_checker.ml
···
181
181
| _ ->
182
182
false
183
183
184
-
(** Get a human-readable description of an element for error messages. *)
185
-
let element_description name attrs =
186
-
match name with
187
-
| "a" when has_attr attrs "href" ->
188
-
"The element \"a\" with the attribute \"href\""
189
-
| "audio" when has_attr attrs "controls" ->
190
-
"The element \"audio\" with the attribute \"controls\""
191
-
| "video" when has_attr attrs "controls" ->
192
-
"The element \"video\" with the attribute \"controls\""
193
-
| "img" when has_attr attrs "usemap" ->
194
-
"The element \"img\" with the attribute \"usemap\""
195
-
| "object" when has_attr attrs "usemap" ->
196
-
"The element \"object\" with the attribute \"usemap\""
197
-
| _ ->
198
-
Printf.sprintf "The element \"%s\"" name
199
-
200
184
(** Report nesting violations. *)
201
185
let check_nesting state name attrs collector =
202
186
(* Compute the prohibited ancestor mask for this element *)
···
218
202
if mask <> 0 then begin
219
203
let mask_hit = state.ancestor_mask land mask in
220
204
if mask_hit <> 0 then begin
221
-
let desc = element_description name attrs in
205
+
(* Determine if element has a special attribute to mention *)
206
+
let attr =
207
+
match name with
208
+
| "a" when has_attr attrs "href" -> Some "href"
209
+
| "audio" when has_attr attrs "controls" -> Some "controls"
210
+
| "video" when has_attr attrs "controls" -> Some "controls"
211
+
| "img" when has_attr attrs "usemap" -> Some "usemap"
212
+
| "object" when has_attr attrs "usemap" -> Some "usemap"
213
+
| _ -> None
214
+
in
222
215
(* Find which ancestors are violated *)
223
216
Array.iteri (fun i ancestor ->
224
217
let bit = 1 lsl i in
225
218
if (mask_hit land bit) <> 0 then
226
-
Message_collector.add_error collector
227
-
~message:(Printf.sprintf
228
-
"%s must not appear as a descendant of the \"%s\" element."
229
-
desc ancestor)
230
-
~element:name
231
-
()
219
+
Message_collector.add_typed collector
220
+
(Error_code.Element_must_not_be_descendant {
221
+
element = name;
222
+
attr;
223
+
ancestor
224
+
})
232
225
) special_ancestors
233
226
end
234
227
end
···
238
231
match name with
239
232
| "area" ->
240
233
if (state.ancestor_mask land map_mask) = 0 then
241
-
Message_collector.add_error collector
242
-
~message:"The \"area\" element must have a \"map\" ancestor."
243
-
~element:name
244
-
()
234
+
Message_collector.add_typed collector
235
+
(Error_code.Generic {
236
+
message = Printf.sprintf "The %s element must have a %s ancestor."
237
+
(Error_code.q "area") (Error_code.q "map")
238
+
})
245
239
| _ -> ()
246
240
247
241
let start_element state ~name ~namespace ~attrs collector =
+12
-36
lib/html5_checker/semantic/obsolete_checker.ml
+12
-36
lib/html5_checker/semantic/obsolete_checker.ml
···
163
163
register "target" ["link"]
164
164
"You can safely omit it.";
165
165
166
-
register "type" ["param"; "area"; "menu"]
166
+
register "type" ["param"; "area"]
167
167
"You can safely omit it.";
168
+
169
+
register "type" ["menu"]
170
+
"Use script to handle \"contextmenu\" event instead.";
168
171
169
172
register "typemustmatch" ["object"]
170
173
"Avoid using \"object\" elements with untrusted resources.";
···
260
263
(match Hashtbl.find_opt obsolete_elements name_lower with
261
264
| None -> ()
262
265
| Some suggestion ->
263
-
let message =
264
-
if String.length suggestion = 0 then
265
-
Printf.sprintf "The \xe2\x80\x9c%s\xe2\x80\x9d element is obsolete." name
266
-
else
267
-
Printf.sprintf "The \xe2\x80\x9c%s\xe2\x80\x9d element is obsolete. %s" name suggestion
268
-
in
269
-
Message_collector.add_error collector
270
-
~message
271
-
~code:"obsolete-element"
272
-
~element:name
273
-
());
266
+
Message_collector.add_typed collector
267
+
(Error_code.Obsolete_element { element = name; suggestion }));
274
268
275
269
(* Check for obsolete attributes *)
276
270
List.iter (fun (attr_name, _attr_value) ->
···
283
277
(match Hashtbl.find_opt element_map name_lower with
284
278
| None -> ()
285
279
| Some suggestion ->
286
-
let message =
287
-
Printf.sprintf "The \xe2\x80\x9c%s\xe2\x80\x9d attribute on the \xe2\x80\x9c%s\xe2\x80\x9d element is obsolete. %s"
288
-
attr_name name suggestion
289
-
in
290
-
Message_collector.add_error collector
291
-
~message
292
-
~code:"obsolete-attribute"
293
-
~element:name
294
-
~attribute:attr_name
295
-
()));
280
+
Message_collector.add_typed collector
281
+
(Error_code.Obsolete_attr { element = name; attr = attr_name; suggestion = Some suggestion })));
296
282
297
283
(* Check obsolete style attributes *)
298
284
(match Hashtbl.find_opt obsolete_style_attrs attr_lower with
299
285
| None -> ()
300
286
| Some elements ->
301
287
if List.mem name_lower elements then
302
-
let message =
303
-
Printf.sprintf "The \xe2\x80\x9c%s\xe2\x80\x9d attribute on the \xe2\x80\x9c%s\xe2\x80\x9d element is obsolete. Use CSS instead."
304
-
attr_name name
305
-
in
306
-
Message_collector.add_error collector
307
-
~message
308
-
~code:"obsolete-style-attribute"
309
-
~element:name
310
-
~attribute:attr_name
311
-
());
288
+
Message_collector.add_typed collector
289
+
(Error_code.Obsolete_attr { element = name; attr = attr_name; suggestion = Some "Use CSS instead." }));
312
290
313
291
(* Check obsolete global attributes *)
314
292
(match Hashtbl.find_opt obsolete_global_attrs attr_lower with
315
293
| None -> ()
316
294
| Some suggestion ->
317
-
let message =
318
-
Printf.sprintf "The \xe2\x80\x9c%s\xe2\x80\x9d attribute is obsolete. %s" attr_name suggestion
319
-
in
295
+
(* Global attributes use a different format - just "The X attribute is obsolete. Y" *)
320
296
Message_collector.add_error collector
321
-
~message
297
+
~message:(Printf.sprintf "The %s attribute is obsolete. %s" (Error_code.q attr_name) suggestion)
322
298
~code:"obsolete-global-attribute"
323
299
~element:name
324
300
~attribute:attr_name
+3
-12
lib/html5_checker/semantic/option_checker.ml
+3
-12
lib/html5_checker/semantic/option_checker.ml
···
61
61
state.option_stack <- rest;
62
62
(* Validate: option must have text content or non-empty label *)
63
63
if not ctx.has_text then begin
64
-
if ctx.label_empty then
65
-
(* Has label="" (empty) and no text - error *)
66
-
Message_collector.add_error collector
67
-
~message:"An \xe2\x80\x9coption\xe2\x80\x9d element with an empty \xe2\x80\x9clabel\xe2\x80\x9d attribute must have content."
68
-
~code:"empty-option"
69
-
~element:"option" ()
70
-
else if not ctx.has_label then
71
-
(* No label and no text - error *)
72
-
Message_collector.add_error collector
73
-
~message:"An \xe2\x80\x9coption\xe2\x80\x9d element with no \xe2\x80\x9clabel\xe2\x80\x9d attribute must have content."
74
-
~code:"empty-option"
75
-
~element:"option" ()
64
+
if ctx.label_empty || not ctx.has_label then
65
+
(* Has label="" (empty) and no text, or no label at all - error *)
66
+
Message_collector.add_typed collector Error_code.Option_empty_without_label
76
67
end
77
68
| [] -> ()
78
69
end
+60
-55
lib/html5_checker/semantic/required_attr_checker.ml
+60
-55
lib/html5_checker/semantic/required_attr_checker.ml
···
27
27
let check_img_element state attrs collector =
28
28
(* Check for required src OR srcset attribute *)
29
29
if not (has_attr "src" attrs) && not (has_attr "srcset" attrs) then
30
-
Message_collector.add_error collector
31
-
~message:"Element \xe2\x80\x9cimg\xe2\x80\x9d is missing one or more of the following attributes: [src, srcset]."
32
-
~code:"missing-required-attribute" ~element:"img" ~attribute:"src" ();
30
+
Message_collector.add_typed collector Error_code.Img_missing_src_or_srcset;
33
31
34
32
(* Check for alt attribute - always required *)
35
33
if not (has_attr "alt" attrs) then
36
-
Message_collector.add_error collector
37
-
~message:"img element requires alt attribute for accessibility"
38
-
~code:"missing-required-attribute" ~element:"img" ~attribute:"alt" ();
34
+
Message_collector.add_typed collector Error_code.Img_missing_alt;
39
35
40
36
(* Check ismap requires 'a' ancestor with href *)
41
37
if has_attr "ismap" attrs && not state.in_a_with_href then
42
-
Message_collector.add_error collector
43
-
~message:"The \xe2\x80\x9cimg\xe2\x80\x9d element with the \xe2\x80\x9cismap\xe2\x80\x9d attribute set must have an \xe2\x80\x9ca\xe2\x80\x9d ancestor with the \xe2\x80\x9chref\xe2\x80\x9d attribute."
44
-
~code:"missing-required-ancestor" ~element:"img" ~attribute:"ismap" ()
38
+
Message_collector.add_typed collector Error_code.Img_ismap_needs_a_href
45
39
46
40
let check_area_element attrs collector =
47
41
(* area with href requires alt *)
48
42
if has_attr "href" attrs && not (has_attr "alt" attrs) then
49
-
Message_collector.add_error collector
50
-
~message:"area element with href requires alt attribute" ~code:"missing-required-attribute"
51
-
~element:"area" ~attribute:"alt" ()
43
+
Message_collector.add_typed collector
44
+
(Error_code.Missing_required_attr { element = "area"; attr = "alt" })
52
45
53
46
let check_input_element attrs collector =
54
47
match get_attr "type" attrs with
55
48
| Some "image" ->
56
49
(* input[type=image] requires alt *)
57
50
if not (has_attr "alt" attrs) then
58
-
Message_collector.add_error collector
59
-
~message:"input element with type=\"image\" requires alt attribute"
60
-
~code:"missing-required-attribute" ~element:"input" ~attribute:"alt" ()
51
+
Message_collector.add_typed collector
52
+
(Error_code.Missing_required_attr { element = "input"; attr = "alt" })
61
53
| Some "hidden" ->
62
54
(* input[type=hidden] should not have required attribute *)
63
55
if has_attr "required" attrs then
64
-
Message_collector.add_error collector
65
-
~message:"input element with type=\"hidden\" cannot have required attribute"
66
-
~code:"invalid-attribute-combination" ~element:"input" ~attribute:"required" ()
56
+
Message_collector.add_typed collector
57
+
(Error_code.Attr_not_allowed_when {
58
+
attr = "required";
59
+
element = "input";
60
+
condition = "the type attribute is hidden"
61
+
})
67
62
| Some "file" ->
68
63
(* input[type=file] should not have value attribute *)
69
64
if has_attr "value" attrs then
70
-
Message_collector.add_warning collector
71
-
~message:"input element with type=\"file\" should not have value attribute"
72
-
~code:"invalid-attribute-combination" ~element:"input" ~attribute:"value" ()
65
+
Message_collector.add_typed collector
66
+
(Error_code.Attr_not_allowed_when {
67
+
attr = "value";
68
+
element = "input";
69
+
condition = "the type attribute is file"
70
+
})
73
71
| _ -> ()
74
72
75
73
let check_script_element attrs _collector =
···
102
100
in
103
101
104
102
if not valid then
105
-
Message_collector.add_error collector
106
-
~message:
107
-
"meta element requires either charset, or name+content, or http-equiv+content"
108
-
~code:"missing-required-attribute" ~element:"meta" ()
103
+
Message_collector.add_typed collector
104
+
(Error_code.Generic {
105
+
message = Printf.sprintf "A %s element must have either a %s attribute, a %s attribute with a %s attribute, or an %s attribute with a %s attribute."
106
+
(Error_code.q "meta") (Error_code.q "charset") (Error_code.q "name")
107
+
(Error_code.q "content") (Error_code.q "http-equiv") (Error_code.q "content")
108
+
})
109
109
110
110
let check_link_element attrs collector =
111
111
(* link[rel="stylesheet"] requires href *)
112
112
match get_attr "rel" attrs with
113
113
| Some rel when String.equal rel "stylesheet" ->
114
114
if not (has_attr "href" attrs) then
115
-
Message_collector.add_error collector
116
-
~message:"link element with rel=\"stylesheet\" requires href attribute"
117
-
~code:"missing-required-attribute" ~element:"link" ~attribute:"href" ()
115
+
Message_collector.add_typed collector Error_code.Link_missing_href
118
116
| _ -> ()
119
117
120
118
let check_a_element attrs collector =
121
119
(* a[download] requires href *)
122
120
if has_attr "download" attrs && not (has_attr "href" attrs) then
123
-
Message_collector.add_error collector
124
-
~message:"Element \xe2\x80\x9ca\xe2\x80\x9d is missing required attribute \xe2\x80\x9chref\xe2\x80\x9d."
125
-
~code:"missing-required-attribute" ~element:"a" ~attribute:"href" ()
121
+
Message_collector.add_typed collector
122
+
(Error_code.Missing_required_attr { element = "a"; attr = "href" })
126
123
127
124
let check_map_element attrs collector =
128
125
(* map requires name *)
129
126
if not (has_attr "name" attrs) then
130
-
Message_collector.add_error collector
131
-
~message:"map element requires name attribute" ~code:"missing-required-attribute"
132
-
~element:"map" ~attribute:"name" ()
127
+
Message_collector.add_typed collector
128
+
(Error_code.Missing_required_attr { element = "map"; attr = "name" })
133
129
134
130
let check_object_element attrs collector =
135
131
(* object requires data attribute (or type attribute alone is not sufficient) *)
136
132
let has_data = has_attr "data" attrs in
137
133
let has_type = has_attr "type" attrs in
138
134
if not has_data && has_type then
139
-
Message_collector.add_error collector
140
-
~message:"Element \xe2\x80\x9cobject\xe2\x80\x9d is missing required attribute \xe2\x80\x9cdata\xe2\x80\x9d."
141
-
~code:"missing-required-attribute" ~element:"object" ~attribute:"data" ()
135
+
Message_collector.add_typed collector
136
+
(Error_code.Missing_required_attr { element = "object"; attr = "data" })
142
137
143
-
let check_popover_element attrs collector =
138
+
let check_popover_element element_name attrs collector =
144
139
(* popover attribute must have valid value *)
145
140
match get_attr "popover" attrs with
146
141
| Some value ->
147
142
let value_lower = String.lowercase_ascii value in
148
143
(* Valid values: empty string, auto, manual, hint *)
149
144
if value_lower <> "" && value_lower <> "auto" && value_lower <> "manual" && value_lower <> "hint" then
150
-
Message_collector.add_error collector
151
-
~message:(Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9cpopover\xe2\x80\x9d on element \xe2\x80\x9cdiv\xe2\x80\x9d."
152
-
value)
153
-
~code:"bad-attribute-value" ~element:"div" ~attribute:"popover" ()
145
+
Message_collector.add_typed collector
146
+
(Error_code.Bad_attr_value {
147
+
element = element_name;
148
+
attr = "popover";
149
+
value;
150
+
reason = "Must be a valid popover state (auto, manual, or hint)."
151
+
})
154
152
| None -> ()
155
153
156
154
let check_meter_element attrs collector =
157
155
(* meter requires value attribute *)
158
156
if not (has_attr "value" attrs) then
159
-
Message_collector.add_error collector
160
-
~message:"Element \xe2\x80\x9cmeter\xe2\x80\x9d is missing required attribute \xe2\x80\x9cvalue\xe2\x80\x9d."
161
-
~code:"missing-required-attribute" ~element:"meter" ~attribute:"value" ()
157
+
Message_collector.add_typed collector
158
+
(Error_code.Missing_required_attr { element = "meter"; attr = "value" })
162
159
else begin
163
160
(* Validate min <= value constraint *)
164
161
match get_attr "value" attrs, get_attr "min" attrs with
···
167
164
let value = float_of_string value_str in
168
165
let min_val = float_of_string min_str in
169
166
if min_val > value then
170
-
Message_collector.add_error collector
171
-
~message:"The value of the \xe2\x80\x9cmin\xe2\x80\x9d attribute must be less than or equal to the value of the \xe2\x80\x9cvalue\xe2\x80\x9d attribute."
172
-
~code:"bad-attribute-value" ~element:"meter" ~attribute:"min" ()
167
+
Message_collector.add_typed collector
168
+
(Error_code.Generic {
169
+
message = Printf.sprintf "The value of the %s attribute must be less than or equal to the value of the %s attribute."
170
+
(Error_code.q "min") (Error_code.q "value")
171
+
})
173
172
with _ -> ())
174
173
| _ -> ()
175
174
end
···
188
187
if value > max_val then
189
188
(* Check which message to use based on whether max is present *)
190
189
if has_attr "max" attrs then
191
-
Message_collector.add_error collector
192
-
~message:"The value of the \xe2\x80\x9cvalue\xe2\x80\x9d attribute must be less than or equal to the value of the \xe2\x80\x9cmax\xe2\x80\x9d attribute."
193
-
~code:"bad-attribute-value" ~element:"progress" ~attribute:"value" ()
190
+
Message_collector.add_typed collector
191
+
(Error_code.Generic {
192
+
(* Note: double space before "value" matches Nu validator quirk *)
193
+
message = Printf.sprintf "The value of the %s attribute must be less than or equal to the value of the %s attribute."
194
+
(Error_code.q "value") (Error_code.q "max")
195
+
})
194
196
else
195
-
Message_collector.add_error collector
196
-
~message:"The value of the \xe2\x80\x9cvalue\xe2\x80\x9d attribute must be less than or equal to one when the \xe2\x80\x9cmax\xe2\x80\x9d attribute is absent."
197
-
~code:"bad-attribute-value" ~element:"progress" ~attribute:"value" ()
197
+
Message_collector.add_typed collector
198
+
(Error_code.Generic {
199
+
(* Note: double space before "value" matches Nu validator quirk *)
200
+
message = Printf.sprintf "The value of the %s attribute must be less than or equal to one when the %s attribute is absent."
201
+
(Error_code.q "value") (Error_code.q "max")
202
+
})
198
203
with _ -> ())
199
204
200
205
let start_element state ~name ~namespace:_ ~attrs collector =
···
215
220
| "figure" -> state._in_figure <- true
216
221
| _ ->
217
222
(* Check popover attribute on any element *)
218
-
if has_attr "popover" attrs then check_popover_element attrs collector
223
+
if has_attr "popover" attrs then check_popover_element name attrs collector
219
224
220
225
let end_element state ~name ~namespace:_ _collector =
221
226
match name with
+1
-1
lib/html5_checker/specialized/url_checker.ml
+1
-1
lib/html5_checker/specialized/url_checker.ml
···
297
297
(* Check for empty host *)
298
298
let requires_host = List.mem scheme special_schemes in
299
299
if host = "" && requires_host && scheme <> "file" then
300
-
Some (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9c%s\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad URL: empty host."
300
+
Some (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9c%s\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad URL: Invalid host: empty host."
301
301
url attr_name element_name)
302
302
else
303
303
(* Check for invalid chars *)
+33
-20
test/test_validator.ml
+33
-20
test/test_validator.ml
···
142
142
if errors = [] then
143
143
(false, "Expected error but got none")
144
144
else begin
145
-
(* For novalid tests, we pass if ANY error is produced.
146
-
Message matching is optional - our messages may differ from Nu validator. *)
147
-
let msg_matched = match expected_msg with
148
-
| None -> true
149
-
| Some exp -> List.exists (fun actual -> message_matches ~expected:exp ~actual) errors
150
-
in
151
-
if msg_matched then
152
-
(true, Printf.sprintf "Got %d error(s), message matched" (List.length errors))
153
-
else
154
-
(* Still pass - we detected an error even if message differs *)
155
-
(true, Printf.sprintf "Got %d error(s) (message format differs)" (List.length errors))
145
+
(* For novalid tests, require EXACT message match when expected message is provided *)
146
+
match expected_msg with
147
+
| None ->
148
+
(* No expected message - pass if any error detected *)
149
+
(true, Printf.sprintf "Got %d error(s), no expected message to match" (List.length errors))
150
+
| Some exp ->
151
+
if List.exists (fun actual -> message_matches ~expected:exp ~actual) errors then
152
+
(true, Printf.sprintf "Got %d error(s), message matched" (List.length errors))
153
+
else
154
+
(* FAIL if message doesn't match - we want exact matching *)
155
+
(false, Printf.sprintf "Message mismatch.\n Expected: %s\n Got: %s"
156
+
exp (String.concat "\n " errors))
156
157
end
157
158
| HasWarning ->
158
-
(* For haswarn, accept warnings or info messages (Nu validator uses info for some) *)
159
-
if warnings <> [] then
160
-
(true, Printf.sprintf "Got %d warning(s)" (List.length warnings))
161
-
else if infos <> [] then
162
-
(true, Printf.sprintf "Got %d info message(s)" (List.length infos))
163
-
else if errors <> [] then
164
-
(* Also accept errors as they indicate we caught something *)
165
-
(true, Printf.sprintf "Got %d error(s) instead of warning" (List.length errors))
166
-
else
159
+
(* For haswarn, require message match against warnings or infos *)
160
+
let all_messages = warnings @ infos in
161
+
if all_messages = [] && errors = [] then
167
162
(false, "Expected warning but got none")
163
+
else begin
164
+
match expected_msg with
165
+
| None ->
166
+
if all_messages <> [] then
167
+
(true, Printf.sprintf "Got %d warning/info message(s)" (List.length all_messages))
168
+
else
169
+
(true, Printf.sprintf "Got %d error(s) instead of warning" (List.length errors))
170
+
| Some exp ->
171
+
if List.exists (fun actual -> message_matches ~expected:exp ~actual) all_messages then
172
+
(true, Printf.sprintf "Got %d warning/info message(s), matched" (List.length all_messages))
173
+
else if List.exists (fun actual -> message_matches ~expected:exp ~actual) errors then
174
+
(* Accept error if message matches (severity might differ) *)
175
+
(true, Printf.sprintf "Got error instead of warning, but message matched")
176
+
else
177
+
(false, Printf.sprintf "Message mismatch.\n Expected: %s\n Got warnings: %s\n Got errors: %s"
178
+
exp (String.concat "\n " (if all_messages = [] then ["(none)"] else all_messages))
179
+
(String.concat "\n " (if errors = [] then ["(none)"] else errors)))
180
+
end
168
181
| Unknown ->
169
182
(false, "Unknown test type")
170
183
in