giles
0f9bb68ba2
Logs timestamps, tool calls, errors, slow calls, stack overflow, OOM. Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
2937 lines
144 KiB
OCaml
2937 lines
144 KiB
OCaml
(** MCP server for SX tree tools — structural reading and editing of .sx files.
|
||
|
||
Stdio JSON-RPC transport following the MCP specification.
|
||
Loads tree-tools.sx into the SX evaluator and exposes comprehension
|
||
and editing functions as MCP tools. *)
|
||
|
||
open Sx_types
|
||
|
||
(* ------------------------------------------------------------------ *)
|
||
(* Hot-reload: re-exec ourselves when the binary has been rebuilt *)
|
||
(* ------------------------------------------------------------------ *)
|
||
|
||
(* ------------------------------------------------------------------ *)
|
||
(* File-based logging for debugging MCP failures *)
|
||
(* ------------------------------------------------------------------ *)
|
||
|
||
let log_file = "/tmp/mcp-tree.log"
|
||
|
||
let log_msg fmt =
|
||
Printf.ksprintf (fun msg ->
|
||
let oc = open_out_gen [Open_append; Open_creat; Open_wronly] 0o644 log_file in
|
||
let t = Unix.gettimeofday () in
|
||
let tm = Unix.localtime t in
|
||
Printf.fprintf oc "[%04d-%02d-%02d %02d:%02d:%02d.%03d] %s\n"
|
||
(1900 + tm.Unix.tm_year) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
|
||
tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
|
||
(int_of_float (mod_float (t *. 1000.0) 1000.0))
|
||
msg;
|
||
close_out oc
|
||
) fmt
|
||
|
||
let exe_path =
|
||
try Unix.readlink "/proc/self/exe"
|
||
with _ -> Sys.executable_name
|
||
|
||
let binary_mtime =
|
||
ref (try (Unix.stat exe_path).Unix.st_mtime with _ -> 0.0)
|
||
|
||
let check_hot_reload () =
|
||
try
|
||
let cur = (Unix.stat exe_path).Unix.st_mtime in
|
||
if cur > !binary_mtime then begin
|
||
Printf.eprintf "[mcp] Binary updated (%.0f -> %.0f), hot-reloading...\n%!" !binary_mtime cur;
|
||
Unix.execv exe_path [| exe_path |]
|
||
end
|
||
with _ -> ()
|
||
|
||
(* ------------------------------------------------------------------ *)
|
||
(* Robust JSON helpers — MCP clients send ints as strings or null *)
|
||
(* ------------------------------------------------------------------ *)
|
||
|
||
let to_int_safe json =
|
||
match json with
|
||
| `Int n -> Some n
|
||
| `Float f -> Some (int_of_float f)
|
||
| `String s -> (try Some (int_of_string s) with _ -> None)
|
||
| `Null -> None
|
||
| _ -> None
|
||
|
||
let to_int_or ~default json =
|
||
match to_int_safe json with Some n -> n | None -> default
|
||
|
||
(* ------------------------------------------------------------------ *)
|
||
(* 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
|
||
|
||
(* ------------------------------------------------------------------ *)
|
||
(* File mtime cache — like a running Lisp image, only reload changed *)
|
||
(* ------------------------------------------------------------------ *)
|
||
|
||
let file_mtimes : (string, float) Hashtbl.t = Hashtbl.create 32
|
||
|
||
let smart_load_file e path =
|
||
let abs = if Filename.is_relative path then Filename.concat (Sys.getcwd ()) path else path in
|
||
let cur_mtime = (Unix.stat abs).Unix.st_mtime in
|
||
let cached = try Some (Hashtbl.find file_mtimes abs) with Not_found -> None in
|
||
match cached with
|
||
| Some prev when prev >= cur_mtime -> false (* unchanged *)
|
||
| _ ->
|
||
load_sx_file e abs;
|
||
Hashtbl.replace file_mtimes abs cur_mtime;
|
||
true (* loaded *)
|
||
|
||
let smart_load_files e paths =
|
||
let loaded = ref [] in
|
||
List.iter (fun path ->
|
||
try
|
||
if smart_load_file e path then
|
||
loaded := path :: !loaded
|
||
with exn ->
|
||
loaded := (Printf.sprintf "%s (error: %s)" path (Printexc.to_string exn)) :: !loaded
|
||
) paths;
|
||
List.rev !loaded
|
||
|
||
(* JIT infrastructure — shared VM globals table, kept in sync via env_bind hook *)
|
||
let _mcp_vm_globals : (string, value) Hashtbl.t = Hashtbl.create 2048
|
||
let _jit_warned : (string, bool) Hashtbl.t = Hashtbl.create 32
|
||
|
||
let register_mcp_jit_hook () =
|
||
Sx_runtime._jit_try_call_fn := Some (fun f args ->
|
||
match f with
|
||
| Lambda l ->
|
||
let fn_name = match l.l_name with Some n -> n | None -> "" in
|
||
if fn_name <> "" && Hashtbl.mem _jit_warned fn_name then None
|
||
else
|
||
(match l.l_compiled with
|
||
| Some cl when not (Sx_vm.is_jit_failed cl) ->
|
||
(* Already compiled — run via VM. Skip during compilation. *)
|
||
if !(Sx_vm._jit_compiling) then None
|
||
else
|
||
(try Some (Sx_vm.call_closure_reuse cl args)
|
||
with
|
||
| Sx_vm.VmSuspended _ as e -> raise e (* let Fix 1 in jit_try_call handle it *)
|
||
| e ->
|
||
if not (Hashtbl.mem _jit_warned fn_name) then begin
|
||
Hashtbl.replace _jit_warned fn_name true;
|
||
Printf.eprintf "[mcp-jit] %s runtime fallback to CEK: %s\n%!" fn_name (Printexc.to_string e)
|
||
end;
|
||
l.l_compiled <- Some Sx_vm.jit_failed_sentinel;
|
||
None)
|
||
| Some _ -> None
|
||
| None ->
|
||
(* Only block NEW compilations during _jit_compiling *)
|
||
if !(Sx_vm._jit_compiling) then None
|
||
else
|
||
let compiled = Sx_vm.jit_compile_lambda l _mcp_vm_globals in
|
||
(match compiled with
|
||
| Some cl ->
|
||
l.l_compiled <- Some cl;
|
||
(try Some (Sx_vm.call_closure_reuse cl args)
|
||
with
|
||
| Sx_vm.VmSuspended _ as e -> raise e
|
||
| e ->
|
||
Printf.eprintf "[mcp-jit] %s first-call fallback: %s\n%!" fn_name (Printexc.to_string e);
|
||
Hashtbl.replace _jit_warned fn_name true;
|
||
l.l_compiled <- Some Sx_vm.jit_failed_sentinel;
|
||
None)
|
||
| None -> None))
|
||
| _ -> None)
|
||
|
||
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);
|
||
(* Seed VM globals with all primitives as NativeFn values.
|
||
Without this, OP_CALL_PRIM in JIT-compiled bytecode can't find
|
||
primitives and falls back to CEK — which causes cascading failures
|
||
for stdlib functions like nth/first that override native versions. *)
|
||
Hashtbl.iter (fun name fn ->
|
||
Hashtbl.replace _mcp_vm_globals name (NativeFn (name, fn))
|
||
) Sx_primitives.primitives;
|
||
(* JIT: mirror root-env bindings into shared VM globals table *)
|
||
Sx_types._env_bind_hook := Some (fun env name v ->
|
||
if env.parent = None then
|
||
if not (Sx_primitives.is_primitive name) then
|
||
Hashtbl.replace _mcp_vm_globals name v);
|
||
(* 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 SX modules with timing *)
|
||
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
|
||
let web_dir = try Sys.getenv "SX_WEB_DIR" with Not_found -> "web" in
|
||
let t0 = Unix.gettimeofday () in
|
||
let timed name f =
|
||
let t = Unix.gettimeofday () in
|
||
f ();
|
||
Printf.eprintf "[mcp] %s: %.0fms\n%!" name ((Unix.gettimeofday () -. t) *. 1000.0)
|
||
in
|
||
timed "parser.sx" (fun () ->
|
||
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));
|
||
timed "tree-tools.sx" (fun () ->
|
||
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);
|
||
timed "signals.sx" (fun () ->
|
||
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));
|
||
timed "render.sx" (fun () ->
|
||
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));
|
||
timed "adapter-html.sx" (fun () ->
|
||
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));
|
||
timed "harness.sx" (fun () ->
|
||
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));
|
||
timed "eval-rules.sx" (fun () ->
|
||
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));
|
||
(* 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)));
|
||
timed "compiler.sx+JIT" (fun () ->
|
||
try load_sx_file e (Filename.concat lib_dir "compiler.sx");
|
||
register_mcp_jit_hook ()
|
||
with exn -> Printf.eprintf "[mcp] Warning: compiler.sx load failed (JIT disabled): %s\n%!" (Printexc.to_string exn));
|
||
Printf.eprintf "[mcp] Ready in %.0fms\n%!" ((Unix.gettimeofday () -. t0) *. 1000.0);
|
||
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)
|
||
|
||
(* File parse cache — avoids re-parsing unchanged files *)
|
||
let _parse_cache : (string, float * value) Hashtbl.t = Hashtbl.create 32
|
||
let _parse_cst_cache : (string, float * value * Sx_parser.cst_file) Hashtbl.t = Hashtbl.create 32
|
||
let _max_cache_entries = 64
|
||
|
||
let cache_invalidate path =
|
||
Hashtbl.remove _parse_cache path;
|
||
Hashtbl.remove _parse_cst_cache path
|
||
|
||
let parse_file path =
|
||
let mtime = (Unix.stat path).Unix.st_mtime in
|
||
match Hashtbl.find_opt _parse_cache path with
|
||
| Some (cached_mtime, ast) when cached_mtime = mtime -> ast
|
||
| _ ->
|
||
if Hashtbl.length _parse_cache > _max_cache_entries then Hashtbl.clear _parse_cache;
|
||
let src = In_channel.with_open_text path In_channel.input_all in
|
||
let ast = List (Sx_parser.parse_all src) in
|
||
Hashtbl.replace _parse_cache path (mtime, ast);
|
||
ast
|
||
|
||
(* CST-based round-tripping — replaces comment_map machinery.
|
||
Parse file as CST for lossless writes, project to AST for tree-tools. *)
|
||
|
||
(* Parse file → (AST for tree-tools, CST for writing back) *)
|
||
let parse_file_cst path =
|
||
let mtime = (Unix.stat path).Unix.st_mtime in
|
||
match Hashtbl.find_opt _parse_cst_cache path with
|
||
| Some (cached_mtime, ast, cst) when cached_mtime = mtime -> (ast, cst)
|
||
| _ ->
|
||
if Hashtbl.length _parse_cst_cache > _max_cache_entries then Hashtbl.clear _parse_cst_cache;
|
||
let cst = Sx_parser.parse_file_cst path in
|
||
let ast = List (List.map Sx_cst.cst_to_ast cst.nodes) in
|
||
Hashtbl.replace _parse_cst_cache path (mtime, ast, cst);
|
||
(ast, cst)
|
||
|
||
(* Extract comment text from CST trivia for display in summarise/read_tree *)
|
||
let extract_cst_comments (cst : Sx_parser.cst_file) =
|
||
let tbl = Hashtbl.create 16 in
|
||
List.iteri (fun i node ->
|
||
let trivia = match node with
|
||
| Sx_cst.CstAtom r -> r.leading_trivia
|
||
| Sx_cst.CstList r -> r.leading_trivia
|
||
| Sx_cst.CstDict r -> r.leading_trivia
|
||
in
|
||
let comments = List.filter_map (function
|
||
| Sx_cst.LineComment text ->
|
||
(* Strip trailing newline for display *)
|
||
let t = if String.length text > 0 && text.[String.length text - 1] = '\n'
|
||
then String.sub text 0 (String.length text - 1) else text in
|
||
Some t
|
||
| _ -> None
|
||
) trivia in
|
||
if comments <> [] then
|
||
Hashtbl.replace tbl i comments
|
||
) cst.nodes;
|
||
tbl
|
||
|
||
(* Inject comment text into summarise/annotate output.
|
||
Matches [N] markers and inserts comment lines that precede expr N. *)
|
||
let inject_cst_comments output comment_tbl =
|
||
if Hashtbl.length comment_tbl = 0 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 ->
|
||
let idx = if String.length line > 1 && line.[0] = '[' then
|
||
(try Scanf.sscanf line "[%d]" (fun n -> Some n) with _ -> None)
|
||
else
|
||
let trimmed = String.trim line in
|
||
if String.length trimmed > 1 && trimmed.[0] = '[' then
|
||
(try Scanf.sscanf trimmed "[%d]" (fun n -> Some n) with _ -> None)
|
||
else None
|
||
in
|
||
(match idx with
|
||
| Some n ->
|
||
(match Hashtbl.find_opt comment_tbl n with
|
||
| Some comments ->
|
||
List.iter (fun text ->
|
||
if not !first then Buffer.add_char buf '\n';
|
||
first := false;
|
||
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
|
||
|
||
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 and has no comments *)
|
||
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
|
||
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
|
||
|
||
|
||
|
||
(* Apply an AST-level edit result back to the CST and write the file.
|
||
Unchanged nodes keep their original source; changed nodes are pretty-printed
|
||
with the original leading trivia preserved. *)
|
||
let write_edit_cst file (cst : Sx_parser.cst_file) result =
|
||
match result with
|
||
| Dict d ->
|
||
(match Hashtbl.find_opt d "ok" with
|
||
| Some new_tree ->
|
||
let new_items = match new_tree with
|
||
| List items | ListRef { contents = items } -> items
|
||
| _ -> [new_tree]
|
||
in
|
||
let old_nodes = cst.nodes in
|
||
let old_asts = List.map Sx_cst.cst_to_ast old_nodes in
|
||
let new_cst_nodes = List.mapi (fun i new_ast ->
|
||
if i < List.length old_nodes then
|
||
let old_ast = List.nth old_asts i in
|
||
if inspect old_ast = inspect new_ast then
|
||
List.nth old_nodes i
|
||
else
|
||
let pp = pretty_print_value new_ast in
|
||
let new_cst = Sx_parser.parse_all_cst pp in
|
||
let orig_trivia = match List.nth old_nodes i with
|
||
| Sx_cst.CstAtom r -> r.leading_trivia
|
||
| Sx_cst.CstList r -> r.leading_trivia
|
||
| Sx_cst.CstDict r -> r.leading_trivia
|
||
in
|
||
(match new_cst.nodes with
|
||
| [node] ->
|
||
(match node with
|
||
| Sx_cst.CstAtom r -> Sx_cst.CstAtom { r with leading_trivia = orig_trivia }
|
||
| Sx_cst.CstList r -> Sx_cst.CstList { r with leading_trivia = orig_trivia }
|
||
| Sx_cst.CstDict r -> Sx_cst.CstDict { r with leading_trivia = orig_trivia })
|
||
| _ -> List.nth old_nodes i)
|
||
else
|
||
let pp = pretty_print_value new_ast in
|
||
let new_cst = Sx_parser.parse_all_cst ("\n\n" ^ pp) in
|
||
(match new_cst.nodes with node :: _ -> node | [] ->
|
||
Sx_cst.CstAtom { leading_trivia = []; token = pp;
|
||
value = new_ast; span = { start_offset = 0; end_offset = 0 } })
|
||
) new_items in
|
||
let source = Sx_cst.cst_file_to_source new_cst_nodes cst.trailing_trivia in
|
||
Out_channel.with_open_text file (fun oc -> output_string oc source);
|
||
cache_invalidate file;
|
||
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"
|
||
|
||
(* ------------------------------------------------------------------ *)
|
||
(* Infrastructure helpers *)
|
||
(* ------------------------------------------------------------------ *)
|
||
|
||
let run_command cmd =
|
||
let ic = Unix.open_process_in cmd in
|
||
let buf = Buffer.create 4096 in
|
||
(try while true do
|
||
if Buffer.length buf > 0 then Buffer.add_char buf '\n';
|
||
Buffer.add_string buf (input_line ic)
|
||
done with End_of_file -> ());
|
||
let status = Unix.close_process_in ic in
|
||
let code = match status with Unix.WEXITED n -> n | _ -> 1 in
|
||
(code, Buffer.contents buf)
|
||
|
||
let require_file args key =
|
||
let open Yojson.Safe.Util in
|
||
let path = args |> member key |> to_string in
|
||
if not (Sys.file_exists path) then
|
||
raise (Invalid_argument (Printf.sprintf "File not found: %s" path));
|
||
path
|
||
|
||
let require_dir args key =
|
||
let open Yojson.Safe.Util in
|
||
let path = args |> member key |> to_string in
|
||
if not (Sys.file_exists path) then
|
||
raise (Invalid_argument (Printf.sprintf "Directory not found: %s" path))
|
||
else if not (Sys.is_directory path) then
|
||
raise (Invalid_argument (Printf.sprintf "Not a directory: %s" path));
|
||
path
|
||
|
||
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
|
||
|
||
(* ------------------------------------------------------------------ *)
|
||
(* Tool dispatch table *)
|
||
(* ------------------------------------------------------------------ *)
|
||
|
||
let tool_handlers : (string, Yojson.Safe.t -> Yojson.Safe.t) Hashtbl.t = Hashtbl.create 64
|
||
let register name f = Hashtbl.replace tool_handlers name f
|
||
|
||
(* ------------------------------------------------------------------ *)
|
||
(* Tool handlers *)
|
||
(* ------------------------------------------------------------------ *)
|
||
|
||
let handle_sx_read_tree args =
|
||
let open Yojson.Safe.Util in
|
||
let file = require_file args "file" in
|
||
let tree, cst = parse_file_cst file in
|
||
let focus = args |> member "focus" |> to_string_option in
|
||
let max_depth = to_int_safe (args |> member "max_depth") in
|
||
let max_lines = to_int_safe (args |> member "max_lines") in
|
||
let offset = to_int_or ~default:0 (args |> member "offset") in
|
||
(match focus with
|
||
| Some pattern ->
|
||
text_result (inject_cst_comments (value_to_string (call_sx "annotate-focused" [tree; String pattern])) (extract_cst_comments cst))
|
||
| None ->
|
||
match max_lines with
|
||
| Some limit ->
|
||
text_result (inject_cst_comments (value_to_string (call_sx "annotate-paginated"
|
||
[tree; Number (float_of_int offset); Number (float_of_int limit)])) (extract_cst_comments cst))
|
||
| None ->
|
||
match max_depth with
|
||
| Some depth ->
|
||
text_result (inject_cst_comments (value_to_string (call_sx "summarise" [tree; Number (float_of_int depth)])) (extract_cst_comments cst))
|
||
| 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_cst_comments full (extract_cst_comments cst))
|
||
else
|
||
let summary = value_to_string (call_sx "summarise" [tree; Number 2.0]) in
|
||
text_result (inject_cst_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) (extract_cst_comments cst)))
|
||
|
||
let handle_sx_summarise args =
|
||
let open Yojson.Safe.Util in
|
||
let file = require_file args "file" in
|
||
let tree, cst = parse_file_cst file in
|
||
let depth = to_int_or ~default:2 (args |> member "depth") in
|
||
text_result (inject_cst_comments (value_to_string (call_sx "summarise" [tree; Number (float_of_int depth)])) (extract_cst_comments cst))
|
||
|
||
let handle_sx_read_subtree args =
|
||
let open Yojson.Safe.Util in
|
||
let tree = parse_file (require_file args "file") in
|
||
let path = resolve_path tree (args |> member "path" |> to_string) in
|
||
text_result (value_to_string (call_sx "read-subtree" [tree; path]))
|
||
|
||
let handle_sx_get_context args =
|
||
let open Yojson.Safe.Util in
|
||
let tree = parse_file (require_file args "file") in
|
||
let path = resolve_path tree (args |> member "path" |> to_string) in
|
||
text_result (value_to_string (call_sx "get-context" [tree; path]))
|
||
|
||
let handle_sx_find_all args =
|
||
let open Yojson.Safe.Util in
|
||
let tree = parse_file (require_file args "file") 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)
|
||
|
||
let handle_sx_get_siblings args =
|
||
let open Yojson.Safe.Util in
|
||
let file = require_file args "file" in
|
||
let tree, cst = parse_file_cst file in
|
||
let path = resolve_path tree (args |> member "path" |> to_string) in
|
||
let output = value_to_string (call_sx "get-siblings" [tree; path]) in
|
||
(* Inject comments for top-level siblings *)
|
||
let is_top_level = match path with
|
||
| List [Number _] | List [Number _; Number _] -> true
|
||
| _ -> false in
|
||
text_result (if is_top_level then inject_cst_comments output (extract_cst_comments cst) else output)
|
||
|
||
let handle_sx_validate args =
|
||
let tree = parse_file (require_file args "file") in
|
||
text_result (value_to_string (call_sx "validate" [tree]))
|
||
|
||
let handle_sx_replace_node args =
|
||
let open Yojson.Safe.Util in
|
||
let file = require_file args "file" in
|
||
let tree, cst = parse_file_cst file in
|
||
let path = resolve_path tree (args |> member "path" |> to_string) in
|
||
let src = args |> member "new_source" |> to_string in
|
||
write_edit_cst file cst (call_sx "replace-node" [tree; path; String src])
|
||
|
||
let handle_sx_insert_child args =
|
||
let open Yojson.Safe.Util in
|
||
let file = require_file args "file" in
|
||
let tree, cst = parse_file_cst file in
|
||
let path = resolve_path tree (args |> member "path" |> to_string) in
|
||
let index = to_int_or ~default:0 (args |> member "index") in
|
||
let src = args |> member "new_source" |> to_string in
|
||
write_edit_cst file cst (call_sx "insert-child" [tree; path; Number (float_of_int index); String src])
|
||
|
||
let handle_sx_delete_node args =
|
||
let open Yojson.Safe.Util in
|
||
let file = require_file args "file" in
|
||
let tree, cst = parse_file_cst file in
|
||
let path = resolve_path tree (args |> member "path" |> to_string) in
|
||
write_edit_cst file cst (call_sx "delete-node" [tree; path])
|
||
|
||
let handle_sx_wrap_node args =
|
||
let open Yojson.Safe.Util in
|
||
let file = require_file args "file" in
|
||
let tree, cst = parse_file_cst file in
|
||
let path = resolve_path tree (args |> member "path" |> to_string) in
|
||
let wrapper = args |> member "wrapper" |> to_string in
|
||
write_edit_cst file cst (call_sx "wrap-node" [tree; path; String wrapper])
|
||
|
||
let handle_sx_format_check args =
|
||
let file = require_file args "file" 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))
|
||
|
||
let handle_sx_macroexpand args =
|
||
let open Yojson.Safe.Util in
|
||
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)
|
||
|
||
let handle_sx_build args =
|
||
let open Yojson.Safe.Util in
|
||
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 pd = project_dir () in
|
||
let cmd = match target with
|
||
| "ocaml" ->
|
||
let abs_project = if Filename.is_relative pd then Sys.getcwd () ^ "/" ^ pd else pd in
|
||
(* Remove assets dir that conflicts with dune's browser target, then build *)
|
||
Printf.sprintf "cd %s/hosts/ocaml && rm -rf browser/sx_browser.bc.wasm.assets && 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 && rm -rf %s/shared/static/wasm/sx_browser.bc.wasm.assets && cp -r _build/default/browser/sx_browser.bc.wasm.assets %s/shared/static/wasm/ && cp -r _build/default/browser/sx_browser.bc.wasm.assets browser/" abs_project abs_project abs_project abs_project abs_project
|
||
| "wasm" ->
|
||
let abs_project = if Filename.is_relative pd then Sys.getcwd () ^ "/" ^ pd else pd 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" pd extra
|
||
in
|
||
let (code, output) = run_command cmd in
|
||
if code = 0 then text_result (Printf.sprintf "OK — %s build succeeded\n%s" target (String.trim output))
|
||
else error_result (Printf.sprintf "%s build failed:\n%s" target output)
|
||
|
||
let handle_sx_build_bytecode _args =
|
||
ignore _args;
|
||
let pd = project_dir () in
|
||
let sx_dir = pd ^ "/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)
|
||
|
||
let handle_sx_test args =
|
||
let open Yojson.Safe.Util in
|
||
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 pd = project_dir () in
|
||
let timeout = to_int_or ~default:300 (args |> member "timeout") in
|
||
let cmd = match host with
|
||
| "ocaml" ->
|
||
(* Use pre-built binary directly — avoids dune rebuild delay.
|
||
Falls back to dune exec if the binary doesn't exist. *)
|
||
let exe = Printf.sprintf "%s/hosts/ocaml/_build/default/bin/run_tests.exe" pd in
|
||
if Sys.file_exists exe then
|
||
Printf.sprintf "cd %s/hosts/ocaml && timeout %d %s%s 2>&1"
|
||
pd timeout exe (if full then " --full" else "")
|
||
else
|
||
Printf.sprintf "cd %s/hosts/ocaml && eval $(opam env 2>/dev/null) && timeout %d dune exec bin/run_tests.exe%s 2>&1"
|
||
pd timeout (if full then " -- --full" else "")
|
||
| "js" | _ ->
|
||
Printf.sprintf "cd %s && timeout %d node hosts/javascript/run_tests.js%s 2>&1"
|
||
pd timeout (if full then " --full" else "")
|
||
in
|
||
let (_code, output) = run_command cmd in
|
||
let all_lines = String.split_on_char '\n' output 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
|
||
|
||
let handle_sx_pretty_print args =
|
||
let open Yojson.Safe.Util in
|
||
let file = args |> member "file" |> to_string in
|
||
let cst = Sx_parser.parse_file_cst file in
|
||
(* Reformat each node's code while preserving trivia (comments, spacing) *)
|
||
let reformatted = List.map (fun node ->
|
||
let trivia = match node with
|
||
| Sx_cst.CstAtom r -> r.leading_trivia
|
||
| Sx_cst.CstList r -> r.leading_trivia
|
||
| Sx_cst.CstDict r -> r.leading_trivia
|
||
in
|
||
let ast = Sx_cst.cst_to_ast node in
|
||
let pp = pretty_print_value ast in
|
||
let new_cst = Sx_parser.parse_all_cst pp in
|
||
match new_cst.nodes with
|
||
| [n] ->
|
||
(match n with
|
||
| Sx_cst.CstAtom r -> Sx_cst.CstAtom { r with leading_trivia = trivia }
|
||
| Sx_cst.CstList r -> Sx_cst.CstList { r with leading_trivia = trivia }
|
||
| Sx_cst.CstDict r -> Sx_cst.CstDict { r with leading_trivia = trivia })
|
||
| _ -> node
|
||
) cst.nodes in
|
||
let source = Sx_cst.cst_file_to_source reformatted cst.trailing_trivia in
|
||
Out_channel.with_open_text file (fun oc -> output_string oc source);
|
||
cache_invalidate file;
|
||
text_result (Printf.sprintf "OK — reformatted %s (%d bytes, %d forms)" file (String.length source) (List.length cst.nodes))
|
||
|
||
let handle_sx_changed args =
|
||
let open Yojson.Safe.Util in
|
||
let base_ref = args |> member "ref" |> to_string_option |> Option.value ~default:"main" in
|
||
let pd = project_dir () in
|
||
let cmd = Printf.sprintf "cd %s && git diff --name-only %s -- '*.sx' '*.sxc' 2>/dev/null" pd base_ref in
|
||
let (_code, output) = run_command cmd in
|
||
let changed = if output = "" then [] else String.split_on_char '\n' output 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 pd 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
|
||
|
||
let handle_sx_diff_branch args =
|
||
let open Yojson.Safe.Util in
|
||
let base_ref = args |> member "ref" |> to_string_option |> Option.value ~default:"main" in
|
||
let pd = project_dir () in
|
||
let cmd = Printf.sprintf "cd %s && git diff --name-only %s -- '*.sx' '*.sxc' 2>/dev/null" pd base_ref in
|
||
let (_code, output) = run_command cmd in
|
||
let changed = if output = "" then [] else String.split_on_char '\n' output 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 pd rel in
|
||
(* Get the base version via git show *)
|
||
let base_cmd = Printf.sprintf "cd %s && git show %s:%s 2>/dev/null" pd base_ref rel in
|
||
let (_base_code, base_src) = run_command base_cmd 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
|
||
|
||
let handle_sx_blame args =
|
||
let open Yojson.Safe.Util in
|
||
let file = require_file args "file" in
|
||
let path_str_arg = args |> member "path" |> to_string_option in
|
||
let pd = project_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:pd 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" pd escaped rel_file rel_file
|
||
| None ->
|
||
Printf.sprintf "cd %s && git blame -- %s 2>/dev/null | head -30" pd rel_file
|
||
in
|
||
let (_code, output) = run_command cmd in
|
||
text_result output
|
||
|
||
let handle_sx_doc_gen args =
|
||
let dir = require_dir args "dir" in
|
||
let files = glob_sx_files dir in
|
||
let strip_comment_prefix text =
|
||
let lines = String.split_on_char '\n' text in
|
||
let cleaned = List.map (fun line ->
|
||
let s = String.trim line in
|
||
if String.length s >= 3 && s.[0] = ';' && s.[1] = ';' && s.[2] = ' ' then
|
||
String.sub s 3 (String.length s - 3)
|
||
else if String.length s >= 2 && s.[0] = ';' && s.[1] = ';' then
|
||
String.sub s 2 (String.length s - 2)
|
||
else s
|
||
) lines in
|
||
(* Filter out section divider lines (═══, ---) *)
|
||
let non_dividers = List.filter (fun s ->
|
||
not (String.length s > 3 && (s.[0] = '=' || s.[0] = '-' || s.[0] = '#'))
|
||
) cleaned in
|
||
let trimmed = List.filter (fun s -> String.trim s <> "") non_dividers in
|
||
String.concat "\n" trimmed
|
||
in
|
||
let all_docs = List.concat_map (fun path ->
|
||
let rel = relative_path ~base:dir path in
|
||
try
|
||
let cst = Sx_parser.parse_file_cst path in
|
||
List.filter_map (fun node ->
|
||
(* Extract leading comment trivia from CST node *)
|
||
let trivia = match node with
|
||
| Sx_cst.CstAtom r -> r.leading_trivia
|
||
| Sx_cst.CstList r -> r.leading_trivia
|
||
| Sx_cst.CstDict r -> r.leading_trivia
|
||
in
|
||
let comment_text = List.filter_map (function
|
||
| Sx_cst.LineComment text -> Some text | _ -> None
|
||
) trivia in
|
||
let prev_comment = if comment_text = [] then None
|
||
else Some (String.concat "" comment_text) in
|
||
let expr = Sx_cst.cst_to_ast node in
|
||
match expr with
|
||
| List (Symbol head :: Symbol name :: params_rest)
|
||
| ListRef { contents = Symbol head :: Symbol name :: params_rest } ->
|
||
(match head with
|
||
| "defcomp" | "defisland" ->
|
||
let params_str = match params_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
|
||
let comment_str = match prev_comment with
|
||
| Some text ->
|
||
let cleaned = strip_comment_prefix text in
|
||
if cleaned = "" then "" else " " ^ cleaned ^ "\n"
|
||
| None -> ""
|
||
in
|
||
Some (Printf.sprintf "## %s `%s`\nDefined in: %s\nType: %s\n%s%s" head name rel head comment_str params_str)
|
||
| "defmacro" ->
|
||
let comment_str = match prev_comment with
|
||
| Some text ->
|
||
let cleaned = strip_comment_prefix text in
|
||
if cleaned = "" then "" else " " ^ cleaned ^ "\n"
|
||
| None -> ""
|
||
in
|
||
Some (Printf.sprintf "## %s `%s`\nDefined in: %s\nType: macro\n%s" head name rel comment_str)
|
||
| _ -> None)
|
||
| _ -> None
|
||
) cst.nodes
|
||
with _ -> []
|
||
) files in
|
||
if all_docs = [] then text_result "(no components found)"
|
||
else text_result (String.concat "\n" all_docs)
|
||
|
||
let handle_sx_nav args =
|
||
let open Yojson.Safe.Util in
|
||
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);
|
||
cache_invalidate file;
|
||
(* 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);
|
||
cache_invalidate pf;
|
||
(* 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);
|
||
cache_invalidate nf;
|
||
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);
|
||
cache_invalidate nf;
|
||
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 begin
|
||
Out_channel.with_open_text tf (fun oc -> output_string oc ts2);
|
||
cache_invalidate tf
|
||
end;
|
||
(* 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);
|
||
cache_invalidate pf;
|
||
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);
|
||
cache_invalidate nf;
|
||
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);
|
||
cache_invalidate tf;
|
||
(* 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);
|
||
cache_invalidate pf;
|
||
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))
|
||
|
||
let handle_sx_playwright args =
|
||
let open Yojson.Safe.Util in
|
||
let pd = project_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
|
||
let setup = args |> member "setup" |> to_string_option in
|
||
let stack = args |> member "stack" |> to_string_option in
|
||
let bytecode = try args |> member "bytecode" |> to_bool with _ -> false in
|
||
let files_json = try args |> member "files" with _ -> `Null 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" pd spec_arg in
|
||
let (_code, output) = run_command cmd in
|
||
let all_lines = String.split_on_char '\n' output 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);
|
||
(match setup with Some s -> Some ("setup", `String s) | None -> None);
|
||
(match stack with Some s -> Some ("stack", `String s) | None -> None);
|
||
(if bytecode then Some ("bytecode", `Bool true) else None);
|
||
(match files_json with
|
||
| `List items -> Some ("files", `List (List.map (fun j -> `String (Yojson.Safe.Util.to_string j)) items))
|
||
| _ -> 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" pd shell_safe in
|
||
let (_code, raw) = run_command cmd 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
|
||
|
||
let handle_sx_harness_eval args =
|
||
let open Yojson.Safe.Util in
|
||
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
|
||
(* Smart-load files — only re-evaluate if source changed *)
|
||
let reloaded = smart_load_files e all_files in
|
||
List.iter (fun r ->
|
||
if String.contains r '(' then (* error entries contain parens *)
|
||
warnings := Printf.sprintf "Warning: %s" r :: !warnings
|
||
) reloaded;
|
||
(* 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 — evaluate so fn exprs become lambdas *)
|
||
let mock_arg = match mock_str with
|
||
| Some s ->
|
||
let parsed = Sx_parser.parse_all s in
|
||
if parsed <> [] then
|
||
let evaluated = Sx_ref.eval_expr (List.hd parsed) (Env e) in
|
||
List [Keyword "platform"; evaluated]
|
||
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]);
|
||
(* IO-aware eval: drives cek_step_loop + cek_resume to handle perform *)
|
||
let io_log = ref [] in
|
||
let eval_with_io expr =
|
||
let state = Sx_ref.make_cek_state expr (Env e) (List []) in
|
||
let rec drive st =
|
||
let final = Sx_ref.cek_step_loop st in
|
||
match Sx_ref.cek_suspended_p final with
|
||
| Bool true ->
|
||
let request = Sx_runtime.get_val final (String "request") in
|
||
io_log := request :: !io_log;
|
||
let resumed = Sx_ref.cek_resume final Nil in
|
||
drive resumed
|
||
| _ -> Sx_ref.cek_value final
|
||
in
|
||
drive state
|
||
in
|
||
(* Evaluate the expression *)
|
||
let exprs = Sx_parser.parse_all expr_str in
|
||
let result = List.fold_left (fun _acc expr ->
|
||
try eval_with_io expr
|
||
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)
|
||
| _ ->
|
||
if !io_log <> [] then
|
||
"\n\nIO suspensions (" ^ string_of_int (List.length !io_log) ^ "):\n" ^
|
||
String.concat "\n" (List.rev_map (fun req ->
|
||
" (perform " ^ Sx_types.inspect req ^ ")"
|
||
) !io_log)
|
||
else "\n\n(no IO calls)"
|
||
in
|
||
let warn_str = if !warnings = [] then "" else
|
||
"\n\nWarnings:\n" ^ String.concat "\n" (List.rev !warnings)
|
||
in
|
||
let reload_str = if reloaded = [] then "" else
|
||
"\n\nReloaded: " ^ String.concat ", " (List.map Filename.basename reloaded) in
|
||
text_result (Printf.sprintf "Result: %s%s%s%s" (Sx_types.inspect result) log_str reload_str warn_str)
|
||
|
||
let handle_sx_write_file args =
|
||
let open Yojson.Safe.Util in
|
||
let file = args |> member "file" |> to_string in
|
||
let source = args |> member "source" |> to_string in
|
||
(* Validate by parsing as CST — preserves comments and formatting *)
|
||
(try
|
||
let cst = Sx_parser.parse_all_cst source in
|
||
if cst.nodes = [] then error_result "Source parsed to empty — nothing to write"
|
||
else begin
|
||
(* Pretty-print each node but keep trivia *)
|
||
let reformatted = List.map (fun node ->
|
||
let trivia = match node with
|
||
| Sx_cst.CstAtom r -> r.leading_trivia
|
||
| Sx_cst.CstList r -> r.leading_trivia
|
||
| Sx_cst.CstDict r -> r.leading_trivia
|
||
in
|
||
let ast = Sx_cst.cst_to_ast node in
|
||
let pp = pretty_print_value ast in
|
||
let new_cst = Sx_parser.parse_all_cst pp in
|
||
match new_cst.nodes with
|
||
| [n] ->
|
||
(match n with
|
||
| Sx_cst.CstAtom r -> Sx_cst.CstAtom { r with leading_trivia = trivia }
|
||
| Sx_cst.CstList r -> Sx_cst.CstList { r with leading_trivia = trivia }
|
||
| Sx_cst.CstDict r -> Sx_cst.CstDict { r with leading_trivia = trivia })
|
||
| _ -> node
|
||
) cst.nodes in
|
||
let output = Sx_cst.cst_file_to_source reformatted cst.trailing_trivia in
|
||
Out_channel.with_open_text file (fun oc -> output_string oc output);
|
||
cache_invalidate file;
|
||
text_result (Printf.sprintf "OK — wrote %d bytes (%d top-level forms) to %s" (String.length output) (List.length cst.nodes) file)
|
||
end
|
||
with e -> error_result (Printf.sprintf "Parse error — file not written: %s" (Printexc.to_string e)))
|
||
|
||
let handle_sx_rename_symbol args =
|
||
let open Yojson.Safe.Util in
|
||
let file = require_file args "file" in
|
||
let tree, cst = parse_file_cst 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_cst file cst (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)
|
||
|
||
let handle_sx_replace_by_pattern args =
|
||
let open Yojson.Safe.Util in
|
||
let file = require_file args "file" in
|
||
let tree, cst = parse_file_cst 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_cst file cst (call_sx "replace-all-by-pattern" [tree; String pattern; String src])
|
||
else
|
||
write_edit_cst file cst (call_sx "replace-by-pattern" [tree; String pattern; String src])
|
||
|
||
let handle_sx_insert_near args =
|
||
let open Yojson.Safe.Util in
|
||
let file = require_file args "file" in
|
||
let tree, cst = parse_file_cst 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_cst file cst (call_sx "insert-near-pattern" [tree; String pattern; String position; String src])
|
||
|
||
let handle_sx_rename_across args =
|
||
let open Yojson.Safe.Util in
|
||
let dir = require_dir args "dir" 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, cst = parse_file_cst 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 result = Dict (let d = Hashtbl.create 2 in Hashtbl.replace d "ok" new_tree; d) in
|
||
ignore (write_edit_cst path cst result);
|
||
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)
|
||
|
||
let handle_sx_comp_list args =
|
||
let open Yojson.Safe.Util in
|
||
let dir = require_dir args "dir" in
|
||
let limit = to_int_or ~default:200 (args |> member "limit") in
|
||
let offset = to_int_or ~default:0 (args |> member "offset") 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
|
||
let total = List.length all_lines in
|
||
let page = all_lines |> List.filteri (fun i _ -> i >= offset && i < offset + limit) in
|
||
text_result (Printf.sprintf "%-10s %-40s %-50s %s (showing %d-%d of %d)\n%s" "TYPE" "NAME" "FILE" "PARAMS" offset (offset + List.length page) total (String.concat "\n" page))
|
||
|
||
let handle_sx_find_across args =
|
||
let open Yojson.Safe.Util in
|
||
let dir = require_dir args "dir" in
|
||
let limit = to_int_or ~default:200 (args |> member "limit") in
|
||
let offset = to_int_or ~default:0 (args |> member "offset") 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
|
||
let total = List.length all_lines in
|
||
let page = all_lines |> List.filteri (fun i _ -> i >= offset && i < offset + limit) in
|
||
text_result (Printf.sprintf "(showing %d-%d of %d)\n%s" offset (offset + List.length page) total (String.concat "\n" page))
|
||
|
||
let handle_sx_diff args =
|
||
let file_a = require_file args "file_a" in
|
||
let file_b = require_file args "file_b" 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]))
|
||
|
||
let handle_sx_comp_usage args =
|
||
let open Yojson.Safe.Util in
|
||
let dir = require_dir args "dir" in
|
||
let limit = to_int_or ~default:200 (args |> member "limit") in
|
||
let offset = to_int_or ~default:0 (args |> member "offset") 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
|
||
let total = List.length all_lines in
|
||
let page = all_lines |> List.filteri (fun i _ -> i >= offset && i < offset + limit) in
|
||
text_result (Printf.sprintf "(showing %d-%d of %d)\n%s" offset (offset + List.length page) total (String.concat "\n" page))
|
||
|
||
let handle_sx_eval args =
|
||
let open Yojson.Safe.Util in
|
||
let expr_str = args |> member "expr" |> to_string in
|
||
let e = !env in
|
||
(* Smart-load files — only re-evaluate if source changed *)
|
||
let files_json = try args |> member "files" with _ -> `Null in
|
||
let file = try args |> member "file" |> to_string_option with _ -> None in
|
||
let all_files = match files_json with
|
||
| `List items -> List.map Yojson.Safe.Util.to_string items
|
||
| _ -> match file with Some f -> [f] | None -> []
|
||
in
|
||
let reloaded = smart_load_files e all_files in
|
||
(* Optional IO tracing via harness *)
|
||
let trace_io = try args |> member "trace_io" |> to_bool with _ -> false in
|
||
let session = if trace_io then begin
|
||
let mock_str = try args |> member "mock" |> to_string_option with _ -> None in
|
||
let mock_arg = match mock_str with
|
||
| Some s ->
|
||
let parsed = Sx_parser.parse_all s in
|
||
if parsed <> [] then
|
||
let evaluated = Sx_ref.eval_expr (List.hd parsed) (Env e) in
|
||
List [Keyword "platform"; evaluated]
|
||
else List []
|
||
| None -> List []
|
||
in
|
||
let s = Sx_ref.cek_call (env_get e "make-harness") mock_arg in
|
||
ignore (call_sx "install-interceptors" [s; Env e]);
|
||
Some s
|
||
end else None in
|
||
(* Run setup if provided *)
|
||
let setup_str = try args |> member "setup" |> to_string_option with _ -> None in
|
||
(match setup_str with
|
||
| Some s ->
|
||
List.iter (fun expr -> ignore (Sx_ref.eval_expr expr (Env e))) (Sx_parser.parse_all s)
|
||
| None -> ());
|
||
(* Evaluate *)
|
||
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
|
||
(* Format output *)
|
||
let result_str = Sx_runtime.value_to_str result in
|
||
let reload_str = if reloaded = [] then "" else
|
||
"\n\nReloaded: " ^ String.concat ", " (List.map Filename.basename reloaded) in
|
||
let io_str = match session with
|
||
| Some s ->
|
||
let log = call_sx "harness-log" [s] in
|
||
(match log with
|
||
| List items | ListRef { contents = items } when items <> [] ->
|
||
"\n\nIO trace:\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)")
|
||
| None -> ""
|
||
in
|
||
text_result (result_str ^ reload_str ^ io_str)
|
||
|
||
let handle_sx_guard args =
|
||
let open Yojson.Safe.Util in
|
||
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)
|
||
|
||
let handle_sx_render_trace args =
|
||
let open Yojson.Safe.Util in
|
||
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))
|
||
|
||
let handle_sx_trace args =
|
||
let open Yojson.Safe.Util in
|
||
let expr_str = args |> member "expr" |> to_string in
|
||
let max_steps = to_int_or ~default:200 (args |> member "max_steps") 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))
|
||
|
||
let handle_sx_deps args =
|
||
let open Yojson.Safe.Util in
|
||
let file = require_file args "file" 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)
|
||
|
||
let handle_sx_build_manifest args =
|
||
let open Yojson.Safe.Util in
|
||
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 pd = project_dir () in
|
||
let cmd = Printf.sprintf "cd %s && python3 hosts/javascript/manifest.py 2>&1"
|
||
(Filename.quote pd) in
|
||
let (_code, output) = run_command cmd in
|
||
text_result output)
|
||
|
||
let handle_sx_explain args =
|
||
let open Yojson.Safe.Util in
|
||
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 *)
|
||
(* ================================================================== *)
|
||
|
||
let handle_sx_load_check _args =
|
||
ignore _args;
|
||
(* Load all .sx files the HTTP server would load, report errors *)
|
||
let pd = project_dir () in
|
||
let spec_base = pd ^ "/spec" in
|
||
let lib_base = pd ^ "/lib" in
|
||
let web_base = pd ^ "/web" in
|
||
let shared_sx = pd ^ "/shared/sx/templates" in
|
||
let sx_sx =
|
||
let dp = pd ^ "/sx" in
|
||
let dv = pd ^ "/sx/sx" in
|
||
if Sys.file_exists (dp ^ "/page-functions.sx") then dp else dv in
|
||
let sx_sxc =
|
||
let dp = pd ^ "/sxc" in
|
||
let dv = pd ^ "/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))
|
||
|
||
let handle_sx_env args =
|
||
let open Yojson.Safe.Util in
|
||
(* 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))
|
||
|
||
let handle_sx_handler_list _args =
|
||
ignore _args;
|
||
(* 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))
|
||
|
||
let handle_sx_page_list _args =
|
||
ignore _args;
|
||
(* List all page functions by scanning page-functions.sx *)
|
||
let pd = project_dir () in
|
||
let pf_path =
|
||
let dp = pd ^ "/sx/page-functions.sx" in
|
||
let dv = pd ^ "/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
|
||
|
||
let handle_sx_request args =
|
||
let open Yojson.Safe.Util in
|
||
(* 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)))
|
||
|
||
let handle_tool name args =
|
||
match Hashtbl.find_opt tool_handlers name with
|
||
| Some handler ->
|
||
(try
|
||
let file_arg = try Yojson.Safe.Util.(args |> member "file" |> to_string) with _ -> "" in
|
||
let t0 = Unix.gettimeofday () in
|
||
let r = handler args in
|
||
let elapsed = (Unix.gettimeofday () -. t0) *. 1000.0 in
|
||
log_msg "OK [%s] %s (%.0fms)" name (if file_arg <> "" then "file=" ^ file_arg else "") elapsed;
|
||
r
|
||
with Invalid_argument msg ->
|
||
log_msg "INVALID_ARG [%s]: %s" name msg;
|
||
error_result msg
|
||
| Stack_overflow ->
|
||
log_msg "STACK OVERFLOW [%s]" name;
|
||
error_result "Stack overflow — file too large or recursive structure"
|
||
| Out_of_memory ->
|
||
log_msg "OUT OF MEMORY [%s]" name;
|
||
error_result "Out of memory"
|
||
| e ->
|
||
log_msg "EXCEPTION [%s]: %s" name (Printexc.to_string e);
|
||
error_result ("Error: " ^ Printexc.to_string e))
|
||
| None ->
|
||
log_msg "UNKNOWN TOOL: %s" name;
|
||
error_result ("Unknown tool: " ^ name)
|
||
|
||
let () =
|
||
register "sx_read_tree" handle_sx_read_tree;
|
||
register "sx_summarise" handle_sx_summarise;
|
||
register "sx_read_subtree" handle_sx_read_subtree;
|
||
register "sx_get_context" handle_sx_get_context;
|
||
register "sx_find_all" handle_sx_find_all;
|
||
register "sx_get_siblings" handle_sx_get_siblings;
|
||
register "sx_validate" handle_sx_validate;
|
||
register "sx_replace_node" handle_sx_replace_node;
|
||
register "sx_insert_child" handle_sx_insert_child;
|
||
register "sx_delete_node" handle_sx_delete_node;
|
||
register "sx_wrap_node" handle_sx_wrap_node;
|
||
register "sx_format_check" handle_sx_format_check;
|
||
register "sx_macroexpand" handle_sx_macroexpand;
|
||
register "sx_build" handle_sx_build;
|
||
register "sx_build_bytecode" handle_sx_build_bytecode;
|
||
register "sx_test" handle_sx_test;
|
||
register "sx_pretty_print" handle_sx_pretty_print;
|
||
register "sx_changed" handle_sx_changed;
|
||
register "sx_diff_branch" handle_sx_diff_branch;
|
||
register "sx_blame" handle_sx_blame;
|
||
register "sx_doc_gen" handle_sx_doc_gen;
|
||
register "sx_nav" handle_sx_nav;
|
||
register "sx_playwright" handle_sx_playwright;
|
||
register "sx_harness_eval" handle_sx_harness_eval;
|
||
register "sx_write_file" handle_sx_write_file;
|
||
register "sx_rename_symbol" handle_sx_rename_symbol;
|
||
register "sx_replace_by_pattern" handle_sx_replace_by_pattern;
|
||
register "sx_insert_near" handle_sx_insert_near;
|
||
register "sx_rename_across" handle_sx_rename_across;
|
||
register "sx_comp_list" handle_sx_comp_list;
|
||
register "sx_find_across" handle_sx_find_across;
|
||
register "sx_diff" handle_sx_diff;
|
||
register "sx_comp_usage" handle_sx_comp_usage;
|
||
register "sx_eval" handle_sx_eval;
|
||
register "sx_guard" handle_sx_guard;
|
||
register "sx_render_trace" handle_sx_render_trace;
|
||
register "sx_trace" handle_sx_trace;
|
||
register "sx_deps" handle_sx_deps;
|
||
register "sx_build_manifest" handle_sx_build_manifest;
|
||
register "sx_explain" handle_sx_explain;
|
||
register "sx_load_check" handle_sx_load_check;
|
||
register "sx_env" handle_sx_env;
|
||
register "sx_handler_list" handle_sx_handler_list;
|
||
register "sx_page_list" handle_sx_page_list;
|
||
register "sx_request" handle_sx_request;
|
||
()
|
||
|
||
|
||
(* ------------------------------------------------------------------ *)
|
||
(* 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, default 2)")])] ["file"];
|
||
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 SX in the persistent image. Definitions survive between calls. Files are smart-loaded (only re-evaluated if source changed on disk). With trace_io=true, wraps in harness to capture all IO calls."
|
||
[("expr", `Assoc [("type", `String "string"); ("description", `String "SX expression to evaluate")]);
|
||
("file", `Assoc [("type", `String "string"); ("description", `String "Optional .sx file to load")]);
|
||
("files", `Assoc [("type", `String "array"); ("items", `Assoc [("type", `String "string")]); ("description", `String "Multiple .sx files to load in order (smart reload — skips unchanged)")]);
|
||
("setup", `Assoc [("type", `String "string"); ("description", `String "SX expression to run before main eval")]);
|
||
("trace_io", `Assoc [("type", `String "boolean"); ("description", `String "Wrap in test harness to capture IO trace (default: false)")]);
|
||
("mock", `Assoc [("type", `String "string"); ("description", `String "Mock platform overrides as SX dict (requires trace_io)")])]
|
||
["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. Paginated (default 200 results)."
|
||
[dir_prop; ("pattern", `Assoc [("type", `String "string"); ("description", `String "Search pattern")]);
|
||
("limit", `Assoc [("type", `String "integer"); ("description", `String "Max results to return (default: 200)")]);
|
||
("offset", `Assoc [("type", `String "integer"); ("description", `String "Skip first N results (default: 0)")])] ["dir"; "pattern"];
|
||
tool "sx_comp_list" "List all definitions (defcomp, defisland, defmacro, defpage, define) across .sx files in a directory. Paginated (default 200 results)."
|
||
[dir_prop;
|
||
("limit", `Assoc [("type", `String "integer"); ("description", `String "Max results to return (default: 200)")]);
|
||
("offset", `Assoc [("type", `String "integer"); ("description", `String "Skip first N results (default: 0)")])] ["dir"];
|
||
tool "sx_comp_usage" "Find all uses of a component or symbol name across .sx files in a directory. Paginated (default 200 results)."
|
||
[dir_prop; ("name", `Assoc [("type", `String "string"); ("description", `String "Component or symbol name to search for")]);
|
||
("limit", `Assoc [("type", `String "integer"); ("description", `String "Max results to return (default: 200)")]);
|
||
("offset", `Assoc [("type", `String "integer"); ("description", `String "Skip first N results (default: 0)")])] ["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, sandbox (offline WASM kernel — no server needed)")]);
|
||
("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")]);
|
||
("files", `Assoc [("type", `String "array"); ("items", `Assoc [("type", `String "string")]); ("description", `String ".sx files to load (sandbox mode)")]);
|
||
("setup", `Assoc [("type", `String "string"); ("description", `String "SX setup expression (sandbox mode)")]);
|
||
("stack", `Assoc [("type", `String "string"); ("description", `String "Module stack for sandbox: core (default), web (full web stack), hs (web + hyperscript), test (web + test framework)")]);
|
||
("bytecode", `Assoc [("type", `String "boolean"); ("description", `String "Load .sxbc bytecode instead of .sx source in sandbox (default: false)")])]
|
||
[];
|
||
]
|
||
|
||
(* ------------------------------------------------------------------ *)
|
||
(* 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 ();
|
||
log_msg "Server started (pid=%d, cwd=%s)" (Unix.getpid ()) (Sys.getcwd ());
|
||
try while true do
|
||
let line = input_line stdin in
|
||
if String.length line > 0 then begin
|
||
try
|
||
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 tool_name = if meth = "tools/call" then
|
||
(try params |> member "name" |> to_string with _ -> "?")
|
||
else meth in
|
||
let t0 = Unix.gettimeofday () in
|
||
let result =
|
||
try dispatch meth params
|
||
with e ->
|
||
let msg = Printexc.to_string e in
|
||
log_msg "DISPATCH ERROR [%s]: %s" tool_name msg;
|
||
error_result ("Error: " ^ msg)
|
||
in
|
||
let elapsed = (Unix.gettimeofday () -. t0) *. 1000.0 in
|
||
if elapsed > 5000.0 then
|
||
log_msg "SLOW [%s]: %.0fms" tool_name elapsed;
|
||
(* Check for error in result *)
|
||
(match result with
|
||
| `Assoc items when List.mem_assoc "isError" items ->
|
||
log_msg "TOOL ERROR [%s]: %s (%.0fms)" tool_name
|
||
(try result |> member "content" |> to_list |> List.hd |> member "text" |> to_string with _ -> "?")
|
||
elapsed
|
||
| _ -> ());
|
||
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;
|
||
check_hot_reload ()
|
||
end
|
||
with e ->
|
||
let msg = Printexc.to_string e in
|
||
log_msg "REQUEST PARSE ERROR: %s" msg;
|
||
Printf.eprintf "[mcp] Request error: %s\n%!" msg
|
||
end
|
||
done
|
||
with End_of_file ->
|
||
log_msg "Server shutting down (End_of_file)"
|