coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
033b2cb304e9552d1ef116d0a2fc95ae92e088d4
rose-ash/hosts/ocaml/bin/mcp_tree.ml
giles 033b2cb304 Add section comments to evaluator.sx, show comments in sx_summarise 
evaluator.sx: 11 section headers + 27 subgroup/function comments
documenting the CEK machine structure (state, frames, kont ops,
extension points, eval utilities, machine core, special forms,
call dispatch, HO forms, continue phase, entry points).

mcp_tree.ml: sx_summarise and sx_read_tree now inject file comments
into their output — comments appear as un-numbered annotation lines
between indexed entries, so indices stay correct for editing.

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
2026-04-03 16:45:39 +00:00

2438 lines
121 KiB
OCaml
Raw Blame History

This file contains ambiguous Unicode characters
This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
(** 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);
(* Character classification for SX parser.sx *)
bind "ident-start?" (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') ||
c = '_' || c = '~' || c = '*' || c = '+' || c = '-' ||
c = '>' || c = '<' || c = '=' || c = '/' || c = '!' ||
c = '?' || c = '&' || c = '@' || c = '^' || c = '%' ||
Char.code c > 127)
| _ -> Bool false);
bind "ident-char?" (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') ||
(c >= '0' && c <= '9') ||
c = '_' || c = '~' || c = '*' || c = '+' || c = '-' ||
c = '>' || c = '<' || c = '=' || c = '/' || c = '!' ||
c = '?' || c = '&' || c = '.' || c = ':' || c = '#' ||
c = ',' || c = '@' || c = '^' || c = '%' ||
Char.code c > 127)
| _ -> Bool false);
bind "make-keyword" (fun args -> match args with
| [String s] -> Keyword s | _ -> Nil);
bind "escape-string" (fun args -> match args with
| [String s] ->
let buf = Buffer.create (String.length s) in
String.iter (fun c -> match c with
| '"' -> Buffer.add_string buf "\\\""
| '\\' -> Buffer.add_string buf "\\\\"
| '\n' -> Buffer.add_string buf "\\n"
| '\t' -> Buffer.add_string buf "\\t"
| '\r' -> Buffer.add_string buf "\\r"
| c -> Buffer.add_char buf c) s;
String (Buffer.contents buf)
| _ -> String "");
bind "sx-expr-source" (fun args -> match args with
| [SxExpr s] -> String s | _ -> String "");
(* 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);
(* Environment operations needed by harness *)
bind "env-bind!" (fun args -> match args with
| [Env env_val; String name; v] -> ignore (env_bind env_val name v); v
| _ -> Nil);
bind "env-get" (fun args -> match args with
| [Env env_val; String name] -> env_get env_val name
| _ -> Nil);
bind "env-has?" (fun args -> match args with
| [Env env_val; String name] -> Bool (env_has env_val name)
| _ -> Bool false);
bind "make-env" (fun _args -> Env (make_env ()));
bind "keys" (fun args -> match args with
| [Dict d] -> List (Hashtbl.fold (fun k _ acc -> String k :: acc) d [])
| _ -> List []);
bind "get" (fun args -> match args with
| [Dict d; String k] -> (match Hashtbl.find_opt d k with Some v -> v | None -> Nil)
| [Dict d; Keyword k] -> (match Hashtbl.find_opt d k with Some v -> v | None -> Nil)
| [List items; Number n] -> (let i = int_of_float n in if i >= 0 && i < List.length items then List.nth items i else Nil)
| _ -> Nil);
bind "dict-set!" (fun args -> match args with
| [Dict d; String k; v] -> Hashtbl.replace d k v; v
| [Dict d; Keyword k; v] -> Hashtbl.replace d k v; v
| _ -> Nil);
bind "merge" (fun args -> match args with
| [Dict a; Dict b] ->
let d = Hashtbl.create (Hashtbl.length a + Hashtbl.length b) in
Hashtbl.iter (fun k v -> Hashtbl.replace d k v) a;
Hashtbl.iter (fun k v -> Hashtbl.replace d k v) b;
Dict d
| _ -> Nil);
bind "apply" (fun args -> match args with
| [f; List items] | [f; ListRef { contents = items }] ->
Sx_ref.cek_call f (List items)
| _ -> Nil);
bind "current-env" (fun _args -> Env e);
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 []);
(* Native list-replace — bypasses CEK map-indexed callback chain for deep tree edits *)
bind "list-replace" (fun args -> match args with
| [List l; Number idx; v] ->
let i = int_of_float idx in
List (List.mapi (fun j x -> if j = i then v else x) l)
| [ListRef { contents = l }; Number idx; v] ->
let i = int_of_float idx in
List (List.mapi (fun j x -> if j = i then v else x) l)
| _ -> Nil);
(* Native navigate — bypasses CEK reduce callback chain for deep path reads *)
bind "navigate" (fun args -> match args with
| [tree; List path] | [tree; ListRef { contents = path }] ->
let nodes = match tree with List _ | ListRef _ -> tree | _ -> List [tree] in
List.fold_left (fun current idx ->
match current, idx with
| (List l | ListRef { contents = l }), Number n ->
let i = int_of_float n in
if i >= 0 && i < List.length l then List.nth l i else Nil
| _ -> Nil
) nodes path
| _ -> Nil);
(* use — module declaration, no-op at eval time, metadata for static analysis *)
bind "use" (fun _args -> Nil);
(* Capability-based evaluation contexts *)
let cap_stack : string list ref = ref [] in
bind "with-capabilities" (fun args -> match args with
| [List caps; body] ->
let cap_set = List.filter_map (fun v -> match v with
| Symbol s | String s -> Some s | _ -> None) caps in
let prev = !cap_stack in
cap_stack := cap_set;
(* body can be a lambda (call it) or an expression (eval it) *)
let result = try
match body with
| Lambda _ -> Sx_ref.cek_call body Nil
| _ -> body
with exn -> cap_stack := prev; raise exn in
cap_stack := prev;
result
| _ -> Nil);
bind "current-capabilities" (fun _args ->
if !cap_stack = [] then Nil
else List (List.map (fun s -> String s) !cap_stack));
bind "has-capability?" (fun args -> match args with
| [String cap] ->
if !cap_stack = [] then Bool true (* no restriction *)
else Bool (List.mem cap !cap_stack)
| _ -> Bool true);
bind "require-capability!" (fun args -> match args with
| [String cap] ->
if !cap_stack = [] then Nil (* no restriction *)
else if List.mem cap !cap_stack then Nil
else raise (Eval_error (Printf.sprintf
"Capability '%s' not available. Current: %s" cap (String.concat ", " !cap_stack)))
| _ -> Nil);
bind "trim" (fun args -> match args with
| [String s] -> String (String.trim s) | _ -> String "");
bind "split" (fun args -> match args with
| [String s; String d] ->
List (List.map (fun p -> String p) (String.split_on_char d.[0] s))
| _ -> 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 "");
(* Stubs needed by signals.sx + adapter-html.sx *)
bind "set-render-active!" (fun _args -> Nil);
bind "render-active?" (fun _args -> Bool true);
bind "trampoline" (fun args -> match args with
| [Thunk (expr, e)] -> Sx_ref.eval_expr expr (Env e)
| [v] -> v | _ -> Nil);
bind "eval-expr" (fun args -> match args with
| [expr; Env ue] -> Sx_ref.eval_expr expr (Env ue)
| [expr] -> Sx_ref.eval_expr expr (Env e)
| _ -> Nil);
bind "deftype" (fun _args -> Nil);
bind "defeffect" (fun _args -> Nil);
(* 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);
(* Load signals — reactive signal primitives *)
(try load_sx_file e (Filename.concat spec_dir "signals.sx")
with exn -> Printf.eprintf "[mcp] Warning: signals.sx load failed: %s\n%!" (Printexc.to_string exn));
(* Load render + adapter-html for render-to-html *)
let web_dir = try Sys.getenv "SX_WEB_DIR" with Not_found -> "web" in
(try load_sx_file e (Filename.concat spec_dir "render.sx")
with exn -> Printf.eprintf "[mcp] Warning: render.sx load failed: %s\n%!" (Printexc.to_string exn));
(try load_sx_file e (Filename.concat web_dir "adapter-html.sx")
with exn -> Printf.eprintf "[mcp] Warning: adapter-html.sx load failed: %s\n%!" (Printexc.to_string exn));
(* Load harness *)
(try load_sx_file e (Filename.concat spec_dir "harness.sx")
with exn -> Printf.eprintf "[mcp] Warning: harness.sx load failed: %s\n%!" (Printexc.to_string exn));
(* Load eval-rules *)
(try load_sx_file e (Filename.concat spec_dir "eval-rules.sx")
with exn -> Printf.eprintf "[mcp] Warning: eval-rules.sx load failed: %s\n%!" (Printexc.to_string exn));
(* Load signals — reactive signal primitives *)
(try load_sx_file e (Filename.concat spec_dir "signals.sx")
with exn -> Printf.eprintf "[mcp] Warning: signals.sx load failed: %s\n%!" (Printexc.to_string exn));
(* Load render + adapter-html for render-to-html *)
let web_dir = try Sys.getenv "SX_WEB_DIR" with Not_found -> "web" in
(try load_sx_file e (Filename.concat spec_dir "render.sx")
with exn -> Printf.eprintf "[mcp] Warning: render.sx load failed: %s\n%!" (Printexc.to_string exn));
(try load_sx_file e (Filename.concat web_dir "adapter-html.sx")
with exn -> Printf.eprintf "[mcp] Warning: adapter-html.sx load failed: %s\n%!" (Printexc.to_string exn));
(* Load render pipeline — native OCaml renderer + HTML tag bindings *)
Sx_render.setup_render_env e;
List.iter (fun tag ->
ignore (Sx_types.env_bind e tag
(NativeFn ("html:" ^ tag, fun args -> List (Symbol tag :: args))))
) Sx_render.html_tags;
ignore (Sx_types.env_bind e "island?" (NativeFn ("island?", fun args -> match args with [Island _] -> Bool true | _ -> Bool false)));
Printf.eprintf "[mcp] SX tree-tools + harness + eval-rules + render 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 ?(comments=false) path =
let src = In_channel.with_open_text path In_channel.input_all in
let exprs = Sx_parser.parse_all ~comments src in
List exprs
(* Comment preservation for edit round-trips.
Comments are separated before tree-tools operate (so paths stay correct),
then re-interleaved before writing. *)
type comment_map = {
before : (int, value list) Hashtbl.t; (* expr_index → comments before it *)
trailing : value list; (* comments after last expression *)
}
let separate_comments items =
let before = Hashtbl.create 16 in
let exprs = ref [] in
let pending = ref [] in
let idx = ref 0 in
List.iter (fun item ->
match item with
| Comment _ -> pending := item :: !pending
| _ ->
if !pending <> [] then
Hashtbl.replace before !idx (List.rev !pending);
pending := [];
exprs := item :: !exprs;
incr idx
) items;
let trailing = List.rev !pending in
(List.rev !exprs, { before; trailing })
let reinterleave exprs cmap =
let result = ref [] in
List.iteri (fun i expr ->
(match Hashtbl.find_opt cmap.before i with
| Some cs -> List.iter (fun c -> result := c :: !result) cs
| None -> ());
result := expr :: !result
) exprs;
List.iter (fun c -> result := c :: !result) cmap.trailing;
List.rev !result
let parse_path_str s =
(* Parse SX path string: "(0 3 2)" or "(0,3,2)" or "0 3 2" → SX list of numbers.
Commas are unquote in SX, so strip them before parsing. *)
let s = String.map (fun c -> if c = ',' then ' ' else c) s in
let exprs = Sx_parser.parse_all s in
match exprs with
| [List items] ->
(* (0 3 2) → list of numbers *)
List (List.map (fun x -> match x with Number _ -> x | _ -> Number 0.0) items)
| _ ->
(* Bare numbers: "0 3 2" → parsed as separate exprs *)
List (List.map (fun x -> match x with Number _ -> x | _ -> Number 0.0) exprs)
let _json_to_path j =
let open Yojson.Safe.Util in
parse_path_str (to_string j)
(* Resolve path: if it contains ">", use resolve-named-path; else parse as index path *)
let resolve_path tree path_str =
if String.contains path_str '>' then
call_sx "resolve-named-path" [tree; String path_str]
else
parse_path_str path_str
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)]
(* ------------------------------------------------------------------ *)
(* Recursive .sx file discovery *)
(* ------------------------------------------------------------------ *)
let glob_sx_files dir =
let results = ref [] in
let rec walk path =
if Sys.is_directory path then
let entries = Sys.readdir path in
Array.iter (fun e -> walk (Filename.concat path e)) entries
else if Filename.check_suffix path ".sx" then
results := path :: !results
in
(try walk dir with Sys_error _ -> ());
List.sort String.compare !results
let relative_path ~base path =
let blen = String.length base in
if String.length path > blen && String.sub path 0 blen = base then
let rest = String.sub path (blen + 1) (String.length path - blen - 1) in
rest
else path
(* ------------------------------------------------------------------ *)
(* Pretty printer *)
(* ------------------------------------------------------------------ *)
let pp_atom = Sx_types.inspect
(* Estimate single-line width of a value *)
let rec est_width = function
| Nil -> 3 | Bool true -> 4 | Bool false -> 5
| Number n -> String.length (if Float.is_integer n then string_of_int (int_of_float n) else Printf.sprintf "%g" n)
| String s -> String.length s + 2
| Symbol s -> String.length s
| Keyword k -> String.length k + 1
| SxExpr s -> String.length s + 2
| List items | ListRef { contents = items } ->
2 + List.fold_left (fun acc x -> acc + est_width x + 1) 0 items
| _ -> 10
let pretty_print_value ?(max_width=80) v =
let buf = Buffer.create 4096 in
let rec pp indent v =
match v with
| List items | ListRef { contents = items } when items <> [] ->
if est_width v <= max_width - indent then
(* Fits on one line *)
Buffer.add_string buf (pp_atom v)
else begin
(* Multi-line *)
Buffer.add_char buf '(';
let head = List.hd items in
Buffer.add_string buf (pp_atom head);
let child_indent = indent + 2 in
let rest = List.tl items in
(* Special case: keyword args stay on same line as their value *)
let rec emit = function
| [] -> ()
| Keyword k :: v :: rest ->
Buffer.add_char buf '\n';
Buffer.add_string buf (String.make child_indent ' ');
Buffer.add_char buf ':';
Buffer.add_string buf k;
Buffer.add_char buf ' ';
pp child_indent v;
emit rest
| item :: rest ->
Buffer.add_char buf '\n';
Buffer.add_string buf (String.make child_indent ' ');
pp child_indent item;
emit rest
in
emit rest;
Buffer.add_char buf ')'
end
| _ -> Buffer.add_string buf (pp_atom v)
in
pp 0 v;
Buffer.contents buf
let pretty_print_file exprs =
(* Comments attach to the following expression — no blank line between
comment and expression. Non-comment expressions get one blank line
between them (matching the old String.concat "\n\n" behaviour). *)
let buf = Buffer.create 4096 in
let rec emit first prev_was_comment = function
| [] -> ()
| Comment text :: rest ->
(* Blank line before comment block, unless it's the first item
or follows another comment *)
if not first && not prev_was_comment then Buffer.add_char buf '\n';
Buffer.add_string buf text;
Buffer.add_char buf '\n';
emit false true rest
| v :: rest ->
(* Blank line between non-comment expressions; no blank line
after a comment (comment sticks to its expression) *)
if not first && not prev_was_comment then Buffer.add_char buf '\n';
Buffer.add_string buf (pretty_print_value v);
Buffer.add_char buf '\n';
emit false false rest
in
emit true false exprs;
Buffer.contents buf
(* Parse a file preserving comments, return clean tree + comment map *)
let parse_file_with_comments path =
let src = In_channel.with_open_text path In_channel.input_all in
let all_items = Sx_parser.parse_all ~comments:true src in
let exprs, cmap = separate_comments all_items in
(List exprs, cmap)
(* Write an edited tree back with comments re-interleaved *)
let write_edit_with_comments file cmap result =
match result with
| Dict d ->
(match Hashtbl.find_opt d "ok" with
| Some new_tree ->
let items = match new_tree with
| List items | ListRef { contents = items } -> items
| _ -> [new_tree]
in
let merged = reinterleave items cmap in
let source = pretty_print_file merged 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"
(* Inject comment text into summarise/annotate output.
Matches [N] markers and inserts the comment block that precedes expr N. *)
let inject_comments output cmap =
if Hashtbl.length cmap.before = 0 && cmap.trailing = [] then output
else
let lines = String.split_on_char '\n' output in
let buf = Buffer.create (String.length output + 512) in
let first = ref true in
List.iter (fun line ->
(* Check if line starts with [N] *)
let idx = if String.length line > 1 && line.[0] = '[' then
(try Scanf.sscanf line "[%d]" (fun n -> Some n) with _ -> None)
else None in
(match idx with
| Some n ->
(match Hashtbl.find_opt cmap.before n with
| Some comments ->
List.iter (fun c ->
if not !first then Buffer.add_char buf '\n';
first := false;
match c with
| Comment text -> Buffer.add_string buf text
| _ -> ()
) comments
| None -> ())
| None -> ());
if not !first then Buffer.add_char buf '\n';
first := false;
Buffer.add_string buf line
) lines;
Buffer.contents buf
(* ------------------------------------------------------------------ *)
(* Tool handlers *)
(* ------------------------------------------------------------------ *)
let handle_tool name args =
let open Yojson.Safe.Util in
match name with
| "sx_read_tree" ->
let file = args |> member "file" |> to_string in
let tree, cmap = parse_file_with_comments file in
let focus = args |> member "focus" |> to_string_option in
let max_depth = args |> member "max_depth" |> to_int_option in
let max_lines = args |> member "max_lines" |> to_int_option in
let offset = args |> member "offset" |> to_int_option |> Option.value ~default:0 in
(match focus with
| Some pattern ->
text_result (inject_comments (value_to_string (call_sx "annotate-focused" [tree; String pattern])) cmap)
| None ->
match max_lines with
| Some limit ->
text_result (inject_comments (value_to_string (call_sx "annotate-paginated"
[tree; Number (float_of_int offset); Number (float_of_int limit)])) cmap)
| None ->
match max_depth with
| Some depth ->
text_result (inject_comments (value_to_string (call_sx "summarise" [tree; Number (float_of_int depth)])) cmap)
| None ->
let full = value_to_string (call_sx "annotate-tree" [tree]) in
let line_count = 1 + String.fold_left (fun n c -> if c = '\n' then n + 1 else n) 0 full in
if line_count <= 200 then text_result (inject_comments full cmap)
else
let summary = value_to_string (call_sx "summarise" [tree; Number 2.0]) in
text_result (inject_comments (Printf.sprintf ";; File has %d lines — showing depth-2 summary. Use max_depth, max_lines, or focus to control output.\n%s" line_count summary) cmap))
| "sx_summarise" ->
let file = args |> member "file" |> to_string in
let tree, cmap = parse_file_with_comments file in
let depth = args |> member "depth" |> to_int in
text_result (inject_comments (value_to_string (call_sx "summarise" [tree; Number (float_of_int depth)])) cmap)
| "sx_read_subtree" ->
let tree = parse_file (args |> member "file" |> to_string) in
let path = resolve_path tree (args |> member "path" |> to_string) 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 = resolve_path tree (args |> member "path" |> to_string) 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 = resolve_path tree (args |> member "path" |> to_string) 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, cmap = parse_file_with_comments file in
let path = resolve_path tree (args |> member "path" |> to_string) in
let src = args |> member "new_source" |> to_string in
write_edit_with_comments file cmap (call_sx "replace-node" [tree; path; String src])
| "sx_insert_child" ->
let file = args |> member "file" |> to_string in
let tree, cmap = parse_file_with_comments file in
let path = resolve_path tree (args |> member "path" |> to_string) in
let index = args |> member "index" |> to_int in
let src = args |> member "new_source" |> to_string in
write_edit_with_comments file cmap (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, cmap = parse_file_with_comments file in
let path = resolve_path tree (args |> member "path" |> to_string) in
write_edit_with_comments file cmap (call_sx "delete-node" [tree; path])
| "sx_wrap_node" ->
let file = args |> member "file" |> to_string in
let tree, cmap = parse_file_with_comments file in
let path = resolve_path tree (args |> member "path" |> to_string) in
let wrapper = args |> member "wrapper" |> to_string in
write_edit_with_comments file cmap (call_sx "wrap-node" [tree; path; String wrapper])
| "sx_format_check" ->
let file = args |> member "file" |> to_string in
let tree = parse_file file in
let warnings = call_sx "lint-file" [tree] in
(match warnings with
| List [] | ListRef { contents = [] } -> text_result "OK — no issues found"
| List items | ListRef { contents = items } ->
text_result (String.concat "\n" (List.map value_to_string items))
| _ -> text_result (value_to_string warnings))
| "sx_macroexpand" ->
let file = args |> member "file" |> to_string_option in
let expr_str = args |> member "expr" |> to_string in
(* Create a fresh env with file definitions loaded *)
let e = !env in
(* Optionally load a file's definitions to get its macros *)
(match file with
| Some f ->
(try load_sx_file e f
with exn -> Printf.eprintf "[mcp] Warning: failed to load %s: %s\n%!" f (Printexc.to_string exn))
| None -> ());
let exprs = Sx_parser.parse_all expr_str in
let result = List.fold_left (fun _acc expr ->
Sx_ref.eval_expr expr (Env e)
) Nil exprs in
text_result (Sx_types.inspect result)
| "sx_build" ->
let target = args |> member "target" |> to_string_option |> Option.value ~default:"js" in
let full = args |> member "full" |> to_bool_option |> Option.value ~default:false in
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in
Filename.dirname spec_dir
in
let cmd = match target with
| "ocaml" ->
let abs_project = if Filename.is_relative project_dir then Sys.getcwd () ^ "/" ^ project_dir else project_dir in
Printf.sprintf "cd %s/hosts/ocaml && eval $(opam env 2>/dev/null) && dune build 2>&1 && cp _build/default/browser/sx_browser.bc.wasm.js %s/shared/static/wasm/sx_browser.bc.wasm.js && cp _build/default/browser/sx_browser.bc.js %s/shared/static/wasm/sx_browser.bc.js && cp -r _build/default/browser/sx_browser.bc.wasm.assets %s/shared/static/wasm/" abs_project abs_project abs_project abs_project
| "wasm" ->
let abs_project = if Filename.is_relative project_dir then Sys.getcwd () ^ "/" ^ project_dir else project_dir in
Printf.sprintf "cd %s && bash hosts/ocaml/browser/build-all.sh 2>&1" abs_project
| "js" | _ ->
let extra = if full then " --extensions continuations --spec-modules types" else "" in
Printf.sprintf "cd %s && python3 hosts/javascript/cli.py%s --output shared/static/scripts/sx-browser.js 2>&1" project_dir extra
in
let ic = Unix.open_process_in cmd in
let lines = ref [] in
(try while true do lines := input_line ic :: !lines done with End_of_file -> ());
let status = Unix.close_process_in ic in
let output = String.concat "\n" (List.rev !lines) in
(match status with
| Unix.WEXITED 0 -> text_result (Printf.sprintf "OK — %s build succeeded\n%s" target (String.trim output))
| _ -> error_result (Printf.sprintf "%s build failed:\n%s" target output))
| "sx_build_bytecode" ->
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in
Filename.dirname spec_dir
in
let sx_dir = project_dir ^ "/shared/static/wasm/sx" in
let files = [
"render.sx"; "core-signals.sx"; "signals.sx"; "deps.sx"; "router.sx";
"page-helpers.sx"; "freeze.sx"; "bytecode.sx"; "compiler.sx"; "vm.sx";
"dom.sx"; "browser.sx"; "adapter-html.sx"; "adapter-sx.sx"; "adapter-dom.sx";
"tw-layout.sx"; "tw-type.sx"; "tw.sx";
"boot-helpers.sx"; "hypersx.sx"; "harness.sx"; "harness-reactive.sx";
"harness-web.sx"; "engine.sx"; "orchestration.sx"; "boot.sx";
] in
let t0 = Unix.gettimeofday () in
(* JSON serialization for bytecode constants *)
let rec const_to_json = function
| Number n ->
if Float.is_integer n then Printf.sprintf "{\"t\":\"n\",\"v\":%d}" (int_of_float n)
else Printf.sprintf "{\"t\":\"n\",\"v\":%g}" n
| String s -> Printf.sprintf "{\"t\":\"s\",\"v\":%s}" (json_escape s)
| Symbol s -> Printf.sprintf "{\"t\":\"sym\",\"v\":%s}" (json_escape s)
| Keyword k -> Printf.sprintf "{\"t\":\"kw\",\"v\":%s}" (json_escape k)
| Bool true -> "{\"t\":\"b\",\"v\":true}"
| Bool false -> "{\"t\":\"b\",\"v\":false}"
| Nil -> "{\"t\":\"nil\"}"
| Dict d when Hashtbl.mem d "bytecode" -> code_to_json (Dict d)
| List items -> Printf.sprintf "{\"t\":\"list\",\"v\":[%s]}"
(String.concat "," (List.map const_to_json items))
| ListRef { contents = items } -> Printf.sprintf "{\"t\":\"list\",\"v\":[%s]}"
(String.concat "," (List.map const_to_json items))
| _ -> "{\"t\":\"nil\"}"
and code_to_json code =
let bc = match Sx_runtime.get code (String "bytecode") with
| List l | ListRef { contents = l } ->
String.concat "," (List.map (fun v -> match v with Number n -> string_of_int (int_of_float n) | _ -> "0") l)
| _ -> "" in
let consts = match Sx_runtime.get code (String "constants") with
| List l | ListRef { contents = l } -> String.concat "," (List.map const_to_json l)
| _ -> "" in
let arity = match Sx_runtime.get code (String "arity") with
| Number n -> int_of_float n | _ -> 0 in
let uvc = match Sx_runtime.get code (String "upvalue-count") with
| Number n -> int_of_float n | _ -> 0 in
Printf.sprintf "{\"t\":\"code\",\"v\":{\"arity\":%d,\"upvalue-count\":%d,\"bytecode\":[%s],\"constants\":[%s]}}" arity uvc bc consts
and json_escape s =
let buf = Buffer.create (String.length s + 2) in
Buffer.add_char buf '"';
String.iter (fun c -> match c with
| '"' -> Buffer.add_string buf "\\\"" | '\\' -> Buffer.add_string buf "\\\\"
| '\n' -> Buffer.add_string buf "\\n" | '\r' -> Buffer.add_string buf "\\r"
| '\t' -> Buffer.add_string buf "\\t"
| c -> Buffer.add_char buf c) s;
Buffer.add_char buf '"';
Buffer.contents buf
in
let compiled = ref 0 in
let skipped = ref 0 in
let log = Buffer.create 1024 in
List.iter (fun file ->
let src_path = sx_dir ^ "/" ^ file in
if Sys.file_exists src_path then begin
try
let src = In_channel.with_open_text src_path In_channel.input_all in
let exprs = Sx_parser.parse_all src in
let hash = Digest.string src |> Digest.to_hex |> fun s -> String.sub s 0 16 in
let code = Sx_compiler.compile_module (List exprs) in
(* Serialize to JSON *)
let bc = match Sx_runtime.get code (String "bytecode") with
| List l | ListRef { contents = l } ->
String.concat "," (List.map (fun v -> match v with Number n -> string_of_int (int_of_float n) | _ -> "0") l)
| _ -> "" in
let consts = match Sx_runtime.get code (String "constants") with
| List l | ListRef { contents = l } -> String.concat "," (List.map const_to_json l)
| _ -> "" in
let arity = match Sx_runtime.get code (String "arity") with
| Number n -> int_of_float n | _ -> 0 in
let json = Printf.sprintf "{\"magic\":\"SXBC\",\"version\":1,\"hash\":\"%s\",\"module\":{\"arity\":%d,\"bytecode\":[%s],\"constants\":[%s]}}"
hash arity bc consts in
let json_path = (String.sub src_path 0 (String.length src_path - 3)) ^ ".sxbc.json" in
Out_channel.with_open_text json_path (fun oc -> output_string oc json);
let kb = String.length json / 1024 in
Buffer.add_string log (Printf.sprintf " ok %s → %dK\n" file kb);
incr compiled
with e ->
Buffer.add_string log (Printf.sprintf " SKIP %s — %s\n" file (Printexc.to_string e));
incr skipped
end
) files;
let dt = Unix.gettimeofday () -. t0 in
let summary = Printf.sprintf "Done: %d compiled, %d skipped in %.1fs\n%s"
!compiled !skipped dt (Buffer.contents log) in
if !skipped = 0 then
text_result (Printf.sprintf "OK — bytecode compilation succeeded\n%s" summary)
else
text_result (Printf.sprintf "Bytecode compilation partial\n%s" summary)
| "sx_test" ->
let host = args |> member "host" |> to_string_option |> Option.value ~default:"js" in
let full = args |> member "full" |> to_bool_option |> Option.value ~default:false in
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
(* Walk up from spec dir to find project root *)
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in
Filename.dirname spec_dir
in
let timeout = args |> member "timeout" |> to_int_option |> Option.value ~default:300 in
let cmd = match host with
| "ocaml" ->
Printf.sprintf "cd %s/hosts/ocaml && eval $(opam env 2>/dev/null) && timeout %d dune exec bin/run_tests.exe%s 2>&1"
project_dir timeout (if full then " -- --full" else "")
| "js" | _ ->
Printf.sprintf "cd %s && timeout %d node hosts/javascript/run_tests.js%s 2>&1"
project_dir timeout (if full then " --full" else "")
in
let ic = Unix.open_process_in cmd in
let lines = ref [] in
(try while true do lines := input_line ic :: !lines done with End_of_file -> ());
ignore (Unix.close_process_in ic);
let all_lines = List.rev !lines in
(* Extract summary and failures *)
let fails = List.filter (fun l -> let t = String.trim l in
String.length t > 5 && String.sub t 0 4 = "FAIL") all_lines in
let summary = List.find_opt (fun l -> try let _ = Str.search_forward (Str.regexp "Results:") l 0 in true with Not_found -> false) all_lines in
let result = match summary with
| Some s ->
if fails = [] then s
else s ^ "\n\nFailures:\n" ^ String.concat "\n" fails
| None ->
let last_n = List.filteri (fun i _ -> i >= List.length all_lines - 5) all_lines in
String.concat "\n" last_n
in
text_result result
| "sx_pretty_print" ->
let file = args |> member "file" |> to_string in
let exprs = Sx_parser.parse_all ~comments:true (In_channel.with_open_text file In_channel.input_all) in
let source = pretty_print_file exprs in
Out_channel.with_open_text file (fun oc -> output_string oc source);
text_result (Printf.sprintf "OK — reformatted %s (%d bytes, %d forms)" file (String.length source) (List.length exprs))
| "sx_changed" ->
let base_ref = args |> member "ref" |> to_string_option |> Option.value ~default:"main" in
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in
Filename.dirname spec_dir
in
let cmd = Printf.sprintf "cd %s && git diff --name-only %s -- '*.sx' '*.sxc' 2>/dev/null" project_dir base_ref in
let ic = Unix.open_process_in cmd in
let files = ref [] in
(try while true do files := input_line ic :: !files done with End_of_file -> ());
ignore (Unix.close_process_in ic);
let changed = List.rev !files in
if changed = [] then text_result (Printf.sprintf "No .sx files changed since %s" base_ref)
else begin
let lines = List.map (fun rel ->
let full = Filename.concat project_dir rel in
try
let tree = parse_file full in
let summary = value_to_string (call_sx "summarise" [tree; Number 1.0]) in
Printf.sprintf "=== %s ===\n%s" rel summary
with _ -> Printf.sprintf "=== %s === (parse error or deleted)" rel
) changed in
text_result (String.concat "\n\n" lines)
end
| "sx_diff_branch" ->
let base_ref = args |> member "ref" |> to_string_option |> Option.value ~default:"main" in
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in
Filename.dirname spec_dir
in
let cmd = Printf.sprintf "cd %s && git diff --name-only %s -- '*.sx' '*.sxc' 2>/dev/null" project_dir base_ref in
let ic = Unix.open_process_in cmd in
let files = ref [] in
(try while true do files := input_line ic :: !files done with End_of_file -> ());
ignore (Unix.close_process_in ic);
let changed = List.rev !files in
if changed = [] then text_result (Printf.sprintf "No .sx files changed since %s" base_ref)
else begin
let lines = List.filter_map (fun rel ->
let full = Filename.concat project_dir rel in
(* Get the base version via git show *)
let base_cmd = Printf.sprintf "cd %s && git show %s:%s 2>/dev/null" project_dir base_ref rel in
let ic2 = Unix.open_process_in base_cmd in
let base_lines = ref [] in
(try while true do base_lines := input_line ic2 :: !base_lines done with End_of_file -> ());
ignore (Unix.close_process_in ic2);
let base_src = String.concat "\n" (List.rev !base_lines) in
try
let tree_b = parse_file full in
if base_src = "" then
Some (Printf.sprintf "=== %s (new file) ===\n%s" rel
(value_to_string (call_sx "summarise" [tree_b; Number 1.0])))
else begin
let tree_a = List (Sx_parser.parse_all base_src) in
let diff = value_to_string (call_sx "tree-diff" [tree_a; tree_b]) in
if diff = "No differences" then None
else Some (Printf.sprintf "=== %s ===\n%s" rel diff)
end
with _ -> Some (Printf.sprintf "=== %s === (parse error)" rel)
) changed in
if lines = [] then text_result "All changed .sx files are structurally identical to base"
else text_result (String.concat "\n\n" lines)
end
| "sx_blame" ->
let file = args |> member "file" |> to_string in
let path_str_arg = args |> member "path" |> to_string_option in
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in
Filename.dirname spec_dir
in
(* Get the node's source span by parsing and finding line numbers *)
let tree = parse_file file in
let target_src = match path_str_arg with
| Some ps ->
let path = resolve_path tree ps in
let node = call_sx "navigate" [tree; path] in
if is_nil node then None
else Some (Sx_types.inspect node)
| None -> None
in
let rel_file = relative_path ~base:project_dir file in
let cmd = match target_src with
| Some src ->
(* Find the line range containing this source fragment *)
let first_line = String.sub src 0 (min 40 (String.length src)) in
let escaped = String.concat "" (List.of_seq (Seq.map (fun c ->
if c = '(' || c = ')' || c = '[' || c = ']' || c = '.' || c = '*' || c = '+' || c = '?' || c = '{' || c = '}' || c = '\\' || c = '|' || c = '^' || c = '$'
then Printf.sprintf "\\%c" c else String.make 1 c
) (String.to_seq first_line))) in
Printf.sprintf "cd %s && git blame -L '/%s/,+10' -- %s 2>/dev/null || git blame -- %s 2>/dev/null | head -20" project_dir escaped rel_file rel_file
| None ->
Printf.sprintf "cd %s && git blame -- %s 2>/dev/null | head -30" project_dir rel_file
in
let ic = Unix.open_process_in cmd in
let lines = ref [] in
(try while true do lines := input_line ic :: !lines done with End_of_file -> ());
ignore (Unix.close_process_in ic);
text_result (String.concat "\n" (List.rev !lines))
| "sx_doc_gen" ->
let dir = args |> member "dir" |> to_string in
let files = glob_sx_files dir in
let all_docs = List.concat_map (fun path ->
let rel = relative_path ~base:dir path in
try
let exprs = Sx_parser.parse_all (In_channel.with_open_text path In_channel.input_all) in
List.filter_map (fun expr ->
match expr with
| List (Symbol head :: Symbol name :: rest) | ListRef { contents = Symbol head :: Symbol name :: rest } ->
(match head with
| "defcomp" | "defisland" ->
let params_str = match rest with
| List ps :: _ | ListRef { contents = ps } :: _ ->
let keys = List.filter_map (fun p -> match p with
| Symbol s when s <> "&key" && s <> "&rest" && not (String.length s > 0 && s.[0] = '&') -> Some s
| List (Symbol s :: _) when s <> "&key" && s <> "&rest" -> Some (Printf.sprintf "%s (typed)" s)
| _ -> None) ps
in
let has_rest = List.exists (fun p -> match p with Symbol "&rest" -> true | _ -> false) ps in
let key_str = if keys = [] then "" else " Keys: " ^ String.concat ", " keys ^ "\n" in
let rest_str = if has_rest then " Children: yes\n" else "" in
key_str ^ rest_str
| _ -> ""
in
Some (Printf.sprintf "## %s `%s`\nDefined in: %s\nType: %s\n%s" head name rel head params_str)
| "defmacro" ->
Some (Printf.sprintf "## %s `%s`\nDefined in: %s\nType: macro\n" head name rel)
| _ -> None)
| _ -> None
) exprs
with _ -> []
) files in
if all_docs = [] then text_result "(no components found)"
else text_result (String.concat "\n" all_docs)
| "sx_nav" ->
let mode = (try args |> member "mode" |> to_string with _ -> "list") in
let section_filter = (try Some (args |> member "section" |> to_string) with _ -> None) in
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
try Sys.getenv "SX_ROOT" with Not_found -> Sys.getcwd () in
let sx_dir = project_dir ^ "/sx/sx" in
(* Extract all nav items from nav-data.sx AND nav-tree.sx *)
let scan_nav () =
let items = ref [] in
let seen = Hashtbl.create 64 in
let rec walk = function
| Dict d ->
(match Hashtbl.find_opt d "href", Hashtbl.find_opt d "label" with
| Some (String href), Some (String label) when not (Hashtbl.mem seen href) ->
Hashtbl.replace seen href ();
let summary = match Hashtbl.find_opt d "summary" with Some (String s) -> s | _ -> "" in
items := (href, label, summary) :: !items
| _ -> ());
Hashtbl.iter (fun _ v -> walk v) d
| List l | ListRef { contents = l } -> List.iter walk l
| _ -> ()
in
(* Scan both files — nav-data has the groups, nav-tree has the sidebar structure *)
List.iter (fun file ->
let src = try In_channel.with_open_text (sx_dir ^ "/" ^ file) In_channel.input_all with _ -> "" in
(* Evaluate defines so (dict :key val) calls produce Dict values *)
let exprs = try Sx_parser.parse_all src with _ -> [] in
List.iter (fun expr ->
try walk (Sx_ref.eval_expr expr (Env !env))
with _ -> walk expr (* fallback: walk unevaluated AST *)
) exprs
) ["nav-data.sx"; "nav-tree.sx"];
List.rev !items
in
let href_section href =
if String.length href > 5 && String.sub href 0 5 = "/sx/(" then
let rest = String.sub href 5 (String.length href - 6) in
match String.index_opt rest '.' with Some i -> String.sub rest 0 i | None -> rest
else ""
in
(* Scan all .sx files under sx_dir for defcomp/defisland *)
let scan_comps () =
let comps = ref [] in
let rec scan dir =
Array.iter (fun e ->
let p = dir ^ "/" ^ e in
if Sys.is_directory p then scan p
else if Filename.check_suffix e ".sx" then
List.iter (function
| List (Symbol "defcomp" :: Symbol n :: _)
| List (Symbol "defisland" :: Symbol n :: _) ->
comps := (n, Filename.basename p) :: !comps
| _ -> ()
) (try Sx_parser.parse_all (In_channel.with_open_text p In_channel.input_all) with _ -> [])
) (try Sys.readdir dir with _ -> [||])
in scan sx_dir; !comps
in
let scan_pagefns () =
let src = try In_channel.with_open_text (sx_dir ^ "/page-functions.sx") In_channel.input_all with _ -> "" in
List.filter_map (function
| List [Symbol "define"; Symbol n; _] -> Some n
| _ -> None
) (try Sx_parser.parse_all src with _ -> [])
in
(match mode with
| "list" ->
let items = scan_nav () in
let lines = List.filter_map (fun (href, label, summary) ->
let sec = href_section href in
match section_filter with
| Some f when f <> sec -> None
| _ ->
let s = if summary = "" then "" else " — " ^ (if String.length summary > 50 then String.sub summary 0 50 ^ "..." else summary) in
Some (Printf.sprintf " %-28s %s%s" label href s)
) items in
text_result (Printf.sprintf "%d nav items%s\n%s"
(List.length lines)
(match section_filter with Some s -> " in " ^ s | None -> "")
(String.concat "\n" lines))
| "check" ->
let items = scan_nav () in
let comps = scan_comps () in
let pfns = scan_pagefns () in
let issues = Buffer.create 256 in
let n = ref 0 in
let issue s = incr n; Buffer.add_string issues s; Buffer.add_char issues '\n' in
(* Duplicate hrefs *)
let seen = Hashtbl.create 64 in
List.iter (fun (href, label, _) ->
if Hashtbl.mem seen href then issue (Printf.sprintf "DUP %s (%s)" href label)
else Hashtbl.replace seen href ()
) items;
(* Check page function coverage *)
List.iter (fun (href, label, _) ->
let sec = href_section href in
if sec <> "" && not (List.mem sec pfns) && sec <> "sx" then
issue (Printf.sprintf "WARN no page-fn '%s' for %s (%s)" sec label href)
) items;
(* Components with -content suffix but no nav *)
let nav_src = try In_channel.with_open_text (sx_dir ^ "/nav-data.sx") In_channel.input_all with _ -> "" in
List.iter (fun (name, file) ->
if String.length name > 8 &&
String.sub name (String.length name - 8) 8 = "-content" then
let slug = String.sub name 1 (String.length name - 1) in (* remove ~ *)
let parts = String.split_on_char '/' slug in
let last = List.nth parts (List.length parts - 1) in
let check = String.sub last 0 (String.length last - 8) in (* remove -content *)
if not (try ignore (Str.search_forward (Str.regexp_string check) nav_src 0); true with Not_found -> false) then
issue (Printf.sprintf "INFO %s (%s) — no nav entry" name file)
) comps;
if !n = 0 then text_result "Nav check: all clear"
else text_result (Printf.sprintf "Nav check: %d issues\n%s" !n (Buffer.contents issues))
| "add" ->
let title = (try args |> member "title" |> to_string with _ -> "") in
let slug = (try args |> member "slug" |> to_string with _ -> "") in
let sec = (match section_filter with Some s -> s | None -> "applications") in
if title = "" || slug = "" then error_result "title and slug required"
else begin
let comp = Printf.sprintf "~%s/%s/content" sec slug in
let file = sx_dir ^ "/" ^ slug ^ ".sx" in
let href = Printf.sprintf "/sx/(%s.(%s))" sec slug in
if Sys.file_exists file then error_result ("exists: " ^ file)
else begin
(* Component file *)
let src = Printf.sprintf ";;; %s\n\n(defcomp %s ()\n (~docs/page :title \"%s\"\n (~docs/section :title \"Overview\" :id \"overview\"\n (p \"TODO\"))))\n" title comp title in
Out_channel.with_open_text file (fun oc -> output_string oc src);
(* Page function *)
let pf = sx_dir ^ "/page-functions.sx" in
let ps = In_channel.with_open_text pf In_channel.input_all in
Out_channel.with_open_text pf (fun oc ->
output_string oc ps;
Printf.fprintf oc "\n(define %s (make-page-fn \"%s\" \"~%s/%s/\" nil \"-content\"))\n" slug comp sec slug);
(* Nav entry *)
let nf = sx_dir ^ "/nav-data.sx" in
let ns = In_channel.with_open_text nf In_channel.input_all in
Out_channel.with_open_text nf (fun oc ->
output_string oc ns;
Printf.fprintf oc "\n(define %s-nav-items\n (list (dict :label \"%s\" :href \"%s\")))\n" slug title href);
text_result (Printf.sprintf "Created:\n File: %s\n Component: %s\n Page fn: %s\n Nav href: %s" file comp slug href)
end
end
| "delete" ->
let slug = (try args |> member "slug" |> to_string with _ -> "") in
if slug = "" then error_result "slug required"
else begin
let changes = Buffer.create 256 in
let log s = Buffer.add_string changes s; Buffer.add_char changes '\n' in
(* Helper: remove a top-level (define name ...) block from text *)
let remove_define_block text name =
let pattern = Printf.sprintf "(define %s " name in
match try Some (Str.search_forward (Str.regexp_string pattern) text 0) with Not_found -> None with
| None -> text
| Some start ->
(* Find matching close paren *)
let depth = ref 0 in
let finish = ref (String.length text) in
for i = start to String.length text - 1 do
if text.[i] = '(' then incr depth
else if text.[i] = ')' then begin
decr depth;
if !depth = 0 && !finish = String.length text then
finish := i + 1
end
done;
(* Also consume trailing newlines *)
let e = ref !finish in
while !e < String.length text && text.[!e] = '\n' do incr e done;
String.sub text 0 start ^ String.sub text !e (String.length text - !e)
in
(* 1. Remove from nav-data.sx *)
let nf = sx_dir ^ "/nav-data.sx" in
let ns = In_channel.with_open_text nf In_channel.input_all in
let nav_items_name = slug ^ "-nav-items" in
let ns2 = remove_define_block ns nav_items_name in
if ns2 <> ns then begin
Out_channel.with_open_text nf (fun oc -> output_string oc ns2);
log (Printf.sprintf "nav-data.sx: removed define %s" nav_items_name)
end;
(* 2. Remove from nav-tree.sx — find the dict block with matching href *)
let tf = sx_dir ^ "/nav-tree.sx" in
let ts = In_channel.with_open_text tf In_channel.input_all in
let href_pat = Printf.sprintf "\"(/sx/(%%.(%s" slug in
(* Match any section: find the (dict ... :href "/sx/(SECTION.(SLUG..." block *)
let slug_re = Str.regexp (Printf.sprintf ":href \"/sx/([a-z]+\\.(%s" (Str.quote slug)) in
let ts2 = match try Some (Str.search_forward slug_re ts 0) with Not_found -> None with
| None -> ignore href_pat; ts
| Some _ ->
(* Walk back to find the opening (dict *)
let href_pos = Str.match_beginning () in
let start = ref href_pos in
while !start > 0 && String.sub ts !start 4 <> "dict" do decr start done;
(* Back one more for the opening paren *)
while !start > 0 && ts.[!start] <> '(' do decr start done;
(* Find matching close paren *)
let depth = ref 0 in
let finish = ref (String.length ts) in
for i = !start to String.length ts - 1 do
if ts.[i] = '(' then incr depth
else if ts.[i] = ')' then begin
decr depth;
if !depth = 0 && !finish = String.length ts then
finish := i + 1
end
done;
(* Consume trailing whitespace/newlines *)
let e = ref !finish in
while !e < String.length ts && (ts.[!e] = '\n' || ts.[!e] = ' ') do incr e done;
log (Printf.sprintf "nav-tree.sx: removed entry for %s" slug);
String.sub ts 0 !start ^ String.sub ts !e (String.length ts - !e)
in
if ts2 <> ts then
Out_channel.with_open_text tf (fun oc -> output_string oc ts2);
(* 3. Remove from page-functions.sx *)
let pf = sx_dir ^ "/page-functions.sx" in
let ps = In_channel.with_open_text pf In_channel.input_all in
let ps2 = remove_define_block ps slug in
if ps2 <> ps then begin
Out_channel.with_open_text pf (fun oc -> output_string oc ps2);
log (Printf.sprintf "page-functions.sx: removed define %s" slug)
end;
text_result (Printf.sprintf "Deleted %s:\n%s" slug (Buffer.contents changes))
end
| "move" ->
let slug = (try args |> member "slug" |> to_string with _ -> "") in
let from_sec = (try args |> member "from" |> to_string with _ -> "") in
let to_sec = (try args |> member "to" |> to_string with _ ->
match section_filter with Some s -> s | None -> "") in
if slug = "" || from_sec = "" || to_sec = "" then
error_result "slug, from, and to (or section) required"
else if from_sec = to_sec then
error_result "from and to must differ"
else begin
let changes = Buffer.create 256 in
let log s = Buffer.add_string changes s; Buffer.add_char changes '\n' in
let old_prefix = from_sec ^ ".(" ^ slug in
let new_prefix = to_sec ^ ".(" ^ slug in
(* 1. Rewrite hrefs in nav-data.sx *)
let nf = sx_dir ^ "/nav-data.sx" in
let ns = In_channel.with_open_text nf In_channel.input_all in
let ns2 = Str.global_replace (Str.regexp_string old_prefix) new_prefix ns in
if ns2 <> ns then begin
Out_channel.with_open_text nf (fun oc -> output_string oc ns2);
log (Printf.sprintf "nav-data.sx: rewrote hrefs %s → %s" from_sec to_sec)
end;
(* 2. Move entry in nav-tree.sx: extract block from source, rewrite hrefs, insert into target *)
let tf = sx_dir ^ "/nav-tree.sx" in
let ts = In_channel.with_open_text tf In_channel.input_all in
(* First rewrite all hrefs *)
let ts2 = Str.global_replace (Str.regexp_string old_prefix) new_prefix ts in
(* Find the dict block for this slug *)
let slug_re = Str.regexp (Printf.sprintf ":href \"/sx/([a-z]+\\.(%s" (Str.quote slug)) in
let ts3 = match try Some (Str.search_forward slug_re ts2 0) with Not_found -> None with
| None ->
log "nav-tree.sx: hrefs rewritten (no entry block found to relocate)";
ts2
| Some _ ->
let href_pos = Str.match_beginning () in
(* Walk back to (dict *)
let start = ref href_pos in
while !start > 0 && String.sub ts2 !start 4 <> "dict" do decr start done;
while !start > 0 && ts2.[!start] <> '(' do decr start done;
(* Find matching close paren *)
let depth = ref 0 in
let finish = ref (String.length ts2) in
for i = !start to String.length ts2 - 1 do
if ts2.[i] = '(' then incr depth
else if ts2.[i] = ')' then begin
decr depth;
if !depth = 0 && !finish = String.length ts2 then
finish := i + 1
end
done;
let block = String.sub ts2 !start (!finish - !start) in
(* Remove block from source position *)
let e = ref !finish in
while !e < String.length ts2 && (ts2.[!e] = '\n' || ts2.[!e] = ' ') do incr e done;
let without = String.sub ts2 0 !start ^ String.sub ts2 !e (String.length ts2 - !e) in
(* Insert into target section — find the last child before the closing paren of target's :children *)
let target_href = Printf.sprintf "\"/sx/(%s)\"" to_sec in
(match try Some (Str.search_forward (Str.regexp_string target_href) without 0) with Not_found -> None with
| None ->
log (Printf.sprintf "nav-tree.sx: hrefs rewritten but target section %s not found" to_sec);
without
| Some _ ->
let target_pos = Str.match_beginning () in
(* Find :children after target_pos *)
let children_re = Str.regexp_string ":children" in
(match try Some (Str.search_forward children_re without target_pos) with Not_found -> None with
| None ->
log (Printf.sprintf "nav-tree.sx: target %s has no :children" to_sec);
without
| Some _ ->
let ch_pos = Str.match_beginning () in
(* Find the opening paren of the children list *)
let lp = ref (ch_pos + 9) in
while !lp < String.length without && without.[!lp] <> '(' do incr lp done;
(* Find its matching close paren *)
let d = ref 0 in
let close = ref (String.length without) in
for i = !lp to String.length without - 1 do
if without.[i] = '(' then incr d
else if without.[i] = ')' then begin
decr d;
if !d = 0 && !close = String.length without then
close := i
end
done;
(* Insert block just before the closing paren *)
let indent = "\n " in
let result = String.sub without 0 !close ^ indent ^ block ^ String.sub without !close (String.length without - !close) in
log (Printf.sprintf "nav-tree.sx: moved %s from %s to %s" slug from_sec to_sec);
result))
in
Out_channel.with_open_text tf (fun oc -> output_string oc ts3);
(* 3. Rewrite page-functions.sx component prefix if needed *)
let pf = sx_dir ^ "/page-functions.sx" in
let ps = In_channel.with_open_text pf In_channel.input_all in
let old_comp_prefix = "~" ^ from_sec ^ "/" ^ slug ^ "/" in
let new_comp_prefix = "~" ^ to_sec ^ "/" ^ slug ^ "/" in
let ps2 = Str.global_replace (Str.regexp_string old_comp_prefix) new_comp_prefix ps in
if ps2 <> ps then begin
Out_channel.with_open_text pf (fun oc -> output_string oc ps2);
log (Printf.sprintf "page-functions.sx: rewrote %s → %s" old_comp_prefix new_comp_prefix)
end;
text_result (Printf.sprintf "Moved %s: %s → %s\n%s" slug from_sec to_sec (Buffer.contents changes))
end
| m -> error_result (Printf.sprintf "unknown mode: %s (list, check, add, move, delete)" m))
| "sx_playwright" ->
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in
Filename.dirname spec_dir
in
let spec = args |> member "spec" |> to_string_option in
let mode = args |> member "mode" |> to_string_option in
let url = args |> member "url" |> to_string_option in
let selector = args |> member "selector" |> to_string_option in
let expr = args |> member "expr" |> to_string_option in
let actions = args |> member "actions" |> to_string_option in
let island = args |> member "island" |> to_string_option in
let phase = args |> member "phase" |> to_string_option in
let filter = args |> member "filter" |> to_string_option in
(* Determine whether to run specs or the inspector *)
let use_inspector = match mode with
| Some m when m <> "run" -> true
| _ -> spec = None && mode <> None
in
if not use_inspector then begin
(* Original spec runner *)
let spec_arg = match spec with Some s -> " " ^ s | None -> "" in
let cmd = Printf.sprintf "cd %s/tests/playwright && npx playwright test%s --reporter=line 2>&1" project_dir spec_arg in
let ic = Unix.open_process_in cmd in
let lines = ref [] in
(try while true do lines := input_line ic :: !lines done with End_of_file -> ());
ignore (Unix.close_process_in ic);
let all_lines = List.rev !lines in
(* Count passed/failed/skipped from the summary line *)
let summary = List.find_opt (fun l ->
try let _ = Str.search_forward (Str.regexp "passed\\|failed") l 0 in true
with Not_found -> false) (List.rev all_lines) in
(* Extract test names that failed *)
let fail_names = List.filter_map (fun l ->
let t = String.trim l in
if String.length t > 2 then
try
let _ = Str.search_forward (Str.regexp "› .* › ") t 0 in
Some (" " ^ t)
with Not_found -> None
else None) all_lines in
(* Extract error messages (lines starting with Error:) *)
let errors = List.filter_map (fun l ->
let t = String.trim l in
if String.length t > 6 then
try
let _ = Str.search_forward (Str.regexp "expect.*\\(received\\)\\|Expected\\|Received\\|Error:.*expect") t 0 in
Some (" " ^ t)
with Not_found -> None
else None) all_lines in
let total = List.length fail_names + (match summary with
| Some s -> (try let _ = Str.search_forward (Str.regexp "\\([0-9]+\\) passed") s 0 in
int_of_string (Str.matched_group 1 s) with _ -> 0)
| None -> 0) in
let summary_str = match summary with Some s -> String.trim s | None -> "no summary" in
let result =
if fail_names = [] then
Printf.sprintf "%s (%d total)" summary_str total
else
Printf.sprintf "%s (%d total)\n\nFailed:\n%s\n\nErrors:\n%s"
summary_str total
(String.concat "\n" fail_names)
(String.concat "\n" (List.filteri (fun i _ -> i < 10) errors))
in
text_result result
end else begin
(* SX-aware inspector *)
let inspector_args = `Assoc (List.filter_map Fun.id [
(match mode with Some m -> Some ("mode", `String m) | None -> Some ("mode", `String "inspect"));
(match url with Some u -> Some ("url", `String u) | None -> None);
(match selector with Some s -> Some ("selector", `String s) | None -> None);
(match expr with Some e -> Some ("expr", `String e) | None -> None);
(match actions with Some a -> Some ("actions", `String a) | None -> None);
(match island with Some i -> Some ("island", `String i) | None -> None);
(match phase with Some p -> Some ("phase", `String p) | None -> None);
(match filter with Some f -> Some ("filter", `String f) | None -> None);
]) in
let args_json = Yojson.Basic.to_string inspector_args in
(* Single-quote shell wrapping — escape any literal single quotes in JSON *)
let shell_safe = String.concat "'\\''" (String.split_on_char '\'' args_json) in
let cmd = Printf.sprintf "cd %s && node tests/playwright/sx-inspect.js '%s' 2>&1" project_dir shell_safe in
let ic = Unix.open_process_in cmd in
let lines = ref [] in
(try while true do lines := input_line ic :: !lines done with End_of_file -> ());
ignore (Unix.close_process_in ic);
let raw = String.concat "\n" (List.rev !lines) in
(* Try to parse as JSON and format nicely *)
try
let json = Yojson.Basic.from_string raw in
let pretty = Yojson.Basic.pretty_to_string json in
text_result pretty
with _ ->
text_result raw
end
| "sx_harness_eval" ->
let expr_str = args |> member "expr" |> to_string in
let mock_str = args |> member "mock" |> to_string_option in
let file = args |> member "file" |> to_string_option in
let setup_str = args |> member "setup" |> to_string_option in
let files_json = try args |> member "files" with _ -> `Null in
let e = !env in
let warnings = ref [] in
(* Collect all files to load *)
let all_files = match files_json with
| `List items ->
List.map (fun j -> Yojson.Safe.Util.to_string j) items
| _ -> match file with Some f -> [f] | None -> []
in
(* Load each file *)
List.iter (fun f ->
try load_sx_file e f
with exn ->
warnings := Printf.sprintf "Warning: %s: %s" f (Printexc.to_string exn) :: !warnings
) all_files;
(* Run setup expression if provided *)
(match setup_str with
| Some s ->
let setup_exprs = Sx_parser.parse_all s in
List.iter (fun expr ->
try ignore (Sx_ref.eval_expr expr (Env e))
with exn ->
warnings := Printf.sprintf "Setup error: %s" (Printexc.to_string exn) :: !warnings
) setup_exprs
| None -> ());
(* Create harness with optional mock overrides *)
let mock_arg = match mock_str with
| Some s ->
let parsed = Sx_parser.parse_all s in
if parsed <> [] then List [Keyword "platform"; List.hd parsed] else List []
| None -> List []
in
let session = Sx_ref.cek_call (env_get e "make-harness") mock_arg in
(* Install interceptors *)
ignore (call_sx "install-interceptors" [session; Env e]);
(* Evaluate the expression *)
let exprs = Sx_parser.parse_all expr_str in
let result = List.fold_left (fun _acc expr ->
try Sx_ref.eval_expr expr (Env e)
with exn -> String (Printf.sprintf "Error: %s" (Printexc.to_string exn))
) Nil exprs in
(* Get the IO log *)
let log = call_sx "harness-log" [session] in
let log_str = match log with
| List items | ListRef { contents = items } when items <> [] ->
"\n\nIO Log:\n" ^ String.concat "\n" (List.map (fun entry ->
let op = value_to_string (call_sx "get" [entry; String "op"]) in
let args_val = call_sx "get" [entry; String "args"] in
Printf.sprintf " %s(%s)" op (Sx_types.inspect args_val)
) items)
| _ -> "\n\n(no IO calls)"
in
let warn_str = if !warnings = [] then "" else
"\n\nWarnings:\n" ^ String.concat "\n" (List.rev !warnings)
in
text_result (Printf.sprintf "Result: %s%s%s" (Sx_types.inspect result) log_str warn_str)
| "sx_write_file" ->
let file = args |> member "file" |> to_string in
let source = args |> member "source" |> to_string in
(* Validate by parsing first — preserve comments *)
(try
let exprs = Sx_parser.parse_all ~comments:true source in
if exprs = [] then error_result "Source parsed to empty — nothing to write"
else begin
let output = pretty_print_file exprs in
Out_channel.with_open_text file (fun oc -> output_string oc output);
text_result (Printf.sprintf "OK — wrote %d bytes (%d top-level forms) to %s" (String.length output) (List.length exprs) file)
end
with e -> error_result (Printf.sprintf "Parse error — file not written: %s" (Printexc.to_string e)))
| "sx_rename_symbol" ->
let file = args |> member "file" |> to_string in
let tree, cmap = parse_file_with_comments file in
let old_name = args |> member "old_name" |> to_string in
let new_name = args |> member "new_name" |> to_string in
let new_tree = call_sx "rename-symbol" [tree; String old_name; String new_name] in
let count = call_sx "count-renames" [tree; String old_name] in
let count_str = value_to_string count in
write_edit_with_comments file cmap (Dict (let d = Hashtbl.create 2 in Hashtbl.replace d "ok" new_tree; d))
|> (fun result ->
match result with
| `Assoc [("content", `List [`Assoc [("type", _); ("text", `String s)]])] when not (String.starts_with ~prefix:"Error" s) ->
text_result (Printf.sprintf "Renamed %s occurrences of '%s' → '%s' in %s" count_str old_name new_name file)
| other -> other)
| "sx_replace_by_pattern" ->
let file = args |> member "file" |> to_string in
let tree, cmap = parse_file_with_comments file in
let pattern = args |> member "pattern" |> to_string in
let src = args |> member "new_source" |> to_string in
let all = args |> member "all" |> to_bool_option |> Option.value ~default:false in
if all then
write_edit_with_comments file cmap (call_sx "replace-all-by-pattern" [tree; String pattern; String src])
else
write_edit_with_comments file cmap (call_sx "replace-by-pattern" [tree; String pattern; String src])
| "sx_insert_near" ->
let file = args |> member "file" |> to_string in
let tree, cmap = parse_file_with_comments file in
let pattern = args |> member "pattern" |> to_string in
let position = args |> member "position" |> to_string_option |> Option.value ~default:"after" in
let src = args |> member "new_source" |> to_string in
write_edit_with_comments file cmap (call_sx "insert-near-pattern" [tree; String pattern; String position; String src])
| "sx_rename_across" ->
let dir = args |> member "dir" |> to_string in
let old_name = args |> member "old_name" |> to_string in
let new_name = args |> member "new_name" |> to_string in
let dry_run = args |> member "dry_run" |> to_bool_option |> Option.value ~default:false in
let files = glob_sx_files dir in
let results = List.filter_map (fun path ->
let rel = relative_path ~base:dir path in
try
let tree, cmap = parse_file_with_comments path in
let count = call_sx "count-renames" [tree; String old_name] in
match count with
| Number n when n > 0.0 ->
if dry_run then
Some (Printf.sprintf "%s: %d occurrences (dry run)" rel (int_of_float n))
else begin
let new_tree = call_sx "rename-symbol" [tree; String old_name; String new_name] in
let items = match new_tree with
| List items | ListRef { contents = items } -> items
| _ -> [new_tree]
in
let merged = reinterleave items cmap in
let source = pretty_print_file merged in
Out_channel.with_open_text path (fun oc -> output_string oc source);
Some (Printf.sprintf "%s: %d occurrences renamed" rel (int_of_float n))
end
| _ -> None
with _ -> None
) files in
if results = [] then text_result (Printf.sprintf "No occurrences of '%s' found" old_name)
else text_result (String.concat "\n" results)
| "sx_comp_list" ->
let dir = args |> member "dir" |> to_string in
let files = glob_sx_files dir in
let all_lines = List.concat_map (fun path ->
let rel = relative_path ~base:dir path in
try
let exprs = Sx_parser.parse_all (In_channel.with_open_text path In_channel.input_all) in
List.filter_map (fun expr ->
match expr with
| List (Symbol head :: Symbol name :: rest) | ListRef { contents = Symbol head :: Symbol name :: rest } ->
(match head with
| "defcomp" | "defisland" | "defmacro" | "defpage" | "define" ->
let params = match rest with
| List ps :: _ | ListRef { contents = ps } :: _ ->
String.concat " " (List.map Sx_runtime.value_to_str ps)
| _ -> ""
in
Some (Printf.sprintf "%-10s %-40s %-50s %s" head name rel params)
| _ -> None)
| _ -> None
) exprs
with _ -> []
) files in
if all_lines = [] then text_result "(no definitions found)"
else text_result (Printf.sprintf "%-10s %-40s %-50s %s\n%s" "TYPE" "NAME" "FILE" "PARAMS" (String.concat "\n" all_lines))
| "sx_find_across" ->
let dir = args |> member "dir" |> to_string in
let pattern = args |> member "pattern" |> to_string in
let files = glob_sx_files dir in
let all_lines = List.concat_map (fun path ->
let rel = relative_path ~base:dir path in
try
let tree = parse_file path in
let results = call_sx "find-all" [tree; String pattern] in
(match results with
| List items | ListRef { contents = items } ->
List.map (fun item ->
match item with
| List [p; s] | ListRef { contents = [p; s] } ->
rel ^ " " ^ value_to_string (call_sx "path-str" [p]) ^ " " ^ value_to_string s
| _ -> rel ^ " " ^ value_to_string item
) items
| _ -> [])
with _ -> []
) files in
if all_lines = [] then text_result "(no matches)"
else text_result (String.concat "\n" all_lines)
| "sx_diff" ->
let file_a = args |> member "file_a" |> to_string in
let file_b = args |> member "file_b" |> to_string in
let tree_a = parse_file file_a in
let tree_b = parse_file file_b in
text_result (value_to_string (call_sx "tree-diff" [tree_a; tree_b]))
| "sx_comp_usage" ->
let dir = args |> member "dir" |> to_string in
let name = args |> member "name" |> to_string in
let files = glob_sx_files dir in
let all_lines = List.concat_map (fun path ->
let rel = relative_path ~base:dir path in
try
let tree = parse_file path in
let results = call_sx "find-all" [tree; String name] in
(match results with
| List items | ListRef { contents = items } ->
List.map (fun item ->
match item with
| List [p; s] | ListRef { contents = [p; s] } ->
rel ^ " " ^ value_to_string (call_sx "path-str" [p]) ^ " " ^ value_to_string s
| _ -> rel ^ " " ^ value_to_string item
) items
| _ -> [])
with _ -> []
) files in
if all_lines = [] then text_result "(no usages found)"
else text_result (String.concat "\n" all_lines)
| "sx_eval" ->
let expr_str = args |> member "expr" |> to_string in
let exprs = Sx_parser.parse_all expr_str in
let e = !env in
let result = List.fold_left (fun _acc expr ->
Sx_ref.eval_expr expr (Env e)
) Nil exprs in
text_result (Sx_runtime.value_to_str result)
| "sx_guard" ->
let expr_str = args |> member "expr" |> to_string in
let file = try Some (args |> member "file" |> to_string) with _ -> None in
let e = !env in
(match file with
| Some f -> (try load_sx_file e f with _ -> ())
| None -> ());
let exprs = Sx_parser.parse_all expr_str in
let conditions = ref [] in
(* Evaluate with error recovery — catch Eval_error, log it, return placeholder *)
let result = ref Nil in
(try
result := List.fold_left (fun _acc expr ->
Sx_ref.eval_expr expr (Env e)
) Nil exprs
with Eval_error msg ->
let enhanced = Sx_ref.enhance_error_with_trace msg in
conditions := enhanced :: !conditions;
result := String ("<error: " ^ msg ^ ">"));
let cond_lines = match !conditions with
| [] -> ""
| cs -> "\n\nConditions signaled:\n" ^
String.concat "\n" (List.rev_map (fun c -> " - " ^ c) cs) in
text_result (Sx_runtime.value_to_str !result ^ cond_lines)
| "sx_render_trace" ->
let expr_str = args |> member "expr" |> to_string in
let file = try Some (args |> member "file" |> to_string) with _ -> None in
let e = !env in
(match file with
| Some f -> (try load_sx_file e f with _ -> ())
| None -> ());
let exprs = Sx_parser.parse_all expr_str in
let expr = match exprs with [e] -> e | _ -> List (Symbol "do" :: exprs) in
let trace = Buffer.create 2048 in
let truncate s n = if String.length s > n then String.sub s 0 n ^ "..." else s in
let expr_str = truncate (Sx_runtime.value_to_str expr) 60 in
let kind = match expr with
| Nil -> "nil" | Bool _ -> "bool" | Number _ -> "number"
| String _ -> "string" | Symbol _ -> "symbol" | Keyword _ -> "keyword"
| RawHTML _ -> "raw-html"
| List (Symbol s :: _) | ListRef { contents = Symbol s :: _ } ->
if List.mem s Sx_render.html_tags then "element:" ^ s
else if List.mem s ["if";"when";"cond";"case";"let";"let*";"do";"begin";"map";"filter";"define";"defcomp"] then "form:" ^ s
else "call:" ^ s
| List _ -> "list" | _ -> "other" in
Buffer.add_string trace (Printf.sprintf "→ %s %s\n" kind expr_str);
let result = (try
Sx_render.sx_render_to_html e expr e
with Sx_types.Eval_error msg -> "ERROR: " ^ Sx_ref.enhance_error_with_trace msg) in
let result_str = truncate result 60 in
Buffer.add_string trace (Printf.sprintf "← %s\n" result_str);
text_result (Printf.sprintf "Result: %s\n\nRender trace:\n%s" result (Buffer.contents trace))
| "sx_trace" ->
let expr_str = args |> member "expr" |> to_string in
let max_steps = (try args |> member "max_steps" |> to_int with _ -> 200) in
let file = try Some (args |> member "file" |> to_string) with _ -> None in
let components_only = (try args |> member "components_only" |> to_bool with _ -> false) in
let e = !env in
(match file with
| Some f -> (try load_sx_file e f with _ -> ())
| None -> ());
let exprs = Sx_parser.parse_all expr_str in
let expr = match exprs with [e] -> e | _ -> List exprs in
let state = ref (Sx_ref.make_cek_state expr (Env e) (List [])) in
let steps = Buffer.create 2048 in
let step_count = ref 0 in
let truncate s n = if String.length s > n then String.sub s 0 n ^ "..." else s in
(* Track comp-trace depth for component-only mode *)
let comp_depth = ref 0 in
let prev_comp_depth = ref 0 in
let get_frame_type kont = match kont with
| List (CekFrame f :: _) -> f.cf_type
| List (Dict d :: _) ->
(match Hashtbl.find_opt d "type" with Some (String s) -> s | _ -> "?")
| _ -> "done" in
let count_comp_trace kont =
let n = ref 0 in
let k = ref kont in
(try while true do
(match !k with
| List (CekFrame f :: rest) ->
if f.cf_type = "comp-trace" then incr n;
k := List rest
| List (Dict d :: rest) ->
(match Hashtbl.find_opt d "type" with
| Some (String "comp-trace") -> incr n | _ -> ());
k := List rest
| _ -> raise Exit)
done with Exit -> ());
!n in
(try
while !step_count < max_steps do
let s = !state in
(match s with
| CekState cs ->
incr step_count;
let n = !step_count in
if components_only then begin
let depth = count_comp_trace cs.cs_kont in
(if depth > !prev_comp_depth then begin
let indent = String.make (depth * 2) ' ' in
let ft = get_frame_type cs.cs_kont in
let name = (match cs.cs_kont with
| List (CekFrame f :: _) when f.cf_type = "comp-trace" ->
(match f.cf_name with String s -> s | _ -> "?")
| _ -> "?") in
Buffer.add_string steps
(Printf.sprintf "%s→ ENTER ~%s\n" indent name);
ignore ft
end else if depth < !prev_comp_depth then begin
let indent = String.make ((depth + 1) * 2) ' ' in
let val_str = if cs.cs_phase = "continue"
then truncate (Sx_runtime.value_to_str cs.cs_value) 60
else "..." in
Buffer.add_string steps
(Printf.sprintf "%s← EXIT → %s\n" indent val_str)
end);
prev_comp_depth := depth
end else begin
if cs.cs_phase = "eval" then begin
let ctrl = cs.cs_control in
(match ctrl with
| Symbol sym_name ->
let resolved = (try
let v = Sx_ref.eval_expr ctrl cs.cs_env in
truncate (Sx_runtime.value_to_str v) 60
with _ -> "???") in
Buffer.add_string steps
(Printf.sprintf "%3d LOOKUP %s → %s\n" n sym_name resolved)
| List (hd :: _) ->
let head_str = truncate (Sx_runtime.value_to_str hd) 30 in
let ctrl_str = truncate (Sx_runtime.value_to_str ctrl) 80 in
Buffer.add_string steps
(Printf.sprintf "%3d CALL %s\n" n ctrl_str);
ignore head_str
| _ ->
Buffer.add_string steps
(Printf.sprintf "%3d LITERAL %s\n" n
(truncate (Sx_runtime.value_to_str ctrl) 60)))
end else begin
let val_str = truncate (Sx_runtime.value_to_str cs.cs_value) 60 in
let ft = get_frame_type cs.cs_kont in
Buffer.add_string steps
(Printf.sprintf "%3d RETURN %s → %s\n" n val_str ft)
end
end;
ignore comp_depth;
(match Sx_ref.cek_terminal_p s with
| Bool true -> raise Exit
| _ -> ());
state := Sx_ref.cek_step s
| _ -> raise Exit)
done
with
| Exit -> ()
| Eval_error msg ->
let enhanced = Sx_ref.enhance_error_with_trace msg in
Buffer.add_string steps (Printf.sprintf "ERROR: %s\n" enhanced)
| exn ->
Buffer.add_string steps (Printf.sprintf "ERROR: %s\n" (Printexc.to_string exn)));
let final_val = (match !state with
| CekState cs -> Sx_runtime.value_to_str cs.cs_value
| v -> Sx_runtime.value_to_str v) in
text_result (Printf.sprintf "Result: %s\n\nTrace (%d steps):\n%s"
final_val !step_count (Buffer.contents steps))
| "sx_deps" ->
let file = args |> member "file" |> to_string in
let name = try Some (args |> member "name" |> to_string) with _ -> None in
let dir = try args |> member "dir" |> to_string with _ ->
try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
try Sys.getenv "PWD" with Not_found -> "." in
let tree = parse_file file in
(* Find the target subtree *)
let target = match name with
| Some n ->
(* Find the named define/defcomp/defisland *)
let items = match tree with List l | ListRef { contents = l } -> l | _ -> [tree] in
let found = List.find_opt (fun item ->
match item with
| List (Symbol head :: Symbol def_name :: _)
| List (Symbol head :: List (Symbol def_name :: _) :: _)
when (head = "define" || head = "defcomp" || head = "defisland" ||
head = "defmacro" || head = "deftest") ->
def_name = n || ("~" ^ def_name) = n || def_name = String.sub n 1 (String.length n - 1)
| _ -> false
) items in
(match found with Some f -> f | None -> tree)
| None -> tree
in
let free_syms = call_sx "collect-free-symbols" [target] in
let sym_names = match free_syms with
| List items | ListRef { contents = items } ->
List.filter_map (fun v -> match v with String s -> Some s | _ -> None) items
| _ -> []
in
(* Resolve where each symbol is defined *)
let file_defines = Hashtbl.create 32 in
let same_file_items = match tree with List l | ListRef { contents = l } -> l | _ -> [] in
List.iter (fun item ->
match item with
| List (Symbol head :: Symbol def_name :: _)
when (head = "define" || head = "defcomp" || head = "defisland" || head = "defmacro") ->
Hashtbl.replace file_defines def_name true
| _ -> ()
) same_file_items;
(* Check primitives *)
let is_prim name = try ignore (Sx_primitives.get_primitive name); true with _ -> false in
(* Scan directory for definitions *)
let all_sx_files = glob_sx_files dir in
let ext_defs = Hashtbl.create 64 in
List.iter (fun path ->
if path <> file then
try
let t = parse_file path in
let items = match t with List l | ListRef { contents = l } -> l | _ -> [] in
List.iter (fun item ->
match item with
| List (Symbol head :: Symbol def_name :: _)
when (head = "define" || head = "defcomp" || head = "defisland" || head = "defmacro") ->
if not (Hashtbl.mem ext_defs def_name) then
Hashtbl.replace ext_defs def_name (relative_path ~base:dir path)
| _ -> ()
) items
with _ -> ()
) all_sx_files;
(* Find use declarations *)
let use_decls = call_sx "find-use-declarations" [tree] in
let declared_modules = match use_decls with
| List items | ListRef { contents = items } ->
List.filter_map (fun v -> match v with String s -> Some s | _ -> None) items
| _ -> []
in
(* Format output *)
let lines = List.map (fun sym ->
if Hashtbl.mem file_defines sym then
Printf.sprintf " %-30s (same file)" sym
else if is_prim sym then
Printf.sprintf " %-30s [primitive]" sym
else match Hashtbl.find_opt ext_defs sym with
| Some path -> Printf.sprintf " %-30s %s" sym path
| None -> Printf.sprintf " %-30s ???" sym
) sym_names in
let header = match name with
| Some n -> Printf.sprintf "Dependencies of %s in %s" n file
| None -> Printf.sprintf "Dependencies of %s" file
in
let use_str = if declared_modules = [] then "" else
Printf.sprintf "\n\nDeclared modules (use):\n %s" (String.concat ", " declared_modules)
in
text_result (Printf.sprintf "%s\n%d symbols referenced:\n%s%s"
header (List.length sym_names) (String.concat "\n" lines) use_str)
| "sx_build_manifest" ->
let target = (try args |> member "target" |> to_string with _ -> "js") in
(match target with
| "ocaml" ->
let e = !env in
(* Collect all bindings from the env *)
let bindings = ref [] in
(* Walk env chain collecting all bindings *)
let rec collect_bindings env acc =
Hashtbl.iter (fun id v ->
if not (Hashtbl.mem acc id) then Hashtbl.replace acc id v
) env.bindings;
match env.parent with Some p -> collect_bindings p acc | None -> ()
in
let all = Hashtbl.create 256 in
collect_bindings e all;
Hashtbl.iter (fun id v ->
let k = Sx_types.unintern id in
let kind = match v with
| NativeFn _ -> "native"
| Lambda _ -> "lambda"
| Component _ -> "component"
| Island _ -> "island"
| Macro _ -> "macro"
| _ -> "value"
in
bindings := (k, kind) :: !bindings
) all;
let sorted = List.sort (fun (a,_) (b,_) -> String.compare a b) !bindings in
let by_kind = Hashtbl.create 8 in
List.iter (fun (name, kind) ->
let cur = try Hashtbl.find by_kind kind with Not_found -> [] in
Hashtbl.replace by_kind kind (name :: cur)
) sorted;
let sections = Buffer.create 2048 in
Buffer.add_string sections "OCaml Build Manifest\n====================\n\n";
Buffer.add_string sections (Printf.sprintf "Total bindings: %d\n\n" (List.length sorted));
Buffer.add_string sections "Loaded files: parser.sx, tree-tools.sx, harness.sx\n\n";
List.iter (fun kind ->
match Hashtbl.find_opt by_kind kind with
| Some names ->
let rev_names = List.rev names in
Buffer.add_string sections
(Printf.sprintf "%s (%d):\n %s\n\n" kind (List.length rev_names)
(String.concat ", " rev_names))
| None -> ()
) ["native"; "lambda"; "macro"; "component"; "island"; "value"];
text_result (Buffer.contents sections)
| _ ->
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
try Sys.getenv "PWD" with Not_found -> "." in
let cmd = Printf.sprintf "cd %s && python3 hosts/javascript/manifest.py 2>&1"
(Filename.quote project_dir) in
let ic = Unix.open_process_in cmd in
let buf = Buffer.create 4096 in
(try while true do Buffer.add_string buf (input_line ic ^ "\n") done
with End_of_file -> ());
ignore (Unix.close_process_in ic);
text_result (Buffer.contents buf))
| "sx_explain" ->
let form_name = args |> member "name" |> to_string in
let e = !env in
let result = try
let find_fn = env_get e "find-rule" in
Sx_ref.cek_call find_fn (List [String form_name])
with _ -> Nil in
(match result with
| Dict d ->
let get_str k = match Hashtbl.find_opt d k with
| Some (String s) -> s | Some v -> value_to_string v | None -> "" in
let effects = match Hashtbl.find_opt d "effects" with
| Some (List items) -> String.concat ", " (List.map value_to_string items)
| Some Nil -> "none" | _ -> "none" in
let examples = match Hashtbl.find_opt d "examples" with
| Some (String s) -> " " ^ s
| Some (List items) ->
String.concat "\n" (List.map (fun ex -> " " ^ value_to_string ex) items)
| _ -> " (none)" in
text_result (Printf.sprintf "%s\n Category: %s\n Pattern: %s\n Effects: %s\n\n%s\n\nExamples:\n%s"
(get_str "name") (get_str "category") (get_str "pattern") effects
(get_str "rule") examples)
| _ ->
(* Try listing by category *)
let cats_fn = try env_get e "rules-by-category" with _ -> Nil in
let cat_results = try Sx_ref.cek_call cats_fn (List [String form_name]) with _ -> Nil in
(match cat_results with
| List items when items <> [] ->
let lines = List.map (fun rule ->
match rule with
| Dict rd ->
let name = match Hashtbl.find_opt rd "name" with Some (String s) -> s | _ -> "?" in
let pattern = match Hashtbl.find_opt rd "pattern" with Some (String s) -> s | _ -> "" in
Printf.sprintf " %-16s %s" name pattern
| _ -> " " ^ value_to_string rule
) items in
text_result (Printf.sprintf "Category: %s (%d rules)\n\n%s"
form_name (List.length items) (String.concat "\n" lines))
| _ ->
(* List all categories *)
let all_cats = try Sx_ref.cek_call (env_get e "rule-categories") Nil with _ -> Nil in
let cat_str = match all_cats with
| List items -> String.concat ", " (List.filter_map (fun v ->
match v with String s -> Some s | _ -> None) items)
| _ -> "?" in
error_result (Printf.sprintf "No rule found for '%s'. Categories: %s" form_name cat_str)))
(* ================================================================== *)
(* Server inspection tools *)
(* ================================================================== *)
| "sx_load_check" ->
(* Load all .sx files the HTTP server would load, report errors *)
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in
Filename.dirname spec_dir in
let spec_base = project_dir ^ "/spec" in
let lib_base = project_dir ^ "/lib" in
let web_base = project_dir ^ "/web" in
let shared_sx = project_dir ^ "/shared/sx/templates" in
let sx_sx =
let dp = project_dir ^ "/sx" in
let dv = project_dir ^ "/sx/sx" in
if Sys.file_exists (dp ^ "/page-functions.sx") then dp else dv in
let sx_sxc =
let dp = project_dir ^ "/sxc" in
let dv = project_dir ^ "/sx/sxc" in
if Sys.file_exists dp then dp else dv in
let skip_files = ["primitives.sx"; "types.sx"; "boundary.sx";
"harness.sx"; "eval-rules.sx"; "vm-inline.sx"] in
let skip_dirs = ["tests"; "test"; "plans"; "essays"; "spec"; "client-libs"] in
let errors = Buffer.create 256 in
let ok_count = ref 0 in
let err_count = ref 0 in
let test_env = Sx_types.make_env () in
(* Bind minimal stubs so files can define things *)
ignore (Sx_types.env_bind test_env "register-special-form!" (NativeFn ("register-special-form!", fun args ->
match args with [String _; _] -> Nil | _ -> Nil)));
ignore (Sx_types.env_bind test_env "*custom-special-forms*" (Dict (Hashtbl.create 0)));
let check_file path =
if Sys.file_exists path then begin
try
let exprs = Sx_parser.parse_file path in
ignore (List.length exprs);
incr ok_count
with e ->
incr err_count;
Buffer.add_string errors (Printf.sprintf " PARSE ERROR %s: %s\n" (Filename.basename path) (Printexc.to_string e))
end in
let rec check_dir dir =
if Sys.file_exists dir && Sys.is_directory dir then begin
let entries = Sys.readdir dir in
Array.sort String.compare entries;
Array.iter (fun f ->
let path = dir ^ "/" ^ f in
if Sys.is_directory path then begin
if not (List.mem f skip_dirs) then check_dir path
end else if Filename.check_suffix f ".sx"
&& not (List.mem f skip_files)
&& not (String.length f > 5 && String.sub f 0 5 = "test-")
&& not (Filename.check_suffix f ".test.sx") then
check_file path
) entries
end in
(* Check core files *)
List.iter check_file [
spec_base ^ "/parser.sx"; spec_base ^ "/render.sx"; spec_base ^ "/signals.sx";
lib_base ^ "/compiler.sx";
web_base ^ "/adapter-html.sx"; web_base ^ "/adapter-sx.sx";
web_base ^ "/web-forms.sx"; web_base ^ "/engine.sx";
web_base ^ "/request-handler.sx"; web_base ^ "/page-helpers.sx";
];
(* Check all dirs *)
check_dir lib_base;
check_dir shared_sx;
check_dir sx_sxc;
check_dir sx_sx;
if !err_count = 0 then
text_result (Printf.sprintf "OK — %d files parse cleanly" !ok_count)
else
text_result (Printf.sprintf "%d files OK, %d errors:\n%s" !ok_count !err_count (Buffer.contents errors))
| "sx_env" ->
(* Query running server for defined symbols *)
let pattern = args |> member "pattern" |> to_string_option |> Option.value ~default:"*" in
let type_filter = args |> member "type" |> to_string_option in
(* Search the MCP tool's own env *)
let e = !env in
let matches = ref [] in
Hashtbl.iter (fun id v ->
let name = Sx_types.unintern id in
let type_name = Sx_runtime.type_of v |> Sx_runtime.value_to_str in
let matches_pattern =
if pattern = "*" then true
else if String.length pattern > 0 && pattern.[String.length pattern - 1] = '*' then
let prefix = String.sub pattern 0 (String.length pattern - 1) in
String.length name >= String.length prefix &&
String.sub name 0 (String.length prefix) = prefix
else name = pattern in
let matches_type = match type_filter with
| None -> true | Some t -> type_name = "\"" ^ t ^ "\"" in
if matches_pattern && matches_type then
matches := (name, type_name) :: !matches
) e.bindings;
let sorted = List.sort (fun (a,_) (b,_) -> String.compare a b) !matches in
let lines = List.map (fun (name, tp) -> Printf.sprintf " %-40s %s" name tp) sorted in
text_result (Printf.sprintf "%d matches:\n%s" (List.length sorted) (String.concat "\n" lines))
| "sx_handler_list" ->
(* List all registered defhandler forms *)
let e = !env in
let handlers = ref [] in
Hashtbl.iter (fun id v ->
let name = Sx_types.unintern id in
if String.length name > 8 && String.sub name 0 8 = "handler:" then begin
let handler_name = String.sub name 8 (String.length name - 8) in
let method_ = match v with
| Dict d -> (match Hashtbl.find_opt d "method" with
| Some (String m) -> String.uppercase_ascii m
| Some (Keyword m) -> String.uppercase_ascii m
| _ -> "GET")
| _ -> "?" in
let path = match v with
| Dict d -> (match Hashtbl.find_opt d "path" with
| Some (String p) -> p | _ -> "(no path)")
| _ -> "?" in
handlers := (handler_name, method_, path) :: !handlers
end
) e.bindings;
let sorted = List.sort (fun (a,_,_) (b,_,_) -> String.compare a b) !handlers in
let lines = List.map (fun (name, m, p) ->
Printf.sprintf " %-6s %-20s %s" m name p) sorted in
if sorted = [] then
text_result "No handlers registered. Load handlers/examples.sx first."
else
text_result (Printf.sprintf "%d handlers:\n%s" (List.length sorted) (String.concat "\n" lines))
| "sx_page_list" ->
(* List all page functions by scanning page-functions.sx *)
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in
Filename.dirname spec_dir in
let pf_path =
let dp = project_dir ^ "/sx/page-functions.sx" in
let dv = project_dir ^ "/sx/sx/page-functions.sx" in
if Sys.file_exists dp then dp else dv in
if not (Sys.file_exists pf_path) then
error_result "page-functions.sx not found"
else begin
try
let exprs = Sx_parser.parse_file pf_path in
let pages = List.filter_map (fun expr ->
match expr with
| List (Symbol "define" :: Symbol name :: _) -> Some name
| List (Symbol "define" :: String name :: _) -> Some name
| _ -> None
) exprs in
let lines = List.map (fun name ->
Printf.sprintf " /sx/(%s)" name) pages in
text_result (Printf.sprintf "%d page functions:\n%s" (List.length pages) (String.concat "\n" lines))
with e ->
error_result (Printf.sprintf "Parse error: %s" (Printexc.to_string e))
end
| "sx_request" ->
(* Simulate HTTP request to running server *)
let url = args |> member "url" |> to_string in
let method_ = args |> member "method" |> to_string_option |> Option.value ~default:"GET" in
let port = 8013 in
let path = if String.length url > 0 && url.[0] = '/' then url
else if String.length url > 4 && String.sub url 0 4 = "http" then
try let i = String.index_from url 10 '/' in
String.sub url i (String.length url - i) with Not_found -> url
else "/" ^ url in
(try
let addr = Unix.ADDR_INET (Unix.inet_addr_loopback, port) in
let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
Unix.connect sock addr;
let request = Printf.sprintf "%s %s HTTP/1.1\r\nHost: localhost\r\nSX-Request: true\r\nConnection: close\r\n\r\n" method_ path in
let _ = Unix.write_substring sock request 0 (String.length request) in
let buf = Buffer.create 4096 in
let tmp = Bytes.create 4096 in
let rec read_all () =
let n = try Unix.read sock tmp 0 4096 with _ -> 0 in
if n > 0 then begin
Buffer.add_subbytes buf tmp 0 n;
read_all ()
end in
read_all ();
Unix.close sock;
let response = Buffer.contents buf in
(* Extract status line and body *)
let body_start =
let rec find i =
if i + 4 > String.length response then 0
else if String.sub response i 4 = "\r\n\r\n" then i + 4
else find (i + 1) in
find 0 in
let status_line = try String.sub response 0 (String.index response '\r')
with Not_found -> "?" in
let body = if body_start > 0 && body_start < String.length response then
String.sub response body_start (String.length response - body_start)
else response in
let body_preview = if String.length body > 2000 then
String.sub body 0 2000 ^ "\n... (" ^ string_of_int (String.length body) ^ " bytes total)"
else body in
text_result (Printf.sprintf "%s\nBody (%d bytes):\n%s" status_line (String.length body) body_preview)
with e ->
error_result (Printf.sprintf "Connection failed (server running on port %d?): %s" port (Printexc.to_string e)))
| _ -> error_result ("Unknown tool: " ^ name)
(* ------------------------------------------------------------------ *)
(* 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 "string"); ("description", `String "SX path, e.g. \"(0 2 1)\"")])
let dir_prop = ("dir", `Assoc [("type", `String "string"); ("description", `String "Directory to scan recursively")])
let tool_definitions = `List [
tool "sx_read_tree" "Read an .sx file as an annotated tree with path labels. Auto-summarises large files (>200 lines). Use focus to expand only matching subtrees, max_depth for depth limit, or max_lines+offset for pagination."
[file_prop;
("focus", `Assoc [("type", `String "string"); ("description", `String "Pattern — expand matching subtrees, collapse rest")]);
("max_depth", `Assoc [("type", `String "integer"); ("description", `String "Depth limit (like summarise)")]);
("max_lines", `Assoc [("type", `String "integer"); ("description", `String "Max lines to return (pagination)")]);
("offset", `Assoc [("type", `String "integer"); ("description", `String "Line offset for pagination (default 0)")])]
["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"];
tool "sx_eval" "Evaluate an SX expression. Environment has parser + tree-tools + primitives."
[("expr", `Assoc [("type", `String "string"); ("description", `String "SX expression to evaluate")])] ["expr"];
tool "sx_guard" "Evaluate with error recovery. Catches errors, shows component trace, and continues. Returns result + any conditions signaled."
[("expr", `Assoc [("type", `String "string"); ("description", `String "SX expression to evaluate with error recovery")]);
("file", `Assoc [("type", `String "string"); ("description", `String "Optional .sx file to load for definitions")])] ["expr"];
tool "sx_render_trace" "Render an SX expression to HTML with full dispatch tracing. Shows which render path each sub-expression takes."
[("expr", `Assoc [("type", `String "string"); ("description", `String "SX expression to render with tracing")]);
("file", `Assoc [("type", `String "string"); ("description", `String "Optional .sx file to load for definitions")])] ["expr"];
tool "sx_trace" "Step-through SX evaluation showing each CEK machine step (symbol lookups, function calls, returns). Set components_only=true for component entry/exit only."
[("expr", `Assoc [("type", `String "string"); ("description", `String "SX expression to trace")]);
("file", `Assoc [("type", `String "string"); ("description", `String "Optional .sx file to load for definitions")]);
("max_steps", `Assoc [("type", `String "integer"); ("description", `String "Max CEK steps to show (default: 200)")]);
("components_only", `Assoc [("type", `String "boolean"); ("description", `String "Show only component entry/exit events (default: false)")])] ["expr"];
tool "sx_explain" "Explain SX evaluation rules. Pass a form name (if, let, map, ...) or category (literal, special-form, higher-order, ...)."
[("name", `Assoc [("type", `String "string"); ("description", `String "Form name or category to explain")])] ["name"];
tool "sx_load_check" "Validate all .sx files that the HTTP server loads. Reports parse errors. No server needed."
[] [];
tool "sx_env" "Search defined symbols in the MCP environment. Supports wildcard patterns (e.g. \"handler:*\", \"~examples*\")."
[("pattern", `Assoc [("type", `String "string"); ("description", `String "Symbol name or pattern (* wildcard). Default: *")]);
("type", `Assoc [("type", `String "string"); ("description", `String "Filter by type: component, island, lambda, macro, native")])]
[];
tool "sx_handler_list" "List all registered defhandler forms with their HTTP methods and paths."
[] [];
tool "sx_page_list" "List all page functions from page-functions.sx with their URL patterns."
[] [];
tool "sx_request" "Send an HTTP request to the running SX server (localhost:8013). Returns status + response body."
[("url", `Assoc [("type", `String "string"); ("description", `String "URL path (e.g. /sx/(geography)) or full URL")]);
("method", `Assoc [("type", `String "string"); ("description", `String "HTTP method: GET (default), POST, PUT, DELETE")])]
["url"];
tool "sx_deps" "Dependency analysis for a component or file. Shows all referenced symbols and where they're defined."
[file_prop;
("name", `Assoc [("type", `String "string"); ("description", `String "Specific define/defcomp/defisland to analyze")]);
("dir", `Assoc [("type", `String "string"); ("description", `String "Directory to search for definitions (default: project root)")])] ["file"];
tool "sx_build_manifest" "Show build manifest: which modules, primitives, adapters, and exports are included in a JS or OCaml build."
[("target", `Assoc [("type", `String "string"); ("description", `String "Build target: \"js\" (default) or \"ocaml\"")])] [];
tool "sx_find_across" "Search for a pattern across all .sx files under a directory. Returns file paths, tree paths, and summaries."
[dir_prop; ("pattern", `Assoc [("type", `String "string"); ("description", `String "Search pattern")])] ["dir"; "pattern"];
tool "sx_comp_list" "List all definitions (defcomp, defisland, defmacro, defpage, define) across .sx files in a directory."
[dir_prop] ["dir"];
tool "sx_comp_usage" "Find all uses of a component or symbol name across .sx files in a directory."
[dir_prop; ("name", `Assoc [("type", `String "string"); ("description", `String "Component or symbol name to search for")])] ["dir"; "name"];
tool "sx_diff" "Structural diff between two .sx files. Reports ADDED, REMOVED, CHANGED nodes with paths."
[("file_a", `Assoc [("type", `String "string"); ("description", `String "Path to first .sx file")]);
("file_b", `Assoc [("type", `String "string"); ("description", `String "Path to second .sx file")])] ["file_a"; "file_b"];
tool "sx_format_check" "Lint an .sx file for common issues: empty let bindings, missing bodies, duplicate params, structural problems."
[file_prop] ["file"];
tool "sx_macroexpand" "Evaluate an SX expression with a file's definitions loaded. Use to test macros — the file's defmacro forms are available."
[("file", `Assoc [("type", `String "string"); ("description", `String "Optional .sx file to load for macro/component definitions")]);
("expr", `Assoc [("type", `String "string"); ("description", `String "Expression to expand/evaluate")])]
["expr"];
tool "sx_build" "Build the SX runtime. Target \"js\" (default) builds sx-browser.js, \"ocaml\" runs dune build, \"wasm\" does full pipeline (dune + bundle + bytecode compile + deploy to shared/static/wasm/). Set full=true for extensions+types."
[("target", `Assoc [("type", `String "string"); ("description", `String "Build target: \"js\" (default), \"ocaml\", or \"wasm\" (full WASM pipeline: build + bundle + bytecode + deploy)")]);
("full", `Assoc [("type", `String "boolean"); ("description", `String "Include extensions and type system (default: false)")])]
[];
tool "sx_build_bytecode" "Compile all web .sx files to pre-compiled .sxbc.json bytecode modules for the WASM browser kernel."
[] [];
tool "sx_test" "Run SX test suite. Returns pass/fail summary and any failures."
[("host", `Assoc [("type", `String "string"); ("description", `String "Test host: \"js\" (default) or \"ocaml\"")]);
("full", `Assoc [("type", `String "boolean"); ("description", `String "Run full test suite including extensions (default: false)")])]
[];
tool "sx_pretty_print" "Reformat an .sx file with indentation. Short forms stay on one line, longer forms break across lines."
[file_prop] ["file"];
tool "sx_write_file" "Create or overwrite an .sx file. Source is parsed first — malformed SX is rejected and the file is not touched."
[file_prop;
("source", `Assoc [("type", `String "string"); ("description", `String "SX source to write")])]
["file"; "source"];
tool "sx_rename_symbol" "Rename all occurrences of a symbol in an .sx file. Structural — only renames symbols, not strings."
[file_prop;
("old_name", `Assoc [("type", `String "string"); ("description", `String "Current symbol name")]);
("new_name", `Assoc [("type", `String "string"); ("description", `String "New symbol name")])]
["file"; "old_name"; "new_name"];
tool "sx_replace_by_pattern" "Find nodes matching a pattern and replace with new source. Set all=true to replace all matches (default: first only)."
[file_prop;
("pattern", `Assoc [("type", `String "string"); ("description", `String "Search pattern to match")]);
("new_source", `Assoc [("type", `String "string"); ("description", `String "Replacement SX source")]);
("all", `Assoc [("type", `String "boolean"); ("description", `String "Replace all matches (default: first only)")])]
["file"; "pattern"; "new_source"];
tool "sx_insert_near" "Insert new source before or after the first node matching a pattern. No path needed."
[file_prop;
("pattern", `Assoc [("type", `String "string"); ("description", `String "Pattern to find insertion point")]);
("new_source", `Assoc [("type", `String "string"); ("description", `String "SX source to insert")]);
("position", `Assoc [("type", `String "string"); ("description", `String "\"before\" or \"after\" (default: after)")])]
["file"; "pattern"; "new_source"];
tool "sx_rename_across" "Rename a symbol across all .sx files in a directory. Use dry_run=true to preview without writing."
[dir_prop;
("old_name", `Assoc [("type", `String "string"); ("description", `String "Current symbol name")]);
("new_name", `Assoc [("type", `String "string"); ("description", `String "New symbol name")]);
("dry_run", `Assoc [("type", `String "boolean"); ("description", `String "Preview changes without writing (default: false)")])]
["dir"; "old_name"; "new_name"];
tool "sx_changed" "List .sx files changed since a git ref (default: main) with depth-1 summaries."
[("ref", `Assoc [("type", `String "string"); ("description", `String "Git ref to diff against (default: main)")])]
[];
tool "sx_diff_branch" "Structural diff of all .sx changes on current branch vs a base ref. Shows ADDED/REMOVED/CHANGED per file."
[("ref", `Assoc [("type", `String "string"); ("description", `String "Base ref (default: main)")])]
[];
tool "sx_blame" "Git blame for an .sx file, optionally focused on a tree path."
[file_prop; path_prop] ["file"];
tool "sx_doc_gen" "Generate component documentation from all defcomp/defisland/defmacro signatures in a directory."
[dir_prop] ["dir"];
tool "sx_harness_eval" "Evaluate SX in a test harness with mock IO. Returns result + IO trace. Supports loading multiple files and setup expressions."
[("expr", `Assoc [("type", `String "string"); ("description", `String "SX expression to evaluate")]);
("mock", `Assoc [("type", `String "string"); ("description", `String "Optional mock platform overrides as SX dict, e.g. {:fetch (fn (url) {:status 200})}")]);
("file", `Assoc [("type", `String "string"); ("description", `String "Optional .sx file to load for definitions")]);
("files", `Assoc [("type", `String "array"); ("items", `Assoc [("type", `String "string")]); ("description", `String "Multiple .sx files to load in order")]);
("setup", `Assoc [("type", `String "string"); ("description", `String "SX setup expression to run before main evaluation")])]
["expr"];
tool "sx_nav" "Manage sx-docs navigation and articles. Modes: list (all nav items with status), check (validate consistency), add (create article + nav entry), delete (remove nav entry + page fn), move (move entry between sections, rewriting hrefs)."
[("mode", `Assoc [("type", `String "string"); ("description", `String "Mode: list, check, add, delete, or move")]);
("section", `Assoc [("type", `String "string"); ("description", `String "Nav section to filter (list), target section (add), or target section (move)")]);
("title", `Assoc [("type", `String "string"); ("description", `String "Article title (add mode)")]);
("slug", `Assoc [("type", `String "string"); ("description", `String "URL slug (add/delete/move modes, e.g. reactive-runtime)")]);
("from", `Assoc [("type", `String "string"); ("description", `String "Source section (move mode, e.g. applications)")]);
("to", `Assoc [("type", `String "string"); ("description", `String "Target section (move mode, e.g. geography)")])]
[];
tool "sx_playwright" "Run Playwright browser tests or inspect SX pages interactively. Modes: run (spec files), inspect (page/island report with leak detection and handler audit), diff (full SSR vs hydrated DOM), hydrate (lake-focused SSR vs hydrated comparison — detects clobbering), eval (JS expression), interact (action sequence), screenshot, listeners (CDP event listener inspection), trace (click + capture console/network/pushState), cdp (raw CDP command), trace-boot (full console capture during boot — ALL prefixes), hydrate-debug (re-run island hydration with full env/state tracing), eval-at (inject eval at a specific boot phase)."
[("spec", `Assoc [("type", `String "string"); ("description", `String "Spec file to run (run mode). e.g. stepper.spec.js")]);
("mode", `Assoc [("type", `String "string"); ("description", `String "Mode: run, inspect, diff, hydrate, eval, interact, screenshot, listeners, trace, cdp, trace-boot, hydrate-debug, eval-at")]);
("phase", `Assoc [("type", `String "string"); ("description", `String "Boot phase for eval-at mode: before-modules, after-modules, before-pages, after-pages, before-components, after-components, before-hydrate, after-hydrate, after-boot")]);
("filter", `Assoc [("type", `String "string"); ("description", `String "Filter prefix for trace-boot mode (e.g. '[sx-platform]')")]);
("url", `Assoc [("type", `String "string"); ("description", `String "URL path to navigate to (default: /)")]);
("island", `Assoc [("type", `String "string"); ("description", `String "Filter inspect to a specific island by name (e.g. home/stepper)")]);
("selector", `Assoc [("type", `String "string"); ("description", `String "CSS selector for screenshot/listeners/trace modes")]);
("expr", `Assoc [("type", `String "string"); ("description", `String "JS expression (eval mode), selector (listeners/trace), or CDP command (cdp mode)")]);
("actions", `Assoc [("type", `String "string"); ("description", `String "Semicolon-separated action sequence (interact mode). Actions: click:sel, fill:sel:val, wait:ms, text:sel, html:sel, attrs:sel, screenshot, screenshot:sel, count:sel, visible:sel")])]
[];
]
(* ------------------------------------------------------------------ *)
(* 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 View Git Blame Copy Permalink