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:
@@ -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 -> ()
|
||||
Reference in New Issue
Block a user