more

lib/html5_checker/checker_registry.ml

···
   Hashtbl.replace reg "mime-type" Mime_type_checker.checker;
   Hashtbl.replace reg "normalization" Normalization_checker.checker;
   Hashtbl.replace reg "svg" Svg_checker.checker;
+  Hashtbl.replace reg "xhtml-content" Xhtml_content_checker.checker;
   (* Hashtbl.replace reg "heading" Heading_checker.checker; *)
   (* Hashtbl.replace reg "content" Content_checker.checker; *)
   reg

lib/html5_checker/dune

···
 (library
  (name html5_checker)
  (public_name html5rw.checker)
- (libraries html5rw jsont jsont.bytesrw astring str uunf uutf)
+ (libraries html5rw jsont jsont.bytesrw astring str uunf uutf xmlm)
 )

lib/html5_checker/html5_checker.ml

···
 }
 
 let check ?(collect_parse_errors = true) ?system_id reader =
-  let doc = Html5rw.parse ~collect_errors:collect_parse_errors reader in
   let collector = Message_collector.create () in
 
-  (* Add parse errors if collected *)
-  if collect_parse_errors then begin
-    let parse_errors = Parse_error_bridge.collect_parse_errors ?system_id doc in
-    List.iter (Message_collector.add collector) parse_errors
-  end;
+  (* Check if this is an XHTML file - use XML parser if so *)
+  if Xhtml_parser.is_xhtml_file system_id then begin
+    (* Read all content for XHTML parsing *)
+    let content = Bytesrw.Bytes.Reader.to_string reader in
+
+    match Xhtml_parser.parse_xhtml content with
+    | Ok root ->
+        (* Run all registered checkers via DOM traversal *)
+        let registry = Checker_registry.default () in
+        Dom_walker.walk_registry registry collector root;
+        let dummy_doc = Html5rw.parse (Bytesrw.Bytes.Reader.of_string "") in
+        { doc = dummy_doc; msgs = Message_collector.messages collector; system_id }
+    | Error msg ->
+        Message_collector.add_error collector ~message:msg ~code:"xml-parse-error" ();
+        let dummy_doc = Html5rw.parse (Bytesrw.Bytes.Reader.of_string "") in
+        { doc = dummy_doc; msgs = Message_collector.messages collector; system_id }
+  end
+  else begin
+    (* Standard HTML5 parsing *)
+    let doc = Html5rw.parse ~collect_errors:collect_parse_errors reader in
 
-  (* Run all registered checkers via DOM traversal *)
-  let registry = Checker_registry.default () in
-  Dom_walker.walk_registry registry collector (Html5rw.root doc);
+    (* Add parse errors if collected *)
+    if collect_parse_errors then begin
+      let parse_errors = Parse_error_bridge.collect_parse_errors ?system_id doc in
+      List.iter (Message_collector.add collector) parse_errors
+    end;
 
-  { doc; msgs = Message_collector.messages collector; system_id }
+    (* Run all registered checkers via DOM traversal *)
+    let registry = Checker_registry.default () in
+    Dom_walker.walk_registry registry collector (Html5rw.root doc);
+
+    { doc; msgs = Message_collector.messages collector; system_id }
+  end
 
 let check_dom ?(collect_parse_errors = true) ?system_id doc =
   let collector = Message_collector.create () in

lib/html5_checker/semantic/required_attr_checker.ml

···
 type state = {
   mutable _in_figure : bool;
   (** Track if we're inside a <figure> element (alt is more critical there) *)
+  mutable in_a_with_href : bool;
+  (** Track if we're inside an <a> element with href attribute *)
 }
 
-let create () = { _in_figure = false }
+let create () = { _in_figure = false; in_a_with_href = false }
 
-let reset state = state._in_figure <- false
+let reset state =
+  state._in_figure <- false;
+  state.in_a_with_href <- false
 
 (** Check if an attribute list contains a specific attribute. *)
 let has_attr name attrs =
···
       if String.equal attr_name name then Some value else None)
     attrs
 
-let check_img_element attrs collector =
+let check_img_element state attrs collector =
   (* Check for required src OR srcset attribute *)
   if not (has_attr "src" attrs) && not (has_attr "srcset" attrs) then
     Message_collector.add_error collector
···
   if not (has_attr "alt" attrs) then
     Message_collector.add_error collector
       ~message:"img element requires alt attribute for accessibility"
-      ~code:"missing-required-attribute" ~element:"img" ~attribute:"alt" ()
+      ~code:"missing-required-attribute" ~element:"img" ~attribute:"alt" ();
+
+  (* Check ismap requires 'a' ancestor with href *)
+  if has_attr "ismap" attrs && not state.in_a_with_href then
+    Message_collector.add_error collector
+      ~message:"The \xe2\x80\x9cimg\xe2\x80\x9d element with the \xe2\x80\x9cismap\xe2\x80\x9d attribute set must have an \xe2\x80\x9ca\xe2\x80\x9d ancestor with the \xe2\x80\x9chref\xe2\x80\x9d attribute."
+      ~code:"missing-required-ancestor" ~element:"img" ~attribute:"ismap" ()
 
 let check_area_element attrs collector =
   (* area with href requires alt *)
···
         ~code:"bad-attribute-value" ~element:"div" ~attribute:"popover" ()
   | None -> ()
 
+let check_meter_element attrs collector =
+  (* meter requires value attribute *)
+  if not (has_attr "value" attrs) then
+    Message_collector.add_error collector
+      ~message:"Element \xe2\x80\x9cmeter\xe2\x80\x9d is missing required attribute \xe2\x80\x9cvalue\xe2\x80\x9d."
+      ~code:"missing-required-attribute" ~element:"meter" ~attribute:"value" ()
+  else begin
+    (* Validate min <= value constraint *)
+    match get_attr "value" attrs, get_attr "min" attrs with
+    | Some value_str, Some min_str ->
+        (try
+          let value = float_of_string value_str in
+          let min_val = float_of_string min_str in
+          if min_val > value then
+            Message_collector.add_error collector
+              ~message:"The value of the \xe2\x80\x9cmin\xe2\x80\x9d attribute must be less than or equal to the value of the \xe2\x80\x9cvalue\xe2\x80\x9d attribute."
+              ~code:"bad-attribute-value" ~element:"meter" ~attribute:"min" ()
+        with _ -> ())
+    | _ -> ()
+  end
+
+let check_progress_element attrs collector =
+  (* Validate progress value constraints *)
+  match get_attr "value" attrs with
+  | None -> ()  (* value is optional *)
+  | Some value_str ->
+      (try
+        let value = float_of_string value_str in
+        let max_val = match get_attr "max" attrs with
+          | None -> 1.0  (* default max is 1 *)
+          | Some max_str -> (try float_of_string max_str with _ -> 1.0)
+        in
+        if value > max_val then
+          (* Check which message to use based on whether max is present *)
+          if has_attr "max" attrs then
+            Message_collector.add_error collector
+              ~message:"The value of the  \xe2\x80\x9cvalue\xe2\x80\x9d attribute must be less than or equal to the value of the \xe2\x80\x9cmax\xe2\x80\x9d attribute."
+              ~code:"bad-attribute-value" ~element:"progress" ~attribute:"value" ()
+          else
+            Message_collector.add_error collector
+              ~message:"The value of the  \xe2\x80\x9cvalue\xe2\x80\x9d attribute must be less than or equal to one when the \xe2\x80\x9cmax\xe2\x80\x9d attribute is absent."
+              ~code:"bad-attribute-value" ~element:"progress" ~attribute:"value" ()
+      with _ -> ())
+
 let start_element state ~name ~namespace:_ ~attrs collector =
   match name with
-  | "img" -> check_img_element attrs collector
+  | "img" -> check_img_element state attrs collector
   | "area" -> check_area_element attrs collector
   | "input" -> check_input_element attrs collector
   | "script" -> check_script_element attrs collector
   | "meta" -> check_meta_element attrs collector
   | "link" -> check_link_element attrs collector
-  | "a" -> check_a_element attrs collector
+  | "a" ->
+      check_a_element attrs collector;
+      if has_attr "href" attrs then state.in_a_with_href <- true
   | "map" -> check_map_element attrs collector
   | "object" -> check_object_element attrs collector
+  | "meter" -> check_meter_element attrs collector
+  | "progress" -> check_progress_element attrs collector
   | "figure" -> state._in_figure <- true
   | _ ->
     (* Check popover attribute on any element *)
     if has_attr "popover" attrs then check_popover_element attrs collector
 
 let end_element state ~name ~namespace:_ _collector =
-  match name with "figure" -> state._in_figure <- false | _ -> ()
+  match name with
+  | "figure" -> state._in_figure <- false
+  | "a" -> state.in_a_with_href <- false
+  | _ -> ()
 
 let characters _state _text _collector = ()
 

lib/html5_checker/specialized/xhtml_content_checker.ml

···
+(** XHTML content model checker.
+
+    Validates specific content model rules that the Nu validator checks,
+    particularly for elements that don't allow text content or specific children. *)
+
+type state = {
+  mutable element_stack : string list;
+}
+
+let create () = { element_stack = [] }
+
+let reset state = state.element_stack <- []
+
+(* Elements that don't allow direct text content (only specific child elements) *)
+let no_text_elements = [
+  "menu";     (* Only li elements *)
+  "iframe";   (* In XHTML mode, no content allowed *)
+  "figure";   (* Only figcaption and flow content, not bare text *)
+]
+
+
+(* Check if an element is allowed as child of parent *)
+let is_child_allowed ~parent ~child =
+  match parent with
+  | "menu" ->
+      (* menu only allows li, script, template *)
+      List.mem child ["li"; "script"; "template"]
+  | _ -> true
+
+(* Check if text is allowed in element *)
+let is_text_allowed element =
+  not (List.mem element no_text_elements)
+
+(* Check if data-* attribute has uppercase characters *)
+let check_data_attr_case attrs collector =
+  List.iter (fun (attr_name, _) ->
+    if String.length attr_name > 5 &&
+       String.sub attr_name 0 5 = "data-" then
+      let suffix = String.sub attr_name 5 (String.length attr_name - 5) in
+      if String.exists (fun c -> c >= 'A' && c <= 'Z') suffix then
+        Message_collector.add_error collector
+          ~message:"\xe2\x80\x9cdata-*\xe2\x80\x9d attributes must not have characters from the range \xe2\x80\x9cA\xe2\x80\x9d\xe2\x80\xa6\xe2\x80\x9cZ\xe2\x80\x9d in the name."
+          ~attribute:attr_name
+          ()
+  ) attrs
+
+let start_element state ~name ~namespace ~attrs collector =
+  ignore namespace;
+  let name_lower = String.lowercase_ascii name in
+
+  (* Check data-* attributes for uppercase *)
+  check_data_attr_case attrs collector;
+
+  (* Check if this element is allowed as child of parent *)
+  (match state.element_stack with
+  | parent :: _ ->
+      let parent_lower = String.lowercase_ascii parent in
+      if not (is_child_allowed ~parent:parent_lower ~child:name_lower) then
+        Message_collector.add_error collector
+          ~message:(Printf.sprintf
+            "Element \xe2\x80\x9c%s\xe2\x80\x9d not allowed as child of element \xe2\x80\x9c%s\xe2\x80\x9d in this context. (Suppressing further errors from this subtree.)"
+            name_lower parent_lower)
+          ~element:name_lower
+          ()
+  | [] -> ());
+
+  (* Push onto stack *)
+  state.element_stack <- name :: state.element_stack
+
+let end_element state ~name:_ ~namespace:_ _collector =
+  (* Pop from stack *)
+  match state.element_stack with
+  | _ :: rest -> state.element_stack <- rest
+  | [] -> ()
+
+let characters state text collector =
+  (* Check if text is allowed in current element *)
+  match state.element_stack with
+  | [] -> ()  (* Root level - ignore *)
+  | parent :: _ ->
+      let parent_lower = String.lowercase_ascii parent in
+      (* Only report non-whitespace text *)
+      let trimmed = String.trim text in
+      if trimmed <> "" && not (is_text_allowed parent_lower) then
+        Message_collector.add_error collector
+          ~message:(Printf.sprintf
+            "Text not allowed in element \xe2\x80\x9c%s\xe2\x80\x9d in this context."
+            parent_lower)
+          ~element:parent_lower
+          ()
+
+let end_document _state _collector = ()
+
+let checker =
+  (module struct
+    type nonrec state = state
+    let create = create
+    let reset = reset
+    let start_element = start_element
+    let end_element = end_element
+    let characters = characters
+    let end_document = end_document
+  end : Checker.S)

lib/html5_checker/specialized/xhtml_content_checker.mli

···
+(** XHTML content model checker.
+
+    Validates specific content model rules for XHTML. *)
+
+val checker : Checker.t

lib/html5_checker/xhtml_parser.ml

···
+(** XHTML parser using xmlm for proper XML parsing.
+
+    This module provides XML parsing for XHTML files, which the HTML5 parser
+    cannot handle correctly (especially self-closing tags on non-void elements). *)
+
+(** Parse XHTML content using xmlm and return a DOM tree. *)
+let parse_xhtml content =
+  let input = Xmlm.make_input (`String (0, content)) in
+
+  (* Stack of nodes during parsing *)
+  let stack = ref [] in
+  let root = Html5rw.Dom.create_document () in
+  stack := [root];
+
+  (* Helper to get namespace shorthand *)
+  let ns_shorthand ns =
+    if ns = "http://www.w3.org/2000/svg" then Some "svg"
+    else if ns = "http://www.w3.org/1998/Math/MathML" then Some "mathml"
+    else if ns = "http://www.w3.org/1999/xhtml" then None  (* HTML namespace *)
+    else if ns = "" then None  (* No namespace = HTML *)
+    else Some ns  (* Keep other namespaces as-is *)
+  in
+
+  (* Process xmlm signals *)
+  let rec process () =
+    if Xmlm.eoi input then ()
+    else begin
+      match Xmlm.input input with
+      | `Dtd _ ->
+          (* Skip DTD for now *)
+          process ()
+      | `El_start ((ns, local), attrs) ->
+          (* Create element node *)
+          let namespace = ns_shorthand ns in
+          let attr_list = List.map (fun ((_, aname), aval) -> (aname, aval)) attrs in
+          let node = Html5rw.Dom.create_element local ~namespace ~attrs:attr_list () in
+          (* Append to current parent *)
+          (match !stack with
+          | parent :: _ -> Html5rw.Dom.append_child parent node
+          | [] -> ());
+          (* Push onto stack *)
+          stack := node :: !stack;
+          process ()
+      | `El_end ->
+          (* Pop from stack *)
+          (match !stack with
+          | _ :: rest -> stack := rest
+          | [] -> ());
+          process ()
+      | `Data text ->
+          (* Create text node and append to current parent *)
+          let trimmed = String.trim text in
+          if trimmed <> "" || String.length text > 0 then begin
+            let text_node = Html5rw.Dom.create_text text in
+            (match !stack with
+            | parent :: _ -> Html5rw.Dom.append_child parent text_node
+            | [] -> ())
+          end;
+          process ()
+    end
+  in
+
+  try
+    process ();
+    Ok root
+  with
+  | Xmlm.Error ((line, col), err) ->
+      Error (Printf.sprintf "XML parse error at %d:%d: %s" line col (Xmlm.error_message err))
+
+(** Check if a system_id indicates an XHTML file. *)
+let is_xhtml_file system_id =
+  match system_id with
+  | Some path ->
+      String.length path > 6 &&
+      String.sub path (String.length path - 6) 6 = ".xhtml"
+  | None -> false
+
+(** Wrap DOM in an Html5rw.t-compatible structure for the checker. *)
+type xhtml_doc = {
+  root : Html5rw.Dom.node;
+  errors : Html5rw.Error.t list;
+}
+
+let xhtml_root doc = doc.root
+let xhtml_errors _doc = []  (* XML parser handles errors differently *)

test/debug_check.ml

···
 let () =
-  let test_file = "validator/tests/xhtml/elements/progress/002-isvalid.xhtml" in
+  let test_file = "validator/tests/xhtml/elements/menu/menu-containing-text-novalid.xhtml" in
   let ic = open_in test_file in
   let html = really_input_string ic (in_channel_length ic) in
   close_in ic;
···
   print_endline "=== Errors ===";
   List.iter (fun e -> print_endline e.Html5_checker.Message.message) errors;
   print_endline "\n=== Expected ===";
-  print_endline "Element \xe2\x80\x9crect\xe2\x80\x9d is missing required attribute \xe2\x80\x9cheight\xe2\x80\x9d."
+  print_endline "Text not allowed in element \xe2\x80\x9cmenu\xe2\x80\x9d in this context."