giles
934604c2bd
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>
354 lines
15 KiB
OCaml
354 lines
15 KiB
OCaml
(** 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 -> ()
|