anil.recoil.org
+1
dune-project
+1
dune-project
+1
html5rw.opam
+1
html5rw.opam
+1
-1
lib/check/checker_registry.ml
+1
-1
lib/check/checker_registry.ml
···
22
Hashtbl.replace reg "source" Source_checker.checker;
23
Hashtbl.replace reg "label" Label_checker.checker;
24
Hashtbl.replace reg "ruby" Ruby_checker.checker;
25
-
Hashtbl.replace reg "h1" H1_checker.checker;
26
Hashtbl.replace reg "srcset-sizes" Srcset_sizes_checker.checker;
27
Hashtbl.replace reg "autofocus" Autofocus_checker.checker;
28
Hashtbl.replace reg "option" Option_checker.checker;
···
22
Hashtbl.replace reg "source" Source_checker.checker;
23
Hashtbl.replace reg "label" Label_checker.checker;
24
Hashtbl.replace reg "ruby" Ruby_checker.checker;
25
+
Hashtbl.replace reg "heading" Heading_checker.checker;
26
Hashtbl.replace reg "srcset-sizes" Srcset_sizes_checker.checker;
27
Hashtbl.replace reg "autofocus" Autofocus_checker.checker;
28
Hashtbl.replace reg "option" Option_checker.checker;
+26
lib/check/datatype/datatype.ml
+26
lib/check/datatype/datatype.ml
···
12
13
(* Helper utilities *)
14
15
let is_whitespace = function
16
| ' ' | '\t' | '\n' | '\r' | '\012' (* FF *) -> true
17
| _ -> false
18
19
let is_ascii_digit = function '0' .. '9' -> true | _ -> false
20
21
let to_ascii_lowercase c =
22
match c with 'A' .. 'Z' -> Char.chr (Char.code c + 32) | _ -> c
23
24
let string_to_ascii_lowercase s =
25
String.map to_ascii_lowercase s
26
27
let trim_html_spaces s =
28
let len = String.length s in
···
12
13
(* Helper utilities *)
14
15
+
(** Character predicates *)
16
+
17
let is_whitespace = function
18
| ' ' | '\t' | '\n' | '\r' | '\012' (* FF *) -> true
19
| _ -> false
20
21
let is_ascii_digit = function '0' .. '9' -> true | _ -> false
22
23
+
let is_lower_alpha = function 'a' .. 'z' -> true | _ -> false
24
+
25
+
let is_upper_alpha = function 'A' .. 'Z' -> true | _ -> false
26
+
27
+
let is_alpha c = is_lower_alpha c || is_upper_alpha c
28
+
29
+
let is_alphanumeric c = is_alpha c || is_ascii_digit c
30
+
31
+
let is_hex_digit = function
32
+
| '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true
33
+
| _ -> false
34
+
35
+
(** Case conversion *)
36
+
37
let to_ascii_lowercase c =
38
match c with 'A' .. 'Z' -> Char.chr (Char.code c + 32) | _ -> c
39
40
let string_to_ascii_lowercase s =
41
String.map to_ascii_lowercase s
42
+
43
+
(** String predicates *)
44
+
45
+
let is_non_empty s = String.trim s <> ""
46
+
47
+
let is_all_digits s = String.length s > 0 && String.for_all is_ascii_digit s
48
+
49
+
let is_all_alpha s = String.length s > 0 && String.for_all is_alpha s
50
+
51
+
let is_all_alphanumeric s = String.length s > 0 && String.for_all is_alphanumeric s
52
53
let trim_html_spaces s =
54
let len = String.length s in
+36
-1
lib/check/datatype/datatype.mli
+36
-1
lib/check/datatype/datatype.mli
···
27
(** Check if a value is valid *)
28
val is_valid : t -> string -> bool
29
30
-
(** Helper utilities for implementing datatype validators. *)
31
32
(** Check if a character is HTML5 whitespace (space, tab, LF, FF, or CR). *)
33
val is_whitespace : char -> bool
···
35
(** Check if a character is an ASCII digit (0-9). *)
36
val is_ascii_digit : char -> bool
37
38
(** Convert an ASCII character to lowercase. *)
39
val to_ascii_lowercase : char -> char
40
41
(** Convert an ASCII string to lowercase. *)
42
val string_to_ascii_lowercase : string -> string
43
44
(** Trim HTML5 whitespace from both ends of a string. *)
45
val trim_html_spaces : string -> string
···
27
(** Check if a value is valid *)
28
val is_valid : t -> string -> bool
29
30
+
(** {1 Helper utilities for implementing datatype validators} *)
31
+
32
+
(** {2 Character predicates} *)
33
34
(** Check if a character is HTML5 whitespace (space, tab, LF, FF, or CR). *)
35
val is_whitespace : char -> bool
···
37
(** Check if a character is an ASCII digit (0-9). *)
38
val is_ascii_digit : char -> bool
39
40
+
(** Check if a character is a lowercase ASCII letter (a-z). *)
41
+
val is_lower_alpha : char -> bool
42
+
43
+
(** Check if a character is an uppercase ASCII letter (A-Z). *)
44
+
val is_upper_alpha : char -> bool
45
+
46
+
(** Check if a character is an ASCII letter (a-z or A-Z). *)
47
+
val is_alpha : char -> bool
48
+
49
+
(** Check if a character is an ASCII letter or digit. *)
50
+
val is_alphanumeric : char -> bool
51
+
52
+
(** Check if a character is a hexadecimal digit (0-9, a-f, A-F). *)
53
+
val is_hex_digit : char -> bool
54
+
55
+
(** {2 Case conversion} *)
56
+
57
(** Convert an ASCII character to lowercase. *)
58
val to_ascii_lowercase : char -> char
59
60
(** Convert an ASCII string to lowercase. *)
61
val string_to_ascii_lowercase : string -> string
62
+
63
+
(** {2 String predicates} *)
64
+
65
+
(** Check if a string has non-whitespace content after trimming. *)
66
+
val is_non_empty : string -> bool
67
+
68
+
(** Check if all characters in a non-empty string are ASCII digits. *)
69
+
val is_all_digits : string -> bool
70
+
71
+
(** Check if all characters in a non-empty string are ASCII letters. *)
72
+
val is_all_alpha : string -> bool
73
+
74
+
(** Check if all characters in a non-empty string are ASCII letters or digits. *)
75
+
val is_all_alphanumeric : string -> bool
76
+
77
+
(** {2 String manipulation} *)
78
79
(** Trim HTML5 whitespace from both ends of a string. *)
80
val trim_html_spaces : string -> string
+6
-8
lib/check/datatype/dt_autocomplete.ml
+6
-8
lib/check/datatype/dt_autocomplete.ml
···
4
let is_whitespace = Datatype.is_whitespace
5
let to_ascii_lowercase = Datatype.to_ascii_lowercase
6
7
(** Trim whitespace from string and collapse internal whitespace *)
8
let trim_whitespace s =
9
let s = String.trim s in
···
104
(** Split string on whitespace - uses shared utility *)
105
let split_on_whitespace = Datatype.split_on_whitespace
106
107
-
(** Check if string starts with prefix *)
108
-
let starts_with s prefix =
109
-
String.length s >= String.length prefix
110
-
&& String.sub s 0 (String.length prefix) = prefix
111
-
112
(** Validate detail tokens *)
113
let check_tokens tokens =
114
let tokens = ref tokens in
···
116
117
(* Check for section-* *)
118
(match !tokens with
119
-
| token :: rest when starts_with token "section-" ->
120
tokens := rest
121
| _ -> ());
122
···
145
146
(* Check if any token in the list is a section-* indicator *)
147
let find_section tokens =
148
-
List.find_opt (fun t -> starts_with t "section-") tokens
149
in
150
151
(* Check if webauthn appears anywhere except as the very last token *)
···
207
(Printf.sprintf
208
"The token \"%s\" must only appear before any autofill field names."
209
token)
210
-
| token :: _ when starts_with token "section-" ->
211
Error
212
"A \"section-*\" indicator must only appear as the first token in a \
213
list of autofill detail tokens."
···
4
let is_whitespace = Datatype.is_whitespace
5
let to_ascii_lowercase = Datatype.to_ascii_lowercase
6
7
+
(* Use Astring for string operations *)
8
+
let is_prefix = Astring.String.is_prefix
9
+
10
(** Trim whitespace from string and collapse internal whitespace *)
11
let trim_whitespace s =
12
let s = String.trim s in
···
107
(** Split string on whitespace - uses shared utility *)
108
let split_on_whitespace = Datatype.split_on_whitespace
109
110
(** Validate detail tokens *)
111
let check_tokens tokens =
112
let tokens = ref tokens in
···
114
115
(* Check for section-* *)
116
(match !tokens with
117
+
| token :: rest when is_prefix ~affix:"section-" token ->
118
tokens := rest
119
| _ -> ());
120
···
143
144
(* Check if any token in the list is a section-* indicator *)
145
let find_section tokens =
146
+
List.find_opt (fun t -> is_prefix ~affix:"section-" t) tokens
147
in
148
149
(* Check if webauthn appears anywhere except as the very last token *)
···
205
(Printf.sprintf
206
"The token \"%s\" must only appear before any autofill field names."
207
token)
208
+
| token :: _ when is_prefix ~affix:"section-" token ->
209
Error
210
"A \"section-*\" indicator must only appear as the first token in a \
211
list of autofill detail tokens."
+3
-6
lib/check/datatype/dt_charset.ml
+3
-6
lib/check/datatype/dt_charset.ml
···
1
(** Helper functions for charset validation *)
2
3
let is_valid_charset_char c =
4
-
(c >= '0' && c <= '9') ||
5
-
(c >= 'a' && c <= 'z') ||
6
-
(c >= 'A' && c <= 'Z') ||
7
c = '-' || c = '!' || c = '#' || c = '$' || c = '%' || c = '&' ||
8
c = '\'' || c = '+' || c = '_' || c = '`' || c = '{' || c = '}' ||
9
c = '~' || c = '^'
10
11
-
let to_lower s = String.lowercase_ascii s
12
13
(** Common encoding labels recognized by WHATWG Encoding Standard.
14
This is a subset of the full list. *)
···
74
module Meta_charset = struct
75
let name = "legacy character encoding declaration"
76
77
-
let is_whitespace c =
78
-
c = ' ' || c = '\t' || c = '\n' || c = '\012' || c = '\r'
79
80
let validate s =
81
let lower = to_lower s in
···
1
(** Helper functions for charset validation *)
2
3
let is_valid_charset_char c =
4
+
Datatype.is_alphanumeric c ||
5
c = '-' || c = '!' || c = '#' || c = '$' || c = '%' || c = '&' ||
6
c = '\'' || c = '+' || c = '_' || c = '`' || c = '{' || c = '}' ||
7
c = '~' || c = '^'
8
9
+
let to_lower = Datatype.string_to_ascii_lowercase
10
11
(** Common encoding labels recognized by WHATWG Encoding Standard.
12
This is a subset of the full list. *)
···
72
module Meta_charset = struct
73
let name = "legacy character encoding declaration"
74
75
+
let is_whitespace = Datatype.is_whitespace
76
77
let validate s =
78
let lower = to_lower s in
+1
-2
lib/check/datatype/dt_color.ml
+1
-2
lib/check/datatype/dt_color.ml
+1
-4
lib/check/datatype/dt_datetime.ml
+1
-4
lib/check/datatype/dt_datetime.ml
+1
-3
lib/check/datatype/dt_email.ml
+1
-3
lib/check/datatype/dt_email.ml
···
2
3
(** Helper to check if a character is valid in email local/domain parts *)
4
let is_email_char c =
5
-
(c >= 'a' && c <= 'z')
6
-
|| (c >= 'A' && c <= 'Z')
7
-
|| (c >= '0' && c <= '9')
8
|| c = '.' || c = '-' || c = '_' || c = '+' || c = '='
9
10
(** Validate a single email address using simplified rules *)
+4
-17
lib/check/datatype/dt_language.ml
+4
-17
lib/check/datatype/dt_language.ml
···
2
3
let q = Error_code.q
4
5
-
let is_lower_alpha c = c >= 'a' && c <= 'z'
6
-
let is_upper_alpha c = c >= 'A' && c <= 'Z'
7
-
let is_alpha c = is_lower_alpha c || is_upper_alpha c
8
-
let is_digit c = c >= '0' && c <= '9'
9
-
let is_alphanumeric c = is_alpha c || is_digit c
10
-
11
-
let is_all_alpha s =
12
-
String.for_all is_alpha s
13
-
14
-
let _is_all_digits s =
15
-
String.for_all is_digit s
16
-
17
-
let is_all_alphanumeric s =
18
-
String.for_all is_alphanumeric s
19
-
20
-
let to_lower s =
21
-
String.lowercase_ascii s
22
23
(** Valid extlang subtags per IANA language-subtag-registry.
24
Extlangs are 3-letter subtags that follow the primary language.
···
2
3
let q = Error_code.q
4
5
+
(* Use shared character predicates from Datatype *)
6
+
let is_all_alpha = Datatype.is_all_alpha
7
+
let is_all_alphanumeric = Datatype.is_all_alphanumeric
8
+
let to_lower = Datatype.string_to_ascii_lowercase
9
10
(** Valid extlang subtags per IANA language-subtag-registry.
11
Extlangs are 3-letter subtags that follow the primary language.
+20
-26
lib/check/datatype/dt_media_query.ml
+20
-26
lib/check/datatype/dt_media_query.ml
···
70
(** Media query keywords (unused but kept for documentation) *)
71
let _media_keywords = [ "and"; "not"; "only" ]
72
73
-
(** Check if character is whitespace *)
74
-
let is_whitespace c = c = ' ' || c = '\t' || c = '\n' || c = '\r'
75
76
(** Check if character can start an identifier *)
77
let is_ident_start c =
78
-
(c >= 'a' && c <= 'z')
79
-
|| (c >= 'A' && c <= 'Z')
80
-
|| c = '_' || c = '-' || Char.code c >= 128
81
82
(** Check if character can be in an identifier *)
83
let is_ident_char c =
84
-
is_ident_start c || (c >= '0' && c <= '9')
85
86
-
(** Unicode case-fold for Turkish dotted-I etc *)
87
-
let lowercase_unicode s =
88
-
(* Handle special case: U+0130 LATIN CAPITAL LETTER I WITH DOT ABOVE -> i *)
89
let buf = Buffer.create (String.length s) in
90
-
let i = ref 0 in
91
-
while !i < String.length s do
92
-
let c = s.[!i] in
93
-
if c = '\xc4' && !i + 1 < String.length s && s.[!i + 1] = '\xb0' then begin
94
-
(* U+0130 -> 'i' + U+0307 (combining dot above), but for simplicity just 'i' followed by U+0307 *)
95
-
Buffer.add_string buf "i\xcc\x87";
96
-
i := !i + 2
97
-
end else begin
98
-
Buffer.add_char buf (Char.lowercase_ascii c);
99
-
incr i
100
-
end
101
-
done;
102
Buffer.contents buf
103
104
(** Check balanced parentheses *)
···
222
match read_ident () with
223
| None -> Error "Parse Error."
224
| Some media_type ->
225
-
let mt_lower = lowercase_unicode media_type in
226
(* Check for deprecated media type *)
227
if List.mem mt_lower deprecated_media_types then
228
Error (Printf.sprintf "The media \"%s\" has been deprecated" mt_lower)
···
341
if List.mem feature length_features then begin
342
(* Must be a valid length: number followed by unit *)
343
let value = String.trim value in
344
-
let is_digit c = c >= '0' && c <= '9' in
345
346
(* Parse number - includes sign, digits, and decimal point *)
347
let i = ref 0 in
348
let len = String.length value in
349
-
while !i < len && (is_digit value.[!i] || value.[!i] = '.' || value.[!i] = '-' || value.[!i] = '+') do
350
incr i
351
done;
352
let num_part = String.sub value 0 !i in
···
377
end else if List.mem feature color_features then begin
378
(* Must be an integer *)
379
let value = String.trim value in
380
-
let is_digit c = c >= '0' && c <= '9' in
381
-
if String.length value > 0 && String.for_all is_digit value then Ok ()
382
else
383
Error (Printf.sprintf "\"%s\" is not a \"%s\" value" value base_feature)
384
end else
···
70
(** Media query keywords (unused but kept for documentation) *)
71
let _media_keywords = [ "and"; "not"; "only" ]
72
73
+
let is_whitespace = Datatype.is_whitespace
74
75
(** Check if character can start an identifier *)
76
let is_ident_start c =
77
+
Datatype.is_alpha c || c = '_' || c = '-' || Char.code c >= 128
78
79
(** Check if character can be in an identifier *)
80
let is_ident_char c =
81
+
is_ident_start c || Datatype.is_ascii_digit c
82
83
+
(** Unicode case folding for case-insensitive comparison.
84
+
85
+
Uses the Uucp library for proper Unicode case folding, which handles
86
+
special cases like Turkish dotted-I (U+0130 -> 'i' + U+0307) correctly. *)
87
+
let case_fold s =
88
let buf = Buffer.create (String.length s) in
89
+
let add_uchar u = Uutf.Buffer.add_utf_8 buf u in
90
+
let fold_char () _pos = function
91
+
| `Malformed _ -> () (* Skip malformed sequences *)
92
+
| `Uchar u ->
93
+
match Uucp.Case.Fold.fold u with
94
+
| `Self -> add_uchar u
95
+
| `Uchars us -> List.iter add_uchar us
96
+
in
97
+
Uutf.String.fold_utf_8 fold_char () s;
98
Buffer.contents buf
99
100
(** Check balanced parentheses *)
···
218
match read_ident () with
219
| None -> Error "Parse Error."
220
| Some media_type ->
221
+
let mt_lower = case_fold media_type in
222
(* Check for deprecated media type *)
223
if List.mem mt_lower deprecated_media_types then
224
Error (Printf.sprintf "The media \"%s\" has been deprecated" mt_lower)
···
337
if List.mem feature length_features then begin
338
(* Must be a valid length: number followed by unit *)
339
let value = String.trim value in
340
341
(* Parse number - includes sign, digits, and decimal point *)
342
let i = ref 0 in
343
let len = String.length value in
344
+
while !i < len && (Datatype.is_ascii_digit value.[!i] || value.[!i] = '.' || value.[!i] = '-' || value.[!i] = '+') do
345
incr i
346
done;
347
let num_part = String.sub value 0 !i in
···
372
end else if List.mem feature color_features then begin
373
(* Must be an integer *)
374
let value = String.trim value in
375
+
if Datatype.is_all_digits value then Ok ()
376
else
377
Error (Printf.sprintf "\"%s\" is not a \"%s\" value" value base_feature)
378
end else
+1
-2
lib/check/datatype/dt_mime.ml
+1
-2
lib/check/datatype/dt_mime.ml
+1
-1
lib/check/dune
+1
-1
lib/check/dune
-37
lib/check/specialized/h1_checker.ml
-37
lib/check/specialized/h1_checker.ml
···
1
-
(** H1 element counter - warns about multiple h1 elements in a document. *)
2
-
3
-
type state = {
4
-
mutable h1_count : int;
5
-
mutable svg_depth : int; (* Track depth inside SVG *)
6
-
}
7
-
8
-
let create () = {
9
-
h1_count = 0;
10
-
svg_depth = 0;
11
-
}
12
-
13
-
let reset state =
14
-
state.h1_count <- 0;
15
-
state.svg_depth <- 0
16
-
17
-
let start_element state ~element collector =
18
-
(* Track SVG depth - h1 inside SVG (foreignObject, desc) shouldn't count *)
19
-
match element.Element.tag with
20
-
| Tag.Svg _ ->
21
-
state.svg_depth <- state.svg_depth + 1
22
-
| Tag.Html `H1 when state.svg_depth = 0 ->
23
-
state.h1_count <- state.h1_count + 1;
24
-
if state.h1_count > 1 then
25
-
Message_collector.add_typed collector (`Misc `Multiple_h1)
26
-
| Tag.Html _ when state.svg_depth = 0 ->
27
-
() (* Other HTML elements outside SVG *)
28
-
| _ ->
29
-
() (* Non-HTML or inside SVG *)
30
-
31
-
let end_element state ~tag _collector =
32
-
match tag with
33
-
| Tag.Svg _ when state.svg_depth > 0 ->
34
-
state.svg_depth <- state.svg_depth - 1
35
-
| _ -> ()
36
-
37
-
let checker = Checker.make ~create ~reset ~start_element ~end_element ()
···
-16
lib/check/specialized/h1_checker.mli
-16
lib/check/specialized/h1_checker.mli
···
1
-
(** H1 element counter checker.
2
-
3
-
This checker validates that documents don't have multiple h1 elements,
4
-
which can confuse document structure and accessibility tools.
5
-
6
-
{2 Validation Rules}
7
-
8
-
- Documents should have at most one [<h1>] element
9
-
- [<h1>] elements inside SVG content (foreignObject, desc) are not counted
10
-
11
-
{2 Error Messages}
12
-
13
-
- [Multiple_h1]: Document contains more than one h1 element *)
14
-
15
-
val checker : Checker.t
16
-
(** The H1 checker instance. *)
···
+19
-107
lib/check/specialized/heading_checker.ml
+19
-107
lib/check/specialized/heading_checker.ml
···
1
(** Heading structure validation checker.
2
3
This checker validates that:
4
-
- Heading levels don't skip (e.g., h1 to h3)
5
-
- Documents have at least one heading
6
-
- Multiple h1 usage is noted
7
-
- Headings are not empty *)
8
9
(** Checker state tracking heading structure. *)
10
type state = {
11
-
mutable current_level : int option;
12
mutable h1_count : int;
13
-
mutable has_any_heading : bool;
14
-
mutable first_heading_checked : bool;
15
-
mutable in_heading : Tag.html_tag option;
16
-
mutable heading_has_text : bool;
17
mutable svg_depth : int; (* Track depth inside SVG - headings in SVG don't count *)
18
}
19
20
-
let create () =
21
-
{
22
-
current_level = None;
23
-
h1_count = 0;
24
-
has_any_heading = false;
25
-
first_heading_checked = false;
26
-
in_heading = None;
27
-
heading_has_text = false;
28
-
svg_depth = 0;
29
-
}
30
31
let reset state =
32
-
state.current_level <- None;
33
state.h1_count <- 0;
34
-
state.has_any_heading <- false;
35
-
state.first_heading_checked <- false;
36
-
state.in_heading <- None;
37
-
state.heading_has_text <- false;
38
state.svg_depth <- 0
39
40
-
(** Check if text is effectively empty (only whitespace). *)
41
-
let is_empty_text text =
42
-
let rec check i =
43
-
if i >= String.length text then
44
-
true
45
-
else
46
-
match text.[i] with
47
-
| ' ' | '\t' | '\n' | '\r' -> check (i + 1)
48
-
| _ -> false
49
-
in
50
-
check 0
51
-
52
let start_element state ~element collector =
53
match element.Element.tag with
54
| Tag.Svg _ ->
55
-
(* Track SVG depth - headings inside SVG (foreignObject, desc) don't count *)
56
state.svg_depth <- state.svg_depth + 1
57
-
| Tag.Html (#Tag.heading_tag as h) when state.svg_depth = 0 ->
58
-
let level = match Tag.heading_level h with Some l -> l | None -> 0 in
59
-
let name = Tag.html_tag_to_string h in
60
-
state.has_any_heading <- true;
61
-
62
-
(* Check if this is the first heading *)
63
-
if not state.first_heading_checked then begin
64
-
state.first_heading_checked <- true;
65
-
if level <> 1 then
66
-
Message_collector.add_typed collector
67
-
(`Generic (Printf.sprintf
68
-
"First heading in document is <%s>, should typically be <h1>" name))
69
-
end;
70
-
71
-
(* Track h1 count *)
72
-
if level = 1 then begin
73
-
state.h1_count <- state.h1_count + 1;
74
-
if state.h1_count > 1 then
75
-
Message_collector.add_typed collector (`Misc `Multiple_h1)
76
-
end;
77
-
78
-
(* Check for skipped levels *)
79
-
begin match state.current_level with
80
-
| None ->
81
-
state.current_level <- Some level
82
-
| Some prev_level ->
83
-
let diff = level - prev_level in
84
-
if diff > 1 then
85
-
Message_collector.add_typed collector
86
-
(`Generic (Printf.sprintf
87
-
"Heading level skipped: <%s> follows <h%d>, skipping %d level%s. This can confuse screen reader users"
88
-
name prev_level (diff - 1) (if diff > 2 then "s" else "")));
89
-
state.current_level <- Some level
90
-
end;
91
-
92
-
(* Track that we're in a heading to check for empty content *)
93
-
state.in_heading <- Some h;
94
-
state.heading_has_text <- false
95
| _ -> ()
96
97
-
let end_element state ~tag collector =
98
-
(* Track SVG depth *)
99
-
(match tag with
100
-
| Tag.Svg _ when state.svg_depth > 0 ->
101
-
state.svg_depth <- state.svg_depth - 1
102
-
| _ -> ());
103
-
(* Check for empty headings *)
104
-
match state.in_heading, tag with
105
-
| Some h, Tag.Html h2 when h = h2 ->
106
-
if not state.heading_has_text then
107
-
Message_collector.add_typed collector
108
-
(`Generic (Printf.sprintf
109
-
"Heading <%s> is empty or contains only whitespace. Empty headings are problematic for screen readers"
110
-
(Tag.html_tag_to_string h)));
111
-
state.in_heading <- None;
112
-
state.heading_has_text <- false
113
| _ -> ()
114
115
-
let characters state text _collector =
116
-
(* If we're inside a heading, check if this text is non-whitespace *)
117
-
match state.in_heading with
118
-
| Some _ ->
119
-
if not (is_empty_text text) then
120
-
state.heading_has_text <- true
121
-
| None ->
122
-
()
123
-
124
-
let end_document state collector =
125
-
if not state.has_any_heading then
126
-
Message_collector.add_typed collector
127
-
(`Generic "Document contains no heading elements (h1-h6). Headings provide important document structure for accessibility")
128
-
129
-
let checker = Checker.make ~create ~reset ~start_element ~end_element
130
-
~characters ~end_document ()
···
1
(** Heading structure validation checker.
2
3
This checker validates that:
4
+
- Multiple h1 usage is reported as an error
5
+
6
+
Note: Additional accessibility checks (first heading should be h1, skipped
7
+
levels, empty headings) are intentionally not included as errors since they
8
+
are recommendations rather than HTML5 spec requirements. *)
9
10
(** Checker state tracking heading structure. *)
11
type state = {
12
mutable h1_count : int;
13
mutable svg_depth : int; (* Track depth inside SVG - headings in SVG don't count *)
14
}
15
16
+
let create () = {
17
+
h1_count = 0;
18
+
svg_depth = 0;
19
+
}
20
21
let reset state =
22
state.h1_count <- 0;
23
state.svg_depth <- 0
24
25
let start_element state ~element collector =
26
match element.Element.tag with
27
| Tag.Svg _ ->
28
+
(* Track SVG depth - h1 inside SVG (foreignObject, desc) shouldn't count *)
29
state.svg_depth <- state.svg_depth + 1
30
+
| Tag.Html `H1 when state.svg_depth = 0 ->
31
+
state.h1_count <- state.h1_count + 1;
32
+
if state.h1_count > 1 then
33
+
Message_collector.add_typed collector (`Misc `Multiple_h1)
34
| _ -> ()
35
36
+
let end_element state ~tag _collector =
37
+
match tag with
38
+
| Tag.Svg _ when state.svg_depth > 0 ->
39
+
state.svg_depth <- state.svg_depth - 1
40
| _ -> ()
41
42
+
let checker = Checker.make ~create ~reset ~start_element ~end_element ()