more

lib/htmlrw_check/checker.ml

···
 end
 
 let noop () = (module Noop : S)
+
+(** Input signature for Make functor *)
+module type Input = sig
+  type state
+  val create : unit -> state
+  val reset : state -> unit
+  val start_element : state -> element:Element.t -> Message_collector.t -> unit
+  val end_element : state -> tag:Tag.element_tag -> Message_collector.t -> unit
+  val characters : (state -> string -> Message_collector.t -> unit) option
+  val end_document : (state -> Message_collector.t -> unit) option
+end
+
+(** Functor to create a checker with default implementations for optional callbacks *)
+module Make (I : Input) : S with type state = I.state = struct
+  type state = I.state
+
+  let create = I.create
+  let reset = I.reset
+  let start_element = I.start_element
+  let end_element = I.end_element
+
+  let characters = match I.characters with
+    | Some f -> f
+    | None -> fun _ _ _ -> ()
+
+  let end_document = match I.end_document with
+    | Some f -> f
+    | None -> fun _ _ -> ()
+end

lib/htmlrw_check/checker.mli

···
       (* Does nothing when walked over a DOM tree *)
     ]}
 *)
+
+(** {1 Checker Construction Helpers} *)
+
+(** Input signature for {!Make} functor.
+
+    Only the required callbacks need to be provided. Optional callbacks
+    (characters, end_document) default to no-op implementations. *)
+module type Input = sig
+  type state
+  val create : unit -> state
+  val reset : state -> unit
+  val start_element : state -> element:Element.t -> Message_collector.t -> unit
+  val end_element : state -> tag:Tag.element_tag -> Message_collector.t -> unit
+
+  (** Optional: called for text content. Default: no-op. *)
+  val characters : (state -> string -> Message_collector.t -> unit) option
+
+  (** Optional: called at document end. Default: no-op. *)
+  val end_document : (state -> Message_collector.t -> unit) option
+end
+
+(** Functor to create a checker from an {!Input} module.
+
+    This reduces boilerplate when creating checkers that don't need
+    to handle all events. The characters and end_document callbacks
+    default to no-ops if not provided.
+
+    {b Example:}
+    {[
+      let checker = Checker.Make(struct
+        type state = { mutable count : int }
+        let create () = { count = 0 }
+        let reset s = s.count <- 0
+        let start_element s ~element collector =
+          s.count <- s.count + 1
+        let end_element _ ~tag:_ _ = ()
+        let characters = None  (* Use default no-op *)
+        let end_document = None  (* Use default no-op *)
+      end)
+    ]}
+*)
+module Make : functor (I : Input) -> S with type state = I.state

lib/htmlrw_check/context_tracker.ml

···
+(** Reusable context/ancestor tracking for checkers.
+
+    Many checkers need to track element ancestors, depth, or maintain
+    context stacks during DOM traversal. This module provides common
+    utilities to reduce duplication. *)
+
+(** Generic stack-based context tracker. *)
+module Stack : sig
+  type 'a t
+
+  (** Create an empty context stack. *)
+  val create : unit -> 'a t
+
+  (** Reset the stack to empty. *)
+  val reset : 'a t -> unit
+
+  (** Push a context onto the stack. *)
+  val push : 'a t -> 'a -> unit
+
+  (** Pop a context from the stack. Returns None if empty. *)
+  val pop : 'a t -> 'a option
+
+  (** Get the current (top) context without removing it. *)
+  val current : 'a t -> 'a option
+
+  (** Get current depth (number of items on stack). *)
+  val depth : 'a t -> int
+
+  (** Check if stack is empty. *)
+  val is_empty : 'a t -> bool
+
+  (** Get all ancestors (bottom to top). *)
+  val to_list : 'a t -> 'a list
+
+  (** Check if any ancestor satisfies predicate. *)
+  val exists : 'a t -> ('a -> bool) -> bool
+
+  (** Find first ancestor satisfying predicate (top to bottom). *)
+  val find : 'a t -> ('a -> bool) -> 'a option
+
+  (** Iterate over all contexts (top to bottom). *)
+  val iter : 'a t -> ('a -> unit) -> unit
+end = struct
+  type 'a t = { mutable stack : 'a list }
+
+  let create () = { stack = [] }
+  let reset t = t.stack <- []
+  let push t x = t.stack <- x :: t.stack
+  let pop t = match t.stack with
+    | [] -> None
+    | x :: rest -> t.stack <- rest; Some x
+  let current t = match t.stack with
+    | [] -> None
+    | x :: _ -> Some x
+  let depth t = List.length t.stack
+  let is_empty t = t.stack = []
+  let to_list t = List.rev t.stack
+  let exists t f = List.exists f t.stack
+  let find t f = List.find_opt f t.stack
+  let iter t f = List.iter f t.stack
+end
+
+(** Simple depth counter for tracking nesting level. *)
+module Depth : sig
+  type t
+
+  (** Create a depth counter starting at 0. *)
+  val create : unit -> t
+
+  (** Reset depth to 0. *)
+  val reset : t -> unit
+
+  (** Increment depth (entering element). *)
+  val enter : t -> unit
+
+  (** Decrement depth (leaving element). Returns false if was already 0. *)
+  val leave : t -> bool
+
+  (** Get current depth. *)
+  val get : t -> int
+
+  (** Check if inside (depth > 0). *)
+  val is_inside : t -> bool
+end = struct
+  type t = { mutable depth : int }
+
+  let create () = { depth = 0 }
+  let reset t = t.depth <- 0
+  let enter t = t.depth <- t.depth + 1
+  let leave t =
+    if t.depth > 0 then begin
+      t.depth <- t.depth - 1;
+      true
+    end else false
+  let get t = t.depth
+  let is_inside t = t.depth > 0
+end
+
+(** Element name stack for tracking ancestors by name. *)
+module Ancestors : sig
+  type t
+
+  (** Create an empty ancestor tracker. *)
+  val create : unit -> t
+
+  (** Reset to empty. *)
+  val reset : t -> unit
+
+  (** Push an element name onto the ancestor stack. *)
+  val push : t -> string -> unit
+
+  (** Pop an element from the ancestor stack. *)
+  val pop : t -> unit
+
+  (** Get the immediate parent element name. *)
+  val parent : t -> string option
+
+  (** Check if an element name is an ancestor. *)
+  val has_ancestor : t -> string -> bool
+
+  (** Get depth (number of ancestors). *)
+  val depth : t -> int
+
+  (** Get all ancestor names (outermost first). *)
+  val to_list : t -> string list
+end = struct
+  type t = { mutable stack : string list }
+
+  let create () = { stack = [] }
+  let reset t = t.stack <- []
+  let push t name = t.stack <- name :: t.stack
+  let pop t = match t.stack with
+    | _ :: rest -> t.stack <- rest
+    | [] -> ()
+  let parent t = match t.stack with
+    | x :: _ -> Some x
+    | [] -> None
+  let has_ancestor t name = List.mem name t.stack
+  let depth t = List.length t.stack
+  let to_list t = List.rev t.stack
+end

lib/htmlrw_check/context_tracker.mli

···
+(** Reusable context/ancestor tracking for checkers.
+
+    Many checkers need to track element ancestors, depth, or maintain
+    context stacks during DOM traversal. This module provides common
+    utilities to reduce duplication across checkers.
+
+    {2 Available Trackers}
+
+    - {!Stack}: Generic stack for any context type
+    - {!Depth}: Simple integer depth counter
+    - {!Ancestors}: String-based element ancestor tracking *)
+
+(** {2 Generic Stack} *)
+
+(** Generic stack-based context tracker.
+
+    Use this when you need to track complex state at each nesting level.
+    For example, tracking whether each ancestor has certain attributes. *)
+module Stack : sig
+  type 'a t
+
+  (** Create an empty context stack. *)
+  val create : unit -> 'a t
+
+  (** Reset the stack to empty. *)
+  val reset : 'a t -> unit
+
+  (** Push a context onto the stack. *)
+  val push : 'a t -> 'a -> unit
+
+  (** Pop a context from the stack. Returns None if empty. *)
+  val pop : 'a t -> 'a option
+
+  (** Get the current (top) context without removing it. *)
+  val current : 'a t -> 'a option
+
+  (** Get current depth (number of items on stack). *)
+  val depth : 'a t -> int
+
+  (** Check if stack is empty. *)
+  val is_empty : 'a t -> bool
+
+  (** Get all ancestors (bottom to top). *)
+  val to_list : 'a t -> 'a list
+
+  (** Check if any ancestor satisfies predicate. *)
+  val exists : 'a t -> ('a -> bool) -> bool
+
+  (** Find first ancestor satisfying predicate (top to bottom). *)
+  val find : 'a t -> ('a -> bool) -> 'a option
+
+  (** Iterate over all contexts (top to bottom). *)
+  val iter : 'a t -> ('a -> unit) -> unit
+end
+
+(** {2 Depth Counter} *)
+
+(** Simple depth counter for tracking nesting level.
+
+    Use this when you only need to know if you're inside a certain
+    element type, not the full context at each level. *)
+module Depth : sig
+  type t
+
+  (** Create a depth counter starting at 0. *)
+  val create : unit -> t
+
+  (** Reset depth to 0. *)
+  val reset : t -> unit
+
+  (** Increment depth (entering element). *)
+  val enter : t -> unit
+
+  (** Decrement depth (leaving element). Returns false if was already 0. *)
+  val leave : t -> bool
+
+  (** Get current depth. *)
+  val get : t -> int
+
+  (** Check if inside (depth > 0). *)
+  val is_inside : t -> bool
+end
+
+(** {2 Ancestor Tracker} *)
+
+(** Element name stack for tracking ancestors by name.
+
+    Use this when you need to check if certain elements are ancestors,
+    but don't need complex context at each level. *)
+module Ancestors : sig
+  type t
+
+  (** Create an empty ancestor tracker. *)
+  val create : unit -> t
+
+  (** Reset to empty. *)
+  val reset : t -> unit
+
+  (** Push an element name onto the ancestor stack. *)
+  val push : t -> string -> unit
+
+  (** Pop an element from the ancestor stack. *)
+  val pop : t -> unit
+
+  (** Get the immediate parent element name. *)
+  val parent : t -> string option
+
+  (** Check if an element name is an ancestor. *)
+  val has_ancestor : t -> string -> bool
+
+  (** Get depth (number of ancestors). *)
+  val depth : t -> int
+
+  (** Get all ancestor names (outermost first). *)
+  val to_list : t -> string list
+end

lib/htmlrw_check/datatype/datatype.ml

···
   let end_pos = find_end (len - 1) in
   if start > end_pos then ""
   else String.sub s start (end_pos - start + 1)
+
+(** Factory for creating enum-based validators.
+    Many HTML attributes accept a fixed set of keyword values. *)
+let make_enum ~name ~values ?(allow_empty = true) () : t =
+  let values_set = List.map String.lowercase_ascii values in
+  let values_str = String.concat ", " (List.map (Printf.sprintf "'%s'") values) in
+  (module struct
+    let name = name
+    let validate s =
+      let s_lower = string_to_ascii_lowercase s in
+      if (allow_empty && s = "") || List.mem s_lower values_set then Ok ()
+      else Error (Printf.sprintf "The value '%s' is not a valid %s value. Expected %s%s."
+        s name (if allow_empty then "empty string, " else "") values_str)
+    let is_valid s = Result.is_ok (validate s)
+  end : S)

lib/htmlrw_check/datatype/datatype.mli

···
 
 (** Trim HTML5 whitespace from both ends of a string. *)
 val trim_html_spaces : string -> string
+
+(** {2 Datatype Factories} *)
+
+(** Create an enum-based validator for attributes with fixed keyword values.
+    @param name The datatype name (e.g., "loading", "crossorigin")
+    @param values List of valid keyword values (case-insensitive)
+    @param allow_empty Whether empty string is valid (default: true) *)
+val make_enum : name:string -> values:string list -> ?allow_empty:bool -> unit -> t

lib/htmlrw_check/error_code.ml

···
 
   (* Generic *)
   | `Generic message -> message
+
+(** {2 Error Construction Helpers} *)
+
+(** Create a bad attribute value error with element, attribute, value, and reason. *)
+let bad_value ~element ~attr ~value ~reason : t =
+  `Attr (`Bad_value (`Elem element, `Attr attr, `Value value, `Reason reason))
+
+(** Create a bad attribute value error with just a message. *)
+let bad_value_msg msg : t =
+  `Attr (`Bad_value_generic (`Message msg))
+
+(** Create a missing required attribute error. *)
+let missing_attr ~element ~attr : t =
+  `Attr (`Missing (`Elem element, `Attr attr))
+
+(** Create an attribute not allowed error. *)
+let attr_not_allowed ~element ~attr : t =
+  `Attr (`Not_allowed (`Attr attr, `Elem element))
+
+(** Create an element not allowed as child error. *)
+let not_allowed_as_child ~child ~parent : t =
+  `Element (`Not_allowed_as_child (`Child child, `Parent parent))
+
+(** Create a must not be empty error. *)
+let must_not_be_empty ~element : t =
+  `Element (`Must_not_be_empty (`Elem element))

lib/htmlrw_check/error_code.mli

···
 (** Format a string with Unicode curly quotes.
     Wraps the string in U+201C and U+201D ("..."). *)
 val q : string -> string
+
+(** {1 Error Construction Helpers}
+
+    These functions simplify creating common error types. *)
+
+(** Create a bad attribute value error.
+    Example: [bad_value ~element:"img" ~attr:"src" ~value:"" ~reason:"URL cannot be empty"] *)
+val bad_value : element:string -> attr:string -> value:string -> reason:string -> t
+
+(** Create a bad attribute value error with just a message.
+    Example: [bad_value_msg "The value must be a valid URL"] *)
+val bad_value_msg : string -> t
+
+(** Create a missing required attribute error.
+    Example: [missing_attr ~element:"img" ~attr:"alt"] *)
+val missing_attr : element:string -> attr:string -> t
+
+(** Create an attribute not allowed error.
+    Example: [attr_not_allowed ~element:"span" ~attr:"href"] *)
+val attr_not_allowed : element:string -> attr:string -> t
+
+(** Create an element not allowed as child error.
+    Example: [not_allowed_as_child ~child:"div" ~parent:"p"] *)
+val not_allowed_as_child : child:string -> parent:string -> t
+
+(** Create a must not be empty error.
+    Example: [must_not_be_empty ~element:"title"] *)
+val must_not_be_empty : element:string -> t

lib/htmlrw_check/specialized/h1_checker.mli

···
-(*---------------------------------------------------------------------------
-  Copyright (c) 2025 Anil Madhavapeddy <[e-mail]>. All rights reserved.
-  SPDX-License-Identifier: MIT
- ---------------------------------------------------------------------------*)
+(** H1 element counter checker.
 
-(** H1 element counter and validator.
+    This checker validates that documents don't have multiple h1 elements,
+    which can confuse document structure and accessibility tools.
 
-    This checker warns about multiple [<h1>] elements in a document.
-    While HTML5 technically allows multiple [<h1>] elements when using
-    the document outline algorithm, this algorithm was never implemented
-    by browsers and has been removed from the specification.
+    {2 Validation Rules}
 
-    {2 Best Practice}
-
-    Documents should have exactly one [<h1>] element that represents the
-    main heading of the page. Multiple [<h1>] elements can confuse users
-    and assistive technologies about the document's structure.
-
-    {2 Special Cases}
-
-    - [<h1>] elements inside [<svg>] content (e.g., in [<foreignObject>])
-      are not counted, as they may represent different content contexts
-    - The checker reports a warning after the second [<h1>] is encountered
+    - Documents should have at most one [<h1>] element
+    - [<h1>] elements inside SVG content (foreignObject, desc) are not counted
 
     {2 Error Messages}
 
-    Reports [Multiple_h1] when more than one [<h1>] element is found
-    in the document.
-
-    @see <https://html.spec.whatwg.org/multipage/sections.html#the-h1,-h2,-h3,-h4,-h5,-and-h6-elements>
-         HTML Standard: The h1-h6 elements
-*)
+    - [Multiple_h1]: Document contains more than one h1 element *)
 
 val checker : Checker.t
-(** The h1 element counter/validator instance. *)
+(** The H1 checker instance. *)

lib/htmlrw_check/specialized/heading_checker.ml

···
   mutable first_heading_checked : bool;
   mutable in_heading : Tag.html_tag option;
   mutable heading_has_text : bool;
+  mutable svg_depth : int;  (* Track depth inside SVG - headings in SVG don't count *)
 }
 
 let create () =
···
     first_heading_checked = false;
     in_heading = None;
     heading_has_text = false;
+    svg_depth = 0;
   }
 
 let reset state =
···
   state.has_any_heading <- false;
   state.first_heading_checked <- false;
   state.in_heading <- None;
-  state.heading_has_text <- false
+  state.heading_has_text <- false;
+  state.svg_depth <- 0
 
 (** Check if text is effectively empty (only whitespace). *)
 let is_empty_text text =
···
 
 let start_element state ~element collector =
   match element.Element.tag with
-  | Tag.Html (#Tag.heading_tag as h) ->
+  | Tag.Svg _ ->
+    (* Track SVG depth - headings inside SVG (foreignObject, desc) don't count *)
+    state.svg_depth <- state.svg_depth + 1
+  | Tag.Html (#Tag.heading_tag as h) when state.svg_depth = 0 ->
     let level = match Tag.heading_level h with Some l -> l | None -> 0 in
     let name = Tag.html_tag_to_string h in
     state.has_any_heading <- true;
···
   | _ -> ()
 
 let end_element state ~tag collector =
+  (* Track SVG depth *)
+  (match tag with
+   | Tag.Svg _ when state.svg_depth > 0 ->
+     state.svg_depth <- state.svg_depth - 1
+   | _ -> ());
+  (* Check for empty headings *)
   match state.in_heading, tag with
   | Some h, Tag.Html h2 when h = h2 ->
     if not state.heading_has_text then