coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions 7 Packages Projects Releases Wiki Activity

HS: extend parser/runtime + new node test runner; ignore test-results/

Browse Source 
- Parser: `--` line comments, `|` op, `result` → `the-result`, query-scoped
  `<sel> in <expr>`, `is a/an <type>` predicate, multi-`as` chaining with `|`,
  `match`/`precede` keyword aliases, `[attr]` add/toggle, between attr forms
- Runtime: per-element listener registry + hs-deactivate!, attr toggle
  variants, set-inner-html boots subtree, hs-append polymorphic on
  string/list/element, default? / array-set! / query-all-in / list-set
  via take+drop, hs-script idempotence guard
- Integration: skip reserved (me/it/event/you/yourself) when collecting vars
- Tokenizer: emit `--` comments and `|` op
- Test framework + conformance runner updates; new tests/hs-run-filtered.js
  (single-process Node runner using OCaml VM step-limit to bound infinite
  loops); generate-sx-conformance-dev.py improvements
- mcp_tree.ml + run_tests.ml: harness extensions
- .gitignore: top-level test-results/ (Playwright artifacts)

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-23 07:11:07 +00:00
parent b2ae80fb21
commit 0515295317
20 changed files with 15224 additions and 8120 deletions
Download Patch File Download Diff File Expand all files Collapse all files

255
hosts/ocaml/bin/mcp_tree.ml
View File

@@ -155,6 +155,192 @@ let register_mcp_jit_hook () =
| None -> None))
| _ -> None)
(* ------------------------------------------------------------------ *)
(* Native tree-tools helpers — avoid CEK overhead on big trees. *)
(* Mirror the SX semantics from lib/tree-tools.sx but run as direct *)
(* OCaml recursion. Used by read-subtree / validate / find-all / *)
(* find-across / comp-usage handlers. *)
(* ------------------------------------------------------------------ *)
let native_path_str path =
"[" ^ String.concat "," (List.map string_of_int path) ^ "]"
let rec native_node_display (node : value) : string =
match node with
| Nil -> "nil"
| Symbol s -> s
| Keyword k -> ":" ^ k
| String s -> "\"" ^ s ^ "\""
| Number n ->
if Float.is_integer n then string_of_int (int_of_float n)
else Printf.sprintf "%g" n
| Bool true -> "true"
| Bool false -> "false"
| List [] | ListRef { contents = [] } -> "()"
| List (h :: t) | ListRef { contents = h :: t } ->
if t = [] then "(" ^ native_node_display h ^ ")"
else "(" ^ native_node_display h ^ " ...)"
| Dict _ -> "{...}"
| v -> Sx_runtime.value_to_str v
(* node-summary-short: "(head)" for singletons, "(head second ...)" for >3,
"(all node-displays joined)" for small lists. Mirrors lib/tree-tools.sx. *)
let native_node_summary_short node =
match node with
| List [] | ListRef { contents = [] } -> "()"
| List items | ListRef { contents = items } ->
let n = List.length items in
if n > 3 then
let head = native_node_display (List.hd items) in
let second = native_node_display (List.nth items 1) in
Printf.sprintf "(%s %s ...)" head second
else
"(" ^ String.concat " " (List.map native_node_display items) ^ ")"
| _ -> native_node_display node
let rec native_node_matches node pattern =
match node with
| Symbol s | String s ->
(try ignore (Str.search_forward (Str.regexp_string pattern) s 0); true
with Not_found -> false)
| List items | ListRef { contents = items } ->
List.exists (fun c -> native_node_matches c pattern) items
| _ -> false
(* Raw find: returns reversed list of (path, summary) pairs — caller reverses. *)
let native_find_all_raw exprs pattern =
let nodes = match exprs with
| List xs | ListRef { contents = xs } -> xs
| x -> [x] in
let acc = ref [] in
let rec go node path =
if native_node_matches node pattern then
acc := (List.rev path, native_node_summary_short node) :: !acc;
match node with
| List items | ListRef { contents = items } ->
List.iteri (fun i child -> go child (i :: path)) items
| _ -> ()
in
List.iteri (fun i node -> go node [i]) nodes;
List.rev !acc
(* SX-value-returning wrapper — kept for any SX code that still calls find-all. *)
let native_find_all_sx exprs pattern =
let pairs = native_find_all_raw exprs pattern in
List (List.map (fun (path, summary) ->
List [List (List.map (fun i -> Number (float_of_int i)) path);
String summary]
) pairs)
(* navigate: walk a tree by a list of indices. Wraps exprs into a list on entry
(mirrors SX navigate). Returns Nil if any index is out of range. *)
let native_navigate exprs path =
let init = match exprs with
| List _ | ListRef _ -> exprs
| x -> List [x] in
let rec step current = function
| [] -> current
| i :: rest ->
(match current with
| List items when i >= 0 && i < List.length items ->
step (List.nth items i) rest
| ListRef { contents = items } when i >= 0 && i < List.length items ->
step (List.nth items i) rest
| _ -> Nil) in
step init path
(* annotate-tree: render a list of exprs as an indented path-annotated string.
Mirrors the `annotate-node` dispatch from lib/tree-tools.sx:
- small lists (len<=4, no list children) render inline
- others render head on first line, children indented, closing ")"
Path annotations use [i,j,k,...] form. *)
let native_annotate_tree exprs =
let nodes = match exprs with
| List xs | ListRef { contents = xs } -> xs
| x -> [x] in
let out = Buffer.create 1024 in
let first = ref true in
let emit s =
if !first then first := false else Buffer.add_char out '\n';
Buffer.add_string out s in
let rec ann node path depth =
let indent = String.make (depth * 2) ' ' in
let label = native_path_str (List.rev path) in
match node with
| List [] | ListRef { contents = [] } ->
emit (indent ^ label ^ " ()")
| List items | ListRef { contents = items } ->
let n = List.length items in
let rest = List.tl items in
let any_child_list = List.exists
(fun c -> match c with List _ | ListRef _ -> true | _ -> false) rest in
if n <= 4 && not any_child_list then
emit (indent ^ label ^ " (" ^
String.concat " " (List.map native_node_display items) ^ ")")
else begin
let head_str = native_node_display (List.hd items) in
emit (indent ^ label ^ " (" ^ head_str);
List.iteri (fun i child ->
if i > 0 then ann child (i :: path) (depth + 1)
) items;
emit (indent ^ " )")
end
| _ ->
emit (indent ^ label ^ " " ^ native_node_display node)
in
List.iteri (fun i node -> ann node [i] 0) nodes;
Buffer.contents out
let native_read_subtree exprs path =
let node = native_navigate exprs path in
match node with
| Nil -> "Error: path " ^ native_path_str path ^ " not found"
| _ -> native_annotate_tree (List [node])
(* validate: walk the tree, emit WARNING for malformed letrec bindings and
ERROR for defisland/defcomp with fewer than 3 args. *)
let native_validate exprs =
let errors = ref [] in
let emit s = errors := s :: !errors in
let rec go node path =
(match node with
| List items | ListRef { contents = items } ->
(match items with
| [] -> ()
| head :: _ ->
let head_name = match head with Symbol s -> Some s | _ -> None in
(match head_name with
| Some "letrec" when List.length items >= 2 ->
let bindings = List.nth items 1 in
(match bindings with
| List pairs | ListRef { contents = pairs } ->
List.iteri (fun i pair ->
let ok = match pair with
| List (Symbol _ :: _ :: _) -> true
| ListRef { contents = Symbol _ :: _ :: _ } -> true
| _ -> false in
if not ok then
emit (Printf.sprintf
"WARNING %s: letrec binding %d is not a (name value) pair: %s"
(native_path_str (List.rev (i :: 1 :: path)))
i
(native_node_display pair))
) pairs
| _ -> ())
| Some (("defisland" | "defcomp") as nm) when List.length items < 4 ->
emit (Printf.sprintf
"ERROR %s: %s has fewer than 3 args (name params b..."
(native_path_str (List.rev path)) nm)
| _ -> ()));
List.iteri (fun i child -> go child (i :: path)) items
| _ -> ())
in
let nodes = match exprs with
| List xs | ListRef { contents = xs } -> xs
| x -> [x] in
List.iteri (fun i node -> go node [i]) nodes;
if !errors = [] then "OK" else String.concat "\n" (List.rev !errors)
let setup_env () =
let e = make_env () in
(* Primitives are auto-registered at module init *)
@@ -439,6 +625,30 @@ let setup_env () =
try load_sx_file e (Filename.concat lib_dir "compiler.sx");
register_mcp_jit_hook ()
with exn -> Printf.eprintf "[mcp] Warning: compiler.sx load failed (JIT disabled): %s\n%!" (Printexc.to_string exn));
(* Native-impl the hot tree-tools ops — replaces SX versions to avoid CEK
overhead on big trees. See native_* helpers defined above setup_env. *)
ignore (Sx_types.env_bind e "find-all" (NativeFn ("find-all", fun args ->
match args with
| [exprs; String pattern] -> native_find_all_sx exprs pattern
| _ -> List [])));
ignore (Sx_types.env_bind e "read-subtree" (NativeFn ("read-subtree", fun args ->
match args with
| [exprs; List path] | [exprs; ListRef { contents = path }] ->
let ints = List.map (fun v -> match v with Number n -> int_of_float n | _ -> 0) path in
String (native_read_subtree exprs ints)
| _ -> String "")));
ignore (Sx_types.env_bind e "validate" (NativeFn ("validate", fun args ->
match args with
| [exprs] -> String (native_validate exprs)
| _ -> String "")));
ignore (Sx_types.env_bind e "path-str" (NativeFn ("path-str", fun args ->
match args with
| [List path] | [ListRef { contents = path }] ->
let ints = List.map (fun v -> match v with Number n -> int_of_float n | _ -> 0) path in
String (native_path_str ints)
| _ -> String "[]")));
Printf.eprintf "[mcp] Ready in %.0fms\n%!" ((Unix.gettimeofday () -. t0) *. 1000.0);
env := e
@@ -804,7 +1014,11 @@ let handle_sx_read_subtree args =
let open Yojson.Safe.Util in
let tree = parse_file (require_file args "file") in
let path = resolve_path tree (args |> member "path" |> to_string) in
text_result (value_to_string (call_sx "read-subtree" [tree; path]))
let ints = match path with
| List xs | ListRef { contents = xs } ->
List.map (fun v -> match v with Number n -> int_of_float n | _ -> 0) xs
| _ -> [] in
text_result (native_read_subtree tree ints)
let handle_sx_get_context args =
let open Yojson.Safe.Util in
@@ -816,17 +1030,8 @@ let handle_sx_find_all args =
let open Yojson.Safe.Util in
let tree = parse_file (require_file args "file") in
let pattern = args |> member "pattern" |> to_string in
let results = call_sx "find-all" [tree; String pattern] in
let lines = match results with
| List items | ListRef { contents = items } ->
List.map (fun item ->
match item with
| List [p; s] | ListRef { contents = [p; s] } ->
value_to_string (call_sx "path-str" [p]) ^ " " ^ value_to_string s
| _ -> value_to_string item
) items
| _ -> [value_to_string results]
in
let results = native_find_all_raw tree pattern in
let lines = List.map (fun (p, s) -> native_path_str p ^ " " ^ s) results in
text_result (String.concat "\n" lines)
let handle_sx_get_siblings args =
@@ -843,7 +1048,7 @@ let handle_sx_get_siblings args =
let handle_sx_validate args =
let tree = parse_file (require_file args "file") in
text_result (value_to_string (call_sx "validate" [tree]))
text_result (native_validate tree)
let handle_sx_replace_node args =
let open Yojson.Safe.Util in
@@ -1912,16 +2117,8 @@ let handle_sx_find_across args =
let rel = relative_path ~base:dir path in
try
let tree = parse_file path in
let results = call_sx "find-all" [tree; String pattern] in
(match results with
| List items | ListRef { contents = items } ->
List.map (fun item ->
match item with
| List [p; s] | ListRef { contents = [p; s] } ->
rel ^ " " ^ value_to_string (call_sx "path-str" [p]) ^ " " ^ value_to_string s
| _ -> rel ^ " " ^ value_to_string item
) items
| _ -> [])
let results = native_find_all_raw tree pattern in
List.map (fun (p, s) -> rel ^ " " ^ native_path_str p ^ " " ^ s) results
with _ -> []
) files in
if all_lines = [] then text_result "(no matches)"
@@ -1948,16 +2145,8 @@ let handle_sx_comp_usage args =
let rel = relative_path ~base:dir path in
try
let tree = parse_file path in
let results = call_sx "find-all" [tree; String name] in
(match results with
| List items | ListRef { contents = items } ->
List.map (fun item ->
match item with
| List [p; s] | ListRef { contents = [p; s] } ->
rel ^ " " ^ value_to_string (call_sx "path-str" [p]) ^ " " ^ value_to_string s
| _ -> rel ^ " " ^ value_to_string item
) items
| _ -> [])
let results = native_find_all_raw tree name in
List.map (fun (p, s) -> rel ^ " " ^ native_path_str p ^ " " ^ s) results
with _ -> []
) files in
if all_lines = [] then text_result "(no usages found)"

360
hosts/ocaml/bin/run_tests.ml
View File

@@ -25,6 +25,9 @@ open Sx_ref
let pass_count = ref 0
let fail_count = ref 0
let suite_stack : string list ref = ref []
(* Test filter: when Some, only run tests (suite, name) in the set.
Populated by --only-failing=FILE from lines like "FAIL: suite > name: error". *)
let suite_filter : (string * string, unit) Hashtbl.t option ref = ref None
(* ====================================================================== *)
(* Deep equality — SX structural comparison *)
@@ -176,6 +179,17 @@ let make_test_env () =
suite_stack := (match !suite_stack with _ :: t -> t | [] -> []);
Nil);
bind "test-allowed?" (fun args ->
match !suite_filter with
| None -> Bool true
| Some filter ->
let name = match args with
| [String s] -> s
| [v] -> Sx_types.value_to_string v
| _ -> "" in
let suite = match !suite_stack with [] -> "" | s :: _ -> s in
Bool (Hashtbl.mem filter (suite, name)));
(* --- Test helpers --- *)
bind "sx-parse" (fun args ->
@@ -1563,6 +1577,131 @@ let run_spec_tests env test_files =
| _ -> child
in
(* Minimal HTML parser for test mock.
Parses an HTML string into mock child elements and appends them to `parent`.
Handles: <tag attr="v" attr='v' attr=v attr>content</tag>, nested elements,
self-closing tags, text content. No comments, CDATA, DOCTYPE, or entities. *)
let parse_html_into parent_d html =
let len = String.length html in
let pos = ref 0 in
let is_name_char c =
(c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') ||
(c >= '0' && c <= '9') || c = '-' || c = '_' || c = ':'
in
let skip_ws () =
while !pos < len && (let c = html.[!pos] in c = ' ' || c = '\n' || c = '\t' || c = '\r') do
incr pos
done
in
let parse_name () =
let start = !pos in
while !pos < len && is_name_char html.[!pos] do incr pos done;
String.sub html start (!pos - start)
in
let parse_attr_value () =
if !pos >= len then ""
else if html.[!pos] = '"' then begin
incr pos;
let start = !pos in
while !pos < len && html.[!pos] <> '"' do incr pos done;
let v = String.sub html start (!pos - start) in
if !pos < len then incr pos;
v
end
else if html.[!pos] = '\'' then begin
incr pos;
let start = !pos in
while !pos < len && html.[!pos] <> '\'' do incr pos done;
let v = String.sub html start (!pos - start) in
if !pos < len then incr pos;
v
end
else begin
let start = !pos in
while !pos < len && (let c = html.[!pos] in
c <> ' ' && c <> '\t' && c <> '\n' && c <> '\r'
&& c <> '>' && c <> '/') do
incr pos
done;
String.sub html start (!pos - start)
end
in
let parse_attrs (elem : (string, Sx_types.value) Hashtbl.t) =
skip_ws ();
while !pos < len && html.[!pos] <> '>' && html.[!pos] <> '/' do
let name = parse_name () in
if name = "" then begin
(* Avoid infinite loop on unexpected char *)
if !pos < len then incr pos
end else begin
let value =
if !pos < len && html.[!pos] = '=' then begin
incr pos; parse_attr_value ()
end else ""
in
let attrs = match Hashtbl.find_opt elem "attributes" with
| Some (Dict a) -> a
| _ -> let a = Hashtbl.create 4 in Hashtbl.replace elem "attributes" (Dict a); a in
Hashtbl.replace attrs name (String value);
if name = "id" then Hashtbl.replace elem "id" (String value);
if name = "class" then Hashtbl.replace elem "className" (String value);
if name = "value" then Hashtbl.replace elem "value" (String value);
skip_ws ()
end
done
in
let void_tags = ["br"; "hr"; "img"; "input"; "meta"; "link"; "area";
"base"; "col"; "embed"; "source"; "track"; "wbr"] in
let rec parse_children parent_elem =
while !pos < len && not (!pos + 1 < len && html.[!pos] = '<' && html.[!pos + 1] = '/') do
if !pos < len && html.[!pos] = '<' && !pos + 1 < len && is_name_char html.[!pos + 1] then
parse_element parent_elem
else if !pos < len && html.[!pos] = '<' then begin
(* Unknown/comment — skip to next '>' *)
while !pos < len && html.[!pos] <> '>' do incr pos done;
if !pos < len then incr pos
end
else begin
let start = !pos in
while !pos < len && html.[!pos] <> '<' do incr pos done;
let text = String.sub html start (!pos - start) in
if String.trim text <> "" then begin
let cur = match Hashtbl.find_opt parent_elem "textContent" with
| Some (String s) -> s | _ -> "" in
Hashtbl.replace parent_elem "textContent" (String (cur ^ text))
end
end
done
and parse_element parent_elem =
incr pos; (* skip '<' *)
let tag = parse_name () in
if tag = "" then () else begin
let el = make_mock_element tag in
let eld = match el with Dict d -> d | _ -> Hashtbl.create 0 in
parse_attrs eld;
skip_ws ();
let self_closing =
if !pos < len && html.[!pos] = '/' then begin incr pos; true end else false
in
if !pos < len && html.[!pos] = '>' then incr pos;
let is_void = List.mem (String.lowercase_ascii tag) void_tags in
if not self_closing && not is_void then begin
parse_children eld;
if !pos + 1 < len && html.[!pos] = '<' && html.[!pos + 1] = '/' then begin
pos := !pos + 2;
let _ = parse_name () in
skip_ws ();
if !pos < len && html.[!pos] = '>' then incr pos
end
end;
ignore (mock_append_child (Dict parent_elem) el)
end
in
pos := 0;
parse_children parent_d
in
let _ = parse_html_into in
(* Helper: remove child from parent *)
let mock_remove_child parent child =
match parent, child with
@@ -1578,11 +1717,21 @@ let run_spec_tests env test_files =
in
(* Helper: querySelector - find element matching selector in tree *)
let mock_matches el sel =
let rec mock_matches el sel =
match el with
| Dict d ->
let sel = String.trim sel in
if String.length sel > 0 && sel.[0] = '#' then
(* Compound selector: tag[attr=value] or tag.class or tag#id — split into parts *)
if String.length sel > 1 &&
((sel.[0] >= 'a' && sel.[0] <= 'z') || (sel.[0] >= 'A' && sel.[0] <= 'Z')) &&
(String.contains sel '[' || String.contains sel '.' || String.contains sel '#') then
let i = ref 0 in
let n = String.length sel in
while !i < n && ((sel.[!i] >= 'a' && sel.[!i] <= 'z') || (sel.[!i] >= 'A' && sel.[!i] <= 'Z') || (sel.[!i] >= '0' && sel.[!i] <= '9') || sel.[!i] = '-') do incr i done;
let tag_part = String.sub sel 0 !i in
let rest_part = String.sub sel !i (n - !i) in
(mock_matches el tag_part) && (mock_matches el rest_part)
else if String.length sel > 0 && sel.[0] = '#' then
let id = String.sub sel 1 (String.length sel - 1) in
(match Hashtbl.find_opt d "id" with Some (String i) -> i = id | _ -> false)
else if String.length sel > 0 && sel.[0] = '.' then
@@ -1590,7 +1739,8 @@ let run_spec_tests env test_files =
List.mem cls (get_classes d)
else if String.length sel > 0 && sel.[0] = '[' then
(* [attr] or [attr="value"] *)
let inner = String.sub sel 1 (String.length sel - 2) in
let end_bracket = try String.index sel ']' with Not_found -> String.length sel - 1 in
let inner = String.sub sel 1 (end_bracket - 1) in
(match String.split_on_char '=' inner with
| [attr] ->
let attrs = match Hashtbl.find_opt d "attributes" with Some (Dict a) -> a | _ -> Hashtbl.create 0 in
@@ -1621,19 +1771,51 @@ let run_spec_tests env test_files =
| found -> mock_query_selector found (String.concat " " rest))
| [] -> Nil
and mock_query_selector_single el sel =
match el with
| Dict d ->
let kids = match Hashtbl.find_opt d "children" with Some (List l) -> l | _ -> [] in
let rec search = function
| [] -> Nil
| child :: rest ->
if mock_matches child sel then child
else match mock_query_selector_single child sel with
| Nil -> search rest
| found -> found
in
search kids
| _ -> Nil
(* Handle tag:nth-of-type(N): find Nth child of same tag under parent *)
let nth_match = try
let idx = String.index sel ':' in
let tag = String.sub sel 0 idx in
let rest = String.sub sel idx (String.length sel - idx) in
if String.length rest > String.length ":nth-of-type(" &&
String.sub rest 0 (String.length ":nth-of-type(") = ":nth-of-type(" &&
rest.[String.length rest - 1] = ')'
then
let n_str = String.sub rest (String.length ":nth-of-type(")
(String.length rest - String.length ":nth-of-type(" - 1) in
(try Some (tag, int_of_string (String.trim n_str)) with _ -> None)
else None
with Not_found -> None in
(match nth_match with
| Some (tag, n) ->
(* Walk tree; collect matching-tag elements in document order; return nth *)
let found = ref [] in
let rec walk node =
match node with
| Dict d ->
let kids = match Hashtbl.find_opt d "children" with Some (List l) -> l | _ -> [] in
List.iter (fun child ->
if mock_matches child tag then found := child :: !found;
walk child
) kids
| _ -> ()
in
walk el;
let matches = List.rev !found in
(try List.nth matches (n - 1) with _ -> Nil)
| None ->
(match el with
| Dict d ->
let kids = match Hashtbl.find_opt d "children" with Some (List l) -> l | _ -> [] in
let rec search = function
| [] -> Nil
| child :: rest ->
if mock_matches child sel then child
else match mock_query_selector_single child sel with
| Nil -> search rest
| found -> found
in
search kids
| _ -> Nil))
in
let rec mock_query_all el sel =
@@ -1742,7 +1924,7 @@ let run_spec_tests env test_files =
| "addEventListener" | "removeEventListener" | "dispatchEvent"
| "appendChild" | "removeChild" | "insertBefore" | "replaceChild"
| "querySelector" | "querySelectorAll" | "closest" | "matches"
| "contains" | "cloneNode" | "remove" | "focus" | "blur" | "click"
| "contains" | "compareDocumentPosition" | "cloneNode" | "remove" | "focus" | "blur" | "click"
| "insertAdjacentHTML" | "prepend" | "showModal" | "show" | "close"
| "getBoundingClientRect" | "getAnimations" | "scrollIntoView"
| "scrollTo" | "scroll" | "reset" -> Bool true
@@ -1841,16 +2023,19 @@ let run_spec_tests env test_files =
| Some (Dict _cl) -> () (* classes live in className *)
| _ -> ())
| "innerHTML" ->
(* Setting innerHTML clears children and syncs textContent (like a browser) *)
(* Setting innerHTML clears existing children, parses the HTML, and
creates new mock child elements (approximating browser behavior). *)
let kids = match Hashtbl.find_opt d "children" with Some (List l) -> l | _ -> [] in
List.iter (fun c -> match c with Dict cd ->
Hashtbl.replace cd "parentElement" Nil;
Hashtbl.replace cd "parentNode" Nil | _ -> ()) kids;
Hashtbl.replace d "children" (List []);
Hashtbl.replace d "childNodes" (List []);
(* Approximate textContent: strip HTML tags from innerHTML *)
Hashtbl.replace d "textContent" (String "");
(match stored with
| String s ->
| String s when String.contains s '<' ->
parse_html_into d s;
(* Strip tags for a best-effort textContent *)
let buf = Buffer.create (String.length s) in
let in_tag = ref false in
String.iter (fun c ->
@@ -1859,6 +2044,7 @@ let run_spec_tests env test_files =
else if not !in_tag then Buffer.add_char buf c
) s;
Hashtbl.replace d "textContent" (String (Buffer.contents buf))
| String s -> Hashtbl.replace d "textContent" (String s)
| _ -> Hashtbl.replace d "textContent" (String ""))
| "textContent" ->
(* Setting textContent clears children *)
@@ -1887,6 +2073,8 @@ let run_spec_tests env test_files =
| "setTimeout" -> (match rest with fn :: _ -> ignore (Sx_ref.cek_call fn (List [])); Nil | _ -> Nil)
| "clearTimeout" -> Nil
| _ -> Nil)
| Dict d :: String "hasOwnProperty" :: [String k] ->
Bool (Hashtbl.mem d k)
| Dict d :: String m :: rest ->
let mt = match Hashtbl.find_opt d "__mock_type" with Some (String t) -> t | _ -> "" in
@@ -2139,6 +2327,33 @@ let run_spec_tests env test_files =
| _ -> Nil
in up (Dict d)
| _ -> Nil)
| "compareDocumentPosition" ->
(match rest with
| [other] ->
let self = Dict d in
let body = Dict mock_body in
let found_self = ref false in
let found_other = ref false in
let self_first = ref false in
let rec walk node =
if !found_self && !found_other then ()
else begin
if mock_el_eq node self then begin
if not !found_other then self_first := true;
found_self := true
end;
if mock_el_eq node other then found_other := true;
(match node with
| Dict dd -> let kids = match Hashtbl.find_opt dd "children" with Some (List l) -> l | _ -> [] in
List.iter walk kids
| _ -> ())
end
in
walk body;
if !found_self && !found_other then
Number (if !self_first then 4.0 else 2.0)
else Number 0.0
| _ -> Number 0.0)
| "matches" ->
(match rest with [String sel] -> Bool (mock_matches (Dict d) sel) | _ -> Bool false)
| "contains" ->
@@ -2213,25 +2428,62 @@ let run_spec_tests env test_files =
Hashtbl.replace r "right" (Number 100.0); Hashtbl.replace r "bottom" (Number 100.0);
Dict r
| "insertAdjacentHTML" ->
(* Position-aware insertion, coerce value to string *)
(* Position-aware insertion. Parse the new HTML into a scratch
container, then splice the resulting children into the target
position WITHOUT disturbing sibling nodes. *)
(match rest with
| [String pos; value] ->
| [String pos_kind; value] ->
let html = match dom_stringify value with String s -> s | _ -> "" in
let cur = match Hashtbl.find_opt d "innerHTML" with Some (String s) -> s | _ -> "" in
let new_html = match pos with
| "afterbegin" -> html ^ cur (* prepend *)
| _ -> cur ^ html (* beforeend / default: append *)
(* Parse new HTML into scratch container to get new child list.
For pure-text content, wrap into the target's innerHTML path. *)
let scratch = make_mock_element "div" in
let scratch_d = match scratch with Dict sd -> sd | _ -> Hashtbl.create 0 in
if String.contains html '<' then parse_html_into scratch_d html;
let new_kids = match Hashtbl.find_opt scratch_d "children" with Some (List l) -> l | _ -> [] in
let prepend = pos_kind = "beforebegin" || pos_kind = "afterbegin" in
let insert_into container_d index =
List.iter (fun c -> match c with
| Dict cd ->
Hashtbl.replace cd "parentElement" (Dict container_d);
Hashtbl.replace cd "parentNode" (Dict container_d)
| _ -> ()) new_kids;
let kids = match Hashtbl.find_opt container_d "children" with Some (List l) -> l | _ -> [] in
let before = List.filteri (fun i _ -> i < index) kids in
let after = List.filteri (fun i _ -> i >= index) kids in
let all = before @ new_kids @ after in
Hashtbl.replace container_d "children" (List all);
Hashtbl.replace container_d "childNodes" (List all);
(* Update container innerHTML based on position kind, not index *)
let cur = match Hashtbl.find_opt container_d "innerHTML" with Some (String s) -> s | _ -> "" in
let new_html = if prepend then html ^ cur else cur ^ html in
Hashtbl.replace container_d "innerHTML" (String new_html);
let buf = Buffer.create (String.length new_html) in
let in_tag = ref false in
String.iter (fun c ->
if c = '<' then in_tag := true
else if c = '>' then in_tag := false
else if not !in_tag then Buffer.add_char buf c
) new_html;
Hashtbl.replace container_d "textContent" (String (Buffer.contents buf))
in
Hashtbl.replace d "innerHTML" (String new_html);
(* Sync textContent *)
let buf = Buffer.create (String.length new_html) in
let in_tag = ref false in
String.iter (fun c ->
if c = '<' then in_tag := true
else if c = '>' then in_tag := false
else if not !in_tag then Buffer.add_char buf c
) new_html;
Hashtbl.replace d "textContent" (String (Buffer.contents buf));
(match pos_kind with
| "beforebegin" | "afterend" ->
(match Hashtbl.find_opt d "parentElement" with
| Some (Dict pd) ->
let siblings = match Hashtbl.find_opt pd "children" with Some (List l) -> l | _ -> [] in
let rec find_idx i = function
| [] -> List.length siblings
| x :: _ when mock_el_eq x (Dict d) -> i
| _ :: rest -> find_idx (i+1) rest
in
let self_idx = find_idx 0 siblings in
let insert_idx = if pos_kind = "beforebegin" then self_idx else self_idx + 1 in
insert_into pd insert_idx
| _ -> ())
| "afterbegin" -> insert_into d 0
| _ (* "beforeend" *) ->
let kids_len = match Hashtbl.find_opt d "children" with Some (List l) -> List.length l | _ -> 0 in
insert_into d kids_len);
Nil
| _ -> Nil)
| "showModal" | "show" ->
@@ -2341,6 +2593,8 @@ let run_spec_tests env test_files =
Hashtbl.replace ev "_stopped" (Bool false);
Hashtbl.replace ev "_stopImmediate" (Bool false);
Dict ev
| [String "Object"] ->
Dict (Hashtbl.create 4)
| _ -> Nil);
reg "host-callback" (fun args ->
@@ -2823,7 +3077,39 @@ let () =
let args = Array.to_list Sys.argv |> List.tl in
let foundation_only = List.mem "--foundation" args in
let jit_enabled = List.mem "--jit" args in
let test_files = List.filter (fun a -> not (String.length a > 0 && a.[0] = '-')) args in
(* --only-failing=PATH : read lines of form "FAIL: suite > name: ..." and
restrict test runs to those (suite, name) pairs. *)
List.iter (fun a ->
let prefix = "--only-failing=" in
if String.length a > String.length prefix
&& String.sub a 0 (String.length prefix) = prefix then begin
let path = String.sub a (String.length prefix) (String.length a - String.length prefix) in
let filter = Hashtbl.create 64 in
let ic = open_in path in
(try while true do
let line = input_line ic in
(* Match " FAIL: <suite> > <name>: <err>" or "FAIL: <suite> > <name>: <err>" *)
let line = String.trim line in
if String.length line > 6 && String.sub line 0 6 = "FAIL: " then begin
let rest = String.sub line 6 (String.length line - 6) in
match String.index_opt rest '>' with
| Some gt ->
let suite = String.trim (String.sub rest 0 gt) in
let after = String.sub rest (gt + 1) (String.length rest - gt - 1) in
(match String.index_opt after ':' with
| Some colon ->
let name = String.trim (String.sub after 0 colon) in
Hashtbl.replace filter (suite, name) ()
| None -> ())
| None -> ()
end
done with End_of_file -> ());
close_in ic;
Printf.eprintf "[filter] %d tests loaded from %s\n%!" (Hashtbl.length filter) path;
suite_filter := Some filter
end) args;
let test_files = List.filter (fun a ->
not (String.length a > 0 && a.[0] = '-')) args in
(* Always run foundation tests *)
run_foundation_tests ();