HS tests: host-get method truthiness + fork-based test timeout
Two critical fixes for the mock DOM test runner: 1. host-get returns truthy for DOM method names on mock elements. dom.sx guards like `(and el (host-get el "setAttribute"))` were silently skipping setAttribute/getAttribute calls because the mock dict had no "setAttribute" key. Now returns Bool true for known DOM method names, fixing hs-activate! → dom-set-attr → dom-get-attr chain. Also adds firstElementChild, nextElementSibling, etc. as computed properties. 2. Fork-based per-test timeout (5 seconds). The HS parser has infinite loops on certain syntax ([@attr], complex put targets). Signal-based alarm doesn't work reliably in OCaml 5. Fork + waitpid + select gives hard OS-level timeout protection. Also adds step_limit/step_count to sx_ref.ml trampoline (currently unused but available for future CEK-level timeout). Result: 525/963 total, up from 498. Many more add/remove/toggle/set tests now pass because hs-activate! actually wires up event handlers. Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
@@ -88,24 +88,61 @@ let make_test_env () =
|
||||
bind "try-call" (fun args ->
|
||||
match args with
|
||||
| [thunk] ->
|
||||
(try
|
||||
(* Call the thunk: it's a lambda with no params *)
|
||||
let result = eval_expr (List [thunk]) (Env env) in
|
||||
ignore result;
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "ok" (Bool true);
|
||||
Dict d
|
||||
with
|
||||
| Eval_error msg ->
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "ok" (Bool false);
|
||||
Hashtbl.replace d "error" (String msg);
|
||||
Dict d
|
||||
| exn ->
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "ok" (Bool false);
|
||||
Hashtbl.replace d "error" (String (Printexc.to_string exn));
|
||||
Dict d)
|
||||
(* Fork-based timeout: child runs test, parent waits up to 5s *)
|
||||
let r, w = Unix.pipe () in
|
||||
let pid = Unix.fork () in
|
||||
if pid = 0 then begin
|
||||
(* Child process *)
|
||||
Unix.close r;
|
||||
let write_result s =
|
||||
let _ = Unix.write_substring w s 0 (String.length s) in
|
||||
Unix.close w; exit 0 in
|
||||
(try
|
||||
let result = eval_expr (List [thunk]) (Env env) in
|
||||
ignore result;
|
||||
write_result "OK:"
|
||||
with
|
||||
| Eval_error msg -> write_result ("ERR:" ^ msg)
|
||||
| exn -> write_result ("EXN:" ^ Printexc.to_string exn))
|
||||
end else begin
|
||||
(* Parent process *)
|
||||
Unix.close w;
|
||||
(* Wait with timeout using select *)
|
||||
let deadline = Unix.gettimeofday () +. 5.0 in
|
||||
let rec wait_loop () =
|
||||
let remaining = deadline -. Unix.gettimeofday () in
|
||||
if remaining <= 0.0 then begin
|
||||
Unix.kill pid Sys.sigkill;
|
||||
ignore (Unix.waitpid [] pid);
|
||||
Unix.close r;
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "ok" (Bool false);
|
||||
Hashtbl.replace d "error" (String "TIMEOUT: test exceeded 5s");
|
||||
Dict d
|
||||
end else begin
|
||||
match Unix.select [r] [] [] (min remaining 0.1) with
|
||||
| _ :: _, _, _ ->
|
||||
let buf = Bytes.create 4096 in
|
||||
let n = Unix.read r buf 0 4096 in
|
||||
Unix.close r;
|
||||
ignore (Unix.waitpid [] pid);
|
||||
let msg = Bytes.sub_string buf 0 n in
|
||||
if String.length msg >= 3 && String.sub msg 0 3 = "OK:" then begin
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "ok" (Bool true);
|
||||
Dict d
|
||||
end else begin
|
||||
let err = if String.length msg > 4 then String.sub msg 4 (String.length msg - 4) else msg in
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "ok" (Bool false);
|
||||
Hashtbl.replace d "error" (String err);
|
||||
Dict d
|
||||
end
|
||||
| [], _, _ -> wait_loop ()
|
||||
end
|
||||
in
|
||||
wait_loop ()
|
||||
end
|
||||
| _ -> raise (Eval_error "try-call: expected 1 arg"));
|
||||
|
||||
bind "report-pass" (fun args ->
|
||||
@@ -1555,7 +1592,63 @@ let run_spec_tests env test_files =
|
||||
let el = match Hashtbl.find_opt d "__mock_el" with Some (Dict e) -> e | _ -> d in
|
||||
Number (float_of_int (List.length (get_classes el)))
|
||||
else
|
||||
(match Hashtbl.find_opt d key with Some v -> v | None -> Nil)
|
||||
(match Hashtbl.find_opt d key with
|
||||
| Some v -> v
|
||||
| None ->
|
||||
(* For mock elements, return a truthy sentinel for method names
|
||||
so that guards like (host-get el "setAttribute") pass *)
|
||||
if mt = "element" then
|
||||
(match key with
|
||||
| "setAttribute" | "getAttribute" | "removeAttribute" | "hasAttribute"
|
||||
| "addEventListener" | "removeEventListener" | "dispatchEvent"
|
||||
| "appendChild" | "removeChild" | "insertBefore" | "replaceChild"
|
||||
| "querySelector" | "querySelectorAll" | "closest" | "matches"
|
||||
| "contains" | "cloneNode" | "remove" | "focus" | "blur" | "click"
|
||||
| "insertAdjacentHTML" | "prepend" | "showModal" | "show" | "close"
|
||||
| "getBoundingClientRect" | "getAnimations" | "scrollIntoView"
|
||||
| "scrollTo" | "scroll" -> Bool true
|
||||
| "firstElementChild" ->
|
||||
let kids = match Hashtbl.find_opt d "children" with Some (List l) -> l | _ -> [] in
|
||||
(match kids with c :: _ -> c | [] -> Nil)
|
||||
| "lastElementChild" ->
|
||||
let kids = match Hashtbl.find_opt d "children" with Some (List l) -> l | _ -> [] in
|
||||
(match List.rev kids with c :: _ -> c | [] -> Nil)
|
||||
| "nextElementSibling" ->
|
||||
(match Hashtbl.find_opt d "parentElement" with
|
||||
| Some (Dict p) ->
|
||||
let kids = match Hashtbl.find_opt p "children" with Some (List l) -> l | _ -> [] in
|
||||
let rec find_next = function
|
||||
| [] | [_] -> Nil
|
||||
| a :: b :: _ when a == Dict d -> b
|
||||
| _ :: rest -> find_next rest in
|
||||
find_next kids
|
||||
| _ -> Nil)
|
||||
| "previousElementSibling" ->
|
||||
(match Hashtbl.find_opt d "parentElement" with
|
||||
| Some (Dict p) ->
|
||||
let kids = match Hashtbl.find_opt p "children" with Some (List l) -> l | _ -> [] in
|
||||
let rec find_prev prev = function
|
||||
| [] -> Nil
|
||||
| a :: _ when a == Dict d -> prev
|
||||
| a :: rest -> find_prev a rest in
|
||||
find_prev Nil kids
|
||||
| _ -> Nil)
|
||||
| "ownerDocument" -> mock_document
|
||||
| _ -> Nil)
|
||||
else if mt = "document" then
|
||||
(match key with
|
||||
| "createElement" | "createElementNS" | "createDocumentFragment"
|
||||
| "createTextNode" | "createComment" | "getElementById"
|
||||
| "querySelector" | "querySelectorAll" | "createEvent"
|
||||
| "addEventListener" | "removeEventListener" -> Bool true
|
||||
| "head" ->
|
||||
let head = Hashtbl.create 4 in
|
||||
Hashtbl.replace head "__mock_type" (String "element");
|
||||
Hashtbl.replace head "tagName" (String "HEAD");
|
||||
Dict head
|
||||
| "activeElement" -> Nil
|
||||
| _ -> Nil)
|
||||
else Nil)
|
||||
| [Dict d; Number n] ->
|
||||
(* Array index access *)
|
||||
let i = int_of_float n in
|
||||
|
||||
@@ -8,7 +8,16 @@ open Sx_runtime
|
||||
|
||||
(* Trampoline — forward ref, resolved after eval_expr is defined. *)
|
||||
let trampoline_fn : (value -> value) ref = ref (fun v -> v)
|
||||
let trampoline v = !trampoline_fn v
|
||||
(* Step limit for detecting infinite loops — 0 = unlimited *)
|
||||
let step_limit : int ref = ref 0
|
||||
let step_count : int ref = ref 0
|
||||
let trampoline v =
|
||||
if !step_limit > 0 then begin
|
||||
incr step_count;
|
||||
if !step_count > !step_limit then
|
||||
raise (Sx_types.Eval_error "TIMEOUT: step limit exceeded")
|
||||
end;
|
||||
!trampoline_fn v
|
||||
|
||||
|
||||
|
||||
|
||||
Reference in New Issue
Block a user