Add SX tree tools: comprehension, editing, and MCP server
Phase 1-3 of the SX Tools plan — structural reading, editing, and
MCP server for .sx files.
lib/tree-tools.sx — Pure SX functions for tree comprehension and editing:
Comprehension: annotate-tree, summarise, read-subtree, get-context,
find-all, get-siblings, validate, navigate
Editing: replace-node, insert-child, delete-node, wrap-node, tree-set
Helpers: list-replace, list-insert, list-remove, replace-placeholder
lib/tests/test-tree-tools.sx — 107 tests covering all functions.
hosts/ocaml/bin/mcp_tree.ml — MCP server (stdio JSON-RPC) exposing
11 tools. Loads tree-tools.sx into the OCaml evaluator, parses .sx
files with the native parser, calls SX functions for tree operations.
The MCP server can be configured in Claude Code's settings.json as:
"mcpServers": { "sx-tree": { "command": "path/to/mcp_tree.exe" } }
1429 tests passing (1322 existing + 107 new tree-tools).
Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
@@ -282,7 +282,7 @@ for (const expr of frameworkExprs) {
|
||||
// Load compiler + VM from lib/ when running full tests
|
||||
if (fullBuild) {
|
||||
const libDir = path.join(projectDir, "lib");
|
||||
for (const libFile of ["bytecode.sx", "compiler.sx", "vm.sx"]) {
|
||||
for (const libFile of ["bytecode.sx", "compiler.sx", "vm.sx", "tree-tools.sx"]) {
|
||||
const libPath = path.join(libDir, libFile);
|
||||
if (fs.existsSync(libPath)) {
|
||||
const src = fs.readFileSync(libPath, "utf8");
|
||||
|
||||
@@ -1,3 +1,7 @@
|
||||
(executables
|
||||
(names run_tests debug_set sx_server integration_tests)
|
||||
(libraries sx unix))
|
||||
|
||||
(executable
|
||||
(name mcp_tree)
|
||||
(libraries sx unix yojson))
|
||||
|
||||
353
hosts/ocaml/bin/mcp_tree.ml
Normal file
353
hosts/ocaml/bin/mcp_tree.ml
Normal file
@@ -0,0 +1,353 @@
|
||||
(** MCP server for SX tree tools — structural reading and editing of .sx files.
|
||||
|
||||
Stdio JSON-RPC transport following the MCP specification.
|
||||
Loads tree-tools.sx into the SX evaluator and exposes comprehension
|
||||
and editing functions as MCP tools. *)
|
||||
|
||||
open Sx_types
|
||||
|
||||
(* ------------------------------------------------------------------ *)
|
||||
(* SX evaluator setup — minimal env for parser + tree-tools *)
|
||||
(* ------------------------------------------------------------------ *)
|
||||
|
||||
let env = ref (make_env ())
|
||||
|
||||
let load_sx_file e path =
|
||||
let src = In_channel.with_open_text path In_channel.input_all in
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
List.iter (fun expr ->
|
||||
try ignore (Sx_ref.cek_call
|
||||
(NativeFn ("eval", fun args ->
|
||||
match args with
|
||||
| [ex] -> Sx_ref.eval_expr ex (Env e)
|
||||
| _ -> Nil))
|
||||
(List [expr]))
|
||||
with _ ->
|
||||
(* Fallback: direct eval *)
|
||||
ignore (Sx_ref.eval_expr expr (Env e))
|
||||
) exprs
|
||||
|
||||
let setup_env () =
|
||||
let e = make_env () in
|
||||
(* Primitives are auto-registered at module init *)
|
||||
(* Trampoline ref for HO primitives *)
|
||||
Sx_primitives._sx_trampoline_fn := (fun v ->
|
||||
match v with
|
||||
| Thunk (body, closure_env) -> Sx_ref.eval_expr body (Env closure_env)
|
||||
| other -> other);
|
||||
(* Character classification for parser *)
|
||||
let bind name fn = ignore (env_bind e name (NativeFn (name, fn))) in
|
||||
bind "is-whitespace?" (fun args -> match args with
|
||||
| [String s] when String.length s = 1 ->
|
||||
let c = s.[0] in Bool (c = ' ' || c = '\t' || c = '\n' || c = '\r')
|
||||
| _ -> Bool false);
|
||||
bind "is-digit?" (fun args -> match args with
|
||||
| [String s] when String.length s = 1 ->
|
||||
Bool (s.[0] >= '0' && s.[0] <= '9')
|
||||
| _ -> Bool false);
|
||||
bind "is-alpha?" (fun args -> match args with
|
||||
| [String s] when String.length s = 1 ->
|
||||
let c = s.[0] in Bool ((c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'))
|
||||
| _ -> Bool false);
|
||||
bind "char-code" (fun args -> match args with
|
||||
| [String s] when String.length s > 0 -> Number (float_of_int (Char.code s.[0]))
|
||||
| _ -> Number 0.0);
|
||||
bind "code-char" (fun args -> match args with
|
||||
| [Number n] -> String (String.make 1 (Char.chr (int_of_float n)))
|
||||
| _ -> String "");
|
||||
bind "parse-number" (fun args -> match args with
|
||||
| [String s] -> (try Number (float_of_string s) with _ -> Nil)
|
||||
| _ -> Nil);
|
||||
bind "identical?" (fun args -> match args with
|
||||
| [a; b] -> Bool (a == b)
|
||||
| _ -> Bool false);
|
||||
(* Runtime functions needed by tree-tools *)
|
||||
bind "symbol-name" (fun args -> match args with
|
||||
| [Symbol s] -> String s | _ -> String "");
|
||||
bind "keyword-name" (fun args -> match args with
|
||||
| [Keyword k] -> String k | _ -> String "");
|
||||
bind "make-symbol" (fun args -> match args with
|
||||
| [String s] -> Symbol s | _ -> Nil);
|
||||
bind "type-of" (fun args -> match args with
|
||||
| [v] -> String (type_of v) | _ -> String "nil");
|
||||
bind "list?" (fun args -> match args with
|
||||
| [List _ | ListRef _] -> Bool true | _ -> Bool false);
|
||||
bind "nil?" (fun args -> match args with
|
||||
| [v] -> Bool (is_nil v) | _ -> Bool true);
|
||||
bind "string?" (fun args -> match args with
|
||||
| [String _] -> Bool true | _ -> Bool false);
|
||||
bind "number?" (fun args -> match args with
|
||||
| [Number _] -> Bool true | _ -> Bool false);
|
||||
bind "callable?" (fun args -> match args with
|
||||
| [NativeFn _ | Lambda _ | Component _ | Island _] -> Bool true | _ -> Bool false);
|
||||
bind "empty?" (fun args -> match args with
|
||||
| [List []] | [ListRef { contents = [] }] -> Bool true
|
||||
| [Nil] -> Bool true | _ -> Bool false);
|
||||
bind "contains?" (fun args -> match args with
|
||||
| [String s; String sub] ->
|
||||
let rec find i =
|
||||
if i > String.length s - String.length sub then false
|
||||
else if String.sub s i (String.length sub) = sub then true
|
||||
else find (i + 1)
|
||||
in Bool (String.length sub = 0 || find 0)
|
||||
| [List l; v] | [ListRef { contents = l }; v] ->
|
||||
Bool (List.exists (fun x -> x = v) l)
|
||||
| _ -> Bool false);
|
||||
bind "starts-with?" (fun args -> match args with
|
||||
| [String s; String prefix] ->
|
||||
Bool (String.length s >= String.length prefix &&
|
||||
String.sub s 0 (String.length prefix) = prefix)
|
||||
| _ -> Bool false);
|
||||
bind "append!" (fun args -> match args with
|
||||
| [ListRef r; v] -> r := !r @ [v]; v
|
||||
| _ -> Nil);
|
||||
bind "map-indexed" (fun args -> match args with
|
||||
| [f; List l] | [f; ListRef { contents = l }] ->
|
||||
List (List.mapi (fun i x -> Sx_ref.cek_call f (List [Number (float_of_int i); x])) l)
|
||||
| _ -> List []);
|
||||
(* sx-parse — use the native OCaml parser for bootstrapping *)
|
||||
bind "sx-parse" (fun args -> match args with
|
||||
| [String s] -> List (Sx_parser.parse_all s)
|
||||
| _ -> List []);
|
||||
bind "sx-serialize" (fun args -> match args with
|
||||
| [v] -> String (Sx_runtime.value_to_str v)
|
||||
| _ -> String "");
|
||||
(* Load parser.sx for the SX-level sx-parse/sx-serialize *)
|
||||
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in
|
||||
let lib_dir = try Sys.getenv "SX_LIB_DIR" with Not_found -> "lib" in
|
||||
(try load_sx_file e (Filename.concat spec_dir "parser.sx")
|
||||
with exn -> Printf.eprintf "[mcp] Warning: parser.sx load failed: %s\n%!" (Printexc.to_string exn));
|
||||
(* Load tree-tools *)
|
||||
(try load_sx_file e (Filename.concat lib_dir "tree-tools.sx")
|
||||
with exn -> Printf.eprintf "[mcp] Error: tree-tools.sx load failed: %s\n%!" (Printexc.to_string exn); exit 1);
|
||||
Printf.eprintf "[mcp] SX tree-tools loaded\n%!";
|
||||
env := e
|
||||
|
||||
(* ------------------------------------------------------------------ *)
|
||||
(* Call SX tree-tools functions *)
|
||||
(* ------------------------------------------------------------------ *)
|
||||
|
||||
let call_sx fn_name args =
|
||||
let e = !env in
|
||||
let fn = env_get e fn_name in
|
||||
Sx_ref.cek_call fn (List args)
|
||||
|
||||
let parse_file path =
|
||||
let src = In_channel.with_open_text path In_channel.input_all in
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
List exprs
|
||||
|
||||
let json_to_path j =
|
||||
let open Yojson.Safe.Util in
|
||||
List (List.map (fun x -> Number (float_of_int (to_int x))) (to_list j))
|
||||
|
||||
let value_to_string v =
|
||||
match v with
|
||||
| String s -> s
|
||||
| _ -> Sx_runtime.value_to_str v
|
||||
|
||||
let text_result s =
|
||||
`Assoc [("content", `List [`Assoc [
|
||||
("type", `String "text");
|
||||
("text", `String s)
|
||||
]])]
|
||||
|
||||
let error_result s =
|
||||
`Assoc [("content", `List [`Assoc [
|
||||
("type", `String "text");
|
||||
("text", `String s)
|
||||
]]);
|
||||
("isError", `Bool true)]
|
||||
|
||||
(* ------------------------------------------------------------------ *)
|
||||
(* Tool handlers *)
|
||||
(* ------------------------------------------------------------------ *)
|
||||
|
||||
let rec handle_tool name args =
|
||||
let open Yojson.Safe.Util in
|
||||
match name with
|
||||
| "sx_read_tree" ->
|
||||
let tree = parse_file (args |> member "file" |> to_string) in
|
||||
text_result (value_to_string (call_sx "annotate-tree" [tree]))
|
||||
|
||||
| "sx_summarise" ->
|
||||
let tree = parse_file (args |> member "file" |> to_string) in
|
||||
let depth = args |> member "depth" |> to_int in
|
||||
text_result (value_to_string (call_sx "summarise" [tree; Number (float_of_int depth)]))
|
||||
|
||||
| "sx_read_subtree" ->
|
||||
let tree = parse_file (args |> member "file" |> to_string) in
|
||||
let path = args |> member "path" |> json_to_path in
|
||||
text_result (value_to_string (call_sx "read-subtree" [tree; path]))
|
||||
|
||||
| "sx_get_context" ->
|
||||
let tree = parse_file (args |> member "file" |> to_string) in
|
||||
let path = args |> member "path" |> json_to_path in
|
||||
text_result (value_to_string (call_sx "get-context" [tree; path]))
|
||||
|
||||
| "sx_find_all" ->
|
||||
let tree = parse_file (args |> member "file" |> to_string) 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
|
||||
text_result (String.concat "\n" lines)
|
||||
|
||||
| "sx_get_siblings" ->
|
||||
let tree = parse_file (args |> member "file" |> to_string) in
|
||||
let path = args |> member "path" |> json_to_path in
|
||||
text_result (value_to_string (call_sx "get-siblings" [tree; path]))
|
||||
|
||||
| "sx_validate" ->
|
||||
let tree = parse_file (args |> member "file" |> to_string) in
|
||||
text_result (value_to_string (call_sx "validate" [tree]))
|
||||
|
||||
| "sx_replace_node" ->
|
||||
let file = args |> member "file" |> to_string in
|
||||
let tree = parse_file file in
|
||||
let path = args |> member "path" |> json_to_path in
|
||||
let src = args |> member "new_source" |> to_string in
|
||||
write_edit file (call_sx "replace-node" [tree; path; String src])
|
||||
|
||||
| "sx_insert_child" ->
|
||||
let file = args |> member "file" |> to_string in
|
||||
let tree = parse_file file in
|
||||
let path = args |> member "path" |> json_to_path in
|
||||
let index = args |> member "index" |> to_int in
|
||||
let src = args |> member "new_source" |> to_string in
|
||||
write_edit file (call_sx "insert-child" [tree; path; Number (float_of_int index); String src])
|
||||
|
||||
| "sx_delete_node" ->
|
||||
let file = args |> member "file" |> to_string in
|
||||
let tree = parse_file file in
|
||||
let path = args |> member "path" |> json_to_path in
|
||||
write_edit file (call_sx "delete-node" [tree; path])
|
||||
|
||||
| "sx_wrap_node" ->
|
||||
let file = args |> member "file" |> to_string in
|
||||
let tree = parse_file file in
|
||||
let path = args |> member "path" |> json_to_path in
|
||||
let wrapper = args |> member "wrapper" |> to_string in
|
||||
write_edit file (call_sx "wrap-node" [tree; path; String wrapper])
|
||||
|
||||
| _ -> error_result ("Unknown tool: " ^ name)
|
||||
|
||||
and write_edit file result =
|
||||
match result with
|
||||
| Dict d ->
|
||||
(match Hashtbl.find_opt d "ok" with
|
||||
| Some new_tree ->
|
||||
let parts = match new_tree with
|
||||
| List items | ListRef { contents = items } ->
|
||||
List.map (fun expr -> Sx_runtime.value_to_str expr) items
|
||||
| _ -> [Sx_runtime.value_to_str new_tree]
|
||||
in
|
||||
let source = String.concat "\n\n" parts ^ "\n" in
|
||||
Out_channel.with_open_text file (fun oc -> output_string oc source);
|
||||
text_result (Printf.sprintf "OK — wrote %d bytes to %s" (String.length source) file)
|
||||
| None ->
|
||||
let err = match Hashtbl.find_opt d "error" with
|
||||
| Some (String s) -> s | Some v -> value_to_string v | None -> "Unknown error"
|
||||
in
|
||||
error_result ("Error: " ^ err))
|
||||
| _ -> error_result "Unexpected result type"
|
||||
|
||||
(* ------------------------------------------------------------------ *)
|
||||
(* MCP tool definitions *)
|
||||
(* ------------------------------------------------------------------ *)
|
||||
|
||||
let tool name desc props required =
|
||||
`Assoc [
|
||||
("name", `String name);
|
||||
("description", `String desc);
|
||||
("inputSchema", `Assoc [
|
||||
("type", `String "object");
|
||||
("required", `List (List.map (fun r -> `String r) required));
|
||||
("properties", `Assoc props)])]
|
||||
|
||||
let file_prop = ("file", `Assoc [("type", `String "string"); ("description", `String "Path to .sx file")])
|
||||
let path_prop = ("path", `Assoc [("type", `String "array"); ("items", `Assoc [("type", `String "integer")]); ("description", `String "Index path, e.g. [0,2,1]")])
|
||||
|
||||
let tool_definitions = `List [
|
||||
tool "sx_read_tree" "Read an .sx file as an annotated tree with path labels on every node. Use this to understand structure before editing."
|
||||
[file_prop] ["file"];
|
||||
tool "sx_summarise" "Folded structural overview of an .sx file. Use to orient before drilling into a region."
|
||||
[file_prop; ("depth", `Assoc [("type", `String "integer"); ("description", `String "Max depth (0=heads only)")])] ["file"; "depth"];
|
||||
tool "sx_read_subtree" "Expand a specific subtree by path. Use after summarise to drill in."
|
||||
[file_prop; path_prop] ["file"; "path"];
|
||||
tool "sx_get_context" "Show enclosing chain from root to a target node."
|
||||
[file_prop; path_prop] ["file"; "path"];
|
||||
tool "sx_find_all" "Search for nodes matching a pattern. Returns paths and summaries."
|
||||
[file_prop; ("pattern", `Assoc [("type", `String "string"); ("description", `String "Search pattern")])] ["file"; "pattern"];
|
||||
tool "sx_get_siblings" "Show siblings of a node with target marked."
|
||||
[file_prop; path_prop] ["file"; "path"];
|
||||
tool "sx_validate" "Check structural integrity of an .sx file."
|
||||
[file_prop] ["file"];
|
||||
tool "sx_replace_node" "Replace node at path with new SX source. Fragment is parsed before file is touched."
|
||||
[file_prop; path_prop; ("new_source", `Assoc [("type", `String "string"); ("description", `String "New SX source")])] ["file"; "path"; "new_source"];
|
||||
tool "sx_insert_child" "Insert new child at index within a list node."
|
||||
[file_prop; path_prop; ("index", `Assoc [("type", `String "integer"); ("description", `String "Insert position")]); ("new_source", `Assoc [("type", `String "string"); ("description", `String "New SX source")])] ["file"; "path"; "index"; "new_source"];
|
||||
tool "sx_delete_node" "Remove node at path. Siblings shift to fill gap."
|
||||
[file_prop; path_prop] ["file"; "path"];
|
||||
tool "sx_wrap_node" "Wrap node in a new form. Use _ as placeholder, e.g. \"(when cond _)\"."
|
||||
[file_prop; path_prop; ("wrapper", `Assoc [("type", `String "string"); ("description", `String "Wrapper with _ placeholder")])] ["file"; "path"; "wrapper"];
|
||||
]
|
||||
|
||||
(* ------------------------------------------------------------------ *)
|
||||
(* JSON-RPC dispatch *)
|
||||
(* ------------------------------------------------------------------ *)
|
||||
|
||||
let dispatch method_name params =
|
||||
match method_name with
|
||||
| "initialize" ->
|
||||
`Assoc [
|
||||
("protocolVersion", `String "2024-11-05");
|
||||
("capabilities", `Assoc [("tools", `Assoc [])]);
|
||||
("serverInfo", `Assoc [
|
||||
("name", `String "sx-tree-tools");
|
||||
("version", `String "0.1.0")])]
|
||||
| "notifications/initialized" -> `Null
|
||||
| "tools/list" -> `Assoc [("tools", tool_definitions)]
|
||||
| "tools/call" ->
|
||||
let open Yojson.Safe.Util in
|
||||
let name = params |> member "name" |> to_string in
|
||||
let args = params |> member "arguments" in
|
||||
(try handle_tool name args
|
||||
with e -> error_result ("Error: " ^ Printexc.to_string e))
|
||||
| _ -> `Null
|
||||
|
||||
(* ------------------------------------------------------------------ *)
|
||||
(* Stdio JSON-RPC main loop *)
|
||||
(* ------------------------------------------------------------------ *)
|
||||
|
||||
let () =
|
||||
setup_env ();
|
||||
try while true do
|
||||
let line = input_line stdin in
|
||||
if String.length line > 0 then begin
|
||||
let json = Yojson.Safe.from_string line in
|
||||
let open Yojson.Safe.Util in
|
||||
let meth = json |> member "method" |> to_string_option |> Option.value ~default:"" in
|
||||
let params = json |> member "params" in
|
||||
let id = json |> member "id" in
|
||||
let result = dispatch meth params in
|
||||
if id <> `Null then begin
|
||||
let resp = `Assoc [
|
||||
("jsonrpc", `String "2.0");
|
||||
("id", id);
|
||||
("result", result)] in
|
||||
print_string (Yojson.Safe.to_string resp);
|
||||
print_char '\n';
|
||||
flush stdout
|
||||
end
|
||||
end
|
||||
done
|
||||
with End_of_file -> ()
|
||||
675
lib/tests/test-tree-tools.sx
Normal file
675
lib/tests/test-tree-tools.sx
Normal file
@@ -0,0 +1,675 @@
|
||||
;; ==========================================================================
|
||||
;; test-tree-tools.sx — Tests for structural comprehension tools
|
||||
;; ==========================================================================
|
||||
|
||||
(defsuite "tree-tools"
|
||||
|
||||
;; ========================================================================
|
||||
;; path-str
|
||||
;; ========================================================================
|
||||
|
||||
(deftest "path-str formats index path"
|
||||
(assert-equal "[0,2,1]" (path-str (list 0 2 1))))
|
||||
|
||||
(deftest "path-str single element"
|
||||
(assert-equal "[0]" (path-str (list 0))))
|
||||
|
||||
(deftest "path-str empty"
|
||||
(assert-equal "[]" (path-str (list))))
|
||||
|
||||
(deftest "path-str deep path"
|
||||
(assert-equal "[0,1,2,3,4,5]" (path-str (list 0 1 2 3 4 5))))
|
||||
|
||||
;; ========================================================================
|
||||
;; navigate
|
||||
;; ========================================================================
|
||||
|
||||
(deftest "navigate to root element"
|
||||
(let ((tree (sx-parse "(defcomp ~card () (div))")))
|
||||
(let ((node (navigate tree (list 0))))
|
||||
(assert (list? node))
|
||||
(assert-equal "defcomp" (symbol-name (first node))))))
|
||||
|
||||
(deftest "navigate to atom child"
|
||||
(let ((tree (sx-parse "(add 1 2)")))
|
||||
(assert-equal 1 (navigate tree (list 0 1)))
|
||||
(assert-equal 2 (navigate tree (list 0 2)))))
|
||||
|
||||
(deftest "navigate to nested child"
|
||||
(let ((tree (sx-parse "(a (b (c d)))")))
|
||||
(let ((node (navigate tree (list 0 1 1 1))))
|
||||
(assert-equal "d" (symbol-name node)))))
|
||||
|
||||
(deftest "navigate invalid path returns nil"
|
||||
(let ((tree (sx-parse "(a b c)")))
|
||||
(assert (nil? (navigate tree (list 0 5))))))
|
||||
|
||||
(deftest "navigate empty path returns root list"
|
||||
(let ((tree (sx-parse "(a b)")))
|
||||
(let ((node (navigate tree (list))))
|
||||
(assert (list? node))
|
||||
(assert-equal 1 (len node)))))
|
||||
|
||||
(deftest "navigate deep path"
|
||||
(let ((tree (sx-parse "(let ((x 1)) (if x (+ x 1) 0))")))
|
||||
(let ((node (navigate tree (list 0 2 2 1))))
|
||||
(assert-equal "x" (symbol-name node)))))
|
||||
|
||||
(deftest "navigate to string"
|
||||
(let ((tree (sx-parse "(div \"hello\")")))
|
||||
(assert-equal "hello" (navigate tree (list 0 1)))))
|
||||
|
||||
(deftest "navigate to keyword"
|
||||
(let ((tree (sx-parse "(div :class \"card\")")))
|
||||
(assert-equal "keyword" (type-of (navigate tree (list 0 1))))))
|
||||
|
||||
(deftest "navigate past atom returns nil"
|
||||
(let ((tree (sx-parse "(a b)")))
|
||||
(assert (nil? (navigate tree (list 0 1 0))))))
|
||||
|
||||
(deftest "navigate multiple top-level forms"
|
||||
(let ((tree (sx-parse "(define x 1) (define y 2)")))
|
||||
(assert-equal "x" (symbol-name (navigate tree (list 0 1))))
|
||||
(assert-equal "y" (symbol-name (navigate tree (list 1 1))))))
|
||||
|
||||
;; ========================================================================
|
||||
;; node-display
|
||||
;; ========================================================================
|
||||
|
||||
(deftest "node-display symbol"
|
||||
(let ((tree (sx-parse "foo")))
|
||||
(assert-equal "foo" (node-display (first tree)))))
|
||||
|
||||
(deftest "node-display number"
|
||||
(assert-equal "42" (node-display 42)))
|
||||
|
||||
(deftest "node-display string short"
|
||||
(assert-equal "\"hello\"" (node-display "hello")))
|
||||
|
||||
(deftest "node-display string truncated"
|
||||
(let ((long "this is a very long string that exceeds forty characters limit"))
|
||||
(let ((result (node-display long)))
|
||||
(assert (contains? result "..."))
|
||||
(assert (< (len result) 50)))))
|
||||
|
||||
(deftest "node-display nil"
|
||||
(assert-equal "nil" (node-display nil)))
|
||||
|
||||
(deftest "node-display boolean"
|
||||
(assert-equal "true" (node-display true))
|
||||
(assert-equal "false" (node-display false)))
|
||||
|
||||
(deftest "node-display keyword"
|
||||
(let ((tree (sx-parse ":class")))
|
||||
(assert-equal ":class" (node-display (first tree)))))
|
||||
|
||||
(deftest "node-display list preview"
|
||||
(let ((tree (sx-parse "(div (span \"hi\") (p \"bye\"))")))
|
||||
(let ((result (node-display (first tree))))
|
||||
(assert (contains? result "div"))
|
||||
(assert (contains? result "...")))))
|
||||
|
||||
(deftest "node-display empty list"
|
||||
(assert-equal "()" (node-display (list))))
|
||||
|
||||
;; ========================================================================
|
||||
;; annotate-tree
|
||||
;; ========================================================================
|
||||
|
||||
(deftest "annotate simple list — compact form"
|
||||
(let ((tree (sx-parse "(add 1 2)")))
|
||||
(let ((result (annotate-tree tree)))
|
||||
(assert (contains? result "[0]"))
|
||||
(assert (contains? result "(add 1 2)")))))
|
||||
|
||||
(deftest "annotate nested list — multi-line"
|
||||
(let ((tree (sx-parse "(div (span \"hello\"))")))
|
||||
(let ((result (annotate-tree tree)))
|
||||
(assert (contains? result "[0] (div"))
|
||||
(assert (contains? result "[0,1] (span \"hello\")")))))
|
||||
|
||||
(deftest "annotate multiple top-level forms"
|
||||
(let ((tree (sx-parse "(define x 1) (define y 2)")))
|
||||
(let ((result (annotate-tree tree)))
|
||||
(assert (contains? result "[0]"))
|
||||
(assert (contains? result "[1]"))
|
||||
(assert (contains? result "x"))
|
||||
(assert (contains? result "y")))))
|
||||
|
||||
(deftest "annotate deeply nested"
|
||||
(let ((tree (sx-parse "(a (b (c (d 1))))")))
|
||||
(let ((result (annotate-tree tree)))
|
||||
(assert (contains? result "[0] (a"))
|
||||
(assert (contains? result "[0,1] (b"))
|
||||
(assert (contains? result "[0,1,1] (c"))
|
||||
(assert (contains? result "[0,1,1,1] (d 1)")))))
|
||||
|
||||
(deftest "annotate preserves string content"
|
||||
(let ((tree (sx-parse "(div :class \"my-class\" \"content\")")))
|
||||
(let ((result (annotate-tree tree)))
|
||||
(assert (contains? result "\"my-class\""))
|
||||
(assert (contains? result "\"content\"")))))
|
||||
|
||||
(deftest "annotate single atom"
|
||||
(let ((tree (sx-parse "42")))
|
||||
(let ((result (annotate-tree tree)))
|
||||
(assert (contains? result "[0] 42")))))
|
||||
|
||||
(deftest "annotate empty list"
|
||||
(let ((tree (sx-parse "()")))
|
||||
(let ((result (annotate-tree tree)))
|
||||
(assert (contains? result "()")))))
|
||||
|
||||
(deftest "annotate defcomp structure"
|
||||
(let ((tree (sx-parse "(defcomp ~card (&key title) (div (h2 title)))")))
|
||||
(let ((result (annotate-tree tree)))
|
||||
(assert (contains? result "[0] (defcomp"))
|
||||
(assert (contains? result "~card"))
|
||||
(assert (contains? result "[0,3] (div")))))
|
||||
|
||||
;; ========================================================================
|
||||
;; summarise
|
||||
;; ========================================================================
|
||||
|
||||
(deftest "summarise at depth 0 shows only heads"
|
||||
(let ((tree (sx-parse "(defcomp ~card () (div (span \"hi\")))")))
|
||||
(let ((result (summarise tree 0)))
|
||||
(assert (contains? result "defcomp"))
|
||||
(assert (not (contains? result "span"))))))
|
||||
|
||||
(deftest "summarise at depth 1 shows one level"
|
||||
(let ((tree (sx-parse "(defcomp ~card () (div (span \"hi\")))")))
|
||||
(let ((result (summarise tree 1)))
|
||||
(assert (contains? result "defcomp"))
|
||||
(assert (contains? result "~card"))
|
||||
(assert (contains? result "div")))))
|
||||
|
||||
(deftest "summarise at depth 2 shows two levels"
|
||||
(let ((tree (sx-parse "(a (b (c (d 1))))")))
|
||||
(let ((result (summarise tree 2)))
|
||||
(assert (contains? result "a"))
|
||||
(assert (contains? result "b"))
|
||||
(assert (contains? result "c"))
|
||||
;; d should be folded
|
||||
(assert (not (contains? result "[0,1,1,1]"))))))
|
||||
|
||||
(deftest "summarise shows child count at fold"
|
||||
(let ((tree (sx-parse "(div (span \"a\") (span \"b\") (span \"c\"))")))
|
||||
(let ((result (summarise tree 0)))
|
||||
(assert (contains? result "children")))))
|
||||
|
||||
(deftest "summarise multiple top-level forms"
|
||||
(let ((tree (sx-parse "(define x 1) (define y 2) (define z 3)")))
|
||||
(let ((result (summarise tree 0)))
|
||||
(assert (contains? result "[0]"))
|
||||
(assert (contains? result "[1]"))
|
||||
(assert (contains? result "[2]")))))
|
||||
|
||||
;; ========================================================================
|
||||
;; read-subtree
|
||||
;; ========================================================================
|
||||
|
||||
(deftest "read-subtree expands target"
|
||||
(let ((tree (sx-parse "(a (b (c 1) (d 2)) (e 3))")))
|
||||
(let ((result (read-subtree tree (list 0 1))))
|
||||
(assert (contains? result "b"))
|
||||
(assert (contains? result "c"))
|
||||
(assert (contains? result "d"))
|
||||
(assert (not (contains? result " e "))))))
|
||||
|
||||
(deftest "read-subtree invalid path gives error"
|
||||
(let ((tree (sx-parse "(a b)")))
|
||||
(let ((result (read-subtree tree (list 5))))
|
||||
(assert (contains? result "Error")))))
|
||||
|
||||
(deftest "read-subtree on atom"
|
||||
(let ((tree (sx-parse "(a \"hello\" 42)")))
|
||||
(let ((result (read-subtree tree (list 0 1))))
|
||||
(assert (contains? result "\"hello\"")))))
|
||||
|
||||
(deftest "read-subtree on deeply nested"
|
||||
(let ((tree (sx-parse "(a (b (c (d (e 1)))))")))
|
||||
(let ((result (read-subtree tree (list 0 1 1 1))))
|
||||
(assert (contains? result "e"))
|
||||
(assert (contains? result "1")))))
|
||||
|
||||
;; ========================================================================
|
||||
;; get-context
|
||||
;; ========================================================================
|
||||
|
||||
(deftest "get-context shows enclosing chain"
|
||||
(let ((tree (sx-parse "(let ((x 1)) (if x (+ x 1) 0))")))
|
||||
(let ((result (get-context tree (list 0 2 2))))
|
||||
(assert (contains? result "[0]"))
|
||||
(assert (contains? result "let"))
|
||||
(assert (contains? result "[0,2]"))
|
||||
(assert (contains? result "[0,2,2]")))))
|
||||
|
||||
(deftest "get-context marks deepest with arrow"
|
||||
(let ((tree (sx-parse "(a (b (c d)))")))
|
||||
(let ((result (get-context tree (list 0 1 1))))
|
||||
(assert (contains? result "→")))))
|
||||
|
||||
(deftest "get-context single level"
|
||||
(let ((tree (sx-parse "(a b c)")))
|
||||
(let ((result (get-context tree (list 0))))
|
||||
(assert (contains? result "[0]"))
|
||||
(assert (contains? result "a")))))
|
||||
|
||||
(deftest "get-context defcomp chain"
|
||||
(let ((tree (sx-parse "(defcomp ~card () (div :class \"c\" (h2 \"title\")))")))
|
||||
(let ((result (get-context tree (list 0 3 3))))
|
||||
(assert (contains? result "defcomp"))
|
||||
(assert (contains? result "div"))
|
||||
(assert (contains? result "h2")))))
|
||||
|
||||
;; ========================================================================
|
||||
;; find-all
|
||||
;; ========================================================================
|
||||
|
||||
(deftest "find-all locates symbols by name"
|
||||
(let ((tree (sx-parse "(define foo 1) (define bar (+ foo 2))")))
|
||||
(let ((results (find-all tree "foo")))
|
||||
(assert (>= (len results) 2)))))
|
||||
|
||||
(deftest "find-all locates list heads"
|
||||
(let ((tree (sx-parse "(div (span \"a\") (span \"b\") (p \"c\"))")))
|
||||
(let ((results (find-all tree "span")))
|
||||
(assert (>= (len results) 2)))))
|
||||
|
||||
(deftest "find-all returns empty for no match"
|
||||
(let ((tree (sx-parse "(a b c)")))
|
||||
(assert (empty? (find-all tree "zzz")))))
|
||||
|
||||
(deftest "find-all finds nested deeply"
|
||||
(let ((tree (sx-parse "(a (b (c (target 1))))")))
|
||||
(let ((results (find-all tree "target")))
|
||||
(assert (>= (len results) 1)))))
|
||||
|
||||
(deftest "find-all finds string content"
|
||||
(let ((tree (sx-parse "(div \"hello world\" (p \"goodbye\"))")))
|
||||
(let ((results (find-all tree "hello")))
|
||||
(assert (>= (len results) 1)))))
|
||||
|
||||
(deftest "find-all finds component names"
|
||||
(let ((tree (sx-parse "(defcomp ~my-card () (div)) (defcomp ~my-button () (button))")))
|
||||
(let ((results (find-all tree "~my-card")))
|
||||
(assert (>= (len results) 1)))))
|
||||
|
||||
(deftest "find-all returns paths"
|
||||
(let ((tree (sx-parse "(a (b target) (c target))")))
|
||||
(let ((results (find-all tree "target")))
|
||||
;; Each result is (path summary)
|
||||
(assert (list? (first (first results)))))))
|
||||
|
||||
;; ========================================================================
|
||||
;; get-siblings
|
||||
;; ========================================================================
|
||||
|
||||
(deftest "get-siblings shows all children of parent"
|
||||
(let ((tree (sx-parse "(div (span \"a\") (p \"b\") (em \"c\"))")))
|
||||
(let ((result (get-siblings tree (list 0 2))))
|
||||
(assert (contains? result "div"))
|
||||
(assert (contains? result "span"))
|
||||
(assert (contains? result "p"))
|
||||
(assert (contains? result "em"))
|
||||
(assert (contains? result "→")))))
|
||||
|
||||
(deftest "get-siblings marks correct target"
|
||||
(let ((tree (sx-parse "(a b c d e)")))
|
||||
(let ((result (get-siblings tree (list 0 3))))
|
||||
;; d is at index 3, should be marked
|
||||
(assert (contains? result "→ [0,3]")))))
|
||||
|
||||
(deftest "get-siblings error on root"
|
||||
(let ((tree (sx-parse "(a b)")))
|
||||
(let ((result (get-siblings tree (list))))
|
||||
(assert (contains? result "Error")))))
|
||||
|
||||
(deftest "get-siblings first child"
|
||||
(let ((tree (sx-parse "(div (span) (p) (em))")))
|
||||
(let ((result (get-siblings tree (list 0 1))))
|
||||
(assert (contains? result "→ [0,1]")))))
|
||||
|
||||
;; ========================================================================
|
||||
;; validate
|
||||
;; ========================================================================
|
||||
|
||||
(deftest "validate passes clean tree"
|
||||
(let ((tree (sx-parse "(defcomp ~card () (div))")))
|
||||
(assert-equal "OK" (validate tree))))
|
||||
|
||||
(deftest "validate catches malformed letrec binding"
|
||||
(let ((tree (sx-parse "(letrec (42 (fn () nil)) nil)")))
|
||||
(let ((result (validate tree)))
|
||||
(assert (contains? result "WARNING"))
|
||||
(assert (contains? result "letrec")))))
|
||||
|
||||
(deftest "validate catches defcomp with no body"
|
||||
(let ((tree (sx-parse "(defcomp ~card)")))
|
||||
(let ((result (validate tree)))
|
||||
(assert (contains? result "ERROR"))
|
||||
(assert (contains? result "defcomp")))))
|
||||
|
||||
(deftest "validate catches defisland with no body"
|
||||
(let ((tree (sx-parse "(defisland ~counter)")))
|
||||
(let ((result (validate tree)))
|
||||
(assert (contains? result "ERROR"))
|
||||
(assert (contains? result "defisland")))))
|
||||
|
||||
(deftest "validate passes valid letrec"
|
||||
(let ((tree (sx-parse "(letrec ((f (fn () 1)) (g (fn () 2))) (f))")))
|
||||
(assert-equal "OK" (validate tree))))
|
||||
|
||||
(deftest "validate nested issues"
|
||||
(let ((tree (sx-parse "(div (defcomp ~bad))")))
|
||||
(let ((result (validate tree)))
|
||||
(assert (contains? result "ERROR")))))
|
||||
|
||||
(deftest "validate multiple issues"
|
||||
(let ((tree (sx-parse "(do (defcomp ~a) (defisland ~b))")))
|
||||
(let ((result (validate tree)))
|
||||
;; Should have two errors
|
||||
(assert (contains? result "defcomp"))
|
||||
(assert (contains? result "defisland")))))
|
||||
|
||||
;; ========================================================================
|
||||
;; node-summary
|
||||
;; ========================================================================
|
||||
|
||||
(deftest "node-summary short list"
|
||||
(let ((tree (sx-parse "(add 1 2)")))
|
||||
(let ((result (node-summary (first tree))))
|
||||
(assert-equal "(add 1 2)" result))))
|
||||
|
||||
(deftest "node-summary long list truncates"
|
||||
(let ((tree (sx-parse "(fn (a b c d e f) body)")))
|
||||
(let ((result (node-summary (first tree))))
|
||||
(assert (contains? result "fn"))
|
||||
(assert (contains? result "...")))))
|
||||
|
||||
(deftest "node-summary atom"
|
||||
(assert-equal "42" (node-summary 42)))
|
||||
|
||||
;; ========================================================================
|
||||
;; Real-world scenarios
|
||||
;; ========================================================================
|
||||
|
||||
(deftest "annotate-tree on defisland"
|
||||
(let ((tree (sx-parse "(defisland ~counter () (let ((count (signal 0))) (div (button count))))")))
|
||||
(let ((result (annotate-tree tree)))
|
||||
(assert (contains? result "defisland"))
|
||||
(assert (contains? result "~counter"))
|
||||
(assert (contains? result "let"))
|
||||
(assert (contains? result "button")))))
|
||||
|
||||
(deftest "find-all finds letrec bindings by name"
|
||||
(let ((tree (sx-parse "(letrec ((helper (fn () 1)) (main (fn () (helper)))) (main))")))
|
||||
(let ((results (find-all tree "helper")))
|
||||
;; Should find: the binding name, the call inside main
|
||||
(assert (>= (len results) 2)))))
|
||||
|
||||
(deftest "validate detects letrec non-pair expression"
|
||||
;; Simulate the original bug: a bare expression in the bindings list
|
||||
(let ((tree (sx-parse "(letrec ((a (fn () nil)) (rebuild-preview 1) (b (fn () nil))) nil)")))
|
||||
;; (rebuild-preview 1) looks like a binding pair, so validate won't flag it
|
||||
;; BUT annotate-tree reveals the structure:
|
||||
(let ((ann (annotate-tree tree)))
|
||||
;; rebuild-preview should be at [0,1,1] as a binding pair
|
||||
(assert (contains? ann "[0,1,1]"))
|
||||
(assert (contains? ann "rebuild-preview")))))
|
||||
|
||||
(deftest "get-context on real component pattern"
|
||||
(let ((tree (sx-parse "(defcomp ~layout (&key title) (html (head (title title)) (body (div :id \"app\" (main children)))))")))
|
||||
;; body is at [0,3] (html), [0,3,2] (body), [0,3,2,1] (div), [0,3,2,1,3] (main)
|
||||
(let ((result (get-context tree (list 0 3 2 1 3))))
|
||||
(assert (contains? result "defcomp"))
|
||||
(assert (contains? result "body"))
|
||||
(assert (contains? result "main")))))
|
||||
|
||||
(deftest "summarise then read-subtree workflow"
|
||||
;; The typical workflow: summarise to find region, then read-subtree to expand
|
||||
(let ((tree (sx-parse "(defcomp ~page () (div (header (h1 \"Title\")) (main (p \"Content\") (p \"More\"))))")))
|
||||
;; Step 1: summarise at depth 1 to find main
|
||||
(let ((summary (summarise tree 1)))
|
||||
(assert (contains? summary "div"))
|
||||
;; Step 2: read-subtree on main — body is [0,3], div children start at [0,3,1]
|
||||
(let ((detail (read-subtree tree (list 0 3 2))))
|
||||
(assert (contains? detail "main"))
|
||||
(assert (contains? detail "Content"))
|
||||
(assert (contains? detail "More"))))))
|
||||
|
||||
;; ========================================================================
|
||||
;; Phase 2: Edit operations
|
||||
;; ========================================================================
|
||||
|
||||
;; -- list helpers --
|
||||
|
||||
(deftest "list-replace replaces at index"
|
||||
(assert-equal (list 1 99 3) (list-replace (list 1 2 3) 1 99)))
|
||||
|
||||
(deftest "list-replace first"
|
||||
(assert-equal (list 99 2 3) (list-replace (list 1 2 3) 0 99)))
|
||||
|
||||
(deftest "list-replace last"
|
||||
(assert-equal (list 1 2 99) (list-replace (list 1 2 3) 2 99)))
|
||||
|
||||
(deftest "list-insert at start"
|
||||
(assert-equal (list 0 1 2 3) (list-insert (list 1 2 3) 0 0)))
|
||||
|
||||
(deftest "list-insert at middle"
|
||||
(assert-equal (list 1 99 2 3) (list-insert (list 1 2 3) 1 99)))
|
||||
|
||||
(deftest "list-insert at end"
|
||||
(assert-equal (list 1 2 3 4) (list-insert (list 1 2 3) 3 4)))
|
||||
|
||||
(deftest "list-remove first"
|
||||
(assert-equal (list 2 3) (list-remove (list 1 2 3) 0)))
|
||||
|
||||
(deftest "list-remove middle"
|
||||
(assert-equal (list 1 3) (list-remove (list 1 2 3) 1)))
|
||||
|
||||
(deftest "list-remove last"
|
||||
(assert-equal (list 1 2) (list-remove (list 1 2 3) 2)))
|
||||
|
||||
;; -- tree-set --
|
||||
|
||||
(deftest "tree-set replaces root child"
|
||||
(let ((tree (sx-parse "(a b c)")))
|
||||
(let ((result (tree-set tree (list 0 1) 99)))
|
||||
(assert-equal 99 (navigate result (list 0 1))))))
|
||||
|
||||
(deftest "tree-set replaces nested child"
|
||||
(let ((tree (sx-parse "(a (b 1 2) c)")))
|
||||
(let ((result (tree-set tree (list 0 1 1) 99)))
|
||||
(assert-equal 99 (navigate result (list 0 1 1)))
|
||||
;; Other nodes unchanged
|
||||
(assert-equal 2 (navigate result (list 0 1 2))))))
|
||||
|
||||
(deftest "tree-set invalid path returns nil"
|
||||
(let ((tree (sx-parse "(a b)")))
|
||||
(assert (nil? (tree-set tree (list 0 5) 99)))))
|
||||
|
||||
(deftest "tree-set preserves siblings"
|
||||
(let ((tree (sx-parse "(div (span) (p) (em))")))
|
||||
(let ((result (tree-set tree (list 0 2) (first (sx-parse "(strong)")))))
|
||||
(assert-equal "span" (symbol-name (first (navigate result (list 0 1)))))
|
||||
(assert-equal "strong" (symbol-name (first (navigate result (list 0 2)))))
|
||||
(assert-equal "em" (symbol-name (first (navigate result (list 0 3))))))))
|
||||
|
||||
;; -- replace-node --
|
||||
|
||||
(deftest "replace-node replaces with parsed source"
|
||||
(let ((tree (sx-parse "(div (span \"old\") (p \"keep\"))")))
|
||||
(let ((result (replace-node tree (list 0 1) "(em \"new\")")))
|
||||
(assert (not (nil? (get result "ok"))))
|
||||
(let ((new-tree (get result "ok")))
|
||||
;; The span should be replaced with em
|
||||
(let ((replaced (navigate new-tree (list 0 1))))
|
||||
(assert (list? replaced))
|
||||
(assert-equal "em" (symbol-name (first replaced))))))))
|
||||
|
||||
(deftest "replace-node error on bad fragment"
|
||||
(let ((tree (sx-parse "(a b)")))
|
||||
(let ((result (replace-node tree (list 0 1) "")))
|
||||
(assert (not (nil? (get result "error")))))))
|
||||
|
||||
(deftest "replace-node error on bad path"
|
||||
(let ((tree (sx-parse "(a b)")))
|
||||
(let ((result (replace-node tree (list 5) "(c)")))
|
||||
(assert (not (nil? (get result "error"))))
|
||||
(assert (contains? (get result "error") "not found")))))
|
||||
|
||||
(deftest "replace-node preserves rest of tree"
|
||||
(let ((tree (sx-parse "(a 1 2 3)")))
|
||||
(let ((result (replace-node tree (list 0 2) "99")))
|
||||
(assert (not (nil? (get result "ok"))))
|
||||
(let ((new-tree (get result "ok")))
|
||||
(assert-equal 1 (navigate new-tree (list 0 1)))
|
||||
(assert-equal 99 (navigate new-tree (list 0 2)))
|
||||
(assert-equal 3 (navigate new-tree (list 0 3)))))))
|
||||
|
||||
(deftest "replace-node deep replacement"
|
||||
(let ((tree (sx-parse "(a (b (c old)))")))
|
||||
(let ((result (replace-node tree (list 0 1 1 1) "new-val")))
|
||||
(assert (not (nil? (get result "ok"))))
|
||||
(let ((new-tree (get result "ok")))
|
||||
(assert-equal "new-val" (symbol-name (navigate new-tree (list 0 1 1 1))))))))
|
||||
|
||||
;; -- insert-child --
|
||||
|
||||
(deftest "insert-child adds at start"
|
||||
(let ((tree (sx-parse "(div (p \"a\") (p \"b\"))")))
|
||||
(let ((result (insert-child tree (list 0) 1 "(h1 \"title\")")))
|
||||
(assert (not (nil? (get result "ok"))))
|
||||
(let ((new-tree (get result "ok")))
|
||||
(assert-equal "h1" (symbol-name (first (navigate new-tree (list 0 1)))))
|
||||
(assert-equal "p" (symbol-name (first (navigate new-tree (list 0 2)))))))))
|
||||
|
||||
(deftest "insert-child adds at end"
|
||||
(let ((tree (sx-parse "(div (p \"a\"))")))
|
||||
(let ((result (insert-child tree (list 0) 2 "(p \"b\")")))
|
||||
(assert (not (nil? (get result "ok"))))
|
||||
(let ((new-tree (get result "ok")))
|
||||
(assert-equal 3 (len (navigate new-tree (list 0))))))))
|
||||
|
||||
(deftest "insert-child error on non-list"
|
||||
(let ((tree (sx-parse "(a \"hello\")")))
|
||||
(let ((result (insert-child tree (list 0 1) 0 "(b)")))
|
||||
(assert (not (nil? (get result "error")))))))
|
||||
|
||||
(deftest "insert-child error on bad index"
|
||||
(let ((tree (sx-parse "(a b c)")))
|
||||
(let ((result (insert-child tree (list 0) 99 "(d)")))
|
||||
(assert (not (nil? (get result "error"))))
|
||||
(assert (contains? (get result "error") "out of range")))))
|
||||
|
||||
;; -- delete-node --
|
||||
|
||||
(deftest "delete-node removes child"
|
||||
(let ((tree (sx-parse "(div (span) (p) (em))")))
|
||||
(let ((result (delete-node tree (list 0 2))))
|
||||
(assert (not (nil? (get result "ok"))))
|
||||
(let ((new-tree (get result "ok")))
|
||||
(assert-equal 3 (len (navigate new-tree (list 0))))
|
||||
;; p is gone, em shifted to index 2
|
||||
(assert-equal "em" (symbol-name (first (navigate new-tree (list 0 2)))))))))
|
||||
|
||||
(deftest "delete-node removes first child"
|
||||
(let ((tree (sx-parse "(a b c d)")))
|
||||
(let ((result (delete-node tree (list 0 1))))
|
||||
(assert (not (nil? (get result "ok"))))
|
||||
(let ((new-tree (get result "ok")))
|
||||
(assert-equal "c" (symbol-name (navigate new-tree (list 0 1))))))))
|
||||
|
||||
(deftest "delete-node error on root"
|
||||
(let ((tree (sx-parse "(a b)")))
|
||||
(let ((result (delete-node tree (list))))
|
||||
(assert (not (nil? (get result "error")))))))
|
||||
|
||||
(deftest "delete-node error on bad index"
|
||||
(let ((tree (sx-parse "(a b)")))
|
||||
(let ((result (delete-node tree (list 0 5))))
|
||||
(assert (not (nil? (get result "error")))))))
|
||||
|
||||
;; -- wrap-node --
|
||||
|
||||
(deftest "wrap-node wraps in new form"
|
||||
(let ((tree (sx-parse "(div (p \"hello\"))")))
|
||||
(let ((result (wrap-node tree (list 0 1) "(when visible _)")))
|
||||
(assert (not (nil? (get result "ok"))))
|
||||
(let ((new-tree (get result "ok")))
|
||||
(let ((wrapped (navigate new-tree (list 0 1))))
|
||||
(assert-equal "when" (symbol-name (first wrapped)))
|
||||
;; The original (p "hello") should be the _ replacement
|
||||
(assert-equal "p" (symbol-name (first (nth wrapped 2)))))))))
|
||||
|
||||
(deftest "wrap-node error on missing placeholder"
|
||||
(let ((tree (sx-parse "(a b)")))
|
||||
(let ((result (wrap-node tree (list 0 1) "(when cond)")))
|
||||
(assert (not (nil? (get result "error"))))
|
||||
(assert (contains? (get result "error") "placeholder")))))
|
||||
|
||||
(deftest "wrap-node error on bad path"
|
||||
(let ((tree (sx-parse "(a b)")))
|
||||
(let ((result (wrap-node tree (list 5) "(when _)")))
|
||||
(assert (not (nil? (get result "error")))))))
|
||||
|
||||
(deftest "wrap-node preserves siblings"
|
||||
(let ((tree (sx-parse "(div (span) (p \"target\") (em))")))
|
||||
(let ((result (wrap-node tree (list 0 2) "(when show _)")))
|
||||
(assert (not (nil? (get result "ok"))))
|
||||
(let ((new-tree (get result "ok")))
|
||||
(assert-equal "span" (symbol-name (first (navigate new-tree (list 0 1)))))
|
||||
(assert-equal "when" (symbol-name (first (navigate new-tree (list 0 2)))))
|
||||
(assert-equal "em" (symbol-name (first (navigate new-tree (list 0 3)))))))))
|
||||
|
||||
;; -- replace-placeholder --
|
||||
|
||||
(deftest "replace-placeholder in flat list"
|
||||
(let ((tree (sx-parse "(when cond _)")))
|
||||
(let ((result (replace-placeholder (first tree) 42)))
|
||||
(assert-equal 42 (nth result 2)))))
|
||||
|
||||
(deftest "replace-placeholder nested"
|
||||
(let ((tree (sx-parse "(div (when cond _))")))
|
||||
(let ((result (replace-placeholder (first tree) 42)))
|
||||
(assert-equal 42 (nth (nth result 1) 2)))))
|
||||
|
||||
(deftest "replace-placeholder only first occurrence"
|
||||
(let ((tree (sx-parse "(a _ _)")))
|
||||
(let ((result (replace-placeholder (first tree) 99)))
|
||||
(assert-equal 99 (nth result 1))
|
||||
;; Second _ should remain
|
||||
(assert-equal "_" (symbol-name (nth result 2))))))
|
||||
|
||||
(deftest "replace-placeholder returns nil if no _"
|
||||
(let ((tree (sx-parse "(a b c)")))
|
||||
(assert (nil? (replace-placeholder (first tree) 42)))))
|
||||
|
||||
;; ========================================================================
|
||||
;; End-to-end edit workflows
|
||||
;; ========================================================================
|
||||
|
||||
(deftest "round-trip: replace then serialize"
|
||||
(let ((tree (sx-parse "(defcomp ~card () (div (h2 \"old\")))")))
|
||||
(let ((result (replace-node tree (list 0 3 1) "(h2 \"new\")")))
|
||||
(assert (not (nil? (get result "ok"))))
|
||||
(let ((serialized (sx-serialize (first (get result "ok")))))
|
||||
(assert (contains? serialized "new"))
|
||||
(assert (not (contains? serialized "old")))))))
|
||||
|
||||
(deftest "delete then validate"
|
||||
(let ((tree (sx-parse "(letrec ((a (fn () 1)) (b (fn () 2))) (a))")))
|
||||
;; Delete second binding
|
||||
(let ((result (delete-node tree (list 0 1 1))))
|
||||
(assert (not (nil? (get result "ok"))))
|
||||
(assert-equal "OK" (validate (get result "ok"))))))
|
||||
|
||||
(deftest "insert then find"
|
||||
(let ((tree (sx-parse "(div (p \"first\"))")))
|
||||
(let ((result (insert-child tree (list 0) 2 "(p \"second\")")))
|
||||
(assert (not (nil? (get result "ok"))))
|
||||
(let ((found (find-all (get result "ok") "second")))
|
||||
(assert (>= (len found) 1))))))
|
||||
)
|
||||
501
lib/tree-tools.sx
Normal file
501
lib/tree-tools.sx
Normal file
@@ -0,0 +1,501 @@
|
||||
;; ==========================================================================
|
||||
;; tree-tools.sx — Structural comprehension tools for s-expression files
|
||||
;; ==========================================================================
|
||||
;;
|
||||
;; Pure functions for navigating, annotating, and understanding parsed
|
||||
;; s-expression trees. Operates on the output of sx-parse (native SX
|
||||
;; values: lists, symbols, strings, numbers, keywords, dicts).
|
||||
;;
|
||||
;; Phase 1: Read-only comprehension tools.
|
||||
;; Phase 2 will add structural edit operations.
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Path utilities
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Format a path list as a display string: (0 2 1) → "[0,2,1]"
|
||||
(define path-str :effects []
|
||||
(fn ((path :as list))
|
||||
(str "[" (join "," (map str path)) "]")))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; annotate-tree — the primary comprehension tool
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Takes a parsed s-expression (or list of top-level expressions) and
|
||||
;; returns a string with every node labeled by its path. This makes tree
|
||||
;; structure explicit — no bracket counting needed.
|
||||
;;
|
||||
;; Example output:
|
||||
;; [0] (defcomp ~card
|
||||
;; [0,0] defcomp
|
||||
;; [0,1] ~card
|
||||
;; [0,2] (&key title)
|
||||
;; [0,3] (div :class "card"
|
||||
;; [0,3,0] div
|
||||
;; [0,3,1] :class
|
||||
;; [0,3,2] "card"
|
||||
;; [0,3,3] (h2 title)))
|
||||
|
||||
(define annotate-tree :effects []
|
||||
(fn (exprs)
|
||||
;; Accept a single expression or a list of top-level expressions
|
||||
(let ((nodes (if (list? exprs) exprs (list exprs))))
|
||||
(let ((result (list)))
|
||||
(for-each (fn (i)
|
||||
(annotate-node (nth nodes i) (list i) 0 result))
|
||||
(range 0 (len nodes)))
|
||||
(join "\n" result)))))
|
||||
|
||||
(define annotate-node :effects []
|
||||
(fn (node path depth result)
|
||||
(let ((indent (join "" (map (fn (_) " ") (range 0 depth))))
|
||||
(label (path-str path)))
|
||||
(if (list? node)
|
||||
;; List node — show opening with path, then recurse into children
|
||||
(if (empty? node)
|
||||
(append! result (str indent label " ()"))
|
||||
(let ((head (first node))
|
||||
(head-str (node-display head)))
|
||||
;; Compact form for short, simple lists (no nested lists)
|
||||
(if (and (<= (len node) 4)
|
||||
(not (some (fn (c) (list? c)) (rest node))))
|
||||
;; Single-line: [path] (head args...)
|
||||
(append! result
|
||||
(str indent label " ("
|
||||
(join " " (map node-display node)) ")"))
|
||||
;; Multi-line: show head on first line, children indented
|
||||
(do
|
||||
(append! result (str indent label " (" head-str))
|
||||
(for-each (fn (i)
|
||||
(annotate-node (nth node i) (concat path (list i))
|
||||
(+ depth 1) result))
|
||||
(range 1 (len node)))
|
||||
(append! result (str indent " )"))))))
|
||||
;; Atom node — display inline
|
||||
(append! result (str indent label " " (node-display node)))))))
|
||||
|
||||
;; Display a single node value as a short string
|
||||
(define node-display :effects []
|
||||
(fn (node)
|
||||
(cond
|
||||
(nil? node) "nil"
|
||||
(= (type-of node) "symbol") (symbol-name node)
|
||||
(= (type-of node) "keyword") (str ":" (keyword-name node))
|
||||
(= (type-of node) "string")
|
||||
(let ((s (if (> (len node) 40) (str (slice node 0 37) "...") node)))
|
||||
(str "\"" s "\""))
|
||||
(= (type-of node) "number") (str node)
|
||||
(= (type-of node) "boolean") (if node "true" "false")
|
||||
(list? node)
|
||||
(if (empty? node) "()"
|
||||
(str "(" (node-display (first node))
|
||||
(if (> (len node) 1) " ..." "")
|
||||
")"))
|
||||
(= (type-of node) "dict") "{...}"
|
||||
:else (str node))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; summarise — folded structural overview
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Shows the shape of a file without full detail. Each top-level form
|
||||
;; is shown with its head and path. Nested forms are folded to a
|
||||
;; configurable depth.
|
||||
|
||||
(define summarise :effects []
|
||||
(fn (exprs max-depth)
|
||||
(let ((nodes (if (list? exprs) exprs (list exprs)))
|
||||
(result (list)))
|
||||
(for-each (fn (i)
|
||||
(summarise-node (nth nodes i) (list i) 0 max-depth result))
|
||||
(range 0 (len nodes)))
|
||||
(join "\n" result))))
|
||||
|
||||
(define summarise-node :effects []
|
||||
(fn (node path depth max-depth result)
|
||||
(let ((indent (join "" (map (fn (_) " ") (range 0 depth))))
|
||||
(label (path-str path)))
|
||||
(if (list? node)
|
||||
(if (empty? node)
|
||||
(append! result (str indent label " ()"))
|
||||
(let ((head (first node))
|
||||
(head-str (node-display head)))
|
||||
(if (>= depth max-depth)
|
||||
;; At max depth — show head + child count
|
||||
(append! result
|
||||
(str indent label " (" head-str
|
||||
(if (> (len node) 1)
|
||||
(str " ... " (- (len node) 1) " children")
|
||||
"")
|
||||
")"))
|
||||
;; Below max depth — recurse
|
||||
(do
|
||||
(append! result (str indent label " (" head-str))
|
||||
(for-each (fn (i)
|
||||
(summarise-node (nth node i) (concat path (list i))
|
||||
(+ depth 1) max-depth result))
|
||||
(range 1 (len node)))
|
||||
(append! result (str indent " )"))))))
|
||||
;; Atom — show inline
|
||||
(append! result (str indent label " " (node-display node)))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; read-subtree — expand a specific subtree
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define read-subtree :effects []
|
||||
(fn (exprs path)
|
||||
(let ((node (navigate exprs path)))
|
||||
(if (nil? node)
|
||||
(str "Error: path " (path-str path) " not found")
|
||||
(annotate-tree (list node))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; get-context — show enclosing chain from root to target
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define get-context :effects []
|
||||
(fn (exprs path)
|
||||
(let ((result (list))
|
||||
(nodes (if (list? exprs) exprs (list exprs))))
|
||||
;; Walk each prefix of the path
|
||||
(for-each (fn (depth)
|
||||
(let ((prefix (slice path 0 (+ depth 1)))
|
||||
(node (navigate nodes prefix)))
|
||||
(when (not (nil? node))
|
||||
(let ((label (path-str prefix))
|
||||
(indent (join "" (map (fn (_) " ") (range 0 depth))))
|
||||
(marker (if (= (+ depth 1) (len path)) "→ " " ")))
|
||||
(if (list? node)
|
||||
(append! result
|
||||
(str indent marker label " " (node-summary node)))
|
||||
(append! result
|
||||
(str indent marker label " " (node-display node))))))))
|
||||
(range 0 (len path)))
|
||||
(join "\n" result))))
|
||||
|
||||
;; One-line summary of a list node (head + key info)
|
||||
(define node-summary :effects []
|
||||
(fn (node)
|
||||
(if (or (not (list? node)) (empty? node))
|
||||
(node-display node)
|
||||
(let ((head (node-display (first node)))
|
||||
(child-count (- (len node) 1)))
|
||||
(if (<= child-count 3)
|
||||
(str "(" (join " " (map node-display node)) ")")
|
||||
(str "(" head " " (node-display (nth node 1))
|
||||
(when (> child-count 1)
|
||||
(str " ... +" (- child-count 1)))
|
||||
")"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; find-all — search for nodes matching a pattern
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define find-all :effects []
|
||||
(fn (exprs pattern)
|
||||
(let ((results (list))
|
||||
(nodes (if (list? exprs) exprs (list exprs))))
|
||||
(for-each (fn (i)
|
||||
(find-in-node (nth nodes i) (list i) pattern results))
|
||||
(range 0 (len nodes)))
|
||||
results)))
|
||||
|
||||
(define find-in-node :effects []
|
||||
(fn (node path pattern results)
|
||||
;; Check if this node matches
|
||||
(when (node-matches? node pattern)
|
||||
(append! results (list path (node-summary-short node))))
|
||||
;; Recurse into list children
|
||||
(when (list? node)
|
||||
(for-each (fn (i)
|
||||
(find-in-node (nth node i) (concat path (list i)) pattern results))
|
||||
(range 0 (len node))))))
|
||||
|
||||
;; Match: string pattern matches symbol names, string content
|
||||
(define node-matches? :effects []
|
||||
(fn (node pattern)
|
||||
(cond
|
||||
;; Symbol matches if name contains pattern
|
||||
(= (type-of node) "symbol")
|
||||
(contains? (symbol-name node) pattern)
|
||||
;; String matches if value contains pattern
|
||||
(string? node)
|
||||
(contains? node pattern)
|
||||
;; List matches if head is a symbol matching pattern
|
||||
(and (list? node) (not (empty? node))
|
||||
(= (type-of (first node)) "symbol"))
|
||||
(contains? (symbol-name (first node)) pattern)
|
||||
:else false)))
|
||||
|
||||
;; Short summary for search results
|
||||
(define node-summary-short :effects []
|
||||
(fn (node)
|
||||
(if (list? node)
|
||||
(if (empty? node) "()"
|
||||
(let ((head (node-display (first node))))
|
||||
(if (> (len node) 3)
|
||||
(str "(" head " " (node-display (nth node 1)) " ...)")
|
||||
(str "(" (join " " (map node-display node)) ")"))))
|
||||
(node-display node))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; get-siblings — show siblings of a node
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define get-siblings :effects []
|
||||
(fn (exprs path)
|
||||
(if (empty? path)
|
||||
"Error: root has no siblings"
|
||||
(let ((parent-path (slice path 0 (- (len path) 1)))
|
||||
(target-idx (last path))
|
||||
(parent (navigate exprs parent-path)))
|
||||
(if (or (nil? parent) (not (list? parent)))
|
||||
(str "Error: parent at " (path-str parent-path) " not found or not a list")
|
||||
(let ((result (list)))
|
||||
(for-each (fn (i)
|
||||
(let ((child (nth parent i))
|
||||
(child-path (concat parent-path (list i)))
|
||||
(marker (if (= i target-idx) "→ " " ")))
|
||||
(append! result
|
||||
(str marker (path-str child-path) " "
|
||||
(if (list? child)
|
||||
(node-summary child)
|
||||
(node-display child))))))
|
||||
(range 0 (len parent)))
|
||||
(join "\n" result)))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; validate — structural integrity checks
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define validate :effects []
|
||||
(fn (exprs)
|
||||
(let ((errors (list))
|
||||
(nodes (if (list? exprs) exprs (list exprs))))
|
||||
(for-each (fn (i)
|
||||
(validate-node (nth nodes i) (list i) errors))
|
||||
(range 0 (len nodes)))
|
||||
(if (empty? errors)
|
||||
"OK"
|
||||
(join "\n" errors)))))
|
||||
|
||||
(define validate-node :effects []
|
||||
(fn (node path errors)
|
||||
(when (list? node)
|
||||
(when (not (empty? node))
|
||||
(let ((head (first node)))
|
||||
;; Check: letrec bindings should all be pairs
|
||||
(when (and (= (type-of head) "symbol")
|
||||
(= (symbol-name head) "letrec")
|
||||
(>= (len node) 2))
|
||||
(let ((bindings (nth node 1)))
|
||||
(when (list? bindings)
|
||||
(for-each (fn (i)
|
||||
(let ((pair (nth bindings i)))
|
||||
(when (not (and (list? pair) (>= (len pair) 2)
|
||||
(= (type-of (first pair)) "symbol")))
|
||||
(append! errors
|
||||
(str "WARNING " (path-str (concat path (list 1 i)))
|
||||
": letrec binding " i " is not a (name value) pair: "
|
||||
(node-display pair))))))
|
||||
(range 0 (len bindings))))))
|
||||
;; Check: defisland/defcomp body should exist
|
||||
(when (and (= (type-of head) "symbol")
|
||||
(or (= (symbol-name head) "defisland")
|
||||
(= (symbol-name head) "defcomp")))
|
||||
(when (< (len node) 4)
|
||||
(append! errors
|
||||
(str "ERROR " (path-str path)
|
||||
": " (symbol-name head) " has fewer than 3 args (name params body)"))))))
|
||||
;; Recurse
|
||||
(for-each (fn (i)
|
||||
(validate-node (nth node i) (concat path (list i)) errors))
|
||||
(range 0 (len node))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; navigate — resolve a path to a node
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define navigate :effects []
|
||||
(fn (exprs path)
|
||||
(let ((nodes (if (list? exprs) exprs (list exprs))))
|
||||
(reduce
|
||||
(fn (current idx)
|
||||
(if (or (nil? current) (not (list? current))
|
||||
(>= idx (len current)))
|
||||
nil
|
||||
(nth current idx)))
|
||||
nodes
|
||||
path))))
|
||||
|
||||
|
||||
;; ==========================================================================
|
||||
;; Phase 2: Structural edit operations
|
||||
;; ==========================================================================
|
||||
;;
|
||||
;; All operations take a tree (list of top-level expressions), perform the
|
||||
;; edit, and return {"ok" new-tree} or {"error" message}. Nothing is mutated
|
||||
;; in place. File writing is a separate concern.
|
||||
;;
|
||||
;; Key invariant: fragments are parsed BEFORE the tree is modified. If the
|
||||
;; fragment is malformed, the operation returns an error immediately.
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; replace-node — replace the node at a path with new parsed source
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define replace-node :effects []
|
||||
(fn (exprs path new-source)
|
||||
(let ((fragment (sx-parse new-source)))
|
||||
(if (empty? fragment)
|
||||
{"error" (str "Fragment parse error: empty result from: " new-source)}
|
||||
(let ((new-node (if (= (len fragment) 1) (first fragment)
|
||||
(cons (make-symbol "begin") fragment)))
|
||||
(result (tree-set exprs path new-node)))
|
||||
(if (nil? result)
|
||||
{"error" (str "Path not found: " (path-str path))}
|
||||
{"ok" result}))))))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; insert-child — insert a new child at a specific index within a list
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define insert-child :effects []
|
||||
(fn (exprs path index new-source)
|
||||
(let ((fragment (sx-parse new-source)))
|
||||
(if (empty? fragment)
|
||||
{"error" (str "Fragment parse error: empty result from: " new-source)}
|
||||
(let ((new-node (if (= (len fragment) 1) (first fragment)
|
||||
(cons (make-symbol "begin") fragment)))
|
||||
(parent (navigate exprs path)))
|
||||
(if (or (nil? parent) (not (list? parent)))
|
||||
{"error" (str "Path not found or not a list: " (path-str path))}
|
||||
(if (or (< index 0) (> index (len parent)))
|
||||
{"error" (str "Index " index " out of range for list with " (len parent) " children")}
|
||||
(let ((new-parent (list-insert parent index new-node))
|
||||
(result (tree-set exprs path new-parent)))
|
||||
(if (nil? result)
|
||||
{"error" (str "Failed to update tree at: " (path-str path))}
|
||||
{"ok" result})))))))))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; delete-node — remove a node at a path
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define delete-node :effects []
|
||||
(fn (exprs path)
|
||||
(if (empty? path)
|
||||
{"error" "Cannot delete root"}
|
||||
(let ((parent-path (slice path 0 (- (len path) 1)))
|
||||
(child-idx (last path))
|
||||
(parent (navigate exprs parent-path)))
|
||||
(if (or (nil? parent) (not (list? parent)))
|
||||
{"error" (str "Parent not found or not a list: " (path-str parent-path))}
|
||||
(if (or (< child-idx 0) (>= child-idx (len parent)))
|
||||
{"error" (str "Index " child-idx " out of range")}
|
||||
(let ((new-parent (list-remove parent child-idx))
|
||||
(result (tree-set exprs parent-path new-parent)))
|
||||
(if (nil? result)
|
||||
{"error" "Failed to update tree"}
|
||||
{"ok" result}))))))))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; wrap-node — wrap a node in a new list form
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; (wrap-node tree [0,2] "(when condition _)")
|
||||
;; Parses the wrapper, finds the placeholder _, replaces it with the
|
||||
;; existing node at the path, then replaces the path with the result.
|
||||
|
||||
(define wrap-node :effects []
|
||||
(fn (exprs path wrapper-source)
|
||||
(let ((fragment (sx-parse wrapper-source)))
|
||||
(if (empty? fragment)
|
||||
{"error" (str "Wrapper parse error: empty result from: " wrapper-source)}
|
||||
(let ((wrapper (first fragment))
|
||||
(target (navigate exprs path)))
|
||||
(if (nil? target)
|
||||
{"error" (str "Path not found: " (path-str path))}
|
||||
(let ((filled (replace-placeholder wrapper target)))
|
||||
(if (nil? filled)
|
||||
{"error" "Wrapper must contain _ as placeholder for the wrapped node"}
|
||||
(let ((result (tree-set exprs path filled)))
|
||||
(if (nil? result)
|
||||
{"error" "Failed to update tree"}
|
||||
{"ok" result}))))))))))
|
||||
|
||||
;; Replace the symbol _ in a tree with a replacement value (first occurrence)
|
||||
(define replace-placeholder :effects []
|
||||
(fn (node replacement)
|
||||
(cond
|
||||
(and (= (type-of node) "symbol") (= (symbol-name node) "_"))
|
||||
replacement
|
||||
(list? node)
|
||||
(let ((found false)
|
||||
(result (map (fn (child)
|
||||
(if found
|
||||
child
|
||||
(if (and (= (type-of child) "symbol") (= (symbol-name child) "_"))
|
||||
(do (set! found true) replacement)
|
||||
(if (list? child)
|
||||
(let ((sub (replace-placeholder child replacement)))
|
||||
(if (nil? sub) child (do (set! found true) sub)))
|
||||
child))))
|
||||
node)))
|
||||
(if found result nil))
|
||||
:else nil)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Tree manipulation helpers
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Set a node at a path in the tree, returning a new tree.
|
||||
;; Immutable — builds new lists along the path.
|
||||
(define tree-set :effects []
|
||||
(fn (exprs path new-node)
|
||||
(let ((nodes (if (list? exprs) exprs (list exprs))))
|
||||
(if (empty? path)
|
||||
(if (list? new-node) new-node (list new-node))
|
||||
(tree-set-inner nodes path 0 new-node)))))
|
||||
|
||||
(define tree-set-inner :effects []
|
||||
(fn (node path depth new-node)
|
||||
(if (not (list? node))
|
||||
nil
|
||||
(let ((idx (nth path depth)))
|
||||
(if (or (< idx 0) (>= idx (len node)))
|
||||
nil
|
||||
(if (= depth (- (len path) 1))
|
||||
;; At target depth — replace the child
|
||||
(list-replace node idx new-node)
|
||||
;; Not at target — recurse into child
|
||||
(let ((child (nth node idx))
|
||||
(new-child (tree-set-inner child path (+ depth 1) new-node)))
|
||||
(if (nil? new-child)
|
||||
nil
|
||||
(list-replace node idx new-child)))))))))
|
||||
|
||||
;; Replace element at index in a list (immutable — returns new list)
|
||||
(define list-replace :effects []
|
||||
(fn (lst idx val)
|
||||
(map-indexed (fn (i item) (if (= i idx) val item)) lst)))
|
||||
|
||||
;; Insert element at index in a list (immutable — returns new list)
|
||||
(define list-insert :effects []
|
||||
(fn (lst idx val)
|
||||
(concat (slice lst 0 idx) (list val) (slice lst idx))))
|
||||
|
||||
;; Remove element at index from a list (immutable — returns new list)
|
||||
(define list-remove :effects []
|
||||
(fn (lst idx)
|
||||
(concat (slice lst 0 idx) (slice lst (+ idx 1)))))
|
||||
Reference in New Issue
Block a user