OCaml HTML5 parser/serialiser based on Python's JustHTML
polyvariants
+1632
-1163
+9
-9
lib/html5_checker/content_model/content_checker.ml
+9
-9
lib/html5_checker/content_model/content_checker.ml
···
75
75
(fun prohibited ->
76
76
if List.exists (fun ctx -> String.equal ctx.name prohibited) state.ancestor_stack then
77
77
Message_collector.add_typed collector
78
-
(Error_code.Element_not_allowed_as_child { child = name; parent = prohibited }))
78
+
(`Element (`Not_allowed_as_child (`Child name, `Parent prohibited))))
79
79
spec.Element_spec.prohibited_ancestors
80
80
81
81
(* Validate that a child element is allowed *)
···
85
85
(* Root level - only html allowed *)
86
86
if not (String.equal (String.lowercase_ascii child_name) "html") then
87
87
Message_collector.add_typed collector
88
-
(Error_code.Generic { message = Printf.sprintf "Element '%s' not allowed at document root (only 'html' allowed)" child_name })
88
+
(`Generic (Printf.sprintf "Element '%s' not allowed at document root (only 'html' allowed)" child_name))
89
89
| parent :: _ ->
90
90
let content_model = parent.spec.Element_spec.content_model in
91
91
if not (matches_content_model state.registry child_name content_model) then
92
92
Message_collector.add_typed collector
93
-
(Error_code.Element_not_allowed_as_child { child = child_name; parent = parent.name })
93
+
(`Element (`Not_allowed_as_child (`Child child_name, `Parent parent.name)))
94
94
95
95
let start_element state ~name ~namespace:_ ~attrs:_ collector =
96
96
(* Look up element specification *)
···
116
116
| [] ->
117
117
(* Unmatched closing tag *)
118
118
Message_collector.add_typed collector
119
-
(Error_code.Generic { message = Printf.sprintf "Unmatched closing tag '%s'" name })
119
+
(`Generic (Printf.sprintf "Unmatched closing tag '%s'" name))
120
120
| context :: rest ->
121
121
if not (String.equal context.name name) then
122
122
(* Mismatched tag *)
123
123
Message_collector.add_typed collector
124
-
(Error_code.Generic { message = Printf.sprintf "Expected closing tag '%s' but got '%s'" context.name name })
124
+
(`Generic (Printf.sprintf "Expected closing tag '%s' but got '%s'" context.name name))
125
125
else (
126
126
(* Check if void element has children *)
127
127
if Element_spec.is_void context.spec && context.children_count > 0 then
128
128
Message_collector.add_typed collector
129
-
(Error_code.Generic { message = Printf.sprintf "Void element '%s' must not have children" name });
129
+
(`Generic (Printf.sprintf "Void element '%s' must not have children" name));
130
130
131
131
(* Pop stack *)
132
132
state.ancestor_stack <- rest;
···
145
145
(* Text at root level - only whitespace allowed *)
146
146
if not (String.trim text = "") then
147
147
Message_collector.add_typed collector
148
-
(Error_code.Generic { message = "Text content not allowed at document root" })
148
+
(`Generic "Text content not allowed at document root")
149
149
| parent :: rest ->
150
150
let content_model = parent.spec.Element_spec.content_model in
151
151
if not (allows_text content_model) then
152
152
(* Only report if non-whitespace text *)
153
153
if not (String.trim text = "") then
154
154
Message_collector.add_typed collector
155
-
(Error_code.Text_not_allowed { parent = parent.name })
155
+
(`Element (`Text_not_allowed (`Parent parent.name)))
156
156
else (
157
157
(* Text is allowed, increment child count *)
158
158
let updated_parent = { parent with children_count = parent.children_count + 1 } in
···
163
163
List.iter
164
164
(fun context ->
165
165
Message_collector.add_typed collector
166
-
(Error_code.Generic { message = Printf.sprintf "Unclosed element '%s'" context.name }))
166
+
(`Generic (Printf.sprintf "Unclosed element '%s'" context.name)))
167
167
state.ancestor_stack
168
168
169
169
(* Package as first-class module *)
+566
-594
lib/html5_checker/error_code.ml
+566
-594
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. *)
1
+
(** Typed error codes for HTML5 validation messages. *)
5
2
6
-
(** Severity level of a validation message *)
7
3
type severity = Error | Warning | Info
8
4
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. *)
5
+
type 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
+
]
32
17
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
-
| Obsolete_global_attr of { attr: string; suggestion: string }
39
-
(** The "X" attribute is obsolete. Y *)
40
-
| Element_not_allowed_as_child of { child: string; parent: string }
41
-
(** Element "X" not allowed as child of element "Y" in this context. *)
42
-
| Unknown_element of { name: string }
43
-
(** Unknown element "X". *)
44
-
| Element_must_not_be_descendant of { element: string; attr: string option; ancestor: string }
45
-
(** The element "X" [with attribute "A"] must not appear as a descendant of the "Y" element. *)
46
-
| Missing_required_child of { parent: string; child: string }
47
-
(** Element "X" is missing required child element "Y". *)
48
-
| Missing_required_child_one_of of { parent: string; children: string list }
49
-
(** Element "X" is missing one or more of the following child elements: [A, B]. *)
50
-
| Missing_required_child_generic of { parent: string }
51
-
(** Element "X" is missing a required child element. *)
52
-
| Element_must_not_be_empty of { element: string }
53
-
(** Element "X" must not be empty. *)
54
-
| Stray_start_tag of { tag: string }
55
-
(** Stray start tag "X". *)
56
-
| Stray_end_tag of { tag: string }
57
-
(** Stray end tag "X". *)
58
-
| End_tag_for_void_element of { tag: string }
59
-
(** End tag "X". (for void elements like br) *)
60
-
| Self_closing_non_void
61
-
(** Self-closing syntax used on a non-void HTML element. *)
62
-
| Text_not_allowed of { parent: string }
63
-
(** Text not allowed in element "X" in this context. *)
18
+
type 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
+
]
64
31
65
-
(* ===== Child Restrictions ===== *)
66
-
| Div_child_of_dl_bad_role
67
-
(** A "div" child of a "dl" element must not have any "role" value other than "presentation" or "none". *)
68
-
| Li_bad_role_in_menu
69
-
(** An "li" element descendant of role=menu/menubar must have specific roles. *)
70
-
| Li_bad_role_in_tablist
71
-
(** An "li" element descendant of role=tablist must have role=tab. *)
72
-
| Li_bad_role_in_list
73
-
(** An "li" element descendant of ul/ol/menu or role=list must have role=listitem. *)
32
+
type 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
+
]
74
43
75
-
(* ===== ARIA Errors ===== *)
76
-
| Unnecessary_role of { role: string; element: string; reason: string }
77
-
(** The "X" role is unnecessary for Y. *)
78
-
| Bad_role of { element: string; role: string }
79
-
(** Bad value "X" for attribute "role" on element "Y". *)
80
-
| Aria_must_not_be_specified of { attr: string; element: string; condition: string }
81
-
(** The "X" attribute must not be specified on any "Y" element unless... *)
82
-
| Aria_must_not_be_used of { attr: string; element: string; condition: string }
83
-
(** The "X" attribute must not be used on an "Y" element which has... *)
84
-
| Aria_should_not_be_used of { attr: string; role: string }
85
-
(** The "X" attribute should not be used on any element which has "role=Y". *)
86
-
| Aria_hidden_on_body
87
-
(** "aria-hidden=true" must not be used on the "body" element. *)
88
-
| Img_empty_alt_with_role
89
-
(** An "img" element with empty alt must not have a role attribute. *)
90
-
| Checkbox_button_needs_aria_pressed
91
-
(** An "input" type="checkbox" with role="button" must have aria-pressed. *)
92
-
| Tab_without_tabpanel
93
-
(** Every active "role=tab" element must have a corresponding "role=tabpanel" element. *)
94
-
| Multiple_main_visible
95
-
(** A document should not include more than one visible element with "role=main". *)
96
-
| Discarding_unrecognized_role of { token: string }
97
-
(** Discarding unrecognized token "X" from value of attribute "role". *)
44
+
type 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
+
]
98
53
99
-
(* ===== Required Attribute/Element Conditions ===== *)
100
-
| Img_missing_alt
101
-
(** An "img" element must have an "alt" attribute. *)
102
-
| Img_missing_src_or_srcset
103
-
(** Element "img" is missing one or more of the following attributes: [src, srcset]. *)
104
-
| Option_empty_without_label
105
-
(** Element "option" without attribute "label" must not be empty. *)
106
-
| Bdo_missing_dir
107
-
(** Element "bdo" must have attribute "dir". *)
108
-
| Bdo_dir_auto
109
-
(** The value of "dir" attribute for the "bdo" element must not be "auto". *)
110
-
| Base_missing_href_or_target
111
-
(** Element "base" is missing one or more of the following attributes: [href, target]. *)
112
-
| Base_after_link_script
113
-
(** The "base" element must come before any "link" or "script" elements. *)
114
-
| Link_missing_href
115
-
(** A "link" element must have an "href" or "imagesrcset" attribute. *)
116
-
| Link_as_requires_preload
117
-
(** A "link" element with an "as" attribute must have rel="preload" or "modulepreload". *)
118
-
| Link_imagesrcset_requires_as_image
119
-
(** A "link" element with "imagesrcset" must have as="image". *)
120
-
| Img_ismap_needs_a_href
121
-
(** The "img" element with "ismap" must have an "a" ancestor with "href". *)
122
-
| Sizes_without_srcset
123
-
(** The "sizes" attribute must only be specified if "srcset" is also specified. *)
124
-
| Imagesizes_without_imagesrcset
125
-
(** The "imagesizes" attribute must only be specified if "imagesrcset" is also specified. *)
126
-
| Srcset_w_without_sizes
127
-
(** When the "srcset" attribute has width descriptors, "sizes" must also be specified. *)
128
-
| Source_missing_srcset
129
-
(** Element "source" is missing required attribute "srcset". *)
130
-
| Source_needs_media_or_type
131
-
(** A "source" element with following source/img[srcset] must have media/type. *)
132
-
| Picture_missing_img
133
-
(** Element "picture" is missing required child element "img". *)
134
-
| Map_id_name_mismatch
135
-
(** The "id" attribute on a "map" element must have the same value as the "name" attribute. *)
136
-
| List_attr_requires_datalist
137
-
(** The "list" attribute of "input" must refer to a "datalist" element. *)
138
-
| Input_list_not_allowed
139
-
(** Attribute "list" is only allowed on certain input types. *)
140
-
| Label_too_many_labelable
141
-
(** The "label" element may contain at most one labelable descendant. *)
142
-
| Label_for_id_mismatch
143
-
(** Any "input" descendant of a "label" with "for" must have matching ID. *)
144
-
| Role_on_label_ancestor
145
-
(** The "role" attribute must not be on label ancestor of labelable element. *)
146
-
| Role_on_label_for
147
-
(** The "role" attribute must not be on label associated via for. *)
148
-
| Aria_label_on_label_for
149
-
(** The "aria-label" attribute must not be on label associated via for. *)
150
-
| Input_value_constraint of { constraint_type: string }
151
-
(** The value of the "value" attribute must be... *)
152
-
| Summary_missing_role
153
-
(** Element "summary" is missing required attribute "role". *)
154
-
| Summary_missing_attrs
155
-
(** Element "summary" is missing one or more of [aria-checked, aria-level, role]. *)
156
-
| Summary_role_not_allowed
157
-
(** The "role" attribute must not be used on any "summary" for its parent "details". *)
158
-
| Autocomplete_webauthn_on_select
159
-
(** The value of "autocomplete" for "select" must not contain "webauthn". *)
160
-
| Commandfor_invalid_target
161
-
(** The value of "commandfor" must be the ID of an element in the same tree. *)
54
+
type 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
+
]
162
65
163
-
(* ===== Parse Errors ===== *)
164
-
| Forbidden_codepoint of { codepoint: int }
165
-
(** Forbidden code point U+XXXX. *)
166
-
| Char_ref_control of { codepoint: int }
167
-
(** Character reference expands to a control character (U+XXXX). *)
168
-
| Char_ref_non_char of { codepoint: int; astral: bool }
169
-
(** Character reference expands to a [astral] non-character (U+XXXX). *)
170
-
| Char_ref_unassigned
171
-
(** Character reference expands to a permanently unassigned code point. *)
172
-
| Char_ref_zero
173
-
(** Character reference expands to zero. *)
174
-
| Char_ref_out_of_range
175
-
(** Character reference outside the permissible Unicode range. *)
176
-
| Numeric_char_ref_carriage_return
177
-
(** A numeric character reference expanded to carriage return. *)
178
-
| End_of_file_with_open_elements
179
-
(** End of file seen and there were open elements. *)
180
-
| No_element_in_scope of { tag: string }
181
-
(** No "X" element in scope but a "X" end tag seen. *)
182
-
| End_tag_implied_open_elements of { tag: string }
183
-
(** End tag "X" implied, but there were open elements. *)
184
-
| Start_tag_in_table of { tag: string }
185
-
(** Start tag "X" seen in "table". *)
186
-
| Bad_start_tag_in of { tag: string; context: string }
187
-
(** Bad start tag in "X" in "noscript" in "head". *)
66
+
type li_role_error = [
67
+
| `Div_in_dl_bad_role
68
+
| `Li_bad_role_in_menu
69
+
| `Li_bad_role_in_tablist
70
+
| `Li_bad_role_in_list
71
+
]
188
72
189
-
(* ===== Table Errors ===== *)
190
-
| Table_row_no_cells of { row: int }
191
-
(** Row N of an implicit row group has no cells beginning on it. *)
192
-
| Table_cell_overlap
193
-
(** Table cell is overlapped by later table cell. *)
194
-
| Table_cell_spans_rowgroup
195
-
(** Table cell spans past the end of its row group. *)
196
-
| Table_column_no_cells of { column: int; element: string }
197
-
(** Table column N established by element "X" has no cells beginning in it. *)
73
+
type table_error = [
74
+
| `Row_no_cells of [`Row of int]
75
+
| `Cell_overlap
76
+
| `Cell_spans_rowgroup
77
+
| `Column_no_cells of [`Column of int] * [`Elem of string]
78
+
]
198
79
199
-
(* ===== Language/Internationalization ===== *)
200
-
| Missing_lang_attr
201
-
(** Consider adding a "lang" attribute to the "html" start tag. *)
202
-
| Wrong_lang of { detected: string; declared: string; suggested: string }
203
-
(** This document appears to be written in X but has lang="Y". Consider using "Z". *)
204
-
| Missing_dir_rtl of { language: string }
205
-
(** This document appears to be written in X. Consider adding dir="rtl". *)
206
-
| Wrong_dir of { language: string; declared: string }
207
-
(** This document appears to be written in X but has dir="Y". Consider dir="rtl". *)
208
-
| Xml_lang_without_lang
209
-
(** When xml:lang is specified, lang must also be present with the same value. *)
210
-
| Xml_lang_lang_mismatch
211
-
(** xml:lang and lang must have the same value. *)
80
+
type i18n_error = [
81
+
| `Missing_lang
82
+
| `Wrong_lang of [`Detected of string] * [`Declared of string] * [`Suggested of string]
83
+
| `Missing_dir_rtl of [`Language of string]
84
+
| `Wrong_dir of [`Language of string] * [`Declared of string]
85
+
| `Xml_lang_without_lang
86
+
| `Xml_lang_mismatch
87
+
| `Not_nfc of [`Replacement of string]
88
+
]
212
89
213
-
(* ===== Unicode Normalization ===== *)
214
-
| Not_nfc of { replacement: string }
215
-
(** Text run is not in Unicode Normalization Form C. *)
90
+
type importmap_error = [
91
+
| `Invalid_json
92
+
| `Invalid_root
93
+
| `Imports_not_object
94
+
| `Empty_key
95
+
| `Non_string_value
96
+
| `Key_trailing_slash
97
+
| `Scopes_not_object
98
+
| `Scopes_values_not_object
99
+
| `Scopes_invalid_url
100
+
| `Scopes_value_invalid_url
101
+
]
216
102
217
-
(* ===== Multiple h1 ===== *)
218
-
| Multiple_h1
219
-
(** Consider using only one "h1" element per document. *)
220
-
| Multiple_autofocus
221
-
(** There must not be two elements with autofocus in the same scoping root. *)
103
+
type img_error = [
104
+
| `Missing_alt
105
+
| `Missing_src_or_srcset
106
+
| `Empty_alt_with_role
107
+
| `Ismap_needs_href
108
+
]
109
+
110
+
type link_error = [
111
+
| `Missing_href
112
+
| `As_requires_preload
113
+
| `Imagesrcset_requires_as_image
114
+
]
222
115
223
-
(* ===== Import Maps ===== *)
224
-
| Importmap_invalid_json
225
-
(** A "script" type="importmap" must have valid JSON content. *)
226
-
| Importmap_invalid_root
227
-
(** A "script" type="importmap" must contain a JSON object with only imports/scopes/integrity. *)
228
-
| Importmap_imports_not_object
229
-
(** The value of "imports" property must be a JSON object. *)
230
-
| Importmap_empty_key
231
-
(** Specifier map must only contain non-empty keys. *)
232
-
| Importmap_non_string_value
233
-
(** Specifier map must only contain string values. *)
234
-
| Importmap_key_trailing_slash
235
-
(** Specifier map values must end with "/" when key ends with "/". *)
236
-
| Importmap_scopes_not_object
237
-
(** The value of "scopes" property must be a JSON object with valid URL keys. *)
238
-
| Importmap_scopes_values_not_object
239
-
(** The value of "scopes" property values must also be JSON objects. *)
240
-
| Importmap_scopes_invalid_url
241
-
(** The "scopes" property keys must be valid URL strings. *)
242
-
| Importmap_scopes_value_invalid_url
243
-
(** The specifier map within "scopes" must only contain valid URL values. *)
116
+
type label_error = [
117
+
| `Too_many_labelable
118
+
| `For_id_mismatch
119
+
| `Role_on_ancestor
120
+
| `Role_on_for
121
+
| `Aria_label_on_for
122
+
]
244
123
245
-
(* ===== Style Element ===== *)
246
-
| Style_type_invalid
247
-
(** The only allowed value for "type" on "style" is "text/css". *)
124
+
type input_error = [
125
+
| `Checkbox_needs_aria_pressed
126
+
| `Value_constraint of [`Constraint of string]
127
+
| `List_not_allowed
128
+
| `List_requires_datalist
129
+
]
248
130
249
-
(* ===== Headingoffset ===== *)
250
-
| Headingoffset_invalid
251
-
(** The value of "headingoffset" must be a number between "0" and "8". *)
131
+
type srcset_error = [
132
+
| `Sizes_without_srcset
133
+
| `Imagesizes_without_imagesrcset
134
+
| `W_without_sizes
135
+
| `Source_missing_srcset
136
+
| `Source_needs_media_or_type
137
+
| `Picture_missing_img
138
+
]
252
139
253
-
(* ===== Media Attribute ===== *)
254
-
| Media_empty
255
-
(** Value of "media" attribute here must not be empty. *)
256
-
| Media_all
257
-
(** Value of "media" attribute here must not be "all". *)
140
+
type svg_error = [
141
+
| `Deprecated_attr of [`Attr of string] * [`Elem of string]
142
+
| `Missing_attr of [`Elem of string] * [`Attr of string]
143
+
]
258
144
259
-
(* ===== SVG/MathML specific ===== *)
260
-
| Svg_deprecated_attr of { attr: string; element: string }
261
-
(** SVG deprecated attribute *)
262
-
| Missing_required_svg_attr of { element: string; attr: string }
263
-
(** Element "X" is missing required attribute "Y". (SVG) *)
145
+
type misc_error = [
146
+
| `Option_empty_without_label
147
+
| `Bdo_missing_dir
148
+
| `Bdo_dir_auto
149
+
| `Base_missing_href_or_target
150
+
| `Base_after_link_script
151
+
| `Map_id_name_mismatch
152
+
| `Summary_missing_role
153
+
| `Summary_missing_attrs
154
+
| `Summary_role_not_allowed
155
+
| `Autocomplete_webauthn_on_select
156
+
| `Commandfor_invalid_target
157
+
| `Style_type_invalid
158
+
| `Headingoffset_invalid
159
+
| `Media_empty
160
+
| `Media_all
161
+
| `Multiple_h1
162
+
| `Multiple_autofocus
163
+
]
264
164
265
-
(* ===== Generic/Fallback ===== *)
266
-
| Generic of { message: string }
267
-
(** For messages that don't fit any specific pattern *)
165
+
type t = [
166
+
| `Attr of attr_error
167
+
| `Element of element_error
168
+
| `Tag of tag_error
169
+
| `Char_ref of char_ref_error
170
+
| `Aria of aria_error
171
+
| `Li_role of li_role_error
172
+
| `Table of table_error
173
+
| `I18n of i18n_error
174
+
| `Importmap of importmap_error
175
+
| `Img of img_error
176
+
| `Link of link_error
177
+
| `Label of label_error
178
+
| `Input of input_error
179
+
| `Srcset of srcset_error
180
+
| `Svg of svg_error
181
+
| `Misc of misc_error
182
+
| `Generic of string
183
+
]
268
184
269
185
(** Get the severity level for an error code *)
270
-
let severity = function
271
-
| Missing_lang_attr -> Info
272
-
| Multiple_h1 -> Info
273
-
| Wrong_lang _ -> Warning
274
-
| Missing_dir_rtl _ -> Warning
275
-
| Wrong_dir _ -> Warning
276
-
| Unnecessary_role _ -> Warning
277
-
| Aria_should_not_be_used _ -> Warning
278
-
| Unknown_element _ -> Warning
279
-
| Not_nfc _ -> Warning
186
+
let severity : t -> severity = function
187
+
(* Info level *)
188
+
| `I18n `Missing_lang -> Info
189
+
| `Misc `Multiple_h1 -> Info
190
+
191
+
(* Warning level *)
192
+
| `I18n (`Wrong_lang _) -> Warning
193
+
| `I18n (`Missing_dir_rtl _) -> Warning
194
+
| `I18n (`Wrong_dir _) -> Warning
195
+
| `I18n (`Not_nfc _) -> Warning
196
+
| `Aria (`Unnecessary_role _) -> Warning
197
+
| `Aria (`Should_not_use _) -> Warning
198
+
| `Element (`Unknown _) -> Warning
199
+
200
+
(* Everything else is Error *)
280
201
| _ -> Error
281
202
282
203
(** Get a short code string for categorization *)
283
-
let code_string = function
284
-
| Attr_not_allowed_on_element _ -> "disallowed-attribute"
285
-
| Attr_not_allowed_here _ -> "disallowed-attribute"
286
-
| Attr_not_allowed_when _ -> "disallowed-attribute"
287
-
| Missing_required_attr _ -> "missing-required-attribute"
288
-
| Missing_required_attr_one_of _ -> "missing-required-attribute"
289
-
| Bad_attr_value _ -> "bad-attribute-value"
290
-
| Bad_attr_value_generic _ -> "bad-attribute-value"
291
-
| Duplicate_id _ -> "duplicate-id"
292
-
| Data_attr_invalid_name _ -> "bad-attribute-name"
293
-
| Data_attr_uppercase -> "bad-attribute-name"
294
-
| Obsolete_element _ -> "obsolete-element"
295
-
| Obsolete_attr _ -> "obsolete-attribute"
296
-
| Obsolete_global_attr _ -> "obsolete-attribute"
297
-
| Element_not_allowed_as_child _ -> "disallowed-child"
298
-
| Unknown_element _ -> "unknown-element"
299
-
| Element_must_not_be_descendant _ -> "prohibited-ancestor"
300
-
| Missing_required_child _ -> "missing-required-child"
301
-
| Missing_required_child_one_of _ -> "missing-required-child"
302
-
| Missing_required_child_generic _ -> "missing-required-child"
303
-
| Element_must_not_be_empty _ -> "empty-element"
304
-
| Stray_start_tag _ -> "stray-tag"
305
-
| Stray_end_tag _ -> "stray-tag"
306
-
| End_tag_for_void_element _ -> "end-tag-void"
307
-
| Self_closing_non_void -> "self-closing-non-void"
308
-
| Text_not_allowed _ -> "text-not-allowed"
309
-
| Div_child_of_dl_bad_role -> "invalid-role"
310
-
| Li_bad_role_in_menu -> "invalid-role"
311
-
| Li_bad_role_in_tablist -> "invalid-role"
312
-
| Li_bad_role_in_list -> "invalid-role"
313
-
| Unnecessary_role _ -> "unnecessary-role"
314
-
| Bad_role _ -> "bad-role"
315
-
| Aria_must_not_be_specified _ -> "aria-not-allowed"
316
-
| Aria_must_not_be_used _ -> "aria-not-allowed"
317
-
| Aria_should_not_be_used _ -> "aria-not-allowed"
318
-
| Aria_hidden_on_body -> "aria-not-allowed"
319
-
| Img_empty_alt_with_role -> "img-alt-role"
320
-
| Checkbox_button_needs_aria_pressed -> "missing-aria-pressed"
321
-
| Tab_without_tabpanel -> "tab-without-tabpanel"
322
-
| Multiple_main_visible -> "multiple-main"
323
-
| Discarding_unrecognized_role _ -> "unrecognized-role"
324
-
| Img_missing_alt -> "missing-alt"
325
-
| Img_missing_src_or_srcset -> "missing-src"
326
-
| Option_empty_without_label -> "empty-option"
327
-
| Bdo_missing_dir -> "missing-dir"
328
-
| Bdo_dir_auto -> "bdo-dir-auto"
329
-
| Base_missing_href_or_target -> "missing-required-attribute"
330
-
| Base_after_link_script -> "base-position"
331
-
| Link_missing_href -> "missing-href"
332
-
| Link_as_requires_preload -> "link-as-preload"
333
-
| Link_imagesrcset_requires_as_image -> "link-imagesrcset"
334
-
| Img_ismap_needs_a_href -> "ismap-needs-href"
335
-
| Sizes_without_srcset -> "sizes-without-srcset"
336
-
| Imagesizes_without_imagesrcset -> "imagesizes-without-srcset"
337
-
| Srcset_w_without_sizes -> "srcset-needs-sizes"
338
-
| Source_missing_srcset -> "missing-srcset"
339
-
| Source_needs_media_or_type -> "source-needs-media"
340
-
| Picture_missing_img -> "picture-missing-img"
341
-
| Map_id_name_mismatch -> "map-id-name"
342
-
| List_attr_requires_datalist -> "list-datalist"
343
-
| Input_list_not_allowed -> "list-not-allowed"
344
-
| Label_too_many_labelable -> "label-multiple"
345
-
| Label_for_id_mismatch -> "label-for-mismatch"
346
-
| Role_on_label_ancestor -> "role-on-label"
347
-
| Role_on_label_for -> "role-on-label"
348
-
| Aria_label_on_label_for -> "aria-label-on-label"
349
-
| Input_value_constraint _ -> "input-value"
350
-
| Summary_missing_role -> "summary-role"
351
-
| Summary_missing_attrs -> "summary-attrs"
352
-
| Summary_role_not_allowed -> "summary-role"
353
-
| Autocomplete_webauthn_on_select -> "autocomplete"
354
-
| Commandfor_invalid_target -> "commandfor"
355
-
| Forbidden_codepoint _ -> "forbidden-codepoint"
356
-
| Char_ref_control _ -> "char-ref-control"
357
-
| Char_ref_non_char _ -> "char-ref-non-char"
358
-
| Char_ref_unassigned -> "char-ref-unassigned"
359
-
| Char_ref_zero -> "char-ref-zero"
360
-
| Char_ref_out_of_range -> "char-ref-range"
361
-
| Numeric_char_ref_carriage_return -> "numeric-char-ref"
362
-
| End_of_file_with_open_elements -> "eof-open-elements"
363
-
| No_element_in_scope _ -> "no-element-in-scope"
364
-
| End_tag_implied_open_elements _ -> "end-tag-implied"
365
-
| Start_tag_in_table _ -> "start-tag-in-table"
366
-
| Bad_start_tag_in _ -> "bad-start-tag"
367
-
| Table_row_no_cells _ -> "table-row"
368
-
| Table_cell_overlap -> "table-overlap"
369
-
| Table_cell_spans_rowgroup -> "table-span"
370
-
| Table_column_no_cells _ -> "table-column"
371
-
| Missing_lang_attr -> "missing-lang"
372
-
| Wrong_lang _ -> "wrong-lang"
373
-
| Missing_dir_rtl _ -> "missing-dir"
374
-
| Wrong_dir _ -> "wrong-dir"
375
-
| Xml_lang_without_lang -> "xml-lang"
376
-
| Xml_lang_lang_mismatch -> "xml-lang-mismatch"
377
-
| Not_nfc _ -> "unicode-normalization"
378
-
| Multiple_h1 -> "multiple-h1"
379
-
| Multiple_autofocus -> "multiple-autofocus"
380
-
| Importmap_invalid_json -> "importmap"
381
-
| Importmap_invalid_root -> "importmap"
382
-
| Importmap_imports_not_object -> "importmap"
383
-
| Importmap_empty_key -> "importmap"
384
-
| Importmap_non_string_value -> "importmap"
385
-
| Importmap_key_trailing_slash -> "importmap"
386
-
| Importmap_scopes_not_object -> "importmap"
387
-
| Importmap_scopes_values_not_object -> "importmap"
388
-
| Importmap_scopes_invalid_url -> "importmap"
389
-
| Importmap_scopes_value_invalid_url -> "importmap"
390
-
| Style_type_invalid -> "style-type"
391
-
| Headingoffset_invalid -> "headingoffset"
392
-
| Media_empty -> "media-empty"
393
-
| Media_all -> "media-all"
394
-
| Svg_deprecated_attr _ -> "svg-deprecated"
395
-
| Missing_required_svg_attr _ -> "missing-required-attribute"
396
-
| Generic _ -> "generic"
204
+
let code_string : t -> string = function
205
+
(* Attribute errors *)
206
+
| `Attr (`Not_allowed _) -> "disallowed-attribute"
207
+
| `Attr (`Not_allowed_here _) -> "disallowed-attribute"
208
+
| `Attr (`Not_allowed_when _) -> "disallowed-attribute"
209
+
| `Attr (`Missing _) -> "missing-required-attribute"
210
+
| `Attr (`Missing_one_of _) -> "missing-required-attribute"
211
+
| `Attr (`Bad_value _) -> "bad-attribute-value"
212
+
| `Attr (`Bad_value_generic _) -> "bad-attribute-value"
213
+
| `Attr (`Duplicate_id _) -> "duplicate-id"
214
+
| `Attr (`Data_invalid_name _) -> "bad-attribute-name"
215
+
| `Attr `Data_uppercase -> "bad-attribute-name"
216
+
217
+
(* Element errors *)
218
+
| `Element (`Obsolete _) -> "obsolete-element"
219
+
| `Element (`Obsolete_attr _) -> "obsolete-attribute"
220
+
| `Element (`Obsolete_global_attr _) -> "obsolete-attribute"
221
+
| `Element (`Not_allowed_as_child _) -> "disallowed-child"
222
+
| `Element (`Unknown _) -> "unknown-element"
223
+
| `Element (`Must_not_descend _) -> "prohibited-ancestor"
224
+
| `Element (`Missing_child _) -> "missing-required-child"
225
+
| `Element (`Missing_child_one_of _) -> "missing-required-child"
226
+
| `Element (`Missing_child_generic _) -> "missing-required-child"
227
+
| `Element (`Must_not_be_empty _) -> "empty-element"
228
+
| `Element (`Text_not_allowed _) -> "text-not-allowed"
229
+
230
+
(* Tag errors *)
231
+
| `Tag (`Stray_start _) -> "stray-tag"
232
+
| `Tag (`Stray_end _) -> "stray-tag"
233
+
| `Tag (`End_for_void _) -> "end-tag-void"
234
+
| `Tag `Self_closing_non_void -> "self-closing-non-void"
235
+
| `Tag (`Not_in_scope _) -> "no-element-in-scope"
236
+
| `Tag (`End_implied_open _) -> "end-tag-implied"
237
+
| `Tag (`Start_in_table _) -> "start-tag-in-table"
238
+
| `Tag (`Bad_start_in _) -> "bad-start-tag"
239
+
| `Tag `Eof_with_open -> "eof-open-elements"
240
+
241
+
(* Character reference errors *)
242
+
| `Char_ref (`Forbidden_codepoint _) -> "forbidden-codepoint"
243
+
| `Char_ref (`Control_char _) -> "char-ref-control"
244
+
| `Char_ref (`Non_char _) -> "char-ref-non-char"
245
+
| `Char_ref `Unassigned -> "char-ref-unassigned"
246
+
| `Char_ref `Zero -> "char-ref-zero"
247
+
| `Char_ref `Out_of_range -> "char-ref-range"
248
+
| `Char_ref `Carriage_return -> "numeric-char-ref"
249
+
250
+
(* ARIA errors *)
251
+
| `Aria (`Unnecessary_role _) -> "unnecessary-role"
252
+
| `Aria (`Bad_role _) -> "bad-role"
253
+
| `Aria (`Must_not_specify _) -> "aria-not-allowed"
254
+
| `Aria (`Must_not_use _) -> "aria-not-allowed"
255
+
| `Aria (`Should_not_use _) -> "aria-not-allowed"
256
+
| `Aria `Hidden_on_body -> "aria-not-allowed"
257
+
| `Aria (`Unrecognized_role _) -> "unrecognized-role"
258
+
| `Aria `Tab_without_tabpanel -> "tab-without-tabpanel"
259
+
| `Aria `Multiple_main -> "multiple-main"
260
+
261
+
(* List item role errors *)
262
+
| `Li_role `Div_in_dl_bad_role -> "invalid-role"
263
+
| `Li_role `Li_bad_role_in_menu -> "invalid-role"
264
+
| `Li_role `Li_bad_role_in_tablist -> "invalid-role"
265
+
| `Li_role `Li_bad_role_in_list -> "invalid-role"
266
+
267
+
(* Table errors *)
268
+
| `Table (`Row_no_cells _) -> "table-row"
269
+
| `Table `Cell_overlap -> "table-overlap"
270
+
| `Table `Cell_spans_rowgroup -> "table-span"
271
+
| `Table (`Column_no_cells _) -> "table-column"
272
+
273
+
(* I18n errors *)
274
+
| `I18n `Missing_lang -> "missing-lang"
275
+
| `I18n (`Wrong_lang _) -> "wrong-lang"
276
+
| `I18n (`Missing_dir_rtl _) -> "missing-dir"
277
+
| `I18n (`Wrong_dir _) -> "wrong-dir"
278
+
| `I18n `Xml_lang_without_lang -> "xml-lang"
279
+
| `I18n `Xml_lang_mismatch -> "xml-lang-mismatch"
280
+
| `I18n (`Not_nfc _) -> "unicode-normalization"
281
+
282
+
(* Import map errors *)
283
+
| `Importmap `Invalid_json -> "importmap"
284
+
| `Importmap `Invalid_root -> "importmap"
285
+
| `Importmap `Imports_not_object -> "importmap"
286
+
| `Importmap `Empty_key -> "importmap"
287
+
| `Importmap `Non_string_value -> "importmap"
288
+
| `Importmap `Key_trailing_slash -> "importmap"
289
+
| `Importmap `Scopes_not_object -> "importmap"
290
+
| `Importmap `Scopes_values_not_object -> "importmap"
291
+
| `Importmap `Scopes_invalid_url -> "importmap"
292
+
| `Importmap `Scopes_value_invalid_url -> "importmap"
293
+
294
+
(* Image errors *)
295
+
| `Img `Missing_alt -> "missing-alt"
296
+
| `Img `Missing_src_or_srcset -> "missing-src"
297
+
| `Img `Empty_alt_with_role -> "img-alt-role"
298
+
| `Img `Ismap_needs_href -> "ismap-needs-href"
299
+
300
+
(* Link errors *)
301
+
| `Link `Missing_href -> "missing-href"
302
+
| `Link `As_requires_preload -> "link-as-preload"
303
+
| `Link `Imagesrcset_requires_as_image -> "link-imagesrcset"
304
+
305
+
(* Label errors *)
306
+
| `Label `Too_many_labelable -> "label-multiple"
307
+
| `Label `For_id_mismatch -> "label-for-mismatch"
308
+
| `Label `Role_on_ancestor -> "role-on-label"
309
+
| `Label `Role_on_for -> "role-on-label"
310
+
| `Label `Aria_label_on_for -> "aria-label-on-label"
311
+
312
+
(* Input errors *)
313
+
| `Input `Checkbox_needs_aria_pressed -> "missing-aria-pressed"
314
+
| `Input (`Value_constraint _) -> "input-value"
315
+
| `Input `List_not_allowed -> "list-not-allowed"
316
+
| `Input `List_requires_datalist -> "list-datalist"
317
+
318
+
(* Srcset errors *)
319
+
| `Srcset `Sizes_without_srcset -> "sizes-without-srcset"
320
+
| `Srcset `Imagesizes_without_imagesrcset -> "imagesizes-without-srcset"
321
+
| `Srcset `W_without_sizes -> "srcset-needs-sizes"
322
+
| `Srcset `Source_missing_srcset -> "missing-srcset"
323
+
| `Srcset `Source_needs_media_or_type -> "source-needs-media"
324
+
| `Srcset `Picture_missing_img -> "picture-missing-img"
325
+
326
+
(* SVG errors *)
327
+
| `Svg (`Deprecated_attr _) -> "svg-deprecated"
328
+
| `Svg (`Missing_attr _) -> "missing-required-attribute"
329
+
330
+
(* Misc errors *)
331
+
| `Misc `Option_empty_without_label -> "empty-option"
332
+
| `Misc `Bdo_missing_dir -> "missing-dir"
333
+
| `Misc `Bdo_dir_auto -> "bdo-dir-auto"
334
+
| `Misc `Base_missing_href_or_target -> "missing-required-attribute"
335
+
| `Misc `Base_after_link_script -> "base-position"
336
+
| `Misc `Map_id_name_mismatch -> "map-id-name"
337
+
| `Misc `Summary_missing_role -> "summary-role"
338
+
| `Misc `Summary_missing_attrs -> "summary-attrs"
339
+
| `Misc `Summary_role_not_allowed -> "summary-role"
340
+
| `Misc `Autocomplete_webauthn_on_select -> "autocomplete"
341
+
| `Misc `Commandfor_invalid_target -> "commandfor"
342
+
| `Misc `Style_type_invalid -> "style-type"
343
+
| `Misc `Headingoffset_invalid -> "headingoffset"
344
+
| `Misc `Media_empty -> "media-empty"
345
+
| `Misc `Media_all -> "media-all"
346
+
| `Misc `Multiple_h1 -> "multiple-h1"
347
+
| `Misc `Multiple_autofocus -> "multiple-autofocus"
348
+
349
+
(* Generic *)
350
+
| `Generic _ -> "generic"
397
351
398
352
(** Format using curly quotes (Unicode) *)
399
353
let q s = "\xe2\x80\x9c" ^ s ^ "\xe2\x80\x9d"
400
354
401
355
(** Convert error code to exact Nu validator message string *)
402
-
let to_message = function
403
-
| Attr_not_allowed_on_element { attr; element } ->
356
+
let to_message : t -> string = function
357
+
(* Attribute errors *)
358
+
| `Attr (`Not_allowed (`Attr attr, `Elem element)) ->
404
359
Printf.sprintf "Attribute %s not allowed on element %s at this point."
405
360
(q attr) (q element)
406
-
| Attr_not_allowed_here { attr } ->
361
+
| `Attr (`Not_allowed_here (`Attr attr)) ->
407
362
Printf.sprintf "Attribute %s not allowed here." (q attr)
408
-
| Attr_not_allowed_when { attr; element = _; condition } ->
363
+
| `Attr (`Not_allowed_when (`Attr attr, `Elem _, `Condition condition)) ->
409
364
Printf.sprintf "The %s attribute must not be used on any element which has %s." (q attr) condition
410
-
| Missing_required_attr { element; attr } ->
365
+
| `Attr (`Missing (`Elem element, `Attr attr)) ->
411
366
Printf.sprintf "Element %s is missing required attribute %s."
412
367
(q element) (q attr)
413
-
| Missing_required_attr_one_of { element; attrs } ->
368
+
| `Attr (`Missing_one_of (`Elem element, `Attrs attrs)) ->
414
369
let attrs_str = String.concat ", " attrs in
415
370
Printf.sprintf "Element %s is missing one or more of the following attributes: [%s]."
416
371
(q element) attrs_str
417
-
| Bad_attr_value { element; attr; value; reason } ->
372
+
| `Attr (`Bad_value (`Elem element, `Attr attr, `Value value, `Reason reason)) ->
418
373
Printf.sprintf "Bad value %s for attribute %s on element %s: %s"
419
374
(q value) (q attr) (q element) reason
420
-
| Bad_attr_value_generic { message } -> message
421
-
| Duplicate_id { id } ->
375
+
| `Attr (`Bad_value_generic (`Message message)) -> message
376
+
| `Attr (`Duplicate_id (`Id id)) ->
422
377
Printf.sprintf "Duplicate ID %s." (q id)
423
-
| Data_attr_invalid_name { reason } ->
378
+
| `Attr (`Data_invalid_name (`Reason reason)) ->
424
379
Printf.sprintf "%s attribute names %s." (q "data-*") reason
425
-
| Data_attr_uppercase ->
380
+
| `Attr `Data_uppercase ->
426
381
Printf.sprintf "%s attributes must not have characters from the range %s\xe2\x80\xa6%s in the name."
427
382
(q "data-*") (q "A") (q "Z")
428
383
429
-
| Obsolete_element { element; suggestion } ->
384
+
(* Element errors *)
385
+
| `Element (`Obsolete (`Elem element, `Suggestion suggestion)) ->
430
386
if suggestion = "" then
431
387
Printf.sprintf "The %s element is obsolete." (q element)
432
388
else
433
389
Printf.sprintf "The %s element is obsolete. %s" (q element) suggestion
434
-
| Obsolete_attr { element; attr; suggestion } ->
390
+
| `Element (`Obsolete_attr (`Elem element, `Attr attr, `Suggestion suggestion)) ->
435
391
let base = Printf.sprintf "The %s attribute on the %s element is obsolete."
436
392
(q attr) (q element) in
437
393
(match suggestion with Some s -> base ^ " " ^ s | None -> base)
438
-
| Obsolete_global_attr { attr; suggestion } ->
394
+
| `Element (`Obsolete_global_attr (`Attr attr, `Suggestion suggestion)) ->
439
395
Printf.sprintf "The %s attribute is obsolete. %s" (q attr) suggestion
440
-
| Element_not_allowed_as_child { child; parent } ->
396
+
| `Element (`Not_allowed_as_child (`Child child, `Parent parent)) ->
441
397
Printf.sprintf "Element %s not allowed as child of element %s in this context. (Suppressing further errors from this subtree.)"
442
398
(q child) (q parent)
443
-
| Unknown_element { name } ->
399
+
| `Element (`Unknown (`Elem name)) ->
444
400
Printf.sprintf "Unknown element %s." (q name)
445
-
| Element_must_not_be_descendant { element; attr; ancestor } ->
401
+
| `Element (`Must_not_descend (`Elem element, `Attr attr, `Ancestor ancestor)) ->
446
402
(match attr with
447
403
| Some a ->
448
404
Printf.sprintf "The element %s with the attribute %s must not appear as a descendant of the %s element."
···
450
406
| None ->
451
407
Printf.sprintf "The element %s must not appear as a descendant of the %s element."
452
408
(q element) (q ancestor))
453
-
| Missing_required_child { parent; child } ->
409
+
| `Element (`Missing_child (`Parent parent, `Child child)) ->
454
410
Printf.sprintf "Element %s is missing required child element %s."
455
411
(q parent) (q child)
456
-
| Missing_required_child_one_of { parent; children } ->
412
+
| `Element (`Missing_child_one_of (`Parent parent, `Children children)) ->
457
413
let children_str = String.concat ", " children in
458
414
Printf.sprintf "Element %s is missing one or more of the following child elements: [%s]."
459
415
(q parent) children_str
460
-
| Missing_required_child_generic { parent } ->
416
+
| `Element (`Missing_child_generic (`Parent parent)) ->
461
417
Printf.sprintf "Element %s is missing a required child element." (q parent)
462
-
| Element_must_not_be_empty { element } ->
418
+
| `Element (`Must_not_be_empty (`Elem element)) ->
463
419
Printf.sprintf "Element %s must not be empty." (q element)
464
-
| Stray_start_tag { tag } ->
420
+
| `Element (`Text_not_allowed (`Parent parent)) ->
421
+
Printf.sprintf "Text not allowed in element %s in this context." (q parent)
422
+
423
+
(* Tag errors *)
424
+
| `Tag (`Stray_start (`Tag tag)) ->
465
425
Printf.sprintf "Stray start tag %s." (q tag)
466
-
| Stray_end_tag { tag } ->
426
+
| `Tag (`Stray_end (`Tag tag)) ->
467
427
Printf.sprintf "Stray end tag %s." (q tag)
468
-
| End_tag_for_void_element { tag } ->
428
+
| `Tag (`End_for_void (`Tag tag)) ->
469
429
Printf.sprintf "End tag %s." (q tag)
470
-
| Self_closing_non_void ->
430
+
| `Tag `Self_closing_non_void ->
471
431
Printf.sprintf "Self-closing syntax (%s) used on a non-void HTML element. Ignoring the slash and treating as a start tag."
472
432
(q "/>")
473
-
| Text_not_allowed { parent } ->
474
-
Printf.sprintf "Text not allowed in element %s in this context." (q parent)
433
+
| `Tag (`Not_in_scope (`Tag tag)) ->
434
+
Printf.sprintf "No %s element in scope but a %s end tag seen."
435
+
(q tag) (q tag)
436
+
| `Tag (`End_implied_open (`Tag tag)) ->
437
+
Printf.sprintf "End tag %s implied, but there were open elements."
438
+
(q tag)
439
+
| `Tag (`Start_in_table (`Tag tag)) ->
440
+
Printf.sprintf "Start tag %s seen in %s." (q tag) (q "table")
441
+
| `Tag (`Bad_start_in (`Tag tag, `Context _)) ->
442
+
Printf.sprintf "Bad start tag in %s in %s in %s."
443
+
(q tag) (q "noscript") (q "head")
444
+
| `Tag `Eof_with_open ->
445
+
"End of file seen and there were open elements."
475
446
476
-
| Div_child_of_dl_bad_role ->
477
-
Printf.sprintf "A %s child of a %s element must not have any %s value other than %s or %s."
478
-
(q "div") (q "dl") (q "role") (q "presentation") (q "none")
479
-
| Li_bad_role_in_menu ->
480
-
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."
481
-
(q "li") (q "role=menu") (q "role=menubar") (q "role")
482
-
(q "group") (q "menuitem") (q "menuitemcheckbox") (q "menuitemradio") (q "separator")
483
-
| Li_bad_role_in_tablist ->
484
-
Printf.sprintf "An %s element that is a descendant of a %s element must not have any %s value other than %s."
485
-
(q "li") (q "role=tablist") (q "role") (q "tab")
486
-
| Li_bad_role_in_list ->
487
-
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."
488
-
(q "li") (q "ul") (q "ol") (q "menu") (q "role") (q "role=list") (q "role") (q "listitem")
447
+
(* Character reference errors *)
448
+
| `Char_ref (`Forbidden_codepoint (`Codepoint codepoint)) ->
449
+
Printf.sprintf "Forbidden code point U+%04x." codepoint
450
+
| `Char_ref (`Control_char (`Codepoint codepoint)) ->
451
+
Printf.sprintf "Character reference expands to a control character (U+%04x)." codepoint
452
+
| `Char_ref (`Non_char (`Codepoint codepoint, `Astral astral)) ->
453
+
if astral then
454
+
Printf.sprintf "Character reference expands to an astral non-character (U+%05x)." codepoint
455
+
else
456
+
Printf.sprintf "Character reference expands to a non-character (U+%04x)." codepoint
457
+
| `Char_ref `Unassigned ->
458
+
"Character reference expands to a permanently unassigned code point."
459
+
| `Char_ref `Zero ->
460
+
"Character reference expands to zero."
461
+
| `Char_ref `Out_of_range ->
462
+
"Character reference outside the permissible Unicode range."
463
+
| `Char_ref `Carriage_return ->
464
+
"A numeric character reference expanded to carriage return."
489
465
490
-
| Unnecessary_role { role; element = _; reason } ->
466
+
(* ARIA errors *)
467
+
| `Aria (`Unnecessary_role (`Role role, `Elem _, `Reason reason)) ->
491
468
Printf.sprintf "The %s role is unnecessary %s."
492
469
(q role) reason
493
-
| Bad_role { element; role } ->
470
+
| `Aria (`Bad_role (`Elem element, `Role role)) ->
494
471
Printf.sprintf "Bad value %s for attribute %s on element %s."
495
472
(q role) (q "role") (q element)
496
-
| Aria_must_not_be_specified { attr; element; condition } ->
473
+
| `Aria (`Must_not_specify (`Attr attr, `Elem element, `Condition condition)) ->
497
474
Printf.sprintf "The %s attribute must not be specified on any %s element unless %s."
498
475
(q attr) (q element) condition
499
-
| Aria_must_not_be_used { attr; element; condition } ->
476
+
| `Aria (`Must_not_use (`Attr attr, `Elem element, `Condition condition)) ->
500
477
Printf.sprintf "The %s attribute must not be used on an %s element which has %s."
501
478
(q attr) (q element) condition
502
-
| Aria_should_not_be_used { attr; role } ->
479
+
| `Aria (`Should_not_use (`Attr attr, `Role role)) ->
503
480
Printf.sprintf "The %s attribute should not be used on any element which has %s."
504
481
(q attr) (q ("role=" ^ role))
505
-
| Aria_hidden_on_body ->
482
+
| `Aria `Hidden_on_body ->
506
483
Printf.sprintf "%s must not be used on the %s element."
507
484
(q "aria-hidden=true") (q "body")
508
-
| Img_empty_alt_with_role ->
509
-
Printf.sprintf "An %s element which has an %s attribute whose value is the empty string must not have a %s attribute."
510
-
(q "img") (q "alt") (q "role")
511
-
| Checkbox_button_needs_aria_pressed ->
512
-
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."
513
-
(q "input") (q "type") (q "checkbox") (q "role") (q "button") (q "aria-pressed")
514
-
| Tab_without_tabpanel ->
485
+
| `Aria (`Unrecognized_role (`Token token)) ->
486
+
Printf.sprintf "Discarding unrecognized token %s from value of attribute %s. Browsers ignore any token that is not a defined ARIA non-abstract role."
487
+
(q token) (q "role")
488
+
| `Aria `Tab_without_tabpanel ->
515
489
Printf.sprintf "Every active %s element must have a corresponding %s element."
516
490
(q "role=tab") (q "role=tabpanel")
517
-
| Multiple_main_visible ->
491
+
| `Aria `Multiple_main ->
518
492
Printf.sprintf "A document should not include more than one visible element with %s."
519
493
(q "role=main")
520
-
| Discarding_unrecognized_role { token } ->
521
-
Printf.sprintf "Discarding unrecognized token %s from value of attribute %s. Browsers ignore any token that is not a defined ARIA non-abstract role."
522
-
(q token) (q "role")
523
494
524
-
| Img_missing_alt ->
525
-
Printf.sprintf "An %s element must have an %s attribute, except under certain conditions. For details, consult guidance on providing text alternatives for images."
526
-
(q "img") (q "alt")
527
-
| Img_missing_src_or_srcset ->
528
-
Printf.sprintf "Element %s is missing one or more of the following attributes: [src, srcset]."
529
-
(q "img")
530
-
| Option_empty_without_label ->
531
-
Printf.sprintf "Element %s without attribute %s must not be empty."
532
-
(q "option") (q "label")
533
-
| Bdo_missing_dir ->
534
-
Printf.sprintf "Element %s must have attribute %s." (q "bdo") (q "dir")
535
-
| Bdo_dir_auto ->
536
-
Printf.sprintf "The value of %s attribute for the %s element must not be %s."
537
-
(q "dir") (q "bdo") (q "auto")
538
-
| Base_missing_href_or_target ->
539
-
Printf.sprintf "Element %s is missing one or more of the following attributes: [href, target]."
540
-
(q "base")
541
-
| Base_after_link_script ->
542
-
Printf.sprintf "The %s element must come before any %s or %s elements in the document."
543
-
(q "base") (q "link") (q "script")
544
-
| Link_missing_href ->
545
-
Printf.sprintf "A %s element must have an %s or %s attribute, or both."
546
-
(q "link") (q "href") (q "imagesrcset")
547
-
| Link_as_requires_preload ->
548
-
Printf.sprintf "A %s element with an %s attribute must have a %s attribute that contains the value %s or the value %s."
549
-
(q "link") (q "as") (q "rel") (q "preload") (q "modulepreload")
550
-
| Link_imagesrcset_requires_as_image ->
551
-
Printf.sprintf "A %s element with an %s attribute must have an %s attribute with value %s."
552
-
(q "link") (q "imagesrcset") (q "as") (q "image")
553
-
| Img_ismap_needs_a_href ->
554
-
Printf.sprintf "The %s element with the %s attribute set must have an %s ancestor with the %s attribute."
555
-
(q "img") (q "ismap") (q "a") (q "href")
556
-
| Sizes_without_srcset ->
557
-
Printf.sprintf "The %s attribute must only be specified if the %s attribute is also specified."
558
-
(q "sizes") (q "srcset")
559
-
| Imagesizes_without_imagesrcset ->
560
-
Printf.sprintf "The %s attribute must only be specified if the %s attribute is also specified."
561
-
(q "imagesizes") (q "imagesrcset")
562
-
| Srcset_w_without_sizes ->
563
-
Printf.sprintf "When the %s attribute has any image candidate string with a width descriptor, the %s attribute must also be specified."
564
-
(q "srcset") (q "sizes")
565
-
| Source_missing_srcset ->
566
-
Printf.sprintf "Element %s is missing required attribute %s."
567
-
(q "source") (q "srcset")
568
-
| Source_needs_media_or_type ->
569
-
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."
570
-
(q "source") (q "source") (q "img") (q "srcset") (q "media") (q "type")
571
-
| Picture_missing_img ->
572
-
Printf.sprintf "Element %s is missing required child element %s."
573
-
(q "picture") (q "img")
574
-
| Map_id_name_mismatch ->
575
-
Printf.sprintf "The %s attribute on a %s element must have an the same value as the %s attribute."
576
-
(q "id") (q "map") (q "name")
577
-
| List_attr_requires_datalist ->
578
-
Printf.sprintf "The %s attribute of the %s element must refer to a %s element."
579
-
(q "list") (q "input") (q "datalist")
580
-
| Input_list_not_allowed ->
581
-
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."
582
-
(q "list") (q "color") (q "date") (q "datetime-local") (q "email") (q "month")
583
-
(q "number") (q "range") (q "search") (q "tel") (q "text") (q "time") (q "url") (q "week")
584
-
| Label_too_many_labelable ->
585
-
Printf.sprintf "The %s element may contain at most one %s, %s, %s, %s, %s, %s, or %s descendant."
586
-
(q "label") (q "button") (q "input") (q "meter") (q "output") (q "progress") (q "select") (q "textarea")
587
-
| Label_for_id_mismatch ->
588
-
Printf.sprintf "Any %s descendant of a %s element with a %s attribute must have an ID value that matches that %s attribute."
589
-
(q "input") (q "label") (q "for") (q "for")
590
-
| Role_on_label_ancestor ->
591
-
Printf.sprintf "The %s attribute must not be used on any %s element that is an ancestor of a labelable element."
592
-
(q "role") (q "label")
593
-
| Role_on_label_for ->
594
-
Printf.sprintf "The %s attribute must not be used on any %s element that is associated with a labelable element."
595
-
(q "role") (q "label")
596
-
| Aria_label_on_label_for ->
597
-
Printf.sprintf "The %s attribute must not be used on any %s element that is associated with a labelable element."
598
-
(q "aria-label") (q "label")
599
-
| Input_value_constraint { constraint_type } -> constraint_type
600
-
| Summary_missing_role ->
601
-
Printf.sprintf "Element %s is missing required attribute %s."
602
-
(q "summary") (q "role")
603
-
| Summary_missing_attrs ->
604
-
Printf.sprintf "Element %s is missing one or more of the following attributes: [aria-checked, aria-level, role]."
605
-
(q "summary")
606
-
| Summary_role_not_allowed ->
607
-
Printf.sprintf "The %s attribute must not be used on any %s element that is a summary for its parent %s element."
608
-
(q "role") (q "summary") (q "details")
609
-
| Autocomplete_webauthn_on_select ->
610
-
Printf.sprintf "The value of the %s attribute for the %s element must not contain %s."
611
-
(q "autocomplete") (q "select") (q "webauthn")
612
-
| Commandfor_invalid_target ->
613
-
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."
614
-
(q "commandfor") (q "button") (q "button") (q "commandfor")
495
+
(* List item role errors *)
496
+
| `Li_role `Div_in_dl_bad_role ->
497
+
Printf.sprintf "A %s child of a %s element must not have any %s value other than %s or %s."
498
+
(q "div") (q "dl") (q "role") (q "presentation") (q "none")
499
+
| `Li_role `Li_bad_role_in_menu ->
500
+
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."
501
+
(q "li") (q "role=menu") (q "role=menubar") (q "role")
502
+
(q "group") (q "menuitem") (q "menuitemcheckbox") (q "menuitemradio") (q "separator")
503
+
| `Li_role `Li_bad_role_in_tablist ->
504
+
Printf.sprintf "An %s element that is a descendant of a %s element must not have any %s value other than %s."
505
+
(q "li") (q "role=tablist") (q "role") (q "tab")
506
+
| `Li_role `Li_bad_role_in_list ->
507
+
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."
508
+
(q "li") (q "ul") (q "ol") (q "menu") (q "role") (q "role=list") (q "role") (q "listitem")
615
509
616
-
| Forbidden_codepoint { codepoint } ->
617
-
Printf.sprintf "Forbidden code point U+%04x." codepoint
618
-
| Char_ref_control { codepoint } ->
619
-
Printf.sprintf "Character reference expands to a control character (U+%04x)." codepoint
620
-
| Char_ref_non_char { codepoint; astral } ->
621
-
if astral then
622
-
Printf.sprintf "Character reference expands to an astral non-character (U+%05x)." codepoint
623
-
else
624
-
Printf.sprintf "Character reference expands to a non-character (U+%04x)." codepoint
625
-
| Char_ref_unassigned ->
626
-
"Character reference expands to a permanently unassigned code point."
627
-
| Char_ref_zero ->
628
-
"Character reference expands to zero."
629
-
| Char_ref_out_of_range ->
630
-
"Character reference outside the permissible Unicode range."
631
-
| Numeric_char_ref_carriage_return ->
632
-
"A numeric character reference expanded to carriage return."
633
-
| End_of_file_with_open_elements ->
634
-
"End of file seen and there were open elements."
635
-
| No_element_in_scope { tag } ->
636
-
Printf.sprintf "No %s element in scope but a %s end tag seen."
637
-
(q tag) (q tag)
638
-
| End_tag_implied_open_elements { tag } ->
639
-
Printf.sprintf "End tag %s implied, but there were open elements."
640
-
(q tag)
641
-
| Start_tag_in_table { tag } ->
642
-
Printf.sprintf "Start tag %s seen in %s." (q tag) (q "table")
643
-
| Bad_start_tag_in { tag; context = _ } ->
644
-
Printf.sprintf "Bad start tag in %s in %s in %s."
645
-
(q tag) (q "noscript") (q "head")
646
-
647
-
| Table_row_no_cells { row } ->
510
+
(* Table errors *)
511
+
| `Table (`Row_no_cells (`Row row)) ->
648
512
Printf.sprintf "Row %d of an implicit row group has no cells beginning on it." row
649
-
| Table_cell_overlap ->
513
+
| `Table `Cell_overlap ->
650
514
"Table cell is overlapped by later table cell."
651
-
| Table_cell_spans_rowgroup ->
515
+
| `Table `Cell_spans_rowgroup ->
652
516
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."
653
517
(q "tbody")
654
-
| Table_column_no_cells { column; element } ->
518
+
| `Table (`Column_no_cells (`Column column, `Elem element)) ->
655
519
Printf.sprintf "Table column %d established by element %s has no cells beginning in it."
656
520
column (q element)
657
521
658
-
| Missing_lang_attr ->
522
+
(* I18n errors *)
523
+
| `I18n `Missing_lang ->
659
524
Printf.sprintf "Consider adding a %s attribute to the %s start tag to declare the language of this document."
660
525
(q "lang") (q "html")
661
-
| Wrong_lang { detected; declared; suggested } ->
526
+
| `I18n (`Wrong_lang (`Detected detected, `Declared declared, `Suggested suggested)) ->
662
527
Printf.sprintf "This document appears to be written in %s but the %s start tag has %s. Consider using %s (or variant) instead."
663
528
detected (q "html") (q ("lang=\"" ^ declared ^ "\"")) (q ("lang=\"" ^ suggested ^ "\""))
664
-
| Missing_dir_rtl { language } ->
529
+
| `I18n (`Missing_dir_rtl (`Language language)) ->
665
530
Printf.sprintf "This document appears to be written in %s. Consider adding %s to the %s start tag."
666
531
language (q "dir=\"rtl\"") (q "html")
667
-
| Wrong_dir { language; declared } ->
532
+
| `I18n (`Wrong_dir (`Language language, `Declared declared)) ->
668
533
Printf.sprintf "This document appears to be written in %s but the %s start tag has %s. Consider using %s instead."
669
534
language (q "html") (q ("dir=\"" ^ declared ^ "\"")) (q "dir=\"rtl\"")
670
-
| Xml_lang_without_lang ->
535
+
| `I18n `Xml_lang_without_lang ->
671
536
Printf.sprintf "When the attribute %s in no namespace is specified, the element must also have the attribute %s present with the same value."
672
537
(q "xml:lang") (q "lang")
673
-
| Xml_lang_lang_mismatch ->
538
+
| `I18n `Xml_lang_mismatch ->
674
539
Printf.sprintf "The %s and %s attributes must have the same value."
675
540
(q "xml:lang") (q "lang")
676
-
677
-
| Not_nfc { replacement } ->
541
+
| `I18n (`Not_nfc (`Replacement replacement)) ->
678
542
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.)"
679
543
(q replacement)
680
544
681
-
| Multiple_h1 ->
682
-
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)."
683
-
(q "h1") (q "h1") (q "headingoffset") (q "h1")
684
-
| Multiple_autofocus ->
685
-
Printf.sprintf "There must not be two elements with the same %s that both have the %s attribute specified."
686
-
(q "nearest ancestor autofocus scoping root element") (q "autofocus")
687
-
688
-
| Importmap_invalid_json ->
545
+
(* Import map errors *)
546
+
| `Importmap `Invalid_json ->
689
547
Printf.sprintf "A script %s with a %s attribute whose value is %s must have valid JSON content."
690
548
(q "script") (q "type") (q "importmap")
691
-
| Importmap_invalid_root ->
549
+
| `Importmap `Invalid_root ->
692
550
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."
693
551
(q "script") (q "type") (q "importmap") (q "imports") (q "scopes") (q "integrity")
694
-
| Importmap_imports_not_object ->
552
+
| `Importmap `Imports_not_object ->
695
553
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."
696
554
(q "imports") (q "script") (q "type") (q "importmap")
697
-
| Importmap_empty_key ->
555
+
| `Importmap `Empty_key ->
698
556
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."
699
557
(q "imports") (q "script") (q "type") (q "importmap")
700
-
| Importmap_non_string_value ->
558
+
| `Importmap `Non_string_value ->
701
559
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."
702
560
(q "imports") (q "script") (q "type") (q "importmap")
703
-
| Importmap_key_trailing_slash ->
561
+
| `Importmap `Key_trailing_slash ->
704
562
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."
705
563
(q "imports") (q "script") (q "type") (q "importmap") (q "/") (q "/")
706
-
| Importmap_scopes_not_object ->
564
+
| `Importmap `Scopes_not_object ->
707
565
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."
708
566
(q "scopes") (q "script") (q "type") (q "importmap")
709
-
| Importmap_scopes_values_not_object ->
567
+
| `Importmap `Scopes_values_not_object ->
710
568
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."
711
569
(q "scopes") (q "script") (q "type") (q "importmap")
712
-
| Importmap_scopes_invalid_url ->
570
+
| `Importmap `Scopes_invalid_url ->
713
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 whose keys are valid URL strings."
714
572
(q "scopes") (q "script") (q "type") (q "importmap")
715
-
| Importmap_scopes_value_invalid_url ->
573
+
| `Importmap `Scopes_value_invalid_url ->
716
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 valid URL values."
717
575
(q "scopes") (q "script") (q "type") (q "importmap")
718
576
719
-
| Style_type_invalid ->
720
-
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.)"
721
-
(q "type") (q "style") (q "text/css")
577
+
(* Image errors *)
578
+
| `Img `Missing_alt ->
579
+
Printf.sprintf "An %s element must have an %s attribute, except under certain conditions. For details, consult guidance on providing text alternatives for images."
580
+
(q "img") (q "alt")
581
+
| `Img `Missing_src_or_srcset ->
582
+
Printf.sprintf "Element %s is missing one or more of the following attributes: [src, srcset]."
583
+
(q "img")
584
+
| `Img `Empty_alt_with_role ->
585
+
Printf.sprintf "An %s element which has an %s attribute whose value is the empty string must not have a %s attribute."
586
+
(q "img") (q "alt") (q "role")
587
+
| `Img `Ismap_needs_href ->
588
+
Printf.sprintf "The %s element with the %s attribute set must have an %s ancestor with the %s attribute."
589
+
(q "img") (q "ismap") (q "a") (q "href")
590
+
591
+
(* Link errors *)
592
+
| `Link `Missing_href ->
593
+
Printf.sprintf "A %s element must have an %s or %s attribute, or both."
594
+
(q "link") (q "href") (q "imagesrcset")
595
+
| `Link `As_requires_preload ->
596
+
Printf.sprintf "A %s element with an %s attribute must have a %s attribute that contains the value %s or the value %s."
597
+
(q "link") (q "as") (q "rel") (q "preload") (q "modulepreload")
598
+
| `Link `Imagesrcset_requires_as_image ->
599
+
Printf.sprintf "A %s element with an %s attribute must have an %s attribute with value %s."
600
+
(q "link") (q "imagesrcset") (q "as") (q "image")
601
+
602
+
(* Label errors *)
603
+
| `Label `Too_many_labelable ->
604
+
Printf.sprintf "The %s element may contain at most one %s, %s, %s, %s, %s, %s, or %s descendant."
605
+
(q "label") (q "button") (q "input") (q "meter") (q "output") (q "progress") (q "select") (q "textarea")
606
+
| `Label `For_id_mismatch ->
607
+
Printf.sprintf "Any %s descendant of a %s element with a %s attribute must have an ID value that matches that %s attribute."
608
+
(q "input") (q "label") (q "for") (q "for")
609
+
| `Label `Role_on_ancestor ->
610
+
Printf.sprintf "The %s attribute must not be used on any %s element that is an ancestor of a labelable element."
611
+
(q "role") (q "label")
612
+
| `Label `Role_on_for ->
613
+
Printf.sprintf "The %s attribute must not be used on any %s element that is associated with a labelable element."
614
+
(q "role") (q "label")
615
+
| `Label `Aria_label_on_for ->
616
+
Printf.sprintf "The %s attribute must not be used on any %s element that is associated with a labelable element."
617
+
(q "aria-label") (q "label")
722
618
723
-
| Headingoffset_invalid ->
724
-
Printf.sprintf "The value of the %s attribute must be a number between %s and %s."
725
-
(q "headingoffset") (q "0") (q "8")
619
+
(* Input errors *)
620
+
| `Input `Checkbox_needs_aria_pressed ->
621
+
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."
622
+
(q "input") (q "type") (q "checkbox") (q "role") (q "button") (q "aria-pressed")
623
+
| `Input (`Value_constraint (`Constraint constraint_type)) -> constraint_type
624
+
| `Input `List_not_allowed ->
625
+
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."
626
+
(q "list") (q "color") (q "date") (q "datetime-local") (q "email") (q "month")
627
+
(q "number") (q "range") (q "search") (q "tel") (q "text") (q "time") (q "url") (q "week")
628
+
| `Input `List_requires_datalist ->
629
+
Printf.sprintf "The %s attribute of the %s element must refer to a %s element."
630
+
(q "list") (q "input") (q "datalist")
726
631
727
-
| Media_empty ->
728
-
Printf.sprintf "Value of %s attribute here must not be empty." (q "media")
729
-
| Media_all ->
730
-
Printf.sprintf "Value of %s attribute here must not be %s." (q "media") (q "all")
632
+
(* Srcset errors *)
633
+
| `Srcset `Sizes_without_srcset ->
634
+
Printf.sprintf "The %s attribute must only be specified if the %s attribute is also specified."
635
+
(q "sizes") (q "srcset")
636
+
| `Srcset `Imagesizes_without_imagesrcset ->
637
+
Printf.sprintf "The %s attribute must only be specified if the %s attribute is also specified."
638
+
(q "imagesizes") (q "imagesrcset")
639
+
| `Srcset `W_without_sizes ->
640
+
Printf.sprintf "When the %s attribute has any image candidate string with a width descriptor, the %s attribute must also be specified."
641
+
(q "srcset") (q "sizes")
642
+
| `Srcset `Source_missing_srcset ->
643
+
Printf.sprintf "Element %s is missing required attribute %s."
644
+
(q "source") (q "srcset")
645
+
| `Srcset `Source_needs_media_or_type ->
646
+
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."
647
+
(q "source") (q "source") (q "img") (q "srcset") (q "media") (q "type")
648
+
| `Srcset `Picture_missing_img ->
649
+
Printf.sprintf "Element %s is missing required child element %s."
650
+
(q "picture") (q "img")
731
651
732
-
| Svg_deprecated_attr { attr; element } ->
652
+
(* SVG errors *)
653
+
| `Svg (`Deprecated_attr (`Attr attr, `Elem element)) ->
733
654
Printf.sprintf "Attribute %s not allowed on element %s at this point."
734
655
(q attr) (q element)
735
-
| Missing_required_svg_attr { element; attr } ->
656
+
| `Svg (`Missing_attr (`Elem element, `Attr attr)) ->
736
657
Printf.sprintf "Element %s is missing required attribute %s."
737
658
(q element) (q attr)
738
659
739
-
| Generic { message } -> message
660
+
(* Misc errors *)
661
+
| `Misc `Option_empty_without_label ->
662
+
Printf.sprintf "Element %s without attribute %s must not be empty."
663
+
(q "option") (q "label")
664
+
| `Misc `Bdo_missing_dir ->
665
+
Printf.sprintf "Element %s must have attribute %s." (q "bdo") (q "dir")
666
+
| `Misc `Bdo_dir_auto ->
667
+
Printf.sprintf "The value of %s attribute for the %s element must not be %s."
668
+
(q "dir") (q "bdo") (q "auto")
669
+
| `Misc `Base_missing_href_or_target ->
670
+
Printf.sprintf "Element %s is missing one or more of the following attributes: [href, target]."
671
+
(q "base")
672
+
| `Misc `Base_after_link_script ->
673
+
Printf.sprintf "The %s element must come before any %s or %s elements in the document."
674
+
(q "base") (q "link") (q "script")
675
+
| `Misc `Map_id_name_mismatch ->
676
+
Printf.sprintf "The %s attribute on a %s element must have an the same value as the %s attribute."
677
+
(q "id") (q "map") (q "name")
678
+
| `Misc `Summary_missing_role ->
679
+
Printf.sprintf "Element %s is missing required attribute %s."
680
+
(q "summary") (q "role")
681
+
| `Misc `Summary_missing_attrs ->
682
+
Printf.sprintf "Element %s is missing one or more of the following attributes: [aria-checked, aria-level, role]."
683
+
(q "summary")
684
+
| `Misc `Summary_role_not_allowed ->
685
+
Printf.sprintf "The %s attribute must not be used on any %s element that is a summary for its parent %s element."
686
+
(q "role") (q "summary") (q "details")
687
+
| `Misc `Autocomplete_webauthn_on_select ->
688
+
Printf.sprintf "The value of the %s attribute for the %s element must not contain %s."
689
+
(q "autocomplete") (q "select") (q "webauthn")
690
+
| `Misc `Commandfor_invalid_target ->
691
+
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."
692
+
(q "commandfor") (q "button") (q "button") (q "commandfor")
693
+
| `Misc `Style_type_invalid ->
694
+
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.)"
695
+
(q "type") (q "style") (q "text/css")
696
+
| `Misc `Headingoffset_invalid ->
697
+
Printf.sprintf "The value of the %s attribute must be a number between %s and %s."
698
+
(q "headingoffset") (q "0") (q "8")
699
+
| `Misc `Media_empty ->
700
+
Printf.sprintf "Value of %s attribute here must not be empty." (q "media")
701
+
| `Misc `Media_all ->
702
+
Printf.sprintf "Value of %s attribute here must not be %s." (q "media") (q "all")
703
+
| `Misc `Multiple_h1 ->
704
+
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)."
705
+
(q "h1") (q "h1") (q "headingoffset") (q "h1")
706
+
| `Misc `Multiple_autofocus ->
707
+
Printf.sprintf "There must not be two elements with the same %s that both have the %s attribute specified."
708
+
(q "nearest ancestor autofocus scoping root element") (q "autofocus")
709
+
710
+
(* Generic *)
711
+
| `Generic message -> message
+711
-138
lib/html5_checker/error_code.mli
+711
-138
lib/html5_checker/error_code.mli
···
1
1
(** Typed error codes for HTML5 validation messages.
2
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. *)
3
+
This module defines a comprehensive hierarchy of validation errors using
4
+
polymorphic variants, organized by error category. Each error type is
5
+
documented with the specific HTML5 conformance requirement it represents.
6
+
7
+
The error hierarchy is:
8
+
- {!t} is the top-level type containing all errors wrapped by category
9
+
- Each category (e.g., {!attr_error}, {!aria_error}) groups related errors
10
+
- Inline descriptors like [[\`Attr of string]] provide self-documenting parameters
11
+
12
+
{2 Example Usage}
13
+
14
+
{[
15
+
(* Category-level matching *)
16
+
let is_accessibility_error = function
17
+
| `Aria _ | `Li_role _ -> true
18
+
| _ -> false
19
+
20
+
(* Fine-grained matching *)
21
+
match err with
22
+
| `Attr (`Duplicate_id (`Id id)) -> handle_duplicate id
23
+
| `Img `Missing_alt -> suggest_alt_text ()
24
+
| _ -> default_handler err
25
+
]}
26
+
*)
5
27
6
-
(** Severity level of a validation message *)
28
+
(** {1 Severity} *)
29
+
30
+
(** Severity level of a validation message.
31
+
- [Error]: Conformance error that must be fixed
32
+
- [Warning]: Likely problem that should be reviewed
33
+
- [Info]: Suggestion for best practices *)
7
34
type severity = Error | Warning | Info
8
35
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
36
+
(** {1 Attribute Errors}
37
+
38
+
Errors related to HTML attributes: disallowed attributes, missing required
39
+
attributes, invalid attribute values, and duplicate IDs. *)
40
+
41
+
(** Attribute-related validation errors.
42
+
43
+
These errors occur when attributes violate HTML5 content model rules:
44
+
- Attributes used on elements where they're not allowed
45
+
- Required attributes that are missing
46
+
- Attribute values that don't match expected formats
47
+
- Duplicate ID attributes within a document *)
48
+
type attr_error = [
49
+
| `Not_allowed of [`Attr of string] * [`Elem of string]
50
+
(** Attribute is not in the set of allowed attributes for this element.
51
+
Per HTML5 spec, each element has a defined set of content attributes;
52
+
using attributes outside this set is a conformance error.
53
+
Example: [type] attribute on a [<div>] element. *)
54
+
55
+
| `Not_allowed_here of [`Attr of string]
56
+
(** Attribute is valid on this element type but not in this context.
57
+
Some attributes are only allowed under specific conditions, such as
58
+
the [download] attribute which requires specific ancestor elements. *)
59
+
60
+
| `Not_allowed_when of [`Attr of string] * [`Elem of string] * [`Condition of string]
61
+
(** Attribute conflicts with another attribute or element state.
62
+
Example: [readonly] and [disabled] together, or [multiple] on
63
+
certain input types where it's not supported. *)
64
+
65
+
| `Missing of [`Elem of string] * [`Attr of string]
66
+
(** Element is missing a required attribute.
67
+
Per HTML5, certain elements have required attributes for conformance.
68
+
Example: [<img>] requires [src] or [srcset], [<input>] requires [type]. *)
69
+
70
+
| `Missing_one_of of [`Elem of string] * [`Attrs of string list]
71
+
(** Element must have at least one of the listed attributes.
72
+
Some elements require at least one from a set of attributes.
73
+
Example: [<base>] needs [href] or [target] (or both). *)
74
+
75
+
| `Bad_value of [`Elem of string] * [`Attr of string] * [`Value of string] * [`Reason of string]
76
+
(** Attribute value doesn't match the expected format or enumeration.
77
+
HTML5 defines specific value spaces for many attributes (enumerations,
78
+
URLs, integers, etc.). This error indicates the value is malformed. *)
79
+
80
+
| `Bad_value_generic of [`Message of string]
81
+
(** Generic bad attribute value with custom message.
82
+
Used when the specific validation failure requires a custom explanation
83
+
that doesn't fit the standard bad value template. *)
84
+
85
+
| `Duplicate_id of [`Id of string]
86
+
(** Document contains multiple elements with the same ID.
87
+
Per HTML5, the [id] attribute must be unique within a document.
88
+
Duplicate IDs cause problems with fragment navigation, label
89
+
association, and JavaScript DOM queries. *)
90
+
91
+
| `Data_invalid_name of [`Reason of string]
92
+
(** Custom data attribute name violates naming rules.
93
+
[data-*] attribute names must be valid XML NCNames (no colons,
94
+
must start with letter or underscore). The reason explains
95
+
the specific naming violation. *)
96
+
97
+
| `Data_uppercase
98
+
(** Custom data attribute name contains uppercase letters.
99
+
[data-*] attribute names must not contain ASCII uppercase letters
100
+
(A-Z) per HTML5. Use lowercase with hyphens instead. *)
101
+
]
102
+
103
+
(** {1 Element Structure Errors}
104
+
105
+
Errors related to element usage, nesting, and content models. *)
106
+
107
+
(** Element structure validation errors.
108
+
109
+
These errors occur when elements violate HTML5 content model rules:
110
+
- Obsolete elements that should be replaced
111
+
- Elements used in wrong contexts (invalid parent/child relationships)
112
+
- Missing required child elements
113
+
- Empty elements that must have content *)
114
+
type element_error = [
115
+
| `Obsolete of [`Elem of string] * [`Suggestion of string]
116
+
(** Element is obsolete and should not be used.
117
+
HTML5 obsoletes certain elements from HTML4 (e.g., [<font>], [<center>]).
118
+
The suggestion provides the recommended modern alternative. *)
119
+
120
+
| `Obsolete_attr of [`Elem of string] * [`Attr of string] * [`Suggestion of string option]
121
+
(** Attribute on this element is obsolete.
122
+
Some attributes are obsolete on specific elements but may be valid
123
+
elsewhere. Example: [align] on [<table>] (use CSS instead). *)
124
+
125
+
| `Obsolete_global_attr of [`Attr of string] * [`Suggestion of string]
126
+
(** Global attribute is obsolete on all elements.
127
+
Attributes like [bgcolor] are obsolete everywhere in HTML5. *)
128
+
129
+
| `Not_allowed_as_child of [`Child of string] * [`Parent of string]
130
+
(** Element cannot be a child of the specified parent.
131
+
HTML5 defines content models for each element specifying which
132
+
children are allowed. Example: [<div>] inside [<p>] is invalid. *)
133
+
134
+
| `Unknown of [`Elem of string]
135
+
(** Element name is not recognized.
136
+
The element is not defined in HTML5, SVG, or MathML specs.
137
+
May be a typo or a custom element without hyphen. *)
138
+
139
+
| `Must_not_descend of [`Elem of string] * [`Attr of string option] * [`Ancestor of string]
140
+
(** Element must not appear as descendant of the specified ancestor.
141
+
Some elements have restrictions on their ancestry regardless of
142
+
direct parent. Example: [<form>] cannot be nested inside [<form>].
143
+
The optional attribute indicates a conditional restriction. *)
144
+
145
+
| `Missing_child of [`Parent of string] * [`Child of string]
146
+
(** Parent element is missing a required child element.
147
+
Some elements must contain specific children for conformance.
148
+
Example: [<dl>] requires [<dt>] and [<dd>] children. *)
149
+
150
+
| `Missing_child_one_of of [`Parent of string] * [`Children of string list]
151
+
(** Parent must contain at least one of the listed child elements.
152
+
Example: [<ruby>] must contain [<rt>] or [<rp>]. *)
153
+
154
+
| `Missing_child_generic of [`Parent of string]
155
+
(** Parent is missing an unspecified required child.
156
+
Used when the required child depends on context. *)
157
+
158
+
| `Must_not_be_empty of [`Elem of string]
159
+
(** Element must have content and cannot be empty.
160
+
Some elements require text or child element content.
161
+
Example: [<title>] must not be empty. *)
162
+
163
+
| `Text_not_allowed of [`Parent of string]
164
+
(** Text content is not allowed in this element.
165
+
Some elements only allow element children, not text.
166
+
Example: [<table>] cannot contain direct text children. *)
167
+
]
168
+
169
+
(** {1 Tag and Parse Errors}
170
+
171
+
Errors from the parsing phase related to tags and document structure. *)
172
+
173
+
(** Tag-level parse errors.
174
+
175
+
These errors occur during HTML parsing when the parser encounters
176
+
problematic tag structures or reaches end-of-file unexpectedly. *)
177
+
type tag_error = [
178
+
| `Stray_start of [`Tag of string]
179
+
(** Start tag appears in a position where it's not allowed.
180
+
The parser encountered an opening tag that cannot appear in
181
+
the current insertion mode. Example: [<tr>] outside [<table>]. *)
182
+
183
+
| `Stray_end of [`Tag of string]
184
+
(** End tag appears without a matching start tag.
185
+
The parser encountered a closing tag with no corresponding
186
+
open element in scope. *)
187
+
188
+
| `End_for_void of [`Tag of string]
189
+
(** End tag for a void element that cannot have one.
190
+
Void elements ([<br>], [<img>], etc.) cannot have end tags
191
+
in HTML5. Example: [</br>] is invalid. *)
192
+
193
+
| `Self_closing_non_void
194
+
(** Self-closing syntax [/>] used on non-void HTML element.
195
+
In HTML5, [/>] is only meaningful on void elements and
196
+
foreign (SVG/MathML) elements. On other elements it's ignored. *)
197
+
198
+
| `Not_in_scope of [`Tag of string]
199
+
(** End tag seen but no matching element in scope.
200
+
The parser found a closing tag but the element isn't in the
201
+
current scope (may be blocked by formatting elements). *)
202
+
203
+
| `End_implied_open of [`Tag of string]
204
+
(** End tag implied closing of other open elements.
205
+
The parser had to implicitly close elements to process this
206
+
end tag, indicating mismatched nesting. *)
207
+
208
+
| `Start_in_table of [`Tag of string]
209
+
(** Start tag appeared inside table where it's foster-parented.
210
+
When certain tags appear in table context, they're moved
211
+
outside the table (foster parenting), indicating malformed markup. *)
212
+
213
+
| `Bad_start_in of [`Tag of string] * [`Context of string]
214
+
(** Start tag appeared in invalid context.
215
+
Generic error for tags in wrong parsing contexts. *)
216
+
217
+
| `Eof_with_open
218
+
(** End of file reached with unclosed elements.
219
+
The document ended with elements still open on the stack,
220
+
indicating missing closing tags. *)
221
+
]
222
+
223
+
(** Character reference errors.
224
+
225
+
These errors occur when character references (like [&] or [A])
226
+
expand to problematic Unicode code points. *)
227
+
type char_ref_error = [
228
+
| `Forbidden_codepoint of [`Codepoint of int]
229
+
(** Character reference expands to a forbidden code point.
230
+
Certain code points are forbidden in HTML documents (e.g.,
231
+
NULL U+0000, noncharacters). These cannot appear even via
232
+
character references. *)
233
+
234
+
| `Control_char of [`Codepoint of int]
235
+
(** Character reference expands to a control character.
236
+
C0 and C1 control characters (except tab, newline, etc.)
237
+
are problematic and trigger this warning. *)
238
+
239
+
| `Non_char of [`Codepoint of int] * [`Astral of bool]
240
+
(** Character reference expands to a Unicode noncharacter.
241
+
Noncharacters (like U+FFFE, U+FFFF) are reserved and
242
+
should not appear in documents. Astral flag indicates
243
+
if it's in the supplementary planes. *)
244
+
245
+
| `Unassigned
246
+
(** Character reference expands to permanently unassigned code point.
247
+
The referenced code point will never be assigned a character. *)
248
+
249
+
| `Zero
250
+
(** Character reference expands to U+0000 (NULL).
251
+
NULL is replaced with U+FFFD (replacement character) per HTML5. *)
252
+
253
+
| `Out_of_range
254
+
(** Character reference value exceeds Unicode maximum.
255
+
Numeric character references must be <= U+10FFFF. *)
256
+
257
+
| `Carriage_return
258
+
(** Numeric character reference expanded to carriage return.
259
+
CR (U+000D) via numeric reference is replaced with LF. *)
260
+
]
261
+
262
+
(** {1 ARIA and Accessibility Errors}
263
+
264
+
Errors related to WAI-ARIA attributes and accessibility conformance. *)
265
+
266
+
(** ARIA and role validation errors.
267
+
268
+
These errors ensure proper usage of WAI-ARIA attributes and roles
269
+
for accessibility. Incorrect ARIA can make content less accessible
270
+
than having no ARIA at all. *)
271
+
type aria_error = [
272
+
| `Unnecessary_role of [`Role of string] * [`Elem of string] * [`Reason of string]
273
+
(** Role is redundant because element has implicit role.
274
+
Many HTML elements have implicit ARIA roles; explicitly setting
275
+
the same role is unnecessary. Example: [role="button"] on [<button>]. *)
276
+
277
+
| `Bad_role of [`Elem of string] * [`Role of string]
278
+
(** Role value is invalid or not allowed on this element.
279
+
The role is either not a valid ARIA role token or is not
280
+
permitted on this particular element type. *)
281
+
282
+
| `Must_not_specify of [`Attr of string] * [`Elem of string] * [`Condition of string]
283
+
(** ARIA attribute must not be specified in this situation.
284
+
Some ARIA attributes are prohibited on certain elements unless
285
+
specific conditions are met. *)
286
+
287
+
| `Must_not_use of [`Attr of string] * [`Elem of string] * [`Condition of string]
288
+
(** ARIA attribute must not be used with this element configuration.
289
+
The attribute conflicts with another attribute or state of the element. *)
290
+
291
+
| `Should_not_use of [`Attr of string] * [`Role of string]
292
+
(** ARIA attribute should not be used with this role (warning).
293
+
While not strictly invalid, the attribute is discouraged
294
+
with this role as it may cause confusion. *)
295
+
296
+
| `Hidden_on_body
297
+
(** [aria-hidden="true"] used on body element.
298
+
Hiding the entire document from assistive technology is
299
+
almost certainly an error. *)
300
+
301
+
| `Unrecognized_role of [`Token of string]
302
+
(** Unrecognized role token was discarded.
303
+
The role attribute contained a token that isn't a valid
304
+
ARIA role. Browsers ignore unknown role tokens. *)
305
+
306
+
| `Tab_without_tabpanel
307
+
(** Tab element has no corresponding tabpanel.
308
+
Each [role="tab"] should control a [role="tabpanel"].
309
+
Missing tabpanels indicate incomplete tab interface. *)
310
+
311
+
| `Multiple_main
312
+
(** Document has multiple visible main landmarks.
313
+
Only one visible [role="main"] or [<main>] should exist
314
+
per document for proper landmark navigation. *)
315
+
]
316
+
317
+
(** List item role constraint errors.
318
+
319
+
Special ARIA role restrictions on [<li>] elements and [<div>]
320
+
children of [<dl>] elements. *)
321
+
type li_role_error = [
322
+
| `Div_in_dl_bad_role
323
+
(** [<div>] child of [<dl>] has invalid role.
324
+
When [<div>] is used to group [<dt>]/[<dd>] pairs in a [<dl>],
325
+
it may only have [role="presentation"] or [role="none"]. *)
326
+
327
+
| `Li_bad_role_in_menu
328
+
(** [<li>] in menu/menubar has invalid role.
329
+
[<li>] descendants of [role="menu"] or [role="menubar"] must
330
+
have roles like [menuitem], [menuitemcheckbox], etc. *)
331
+
332
+
| `Li_bad_role_in_tablist
333
+
(** [<li>] in tablist has invalid role.
334
+
[<li>] descendants of [role="tablist"] must have [role="tab"]. *)
335
+
336
+
| `Li_bad_role_in_list
337
+
(** [<li>] in list context has invalid role.
338
+
[<li>] in [<ul>], [<ol>], [<menu>], or [role="list"] must
339
+
have [role="listitem"] or no explicit role. *)
340
+
]
341
+
342
+
(** {1 Table Errors}
343
+
344
+
Errors in HTML table structure and cell spanning. *)
345
+
346
+
(** Table structure validation errors.
347
+
348
+
These errors indicate problems with table structure that may
349
+
cause incorrect rendering or accessibility issues. *)
350
+
type table_error = [
351
+
| `Row_no_cells of [`Row of int]
352
+
(** Table row has no cells starting on it.
353
+
The specified row number (1-indexed) in an implicit row group
354
+
has no cells beginning on that row, possibly due to rowspan. *)
355
+
356
+
| `Cell_overlap
357
+
(** Table cells overlap due to spanning.
358
+
A cell's rowspan/colspan causes it to overlap with another cell,
359
+
making the table structure ambiguous. *)
360
+
361
+
| `Cell_spans_rowgroup
362
+
(** Cell's rowspan extends past its row group.
363
+
A cell's rowspan would extend beyond the [<tbody>], [<thead>],
364
+
or [<tfoot>] containing it; the span is clipped. *)
365
+
366
+
| `Column_no_cells of [`Column of int] * [`Elem of string]
367
+
(** Table column has no cells.
368
+
A column established by [<col>] or [<colgroup>] has no cells
369
+
beginning in it, indicating mismatched column definitions. *)
370
+
]
371
+
372
+
(** {1 Internationalization Errors}
373
+
374
+
Errors related to language declaration and text direction. *)
375
+
376
+
(** Language and internationalization validation errors.
377
+
378
+
These errors help ensure documents properly declare their language
379
+
and text direction for accessibility and correct rendering. *)
380
+
type i18n_error = [
381
+
| `Missing_lang
382
+
(** Document has no language declaration.
383
+
The [<html>] element should have a [lang] attribute declaring
384
+
the document's primary language for accessibility. *)
385
+
386
+
| `Wrong_lang of [`Detected of string] * [`Declared of string] * [`Suggested of string]
387
+
(** Declared language doesn't match detected content language.
388
+
Automatic language detection suggests the [lang] attribute
389
+
value is incorrect for the actual content. *)
390
+
391
+
| `Missing_dir_rtl of [`Language of string]
392
+
(** RTL language content lacks [dir="rtl"].
393
+
Content detected as a right-to-left language should have
394
+
explicit direction declaration. *)
395
+
396
+
| `Wrong_dir of [`Language of string] * [`Declared of string]
397
+
(** Text direction doesn't match detected language direction.
398
+
The [dir] attribute value conflicts with the detected
399
+
language's natural direction. *)
400
+
401
+
| `Xml_lang_without_lang
402
+
(** [xml:lang] present but [lang] is missing.
403
+
When [xml:lang] is specified (for XHTML compatibility),
404
+
the [lang] attribute must also be present with the same value. *)
405
+
406
+
| `Xml_lang_mismatch
407
+
(** [xml:lang] and [lang] attribute values don't match.
408
+
Both attributes must have identical values when present. *)
409
+
410
+
| `Not_nfc of [`Replacement of string]
411
+
(** Text is not in Unicode Normalization Form C.
412
+
HTML5 requires NFC normalization. The replacement string
413
+
shows the correctly normalized form. *)
414
+
]
415
+
416
+
(** {1 Import Map Errors}
417
+
418
+
Errors in [<script type="importmap">] JSON content. *)
419
+
420
+
(** Import map validation errors.
421
+
422
+
These errors occur when validating the JSON content of
423
+
[<script type="importmap">] elements per the Import Maps spec. *)
424
+
type importmap_error = [
425
+
| `Invalid_json
426
+
(** Import map content is not valid JSON.
427
+
The script content must be parseable as JSON. *)
22
428
23
-
(* Element Errors *)
24
-
| Obsolete_element of { element: string; suggestion: string }
25
-
| Obsolete_attr of { element: string; attr: string; suggestion: string option }
26
-
| Obsolete_global_attr of { attr: string; suggestion: string }
27
-
| Element_not_allowed_as_child of { child: string; parent: string }
28
-
| Unknown_element of { name: string }
29
-
| Element_must_not_be_descendant of { element: string; attr: string option; ancestor: string }
30
-
| Missing_required_child of { parent: string; child: string }
31
-
| Missing_required_child_one_of of { parent: string; children: string list }
32
-
| Missing_required_child_generic of { parent: string }
33
-
| Element_must_not_be_empty of { element: string }
34
-
| Stray_start_tag of { tag: string }
35
-
| Stray_end_tag of { tag: string }
36
-
| End_tag_for_void_element of { tag: string }
37
-
| Self_closing_non_void
38
-
| Text_not_allowed of { parent: string }
429
+
| `Invalid_root
430
+
(** Import map root is not a valid object.
431
+
The JSON must be an object with only [imports], [scopes],
432
+
and [integrity] properties. *)
39
433
40
-
(* Child Restrictions *)
41
-
| Div_child_of_dl_bad_role
42
-
| Li_bad_role_in_menu
43
-
| Li_bad_role_in_tablist
44
-
| Li_bad_role_in_list
434
+
| `Imports_not_object
435
+
(** The [imports] property is not a JSON object.
436
+
[imports] must be an object mapping specifiers to URLs. *)
45
437
46
-
(* ARIA Errors *)
47
-
| Unnecessary_role of { role: string; element: string; reason: string }
48
-
| Bad_role of { element: string; role: string }
49
-
| Aria_must_not_be_specified of { attr: string; element: string; condition: string }
50
-
| Aria_must_not_be_used of { attr: string; element: string; condition: string }
51
-
| Aria_should_not_be_used of { attr: string; role: string }
52
-
| Aria_hidden_on_body
53
-
| Img_empty_alt_with_role
54
-
| Checkbox_button_needs_aria_pressed
55
-
| Tab_without_tabpanel
56
-
| Multiple_main_visible
57
-
| Discarding_unrecognized_role of { token: string }
438
+
| `Empty_key
439
+
(** Specifier map contains an empty string key.
440
+
Module specifier keys must be non-empty strings. *)
58
441
59
-
(* Required Attribute/Element Conditions *)
60
-
| Img_missing_alt
61
-
| Img_missing_src_or_srcset
62
-
| Option_empty_without_label
63
-
| Bdo_missing_dir
64
-
| Bdo_dir_auto
65
-
| Base_missing_href_or_target
66
-
| Base_after_link_script
67
-
| Link_missing_href
68
-
| Link_as_requires_preload
69
-
| Link_imagesrcset_requires_as_image
70
-
| Img_ismap_needs_a_href
71
-
| Sizes_without_srcset
72
-
| Imagesizes_without_imagesrcset
73
-
| Srcset_w_without_sizes
74
-
| Source_missing_srcset
75
-
| Source_needs_media_or_type
76
-
| Picture_missing_img
77
-
| Map_id_name_mismatch
78
-
| List_attr_requires_datalist
79
-
| Input_list_not_allowed
80
-
| Label_too_many_labelable
81
-
| Label_for_id_mismatch
82
-
| Role_on_label_ancestor
83
-
| Role_on_label_for
84
-
| Aria_label_on_label_for
85
-
| Input_value_constraint of { constraint_type: string }
86
-
| Summary_missing_role
87
-
| Summary_missing_attrs
88
-
| Summary_role_not_allowed
89
-
| Autocomplete_webauthn_on_select
90
-
| Commandfor_invalid_target
442
+
| `Non_string_value
443
+
(** Specifier map contains a non-string value.
444
+
All values in the specifier map must be strings (URLs). *)
91
445
92
-
(* Parse Errors *)
93
-
| Forbidden_codepoint of { codepoint: int }
94
-
| Char_ref_control of { codepoint: int }
95
-
| Char_ref_non_char of { codepoint: int; astral: bool }
96
-
| Char_ref_unassigned
97
-
| Char_ref_zero
98
-
| Char_ref_out_of_range
99
-
| Numeric_char_ref_carriage_return
100
-
| End_of_file_with_open_elements
101
-
| No_element_in_scope of { tag: string }
102
-
| End_tag_implied_open_elements of { tag: string }
103
-
| Start_tag_in_table of { tag: string }
104
-
| Bad_start_tag_in of { tag: string; context: string }
446
+
| `Key_trailing_slash
447
+
(** Specifier with trailing [/] maps to URL without trailing [/].
448
+
When a specifier key ends with [/], its value must also
449
+
end with [/] for proper prefix matching. *)
105
450
106
-
(* Table Errors *)
107
-
| Table_row_no_cells of { row: int }
108
-
| Table_cell_overlap
109
-
| Table_cell_spans_rowgroup
110
-
| Table_column_no_cells of { column: int; element: string }
451
+
| `Scopes_not_object
452
+
(** The [scopes] property is not a JSON object.
453
+
[scopes] must be an object with URL keys. *)
111
454
112
-
(* Language/Internationalization *)
113
-
| Missing_lang_attr
114
-
| Wrong_lang of { detected: string; declared: string; suggested: string }
115
-
| Missing_dir_rtl of { language: string }
116
-
| Wrong_dir of { language: string; declared: string }
117
-
| Xml_lang_without_lang
118
-
| Xml_lang_lang_mismatch
455
+
| `Scopes_values_not_object
456
+
(** A [scopes] entry value is not a JSON object.
457
+
Each scope must map to a specifier map object. *)
119
458
120
-
(* Unicode Normalization *)
121
-
| Not_nfc of { replacement: string }
459
+
| `Scopes_invalid_url
460
+
(** A [scopes] key is not a valid URL.
461
+
Scope keys must be valid URL strings. *)
122
462
123
-
(* Multiple h1 *)
124
-
| Multiple_h1
125
-
| Multiple_autofocus
463
+
| `Scopes_value_invalid_url
464
+
(** A specifier value in [scopes] is not a valid URL.
465
+
URL values in scope specifier maps must be valid. *)
466
+
]
126
467
127
-
(* Import Maps *)
128
-
| Importmap_invalid_json
129
-
| Importmap_invalid_root
130
-
| Importmap_imports_not_object
131
-
| Importmap_empty_key
132
-
| Importmap_non_string_value
133
-
| Importmap_key_trailing_slash
134
-
| Importmap_scopes_not_object
135
-
| Importmap_scopes_values_not_object
136
-
| Importmap_scopes_invalid_url
137
-
| Importmap_scopes_value_invalid_url
468
+
(** {1 Element-Specific Errors}
138
469
139
-
(* Style Element *)
140
-
| Style_type_invalid
470
+
Validation errors specific to particular HTML elements. *)
141
471
142
-
(* Headingoffset *)
143
-
| Headingoffset_invalid
472
+
(** Image element ([<img>]) validation errors. *)
473
+
type img_error = [
474
+
| `Missing_alt
475
+
(** Image lacks [alt] attribute for accessibility.
476
+
Per WCAG and HTML5, images must have [alt] text describing
477
+
their content, or [alt=""] for decorative images. *)
144
478
145
-
(* Media Attribute *)
146
-
| Media_empty
147
-
| Media_all
479
+
| `Missing_src_or_srcset
480
+
(** Image has neither [src] nor [srcset].
481
+
An [<img>] must have at least one image source specified. *)
482
+
483
+
| `Empty_alt_with_role
484
+
(** Image with [alt=""] has a [role] attribute.
485
+
Decorative images (empty [alt]) must not have [role] because
486
+
they should be hidden from assistive technology. *)
487
+
488
+
| `Ismap_needs_href
489
+
(** Image with [ismap] lacks [<a href>] ancestor.
490
+
Server-side image maps require a link wrapper to function. *)
491
+
]
492
+
493
+
(** Link element ([<link>]) validation errors. *)
494
+
type link_error = [
495
+
| `Missing_href
496
+
(** [<link>] has no [href] or [imagesrcset].
497
+
A link element must have a resource to link to. *)
498
+
499
+
| `As_requires_preload
500
+
(** [<link as="...">] used without [rel="preload"].
501
+
The [as] attribute is only meaningful for preload/modulepreload. *)
502
+
503
+
| `Imagesrcset_requires_as_image
504
+
(** [<link imagesrcset>] used without [as="image"].
505
+
Image srcset preloading requires [as="image"]. *)
506
+
]
148
507
149
-
(* SVG/MathML specific *)
150
-
| Svg_deprecated_attr of { attr: string; element: string }
151
-
| Missing_required_svg_attr of { element: string; attr: string }
508
+
(** Label element ([<label>]) validation errors. *)
509
+
type label_error = [
510
+
| `Too_many_labelable
511
+
(** Label contains multiple labelable descendants.
512
+
A [<label>] should associate with exactly one form control. *)
152
513
153
-
(* Generic/Fallback *)
154
-
| Generic of { message: string }
514
+
| `For_id_mismatch
515
+
(** Label's [for] doesn't match descendant input's [id].
516
+
When a [<label>] has both [for] and a descendant input,
517
+
the input's [id] must match the [for] value. *)
518
+
519
+
| `Role_on_ancestor
520
+
(** [<label>] with role is ancestor of labelable element.
521
+
Adding [role] to a label that wraps a form control
522
+
breaks the implicit label association. *)
155
523
156
-
(** Get the severity level for an error code *)
524
+
| `Role_on_for
525
+
(** [<label>] with role uses [for] association.
526
+
Labels with explicit [for] association must not have [role]. *)
527
+
528
+
| `Aria_label_on_for
529
+
(** [<label>] with [aria-label] uses [for] association.
530
+
[aria-label] on a label associated via [for] creates
531
+
conflicting accessible names. *)
532
+
]
533
+
534
+
(** Input element ([<input>]) validation errors. *)
535
+
type input_error = [
536
+
| `Checkbox_needs_aria_pressed
537
+
(** Checkbox with [role="button"] lacks [aria-pressed].
538
+
When a checkbox is styled as a toggle button, it needs
539
+
[aria-pressed] to convey the toggle state. *)
540
+
541
+
| `Value_constraint of [`Constraint of string]
542
+
(** Input [value] doesn't meet type-specific constraints.
543
+
Different input types have different value format requirements
544
+
(dates, numbers, emails, etc.). *)
545
+
546
+
| `List_not_allowed
547
+
(** [list] attribute used on incompatible input type.
548
+
The [list] attribute for datalist binding is only valid
549
+
on certain input types (text, search, url, etc.). *)
550
+
551
+
| `List_requires_datalist
552
+
(** [list] attribute doesn't reference a [<datalist>].
553
+
The [list] attribute must contain the ID of a datalist element. *)
554
+
]
555
+
556
+
(** Responsive image ([srcset]/[sizes]) validation errors. *)
557
+
type srcset_error = [
558
+
| `Sizes_without_srcset
559
+
(** [sizes] used without [srcset].
560
+
The [sizes] attribute is meaningless without [srcset]. *)
561
+
562
+
| `Imagesizes_without_imagesrcset
563
+
(** [imagesizes] used without [imagesrcset].
564
+
On [<link>], [imagesizes] requires [imagesrcset]. *)
565
+
566
+
| `W_without_sizes
567
+
(** [srcset] with width descriptors lacks [sizes].
568
+
When using width descriptors ([w]) in [srcset], the [sizes]
569
+
attribute must specify the rendered size. *)
570
+
571
+
| `Source_missing_srcset
572
+
(** [<source>] in [<picture>] lacks [srcset].
573
+
Picture source elements must have a srcset. *)
574
+
575
+
| `Source_needs_media_or_type
576
+
(** [<source>] needs [media] or [type] to differentiate.
577
+
When multiple sources exist, each must have selection criteria. *)
578
+
579
+
| `Picture_missing_img
580
+
(** [<picture>] lacks required [<img>] child.
581
+
A picture element must contain an img as the fallback. *)
582
+
]
583
+
584
+
(** SVG element validation errors. *)
585
+
type svg_error = [
586
+
| `Deprecated_attr of [`Attr of string] * [`Elem of string]
587
+
(** SVG attribute is deprecated.
588
+
Certain SVG presentation attributes are deprecated in
589
+
favor of CSS properties. *)
590
+
591
+
| `Missing_attr of [`Elem of string] * [`Attr of string]
592
+
(** SVG element missing required attribute.
593
+
Some SVG elements have required attributes for valid rendering. *)
594
+
]
595
+
596
+
(** Miscellaneous element-specific errors.
597
+
598
+
These errors are specific to individual elements that don't
599
+
warrant their own category. *)
600
+
type misc_error = [
601
+
| `Option_empty_without_label
602
+
(** [<option>] without [label] attribute is empty.
603
+
Options need either text content or a label attribute. *)
604
+
605
+
| `Bdo_missing_dir
606
+
(** [<bdo>] element lacks required [dir] attribute.
607
+
The bidirectional override element must specify direction. *)
608
+
609
+
| `Bdo_dir_auto
610
+
(** [<bdo>] has [dir="auto"] which is invalid.
611
+
BDO requires explicit [ltr] or [rtl], not auto-detection. *)
612
+
613
+
| `Base_missing_href_or_target
614
+
(** [<base>] has neither [href] nor [target].
615
+
A base element must specify at least one of these. *)
616
+
617
+
| `Base_after_link_script
618
+
(** [<base>] appears after [<link>] or [<script>].
619
+
The base URL must be established before other URL resolution. *)
620
+
621
+
| `Map_id_name_mismatch
622
+
(** [<map>] [id] and [name] attributes don't match.
623
+
For image maps, both attributes must have the same value. *)
624
+
625
+
| `Summary_missing_role
626
+
(** Non-default [<summary>] lacks [role] attribute.
627
+
Custom summary content outside details needs explicit role. *)
628
+
629
+
| `Summary_missing_attrs
630
+
(** Non-default [<summary>] missing required ARIA attributes.
631
+
Custom summary implementations need proper ARIA. *)
632
+
633
+
| `Summary_role_not_allowed
634
+
(** [<summary>] for its parent [<details>] has [role].
635
+
Default summary for details must not override its role. *)
636
+
637
+
| `Autocomplete_webauthn_on_select
638
+
(** [<select>] has [autocomplete] containing [webauthn].
639
+
WebAuthn autocomplete tokens are not valid for select elements. *)
640
+
641
+
| `Commandfor_invalid_target
642
+
(** [commandfor] doesn't reference a valid element ID.
643
+
The invoker must reference an element in the same tree. *)
644
+
645
+
| `Style_type_invalid
646
+
(** [<style type>] has value other than [text/css].
647
+
HTML5 only supports CSS in style elements. *)
648
+
649
+
| `Headingoffset_invalid
650
+
(** [headingoffset] value is out of range.
651
+
Must be an integer between 0 and 8. *)
652
+
653
+
| `Media_empty
654
+
(** [media] attribute is empty string.
655
+
Media queries must be non-empty if the attribute is present. *)
656
+
657
+
| `Media_all
658
+
(** [media] attribute is just ["all"].
659
+
Using [media="all"] is pointless; omit the attribute instead. *)
660
+
661
+
| `Multiple_h1
662
+
(** Document contains multiple [<h1>] elements.
663
+
Best practice is one [<h1>] per document unless using
664
+
[headingoffset] to indicate sectioning. *)
665
+
666
+
| `Multiple_autofocus
667
+
(** Multiple elements have [autofocus] in same scope.
668
+
Only one element should have autofocus per scoping root. *)
669
+
]
670
+
671
+
(** {1 Top-Level Error Type} *)
672
+
673
+
(** All HTML5 validation errors, organized by category.
674
+
675
+
Pattern match on the outer constructor to handle error categories,
676
+
or match through to specific errors as needed.
677
+
678
+
{[
679
+
let severity_of_category = function
680
+
| `Aria _ -> may_be_warning
681
+
| `I18n _ -> usually_info_or_warning
682
+
| _ -> usually_error
683
+
]} *)
684
+
type t = [
685
+
| `Attr of attr_error
686
+
(** Attribute validation errors *)
687
+
| `Element of element_error
688
+
(** Element structure errors *)
689
+
| `Tag of tag_error
690
+
(** Tag-level parse errors *)
691
+
| `Char_ref of char_ref_error
692
+
(** Character reference errors *)
693
+
| `Aria of aria_error
694
+
(** ARIA and accessibility errors *)
695
+
| `Li_role of li_role_error
696
+
(** List item role constraints *)
697
+
| `Table of table_error
698
+
(** Table structure errors *)
699
+
| `I18n of i18n_error
700
+
(** Language and direction errors *)
701
+
| `Importmap of importmap_error
702
+
(** Import map JSON errors *)
703
+
| `Img of img_error
704
+
(** Image element errors *)
705
+
| `Link of link_error
706
+
(** Link element errors *)
707
+
| `Label of label_error
708
+
(** Label element errors *)
709
+
| `Input of input_error
710
+
(** Input element errors *)
711
+
| `Srcset of srcset_error
712
+
(** Responsive image errors *)
713
+
| `Svg of svg_error
714
+
(** SVG-specific errors *)
715
+
| `Misc of misc_error
716
+
(** Miscellaneous element errors *)
717
+
| `Generic of string
718
+
(** Fallback for messages without specific error codes *)
719
+
]
720
+
721
+
(** {1 Functions} *)
722
+
723
+
(** Get the severity level for an error.
724
+
Most errors are [Error]; some ARIA and i18n issues are [Warning] or [Info]. *)
157
725
val severity : t -> severity
158
726
159
-
(** Get a short code string for categorization *)
727
+
(** Get a short categorization code string.
728
+
Useful for filtering, grouping, or machine-readable output.
729
+
Example: ["disallowed-attribute"], ["missing-alt"], ["aria-not-allowed"]. *)
160
730
val code_string : t -> string
161
731
162
-
(** Convert error code to exact Nu validator message string *)
732
+
(** Convert error to human-readable message.
733
+
Produces messages matching the Nu HTML Validator format with
734
+
proper Unicode curly quotes around identifiers. *)
163
735
val to_message : t -> string
164
736
165
-
(** Format a string with curly quotes *)
737
+
(** Format a string with Unicode curly quotes.
738
+
Wraps the string in U+201C and U+201D ("..."). *)
166
739
val q : string -> string
+2
-2
lib/html5_checker/html5_checker.ml
+2
-2
lib/html5_checker/html5_checker.ml
···
42
42
let dummy_doc = Html5rw.parse (Bytesrw.Bytes.Reader.of_string "") in
43
43
{ doc = dummy_doc; msgs = Message_collector.messages collector; system_id }
44
44
| Error msg ->
45
-
Message_collector.add_typed collector (Error_code.Generic { message = msg });
45
+
Message_collector.add_typed collector (`Generic msg);
46
46
let dummy_doc = Html5rw.parse (Bytesrw.Bytes.Reader.of_string "") in
47
47
{ doc = dummy_doc; msgs = Message_collector.messages collector; system_id }
48
48
end
···
62
62
63
63
(* Special case: emit missing-lang warning for specific test file *)
64
64
if is_missing_lang_test system_id then
65
-
Message_collector.add_typed collector Error_code.Missing_lang_attr;
65
+
Message_collector.add_typed collector (`I18n `Missing_lang);
66
66
67
67
{ doc; msgs = Message_collector.messages collector; system_id }
68
68
end
+1
-1
lib/html5_checker/semantic/autofocus_checker.ml
+1
-1
lib/html5_checker/semantic/autofocus_checker.ml
+2
-7
lib/html5_checker/semantic/form_checker.ml
+2
-7
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_typed collector Error_code.Autocomplete_webauthn_on_select
29
+
Message_collector.add_typed collector (`Misc `Autocomplete_webauthn_on_select)
30
30
end else begin
31
31
(* Use the proper autocomplete validator from dt_autocomplete *)
32
32
match Dt_autocomplete.validate_autocomplete value with
···
35
35
(* Nu validator prefixes autocomplete errors with "Bad autocomplete detail tokens (any): " for select/textarea, but not for input *)
36
36
let reason = if element_name = "input" then msg else "Bad autocomplete detail tokens (any): " ^ msg in
37
37
Message_collector.add_typed collector
38
-
(Error_code.Bad_attr_value {
39
-
element = element_name;
40
-
attr = "autocomplete";
41
-
value;
42
-
reason
43
-
})
38
+
(`Attr (`Bad_value (`Elem element_name, `Attr "autocomplete", `Value value, `Reason reason)))
44
39
end
45
40
46
41
let start_element _state ~name ~namespace:_ ~attrs collector =
+17
-33
lib/html5_checker/semantic/id_checker.ml
+17
-33
lib/html5_checker/semantic/id_checker.ml
···
100
100
(* Check for empty ID *)
101
101
if String.length id = 0 then
102
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
-
})
103
+
(`Attr (`Bad_value_generic (`Message "Bad value \"\" for attribute \"id\": An ID must not be the empty string.")))
106
104
(* Check for whitespace in ID *)
107
105
else if contains_whitespace id then
108
106
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
-
})
107
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value %s for attribute \"id\": An ID must not contain whitespace."
108
+
(Error_code.q id)))))
113
109
(* Check for duplicate ID *)
114
110
else if Hashtbl.mem state.ids id then
115
-
Message_collector.add_typed collector (Error_code.Duplicate_id { id })
111
+
Message_collector.add_typed collector (`Attr (`Duplicate_id (`Id id)))
116
112
else
117
113
(* Store the ID *)
118
114
Hashtbl.add state.ids id ()
···
148
144
else
149
145
(* Empty hash name: "#" *)
150
146
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
-
})
147
+
(`Attr (`Bad_value (`Elem element, `Attr name, `Value value,
148
+
`Reason (Printf.sprintf "Bad hash-name reference: A hash-name reference must have at least one character after %s."
149
+
(Error_code.q "#")))))
158
150
| None ->
159
151
if String.length value > 0 then
160
152
(* Missing # prefix *)
161
153
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
-
})
154
+
(`Attr (`Bad_value (`Elem element, `Attr name, `Value value,
155
+
`Reason (Printf.sprintf "Bad hash-name reference: A hash-name reference must start with %s."
156
+
(Error_code.q "#")))))
169
157
end
170
158
171
159
| "name" when element = "map" ->
···
201
189
let name_opt = List.find_map (fun (n, v) -> if n = "name" then Some v else None) attrs in
202
190
match id_opt, name_opt with
203
191
| Some id_val, Some name_val when id_val <> name_val ->
204
-
Message_collector.add_typed collector Error_code.Map_id_name_mismatch
192
+
Message_collector.add_typed collector (`Misc `Map_id_name_mismatch)
205
193
| _ -> ()
206
194
end
207
195
···
217
205
if not (Hashtbl.mem state.ids ref.referenced_id) then begin
218
206
(* Use specific error for list attribute on input *)
219
207
if ref.attribute = "list" && ref.referring_element = "input" then
220
-
Message_collector.add_typed collector Error_code.List_attr_requires_datalist
208
+
Message_collector.add_typed collector (`Input `List_requires_datalist)
221
209
else if ref.attribute = "commandfor" then
222
-
Message_collector.add_typed collector Error_code.Commandfor_invalid_target
210
+
Message_collector.add_typed collector (`Misc `Commandfor_invalid_target)
223
211
else
224
212
(* Use generic for dangling references - format may vary *)
225
213
Message_collector.add_typed collector
226
-
(Error_code.Generic {
227
-
message = Printf.sprintf "The %s attribute on the %s element refers to ID %s which does not exist in the document."
228
-
(Error_code.q ref.attribute) (Error_code.q ref.referring_element) (Error_code.q ref.referenced_id)
229
-
})
214
+
(`Generic (Printf.sprintf "The %s attribute on the %s element refers to ID %s which does not exist in the document."
215
+
(Error_code.q ref.attribute) (Error_code.q ref.referring_element) (Error_code.q ref.referenced_id)))
230
216
end
231
217
) state.references;
232
218
···
234
220
List.iter (fun ref ->
235
221
if not (Hashtbl.mem state.map_names ref.referenced_id) then
236
222
Message_collector.add_typed collector
237
-
(Error_code.Generic {
238
-
message = Printf.sprintf "The %s attribute on the %s element refers to map name %s which does not exist in the document."
239
-
(Error_code.q ref.attribute) (Error_code.q ref.referring_element) (Error_code.q ref.referenced_id)
240
-
})
223
+
(`Generic (Printf.sprintf "The %s attribute on the %s element refers to map name %s which does not exist in the document."
224
+
(Error_code.q ref.attribute) (Error_code.q ref.referring_element) (Error_code.q ref.referenced_id)))
241
225
) state.usemap_references
242
226
243
227
let checker = (module struct
+4
-12
lib/html5_checker/semantic/lang_detecting_checker.ml
+4
-12
lib/html5_checker/semantic/lang_detecting_checker.ml
···
322
322
if original_declared = "" then begin
323
323
(* No lang attribute - suggest adding one *)
324
324
Message_collector.add_typed collector
325
-
(Error_code.Wrong_lang {
326
-
detected = detected_name;
327
-
declared = "";
328
-
suggested = suggested_code
329
-
})
325
+
(`I18n (`Wrong_lang (`Detected detected_name, `Declared "", `Suggested suggested_code)))
330
326
end
331
327
else if base_declared <> base_detected &&
332
328
(* Don't warn for zh variants *)
333
329
not (base_declared = "zh" && base_detected = "zh") then begin
334
330
Message_collector.add_typed collector
335
-
(Error_code.Wrong_lang {
336
-
detected = detected_name;
337
-
declared = original_declared;
338
-
suggested = suggested_code
339
-
})
331
+
(`I18n (`Wrong_lang (`Detected detected_name, `Declared original_declared, `Suggested suggested_code)))
340
332
end;
341
333
342
334
(* Check dir attribute for RTL languages *)
···
344
336
match state.html_dir with
345
337
| None ->
346
338
Message_collector.add_typed collector
347
-
(Error_code.Missing_dir_rtl { language = detected_name })
339
+
(`I18n (`Missing_dir_rtl (`Language detected_name)))
348
340
| Some dir when String.lowercase_ascii dir <> "rtl" ->
349
341
Message_collector.add_typed collector
350
-
(Error_code.Wrong_dir { language = detected_name; declared = dir })
342
+
(`I18n (`Wrong_dir (`Language detected_name, `Declared dir)))
351
343
| _ -> ()
352
344
end
353
345
| _ -> ()
+5
-17
lib/html5_checker/semantic/nesting_checker.ml
+5
-17
lib/html5_checker/semantic/nesting_checker.ml
···
263
263
| None -> ancestor
264
264
in
265
265
Message_collector.add_typed collector
266
-
(Error_code.Element_not_allowed_as_child {
267
-
child = name;
268
-
parent
269
-
})
266
+
(`Element (`Not_allowed_as_child (`Child name, `Parent parent)))
270
267
end else
271
268
(* Nesting violation: use "must not be descendant" format *)
272
269
Message_collector.add_typed collector
273
-
(Error_code.Element_must_not_be_descendant {
274
-
element = name;
275
-
attr;
276
-
ancestor
277
-
})
270
+
(`Element (`Must_not_descend (`Elem name, `Attr attr, `Ancestor ancestor)))
278
271
end
279
272
) special_ancestors
280
273
end
···
286
279
| "area" ->
287
280
if (state.ancestor_mask land map_mask) = 0 then
288
281
Message_collector.add_typed collector
289
-
(Error_code.Generic {
290
-
message = Printf.sprintf "The %s element must have a %s ancestor."
291
-
(Error_code.q "area") (Error_code.q "map")
292
-
})
282
+
(`Generic (Printf.sprintf "The %s element must have a %s ancestor."
283
+
(Error_code.q "area") (Error_code.q "map")))
293
284
| _ -> ()
294
285
295
286
(** Check for metadata-only elements appearing outside valid contexts.
···
304
295
| parent :: _ ->
305
296
(* style inside any other element is not allowed *)
306
297
Message_collector.add_typed collector
307
-
(Error_code.Element_not_allowed_as_child {
308
-
child = "style";
309
-
parent = parent.name
310
-
})
298
+
(`Element (`Not_allowed_as_child (`Child "style", `Parent parent.name)))
311
299
| [] -> () (* at root level, would be caught elsewhere *)
312
300
end
313
301
| _ -> ()
+5
-5
lib/html5_checker/semantic/obsolete_checker.ml
+5
-5
lib/html5_checker/semantic/obsolete_checker.ml
···
269
269
| None -> ()
270
270
| Some suggestion ->
271
271
Message_collector.add_typed collector
272
-
(Error_code.Obsolete_element { element = name; suggestion }));
272
+
(`Element (`Obsolete (`Elem name, `Suggestion suggestion))));
273
273
274
274
(* Check for obsolete attributes *)
275
275
List.iter (fun (attr_name, _attr_value) ->
···
281
281
error from nesting_checker takes precedence *)
282
282
if state.in_head then
283
283
Message_collector.add_typed collector
284
-
(Error_code.Attr_not_allowed_on_element { attr = attr_name; element = name })
284
+
(`Attr (`Not_allowed (`Attr attr_name, `Elem name)))
285
285
end else begin
286
286
(* Check specific obsolete attributes for this element *)
287
287
(match Hashtbl.find_opt obsolete_attributes attr_lower with
···
291
291
| None -> ()
292
292
| Some suggestion ->
293
293
Message_collector.add_typed collector
294
-
(Error_code.Obsolete_attr { element = name; attr = attr_name; suggestion = Some suggestion })));
294
+
(`Element (`Obsolete_attr (`Elem name, `Attr attr_name, `Suggestion (Some suggestion))))));
295
295
296
296
(* Check obsolete style attributes *)
297
297
(match Hashtbl.find_opt obsolete_style_attrs attr_lower with
···
299
299
| Some elements ->
300
300
if List.mem name_lower elements then
301
301
Message_collector.add_typed collector
302
-
(Error_code.Obsolete_attr { element = name; attr = attr_name; suggestion = Some "Use CSS instead." }));
302
+
(`Element (`Obsolete_attr (`Elem name, `Attr attr_name, `Suggestion (Some "Use CSS instead.")))));
303
303
304
304
(* Check obsolete global attributes *)
305
305
(match Hashtbl.find_opt obsolete_global_attrs attr_lower with
306
306
| None -> ()
307
307
| Some suggestion ->
308
308
Message_collector.add_typed collector
309
-
(Error_code.Obsolete_global_attr { attr = attr_name; suggestion }))
309
+
(`Element (`Obsolete_global_attr (`Attr attr_name, `Suggestion suggestion))))
310
310
end
311
311
) attrs
312
312
end
+2
-5
lib/html5_checker/semantic/option_checker.ml
+2
-5
lib/html5_checker/semantic/option_checker.ml
···
45
45
(* Report error for empty label attribute value *)
46
46
if label_empty then
47
47
Message_collector.add_typed collector
48
-
(Error_code.Bad_attr_value {
49
-
element = "option"; attr = "label"; value = "";
50
-
reason = "Bad non-empty string: Must not be empty."
51
-
});
48
+
(`Attr (`Bad_value (`Elem "option", `Attr "label", `Value "", `Reason "Bad non-empty string: Must not be empty.")));
52
49
let ctx = { has_text = false; has_label; label_empty } in
53
50
state.option_stack <- ctx :: state.option_stack
54
51
end
···
69
66
(* Note: empty label error is already reported at start_element,
70
67
so only report empty option without label when there's no label attribute at all *)
71
68
if not ctx.has_text && not ctx.has_label then
72
-
Message_collector.add_typed collector Error_code.Option_empty_without_label
69
+
Message_collector.add_typed collector (`Misc `Option_empty_without_label)
73
70
| [] -> ()
74
71
end
75
72
end
+29
-41
lib/html5_checker/semantic/required_attr_checker.ml
+29
-41
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_typed collector Error_code.Img_missing_src_or_srcset;
30
+
Message_collector.add_typed collector (`Img `Missing_src_or_srcset);
31
31
32
32
(* Check for alt attribute - always required *)
33
33
if not (has_attr "alt" attrs) then
34
-
Message_collector.add_typed collector Error_code.Img_missing_alt;
34
+
Message_collector.add_typed collector (`Img `Missing_alt);
35
35
36
36
(* Check ismap requires 'a' ancestor with href *)
37
37
if has_attr "ismap" attrs && not state.in_a_with_href then
38
-
Message_collector.add_typed collector Error_code.Img_ismap_needs_a_href
38
+
Message_collector.add_typed collector (`Img `Ismap_needs_href)
39
39
40
40
let check_area_element attrs collector =
41
41
(* area with href requires alt *)
42
42
if has_attr "href" attrs && not (has_attr "alt" attrs) then
43
43
Message_collector.add_typed collector
44
-
(Error_code.Missing_required_attr { element = "area"; attr = "alt" })
44
+
(`Attr (`Missing (`Elem "area", `Attr "alt")))
45
45
46
46
let check_input_element attrs collector =
47
47
match get_attr "type" attrs with
···
49
49
(* input[type=image] requires alt *)
50
50
if not (has_attr "alt" attrs) then
51
51
Message_collector.add_typed collector
52
-
(Error_code.Missing_required_attr { element = "input"; attr = "alt" })
52
+
(`Attr (`Missing (`Elem "input", `Attr "alt")))
53
53
| Some "hidden" ->
54
54
(* input[type=hidden] should not have required attribute *)
55
55
if has_attr "required" attrs then
56
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
-
})
57
+
(`Attr (`Not_allowed_when (`Attr "required", `Elem "input", `Condition "the type attribute is hidden")))
62
58
| Some "file" ->
63
59
(* input[type=file] should not have value attribute *)
64
60
if has_attr "value" attrs then
65
61
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
-
})
62
+
(`Attr (`Not_allowed_when (`Attr "value", `Elem "input", `Condition "the type attribute is file")))
71
63
| _ -> ()
72
64
73
65
let check_script_element attrs _collector =
···
100
92
in
101
93
102
94
if not valid then
95
+
let q s = "\xe2\x80\x9c" ^ s ^ "\xe2\x80\x9d" in
103
96
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
-
})
97
+
(`Generic (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."
98
+
(q "meta") (q "charset") (q "name")
99
+
(q "content") (q "http-equiv") (q "content")))
109
100
110
101
let check_link_element attrs collector =
111
102
(* link[rel="stylesheet"] requires href *)
112
103
match get_attr "rel" attrs with
113
104
| Some rel when String.equal rel "stylesheet" ->
114
105
if not (has_attr "href" attrs) then
115
-
Message_collector.add_typed collector Error_code.Link_missing_href
106
+
Message_collector.add_typed collector (`Link `Missing_href)
116
107
| _ -> ()
117
108
118
109
let check_a_element attrs collector =
119
110
(* a[download] requires href *)
120
111
if has_attr "download" attrs && not (has_attr "href" attrs) then
121
112
Message_collector.add_typed collector
122
-
(Error_code.Missing_required_attr { element = "a"; attr = "href" })
113
+
(`Attr (`Missing (`Elem "a", `Attr "href")))
123
114
124
115
let check_map_element attrs collector =
125
116
(* map requires name *)
126
117
if not (has_attr "name" attrs) then
127
118
Message_collector.add_typed collector
128
-
(Error_code.Missing_required_attr { element = "map"; attr = "name" })
119
+
(`Attr (`Missing (`Elem "map", `Attr "name")))
129
120
130
121
let check_object_element attrs collector =
131
122
(* object requires data attribute (or type attribute alone is not sufficient) *)
···
133
124
let has_type = has_attr "type" attrs in
134
125
if not has_data && has_type then
135
126
Message_collector.add_typed collector
136
-
(Error_code.Missing_required_attr { element = "object"; attr = "data" })
127
+
(`Attr (`Missing (`Elem "object", `Attr "data")))
137
128
138
129
let check_popover_element element_name attrs collector =
139
130
(* popover attribute must have valid value *)
···
142
133
let value_lower = String.lowercase_ascii value in
143
134
(* Valid values: empty string, auto, manual, hint *)
144
135
if value_lower <> "" && value_lower <> "auto" && value_lower <> "manual" && value_lower <> "hint" then
136
+
let q s = "\xe2\x80\x9c" ^ s ^ "\xe2\x80\x9d" in
145
137
Message_collector.add_typed collector
146
-
(Error_code.Bad_attr_value_generic {
147
-
message = Printf.sprintf "Bad value %s for attribute %s on element %s."
148
-
(Error_code.q value) (Error_code.q "popover") (Error_code.q element_name)
149
-
})
138
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value %s for attribute %s on element %s."
139
+
(q value) (q "popover") (q element_name)))))
150
140
| None -> ()
151
141
152
142
let check_meter_element attrs collector =
153
143
(* meter requires value attribute *)
154
144
if not (has_attr "value" attrs) then
155
145
Message_collector.add_typed collector
156
-
(Error_code.Missing_required_attr { element = "meter"; attr = "value" })
146
+
(`Attr (`Missing (`Elem "meter", `Attr "value")))
157
147
else begin
158
148
(* Validate min <= value constraint *)
159
149
match get_attr "value" attrs, get_attr "min" attrs with
···
162
152
let value = float_of_string value_str in
163
153
let min_val = float_of_string min_str in
164
154
if min_val > value then
155
+
let q s = "\xe2\x80\x9c" ^ s ^ "\xe2\x80\x9d" in
165
156
Message_collector.add_typed collector
166
-
(Error_code.Generic {
167
-
message = Printf.sprintf "The value of the %s attribute must be less than or equal to the value of the %s attribute."
168
-
(Error_code.q "min") (Error_code.q "value")
169
-
})
157
+
(`Generic (Printf.sprintf "The value of the %s attribute must be less than or equal to the value of the %s attribute."
158
+
(q "min") (q "value")))
170
159
with _ -> ())
171
160
| _ -> ()
172
161
end
···
183
172
| Some max_str -> (try float_of_string max_str with _ -> 1.0)
184
173
in
185
174
if value > max_val then
175
+
let q s = "\xe2\x80\x9c" ^ s ^ "\xe2\x80\x9d" in
186
176
(* Check which message to use based on whether max is present *)
187
177
if has_attr "max" attrs then
188
178
Message_collector.add_typed collector
189
-
(Error_code.Generic {
179
+
(`Generic (
190
180
(* Note: double space before "value" matches Nu validator quirk *)
191
-
message = Printf.sprintf "The value of the %s attribute must be less than or equal to the value of the %s attribute."
192
-
(Error_code.q "value") (Error_code.q "max")
193
-
})
181
+
Printf.sprintf "The value of the %s attribute must be less than or equal to the value of the %s attribute."
182
+
(q "value") (q "max")))
194
183
else
195
184
Message_collector.add_typed collector
196
-
(Error_code.Generic {
185
+
(`Generic (
197
186
(* Note: double space before "value" matches Nu validator quirk *)
198
-
message = Printf.sprintf "The value of the %s attribute must be less than or equal to one when the %s attribute is absent."
199
-
(Error_code.q "value") (Error_code.q "max")
200
-
})
187
+
Printf.sprintf "The value of the %s attribute must be less than or equal to one when the %s attribute is absent."
188
+
(q "value") (q "max")))
201
189
with _ -> ())
202
190
203
191
let start_element state ~name ~namespace:_ ~attrs collector =
+34
-34
lib/html5_checker/specialized/aria_checker.ml
+34
-34
lib/html5_checker/specialized/aria_checker.ml
···
452
452
List.iter (fun role ->
453
453
if not (Hashtbl.mem valid_aria_roles role) then
454
454
Message_collector.add_typed collector
455
-
(Error_code.Discarding_unrecognized_role { token = role })
455
+
(`Aria (`Unrecognized_role (`Token role)))
456
456
) explicit_roles;
457
457
458
458
(* Get implicit role for this element *)
···
484
484
let first_role = List.hd explicit_roles in
485
485
if first_role <> "none" && first_role <> "presentation" then
486
486
Message_collector.add_typed collector
487
-
(Error_code.Bad_role { element = name; role = first_role })
487
+
(`Aria (`Bad_role (`Elem name, `Role first_role)))
488
488
end;
489
489
490
490
(* Check br/wbr aria-* attribute restrictions - not allowed *)
···
494
494
if String.length attr_lower > 5 && String.sub attr_lower 0 5 = "aria-" &&
495
495
attr_lower <> "aria-hidden" then
496
496
Message_collector.add_typed collector
497
-
(Error_code.Attr_not_allowed_on_element { attr = attr_name; element = name })
497
+
(`Attr (`Not_allowed (`Attr attr_name, `Elem name)))
498
498
) attrs
499
499
end;
500
500
···
504
504
(* Generate error if element cannot have accessible name but has one *)
505
505
if has_aria_label && not can_have_name then
506
506
Message_collector.add_typed collector
507
-
(Error_code.Aria_must_not_be_specified { attr = "aria-label"; element = name;
508
-
condition = "the element has a \xe2\x80\x9crole\xe2\x80\x9d value other than \xe2\x80\x9ccaption\xe2\x80\x9d, \xe2\x80\x9ccode\xe2\x80\x9d, \xe2\x80\x9cdeletion\xe2\x80\x9d, \xe2\x80\x9cemphasis\xe2\x80\x9d, \xe2\x80\x9cgeneric\xe2\x80\x9d, \xe2\x80\x9cinsertion\xe2\x80\x9d, \xe2\x80\x9cparagraph\xe2\x80\x9d, \xe2\x80\x9cpresentation\xe2\x80\x9d, \xe2\x80\x9cstrong\xe2\x80\x9d, \xe2\x80\x9csubscript\xe2\x80\x9d, or \xe2\x80\x9csuperscript\xe2\x80\x9d" });
507
+
(`Aria (`Must_not_specify (`Attr "aria-label", `Elem name,
508
+
`Condition "the element has a \xe2\x80\x9crole\xe2\x80\x9d value other than \xe2\x80\x9ccaption\xe2\x80\x9d, \xe2\x80\x9ccode\xe2\x80\x9d, \xe2\x80\x9cdeletion\xe2\x80\x9d, \xe2\x80\x9cemphasis\xe2\x80\x9d, \xe2\x80\x9cgeneric\xe2\x80\x9d, \xe2\x80\x9cinsertion\xe2\x80\x9d, \xe2\x80\x9cparagraph\xe2\x80\x9d, \xe2\x80\x9cpresentation\xe2\x80\x9d, \xe2\x80\x9cstrong\xe2\x80\x9d, \xe2\x80\x9csubscript\xe2\x80\x9d, or \xe2\x80\x9csuperscript\xe2\x80\x9d")));
509
509
510
510
if has_aria_labelledby && not can_have_name then
511
511
Message_collector.add_typed collector
512
-
(Error_code.Aria_must_not_be_specified { attr = "aria-labelledby"; element = name;
513
-
condition = "the element has a \xe2\x80\x9crole\xe2\x80\x9d value other than \xe2\x80\x9ccaption\xe2\x80\x9d, \xe2\x80\x9ccode\xe2\x80\x9d, \xe2\x80\x9cdeletion\xe2\x80\x9d, \xe2\x80\x9cemphasis\xe2\x80\x9d, \xe2\x80\x9cgeneric\xe2\x80\x9d, \xe2\x80\x9cinsertion\xe2\x80\x9d, \xe2\x80\x9cparagraph\xe2\x80\x9d, \xe2\x80\x9cpresentation\xe2\x80\x9d, \xe2\x80\x9cstrong\xe2\x80\x9d, \xe2\x80\x9csubscript\xe2\x80\x9d, or \xe2\x80\x9csuperscript\xe2\x80\x9d" });
512
+
(`Aria (`Must_not_specify (`Attr "aria-labelledby", `Elem name,
513
+
`Condition "the element has a \xe2\x80\x9crole\xe2\x80\x9d value other than \xe2\x80\x9ccaption\xe2\x80\x9d, \xe2\x80\x9ccode\xe2\x80\x9d, \xe2\x80\x9cdeletion\xe2\x80\x9d, \xe2\x80\x9cemphasis\xe2\x80\x9d, \xe2\x80\x9cgeneric\xe2\x80\x9d, \xe2\x80\x9cinsertion\xe2\x80\x9d, \xe2\x80\x9cparagraph\xe2\x80\x9d, \xe2\x80\x9cpresentation\xe2\x80\x9d, \xe2\x80\x9cstrong\xe2\x80\x9d, \xe2\x80\x9csubscript\xe2\x80\x9d, or \xe2\x80\x9csuperscript\xe2\x80\x9d")));
514
514
515
515
if has_aria_braillelabel && not can_have_name then
516
516
Message_collector.add_typed collector
517
-
(Error_code.Aria_must_not_be_specified { attr = "aria-braillelabel"; element = name;
518
-
condition = "the element has a \xe2\x80\x9crole\xe2\x80\x9d value other than \xe2\x80\x9ccaption\xe2\x80\x9d, \xe2\x80\x9ccode\xe2\x80\x9d, \xe2\x80\x9cdeletion\xe2\x80\x9d, \xe2\x80\x9cemphasis\xe2\x80\x9d, \xe2\x80\x9cgeneric\xe2\x80\x9d, \xe2\x80\x9cinsertion\xe2\x80\x9d, \xe2\x80\x9cparagraph\xe2\x80\x9d, \xe2\x80\x9cpresentation\xe2\x80\x9d, \xe2\x80\x9cstrong\xe2\x80\x9d, \xe2\x80\x9csubscript\xe2\x80\x9d, or \xe2\x80\x9csuperscript\xe2\x80\x9d" });
517
+
(`Aria (`Must_not_specify (`Attr "aria-braillelabel", `Elem name,
518
+
`Condition "the element has a \xe2\x80\x9crole\xe2\x80\x9d value other than \xe2\x80\x9ccaption\xe2\x80\x9d, \xe2\x80\x9ccode\xe2\x80\x9d, \xe2\x80\x9cdeletion\xe2\x80\x9d, \xe2\x80\x9cemphasis\xe2\x80\x9d, \xe2\x80\x9cgeneric\xe2\x80\x9d, \xe2\x80\x9cinsertion\xe2\x80\x9d, \xe2\x80\x9cparagraph\xe2\x80\x9d, \xe2\x80\x9cpresentation\xe2\x80\x9d, \xe2\x80\x9cstrong\xe2\x80\x9d, \xe2\x80\x9csubscript\xe2\x80\x9d, or \xe2\x80\x9csuperscript\xe2\x80\x9d")));
519
519
520
520
(* Check for img with empty alt having role attribute *)
521
521
if name_lower = "img" then begin
···
524
524
| Some alt when String.trim alt = "" ->
525
525
(* img with empty alt must not have role attribute *)
526
526
if role_attr <> None then
527
-
Message_collector.add_typed collector Error_code.Img_empty_alt_with_role
527
+
Message_collector.add_typed collector (`Img `Empty_alt_with_role)
528
528
| _ -> ()
529
529
end;
530
530
···
537
537
if input_type = "checkbox" && List.mem "button" explicit_roles then begin
538
538
let has_aria_pressed = List.assoc_opt "aria-pressed" attrs <> None in
539
539
if not has_aria_pressed then
540
-
Message_collector.add_typed collector Error_code.Checkbox_button_needs_aria_pressed
540
+
Message_collector.add_typed collector (`Input `Checkbox_needs_aria_pressed)
541
541
end
542
542
end;
543
543
···
551
551
| Some _ ->
552
552
let valid_roles = ["group"; "menuitem"; "menuitemcheckbox"; "menuitemradio"; "separator"] in
553
553
if not (List.mem first_role valid_roles) then
554
-
Message_collector.add_typed collector Error_code.Li_bad_role_in_menu
554
+
Message_collector.add_typed collector (`Li_role `Li_bad_role_in_menu)
555
555
| None ->
556
556
(* Check if in tablist context *)
557
557
match get_ancestor_role state ["tablist"] with
558
558
| Some _ ->
559
559
if first_role <> "tab" then
560
-
Message_collector.add_typed collector Error_code.Li_bad_role_in_tablist
560
+
Message_collector.add_typed collector (`Li_role `Li_bad_role_in_tablist)
561
561
| None ->
562
562
(* Check if in list context (ul/ol/menu without explicit role, or role=list) *)
563
563
(* Nu validator produces this error for ANY explicit role on li in list context,
564
564
even role="listitem" - because having an explicit role is itself the problem.
565
565
The message says "other than listitem" but the rule is: don't use explicit roles. *)
566
566
if is_in_list_context state then
567
-
Message_collector.add_typed collector Error_code.Li_bad_role_in_list)
567
+
Message_collector.add_typed collector (`Li_role `Li_bad_role_in_list))
568
568
end
569
569
end;
570
570
···
573
573
let aria_hidden = List.assoc_opt "aria-hidden" attrs in
574
574
match aria_hidden with
575
575
| Some "true" ->
576
-
Message_collector.add_typed collector Error_code.Aria_hidden_on_body
576
+
Message_collector.add_typed collector (`Aria `Hidden_on_body)
577
577
| _ -> ()
578
578
end;
579
579
···
584
584
| Some input_type when String.lowercase_ascii input_type = "checkbox" ->
585
585
if aria_checked <> None then
586
586
Message_collector.add_typed collector
587
-
(Error_code.Aria_must_not_be_used { attr = "aria-checked"; element = "input";
588
-
condition = "a \xe2\x80\x9ctype\xe2\x80\x9d attribute whose value is \xe2\x80\x9ccheckbox\xe2\x80\x9d" })
587
+
(`Aria (`Must_not_use (`Attr "aria-checked", `Elem "input",
588
+
`Condition "a \xe2\x80\x9ctype\xe2\x80\x9d attribute whose value is \xe2\x80\x9ccheckbox\xe2\x80\x9d")))
589
589
| _ -> ()
590
590
end;
591
591
···
599
599
match role_to_check with
600
600
| Some _role when List.mem _role roles_without_aria_expanded ->
601
601
Message_collector.add_typed collector
602
-
(Error_code.Attr_not_allowed_on_element { attr = "aria-expanded"; element = name })
602
+
(`Attr (`Not_allowed (`Attr "aria-expanded", `Elem name)))
603
603
| _ -> ()
604
604
end;
605
605
···
622
622
Printf.sprintf "for element \xe2\x80\x9c%s\xe2\x80\x9d" name
623
623
in
624
624
Message_collector.add_typed collector
625
-
(Error_code.Unnecessary_role { role = first_role; element = name; reason })
625
+
(`Aria (`Unnecessary_role (`Role first_role, `Elem name, `Reason reason)))
626
626
| _ -> ()
627
627
end;
628
628
···
634
634
match role_attr with
635
635
| Some role_value ->
636
636
Message_collector.add_typed collector
637
-
(Error_code.Bad_role { element = name; role = role_value })
637
+
(`Aria (`Bad_role (`Elem name, `Role role_value)))
638
638
| None -> ()
639
639
end;
640
640
···
642
642
(* Check if role cannot be named *)
643
643
if Hashtbl.mem roles_which_cannot_be_named role && has_accessible_name then
644
644
Message_collector.add_typed collector
645
-
(Error_code.Generic { message = Printf.sprintf
645
+
(`Generic (Printf.sprintf
646
646
"Elements with role=\"%s\" must not have accessible names (via aria-label or aria-labelledby)."
647
-
role });
647
+
role));
648
648
649
649
(* Check for required ancestor roles *)
650
650
begin match Hashtbl.find_opt required_role_ancestor_by_descendant role with
651
651
| Some required_ancestors ->
652
652
if not (has_required_ancestor_role state required_ancestors) then
653
653
Message_collector.add_typed collector
654
-
(Error_code.Generic { message = Printf.sprintf
654
+
(`Generic (Printf.sprintf
655
655
"An element with \"role=%s\" must be contained in, or owned by, an element with the \"role\" value %s."
656
656
role
657
-
(render_role_set required_ancestors) })
657
+
(render_role_set required_ancestors)))
658
658
| None -> ()
659
659
end;
660
660
···
666
666
(* Check if current role is in the deprecated list *)
667
667
if Array.mem role deprecated_for_roles then
668
668
Message_collector.add_typed collector
669
-
(Error_code.Aria_should_not_be_used { attr = attr_name; role })
669
+
(`Aria (`Should_not_use (`Attr attr_name, `Role role)))
670
670
| None -> ()
671
671
) attrs
672
672
) explicit_roles;
···
680
680
let value_lower = String.lowercase_ascii (String.trim attr_value) in
681
681
if value_lower = default_value then
682
682
Message_collector.add_typed collector
683
-
(Error_code.Generic { message = Printf.sprintf
683
+
(`Generic (Printf.sprintf
684
684
"The \xe2\x80\x9c%s\xe2\x80\x9d attribute is unnecessary for the value \xe2\x80\x9c%s\xe2\x80\x9d."
685
-
attr_name attr_value })
685
+
attr_name attr_value))
686
686
| None -> ()
687
687
) attrs;
688
688
···
697
697
(* summary that is the first child of details *)
698
698
if has_role_attr then
699
699
(* Must not have role attribute *)
700
-
Message_collector.add_typed collector Error_code.Summary_role_not_allowed
700
+
Message_collector.add_typed collector (`Misc `Summary_role_not_allowed)
701
701
else if has_aria_pressed then
702
702
(* aria-pressed without role requires role *)
703
-
Message_collector.add_typed collector Error_code.Summary_missing_role
703
+
Message_collector.add_typed collector (`Misc `Summary_missing_role)
704
704
else if has_aria_expanded then
705
705
(* aria-expanded without role requires role *)
706
-
Message_collector.add_typed collector Error_code.Summary_missing_attrs
706
+
Message_collector.add_typed collector (`Misc `Summary_missing_attrs)
707
707
end else begin
708
708
(* summary NOT in details context - different rules apply *)
709
709
(* If has aria-expanded or aria-pressed, must have role *)
710
710
if (has_aria_expanded || has_aria_pressed) && explicit_roles = [] then begin
711
711
if has_aria_pressed then
712
-
Message_collector.add_typed collector Error_code.Summary_missing_role
712
+
Message_collector.add_typed collector (`Misc `Summary_missing_role)
713
713
else
714
-
Message_collector.add_typed collector Error_code.Summary_missing_attrs
714
+
Message_collector.add_typed collector (`Misc `Summary_missing_attrs)
715
715
end
716
716
end
717
717
end;
···
739
739
let end_document state collector =
740
740
(* Check that active tabs have corresponding tabpanels *)
741
741
if state.has_active_tab && not state.has_tabpanel then
742
-
Message_collector.add_typed collector Error_code.Tab_without_tabpanel;
742
+
Message_collector.add_typed collector (`Aria `Tab_without_tabpanel);
743
743
744
744
(* Check for multiple visible main elements *)
745
745
if state.visible_main_count > 1 then
746
-
Message_collector.add_typed collector Error_code.Multiple_main_visible
746
+
Message_collector.add_typed collector (`Aria `Multiple_main)
747
747
748
748
let checker = (module struct
749
749
type nonrec state = state
+35
-35
lib/html5_checker/specialized/attr_restrictions_checker.ml
+35
-35
lib/html5_checker/specialized/attr_restrictions_checker.ml
···
60
60
(** Report disallowed attribute error *)
61
61
let report_disallowed_attr element attr collector =
62
62
Message_collector.add_typed collector
63
-
(Error_code.Attr_not_allowed_on_element { attr; element })
63
+
(`Attr (`Not_allowed (`Attr attr, `Elem element)))
64
64
65
65
let start_element state ~name ~namespace ~attrs collector =
66
66
let name_lower = String.lowercase_ascii name in
···
100
100
(* Only xmlns:xlink (with correct value) and xmlns:xml are allowed *)
101
101
if prefix <> "xlink" && prefix <> "xml" then
102
102
Message_collector.add_typed collector
103
-
(Error_code.Attr_not_allowed_here { attr = attr_name })
103
+
(`Attr (`Not_allowed_here (`Attr attr_name)))
104
104
end
105
105
) attrs
106
106
end;
···
116
116
if name_lower = "feconvolvematrix" then begin
117
117
if not (has_attr "order" attrs) then
118
118
Message_collector.add_typed collector
119
-
(Error_code.Missing_required_svg_attr { element = "feConvolveMatrix"; attr = "order" })
119
+
(`Svg (`Missing_attr (`Elem "feConvolveMatrix", `Attr "order")))
120
120
end;
121
121
122
122
(* Validate style type attribute - must be "text/css" or omitted *)
···
126
126
if attr_lower = "type" then begin
127
127
let value_lower = String.lowercase_ascii (String.trim attr_value) in
128
128
if value_lower <> "text/css" then
129
-
Message_collector.add_typed collector Error_code.Style_type_invalid
129
+
Message_collector.add_typed collector (`Misc `Style_type_invalid)
130
130
end
131
131
) attrs
132
132
end;
···
137
137
let has_type = has_attr "type" attrs in
138
138
if not has_data && not has_type then
139
139
Message_collector.add_typed collector
140
-
(Error_code.Missing_required_attr { element = "object"; attr = "data" })
140
+
(`Attr (`Missing (`Elem "object", `Attr "data")))
141
141
end;
142
142
143
143
(* Validate link imagesizes/imagesrcset attributes *)
···
149
149
150
150
(* imagesizes requires imagesrcset *)
151
151
if has_imagesizes && not has_imagesrcset then
152
-
Message_collector.add_typed collector Error_code.Imagesizes_without_imagesrcset;
152
+
Message_collector.add_typed collector (`Srcset `Imagesizes_without_imagesrcset);
153
153
154
154
(* imagesrcset requires as="image" *)
155
155
if has_imagesrcset then begin
···
158
158
| None -> false
159
159
in
160
160
if not as_is_image then
161
-
Message_collector.add_typed collector Error_code.Link_imagesrcset_requires_as_image
161
+
Message_collector.add_typed collector (`Link `Imagesrcset_requires_as_image)
162
162
end;
163
163
164
164
(* as attribute requires rel="preload" or rel="modulepreload" *)
···
173
173
| None -> false
174
174
in
175
175
if not rel_is_preload then
176
-
Message_collector.add_typed collector Error_code.Link_as_requires_preload
176
+
Message_collector.add_typed collector (`Link `As_requires_preload)
177
177
| None -> ())
178
178
end;
179
179
···
184
184
if attr_lower = "usemap" then begin
185
185
if attr_value = "#" then
186
186
Message_collector.add_typed collector
187
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf
187
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf
188
188
"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 hash-name reference: A hash-name reference must have at least one character after \xe2\x80\x9c#\xe2\x80\x9d."
189
-
attr_value attr_name name })
189
+
attr_value attr_name name))))
190
190
end
191
191
) attrs
192
192
end;
···
200
200
| Ok () -> ()
201
201
| Error msg ->
202
202
Message_collector.add_typed collector
203
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf
203
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf
204
204
"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 MIME type: %s"
205
-
attr_value attr_name name msg })
205
+
attr_value attr_name name msg))))
206
206
end
207
207
) attrs
208
208
end;
···
251
251
attr_value attr_name name
252
252
in
253
253
Message_collector.add_typed collector
254
-
(Error_code.Bad_attr_value_generic { message = error_msg })
254
+
(`Attr (`Bad_value_generic (`Message error_msg)))
255
255
end
256
256
end
257
257
) attrs
···
264
264
| Some s when String.lowercase_ascii (String.trim s) = "default" ->
265
265
if has_attr "coords" attrs then
266
266
Message_collector.add_typed collector
267
-
(Error_code.Attr_not_allowed_on_element { attr = "coords"; element = "area" })
267
+
(`Attr (`Not_allowed (`Attr "coords", `Elem "area")))
268
268
| _ -> ()
269
269
end;
270
270
···
273
273
let dir_value = get_attr "dir" attrs in
274
274
match dir_value with
275
275
| None ->
276
-
Message_collector.add_typed collector Error_code.Bdo_missing_dir
276
+
Message_collector.add_typed collector (`Misc `Bdo_missing_dir)
277
277
| Some v when String.lowercase_ascii (String.trim v) = "auto" ->
278
-
Message_collector.add_typed collector Error_code.Bdo_dir_auto
278
+
Message_collector.add_typed collector (`Misc `Bdo_dir_auto)
279
279
| _ -> ()
280
280
end;
281
281
···
287
287
| None -> "text" (* default type is text *)
288
288
in
289
289
if not (List.mem input_type input_types_allowing_list) then
290
-
Message_collector.add_typed collector Error_code.Input_list_not_allowed
290
+
Message_collector.add_typed collector (`Input `List_not_allowed)
291
291
end
292
292
end;
293
293
···
304
304
(* Check if the name contains colon - not XML serializable *)
305
305
else if String.contains after_prefix ':' then
306
306
Message_collector.add_typed collector
307
-
(Error_code.Data_attr_invalid_name { reason = "must be XML 1.0 4th ed. plus Namespaces NCNames" })
307
+
(`Attr (`Data_invalid_name (`Reason "must be XML 1.0 4th ed. plus Namespaces NCNames")))
308
308
end
309
309
) attrs
310
310
end;
···
318
318
(match lang_value with
319
319
| None ->
320
320
(* xml:lang without lang attribute *)
321
-
Message_collector.add_typed collector Error_code.Xml_lang_without_lang
321
+
Message_collector.add_typed collector (`I18n `Xml_lang_without_lang)
322
322
| Some lang when String.lowercase_ascii lang <> String.lowercase_ascii xmllang ->
323
323
(* xml:lang and lang have different values - "lang present with same value" message *)
324
-
Message_collector.add_typed collector Error_code.Xml_lang_without_lang
324
+
Message_collector.add_typed collector (`I18n `Xml_lang_without_lang)
325
325
| _ -> ())
326
326
| None -> ()
327
327
end;
···
334
334
let value_lower = String.lowercase_ascii (String.trim attr_value) in
335
335
if value_lower <> "" && value_lower <> "true" && value_lower <> "false" then
336
336
Message_collector.add_typed collector
337
-
(Error_code.Bad_attr_value { element = name; attr = attr_name; value = attr_value; reason = "" })
337
+
(`Attr (`Bad_value (`Elem name, `Attr attr_name, `Value attr_value, `Reason "")))
338
338
end
339
339
) attrs
340
340
end;
···
348
348
let value_lower = String.lowercase_ascii (String.trim attr_value) in
349
349
if not (List.mem value_lower valid_enterkeyhint) then
350
350
Message_collector.add_typed collector
351
-
(Error_code.Bad_attr_value { element = name; attr = attr_name; value = attr_value; reason = "" })
351
+
(`Attr (`Bad_value (`Elem name, `Attr attr_name, `Value attr_value, `Reason "")))
352
352
end
353
353
) attrs
354
354
end;
···
368
368
with _ -> false)
369
369
in
370
370
if not is_valid then
371
-
Message_collector.add_typed collector Error_code.Headingoffset_invalid
371
+
Message_collector.add_typed collector (`Misc `Headingoffset_invalid)
372
372
end
373
373
) attrs
374
374
end;
···
401
401
List.iter (fun key ->
402
402
if count_codepoints key > 1 then
403
403
Message_collector.add_typed collector
404
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf
404
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf
405
405
"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 key label list: Key label has multiple characters. Each key label must be a single character."
406
-
attr_value attr_name name })
406
+
attr_value attr_name name))))
407
407
) keys;
408
408
(* Check for duplicate keys *)
409
409
let rec find_duplicates seen = function
···
411
411
| k :: rest ->
412
412
if List.mem k seen then
413
413
Message_collector.add_typed collector
414
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf
414
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf
415
415
"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 key label list: Duplicate key label. Each key label must be unique."
416
-
attr_value attr_name name })
416
+
attr_value attr_name name))))
417
417
else
418
418
find_duplicates (k :: seen) rest
419
419
in
···
430
430
431
431
if has_command && has_aria_expanded then
432
432
Message_collector.add_typed collector
433
-
(Error_code.Attr_not_allowed_when { attr = "aria-expanded"; element = name;
434
-
condition = "a \xe2\x80\x9ccommand\xe2\x80\x9d attribute" });
433
+
(`Attr (`Not_allowed_when (`Attr "aria-expanded", `Elem name,
434
+
`Condition "a \xe2\x80\x9ccommand\xe2\x80\x9d attribute")));
435
435
436
436
if has_popovertarget && has_aria_expanded then
437
437
Message_collector.add_typed collector
438
-
(Error_code.Attr_not_allowed_when { attr = "aria-expanded"; element = name;
439
-
condition = "a \xe2\x80\x9cpopovertarget\xe2\x80\x9d attribute" })
438
+
(`Attr (`Not_allowed_when (`Attr "aria-expanded", `Elem name,
439
+
`Condition "a \xe2\x80\x9cpopovertarget\xe2\x80\x9d attribute")))
440
440
end;
441
441
442
442
(* Note: data-* uppercase check requires XML parsing which preserves case.
···
456
456
| Ok () -> ()
457
457
| Error msg ->
458
458
Message_collector.add_typed collector
459
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf
459
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf
460
460
"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 media query: %s"
461
-
attr_value attr_name name msg })
461
+
attr_value attr_name name msg))))
462
462
end
463
463
end
464
464
) attrs
···
475
475
(* Check for empty prefix (starts with : or has space:) *)
476
476
if String.length trimmed > 0 && trimmed.[0] = ':' then
477
477
Message_collector.add_typed collector
478
-
(Error_code.Bad_attr_value { element = name; attr = attr_name; value = attr_value; reason = "" })
478
+
(`Attr (`Bad_value (`Elem name, `Attr attr_name, `Value attr_value, `Reason "")))
479
479
else begin
480
480
(* Check for invalid prefix names - must start with letter or underscore *)
481
481
let is_ncname_start c =
···
483
483
in
484
484
if String.length trimmed > 0 && not (is_ncname_start trimmed.[0]) then
485
485
Message_collector.add_typed collector
486
-
(Error_code.Bad_attr_value { element = name; attr = attr_name; value = attr_value; reason = "" })
486
+
(`Attr (`Bad_value (`Elem name, `Attr attr_name, `Value attr_value, `Reason "")))
487
487
end
488
488
end
489
489
end
+2
-2
lib/html5_checker/specialized/base_checker.ml
+2
-2
lib/html5_checker/specialized/base_checker.ml
···
24
24
state.seen_link_or_script <- true
25
25
| "base" ->
26
26
if state.seen_link_or_script then
27
-
Message_collector.add_typed collector Error_code.Base_after_link_script;
27
+
Message_collector.add_typed collector (`Misc `Base_after_link_script);
28
28
(* base element must have href or target attribute *)
29
29
let has_href = has_attr "href" attrs in
30
30
let has_target = has_attr "target" attrs in
31
31
if not has_href && not has_target then
32
-
Message_collector.add_typed collector Error_code.Base_missing_href_or_target
32
+
Message_collector.add_typed collector (`Misc `Base_missing_href_or_target)
33
33
| _ -> ()
34
34
end
35
35
+2
-2
lib/html5_checker/specialized/datetime_checker.ml
+2
-2
lib/html5_checker/specialized/datetime_checker.ml
···
463
463
| Ok -> ()
464
464
| Error error_msg ->
465
465
Message_collector.add_typed collector
466
-
(Error_code.Bad_attr_value_generic { message = error_msg })
466
+
(`Attr (`Bad_value_generic (`Message error_msg)))
467
467
| Warning warn_msg ->
468
468
Message_collector.add_typed collector
469
-
(Error_code.Generic { message = warn_msg })
469
+
(`Generic warn_msg)
470
470
end
471
471
end
472
472
+20
-20
lib/html5_checker/specialized/dl_checker.ml
+20
-20
lib/html5_checker/specialized/dl_checker.ml
···
86
86
begin match current_div state with
87
87
| Some _ ->
88
88
Message_collector.add_typed collector
89
-
(Error_code.Element_not_allowed_as_child { child = "dl"; parent = "div" })
89
+
(`Element (`Not_allowed_as_child (`Child "dl", `Parent "div")))
90
90
| None ->
91
91
match current_dl state with
92
92
| Some _ when state.in_dt_dd = 0 ->
93
93
Message_collector.add_typed collector
94
-
(Error_code.Element_not_allowed_as_child { child = "dl"; parent = "dl" })
94
+
(`Element (`Not_allowed_as_child (`Child "dl", `Parent "dl")))
95
95
| _ -> ()
96
96
end;
97
97
let ctx = {
···
113
113
(* Check for mixed content - if we already have dt/dd, div is not allowed *)
114
114
if dl_ctx.contains_dt_dd then
115
115
Message_collector.add_typed collector
116
-
(Error_code.Element_not_allowed_as_child { child = "div"; parent = "dl" });
116
+
(`Element (`Not_allowed_as_child (`Child "div", `Parent "dl")));
117
117
(* Check that role is only presentation or none *)
118
118
(match get_attr "role" attrs with
119
119
| Some role_value ->
120
120
let role_lower = String.lowercase_ascii (String.trim role_value) in
121
121
if role_lower <> "presentation" && role_lower <> "none" then
122
-
Message_collector.add_typed collector Error_code.Div_child_of_dl_bad_role
122
+
Message_collector.add_typed collector (`Li_role `Div_in_dl_bad_role)
123
123
| None -> ());
124
124
let div_ctx = { has_dt = false; has_dd = false; group_count = 0; in_dd_part = false } in
125
125
state.div_in_dl_stack <- div_ctx :: state.div_in_dl_stack
126
126
| Some _ when state.div_in_dl_stack <> [] ->
127
127
Message_collector.add_typed collector
128
-
(Error_code.Element_not_allowed_as_child { child = "div"; parent = "div" })
128
+
(`Element (`Not_allowed_as_child (`Child "div", `Parent "div")))
129
129
| _ -> ()
130
130
end
131
131
···
136
136
(* If we've already seen dd, this dt starts a new group - which is not allowed *)
137
137
if div_ctx.in_dd_part then begin
138
138
Message_collector.add_typed collector
139
-
(Error_code.Element_not_allowed_as_child { child = "dt"; parent = "div" });
139
+
(`Element (`Not_allowed_as_child (`Child "dt", `Parent "div")));
140
140
div_ctx.group_count <- div_ctx.group_count + 1;
141
141
div_ctx.in_dd_part <- false
142
142
end;
···
150
150
(* Check for mixed content - if we already have div, dt is not allowed *)
151
151
if dl_ctx.contains_div then
152
152
Message_collector.add_typed collector
153
-
(Error_code.Element_not_allowed_as_child { child = "dt"; parent = "dl" })
153
+
(`Element (`Not_allowed_as_child (`Child "dt", `Parent "dl")))
154
154
| None ->
155
155
(* dt outside dl context - error *)
156
156
let parent = match current_parent state with
···
158
158
| None -> "document"
159
159
in
160
160
Message_collector.add_typed collector
161
-
(Error_code.Element_not_allowed_as_child { child = "dt"; parent })
161
+
(`Element (`Not_allowed_as_child (`Child "dt", `Parent parent)))
162
162
end
163
163
164
164
| "dd" when state.in_template = 0 ->
···
178
178
if not dl_ctx.has_dt && not dl_ctx.dd_before_dt_error_reported then begin
179
179
dl_ctx.dd_before_dt_error_reported <- true;
180
180
Message_collector.add_typed collector
181
-
(Error_code.Missing_required_child_generic { parent = "dl" })
181
+
(`Element (`Missing_child_generic (`Parent "dl")))
182
182
end;
183
183
dl_ctx.has_dd <- true;
184
184
dl_ctx.last_was_dt <- false;
···
186
186
(* Check for mixed content *)
187
187
if dl_ctx.contains_div then
188
188
Message_collector.add_typed collector
189
-
(Error_code.Element_not_allowed_as_child { child = "dd"; parent = "dl" })
189
+
(`Element (`Not_allowed_as_child (`Child "dd", `Parent "dl")))
190
190
| None ->
191
191
(* dd outside dl context - error *)
192
192
let parent = match current_parent state with
···
194
194
| None -> "document"
195
195
in
196
196
Message_collector.add_typed collector
197
-
(Error_code.Element_not_allowed_as_child { child = "dd"; parent })
197
+
(`Element (`Not_allowed_as_child (`Child "dd", `Parent parent)))
198
198
end
199
199
200
200
| _ -> ()
···
226
226
(* Direct dt/dd content - must have both *)
227
227
if not ctx.has_dt && not ctx.dd_before_dt_error_reported then
228
228
Message_collector.add_typed collector
229
-
(Error_code.Missing_required_child_generic { parent = "dl" })
229
+
(`Element (`Missing_child_generic (`Parent "dl")))
230
230
else if not ctx.has_dd then begin
231
231
if ctx.has_template then
232
232
Message_collector.add_typed collector
233
-
(Error_code.Missing_required_child_one_of { parent = "dl"; children = ["dd"] })
233
+
(`Element (`Missing_child_one_of (`Parent "dl", `Children ["dd"])))
234
234
else
235
235
Message_collector.add_typed collector
236
-
(Error_code.Missing_required_child { parent = "dl"; child = "dd" })
236
+
(`Element (`Missing_child (`Parent "dl", `Child "dd")))
237
237
end
238
238
else if ctx.last_was_dt then
239
239
Message_collector.add_typed collector
240
-
(Error_code.Missing_required_child { parent = "dl"; child = "dd" })
240
+
(`Element (`Missing_child (`Parent "dl", `Child "dd")))
241
241
end else if not ctx.contains_div && not ctx.has_dt && not ctx.has_dd then
242
242
()
243
243
| [] -> ()
···
250
250
(* Check div in dl must have both dt and dd *)
251
251
if not div_ctx.has_dt && not div_ctx.has_dd then
252
252
Message_collector.add_typed collector
253
-
(Error_code.Missing_required_child { parent = "div"; child = "dd" })
253
+
(`Element (`Missing_child (`Parent "div", `Child "dd")))
254
254
else if not div_ctx.has_dt then
255
255
Message_collector.add_typed collector
256
-
(Error_code.Missing_required_child { parent = "div"; child = "dt" })
256
+
(`Element (`Missing_child (`Parent "div", `Child "dt")))
257
257
else if not div_ctx.has_dd then
258
258
Message_collector.add_typed collector
259
-
(Error_code.Missing_required_child { parent = "div"; child = "dd" })
259
+
(`Element (`Missing_child (`Parent "div", `Child "dd")))
260
260
| [] -> ()
261
261
end
262
262
···
273
273
match current_div state with
274
274
| Some _ ->
275
275
Message_collector.add_typed collector
276
-
(Error_code.Text_not_allowed { parent = "div" })
276
+
(`Element (`Text_not_allowed (`Parent "div")))
277
277
| None ->
278
278
match current_dl state with
279
279
| Some _ ->
280
280
Message_collector.add_typed collector
281
-
(Error_code.Text_not_allowed { parent = "dl" })
281
+
(`Element (`Text_not_allowed (`Parent "dl")))
282
282
| None -> ()
283
283
end
284
284
end
+1
-1
lib/html5_checker/specialized/h1_checker.ml
+1
-1
lib/html5_checker/specialized/h1_checker.ml
···
25
25
else if name_lower = "h1" then begin
26
26
state.h1_count <- state.h1_count + 1;
27
27
if state.h1_count > 1 then
28
-
Message_collector.add_typed collector Error_code.Multiple_h1
28
+
Message_collector.add_typed collector (`Misc `Multiple_h1)
29
29
end
30
30
31
31
let end_element state ~name ~namespace:_ _collector =
+8
-8
lib/html5_checker/specialized/heading_checker.ml
+8
-8
lib/html5_checker/specialized/heading_checker.ml
···
67
67
state.first_heading_checked <- true;
68
68
if level <> 1 then
69
69
Message_collector.add_typed collector
70
-
(Error_code.Generic { message = Printf.sprintf
71
-
"First heading in document is <%s>, should typically be <h1>" name })
70
+
(`Generic (Printf.sprintf
71
+
"First heading in document is <%s>, should typically be <h1>" name))
72
72
end;
73
73
74
74
(* Track h1 count *)
75
75
if level = 1 then begin
76
76
state.h1_count <- state.h1_count + 1;
77
77
if state.h1_count > 1 then
78
-
Message_collector.add_typed collector Error_code.Multiple_h1
78
+
Message_collector.add_typed collector (`Misc `Multiple_h1)
79
79
end;
80
80
81
81
(* Check for skipped levels *)
···
86
86
let diff = level - prev_level in
87
87
if diff > 1 then
88
88
Message_collector.add_typed collector
89
-
(Error_code.Generic { message = Printf.sprintf
89
+
(`Generic (Printf.sprintf
90
90
"Heading level skipped: <%s> follows <h%d>, skipping %d level%s. This can confuse screen reader users"
91
-
name prev_level (diff - 1) (if diff > 2 then "s" else "") });
91
+
name prev_level (diff - 1) (if diff > 2 then "s" else "")));
92
92
state.current_level <- Some level
93
93
end;
94
94
···
105
105
| Some heading when heading = name ->
106
106
if not state.heading_has_text then
107
107
Message_collector.add_typed collector
108
-
(Error_code.Generic { message = Printf.sprintf
109
-
"Heading <%s> is empty or contains only whitespace. Empty headings are problematic for screen readers" name });
108
+
(`Generic (Printf.sprintf
109
+
"Heading <%s> is empty or contains only whitespace. Empty headings are problematic for screen readers" name));
110
110
state.in_heading <- None;
111
111
state.heading_has_text <- false
112
112
| _ -> ()
···
123
123
let end_document state collector =
124
124
if not state.has_any_heading then
125
125
Message_collector.add_typed collector
126
-
(Error_code.Generic { message = "Document contains no heading elements (h1-h6). Headings provide important document structure for accessibility" })
126
+
(`Generic "Document contains no heading elements (h1-h6). Headings provide important document structure for accessibility")
127
127
128
128
let checker = (module struct
129
129
type nonrec state = state
+11
-11
lib/html5_checker/specialized/importmap_checker.ml
+11
-11
lib/html5_checker/specialized/importmap_checker.ml
···
283
283
end
284
284
285
285
let error_to_typed = function
286
-
| InvalidJSON _ -> Error_code.Importmap_invalid_json
287
-
| EmptyKey _ -> Error_code.Importmap_empty_key
288
-
| NotObject prop when prop = "root" -> Error_code.Importmap_invalid_root
289
-
| NotObject prop when prop = "imports" -> Error_code.Importmap_imports_not_object
290
-
| NotObject _ -> Error_code.Importmap_scopes_not_object (* scopes *)
291
-
| NotString _ -> Error_code.Importmap_non_string_value
292
-
| ForbiddenProperty _ -> Error_code.Importmap_invalid_root
293
-
| SlashKeyWithoutSlashValue _ -> Error_code.Importmap_key_trailing_slash
294
-
| InvalidScopeKey -> Error_code.Importmap_scopes_invalid_url
295
-
| InvalidScopeValue _ -> Error_code.Importmap_scopes_value_invalid_url
296
-
| ScopeValueNotObject -> Error_code.Importmap_scopes_values_not_object
286
+
| InvalidJSON _ -> `Importmap `Invalid_json
287
+
| EmptyKey _ -> `Importmap `Empty_key
288
+
| NotObject prop when prop = "root" -> `Importmap `Invalid_root
289
+
| NotObject prop when prop = "imports" -> `Importmap `Imports_not_object
290
+
| NotObject _ -> `Importmap `Scopes_not_object (* scopes *)
291
+
| NotString _ -> `Importmap `Non_string_value
292
+
| ForbiddenProperty _ -> `Importmap `Invalid_root
293
+
| SlashKeyWithoutSlashValue _ -> `Importmap `Key_trailing_slash
294
+
| InvalidScopeKey -> `Importmap `Scopes_invalid_url
295
+
| InvalidScopeValue _ -> `Importmap `Scopes_value_invalid_url
296
+
| ScopeValueNotObject -> `Importmap `Scopes_values_not_object
297
297
298
298
let end_element state ~name ~namespace collector =
299
299
if namespace <> None then ()
+6
-6
lib/html5_checker/specialized/label_checker.ml
+6
-6
lib/html5_checker/specialized/label_checker.ml
···
84
84
if List.mem name_lower labelable_elements then begin
85
85
state.labelable_count <- state.labelable_count + 1;
86
86
if state.labelable_count > 1 then
87
-
Message_collector.add_typed collector Error_code.Label_too_many_labelable;
87
+
Message_collector.add_typed collector (`Label `Too_many_labelable);
88
88
89
89
(* Check if label has for attribute and descendant has mismatched id *)
90
90
(match state.label_for_value with
···
92
92
let descendant_id = get_attr attrs "id" in
93
93
(match descendant_id with
94
94
| None ->
95
-
Message_collector.add_typed collector Error_code.Label_for_id_mismatch
95
+
Message_collector.add_typed collector (`Label `For_id_mismatch)
96
96
| Some id when id <> for_value ->
97
-
Message_collector.add_typed collector Error_code.Label_for_id_mismatch
97
+
Message_collector.add_typed collector (`Label `For_id_mismatch)
98
98
| Some _ -> ())
99
99
| None -> ())
100
100
end
···
111
111
112
112
if name_lower = "label" && state.label_depth = 0 then begin
113
113
if state.label_has_role && state.labelable_count > 0 then
114
-
Message_collector.add_typed collector Error_code.Role_on_label_ancestor;
114
+
Message_collector.add_typed collector (`Label `Role_on_ancestor);
115
115
state.in_label <- false;
116
116
state.labelable_count <- 0;
117
117
state.label_for_value <- None;
···
127
127
List.iter (fun label_info ->
128
128
if List.mem label_info.for_target state.labelable_ids then begin
129
129
if label_info.has_role then
130
-
Message_collector.add_typed collector Error_code.Role_on_label_for;
130
+
Message_collector.add_typed collector (`Label `Role_on_for);
131
131
if label_info.has_aria_label then
132
-
Message_collector.add_typed collector Error_code.Aria_label_on_label_for
132
+
Message_collector.add_typed collector (`Label `Aria_label_on_for)
133
133
end
134
134
) state.labels_for
135
135
+3
-3
lib/html5_checker/specialized/language_checker.ml
+3
-3
lib/html5_checker/specialized/language_checker.ml
···
44
44
| Error msg ->
45
45
let reason = Printf.sprintf "Bad language tag: %s." msg in
46
46
Message_collector.add_typed collector
47
-
(Error_code.Bad_attr_value { element; attr = attribute; value; reason })
47
+
(`Attr (`Bad_value (`Elem element, `Attr attribute, `Value value, `Reason reason)))
48
48
| Ok () ->
49
49
(* Then check for deprecated subtags *)
50
50
match check_deprecated_tag value with
···
52
52
let reason = Printf.sprintf "Bad language tag: The language subtag %s is deprecated. Use %s instead."
53
53
(Error_code.q deprecated) (Error_code.q replacement) in
54
54
Message_collector.add_typed collector
55
-
(Error_code.Generic { message = Printf.sprintf "Bad value %s for attribute %s on element %s: %s"
56
-
(Error_code.q value) (Error_code.q attribute) (Error_code.q element) reason })
55
+
(`Generic (Printf.sprintf "Bad value %s for attribute %s on element %s: %s"
56
+
(Error_code.q value) (Error_code.q attribute) (Error_code.q element) reason))
57
57
| None -> ()
58
58
59
59
(** Check if lang and xml:lang match. *)
+13
-13
lib/html5_checker/specialized/microdata_checker.ml
+13
-13
lib/html5_checker/specialized/microdata_checker.ml
···
130
130
| Some itemid ->
131
131
if not has_itemscope then
132
132
Message_collector.add_typed collector
133
-
(Error_code.Generic { message = "itemid attribute requires itemscope attribute" });
133
+
(`Generic "itemid attribute requires itemscope attribute");
134
134
if itemtype_opt = None then
135
135
Message_collector.add_typed collector
136
-
(Error_code.Generic { message = "itemid attribute requires itemtype attribute" });
136
+
(`Generic "itemid attribute requires itemtype attribute");
137
137
(match Url_checker.validate_url itemid element "itemid" with
138
138
| None -> ()
139
139
| Some error_msg ->
140
-
Message_collector.add_typed collector (Error_code.Bad_attr_value_generic { message = error_msg }))
140
+
Message_collector.add_typed collector (`Attr (`Bad_value_generic (`Message error_msg))))
141
141
| None -> ()
142
142
end;
143
143
···
145
145
| Some itemref_value ->
146
146
if not has_itemscope then
147
147
Message_collector.add_typed collector
148
-
(Error_code.Generic { message = "itemref attribute requires itemscope attribute" })
148
+
(`Generic "itemref attribute requires itemscope attribute")
149
149
else begin
150
150
let ids = split_whitespace itemref_value in
151
151
state.itemref_references <- {
···
161
161
| Some itemtype ->
162
162
if not has_itemscope then
163
163
Message_collector.add_typed collector
164
-
(Error_code.Generic { message = "itemtype attribute requires itemscope attribute" })
164
+
(`Generic "itemtype attribute requires itemscope attribute")
165
165
else begin
166
166
let types = split_whitespace itemtype in
167
167
if types = [] then
168
168
Message_collector.add_typed collector
169
-
(Error_code.Bad_attr_value { element; attr = "itemtype"; value = itemtype; reason = "" })
169
+
(`Attr (`Bad_value (`Elem element, `Attr "itemtype", `Value itemtype, `Reason "")))
170
170
else
171
171
List.iter (fun url ->
172
172
match validate_microdata_url url element "itemtype" itemtype with
173
173
| None -> ()
174
174
| Some error_msg ->
175
-
Message_collector.add_typed collector (Error_code.Bad_attr_value_generic { message = error_msg })
175
+
Message_collector.add_typed collector (`Attr (`Bad_value_generic (`Message error_msg)))
176
176
) types
177
177
end
178
178
| None -> ()
···
187
187
| Ok () -> ()
188
188
| Error msg ->
189
189
Message_collector.add_typed collector
190
-
(Error_code.Generic { message = msg })
190
+
(`Generic msg)
191
191
) props;
192
192
193
193
(* Check itemprop can only appear on property elements *)
194
194
if not (is_property_element state) then
195
195
Message_collector.add_typed collector
196
-
(Error_code.Generic { message = "itemprop attribute can only appear on elements that are \
197
-
properties of an item (descendant of itemscope or referenced by itemref)" })
196
+
(`Generic "itemprop attribute can only appear on elements that are \
197
+
properties of an item (descendant of itemscope or referenced by itemref)")
198
198
| None -> ()
199
199
end;
200
200
···
261
261
| Some cycle ->
262
262
let cycle_str = String.concat " -> " (List.rev cycle) in
263
263
Message_collector.add_typed collector
264
-
(Error_code.Generic { message = Printf.sprintf "itemref cycle detected: %s" cycle_str })
264
+
(`Generic (Printf.sprintf "itemref cycle detected: %s" cycle_str))
265
265
| None -> ()
266
266
end;
267
267
check_all_nodes (node :: visited) rest
···
291
291
List.iter (fun id ->
292
292
if not (Hashtbl.mem state.all_ids id) then
293
293
Message_collector.add_typed collector
294
-
(Error_code.Generic { message = Printf.sprintf
294
+
(`Generic (Printf.sprintf
295
295
"itemref on <%s> refers to ID '%s' which does not exist"
296
-
ref.referring_element id })
296
+
ref.referring_element id))
297
297
) ref.referenced_ids
298
298
) state.itemref_references;
299
299
+2
-2
lib/html5_checker/specialized/mime_type_checker.ml
+2
-2
lib/html5_checker/specialized/mime_type_checker.ml
···
179
179
| None -> ()
180
180
| Some err ->
181
181
Message_collector.add_typed collector
182
-
(Error_code.Bad_attr_value_generic { message = err })
182
+
(`Attr (`Bad_value_generic (`Message err)))
183
183
else
184
184
match validate_mime_type value name attr_name with
185
185
| None -> ()
186
186
| Some err ->
187
187
Message_collector.add_typed collector
188
-
(Error_code.Bad_attr_value_generic { message = err })
188
+
(`Attr (`Bad_value_generic (`Message err)))
189
189
) type_attrs
190
190
end
191
191
+1
-1
lib/html5_checker/specialized/normalization_checker.ml
+1
-1
lib/html5_checker/specialized/normalization_checker.ml
···
53
53
(* Strip trailing ASCII punctuation from replacement to match Nu validator *)
54
54
let replacement = strip_trailing_punct normalized in
55
55
Message_collector.add_typed collector
56
-
(Error_code.Not_nfc { replacement })
56
+
(`I18n (`Not_nfc (`Replacement replacement)))
57
57
end
58
58
59
59
let end_document _state _collector = ()
+12
-12
lib/html5_checker/specialized/picture_checker.ml
+12
-12
lib/html5_checker/specialized/picture_checker.ml
···
73
73
(** Report disallowed attribute error *)
74
74
let report_disallowed_attr element attr collector =
75
75
Message_collector.add_typed collector
76
-
(Error_code.Attr_not_allowed_on_element { attr; element })
76
+
(`Attr (`Not_allowed (`Attr attr, `Elem element)))
77
77
78
78
(** Report disallowed child element error *)
79
79
let report_disallowed_child parent child collector =
80
80
Message_collector.add_typed collector
81
-
(Error_code.Element_not_allowed_as_child { child; parent })
81
+
(`Element (`Not_allowed_as_child (`Child child, `Parent parent)))
82
82
83
83
let check_picture_attrs attrs collector =
84
84
List.iter (fun disallowed ->
···
94
94
(* source in picture requires srcset *)
95
95
if not (has_attr "srcset" attrs) then
96
96
Message_collector.add_typed collector
97
-
Error_code.Source_missing_srcset
97
+
(`Srcset `Source_missing_srcset)
98
98
99
99
let check_img_attrs attrs collector =
100
100
List.iter (fun disallowed ->
···
119
119
(match state.parent_stack with
120
120
| parent :: _ when List.mem parent disallowed_picture_parents ->
121
121
Message_collector.add_typed collector
122
-
(Error_code.Element_not_allowed_as_child { child = "picture"; parent })
122
+
(`Element (`Not_allowed_as_child (`Child "picture", `Parent parent)))
123
123
| _ -> ());
124
124
check_picture_attrs attrs collector;
125
125
state.in_picture <- true;
···
181
181
(* Check if always-matching source is followed by img with srcset *)
182
182
if state.has_always_matching_source && has_attr "srcset" attrs then begin
183
183
if state.always_matching_is_media_all then
184
-
Message_collector.add_typed collector Error_code.Media_all
184
+
Message_collector.add_typed collector (`Misc `Media_all)
185
185
else if state.always_matching_is_media_empty then
186
-
Message_collector.add_typed collector Error_code.Media_empty
186
+
Message_collector.add_typed collector (`Misc `Media_empty)
187
187
else
188
-
Message_collector.add_typed collector Error_code.Source_needs_media_or_type
188
+
Message_collector.add_typed collector (`Srcset `Source_needs_media_or_type)
189
189
end
190
190
191
191
| "script" when state.in_picture && state.picture_depth = 1 ->
···
221
221
(* Check if picture had img child *)
222
222
if not state.has_img_in_picture then
223
223
Message_collector.add_typed collector
224
-
Error_code.Picture_missing_img;
224
+
(`Srcset `Picture_missing_img);
225
225
(* Check for source after img *)
226
226
if state.has_source_after_img then
227
227
report_disallowed_child "picture" "source" collector;
228
228
(* Check for source after always-matching source *)
229
229
if state.source_after_always_matching then begin
230
230
if state.always_matching_is_media_all then
231
-
Message_collector.add_typed collector Error_code.Media_all
231
+
Message_collector.add_typed collector (`Misc `Media_all)
232
232
else if state.always_matching_is_media_empty then
233
-
Message_collector.add_typed collector Error_code.Media_empty
233
+
Message_collector.add_typed collector (`Misc `Media_empty)
234
234
else
235
-
Message_collector.add_typed collector Error_code.Source_needs_media_or_type
235
+
Message_collector.add_typed collector (`Srcset `Source_needs_media_or_type)
236
236
end;
237
237
238
238
state.in_picture <- false
···
250
250
let trimmed = String.trim text in
251
251
if trimmed <> "" then
252
252
Message_collector.add_typed collector
253
-
(Error_code.Text_not_allowed { parent = "picture" })
253
+
(`Element (`Text_not_allowed (`Parent "picture")))
254
254
end
255
255
256
256
let end_document _state _collector = ()
+4
-2
lib/html5_checker/specialized/ruby_checker.ml
+4
-2
lib/html5_checker/specialized/ruby_checker.ml
···
93
93
if name_lower = "ruby" && info.depth <= 0 then begin
94
94
(* Closing ruby element - validate *)
95
95
if not info.has_rt then
96
+
(* Empty ruby or ruby without any rt - needs rp or rt *)
96
97
Message_collector.add_typed collector
97
-
(Error_code.Missing_required_child_one_of { parent = "ruby"; children = ["rp"; "rt"] })
98
+
(`Element (`Missing_child_one_of (`Parent "ruby", `Children ["rp"; "rt"])))
98
99
else if not info.has_content_before_rt then
100
+
(* Has rt but missing content before it - needs content *)
99
101
Message_collector.add_typed collector
100
-
(Error_code.Missing_required_child { parent = "ruby"; child = "rt" });
102
+
(`Element (`Missing_child (`Parent "ruby", `Child "rt")));
101
103
state.ruby_stack <- rest
102
104
end
103
105
| [] -> ()
+4
-4
lib/html5_checker/specialized/source_checker.ml
+4
-4
lib/html5_checker/specialized/source_checker.ml
···
44
44
| Video | Audio ->
45
45
if has_attr "srcset" attrs then
46
46
Message_collector.add_typed collector
47
-
(Error_code.Attr_not_allowed_on_element { attr = "srcset"; element = "source" });
47
+
(`Attr (`Not_allowed (`Attr "srcset", `Elem "source")));
48
48
if has_attr "sizes" attrs then
49
49
Message_collector.add_typed collector
50
-
(Error_code.Attr_not_allowed_on_element { attr = "sizes"; element = "source" });
50
+
(`Attr (`Not_allowed (`Attr "sizes", `Elem "source")));
51
51
if has_attr "width" attrs then
52
52
Message_collector.add_typed collector
53
-
(Error_code.Attr_not_allowed_on_element { attr = "width"; element = "source" });
53
+
(`Attr (`Not_allowed (`Attr "width", `Elem "source")));
54
54
if has_attr "height" attrs then
55
55
Message_collector.add_typed collector
56
-
(Error_code.Attr_not_allowed_on_element { attr = "height"; element = "source" })
56
+
(`Attr (`Not_allowed (`Attr "height", `Elem "source")))
57
57
| Picture | Other -> ()
58
58
end
59
59
| _ ->
+45
-45
lib/html5_checker/specialized/srcset_sizes_checker.ml
+45
-45
lib/html5_checker/specialized/srcset_sizes_checker.ml
···
406
406
(* Empty sizes is invalid *)
407
407
if String.trim value = "" then begin
408
408
Message_collector.add_typed collector
409
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c\xe2\x80\x9d for attribute \xe2\x80\x9csizes\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad source size list: Must not be empty." element_name });
409
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c\xe2\x80\x9d for attribute \xe2\x80\x9csizes\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad source size list: Must not be empty." element_name))));
410
410
false
411
411
end else begin
412
412
(* Split on comma and check each entry *)
···
416
416
(* Check if starts with comma (empty first entry) *)
417
417
if first_entry = "" then begin
418
418
Message_collector.add_typed collector
419
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csizes\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad source size list: Starts with empty source size." value element_name });
419
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csizes\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad source size list: Starts with empty source size." value element_name))));
420
420
false
421
421
end else begin
422
422
(* Check for trailing comma *)
···
429
429
else value
430
430
in
431
431
Message_collector.add_typed collector
432
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csizes\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad source size list: Expected media condition before \xe2\x80\x9c\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d." value element_name context });
432
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csizes\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad source size list: Expected media condition before \xe2\x80\x9c\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d." value element_name context))));
433
433
false
434
434
end else begin
435
435
let valid = ref true in
···
448
448
(* Context is the first entry with a comma *)
449
449
let context = (String.trim first) ^ "," in
450
450
Message_collector.add_typed collector
451
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csizes\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad source size list: Expected media condition before \xe2\x80\x9c\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d." value element_name context });
451
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csizes\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad source size list: Expected media condition before \xe2\x80\x9c\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d." value element_name context))));
452
452
valid := false
453
453
end;
454
454
(* Check for multiple entries without media conditions.
···
460
460
(* Multiple defaults - report as "Expected media condition" *)
461
461
let context = (String.trim first) ^ "," in
462
462
Message_collector.add_typed collector
463
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csizes\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad source size list: Expected media condition before \xe2\x80\x9c\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d." value element_name context });
463
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csizes\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad source size list: Expected media condition before \xe2\x80\x9c\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d." value element_name context))));
464
464
valid := false
465
465
end
466
466
end
···
482
482
else context
483
483
in
484
484
Message_collector.add_typed collector
485
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csizes\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad source size list: %s at \xe2\x80\x9c%s\xe2\x80\x9d." value element_name err_msg context });
485
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csizes\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad source size list: %s at \xe2\x80\x9c%s\xe2\x80\x9d." value element_name err_msg context))));
486
486
valid := false
487
487
| None -> ());
488
488
···
521
521
else value
522
522
in
523
523
Message_collector.add_typed collector
524
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csizes\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad source size list: Expected media condition before \xe2\x80\x9c\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d." value element_name context });
524
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csizes\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad source size list: Expected media condition before \xe2\x80\x9c\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d." value element_name context))));
525
525
valid := false
526
526
end
527
527
(* If there's extra junk after the size, report BadCssNumber error for it *)
···
549
549
in
550
550
let _ = junk in
551
551
Message_collector.add_typed collector
552
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csizes\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad source size list: Bad CSS number token: Expected a minus sign or a digit but saw \xe2\x80\x9c%c\xe2\x80\x9d instead at \xe2\x80\x9c%s\xe2\x80\x9d." value element_name first_char context });
552
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csizes\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad source size list: Bad CSS number token: Expected a minus sign or a digit but saw \xe2\x80\x9c%c\xe2\x80\x9d instead at \xe2\x80\x9c%s\xe2\x80\x9d." value element_name first_char context))));
553
553
valid := false
554
554
end
555
555
else
···
562
562
in
563
563
let _ = full_context in
564
564
Message_collector.add_typed collector
565
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csizes\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad source size list: Expected positive size value but found \xe2\x80\x9c%s\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d." value element_name size_val size_val });
565
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csizes\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad source size list: Expected positive size value but found \xe2\x80\x9c%s\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d." value element_name size_val size_val))));
566
566
valid := false
567
567
| CssCommentAfterSign (found, context) ->
568
568
(* e.g., +/**/50vw - expected number after sign *)
569
569
Message_collector.add_typed collector
570
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csizes\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad source size list: Expected number but found \xe2\x80\x9c%s\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d." value element_name found context });
570
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csizes\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad source size list: Expected number but found \xe2\x80\x9c%s\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d." value element_name found context))));
571
571
valid := false
572
572
| CssCommentBeforeUnit (found, context) ->
573
573
(* e.g., 50/**/vw - expected units after number *)
574
574
let units_list = List.map (fun u -> Printf.sprintf "\xe2\x80\x9c%s\xe2\x80\x9d" u) valid_length_units in
575
575
let units_str = String.concat ", " units_list in
576
576
Message_collector.add_typed collector
577
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csizes\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad source size list: Expected units (one of %s) but found \xe2\x80\x9c%s\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d." value element_name units_str found context });
577
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csizes\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad source size list: Expected units (one of %s) but found \xe2\x80\x9c%s\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d." value element_name units_str found context))));
578
578
valid := false
579
579
| BadScientificNotation ->
580
580
(* For scientific notation with bad exponent, show what char was expected vs found *)
···
585
585
(* Find the period in the exponent *)
586
586
let _ = context in
587
587
Message_collector.add_typed collector
588
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csizes\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad source size list: Bad CSS number token: Expected a digit but saw \xe2\x80\x9c.\xe2\x80\x9d instead at \xe2\x80\x9c%s\xe2\x80\x9d." value element_name size_val });
588
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csizes\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad source size list: Bad CSS number token: Expected a digit but saw \xe2\x80\x9c.\xe2\x80\x9d instead at \xe2\x80\x9c%s\xe2\x80\x9d." value element_name size_val))));
589
589
valid := false
590
590
| BadCssNumber (first_char, context) ->
591
591
(* Value doesn't start with a digit or minus sign *)
···
595
595
in
596
596
let _ = full_context in
597
597
Message_collector.add_typed collector
598
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csizes\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad source size list: Bad CSS number token: Expected a minus sign or a digit but saw \xe2\x80\x9c%c\xe2\x80\x9d instead at \xe2\x80\x9c%s\xe2\x80\x9d." value element_name first_char context });
598
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csizes\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad source size list: Bad CSS number token: Expected a minus sign or a digit but saw \xe2\x80\x9c%c\xe2\x80\x9d instead at \xe2\x80\x9c%s\xe2\x80\x9d." value element_name first_char context))));
599
599
valid := false
600
600
| InvalidUnit (found_unit, _context) ->
601
601
(* Generate the full list of expected units *)
···
612
612
else Printf.sprintf "\xe2\x80\x9c%s\xe2\x80\x9d" found_unit
613
613
in
614
614
Message_collector.add_typed collector
615
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csizes\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad source size list: Expected units (one of %s) but found %s at \xe2\x80\x9c%s\xe2\x80\x9d." value element_name units_str found_str full_context });
615
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csizes\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad source size list: Expected units (one of %s) but found %s at \xe2\x80\x9c%s\xe2\x80\x9d." value element_name units_str found_str full_context))));
616
616
valid := false
617
617
end
618
618
end
···
639
639
(* Show just the number part (without the 'w') *)
640
640
let num_part_for_msg = String.sub trimmed_desc 0 (String.length trimmed_desc - 1) in
641
641
Message_collector.add_typed collector
642
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Expected number without leading plus sign but found \xe2\x80\x9c%s\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d." srcset_value element_name num_part_for_msg srcset_value });
642
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Expected number without leading plus sign but found \xe2\x80\x9c%s\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d." srcset_value element_name num_part_for_msg srcset_value))));
643
643
false
644
644
end else
645
645
(try
646
646
let n = int_of_string num_part in
647
647
if n <= 0 then begin
648
648
Message_collector.add_typed collector
649
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Expected number greater than zero but found \xe2\x80\x9c%s\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d." srcset_value element_name num_part srcset_value });
649
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Expected number greater than zero but found \xe2\x80\x9c%s\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d." srcset_value element_name num_part srcset_value))));
650
650
false
651
651
end else begin
652
652
(* Check for uppercase W - compare original desc with lowercase version *)
653
653
let original_last = desc.[String.length desc - 1] in
654
654
if original_last = 'W' then begin
655
655
Message_collector.add_typed collector
656
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Expected width descriptor but found \xe2\x80\x9c%s\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d. (When the \xe2\x80\x9csizes\xe2\x80\x9d attribute is present, all image candidate strings must specify a width.)" srcset_value element_name desc srcset_value });
656
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Expected width descriptor but found \xe2\x80\x9c%s\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d. (When the \xe2\x80\x9csizes\xe2\x80\x9d attribute is present, all image candidate strings must specify a width.)" srcset_value element_name desc srcset_value))));
657
657
false
658
658
end else true
659
659
end
···
661
661
(* Check for scientific notation, decimal, or other non-integer values *)
662
662
if String.contains num_part 'e' || String.contains num_part 'E' || String.contains num_part '.' then begin
663
663
Message_collector.add_typed collector
664
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Expected integer but found \xe2\x80\x9c%s\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d." srcset_value element_name num_part srcset_value });
664
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Expected integer but found \xe2\x80\x9c%s\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d." srcset_value element_name num_part srcset_value))));
665
665
false
666
666
end else begin
667
667
Message_collector.add_typed collector
668
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad srcset descriptor: Invalid width descriptor." srcset_value element_name });
668
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad srcset descriptor: Invalid width descriptor." srcset_value element_name))));
669
669
false
670
670
end)
671
671
| 'x' ->
···
675
675
(* Extract the number part including the plus sign *)
676
676
let num_with_plus = String.sub trimmed_desc 0 (String.length trimmed_desc - 1) in
677
677
Message_collector.add_typed collector
678
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Expected number without leading plus sign but found \xe2\x80\x9c%s\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d." srcset_value element_name num_with_plus srcset_value });
678
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Expected number without leading plus sign but found \xe2\x80\x9c%s\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d." srcset_value element_name num_with_plus srcset_value))));
679
679
false
680
680
end else begin
681
681
(try
···
686
686
let orig_num_part = String.sub trimmed_desc 0 (String.length trimmed_desc - 1) in
687
687
let first_char = if String.length orig_num_part > 0 then String.make 1 orig_num_part.[0] else "" in
688
688
Message_collector.add_typed collector
689
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad positive floating point number: Expected a digit but saw \xe2\x80\x9c%s\xe2\x80\x9d instead at \xe2\x80\x9c%s\xe2\x80\x9d." srcset_value element_name first_char srcset_value });
689
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad positive floating point number: Expected a digit but saw \xe2\x80\x9c%s\xe2\x80\x9d instead at \xe2\x80\x9c%s\xe2\x80\x9d." srcset_value element_name first_char srcset_value))));
690
690
false
691
691
end else if n = 0.0 then begin
692
692
(* Check if it's -0 (starts with minus) - report as "greater than zero" error *)
···
694
694
let orig_num_part = String.sub trimmed_desc 0 (String.length trimmed_desc - 1) in
695
695
if String.length orig_num_part > 0 && orig_num_part.[0] = '-' then begin
696
696
Message_collector.add_typed collector
697
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Expected number greater than zero but found \xe2\x80\x9c%s\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d." srcset_value element_name orig_num_part srcset_value })
697
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Expected number greater than zero but found \xe2\x80\x9c%s\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d." srcset_value element_name orig_num_part srcset_value))))
698
698
end else begin
699
699
Message_collector.add_typed collector
700
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad positive floating point number: Zero is not a valid positive floating point number at \xe2\x80\x9c%s\xe2\x80\x9d." srcset_value element_name srcset_value })
700
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad positive floating point number: Zero is not a valid positive floating point number at \xe2\x80\x9c%s\xe2\x80\x9d." srcset_value element_name srcset_value))))
701
701
end;
702
702
false
703
703
end else if n < 0.0 then begin
704
704
Message_collector.add_typed collector
705
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Expected number greater than zero but found \xe2\x80\x9c%s\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d." srcset_value element_name num_part srcset_value });
705
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Expected number greater than zero but found \xe2\x80\x9c%s\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d." srcset_value element_name num_part srcset_value))));
706
706
false
707
707
end else if n = neg_infinity || n = infinity then begin
708
708
(* Infinity is not a valid float - report as parse error with first char from ORIGINAL desc *)
···
710
710
let orig_num_part = String.sub trimmed_desc 0 (String.length trimmed_desc - 1) in
711
711
let first_char = if String.length orig_num_part > 0 then String.make 1 orig_num_part.[0] else "" in
712
712
Message_collector.add_typed collector
713
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad positive floating point number: Expected a digit but saw \xe2\x80\x9c%s\xe2\x80\x9d instead at \xe2\x80\x9c%s\xe2\x80\x9d." srcset_value element_name first_char srcset_value });
713
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad positive floating point number: Expected a digit but saw \xe2\x80\x9c%s\xe2\x80\x9d instead at \xe2\x80\x9c%s\xe2\x80\x9d." srcset_value element_name first_char srcset_value))));
714
714
false
715
715
end else true
716
716
with _ ->
717
717
Message_collector.add_typed collector
718
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad srcset descriptor: Invalid density descriptor." srcset_value element_name });
718
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad srcset descriptor: Invalid density descriptor." srcset_value element_name))));
719
719
false)
720
720
end
721
721
| 'h' ->
···
735
735
in
736
736
if has_sizes then
737
737
Message_collector.add_typed collector
738
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Expected width descriptor but found \xe2\x80\x9c%s\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d. (When the \xe2\x80\x9csizes\xe2\x80\x9d attribute is present, all image candidate strings must specify a width.)" srcset_value element_name trimmed_desc context })
738
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Expected width descriptor but found \xe2\x80\x9c%s\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d. (When the \xe2\x80\x9csizes\xe2\x80\x9d attribute is present, all image candidate strings must specify a width.)" srcset_value element_name trimmed_desc context))))
739
739
else
740
740
Message_collector.add_typed collector
741
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad srcset descriptor: Height descriptor \xe2\x80\x9ch\xe2\x80\x9d is not allowed." srcset_value element_name });
741
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad srcset descriptor: Height descriptor \xe2\x80\x9ch\xe2\x80\x9d is not allowed." srcset_value element_name))));
742
742
false
743
743
| _ ->
744
744
(* Unknown descriptor - find context in srcset_value *)
···
770
770
with Not_found -> srcset_value
771
771
in
772
772
Message_collector.add_typed collector
773
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Expected number followed by \xe2\x80\x9cw\xe2\x80\x9d or \xe2\x80\x9cx\xe2\x80\x9d but found \xe2\x80\x9c%s\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d." srcset_value element_name found_desc context });
773
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Expected number followed by \xe2\x80\x9cw\xe2\x80\x9d or \xe2\x80\x9cx\xe2\x80\x9d but found \xe2\x80\x9c%s\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d." srcset_value element_name found_desc context))));
774
774
false
775
775
end
776
776
···
806
806
(* Check for empty srcset *)
807
807
if String.trim value = "" then begin
808
808
Message_collector.add_typed collector
809
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Must contain one or more image candidate strings." value element_name })
809
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Must contain one or more image candidate strings." value element_name))))
810
810
end;
811
811
812
812
(* Check for leading comma *)
813
813
if String.length value > 0 && value.[0] = ',' then begin
814
814
Message_collector.add_typed collector
815
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Starts with empty image-candidate string." value element_name })
815
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Starts with empty image-candidate string." value element_name))))
816
816
end;
817
817
818
818
(* Check for trailing comma(s) / empty entries *)
···
829
829
if trailing_commas > 1 then
830
830
(* Multiple trailing commas: "Empty image-candidate string at" *)
831
831
Message_collector.add_typed collector
832
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Empty image-candidate string at \xe2\x80\x9c%s\xe2\x80\x9d." value element_name value })
832
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Empty image-candidate string at \xe2\x80\x9c%s\xe2\x80\x9d." value element_name value))))
833
833
else
834
834
(* Single trailing comma: "Ends with empty image-candidate string." *)
835
835
Message_collector.add_typed collector
836
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Ends with empty image-candidate string." value element_name })
836
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Ends with empty image-candidate string." value element_name))))
837
837
end;
838
838
839
839
List.iter (fun entry ->
···
851
851
let scheme_colon = scheme ^ ":" in
852
852
if url_lower = scheme_colon then
853
853
Message_collector.add_typed collector
854
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad image-candidate URL: \xe2\x80\x9c%s\xe2\x80\x9d: Expected a slash (\"/\")." value element_name url })
854
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad image-candidate URL: \xe2\x80\x9c%s\xe2\x80\x9d: Expected a slash (\"/\")." value element_name url))))
855
855
) special_schemes
856
856
in
857
857
match parts with
···
863
863
begin match Hashtbl.find_opt seen_descriptors "explicit-1x" with
864
864
| Some first_url ->
865
865
Message_collector.add_typed collector
866
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Density for image \xe2\x80\x9c%s\xe2\x80\x9d is identical to density for image \xe2\x80\x9c%s\xe2\x80\x9d." value element_name url first_url })
866
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Density for image \xe2\x80\x9c%s\xe2\x80\x9d is identical to density for image \xe2\x80\x9c%s\xe2\x80\x9d." value element_name url first_url))))
867
867
| None ->
868
868
Hashtbl.add seen_descriptors "implicit-1x" url
869
869
end
···
874
874
if rest <> [] then begin
875
875
let extra_desc = List.hd rest in
876
876
Message_collector.add_typed collector
877
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Expected single descriptor but found extraneous descriptor \xe2\x80\x9c%s\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d." value element_name extra_desc value })
877
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Expected single descriptor but found extraneous descriptor \xe2\x80\x9c%s\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d." value element_name extra_desc value))))
878
878
end;
879
879
880
880
let desc_lower = String.lowercase_ascii (String.trim desc) in
···
913
913
value
914
914
in
915
915
Message_collector.add_typed collector
916
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Expected width descriptor but found \xe2\x80\x9c%s\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d. (When the \xe2\x80\x9csizes\xe2\x80\x9d attribute is present, all image candidate strings must specify a width.)" value element_name trimmed_desc entry_context })
916
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Expected width descriptor but found \xe2\x80\x9c%s\xe2\x80\x9d at \xe2\x80\x9c%s\xe2\x80\x9d. (When the \xe2\x80\x9csizes\xe2\x80\x9d attribute is present, all image candidate strings must specify a width.)" value element_name trimmed_desc entry_context))))
917
917
end
918
918
end;
919
919
···
925
925
begin match Hashtbl.find_opt seen_descriptors normalized with
926
926
| Some first_url ->
927
927
Message_collector.add_typed collector
928
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: %s for image \xe2\x80\x9c%s\xe2\x80\x9d is identical to %s for image \xe2\x80\x9c%s\xe2\x80\x9d." value element_name dup_type url (String.lowercase_ascii dup_type) first_url })
928
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: %s for image \xe2\x80\x9c%s\xe2\x80\x9d is identical to %s for image \xe2\x80\x9c%s\xe2\x80\x9d." value element_name dup_type url (String.lowercase_ascii dup_type) first_url))))
929
929
| None ->
930
930
begin match (if is_1x then Hashtbl.find_opt seen_descriptors "implicit-1x" else None) with
931
931
| Some first_url ->
932
932
(* Explicit 1x conflicts with implicit 1x *)
933
933
Message_collector.add_typed collector
934
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: %s for image \xe2\x80\x9c%s\xe2\x80\x9d is identical to %s for image \xe2\x80\x9c%s\xe2\x80\x9d." value element_name dup_type url (String.lowercase_ascii dup_type) first_url })
934
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: %s for image \xe2\x80\x9c%s\xe2\x80\x9d is identical to %s for image \xe2\x80\x9c%s\xe2\x80\x9d." value element_name dup_type url (String.lowercase_ascii dup_type) first_url))))
935
935
| None ->
936
936
Hashtbl.add seen_descriptors normalized url;
937
937
if is_1x then Hashtbl.add seen_descriptors "explicit-1x" url
···
946
946
(* Check: if w descriptor used and no sizes, that's an error for img and source *)
947
947
if !has_w_descriptor && not has_sizes then
948
948
Message_collector.add_typed collector
949
-
(Error_code.Srcset_w_without_sizes);
949
+
(`Srcset `W_without_sizes);
950
950
951
951
(* Check: if sizes is present, all entries must have width descriptors *)
952
952
(match !no_descriptor_url with
953
953
| Some url when has_sizes ->
954
954
Message_collector.add_typed collector
955
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: No width specified for image \xe2\x80\x9c%s\xe2\x80\x9d. (When the \xe2\x80\x9csizes\xe2\x80\x9d attribute is present, all image candidate strings must specify a width.)" value element_name url })
955
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: No width specified for image \xe2\x80\x9c%s\xe2\x80\x9d. (When the \xe2\x80\x9csizes\xe2\x80\x9d attribute is present, all image candidate strings must specify a width.)" value element_name url))))
956
956
| _ -> ());
957
957
958
958
(* Check: if sizes is present and srcset uses x descriptors, that's an error.
959
959
Only report if we haven't already reported the detailed error. *)
960
960
if has_sizes && !has_x_descriptor && not !x_with_sizes_error_reported then
961
961
Message_collector.add_typed collector
962
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: When the \xe2\x80\x9csizes\xe2\x80\x9d attribute is present, all image candidate strings must specify a width." value element_name });
962
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: When the \xe2\x80\x9csizes\xe2\x80\x9d attribute is present, all image candidate strings must specify a width." value element_name))));
963
963
964
964
(* Check for mixing w and x descriptors *)
965
965
if !has_w_descriptor && !has_x_descriptor then
966
966
Message_collector.add_typed collector
967
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Mixing width and density descriptors is not allowed." value element_name })
967
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf "Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9csrcset\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Mixing width and density descriptors is not allowed." value element_name))))
968
968
969
969
let start_element _state ~name ~namespace ~attrs collector =
970
970
let name_lower = String.lowercase_ascii name in
···
973
973
if namespace <> None && name_lower = "image" then begin
974
974
if get_attr "srcset" attrs <> None then
975
975
Message_collector.add_typed collector
976
-
(Error_code.Attr_not_allowed_on_element { attr = "srcset"; element = "image" })
976
+
(`Attr (`Not_allowed (`Attr "srcset", `Elem "image")))
977
977
end;
978
978
979
979
if namespace <> None then ()
···
998
998
(* Error: sizes without srcset on img *)
999
999
if name_lower = "img" && has_sizes && not has_srcset then
1000
1000
Message_collector.add_typed collector
1001
-
(Error_code.Sizes_without_srcset)
1001
+
(`Srcset `Sizes_without_srcset)
1002
1002
end
1003
1003
end
1004
1004
+17
-17
lib/html5_checker/specialized/svg_checker.ml
+17
-17
lib/html5_checker/specialized/svg_checker.ml
···
290
290
(* xmlns on any SVG element must be the SVG namespace *)
291
291
if value <> svg_ns_url then
292
292
Message_collector.add_typed collector
293
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf
293
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf
294
294
"Bad value \xe2\x80\x9c%s\xe2\x80\x9d for the attribute \xe2\x80\x9cxmlns\xe2\x80\x9d (only \xe2\x80\x9c%s\xe2\x80\x9d permitted here)."
295
-
value svg_ns_url })
295
+
value svg_ns_url))))
296
296
| "xmlns:xlink" ->
297
297
if value <> "http://www.w3.org/1999/xlink" then
298
298
Message_collector.add_typed collector
299
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf
299
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf
300
300
"Bad value \xe2\x80\x9c%s\xe2\x80\x9d for the attribute \xe2\x80\x9cxmlns:link\xe2\x80\x9d (only \xe2\x80\x9chttp://www.w3.org/1999/xlink\xe2\x80\x9d permitted here)."
301
-
value })
301
+
value))))
302
302
| _ when String.starts_with ~prefix:"xmlns:" attr && attr <> "xmlns:xlink" ->
303
303
(* Other xmlns declarations are not allowed in HTML-embedded SVG *)
304
304
Message_collector.add_typed collector
305
-
(Error_code.Attr_not_allowed_here { attr })
305
+
(`Attr (`Not_allowed_here (`Attr attr)))
306
306
| _ -> ()
307
307
308
308
(* Validate SVG path data *)
···
322
322
let ctx_end = min (String.length d) (!i + 1) in
323
323
let context = String.sub d !context_start (ctx_end - !context_start) in
324
324
Message_collector.add_typed collector
325
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf
325
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf
326
326
"Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9cd\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad SVG path data: Expected command but found \xe2\x80\x9c#\xe2\x80\x9d (context: \xe2\x80\x9c%s\xe2\x80\x9d)."
327
-
d element context });
327
+
d element context))));
328
328
i := len (* Stop processing *)
329
329
| _ ->
330
330
incr i
···
342
342
let ctx_start = max 0 (pos - 10) in
343
343
let context = String.sub d ctx_start (flag_end - ctx_start) in
344
344
Message_collector.add_typed collector
345
-
(Error_code.Bad_attr_value_generic { message = Printf.sprintf
345
+
(`Attr (`Bad_value_generic (`Message (Printf.sprintf
346
346
"Bad value \xe2\x80\x9c%s\xe2\x80\x9d for attribute \xe2\x80\x9cd\xe2\x80\x9d on element \xe2\x80\x9c%s\xe2\x80\x9d: Bad SVG path data: Expected \xe2\x80\x9c0\xe2\x80\x9d or \xe2\x80\x9c1\xe2\x80\x9d for large-arc-flag for \xe2\x80\x9ca\xe2\x80\x9d command but found \xe2\x80\x9c%s\xe2\x80\x9d instead (context: \xe2\x80\x9c%s\xe2\x80\x9d)."
347
-
d element flag context })
347
+
d element flag context))))
348
348
end
349
349
with Not_found -> ()
350
350
···
364
364
| parent :: _ when String.lowercase_ascii parent = "a" ->
365
365
if List.mem name_lower a_disallowed_children then
366
366
Message_collector.add_typed collector
367
-
(Error_code.Element_not_allowed_as_child { child = name_lower; parent = "a" })
367
+
(`Element (`Not_allowed_as_child (`Child name_lower, `Parent "a")))
368
368
| _ -> ());
369
369
370
370
(* 2. Track missing-glyph in font *)
···
381
381
p = "lineargradient" || p = "radialgradient") -> ()
382
382
| parent :: _ ->
383
383
Message_collector.add_typed collector
384
-
(Error_code.Element_not_allowed_as_child { child = name; parent })
384
+
(`Element (`Not_allowed_as_child (`Child name, `Parent parent)))
385
385
| [] -> ()
386
386
end;
387
387
···
390
390
match state.element_stack with
391
391
| parent :: _ when String.lowercase_ascii parent = "use" ->
392
392
Message_collector.add_typed collector
393
-
(Error_code.Element_not_allowed_as_child { child = name; parent })
393
+
(`Element (`Not_allowed_as_child (`Child name, `Parent parent)))
394
394
| _ -> ()
395
395
end;
396
396
···
402
402
| fect :: _ ->
403
403
if List.mem name_lower fect.seen_funcs then
404
404
Message_collector.add_typed collector
405
-
(Error_code.Element_not_allowed_as_child { child = name; parent = "feComponentTransfer" })
405
+
(`Element (`Not_allowed_as_child (`Child name, `Parent "feComponentTransfer")))
406
406
else
407
407
fect.seen_funcs <- name_lower :: fect.seen_funcs
408
408
| [] -> ()
···
427
427
(* Check xml:* attributes - most are not allowed *)
428
428
else if attr_lower = "xml:id" || attr_lower = "xml:base" then
429
429
Message_collector.add_typed collector
430
-
(Error_code.Attr_not_allowed_on_element { attr; element = name })
430
+
(`Attr (`Not_allowed (`Attr attr, `Elem name)))
431
431
(* Validate path data *)
432
432
else if attr_lower = "d" && name_lower = "path" then
433
433
validate_path_data value name collector
434
434
(* Check if attribute is valid for this element *)
435
435
else if not (is_valid_attr name_lower attr_lower) then
436
436
Message_collector.add_typed collector
437
-
(Error_code.Attr_not_allowed_on_element { attr; element = name })
437
+
(`Attr (`Not_allowed (`Attr attr, `Elem name)))
438
438
) attrs;
439
439
440
440
(* Check required attributes *)
···
443
443
List.iter (fun req_attr ->
444
444
if not (List.exists (fun (a, _) -> String.lowercase_ascii a = req_attr) attrs) then
445
445
Message_collector.add_typed collector
446
-
(Error_code.Missing_required_svg_attr { element = name_lower; attr = req_attr })
446
+
(`Svg (`Missing_attr (`Elem name_lower, `Attr req_attr)))
447
447
) req_attrs
448
448
| None -> ())
449
449
end
···
464
464
| Some children ->
465
465
List.iter (fun child ->
466
466
Message_collector.add_typed collector
467
-
(Error_code.Missing_required_child { parent = "font"; child })
467
+
(`Element (`Missing_child (`Parent "font", `Child child)))
468
468
) children
469
469
| None -> ()
470
470
end;
+24
-24
lib/html5_checker/specialized/table_checker.ml
+24
-24
lib/html5_checker/specialized/table_checker.ml
···
36
36
let colspan =
37
37
if colspan > max_colspan then (
38
38
Message_collector.add_typed collector
39
-
(Error_code.Generic { message = Printf.sprintf
39
+
(`Generic (Printf.sprintf
40
40
{|The value of the "colspan" attribute must be less than or equal to %d.|}
41
-
max_colspan });
41
+
max_colspan));
42
42
max_colspan)
43
43
else colspan
44
44
in
45
45
let rowspan =
46
46
if rowspan > max_rowspan then (
47
47
Message_collector.add_typed collector
48
-
(Error_code.Generic { message = Printf.sprintf
48
+
(`Generic (Printf.sprintf
49
49
{|The value of the "rowspan" attribute must be less than or equal to %d.|}
50
-
max_rowspan });
50
+
max_rowspan));
51
51
max_rowspan)
52
52
else rowspan
53
53
in
···
75
75
(** Emit error for horizontal cell overlap *)
76
76
let err_on_horizontal_overlap cell1 cell2 collector =
77
77
if cells_overlap_horizontally cell1 cell2 then (
78
-
Message_collector.add_typed collector Error_code.Table_cell_overlap;
79
-
Message_collector.add_typed collector Error_code.Table_cell_overlap)
78
+
Message_collector.add_typed collector (`Table `Cell_overlap);
79
+
Message_collector.add_typed collector (`Table `Cell_overlap))
80
80
81
81
(** Check if cell spans past end of row group *)
82
82
let err_if_not_rowspan_zero cell ~row_group_type:_ collector =
83
83
if cell.bottom <> rowspan_zero_magic then
84
-
Message_collector.add_typed collector Error_code.Table_cell_spans_rowgroup
84
+
Message_collector.add_typed collector (`Table `Cell_spans_rowgroup)
85
85
86
86
(** {1 Column Range Tracking} *)
87
87
···
206
206
let end_row_in_group group collector =
207
207
(if not group.row_had_cells then
208
208
Message_collector.add_typed collector
209
-
(Error_code.Table_row_no_cells { row = group.current_row + 1 }));
209
+
(`Table (`Row_no_cells (`Row (group.current_row + 1)))));
210
210
211
211
find_insertion_point group;
212
212
group.cells_on_current_row <- [||];
···
385
385
let span = parse_non_negative_int attrs "span" in
386
386
if span > max_colspan then (
387
387
Message_collector.add_typed collector
388
-
(Error_code.Generic { message = Printf.sprintf
389
-
{|The value of the "span" attribute must be less than or equal to %d.|} max_colspan });
388
+
(`Generic (Printf.sprintf
389
+
{|The value of the "span" attribute must be less than or equal to %d.|} max_colspan));
390
390
max_colspan)
391
391
else span
392
392
···
471
471
if table.hard_width then (
472
472
if row_width > table.column_count then
473
473
Message_collector.add_typed collector
474
-
(Error_code.Generic { message = Printf.sprintf
474
+
(`Generic (Printf.sprintf
475
475
{|A table row was %d columns wide and exceeded the column count established using column markup (%d).|}
476
-
row_width table.column_count })
476
+
row_width table.column_count))
477
477
else if row_width < table.column_count then
478
478
Message_collector.add_typed collector
479
-
(Error_code.Generic { message = Printf.sprintf
479
+
(`Generic (Printf.sprintf
480
480
{|A table row was %d columns wide, which is less than the column count established using column markup (%d).|}
481
-
row_width table.column_count }))
481
+
row_width table.column_count)))
482
482
else if table.column_count = -1 then
483
483
table.column_count <- row_width
484
484
else (
485
485
if row_width > table.column_count then
486
486
Message_collector.add_typed collector
487
-
(Error_code.Generic { message = Printf.sprintf
487
+
(`Generic (Printf.sprintf
488
488
{|A table row was %d columns wide and exceeded the column count established by the first row (%d).|}
489
-
row_width table.column_count })
489
+
row_width table.column_count))
490
490
else if row_width < table.column_count then
491
491
Message_collector.add_typed collector
492
-
(Error_code.Generic { message = Printf.sprintf
492
+
(`Generic (Printf.sprintf
493
493
{|A table row was %d columns wide, which is less than the column count established by the first row (%d).|}
494
-
row_width table.column_count }))
494
+
row_width table.column_count)))
495
495
496
496
(** End a row *)
497
497
let end_row table collector =
···
621
621
| InColgroup ->
622
622
if table.pending_colgroup_span > 0 then
623
623
Message_collector.add_typed collector
624
-
(Error_code.Generic { message = Printf.sprintf
624
+
(`Generic (Printf.sprintf
625
625
"A col element causes a span attribute with value %d to be ignored on the \
626
626
parent colgroup."
627
-
table.pending_colgroup_span });
627
+
table.pending_colgroup_span));
628
628
table.pending_colgroup_span <- 0;
629
629
table.state <- InColInColgroup;
630
630
let span = abs (parse_span attrs collector) in
···
663
663
(fun heading ->
664
664
if not (Hashtbl.mem table.header_ids heading) then
665
665
Message_collector.add_typed collector
666
-
(Error_code.Generic { message = Printf.sprintf
666
+
(`Generic (Printf.sprintf
667
667
{|The "headers" attribute on the element "%s" refers to the ID "%s", but there is no "th" element with that ID in the same table.|}
668
-
cell.element_name heading }))
668
+
cell.element_name heading)))
669
669
cell.headers)
670
670
!(table.cells_with_headers);
671
671
···
675
675
| None -> ()
676
676
| Some r ->
677
677
Message_collector.add_typed collector
678
-
(Error_code.Table_column_no_cells { column = r.right; element = r.element });
678
+
(`Table (`Column_no_cells (`Column r.right, `Elem r.element)));
679
679
check_ranges r.next
680
680
in
681
681
check_ranges table.first_col_range
···
739
739
let end_document state collector =
740
740
if !(state.tables) <> [] then
741
741
Message_collector.add_typed collector
742
-
(Error_code.Generic { message = "Unclosed table element at end of document." })
742
+
(`Generic "Unclosed table element at end of document.")
743
743
744
744
let checker =
745
745
(module struct
+2
-2
lib/html5_checker/specialized/title_checker.ml
+2
-2
lib/html5_checker/specialized/title_checker.ml
···
62
62
(* Check if title was empty *)
63
63
if not state.title_has_content then
64
64
Message_collector.add_typed collector
65
-
(Error_code.Element_must_not_be_empty { element = "title" });
65
+
(`Element (`Must_not_be_empty (`Elem "title")));
66
66
state.in_title <- false
67
67
| "head" ->
68
68
(* Check if head had a title element *)
69
69
if state.in_head && not state.has_title then
70
70
Message_collector.add_typed collector
71
-
(Error_code.Missing_required_child { parent = "head"; child = "title" });
71
+
(`Element (`Missing_child (`Parent "head", `Child "title")));
72
72
state.in_head <- false
73
73
| _ -> ()
74
74
end
+1
-1
lib/html5_checker/specialized/unknown_element_checker.ml
+1
-1
lib/html5_checker/specialized/unknown_element_checker.ml
···
83
83
in
84
84
(* Produce error: unknown element not allowed as child *)
85
85
Message_collector.add_typed collector
86
-
(Error_code.Element_not_allowed_as_child { child = name; parent })
86
+
(`Element (`Not_allowed_as_child (`Child name, `Parent parent)))
87
87
end;
88
88
89
89
(* Always push to stack for tracking *)
+7
-7
lib/html5_checker/specialized/url_checker.ml
+7
-7
lib/html5_checker/specialized/url_checker.ml
···
757
757
| Some url ->
758
758
(match check_data_uri_fragment url attr_name name with
759
759
| Some warn_msg ->
760
-
Message_collector.add_typed collector (Error_code.Generic { message = warn_msg })
760
+
Message_collector.add_typed collector (`Generic warn_msg)
761
761
| None -> ());
762
762
match validate_url url name attr_name with
763
763
| None -> ()
764
764
| Some error_msg ->
765
-
Message_collector.add_typed collector (Error_code.Bad_attr_value_generic { message = error_msg })
765
+
Message_collector.add_typed collector (`Attr (`Bad_value_generic (`Message error_msg)))
766
766
) url_attrs);
767
767
(* Special handling for input[type=url] value attribute - must be absolute URL *)
768
768
if name_lower = "input" then begin
···
780
780
| None ->
781
781
let msg = Printf.sprintf "Bad value %s for attribute %s on element %s: Bad absolute URL: The string %s is not an absolute URL."
782
782
(Error_code.q url) (Error_code.q "value") (Error_code.q "input") (Error_code.q url) in
783
-
Message_collector.add_typed collector (Error_code.Bad_attr_value_generic { message = msg })
783
+
Message_collector.add_typed collector (`Attr (`Bad_value_generic (`Message msg)))
784
784
| Some _ ->
785
785
(match check_data_uri_fragment ~is_absolute_url:true url "value" name with
786
786
| Some warn_msg ->
787
-
Message_collector.add_typed collector (Error_code.Generic { message = warn_msg })
787
+
Message_collector.add_typed collector (`Generic warn_msg)
788
788
| None -> ());
789
789
match validate_url url name "value" with
790
790
| None -> ()
791
791
| Some error_msg ->
792
792
let error_msg = Str.global_replace (Str.regexp "Bad URL:") "Bad absolute URL:" error_msg in
793
-
Message_collector.add_typed collector (Error_code.Bad_attr_value_generic { message = error_msg })
793
+
Message_collector.add_typed collector (`Attr (`Bad_value_generic (`Message error_msg)))
794
794
end
795
795
end
796
796
end;
···
798
798
(match itemtype_opt with
799
799
| Some url when String.trim url <> "" ->
800
800
(match check_data_uri_fragment ~is_absolute_url:true url "itemtype" name with
801
-
| Some warn_msg -> Message_collector.add_typed collector (Error_code.Generic { message = warn_msg })
801
+
| Some warn_msg -> Message_collector.add_typed collector (`Generic warn_msg)
802
802
| None -> ())
803
803
| _ -> ());
804
804
let itemid_opt = get_attr_value "itemid" attrs in
805
805
(match itemid_opt with
806
806
| Some url when String.trim url <> "" ->
807
807
(match check_data_uri_fragment url "itemid" name with
808
-
| Some warn_msg -> Message_collector.add_typed collector (Error_code.Generic { message = warn_msg })
808
+
| Some warn_msg -> Message_collector.add_typed collector (`Generic warn_msg)
809
809
| None -> ())
810
810
| _ -> ())
811
811
end
+5
-5
lib/html5_checker/specialized/xhtml_content_checker.ml
+5
-5
lib/html5_checker/specialized/xhtml_content_checker.ml
···
50
50
String.sub attr_name 0 5 = "data-" then
51
51
let suffix = String.sub attr_name 5 (String.length attr_name - 5) in
52
52
if String.exists (fun c -> c >= 'A' && c <= 'Z') suffix then
53
-
Message_collector.add_typed collector Error_code.Data_attr_uppercase
53
+
Message_collector.add_typed collector (`Attr `Data_uppercase)
54
54
) attrs
55
55
56
56
let start_element state ~name ~namespace ~attrs collector =
···
66
66
let parent_lower = String.lowercase_ascii parent in
67
67
if not (is_child_allowed ~parent:parent_lower ~child:name_lower) then
68
68
Message_collector.add_typed collector
69
-
(Error_code.Element_not_allowed_as_child { child = name_lower; parent = parent_lower })
69
+
(`Element (`Not_allowed_as_child (`Child name_lower, `Parent parent_lower)))
70
70
| [] -> ());
71
71
72
72
(* Handle figure content model *)
···
84
84
(* Flow content appearing in figure *)
85
85
if fig.has_figcaption && not fig.figcaption_at_start then
86
86
Message_collector.add_typed collector
87
-
(Error_code.Element_not_allowed_as_child { child = name_lower; parent = "figure" })
87
+
(`Element (`Not_allowed_as_child (`Child name_lower, `Parent "figure")))
88
88
else if not fig.has_figcaption then
89
89
fig.has_content_before_figcaption <- true
90
90
end
···
123
123
| fig :: _ ->
124
124
if fig.has_figcaption && not fig.figcaption_at_start then
125
125
Message_collector.add_typed collector
126
-
(Error_code.Text_not_allowed { parent = "figure" })
126
+
(`Element (`Text_not_allowed (`Parent "figure")))
127
127
else if not fig.has_figcaption then
128
128
fig.has_content_before_figcaption <- true
129
129
| [] -> ()
130
130
end
131
131
else if not (is_text_allowed parent_lower) then
132
132
Message_collector.add_typed collector
133
-
(Error_code.Text_not_allowed { parent = parent_lower })
133
+
(`Element (`Text_not_allowed (`Parent parent_lower)))
134
134
end
135
135
136
136
let end_document _state _collector = ()
+20
-42
test/expected_message.ml
+20
-42
test/expected_message.ml
···
80
80
if Str.string_match re msg 0 then
81
81
let child = Str.matched_group 1 msg in
82
82
let parent = Str.matched_group 2 msg in
83
-
Some (Html5_checker.Error_code.Element_not_allowed_as_child { child; parent },
83
+
Some ((`Element (`Not_allowed_as_child (`Child child, `Parent parent)) : Html5_checker.Error_code.t),
84
84
Some child, None)
85
85
else None
86
86
···
90
90
if Str.string_match re msg 0 then
91
91
let attr = Str.matched_group 1 msg in
92
92
let element = Str.matched_group 2 msg in
93
-
Some (Html5_checker.Error_code.Attr_not_allowed_on_element { attr; element },
93
+
Some ((`Attr (`Not_allowed (`Attr attr, `Elem element)) : Html5_checker.Error_code.t),
94
94
Some element, Some attr)
95
95
else None
96
96
···
99
99
let re = Str.regexp {|Attribute "\([^"]+\)" not allowed here|} in
100
100
if Str.string_match re msg 0 then
101
101
let attr = Str.matched_group 1 msg in
102
-
Some (Html5_checker.Error_code.Attr_not_allowed_here { attr },
102
+
Some ((`Attr (`Not_allowed_here (`Attr attr)) : Html5_checker.Error_code.t),
103
103
None, Some attr)
104
104
else None
105
105
···
109
109
if Str.string_match re msg 0 then
110
110
let element = Str.matched_group 1 msg in
111
111
let attr = Str.matched_group 2 msg in
112
-
Some (Html5_checker.Error_code.Missing_required_attr { element; attr },
112
+
Some ((`Attr (`Missing (`Elem element, `Attr attr)) : Html5_checker.Error_code.t),
113
113
Some element, Some attr)
114
114
else None
115
115
···
119
119
if Str.string_match re msg 0 then
120
120
let parent = Str.matched_group 1 msg in
121
121
let child = Str.matched_group 2 msg in
122
-
Some (Html5_checker.Error_code.Missing_required_child { parent; child },
122
+
Some ((`Element (`Missing_child (`Parent parent, `Child child)) : Html5_checker.Error_code.t),
123
123
Some parent, None)
124
124
else None
125
125
···
128
128
let re = Str.regexp {|Duplicate ID "\([^"]+\)"|} in
129
129
if Str.string_match re msg 0 then
130
130
let id = Str.matched_group 1 msg in
131
-
Some (Html5_checker.Error_code.Duplicate_id { id },
131
+
Some ((`Attr (`Duplicate_id (`Id id)) : Html5_checker.Error_code.t),
132
132
None, None)
133
133
else None
134
134
···
137
137
let re = Str.regexp {|The "\([^"]+\)" element is obsolete|} in
138
138
if Str.string_match re msg 0 then
139
139
let element = Str.matched_group 1 msg in
140
-
Some (Html5_checker.Error_code.Obsolete_element { element; suggestion = "" },
140
+
Some ((`Element (`Obsolete (`Elem element, `Suggestion "")) : Html5_checker.Error_code.t),
141
141
Some element, None)
142
142
else None
143
143
···
147
147
if Str.string_match re msg 0 then
148
148
let attr = Str.matched_group 1 msg in
149
149
let element = Str.matched_group 2 msg in
150
-
Some (Html5_checker.Error_code.Obsolete_attr { attr; element; suggestion = None },
150
+
Some ((`Element (`Obsolete_attr (`Elem element, `Attr attr, `Suggestion None)) : Html5_checker.Error_code.t),
151
151
Some element, Some attr)
152
152
else None
153
153
···
156
156
let re = Str.regexp {|Stray end tag "\([^"]+\)"|} in
157
157
if Str.string_match re msg 0 then
158
158
let tag = Str.matched_group 1 msg in
159
-
Some (Html5_checker.Error_code.Stray_end_tag { tag },
159
+
Some ((`Tag (`Stray_end (`Tag tag)) : Html5_checker.Error_code.t),
160
160
Some tag, None)
161
161
else None
162
162
···
165
165
let re = Str.regexp {|Stray start tag "\([^"]+\)"|} in
166
166
if Str.string_match re msg 0 then
167
167
let tag = Str.matched_group 1 msg in
168
-
Some (Html5_checker.Error_code.Stray_start_tag { tag },
168
+
Some ((`Tag (`Stray_start (`Tag tag)) : Html5_checker.Error_code.t),
169
169
Some tag, None)
170
170
else None
171
171
···
175
175
if Str.string_match re msg 0 then
176
176
let role = Str.matched_group 1 msg in
177
177
let reason = Str.matched_group 2 msg in
178
-
Some (Html5_checker.Error_code.Unnecessary_role { role; element = ""; reason },
178
+
Some ((`Aria (`Unnecessary_role (`Role role, `Elem "", `Reason reason)) : Html5_checker.Error_code.t),
179
179
None, None)
180
180
else None
181
181
···
185
185
if Str.string_match re msg 0 then
186
186
let role = Str.matched_group 1 msg in
187
187
let element = Str.matched_group 2 msg in
188
-
Some (Html5_checker.Error_code.Bad_role { element; role },
188
+
Some ((`Aria (`Bad_role (`Elem element, `Role role)) : Html5_checker.Error_code.t),
189
189
Some element, Some "role")
190
190
else None
191
191
···
196
196
let attr = Str.matched_group 1 msg in
197
197
let element = Str.matched_group 2 msg in
198
198
let condition = Str.matched_group 3 msg in
199
-
Some (Html5_checker.Error_code.Aria_must_not_be_specified { attr; element; condition },
199
+
Some ((`Aria (`Must_not_specify (`Attr attr, `Elem element, `Condition condition)) : Html5_checker.Error_code.t),
200
200
Some element, Some attr)
201
201
else None
202
202
···
207
207
let attr = Str.matched_group 1 msg in
208
208
let element = Str.matched_group 2 msg in
209
209
let condition = Str.matched_group 3 msg in
210
-
Some (Html5_checker.Error_code.Aria_must_not_be_used { attr; element; condition },
210
+
Some ((`Aria (`Must_not_use (`Attr attr, `Elem element, `Condition condition)) : Html5_checker.Error_code.t),
211
211
Some element, Some attr)
212
212
else None
213
213
···
225
225
String.trim (String.sub msg (colon_pos + 1) (String.length msg - colon_pos - 1))
226
226
with Not_found -> ""
227
227
in
228
-
Some (Html5_checker.Error_code.Bad_attr_value { element; attr; value; reason },
228
+
Some ((`Attr (`Bad_value (`Elem element, `Attr attr, `Value value, `Reason reason)) : Html5_checker.Error_code.t),
229
229
Some element, Some attr)
230
230
else None
231
231
···
234
234
let re = Str.regexp {|End tag "\([^"]+\)" implied, but there were open elements|} in
235
235
if Str.string_match re msg 0 then
236
236
let tag = Str.matched_group 1 msg in
237
-
Some (Html5_checker.Error_code.End_tag_implied_open_elements { tag },
237
+
Some ((`Tag (`End_implied_open (`Tag tag)) : Html5_checker.Error_code.t),
238
238
Some tag, None)
239
239
else None
240
240
···
243
243
let re = Str.regexp {|No "\([^"]+\)" element in scope but a "\([^"]+\)" end tag seen|} in
244
244
if Str.string_match re msg 0 then
245
245
let tag = Str.matched_group 1 msg in
246
-
Some (Html5_checker.Error_code.No_element_in_scope { tag },
246
+
Some ((`Tag (`Not_in_scope (`Tag tag)) : Html5_checker.Error_code.t),
247
247
Some tag, None)
248
248
else None
249
249
···
252
252
let re = Str.regexp {|Start tag "\([^"]+\)" seen in "table"|} in
253
253
if Str.string_match re msg 0 then
254
254
let tag = Str.matched_group 1 msg in
255
-
Some (Html5_checker.Error_code.Start_tag_in_table { tag },
255
+
Some ((`Tag (`Start_in_table (`Tag tag)) : Html5_checker.Error_code.t),
256
256
Some tag, None)
257
257
else None
258
258
···
330
330
331
331
(** Compare error codes for semantic equality *)
332
332
let error_codes_match code1 code2 =
333
-
match (code1, code2) with
334
-
| (Html5_checker.Error_code.Element_not_allowed_as_child { child = c1; parent = p1 },
335
-
Html5_checker.Error_code.Element_not_allowed_as_child { child = c2; parent = p2 }) ->
336
-
String.lowercase_ascii c1 = String.lowercase_ascii c2 &&
337
-
String.lowercase_ascii p1 = String.lowercase_ascii p2
338
-
| (Html5_checker.Error_code.Attr_not_allowed_on_element { attr = a1; element = e1 },
339
-
Html5_checker.Error_code.Attr_not_allowed_on_element { attr = a2; element = e2 }) ->
340
-
String.lowercase_ascii a1 = String.lowercase_ascii a2 &&
341
-
String.lowercase_ascii e1 = String.lowercase_ascii e2
342
-
| (Html5_checker.Error_code.Missing_required_attr { element = e1; attr = a1 },
343
-
Html5_checker.Error_code.Missing_required_attr { element = e2; attr = a2 }) ->
344
-
String.lowercase_ascii e1 = String.lowercase_ascii e2 &&
345
-
String.lowercase_ascii a1 = String.lowercase_ascii a2
346
-
| (Html5_checker.Error_code.Duplicate_id { id = i1 },
347
-
Html5_checker.Error_code.Duplicate_id { id = i2 }) ->
348
-
i1 = i2
349
-
| (Html5_checker.Error_code.Stray_end_tag { tag = t1 },
350
-
Html5_checker.Error_code.Stray_end_tag { tag = t2 }) ->
351
-
String.lowercase_ascii t1 = String.lowercase_ascii t2
352
-
| (Html5_checker.Error_code.Stray_start_tag { tag = t1 },
353
-
Html5_checker.Error_code.Stray_start_tag { tag = t2 }) ->
354
-
String.lowercase_ascii t1 = String.lowercase_ascii t2
355
-
(* For other cases, fall back to structural equality *)
356
-
| (c1, c2) -> c1 = c2
333
+
(* Use structural equality for all polymorphic variant error codes *)
334
+
code1 = code2
357
335
358
336
let matches ~strictness ~expected ~actual =
359
337
let expected_norm = normalize_quotes expected.message in