giles
03c2115f0d
The deployed sx_browser.bc.wasm.js was actually the js_of_ocaml output (pure JS), not the wasm_of_ocaml loader. Nothing synced the correct build output from _build/ to shared/static/wasm/. - sx_build target=ocaml now auto-syncs WASM kernel + JS fallback + assets - sx-build-all.sh syncs after dune build - Correct 68KB WASM loader replaces 3.6MB JS imposter Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
2082 lines
104 KiB
OCaml
2082 lines
104 KiB
OCaml
(** MCP server for SX tree tools — structural reading and editing of .sx files.
|
|
|
|
Stdio JSON-RPC transport following the MCP specification.
|
|
Loads tree-tools.sx into the SX evaluator and exposes comprehension
|
|
and editing functions as MCP tools. *)
|
|
|
|
open Sx_types
|
|
|
|
(* ------------------------------------------------------------------ *)
|
|
(* SX evaluator setup — minimal env for parser + tree-tools *)
|
|
(* ------------------------------------------------------------------ *)
|
|
|
|
let env = ref (make_env ())
|
|
|
|
let load_sx_file e path =
|
|
let src = In_channel.with_open_text path In_channel.input_all in
|
|
let exprs = Sx_parser.parse_all src in
|
|
List.iter (fun expr ->
|
|
try ignore (Sx_ref.cek_call
|
|
(NativeFn ("eval", fun args ->
|
|
match args with
|
|
| [ex] -> Sx_ref.eval_expr ex (Env e)
|
|
| _ -> Nil))
|
|
(List [expr]))
|
|
with _ ->
|
|
(* Fallback: direct eval *)
|
|
ignore (Sx_ref.eval_expr expr (Env e))
|
|
) exprs
|
|
|
|
let setup_env () =
|
|
let e = make_env () in
|
|
(* Primitives are auto-registered at module init *)
|
|
(* Trampoline ref for HO primitives *)
|
|
Sx_primitives._sx_trampoline_fn := (fun v ->
|
|
match v with
|
|
| Thunk (body, closure_env) -> Sx_ref.eval_expr body (Env closure_env)
|
|
| other -> other);
|
|
(* Character classification for parser *)
|
|
let bind name fn = ignore (env_bind e name (NativeFn (name, fn))) in
|
|
bind "is-whitespace?" (fun args -> match args with
|
|
| [String s] when String.length s = 1 ->
|
|
let c = s.[0] in Bool (c = ' ' || c = '\t' || c = '\n' || c = '\r')
|
|
| _ -> Bool false);
|
|
bind "is-digit?" (fun args -> match args with
|
|
| [String s] when String.length s = 1 ->
|
|
Bool (s.[0] >= '0' && s.[0] <= '9')
|
|
| _ -> Bool false);
|
|
bind "is-alpha?" (fun args -> match args with
|
|
| [String s] when String.length s = 1 ->
|
|
let c = s.[0] in Bool ((c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'))
|
|
| _ -> Bool false);
|
|
bind "char-code" (fun args -> match args with
|
|
| [String s] when String.length s > 0 -> Number (float_of_int (Char.code s.[0]))
|
|
| _ -> Number 0.0);
|
|
bind "code-char" (fun args -> match args with
|
|
| [Number n] -> String (String.make 1 (Char.chr (int_of_float n)))
|
|
| _ -> String "");
|
|
bind "parse-number" (fun args -> match args with
|
|
| [String s] -> (try Number (float_of_string s) with _ -> Nil)
|
|
| _ -> Nil);
|
|
bind "identical?" (fun args -> match args with
|
|
| [a; b] -> Bool (a == b)
|
|
| _ -> Bool false);
|
|
(* Character classification for SX parser.sx *)
|
|
bind "ident-start?" (fun args -> match args with
|
|
| [String s] when String.length s = 1 ->
|
|
let c = s.[0] in
|
|
Bool ((c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') ||
|
|
c = '_' || c = '~' || c = '*' || c = '+' || c = '-' ||
|
|
c = '>' || c = '<' || c = '=' || c = '/' || c = '!' ||
|
|
c = '?' || c = '&' || c = '@' || c = '^' || c = '%' ||
|
|
Char.code c > 127)
|
|
| _ -> Bool false);
|
|
bind "ident-char?" (fun args -> match args with
|
|
| [String s] when String.length s = 1 ->
|
|
let c = s.[0] in
|
|
Bool ((c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') ||
|
|
(c >= '0' && c <= '9') ||
|
|
c = '_' || c = '~' || c = '*' || c = '+' || c = '-' ||
|
|
c = '>' || c = '<' || c = '=' || c = '/' || c = '!' ||
|
|
c = '?' || c = '&' || c = '.' || c = ':' || c = '#' ||
|
|
c = ',' || c = '@' || c = '^' || c = '%' ||
|
|
Char.code c > 127)
|
|
| _ -> Bool false);
|
|
bind "make-keyword" (fun args -> match args with
|
|
| [String s] -> Keyword s | _ -> Nil);
|
|
bind "escape-string" (fun args -> match args with
|
|
| [String s] ->
|
|
let buf = Buffer.create (String.length s) in
|
|
String.iter (fun c -> match c with
|
|
| '"' -> Buffer.add_string buf "\\\""
|
|
| '\\' -> Buffer.add_string buf "\\\\"
|
|
| '\n' -> Buffer.add_string buf "\\n"
|
|
| '\t' -> Buffer.add_string buf "\\t"
|
|
| '\r' -> Buffer.add_string buf "\\r"
|
|
| c -> Buffer.add_char buf c) s;
|
|
String (Buffer.contents buf)
|
|
| _ -> String "");
|
|
bind "sx-expr-source" (fun args -> match args with
|
|
| [SxExpr s] -> String s | _ -> String "");
|
|
(* Runtime functions needed by tree-tools *)
|
|
bind "symbol-name" (fun args -> match args with
|
|
| [Symbol s] -> String s | _ -> String "");
|
|
bind "keyword-name" (fun args -> match args with
|
|
| [Keyword k] -> String k | _ -> String "");
|
|
bind "make-symbol" (fun args -> match args with
|
|
| [String s] -> Symbol s | _ -> Nil);
|
|
(* Environment operations needed by harness *)
|
|
bind "env-bind!" (fun args -> match args with
|
|
| [Env env_val; String name; v] -> ignore (env_bind env_val name v); v
|
|
| _ -> Nil);
|
|
bind "env-get" (fun args -> match args with
|
|
| [Env env_val; String name] -> env_get env_val name
|
|
| _ -> Nil);
|
|
bind "env-has?" (fun args -> match args with
|
|
| [Env env_val; String name] -> Bool (env_has env_val name)
|
|
| _ -> Bool false);
|
|
bind "make-env" (fun _args -> Env (make_env ()));
|
|
bind "keys" (fun args -> match args with
|
|
| [Dict d] -> List (Hashtbl.fold (fun k _ acc -> String k :: acc) d [])
|
|
| _ -> List []);
|
|
bind "get" (fun args -> match args with
|
|
| [Dict d; String k] -> (match Hashtbl.find_opt d k with Some v -> v | None -> Nil)
|
|
| [Dict d; Keyword k] -> (match Hashtbl.find_opt d k with Some v -> v | None -> Nil)
|
|
| [List items; Number n] -> (let i = int_of_float n in if i >= 0 && i < List.length items then List.nth items i else Nil)
|
|
| _ -> Nil);
|
|
bind "dict-set!" (fun args -> match args with
|
|
| [Dict d; String k; v] -> Hashtbl.replace d k v; v
|
|
| [Dict d; Keyword k; v] -> Hashtbl.replace d k v; v
|
|
| _ -> Nil);
|
|
bind "merge" (fun args -> match args with
|
|
| [Dict a; Dict b] ->
|
|
let d = Hashtbl.create (Hashtbl.length a + Hashtbl.length b) in
|
|
Hashtbl.iter (fun k v -> Hashtbl.replace d k v) a;
|
|
Hashtbl.iter (fun k v -> Hashtbl.replace d k v) b;
|
|
Dict d
|
|
| _ -> Nil);
|
|
bind "apply" (fun args -> match args with
|
|
| [f; List items] | [f; ListRef { contents = items }] ->
|
|
Sx_ref.cek_call f (List items)
|
|
| _ -> Nil);
|
|
bind "current-env" (fun _args -> Env e);
|
|
bind "type-of" (fun args -> match args with
|
|
| [v] -> String (type_of v) | _ -> String "nil");
|
|
bind "list?" (fun args -> match args with
|
|
| [List _ | ListRef _] -> Bool true | _ -> Bool false);
|
|
bind "nil?" (fun args -> match args with
|
|
| [v] -> Bool (is_nil v) | _ -> Bool true);
|
|
bind "string?" (fun args -> match args with
|
|
| [String _] -> Bool true | _ -> Bool false);
|
|
bind "number?" (fun args -> match args with
|
|
| [Number _] -> Bool true | _ -> Bool false);
|
|
bind "callable?" (fun args -> match args with
|
|
| [NativeFn _ | Lambda _ | Component _ | Island _] -> Bool true | _ -> Bool false);
|
|
bind "empty?" (fun args -> match args with
|
|
| [List []] | [ListRef { contents = [] }] -> Bool true
|
|
| [Nil] -> Bool true | _ -> Bool false);
|
|
bind "contains?" (fun args -> match args with
|
|
| [String s; String sub] ->
|
|
let rec find i =
|
|
if i > String.length s - String.length sub then false
|
|
else if String.sub s i (String.length sub) = sub then true
|
|
else find (i + 1)
|
|
in Bool (String.length sub = 0 || find 0)
|
|
| [List l; v] | [ListRef { contents = l }; v] ->
|
|
Bool (List.exists (fun x -> x = v) l)
|
|
| _ -> Bool false);
|
|
bind "starts-with?" (fun args -> match args with
|
|
| [String s; String prefix] ->
|
|
Bool (String.length s >= String.length prefix &&
|
|
String.sub s 0 (String.length prefix) = prefix)
|
|
| _ -> Bool false);
|
|
bind "append!" (fun args -> match args with
|
|
| [ListRef r; v] -> r := !r @ [v]; v
|
|
| _ -> Nil);
|
|
bind "map-indexed" (fun args -> match args with
|
|
| [f; List l] | [f; ListRef { contents = l }] ->
|
|
List (List.mapi (fun i x -> Sx_ref.cek_call f (List [Number (float_of_int i); x])) l)
|
|
| _ -> List []);
|
|
(* Native list-replace — bypasses CEK map-indexed callback chain for deep tree edits *)
|
|
bind "list-replace" (fun args -> match args with
|
|
| [List l; Number idx; v] ->
|
|
let i = int_of_float idx in
|
|
List (List.mapi (fun j x -> if j = i then v else x) l)
|
|
| [ListRef { contents = l }; Number idx; v] ->
|
|
let i = int_of_float idx in
|
|
List (List.mapi (fun j x -> if j = i then v else x) l)
|
|
| _ -> Nil);
|
|
(* Native navigate — bypasses CEK reduce callback chain for deep path reads *)
|
|
bind "navigate" (fun args -> match args with
|
|
| [tree; List path] | [tree; ListRef { contents = path }] ->
|
|
let nodes = match tree with List _ | ListRef _ -> tree | _ -> List [tree] in
|
|
List.fold_left (fun current idx ->
|
|
match current, idx with
|
|
| (List l | ListRef { contents = l }), Number n ->
|
|
let i = int_of_float n in
|
|
if i >= 0 && i < List.length l then List.nth l i else Nil
|
|
| _ -> Nil
|
|
) nodes path
|
|
| _ -> Nil);
|
|
(* use — module declaration, no-op at eval time, metadata for static analysis *)
|
|
bind "use" (fun _args -> Nil);
|
|
(* Capability-based evaluation contexts *)
|
|
let cap_stack : string list ref = ref [] in
|
|
bind "with-capabilities" (fun args -> match args with
|
|
| [List caps; body] ->
|
|
let cap_set = List.filter_map (fun v -> match v with
|
|
| Symbol s | String s -> Some s | _ -> None) caps in
|
|
let prev = !cap_stack in
|
|
cap_stack := cap_set;
|
|
(* body can be a lambda (call it) or an expression (eval it) *)
|
|
let result = try
|
|
match body with
|
|
| Lambda _ -> Sx_ref.cek_call body Nil
|
|
| _ -> body
|
|
with exn -> cap_stack := prev; raise exn in
|
|
cap_stack := prev;
|
|
result
|
|
| _ -> Nil);
|
|
bind "current-capabilities" (fun _args ->
|
|
if !cap_stack = [] then Nil
|
|
else List (List.map (fun s -> String s) !cap_stack));
|
|
bind "has-capability?" (fun args -> match args with
|
|
| [String cap] ->
|
|
if !cap_stack = [] then Bool true (* no restriction *)
|
|
else Bool (List.mem cap !cap_stack)
|
|
| _ -> Bool true);
|
|
bind "require-capability!" (fun args -> match args with
|
|
| [String cap] ->
|
|
if !cap_stack = [] then Nil (* no restriction *)
|
|
else if List.mem cap !cap_stack then Nil
|
|
else raise (Eval_error (Printf.sprintf
|
|
"Capability '%s' not available. Current: %s" cap (String.concat ", " !cap_stack)))
|
|
| _ -> Nil);
|
|
bind "trim" (fun args -> match args with
|
|
| [String s] -> String (String.trim s) | _ -> String "");
|
|
bind "split" (fun args -> match args with
|
|
| [String s; String d] ->
|
|
List (List.map (fun p -> String p) (String.split_on_char d.[0] s))
|
|
| _ -> List []);
|
|
(* sx-parse — use the native OCaml parser for bootstrapping *)
|
|
bind "sx-parse" (fun args -> match args with
|
|
| [String s] -> List (Sx_parser.parse_all s)
|
|
| _ -> List []);
|
|
bind "sx-serialize" (fun args -> match args with
|
|
| [v] -> String (Sx_runtime.value_to_str v)
|
|
| _ -> String "");
|
|
(* Stubs needed by signals.sx + adapter-html.sx *)
|
|
bind "set-render-active!" (fun _args -> Nil);
|
|
bind "render-active?" (fun _args -> Bool true);
|
|
bind "trampoline" (fun args -> match args with
|
|
| [Thunk (expr, e)] -> Sx_ref.eval_expr expr (Env e)
|
|
| [v] -> v | _ -> Nil);
|
|
bind "eval-expr" (fun args -> match args with
|
|
| [expr; Env ue] -> Sx_ref.eval_expr expr (Env ue)
|
|
| [expr] -> Sx_ref.eval_expr expr (Env e)
|
|
| _ -> Nil);
|
|
bind "deftype" (fun _args -> Nil);
|
|
bind "defeffect" (fun _args -> Nil);
|
|
(* Load parser.sx for the SX-level sx-parse/sx-serialize *)
|
|
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in
|
|
let lib_dir = try Sys.getenv "SX_LIB_DIR" with Not_found -> "lib" in
|
|
(try load_sx_file e (Filename.concat spec_dir "parser.sx")
|
|
with exn -> Printf.eprintf "[mcp] Warning: parser.sx load failed: %s\n%!" (Printexc.to_string exn));
|
|
(* Load tree-tools *)
|
|
(try load_sx_file e (Filename.concat lib_dir "tree-tools.sx")
|
|
with exn -> Printf.eprintf "[mcp] Error: tree-tools.sx load failed: %s\n%!" (Printexc.to_string exn); exit 1);
|
|
(* Load signals — reactive signal primitives *)
|
|
(try load_sx_file e (Filename.concat spec_dir "signals.sx")
|
|
with exn -> Printf.eprintf "[mcp] Warning: signals.sx load failed: %s\n%!" (Printexc.to_string exn));
|
|
(* Load render + adapter-html for render-to-html *)
|
|
let web_dir = try Sys.getenv "SX_WEB_DIR" with Not_found -> "web" in
|
|
(try load_sx_file e (Filename.concat spec_dir "render.sx")
|
|
with exn -> Printf.eprintf "[mcp] Warning: render.sx load failed: %s\n%!" (Printexc.to_string exn));
|
|
(try load_sx_file e (Filename.concat web_dir "adapter-html.sx")
|
|
with exn -> Printf.eprintf "[mcp] Warning: adapter-html.sx load failed: %s\n%!" (Printexc.to_string exn));
|
|
(* Load harness *)
|
|
(try load_sx_file e (Filename.concat spec_dir "harness.sx")
|
|
with exn -> Printf.eprintf "[mcp] Warning: harness.sx load failed: %s\n%!" (Printexc.to_string exn));
|
|
(* Load eval-rules *)
|
|
(try load_sx_file e (Filename.concat spec_dir "eval-rules.sx")
|
|
with exn -> Printf.eprintf "[mcp] Warning: eval-rules.sx load failed: %s\n%!" (Printexc.to_string exn));
|
|
(* Load signals — reactive signal primitives *)
|
|
(try load_sx_file e (Filename.concat spec_dir "signals.sx")
|
|
with exn -> Printf.eprintf "[mcp] Warning: signals.sx load failed: %s\n%!" (Printexc.to_string exn));
|
|
(* Load render + adapter-html for render-to-html *)
|
|
let web_dir = try Sys.getenv "SX_WEB_DIR" with Not_found -> "web" in
|
|
(try load_sx_file e (Filename.concat spec_dir "render.sx")
|
|
with exn -> Printf.eprintf "[mcp] Warning: render.sx load failed: %s\n%!" (Printexc.to_string exn));
|
|
(try load_sx_file e (Filename.concat web_dir "adapter-html.sx")
|
|
with exn -> Printf.eprintf "[mcp] Warning: adapter-html.sx load failed: %s\n%!" (Printexc.to_string exn));
|
|
(* Load render pipeline — native OCaml renderer + HTML tag bindings *)
|
|
Sx_render.setup_render_env e;
|
|
List.iter (fun tag ->
|
|
ignore (Sx_types.env_bind e tag
|
|
(NativeFn ("html:" ^ tag, fun args -> List (Symbol tag :: args))))
|
|
) Sx_render.html_tags;
|
|
ignore (Sx_types.env_bind e "island?" (NativeFn ("island?", fun args -> match args with [Island _] -> Bool true | _ -> Bool false)));
|
|
Printf.eprintf "[mcp] SX tree-tools + harness + eval-rules + render loaded\n%!";
|
|
env := e
|
|
|
|
(* ------------------------------------------------------------------ *)
|
|
(* Call SX tree-tools functions *)
|
|
(* ------------------------------------------------------------------ *)
|
|
|
|
let call_sx fn_name args =
|
|
let e = !env in
|
|
let fn = env_get e fn_name in
|
|
Sx_ref.cek_call fn (List args)
|
|
|
|
let parse_file path =
|
|
let src = In_channel.with_open_text path In_channel.input_all in
|
|
let exprs = Sx_parser.parse_all src in
|
|
List exprs
|
|
|
|
let parse_path_str s =
|
|
(* Parse SX path string: "(0 3 2)" or "(0,3,2)" or "0 3 2" → SX list of numbers.
|
|
Commas are unquote in SX, so strip them before parsing. *)
|
|
let s = String.map (fun c -> if c = ',' then ' ' else c) s in
|
|
let exprs = Sx_parser.parse_all s in
|
|
match exprs with
|
|
| [List items] ->
|
|
(* (0 3 2) → list of numbers *)
|
|
List (List.map (fun x -> match x with Number _ -> x | _ -> Number 0.0) items)
|
|
| _ ->
|
|
(* Bare numbers: "0 3 2" → parsed as separate exprs *)
|
|
List (List.map (fun x -> match x with Number _ -> x | _ -> Number 0.0) exprs)
|
|
|
|
let _json_to_path j =
|
|
let open Yojson.Safe.Util in
|
|
parse_path_str (to_string j)
|
|
|
|
(* Resolve path: if it contains ">", use resolve-named-path; else parse as index path *)
|
|
let resolve_path tree path_str =
|
|
if String.contains path_str '>' then
|
|
call_sx "resolve-named-path" [tree; String path_str]
|
|
else
|
|
parse_path_str path_str
|
|
|
|
let value_to_string v =
|
|
match v with
|
|
| String s -> s
|
|
| _ -> Sx_runtime.value_to_str v
|
|
|
|
let text_result s =
|
|
`Assoc [("content", `List [`Assoc [
|
|
("type", `String "text");
|
|
("text", `String s)
|
|
]])]
|
|
|
|
let error_result s =
|
|
`Assoc [("content", `List [`Assoc [
|
|
("type", `String "text");
|
|
("text", `String s)
|
|
]]);
|
|
("isError", `Bool true)]
|
|
|
|
(* ------------------------------------------------------------------ *)
|
|
(* Recursive .sx file discovery *)
|
|
(* ------------------------------------------------------------------ *)
|
|
|
|
let glob_sx_files dir =
|
|
let results = ref [] in
|
|
let rec walk path =
|
|
if Sys.is_directory path then
|
|
let entries = Sys.readdir path in
|
|
Array.iter (fun e -> walk (Filename.concat path e)) entries
|
|
else if Filename.check_suffix path ".sx" then
|
|
results := path :: !results
|
|
in
|
|
(try walk dir with Sys_error _ -> ());
|
|
List.sort String.compare !results
|
|
|
|
let relative_path ~base path =
|
|
let blen = String.length base in
|
|
if String.length path > blen && String.sub path 0 blen = base then
|
|
let rest = String.sub path (blen + 1) (String.length path - blen - 1) in
|
|
rest
|
|
else path
|
|
|
|
(* ------------------------------------------------------------------ *)
|
|
(* Pretty printer *)
|
|
(* ------------------------------------------------------------------ *)
|
|
|
|
let pp_atom = Sx_types.inspect
|
|
|
|
(* Estimate single-line width of a value *)
|
|
let rec est_width = function
|
|
| Nil -> 3 | Bool true -> 4 | Bool false -> 5
|
|
| Number n -> String.length (if Float.is_integer n then string_of_int (int_of_float n) else Printf.sprintf "%g" n)
|
|
| String s -> String.length s + 2
|
|
| Symbol s -> String.length s
|
|
| Keyword k -> String.length k + 1
|
|
| SxExpr s -> String.length s + 2
|
|
| List items | ListRef { contents = items } ->
|
|
2 + List.fold_left (fun acc x -> acc + est_width x + 1) 0 items
|
|
| _ -> 10
|
|
|
|
let pretty_print_value ?(max_width=80) v =
|
|
let buf = Buffer.create 4096 in
|
|
let rec pp indent v =
|
|
match v with
|
|
| List items | ListRef { contents = items } when items <> [] ->
|
|
if est_width v <= max_width - indent then
|
|
(* Fits on one line *)
|
|
Buffer.add_string buf (pp_atom v)
|
|
else begin
|
|
(* Multi-line *)
|
|
Buffer.add_char buf '(';
|
|
let head = List.hd items in
|
|
Buffer.add_string buf (pp_atom head);
|
|
let child_indent = indent + 2 in
|
|
let rest = List.tl items in
|
|
(* Special case: keyword args stay on same line as their value *)
|
|
let rec emit = function
|
|
| [] -> ()
|
|
| Keyword k :: v :: rest ->
|
|
Buffer.add_char buf '\n';
|
|
Buffer.add_string buf (String.make child_indent ' ');
|
|
Buffer.add_char buf ':';
|
|
Buffer.add_string buf k;
|
|
Buffer.add_char buf ' ';
|
|
pp child_indent v;
|
|
emit rest
|
|
| item :: rest ->
|
|
Buffer.add_char buf '\n';
|
|
Buffer.add_string buf (String.make child_indent ' ');
|
|
pp child_indent item;
|
|
emit rest
|
|
in
|
|
emit rest;
|
|
Buffer.add_char buf ')'
|
|
end
|
|
| _ -> Buffer.add_string buf (pp_atom v)
|
|
in
|
|
pp 0 v;
|
|
Buffer.contents buf
|
|
|
|
let pretty_print_file exprs =
|
|
String.concat "\n\n" (List.map pretty_print_value exprs) ^ "\n"
|
|
|
|
(* ------------------------------------------------------------------ *)
|
|
(* Tool handlers *)
|
|
(* ------------------------------------------------------------------ *)
|
|
|
|
let rec handle_tool name args =
|
|
let open Yojson.Safe.Util in
|
|
match name with
|
|
| "sx_read_tree" ->
|
|
let file = args |> member "file" |> to_string in
|
|
let tree = parse_file file in
|
|
let focus = args |> member "focus" |> to_string_option in
|
|
let max_depth = args |> member "max_depth" |> to_int_option in
|
|
let max_lines = args |> member "max_lines" |> to_int_option in
|
|
let offset = args |> member "offset" |> to_int_option |> Option.value ~default:0 in
|
|
(match focus with
|
|
| Some pattern ->
|
|
(* Focus mode: expand matching subtrees, collapse rest *)
|
|
text_result (value_to_string (call_sx "annotate-focused" [tree; String pattern]))
|
|
| None ->
|
|
match max_lines with
|
|
| Some limit ->
|
|
(* Paginated mode *)
|
|
text_result (value_to_string (call_sx "annotate-paginated"
|
|
[tree; Number (float_of_int offset); Number (float_of_int limit)]))
|
|
| None ->
|
|
match max_depth with
|
|
| Some depth ->
|
|
(* Depth-limited mode *)
|
|
text_result (value_to_string (call_sx "summarise" [tree; Number (float_of_int depth)]))
|
|
| None ->
|
|
(* Auto mode: full tree if small, summarise if large *)
|
|
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 full
|
|
else
|
|
let summary = value_to_string (call_sx "summarise" [tree; Number 2.0]) in
|
|
text_result (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))
|
|
|
|
| "sx_summarise" ->
|
|
let tree = parse_file (args |> member "file" |> to_string) in
|
|
let depth = args |> member "depth" |> to_int in
|
|
text_result (value_to_string (call_sx "summarise" [tree; Number (float_of_int depth)]))
|
|
|
|
| "sx_read_subtree" ->
|
|
let tree = parse_file (args |> member "file" |> to_string) in
|
|
let path = resolve_path tree (args |> member "path" |> to_string) in
|
|
text_result (value_to_string (call_sx "read-subtree" [tree; path]))
|
|
|
|
| "sx_get_context" ->
|
|
let tree = parse_file (args |> member "file" |> to_string) in
|
|
let path = resolve_path tree (args |> member "path" |> to_string) in
|
|
text_result (value_to_string (call_sx "get-context" [tree; path]))
|
|
|
|
| "sx_find_all" ->
|
|
let tree = parse_file (args |> member "file" |> to_string) in
|
|
let pattern = args |> member "pattern" |> to_string in
|
|
let results = call_sx "find-all" [tree; String pattern] in
|
|
let lines = match results with
|
|
| List items | ListRef { contents = items } ->
|
|
List.map (fun item ->
|
|
match item with
|
|
| List [p; s] | ListRef { contents = [p; s] } ->
|
|
value_to_string (call_sx "path-str" [p]) ^ " " ^ value_to_string s
|
|
| _ -> value_to_string item
|
|
) items
|
|
| _ -> [value_to_string results]
|
|
in
|
|
text_result (String.concat "\n" lines)
|
|
|
|
| "sx_get_siblings" ->
|
|
let tree = parse_file (args |> member "file" |> to_string) in
|
|
let path = resolve_path tree (args |> member "path" |> to_string) in
|
|
text_result (value_to_string (call_sx "get-siblings" [tree; path]))
|
|
|
|
| "sx_validate" ->
|
|
let tree = parse_file (args |> member "file" |> to_string) in
|
|
text_result (value_to_string (call_sx "validate" [tree]))
|
|
|
|
| "sx_replace_node" ->
|
|
let file = args |> member "file" |> to_string in
|
|
let tree = parse_file file in
|
|
let path = resolve_path tree (args |> member "path" |> to_string) in
|
|
let src = args |> member "new_source" |> to_string in
|
|
write_edit file (call_sx "replace-node" [tree; path; String src])
|
|
|
|
| "sx_insert_child" ->
|
|
let file = args |> member "file" |> to_string in
|
|
let tree = parse_file file in
|
|
let path = resolve_path tree (args |> member "path" |> to_string) in
|
|
let index = args |> member "index" |> to_int in
|
|
let src = args |> member "new_source" |> to_string in
|
|
write_edit file (call_sx "insert-child" [tree; path; Number (float_of_int index); String src])
|
|
|
|
| "sx_delete_node" ->
|
|
let file = args |> member "file" |> to_string in
|
|
let tree = parse_file file in
|
|
let path = resolve_path tree (args |> member "path" |> to_string) in
|
|
write_edit file (call_sx "delete-node" [tree; path])
|
|
|
|
| "sx_wrap_node" ->
|
|
let file = args |> member "file" |> to_string in
|
|
let tree = parse_file file in
|
|
let path = resolve_path tree (args |> member "path" |> to_string) in
|
|
let wrapper = args |> member "wrapper" |> to_string in
|
|
write_edit file (call_sx "wrap-node" [tree; path; String wrapper])
|
|
|
|
| "sx_format_check" ->
|
|
let file = args |> member "file" |> to_string in
|
|
let tree = parse_file file in
|
|
let warnings = call_sx "lint-file" [tree] in
|
|
(match warnings with
|
|
| List [] | ListRef { contents = [] } -> text_result "OK — no issues found"
|
|
| List items | ListRef { contents = items } ->
|
|
text_result (String.concat "\n" (List.map value_to_string items))
|
|
| _ -> text_result (value_to_string warnings))
|
|
|
|
| "sx_macroexpand" ->
|
|
let file = args |> member "file" |> to_string_option in
|
|
let expr_str = args |> member "expr" |> to_string in
|
|
(* Create a fresh env with file definitions loaded *)
|
|
let e = !env in
|
|
(* Optionally load a file's definitions to get its macros *)
|
|
(match file with
|
|
| Some f ->
|
|
(try load_sx_file e f
|
|
with exn -> Printf.eprintf "[mcp] Warning: failed to load %s: %s\n%!" f (Printexc.to_string exn))
|
|
| None -> ());
|
|
let exprs = Sx_parser.parse_all expr_str in
|
|
let result = List.fold_left (fun _acc expr ->
|
|
Sx_ref.eval_expr expr (Env e)
|
|
) Nil exprs in
|
|
text_result (Sx_types.inspect result)
|
|
|
|
| "sx_build" ->
|
|
let target = args |> member "target" |> to_string_option |> Option.value ~default:"js" in
|
|
let full = args |> member "full" |> to_bool_option |> Option.value ~default:false in
|
|
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
|
|
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in
|
|
Filename.dirname spec_dir
|
|
in
|
|
let cmd = match target with
|
|
| "ocaml" ->
|
|
let abs_project = if Filename.is_relative project_dir then Sys.getcwd () ^ "/" ^ project_dir else project_dir in
|
|
Printf.sprintf "cd %s/hosts/ocaml && eval $(opam env 2>/dev/null) && dune build 2>&1 && cp _build/default/browser/sx_browser.bc.wasm.js %s/shared/static/wasm/sx_browser.bc.wasm.js && cp _build/default/browser/sx_browser.bc.js %s/shared/static/wasm/sx_browser.bc.js && cp -r _build/default/browser/sx_browser.bc.wasm.assets %s/shared/static/wasm/" abs_project abs_project abs_project abs_project
|
|
| "js" | _ ->
|
|
let extra = if full then " --extensions continuations --spec-modules types" else "" in
|
|
Printf.sprintf "cd %s && python3 hosts/javascript/cli.py%s --output shared/static/scripts/sx-browser.js 2>&1" project_dir extra
|
|
in
|
|
let ic = Unix.open_process_in cmd in
|
|
let lines = ref [] in
|
|
(try while true do lines := input_line ic :: !lines done with End_of_file -> ());
|
|
let status = Unix.close_process_in ic in
|
|
let output = String.concat "\n" (List.rev !lines) in
|
|
(match status with
|
|
| Unix.WEXITED 0 -> text_result (Printf.sprintf "OK — %s build succeeded\n%s" target (String.trim output))
|
|
| _ -> error_result (Printf.sprintf "%s build failed:\n%s" target output))
|
|
|
|
| "sx_build_bytecode" ->
|
|
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
|
|
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in
|
|
Filename.dirname spec_dir
|
|
in
|
|
let sx_dir = project_dir ^ "/shared/static/wasm/sx" in
|
|
let files = [
|
|
"render.sx"; "core-signals.sx"; "signals.sx"; "deps.sx"; "router.sx";
|
|
"page-helpers.sx"; "freeze.sx"; "bytecode.sx"; "compiler.sx"; "vm.sx";
|
|
"dom.sx"; "browser.sx"; "adapter-html.sx"; "adapter-sx.sx"; "adapter-dom.sx";
|
|
"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
|
|
Printf.sprintf "{\"t\":\"code\",\"v\":{\"bytecode\":[%s],\"constants\":[%s]}}" 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 json = Printf.sprintf "{\"magic\":\"SXBC\",\"version\":1,\"hash\":\"%s\",\"module\":{\"bytecode\":[%s],\"constants\":[%s]}}"
|
|
hash bc consts in
|
|
let json_path = (String.sub src_path 0 (String.length src_path - 3)) ^ ".sxbc.json" in
|
|
Out_channel.with_open_text json_path (fun oc -> output_string oc json);
|
|
let kb = String.length json / 1024 in
|
|
Buffer.add_string log (Printf.sprintf " ok %s → %dK\n" file kb);
|
|
incr compiled
|
|
with e ->
|
|
Buffer.add_string log (Printf.sprintf " SKIP %s — %s\n" file (Printexc.to_string e));
|
|
incr skipped
|
|
end
|
|
) files;
|
|
let dt = Unix.gettimeofday () -. t0 in
|
|
let summary = Printf.sprintf "Done: %d compiled, %d skipped in %.1fs\n%s"
|
|
!compiled !skipped dt (Buffer.contents log) in
|
|
if !skipped = 0 then
|
|
text_result (Printf.sprintf "OK — bytecode compilation succeeded\n%s" summary)
|
|
else
|
|
text_result (Printf.sprintf "Bytecode compilation partial\n%s" summary)
|
|
|
|
| "sx_test" ->
|
|
let host = args |> member "host" |> to_string_option |> Option.value ~default:"js" in
|
|
let full = args |> member "full" |> to_bool_option |> Option.value ~default:false in
|
|
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
|
|
(* Walk up from spec dir to find project root *)
|
|
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in
|
|
Filename.dirname spec_dir
|
|
in
|
|
let cmd = match host with
|
|
| "ocaml" ->
|
|
Printf.sprintf "cd %s/hosts/ocaml && eval $(opam env 2>/dev/null) && dune exec bin/run_tests.exe%s 2>&1"
|
|
project_dir (if full then " -- --full" else "")
|
|
| "js" | _ ->
|
|
Printf.sprintf "cd %s && node hosts/javascript/run_tests.js%s 2>&1"
|
|
project_dir (if full then " --full" else "")
|
|
in
|
|
let ic = Unix.open_process_in cmd in
|
|
let lines = ref [] in
|
|
(try while true do lines := input_line ic :: !lines done with End_of_file -> ());
|
|
ignore (Unix.close_process_in ic);
|
|
let all_lines = List.rev !lines in
|
|
(* Extract summary and failures *)
|
|
let fails = List.filter (fun l -> let t = String.trim l in
|
|
String.length t > 5 && String.sub t 0 4 = "FAIL") all_lines in
|
|
let summary = List.find_opt (fun l -> try let _ = Str.search_forward (Str.regexp "Results:") l 0 in true with Not_found -> false) all_lines in
|
|
let result = match summary with
|
|
| Some s ->
|
|
if fails = [] then s
|
|
else s ^ "\n\nFailures:\n" ^ String.concat "\n" fails
|
|
| None ->
|
|
let last_n = List.filteri (fun i _ -> i >= List.length all_lines - 5) all_lines in
|
|
String.concat "\n" last_n
|
|
in
|
|
text_result result
|
|
|
|
| "sx_pretty_print" ->
|
|
let file = args |> member "file" |> to_string in
|
|
let exprs = Sx_parser.parse_all (In_channel.with_open_text file In_channel.input_all) in
|
|
let source = pretty_print_file exprs in
|
|
Out_channel.with_open_text file (fun oc -> output_string oc source);
|
|
text_result (Printf.sprintf "OK — reformatted %s (%d bytes, %d forms)" file (String.length source) (List.length exprs))
|
|
|
|
| "sx_changed" ->
|
|
let base_ref = args |> member "ref" |> to_string_option |> Option.value ~default:"main" in
|
|
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
|
|
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in
|
|
Filename.dirname spec_dir
|
|
in
|
|
let cmd = Printf.sprintf "cd %s && git diff --name-only %s -- '*.sx' '*.sxc' 2>/dev/null" project_dir base_ref in
|
|
let ic = Unix.open_process_in cmd in
|
|
let files = ref [] in
|
|
(try while true do files := input_line ic :: !files done with End_of_file -> ());
|
|
ignore (Unix.close_process_in ic);
|
|
let changed = List.rev !files in
|
|
if changed = [] then text_result (Printf.sprintf "No .sx files changed since %s" base_ref)
|
|
else begin
|
|
let lines = List.map (fun rel ->
|
|
let full = Filename.concat project_dir rel in
|
|
try
|
|
let tree = parse_file full in
|
|
let summary = value_to_string (call_sx "summarise" [tree; Number 1.0]) in
|
|
Printf.sprintf "=== %s ===\n%s" rel summary
|
|
with _ -> Printf.sprintf "=== %s === (parse error or deleted)" rel
|
|
) changed in
|
|
text_result (String.concat "\n\n" lines)
|
|
end
|
|
|
|
| "sx_diff_branch" ->
|
|
let base_ref = args |> member "ref" |> to_string_option |> Option.value ~default:"main" in
|
|
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
|
|
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in
|
|
Filename.dirname spec_dir
|
|
in
|
|
let cmd = Printf.sprintf "cd %s && git diff --name-only %s -- '*.sx' '*.sxc' 2>/dev/null" project_dir base_ref in
|
|
let ic = Unix.open_process_in cmd in
|
|
let files = ref [] in
|
|
(try while true do files := input_line ic :: !files done with End_of_file -> ());
|
|
ignore (Unix.close_process_in ic);
|
|
let changed = List.rev !files in
|
|
if changed = [] then text_result (Printf.sprintf "No .sx files changed since %s" base_ref)
|
|
else begin
|
|
let lines = List.filter_map (fun rel ->
|
|
let full = Filename.concat project_dir rel in
|
|
(* Get the base version via git show *)
|
|
let base_cmd = Printf.sprintf "cd %s && git show %s:%s 2>/dev/null" project_dir base_ref rel in
|
|
let ic2 = Unix.open_process_in base_cmd in
|
|
let base_lines = ref [] in
|
|
(try while true do base_lines := input_line ic2 :: !base_lines done with End_of_file -> ());
|
|
ignore (Unix.close_process_in ic2);
|
|
let base_src = String.concat "\n" (List.rev !base_lines) in
|
|
try
|
|
let tree_b = parse_file full in
|
|
if base_src = "" then
|
|
Some (Printf.sprintf "=== %s (new file) ===\n%s" rel
|
|
(value_to_string (call_sx "summarise" [tree_b; Number 1.0])))
|
|
else begin
|
|
let tree_a = List (Sx_parser.parse_all base_src) in
|
|
let diff = value_to_string (call_sx "tree-diff" [tree_a; tree_b]) in
|
|
if diff = "No differences" then None
|
|
else Some (Printf.sprintf "=== %s ===\n%s" rel diff)
|
|
end
|
|
with _ -> Some (Printf.sprintf "=== %s === (parse error)" rel)
|
|
) changed in
|
|
if lines = [] then text_result "All changed .sx files are structurally identical to base"
|
|
else text_result (String.concat "\n\n" lines)
|
|
end
|
|
|
|
| "sx_blame" ->
|
|
let file = args |> member "file" |> to_string in
|
|
let path_str_arg = args |> member "path" |> to_string_option in
|
|
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
|
|
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in
|
|
Filename.dirname spec_dir
|
|
in
|
|
(* Get the node's source span by parsing and finding line numbers *)
|
|
let tree = parse_file file in
|
|
let target_src = match path_str_arg with
|
|
| Some ps ->
|
|
let path = resolve_path tree ps in
|
|
let node = call_sx "navigate" [tree; path] in
|
|
if is_nil node then None
|
|
else Some (Sx_types.inspect node)
|
|
| None -> None
|
|
in
|
|
let rel_file = relative_path ~base:project_dir file in
|
|
let cmd = match target_src with
|
|
| Some src ->
|
|
(* Find the line range containing this source fragment *)
|
|
let first_line = String.sub src 0 (min 40 (String.length src)) in
|
|
let escaped = String.concat "" (List.of_seq (Seq.map (fun c ->
|
|
if c = '(' || c = ')' || c = '[' || c = ']' || c = '.' || c = '*' || c = '+' || c = '?' || c = '{' || c = '}' || c = '\\' || c = '|' || c = '^' || c = '$'
|
|
then Printf.sprintf "\\%c" c else String.make 1 c
|
|
) (String.to_seq first_line))) in
|
|
Printf.sprintf "cd %s && git blame -L '/%s/,+10' -- %s 2>/dev/null || git blame -- %s 2>/dev/null | head -20" project_dir escaped rel_file rel_file
|
|
| None ->
|
|
Printf.sprintf "cd %s && git blame -- %s 2>/dev/null | head -30" project_dir rel_file
|
|
in
|
|
let ic = Unix.open_process_in cmd in
|
|
let lines = ref [] in
|
|
(try while true do lines := input_line ic :: !lines done with End_of_file -> ());
|
|
ignore (Unix.close_process_in ic);
|
|
text_result (String.concat "\n" (List.rev !lines))
|
|
|
|
| "sx_doc_gen" ->
|
|
let dir = args |> member "dir" |> to_string in
|
|
let files = glob_sx_files dir in
|
|
let all_docs = List.concat_map (fun path ->
|
|
let rel = relative_path ~base:dir path in
|
|
try
|
|
let exprs = Sx_parser.parse_all (In_channel.with_open_text path In_channel.input_all) in
|
|
List.filter_map (fun expr ->
|
|
match expr with
|
|
| List (Symbol head :: Symbol name :: rest) | ListRef { contents = Symbol head :: Symbol name :: rest } ->
|
|
(match head with
|
|
| "defcomp" | "defisland" ->
|
|
let params_str = match rest with
|
|
| List ps :: _ | ListRef { contents = ps } :: _ ->
|
|
let keys = List.filter_map (fun p -> match p with
|
|
| Symbol s when s <> "&key" && s <> "&rest" && not (String.length s > 0 && s.[0] = '&') -> Some s
|
|
| List (Symbol s :: _) when s <> "&key" && s <> "&rest" -> Some (Printf.sprintf "%s (typed)" s)
|
|
| _ -> None) ps
|
|
in
|
|
let has_rest = List.exists (fun p -> match p with Symbol "&rest" -> true | _ -> false) ps in
|
|
let key_str = if keys = [] then "" else " Keys: " ^ String.concat ", " keys ^ "\n" in
|
|
let rest_str = if has_rest then " Children: yes\n" else "" in
|
|
key_str ^ rest_str
|
|
| _ -> ""
|
|
in
|
|
Some (Printf.sprintf "## %s `%s`\nDefined in: %s\nType: %s\n%s" head name rel head params_str)
|
|
| "defmacro" ->
|
|
Some (Printf.sprintf "## %s `%s`\nDefined in: %s\nType: macro\n" head name rel)
|
|
| _ -> None)
|
|
| _ -> None
|
|
) exprs
|
|
with _ -> []
|
|
) files in
|
|
if all_docs = [] then text_result "(no components found)"
|
|
else text_result (String.concat "\n" all_docs)
|
|
|
|
| "sx_nav" ->
|
|
let mode = (try args |> member "mode" |> to_string with _ -> "list") in
|
|
let section_filter = (try Some (args |> member "section" |> to_string) with _ -> None) in
|
|
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
|
|
try Sys.getenv "SX_ROOT" with Not_found -> Sys.getcwd () in
|
|
let sx_dir = project_dir ^ "/sx/sx" in
|
|
(* Extract all nav items from nav-data.sx AND nav-tree.sx *)
|
|
let scan_nav () =
|
|
let items = ref [] in
|
|
let seen = Hashtbl.create 64 in
|
|
let rec walk = function
|
|
| Dict d ->
|
|
(match Hashtbl.find_opt d "href", Hashtbl.find_opt d "label" with
|
|
| Some (String href), Some (String label) when not (Hashtbl.mem seen href) ->
|
|
Hashtbl.replace seen href ();
|
|
let summary = match Hashtbl.find_opt d "summary" with Some (String s) -> s | _ -> "" in
|
|
items := (href, label, summary) :: !items
|
|
| _ -> ());
|
|
Hashtbl.iter (fun _ v -> walk v) d
|
|
| List l | ListRef { contents = l } -> List.iter walk l
|
|
| _ -> ()
|
|
in
|
|
(* Scan both files — nav-data has the groups, nav-tree has the sidebar structure *)
|
|
List.iter (fun file ->
|
|
let src = try In_channel.with_open_text (sx_dir ^ "/" ^ file) In_channel.input_all with _ -> "" in
|
|
(* Evaluate defines so (dict :key val) calls produce Dict values *)
|
|
let exprs = try Sx_parser.parse_all src with _ -> [] in
|
|
List.iter (fun expr ->
|
|
try walk (Sx_ref.eval_expr expr (Env !env))
|
|
with _ -> walk expr (* fallback: walk unevaluated AST *)
|
|
) exprs
|
|
) ["nav-data.sx"; "nav-tree.sx"];
|
|
List.rev !items
|
|
in
|
|
let href_section href =
|
|
if String.length href > 5 && String.sub href 0 5 = "/sx/(" then
|
|
let rest = String.sub href 5 (String.length href - 6) in
|
|
match String.index_opt rest '.' with Some i -> String.sub rest 0 i | None -> rest
|
|
else ""
|
|
in
|
|
(* Scan all .sx files under sx_dir for defcomp/defisland *)
|
|
let scan_comps () =
|
|
let comps = ref [] in
|
|
let rec scan dir =
|
|
Array.iter (fun e ->
|
|
let p = dir ^ "/" ^ e in
|
|
if Sys.is_directory p then scan p
|
|
else if Filename.check_suffix e ".sx" then
|
|
List.iter (function
|
|
| List (Symbol "defcomp" :: Symbol n :: _)
|
|
| List (Symbol "defisland" :: Symbol n :: _) ->
|
|
comps := (n, Filename.basename p) :: !comps
|
|
| _ -> ()
|
|
) (try Sx_parser.parse_all (In_channel.with_open_text p In_channel.input_all) with _ -> [])
|
|
) (try Sys.readdir dir with _ -> [||])
|
|
in scan sx_dir; !comps
|
|
in
|
|
let scan_pagefns () =
|
|
let src = try In_channel.with_open_text (sx_dir ^ "/page-functions.sx") In_channel.input_all with _ -> "" in
|
|
List.filter_map (function
|
|
| List [Symbol "define"; Symbol n; _] -> Some n
|
|
| _ -> None
|
|
) (try Sx_parser.parse_all src with _ -> [])
|
|
in
|
|
(match mode with
|
|
| "list" ->
|
|
let items = scan_nav () in
|
|
let lines = List.filter_map (fun (href, label, summary) ->
|
|
let sec = href_section href in
|
|
match section_filter with
|
|
| Some f when f <> sec -> None
|
|
| _ ->
|
|
let s = if summary = "" then "" else " — " ^ (if String.length summary > 50 then String.sub summary 0 50 ^ "..." else summary) in
|
|
Some (Printf.sprintf " %-28s %s%s" label href s)
|
|
) items in
|
|
text_result (Printf.sprintf "%d nav items%s\n%s"
|
|
(List.length lines)
|
|
(match section_filter with Some s -> " in " ^ s | None -> "")
|
|
(String.concat "\n" lines))
|
|
| "check" ->
|
|
let items = scan_nav () in
|
|
let comps = scan_comps () in
|
|
let pfns = scan_pagefns () in
|
|
let issues = Buffer.create 256 in
|
|
let n = ref 0 in
|
|
let issue s = incr n; Buffer.add_string issues s; Buffer.add_char issues '\n' in
|
|
(* Duplicate hrefs *)
|
|
let seen = Hashtbl.create 64 in
|
|
List.iter (fun (href, label, _) ->
|
|
if Hashtbl.mem seen href then issue (Printf.sprintf "DUP %s (%s)" href label)
|
|
else Hashtbl.replace seen href ()
|
|
) items;
|
|
(* Check page function coverage *)
|
|
List.iter (fun (href, label, _) ->
|
|
let sec = href_section href in
|
|
if sec <> "" && not (List.mem sec pfns) && sec <> "sx" then
|
|
issue (Printf.sprintf "WARN no page-fn '%s' for %s (%s)" sec label href)
|
|
) items;
|
|
(* Components with -content suffix but no nav *)
|
|
let nav_src = try In_channel.with_open_text (sx_dir ^ "/nav-data.sx") In_channel.input_all with _ -> "" in
|
|
List.iter (fun (name, file) ->
|
|
if String.length name > 8 &&
|
|
String.sub name (String.length name - 8) 8 = "-content" then
|
|
let slug = String.sub name 1 (String.length name - 1) in (* remove ~ *)
|
|
let parts = String.split_on_char '/' slug in
|
|
let last = List.nth parts (List.length parts - 1) in
|
|
let check = String.sub last 0 (String.length last - 8) in (* remove -content *)
|
|
if not (try ignore (Str.search_forward (Str.regexp_string check) nav_src 0); true with Not_found -> false) then
|
|
issue (Printf.sprintf "INFO %s (%s) — no nav entry" name file)
|
|
) comps;
|
|
if !n = 0 then text_result "Nav check: all clear"
|
|
else text_result (Printf.sprintf "Nav check: %d issues\n%s" !n (Buffer.contents issues))
|
|
| "add" ->
|
|
let title = (try args |> member "title" |> to_string with _ -> "") in
|
|
let slug = (try args |> member "slug" |> to_string with _ -> "") in
|
|
let sec = (match section_filter with Some s -> s | None -> "applications") in
|
|
if title = "" || slug = "" then error_result "title and slug required"
|
|
else begin
|
|
let comp = Printf.sprintf "~%s/%s/content" sec slug in
|
|
let file = sx_dir ^ "/" ^ slug ^ ".sx" in
|
|
let href = Printf.sprintf "/sx/(%s.(%s))" sec slug in
|
|
if Sys.file_exists file then error_result ("exists: " ^ file)
|
|
else begin
|
|
(* Component file *)
|
|
let src = Printf.sprintf ";;; %s\n\n(defcomp %s ()\n (~docs/page :title \"%s\"\n (~docs/section :title \"Overview\" :id \"overview\"\n (p \"TODO\"))))\n" title comp title in
|
|
Out_channel.with_open_text file (fun oc -> output_string oc src);
|
|
(* Page function *)
|
|
let pf = sx_dir ^ "/page-functions.sx" in
|
|
let ps = In_channel.with_open_text pf In_channel.input_all in
|
|
Out_channel.with_open_text pf (fun oc ->
|
|
output_string oc ps;
|
|
Printf.fprintf oc "\n(define %s (make-page-fn \"%s\" \"~%s/%s/\" nil \"-content\"))\n" slug comp sec slug);
|
|
(* Nav entry *)
|
|
let nf = sx_dir ^ "/nav-data.sx" in
|
|
let ns = In_channel.with_open_text nf In_channel.input_all in
|
|
Out_channel.with_open_text nf (fun oc ->
|
|
output_string oc ns;
|
|
Printf.fprintf oc "\n(define %s-nav-items\n (list (dict :label \"%s\" :href \"%s\")))\n" slug title href);
|
|
text_result (Printf.sprintf "Created:\n File: %s\n Component: %s\n Page fn: %s\n Nav href: %s" file comp slug href)
|
|
end
|
|
end
|
|
| "delete" ->
|
|
let slug = (try args |> member "slug" |> to_string with _ -> "") in
|
|
if slug = "" then error_result "slug required"
|
|
else begin
|
|
let changes = Buffer.create 256 in
|
|
let log s = Buffer.add_string changes s; Buffer.add_char changes '\n' in
|
|
(* Helper: remove a top-level (define name ...) block from text *)
|
|
let remove_define_block text name =
|
|
let pattern = Printf.sprintf "(define %s " name in
|
|
match try Some (Str.search_forward (Str.regexp_string pattern) text 0) with Not_found -> None with
|
|
| None -> text
|
|
| Some start ->
|
|
(* Find matching close paren *)
|
|
let depth = ref 0 in
|
|
let finish = ref (String.length text) in
|
|
for i = start to String.length text - 1 do
|
|
if text.[i] = '(' then incr depth
|
|
else if text.[i] = ')' then begin
|
|
decr depth;
|
|
if !depth = 0 && !finish = String.length text then
|
|
finish := i + 1
|
|
end
|
|
done;
|
|
(* Also consume trailing newlines *)
|
|
let e = ref !finish in
|
|
while !e < String.length text && text.[!e] = '\n' do incr e done;
|
|
String.sub text 0 start ^ String.sub text !e (String.length text - !e)
|
|
in
|
|
(* 1. Remove from nav-data.sx *)
|
|
let nf = sx_dir ^ "/nav-data.sx" in
|
|
let ns = In_channel.with_open_text nf In_channel.input_all in
|
|
let nav_items_name = slug ^ "-nav-items" in
|
|
let ns2 = remove_define_block ns nav_items_name in
|
|
if ns2 <> ns then begin
|
|
Out_channel.with_open_text nf (fun oc -> output_string oc ns2);
|
|
log (Printf.sprintf "nav-data.sx: removed define %s" nav_items_name)
|
|
end;
|
|
(* 2. Remove from nav-tree.sx — find the dict block with matching href *)
|
|
let tf = sx_dir ^ "/nav-tree.sx" in
|
|
let ts = In_channel.with_open_text tf In_channel.input_all in
|
|
let href_pat = Printf.sprintf "\"(/sx/(%%.(%s" slug in
|
|
(* Match any section: find the (dict ... :href "/sx/(SECTION.(SLUG..." block *)
|
|
let slug_re = Str.regexp (Printf.sprintf ":href \"/sx/([a-z]+\\.(%s" (Str.quote slug)) in
|
|
let ts2 = match try Some (Str.search_forward slug_re ts 0) with Not_found -> None with
|
|
| None -> ignore href_pat; ts
|
|
| Some _ ->
|
|
(* Walk back to find the opening (dict *)
|
|
let href_pos = Str.match_beginning () in
|
|
let start = ref href_pos in
|
|
while !start > 0 && String.sub ts !start 4 <> "dict" do decr start done;
|
|
(* Back one more for the opening paren *)
|
|
while !start > 0 && ts.[!start] <> '(' do decr start done;
|
|
(* Find matching close paren *)
|
|
let depth = ref 0 in
|
|
let finish = ref (String.length ts) in
|
|
for i = !start to String.length ts - 1 do
|
|
if ts.[i] = '(' then incr depth
|
|
else if ts.[i] = ')' then begin
|
|
decr depth;
|
|
if !depth = 0 && !finish = String.length ts then
|
|
finish := i + 1
|
|
end
|
|
done;
|
|
(* Consume trailing whitespace/newlines *)
|
|
let e = ref !finish in
|
|
while !e < String.length ts && (ts.[!e] = '\n' || ts.[!e] = ' ') do incr e done;
|
|
log (Printf.sprintf "nav-tree.sx: removed entry for %s" slug);
|
|
String.sub ts 0 !start ^ String.sub ts !e (String.length ts - !e)
|
|
in
|
|
if ts2 <> ts then
|
|
Out_channel.with_open_text tf (fun oc -> output_string oc ts2);
|
|
(* 3. Remove from page-functions.sx *)
|
|
let pf = sx_dir ^ "/page-functions.sx" in
|
|
let ps = In_channel.with_open_text pf In_channel.input_all in
|
|
let ps2 = remove_define_block ps slug in
|
|
if ps2 <> ps then begin
|
|
Out_channel.with_open_text pf (fun oc -> output_string oc ps2);
|
|
log (Printf.sprintf "page-functions.sx: removed define %s" slug)
|
|
end;
|
|
text_result (Printf.sprintf "Deleted %s:\n%s" slug (Buffer.contents changes))
|
|
end
|
|
| "move" ->
|
|
let slug = (try args |> member "slug" |> to_string with _ -> "") in
|
|
let from_sec = (try args |> member "from" |> to_string with _ -> "") in
|
|
let to_sec = (try args |> member "to" |> to_string with _ ->
|
|
match section_filter with Some s -> s | None -> "") in
|
|
if slug = "" || from_sec = "" || to_sec = "" then
|
|
error_result "slug, from, and to (or section) required"
|
|
else if from_sec = to_sec then
|
|
error_result "from and to must differ"
|
|
else begin
|
|
let changes = Buffer.create 256 in
|
|
let log s = Buffer.add_string changes s; Buffer.add_char changes '\n' in
|
|
let old_prefix = from_sec ^ ".(" ^ slug in
|
|
let new_prefix = to_sec ^ ".(" ^ slug in
|
|
(* 1. Rewrite hrefs in nav-data.sx *)
|
|
let nf = sx_dir ^ "/nav-data.sx" in
|
|
let ns = In_channel.with_open_text nf In_channel.input_all in
|
|
let ns2 = Str.global_replace (Str.regexp_string old_prefix) new_prefix ns in
|
|
if ns2 <> ns then begin
|
|
Out_channel.with_open_text nf (fun oc -> output_string oc ns2);
|
|
log (Printf.sprintf "nav-data.sx: rewrote hrefs %s → %s" from_sec to_sec)
|
|
end;
|
|
(* 2. Move entry in nav-tree.sx: extract block from source, rewrite hrefs, insert into target *)
|
|
let tf = sx_dir ^ "/nav-tree.sx" in
|
|
let ts = In_channel.with_open_text tf In_channel.input_all in
|
|
(* First rewrite all hrefs *)
|
|
let ts2 = Str.global_replace (Str.regexp_string old_prefix) new_prefix ts in
|
|
(* Find the dict block for this slug *)
|
|
let slug_re = Str.regexp (Printf.sprintf ":href \"/sx/([a-z]+\\.(%s" (Str.quote slug)) in
|
|
let ts3 = match try Some (Str.search_forward slug_re ts2 0) with Not_found -> None with
|
|
| None ->
|
|
log "nav-tree.sx: hrefs rewritten (no entry block found to relocate)";
|
|
ts2
|
|
| Some _ ->
|
|
let href_pos = Str.match_beginning () in
|
|
(* Walk back to (dict *)
|
|
let start = ref href_pos in
|
|
while !start > 0 && String.sub ts2 !start 4 <> "dict" do decr start done;
|
|
while !start > 0 && ts2.[!start] <> '(' do decr start done;
|
|
(* Find matching close paren *)
|
|
let depth = ref 0 in
|
|
let finish = ref (String.length ts2) in
|
|
for i = !start to String.length ts2 - 1 do
|
|
if ts2.[i] = '(' then incr depth
|
|
else if ts2.[i] = ')' then begin
|
|
decr depth;
|
|
if !depth = 0 && !finish = String.length ts2 then
|
|
finish := i + 1
|
|
end
|
|
done;
|
|
let block = String.sub ts2 !start (!finish - !start) in
|
|
(* Remove block from source position *)
|
|
let e = ref !finish in
|
|
while !e < String.length ts2 && (ts2.[!e] = '\n' || ts2.[!e] = ' ') do incr e done;
|
|
let without = String.sub ts2 0 !start ^ String.sub ts2 !e (String.length ts2 - !e) in
|
|
(* Insert into target section — find the last child before the closing paren of target's :children *)
|
|
let target_href = Printf.sprintf "\"/sx/(%s)\"" to_sec in
|
|
(match try Some (Str.search_forward (Str.regexp_string target_href) without 0) with Not_found -> None with
|
|
| None ->
|
|
log (Printf.sprintf "nav-tree.sx: hrefs rewritten but target section %s not found" to_sec);
|
|
without
|
|
| Some _ ->
|
|
let target_pos = Str.match_beginning () in
|
|
(* Find :children after target_pos *)
|
|
let children_re = Str.regexp_string ":children" in
|
|
(match try Some (Str.search_forward children_re without target_pos) with Not_found -> None with
|
|
| None ->
|
|
log (Printf.sprintf "nav-tree.sx: target %s has no :children" to_sec);
|
|
without
|
|
| Some _ ->
|
|
let ch_pos = Str.match_beginning () in
|
|
(* Find the opening paren of the children list *)
|
|
let lp = ref (ch_pos + 9) in
|
|
while !lp < String.length without && without.[!lp] <> '(' do incr lp done;
|
|
(* Find its matching close paren *)
|
|
let d = ref 0 in
|
|
let close = ref (String.length without) in
|
|
for i = !lp to String.length without - 1 do
|
|
if without.[i] = '(' then incr d
|
|
else if without.[i] = ')' then begin
|
|
decr d;
|
|
if !d = 0 && !close = String.length without then
|
|
close := i
|
|
end
|
|
done;
|
|
(* Insert block just before the closing paren *)
|
|
let indent = "\n " in
|
|
let result = String.sub without 0 !close ^ indent ^ block ^ String.sub without !close (String.length without - !close) in
|
|
log (Printf.sprintf "nav-tree.sx: moved %s from %s to %s" slug from_sec to_sec);
|
|
result))
|
|
in
|
|
Out_channel.with_open_text tf (fun oc -> output_string oc ts3);
|
|
(* 3. Rewrite page-functions.sx component prefix if needed *)
|
|
let pf = sx_dir ^ "/page-functions.sx" in
|
|
let ps = In_channel.with_open_text pf In_channel.input_all in
|
|
let old_comp_prefix = "~" ^ from_sec ^ "/" ^ slug ^ "/" in
|
|
let new_comp_prefix = "~" ^ to_sec ^ "/" ^ slug ^ "/" in
|
|
let ps2 = Str.global_replace (Str.regexp_string old_comp_prefix) new_comp_prefix ps in
|
|
if ps2 <> ps then begin
|
|
Out_channel.with_open_text pf (fun oc -> output_string oc ps2);
|
|
log (Printf.sprintf "page-functions.sx: rewrote %s → %s" old_comp_prefix new_comp_prefix)
|
|
end;
|
|
text_result (Printf.sprintf "Moved %s: %s → %s\n%s" slug from_sec to_sec (Buffer.contents changes))
|
|
end
|
|
| m -> error_result (Printf.sprintf "unknown mode: %s (list, check, add, move, delete)" m))
|
|
|
|
| "sx_playwright" ->
|
|
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
|
|
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in
|
|
Filename.dirname spec_dir
|
|
in
|
|
let spec = args |> member "spec" |> to_string_option in
|
|
let mode = args |> member "mode" |> to_string_option in
|
|
let url = args |> member "url" |> to_string_option in
|
|
let selector = args |> member "selector" |> to_string_option in
|
|
let expr = args |> member "expr" |> to_string_option in
|
|
let actions = args |> member "actions" |> to_string_option in
|
|
let island = args |> member "island" |> to_string_option in
|
|
(* Determine whether to run specs or the inspector *)
|
|
let use_inspector = match mode with
|
|
| Some m when m <> "run" -> true
|
|
| _ -> spec = None && mode <> None
|
|
in
|
|
if not use_inspector then begin
|
|
(* Original spec runner *)
|
|
let spec_arg = match spec with Some s -> " " ^ s | None -> "" in
|
|
let cmd = Printf.sprintf "cd %s/tests/playwright && npx playwright test%s --reporter=line 2>&1" project_dir spec_arg in
|
|
let ic = Unix.open_process_in cmd in
|
|
let lines = ref [] in
|
|
(try while true do lines := input_line ic :: !lines done with End_of_file -> ());
|
|
ignore (Unix.close_process_in ic);
|
|
let all_lines = List.rev !lines in
|
|
let fails = List.filter (fun l -> let t = String.trim l in
|
|
String.length t > 1 && (t.[0] = '\xE2' (* ✘ *) || (String.length t > 4 && String.sub t 0 4 = "FAIL"))) all_lines in
|
|
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
|
|
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 - 10) all_lines in
|
|
String.concat "\n" last_n
|
|
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);
|
|
]) in
|
|
let args_json = Yojson.Basic.to_string inspector_args in
|
|
(* Single-quote shell wrapping — escape any literal single quotes in JSON *)
|
|
let shell_safe = String.concat "'\\''" (String.split_on_char '\'' args_json) in
|
|
let cmd = Printf.sprintf "cd %s && node tests/playwright/sx-inspect.js '%s' 2>&1" project_dir shell_safe in
|
|
let ic = Unix.open_process_in cmd in
|
|
let lines = ref [] in
|
|
(try while true do lines := input_line ic :: !lines done with End_of_file -> ());
|
|
ignore (Unix.close_process_in ic);
|
|
let raw = String.concat "\n" (List.rev !lines) in
|
|
(* Try to parse as JSON and format nicely *)
|
|
try
|
|
let json = Yojson.Basic.from_string raw in
|
|
let pretty = Yojson.Basic.pretty_to_string json in
|
|
text_result pretty
|
|
with _ ->
|
|
text_result raw
|
|
end
|
|
|
|
| "sx_harness_eval" ->
|
|
let expr_str = args |> member "expr" |> to_string in
|
|
let mock_str = args |> member "mock" |> to_string_option in
|
|
let file = args |> member "file" |> to_string_option in
|
|
let setup_str = args |> member "setup" |> to_string_option in
|
|
let files_json = try args |> member "files" with _ -> `Null in
|
|
let e = !env in
|
|
let warnings = ref [] in
|
|
(* Collect all files to load *)
|
|
let all_files = match files_json with
|
|
| `List items ->
|
|
List.map (fun j -> Yojson.Safe.Util.to_string j) items
|
|
| _ -> match file with Some f -> [f] | None -> []
|
|
in
|
|
(* Load each file *)
|
|
List.iter (fun f ->
|
|
try load_sx_file e f
|
|
with exn ->
|
|
warnings := Printf.sprintf "Warning: %s: %s" f (Printexc.to_string exn) :: !warnings
|
|
) all_files;
|
|
(* Run setup expression if provided *)
|
|
(match setup_str with
|
|
| Some s ->
|
|
let setup_exprs = Sx_parser.parse_all s in
|
|
List.iter (fun expr ->
|
|
try ignore (Sx_ref.eval_expr expr (Env e))
|
|
with exn ->
|
|
warnings := Printf.sprintf "Setup error: %s" (Printexc.to_string exn) :: !warnings
|
|
) setup_exprs
|
|
| None -> ());
|
|
(* Create harness with optional mock overrides *)
|
|
let mock_arg = match mock_str with
|
|
| Some s ->
|
|
let parsed = Sx_parser.parse_all s in
|
|
if parsed <> [] then List [Keyword "platform"; List.hd parsed] else List []
|
|
| None -> List []
|
|
in
|
|
let session = Sx_ref.cek_call (env_get e "make-harness") mock_arg in
|
|
(* Install interceptors *)
|
|
ignore (call_sx "install-interceptors" [session; Env e]);
|
|
(* Evaluate the expression *)
|
|
let exprs = Sx_parser.parse_all expr_str in
|
|
let result = List.fold_left (fun _acc expr ->
|
|
try Sx_ref.eval_expr expr (Env e)
|
|
with exn -> String (Printf.sprintf "Error: %s" (Printexc.to_string exn))
|
|
) Nil exprs in
|
|
(* Get the IO log *)
|
|
let log = call_sx "harness-log" [session] in
|
|
let log_str = match log with
|
|
| List items | ListRef { contents = items } when items <> [] ->
|
|
"\n\nIO Log:\n" ^ String.concat "\n" (List.map (fun entry ->
|
|
let op = value_to_string (call_sx "get" [entry; String "op"]) in
|
|
let args_val = call_sx "get" [entry; String "args"] in
|
|
Printf.sprintf " %s(%s)" op (Sx_types.inspect args_val)
|
|
) items)
|
|
| _ -> "\n\n(no IO calls)"
|
|
in
|
|
let warn_str = if !warnings = [] then "" else
|
|
"\n\nWarnings:\n" ^ String.concat "\n" (List.rev !warnings)
|
|
in
|
|
text_result (Printf.sprintf "Result: %s%s%s" (Sx_types.inspect result) log_str warn_str)
|
|
|
|
| "sx_write_file" ->
|
|
let file = args |> member "file" |> to_string in
|
|
let source = args |> member "source" |> to_string in
|
|
(* Validate by parsing first *)
|
|
(try
|
|
let exprs = Sx_parser.parse_all source in
|
|
if exprs = [] then error_result "Source parsed to empty — nothing to write"
|
|
else begin
|
|
let output = pretty_print_file exprs in
|
|
Out_channel.with_open_text file (fun oc -> output_string oc output);
|
|
text_result (Printf.sprintf "OK — wrote %d bytes (%d top-level forms) to %s" (String.length output) (List.length exprs) file)
|
|
end
|
|
with e -> error_result (Printf.sprintf "Parse error — file not written: %s" (Printexc.to_string e)))
|
|
|
|
| "sx_rename_symbol" ->
|
|
let file = args |> member "file" |> to_string in
|
|
let tree = parse_file 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 file (Dict (let d = Hashtbl.create 2 in Hashtbl.replace d "ok" new_tree; d))
|
|
|> (fun result ->
|
|
match result with
|
|
| `Assoc [("content", `List [`Assoc [("type", _); ("text", `String s)]])] when not (String.starts_with ~prefix:"Error" s) ->
|
|
text_result (Printf.sprintf "Renamed %s occurrences of '%s' → '%s' in %s" count_str old_name new_name file)
|
|
| other -> other)
|
|
|
|
| "sx_replace_by_pattern" ->
|
|
let file = args |> member "file" |> to_string in
|
|
let tree = parse_file 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 file (call_sx "replace-all-by-pattern" [tree; String pattern; String src])
|
|
else
|
|
write_edit file (call_sx "replace-by-pattern" [tree; String pattern; String src])
|
|
|
|
| "sx_insert_near" ->
|
|
let file = args |> member "file" |> to_string in
|
|
let tree = parse_file 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 file (call_sx "insert-near-pattern" [tree; String pattern; String position; String src])
|
|
|
|
| "sx_rename_across" ->
|
|
let dir = args |> member "dir" |> to_string in
|
|
let old_name = args |> member "old_name" |> to_string in
|
|
let new_name = args |> member "new_name" |> to_string in
|
|
let dry_run = args |> member "dry_run" |> to_bool_option |> Option.value ~default:false in
|
|
let files = glob_sx_files dir in
|
|
let results = List.filter_map (fun path ->
|
|
let rel = relative_path ~base:dir path in
|
|
try
|
|
let tree = parse_file path in
|
|
let count = call_sx "count-renames" [tree; String old_name] in
|
|
match count with
|
|
| Number n when n > 0.0 ->
|
|
if dry_run then
|
|
Some (Printf.sprintf "%s: %d occurrences (dry run)" rel (int_of_float n))
|
|
else begin
|
|
let new_tree = call_sx "rename-symbol" [tree; String old_name; String new_name] in
|
|
let items = match new_tree with
|
|
| List items | ListRef { contents = items } -> items
|
|
| _ -> [new_tree]
|
|
in
|
|
let source = pretty_print_file items in
|
|
Out_channel.with_open_text path (fun oc -> output_string oc source);
|
|
Some (Printf.sprintf "%s: %d occurrences renamed" rel (int_of_float n))
|
|
end
|
|
| _ -> None
|
|
with _ -> None
|
|
) files in
|
|
if results = [] then text_result (Printf.sprintf "No occurrences of '%s' found" old_name)
|
|
else text_result (String.concat "\n" results)
|
|
|
|
| "sx_comp_list" ->
|
|
let dir = args |> member "dir" |> to_string in
|
|
let files = glob_sx_files dir in
|
|
let all_lines = List.concat_map (fun path ->
|
|
let rel = relative_path ~base:dir path in
|
|
try
|
|
let exprs = Sx_parser.parse_all (In_channel.with_open_text path In_channel.input_all) in
|
|
List.filter_map (fun expr ->
|
|
match expr with
|
|
| List (Symbol head :: Symbol name :: rest) | ListRef { contents = Symbol head :: Symbol name :: rest } ->
|
|
(match head with
|
|
| "defcomp" | "defisland" | "defmacro" | "defpage" | "define" ->
|
|
let params = match rest with
|
|
| List ps :: _ | ListRef { contents = ps } :: _ ->
|
|
String.concat " " (List.map Sx_runtime.value_to_str ps)
|
|
| _ -> ""
|
|
in
|
|
Some (Printf.sprintf "%-10s %-40s %-50s %s" head name rel params)
|
|
| _ -> None)
|
|
| _ -> None
|
|
) exprs
|
|
with _ -> []
|
|
) files in
|
|
if all_lines = [] then text_result "(no definitions found)"
|
|
else text_result (Printf.sprintf "%-10s %-40s %-50s %s\n%s" "TYPE" "NAME" "FILE" "PARAMS" (String.concat "\n" all_lines))
|
|
|
|
| "sx_find_across" ->
|
|
let dir = args |> member "dir" |> to_string in
|
|
let pattern = args |> member "pattern" |> to_string in
|
|
let files = glob_sx_files dir in
|
|
let all_lines = List.concat_map (fun path ->
|
|
let rel = relative_path ~base:dir path in
|
|
try
|
|
let tree = parse_file path in
|
|
let results = call_sx "find-all" [tree; String pattern] in
|
|
(match results with
|
|
| List items | ListRef { contents = items } ->
|
|
List.map (fun item ->
|
|
match item with
|
|
| List [p; s] | ListRef { contents = [p; s] } ->
|
|
rel ^ " " ^ value_to_string (call_sx "path-str" [p]) ^ " " ^ value_to_string s
|
|
| _ -> rel ^ " " ^ value_to_string item
|
|
) items
|
|
| _ -> [])
|
|
with _ -> []
|
|
) files in
|
|
if all_lines = [] then text_result "(no matches)"
|
|
else text_result (String.concat "\n" all_lines)
|
|
|
|
| "sx_diff" ->
|
|
let file_a = args |> member "file_a" |> to_string in
|
|
let file_b = args |> member "file_b" |> to_string in
|
|
let tree_a = parse_file file_a in
|
|
let tree_b = parse_file file_b in
|
|
text_result (value_to_string (call_sx "tree-diff" [tree_a; tree_b]))
|
|
|
|
| "sx_comp_usage" ->
|
|
let dir = args |> member "dir" |> to_string in
|
|
let name = args |> member "name" |> to_string in
|
|
let files = glob_sx_files dir in
|
|
let all_lines = List.concat_map (fun path ->
|
|
let rel = relative_path ~base:dir path in
|
|
try
|
|
let tree = parse_file path in
|
|
let results = call_sx "find-all" [tree; String name] in
|
|
(match results with
|
|
| List items | ListRef { contents = items } ->
|
|
List.map (fun item ->
|
|
match item with
|
|
| List [p; s] | ListRef { contents = [p; s] } ->
|
|
rel ^ " " ^ value_to_string (call_sx "path-str" [p]) ^ " " ^ value_to_string s
|
|
| _ -> rel ^ " " ^ value_to_string item
|
|
) items
|
|
| _ -> [])
|
|
with _ -> []
|
|
) files in
|
|
if all_lines = [] then text_result "(no usages found)"
|
|
else text_result (String.concat "\n" all_lines)
|
|
|
|
| "sx_eval" ->
|
|
let expr_str = args |> member "expr" |> to_string in
|
|
let exprs = Sx_parser.parse_all expr_str in
|
|
let e = !env in
|
|
let result = List.fold_left (fun _acc expr ->
|
|
Sx_ref.eval_expr expr (Env e)
|
|
) Nil exprs in
|
|
text_result (Sx_runtime.value_to_str result)
|
|
|
|
| "sx_guard" ->
|
|
let expr_str = args |> member "expr" |> to_string in
|
|
let file = try Some (args |> member "file" |> to_string) with _ -> None in
|
|
let e = !env in
|
|
(match file with
|
|
| Some f -> (try load_sx_file e f with _ -> ())
|
|
| None -> ());
|
|
let exprs = Sx_parser.parse_all expr_str in
|
|
let conditions = ref [] in
|
|
(* Evaluate with error recovery — catch Eval_error, log it, return placeholder *)
|
|
let result = ref Nil in
|
|
(try
|
|
result := List.fold_left (fun _acc expr ->
|
|
Sx_ref.eval_expr expr (Env e)
|
|
) Nil exprs
|
|
with Eval_error msg ->
|
|
let enhanced = Sx_ref.enhance_error_with_trace msg in
|
|
conditions := enhanced :: !conditions;
|
|
result := String ("<error: " ^ msg ^ ">"));
|
|
let cond_lines = match !conditions with
|
|
| [] -> ""
|
|
| cs -> "\n\nConditions signaled:\n" ^
|
|
String.concat "\n" (List.rev_map (fun c -> " - " ^ c) cs) in
|
|
text_result (Sx_runtime.value_to_str !result ^ cond_lines)
|
|
|
|
| "sx_render_trace" ->
|
|
let expr_str = args |> member "expr" |> to_string in
|
|
let file = try Some (args |> member "file" |> to_string) with _ -> None in
|
|
let e = !env in
|
|
(match file with
|
|
| Some f -> (try load_sx_file e f with _ -> ())
|
|
| None -> ());
|
|
let exprs = Sx_parser.parse_all expr_str in
|
|
let expr = match exprs with [e] -> e | _ -> List (Symbol "do" :: exprs) in
|
|
let trace = Buffer.create 2048 in
|
|
let truncate s n = if String.length s > n then String.sub s 0 n ^ "..." else s in
|
|
let expr_str = truncate (Sx_runtime.value_to_str expr) 60 in
|
|
let kind = match expr with
|
|
| Nil -> "nil" | Bool _ -> "bool" | Number _ -> "number"
|
|
| String _ -> "string" | Symbol _ -> "symbol" | Keyword _ -> "keyword"
|
|
| RawHTML _ -> "raw-html"
|
|
| List (Symbol s :: _) | ListRef { contents = Symbol s :: _ } ->
|
|
if List.mem s Sx_render.html_tags then "element:" ^ s
|
|
else if List.mem s ["if";"when";"cond";"case";"let";"let*";"do";"begin";"map";"filter";"define";"defcomp"] then "form:" ^ s
|
|
else "call:" ^ s
|
|
| List _ -> "list" | _ -> "other" in
|
|
Buffer.add_string trace (Printf.sprintf "→ %s %s\n" kind expr_str);
|
|
let result = (try
|
|
Sx_render.sx_render_to_html e expr e
|
|
with Sx_types.Eval_error msg -> "ERROR: " ^ Sx_ref.enhance_error_with_trace msg) in
|
|
let result_str = truncate result 60 in
|
|
Buffer.add_string trace (Printf.sprintf "← %s\n" result_str);
|
|
text_result (Printf.sprintf "Result: %s\n\nRender trace:\n%s" result (Buffer.contents trace))
|
|
|
|
| "sx_trace" ->
|
|
let expr_str = args |> member "expr" |> to_string in
|
|
let max_steps = (try args |> member "max_steps" |> to_int with _ -> 200) in
|
|
let file = try Some (args |> member "file" |> to_string) with _ -> None in
|
|
let components_only = (try args |> member "components_only" |> to_bool with _ -> false) in
|
|
let e = !env in
|
|
(match file with
|
|
| Some f -> (try load_sx_file e f with _ -> ())
|
|
| None -> ());
|
|
let exprs = Sx_parser.parse_all expr_str in
|
|
let expr = match exprs with [e] -> e | _ -> List exprs in
|
|
let state = ref (Sx_ref.make_cek_state expr (Env e) (List [])) in
|
|
let steps = Buffer.create 2048 in
|
|
let step_count = ref 0 in
|
|
let truncate s n = if String.length s > n then String.sub s 0 n ^ "..." else s in
|
|
(* Track comp-trace depth for component-only mode *)
|
|
let comp_depth = ref 0 in
|
|
let prev_comp_depth = ref 0 in
|
|
let get_frame_type kont = match kont with
|
|
| List (CekFrame f :: _) -> f.cf_type
|
|
| List (Dict d :: _) ->
|
|
(match Hashtbl.find_opt d "type" with Some (String s) -> s | _ -> "?")
|
|
| _ -> "done" in
|
|
let count_comp_trace kont =
|
|
let n = ref 0 in
|
|
let k = ref kont in
|
|
(try while true do
|
|
(match !k with
|
|
| List (CekFrame f :: rest) ->
|
|
if f.cf_type = "comp-trace" then incr n;
|
|
k := List rest
|
|
| List (Dict d :: rest) ->
|
|
(match Hashtbl.find_opt d "type" with
|
|
| Some (String "comp-trace") -> incr n | _ -> ());
|
|
k := List rest
|
|
| _ -> raise Exit)
|
|
done with Exit -> ());
|
|
!n in
|
|
(try
|
|
while !step_count < max_steps do
|
|
let s = !state in
|
|
(match s with
|
|
| CekState cs ->
|
|
incr step_count;
|
|
let n = !step_count in
|
|
if components_only then begin
|
|
let depth = count_comp_trace cs.cs_kont in
|
|
(if depth > !prev_comp_depth then begin
|
|
let indent = String.make (depth * 2) ' ' in
|
|
let ft = get_frame_type cs.cs_kont in
|
|
let name = (match cs.cs_kont with
|
|
| List (CekFrame f :: _) when f.cf_type = "comp-trace" ->
|
|
(match f.cf_name with String s -> s | _ -> "?")
|
|
| _ -> "?") in
|
|
Buffer.add_string steps
|
|
(Printf.sprintf "%s→ ENTER ~%s\n" indent name);
|
|
ignore ft
|
|
end else if depth < !prev_comp_depth then begin
|
|
let indent = String.make ((depth + 1) * 2) ' ' in
|
|
let val_str = if cs.cs_phase = "continue"
|
|
then truncate (Sx_runtime.value_to_str cs.cs_value) 60
|
|
else "..." in
|
|
Buffer.add_string steps
|
|
(Printf.sprintf "%s← EXIT → %s\n" indent val_str)
|
|
end);
|
|
prev_comp_depth := depth
|
|
end else begin
|
|
if cs.cs_phase = "eval" then begin
|
|
let ctrl = cs.cs_control in
|
|
(match ctrl with
|
|
| Symbol sym_name ->
|
|
let resolved = (try
|
|
let v = Sx_ref.eval_expr ctrl cs.cs_env in
|
|
truncate (Sx_runtime.value_to_str v) 60
|
|
with _ -> "???") in
|
|
Buffer.add_string steps
|
|
(Printf.sprintf "%3d LOOKUP %s → %s\n" n sym_name resolved)
|
|
| List (hd :: _) ->
|
|
let head_str = truncate (Sx_runtime.value_to_str hd) 30 in
|
|
let ctrl_str = truncate (Sx_runtime.value_to_str ctrl) 80 in
|
|
Buffer.add_string steps
|
|
(Printf.sprintf "%3d CALL %s\n" n ctrl_str);
|
|
ignore head_str
|
|
| _ ->
|
|
Buffer.add_string steps
|
|
(Printf.sprintf "%3d LITERAL %s\n" n
|
|
(truncate (Sx_runtime.value_to_str ctrl) 60)))
|
|
end else begin
|
|
let val_str = truncate (Sx_runtime.value_to_str cs.cs_value) 60 in
|
|
let ft = get_frame_type cs.cs_kont in
|
|
Buffer.add_string steps
|
|
(Printf.sprintf "%3d RETURN %s → %s\n" n val_str ft)
|
|
end
|
|
end;
|
|
ignore comp_depth;
|
|
(match Sx_ref.cek_terminal_p s with
|
|
| Bool true -> raise Exit
|
|
| _ -> ());
|
|
state := Sx_ref.cek_step s
|
|
| _ -> raise Exit)
|
|
done
|
|
with
|
|
| Exit -> ()
|
|
| Eval_error msg ->
|
|
let enhanced = Sx_ref.enhance_error_with_trace msg in
|
|
Buffer.add_string steps (Printf.sprintf "ERROR: %s\n" enhanced)
|
|
| exn ->
|
|
Buffer.add_string steps (Printf.sprintf "ERROR: %s\n" (Printexc.to_string exn)));
|
|
let final_val = (match !state with
|
|
| CekState cs -> Sx_runtime.value_to_str cs.cs_value
|
|
| v -> Sx_runtime.value_to_str v) in
|
|
text_result (Printf.sprintf "Result: %s\n\nTrace (%d steps):\n%s"
|
|
final_val !step_count (Buffer.contents steps))
|
|
|
|
| "sx_deps" ->
|
|
let file = args |> member "file" |> to_string in
|
|
let name = try Some (args |> member "name" |> to_string) with _ -> None in
|
|
let dir = try args |> member "dir" |> to_string with _ ->
|
|
try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
|
|
try Sys.getenv "PWD" with Not_found -> "." in
|
|
let tree = parse_file file in
|
|
(* Find the target subtree *)
|
|
let target = match name with
|
|
| Some n ->
|
|
(* Find the named define/defcomp/defisland *)
|
|
let items = match tree with List l | ListRef { contents = l } -> l | _ -> [tree] in
|
|
let found = List.find_opt (fun item ->
|
|
match item with
|
|
| List (Symbol head :: Symbol def_name :: _)
|
|
| List (Symbol head :: List (Symbol def_name :: _) :: _)
|
|
when (head = "define" || head = "defcomp" || head = "defisland" ||
|
|
head = "defmacro" || head = "deftest") ->
|
|
def_name = n || ("~" ^ def_name) = n || def_name = String.sub n 1 (String.length n - 1)
|
|
| _ -> false
|
|
) items in
|
|
(match found with Some f -> f | None -> tree)
|
|
| None -> tree
|
|
in
|
|
let free_syms = call_sx "collect-free-symbols" [target] in
|
|
let sym_names = match free_syms with
|
|
| List items | ListRef { contents = items } ->
|
|
List.filter_map (fun v -> match v with String s -> Some s | _ -> None) items
|
|
| _ -> []
|
|
in
|
|
(* Resolve where each symbol is defined *)
|
|
let file_defines = Hashtbl.create 32 in
|
|
let same_file_items = match tree with List l | ListRef { contents = l } -> l | _ -> [] in
|
|
List.iter (fun item ->
|
|
match item with
|
|
| List (Symbol head :: Symbol def_name :: _)
|
|
when (head = "define" || head = "defcomp" || head = "defisland" || head = "defmacro") ->
|
|
Hashtbl.replace file_defines def_name true
|
|
| _ -> ()
|
|
) same_file_items;
|
|
(* Check primitives *)
|
|
let is_prim name = try ignore (Sx_primitives.get_primitive name); true with _ -> false in
|
|
(* Scan directory for definitions *)
|
|
let all_sx_files = glob_sx_files dir in
|
|
let ext_defs = Hashtbl.create 64 in
|
|
List.iter (fun path ->
|
|
if path <> file then
|
|
try
|
|
let t = parse_file path in
|
|
let items = match t with List l | ListRef { contents = l } -> l | _ -> [] in
|
|
List.iter (fun item ->
|
|
match item with
|
|
| List (Symbol head :: Symbol def_name :: _)
|
|
when (head = "define" || head = "defcomp" || head = "defisland" || head = "defmacro") ->
|
|
if not (Hashtbl.mem ext_defs def_name) then
|
|
Hashtbl.replace ext_defs def_name (relative_path ~base:dir path)
|
|
| _ -> ()
|
|
) items
|
|
with _ -> ()
|
|
) all_sx_files;
|
|
(* Find use declarations *)
|
|
let use_decls = call_sx "find-use-declarations" [tree] in
|
|
let declared_modules = match use_decls with
|
|
| List items | ListRef { contents = items } ->
|
|
List.filter_map (fun v -> match v with String s -> Some s | _ -> None) items
|
|
| _ -> []
|
|
in
|
|
(* Format output *)
|
|
let lines = List.map (fun sym ->
|
|
if Hashtbl.mem file_defines sym then
|
|
Printf.sprintf " %-30s (same file)" sym
|
|
else if is_prim sym then
|
|
Printf.sprintf " %-30s [primitive]" sym
|
|
else match Hashtbl.find_opt ext_defs sym with
|
|
| Some path -> Printf.sprintf " %-30s %s" sym path
|
|
| None -> Printf.sprintf " %-30s ???" sym
|
|
) sym_names in
|
|
let header = match name with
|
|
| Some n -> Printf.sprintf "Dependencies of %s in %s" n file
|
|
| None -> Printf.sprintf "Dependencies of %s" file
|
|
in
|
|
let use_str = if declared_modules = [] then "" else
|
|
Printf.sprintf "\n\nDeclared modules (use):\n %s" (String.concat ", " declared_modules)
|
|
in
|
|
text_result (Printf.sprintf "%s\n%d symbols referenced:\n%s%s"
|
|
header (List.length sym_names) (String.concat "\n" lines) use_str)
|
|
|
|
| "sx_build_manifest" ->
|
|
let target = (try args |> member "target" |> to_string with _ -> "js") in
|
|
(match target with
|
|
| "ocaml" ->
|
|
let e = !env in
|
|
(* Collect all bindings from the env *)
|
|
let bindings = ref [] in
|
|
(* Walk env chain collecting all bindings *)
|
|
let rec collect_bindings env acc =
|
|
Hashtbl.iter (fun id v ->
|
|
if not (Hashtbl.mem acc id) then Hashtbl.replace acc id v
|
|
) env.bindings;
|
|
match env.parent with Some p -> collect_bindings p acc | None -> ()
|
|
in
|
|
let all = Hashtbl.create 256 in
|
|
collect_bindings e all;
|
|
Hashtbl.iter (fun id v ->
|
|
let k = Sx_types.unintern id in
|
|
let kind = match v with
|
|
| NativeFn _ -> "native"
|
|
| Lambda _ -> "lambda"
|
|
| Component _ -> "component"
|
|
| Island _ -> "island"
|
|
| Macro _ -> "macro"
|
|
| _ -> "value"
|
|
in
|
|
bindings := (k, kind) :: !bindings
|
|
) all;
|
|
let sorted = List.sort (fun (a,_) (b,_) -> String.compare a b) !bindings in
|
|
let by_kind = Hashtbl.create 8 in
|
|
List.iter (fun (name, kind) ->
|
|
let cur = try Hashtbl.find by_kind kind with Not_found -> [] in
|
|
Hashtbl.replace by_kind kind (name :: cur)
|
|
) sorted;
|
|
let sections = Buffer.create 2048 in
|
|
Buffer.add_string sections "OCaml Build Manifest\n====================\n\n";
|
|
Buffer.add_string sections (Printf.sprintf "Total bindings: %d\n\n" (List.length sorted));
|
|
Buffer.add_string sections "Loaded files: parser.sx, tree-tools.sx, harness.sx\n\n";
|
|
List.iter (fun kind ->
|
|
match Hashtbl.find_opt by_kind kind with
|
|
| Some names ->
|
|
let rev_names = List.rev names in
|
|
Buffer.add_string sections
|
|
(Printf.sprintf "%s (%d):\n %s\n\n" kind (List.length rev_names)
|
|
(String.concat ", " rev_names))
|
|
| None -> ()
|
|
) ["native"; "lambda"; "macro"; "component"; "island"; "value"];
|
|
text_result (Buffer.contents sections)
|
|
| _ ->
|
|
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
|
|
try Sys.getenv "PWD" with Not_found -> "." in
|
|
let cmd = Printf.sprintf "cd %s && python3 hosts/javascript/manifest.py 2>&1"
|
|
(Filename.quote project_dir) in
|
|
let ic = Unix.open_process_in cmd in
|
|
let buf = Buffer.create 4096 in
|
|
(try while true do Buffer.add_string buf (input_line ic ^ "\n") done
|
|
with End_of_file -> ());
|
|
ignore (Unix.close_process_in ic);
|
|
text_result (Buffer.contents buf))
|
|
|
|
| "sx_explain" ->
|
|
let form_name = args |> member "name" |> to_string in
|
|
let e = !env in
|
|
let result = try
|
|
let find_fn = env_get e "find-rule" in
|
|
Sx_ref.cek_call find_fn (List [String form_name])
|
|
with _ -> Nil in
|
|
(match result with
|
|
| Dict d ->
|
|
let get_str k = match Hashtbl.find_opt d k with
|
|
| Some (String s) -> s | Some v -> value_to_string v | None -> "" in
|
|
let effects = match Hashtbl.find_opt d "effects" with
|
|
| Some (List items) -> String.concat ", " (List.map value_to_string items)
|
|
| Some Nil -> "none" | _ -> "none" in
|
|
let examples = match Hashtbl.find_opt d "examples" with
|
|
| Some (String s) -> " " ^ s
|
|
| Some (List items) ->
|
|
String.concat "\n" (List.map (fun ex -> " " ^ value_to_string ex) items)
|
|
| _ -> " (none)" in
|
|
text_result (Printf.sprintf "%s\n Category: %s\n Pattern: %s\n Effects: %s\n\n%s\n\nExamples:\n%s"
|
|
(get_str "name") (get_str "category") (get_str "pattern") effects
|
|
(get_str "rule") examples)
|
|
| _ ->
|
|
(* Try listing by category *)
|
|
let cats_fn = try env_get e "rules-by-category" with _ -> Nil in
|
|
let cat_results = try Sx_ref.cek_call cats_fn (List [String form_name]) with _ -> Nil in
|
|
(match cat_results with
|
|
| List items when items <> [] ->
|
|
let lines = List.map (fun rule ->
|
|
match rule with
|
|
| Dict rd ->
|
|
let name = match Hashtbl.find_opt rd "name" with Some (String s) -> s | _ -> "?" in
|
|
let pattern = match Hashtbl.find_opt rd "pattern" with Some (String s) -> s | _ -> "" in
|
|
Printf.sprintf " %-16s %s" name pattern
|
|
| _ -> " " ^ value_to_string rule
|
|
) items in
|
|
text_result (Printf.sprintf "Category: %s (%d rules)\n\n%s"
|
|
form_name (List.length items) (String.concat "\n" lines))
|
|
| _ ->
|
|
(* List all categories *)
|
|
let all_cats = try Sx_ref.cek_call (env_get e "rule-categories") Nil with _ -> Nil in
|
|
let cat_str = match all_cats with
|
|
| List items -> String.concat ", " (List.filter_map (fun v ->
|
|
match v with String s -> Some s | _ -> None) items)
|
|
| _ -> "?" in
|
|
error_result (Printf.sprintf "No rule found for '%s'. Categories: %s" form_name cat_str)))
|
|
|
|
| _ -> error_result ("Unknown tool: " ^ name)
|
|
|
|
and write_edit file result =
|
|
match result with
|
|
| Dict d ->
|
|
(match Hashtbl.find_opt d "ok" with
|
|
| Some new_tree ->
|
|
let items = match new_tree with
|
|
| List items | ListRef { contents = items } -> items
|
|
| _ -> [new_tree]
|
|
in
|
|
let source = pretty_print_file items in
|
|
Out_channel.with_open_text file (fun oc -> output_string oc source);
|
|
text_result (Printf.sprintf "OK — wrote %d bytes to %s" (String.length source) file)
|
|
| None ->
|
|
let err = match Hashtbl.find_opt d "error" with
|
|
| Some (String s) -> s | Some v -> value_to_string v | None -> "Unknown error"
|
|
in
|
|
error_result ("Error: " ^ err))
|
|
| _ -> error_result "Unexpected result type"
|
|
|
|
(* ------------------------------------------------------------------ *)
|
|
(* MCP tool definitions *)
|
|
(* ------------------------------------------------------------------ *)
|
|
|
|
let tool name desc props required =
|
|
`Assoc [
|
|
("name", `String name);
|
|
("description", `String desc);
|
|
("inputSchema", `Assoc [
|
|
("type", `String "object");
|
|
("required", `List (List.map (fun r -> `String r) required));
|
|
("properties", `Assoc props)])]
|
|
|
|
let file_prop = ("file", `Assoc [("type", `String "string"); ("description", `String "Path to .sx file")])
|
|
let path_prop = ("path", `Assoc [("type", `String "string"); ("description", `String "SX path, e.g. \"(0 2 1)\"")])
|
|
let dir_prop = ("dir", `Assoc [("type", `String "string"); ("description", `String "Directory to scan recursively")])
|
|
|
|
let tool_definitions = `List [
|
|
tool "sx_read_tree" "Read an .sx file as an annotated tree with path labels. Auto-summarises large files (>200 lines). Use focus to expand only matching subtrees, max_depth for depth limit, or max_lines+offset for pagination."
|
|
[file_prop;
|
|
("focus", `Assoc [("type", `String "string"); ("description", `String "Pattern — expand matching subtrees, collapse rest")]);
|
|
("max_depth", `Assoc [("type", `String "integer"); ("description", `String "Depth limit (like summarise)")]);
|
|
("max_lines", `Assoc [("type", `String "integer"); ("description", `String "Max lines to return (pagination)")]);
|
|
("offset", `Assoc [("type", `String "integer"); ("description", `String "Line offset for pagination (default 0)")])]
|
|
["file"];
|
|
tool "sx_summarise" "Folded structural overview of an .sx file. Use to orient before drilling into a region."
|
|
[file_prop; ("depth", `Assoc [("type", `String "integer"); ("description", `String "Max depth (0=heads only)")])] ["file"; "depth"];
|
|
tool "sx_read_subtree" "Expand a specific subtree by path. Use after summarise to drill in."
|
|
[file_prop; path_prop] ["file"; "path"];
|
|
tool "sx_get_context" "Show enclosing chain from root to a target node."
|
|
[file_prop; path_prop] ["file"; "path"];
|
|
tool "sx_find_all" "Search for nodes matching a pattern. Returns paths and summaries."
|
|
[file_prop; ("pattern", `Assoc [("type", `String "string"); ("description", `String "Search pattern")])] ["file"; "pattern"];
|
|
tool "sx_get_siblings" "Show siblings of a node with target marked."
|
|
[file_prop; path_prop] ["file"; "path"];
|
|
tool "sx_validate" "Check structural integrity of an .sx file."
|
|
[file_prop] ["file"];
|
|
tool "sx_replace_node" "Replace node at path with new SX source. Fragment is parsed before file is touched."
|
|
[file_prop; path_prop; ("new_source", `Assoc [("type", `String "string"); ("description", `String "New SX source")])] ["file"; "path"; "new_source"];
|
|
tool "sx_insert_child" "Insert new child at index within a list node."
|
|
[file_prop; path_prop; ("index", `Assoc [("type", `String "integer"); ("description", `String "Insert position")]); ("new_source", `Assoc [("type", `String "string"); ("description", `String "New SX source")])] ["file"; "path"; "index"; "new_source"];
|
|
tool "sx_delete_node" "Remove node at path. Siblings shift to fill gap."
|
|
[file_prop; path_prop] ["file"; "path"];
|
|
tool "sx_wrap_node" "Wrap node in a new form. Use _ as placeholder, e.g. \"(when cond _)\"."
|
|
[file_prop; path_prop; ("wrapper", `Assoc [("type", `String "string"); ("description", `String "Wrapper with _ placeholder")])] ["file"; "path"; "wrapper"];
|
|
tool "sx_eval" "Evaluate an SX expression. Environment has parser + tree-tools + primitives."
|
|
[("expr", `Assoc [("type", `String "string"); ("description", `String "SX expression to evaluate")])] ["expr"];
|
|
tool "sx_guard" "Evaluate with error recovery. Catches errors, shows component trace, and continues. Returns result + any conditions signaled."
|
|
[("expr", `Assoc [("type", `String "string"); ("description", `String "SX expression to evaluate with error recovery")]);
|
|
("file", `Assoc [("type", `String "string"); ("description", `String "Optional .sx file to load for definitions")])] ["expr"];
|
|
tool "sx_render_trace" "Render an SX expression to HTML with full dispatch tracing. Shows which render path each sub-expression takes."
|
|
[("expr", `Assoc [("type", `String "string"); ("description", `String "SX expression to render with tracing")]);
|
|
("file", `Assoc [("type", `String "string"); ("description", `String "Optional .sx file to load for definitions")])] ["expr"];
|
|
tool "sx_trace" "Step-through SX evaluation showing each CEK machine step (symbol lookups, function calls, returns). Set components_only=true for component entry/exit only."
|
|
[("expr", `Assoc [("type", `String "string"); ("description", `String "SX expression to trace")]);
|
|
("file", `Assoc [("type", `String "string"); ("description", `String "Optional .sx file to load for definitions")]);
|
|
("max_steps", `Assoc [("type", `String "integer"); ("description", `String "Max CEK steps to show (default: 200)")]);
|
|
("components_only", `Assoc [("type", `String "boolean"); ("description", `String "Show only component entry/exit events (default: false)")])] ["expr"];
|
|
tool "sx_explain" "Explain SX evaluation rules. Pass a form name (if, let, map, ...) or category (literal, special-form, higher-order, ...)."
|
|
[("name", `Assoc [("type", `String "string"); ("description", `String "Form name or category to explain")])] ["name"];
|
|
tool "sx_deps" "Dependency analysis for a component or file. Shows all referenced symbols and where they're defined."
|
|
[file_prop;
|
|
("name", `Assoc [("type", `String "string"); ("description", `String "Specific define/defcomp/defisland to analyze")]);
|
|
("dir", `Assoc [("type", `String "string"); ("description", `String "Directory to search for definitions (default: project root)")])] ["file"];
|
|
tool "sx_build_manifest" "Show build manifest: which modules, primitives, adapters, and exports are included in a JS or OCaml build."
|
|
[("target", `Assoc [("type", `String "string"); ("description", `String "Build target: \"js\" (default) or \"ocaml\"")])] [];
|
|
tool "sx_find_across" "Search for a pattern across all .sx files under a directory. Returns file paths, tree paths, and summaries."
|
|
[dir_prop; ("pattern", `Assoc [("type", `String "string"); ("description", `String "Search pattern")])] ["dir"; "pattern"];
|
|
tool "sx_comp_list" "List all definitions (defcomp, defisland, defmacro, defpage, define) across .sx files in a directory."
|
|
[dir_prop] ["dir"];
|
|
tool "sx_comp_usage" "Find all uses of a component or symbol name across .sx files in a directory."
|
|
[dir_prop; ("name", `Assoc [("type", `String "string"); ("description", `String "Component or symbol name to search for")])] ["dir"; "name"];
|
|
tool "sx_diff" "Structural diff between two .sx files. Reports ADDED, REMOVED, CHANGED nodes with paths."
|
|
[("file_a", `Assoc [("type", `String "string"); ("description", `String "Path to first .sx file")]);
|
|
("file_b", `Assoc [("type", `String "string"); ("description", `String "Path to second .sx file")])] ["file_a"; "file_b"];
|
|
tool "sx_format_check" "Lint an .sx file for common issues: empty let bindings, missing bodies, duplicate params, structural problems."
|
|
[file_prop] ["file"];
|
|
tool "sx_macroexpand" "Evaluate an SX expression with a file's definitions loaded. Use to test macros — the file's defmacro forms are available."
|
|
[("file", `Assoc [("type", `String "string"); ("description", `String "Optional .sx file to load for macro/component definitions")]);
|
|
("expr", `Assoc [("type", `String "string"); ("description", `String "Expression to expand/evaluate")])]
|
|
["expr"];
|
|
tool "sx_build" "Build the SX runtime. Target \"js\" (default) builds sx-browser.js, \"ocaml\" runs dune build. Set full=true for extensions+types."
|
|
[("target", `Assoc [("type", `String "string"); ("description", `String "Build target: \"js\" (default) or \"ocaml\"")]);
|
|
("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)."
|
|
[("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")]);
|
|
("url", `Assoc [("type", `String "string"); ("description", `String "URL path to navigate to (default: /)")]);
|
|
("island", `Assoc [("type", `String "string"); ("description", `String "Filter inspect to a specific island by name (e.g. home/stepper)")]);
|
|
("selector", `Assoc [("type", `String "string"); ("description", `String "CSS selector for screenshot/listeners/trace modes")]);
|
|
("expr", `Assoc [("type", `String "string"); ("description", `String "JS expression (eval mode), selector (listeners/trace), or CDP command (cdp mode)")]);
|
|
("actions", `Assoc [("type", `String "string"); ("description", `String "Semicolon-separated action sequence (interact mode). Actions: click:sel, fill:sel:val, wait:ms, text:sel, html:sel, attrs:sel, screenshot, screenshot:sel, count:sel, visible:sel")])]
|
|
[];
|
|
]
|
|
|
|
(* ------------------------------------------------------------------ *)
|
|
(* JSON-RPC dispatch *)
|
|
(* ------------------------------------------------------------------ *)
|
|
|
|
let dispatch method_name params =
|
|
match method_name with
|
|
| "initialize" ->
|
|
`Assoc [
|
|
("protocolVersion", `String "2024-11-05");
|
|
("capabilities", `Assoc [("tools", `Assoc [])]);
|
|
("serverInfo", `Assoc [
|
|
("name", `String "sx-tree-tools");
|
|
("version", `String "0.1.0")])]
|
|
| "notifications/initialized" -> `Null
|
|
| "tools/list" -> `Assoc [("tools", tool_definitions)]
|
|
| "tools/call" ->
|
|
let open Yojson.Safe.Util in
|
|
let name = params |> member "name" |> to_string in
|
|
let args = params |> member "arguments" in
|
|
(try handle_tool name args
|
|
with e -> error_result ("Error: " ^ Printexc.to_string e))
|
|
| _ -> `Null
|
|
|
|
(* ------------------------------------------------------------------ *)
|
|
(* Stdio JSON-RPC main loop *)
|
|
(* ------------------------------------------------------------------ *)
|
|
|
|
let () =
|
|
setup_env ();
|
|
try while true do
|
|
let line = input_line stdin in
|
|
if String.length line > 0 then begin
|
|
let json = Yojson.Safe.from_string line in
|
|
let open Yojson.Safe.Util in
|
|
let meth = json |> member "method" |> to_string_option |> Option.value ~default:"" in
|
|
let params = json |> member "params" in
|
|
let id = json |> member "id" in
|
|
let result = dispatch meth params in
|
|
if id <> `Null then begin
|
|
let resp = `Assoc [
|
|
("jsonrpc", `String "2.0");
|
|
("id", id);
|
|
("result", result)] in
|
|
print_string (Yojson.Safe.to_string resp);
|
|
print_char '\n';
|
|
flush stdout
|
|
end
|
|
end
|
|
done
|
|
with End_of_file -> ()
|