ocaml-html5rw / test / test_validator.ml

(** Test runner for Nu HTML Validator test suite

    This validates HTML5 documents against the upstream Nu HTML Validator test suite.
    Tests are classified by filename suffix:
    - `-isvalid.html` : Should produce no errors or warnings
    - `-novalid.html` : Should produce at least one error
    - `-haswarn.html` : Should produce at least one warning
*)

module Report = Test_report

type expected_outcome =
  | Valid      (** -isvalid.html: expect no errors *)
  | Invalid    (** -novalid.html: expect error matching messages.json *)
  | HasWarning (** -haswarn.html: expect warning matching messages.json *)
  | Unknown    (** Unknown suffix *)

type test_file = {
  path : string;           (** Full filesystem path *)
  relative_path : string;  (** Path relative to tests/, used as key in messages.json *)
  category : string;       (** html, html-aria, etc. *)
  expected : expected_outcome;
}

type test_result = {
  file : test_file;
  passed : bool;
  actual_errors : string list;
  actual_warnings : string list;
  actual_infos : string list;
  expected_message : string option;
  match_quality : Expected_message.match_quality option;  (** How well did message match? *)
  details : string;
}

(** Parse expected outcome from filename suffix *)
let parse_outcome filename =
  (* Check for .html suffix *)
  if String.length filename > 13 && String.sub filename (String.length filename - 13) 13 = "-isvalid.html" then
    Valid
  else if String.length filename > 13 && String.sub filename (String.length filename - 13) 13 = "-novalid.html" then
    Invalid
  else if String.length filename > 13 && String.sub filename (String.length filename - 13) 13 = "-haswarn.html" then
    HasWarning
  (* Check for .xhtml suffix *)
  else if String.length filename > 14 && String.sub filename (String.length filename - 14) 14 = "-isvalid.xhtml" then
    Valid
  else if String.length filename > 14 && String.sub filename (String.length filename - 14) 14 = "-novalid.xhtml" then
    Invalid
  else if String.length filename > 14 && String.sub filename (String.length filename - 14) 14 = "-haswarn.xhtml" then
    HasWarning
  else
    Unknown

(** Current strictness setting - can be set via --strict flag *)
let strictness = ref Expected_message.lenient

(** Find best matching message and return (found_acceptable, best_quality) *)
let find_best_match ~expected_str ~actual_msgs =
  let expected = Expected_message.parse expected_str in
  let qualities = List.map (fun msg ->
    Expected_message.matches ~strictness:!strictness ~expected ~actual:msg
  ) actual_msgs in

  let best_quality =
    List.fold_left (fun best q ->
      (* Lower variant = better match in our type definition *)
      if q < best then q else best
    ) Expected_message.No_match qualities
  in
  let acceptable = Expected_message.is_acceptable ~strictness:!strictness best_quality in
  (acceptable, best_quality)

(** Recursively find all HTML test files *)
let rec discover_tests_in_dir base_dir current_dir =
  let full_path = Filename.concat base_dir current_dir in
  if not (Sys.file_exists full_path) then []
  else if Sys.is_directory full_path then begin
    let entries = Sys.readdir full_path |> Array.to_list in
    List.concat_map (fun entry ->
      let sub_path = if current_dir = "" then entry else Filename.concat current_dir entry in
      discover_tests_in_dir base_dir sub_path
    ) entries
  end else if Filename.check_suffix current_dir ".html" || Filename.check_suffix current_dir ".xhtml" then begin
    let outcome = parse_outcome (Filename.basename current_dir) in
    if outcome = Unknown then []
    else
      let category =
        match String.split_on_char '/' current_dir with
        | cat :: _ -> cat
        | [] -> "unknown"
      in
      [{ path = full_path; relative_path = current_dir; category; expected = outcome }]
  end else
    []

let discover_tests tests_dir =
  discover_tests_in_dir tests_dir ""

(** Run a single test *)
let run_test messages test =
  try
    let ic = open_in test.path in
    let content = really_input_string ic (in_channel_length ic) in
    close_in ic;

    let reader = Bytesrw.Bytes.Reader.of_string content in
    let result = Html5_checker.check ~collect_parse_errors:true ~system_id:test.relative_path reader in

    (* Keep full message objects for proper matching *)
    let error_msgs = Html5_checker.errors result in
    let warning_msgs = Html5_checker.warnings result in
    let info_msgs = Html5_checker.infos result in

    (* Extract text for reporting *)
    let errors = List.map (fun m -> m.Html5_checker.Message.message) error_msgs in
    let warnings = List.map (fun m -> m.Html5_checker.Message.message) warning_msgs in
    let infos = List.map (fun m -> m.Html5_checker.Message.message) info_msgs in
    let expected_msg = Validator_messages.get messages test.relative_path in

    let (passed, match_quality, details) = match test.expected with
      | Valid ->
        (* isvalid tests fail on errors or warnings, but info messages are OK *)
        if errors = [] && warnings = [] then
          (true, None,
           if infos = [] then "OK: No messages" else Printf.sprintf "OK: No errors/warnings (%d info)" (List.length infos))
        else
          (false, None,
           Printf.sprintf "Expected valid but got %d errors, %d warnings"
            (List.length errors) (List.length warnings))
      | Invalid ->
        if errors = [] then
          (false, None, "Expected error but got none")
        else begin
          (* For novalid tests, require message match when expected message is provided *)
          match expected_msg with
          | None ->
              (* No expected message - pass if any error detected *)
              (true, None,
               Printf.sprintf "Got %d error(s), no expected message to match" (List.length errors))
          | Some exp ->
              let (matched, quality) = find_best_match ~expected_str:exp ~actual_msgs:error_msgs in
              if matched then
                (true, Some quality,
                 Printf.sprintf "Got %d error(s), match: %s" (List.length errors)
                   (Expected_message.match_quality_to_string quality))
              else
                (* FAIL if message doesn't match *)
                (false, Some quality,
                 Printf.sprintf "Message mismatch (quality: %s).\n      Expected: %s\n      Got: %s"
                   (Expected_message.match_quality_to_string quality)
                   exp (String.concat "\n           " errors))
        end
      | HasWarning ->
        (* For haswarn, require message match against warnings or infos *)
        let all_msgs = warning_msgs @ info_msgs in
        let all_messages = warnings @ infos in
        if all_messages = [] && errors = [] then
          (false, None, "Expected warning but got none")
        else begin
          match expected_msg with
          | None ->
              if all_messages <> [] then
                (true, None, Printf.sprintf "Got %d warning/info message(s)" (List.length all_messages))
              else
                (true, None, Printf.sprintf "Got %d error(s) instead of warning" (List.length errors))
          | Some exp ->
              let (warn_matched, warn_quality) = find_best_match ~expected_str:exp ~actual_msgs:all_msgs in
              if warn_matched then
                (true, Some warn_quality,
                 Printf.sprintf "Got %d warning/info message(s), match: %s" (List.length all_messages)
                   (Expected_message.match_quality_to_string warn_quality))
              else begin
                let (err_matched, err_quality) = find_best_match ~expected_str:exp ~actual_msgs:error_msgs in
                if err_matched then
                  (* Accept error if message matches (severity might differ) *)
                  (true, Some err_quality,
                   Printf.sprintf "Got error instead of warning, match: %s"
                     (Expected_message.match_quality_to_string err_quality))
                else
                  let best = if warn_quality < err_quality then warn_quality else err_quality in
                  (false, Some best,
                   Printf.sprintf "Message mismatch (quality: %s).\n      Expected: %s\n      Got warnings: %s\n      Got errors: %s"
                     (Expected_message.match_quality_to_string best)
                     exp (String.concat "\n                " (if all_messages = [] then ["(none)"] else all_messages))
                     (String.concat "\n              " (if errors = [] then ["(none)"] else errors)))
              end
        end
      | Unknown ->
        (false, None, "Unknown test type")
    in
    { file = test; passed; actual_errors = errors; actual_warnings = warnings;
      actual_infos = infos; expected_message = expected_msg; match_quality; details }
  with e ->
    { file = test; passed = false; actual_errors = []; actual_warnings = [];
      actual_infos = []; expected_message = None; match_quality = None;
      details = Printf.sprintf "Exception: %s" (Printexc.to_string e) }

(** Group tests by category *)
let group_by_category tests =
  let tbl = Hashtbl.create 16 in
  List.iter (fun test ->
    let cat = test.file.category in
    let existing = try Hashtbl.find tbl cat with Not_found -> [] in
    Hashtbl.replace tbl cat (test :: existing)
  ) tests;
  Hashtbl.fold (fun k v acc -> (k, List.rev v) :: acc) tbl []
  |> List.sort (fun (a, _) (b, _) -> String.compare a b)

(** Print summary to console *)
let print_summary results =
  let by_category = group_by_category results in
  Printf.printf "\n=== Results by Category ===\n";
  List.iter (fun (cat, tests) ->
    let passed = List.filter (fun r -> r.passed) tests |> List.length in
    let total = List.length tests in
    Printf.printf "%s: %d/%d passed (%.1f%%)\n" cat passed total
      (100.0 *. float_of_int passed /. float_of_int (max 1 total))
  ) by_category;

  (* Breakdown by test type *)
  let isvalid_results = List.filter (fun r -> r.file.expected = Valid) results in
  let novalid_results = List.filter (fun r -> r.file.expected = Invalid) results in
  let haswarn_results = List.filter (fun r -> r.file.expected = HasWarning) results in

  let count_passed rs = List.filter (fun r -> r.passed) rs |> List.length in

  Printf.printf "\n=== Results by Test Type ===\n";
  Printf.printf "isvalid (no errors expected): %d/%d passed (%.1f%%)\n"
    (count_passed isvalid_results) (List.length isvalid_results)
    (100.0 *. float_of_int (count_passed isvalid_results) /. float_of_int (max 1 (List.length isvalid_results)));
  Printf.printf "novalid (errors expected): %d/%d passed (%.1f%%)\n"
    (count_passed novalid_results) (List.length novalid_results)
    (100.0 *. float_of_int (count_passed novalid_results) /. float_of_int (max 1 (List.length novalid_results)));
  Printf.printf "haswarn (warnings expected): %d/%d passed (%.1f%%)\n"
    (count_passed haswarn_results) (List.length haswarn_results)
    (100.0 *. float_of_int (count_passed haswarn_results) /. float_of_int (max 1 (List.length haswarn_results)));

  let total_passed = List.filter (fun r -> r.passed) results |> List.length in
  let total = List.length results in
  Printf.printf "\n=== Overall ===\n";
  Printf.printf "Total: %d/%d passed (%.1f%%)\n" total_passed total
    (100.0 *. float_of_int total_passed /. float_of_int (max 1 total));

  (* Match quality breakdown *)
  let count_quality q = List.filter (fun r ->
    match r.match_quality with Some mq -> mq = q | None -> false
  ) results |> List.length in
  let exact = count_quality Expected_message.Exact_match in
  let code_match = count_quality Expected_message.Code_match in
  let msg_match = count_quality Expected_message.Message_match in
  let substring = count_quality Expected_message.Substring_match in
  let sev_mismatch = count_quality Expected_message.Severity_mismatch in
  let no_match = count_quality Expected_message.No_match in
  let no_quality = List.filter (fun r -> r.match_quality = None) results |> List.length in

  Printf.printf "\n=== Match Quality ===\n";
  let mode_name =
    if !strictness = Expected_message.strict then "STRICT (full)"
    else if !strictness = Expected_message.exact_message then "STRICT (exact message)"
    else "lenient"
  in
  Printf.printf "Mode: %s\n" mode_name;
  Printf.printf "Exact matches: %d\n" exact;
  Printf.printf "Code matches: %d\n" code_match;
  Printf.printf "Message matches: %d\n" msg_match;
  Printf.printf "Substring matches: %d\n" substring;
  Printf.printf "Severity mismatches: %d\n" sev_mismatch;
  Printf.printf "No matches: %d\n" no_match;
  Printf.printf "N/A (isvalid or no expected): %d\n" no_quality

(** Generate HTML report *)
let generate_html_report results output_path =
  let by_category = group_by_category results in

  let file_results = List.map (fun (category, tests) ->
    let passed_count = List.filter (fun r -> r.passed) tests |> List.length in
    let failed_count = List.length tests - passed_count in
    let test_results = List.mapi (fun i r ->
      let outcome_str = match r.file.expected with
        | Valid -> "valid"
        | Invalid -> "invalid"
        | HasWarning -> "has-warning"
        | Unknown -> "unknown"
      in
      let description = Printf.sprintf "[%s] %s" outcome_str r.file.relative_path in
      let expected = match r.expected_message with
        | Some m -> m
        | None -> "(no expected message)"
      in
      let actual_str =
        let errors = if r.actual_errors = [] then ""
          else "Errors:\n" ^ String.concat "\n" r.actual_errors in
        let warnings = if r.actual_warnings = [] then ""
          else "Warnings:\n" ^ String.concat "\n" r.actual_warnings in
        let infos = if r.actual_infos = [] then ""
          else "Info:\n" ^ String.concat "\n" r.actual_infos in
        if errors = "" && warnings = "" && infos = "" then "(no messages)"
        else String.trim (errors ^ "\n" ^ warnings ^ "\n" ^ infos)
      in
      Report.{
        test_num = i + 1;
        description;
        input = r.file.relative_path;
        expected;
        actual = actual_str;
        success = r.passed;
        details = [("Status", r.details)];
        raw_test_data = None;
      }
    ) tests in
    Report.{
      filename = category;
      test_type = "HTML5 Validator";
      passed_count;
      failed_count;
      tests = test_results;
    }
  ) by_category in

  let total_passed = List.filter (fun r -> r.passed) results |> List.length in
  let total_failed = List.length results - total_passed in

  let report : Report.report = {
    title = "Nu HTML Validator Tests";
    test_type = "validator";
    description = "Tests from the Nu HTML Validator (W3C's official HTML checker). \
                   Tests validate HTML5 conformance including element nesting, required attributes, \
                   ARIA roles, obsolete elements, and more. Each test file is classified by suffix: \
                   -isvalid.html (should produce no errors), -novalid.html (should produce errors), \
                   -haswarn.html (should produce warnings).";
    files = file_results;
    total_passed;
    total_failed;
  } in
  Report.generate_report report output_path

let () =
  (* Parse command line arguments *)
  let args = Array.to_list Sys.argv |> List.tl in
  let is_strict = List.mem "--strict" args in
  let non_flag_args = List.filter (fun s -> not (String.length s > 0 && s.[0] = '-')) args in
  let tests_dir = match non_flag_args with x :: _ -> x | [] -> "validator/tests" in
  let report_path = match non_flag_args with _ :: x :: _ -> x | _ -> "test_validator_report.html" in

  (* Apply strict mode if requested - use exact_message which requires exact text but not typed codes *)
  if is_strict then begin
    strictness := Expected_message.exact_message;
    Printf.printf "Running in STRICT mode (exact message matching required)\n%!"
  end;

  Printf.printf "Loading messages.json...\n%!";
  let messages_path = Filename.concat tests_dir "messages.json" in
  let messages = Validator_messages.load messages_path in
  Printf.printf "Loaded %d expected messages\n%!" (Validator_messages.count messages);

  Printf.printf "Discovering test files...\n%!";
  let tests = discover_tests tests_dir in
  Printf.printf "Found %d test files\n%!" (List.length tests);

  Printf.printf "Running tests...\n%!";
  let results = List.map (run_test messages) tests in

  (* Print failing isvalid tests *)
  let failing_isvalid = List.filter (fun r ->
    r.file.expected = Valid && not r.passed
  ) results in
  if failing_isvalid <> [] then begin
    Printf.printf "\n=== Failing isvalid tests ===\n";
    List.iter (fun r ->
      Printf.printf "%s: %s\n" r.file.relative_path r.details
    ) failing_isvalid
  end;

  (* Print failing haswarn tests *)
  let failing_haswarn = List.filter (fun r ->
    r.file.expected = HasWarning && not r.passed
  ) results in
  if failing_haswarn <> [] then begin
    Printf.printf "\n=== Failing haswarn tests ===\n";
    List.iter (fun r ->
      Printf.printf "%s\n" r.file.relative_path
    ) failing_haswarn
  end;

  (* Print failing novalid tests *)
  let failing_novalid = List.filter (fun r ->
    r.file.expected = Invalid && not r.passed
  ) results in
  if failing_novalid <> [] then begin
    Printf.printf "\n=== Failing novalid tests (first 50) ===\n";
    List.iteri (fun i r ->
      if i < 50 then Printf.printf "%s\n" r.file.relative_path
    ) failing_novalid
  end;

  print_summary results;
  generate_html_report results report_path;

  let failed_count = List.filter (fun r -> not r.passed) results |> List.length in
  exit (if failed_count > 0 then 1 else 0)