From 934604c2bd1a2ee5ad636043f3e7f5fb0bfa99e0 Mon Sep 17 00:00:00 2001 From: giles Date: Wed, 25 Mar 2026 19:16:41 +0000 Subject: [PATCH] Add SX tree tools: comprehension, editing, and MCP server MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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) --- hosts/javascript/run_tests.js | 2 +- hosts/ocaml/bin/dune | 4 + hosts/ocaml/bin/mcp_tree.ml | 353 ++++++++++++++++++ lib/tests/test-tree-tools.sx | 675 ++++++++++++++++++++++++++++++++++ lib/tree-tools.sx | 501 +++++++++++++++++++++++++ 5 files changed, 1534 insertions(+), 1 deletion(-) create mode 100644 hosts/ocaml/bin/mcp_tree.ml create mode 100644 lib/tests/test-tree-tools.sx create mode 100644 lib/tree-tools.sx diff --git a/hosts/javascript/run_tests.js b/hosts/javascript/run_tests.js index 0a56705f..6fb86d49 100644 --- a/hosts/javascript/run_tests.js +++ b/hosts/javascript/run_tests.js @@ -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"); diff --git a/hosts/ocaml/bin/dune b/hosts/ocaml/bin/dune index 42bf9df8..b3057669 100644 --- a/hosts/ocaml/bin/dune +++ b/hosts/ocaml/bin/dune @@ -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)) diff --git a/hosts/ocaml/bin/mcp_tree.ml b/hosts/ocaml/bin/mcp_tree.ml new file mode 100644 index 00000000..536ad7e2 --- /dev/null +++ b/hosts/ocaml/bin/mcp_tree.ml @@ -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 -> () diff --git a/lib/tests/test-tree-tools.sx b/lib/tests/test-tree-tools.sx new file mode 100644 index 00000000..abaa3596 --- /dev/null +++ b/lib/tests/test-tree-tools.sx @@ -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)))))) +) diff --git a/lib/tree-tools.sx b/lib/tree-tools.sx new file mode 100644 index 00000000..a3c970a5 --- /dev/null +++ b/lib/tree-tools.sx @@ -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)))))