OCaml bootstrapper Phase 2: HTML renderer, SX server, Python bridge
Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
36
hosts/ocaml/bin/debug_set.ml
Normal file
36
hosts/ocaml/bin/debug_set.ml
Normal file
@@ -0,0 +1,36 @@
|
||||
module T = Sx.Sx_types
|
||||
module P = Sx.Sx_parser
|
||||
module R = Sx.Sx_ref
|
||||
open T
|
||||
|
||||
let () =
|
||||
let env = T.make_env () in
|
||||
let eval src =
|
||||
let exprs = P.parse_all src in
|
||||
let result = ref Nil in
|
||||
List.iter (fun e -> result := R.eval_expr e (Env env)) exprs;
|
||||
!result
|
||||
in
|
||||
(* Test 1: basic set! in closure *)
|
||||
let r = eval "(let ((x 0)) (set! x 42) x)" in
|
||||
Printf.printf "basic set!: %s (expect 42)\n%!" (T.inspect r);
|
||||
|
||||
(* Test 2: set! through lambda call *)
|
||||
let r = eval "(let ((x 0)) (let ((f (fn () (set! x 99)))) (f) x))" in
|
||||
Printf.printf "set! via lambda: %s (expect 99)\n%!" (T.inspect r);
|
||||
|
||||
(* Test 3: counter pattern *)
|
||||
let r = eval "(do (define make-counter (fn () (let ((c 0)) (fn () (set! c (+ c 1)) c)))) (let ((counter (make-counter))) (counter) (counter) (counter)))" in
|
||||
Printf.printf "counter: %s (expect 3)\n%!" (T.inspect r);
|
||||
|
||||
(* Test 4: set! in for-each *)
|
||||
let r = eval "(let ((total 0)) (for-each (fn (n) (set! total (+ total n))) (list 1 2 3 4 5)) total)" in
|
||||
Printf.printf "set! in for-each: %s (expect 15)\n%!" (T.inspect r);
|
||||
|
||||
(* Test 5: append! in for-each *)
|
||||
ignore (T.env_bind env "append!" (NativeFn ("append!", fun args ->
|
||||
match args with
|
||||
| [List items; v] -> List (items @ [v])
|
||||
| _ -> raise (Eval_error "append!: expected list and value"))));
|
||||
let r = eval "(let ((log (list))) (for-each (fn (x) (append! log x)) (list 1 2 3)) log)" in
|
||||
Printf.printf "append! in for-each: %s (expect (1 2 3))\n%!" (T.inspect r)
|
||||
@@ -1,3 +1,3 @@
|
||||
(executable
|
||||
(name run_tests)
|
||||
(executables
|
||||
(names run_tests debug_set sx_server)
|
||||
(libraries sx))
|
||||
|
||||
1
hosts/ocaml/bin/dune_debug
Normal file
1
hosts/ocaml/bin/dune_debug
Normal file
@@ -0,0 +1 @@
|
||||
(executable (name debug_macro) (libraries sx))
|
||||
@@ -1,102 +1,539 @@
|
||||
(** Minimal test runner — verifies the OCaml foundation (types, parser, primitives).
|
||||
(** Test runner — runs the SX spec test suite against the transpiled CEK evaluator.
|
||||
|
||||
Eventually this will load test-framework.sx and run the full spec test
|
||||
suite against the transpiled evaluator. For now it exercises the parser
|
||||
and primitives directly. *)
|
||||
Provides the 5 platform functions required by test-framework.sx:
|
||||
try-call, report-pass, report-fail, push-suite, pop-suite
|
||||
|
||||
open Sx.Sx_types
|
||||
open Sx.Sx_parser
|
||||
open Sx.Sx_primitives
|
||||
Plus test helpers: sx-parse, cek-eval, env-*, equal?, etc.
|
||||
|
||||
Usage:
|
||||
dune exec bin/run_tests.exe # foundation + spec tests
|
||||
dune exec bin/run_tests.exe -- test-primitives # specific test
|
||||
dune exec bin/run_tests.exe -- --foundation # foundation only *)
|
||||
|
||||
module Sx_types = Sx.Sx_types
|
||||
module Sx_parser = Sx.Sx_parser
|
||||
module Sx_primitives = Sx.Sx_primitives
|
||||
module Sx_runtime = Sx.Sx_runtime
|
||||
module Sx_ref = Sx.Sx_ref
|
||||
module Sx_render = Sx.Sx_render
|
||||
|
||||
open Sx_types
|
||||
open Sx_parser
|
||||
open Sx_primitives
|
||||
open Sx_runtime
|
||||
open Sx_ref
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Test state *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let pass_count = ref 0
|
||||
let fail_count = ref 0
|
||||
let suite_stack : string list ref = ref []
|
||||
|
||||
let assert_eq name expected actual =
|
||||
if expected = actual then begin
|
||||
incr pass_count;
|
||||
Printf.printf " PASS: %s\n" name
|
||||
end else begin
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: %s — expected %s, got %s\n" name (inspect expected) (inspect actual)
|
||||
end
|
||||
(* ====================================================================== *)
|
||||
(* Deep equality — SX structural comparison *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let assert_true name v =
|
||||
if sx_truthy v then begin
|
||||
incr pass_count;
|
||||
Printf.printf " PASS: %s\n" name
|
||||
end else begin
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: %s — expected truthy, got %s\n" name (inspect v)
|
||||
end
|
||||
let rec deep_equal a b =
|
||||
match a, b with
|
||||
| Nil, Nil -> true
|
||||
| Bool a, Bool b -> a = b
|
||||
| Number a, Number b -> a = b
|
||||
| String a, String b -> a = b
|
||||
| Symbol a, Symbol b -> a = b
|
||||
| Keyword a, Keyword b -> a = b
|
||||
| (List a | ListRef { contents = a }), (List b | ListRef { contents = b }) ->
|
||||
List.length a = List.length b &&
|
||||
List.for_all2 deep_equal a b
|
||||
| Dict a, Dict b ->
|
||||
let ka = Hashtbl.fold (fun k _ acc -> k :: acc) a [] in
|
||||
let kb = Hashtbl.fold (fun k _ acc -> k :: acc) b [] in
|
||||
List.length ka = List.length kb &&
|
||||
List.for_all (fun k ->
|
||||
Hashtbl.mem b k &&
|
||||
deep_equal
|
||||
(match Hashtbl.find_opt a k with Some v -> v | None -> Nil)
|
||||
(match Hashtbl.find_opt b k with Some v -> v | None -> Nil)) ka
|
||||
| Lambda _, Lambda _ -> a == b (* identity *)
|
||||
| NativeFn _, NativeFn _ -> a == b
|
||||
| _ -> false
|
||||
|
||||
let call name args =
|
||||
match Hashtbl.find_opt primitives name with
|
||||
| Some f -> f args
|
||||
| None -> failwith ("Unknown primitive: " ^ name)
|
||||
(* ====================================================================== *)
|
||||
(* Build evaluator environment with test platform functions *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let () =
|
||||
let make_test_env () =
|
||||
let env = Sx_types.make_env () in
|
||||
|
||||
let bind name fn =
|
||||
ignore (Sx_types.env_bind env name (NativeFn (name, fn)))
|
||||
in
|
||||
|
||||
(* --- 5 platform functions required by test-framework.sx --- *)
|
||||
|
||||
bind "try-call" (fun args ->
|
||||
match args with
|
||||
| [thunk] ->
|
||||
(try
|
||||
(* Call the thunk: it's a lambda with no params *)
|
||||
let result = eval_expr (List [thunk]) (Env env) in
|
||||
ignore result;
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "ok" (Bool true);
|
||||
Dict d
|
||||
with
|
||||
| Eval_error msg ->
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "ok" (Bool false);
|
||||
Hashtbl.replace d "error" (String msg);
|
||||
Dict d
|
||||
| exn ->
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "ok" (Bool false);
|
||||
Hashtbl.replace d "error" (String (Printexc.to_string exn));
|
||||
Dict d)
|
||||
| _ -> raise (Eval_error "try-call: expected 1 arg"));
|
||||
|
||||
bind "report-pass" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
incr pass_count;
|
||||
let ctx = String.concat " > " (List.rev !suite_stack) in
|
||||
Printf.printf " PASS: %s > %s\n%!" ctx name;
|
||||
Nil
|
||||
| [v] ->
|
||||
incr pass_count;
|
||||
let ctx = String.concat " > " (List.rev !suite_stack) in
|
||||
Printf.printf " PASS: %s > %s\n%!" ctx (Sx_types.inspect v);
|
||||
Nil
|
||||
| _ -> raise (Eval_error "report-pass: expected 1 arg"));
|
||||
|
||||
bind "report-fail" (fun args ->
|
||||
match args with
|
||||
| [String name; String error] ->
|
||||
incr fail_count;
|
||||
let ctx = String.concat " > " (List.rev !suite_stack) in
|
||||
Printf.printf " FAIL: %s > %s: %s\n%!" ctx name error;
|
||||
Nil
|
||||
| [name_v; error_v] ->
|
||||
incr fail_count;
|
||||
let ctx = String.concat " > " (List.rev !suite_stack) in
|
||||
Printf.printf " FAIL: %s > %s: %s\n%!" ctx
|
||||
(Sx_types.value_to_string name_v)
|
||||
(Sx_types.value_to_string error_v);
|
||||
Nil
|
||||
| _ -> raise (Eval_error "report-fail: expected 2 args"));
|
||||
|
||||
bind "push-suite" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
suite_stack := name :: !suite_stack;
|
||||
let indent = String.make ((List.length !suite_stack - 1) * 2) ' ' in
|
||||
Printf.printf "%sSuite: %s\n%!" indent name;
|
||||
Nil
|
||||
| [v] ->
|
||||
let name = Sx_types.value_to_string v in
|
||||
suite_stack := name :: !suite_stack;
|
||||
let indent = String.make ((List.length !suite_stack - 1) * 2) ' ' in
|
||||
Printf.printf "%sSuite: %s\n%!" indent name;
|
||||
Nil
|
||||
| _ -> raise (Eval_error "push-suite: expected 1 arg"));
|
||||
|
||||
bind "pop-suite" (fun _args ->
|
||||
suite_stack := (match !suite_stack with _ :: t -> t | [] -> []);
|
||||
Nil);
|
||||
|
||||
(* --- Test helpers --- *)
|
||||
|
||||
bind "sx-parse" (fun args ->
|
||||
match args with
|
||||
| [String s] -> List (parse_all s)
|
||||
| _ -> raise (Eval_error "sx-parse: expected string"));
|
||||
|
||||
bind "sx-parse-one" (fun args ->
|
||||
match args with
|
||||
| [String s] ->
|
||||
let exprs = parse_all s in
|
||||
(match exprs with e :: _ -> e | [] -> Nil)
|
||||
| _ -> raise (Eval_error "sx-parse-one: expected string"));
|
||||
|
||||
bind "cek-eval" (fun args ->
|
||||
match args with
|
||||
| [String s] ->
|
||||
let exprs = parse_all s in
|
||||
(match exprs with
|
||||
| e :: _ -> eval_expr e (Env env)
|
||||
| [] -> Nil)
|
||||
| _ -> raise (Eval_error "cek-eval: expected string"));
|
||||
|
||||
bind "eval-expr-cek" (fun args ->
|
||||
match args with
|
||||
| [expr; e] -> eval_expr expr e
|
||||
| [expr] -> eval_expr expr (Env env)
|
||||
| _ -> raise (Eval_error "eval-expr-cek: expected 1-2 args"));
|
||||
|
||||
bind "test-env" (fun _args -> Env (Sx_types.env_extend env));
|
||||
|
||||
(* --- Environment operations --- *)
|
||||
|
||||
bind "env-get" (fun args ->
|
||||
match args with
|
||||
| [Env e; String k] -> Sx_types.env_get e k
|
||||
| [Env e; Keyword k] -> Sx_types.env_get e k
|
||||
| _ -> raise (Eval_error "env-get: expected env and string"));
|
||||
|
||||
bind "env-has?" (fun args ->
|
||||
match args with
|
||||
| [Env e; String k] -> Bool (Sx_types.env_has e k)
|
||||
| [Env e; Keyword k] -> Bool (Sx_types.env_has e k)
|
||||
| _ -> raise (Eval_error "env-has?: expected env and string"));
|
||||
|
||||
bind "env-bind!" (fun args ->
|
||||
match args with
|
||||
| [Env e; String k; v] -> Sx_types.env_bind e k v
|
||||
| [Env e; Keyword k; v] -> Sx_types.env_bind e k v
|
||||
| _ -> raise (Eval_error "env-bind!: expected env, key, value"));
|
||||
|
||||
bind "env-set!" (fun args ->
|
||||
match args with
|
||||
| [Env e; String k; v] -> Sx_types.env_set e k v
|
||||
| [Env e; Keyword k; v] -> Sx_types.env_set e k v
|
||||
| _ -> raise (Eval_error "env-set!: expected env, key, value"));
|
||||
|
||||
bind "env-extend" (fun args ->
|
||||
match args with
|
||||
| [Env e] -> Env (Sx_types.env_extend e)
|
||||
| _ -> raise (Eval_error "env-extend: expected env"));
|
||||
|
||||
bind "env-merge" (fun args ->
|
||||
match args with
|
||||
| [Env a; Env b] -> Env (Sx_types.env_merge a b)
|
||||
| _ -> raise (Eval_error "env-merge: expected 2 envs"));
|
||||
|
||||
(* --- Equality --- *)
|
||||
|
||||
bind "equal?" (fun args ->
|
||||
match args with
|
||||
| [a; b] -> Bool (deep_equal a b)
|
||||
| _ -> raise (Eval_error "equal?: expected 2 args"));
|
||||
|
||||
bind "identical?" (fun args ->
|
||||
match args with
|
||||
| [a; b] -> Bool (a == b)
|
||||
| _ -> raise (Eval_error "identical?: expected 2 args"));
|
||||
|
||||
(* --- Continuation support --- *)
|
||||
|
||||
bind "make-continuation" (fun args ->
|
||||
match args with
|
||||
| [f] ->
|
||||
let k v = sx_call f [v] in
|
||||
Continuation (k, None)
|
||||
| _ -> raise (Eval_error "make-continuation: expected 1 arg"));
|
||||
|
||||
bind "continuation?" (fun args ->
|
||||
match args with
|
||||
| [Continuation _] -> Bool true
|
||||
| [_] -> Bool false
|
||||
| _ -> raise (Eval_error "continuation?: expected 1 arg"));
|
||||
|
||||
bind "continuation-fn" (fun args ->
|
||||
match args with
|
||||
| [Continuation (f, _)] -> NativeFn ("continuation-fn-result", fun args ->
|
||||
match args with [v] -> f v | _ -> f Nil)
|
||||
| _ -> raise (Eval_error "continuation-fn: expected continuation"));
|
||||
|
||||
(* --- Core builtins used by test framework / test code --- *)
|
||||
|
||||
bind "assert" (fun args ->
|
||||
match args with
|
||||
| [cond] ->
|
||||
if not (sx_truthy cond) then raise (Eval_error "Assertion failed");
|
||||
Bool true
|
||||
| [cond; String msg] ->
|
||||
if not (sx_truthy cond) then raise (Eval_error ("Assertion error: " ^ msg));
|
||||
Bool true
|
||||
| [cond; msg] ->
|
||||
if not (sx_truthy cond) then
|
||||
raise (Eval_error ("Assertion error: " ^ Sx_types.value_to_string msg));
|
||||
Bool true
|
||||
| _ -> raise (Eval_error "assert: expected 1-2 args"));
|
||||
|
||||
bind "append!" (fun args ->
|
||||
match args with
|
||||
| [ListRef r; v] -> r := !r @ [v]; ListRef r (* mutate in place *)
|
||||
| [List items; v] -> List (items @ [v]) (* immutable fallback *)
|
||||
| _ -> raise (Eval_error "append!: expected list and value"));
|
||||
|
||||
(* --- HTML Renderer (from sx_render.ml library module) --- *)
|
||||
Sx.Sx_render.setup_render_env env;
|
||||
|
||||
(* --- Missing primitives referenced by tests --- *)
|
||||
|
||||
bind "upcase" (fun args ->
|
||||
match args with
|
||||
| [String s] -> String (String.uppercase_ascii s)
|
||||
| _ -> raise (Eval_error "upcase: expected string"));
|
||||
|
||||
bind "downcase" (fun args ->
|
||||
match args with
|
||||
| [String s] -> String (String.lowercase_ascii s)
|
||||
| _ -> raise (Eval_error "downcase: expected string"));
|
||||
|
||||
bind "make-keyword" (fun args ->
|
||||
match args with
|
||||
| [String s] -> Keyword s
|
||||
| _ -> raise (Eval_error "make-keyword: expected string"));
|
||||
|
||||
bind "string-length" (fun args ->
|
||||
match args with
|
||||
| [String s] -> Number (float_of_int (String.length s))
|
||||
| _ -> raise (Eval_error "string-length: expected string"));
|
||||
|
||||
bind "dict-get" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k] -> Sx_types.dict_get d k
|
||||
| [Dict d; Keyword k] -> Sx_types.dict_get d k
|
||||
| _ -> raise (Eval_error "dict-get: expected dict and key"));
|
||||
|
||||
bind "apply" (fun args ->
|
||||
match args with
|
||||
| f :: rest ->
|
||||
let all_args = match List.rev rest with
|
||||
| List last :: prefix -> List.rev prefix @ last
|
||||
| _ -> rest
|
||||
in
|
||||
sx_call f all_args
|
||||
| _ -> raise (Eval_error "apply: expected function and args"));
|
||||
|
||||
(* --- Type system helpers (for --full tests) --- *)
|
||||
|
||||
bind "test-prim-types" (fun _args ->
|
||||
let d = Hashtbl.create 40 in
|
||||
List.iter (fun (k, v) -> Hashtbl.replace d k (String v)) [
|
||||
"+", "number"; "-", "number"; "*", "number"; "/", "number";
|
||||
"mod", "number"; "inc", "number"; "dec", "number";
|
||||
"abs", "number"; "min", "number"; "max", "number";
|
||||
"floor", "number"; "ceil", "number"; "round", "number";
|
||||
"str", "string"; "upper", "string"; "lower", "string";
|
||||
"trim", "string"; "join", "string"; "replace", "string";
|
||||
"format", "string"; "substr", "string";
|
||||
"=", "boolean"; "<", "boolean"; ">", "boolean";
|
||||
"<=", "boolean"; ">=", "boolean"; "!=", "boolean";
|
||||
"not", "boolean"; "nil?", "boolean"; "empty?", "boolean";
|
||||
"number?", "boolean"; "string?", "boolean"; "boolean?", "boolean";
|
||||
"list?", "boolean"; "dict?", "boolean"; "symbol?", "boolean";
|
||||
"keyword?", "boolean"; "contains?", "boolean"; "has-key?", "boolean";
|
||||
"starts-with?", "boolean"; "ends-with?", "boolean";
|
||||
"len", "number"; "first", "any"; "rest", "list";
|
||||
"last", "any"; "nth", "any"; "cons", "list";
|
||||
"append", "list"; "concat", "list"; "reverse", "list";
|
||||
"sort", "list"; "slice", "list"; "range", "list";
|
||||
"flatten", "list"; "keys", "list"; "vals", "list";
|
||||
"map-dict", "dict"; "assoc", "dict"; "dissoc", "dict";
|
||||
"merge", "dict"; "dict", "dict";
|
||||
"get", "any"; "type-of", "string";
|
||||
];
|
||||
Dict d);
|
||||
|
||||
bind "test-prim-param-types" (fun _args ->
|
||||
let d = Hashtbl.create 10 in
|
||||
let pos name typ =
|
||||
let d2 = Hashtbl.create 2 in
|
||||
Hashtbl.replace d2 "positional" (List [List [String name; String typ]]);
|
||||
Hashtbl.replace d2 "rest-type" Nil;
|
||||
Dict d2
|
||||
in
|
||||
let pos_rest name typ rt =
|
||||
let d2 = Hashtbl.create 2 in
|
||||
Hashtbl.replace d2 "positional" (List [List [String name; String typ]]);
|
||||
Hashtbl.replace d2 "rest-type" (String rt);
|
||||
Dict d2
|
||||
in
|
||||
Hashtbl.replace d "+" (pos_rest "a" "number" "number");
|
||||
Hashtbl.replace d "-" (pos_rest "a" "number" "number");
|
||||
Hashtbl.replace d "*" (pos_rest "a" "number" "number");
|
||||
Hashtbl.replace d "/" (pos_rest "a" "number" "number");
|
||||
Hashtbl.replace d "inc" (pos "n" "number");
|
||||
Hashtbl.replace d "dec" (pos "n" "number");
|
||||
Hashtbl.replace d "upper" (pos "s" "string");
|
||||
Hashtbl.replace d "lower" (pos "s" "string");
|
||||
Hashtbl.replace d "keys" (pos "d" "dict");
|
||||
Hashtbl.replace d "vals" (pos "d" "dict");
|
||||
Dict d);
|
||||
|
||||
(* --- Component accessors --- *)
|
||||
|
||||
bind "component-param-types" (fun _args -> Nil);
|
||||
|
||||
bind "component-set-param-types!" (fun _args -> Nil);
|
||||
|
||||
bind "component-params" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> List (List.map (fun s -> String s) c.c_params)
|
||||
| _ -> Nil);
|
||||
|
||||
bind "component-body" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> c.c_body
|
||||
| _ -> Nil);
|
||||
|
||||
bind "component-has-children" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> Bool c.c_has_children
|
||||
| _ -> Bool false);
|
||||
|
||||
bind "component-affinity" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> String c.c_affinity
|
||||
| _ -> String "auto");
|
||||
|
||||
(* --- Parser test helpers --- *)
|
||||
|
||||
bind "keyword-name" (fun args ->
|
||||
match args with
|
||||
| [Keyword k] -> String k
|
||||
| _ -> raise (Eval_error "keyword-name: expected keyword"));
|
||||
|
||||
bind "symbol-name" (fun args ->
|
||||
match args with
|
||||
| [Symbol s] -> String s
|
||||
| _ -> raise (Eval_error "symbol-name: expected symbol"));
|
||||
|
||||
bind "sx-serialize" (fun args ->
|
||||
match args with
|
||||
| [v] -> String (Sx_types.inspect v)
|
||||
| _ -> raise (Eval_error "sx-serialize: expected 1 arg"));
|
||||
|
||||
(* --- make-symbol --- *)
|
||||
|
||||
bind "make-symbol" (fun args ->
|
||||
match args with
|
||||
| [String s] -> Symbol s
|
||||
| [v] -> Symbol (Sx_types.value_to_string v)
|
||||
| _ -> raise (Eval_error "make-symbol: expected 1 arg"));
|
||||
|
||||
(* --- CEK stepping / introspection --- *)
|
||||
|
||||
bind "make-cek-state" (fun args ->
|
||||
match args with
|
||||
| [ctrl; env'; kont] -> Sx_ref.make_cek_state ctrl env' kont
|
||||
| _ -> raise (Eval_error "make-cek-state: expected 3 args"));
|
||||
|
||||
bind "cek-step" (fun args ->
|
||||
match args with
|
||||
| [state] -> Sx_ref.cek_step state
|
||||
| _ -> raise (Eval_error "cek-step: expected 1 arg"));
|
||||
|
||||
bind "cek-phase" (fun args ->
|
||||
match args with
|
||||
| [state] -> Sx_ref.cek_phase state
|
||||
| _ -> raise (Eval_error "cek-phase: expected 1 arg"));
|
||||
|
||||
bind "cek-value" (fun args ->
|
||||
match args with
|
||||
| [state] -> Sx_ref.cek_value state
|
||||
| _ -> raise (Eval_error "cek-value: expected 1 arg"));
|
||||
|
||||
bind "cek-terminal?" (fun args ->
|
||||
match args with
|
||||
| [state] -> Sx_ref.cek_terminal_p state
|
||||
| _ -> raise (Eval_error "cek-terminal?: expected 1 arg"));
|
||||
|
||||
bind "cek-kont" (fun args ->
|
||||
match args with
|
||||
| [state] -> Sx_ref.cek_kont state
|
||||
| _ -> raise (Eval_error "cek-kont: expected 1 arg"));
|
||||
|
||||
bind "frame-type" (fun args ->
|
||||
match args with
|
||||
| [frame] -> Sx_ref.frame_type frame
|
||||
| _ -> raise (Eval_error "frame-type: expected 1 arg"));
|
||||
|
||||
(* --- Strict mode --- *)
|
||||
(* *strict* is a plain value in the env, mutated via env_set by set-strict! *)
|
||||
ignore (Sx_types.env_bind env "*strict*" (Bool false));
|
||||
ignore (Sx_types.env_bind env "*prim-param-types*" Nil);
|
||||
|
||||
bind "set-strict!" (fun args ->
|
||||
match args with
|
||||
| [v] ->
|
||||
Sx_ref._strict_ref := v;
|
||||
ignore (Sx_types.env_set env "*strict*" v); Nil
|
||||
| _ -> raise (Eval_error "set-strict!: expected 1 arg"));
|
||||
|
||||
bind "set-prim-param-types!" (fun args ->
|
||||
match args with
|
||||
| [v] ->
|
||||
Sx_ref._prim_param_types_ref := v;
|
||||
ignore (Sx_types.env_set env "*prim-param-types*" v); Nil
|
||||
| _ -> raise (Eval_error "set-prim-param-types!: expected 1 arg"));
|
||||
|
||||
bind "value-matches-type?" (fun args ->
|
||||
match args with
|
||||
| [v; String expected] -> Sx_ref.value_matches_type_p v (String expected)
|
||||
| _ -> raise (Eval_error "value-matches-type?: expected value and type string"));
|
||||
|
||||
env
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Foundation tests (direct, no evaluator) *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let run_foundation_tests () =
|
||||
Printf.printf "=== SX OCaml Foundation Tests ===\n\n";
|
||||
|
||||
(* --- Parser tests --- *)
|
||||
let assert_eq name expected actual =
|
||||
if deep_equal expected actual then begin
|
||||
incr pass_count;
|
||||
Printf.printf " PASS: %s\n" name
|
||||
end else begin
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: %s — expected %s, got %s\n" name
|
||||
(Sx_types.inspect expected) (Sx_types.inspect actual)
|
||||
end
|
||||
in
|
||||
let assert_true name v =
|
||||
if sx_truthy v then begin
|
||||
incr pass_count;
|
||||
Printf.printf " PASS: %s\n" name
|
||||
end else begin
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: %s — expected truthy, got %s\n" name (Sx_types.inspect v)
|
||||
end
|
||||
in
|
||||
let call name args =
|
||||
match Hashtbl.find_opt primitives name with
|
||||
| Some f -> f args
|
||||
| None -> failwith ("Unknown primitive: " ^ name)
|
||||
in
|
||||
|
||||
Printf.printf "Suite: parser\n";
|
||||
|
||||
let exprs = parse_all "42" in
|
||||
assert_eq "number" (Number 42.0) (List.hd exprs);
|
||||
|
||||
let exprs = parse_all "\"hello\"" in
|
||||
assert_eq "string" (String "hello") (List.hd exprs);
|
||||
|
||||
let exprs = parse_all "true" in
|
||||
assert_eq "bool true" (Bool true) (List.hd exprs);
|
||||
|
||||
let exprs = parse_all "nil" in
|
||||
assert_eq "nil" Nil (List.hd exprs);
|
||||
|
||||
let exprs = parse_all ":class" in
|
||||
assert_eq "keyword" (Keyword "class") (List.hd exprs);
|
||||
|
||||
let exprs = parse_all "foo" in
|
||||
assert_eq "symbol" (Symbol "foo") (List.hd exprs);
|
||||
|
||||
let exprs = parse_all "(+ 1 2)" in
|
||||
assert_eq "list" (List [Symbol "+"; Number 1.0; Number 2.0]) (List.hd exprs);
|
||||
|
||||
let exprs = parse_all "(div :class \"card\" (p \"hi\"))" in
|
||||
(match List.hd exprs with
|
||||
assert_eq "number" (Number 42.0) (List.hd (parse_all "42"));
|
||||
assert_eq "string" (String "hello") (List.hd (parse_all "\"hello\""));
|
||||
assert_eq "bool true" (Bool true) (List.hd (parse_all "true"));
|
||||
assert_eq "nil" Nil (List.hd (parse_all "nil"));
|
||||
assert_eq "keyword" (Keyword "class") (List.hd (parse_all ":class"));
|
||||
assert_eq "symbol" (Symbol "foo") (List.hd (parse_all "foo"));
|
||||
assert_eq "list" (List [Symbol "+"; Number 1.0; Number 2.0]) (List.hd (parse_all "(+ 1 2)"));
|
||||
(match List.hd (parse_all "(div :class \"card\" (p \"hi\"))") with
|
||||
| List [Symbol "div"; Keyword "class"; String "card"; List [Symbol "p"; String "hi"]] ->
|
||||
incr pass_count; Printf.printf " PASS: nested list\n"
|
||||
| v -> incr fail_count; Printf.printf " FAIL: nested list — got %s\n" (inspect v));
|
||||
|
||||
let exprs = parse_all "'(1 2 3)" in
|
||||
(match List.hd exprs with
|
||||
| v -> incr fail_count; Printf.printf " FAIL: nested list — got %s\n" (Sx_types.inspect v));
|
||||
(match List.hd (parse_all "'(1 2 3)") with
|
||||
| List [Symbol "quote"; List [Number 1.0; Number 2.0; Number 3.0]] ->
|
||||
incr pass_count; Printf.printf " PASS: quote sugar\n"
|
||||
| v -> incr fail_count; Printf.printf " FAIL: quote sugar — got %s\n" (inspect v));
|
||||
|
||||
let exprs = parse_all "{:a 1 :b 2}" in
|
||||
(match List.hd exprs with
|
||||
| v -> incr fail_count; Printf.printf " FAIL: quote sugar — got %s\n" (Sx_types.inspect v));
|
||||
(match List.hd (parse_all "{:a 1 :b 2}") with
|
||||
| Dict d when dict_has d "a" && dict_has d "b" ->
|
||||
incr pass_count; Printf.printf " PASS: dict literal\n"
|
||||
| v -> incr fail_count; Printf.printf " FAIL: dict literal — got %s\n" (inspect v));
|
||||
|
||||
let exprs = parse_all ";; comment\n42" in
|
||||
assert_eq "comment" (Number 42.0) (List.hd exprs);
|
||||
|
||||
let exprs = parse_all "(fn (x) (+ x 1))" in
|
||||
(match List.hd exprs with
|
||||
| List [Symbol "fn"; List [Symbol "x"]; List [Symbol "+"; Symbol "x"; Number 1.0]] ->
|
||||
incr pass_count; Printf.printf " PASS: fn form\n"
|
||||
| v -> incr fail_count; Printf.printf " FAIL: fn form — got %s\n" (inspect v));
|
||||
|
||||
let exprs = parse_all "\"hello\\nworld\"" in
|
||||
assert_eq "string escape" (String "hello\nworld") (List.hd exprs);
|
||||
|
||||
let exprs = parse_all "(1 2 3) (4 5)" in
|
||||
assert_eq "multiple exprs" (Number 2.0) (Number (float_of_int (List.length exprs)));
|
||||
| v -> incr fail_count; Printf.printf " FAIL: dict literal — got %s\n" (Sx_types.inspect v));
|
||||
assert_eq "comment" (Number 42.0) (List.hd (parse_all ";; comment\n42"));
|
||||
assert_eq "string escape" (String "hello\nworld") (List.hd (parse_all "\"hello\\nworld\""));
|
||||
assert_eq "multiple exprs" (Number 2.0) (Number (float_of_int (List.length (parse_all "(1 2 3) (4 5)"))));
|
||||
|
||||
Printf.printf "\nSuite: primitives\n";
|
||||
|
||||
(* --- Primitive tests --- *)
|
||||
assert_eq "+" (Number 6.0) (call "+" [Number 1.0; Number 2.0; Number 3.0]);
|
||||
assert_eq "-" (Number 3.0) (call "-" [Number 5.0; Number 2.0]);
|
||||
assert_eq "*" (Number 12.0) (call "*" [Number 3.0; Number 4.0]);
|
||||
@@ -104,26 +541,22 @@ let () =
|
||||
assert_eq "mod" (Number 1.0) (call "mod" [Number 5.0; Number 2.0]);
|
||||
assert_eq "inc" (Number 6.0) (call "inc" [Number 5.0]);
|
||||
assert_eq "abs" (Number 5.0) (call "abs" [Number (-5.0)]);
|
||||
|
||||
assert_true "=" (call "=" [Number 1.0; Number 1.0]);
|
||||
assert_true "!=" (call "!=" [Number 1.0; Number 2.0]);
|
||||
assert_true "<" (call "<" [Number 1.0; Number 2.0]);
|
||||
assert_true ">" (call ">" [Number 2.0; Number 1.0]);
|
||||
|
||||
assert_true "nil?" (call "nil?" [Nil]);
|
||||
assert_true "number?" (call "number?" [Number 1.0]);
|
||||
assert_true "string?" (call "string?" [String "hi"]);
|
||||
assert_true "list?" (call "list?" [List [Number 1.0]]);
|
||||
assert_true "empty? list" (call "empty?" [List []]);
|
||||
assert_true "empty? string" (call "empty?" [String ""]);
|
||||
|
||||
assert_eq "str" (String "hello42") (call "str" [String "hello"; Number 42.0]);
|
||||
assert_eq "upper" (String "HI") (call "upper" [String "hi"]);
|
||||
assert_eq "trim" (String "hi") (call "trim" [String " hi "]);
|
||||
assert_eq "join" (String "a,b,c") (call "join" [String ","; List [String "a"; String "b"; String "c"]]);
|
||||
assert_true "starts-with?" (call "starts-with?" [String "hello"; String "hel"]);
|
||||
assert_true "contains?" (call "contains?" [List [Number 1.0; Number 2.0; Number 3.0]; Number 2.0]);
|
||||
|
||||
assert_eq "list" (List [Number 1.0; Number 2.0]) (call "list" [Number 1.0; Number 2.0]);
|
||||
assert_eq "len" (Number 3.0) (call "len" [List [Number 1.0; Number 2.0; Number 3.0]]);
|
||||
assert_eq "first" (Number 1.0) (call "first" [List [Number 1.0; Number 2.0]]);
|
||||
@@ -135,43 +568,134 @@ let () =
|
||||
assert_eq "reverse" (List [Number 3.0; Number 2.0; Number 1.0])
|
||||
(call "reverse" [List [Number 1.0; Number 2.0; Number 3.0]]);
|
||||
assert_eq "range" (List [Number 0.0; Number 1.0; Number 2.0]) (call "range" [Number 3.0]);
|
||||
assert_eq "slice" (List [Number 2.0; Number 3.0]) (call "slice" [List [Number 1.0; Number 2.0; Number 3.0]; Number 1.0]);
|
||||
|
||||
assert_eq "slice" (List [Number 2.0; Number 3.0])
|
||||
(call "slice" [List [Number 1.0; Number 2.0; Number 3.0]; Number 1.0]);
|
||||
assert_eq "type-of" (String "number") (call "type-of" [Number 1.0]);
|
||||
assert_eq "type-of nil" (String "nil") (call "type-of" [Nil]);
|
||||
|
||||
Printf.printf "\nSuite: env\n";
|
||||
|
||||
(* --- Environment tests --- *)
|
||||
let e = make_env () in
|
||||
ignore (env_bind e "x" (Number 42.0));
|
||||
assert_eq "env-bind + get" (Number 42.0) (env_get e "x");
|
||||
assert_true "env-has" (Bool (env_has e "x"));
|
||||
|
||||
let child = env_extend e in
|
||||
ignore (env_bind child "y" (Number 10.0));
|
||||
assert_eq "child sees parent" (Number 42.0) (env_get child "x");
|
||||
assert_eq "child own binding" (Number 10.0) (env_get child "y");
|
||||
|
||||
ignore (env_set child "x" (Number 99.0));
|
||||
assert_eq "set! walks chain" (Number 99.0) (env_get e "x");
|
||||
let e = Sx_types.make_env () in
|
||||
ignore (Sx_types.env_bind e "x" (Number 42.0));
|
||||
assert_eq "env-bind + get" (Number 42.0) (Sx_types.env_get e "x");
|
||||
assert_true "env-has" (Bool (Sx_types.env_has e "x"));
|
||||
let child = Sx_types.env_extend e in
|
||||
ignore (Sx_types.env_bind child "y" (Number 10.0));
|
||||
assert_eq "child sees parent" (Number 42.0) (Sx_types.env_get child "x");
|
||||
assert_eq "child own binding" (Number 10.0) (Sx_types.env_get child "y");
|
||||
ignore (Sx_types.env_set child "x" (Number 99.0));
|
||||
assert_eq "set! walks chain" (Number 99.0) (Sx_types.env_get e "x");
|
||||
|
||||
Printf.printf "\nSuite: types\n";
|
||||
|
||||
(* --- Type tests --- *)
|
||||
assert_true "sx_truthy true" (Bool (sx_truthy (Bool true)));
|
||||
assert_true "sx_truthy 0" (Bool (sx_truthy (Number 0.0)));
|
||||
assert_true "sx_truthy \"\"" (Bool (sx_truthy (String "")));
|
||||
assert_eq "not truthy nil" (Bool false) (Bool (sx_truthy Nil));
|
||||
assert_eq "not truthy false" (Bool false) (Bool (sx_truthy (Bool false)));
|
||||
let l = { l_params = ["x"]; l_body = Symbol "x"; l_closure = Sx_types.make_env (); l_name = None } in
|
||||
assert_true "is_lambda" (Bool (Sx_types.is_lambda (Lambda l)));
|
||||
ignore (Sx_types.set_lambda_name (Lambda l) "my-fn");
|
||||
assert_eq "lambda name mutated" (String "my-fn") (lambda_name (Lambda l))
|
||||
|
||||
let l = { l_params = ["x"]; l_body = Symbol "x"; l_closure = make_env (); l_name = None } in
|
||||
assert_true "is_lambda" (Bool (is_lambda (Lambda l)));
|
||||
ignore (Sx.Sx_types.set_lambda_name (Lambda l) "my-fn");
|
||||
assert_eq "lambda name mutated" (String "my-fn") (lambda_name (Lambda l));
|
||||
|
||||
(* --- Summary --- *)
|
||||
Printf.printf "\n============================================================\n";
|
||||
(* ====================================================================== *)
|
||||
(* Spec test runner *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let run_spec_tests env test_files =
|
||||
(* Find project root: walk up from cwd until we find spec/tests *)
|
||||
let rec find_root dir =
|
||||
let candidate = Filename.concat dir "spec/tests" in
|
||||
if Sys.file_exists candidate then dir
|
||||
else
|
||||
let parent = Filename.dirname dir in
|
||||
if parent = dir then Sys.getcwd () (* reached filesystem root *)
|
||||
else find_root parent
|
||||
in
|
||||
let project_dir = find_root (Sys.getcwd ()) in
|
||||
let spec_tests_dir = Filename.concat project_dir "spec/tests" in
|
||||
let framework_path = Filename.concat spec_tests_dir "test-framework.sx" in
|
||||
|
||||
if not (Sys.file_exists framework_path) then begin
|
||||
Printf.eprintf "test-framework.sx not found at %s\n" framework_path;
|
||||
Printf.eprintf "Run from the project root directory.\n";
|
||||
exit 1
|
||||
end;
|
||||
|
||||
let load_and_eval path =
|
||||
let ic = open_in path in
|
||||
let n = in_channel_length ic in
|
||||
let s = Bytes.create n in
|
||||
really_input ic s 0 n;
|
||||
close_in ic;
|
||||
let src = Bytes.to_string s in
|
||||
let exprs = parse_all src in
|
||||
List.iter (fun expr ->
|
||||
ignore (eval_expr expr (Env env))
|
||||
) exprs
|
||||
in
|
||||
|
||||
Printf.printf "\nLoading test framework...\n%!";
|
||||
load_and_eval framework_path;
|
||||
|
||||
(* Determine test files *)
|
||||
let files = if test_files = [] then begin
|
||||
let entries = Sys.readdir spec_tests_dir in
|
||||
Array.sort String.compare entries;
|
||||
let requires_full = ["test-continuations.sx"; "test-types.sx"; "test-freeze.sx";
|
||||
"test-continuations-advanced.sx"; "test-signals-advanced.sx"] in
|
||||
Array.to_list entries
|
||||
|> List.filter (fun f ->
|
||||
String.length f > 5 &&
|
||||
String.sub f 0 5 = "test-" &&
|
||||
Filename.check_suffix f ".sx" &&
|
||||
f <> "test-framework.sx" &&
|
||||
not (List.mem f requires_full))
|
||||
end else
|
||||
List.map (fun name ->
|
||||
if Filename.check_suffix name ".sx" then name
|
||||
else name ^ ".sx") test_files
|
||||
in
|
||||
|
||||
List.iter (fun name ->
|
||||
let path = Filename.concat spec_tests_dir name in
|
||||
if Sys.file_exists path then begin
|
||||
Printf.printf "\n%s\n" (String.make 60 '=');
|
||||
Printf.printf "Running %s\n" name;
|
||||
Printf.printf "%s\n%!" (String.make 60 '=');
|
||||
(try
|
||||
load_and_eval path
|
||||
with
|
||||
| Eval_error msg ->
|
||||
incr fail_count;
|
||||
Printf.printf " ERROR in %s: %s\n%!" name msg
|
||||
| exn ->
|
||||
incr fail_count;
|
||||
Printf.printf " ERROR in %s: %s\n%!" name (Printexc.to_string exn))
|
||||
end else
|
||||
Printf.eprintf "Test file not found: %s\n" path
|
||||
) files
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Main *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let () =
|
||||
let args = Array.to_list Sys.argv |> List.tl in
|
||||
let foundation_only = List.mem "--foundation" args in
|
||||
let test_files = List.filter (fun a -> not (String.length a > 0 && a.[0] = '-')) args in
|
||||
|
||||
(* Always run foundation tests *)
|
||||
run_foundation_tests ();
|
||||
|
||||
if not foundation_only then begin
|
||||
Printf.printf "\n=== SX Spec Tests (CEK Evaluator) ===\n%!";
|
||||
let env = make_test_env () in
|
||||
run_spec_tests env test_files
|
||||
end;
|
||||
|
||||
(* Summary *)
|
||||
Printf.printf "\n%s\n" (String.make 60 '=');
|
||||
Printf.printf "Results: %d passed, %d failed\n" !pass_count !fail_count;
|
||||
Printf.printf "============================================================\n";
|
||||
Printf.printf "%s\n" (String.make 60 '=');
|
||||
if !fail_count > 0 then exit 1
|
||||
|
||||
427
hosts/ocaml/bin/sx_server.ml
Normal file
427
hosts/ocaml/bin/sx_server.ml
Normal file
@@ -0,0 +1,427 @@
|
||||
(** SX coroutine subprocess server.
|
||||
|
||||
Persistent process that accepts commands on stdin and writes
|
||||
responses on stdout. All messages are single-line SX expressions,
|
||||
newline-delimited.
|
||||
|
||||
Protocol:
|
||||
Python → OCaml: (ping), (load path), (load-source src),
|
||||
(eval src), (render src), (reset),
|
||||
(io-response value)
|
||||
OCaml → Python: (ready), (ok), (ok value), (error msg),
|
||||
(io-request name args...)
|
||||
|
||||
IO primitives (query, action, request-arg, request-method, ctx)
|
||||
yield (io-request ...) and block on stdin for (io-response ...). *)
|
||||
|
||||
module Sx_types = Sx.Sx_types
|
||||
module Sx_parser = Sx.Sx_parser
|
||||
module Sx_primitives = Sx.Sx_primitives
|
||||
module Sx_runtime = Sx.Sx_runtime
|
||||
module Sx_ref = Sx.Sx_ref
|
||||
module Sx_render = Sx.Sx_render
|
||||
|
||||
open Sx_types
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Output helpers *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
(** Escape a string for embedding in an SX string literal. *)
|
||||
let escape_sx_string s =
|
||||
let buf = Buffer.create (String.length s + 16) in
|
||||
String.iter (function
|
||||
| '"' -> 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.contents buf
|
||||
|
||||
(** Serialize a value to SX text (for io-request args). *)
|
||||
let rec serialize_value = function
|
||||
| Nil -> "nil"
|
||||
| Bool true -> "true"
|
||||
| Bool false -> "false"
|
||||
| Number n ->
|
||||
if Float.is_integer n then string_of_int (int_of_float n)
|
||||
else Printf.sprintf "%g" n
|
||||
| String s -> "\"" ^ escape_sx_string s ^ "\""
|
||||
| Symbol s -> s
|
||||
| Keyword k -> ":" ^ k
|
||||
| List items | ListRef { contents = items } ->
|
||||
"(list " ^ String.concat " " (List.map serialize_value items) ^ ")"
|
||||
| Dict d ->
|
||||
let pairs = Hashtbl.fold (fun k v acc ->
|
||||
(Printf.sprintf ":%s %s" k (serialize_value v)) :: acc) d [] in
|
||||
"{" ^ String.concat " " pairs ^ "}"
|
||||
| RawHTML s -> "\"" ^ escape_sx_string s ^ "\""
|
||||
| _ -> "nil"
|
||||
|
||||
let send line =
|
||||
print_string line;
|
||||
print_char '\n';
|
||||
flush stdout
|
||||
|
||||
let send_ok () = send "(ok)"
|
||||
let send_ok_value v = send (Printf.sprintf "(ok %s)" (serialize_value v))
|
||||
let send_ok_string s = send (Printf.sprintf "(ok \"%s\")" (escape_sx_string s))
|
||||
let send_error msg = send (Printf.sprintf "(error \"%s\")" (escape_sx_string msg))
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* IO bridge — primitives that yield to Python *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
(** Read a line from stdin (blocking). *)
|
||||
let read_line_blocking () =
|
||||
try Some (input_line stdin)
|
||||
with End_of_file -> None
|
||||
|
||||
(** Send an io-request and block until io-response arrives. *)
|
||||
let io_request name args =
|
||||
let args_str = String.concat " " (List.map serialize_value args) in
|
||||
send (Printf.sprintf "(io-request \"%s\" %s)" name args_str);
|
||||
(* Block on stdin for io-response *)
|
||||
match read_line_blocking () with
|
||||
| None -> raise (Eval_error "IO bridge: stdin closed while waiting for io-response")
|
||||
| Some line ->
|
||||
let exprs = Sx_parser.parse_all line in
|
||||
match exprs with
|
||||
| [List [Symbol "io-response"; value]] -> value
|
||||
| [List (Symbol "io-response" :: values)] ->
|
||||
(match values with
|
||||
| [v] -> v
|
||||
| _ -> List values)
|
||||
| _ -> raise (Eval_error ("IO bridge: unexpected response: " ^ line))
|
||||
|
||||
(** Bind IO primitives into the environment. *)
|
||||
let setup_io_env env =
|
||||
let bind name fn =
|
||||
ignore (env_bind env name (NativeFn (name, fn)))
|
||||
in
|
||||
|
||||
bind "query" (fun args ->
|
||||
match args with
|
||||
| service :: query_name :: rest ->
|
||||
io_request "query" (service :: query_name :: rest)
|
||||
| _ -> raise (Eval_error "query: expected (query service name ...)"));
|
||||
|
||||
bind "action" (fun args ->
|
||||
match args with
|
||||
| service :: action_name :: rest ->
|
||||
io_request "action" (service :: action_name :: rest)
|
||||
| _ -> raise (Eval_error "action: expected (action service name ...)"));
|
||||
|
||||
bind "request-arg" (fun args ->
|
||||
match args with
|
||||
| [name] -> io_request "request-arg" [name]
|
||||
| _ -> raise (Eval_error "request-arg: expected 1 arg"));
|
||||
|
||||
bind "request-method" (fun _args ->
|
||||
io_request "request-method" []);
|
||||
|
||||
bind "ctx" (fun args ->
|
||||
match args with
|
||||
| [key] -> io_request "ctx" [key]
|
||||
| _ -> raise (Eval_error "ctx: expected 1 arg"))
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Environment setup *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let make_server_env () =
|
||||
let env = make_env () in
|
||||
|
||||
(* Evaluator bindings — same as run_tests.ml's make_test_env,
|
||||
but only the ones needed for rendering (not test helpers). *)
|
||||
let bind name fn =
|
||||
ignore (env_bind env name (NativeFn (name, fn)))
|
||||
in
|
||||
|
||||
bind "assert" (fun args ->
|
||||
match args with
|
||||
| [cond] ->
|
||||
if not (sx_truthy cond) then raise (Eval_error "Assertion failed");
|
||||
Bool true
|
||||
| [cond; String msg] ->
|
||||
if not (sx_truthy cond) then raise (Eval_error ("Assertion error: " ^ msg));
|
||||
Bool true
|
||||
| [cond; msg] ->
|
||||
if not (sx_truthy cond) then
|
||||
raise (Eval_error ("Assertion error: " ^ value_to_string msg));
|
||||
Bool true
|
||||
| _ -> raise (Eval_error "assert: expected 1-2 args"));
|
||||
|
||||
bind "append!" (fun args ->
|
||||
match args with
|
||||
| [ListRef r; v] -> r := !r @ [v]; ListRef r
|
||||
| [List items; v] -> List (items @ [v])
|
||||
| _ -> raise (Eval_error "append!: expected list and value"));
|
||||
|
||||
(* HTML renderer *)
|
||||
Sx_render.setup_render_env env;
|
||||
|
||||
(* Missing primitives that may be referenced *)
|
||||
bind "upcase" (fun args ->
|
||||
match args with
|
||||
| [String s] -> String (String.uppercase_ascii s)
|
||||
| _ -> raise (Eval_error "upcase: expected string"));
|
||||
|
||||
bind "downcase" (fun args ->
|
||||
match args with
|
||||
| [String s] -> String (String.lowercase_ascii s)
|
||||
| _ -> raise (Eval_error "downcase: expected string"));
|
||||
|
||||
bind "make-keyword" (fun args ->
|
||||
match args with
|
||||
| [String s] -> Keyword s
|
||||
| _ -> raise (Eval_error "make-keyword: expected string"));
|
||||
|
||||
bind "string-length" (fun args ->
|
||||
match args with
|
||||
| [String s] -> Number (float_of_int (String.length s))
|
||||
| _ -> raise (Eval_error "string-length: expected string"));
|
||||
|
||||
bind "dict-get" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k] -> dict_get d k
|
||||
| [Dict d; Keyword k] -> dict_get d k
|
||||
| _ -> raise (Eval_error "dict-get: expected dict and key"));
|
||||
|
||||
bind "apply" (fun args ->
|
||||
match args with
|
||||
| f :: rest ->
|
||||
let all_args = match List.rev rest with
|
||||
| List last :: prefix -> List.rev prefix @ last
|
||||
| _ -> rest
|
||||
in
|
||||
Sx_runtime.sx_call f all_args
|
||||
| _ -> raise (Eval_error "apply: expected function and args"));
|
||||
|
||||
bind "equal?" (fun args ->
|
||||
match args with
|
||||
| [a; b] -> Bool (a = b)
|
||||
| _ -> raise (Eval_error "equal?: expected 2 args"));
|
||||
|
||||
bind "identical?" (fun args ->
|
||||
match args with
|
||||
| [a; b] -> Bool (a == b)
|
||||
| _ -> raise (Eval_error "identical?: expected 2 args"));
|
||||
|
||||
bind "make-continuation" (fun args ->
|
||||
match args with
|
||||
| [f] ->
|
||||
let k v = Sx_runtime.sx_call f [v] in
|
||||
Continuation (k, None)
|
||||
| _ -> raise (Eval_error "make-continuation: expected 1 arg"));
|
||||
|
||||
bind "continuation?" (fun args ->
|
||||
match args with
|
||||
| [Continuation _] -> Bool true
|
||||
| [_] -> Bool false
|
||||
| _ -> raise (Eval_error "continuation?: expected 1 arg"));
|
||||
|
||||
bind "make-symbol" (fun args ->
|
||||
match args with
|
||||
| [String s] -> Symbol s
|
||||
| [v] -> Symbol (value_to_string v)
|
||||
| _ -> raise (Eval_error "make-symbol: expected 1 arg"));
|
||||
|
||||
bind "sx-serialize" (fun args ->
|
||||
match args with
|
||||
| [v] -> String (inspect v)
|
||||
| _ -> raise (Eval_error "sx-serialize: expected 1 arg"));
|
||||
|
||||
(* Env operations *)
|
||||
bind "env-get" (fun args ->
|
||||
match args with
|
||||
| [Env e; String k] -> env_get e k
|
||||
| [Env e; Keyword k] -> env_get e k
|
||||
| _ -> raise (Eval_error "env-get: expected env and string"));
|
||||
|
||||
bind "env-has?" (fun args ->
|
||||
match args with
|
||||
| [Env e; String k] -> Bool (env_has e k)
|
||||
| [Env e; Keyword k] -> Bool (env_has e k)
|
||||
| _ -> raise (Eval_error "env-has?: expected env and string"));
|
||||
|
||||
bind "env-bind!" (fun args ->
|
||||
match args with
|
||||
| [Env e; String k; v] -> env_bind e k v
|
||||
| [Env e; Keyword k; v] -> env_bind e k v
|
||||
| _ -> raise (Eval_error "env-bind!: expected env, key, value"));
|
||||
|
||||
bind "env-set!" (fun args ->
|
||||
match args with
|
||||
| [Env e; String k; v] -> env_set e k v
|
||||
| [Env e; Keyword k; v] -> env_set e k v
|
||||
| _ -> raise (Eval_error "env-set!: expected env, key, value"));
|
||||
|
||||
bind "env-extend" (fun args ->
|
||||
match args with
|
||||
| [Env e] -> Env (env_extend e)
|
||||
| _ -> raise (Eval_error "env-extend: expected env"));
|
||||
|
||||
bind "env-merge" (fun args ->
|
||||
match args with
|
||||
| [Env a; Env b] -> Env (env_merge a b)
|
||||
| _ -> raise (Eval_error "env-merge: expected 2 envs"));
|
||||
|
||||
(* Strict mode state *)
|
||||
ignore (env_bind env "*strict*" (Bool false));
|
||||
ignore (env_bind env "*prim-param-types*" Nil);
|
||||
|
||||
bind "set-strict!" (fun args ->
|
||||
match args with
|
||||
| [v] ->
|
||||
Sx_ref._strict_ref := v;
|
||||
ignore (env_set env "*strict*" v); Nil
|
||||
| _ -> raise (Eval_error "set-strict!: expected 1 arg"));
|
||||
|
||||
bind "set-prim-param-types!" (fun args ->
|
||||
match args with
|
||||
| [v] ->
|
||||
Sx_ref._prim_param_types_ref := v;
|
||||
ignore (env_set env "*prim-param-types*" v); Nil
|
||||
| _ -> raise (Eval_error "set-prim-param-types!: expected 1 arg"));
|
||||
|
||||
bind "component-param-types" (fun _args -> Nil);
|
||||
bind "component-set-param-types!" (fun _args -> Nil);
|
||||
|
||||
bind "component-params" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> List (List.map (fun s -> String s) c.c_params)
|
||||
| _ -> Nil);
|
||||
|
||||
bind "component-body" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> c.c_body
|
||||
| _ -> Nil);
|
||||
|
||||
bind "component-has-children" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> Bool c.c_has_children
|
||||
| _ -> Bool false);
|
||||
|
||||
bind "component-affinity" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> String c.c_affinity
|
||||
| _ -> String "auto");
|
||||
|
||||
bind "keyword-name" (fun args ->
|
||||
match args with
|
||||
| [Keyword k] -> String k
|
||||
| _ -> raise (Eval_error "keyword-name: expected keyword"));
|
||||
|
||||
bind "symbol-name" (fun args ->
|
||||
match args with
|
||||
| [Symbol s] -> String s
|
||||
| _ -> raise (Eval_error "symbol-name: expected symbol"));
|
||||
|
||||
(* IO primitives *)
|
||||
setup_io_env env;
|
||||
|
||||
env
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Command dispatch *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let dispatch env cmd =
|
||||
match cmd with
|
||||
| List [Symbol "ping"] ->
|
||||
send_ok_string "ocaml-cek"
|
||||
|
||||
| List [Symbol "load"; String path] ->
|
||||
(try
|
||||
let exprs = Sx_parser.parse_file path in
|
||||
let count = ref 0 in
|
||||
List.iter (fun expr ->
|
||||
ignore (Sx_ref.eval_expr expr (Env env));
|
||||
incr count
|
||||
) exprs;
|
||||
send_ok_value (Number (float_of_int !count))
|
||||
with
|
||||
| Eval_error msg -> send_error msg
|
||||
| Sys_error msg -> send_error ("File error: " ^ msg)
|
||||
| exn -> send_error (Printexc.to_string exn))
|
||||
|
||||
| List [Symbol "load-source"; String src] ->
|
||||
(try
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let count = ref 0 in
|
||||
List.iter (fun expr ->
|
||||
ignore (Sx_ref.eval_expr expr (Env env));
|
||||
incr count
|
||||
) exprs;
|
||||
send_ok_value (Number (float_of_int !count))
|
||||
with
|
||||
| Eval_error msg -> send_error msg
|
||||
| exn -> send_error (Printexc.to_string exn))
|
||||
|
||||
| List [Symbol "eval"; String src] ->
|
||||
(try
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let result = List.fold_left (fun _acc expr ->
|
||||
Sx_ref.eval_expr expr (Env env)
|
||||
) Nil exprs in
|
||||
send_ok_value result
|
||||
with
|
||||
| Eval_error msg -> send_error msg
|
||||
| exn -> send_error (Printexc.to_string exn))
|
||||
|
||||
| List [Symbol "render"; String src] ->
|
||||
(try
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let expr = match exprs with
|
||||
| [e] -> e
|
||||
| [] -> Nil
|
||||
| _ -> List (Symbol "do" :: exprs)
|
||||
in
|
||||
let html = Sx_render.render_to_html expr env in
|
||||
send_ok_string html
|
||||
with
|
||||
| Eval_error msg -> send_error msg
|
||||
| exn -> send_error (Printexc.to_string exn))
|
||||
|
||||
| List [Symbol "reset"] ->
|
||||
(* Clear all bindings and rebuild env.
|
||||
We can't reassign env, so clear and re-populate. *)
|
||||
Hashtbl.clear env.bindings;
|
||||
let fresh = make_server_env () in
|
||||
Hashtbl.iter (fun k v -> Hashtbl.replace env.bindings k v) fresh.bindings;
|
||||
send_ok ()
|
||||
|
||||
| _ ->
|
||||
send_error ("Unknown command: " ^ inspect cmd)
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Main loop *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let () =
|
||||
let env = make_server_env () in
|
||||
send "(ready)";
|
||||
(* Main command loop *)
|
||||
try
|
||||
while true do
|
||||
match read_line_blocking () with
|
||||
| None -> exit 0 (* stdin closed *)
|
||||
| Some line ->
|
||||
let line = String.trim line in
|
||||
if line = "" then () (* skip blank lines *)
|
||||
else begin
|
||||
let exprs = Sx_parser.parse_all line in
|
||||
match exprs with
|
||||
| [cmd] -> dispatch env cmd
|
||||
| _ -> send_error ("Expected single command, got " ^ string_of_int (List.length exprs))
|
||||
end
|
||||
done
|
||||
with
|
||||
| End_of_file -> ()
|
||||
Reference in New Issue
Block a user