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)"