giles
9a57bd5beb
lib/hyperscript/runtime.sx — thin wrappers over web/lib/dom.sx primitives implementing hyperscript-specific semantics: Event handling: hs-on, hs-on-every, hs-init Async/timing: hs-wait (IO suspend), hs-wait-for, hs-settle Classes: hs-toggle-class!, hs-toggle-between!, hs-take! DOM insertion: hs-put! (into/before/after) Navigation: hs-navigate!, hs-next, hs-previous, hs-query-first/last Iteration: hs-repeat-times, hs-repeat-forever Fetch: hs-fetch (json/text/html format dispatch) Type coercion: hs-coerce (Int/Float/String/Boolean/Array) Object creation: hs-make (Object/Array/Set/Map) Behaviors: hs-install Measurement: hs-measure Transitions: hs-transition (CSS property + optional duration) 23 runtime + 7 end-to-end pipeline tests. 3099/3099 full build, zero regressions. Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
1528 lines
64 KiB
OCaml
1528 lines
64 KiB
OCaml
(** Test runner — runs the SX spec test suite against the transpiled CEK evaluator.
|
|
|
|
Provides the 5 platform functions required by test-framework.sx:
|
|
try-call, report-pass, report-fail, push-suite, pop-suite
|
|
|
|
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 *)
|
|
|
|
(* Modules accessed directly — library is unwrapped *)
|
|
|
|
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 []
|
|
|
|
(* ====================================================================== *)
|
|
(* Deep equality — SX structural comparison *)
|
|
(* ====================================================================== *)
|
|
|
|
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
|
|
| Record a, Record b ->
|
|
a.r_type.rt_uid = b.r_type.rt_uid &&
|
|
Array.length a.r_fields = Array.length b.r_fields &&
|
|
(let eq = ref true in
|
|
for i = 0 to Array.length a.r_fields - 1 do
|
|
if not (deep_equal a.r_fields.(i) b.r_fields.(i)) then eq := false
|
|
done; !eq)
|
|
| Lambda _, Lambda _ -> a == b (* identity *)
|
|
| NativeFn _, NativeFn _ -> a == b
|
|
| _ -> false
|
|
|
|
(* ====================================================================== *)
|
|
(* Build evaluator environment with test platform functions *)
|
|
(* ====================================================================== *)
|
|
|
|
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
|
|
|
|
(* --- platform functions required by test-framework.sx --- *)
|
|
|
|
bind "cek-try" (fun args ->
|
|
match args with
|
|
| [thunk; handler] ->
|
|
(try Sx_ref.cek_call thunk Nil
|
|
with Eval_error msg -> Sx_ref.cek_call handler (List [String msg]))
|
|
| [thunk] ->
|
|
(try let r = Sx_ref.cek_call thunk Nil in
|
|
List [Symbol "ok"; r]
|
|
with Eval_error msg -> List [Symbol "error"; String msg])
|
|
| _ -> Nil);
|
|
|
|
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 --- *)
|
|
|
|
(* Env operations — accept both Env and Dict *)
|
|
let uw = Sx_runtime.unwrap_env in
|
|
bind "env-get" (fun args ->
|
|
match args with
|
|
| [e; String k] -> Sx_types.env_get (uw e) k
|
|
| [e; Keyword k] -> Sx_types.env_get (uw e) k
|
|
| _ -> raise (Eval_error "env-get: expected env and string"));
|
|
|
|
bind "env-has?" (fun args ->
|
|
match args with
|
|
| [e; String k] -> Bool (Sx_types.env_has (uw e) k)
|
|
| [e; Keyword k] -> Bool (Sx_types.env_has (uw e) k)
|
|
| _ -> raise (Eval_error "env-has?: expected env and string"));
|
|
|
|
bind "env-bind!" (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
|
|
| [e; String k; v] -> Sx_types.env_bind (uw e) k v
|
|
| [e; Keyword k; v] -> Sx_types.env_bind (uw e) k v
|
|
| _ -> raise (Eval_error "env-bind!: expected env, key, value"));
|
|
|
|
bind "env-set!" (fun args ->
|
|
match args with
|
|
| [e; String k; v] -> Sx_types.env_set (uw e) k v
|
|
| [e; Keyword k; v] -> Sx_types.env_set (uw e) k v
|
|
| _ -> raise (Eval_error "env-set!: expected env, key, value"));
|
|
|
|
bind "make-env" (fun _args -> Env (Sx_types.make_env ()));
|
|
|
|
bind "env-extend" (fun args ->
|
|
match args with
|
|
| [e] -> Env (Sx_types.env_extend (uw e))
|
|
| _ -> raise (Eval_error "env-extend: expected env"));
|
|
|
|
bind "env-merge" (fun args ->
|
|
match args with
|
|
| [a; b] -> Sx_runtime.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 (match a, b with
|
|
| Number x, Number y -> x = y
|
|
| String x, String y -> x = y
|
|
| Bool x, Bool y -> x = y
|
|
| Nil, Nil -> true
|
|
| _ -> 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_render.setup_render_env env;
|
|
|
|
(* HTML tag functions — bind all tags as native fns returning (tag ...args) *)
|
|
List.iter (fun tag ->
|
|
ignore (Sx_types.env_bind env tag
|
|
(NativeFn ("html:" ^ tag, fun args -> List (Symbol tag :: args))))
|
|
) Sx_render.html_tags;
|
|
bind "is-html-tag?" (fun args -> match args with [String s] -> Bool (Sx_render.is_html_tag s) | _ -> Bool false);
|
|
|
|
(* Stubs needed by adapter-html.sx when loaded at test time *)
|
|
bind "set-render-active!" (fun _args -> Nil);
|
|
bind "render-active?" (fun _args -> Bool true);
|
|
bind "trampoline" (fun args ->
|
|
match args with
|
|
| [Thunk (expr, e)] -> eval_expr expr (Env e)
|
|
| [v] -> v
|
|
| _ -> Nil);
|
|
bind "eval-expr" (fun args ->
|
|
match args with
|
|
| [expr; e] ->
|
|
(match e with
|
|
| Dict _ -> Printf.eprintf "[EVAL-EXPR] env is Dict! expr=%s\n%!" (Sx_runtime.value_to_str expr)
|
|
| Nil -> Printf.eprintf "[EVAL-EXPR] env is Nil! expr=%s\n%!" (Sx_runtime.value_to_str expr)
|
|
| _ -> ());
|
|
let ue = Sx_runtime.unwrap_env e in
|
|
eval_expr expr (Env ue)
|
|
| [expr] -> eval_expr expr (Env env)
|
|
| _ -> raise (Eval_error "eval-expr: expected (expr env)"));
|
|
bind "set-render-active!" (fun _args -> Nil);
|
|
(* render-to-sx wrapper: if called with a string, parse and aser it *)
|
|
bind "render-to-sx" (fun args ->
|
|
match args with
|
|
| [String src] ->
|
|
let exprs = Sx_parser.parse_all src in
|
|
let expr = match exprs with [e] -> e | es -> List (Symbol "do" :: es) in
|
|
let result = eval_expr (List [Symbol "aser"; expr; Env env]) (Env env) in
|
|
(match result with SxExpr s -> String s | String s -> String s | _ -> String (Sx_runtime.value_to_str result))
|
|
| [expr; Env e] ->
|
|
let result = eval_expr (List [Symbol "aser"; expr; Env e]) (Env e) in
|
|
(match result with SxExpr s -> String s | String s -> String s | _ -> String (Sx_runtime.value_to_str result))
|
|
| _ -> String "");
|
|
(* Scope primitives — share the same scope stacks as sx_primitives.ml
|
|
so that CEK evaluator's scope_push/scope_peek and SX-level scope-push!/scope-peek
|
|
operate on the same table. *)
|
|
let _scope_stacks = Sx_primitives._scope_stacks in
|
|
bind "scope-push!" (fun args ->
|
|
match args with
|
|
| [String name; value] ->
|
|
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
|
Hashtbl.replace _scope_stacks name (value :: stack); Nil
|
|
| [String name] ->
|
|
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
|
Hashtbl.replace _scope_stacks name (Nil :: stack); Nil
|
|
| _ -> Nil);
|
|
bind "scope-pop!" (fun args ->
|
|
match args with
|
|
| [String name] ->
|
|
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
|
(match stack with _ :: rest -> Hashtbl.replace _scope_stacks name rest | [] -> ()); Nil
|
|
| _ -> Nil);
|
|
bind "scope-peek" (fun args ->
|
|
match args with
|
|
| [String name] ->
|
|
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
|
(match stack with v :: _ -> v | [] -> Nil)
|
|
| _ -> Nil);
|
|
let context_fn = (fun args ->
|
|
match args with
|
|
| String name :: rest ->
|
|
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
|
(match stack with v :: _ -> v | [] -> (match rest with d :: _ -> d | [] -> Nil))
|
|
| _ -> Nil) in
|
|
bind "context" context_fn;
|
|
Sx_primitives.register "context" context_fn;
|
|
bind "scope-emit!" (fun args ->
|
|
match args with
|
|
| [String name; value] ->
|
|
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
|
(match stack with
|
|
| List items :: rest ->
|
|
Hashtbl.replace _scope_stacks name (List (items @ [value]) :: rest)
|
|
| _ :: rest ->
|
|
Hashtbl.replace _scope_stacks name (List [value] :: rest)
|
|
| [] ->
|
|
Hashtbl.replace _scope_stacks name [List [value]]);
|
|
Nil
|
|
| _ -> Nil);
|
|
bind "emitted" (fun args ->
|
|
match args with
|
|
| [String name] ->
|
|
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
|
(match stack with List items :: _ -> List items | _ -> List [])
|
|
| _ -> List []);
|
|
bind "scope-emitted" (fun args ->
|
|
match args with
|
|
| [String name] ->
|
|
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
|
(match stack with List items :: _ -> List items | _ -> List [])
|
|
| _ -> List []);
|
|
bind "provide-push!" (fun args ->
|
|
match args with
|
|
| [String name; value] ->
|
|
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
|
Hashtbl.replace _scope_stacks name (value :: stack); Nil
|
|
| _ -> Nil);
|
|
bind "provide-pop!" (fun args ->
|
|
match args with
|
|
| [String name] ->
|
|
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
|
(match stack with _ :: rest -> Hashtbl.replace _scope_stacks name rest | [] -> ()); Nil
|
|
| _ -> Nil);
|
|
bind "cond-scheme?" (fun args ->
|
|
match args with
|
|
| [(List clauses | ListRef { contents = clauses })] ->
|
|
Bool (List.for_all (fun c ->
|
|
match c with
|
|
| List l | ListRef { contents = l } -> List.length l = 2
|
|
| _ -> false
|
|
) clauses)
|
|
| _ -> Bool false);
|
|
bind "expand-macro" (fun args ->
|
|
match args with
|
|
| [Macro m; (List a | ListRef { contents = a }); _] ->
|
|
let local = Sx_types.env_extend m.m_closure in
|
|
let rec bind_params ps as' =
|
|
match ps, as' with
|
|
| [], rest ->
|
|
(match m.m_rest_param with
|
|
| Some rp -> ignore (Sx_types.env_bind local rp (List rest))
|
|
| None -> ())
|
|
| p :: ps_rest, a :: as_rest ->
|
|
ignore (Sx_types.env_bind local p a);
|
|
bind_params ps_rest as_rest
|
|
| remaining, [] ->
|
|
List.iter (fun p -> ignore (Sx_types.env_bind local p Nil)) remaining
|
|
in
|
|
bind_params m.m_params a;
|
|
eval_expr m.m_body (Env local)
|
|
| _ -> raise (Eval_error "expand-macro: expected (macro args env)"));
|
|
|
|
bind "cek-call" (fun args ->
|
|
match args with
|
|
| [fn_val; List call_args] -> Sx_ref.cek_call fn_val (List call_args)
|
|
| [fn_val; ListRef { contents = call_args }] -> Sx_ref.cek_call fn_val (List call_args)
|
|
| [fn_val; Nil] -> Sx_ref.cek_call fn_val (List [])
|
|
| [fn_val] -> Sx_ref.cek_call fn_val (List [])
|
|
| _ -> Nil);
|
|
bind "cek-run" (fun args ->
|
|
match args with
|
|
| [state] -> Sx_ref.cek_run state
|
|
| _ -> Nil);
|
|
bind "batch-begin!" (fun _args -> Sx_ref.batch_begin_b ());
|
|
bind "batch-end!" (fun _args -> Sx_ref.batch_end_b ());
|
|
bind "now-ms" (fun _args -> Number 1000.0);
|
|
bind "random-int" (fun args -> match args with [Number lo; _] -> Number lo | _ -> Number 0.0);
|
|
bind "try-rerender-page" (fun _args -> Nil);
|
|
bind "collect!" (fun args ->
|
|
match args with
|
|
| [String name; value] ->
|
|
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
|
(match stack with
|
|
| List items :: rest ->
|
|
if List.mem value items then Nil
|
|
else (Hashtbl.replace _scope_stacks name (List (items @ [value]) :: rest); Nil)
|
|
| _ ->
|
|
Hashtbl.replace _scope_stacks name (List [value] :: stack); Nil)
|
|
| _ -> Nil);
|
|
bind "collected" (fun args ->
|
|
match args with
|
|
| [String name] ->
|
|
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
|
(match stack with List items :: _ -> List items | _ -> List [])
|
|
| _ -> List []);
|
|
bind "clear-collected!" (fun args ->
|
|
match args with
|
|
| [String name] ->
|
|
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
|
(match stack with _ :: rest -> Hashtbl.replace _scope_stacks name (List [] :: rest) | [] -> ()); Nil
|
|
| _ -> Nil);
|
|
(* regex-find-all now provided by sx_primitives.ml *)
|
|
bind "callable?" (fun args ->
|
|
match args with
|
|
| [NativeFn _] | [Lambda _] | [Component _] | [Island _] -> Bool true
|
|
| _ -> Bool false);
|
|
bind "make-sx-expr" (fun args -> match args with [String s] -> SxExpr s | _ -> raise (Eval_error "make-sx-expr: expected string"));
|
|
bind "sx-expr-source" (fun args -> match args with [SxExpr s] -> String s | [String s] -> String s | _ -> raise (Eval_error "sx-expr-source: expected sx-expr or string"));
|
|
bind "sx-expr?" (fun args -> match args with [SxExpr _] -> Bool true | _ -> Bool false);
|
|
bind "spread?" (fun args -> match args with [Spread _] -> Bool true | _ -> Bool false);
|
|
bind "call-lambda" (fun args ->
|
|
match args with
|
|
| [Lambda _ as f; (List a | ListRef { contents = a })] ->
|
|
let l = match f with Lambda l -> l | _ -> assert false in
|
|
let local = Sx_types.env_extend l.l_closure in
|
|
let rec bind_ps ps as' = match ps, as' with
|
|
| [], _ -> () | p :: pr, a :: ar -> ignore (Sx_types.env_bind local p a); bind_ps pr ar
|
|
| p :: pr, [] -> ignore (Sx_types.env_bind local p Nil); bind_ps pr [] in
|
|
bind_ps l.l_params a;
|
|
eval_expr l.l_body (Env local)
|
|
| [Lambda _ as f; (List a | ListRef { contents = a }); Env e] ->
|
|
let l = match f with Lambda l -> l | _ -> assert false in
|
|
let local = Sx_types.env_merge l.l_closure e in
|
|
let rec bind_ps ps as' = match ps, as' with
|
|
| [], _ -> () | p :: pr, a :: ar -> ignore (Sx_types.env_bind local p a); bind_ps pr ar
|
|
| p :: pr, [] -> ignore (Sx_types.env_bind local p Nil); bind_ps pr [] in
|
|
bind_ps l.l_params a;
|
|
eval_expr l.l_body (Env local)
|
|
| _ -> raise (Eval_error "call-lambda: expected (fn args env?)"));
|
|
|
|
(* Declarative type/effect forms — no-ops at runtime *)
|
|
bind "deftype" (fun _args -> Nil);
|
|
bind "defeffect" (fun _args -> Nil);
|
|
bind "register-special-form!" (fun args ->
|
|
match args with
|
|
| [String name; fn_val] ->
|
|
(* Don't let SX modules override OCaml-registered defhandler/defisland *)
|
|
if name = "defhandler" || name = "defisland" then Nil
|
|
else (ignore (Sx_ref.register_special_form (String name) fn_val); Nil)
|
|
| _ -> Nil);
|
|
|
|
(* defhandler — register handler as handler:name in eval env.
|
|
Mirrors sx_server.ml's defhandler special form. *)
|
|
ignore (Sx_ref.register_special_form (String "defhandler") (NativeFn ("defhandler", fun sf_args ->
|
|
let raw_args, eval_env = match sf_args with
|
|
| [List a; Env e] | [ListRef { contents = a }; Env e] -> (a, e)
|
|
| _ -> ([], env) in
|
|
match raw_args with
|
|
| name_sym :: rest ->
|
|
let name = match name_sym with Symbol s -> s | String s -> s | _ -> Sx_types.inspect name_sym in
|
|
let rec parse_opts acc = function
|
|
| Keyword k :: v :: rest -> Hashtbl.replace acc k v; parse_opts acc rest
|
|
| rest -> (acc, rest) in
|
|
let opts = Hashtbl.create 4 in
|
|
let (_, remaining) = parse_opts opts rest in
|
|
let params, body_forms = match remaining with
|
|
| List p :: rest -> (p, rest) | _ -> ([], []) in
|
|
(* Wrap multiple body forms in (do ...) *)
|
|
let body = match body_forms with
|
|
| [] -> Nil | [b] -> b
|
|
| forms -> List (Symbol "do" :: forms) in
|
|
(* Extract &key param names for binding *)
|
|
let key_params =
|
|
let rec collect acc in_key = function
|
|
| [] -> List.rev acc
|
|
| Symbol "&key" :: rest -> collect acc true rest
|
|
| Symbol "&rest" :: _ :: rest -> collect acc false rest
|
|
| Symbol s :: rest when in_key -> collect (s :: acc) true rest
|
|
| _ :: rest -> collect acc in_key rest
|
|
in collect [] false params in
|
|
let hdef = Hashtbl.create 8 in
|
|
Hashtbl.replace hdef "__type" (String "handler");
|
|
Hashtbl.replace hdef "name" (String name);
|
|
Hashtbl.replace hdef "body" body;
|
|
Hashtbl.replace hdef "params" (List (List.map (fun s -> String s) key_params));
|
|
Hashtbl.replace hdef "closure" (Env eval_env);
|
|
Hashtbl.replace hdef "method" (match Hashtbl.find_opt opts "method" with
|
|
| Some (Keyword m) -> String m | Some v -> v | None -> String "get");
|
|
ignore (Sx_types.env_bind eval_env ("handler:" ^ name) (Dict hdef));
|
|
Dict hdef
|
|
| _ -> Nil)));
|
|
|
|
(* defisland — register island component. Stub: creates a component record. *)
|
|
ignore (Sx_ref.register_special_form (String "defisland") (NativeFn ("defisland", fun sf_args ->
|
|
let raw_args, eval_env = match sf_args with
|
|
| [List a; Env e] | [ListRef { contents = a }; Env e] -> (a, e)
|
|
| _ -> ([], env) in
|
|
match raw_args with
|
|
| name_sym :: rest ->
|
|
let name = match name_sym with Symbol s -> s | String s -> s | _ -> Sx_types.inspect name_sym in
|
|
let short_name = if String.length name > 1 && name.[0] = '~' then String.sub name 1 (String.length name - 1) else name in
|
|
let params, body = match rest with
|
|
| List p :: b :: _ -> (p, b) | List p :: [] -> (p, Nil) | _ -> ([], Nil) in
|
|
let param_names = List.filter_map (fun p ->
|
|
match p with Symbol s -> Some s | _ -> None) params in
|
|
let has_children = List.exists (fun p ->
|
|
match p with Symbol "&rest" -> true | _ -> false) params in
|
|
let island = Island {
|
|
i_name = short_name; i_params = param_names;
|
|
i_has_children = has_children;
|
|
i_body = body; i_closure = eval_env; i_file = None; i_compiled = None;
|
|
} in
|
|
ignore (Sx_types.env_bind eval_env name island);
|
|
island
|
|
| _ -> Nil)));
|
|
|
|
(* IO registry — spec-level defio populates *io-registry* in evaluator.
|
|
Bind accessor functions + __io-registry alias for backward compat. *)
|
|
ignore (Sx_types.env_bind env "__io-registry" Sx_ref._io_registry_);
|
|
bind "io-registered?" (fun args -> match args with [String n] -> Sx_ref.io_registered_p (String n) | _ -> Bool false);
|
|
bind "io-lookup" (fun args -> match args with [String n] -> Sx_ref.io_lookup (String n) | _ -> Nil);
|
|
bind "io-names" (fun _args -> Sx_ref.io_names ());
|
|
bind "io-register!" (fun args -> match args with [String n; spec] -> Sx_ref.io_register_b (String n) spec | _ -> Nil);
|
|
|
|
(* Foreign registry — spec-level define-foreign populates *foreign-registry*.
|
|
Bind accessor functions so test-foreign.sx can inspect the registry. *)
|
|
ignore (Sx_types.env_bind env "*foreign-registry*" Sx_ref._foreign_registry_);
|
|
bind "foreign-registered?" (fun args -> match args with [String n] -> Sx_ref.foreign_registered_p (String n) | _ -> Bool false);
|
|
bind "foreign-lookup" (fun args -> match args with [String n] -> Sx_ref.foreign_lookup (String n) | _ -> Nil);
|
|
bind "foreign-names" (fun _args -> Sx_ref.foreign_names ());
|
|
bind "foreign-register!" (fun args -> match args with [String n; spec] -> Sx_ref.foreign_register_b (String n) spec | _ -> Nil);
|
|
bind "foreign-resolve-binding" (fun args -> match args with [String s] -> Sx_ref.foreign_resolve_binding (String s) | _ -> Nil);
|
|
bind "foreign-check-args" (fun args ->
|
|
let to_list = function List l -> List l | ListRef r -> List !r | v -> v in
|
|
match args with
|
|
| [String n; (List _ | ListRef _ as p); (List _ | ListRef _ as a)] ->
|
|
Sx_ref.foreign_check_args (String n) (to_list p) (to_list a)
|
|
| _ -> Nil);
|
|
bind "foreign-build-lambda" (fun args -> match args with [spec] -> Sx_ref.foreign_build_lambda spec | _ -> Nil);
|
|
|
|
(* Initialize CEK call forward ref — needed by with-capabilities and foreign-dispatch *)
|
|
Sx_types._cek_call_ref := Sx_ref.cek_call;
|
|
|
|
(* --- Primitives for canonical.sx / content tests --- *)
|
|
bind "contains-char?" (fun args ->
|
|
match args with
|
|
| [String s; String c] when String.length c = 1 ->
|
|
Bool (String.contains s c.[0])
|
|
| _ -> Bool false);
|
|
bind "escape-string" (fun args ->
|
|
match args with
|
|
| [String s] ->
|
|
let buf = Buffer.create (String.length s + 4) 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"
|
|
| c -> Buffer.add_char buf c) s;
|
|
String (Buffer.contents buf)
|
|
| _ -> raise (Eval_error "escape-string: expected string"));
|
|
bind "sha3-256" (fun args ->
|
|
match args with
|
|
| [String s] ->
|
|
(* Stub: use a simple hash for testing — not real SHA3 *)
|
|
let h = Hashtbl.hash s in
|
|
String (Printf.sprintf "%064x" (abs h))
|
|
| _ -> raise (Eval_error "sha3-256: expected string"));
|
|
|
|
(* --- 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-file" (fun args -> match args with [v] -> component_file v | _ -> Nil);
|
|
bind "component-set-file!" (fun args -> match args with [v; f] -> component_set_file v f | _ -> Nil);
|
|
|
|
bind "component-params" (fun args ->
|
|
match args with
|
|
| [Component c] -> List (List.map (fun s -> String s) c.c_params)
|
|
| [Island i] -> List (List.map (fun s -> String s) i.i_params)
|
|
| _ -> Nil);
|
|
|
|
bind "component-body" (fun args ->
|
|
match args with
|
|
| [Component c] -> c.c_body
|
|
| [Island i] -> i.i_body
|
|
| _ -> Nil);
|
|
|
|
bind "component-has-children" (fun args ->
|
|
match args with
|
|
| [Component c] -> Bool c.c_has_children
|
|
| [Island i] -> Bool i.i_has_children
|
|
| _ -> Bool false);
|
|
|
|
bind "component-affinity" (fun args ->
|
|
match args with
|
|
| [Component c] -> String c.c_affinity
|
|
| [Island _] -> String "client"
|
|
| _ -> 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"));
|
|
|
|
(* IO suspension primitives — inline until retranspile *)
|
|
let is_suspended state =
|
|
match get_val state (String "phase") with String "io-suspended" -> true | _ -> false in
|
|
let step_loop state =
|
|
let s = ref state in
|
|
while not (match Sx_ref.cek_terminal_p !s with Bool true -> true | _ -> false)
|
|
&& not (is_suspended !s) do
|
|
s := Sx_ref.cek_step !s
|
|
done;
|
|
!s in
|
|
bind "cek-step-loop" (fun args ->
|
|
match args with
|
|
| [state] -> step_loop state
|
|
| _ -> raise (Eval_error "cek-step-loop: expected 1 arg"));
|
|
bind "cek-resume" (fun args ->
|
|
match args with
|
|
| [state; result] ->
|
|
step_loop (Sx_ref.make_cek_value result (get_val state (String "env")) (get_val state (String "kont")))
|
|
| _ -> raise (Eval_error "cek-resume: expected 2 args"));
|
|
bind "cek-suspended?" (fun args ->
|
|
match args with
|
|
| [state] -> Bool (is_suspended state)
|
|
| _ -> raise (Eval_error "cek-suspended?: expected 1 arg"));
|
|
bind "cek-io-request" (fun args ->
|
|
match args with
|
|
| [state] -> get_val state (String "request")
|
|
| _ -> raise (Eval_error "cek-io-request: expected 1 arg"));
|
|
bind "make-cek-suspended" (fun args ->
|
|
match args with
|
|
| [req; env'; kont] ->
|
|
let d = Hashtbl.create 4 in
|
|
Hashtbl.replace d "phase" (String "io-suspended");
|
|
Hashtbl.replace d "request" req;
|
|
Hashtbl.replace d "env" env';
|
|
Hashtbl.replace d "kont" kont;
|
|
Dict d
|
|
| _ -> raise (Eval_error "make-cek-suspended: expected 3 args"));
|
|
|
|
(* --- Library registry --- *)
|
|
let lib_registry = Hashtbl.create 16 in
|
|
ignore (Sx_types.env_bind env "*library-registry*" (Dict lib_registry));
|
|
bind "library-loaded?" (fun args ->
|
|
match args with
|
|
| [spec] -> Sx_ref.library_loaded_p spec
|
|
| _ -> raise (Eval_error "library-loaded?: expected 1 arg"));
|
|
bind "library-exports" (fun args ->
|
|
match args with
|
|
| [spec] -> Sx_ref.library_exports spec
|
|
| _ -> raise (Eval_error "library-exports: expected 1 arg"));
|
|
bind "register-library" (fun args ->
|
|
match args with
|
|
| [spec; exports] -> Sx_ref.register_library spec exports
|
|
| _ -> raise (Eval_error "register-library: expected 2 args"));
|
|
|
|
(* --- 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"));
|
|
|
|
(* Request primitives — stubs for test environment *)
|
|
let _test_state : (string, value) Hashtbl.t = Hashtbl.create 16 in
|
|
bind "now" (fun args ->
|
|
let fmt = match args with String f :: _ -> f | _ -> "%Y-%m-%d %H:%M:%S" in
|
|
let open Unix in let tm = localtime (gettimeofday ()) in
|
|
let r = if fmt = "%H:%M:%S" then Printf.sprintf "%02d:%02d:%02d" tm.tm_hour tm.tm_min tm.tm_sec
|
|
else Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d" (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec in
|
|
String r);
|
|
bind "state-get" (fun args -> match args with
|
|
| String key :: rest -> let default = match rest with v :: _ -> v | [] -> Nil in
|
|
(match Hashtbl.find_opt _test_state key with Some v -> v | None -> default)
|
|
| _ -> Nil);
|
|
bind "state-set!" (fun args -> match args with
|
|
| String key :: value :: _ -> Hashtbl.replace _test_state key value; Nil | _ -> Nil);
|
|
bind "state-clear!" (fun args -> match args with
|
|
| [String key] -> Hashtbl.remove _test_state key; Nil | _ -> Nil);
|
|
bind "request-method" (fun _args -> String "GET");
|
|
bind "request-body" (fun _args -> String "");
|
|
bind "request-form" (fun args -> match args with
|
|
| String _ :: rest -> (match rest with v :: _ -> v | [] -> String "") | _ -> String "");
|
|
bind "request-arg" (fun args -> match args with
|
|
| String _ :: rest -> (match rest with v :: _ -> v | [] -> Nil) | _ -> Nil);
|
|
bind "request-form-all" (fun _args -> Dict (Hashtbl.create 0));
|
|
bind "request-args-all" (fun _args -> Dict (Hashtbl.create 0));
|
|
bind "request-form-list" (fun _args -> List []);
|
|
bind "request-json" (fun _args -> String "");
|
|
bind "request-header" (fun args -> match args with
|
|
| String _ :: rest -> (match rest with v :: _ -> v | [] -> String "") | _ -> String "");
|
|
bind "request-headers-all" (fun _args -> Dict (Hashtbl.create 0));
|
|
bind "request-content-type" (fun _args -> String "");
|
|
bind "request-file-name" (fun _args -> String "");
|
|
bind "into" (fun args -> match args with
|
|
| [String "list"; Dict d] ->
|
|
List (Hashtbl.fold (fun k v acc -> List [String k; v] :: acc) d [])
|
|
| [String "dict"; List pairs] | [String "dict"; ListRef { contents = pairs }] ->
|
|
let d = Hashtbl.create 8 in
|
|
List.iter (fun pair -> match pair with
|
|
| List [String k; v] | ListRef { contents = [String k; v] } -> Hashtbl.replace d k v
|
|
| _ -> ()) pairs;
|
|
Dict d
|
|
| _ -> Nil);
|
|
|
|
(* --- Stubs for offline/IO tests --- *)
|
|
bind "log-info" (fun _args -> Nil);
|
|
bind "log-warn" (fun _args -> Nil);
|
|
bind "log-error" (fun _args -> Nil);
|
|
bind "execute-action" (fun _args -> Nil);
|
|
|
|
(* --- make-page-def for defpage tests --- *)
|
|
bind "make-page-def" (fun args ->
|
|
let convert_val = function Keyword k -> String k | v -> v in
|
|
let make_pdef name slots =
|
|
let d = Hashtbl.create 8 in
|
|
Hashtbl.replace d "__type" (String "page");
|
|
Hashtbl.replace d "name" (String name);
|
|
(* Defaults for missing fields *)
|
|
Hashtbl.replace d "stream" (Bool false);
|
|
Hashtbl.replace d "shell" Nil;
|
|
Hashtbl.replace d "fallback" Nil;
|
|
Hashtbl.replace d "data" Nil;
|
|
(* Override with actual slot values *)
|
|
Hashtbl.iter (fun k v -> Hashtbl.replace d k (convert_val v)) slots;
|
|
Dict d
|
|
in
|
|
match args with
|
|
| [String name; Dict slots; _env] -> make_pdef name slots
|
|
| [String name; Dict slots] -> make_pdef name slots
|
|
| _ -> Nil);
|
|
|
|
(* --- component-io-refs for deps.sx tests --- *)
|
|
bind "component-io-refs" (fun args ->
|
|
match args with
|
|
| [Component c] ->
|
|
(* Scan body for IO calls — look for known IO functions *)
|
|
let rec scan = function
|
|
| List (Symbol s :: _) when
|
|
s = "fetch" || s = "fetch-data" || s = "query" || s = "action" ||
|
|
s = "state-get" || s = "state-set!" ||
|
|
s = "request-arg" || s = "request-form" || s = "request-method" || s = "now" ||
|
|
s = "request-header" || s = "request-json" || s = "request-content-type" ||
|
|
s = "execute-action" || s = "submit-mutation" -> [s]
|
|
| List items | ListRef { contents = items } -> List.concat_map scan items
|
|
| _ -> []
|
|
in
|
|
let refs = scan c.c_body in
|
|
let unique = List.sort_uniq String.compare refs in
|
|
List (List.map (fun s -> String s) unique)
|
|
| _ -> List []);
|
|
bind "component-set-io-refs!" (fun _args -> Nil);
|
|
|
|
(* --- Fragment binding for aser tests --- *)
|
|
bind "<>" (fun args -> List args);
|
|
|
|
(* --- component-deps / component-set-deps! for deps.sx --- *)
|
|
let _comp_deps : (string, value) Hashtbl.t = Hashtbl.create 16 in
|
|
bind "component-deps" (fun args ->
|
|
match args with
|
|
| [Component c] -> (match Hashtbl.find_opt _comp_deps c.c_name with Some v -> v | None -> Nil)
|
|
| [Island i] -> (match Hashtbl.find_opt _comp_deps i.i_name with Some v -> v | None -> Nil)
|
|
| _ -> Nil);
|
|
bind "component-set-deps!" (fun args ->
|
|
match args with
|
|
| [Component c; v] -> Hashtbl.replace _comp_deps c.c_name v; Nil
|
|
| [Island i; v] -> Hashtbl.replace _comp_deps i.i_name v; Nil
|
|
| _ -> Nil);
|
|
|
|
(* --- submit-mutation stub for offline tests --- *)
|
|
bind "submit-mutation" (fun args ->
|
|
match args with
|
|
| _ :: _ -> String "confirmed"
|
|
| _ -> Nil);
|
|
|
|
env
|
|
|
|
(* ====================================================================== *)
|
|
(* Foundation tests (direct, no evaluator) *)
|
|
(* ====================================================================== *)
|
|
|
|
let run_foundation_tests () =
|
|
Printf.printf "=== SX OCaml Foundation Tests ===\n\n";
|
|
|
|
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";
|
|
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" (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" (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" (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";
|
|
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]);
|
|
assert_eq "/" (Number 2.5) (call "/" [Number 5.0; Number 2.0]);
|
|
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]]);
|
|
assert_eq "rest" (List [Number 2.0; Number 3.0]) (call "rest" [List [Number 1.0; Number 2.0; Number 3.0]]);
|
|
assert_eq "nth" (Number 2.0) (call "nth" [List [Number 1.0; Number 2.0]; Number 1.0]);
|
|
assert_eq "cons" (List [Number 0.0; Number 1.0]) (call "cons" [Number 0.0; List [Number 1.0]]);
|
|
assert_eq "append" (List [Number 1.0; Number 2.0; Number 3.0])
|
|
(call "append" [List [Number 1.0]; List [Number 2.0; Number 3.0]]);
|
|
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 "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";
|
|
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";
|
|
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; l_compiled = 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))
|
|
|
|
|
|
(* ====================================================================== *)
|
|
(* 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;
|
|
|
|
(* IO-aware evaluation: resolve library paths and handle import suspension *)
|
|
let lib_base = Filename.concat project_dir "lib" in
|
|
let spec_base = Filename.concat project_dir "spec" in
|
|
let web_base = Filename.concat project_dir "web" in
|
|
|
|
let resolve_library_path lib_spec =
|
|
let parts = match lib_spec with List l | ListRef { contents = l } -> l | _ -> [] in
|
|
match List.map (fun v -> match v with Symbol s -> s | String s -> s | _ -> "") parts with
|
|
| ["sx"; name] ->
|
|
let spec_path = Filename.concat spec_base (name ^ ".sx") in
|
|
let lib_path = Filename.concat lib_base (name ^ ".sx") in
|
|
let web_lib_path = Filename.concat (Filename.concat web_base "lib") (name ^ ".sx") in
|
|
if Sys.file_exists spec_path then Some spec_path
|
|
else if Sys.file_exists lib_path then Some lib_path
|
|
else if Sys.file_exists web_lib_path then Some web_lib_path
|
|
else None
|
|
| ["web"; name] ->
|
|
let path = Filename.concat web_base (name ^ ".sx") in
|
|
let lib_path = Filename.concat (Filename.concat web_base "lib") (name ^ ".sx") in
|
|
if Sys.file_exists path then Some path
|
|
else if Sys.file_exists lib_path then Some lib_path
|
|
else None
|
|
| [prefix; name] ->
|
|
let path = Filename.concat (Filename.concat project_dir prefix) (name ^ ".sx") in
|
|
if Sys.file_exists path then Some path else None
|
|
| _ -> None
|
|
in
|
|
|
|
(* Run CEK step loop, handling IO suspension for imports *)
|
|
let rec eval_with_io expr env_val =
|
|
let state = Sx_ref.make_cek_state expr env_val (List []) in
|
|
run_with_io state
|
|
and load_library_file path =
|
|
let exprs = Sx_parser.parse_file path in
|
|
List.iter (fun expr -> ignore (eval_with_io expr (Env env))) exprs
|
|
and run_with_io state =
|
|
let s = ref state in
|
|
let is_terminal st = match Sx_ref.cek_terminal_p st with Bool true -> true | _ -> false in
|
|
let is_suspended st = match Sx_runtime.get_val st (String "phase") with String "io-suspended" -> true | _ -> false in
|
|
(* Check if kont has any handler frames — pure structural scan *)
|
|
let kont_has_handler kont =
|
|
let k = ref kont in
|
|
let found = ref false in
|
|
while (match !k with List (_::_) -> true | _ -> false) && not !found do
|
|
(match !k with
|
|
| List (frame :: rest) ->
|
|
(match frame with
|
|
| CekFrame f when f.cf_type = "handler" -> found := true
|
|
| _ -> ());
|
|
k := List rest
|
|
| _ -> k := List [])
|
|
done;
|
|
!found in
|
|
let rec loop () =
|
|
while not (is_terminal !s) && not (is_suspended !s) do
|
|
(try s := Sx_ref.cek_step !s
|
|
with Eval_error msg ->
|
|
let kont = Sx_ref.cek_kont !s in
|
|
if kont_has_handler kont then
|
|
(* Convert to CEK-level raise so guard/handler-bind can catch it *)
|
|
let env = Sx_ref.cek_env !s in
|
|
s := Sx_ref.make_cek_value (String msg) env
|
|
(Sx_ref.kont_push (Sx_ref.make_raise_eval_frame env (Bool false)) kont)
|
|
else
|
|
raise (Eval_error msg))
|
|
done;
|
|
if is_suspended !s then begin
|
|
let request = Sx_runtime.get_val !s (String "request") in
|
|
let op = match Sx_runtime.get_val request (String "op") with String s -> s | _ -> "" in
|
|
let response = match op with
|
|
| "import" ->
|
|
let lib_spec = Sx_runtime.get_val request (String "library") in
|
|
let key = Sx_ref.library_name_key lib_spec in
|
|
if Sx_types.sx_truthy (Sx_ref.library_loaded_p key) then
|
|
Nil
|
|
else begin
|
|
(match resolve_library_path lib_spec with
|
|
| Some path ->
|
|
(try load_library_file path
|
|
with Sx_types.Eval_error msg ->
|
|
Printf.eprintf "[import] Warning loading %s: %s\n%!"
|
|
(Sx_runtime.value_to_str lib_spec) msg)
|
|
| None -> ()); (* silently skip unresolvable libraries *)
|
|
Nil
|
|
end
|
|
| _ -> Nil (* Other IO ops return nil in test context *)
|
|
in
|
|
s := Sx_ref.cek_resume !s response;
|
|
loop ()
|
|
end else
|
|
Sx_ref.cek_value !s
|
|
in
|
|
loop ()
|
|
in
|
|
|
|
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 ->
|
|
try ignore (eval_with_io expr (Env env))
|
|
with Sx_types.Eval_error _ -> () (* skip expressions that fail during load *)
|
|
) exprs
|
|
in
|
|
|
|
Printf.printf "\nLoading test framework...\n%!";
|
|
load_and_eval framework_path;
|
|
|
|
(* Load test harness (mock IO platform) *)
|
|
let harness_path = Filename.concat (Filename.concat project_dir "spec") "harness.sx" in
|
|
if Sys.file_exists harness_path then begin
|
|
Printf.printf "Loading test harness...\n%!";
|
|
(try load_and_eval harness_path
|
|
with e -> Printf.eprintf "Warning: harness.sx: %s\n%!" (Printexc.to_string e))
|
|
end;
|
|
|
|
(* Load modules needed by tests *)
|
|
let spec_dir = Filename.concat project_dir "spec" in
|
|
let lib_dir = Filename.concat project_dir "lib" in
|
|
let web_dir = Filename.concat project_dir "web" in
|
|
let load_module name dir =
|
|
let path = Filename.concat dir name in
|
|
if Sys.file_exists path then begin
|
|
Printf.printf "Loading %s...\n%!" name;
|
|
(try load_and_eval path
|
|
with e -> Printf.eprintf "Warning: %s: %s\n%!" name (Printexc.to_string e))
|
|
end
|
|
in
|
|
(* R7RS compatibility library — minimal test version *)
|
|
load_module "r7rs.sx" lib_dir;
|
|
(* Render adapter for test-render-html.sx *)
|
|
load_module "render.sx" spec_dir;
|
|
load_module "canonical.sx" spec_dir;
|
|
load_module "adapter-html.sx" web_dir;
|
|
load_module "adapter-sx.sx" web_dir;
|
|
(* Web modules for web/tests/ *)
|
|
load_module "forms.sx" web_dir;
|
|
load_module "engine.sx" web_dir;
|
|
load_module "page-helpers.sx" web_dir;
|
|
load_module "request-handler.sx" web_dir;
|
|
load_module "router.sx" web_dir;
|
|
load_module "deps.sx" web_dir;
|
|
load_module "orchestration.sx" web_dir;
|
|
(* Library modules for lib/tests/ *)
|
|
load_module "bytecode.sx" lib_dir;
|
|
load_module "compiler.sx" lib_dir;
|
|
load_module "vm.sx" lib_dir;
|
|
load_module "signals.sx" spec_dir; (* core reactive primitives *)
|
|
load_module "signals.sx" web_dir; (* web extensions *)
|
|
load_module "freeze.sx" lib_dir;
|
|
load_module "content.sx" lib_dir;
|
|
load_module "parser-combinators.sx" lib_dir;
|
|
let hs_dir = Filename.concat lib_dir "hyperscript" in
|
|
load_module "tokenizer.sx" hs_dir;
|
|
load_module "parser.sx" hs_dir;
|
|
load_module "compiler.sx" hs_dir;
|
|
load_module "runtime.sx" hs_dir;
|
|
load_module "types.sx" lib_dir;
|
|
load_module "sx-swap.sx" lib_dir;
|
|
(* Shared templates: TW styling engine *)
|
|
let templates_dir = Filename.concat project_dir "shared/sx/templates" in
|
|
load_module "tw.sx" templates_dir;
|
|
load_module "tw-layout.sx" templates_dir;
|
|
load_module "tw-type.sx" templates_dir;
|
|
(* SX docs site: components, handlers, demos *)
|
|
let sx_comp_dir = Filename.concat project_dir "sx/sxc" in
|
|
let sx_sx_dir = Filename.concat project_dir "sx/sx" in
|
|
let sx_handlers_dir = Filename.concat project_dir "sx/sx/handlers" in
|
|
let sx_islands_dir = Filename.concat project_dir "sx/sx/reactive-islands" in
|
|
let sx_geo_dir = Filename.concat project_dir "sx/sx/geography" in
|
|
(* Components + handlers *)
|
|
load_module "examples.sx" sx_comp_dir;
|
|
load_module "docs.sx" sx_sx_dir;
|
|
load_module "examples.sx" sx_handlers_dir;
|
|
load_module "ref-api.sx" sx_handlers_dir;
|
|
load_module "reactive-api.sx" sx_handlers_dir;
|
|
(* Server-rendered demos *)
|
|
load_module "scopes.sx" sx_sx_dir;
|
|
load_module "provide.sx" sx_sx_dir;
|
|
load_module "spreads.sx" sx_sx_dir;
|
|
(* Island definitions *)
|
|
load_module "index.sx" sx_islands_dir;
|
|
load_module "demo.sx" sx_islands_dir;
|
|
load_module "marshes.sx" sx_islands_dir;
|
|
load_module "cek.sx" sx_geo_dir;
|
|
load_module "reactive-runtime.sx" sx_sx_dir;
|
|
|
|
(* Create short-name aliases for reactive-islands tests *)
|
|
let alias short full =
|
|
try let v = Sx_types.env_get env full in
|
|
ignore (Sx_types.env_bind env short v)
|
|
with _ -> () in
|
|
alias "~reactive-islands/counter" "~reactive-islands/index/demo-counter";
|
|
alias "~reactive-islands/temperature" "~reactive-islands/index/demo-temperature";
|
|
alias "~reactive-islands/stopwatch" "~reactive-islands/index/demo-stopwatch";
|
|
alias "~reactive-islands/reactive-list" "~reactive-islands/index/demo-reactive-list";
|
|
alias "~reactive-islands/input-binding" "~reactive-islands/index/demo-input-binding";
|
|
alias "~reactive-islands/error-boundary" "~reactive-islands/index/demo-error-boundary";
|
|
alias "~reactive-islands/dynamic-class" "~reactive-islands/index/demo-dynamic-class";
|
|
alias "~reactive-islands/store-writer" "~reactive-islands/index/demo-store-writer";
|
|
alias "~reactive-islands/store-reader" "~reactive-islands/index/demo-store-reader";
|
|
alias "~marshes/demo-marsh-product" "~reactive-islands/marshes/demo-marsh-product";
|
|
alias "~marshes/demo-marsh-settle" "~reactive-islands/marshes/demo-marsh-settle";
|
|
|
|
(* Determine test files — scan spec/tests/, lib/tests/, web/tests/ *)
|
|
let lib_tests_dir = Filename.concat project_dir "lib/tests" in
|
|
let web_tests_dir = Filename.concat project_dir "web/tests" in
|
|
|
|
(* Pre-load test-handlers.sx so its mock definitions (reset-mocks!, helper, etc.)
|
|
are available to test-examples.sx which loads before it alphabetically *)
|
|
load_module "test-handlers.sx" web_tests_dir;
|
|
|
|
(* Re-bind render-to-sx AFTER adapter-sx.sx has loaded, wrapping the SX version.
|
|
The SX render-to-sx handles AST inputs; we add string→parse→aser support. *)
|
|
let sx_render_to_sx = try Some (Sx_types.env_get env "render-to-sx") with _ -> None in
|
|
ignore (Sx_types.env_bind env "render-to-sx" (NativeFn ("render-to-sx", fun args ->
|
|
match args with
|
|
| [String src] ->
|
|
(* String input: parse then evaluate via aser (quote the parsed AST so aser sees raw structure) *)
|
|
let exprs = Sx_parser.parse_all src in
|
|
let expr = match exprs with [e] -> e | es -> List (Symbol "do" :: es) in
|
|
let result = eval_expr (List [Symbol "aser"; List [Symbol "quote"; expr]; Env env]) (Env env) in
|
|
(match result with SxExpr s -> String s | String s -> String s | _ -> String (Sx_runtime.value_to_str result))
|
|
| _ ->
|
|
(* AST input: delegate to the SX render-to-sx *)
|
|
match sx_render_to_sx with
|
|
| Some (NativeFn (_, f)) -> f args
|
|
| Some (Lambda _ as fn) -> Sx_ref.cek_call fn (List args)
|
|
| _ -> String "")));
|
|
|
|
|
|
let files = if test_files = [] then begin
|
|
(* Spec tests (core language — always run) *)
|
|
let spec_entries = Sys.readdir spec_tests_dir in
|
|
Array.sort String.compare spec_entries;
|
|
let spec_files = Array.to_list spec_entries
|
|
|> List.filter (fun f ->
|
|
String.length f > 5 &&
|
|
String.sub f 0 5 = "test-" &&
|
|
Filename.check_suffix f ".sx" &&
|
|
f <> "test-framework.sx")
|
|
|> List.map (fun f -> Filename.concat spec_tests_dir f)
|
|
in
|
|
(* Web tests (orchestration, handlers) *)
|
|
let web_files = if Sys.file_exists web_tests_dir then begin
|
|
let entries = Sys.readdir web_tests_dir in
|
|
Array.sort String.compare entries;
|
|
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-handlers.sx" && (* pre-loaded above *)
|
|
f <> "test-wasm-browser.sx" && (* browser-only, needs DOM primitives *)
|
|
f <> "test-adapter-dom.sx" && (* browser-only, needs DOM renderer *)
|
|
f <> "test-boot-helpers.sx" && (* browser-only, needs boot module *)
|
|
f <> "test-layout.sx" && (* needs render-to-html begin+defcomp support *)
|
|
f <> "test-cek-reactive.sx") (* needs test-env/make-reactive-reset-frame infra *)
|
|
|> List.map (fun f -> Filename.concat web_tests_dir f)
|
|
end else [] in
|
|
spec_files @ web_files
|
|
end else
|
|
(* Specific test files — search all test dirs *)
|
|
List.map (fun name ->
|
|
let name = if Filename.check_suffix name ".sx" then name else name ^ ".sx" in
|
|
let spec_path = Filename.concat spec_tests_dir name in
|
|
let lib_path = Filename.concat lib_tests_dir name in
|
|
let web_path = Filename.concat web_tests_dir name in
|
|
if Sys.file_exists spec_path then spec_path
|
|
else if Sys.file_exists lib_path then lib_path
|
|
else if Sys.file_exists web_path then web_path
|
|
else Filename.concat spec_tests_dir name (* will fail with "not found" *)
|
|
) test_files
|
|
in
|
|
|
|
List.iter (fun path ->
|
|
if Sys.file_exists path then begin
|
|
let name = Filename.basename path in
|
|
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 jit_enabled = List.mem "--jit" 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 + JIT) ===\n%!";
|
|
let env = make_test_env () in
|
|
(* Load compiler and enable JIT (opt-in via --jit flag) *)
|
|
if jit_enabled then begin
|
|
let globals = Hashtbl.create 512 in
|
|
let rec env_to_globals e =
|
|
Hashtbl.iter (fun id v ->
|
|
let name = Sx_types.unintern id in
|
|
if not (Hashtbl.mem globals name) then
|
|
Hashtbl.replace globals name v) e.Sx_types.bindings;
|
|
match e.Sx_types.parent with Some p -> env_to_globals p | None -> ()
|
|
in
|
|
env_to_globals env;
|
|
(try
|
|
let compiler_path = if Sys.file_exists "lib/compiler.sx" then "lib/compiler.sx"
|
|
else "../../lib/compiler.sx" in
|
|
let ic = open_in compiler_path in
|
|
let src = really_input_string ic (in_channel_length ic) in
|
|
close_in ic; let _ = src in
|
|
let exprs = Sx_parser.parse_all src in
|
|
List.iter (fun e -> ignore (Sx_ref.eval_expr e (Env env))) exprs;
|
|
env_to_globals env;
|
|
Sx_runtime._jit_try_call_fn := Some (fun f args ->
|
|
match f with
|
|
| Lambda l ->
|
|
(match l.l_compiled with
|
|
| Some cl when not (Sx_vm.is_jit_failed cl) ->
|
|
(try Some (Sx_vm.call_closure cl args cl.vm_env_ref)
|
|
with _ -> None)
|
|
| Some _ -> None
|
|
| None ->
|
|
if l.l_name = None then None
|
|
else begin
|
|
l.l_compiled <- Some Sx_vm.jit_failed_sentinel;
|
|
match Sx_vm.jit_compile_lambda l globals with
|
|
| Some cl -> l.l_compiled <- Some cl;
|
|
(try Some (Sx_vm.call_closure cl args cl.vm_env_ref) with _ -> None)
|
|
| None -> None
|
|
end)
|
|
| _ -> None);
|
|
Printf.printf "[jit] Compiler loaded, JIT enabled\n%!"
|
|
with e ->
|
|
Printf.printf "[jit] Compiler not loaded: %s\n%!" (Printexc.to_string e));
|
|
end;
|
|
Sx_runtime.jit_reset_counters ();
|
|
run_spec_tests env test_files
|
|
end;
|
|
|
|
(* JIT statistics *)
|
|
let jh = !(Sx_runtime._jit_hit) and jm = !(Sx_runtime._jit_miss) and js = !(Sx_runtime._jit_skip) in
|
|
let total = jh + jm + js in
|
|
if total > 0 then
|
|
Printf.printf "\n[jit] calls=%d hit=%d (%.1f%%) miss=%d skip=%d\n"
|
|
total jh (100.0 *. float_of_int jh /. float_of_int (max 1 total)) jm js;
|
|
|
|
(* Summary *)
|
|
Printf.printf "\n%s\n" (String.make 60 '=');
|
|
Printf.printf "Results: %d passed, %d failed\n" !pass_count !fail_count;
|
|
Printf.printf "%s\n" (String.make 60 '=');
|
|
if !fail_count > 0 then exit 1
|