Compare commits
7 Commits
2ef3f03db3
...
macros
| Author | SHA1 | Date | |
|---|---|---|---|
| 5ab3ecb7e0 | |||
| 313f7d6be1 | |||
| 16fa813d6d | |||
| 818e5d53f0 | |||
| 3a268e7277 | |||
| bdbf594bc8 | |||
| a1fa1edf8a |
1
.gitignore
vendored
1
.gitignore
vendored
@@ -14,3 +14,4 @@ _debug/
|
||||
sx-haskell/
|
||||
sx-rust/
|
||||
shared/static/scripts/sx-full-test.js
|
||||
hosts/ocaml/_build/
|
||||
|
||||
@@ -13,6 +13,8 @@ services:
|
||||
ENVIRONMENT: development
|
||||
RELOAD: "true"
|
||||
SX_USE_REF: "1"
|
||||
SX_USE_OCAML: "1"
|
||||
SX_OCAML_BIN: "/app/bin/sx_server"
|
||||
SX_BOUNDARY_STRICT: "1"
|
||||
SX_DEV: "1"
|
||||
volumes:
|
||||
@@ -26,6 +28,8 @@ services:
|
||||
- ./sx/sx:/app/sx
|
||||
- ./sx/path_setup.py:/app/path_setup.py
|
||||
- ./sx/entrypoint.sh:/usr/local/bin/entrypoint.sh
|
||||
# OCaml SX kernel binary (built with: cd hosts/ocaml && eval $(opam env) && dune build)
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./sx/__init__.py:/app/__init__.py:ro
|
||||
# sibling models for cross-domain SQLAlchemy imports
|
||||
- ./blog/__init__.py:/app/blog/__init__.py:ro
|
||||
|
||||
@@ -228,6 +228,8 @@ services:
|
||||
<<: *app-env
|
||||
REDIS_URL: redis://redis:6379/10
|
||||
WORKERS: "1"
|
||||
SX_USE_OCAML: "1"
|
||||
SX_OCAML_BIN: "/app/bin/sx_server"
|
||||
|
||||
db:
|
||||
image: postgres:16
|
||||
|
||||
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)
|
||||
3
hosts/ocaml/bin/dune
Normal file
3
hosts/ocaml/bin/dune
Normal file
@@ -0,0 +1,3 @@
|
||||
(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))
|
||||
701
hosts/ocaml/bin/run_tests.ml
Normal file
701
hosts/ocaml/bin/run_tests.ml
Normal file
@@ -0,0 +1,701 @@
|
||||
(** 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 *)
|
||||
|
||||
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 []
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* 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
|
||||
| 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
|
||||
|
||||
(* --- 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";
|
||||
|
||||
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 } 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;
|
||||
|
||||
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 "%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 -> ()
|
||||
150
hosts/ocaml/bootstrap.py
Normal file
150
hosts/ocaml/bootstrap.py
Normal file
@@ -0,0 +1,150 @@
|
||||
#!/usr/bin/env python3
|
||||
"""
|
||||
Bootstrap compiler: SX spec -> OCaml.
|
||||
|
||||
Loads the SX-to-OCaml transpiler (transpiler.sx), feeds it the spec files,
|
||||
and produces sx_ref.ml — the transpiled evaluator as native OCaml.
|
||||
|
||||
Usage:
|
||||
python3 hosts/ocaml/bootstrap.py --output hosts/ocaml/lib/sx_ref.ml
|
||||
"""
|
||||
from __future__ import annotations
|
||||
|
||||
import os
|
||||
import sys
|
||||
|
||||
_HERE = os.path.dirname(os.path.abspath(__file__))
|
||||
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", ".."))
|
||||
sys.path.insert(0, _PROJECT)
|
||||
|
||||
from shared.sx.parser import parse_all
|
||||
from shared.sx.types import Symbol
|
||||
|
||||
|
||||
def extract_defines(source: str) -> list[tuple[str, list]]:
|
||||
"""Parse .sx source, return list of (name, define-expr) for top-level defines."""
|
||||
exprs = parse_all(source)
|
||||
defines = []
|
||||
for expr in exprs:
|
||||
if isinstance(expr, list) and expr and isinstance(expr[0], Symbol):
|
||||
if expr[0].name == "define":
|
||||
name = expr[1].name if isinstance(expr[1], Symbol) else str(expr[1])
|
||||
defines.append((name, expr))
|
||||
return defines
|
||||
|
||||
|
||||
# OCaml preamble — opens and runtime helpers
|
||||
PREAMBLE = """\
|
||||
(* sx_ref.ml — Auto-generated from SX spec by hosts/ocaml/bootstrap.py *)
|
||||
(* Do not edit — regenerate with: python3 hosts/ocaml/bootstrap.py *)
|
||||
|
||||
[@@@warning "-26-27"]
|
||||
|
||||
open Sx_types
|
||||
open Sx_runtime
|
||||
|
||||
(* Trampoline — evaluates thunks via the CEK machine.
|
||||
eval_expr is defined in the transpiled block below. *)
|
||||
let trampoline v = v (* CEK machine doesn't produce thunks *)
|
||||
|
||||
"""
|
||||
|
||||
|
||||
# OCaml fixups — override iterative CEK run
|
||||
FIXUPS = """\
|
||||
|
||||
(* Override recursive cek_run with iterative loop *)
|
||||
let cek_run_iterative state =
|
||||
let s = ref state in
|
||||
while not (match cek_terminal_p !s with Bool true -> true | _ -> false) do
|
||||
s := cek_step !s
|
||||
done;
|
||||
cek_value !s
|
||||
|
||||
"""
|
||||
|
||||
|
||||
def compile_spec_to_ml(spec_dir: str | None = None) -> str:
|
||||
"""Compile the SX spec to OCaml source."""
|
||||
from shared.sx.ref.sx_ref import eval_expr, trampoline, make_env, sx_parse
|
||||
|
||||
if spec_dir is None:
|
||||
spec_dir = os.path.join(_PROJECT, "spec")
|
||||
|
||||
# Load the transpiler
|
||||
env = make_env()
|
||||
transpiler_path = os.path.join(_HERE, "transpiler.sx")
|
||||
with open(transpiler_path) as f:
|
||||
transpiler_src = f.read()
|
||||
for expr in sx_parse(transpiler_src):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Spec files to transpile (in dependency order)
|
||||
sx_files = [
|
||||
("evaluator.sx", "evaluator (frames + eval + CEK)"),
|
||||
]
|
||||
|
||||
parts = [PREAMBLE]
|
||||
|
||||
for filename, label in sx_files:
|
||||
filepath = os.path.join(spec_dir, filename)
|
||||
if not os.path.exists(filepath):
|
||||
print(f"Warning: {filepath} not found, skipping", file=sys.stderr)
|
||||
continue
|
||||
|
||||
with open(filepath) as f:
|
||||
src = f.read()
|
||||
defines = extract_defines(src)
|
||||
|
||||
# Skip defines provided by preamble or fixups
|
||||
skip = {"trampoline"}
|
||||
defines = [(n, e) for n, e in defines if n not in skip]
|
||||
|
||||
# Deduplicate — keep last definition for each name (CEK overrides tree-walk)
|
||||
seen = {}
|
||||
for i, (n, e) in enumerate(defines):
|
||||
seen[n] = i
|
||||
defines = [(n, e) for i, (n, e) in enumerate(defines) if seen[n] == i]
|
||||
|
||||
# Build the defines list for the transpiler
|
||||
defines_list = [[name, expr] for name, expr in defines]
|
||||
env["_defines"] = defines_list
|
||||
|
||||
# Pass known define names so the transpiler can distinguish
|
||||
# static (OCaml fn) calls from dynamic (SX value) calls
|
||||
env["_known_defines"] = [name for name, _ in defines]
|
||||
|
||||
# Call ml-translate-file — emits as single let rec block
|
||||
translate_expr = sx_parse("(ml-translate-file _defines)")[0]
|
||||
result = trampoline(eval_expr(translate_expr, env))
|
||||
|
||||
parts.append(f"\n(* === Transpiled from {label} === *)\n")
|
||||
parts.append(result)
|
||||
|
||||
parts.append(FIXUPS)
|
||||
return "\n".join(parts)
|
||||
|
||||
|
||||
def main():
|
||||
import argparse
|
||||
parser = argparse.ArgumentParser(description="Bootstrap SX spec -> OCaml")
|
||||
parser.add_argument(
|
||||
"--output", "-o",
|
||||
default=None,
|
||||
help="Output file (default: stdout)",
|
||||
)
|
||||
args = parser.parse_args()
|
||||
|
||||
result = compile_spec_to_ml()
|
||||
|
||||
if args.output:
|
||||
with open(args.output, "w") as f:
|
||||
f.write(result)
|
||||
size = os.path.getsize(args.output)
|
||||
print(f"Wrote {args.output} ({size} bytes)", file=sys.stderr)
|
||||
else:
|
||||
print(result)
|
||||
|
||||
|
||||
if __name__ == "__main__":
|
||||
main()
|
||||
2
hosts/ocaml/dune-project
Normal file
2
hosts/ocaml/dune-project
Normal file
@@ -0,0 +1,2 @@
|
||||
(lang dune 3.0)
|
||||
(name sx)
|
||||
2
hosts/ocaml/lib/dune
Normal file
2
hosts/ocaml/lib/dune
Normal file
@@ -0,0 +1,2 @@
|
||||
(library
|
||||
(name sx))
|
||||
206
hosts/ocaml/lib/sx_parser.ml
Normal file
206
hosts/ocaml/lib/sx_parser.ml
Normal file
@@ -0,0 +1,206 @@
|
||||
(** S-expression parser.
|
||||
|
||||
Recursive descent over a string, producing [Sx_types.value list].
|
||||
Supports: lists, dicts, symbols, keywords, strings (with escapes),
|
||||
numbers, booleans, nil, comments, quote/quasiquote/unquote sugar. *)
|
||||
|
||||
open Sx_types
|
||||
|
||||
type state = {
|
||||
src : string;
|
||||
len : int;
|
||||
mutable pos : int;
|
||||
}
|
||||
|
||||
let make_state src = { src; len = String.length src; pos = 0 }
|
||||
|
||||
let peek s = if s.pos < s.len then Some s.src.[s.pos] else None
|
||||
let advance s = s.pos <- s.pos + 1
|
||||
let at_end s = s.pos >= s.len
|
||||
|
||||
let skip_whitespace_and_comments s =
|
||||
let rec go () =
|
||||
if at_end s then ()
|
||||
else match s.src.[s.pos] with
|
||||
| ' ' | '\t' | '\n' | '\r' -> advance s; go ()
|
||||
| ';' ->
|
||||
while s.pos < s.len && s.src.[s.pos] <> '\n' do advance s done;
|
||||
if s.pos < s.len then advance s;
|
||||
go ()
|
||||
| _ -> ()
|
||||
in go ()
|
||||
|
||||
let is_symbol_char = function
|
||||
| '(' | ')' | '[' | ']' | '{' | '}' | '"' | '\'' | '`'
|
||||
| ' ' | '\t' | '\n' | '\r' | ',' | ';' -> false
|
||||
| _ -> true
|
||||
|
||||
let read_string s =
|
||||
(* s.pos is on the opening quote *)
|
||||
advance s;
|
||||
let buf = Buffer.create 64 in
|
||||
let rec go () =
|
||||
if at_end s then raise (Parse_error "Unterminated string");
|
||||
let c = s.src.[s.pos] in
|
||||
advance s;
|
||||
if c = '"' then Buffer.contents buf
|
||||
else if c = '\\' then begin
|
||||
if at_end s then raise (Parse_error "Unterminated string escape");
|
||||
let esc = s.src.[s.pos] in
|
||||
advance s;
|
||||
(match esc with
|
||||
| 'n' -> Buffer.add_char buf '\n'
|
||||
| 't' -> Buffer.add_char buf '\t'
|
||||
| 'r' -> Buffer.add_char buf '\r'
|
||||
| '"' -> Buffer.add_char buf '"'
|
||||
| '\\' -> Buffer.add_char buf '\\'
|
||||
| 'u' ->
|
||||
(* \uXXXX — read 4 hex digits, encode as UTF-8 *)
|
||||
if s.pos + 4 > s.len then raise (Parse_error "Incomplete \\u escape");
|
||||
let hex = String.sub s.src s.pos 4 in
|
||||
s.pos <- s.pos + 4;
|
||||
let code = int_of_string ("0x" ^ hex) in
|
||||
let ubuf = Buffer.create 4 in
|
||||
Buffer.add_utf_8_uchar ubuf (Uchar.of_int code);
|
||||
Buffer.add_string buf (Buffer.contents ubuf)
|
||||
| '`' -> Buffer.add_char buf '`'
|
||||
| _ -> Buffer.add_char buf '\\'; Buffer.add_char buf esc);
|
||||
go ()
|
||||
end else begin
|
||||
Buffer.add_char buf c;
|
||||
go ()
|
||||
end
|
||||
in go ()
|
||||
|
||||
let read_symbol s =
|
||||
let start = s.pos in
|
||||
while s.pos < s.len && is_symbol_char s.src.[s.pos] do advance s done;
|
||||
String.sub s.src start (s.pos - start)
|
||||
|
||||
let try_number str =
|
||||
match float_of_string_opt str with
|
||||
| Some n -> Some (Number n)
|
||||
| None -> None
|
||||
|
||||
let rec read_value s : value =
|
||||
skip_whitespace_and_comments s;
|
||||
if at_end s then raise (Parse_error "Unexpected end of input");
|
||||
match s.src.[s.pos] with
|
||||
| '(' -> read_list s ')'
|
||||
| '[' -> read_list s ']'
|
||||
| '{' -> read_dict s
|
||||
| '"' -> String (read_string s)
|
||||
| '\'' -> advance s; List [Symbol "quote"; read_value s]
|
||||
| '`' -> advance s; List [Symbol "quasiquote"; read_value s]
|
||||
| '#' when s.pos + 1 < s.len && s.src.[s.pos + 1] = ';' ->
|
||||
(* Datum comment: #; discards next expression *)
|
||||
advance s; advance s;
|
||||
ignore (read_value s);
|
||||
read_value s
|
||||
| '#' when s.pos + 1 < s.len && s.src.[s.pos + 1] = '\'' ->
|
||||
(* Quote shorthand: #'expr -> (quote expr) *)
|
||||
advance s; advance s;
|
||||
List [Symbol "quote"; read_value s]
|
||||
| '#' when s.pos + 1 < s.len && s.src.[s.pos + 1] = '|' ->
|
||||
(* Raw string: #|...| — ends at next | *)
|
||||
advance s; advance s;
|
||||
let buf = Buffer.create 64 in
|
||||
let rec go () =
|
||||
if at_end s then raise (Parse_error "Unterminated raw string");
|
||||
let c = s.src.[s.pos] in
|
||||
advance s;
|
||||
if c = '|' then
|
||||
String (Buffer.contents buf)
|
||||
else begin
|
||||
Buffer.add_char buf c;
|
||||
go ()
|
||||
end
|
||||
in go ()
|
||||
| '~' when s.pos + 1 < s.len && s.src.[s.pos + 1] = '@' ->
|
||||
advance s; advance s; (* skip ~@ *)
|
||||
List [Symbol "splice-unquote"; read_value s]
|
||||
| _ ->
|
||||
(* Check for unquote: , followed by non-whitespace *)
|
||||
if s.src.[s.pos] = ',' && s.pos + 1 < s.len &&
|
||||
s.src.[s.pos + 1] <> ' ' && s.src.[s.pos + 1] <> '\n' then begin
|
||||
advance s;
|
||||
if s.pos < s.len && s.src.[s.pos] = '@' then begin
|
||||
advance s;
|
||||
List [Symbol "splice-unquote"; read_value s]
|
||||
end else
|
||||
List [Symbol "unquote"; read_value s]
|
||||
end else begin
|
||||
(* Symbol, keyword, number, or boolean *)
|
||||
let token = read_symbol s in
|
||||
if token = "" then raise (Parse_error ("Unexpected char: " ^ String.make 1 s.src.[s.pos]));
|
||||
match token with
|
||||
| "true" -> Bool true
|
||||
| "false" -> Bool false
|
||||
| "nil" -> Nil
|
||||
| _ when token.[0] = ':' ->
|
||||
Keyword (String.sub token 1 (String.length token - 1))
|
||||
| _ ->
|
||||
match try_number token with
|
||||
| Some n -> n
|
||||
| None -> Symbol token
|
||||
end
|
||||
|
||||
and read_list s close_char =
|
||||
advance s; (* skip opening paren/bracket *)
|
||||
let items = ref [] in
|
||||
let rec go () =
|
||||
skip_whitespace_and_comments s;
|
||||
if at_end s then raise (Parse_error "Unterminated list");
|
||||
if s.src.[s.pos] = close_char then begin
|
||||
advance s;
|
||||
List (List.rev !items)
|
||||
end else begin
|
||||
items := read_value s :: !items;
|
||||
go ()
|
||||
end
|
||||
in go ()
|
||||
|
||||
and read_dict s =
|
||||
advance s; (* skip { *)
|
||||
let d = make_dict () in
|
||||
let rec go () =
|
||||
skip_whitespace_and_comments s;
|
||||
if at_end s then raise (Parse_error "Unterminated dict");
|
||||
if s.src.[s.pos] = '}' then begin
|
||||
advance s;
|
||||
Dict d
|
||||
end else begin
|
||||
let key = read_value s in
|
||||
let key_str = match key with
|
||||
| Keyword k -> k
|
||||
| String k -> k
|
||||
| Symbol k -> k
|
||||
| _ -> raise (Parse_error "Dict key must be keyword, string, or symbol")
|
||||
in
|
||||
let v = read_value s in
|
||||
dict_set d key_str v;
|
||||
go ()
|
||||
end
|
||||
in go ()
|
||||
|
||||
|
||||
(** Parse a string into a list of SX values. *)
|
||||
let parse_all src =
|
||||
let s = make_state src in
|
||||
let results = ref [] in
|
||||
let rec go () =
|
||||
skip_whitespace_and_comments s;
|
||||
if at_end s then List.rev !results
|
||||
else begin
|
||||
results := read_value s :: !results;
|
||||
go ()
|
||||
end
|
||||
in go ()
|
||||
|
||||
(** Parse a file into a list of SX values. *)
|
||||
let parse_file path =
|
||||
let ic = open_in path in
|
||||
let n = in_channel_length ic in
|
||||
let src = really_input_string ic n in
|
||||
close_in ic;
|
||||
parse_all src
|
||||
578
hosts/ocaml/lib/sx_primitives.ml
Normal file
578
hosts/ocaml/lib/sx_primitives.ml
Normal file
@@ -0,0 +1,578 @@
|
||||
(** Built-in primitive functions (~80 pure functions).
|
||||
|
||||
Registered in a global table; the evaluator checks this table
|
||||
when a symbol isn't found in the lexical environment. *)
|
||||
|
||||
open Sx_types
|
||||
|
||||
let primitives : (string, value list -> value) Hashtbl.t = Hashtbl.create 128
|
||||
|
||||
let register name fn = Hashtbl.replace primitives name fn
|
||||
|
||||
let is_primitive name = Hashtbl.mem primitives name
|
||||
|
||||
let get_primitive name =
|
||||
match Hashtbl.find_opt primitives name with
|
||||
| Some fn -> NativeFn (name, fn)
|
||||
| None -> raise (Eval_error ("Unknown primitive: " ^ name))
|
||||
|
||||
(* --- Helpers --- *)
|
||||
|
||||
let as_number = function
|
||||
| Number n -> n
|
||||
| Bool true -> 1.0
|
||||
| Bool false -> 0.0
|
||||
| Nil -> 0.0
|
||||
| String s -> (match float_of_string_opt s with Some n -> n | None -> Float.nan)
|
||||
| v -> raise (Eval_error ("Expected number, got " ^ type_of v))
|
||||
|
||||
let as_string = function
|
||||
| String s -> s
|
||||
| v -> raise (Eval_error ("Expected string, got " ^ type_of v))
|
||||
|
||||
let as_list = function
|
||||
| List l -> l
|
||||
| ListRef r -> !r
|
||||
| Nil -> []
|
||||
| v -> raise (Eval_error ("Expected list, got " ^ type_of v))
|
||||
|
||||
let as_bool = function
|
||||
| Bool b -> b
|
||||
| v -> sx_truthy v
|
||||
|
||||
let to_string = function
|
||||
| String s -> s
|
||||
| Number n ->
|
||||
if Float.is_integer n then string_of_int (int_of_float n)
|
||||
else Printf.sprintf "%g" n
|
||||
| Bool true -> "true"
|
||||
| Bool false -> "false"
|
||||
| Nil -> ""
|
||||
| Symbol s -> s
|
||||
| Keyword k -> k
|
||||
| v -> inspect v
|
||||
|
||||
let () =
|
||||
(* === Arithmetic === *)
|
||||
register "+" (fun args ->
|
||||
Number (List.fold_left (fun acc a -> acc +. as_number a) 0.0 args));
|
||||
register "-" (fun args ->
|
||||
match args with
|
||||
| [] -> Number 0.0
|
||||
| [a] -> Number (-. (as_number a))
|
||||
| a :: rest -> Number (List.fold_left (fun acc x -> acc -. as_number x) (as_number a) rest));
|
||||
register "*" (fun args ->
|
||||
Number (List.fold_left (fun acc a -> acc *. as_number a) 1.0 args));
|
||||
register "/" (fun args ->
|
||||
match args with
|
||||
| [a; b] -> Number (as_number a /. as_number b)
|
||||
| _ -> raise (Eval_error "/: expected 2 args"));
|
||||
register "mod" (fun args ->
|
||||
match args with
|
||||
| [a; b] -> Number (Float.rem (as_number a) (as_number b))
|
||||
| _ -> raise (Eval_error "mod: expected 2 args"));
|
||||
register "inc" (fun args ->
|
||||
match args with [a] -> Number (as_number a +. 1.0) | _ -> raise (Eval_error "inc: 1 arg"));
|
||||
register "dec" (fun args ->
|
||||
match args with [a] -> Number (as_number a -. 1.0) | _ -> raise (Eval_error "dec: 1 arg"));
|
||||
register "abs" (fun args ->
|
||||
match args with [a] -> Number (Float.abs (as_number a)) | _ -> raise (Eval_error "abs: 1 arg"));
|
||||
register "floor" (fun args ->
|
||||
match args with [a] -> Number (Float.of_int (int_of_float (Float.round (as_number a -. 0.5))))
|
||||
| _ -> raise (Eval_error "floor: 1 arg"));
|
||||
register "ceil" (fun args ->
|
||||
match args with [a] -> Number (Float.of_int (int_of_float (Float.round (as_number a +. 0.5))))
|
||||
| _ -> raise (Eval_error "ceil: 1 arg"));
|
||||
register "round" (fun args ->
|
||||
match args with
|
||||
| [a] -> Number (Float.round (as_number a))
|
||||
| [a; b] ->
|
||||
let n = as_number a and places = int_of_float (as_number b) in
|
||||
let factor = 10.0 ** float_of_int places in
|
||||
Number (Float.round (n *. factor) /. factor)
|
||||
| _ -> raise (Eval_error "round: 1-2 args"));
|
||||
register "min" (fun args ->
|
||||
match args with
|
||||
| [] -> raise (Eval_error "min: at least 1 arg")
|
||||
| _ -> Number (List.fold_left (fun acc a -> Float.min acc (as_number a)) Float.infinity args));
|
||||
register "max" (fun args ->
|
||||
match args with
|
||||
| [] -> raise (Eval_error "max: at least 1 arg")
|
||||
| _ -> Number (List.fold_left (fun acc a -> Float.max acc (as_number a)) Float.neg_infinity args));
|
||||
register "sqrt" (fun args ->
|
||||
match args with [a] -> Number (Float.sqrt (as_number a)) | _ -> raise (Eval_error "sqrt: 1 arg"));
|
||||
register "pow" (fun args ->
|
||||
match args with [a; b] -> Number (as_number a ** as_number b)
|
||||
| _ -> raise (Eval_error "pow: 2 args"));
|
||||
register "clamp" (fun args ->
|
||||
match args with
|
||||
| [x; lo; hi] ->
|
||||
let x = as_number x and lo = as_number lo and hi = as_number hi in
|
||||
Number (Float.max lo (Float.min hi x))
|
||||
| _ -> raise (Eval_error "clamp: 3 args"));
|
||||
register "parse-int" (fun args ->
|
||||
match args with
|
||||
| [String s] -> (match int_of_string_opt s with Some n -> Number (float_of_int n) | None -> Nil)
|
||||
| [Number n] -> Number (float_of_int (int_of_float n))
|
||||
| _ -> Nil);
|
||||
register "parse-float" (fun args ->
|
||||
match args with
|
||||
| [String s] -> (match float_of_string_opt s with Some n -> Number n | None -> Nil)
|
||||
| [Number n] -> Number n
|
||||
| _ -> Nil);
|
||||
|
||||
(* === Comparison === *)
|
||||
(* Normalize ListRef to List for structural equality *)
|
||||
let rec normalize_for_eq = function
|
||||
| ListRef { contents = items } -> List (List.map normalize_for_eq items)
|
||||
| List items -> List (List.map normalize_for_eq items)
|
||||
| v -> v
|
||||
in
|
||||
register "=" (fun args ->
|
||||
match args with
|
||||
| [a; b] -> Bool (normalize_for_eq a = normalize_for_eq b)
|
||||
| _ -> raise (Eval_error "=: 2 args"));
|
||||
register "!=" (fun args ->
|
||||
match args with
|
||||
| [a; b] -> Bool (normalize_for_eq a <> normalize_for_eq b)
|
||||
| _ -> raise (Eval_error "!=: 2 args"));
|
||||
register "<" (fun args ->
|
||||
match args with
|
||||
| [String a; String b] -> Bool (a < b)
|
||||
| [a; b] -> Bool (as_number a < as_number b)
|
||||
| _ -> raise (Eval_error "<: 2 args"));
|
||||
register ">" (fun args ->
|
||||
match args with
|
||||
| [String a; String b] -> Bool (a > b)
|
||||
| [a; b] -> Bool (as_number a > as_number b)
|
||||
| _ -> raise (Eval_error ">: 2 args"));
|
||||
register "<=" (fun args ->
|
||||
match args with
|
||||
| [String a; String b] -> Bool (a <= b)
|
||||
| [a; b] -> Bool (as_number a <= as_number b)
|
||||
| _ -> raise (Eval_error "<=: 2 args"));
|
||||
register ">=" (fun args ->
|
||||
match args with
|
||||
| [String a; String b] -> Bool (a >= b)
|
||||
| [a; b] -> Bool (as_number a >= as_number b)
|
||||
| _ -> raise (Eval_error ">=: 2 args"));
|
||||
|
||||
(* === Logic === *)
|
||||
register "not" (fun args ->
|
||||
match args with [a] -> Bool (not (sx_truthy a)) | _ -> raise (Eval_error "not: 1 arg"));
|
||||
|
||||
(* === Predicates === *)
|
||||
register "nil?" (fun args ->
|
||||
match args with [a] -> Bool (is_nil a) | _ -> raise (Eval_error "nil?: 1 arg"));
|
||||
register "number?" (fun args ->
|
||||
match args with [Number _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "number?: 1 arg"));
|
||||
register "string?" (fun args ->
|
||||
match args with [String _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "string?: 1 arg"));
|
||||
register "boolean?" (fun args ->
|
||||
match args with [Bool _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "boolean?: 1 arg"));
|
||||
register "list?" (fun args ->
|
||||
match args with [List _] | [ListRef _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "list?: 1 arg"));
|
||||
register "dict?" (fun args ->
|
||||
match args with [Dict _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "dict?: 1 arg"));
|
||||
register "symbol?" (fun args ->
|
||||
match args with [Symbol _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "symbol?: 1 arg"));
|
||||
register "keyword?" (fun args ->
|
||||
match args with [Keyword _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "keyword?: 1 arg"));
|
||||
register "empty?" (fun args ->
|
||||
match args with
|
||||
| [List []] | [ListRef { contents = [] }] -> Bool true
|
||||
| [List _] | [ListRef _] -> Bool false
|
||||
| [String ""] -> Bool true | [String _] -> Bool false
|
||||
| [Dict d] -> Bool (Hashtbl.length d = 0)
|
||||
| [Nil] -> Bool true
|
||||
| [_] -> Bool false
|
||||
| _ -> raise (Eval_error "empty?: 1 arg"));
|
||||
register "odd?" (fun args ->
|
||||
match args with [a] -> Bool (int_of_float (as_number a) mod 2 <> 0) | _ -> raise (Eval_error "odd?: 1 arg"));
|
||||
register "even?" (fun args ->
|
||||
match args with [a] -> Bool (int_of_float (as_number a) mod 2 = 0) | _ -> raise (Eval_error "even?: 1 arg"));
|
||||
register "zero?" (fun args ->
|
||||
match args with [a] -> Bool (as_number a = 0.0) | _ -> raise (Eval_error "zero?: 1 arg"));
|
||||
|
||||
(* === Strings === *)
|
||||
register "str" (fun args -> String (String.concat "" (List.map to_string args)));
|
||||
register "upper" (fun args ->
|
||||
match args with [a] -> String (String.uppercase_ascii (as_string a)) | _ -> raise (Eval_error "upper: 1 arg"));
|
||||
register "upcase" (fun args ->
|
||||
match args with [a] -> String (String.uppercase_ascii (as_string a)) | _ -> raise (Eval_error "upcase: 1 arg"));
|
||||
register "lower" (fun args ->
|
||||
match args with [a] -> String (String.lowercase_ascii (as_string a)) | _ -> raise (Eval_error "lower: 1 arg"));
|
||||
register "downcase" (fun args ->
|
||||
match args with [a] -> String (String.lowercase_ascii (as_string a)) | _ -> raise (Eval_error "downcase: 1 arg"));
|
||||
register "trim" (fun args ->
|
||||
match args with [a] -> String (String.trim (as_string a)) | _ -> raise (Eval_error "trim: 1 arg"));
|
||||
register "string-length" (fun args ->
|
||||
match args with [a] -> Number (float_of_int (String.length (as_string a)))
|
||||
| _ -> raise (Eval_error "string-length: 1 arg"));
|
||||
register "string-contains?" (fun args ->
|
||||
match args with
|
||||
| [String haystack; String needle] ->
|
||||
let rec find i =
|
||||
if i + String.length needle > String.length haystack then false
|
||||
else if String.sub haystack i (String.length needle) = needle then true
|
||||
else find (i + 1)
|
||||
in Bool (find 0)
|
||||
| _ -> raise (Eval_error "string-contains?: 2 string args"));
|
||||
register "starts-with?" (fun args ->
|
||||
match args with
|
||||
| [String s; String prefix] ->
|
||||
Bool (String.length s >= String.length prefix &&
|
||||
String.sub s 0 (String.length prefix) = prefix)
|
||||
| _ -> raise (Eval_error "starts-with?: 2 string args"));
|
||||
register "ends-with?" (fun args ->
|
||||
match args with
|
||||
| [String s; String suffix] ->
|
||||
let sl = String.length s and xl = String.length suffix in
|
||||
Bool (sl >= xl && String.sub s (sl - xl) xl = suffix)
|
||||
| _ -> raise (Eval_error "ends-with?: 2 string args"));
|
||||
register "index-of" (fun args ->
|
||||
match args with
|
||||
| [String haystack; String needle] ->
|
||||
let nl = String.length needle and hl = String.length haystack in
|
||||
let rec find i =
|
||||
if i + nl > hl then Number (-1.0)
|
||||
else if String.sub haystack i nl = needle then Number (float_of_int i)
|
||||
else find (i + 1)
|
||||
in find 0
|
||||
| _ -> raise (Eval_error "index-of: 2 string args"));
|
||||
register "substring" (fun args ->
|
||||
match args with
|
||||
| [String s; Number start; Number end_] ->
|
||||
let i = int_of_float start and j = int_of_float end_ in
|
||||
let len = String.length s in
|
||||
let i = max 0 (min i len) and j = max 0 (min j len) in
|
||||
String (String.sub s i (max 0 (j - i)))
|
||||
| _ -> raise (Eval_error "substring: 3 args"));
|
||||
register "substr" (fun args ->
|
||||
match args with
|
||||
| [String s; Number start; Number len] ->
|
||||
let i = int_of_float start and n = int_of_float len in
|
||||
let sl = String.length s in
|
||||
let i = max 0 (min i sl) in
|
||||
let n = max 0 (min n (sl - i)) in
|
||||
String (String.sub s i n)
|
||||
| [String s; Number start] ->
|
||||
let i = int_of_float start in
|
||||
let sl = String.length s in
|
||||
let i = max 0 (min i sl) in
|
||||
String (String.sub s i (sl - i))
|
||||
| _ -> raise (Eval_error "substr: 2-3 args"));
|
||||
register "split" (fun args ->
|
||||
match args with
|
||||
| [String s; String sep] ->
|
||||
List (List.map (fun p -> String p) (String.split_on_char sep.[0] s))
|
||||
| _ -> raise (Eval_error "split: 2 args"));
|
||||
register "join" (fun args ->
|
||||
match args with
|
||||
| [String sep; (List items | ListRef { contents = items })] ->
|
||||
String (String.concat sep (List.map to_string items))
|
||||
| _ -> raise (Eval_error "join: 2 args"));
|
||||
register "replace" (fun args ->
|
||||
match args with
|
||||
| [String s; String old_s; String new_s] ->
|
||||
let ol = String.length old_s in
|
||||
if ol = 0 then String s
|
||||
else begin
|
||||
let buf = Buffer.create (String.length s) in
|
||||
let rec go i =
|
||||
if i >= String.length s then ()
|
||||
else if i + ol <= String.length s && String.sub s i ol = old_s then begin
|
||||
Buffer.add_string buf new_s;
|
||||
go (i + ol)
|
||||
end else begin
|
||||
Buffer.add_char buf s.[i];
|
||||
go (i + 1)
|
||||
end
|
||||
in go 0;
|
||||
String (Buffer.contents buf)
|
||||
end
|
||||
| _ -> raise (Eval_error "replace: 3 string args"));
|
||||
register "char-from-code" (fun args ->
|
||||
match args with
|
||||
| [Number n] ->
|
||||
let buf = Buffer.create 4 in
|
||||
Buffer.add_utf_8_uchar buf (Uchar.of_int (int_of_float n));
|
||||
String (Buffer.contents buf)
|
||||
| _ -> raise (Eval_error "char-from-code: 1 arg"));
|
||||
|
||||
(* === Collections === *)
|
||||
register "list" (fun args -> ListRef (ref args));
|
||||
register "len" (fun args ->
|
||||
match args with
|
||||
| [List l] | [ListRef { contents = l }] -> Number (float_of_int (List.length l))
|
||||
| [String s] -> Number (float_of_int (String.length s))
|
||||
| [Dict d] -> Number (float_of_int (Hashtbl.length d))
|
||||
| [Nil] -> Number 0.0
|
||||
| _ -> raise (Eval_error "len: 1 arg"));
|
||||
register "first" (fun args ->
|
||||
match args with
|
||||
| [List (x :: _)] | [ListRef { contents = x :: _ }] -> x
|
||||
| [List []] | [ListRef { contents = [] }] -> Nil | [Nil] -> Nil
|
||||
| _ -> raise (Eval_error "first: 1 list arg"));
|
||||
register "rest" (fun args ->
|
||||
match args with
|
||||
| [List (_ :: xs)] | [ListRef { contents = _ :: xs }] -> List xs
|
||||
| [List []] | [ListRef { contents = [] }] -> List [] | [Nil] -> List []
|
||||
| _ -> raise (Eval_error "rest: 1 list arg"));
|
||||
register "last" (fun args ->
|
||||
match args with
|
||||
| [List l] | [ListRef { contents = l }] ->
|
||||
(match List.rev l with x :: _ -> x | [] -> Nil)
|
||||
| _ -> raise (Eval_error "last: 1 list arg"));
|
||||
register "nth" (fun args ->
|
||||
match args with
|
||||
| [List l; Number n] | [ListRef { contents = l }; Number n] ->
|
||||
(try List.nth l (int_of_float n) with _ -> Nil)
|
||||
| _ -> raise (Eval_error "nth: list and number"));
|
||||
register "cons" (fun args ->
|
||||
match args with
|
||||
| [x; List l] | [x; ListRef { contents = l }] -> List (x :: l)
|
||||
| [x; Nil] -> List [x]
|
||||
| _ -> raise (Eval_error "cons: value and list"));
|
||||
register "append" (fun args ->
|
||||
let all = List.concat_map (fun a -> as_list a) args in
|
||||
List all);
|
||||
register "reverse" (fun args ->
|
||||
match args with
|
||||
| [List l] | [ListRef { contents = l }] -> List (List.rev l)
|
||||
| _ -> raise (Eval_error "reverse: 1 list"));
|
||||
register "flatten" (fun args ->
|
||||
let rec flat = function
|
||||
| List items | ListRef { contents = items } -> List.concat_map flat items
|
||||
| x -> [x]
|
||||
in
|
||||
match args with
|
||||
| [List l] | [ListRef { contents = l }] -> List (List.concat_map flat l)
|
||||
| _ -> raise (Eval_error "flatten: 1 list"));
|
||||
register "concat" (fun args -> List (List.concat_map as_list args));
|
||||
register "contains?" (fun args ->
|
||||
match args with
|
||||
| [List l; item] | [ListRef { contents = l }; item] -> Bool (List.mem item l)
|
||||
| [String s; String sub] ->
|
||||
let rec find i =
|
||||
if i + String.length sub > String.length s then false
|
||||
else if String.sub s i (String.length sub) = sub then true
|
||||
else find (i + 1)
|
||||
in Bool (find 0)
|
||||
| _ -> raise (Eval_error "contains?: 2 args"));
|
||||
register "range" (fun args ->
|
||||
match args with
|
||||
| [Number stop] ->
|
||||
let n = int_of_float stop in
|
||||
List (List.init (max 0 n) (fun i -> Number (float_of_int i)))
|
||||
| [Number start; Number stop] ->
|
||||
let s = int_of_float start and e = int_of_float stop in
|
||||
let len = max 0 (e - s) in
|
||||
List (List.init len (fun i -> Number (float_of_int (s + i))))
|
||||
| [Number start; Number stop; Number step] ->
|
||||
let s = start and e = stop and st = step in
|
||||
if st = 0.0 then List []
|
||||
else
|
||||
let items = ref [] in
|
||||
let i = ref s in
|
||||
if st > 0.0 then
|
||||
(while !i < e do items := Number !i :: !items; i := !i +. st done)
|
||||
else
|
||||
(while !i > e do items := Number !i :: !items; i := !i +. st done);
|
||||
List (List.rev !items)
|
||||
| _ -> raise (Eval_error "range: 1-3 args"));
|
||||
register "slice" (fun args ->
|
||||
match args with
|
||||
| [(List l | ListRef { contents = l }); Number start] ->
|
||||
let i = max 0 (int_of_float start) in
|
||||
let rec drop n = function _ :: xs when n > 0 -> drop (n-1) xs | l -> l in
|
||||
List (drop i l)
|
||||
| [(List l | ListRef { contents = l }); Number start; Number end_] ->
|
||||
let i = max 0 (int_of_float start) and j = int_of_float end_ in
|
||||
let len = List.length l in
|
||||
let j = min j len in
|
||||
let rec take_range idx = function
|
||||
| [] -> []
|
||||
| x :: xs ->
|
||||
if idx >= j then []
|
||||
else if idx >= i then x :: take_range (idx+1) xs
|
||||
else take_range (idx+1) xs
|
||||
in List (take_range 0 l)
|
||||
| [String s; Number start] ->
|
||||
let i = max 0 (int_of_float start) in
|
||||
String (String.sub s i (max 0 (String.length s - i)))
|
||||
| [String s; Number start; Number end_] ->
|
||||
let i = max 0 (int_of_float start) and j = int_of_float end_ in
|
||||
let sl = String.length s in
|
||||
let j = min j sl in
|
||||
String (String.sub s i (max 0 (j - i)))
|
||||
| _ -> raise (Eval_error "slice: 2-3 args"));
|
||||
register "sort" (fun args ->
|
||||
match args with
|
||||
| [List l] | [ListRef { contents = l }] -> List (List.sort compare l)
|
||||
| _ -> raise (Eval_error "sort: 1 list"));
|
||||
register "zip" (fun args ->
|
||||
match args with
|
||||
| [a; b] ->
|
||||
let la = as_list a and lb = as_list b in
|
||||
let rec go l1 l2 acc = match l1, l2 with
|
||||
| x :: xs, y :: ys -> go xs ys (List [x; y] :: acc)
|
||||
| _ -> List.rev acc
|
||||
in List (go la lb [])
|
||||
| _ -> raise (Eval_error "zip: 2 lists"));
|
||||
register "zip-pairs" (fun args ->
|
||||
match args with
|
||||
| [v] ->
|
||||
let l = as_list v in
|
||||
let rec go = function
|
||||
| a :: b :: rest -> List [a; b] :: go rest
|
||||
| _ -> []
|
||||
in List (go l)
|
||||
| _ -> raise (Eval_error "zip-pairs: 1 list"));
|
||||
register "take" (fun args ->
|
||||
match args with
|
||||
| [(List l | ListRef { contents = l }); Number n] ->
|
||||
let rec take_n i = function
|
||||
| x :: xs when i > 0 -> x :: take_n (i-1) xs
|
||||
| _ -> []
|
||||
in List (take_n (int_of_float n) l)
|
||||
| _ -> raise (Eval_error "take: list and number"));
|
||||
register "drop" (fun args ->
|
||||
match args with
|
||||
| [(List l | ListRef { contents = l }); Number n] ->
|
||||
let rec drop_n i = function
|
||||
| _ :: xs when i > 0 -> drop_n (i-1) xs
|
||||
| l -> l
|
||||
in List (drop_n (int_of_float n) l)
|
||||
| _ -> raise (Eval_error "drop: list and number"));
|
||||
register "chunk-every" (fun args ->
|
||||
match args with
|
||||
| [(List l | ListRef { contents = l }); Number n] ->
|
||||
let size = int_of_float n in
|
||||
let rec go = function
|
||||
| [] -> []
|
||||
| l ->
|
||||
let rec take_n i = function
|
||||
| x :: xs when i > 0 -> x :: take_n (i-1) xs
|
||||
| _ -> []
|
||||
in
|
||||
let rec drop_n i = function
|
||||
| _ :: xs when i > 0 -> drop_n (i-1) xs
|
||||
| l -> l
|
||||
in
|
||||
List (take_n size l) :: go (drop_n size l)
|
||||
in List (go l)
|
||||
| _ -> raise (Eval_error "chunk-every: list and number"));
|
||||
register "unique" (fun args ->
|
||||
match args with
|
||||
| [(List l | ListRef { contents = l })] ->
|
||||
let seen = Hashtbl.create 16 in
|
||||
let result = List.filter (fun x ->
|
||||
let key = inspect x in
|
||||
if Hashtbl.mem seen key then false
|
||||
else (Hashtbl.replace seen key true; true)
|
||||
) l in
|
||||
List result
|
||||
| _ -> raise (Eval_error "unique: 1 list"));
|
||||
|
||||
(* === Dict === *)
|
||||
register "dict" (fun args ->
|
||||
let d = make_dict () in
|
||||
let rec go = function
|
||||
| [] -> Dict d
|
||||
| Keyword k :: v :: rest -> dict_set d k v; go rest
|
||||
| String k :: v :: rest -> dict_set d k v; go rest
|
||||
| _ -> raise (Eval_error "dict: pairs of key value")
|
||||
in go args);
|
||||
register "get" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k] -> dict_get d k
|
||||
| [Dict d; Keyword k] -> dict_get d k
|
||||
| [List l; Number n] | [ListRef { contents = l }; Number n] ->
|
||||
(try List.nth l (int_of_float n) with _ -> Nil)
|
||||
| _ -> raise (Eval_error "get: dict+key or list+index"));
|
||||
register "has-key?" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k] -> Bool (dict_has d k)
|
||||
| [Dict d; Keyword k] -> Bool (dict_has d k)
|
||||
| _ -> raise (Eval_error "has-key?: dict and key"));
|
||||
register "assoc" (fun args ->
|
||||
match args with
|
||||
| Dict d :: rest ->
|
||||
let d2 = Hashtbl.copy d in
|
||||
let rec go = function
|
||||
| [] -> Dict d2
|
||||
| String k :: v :: rest -> Hashtbl.replace d2 k v; go rest
|
||||
| Keyword k :: v :: rest -> Hashtbl.replace d2 k v; go rest
|
||||
| _ -> raise (Eval_error "assoc: pairs")
|
||||
in go rest
|
||||
| _ -> raise (Eval_error "assoc: dict + pairs"));
|
||||
register "dissoc" (fun args ->
|
||||
match args with
|
||||
| Dict d :: keys ->
|
||||
let d2 = Hashtbl.copy d in
|
||||
List.iter (fun k -> Hashtbl.remove d2 (to_string k)) keys;
|
||||
Dict d2
|
||||
| _ -> raise (Eval_error "dissoc: dict + keys"));
|
||||
register "merge" (fun args ->
|
||||
let d = make_dict () in
|
||||
List.iter (function
|
||||
| Dict src -> Hashtbl.iter (fun k v -> Hashtbl.replace d k v) src
|
||||
| _ -> raise (Eval_error "merge: all args must be dicts")
|
||||
) args;
|
||||
Dict d);
|
||||
register "keys" (fun args ->
|
||||
match args with [Dict d] -> List (dict_keys d) | _ -> raise (Eval_error "keys: 1 dict"));
|
||||
register "vals" (fun args ->
|
||||
match args with [Dict d] -> List (dict_vals d) | _ -> raise (Eval_error "vals: 1 dict"));
|
||||
register "dict-set!" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k; v] -> dict_set d k v; v
|
||||
| [Dict d; Keyword k; v] -> dict_set d k v; v
|
||||
| _ -> raise (Eval_error "dict-set!: dict key val"));
|
||||
register "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: dict and key"));
|
||||
register "dict-has?" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k] -> Bool (dict_has d k)
|
||||
| _ -> raise (Eval_error "dict-has?: dict and key"));
|
||||
register "dict-delete!" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k] -> dict_delete d k; Nil
|
||||
| _ -> raise (Eval_error "dict-delete!: dict and key"));
|
||||
|
||||
(* === Misc === *)
|
||||
register "type-of" (fun args ->
|
||||
match args with [a] -> String (type_of a) | _ -> raise (Eval_error "type-of: 1 arg"));
|
||||
register "inspect" (fun args ->
|
||||
match args with [a] -> String (inspect a) | _ -> raise (Eval_error "inspect: 1 arg"));
|
||||
register "error" (fun args ->
|
||||
match args with [String msg] -> raise (Eval_error msg)
|
||||
| [a] -> raise (Eval_error (to_string a))
|
||||
| _ -> raise (Eval_error "error: 1 arg"));
|
||||
register "apply" (fun args ->
|
||||
match args with
|
||||
| [NativeFn (_, f); List a] -> f a
|
||||
| _ -> raise (Eval_error "apply: function and list"));
|
||||
register "identical?" (fun args ->
|
||||
match args with [a; b] -> Bool (a == b) | _ -> raise (Eval_error "identical?: 2 args"));
|
||||
register "make-spread" (fun args ->
|
||||
match args with
|
||||
| [Dict d] ->
|
||||
let pairs = Hashtbl.fold (fun k v acc -> (k, v) :: acc) d [] in
|
||||
Spread pairs
|
||||
| _ -> raise (Eval_error "make-spread: 1 dict"));
|
||||
register "spread?" (fun args ->
|
||||
match args with [Spread _] -> Bool true | [_] -> Bool false
|
||||
| _ -> raise (Eval_error "spread?: 1 arg"));
|
||||
register "spread-attrs" (fun args ->
|
||||
match args with
|
||||
| [Spread pairs] ->
|
||||
let d = make_dict () in
|
||||
List.iter (fun (k, v) -> dict_set d k v) pairs;
|
||||
Dict d
|
||||
| _ -> raise (Eval_error "spread-attrs: 1 spread"));
|
||||
()
|
||||
573
hosts/ocaml/lib/sx_ref.ml
Normal file
573
hosts/ocaml/lib/sx_ref.ml
Normal file
File diff suppressed because one or more lines are too long
435
hosts/ocaml/lib/sx_render.ml
Normal file
435
hosts/ocaml/lib/sx_render.ml
Normal file
@@ -0,0 +1,435 @@
|
||||
(** HTML renderer for SX values.
|
||||
|
||||
Extracted from run_tests.ml — renders an SX expression tree to an
|
||||
HTML string, expanding components and macros along the way.
|
||||
|
||||
Depends on [Sx_ref.eval_expr] for evaluating sub-expressions
|
||||
during rendering (keyword arg values, conditionals, etc.). *)
|
||||
|
||||
open Sx_types
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Tag / attribute registries *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let html_tags = [
|
||||
"html"; "head"; "body"; "title"; "meta"; "link"; "script"; "style"; "noscript";
|
||||
"header"; "nav"; "main"; "section"; "article"; "aside"; "footer";
|
||||
"h1"; "h2"; "h3"; "h4"; "h5"; "h6"; "hgroup";
|
||||
"div"; "p"; "blockquote"; "pre"; "figure"; "figcaption"; "address"; "hr";
|
||||
"ul"; "ol"; "li"; "dl"; "dt"; "dd"; "menu";
|
||||
"a"; "span"; "em"; "strong"; "small"; "b"; "i"; "u"; "s"; "sub"; "sup";
|
||||
"mark"; "del"; "ins"; "q"; "cite"; "dfn"; "abbr"; "code"; "var"; "samp";
|
||||
"kbd"; "data"; "time"; "ruby"; "rt"; "rp"; "bdi"; "bdo"; "wbr"; "br";
|
||||
"table"; "thead"; "tbody"; "tfoot"; "tr"; "th"; "td"; "caption"; "colgroup"; "col";
|
||||
"form"; "input"; "textarea"; "select"; "option"; "optgroup"; "button"; "label";
|
||||
"fieldset"; "legend"; "datalist"; "output"; "progress"; "meter";
|
||||
"details"; "summary"; "dialog";
|
||||
"img"; "video"; "audio"; "source"; "picture"; "canvas"; "iframe"; "embed"; "object"; "param";
|
||||
"svg"; "path"; "circle"; "rect"; "line"; "polyline"; "polygon"; "ellipse";
|
||||
"g"; "defs"; "use"; "text"; "tspan"; "clipPath"; "mask"; "pattern";
|
||||
"linearGradient"; "radialGradient"; "stop"; "filter"; "feBlend"; "feFlood";
|
||||
"feGaussianBlur"; "feOffset"; "feMerge"; "feMergeNode"; "feComposite";
|
||||
"template"; "slot";
|
||||
]
|
||||
|
||||
let void_elements = [
|
||||
"area"; "base"; "br"; "col"; "embed"; "hr"; "img"; "input";
|
||||
"link"; "meta"; "param"; "source"; "track"; "wbr"
|
||||
]
|
||||
|
||||
let boolean_attrs = [
|
||||
"async"; "autofocus"; "autoplay"; "checked"; "controls"; "default";
|
||||
"defer"; "disabled"; "formnovalidate"; "hidden"; "inert"; "ismap";
|
||||
"loop"; "multiple"; "muted"; "nomodule"; "novalidate"; "open";
|
||||
"playsinline"; "readonly"; "required"; "reversed"; "selected"
|
||||
]
|
||||
|
||||
let is_html_tag name = List.mem name html_tags
|
||||
let is_void name = List.mem name void_elements
|
||||
let is_boolean_attr name = List.mem name boolean_attrs
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* HTML escaping *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let escape_html s =
|
||||
let buf = Buffer.create (String.length s) in
|
||||
String.iter (function
|
||||
| '&' -> Buffer.add_string buf "&"
|
||||
| '<' -> Buffer.add_string buf "<"
|
||||
| '>' -> Buffer.add_string buf ">"
|
||||
| '"' -> Buffer.add_string buf """
|
||||
| c -> Buffer.add_char buf c) s;
|
||||
Buffer.contents buf
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Attribute rendering *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let render_attrs attrs =
|
||||
let buf = Buffer.create 64 in
|
||||
Hashtbl.iter (fun k v ->
|
||||
if is_boolean_attr k then begin
|
||||
if sx_truthy v then begin
|
||||
Buffer.add_char buf ' ';
|
||||
Buffer.add_string buf k
|
||||
end
|
||||
end else if not (is_nil v) then begin
|
||||
Buffer.add_char buf ' ';
|
||||
Buffer.add_string buf k;
|
||||
Buffer.add_string buf "=\"";
|
||||
Buffer.add_string buf (escape_html (value_to_string v));
|
||||
Buffer.add_char buf '"'
|
||||
end) attrs;
|
||||
Buffer.contents buf
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* HTML renderer *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
(* Forward ref — resolved at setup time *)
|
||||
let render_to_html_ref : (value -> env -> string) ref =
|
||||
ref (fun _expr _env -> "")
|
||||
|
||||
let render_to_html expr env = !render_to_html_ref expr env
|
||||
|
||||
let render_children children env =
|
||||
String.concat "" (List.map (fun c -> render_to_html c env) children)
|
||||
|
||||
(** Parse keyword attrs and positional children from an element call's args.
|
||||
Attrs are evaluated; children are returned UNEVALUATED for render dispatch. *)
|
||||
let parse_element_args args env =
|
||||
let attrs = Hashtbl.create 8 in
|
||||
let children = ref [] in
|
||||
let skip = ref false in
|
||||
let len = List.length args in
|
||||
List.iteri (fun idx arg ->
|
||||
if !skip then skip := false
|
||||
else match arg with
|
||||
| Keyword k when idx + 1 < len ->
|
||||
let v = Sx_ref.eval_expr (List.nth args (idx + 1)) (Env env) in
|
||||
Hashtbl.replace attrs k v;
|
||||
skip := true
|
||||
| Spread pairs ->
|
||||
List.iter (fun (k, v) -> Hashtbl.replace attrs k v) pairs
|
||||
| _ ->
|
||||
children := arg :: !children
|
||||
) args;
|
||||
(attrs, List.rev !children)
|
||||
|
||||
let render_html_element tag args env =
|
||||
let (attrs, children) = parse_element_args args env in
|
||||
let attr_str = render_attrs attrs in
|
||||
if is_void tag then
|
||||
"<" ^ tag ^ attr_str ^ " />"
|
||||
else
|
||||
let content = String.concat ""
|
||||
(List.map (fun c -> render_to_html c env) children) in
|
||||
"<" ^ tag ^ attr_str ^ ">" ^ content ^ "</" ^ tag ^ ">"
|
||||
|
||||
let render_component comp args env =
|
||||
match comp with
|
||||
| Component c ->
|
||||
let kwargs = Hashtbl.create 8 in
|
||||
let children_exprs = ref [] in
|
||||
let skip = ref false in
|
||||
let len = List.length args in
|
||||
List.iteri (fun idx arg ->
|
||||
if !skip then skip := false
|
||||
else match arg with
|
||||
| Keyword k when idx + 1 < len ->
|
||||
let v = Sx_ref.eval_expr (List.nth args (idx + 1)) (Env env) in
|
||||
Hashtbl.replace kwargs k v;
|
||||
skip := true
|
||||
| _ ->
|
||||
children_exprs := arg :: !children_exprs
|
||||
) args;
|
||||
let children = List.rev !children_exprs in
|
||||
let local = env_merge c.c_closure env in
|
||||
List.iter (fun p ->
|
||||
let v = match Hashtbl.find_opt kwargs p with Some v -> v | None -> Nil in
|
||||
ignore (env_bind local p v)
|
||||
) c.c_params;
|
||||
if c.c_has_children then begin
|
||||
let rendered_children = String.concat ""
|
||||
(List.map (fun c -> render_to_html c env) children) in
|
||||
ignore (env_bind local "children" (RawHTML rendered_children))
|
||||
end;
|
||||
render_to_html c.c_body local
|
||||
| _ -> ""
|
||||
|
||||
let expand_macro (m : macro) args _env =
|
||||
let local = env_extend m.m_closure in
|
||||
let params = m.m_params in
|
||||
let rec bind_params ps as' =
|
||||
match ps, as' with
|
||||
| [], rest ->
|
||||
(match m.m_rest_param with
|
||||
| Some rp -> ignore (env_bind local rp (List rest))
|
||||
| None -> ())
|
||||
| p :: ps_rest, a :: as_rest ->
|
||||
ignore (env_bind local p a);
|
||||
bind_params ps_rest as_rest
|
||||
| _ :: _, [] ->
|
||||
List.iter (fun p -> ignore (env_bind local p Nil)) (List.rev ps)
|
||||
in
|
||||
bind_params params args;
|
||||
Sx_ref.eval_expr m.m_body (Env local)
|
||||
|
||||
let rec do_render_to_html (expr : value) (env : env) : string =
|
||||
match expr with
|
||||
| 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_html s
|
||||
| Keyword k -> escape_html k
|
||||
| RawHTML s -> s
|
||||
| Symbol s ->
|
||||
let v = Sx_ref.eval_expr (Symbol s) (Env env) in
|
||||
do_render_to_html v env
|
||||
| List [] | ListRef { contents = [] } -> ""
|
||||
| List (head :: args) | ListRef { contents = head :: args } ->
|
||||
render_list_to_html head args env
|
||||
| _ ->
|
||||
let v = Sx_ref.eval_expr expr (Env env) in
|
||||
do_render_to_html v env
|
||||
|
||||
and render_list_to_html head args env =
|
||||
match head with
|
||||
| Symbol "<>" ->
|
||||
render_children args env
|
||||
| Symbol tag when is_html_tag tag ->
|
||||
render_html_element tag args env
|
||||
| Symbol "if" ->
|
||||
let cond_val = Sx_ref.eval_expr (List.hd args) (Env env) in
|
||||
if sx_truthy cond_val then
|
||||
(if List.length args > 1 then do_render_to_html (List.nth args 1) env else "")
|
||||
else
|
||||
(if List.length args > 2 then do_render_to_html (List.nth args 2) env else "")
|
||||
| Symbol "when" ->
|
||||
let cond_val = Sx_ref.eval_expr (List.hd args) (Env env) in
|
||||
if sx_truthy cond_val then
|
||||
String.concat "" (List.map (fun e -> do_render_to_html e env) (List.tl args))
|
||||
else ""
|
||||
| Symbol "cond" ->
|
||||
render_cond args env
|
||||
| Symbol "case" ->
|
||||
let v = Sx_ref.eval_expr (List (head :: args)) (Env env) in
|
||||
do_render_to_html v env
|
||||
| Symbol ("let" | "let*") ->
|
||||
render_let args env
|
||||
| Symbol ("begin" | "do") ->
|
||||
let rec go = function
|
||||
| [] -> ""
|
||||
| [last] -> do_render_to_html last env
|
||||
| e :: rest ->
|
||||
ignore (Sx_ref.eval_expr e (Env env));
|
||||
go rest
|
||||
in go args
|
||||
| Symbol ("define" | "defcomp" | "defmacro" | "defisland") ->
|
||||
ignore (Sx_ref.eval_expr (List (head :: args)) (Env env));
|
||||
""
|
||||
| Symbol "map" ->
|
||||
render_map args env false
|
||||
| Symbol "map-indexed" ->
|
||||
render_map args env true
|
||||
| Symbol "filter" ->
|
||||
let v = Sx_ref.eval_expr (List (head :: args)) (Env env) in
|
||||
do_render_to_html v env
|
||||
| Symbol "for-each" ->
|
||||
render_for_each args env
|
||||
| Symbol name ->
|
||||
(try
|
||||
let v = env_get env name in
|
||||
(match v with
|
||||
| Component _ -> render_component v args env
|
||||
| Macro m ->
|
||||
let expanded = expand_macro m args env in
|
||||
do_render_to_html expanded env
|
||||
| _ ->
|
||||
let result = Sx_ref.eval_expr (List (head :: args)) (Env env) in
|
||||
do_render_to_html result env)
|
||||
with Eval_error _ ->
|
||||
let result = Sx_ref.eval_expr (List (head :: args)) (Env env) in
|
||||
do_render_to_html result env)
|
||||
| _ ->
|
||||
let result = Sx_ref.eval_expr (List (head :: args)) (Env env) in
|
||||
do_render_to_html result env
|
||||
|
||||
and render_cond args env =
|
||||
let as_list = function List l | ListRef { contents = l } -> Some l | _ -> None in
|
||||
let is_scheme = List.for_all (fun a -> match as_list a with
|
||||
| Some items when List.length items = 2 -> true
|
||||
| _ -> false) args
|
||||
in
|
||||
if is_scheme then begin
|
||||
let rec go = function
|
||||
| [] -> ""
|
||||
| clause :: rest ->
|
||||
(match as_list clause with
|
||||
| Some [test; body] ->
|
||||
let is_else = match test with
|
||||
| Keyword "else" -> true
|
||||
| Symbol "else" | Symbol ":else" -> true
|
||||
| _ -> false
|
||||
in
|
||||
if is_else then do_render_to_html body env
|
||||
else
|
||||
let v = Sx_ref.eval_expr test (Env env) in
|
||||
if sx_truthy v then do_render_to_html body env
|
||||
else go rest
|
||||
| _ -> "")
|
||||
in go args
|
||||
end else begin
|
||||
let rec go = function
|
||||
| [] -> ""
|
||||
| [_] -> ""
|
||||
| test :: body :: rest ->
|
||||
let is_else = match test with
|
||||
| Keyword "else" -> true
|
||||
| Symbol "else" | Symbol ":else" -> true
|
||||
| _ -> false
|
||||
in
|
||||
if is_else then do_render_to_html body env
|
||||
else
|
||||
let v = Sx_ref.eval_expr test (Env env) in
|
||||
if sx_truthy v then do_render_to_html body env
|
||||
else go rest
|
||||
in go args
|
||||
end
|
||||
|
||||
and render_let args env =
|
||||
let as_list = function List l | ListRef { contents = l } -> Some l | _ -> None in
|
||||
let bindings_expr = List.hd args in
|
||||
let body = List.tl args in
|
||||
let local = env_extend env in
|
||||
let bindings = match as_list bindings_expr with Some l -> l | None -> [] in
|
||||
let is_scheme = match bindings with
|
||||
| (List _ :: _) | (ListRef _ :: _) -> true
|
||||
| _ -> false
|
||||
in
|
||||
if is_scheme then
|
||||
List.iter (fun b ->
|
||||
match as_list b with
|
||||
| Some [Symbol name; expr] | Some [String name; expr] ->
|
||||
let v = Sx_ref.eval_expr expr (Env local) in
|
||||
ignore (env_bind local name v)
|
||||
| _ -> ()
|
||||
) bindings
|
||||
else begin
|
||||
let rec go = function
|
||||
| [] -> ()
|
||||
| (Symbol name) :: expr :: rest | (String name) :: expr :: rest ->
|
||||
let v = Sx_ref.eval_expr expr (Env local) in
|
||||
ignore (env_bind local name v);
|
||||
go rest
|
||||
| _ -> ()
|
||||
in go bindings
|
||||
end;
|
||||
let rec render_body = function
|
||||
| [] -> ""
|
||||
| [last] -> do_render_to_html last local
|
||||
| e :: rest ->
|
||||
ignore (Sx_ref.eval_expr e (Env local));
|
||||
render_body rest
|
||||
in render_body body
|
||||
|
||||
and render_map args env indexed =
|
||||
let (fn_val, coll_val) = match args with
|
||||
| [a; b] ->
|
||||
let va = Sx_ref.eval_expr a (Env env) in
|
||||
let vb = Sx_ref.eval_expr b (Env env) in
|
||||
(match va, vb with
|
||||
| (Lambda _ | NativeFn _), _ -> (va, vb)
|
||||
| _, (Lambda _ | NativeFn _) -> (vb, va)
|
||||
| _ -> (va, vb))
|
||||
| _ -> (Nil, Nil)
|
||||
in
|
||||
let items = match coll_val with List l | ListRef { contents = l } -> l | _ -> [] in
|
||||
String.concat "" (List.mapi (fun i item ->
|
||||
let call_args = if indexed then [Number (float_of_int i); item] else [item] in
|
||||
match fn_val with
|
||||
| Lambda l ->
|
||||
let local = env_extend l.l_closure in
|
||||
List.iter2 (fun p a -> ignore (env_bind local p a))
|
||||
l.l_params call_args;
|
||||
do_render_to_html l.l_body local
|
||||
| _ ->
|
||||
let result = Sx_runtime.sx_call fn_val call_args in
|
||||
do_render_to_html result env
|
||||
) items)
|
||||
|
||||
and render_for_each args env =
|
||||
let (fn_val, coll_val) = match args with
|
||||
| [a; b] ->
|
||||
let va = Sx_ref.eval_expr a (Env env) in
|
||||
let vb = Sx_ref.eval_expr b (Env env) in
|
||||
(match va, vb with
|
||||
| (Lambda _ | NativeFn _), _ -> (va, vb)
|
||||
| _, (Lambda _ | NativeFn _) -> (vb, va)
|
||||
| _ -> (va, vb))
|
||||
| _ -> (Nil, Nil)
|
||||
in
|
||||
let items = match coll_val with List l | ListRef { contents = l } -> l | _ -> [] in
|
||||
String.concat "" (List.map (fun item ->
|
||||
match fn_val with
|
||||
| Lambda l ->
|
||||
let local = env_extend l.l_closure in
|
||||
List.iter2 (fun p a -> ignore (env_bind local p a))
|
||||
l.l_params [item];
|
||||
do_render_to_html l.l_body local
|
||||
| _ ->
|
||||
let result = Sx_runtime.sx_call fn_val [item] in
|
||||
do_render_to_html result env
|
||||
) items)
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Setup — bind render primitives in an env and wire up the ref *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let setup_render_env env =
|
||||
render_to_html_ref := do_render_to_html;
|
||||
|
||||
let bind name fn =
|
||||
ignore (env_bind env name (NativeFn (name, fn)))
|
||||
in
|
||||
|
||||
bind "render-html" (fun args ->
|
||||
match args with
|
||||
| [String src] ->
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let expr = match exprs with
|
||||
| [e] -> e
|
||||
| [] -> Nil
|
||||
| _ -> List (Symbol "do" :: exprs)
|
||||
in
|
||||
String (render_to_html expr env)
|
||||
| [expr] ->
|
||||
String (render_to_html expr env)
|
||||
| [expr; Env e] ->
|
||||
String (render_to_html expr e)
|
||||
| _ -> String "");
|
||||
|
||||
bind "render-to-html" (fun args ->
|
||||
match args with
|
||||
| [String src] ->
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let expr = match exprs with
|
||||
| [e] -> e
|
||||
| [] -> Nil
|
||||
| _ -> List (Symbol "do" :: exprs)
|
||||
in
|
||||
String (render_to_html expr env)
|
||||
| [expr] ->
|
||||
String (render_to_html expr env)
|
||||
| [expr; Env e] ->
|
||||
String (render_to_html expr e)
|
||||
| _ -> String "")
|
||||
356
hosts/ocaml/lib/sx_runtime.ml
Normal file
356
hosts/ocaml/lib/sx_runtime.ml
Normal file
@@ -0,0 +1,356 @@
|
||||
(** Runtime helpers for transpiled code.
|
||||
|
||||
These bridge the gap between the transpiler's output and the
|
||||
foundation types/primitives. The transpiled evaluator calls these
|
||||
functions directly. *)
|
||||
|
||||
open Sx_types
|
||||
|
||||
(** Call a registered primitive by name. *)
|
||||
let prim_call name args =
|
||||
match Hashtbl.find_opt Sx_primitives.primitives name with
|
||||
| Some f -> f args
|
||||
| None -> raise (Eval_error ("Unknown primitive: " ^ name))
|
||||
|
||||
(** Convert any SX value to an OCaml string (internal). *)
|
||||
let value_to_str = function
|
||||
| String s -> s
|
||||
| Number n ->
|
||||
if Float.is_integer n then string_of_int (int_of_float n)
|
||||
else Printf.sprintf "%g" n
|
||||
| Bool true -> "true"
|
||||
| Bool false -> "false"
|
||||
| Nil -> ""
|
||||
| Symbol s -> s
|
||||
| Keyword k -> k
|
||||
| v -> inspect v
|
||||
|
||||
(** sx_to_string returns a value (String) for transpiled code. *)
|
||||
let sx_to_string v = String (value_to_str v)
|
||||
|
||||
(** String concatenation helper — [sx_str] takes a list of values. *)
|
||||
let sx_str args =
|
||||
String.concat "" (List.map value_to_str args)
|
||||
|
||||
(** Convert a value to a list. *)
|
||||
let sx_to_list = function
|
||||
| List l -> l
|
||||
| ListRef r -> !r
|
||||
| Nil -> []
|
||||
| v -> raise (Eval_error ("Expected list, got " ^ type_of v))
|
||||
|
||||
(** Call an SX callable (lambda, native fn, continuation). *)
|
||||
let sx_call f args =
|
||||
match f with
|
||||
| NativeFn (_, fn) -> fn args
|
||||
| Lambda l ->
|
||||
let local = Sx_types.env_extend l.l_closure in
|
||||
List.iter2 (fun p a -> ignore (Sx_types.env_bind local p a)) l.l_params args;
|
||||
(* Return the body + env for the trampoline to evaluate *)
|
||||
Thunk (l.l_body, local)
|
||||
| Continuation (k, _) ->
|
||||
k (match args with x :: _ -> x | [] -> Nil)
|
||||
| _ -> raise (Eval_error ("Not callable: " ^ inspect f))
|
||||
|
||||
(** Apply a function to a list of args. *)
|
||||
let sx_apply f args_list =
|
||||
sx_call f (sx_to_list args_list)
|
||||
|
||||
(** Mutable append — add item to a list ref or accumulator.
|
||||
In transpiled code, lists that get appended to are mutable refs. *)
|
||||
let sx_append_b lst item =
|
||||
match lst with
|
||||
| List items -> List (items @ [item])
|
||||
| ListRef r -> r := !r @ [item]; lst (* mutate in place, return same ref *)
|
||||
| _ -> raise (Eval_error ("append!: expected list, got " ^ type_of lst))
|
||||
|
||||
(** Mutable dict-set — set key in dict, return value. *)
|
||||
let sx_dict_set_b d k v =
|
||||
match d, k with
|
||||
| Dict tbl, String key -> Hashtbl.replace tbl key v; v
|
||||
| Dict tbl, Keyword key -> Hashtbl.replace tbl key v; v
|
||||
| _ -> raise (Eval_error "dict-set!: expected dict and string key")
|
||||
|
||||
(** Get from dict or list. *)
|
||||
let get_val container key =
|
||||
match container, key with
|
||||
| Dict d, String k -> dict_get d k
|
||||
| Dict d, Keyword k -> dict_get d k
|
||||
| (List l | ListRef { contents = l }), Number n ->
|
||||
(try List.nth l (int_of_float n) with _ -> Nil)
|
||||
| _ -> raise (Eval_error ("get: unsupported " ^ type_of container ^ " / " ^ type_of key))
|
||||
|
||||
(** Register get as a primitive override — transpiled code calls (get d k). *)
|
||||
let () =
|
||||
Sx_primitives.register "get" (fun args ->
|
||||
match args with
|
||||
| [c; k] -> get_val c k
|
||||
| [c; k; default] ->
|
||||
(try
|
||||
let v = get_val c k in
|
||||
if v = Nil then default else v
|
||||
with _ -> default)
|
||||
| _ -> raise (Eval_error "get: 2-3 args"))
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Primitive aliases — top-level functions called by transpiled code *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
(** The transpiled evaluator calls primitives directly by their mangled
|
||||
OCaml name. These aliases delegate to the primitives table so the
|
||||
transpiled code compiles without needing [prim_call] everywhere. *)
|
||||
|
||||
let _prim name = match Hashtbl.find_opt Sx_primitives.primitives name with
|
||||
| Some f -> f | None -> (fun _ -> raise (Eval_error ("Missing prim: " ^ name)))
|
||||
|
||||
(* Collection ops *)
|
||||
let first args = _prim "first" [args]
|
||||
let rest args = _prim "rest" [args]
|
||||
let last args = _prim "last" [args]
|
||||
let nth coll i = _prim "nth" [coll; i]
|
||||
let cons x l = _prim "cons" [x; l]
|
||||
let append a b = _prim "append" [a; b]
|
||||
let reverse l = _prim "reverse" [l]
|
||||
let flatten l = _prim "flatten" [l]
|
||||
let concat a b = _prim "concat" [a; b]
|
||||
let slice a b = _prim "slice" [a; b]
|
||||
let len a = _prim "len" [a]
|
||||
let get a b = get_val a b
|
||||
let sort' a = _prim "sort" [a]
|
||||
let range' a = _prim "range" [a]
|
||||
let unique a = _prim "unique" [a]
|
||||
let zip a b = _prim "zip" [a; b]
|
||||
let zip_pairs a = _prim "zip-pairs" [a]
|
||||
let take a b = _prim "take" [a; b]
|
||||
let drop a b = _prim "drop" [a; b]
|
||||
let chunk_every a b = _prim "chunk-every" [a; b]
|
||||
|
||||
(* Predicates *)
|
||||
let empty_p a = _prim "empty?" [a]
|
||||
let nil_p a = _prim "nil?" [a]
|
||||
let number_p a = _prim "number?" [a]
|
||||
let string_p a = _prim "string?" [a]
|
||||
let boolean_p a = _prim "boolean?" [a]
|
||||
let list_p a = _prim "list?" [a]
|
||||
let dict_p a = _prim "dict?" [a]
|
||||
let symbol_p a = _prim "symbol?" [a]
|
||||
let keyword_p a = _prim "keyword?" [a]
|
||||
let contains_p a b = _prim "contains?" [a; b]
|
||||
let has_key_p a b = _prim "has-key?" [a; b]
|
||||
let starts_with_p a b = _prim "starts-with?" [a; b]
|
||||
let ends_with_p a b = _prim "ends-with?" [a; b]
|
||||
let string_contains_p a b = _prim "string-contains?" [a; b]
|
||||
let odd_p a = _prim "odd?" [a]
|
||||
let even_p a = _prim "even?" [a]
|
||||
let zero_p a = _prim "zero?" [a]
|
||||
|
||||
(* String ops *)
|
||||
let str' args = String (sx_str args)
|
||||
let upper a = _prim "upper" [a]
|
||||
let upcase a = _prim "upcase" [a]
|
||||
let lower a = _prim "lower" [a]
|
||||
let downcase a = _prim "downcase" [a]
|
||||
let trim a = _prim "trim" [a]
|
||||
let split a b = _prim "split" [a; b]
|
||||
let join a b = _prim "join" [a; b]
|
||||
let replace a b c = _prim "replace" [a; b; c]
|
||||
let index_of a b = _prim "index-of" [a; b]
|
||||
let substring a b c = _prim "substring" [a; b; c]
|
||||
let string_length a = _prim "string-length" [a]
|
||||
let char_from_code a = _prim "char-from-code" [a]
|
||||
|
||||
(* Dict ops *)
|
||||
let assoc d k v = _prim "assoc" [d; k; v]
|
||||
let dissoc d k = _prim "dissoc" [d; k]
|
||||
let merge' a b = _prim "merge" [a; b]
|
||||
let keys a = _prim "keys" [a]
|
||||
let vals a = _prim "vals" [a]
|
||||
let dict_set a b c = _prim "dict-set!" [a; b; c]
|
||||
let dict_get a b = _prim "dict-get" [a; b]
|
||||
let dict_has_p a b = _prim "dict-has?" [a; b]
|
||||
let dict_delete a b = _prim "dict-delete!" [a; b]
|
||||
|
||||
(* Math *)
|
||||
let abs' a = _prim "abs" [a]
|
||||
let sqrt' a = _prim "sqrt" [a]
|
||||
let pow' a b = _prim "pow" [a; b]
|
||||
let floor' a = _prim "floor" [a]
|
||||
let ceil' a = _prim "ceil" [a]
|
||||
let round' a = _prim "round" [a]
|
||||
let min' a b = _prim "min" [a; b]
|
||||
let max' a b = _prim "max" [a; b]
|
||||
let clamp a b c = _prim "clamp" [a; b; c]
|
||||
let parse_int a = _prim "parse-int" [a]
|
||||
let parse_float a = _prim "parse-float" [a]
|
||||
|
||||
(* Misc *)
|
||||
let error msg = raise (Eval_error (value_to_str msg))
|
||||
|
||||
(* inspect wrapper — returns String value instead of OCaml string *)
|
||||
let inspect v = String (Sx_types.inspect v)
|
||||
let apply' f args = sx_apply f args
|
||||
let identical_p a b = _prim "identical?" [a; b]
|
||||
let _is_spread_prim a = _prim "spread?" [a]
|
||||
let spread_attrs a = _prim "spread-attrs" [a]
|
||||
let make_spread a = _prim "make-spread" [a]
|
||||
|
||||
(* Scope primitives — delegate to sx_ref.py's shared scope stacks *)
|
||||
let sx_collect a b = prim_call "collect!" [a; b]
|
||||
let sx_collected a = prim_call "collected" [a]
|
||||
let sx_clear_collected a = prim_call "clear-collected!" [a]
|
||||
let sx_emit a b = prim_call "emit!" [a; b]
|
||||
let sx_emitted a = prim_call "emitted" [a]
|
||||
let sx_context a b = prim_call "context" [a; b]
|
||||
|
||||
(* Trampoline — forward-declared in sx_ref.ml, delegates to CEK eval_expr *)
|
||||
(* This is a stub; the real trampoline is wired up in sx_ref.ml after eval_expr is defined *)
|
||||
let trampoline v = v
|
||||
|
||||
(* Value-returning type predicates — the transpiled code passes these through
|
||||
sx_truthy, so they need to return Bool, not OCaml bool. *)
|
||||
(* type_of returns value, not string *)
|
||||
let type_of v = String (Sx_types.type_of v)
|
||||
|
||||
(* Env operations — accept Env-wrapped values and value keys.
|
||||
The transpiled CEK machine stores envs in dicts as Env values. *)
|
||||
let unwrap_env = function
|
||||
| Env e -> e
|
||||
| _ -> raise (Eval_error "Expected env")
|
||||
|
||||
let env_has e name = Bool (Sx_types.env_has (unwrap_env e) (value_to_str name))
|
||||
let env_get e name = Sx_types.env_get (unwrap_env e) (value_to_str name)
|
||||
let env_bind e name v = Sx_types.env_bind (unwrap_env e) (value_to_str name) v
|
||||
let env_set e name v = Sx_types.env_set (unwrap_env e) (value_to_str name) v
|
||||
|
||||
let make_env () = Env (Sx_types.make_env ())
|
||||
let env_extend e = Env (Sx_types.env_extend (unwrap_env e))
|
||||
let env_merge a b = Env (Sx_types.env_merge (unwrap_env a) (unwrap_env b))
|
||||
|
||||
(* set_lambda_name wrapper — accepts value, extracts string *)
|
||||
let set_lambda_name l n = Sx_types.set_lambda_name l (value_to_str n)
|
||||
|
||||
let is_nil v = Bool (Sx_types.is_nil v)
|
||||
let is_thunk v = Bool (Sx_types.is_thunk v)
|
||||
let is_lambda v = Bool (Sx_types.is_lambda v)
|
||||
let is_component v = Bool (Sx_types.is_component v)
|
||||
let is_island v = Bool (Sx_types.is_island v)
|
||||
let is_macro v = Bool (Sx_types.is_macro v)
|
||||
let is_signal v = Bool (Sx_types.is_signal v)
|
||||
let is_callable v = Bool (Sx_types.is_callable v)
|
||||
let is_identical a b = Bool (a == b)
|
||||
let is_primitive name = Bool (Sx_primitives.is_primitive (value_to_str name))
|
||||
let get_primitive name = Sx_primitives.get_primitive (value_to_str name)
|
||||
let is_spread v = match v with Spread _ -> Bool true | _ -> Bool false
|
||||
|
||||
(* Stubs for functions defined in sx_ref.ml — resolved at link time *)
|
||||
(* These are forward-declared here; sx_ref.ml defines the actual implementations *)
|
||||
|
||||
(* strip-prefix *)
|
||||
(* Stubs for evaluator functions — defined in sx_ref.ml but
|
||||
sometimes referenced before their definition via forward calls.
|
||||
These get overridden by the actual transpiled definitions. *)
|
||||
|
||||
let map_indexed fn coll =
|
||||
List (List.mapi (fun i x -> sx_call fn [Number (float_of_int i); x]) (sx_to_list coll))
|
||||
|
||||
let map_dict fn d =
|
||||
match d with
|
||||
| Dict tbl ->
|
||||
let result = Hashtbl.create (Hashtbl.length tbl) in
|
||||
Hashtbl.iter (fun k v -> Hashtbl.replace result k (sx_call fn [String k; v])) tbl;
|
||||
Dict result
|
||||
| _ -> raise (Eval_error "map-dict: expected dict")
|
||||
|
||||
let for_each fn coll =
|
||||
List.iter (fun x -> ignore (sx_call fn [x])) (sx_to_list coll);
|
||||
Nil
|
||||
|
||||
let for_each_indexed fn coll =
|
||||
List.iteri (fun i x -> ignore (sx_call fn [Number (float_of_int i); x])) (sx_to_list coll);
|
||||
Nil
|
||||
|
||||
(* Continuation support *)
|
||||
let continuation_p v = match v with Continuation (_, _) -> Bool true | _ -> Bool false
|
||||
|
||||
let make_cek_continuation captured rest_kont =
|
||||
let data = Hashtbl.create 2 in
|
||||
Hashtbl.replace data "captured" captured;
|
||||
Hashtbl.replace data "rest-kont" rest_kont;
|
||||
Continuation ((fun v -> v), Some data)
|
||||
|
||||
let continuation_data v = match v with
|
||||
| Continuation (_, Some d) -> Dict d
|
||||
| Continuation (_, None) -> Dict (Hashtbl.create 0)
|
||||
| _ -> raise (Eval_error "not a continuation")
|
||||
|
||||
(* Dynamic wind — simplified for OCaml (no async) *)
|
||||
let dynamic_wind_call before body after _env =
|
||||
ignore (sx_call before []);
|
||||
let result = sx_call body [] in
|
||||
ignore (sx_call after []);
|
||||
result
|
||||
|
||||
(* Scope stack stubs — delegated to primitives when available *)
|
||||
let scope_push name value = prim_call "collect!" [name; value]
|
||||
let scope_pop _name = Nil
|
||||
let provide_push name value = ignore name; ignore value; Nil
|
||||
let provide_pop _name = Nil
|
||||
|
||||
(* Render mode stubs *)
|
||||
let render_active_p () = Bool false
|
||||
let render_expr _expr _env = Nil
|
||||
let is_render_expr _expr = Bool false
|
||||
|
||||
(* Signal accessors *)
|
||||
let signal_value s = match s with Signal sig' -> sig'.s_value | _ -> raise (Eval_error "not a signal")
|
||||
let signal_set_value s v = match s with Signal sig' -> sig'.s_value <- v; v | _ -> raise (Eval_error "not a signal")
|
||||
let signal_subscribers s = match s with Signal sig' -> List (List.map (fun _ -> Nil) sig'.s_subscribers) | _ -> List []
|
||||
let signal_add_sub_b _s _f = Nil
|
||||
let signal_remove_sub_b _s _f = Nil
|
||||
let signal_deps _s = List []
|
||||
let signal_set_deps _s _d = Nil
|
||||
let notify_subscribers _s = Nil
|
||||
let flush_subscribers _s = Nil
|
||||
let dispose_computed _s = Nil
|
||||
|
||||
(* Island scope stubs — accept OCaml functions from transpiled code *)
|
||||
let with_island_scope _register_fn body_fn = body_fn ()
|
||||
let register_in_scope _dispose_fn = Nil
|
||||
|
||||
(* Component type annotation stub *)
|
||||
let component_set_param_types_b _comp _types = Nil
|
||||
|
||||
(* Parse keyword args from a call — this is defined in evaluator.sx,
|
||||
the transpiled version will override this stub. *)
|
||||
(* Forward-reference stubs for evaluator functions used before definition *)
|
||||
let parse_comp_params _params = List [List []; Nil; Bool false]
|
||||
let parse_macro_params _params = List [List []; Nil]
|
||||
|
||||
let parse_keyword_args _raw_args _env =
|
||||
(* Stub — the real implementation is transpiled from evaluator.sx *)
|
||||
List [Dict (Hashtbl.create 0); List []]
|
||||
|
||||
(* Make handler/query/action/page def stubs *)
|
||||
let make_handler_def name params body _env = Dict (let d = Hashtbl.create 4 in Hashtbl.replace d "type" (String "handler"); Hashtbl.replace d "name" name; Hashtbl.replace d "params" params; Hashtbl.replace d "body" body; d)
|
||||
let make_query_def name params body _env = make_handler_def name params body _env
|
||||
let make_action_def name params body _env = make_handler_def name params body _env
|
||||
let make_page_def name _opts = Dict (let d = Hashtbl.create 4 in Hashtbl.replace d "type" (String "page"); Hashtbl.replace d "name" name; d)
|
||||
|
||||
(* sf-def* stubs — platform-specific def-forms, not in the SX spec *)
|
||||
let sf_defhandler args env =
|
||||
let name = first args in let rest_args = rest args in
|
||||
make_handler_def name (first rest_args) (nth rest_args (Number 1.0)) env
|
||||
let sf_defquery args env = sf_defhandler args env
|
||||
let sf_defaction args env = sf_defhandler args env
|
||||
let sf_defpage args _env =
|
||||
let name = first args in make_page_def name (rest args)
|
||||
|
||||
let strip_prefix s prefix =
|
||||
match s, prefix with
|
||||
| String s, String p ->
|
||||
let pl = String.length p in
|
||||
if String.length s >= pl && String.sub s 0 pl = p
|
||||
then String (String.sub s pl (String.length s - pl))
|
||||
else String s
|
||||
| _ -> s
|
||||
392
hosts/ocaml/lib/sx_types.ml
Normal file
392
hosts/ocaml/lib/sx_types.ml
Normal file
@@ -0,0 +1,392 @@
|
||||
(** Core types for the SX language.
|
||||
|
||||
The [value] sum type represents every possible SX runtime value.
|
||||
OCaml's algebraic types make the CEK machine's frame dispatch a
|
||||
pattern match — exactly what the spec describes. *)
|
||||
|
||||
(** {1 Environment} *)
|
||||
|
||||
(** Lexical scope chain. Each frame holds a mutable binding table and
|
||||
an optional parent link for scope-chain lookup. *)
|
||||
type env = {
|
||||
bindings : (string, value) Hashtbl.t;
|
||||
parent : env option;
|
||||
}
|
||||
|
||||
(** {1 Values} *)
|
||||
|
||||
and value =
|
||||
| Nil
|
||||
| Bool of bool
|
||||
| Number of float
|
||||
| String of string
|
||||
| Symbol of string
|
||||
| Keyword of string
|
||||
| List of value list
|
||||
| Dict of dict
|
||||
| Lambda of lambda
|
||||
| Component of component
|
||||
| Island of island
|
||||
| Macro of macro
|
||||
| Thunk of value * env
|
||||
| Continuation of (value -> value) * dict option
|
||||
| NativeFn of string * (value list -> value)
|
||||
| Signal of signal
|
||||
| RawHTML of string
|
||||
| Spread of (string * value) list
|
||||
| SxExpr of string (** Opaque SX wire-format string — aser output. *)
|
||||
| Env of env (** First-class environment — used by CEK machine state dicts. *)
|
||||
| ListRef of value list ref (** Mutable list — JS-style array for append! *)
|
||||
|
||||
(** Mutable string-keyed table (SX dicts support [dict-set!]). *)
|
||||
and dict = (string, value) Hashtbl.t
|
||||
|
||||
and lambda = {
|
||||
l_params : string list;
|
||||
l_body : value;
|
||||
l_closure : env;
|
||||
mutable l_name : string option;
|
||||
}
|
||||
|
||||
and component = {
|
||||
c_name : string;
|
||||
c_params : string list;
|
||||
c_has_children : bool;
|
||||
c_body : value;
|
||||
c_closure : env;
|
||||
c_affinity : string; (** "auto" | "client" | "server" *)
|
||||
}
|
||||
|
||||
and island = {
|
||||
i_name : string;
|
||||
i_params : string list;
|
||||
i_has_children : bool;
|
||||
i_body : value;
|
||||
i_closure : env;
|
||||
}
|
||||
|
||||
and macro = {
|
||||
m_params : string list;
|
||||
m_rest_param : string option;
|
||||
m_body : value;
|
||||
m_closure : env;
|
||||
m_name : string option;
|
||||
}
|
||||
|
||||
and signal = {
|
||||
mutable s_value : value;
|
||||
mutable s_subscribers : (unit -> unit) list;
|
||||
mutable s_deps : signal list;
|
||||
}
|
||||
|
||||
|
||||
(** {1 Errors} *)
|
||||
|
||||
exception Eval_error of string
|
||||
exception Parse_error of string
|
||||
|
||||
|
||||
(** {1 Environment operations} *)
|
||||
|
||||
let make_env () =
|
||||
{ bindings = Hashtbl.create 16; parent = None }
|
||||
|
||||
let env_extend parent =
|
||||
{ bindings = Hashtbl.create 16; parent = Some parent }
|
||||
|
||||
let env_bind env name v =
|
||||
Hashtbl.replace env.bindings name v; Nil
|
||||
|
||||
let rec env_has env name =
|
||||
Hashtbl.mem env.bindings name ||
|
||||
match env.parent with Some p -> env_has p name | None -> false
|
||||
|
||||
let rec env_get env name =
|
||||
match Hashtbl.find_opt env.bindings name with
|
||||
| Some v -> v
|
||||
| None ->
|
||||
match env.parent with
|
||||
| Some p -> env_get p name
|
||||
| None -> raise (Eval_error ("Undefined symbol: " ^ name))
|
||||
|
||||
let rec env_set env name v =
|
||||
if Hashtbl.mem env.bindings name then
|
||||
(Hashtbl.replace env.bindings name v; Nil)
|
||||
else
|
||||
match env.parent with
|
||||
| Some p -> env_set p name v
|
||||
| None -> Hashtbl.replace env.bindings name v; Nil
|
||||
|
||||
let env_merge base overlay =
|
||||
(* If base and overlay are the same env (physical equality) or overlay
|
||||
is a descendant of base, just extend base — no copying needed.
|
||||
This prevents set! inside lambdas from modifying shadow copies. *)
|
||||
if base == overlay then
|
||||
{ bindings = Hashtbl.create 16; parent = Some base }
|
||||
else begin
|
||||
(* Check if overlay is a descendant of base *)
|
||||
let rec is_descendant e depth =
|
||||
if depth > 100 then false
|
||||
else if e == base then true
|
||||
else match e.parent with Some p -> is_descendant p (depth + 1) | None -> false
|
||||
in
|
||||
if is_descendant overlay 0 then
|
||||
{ bindings = Hashtbl.create 16; parent = Some base }
|
||||
else begin
|
||||
(* General case: extend base, copy ONLY overlay bindings that don't
|
||||
exist anywhere in the base chain (avoids shadowing closure bindings). *)
|
||||
let e = { bindings = Hashtbl.create 16; parent = Some base } in
|
||||
Hashtbl.iter (fun k v ->
|
||||
if not (env_has base k) then Hashtbl.replace e.bindings k v
|
||||
) overlay.bindings;
|
||||
e
|
||||
end
|
||||
end
|
||||
|
||||
|
||||
(** {1 Value extraction helpers} *)
|
||||
|
||||
let value_to_string = function
|
||||
| String s -> s | Symbol s -> s | Keyword k -> k
|
||||
| Number n -> if Float.is_integer n then string_of_int (int_of_float n) else Printf.sprintf "%g" n
|
||||
| Bool true -> "true" | Bool false -> "false"
|
||||
| Nil -> "" | _ -> "<value>"
|
||||
|
||||
let value_to_string_list = function
|
||||
| List items | ListRef { contents = items } -> List.map value_to_string items
|
||||
| _ -> []
|
||||
|
||||
let value_to_bool = function
|
||||
| Bool b -> b | Nil -> false | _ -> true
|
||||
|
||||
let value_to_string_opt = function
|
||||
| String s -> Some s | Symbol s -> Some s | Nil -> None | _ -> None
|
||||
|
||||
|
||||
(** {1 Constructors — accept [value] args from transpiled code} *)
|
||||
|
||||
let unwrap_env_val = function
|
||||
| Env e -> e
|
||||
| _ -> raise (Eval_error "make_lambda: expected env for closure")
|
||||
|
||||
let make_lambda params body closure =
|
||||
let ps = match params with
|
||||
| List items -> List.map value_to_string items
|
||||
| _ -> value_to_string_list params
|
||||
in
|
||||
Lambda { l_params = ps; l_body = body; l_closure = unwrap_env_val closure; l_name = None }
|
||||
|
||||
let make_component name params has_children body closure affinity =
|
||||
let n = value_to_string name in
|
||||
let ps = value_to_string_list params in
|
||||
let hc = value_to_bool has_children in
|
||||
let aff = match affinity with String s -> s | _ -> "auto" in
|
||||
Component {
|
||||
c_name = n; c_params = ps; c_has_children = hc;
|
||||
c_body = body; c_closure = unwrap_env_val closure; c_affinity = aff;
|
||||
}
|
||||
|
||||
let make_island name params has_children body closure =
|
||||
let n = value_to_string name in
|
||||
let ps = value_to_string_list params in
|
||||
let hc = value_to_bool has_children in
|
||||
Island {
|
||||
i_name = n; i_params = ps; i_has_children = hc;
|
||||
i_body = body; i_closure = unwrap_env_val closure;
|
||||
}
|
||||
|
||||
let make_macro params rest_param body closure name =
|
||||
let ps = value_to_string_list params in
|
||||
let rp = value_to_string_opt rest_param in
|
||||
let n = value_to_string_opt name in
|
||||
Macro {
|
||||
m_params = ps; m_rest_param = rp;
|
||||
m_body = body; m_closure = unwrap_env_val closure; m_name = n;
|
||||
}
|
||||
|
||||
let make_thunk expr env = Thunk (expr, unwrap_env_val env)
|
||||
|
||||
let make_symbol name = Symbol (value_to_string name)
|
||||
let make_keyword name = Keyword (value_to_string name)
|
||||
|
||||
|
||||
(** {1 Type inspection} *)
|
||||
|
||||
let type_of = function
|
||||
| Nil -> "nil"
|
||||
| Bool _ -> "boolean"
|
||||
| Number _ -> "number"
|
||||
| String _ -> "string"
|
||||
| Symbol _ -> "symbol"
|
||||
| Keyword _ -> "keyword"
|
||||
| List _ | ListRef _ -> "list"
|
||||
| Dict _ -> "dict"
|
||||
| Lambda _ -> "lambda"
|
||||
| Component _ -> "component"
|
||||
| Island _ -> "island"
|
||||
| Macro _ -> "macro"
|
||||
| Thunk _ -> "thunk"
|
||||
| Continuation (_, _) -> "continuation"
|
||||
| NativeFn _ -> "function"
|
||||
| Signal _ -> "signal"
|
||||
| RawHTML _ -> "raw-html"
|
||||
| Spread _ -> "spread"
|
||||
| SxExpr _ -> "sx-expr"
|
||||
| Env _ -> "env"
|
||||
|
||||
let is_nil = function Nil -> true | _ -> false
|
||||
let is_lambda = function Lambda _ -> true | _ -> false
|
||||
let is_component = function Component _ -> true | _ -> false
|
||||
let is_island = function Island _ -> true | _ -> false
|
||||
let is_macro = function Macro _ -> true | _ -> false
|
||||
let is_thunk = function Thunk _ -> true | _ -> false
|
||||
let is_signal = function Signal _ -> true | _ -> false
|
||||
|
||||
let is_callable = function
|
||||
| Lambda _ | NativeFn _ | Continuation (_, _) -> true
|
||||
| _ -> false
|
||||
|
||||
|
||||
(** {1 Truthiness} *)
|
||||
|
||||
(** SX truthiness: everything is truthy except [Nil] and [Bool false]. *)
|
||||
let sx_truthy = function
|
||||
| Nil | Bool false -> false
|
||||
| _ -> true
|
||||
|
||||
|
||||
(** {1 Accessors} *)
|
||||
|
||||
let symbol_name = function
|
||||
| Symbol s -> String s
|
||||
| v -> raise (Eval_error ("Expected symbol, got " ^ type_of v))
|
||||
|
||||
let keyword_name = function
|
||||
| Keyword k -> String k
|
||||
| v -> raise (Eval_error ("Expected keyword, got " ^ type_of v))
|
||||
|
||||
let lambda_params = function
|
||||
| Lambda l -> List (List.map (fun s -> String s) l.l_params)
|
||||
| v -> raise (Eval_error ("Expected lambda, got " ^ type_of v))
|
||||
|
||||
let lambda_body = function
|
||||
| Lambda l -> l.l_body
|
||||
| v -> raise (Eval_error ("Expected lambda, got " ^ type_of v))
|
||||
|
||||
let lambda_closure = function
|
||||
| Lambda l -> Env l.l_closure
|
||||
| v -> raise (Eval_error ("Expected lambda, got " ^ type_of v))
|
||||
|
||||
let lambda_name = function
|
||||
| Lambda l -> (match l.l_name with Some n -> String n | None -> Nil)
|
||||
| v -> raise (Eval_error ("Expected lambda, got " ^ type_of v))
|
||||
|
||||
let set_lambda_name l n = match l with
|
||||
| Lambda l -> l.l_name <- Some n; Nil
|
||||
| _ -> raise (Eval_error "set-lambda-name!: not a lambda")
|
||||
|
||||
let component_name = function
|
||||
| Component c -> String c.c_name
|
||||
| v -> raise (Eval_error ("Expected component, got " ^ type_of v))
|
||||
|
||||
let component_params = function
|
||||
| Component c -> List (List.map (fun s -> String s) c.c_params)
|
||||
| v -> raise (Eval_error ("Expected component, got " ^ type_of v))
|
||||
|
||||
let component_body = function
|
||||
| Component c -> c.c_body
|
||||
| v -> raise (Eval_error ("Expected component, got " ^ type_of v))
|
||||
|
||||
let component_closure = function
|
||||
| Component c -> Env c.c_closure
|
||||
| v -> raise (Eval_error ("Expected component, got " ^ type_of v))
|
||||
|
||||
let component_has_children = function
|
||||
| Component c -> Bool c.c_has_children
|
||||
| v -> raise (Eval_error ("Expected component, got " ^ type_of v))
|
||||
|
||||
let component_affinity = function
|
||||
| Component c -> String c.c_affinity
|
||||
| _ -> String "auto"
|
||||
|
||||
let macro_params = function
|
||||
| Macro m -> List (List.map (fun s -> String s) m.m_params)
|
||||
| v -> raise (Eval_error ("Expected macro, got " ^ type_of v))
|
||||
|
||||
let macro_rest_param = function
|
||||
| Macro m -> (match m.m_rest_param with Some s -> String s | None -> Nil)
|
||||
| v -> raise (Eval_error ("Expected macro, got " ^ type_of v))
|
||||
|
||||
let macro_body = function
|
||||
| Macro m -> m.m_body
|
||||
| v -> raise (Eval_error ("Expected macro, got " ^ type_of v))
|
||||
|
||||
let macro_closure = function
|
||||
| Macro m -> Env m.m_closure
|
||||
| v -> raise (Eval_error ("Expected macro, got " ^ type_of v))
|
||||
|
||||
let thunk_expr = function
|
||||
| Thunk (e, _) -> e
|
||||
| v -> raise (Eval_error ("Expected thunk, got " ^ type_of v))
|
||||
|
||||
let thunk_env = function
|
||||
| Thunk (_, e) -> Env e
|
||||
| v -> raise (Eval_error ("Expected thunk, got " ^ type_of v))
|
||||
|
||||
|
||||
(** {1 Dict operations} *)
|
||||
|
||||
let make_dict () : dict = Hashtbl.create 8
|
||||
|
||||
let dict_get (d : dict) key =
|
||||
match Hashtbl.find_opt d key with Some v -> v | None -> Nil
|
||||
|
||||
let dict_has (d : dict) key = Hashtbl.mem d key
|
||||
|
||||
let dict_set (d : dict) key v = Hashtbl.replace d key v
|
||||
|
||||
let dict_delete (d : dict) key = Hashtbl.remove d key
|
||||
|
||||
let dict_keys (d : dict) =
|
||||
Hashtbl.fold (fun k _ acc -> String k :: acc) d []
|
||||
|
||||
let dict_vals (d : dict) =
|
||||
Hashtbl.fold (fun _ v acc -> v :: acc) d []
|
||||
|
||||
|
||||
(** {1 Value display} *)
|
||||
|
||||
let rec inspect = function
|
||||
| Nil -> "nil"
|
||||
| Bool true -> "true"
|
||||
| Bool false -> "false"
|
||||
| Number n ->
|
||||
if Float.is_integer n then Printf.sprintf "%d" (int_of_float n)
|
||||
else Printf.sprintf "%g" n
|
||||
| String s -> Printf.sprintf "%S" s
|
||||
| Symbol s -> s
|
||||
| Keyword k -> ":" ^ k
|
||||
| List items | ListRef { contents = items } ->
|
||||
"(" ^ String.concat " " (List.map inspect items) ^ ")"
|
||||
| Dict d ->
|
||||
let pairs = Hashtbl.fold (fun k v acc ->
|
||||
(Printf.sprintf ":%s %s" k (inspect v)) :: acc) d [] in
|
||||
"{" ^ String.concat " " pairs ^ "}"
|
||||
| Lambda l ->
|
||||
let tag = match l.l_name with Some n -> n | None -> "lambda" in
|
||||
Printf.sprintf "<%s(%s)>" tag (String.concat ", " l.l_params)
|
||||
| Component c ->
|
||||
Printf.sprintf "<Component ~%s(%s)>" c.c_name (String.concat ", " c.c_params)
|
||||
| Island i ->
|
||||
Printf.sprintf "<Island ~%s(%s)>" i.i_name (String.concat ", " i.i_params)
|
||||
| Macro m ->
|
||||
let tag = match m.m_name with Some n -> n | None -> "macro" in
|
||||
Printf.sprintf "<%s(%s)>" tag (String.concat ", " m.m_params)
|
||||
| Thunk _ -> "<thunk>"
|
||||
| Continuation (_, _) -> "<continuation>"
|
||||
| NativeFn (name, _) -> Printf.sprintf "<native:%s>" name
|
||||
| Signal _ -> "<signal>"
|
||||
| RawHTML s -> Printf.sprintf "<raw-html:%d chars>" (String.length s)
|
||||
| Spread _ -> "<spread>"
|
||||
| SxExpr s -> Printf.sprintf "<sx-expr:%d chars>" (String.length s)
|
||||
| Env _ -> "<env>"
|
||||
1230
hosts/ocaml/transpiler.sx
Normal file
1230
hosts/ocaml/transpiler.sx
Normal file
File diff suppressed because it is too large
Load Diff
@@ -525,13 +525,24 @@ def env_merge(base, overlay):
|
||||
if base is overlay:
|
||||
# Same env — just extend with empty local scope for params
|
||||
return base.extend()
|
||||
# Check if base is an ancestor of overlay — if so, no need to merge
|
||||
# (common for self-recursive calls where closure == caller's ancestor)
|
||||
# Check if base is an ancestor of overlay — if so, overlay contains
|
||||
# everything in base. But overlay scopes between overlay and base may
|
||||
# have extra local bindings (e.g. page helpers injected at request time).
|
||||
# Only take the shortcut if no intermediate scope has local bindings.
|
||||
p = overlay
|
||||
depth = 0
|
||||
while p is not None and depth < 100:
|
||||
if p is base:
|
||||
return base.extend()
|
||||
q = overlay
|
||||
has_extra = False
|
||||
while q is not base:
|
||||
if hasattr(q, '_bindings') and q._bindings:
|
||||
has_extra = True
|
||||
break
|
||||
q = getattr(q, '_parent', None)
|
||||
if not has_extra:
|
||||
return base.extend()
|
||||
break
|
||||
p = getattr(p, '_parent', None)
|
||||
depth += 1
|
||||
# MergedEnv: reads walk base then overlay; set! walks base only
|
||||
|
||||
@@ -273,7 +273,7 @@ for expr in parse_all(framework_src):
|
||||
args = [a for a in sys.argv[1:] if not a.startswith("--")]
|
||||
|
||||
# Tests requiring optional modules (only with --full)
|
||||
REQUIRES_FULL = {"test-continuations.sx", "test-types.sx", "test-freeze.sx", "test-strict.sx", "test-cek.sx"}
|
||||
REQUIRES_FULL = {"test-continuations.sx", "test-continuations-advanced.sx", "test-types.sx", "test-freeze.sx", "test-strict.sx", "test-cek.sx", "test-cek-advanced.sx", "test-signals-advanced.sx"}
|
||||
|
||||
test_files = []
|
||||
if args:
|
||||
|
||||
@@ -14,7 +14,7 @@
|
||||
// =========================================================================
|
||||
|
||||
var NIL = Object.freeze({ _nil: true, toString: function() { return "nil"; } });
|
||||
var SX_VERSION = "2026-03-15T15:05:23Z";
|
||||
var SX_VERSION = "2026-03-15T17:07:09Z";
|
||||
|
||||
function isNil(x) { return x === NIL || x === null || x === undefined; }
|
||||
function isSxTruthy(x) { return x !== false && !isNil(x); }
|
||||
@@ -1628,32 +1628,55 @@ PRIMITIVES["reactive-shift-deref"] = reactiveShiftDeref;
|
||||
})(); };
|
||||
PRIMITIVES["step-eval-call"] = stepEvalCall;
|
||||
|
||||
// ho-form-name?
|
||||
var hoFormName_p = function(name) { return sxOr((name == "map"), (name == "map-indexed"), (name == "filter"), (name == "reduce"), (name == "some"), (name == "every?"), (name == "for-each")); };
|
||||
PRIMITIVES["ho-form-name?"] = hoFormName_p;
|
||||
|
||||
// ho-fn?
|
||||
var hoFn_p = function(v) { return sxOr(isCallable(v), isLambda(v)); };
|
||||
PRIMITIVES["ho-fn?"] = hoFn_p;
|
||||
|
||||
// ho-swap-args
|
||||
var hoSwapArgs = function(hoType, evaled) { return (isSxTruthy((hoType == "reduce")) ? (function() {
|
||||
var a = first(evaled);
|
||||
var b = nth(evaled, 1);
|
||||
return (isSxTruthy((isSxTruthy(!isSxTruthy(hoFn_p(a))) && hoFn_p(b))) ? [b, nth(evaled, 2), a] : evaled);
|
||||
})() : (function() {
|
||||
var a = first(evaled);
|
||||
var b = nth(evaled, 1);
|
||||
return (isSxTruthy((isSxTruthy(!isSxTruthy(hoFn_p(a))) && hoFn_p(b))) ? [b, a] : evaled);
|
||||
})()); };
|
||||
PRIMITIVES["ho-swap-args"] = hoSwapArgs;
|
||||
|
||||
// ho-setup-dispatch
|
||||
var hoSetupDispatch = function(hoType, evaled, env, kont) { return (function() {
|
||||
var f = first(evaled);
|
||||
var ordered = hoSwapArgs(hoType, evaled);
|
||||
return (function() {
|
||||
var f = first(ordered);
|
||||
return (isSxTruthy((hoType == "map")) ? (function() {
|
||||
var coll = nth(evaled, 1);
|
||||
var coll = nth(ordered, 1);
|
||||
return (isSxTruthy(isEmpty(coll)) ? makeCekValue([], env, kont) : continueWithCall(f, [first(coll)], env, [], kontPush(makeMapFrame(f, rest(coll), [], env), kont)));
|
||||
})() : (isSxTruthy((hoType == "map-indexed")) ? (function() {
|
||||
var coll = nth(evaled, 1);
|
||||
var coll = nth(ordered, 1);
|
||||
return (isSxTruthy(isEmpty(coll)) ? makeCekValue([], env, kont) : continueWithCall(f, [0, first(coll)], env, [], kontPush(makeMapIndexedFrame(f, rest(coll), [], env), kont)));
|
||||
})() : (isSxTruthy((hoType == "filter")) ? (function() {
|
||||
var coll = nth(evaled, 1);
|
||||
var coll = nth(ordered, 1);
|
||||
return (isSxTruthy(isEmpty(coll)) ? makeCekValue([], env, kont) : continueWithCall(f, [first(coll)], env, [], kontPush(makeFilterFrame(f, rest(coll), [], first(coll), env), kont)));
|
||||
})() : (isSxTruthy((hoType == "reduce")) ? (function() {
|
||||
var init = nth(evaled, 1);
|
||||
var coll = nth(evaled, 2);
|
||||
var init = nth(ordered, 1);
|
||||
var coll = nth(ordered, 2);
|
||||
return (isSxTruthy(isEmpty(coll)) ? makeCekValue(init, env, kont) : continueWithCall(f, [init, first(coll)], env, [], kontPush(makeReduceFrame(f, rest(coll), env), kont)));
|
||||
})() : (isSxTruthy((hoType == "some")) ? (function() {
|
||||
var coll = nth(evaled, 1);
|
||||
var coll = nth(ordered, 1);
|
||||
return (isSxTruthy(isEmpty(coll)) ? makeCekValue(false, env, kont) : continueWithCall(f, [first(coll)], env, [], kontPush(makeSomeFrame(f, rest(coll), env), kont)));
|
||||
})() : (isSxTruthy((hoType == "every")) ? (function() {
|
||||
var coll = nth(evaled, 1);
|
||||
var coll = nth(ordered, 1);
|
||||
return (isSxTruthy(isEmpty(coll)) ? makeCekValue(true, env, kont) : continueWithCall(f, [first(coll)], env, [], kontPush(makeEveryFrame(f, rest(coll), env), kont)));
|
||||
})() : (isSxTruthy((hoType == "for-each")) ? (function() {
|
||||
var coll = nth(evaled, 1);
|
||||
var coll = nth(ordered, 1);
|
||||
return (isSxTruthy(isEmpty(coll)) ? makeCekValue(NIL, env, kont) : continueWithCall(f, [first(coll)], env, [], kontPush(makeForEachFrame(f, rest(coll), env), kont)));
|
||||
})() : error((String("Unknown HO type: ") + String(hoType))))))))));
|
||||
})();
|
||||
})(); };
|
||||
PRIMITIVES["ho-setup-dispatch"] = hoSetupDispatch;
|
||||
|
||||
@@ -1771,7 +1794,8 @@ PRIMITIVES["step-ho-for-each"] = stepHoForEach;
|
||||
return (isSxTruthy(isEmpty(remaining)) ? makeCekValue(value, fenv, restK) : (function() {
|
||||
var form = first(remaining);
|
||||
var restForms = rest(remaining);
|
||||
return (function() {
|
||||
var newKont = (isSxTruthy(isEmpty(rest(remaining))) ? restK : kontPush(makeThreadFrame(rest(remaining), fenv), restK));
|
||||
return (isSxTruthy((isSxTruthy((typeOf(form) == "list")) && isSxTruthy(!isSxTruthy(isEmpty(form))) && isSxTruthy((typeOf(first(form)) == "symbol")) && hoFormName_p(symbolName(first(form))))) ? makeCekState(cons(first(form), cons([new Symbol("quote"), value], rest(form))), fenv, newKont) : (function() {
|
||||
var result = (isSxTruthy((typeOf(form) == "list")) ? (function() {
|
||||
var f = trampoline(evalExpr(first(form), fenv));
|
||||
var rargs = map(function(a) { return trampoline(evalExpr(a, fenv)); }, rest(form));
|
||||
@@ -1782,7 +1806,7 @@ PRIMITIVES["step-ho-for-each"] = stepHoForEach;
|
||||
return (isSxTruthy((isSxTruthy(isCallable(f)) && !isSxTruthy(isLambda(f)))) ? f(value) : (isSxTruthy(isLambda(f)) ? trampoline(callLambda(f, [value], fenv)) : error((String("-> form not callable: ") + String(inspect(f))))));
|
||||
})());
|
||||
return (isSxTruthy(isEmpty(restForms)) ? makeCekValue(result, fenv, restK) : makeCekValue(result, fenv, kontPush(makeThreadFrame(restForms, fenv), restK)));
|
||||
})();
|
||||
})());
|
||||
})());
|
||||
})() : (isSxTruthy((ft == "arg")) ? (function() {
|
||||
var f = get(frame, "f");
|
||||
|
||||
@@ -31,7 +31,13 @@ from typing import Any
|
||||
from .types import NIL, Component, Island, Keyword, Lambda, Macro, Symbol
|
||||
from .parser import parse
|
||||
import os as _os
|
||||
if _os.environ.get("SX_USE_REF") == "1":
|
||||
if _os.environ.get("SX_USE_OCAML") == "1":
|
||||
# OCaml kernel bridge — render via persistent subprocess.
|
||||
# html_render and _render_component are set up lazily since the bridge
|
||||
# requires an async event loop. The sync sx() function falls back to
|
||||
# the ref renderer; async callers use ocaml_bridge directly.
|
||||
from .ref.sx_ref import render as html_render, render_html_component as _render_component
|
||||
elif _os.environ.get("SX_USE_REF") == "1":
|
||||
from .ref.sx_ref import render as html_render, render_html_component as _render_component
|
||||
else:
|
||||
from .html import render as html_render, _render_component
|
||||
@@ -348,6 +354,12 @@ def reload_if_changed() -> None:
|
||||
reload_logger.info("Reloaded %d file(s), components in %.1fms",
|
||||
len(changed_files), (t1 - t0) * 1000)
|
||||
|
||||
# Invalidate OCaml bridge component cache so next render reloads
|
||||
if _os.environ.get("SX_USE_OCAML") == "1":
|
||||
from .ocaml_bridge import _bridge
|
||||
if _bridge is not None:
|
||||
_bridge._components_loaded = False
|
||||
|
||||
# Recompute render plans for all services that have pages
|
||||
from .pages import _PAGE_REGISTRY, compute_page_render_plans
|
||||
for svc in _PAGE_REGISTRY:
|
||||
@@ -430,6 +442,9 @@ def finalize_components() -> None:
|
||||
compute_all_io_refs(_COMPONENT_ENV, get_all_io_names())
|
||||
_compute_component_hash()
|
||||
|
||||
# OCaml bridge loads components lazily on first render via
|
||||
# OcamlBridge._ensure_components() — no sync needed here.
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# sx() — render s-expression from Jinja template
|
||||
@@ -482,7 +497,16 @@ async def sx_async(source: str, **kwargs: Any) -> str:
|
||||
Use when the s-expression contains I/O nodes::
|
||||
|
||||
{{ sx_async('(frag "blog" "card" :slug "apple")') | safe }}
|
||||
|
||||
When SX_USE_OCAML=1, renders via the OCaml kernel subprocess which
|
||||
yields io-requests back to Python for async fulfillment.
|
||||
"""
|
||||
if _os.environ.get("SX_USE_OCAML") == "1":
|
||||
from .ocaml_bridge import get_bridge
|
||||
bridge = await get_bridge()
|
||||
ctx = dict(kwargs)
|
||||
return await bridge.render(source, ctx=ctx)
|
||||
|
||||
from .resolver import resolve, RequestContext
|
||||
|
||||
env = dict(_COMPONENT_ENV)
|
||||
|
||||
408
shared/sx/ocaml_bridge.py
Normal file
408
shared/sx/ocaml_bridge.py
Normal file
@@ -0,0 +1,408 @@
|
||||
"""
|
||||
OCaml SX kernel ↔ Python coroutine bridge.
|
||||
|
||||
Manages a persistent OCaml subprocess (sx_server) that evaluates SX
|
||||
expressions. When the OCaml kernel needs IO (database queries, service
|
||||
calls), it yields an ``(io-request ...)`` back to Python, which fulfills
|
||||
it asynchronously and sends an ``(io-response ...)`` back.
|
||||
|
||||
Usage::
|
||||
|
||||
bridge = OcamlBridge()
|
||||
await bridge.start()
|
||||
html = await bridge.render('(div (p "hello"))')
|
||||
await bridge.stop()
|
||||
"""
|
||||
|
||||
from __future__ import annotations
|
||||
|
||||
import asyncio
|
||||
import logging
|
||||
import os
|
||||
from typing import Any
|
||||
|
||||
_logger = logging.getLogger("sx.ocaml")
|
||||
|
||||
# Default binary path — can be overridden via SX_OCAML_BIN env var
|
||||
_DEFAULT_BIN = os.path.join(
|
||||
os.path.dirname(__file__),
|
||||
"../../hosts/ocaml/_build/default/bin/sx_server.exe",
|
||||
)
|
||||
|
||||
|
||||
class OcamlBridgeError(Exception):
|
||||
"""Error from the OCaml SX kernel."""
|
||||
|
||||
|
||||
class OcamlBridge:
|
||||
"""Async bridge to a persistent OCaml SX subprocess."""
|
||||
|
||||
def __init__(self, binary: str | None = None):
|
||||
self._binary = binary or os.environ.get("SX_OCAML_BIN") or _DEFAULT_BIN
|
||||
self._proc: asyncio.subprocess.Process | None = None
|
||||
self._lock = asyncio.Lock()
|
||||
self._started = False
|
||||
self._components_loaded = False
|
||||
|
||||
async def start(self) -> None:
|
||||
"""Launch the OCaml subprocess and wait for (ready)."""
|
||||
if self._started:
|
||||
return
|
||||
|
||||
bin_path = os.path.abspath(self._binary)
|
||||
if not os.path.isfile(bin_path):
|
||||
raise FileNotFoundError(
|
||||
f"OCaml SX server binary not found: {bin_path}\n"
|
||||
f"Build with: cd hosts/ocaml && eval $(opam env) && dune build"
|
||||
)
|
||||
|
||||
_logger.info("Starting OCaml SX kernel: %s", bin_path)
|
||||
self._proc = await asyncio.create_subprocess_exec(
|
||||
bin_path,
|
||||
stdin=asyncio.subprocess.PIPE,
|
||||
stdout=asyncio.subprocess.PIPE,
|
||||
stderr=asyncio.subprocess.PIPE,
|
||||
)
|
||||
|
||||
# Wait for (ready)
|
||||
line = await self._readline()
|
||||
if line != "(ready)":
|
||||
raise OcamlBridgeError(f"Expected (ready), got: {line!r}")
|
||||
|
||||
self._started = True
|
||||
|
||||
# Verify engine identity
|
||||
self._send("(ping)")
|
||||
kind, engine = await self._read_response()
|
||||
engine_name = engine if kind == "ok" else "unknown"
|
||||
_logger.info("OCaml SX kernel ready (pid=%d, engine=%s)", self._proc.pid, engine_name)
|
||||
|
||||
async def stop(self) -> None:
|
||||
"""Terminate the subprocess."""
|
||||
if self._proc and self._proc.returncode is None:
|
||||
self._proc.stdin.close()
|
||||
try:
|
||||
await asyncio.wait_for(self._proc.wait(), timeout=5.0)
|
||||
except asyncio.TimeoutError:
|
||||
self._proc.kill()
|
||||
await self._proc.wait()
|
||||
_logger.info("OCaml SX kernel stopped")
|
||||
self._proc = None
|
||||
self._started = False
|
||||
|
||||
async def ping(self) -> str:
|
||||
"""Health check — returns engine name (e.g. 'ocaml-cek')."""
|
||||
async with self._lock:
|
||||
self._send("(ping)")
|
||||
kind, value = await self._read_response()
|
||||
return value or "" if kind == "ok" else ""
|
||||
|
||||
async def load(self, path: str) -> int:
|
||||
"""Load an .sx file for side effects (defcomp, define, defmacro)."""
|
||||
async with self._lock:
|
||||
self._send(f'(load "{_escape(path)}")')
|
||||
kind, value = await self._read_response()
|
||||
if kind == "error":
|
||||
raise OcamlBridgeError(f"load {path}: {value}")
|
||||
return int(float(value)) if value else 0
|
||||
|
||||
async def load_source(self, source: str) -> int:
|
||||
"""Evaluate SX source for side effects."""
|
||||
async with self._lock:
|
||||
self._send(f'(load-source "{_escape(source)}")')
|
||||
kind, value = await self._read_response()
|
||||
if kind == "error":
|
||||
raise OcamlBridgeError(f"load-source: {value}")
|
||||
return int(float(value)) if value else 0
|
||||
|
||||
async def eval(self, source: str) -> str:
|
||||
"""Evaluate SX expression, return serialized result."""
|
||||
async with self._lock:
|
||||
self._send(f'(eval "{_escape(source)}")')
|
||||
kind, value = await self._read_response()
|
||||
if kind == "error":
|
||||
raise OcamlBridgeError(f"eval: {value}")
|
||||
return value or ""
|
||||
|
||||
async def render(
|
||||
self,
|
||||
source: str,
|
||||
ctx: dict[str, Any] | None = None,
|
||||
) -> str:
|
||||
"""Render SX to HTML, handling io-requests via Python async IO."""
|
||||
await self._ensure_components()
|
||||
async with self._lock:
|
||||
self._send(f'(render "{_escape(source)}")')
|
||||
return await self._read_until_ok(ctx)
|
||||
|
||||
async def _ensure_components(self) -> None:
|
||||
"""Load component definitions into the kernel on first use."""
|
||||
if self._components_loaded:
|
||||
return
|
||||
self._components_loaded = True
|
||||
try:
|
||||
from .jinja_bridge import get_component_env, _CLIENT_LIBRARY_SOURCES
|
||||
from .parser import serialize
|
||||
from .types import Component, Island, Macro
|
||||
|
||||
env = get_component_env()
|
||||
parts: list[str] = list(_CLIENT_LIBRARY_SOURCES)
|
||||
for key, val in env.items():
|
||||
if isinstance(val, Island):
|
||||
ps = ["&key"] + list(val.params)
|
||||
if val.has_children:
|
||||
ps.extend(["&rest", "children"])
|
||||
parts.append(f"(defisland ~{val.name} ({' '.join(ps)}) {serialize(val.body)})")
|
||||
elif isinstance(val, Component):
|
||||
ps = ["&key"] + list(val.params)
|
||||
if val.has_children:
|
||||
ps.extend(["&rest", "children"])
|
||||
parts.append(f"(defcomp ~{val.name} ({' '.join(ps)}) {serialize(val.body)})")
|
||||
elif isinstance(val, Macro):
|
||||
ps = list(val.params)
|
||||
if val.rest_param:
|
||||
ps.extend(["&rest", val.rest_param])
|
||||
parts.append(f"(defmacro {val.name} ({' '.join(ps)}) {serialize(val.body)})")
|
||||
if parts:
|
||||
source = "\n".join(parts)
|
||||
await self.load_source(source)
|
||||
_logger.info("Loaded %d definitions into OCaml kernel", len(parts))
|
||||
except Exception as e:
|
||||
_logger.error("Failed to load components into OCaml kernel: %s", e)
|
||||
self._components_loaded = False # retry next time
|
||||
|
||||
async def reset(self) -> None:
|
||||
"""Reset the kernel environment to pristine state."""
|
||||
async with self._lock:
|
||||
self._send("(reset)")
|
||||
kind, value = await self._read_response()
|
||||
if kind == "error":
|
||||
raise OcamlBridgeError(f"reset: {value}")
|
||||
|
||||
# ------------------------------------------------------------------
|
||||
# Internal protocol handling
|
||||
# ------------------------------------------------------------------
|
||||
|
||||
def _send(self, line: str) -> None:
|
||||
"""Write a line to the subprocess stdin."""
|
||||
assert self._proc and self._proc.stdin
|
||||
self._proc.stdin.write((line + "\n").encode())
|
||||
|
||||
async def _readline(self) -> str:
|
||||
"""Read a line from the subprocess stdout."""
|
||||
assert self._proc and self._proc.stdout
|
||||
data = await self._proc.stdout.readline()
|
||||
if not data:
|
||||
# Process died — collect stderr for diagnostics
|
||||
stderr = b""
|
||||
if self._proc.stderr:
|
||||
stderr = await self._proc.stderr.read()
|
||||
raise OcamlBridgeError(
|
||||
f"OCaml subprocess died unexpectedly. stderr: {stderr.decode(errors='replace')}"
|
||||
)
|
||||
return data.decode().rstrip("\n")
|
||||
|
||||
async def _read_response(self) -> tuple[str, str | None]:
|
||||
"""Read a single (ok ...) or (error ...) response.
|
||||
|
||||
Returns (kind, value) where kind is "ok" or "error".
|
||||
"""
|
||||
line = await self._readline()
|
||||
return _parse_response(line)
|
||||
|
||||
async def _read_until_ok(
|
||||
self,
|
||||
ctx: dict[str, Any] | None = None,
|
||||
) -> str:
|
||||
"""Read lines until (ok ...) or (error ...).
|
||||
|
||||
Handles (io-request ...) by fulfilling IO and sending (io-response ...).
|
||||
"""
|
||||
while True:
|
||||
line = await self._readline()
|
||||
|
||||
if line.startswith("(io-request "):
|
||||
result = await self._handle_io_request(line, ctx)
|
||||
# Send response back to OCaml
|
||||
self._send(f"(io-response {_serialize_for_ocaml(result)})")
|
||||
continue
|
||||
|
||||
kind, value = _parse_response(line)
|
||||
if kind == "error":
|
||||
raise OcamlBridgeError(value or "Unknown error")
|
||||
# kind == "ok"
|
||||
return value or ""
|
||||
|
||||
async def _handle_io_request(
|
||||
self,
|
||||
line: str,
|
||||
ctx: dict[str, Any] | None,
|
||||
) -> Any:
|
||||
"""Dispatch an io-request to the appropriate Python handler."""
|
||||
from .parser import parse_all
|
||||
|
||||
# Parse the io-request
|
||||
parsed = parse_all(line)
|
||||
if not parsed or not isinstance(parsed[0], list):
|
||||
raise OcamlBridgeError(f"Malformed io-request: {line}")
|
||||
|
||||
parts = parsed[0]
|
||||
# parts = [Symbol("io-request"), name_str, ...args]
|
||||
if len(parts) < 2:
|
||||
raise OcamlBridgeError(f"Malformed io-request: {line}")
|
||||
|
||||
req_name = _to_str(parts[1])
|
||||
args = parts[2:]
|
||||
|
||||
if req_name == "query":
|
||||
return await self._io_query(args)
|
||||
elif req_name == "action":
|
||||
return await self._io_action(args)
|
||||
elif req_name == "request-arg":
|
||||
return self._io_request_arg(args)
|
||||
elif req_name == "request-method":
|
||||
return self._io_request_method()
|
||||
elif req_name == "ctx":
|
||||
return self._io_ctx(args, ctx)
|
||||
else:
|
||||
raise OcamlBridgeError(f"Unknown io-request type: {req_name}")
|
||||
|
||||
async def _io_query(self, args: list) -> Any:
|
||||
"""Handle (io-request "query" service name params...)."""
|
||||
from shared.infrastructure.internal import fetch_data
|
||||
|
||||
service = _to_str(args[0]) if len(args) > 0 else ""
|
||||
query = _to_str(args[1]) if len(args) > 1 else ""
|
||||
params = _to_dict(args[2]) if len(args) > 2 else {}
|
||||
return await fetch_data(service, query, params)
|
||||
|
||||
async def _io_action(self, args: list) -> Any:
|
||||
"""Handle (io-request "action" service name payload...)."""
|
||||
from shared.infrastructure.internal import call_action
|
||||
|
||||
service = _to_str(args[0]) if len(args) > 0 else ""
|
||||
action = _to_str(args[1]) if len(args) > 1 else ""
|
||||
payload = _to_dict(args[2]) if len(args) > 2 else {}
|
||||
return await call_action(service, action, payload)
|
||||
|
||||
def _io_request_arg(self, args: list) -> Any:
|
||||
"""Handle (io-request "request-arg" name)."""
|
||||
try:
|
||||
from quart import request
|
||||
name = _to_str(args[0]) if args else ""
|
||||
return request.args.get(name)
|
||||
except RuntimeError:
|
||||
return None
|
||||
|
||||
def _io_request_method(self) -> str:
|
||||
"""Handle (io-request "request-method")."""
|
||||
try:
|
||||
from quart import request
|
||||
return request.method
|
||||
except RuntimeError:
|
||||
return "GET"
|
||||
|
||||
def _io_ctx(self, args: list, ctx: dict[str, Any] | None) -> Any:
|
||||
"""Handle (io-request "ctx" key)."""
|
||||
if ctx is None:
|
||||
return None
|
||||
key = _to_str(args[0]) if args else ""
|
||||
return ctx.get(key)
|
||||
|
||||
|
||||
# ------------------------------------------------------------------
|
||||
# Module-level singleton
|
||||
# ------------------------------------------------------------------
|
||||
|
||||
_bridge: OcamlBridge | None = None
|
||||
|
||||
|
||||
async def get_bridge() -> OcamlBridge:
|
||||
"""Get or create the singleton bridge instance."""
|
||||
global _bridge
|
||||
if _bridge is None:
|
||||
_bridge = OcamlBridge()
|
||||
if not _bridge._started:
|
||||
await _bridge.start()
|
||||
return _bridge
|
||||
|
||||
|
||||
# ------------------------------------------------------------------
|
||||
# Helpers
|
||||
# ------------------------------------------------------------------
|
||||
|
||||
def _escape(s: str) -> str:
|
||||
"""Escape a string for embedding in an SX string literal."""
|
||||
return s.replace("\\", "\\\\").replace('"', '\\"').replace("\n", "\\n").replace("\r", "\\r").replace("\t", "\\t")
|
||||
|
||||
|
||||
def _parse_response(line: str) -> tuple[str, str | None]:
|
||||
"""Parse an (ok ...) or (error ...) response line.
|
||||
|
||||
Returns (kind, value) tuple.
|
||||
"""
|
||||
line = line.strip()
|
||||
if line == "(ok)":
|
||||
return ("ok", None)
|
||||
if line.startswith("(ok "):
|
||||
value = line[4:-1] # strip (ok and )
|
||||
# If the value is a quoted string, unquote it
|
||||
if value.startswith('"') and value.endswith('"'):
|
||||
value = _unescape(value[1:-1])
|
||||
return ("ok", value)
|
||||
if line.startswith("(error "):
|
||||
msg = line[7:-1]
|
||||
if msg.startswith('"') and msg.endswith('"'):
|
||||
msg = _unescape(msg[1:-1])
|
||||
return ("error", msg)
|
||||
return ("error", f"Unexpected response: {line}")
|
||||
|
||||
|
||||
def _unescape(s: str) -> str:
|
||||
"""Unescape an SX string literal."""
|
||||
return (
|
||||
s.replace("\\n", "\n")
|
||||
.replace("\\r", "\r")
|
||||
.replace("\\t", "\t")
|
||||
.replace('\\"', '"')
|
||||
.replace("\\\\", "\\")
|
||||
)
|
||||
|
||||
|
||||
def _to_str(val: Any) -> str:
|
||||
"""Convert an SX parsed value to a Python string."""
|
||||
if isinstance(val, str):
|
||||
return val
|
||||
if hasattr(val, "name"):
|
||||
return val.name
|
||||
return str(val)
|
||||
|
||||
|
||||
def _to_dict(val: Any) -> dict:
|
||||
"""Convert an SX parsed value to a Python dict."""
|
||||
if isinstance(val, dict):
|
||||
return val
|
||||
return {}
|
||||
|
||||
|
||||
def _serialize_for_ocaml(val: Any) -> str:
|
||||
"""Serialize a Python value to SX text for sending to OCaml."""
|
||||
if val is None:
|
||||
return "nil"
|
||||
if isinstance(val, bool):
|
||||
return "true" if val else "false"
|
||||
if isinstance(val, (int, float)):
|
||||
if isinstance(val, float) and val == int(val):
|
||||
return str(int(val))
|
||||
return str(val)
|
||||
if isinstance(val, str):
|
||||
return f'"{_escape(val)}"'
|
||||
if isinstance(val, (list, tuple)):
|
||||
items = " ".join(_serialize_for_ocaml(v) for v in val)
|
||||
return f"(list {items})"
|
||||
if isinstance(val, dict):
|
||||
pairs = " ".join(
|
||||
f":{k} {_serialize_for_ocaml(v)}" for k, v in val.items()
|
||||
)
|
||||
return "{" + pairs + "}"
|
||||
return f'"{_escape(str(val))}"'
|
||||
@@ -23,11 +23,28 @@ import logging
|
||||
import os
|
||||
from typing import Any
|
||||
|
||||
from .types import PageDef
|
||||
import traceback
|
||||
|
||||
from .types import EvalError, PageDef
|
||||
|
||||
logger = logging.getLogger("sx.pages")
|
||||
|
||||
|
||||
def _eval_error_sx(e: EvalError, context: str) -> str:
|
||||
"""Render an EvalError as SX content that's visible to the developer."""
|
||||
from .ref.sx_ref import escape_html as _esc
|
||||
msg = _esc(str(e))
|
||||
ctx = _esc(context)
|
||||
return (
|
||||
f'(div :class "sx-eval-error" :style '
|
||||
f'"background:#fef2f2;border:1px solid #fca5a5;'
|
||||
f'color:#991b1b;padding:1rem;margin:1rem 0;'
|
||||
f'border-radius:0.5rem;font-family:monospace;white-space:pre-wrap"'
|
||||
f' (p :style "font-weight:700;margin:0 0 0.5rem" "SX EvalError in {ctx}")'
|
||||
f' (p :style "margin:0" "{msg}"))'
|
||||
)
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Registry — service → page-name → PageDef
|
||||
# ---------------------------------------------------------------------------
|
||||
@@ -511,8 +528,12 @@ async def execute_page_streaming(
|
||||
aside_sx = await _eval_slot(page_def.aside_expr, data_env, ctx) if page_def.aside_expr else ""
|
||||
menu_sx = await _eval_slot(page_def.menu_expr, data_env, ctx) if page_def.menu_expr else ""
|
||||
await _stream_queue.put(("data-single", content_sx, filter_sx, aside_sx, menu_sx))
|
||||
except EvalError as e:
|
||||
logger.error("Streaming data task failed (EvalError): %s\n%s", e, traceback.format_exc())
|
||||
error_sx = _eval_error_sx(e, "page content")
|
||||
await _stream_queue.put(("data-single", error_sx, "", "", ""))
|
||||
except Exception as e:
|
||||
logger.error("Streaming data task failed: %s", e)
|
||||
logger.error("Streaming data task failed: %s\n%s", e, traceback.format_exc())
|
||||
await _stream_queue.put(("data-done",))
|
||||
|
||||
async def _eval_headers():
|
||||
@@ -524,7 +545,7 @@ async def execute_page_streaming(
|
||||
menu = await layout.mobile_menu(tctx, **layout_kwargs)
|
||||
await _stream_queue.put(("headers", rows, menu))
|
||||
except Exception as e:
|
||||
logger.error("Streaming headers task failed: %s", e)
|
||||
logger.error("Streaming headers task failed: %s\n%s", e, traceback.format_exc())
|
||||
await _stream_queue.put(("headers", "", ""))
|
||||
|
||||
data_task = asyncio.create_task(_eval_data_and_content())
|
||||
@@ -629,7 +650,7 @@ async def execute_page_streaming(
|
||||
elif kind == "data-done":
|
||||
remaining -= 1
|
||||
except Exception as e:
|
||||
logger.error("Streaming resolve failed for %s: %s", kind, e)
|
||||
logger.error("Streaming resolve failed for %s: %s\n%s", kind, e, traceback.format_exc())
|
||||
|
||||
yield "\n</body>\n</html>"
|
||||
|
||||
@@ -733,8 +754,13 @@ async def execute_page_streaming_oob(
|
||||
await _stream_queue.put(("data-done",))
|
||||
return
|
||||
await _stream_queue.put(("data-done",))
|
||||
except EvalError as e:
|
||||
logger.error("Streaming OOB data task failed (EvalError): %s\n%s", e, traceback.format_exc())
|
||||
error_sx = _eval_error_sx(e, "page content")
|
||||
await _stream_queue.put(("data", "stream-content", error_sx))
|
||||
await _stream_queue.put(("data-done",))
|
||||
except Exception as e:
|
||||
logger.error("Streaming OOB data task failed: %s", e)
|
||||
logger.error("Streaming OOB data task failed: %s\n%s", e, traceback.format_exc())
|
||||
await _stream_queue.put(("data-done",))
|
||||
|
||||
async def _eval_oob_headers():
|
||||
@@ -745,7 +771,7 @@ async def execute_page_streaming_oob(
|
||||
else:
|
||||
await _stream_queue.put(("headers", ""))
|
||||
except Exception as e:
|
||||
logger.error("Streaming OOB headers task failed: %s", e)
|
||||
logger.error("Streaming OOB headers task failed: %s\n%s", e, traceback.format_exc())
|
||||
await _stream_queue.put(("headers", ""))
|
||||
|
||||
data_task = asyncio.create_task(_eval_data())
|
||||
@@ -836,7 +862,7 @@ async def execute_page_streaming_oob(
|
||||
elif kind == "data-done":
|
||||
remaining -= 1
|
||||
except Exception as e:
|
||||
logger.error("Streaming OOB resolve failed for %s: %s", kind, e)
|
||||
logger.error("Streaming OOB resolve failed for %s: %s\n%s", kind, e, traceback.format_exc())
|
||||
|
||||
return _stream_oob_chunks()
|
||||
|
||||
|
||||
@@ -573,3 +573,32 @@ def prim_json_encode(value) -> str:
|
||||
import json
|
||||
return json.dumps(value, indent=2)
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Scope primitives — delegate to sx_ref.py's scope stack implementation
|
||||
# (shared global state between transpiled and hand-written evaluators)
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
def _lazy_scope_primitives():
|
||||
"""Register scope/provide/collect primitives from sx_ref.py.
|
||||
|
||||
Called at import time — if sx_ref.py isn't built yet, silently skip.
|
||||
These are needed by the hand-written _aser in async_eval.py when
|
||||
expanding components that use scoped effects (e.g. ~cssx/flush).
|
||||
"""
|
||||
try:
|
||||
from .ref.sx_ref import (
|
||||
sx_collect, sx_collected, sx_clear_collected,
|
||||
sx_emitted, sx_emit, sx_context,
|
||||
)
|
||||
_PRIMITIVES["collect!"] = sx_collect
|
||||
_PRIMITIVES["collected"] = sx_collected
|
||||
_PRIMITIVES["clear-collected!"] = sx_clear_collected
|
||||
_PRIMITIVES["emitted"] = sx_emitted
|
||||
_PRIMITIVES["emit!"] = sx_emit
|
||||
_PRIMITIVES["context"] = sx_context
|
||||
except ImportError:
|
||||
pass
|
||||
|
||||
_lazy_scope_primitives()
|
||||
|
||||
|
||||
245
shared/sx/tests/test_aser_errors.py
Normal file
245
shared/sx/tests/test_aser_errors.py
Normal file
@@ -0,0 +1,245 @@
|
||||
"""Tests for aser (SX wire format) error propagation.
|
||||
|
||||
Verifies that evaluation errors inside control flow forms (case, cond, if,
|
||||
when, let, begin) propagate correctly — they must throw, not silently
|
||||
produce wrong output or fall through to :else branches.
|
||||
|
||||
This test file targets the production bug where a case body referencing an
|
||||
undefined symbol was silently swallowed, causing the case to appear to fall
|
||||
through to :else instead of raising an error.
|
||||
"""
|
||||
from __future__ import annotations
|
||||
|
||||
import pytest
|
||||
|
||||
from shared.sx.ref.sx_ref import (
|
||||
aser,
|
||||
sx_parse as parse_all,
|
||||
make_env,
|
||||
eval_expr,
|
||||
trampoline,
|
||||
serialize as sx_serialize,
|
||||
)
|
||||
from shared.sx.types import NIL, EvalError
|
||||
|
||||
|
||||
def _render_sx(source: str, env=None) -> str:
|
||||
"""Parse SX source and serialize via aser (sync)."""
|
||||
if env is None:
|
||||
env = make_env()
|
||||
exprs = parse_all(source)
|
||||
result = ""
|
||||
for expr in exprs:
|
||||
val = aser(expr, env)
|
||||
if isinstance(val, str):
|
||||
result += val
|
||||
elif val is None or val is NIL:
|
||||
pass
|
||||
else:
|
||||
result += sx_serialize(val)
|
||||
return result
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Case — matched branch errors must throw, not fall through
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
class TestCaseErrorPropagation:
|
||||
def test_matched_branch_undefined_symbol_throws(self):
|
||||
"""If the matched case body references an undefined symbol, the aser
|
||||
must throw — NOT silently skip to :else."""
|
||||
with pytest.raises(Exception, match="Undefined symbol"):
|
||||
_render_sx('(case "x" "x" undefined_sym :else "fallback")')
|
||||
|
||||
def test_else_branch_error_throws(self):
|
||||
with pytest.raises(Exception, match="Undefined symbol"):
|
||||
_render_sx('(case "miss" "x" "ok" :else undefined_sym)')
|
||||
|
||||
def test_matched_branch_nested_error_throws(self):
|
||||
"""Error inside a tag within the matched body must propagate."""
|
||||
with pytest.raises(Exception, match="Undefined symbol"):
|
||||
_render_sx('(case "a" "a" (div (p undefined_nested)) :else (p "index"))')
|
||||
|
||||
def test_unmatched_correctly_falls_through(self):
|
||||
"""Verify :else works when no clause matches (happy path)."""
|
||||
result = _render_sx('(case "miss" "x" "found" :else "fallback")')
|
||||
assert "fallback" in result
|
||||
|
||||
def test_matched_branch_succeeds(self):
|
||||
"""Verify the happy path: matched branch evaluates normally."""
|
||||
result = _render_sx('(case "ok" "ok" (p "matched") :else "fallback")')
|
||||
assert "matched" in result
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Cond — matched branch errors must throw
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
class TestCondErrorPropagation:
|
||||
def test_matched_branch_error_throws(self):
|
||||
with pytest.raises(Exception, match="Undefined symbol"):
|
||||
_render_sx('(cond true undefined_cond_sym :else "fallback")')
|
||||
|
||||
def test_else_branch_error_throws(self):
|
||||
with pytest.raises(Exception, match="Undefined symbol"):
|
||||
_render_sx('(cond false "skip" :else undefined_cond_sym)')
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# If / When — body errors must throw
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
class TestIfWhenErrorPropagation:
|
||||
def test_if_true_branch_error_throws(self):
|
||||
with pytest.raises(Exception, match="Undefined symbol"):
|
||||
_render_sx('(if true undefined_if_sym "fallback")')
|
||||
|
||||
def test_when_body_error_throws(self):
|
||||
with pytest.raises(Exception, match="Undefined symbol"):
|
||||
_render_sx('(when true undefined_when_sym)')
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Let — binding or body errors must throw
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
class TestLetErrorPropagation:
|
||||
def test_binding_error_throws(self):
|
||||
with pytest.raises(Exception, match="Undefined symbol"):
|
||||
_render_sx('(let ((x undefined_let_sym)) (p x))')
|
||||
|
||||
def test_body_error_throws(self):
|
||||
with pytest.raises(Exception, match="Undefined symbol"):
|
||||
_render_sx('(let ((x 1)) (p undefined_let_body_sym))')
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Begin/Do — body errors must throw
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
class TestBeginErrorPropagation:
|
||||
def test_do_body_error_throws(self):
|
||||
with pytest.raises(Exception, match="Undefined symbol"):
|
||||
_render_sx('(do "ok" undefined_do_sym)')
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Sync aser: components serialize WITHOUT expansion (by design)
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
class TestSyncAserComponentSerialization:
|
||||
"""The sync aser serializes component calls as SX wire format without
|
||||
expanding the body. This is correct — expansion only happens in the
|
||||
async path with expand_components=True."""
|
||||
|
||||
def test_component_in_case_serializes_without_expanding(self):
|
||||
"""Sync aser should serialize the component call, not expand it."""
|
||||
result = _render_sx(
|
||||
'(do (defcomp ~broken (&key title) (div (p title) (p no_such_helper)))'
|
||||
' (case "slug" "slug" (~broken :title "test") '
|
||||
' :else "index"))'
|
||||
)
|
||||
# Component call is serialized as SX, not expanded — no error
|
||||
assert "~broken" in result
|
||||
|
||||
def test_working_component_in_case_serializes(self):
|
||||
result = _render_sx(
|
||||
'(do (defcomp ~working (&key title) (div (p title)))'
|
||||
' (case "ok" "ok" (~working :title "hello") '
|
||||
' :else "index"))'
|
||||
)
|
||||
assert "~working" in result
|
||||
|
||||
def test_unmatched_case_falls_through_correctly(self):
|
||||
result = _render_sx(
|
||||
'(do (defcomp ~page (&key x) (div x))'
|
||||
' (case "miss" "hit" (~page :x "found") '
|
||||
' :else "index"))'
|
||||
)
|
||||
assert "index" in result
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Async aser with expand_components=True — the production path
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
class TestAsyncAserComponentExpansion:
|
||||
"""Tests the production code path: async aser with component expansion
|
||||
enabled. Errors in expanded component bodies must propagate, not be
|
||||
silently swallowed."""
|
||||
|
||||
def _async_render(self, source: str) -> str:
|
||||
"""Render via the async aser with component expansion enabled."""
|
||||
import asyncio
|
||||
from shared.sx.ref.sx_ref import async_aser, _expand_components_cv
|
||||
exprs = parse_all(source)
|
||||
env = make_env()
|
||||
|
||||
async def run():
|
||||
token = _expand_components_cv.set(True)
|
||||
try:
|
||||
result = ""
|
||||
for expr in exprs:
|
||||
val = await async_aser(expr, env, None)
|
||||
if isinstance(val, str):
|
||||
result += val
|
||||
elif val is None or val is NIL:
|
||||
pass
|
||||
else:
|
||||
result += sx_serialize(val)
|
||||
return result
|
||||
finally:
|
||||
_expand_components_cv.reset(token)
|
||||
|
||||
return asyncio.run(run())
|
||||
|
||||
def test_expanded_component_with_undefined_symbol_throws(self):
|
||||
"""When expand_components is True and the component body references
|
||||
an undefined symbol, the error must propagate — not be swallowed."""
|
||||
with pytest.raises(Exception, match="Undefined symbol"):
|
||||
self._async_render(
|
||||
'(do (defcomp ~broken (&key title) '
|
||||
' (div (p title) (p no_such_helper)))'
|
||||
' (case "slug" "slug" (~broken :title "test") '
|
||||
' :else "index"))'
|
||||
)
|
||||
|
||||
def test_expanded_working_component_succeeds(self):
|
||||
result = self._async_render(
|
||||
'(do (defcomp ~working (&key title) (div (p title)))'
|
||||
' (case "ok" "ok" (~working :title "hello") '
|
||||
' :else "index"))'
|
||||
)
|
||||
assert "hello" in result
|
||||
|
||||
def test_expanded_unmatched_falls_through(self):
|
||||
result = self._async_render(
|
||||
'(do (defcomp ~page (&key x) (div x))'
|
||||
' (case "miss" "hit" (~page :x "found") '
|
||||
' :else "index"))'
|
||||
)
|
||||
assert "index" in result
|
||||
|
||||
def test_hand_written_aser_also_propagates(self):
|
||||
"""Test the hand-written _aser in async_eval.py (the production
|
||||
path used by page rendering)."""
|
||||
import asyncio
|
||||
from shared.sx.async_eval import (
|
||||
async_eval_slot_to_sx, RequestContext,
|
||||
)
|
||||
from shared.sx.ref.sx_ref import aser
|
||||
|
||||
env = make_env()
|
||||
# Define the component via sync aser
|
||||
for expr in parse_all(
|
||||
'(defcomp ~broken (&key title) (div (p title) (p no_such_helper)))'
|
||||
):
|
||||
aser(expr, env)
|
||||
|
||||
case_expr = parse_all(
|
||||
'(case "slug" "slug" (~broken :title "test") :else "index")'
|
||||
)[0]
|
||||
ctx = RequestContext()
|
||||
|
||||
with pytest.raises(Exception, match="Undefined symbol"):
|
||||
asyncio.run(async_eval_slot_to_sx(case_expr, dict(env), ctx))
|
||||
220
shared/sx/tests/test_ocaml_bridge.py
Normal file
220
shared/sx/tests/test_ocaml_bridge.py
Normal file
@@ -0,0 +1,220 @@
|
||||
"""Tests for the OCaml SX bridge."""
|
||||
|
||||
import asyncio
|
||||
import os
|
||||
import sys
|
||||
import unittest
|
||||
|
||||
# Add project root to path
|
||||
_project_root = os.path.abspath(os.path.join(os.path.dirname(__file__), "../../.."))
|
||||
if _project_root not in sys.path:
|
||||
sys.path.insert(0, _project_root)
|
||||
|
||||
from shared.sx.ocaml_bridge import OcamlBridge, OcamlBridgeError, _escape, _parse_response, _serialize_for_ocaml
|
||||
|
||||
|
||||
class TestHelpers(unittest.TestCase):
|
||||
"""Test helper functions (no subprocess needed)."""
|
||||
|
||||
def test_escape_basic(self):
|
||||
self.assertEqual(_escape('hello'), 'hello')
|
||||
self.assertEqual(_escape('say "hi"'), 'say \\"hi\\"')
|
||||
self.assertEqual(_escape('a\\b'), 'a\\\\b')
|
||||
self.assertEqual(_escape('line\nbreak'), 'line\\nbreak')
|
||||
|
||||
def test_parse_response_ok_empty(self):
|
||||
self.assertEqual(_parse_response("(ok)"), ("ok", None))
|
||||
|
||||
def test_parse_response_ok_number(self):
|
||||
self.assertEqual(_parse_response("(ok 3)"), ("ok", "3"))
|
||||
|
||||
def test_parse_response_ok_string(self):
|
||||
kind, val = _parse_response('(ok "<div>hi</div>")')
|
||||
self.assertEqual(kind, "ok")
|
||||
self.assertEqual(val, "<div>hi</div>")
|
||||
|
||||
def test_parse_response_error(self):
|
||||
kind, val = _parse_response('(error "something broke")')
|
||||
self.assertEqual(kind, "error")
|
||||
self.assertEqual(val, "something broke")
|
||||
|
||||
def test_serialize_none(self):
|
||||
self.assertEqual(_serialize_for_ocaml(None), "nil")
|
||||
|
||||
def test_serialize_bool(self):
|
||||
self.assertEqual(_serialize_for_ocaml(True), "true")
|
||||
self.assertEqual(_serialize_for_ocaml(False), "false")
|
||||
|
||||
def test_serialize_number(self):
|
||||
self.assertEqual(_serialize_for_ocaml(42), "42")
|
||||
self.assertEqual(_serialize_for_ocaml(3.14), "3.14")
|
||||
|
||||
def test_serialize_string(self):
|
||||
self.assertEqual(_serialize_for_ocaml("hello"), '"hello"')
|
||||
self.assertEqual(_serialize_for_ocaml('say "hi"'), '"say \\"hi\\""')
|
||||
|
||||
def test_serialize_list(self):
|
||||
self.assertEqual(_serialize_for_ocaml([1, 2, 3]), "(list 1 2 3)")
|
||||
|
||||
def test_serialize_dict(self):
|
||||
result = _serialize_for_ocaml({"a": 1})
|
||||
self.assertEqual(result, "{:a 1}")
|
||||
|
||||
|
||||
class TestBridge(unittest.IsolatedAsyncioTestCase):
|
||||
"""Integration tests — require the OCaml binary to be built."""
|
||||
|
||||
@classmethod
|
||||
def setUpClass(cls):
|
||||
# Check if binary exists
|
||||
from shared.sx.ocaml_bridge import _DEFAULT_BIN
|
||||
bin_path = os.path.abspath(_DEFAULT_BIN)
|
||||
if not os.path.isfile(bin_path):
|
||||
raise unittest.SkipTest(
|
||||
f"OCaml binary not found at {bin_path}. "
|
||||
f"Build with: cd hosts/ocaml && eval $(opam env) && dune build"
|
||||
)
|
||||
|
||||
async def asyncSetUp(self):
|
||||
self.bridge = OcamlBridge()
|
||||
await self.bridge.start()
|
||||
|
||||
async def asyncTearDown(self):
|
||||
await self.bridge.stop()
|
||||
|
||||
async def test_ping(self):
|
||||
self.assertTrue(await self.bridge.ping())
|
||||
|
||||
async def test_eval_arithmetic(self):
|
||||
result = await self.bridge.eval("(+ 1 2)")
|
||||
self.assertEqual(result, "3")
|
||||
|
||||
async def test_eval_string(self):
|
||||
result = await self.bridge.eval('(str "hello" " " "world")')
|
||||
self.assertIn("hello world", result)
|
||||
|
||||
async def test_render_simple(self):
|
||||
html = await self.bridge.render('(div (p "hello"))')
|
||||
self.assertEqual(html, "<div><p>hello</p></div>")
|
||||
|
||||
async def test_render_attrs(self):
|
||||
html = await self.bridge.render('(div :class "card" (p "hi"))')
|
||||
self.assertIn('class="card"', html)
|
||||
self.assertIn("<p>hi</p>", html)
|
||||
|
||||
async def test_render_void_element(self):
|
||||
html = await self.bridge.render("(br)")
|
||||
self.assertEqual(html, "<br />")
|
||||
|
||||
async def test_load_source_defcomp(self):
|
||||
count = await self.bridge.load_source(
|
||||
'(defcomp ~test-card (&key title) (div :class "card" (h2 title)))'
|
||||
)
|
||||
self.assertEqual(count, 1)
|
||||
html = await self.bridge.render('(~test-card :title "Hello")')
|
||||
self.assertIn("Hello", html)
|
||||
self.assertIn("card", html)
|
||||
|
||||
async def test_reset(self):
|
||||
await self.bridge.load_source("(define x 42)")
|
||||
result = await self.bridge.eval("x")
|
||||
self.assertEqual(result, "42")
|
||||
await self.bridge.reset()
|
||||
with self.assertRaises(OcamlBridgeError):
|
||||
await self.bridge.eval("x")
|
||||
|
||||
async def test_render_conditional(self):
|
||||
html = await self.bridge.render('(if true (p "yes") (p "no"))')
|
||||
self.assertEqual(html, "<p>yes</p>")
|
||||
|
||||
async def test_render_let(self):
|
||||
html = await self.bridge.render('(let (x "hi") (p x))')
|
||||
self.assertEqual(html, "<p>hi</p>")
|
||||
|
||||
async def test_render_map(self):
|
||||
html = await self.bridge.render(
|
||||
"(map (lambda (x) (li x)) (list \"a\" \"b\" \"c\"))"
|
||||
)
|
||||
self.assertEqual(html, "<li>a</li><li>b</li><li>c</li>")
|
||||
|
||||
async def test_render_fragment(self):
|
||||
html = await self.bridge.render('(<> (p "a") (p "b"))')
|
||||
self.assertEqual(html, "<p>a</p><p>b</p>")
|
||||
|
||||
async def test_eval_error(self):
|
||||
with self.assertRaises(OcamlBridgeError):
|
||||
await self.bridge.eval("(undefined-symbol-xyz)")
|
||||
|
||||
async def test_render_component_with_children(self):
|
||||
await self.bridge.load_source(
|
||||
'(defcomp ~wrapper (&rest children) (div :class "wrap" children))'
|
||||
)
|
||||
html = await self.bridge.render('(~wrapper (p "inside"))')
|
||||
self.assertIn("wrap", html)
|
||||
self.assertIn("<p>inside</p>", html)
|
||||
|
||||
async def test_render_macro(self):
|
||||
await self.bridge.load_source(
|
||||
"(defmacro unless (cond &rest body) (list 'if (list 'not cond) (cons 'do body)))"
|
||||
)
|
||||
html = await self.bridge.render('(unless false (p "shown"))')
|
||||
self.assertEqual(html, "<p>shown</p>")
|
||||
|
||||
# ------------------------------------------------------------------
|
||||
# ListRef regression tests — the `list` primitive returns ListRef
|
||||
# (mutable), not List (immutable). Macro expansions that construct
|
||||
# AST via `list` produce ListRef nodes. The renderer must handle
|
||||
# both List and ListRef at every structural match point.
|
||||
# ------------------------------------------------------------------
|
||||
|
||||
async def test_render_macro_generates_cond(self):
|
||||
"""Macro that programmatically builds a (cond ...) with list."""
|
||||
await self.bridge.load_source(
|
||||
"(defmacro pick (x) "
|
||||
" (list 'cond "
|
||||
" (list (list '= x 1) '(p \"one\")) "
|
||||
" (list (list '= x 2) '(p \"two\")) "
|
||||
" (list ':else '(p \"other\"))))"
|
||||
)
|
||||
html = await self.bridge.render("(pick 2)")
|
||||
self.assertEqual(html, "<p>two</p>")
|
||||
|
||||
async def test_render_macro_generates_let(self):
|
||||
"""Macro that programmatically builds a (let ...) with list."""
|
||||
await self.bridge.load_source(
|
||||
"(defmacro with-greeting (name &rest body) "
|
||||
" (list 'let (list (list 'greeting (list 'str \"Hello \" name))) "
|
||||
" (cons 'do body)))"
|
||||
)
|
||||
html = await self.bridge.render('(with-greeting "World" (p greeting))')
|
||||
self.assertEqual(html, "<p>Hello World</p>")
|
||||
|
||||
async def test_render_macro_nested_html_tags(self):
|
||||
"""Macro expansion containing nested HTML tags via list."""
|
||||
await self.bridge.load_source(
|
||||
"(defmacro card (title &rest body) "
|
||||
" (list 'div ':class \"card\" "
|
||||
" (list 'h2 title) "
|
||||
" (cons 'do body)))"
|
||||
)
|
||||
html = await self.bridge.render('(card "Title" (p "content"))')
|
||||
self.assertIn('<div class="card">', html)
|
||||
self.assertIn("<h2>Title</h2>", html)
|
||||
self.assertIn("<p>content</p>", html)
|
||||
|
||||
async def test_render_eval_returns_listref(self):
|
||||
"""Values created at runtime via (list ...) are ListRef."""
|
||||
await self.bridge.load_source(
|
||||
"(define make-items (lambda () (list "
|
||||
' (list "a") (list "b") (list "c"))))'
|
||||
)
|
||||
html = await self.bridge.render(
|
||||
"(ul (map (lambda (x) (li (first x))) (make-items)))"
|
||||
)
|
||||
self.assertIn("<li>a</li>", html)
|
||||
self.assertIn("<li>b</li>", html)
|
||||
self.assertIn("<li>c</li>", html)
|
||||
|
||||
|
||||
if __name__ == "__main__":
|
||||
unittest.main()
|
||||
@@ -1684,62 +1684,91 @@
|
||||
;; (no nested eval-expr calls). When all args are evaluated, the
|
||||
;; HoSetupFrame dispatch in step-continue sets up the iteration frame.
|
||||
|
||||
;; ho-form-name? — is this symbol name a higher-order special form?
|
||||
(define ho-form-name?
|
||||
(fn (name)
|
||||
(or (= name "map") (= name "map-indexed") (= name "filter")
|
||||
(= name "reduce") (= name "some") (= name "every?")
|
||||
(= name "for-each"))))
|
||||
|
||||
;; ho-fn? — is this value usable as a HO callback?
|
||||
(define ho-fn?
|
||||
(fn (v) (or (callable? v) (lambda? v))))
|
||||
|
||||
;; ho-swap-args: normalise data-first arg order
|
||||
;; 2-arg forms: (coll fn) → (fn coll)
|
||||
;; 3-arg reduce: (coll fn init) → (fn init coll)
|
||||
(define ho-swap-args
|
||||
(fn (ho-type evaled)
|
||||
(if (= ho-type "reduce")
|
||||
(let ((a (first evaled))
|
||||
(b (nth evaled 1)))
|
||||
(if (and (not (ho-fn? a)) (ho-fn? b))
|
||||
(list b (nth evaled 2) a)
|
||||
evaled))
|
||||
(let ((a (first evaled))
|
||||
(b (nth evaled 1)))
|
||||
(if (and (not (ho-fn? a)) (ho-fn? b))
|
||||
(list b a)
|
||||
evaled)))))
|
||||
|
||||
;; ho-setup-dispatch: all HO args evaluated, set up iteration
|
||||
(define ho-setup-dispatch
|
||||
(fn (ho-type evaled env kont)
|
||||
(let ((f (first evaled)))
|
||||
(let ((ordered (ho-swap-args ho-type evaled)))
|
||||
(let ((f (first ordered)))
|
||||
(cond
|
||||
(= ho-type "map")
|
||||
(let ((coll (nth evaled 1)))
|
||||
(let ((coll (nth ordered 1)))
|
||||
(if (empty? coll)
|
||||
(make-cek-value (list) env kont)
|
||||
(continue-with-call f (list (first coll)) env (list)
|
||||
(kont-push (make-map-frame f (rest coll) (list) env) kont))))
|
||||
|
||||
(= ho-type "map-indexed")
|
||||
(let ((coll (nth evaled 1)))
|
||||
(let ((coll (nth ordered 1)))
|
||||
(if (empty? coll)
|
||||
(make-cek-value (list) env kont)
|
||||
(continue-with-call f (list 0 (first coll)) env (list)
|
||||
(kont-push (make-map-indexed-frame f (rest coll) (list) env) kont))))
|
||||
|
||||
(= ho-type "filter")
|
||||
(let ((coll (nth evaled 1)))
|
||||
(let ((coll (nth ordered 1)))
|
||||
(if (empty? coll)
|
||||
(make-cek-value (list) env kont)
|
||||
(continue-with-call f (list (first coll)) env (list)
|
||||
(kont-push (make-filter-frame f (rest coll) (list) (first coll) env) kont))))
|
||||
|
||||
(= ho-type "reduce")
|
||||
(let ((init (nth evaled 1))
|
||||
(coll (nth evaled 2)))
|
||||
(let ((init (nth ordered 1))
|
||||
(coll (nth ordered 2)))
|
||||
(if (empty? coll)
|
||||
(make-cek-value init env kont)
|
||||
(continue-with-call f (list init (first coll)) env (list)
|
||||
(kont-push (make-reduce-frame f (rest coll) env) kont))))
|
||||
|
||||
(= ho-type "some")
|
||||
(let ((coll (nth evaled 1)))
|
||||
(let ((coll (nth ordered 1)))
|
||||
(if (empty? coll)
|
||||
(make-cek-value false env kont)
|
||||
(continue-with-call f (list (first coll)) env (list)
|
||||
(kont-push (make-some-frame f (rest coll) env) kont))))
|
||||
|
||||
(= ho-type "every")
|
||||
(let ((coll (nth evaled 1)))
|
||||
(let ((coll (nth ordered 1)))
|
||||
(if (empty? coll)
|
||||
(make-cek-value true env kont)
|
||||
(continue-with-call f (list (first coll)) env (list)
|
||||
(kont-push (make-every-frame f (rest coll) env) kont))))
|
||||
|
||||
(= ho-type "for-each")
|
||||
(let ((coll (nth evaled 1)))
|
||||
(let ((coll (nth ordered 1)))
|
||||
(if (empty? coll)
|
||||
(make-cek-value nil env kont)
|
||||
(continue-with-call f (list (first coll)) env (list)
|
||||
(kont-push (make-for-each-frame f (rest coll) env) kont))))
|
||||
|
||||
:else (error (str "Unknown HO type: " ho-type))))))
|
||||
:else (error (str "Unknown HO type: " ho-type)))))))
|
||||
|
||||
(define step-ho-map
|
||||
(fn (args env kont)
|
||||
@@ -1965,24 +1994,36 @@
|
||||
(make-cek-value value fenv rest-k)
|
||||
;; Apply next form to value
|
||||
(let ((form (first remaining))
|
||||
(rest-forms (rest remaining)))
|
||||
(let ((result (if (= (type-of form) "list")
|
||||
(let ((f (trampoline (eval-expr (first form) fenv)))
|
||||
(rargs (map (fn (a) (trampoline (eval-expr a fenv))) (rest form)))
|
||||
(all-args (cons value rargs)))
|
||||
(cond
|
||||
(and (callable? f) (not (lambda? f))) (apply f all-args)
|
||||
(lambda? f) (trampoline (call-lambda f all-args fenv))
|
||||
:else (error (str "-> form not callable: " (inspect f)))))
|
||||
(let ((f (trampoline (eval-expr form fenv))))
|
||||
(cond
|
||||
(and (callable? f) (not (lambda? f))) (f value)
|
||||
(lambda? f) (trampoline (call-lambda f (list value) fenv))
|
||||
:else (error (str "-> form not callable: " (inspect f))))))))
|
||||
(if (empty? rest-forms)
|
||||
(make-cek-value result fenv rest-k)
|
||||
(make-cek-value result fenv
|
||||
(kont-push (make-thread-frame rest-forms fenv) rest-k)))))))
|
||||
(rest-forms (rest remaining))
|
||||
(new-kont (if (empty? (rest remaining)) rest-k
|
||||
(kont-push (make-thread-frame (rest remaining) fenv) rest-k))))
|
||||
;; Check if form is a HO call like (map fn)
|
||||
(if (and (= (type-of form) "list")
|
||||
(not (empty? form))
|
||||
(= (type-of (first form)) "symbol")
|
||||
(ho-form-name? (symbol-name (first form))))
|
||||
;; HO form — splice value as quoted arg, dispatch via CEK
|
||||
(make-cek-state
|
||||
(cons (first form) (cons (list 'quote value) (rest form)))
|
||||
fenv new-kont)
|
||||
;; Normal: tree-walk eval + apply
|
||||
(let ((result (if (= (type-of form) "list")
|
||||
(let ((f (trampoline (eval-expr (first form) fenv)))
|
||||
(rargs (map (fn (a) (trampoline (eval-expr a fenv))) (rest form)))
|
||||
(all-args (cons value rargs)))
|
||||
(cond
|
||||
(and (callable? f) (not (lambda? f))) (apply f all-args)
|
||||
(lambda? f) (trampoline (call-lambda f all-args fenv))
|
||||
:else (error (str "-> form not callable: " (inspect f)))))
|
||||
(let ((f (trampoline (eval-expr form fenv))))
|
||||
(cond
|
||||
(and (callable? f) (not (lambda? f))) (f value)
|
||||
(lambda? f) (trampoline (call-lambda f (list value) fenv))
|
||||
:else (error (str "-> form not callable: " (inspect f))))))))
|
||||
(if (empty? rest-forms)
|
||||
(make-cek-value result fenv rest-k)
|
||||
(make-cek-value result fenv
|
||||
(kont-push (make-thread-frame rest-forms fenv) rest-k))))))))
|
||||
|
||||
;; --- ArgFrame: head or arg evaluated ---
|
||||
(= ft "arg")
|
||||
|
||||
697
spec/tests/test-cek-advanced.sx
Normal file
697
spec/tests/test-cek-advanced.sx
Normal file
@@ -0,0 +1,697 @@
|
||||
;; ==========================================================================
|
||||
;; test-cek-advanced.sx — Advanced stress tests for the CEK machine evaluator
|
||||
;;
|
||||
;; Exercises complex evaluation patterns that stress the step/continue
|
||||
;; dispatch loop: deep nesting, higher-order forms, macro expansion in
|
||||
;; the CEK context, environment pressure, and subtle edge cases.
|
||||
;;
|
||||
;; Requires: test-framework.sx, frames.sx, cek.sx loaded.
|
||||
;; Helpers: cek-eval (source string → value via eval-expr-cek).
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 1. Deep nesting
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "cek-deep-nesting"
|
||||
(deftest "deeply nested let — 5 levels"
|
||||
;; Each let layer adds a binding; innermost body sees all of them.
|
||||
(assert-equal 15
|
||||
(cek-eval
|
||||
"(let ((a 1))
|
||||
(let ((b 2))
|
||||
(let ((c 3))
|
||||
(let ((d 4))
|
||||
(let ((e 5))
|
||||
(+ a b c d e))))))")))
|
||||
|
||||
(deftest "deeply nested let — 7 levels with shadowing"
|
||||
;; x is rebound at each level; innermost sees 7.
|
||||
(assert-equal 7
|
||||
(cek-eval
|
||||
"(let ((x 1))
|
||||
(let ((x 2))
|
||||
(let ((x 3))
|
||||
(let ((x 4))
|
||||
(let ((x 5))
|
||||
(let ((x 6))
|
||||
(let ((x 7))
|
||||
x)))))))")))
|
||||
|
||||
(deftest "deeply nested if — 5 levels"
|
||||
;; All true branches taken; value propagates through every level.
|
||||
(assert-equal 42
|
||||
(cek-eval
|
||||
"(if true
|
||||
(if true
|
||||
(if true
|
||||
(if true
|
||||
(if true
|
||||
42
|
||||
0)
|
||||
0)
|
||||
0)
|
||||
0)
|
||||
0)")))
|
||||
|
||||
(deftest "deeply nested if — alternating true/false reaching else"
|
||||
;; Outer true → inner false → its else → next true → final value.
|
||||
(assert-equal "deep"
|
||||
(cek-eval
|
||||
"(if true
|
||||
(if false
|
||||
\"wrong\"
|
||||
(if true
|
||||
(if false
|
||||
\"also-wrong\"
|
||||
(if true \"deep\" \"no\"))
|
||||
\"bad\"))
|
||||
\"outer-else\")")))
|
||||
|
||||
(deftest "deeply nested function calls f(g(h(x)))"
|
||||
;; Three composed single-arg functions: inc, double, square.
|
||||
;; square(double(inc(3))) = square(double(4)) = square(8) = 64
|
||||
(assert-equal 64
|
||||
(cek-eval
|
||||
"(do
|
||||
(define inc-fn (fn (x) (+ x 1)))
|
||||
(define double-fn (fn (x) (* x 2)))
|
||||
(define square-fn (fn (x) (* x x)))
|
||||
(square-fn (double-fn (inc-fn 3))))")))
|
||||
|
||||
(deftest "5-level deeply nested function call chain"
|
||||
;; f1(f2(f3(f4(f5(0))))) with each adding 10.
|
||||
(assert-equal 50
|
||||
(cek-eval
|
||||
"(do
|
||||
(define f1 (fn (x) (+ x 10)))
|
||||
(define f2 (fn (x) (+ x 10)))
|
||||
(define f3 (fn (x) (+ x 10)))
|
||||
(define f4 (fn (x) (+ x 10)))
|
||||
(define f5 (fn (x) (+ x 10)))
|
||||
(f1 (f2 (f3 (f4 (f5 0))))))")))
|
||||
|
||||
(deftest "deep begin/do chain — 6 sequential expressions"
|
||||
;; All expressions evaluated; last value returned.
|
||||
(assert-equal 60
|
||||
(cek-eval
|
||||
"(do
|
||||
(define acc 0)
|
||||
(set! acc (+ acc 10))
|
||||
(set! acc (+ acc 10))
|
||||
(set! acc (+ acc 10))
|
||||
(set! acc (+ acc 10))
|
||||
(set! acc (+ acc 10))
|
||||
(set! acc (+ acc 10))
|
||||
acc)")))
|
||||
|
||||
(deftest "let inside if inside let inside cond"
|
||||
;; cond dispatches → outer let binds → if selects → inner let computes.
|
||||
(assert-equal 30
|
||||
(cek-eval
|
||||
"(let ((mode \"go\"))
|
||||
(cond
|
||||
(= mode \"stop\") -1
|
||||
(= mode \"go\")
|
||||
(let ((base 10))
|
||||
(if (> base 5)
|
||||
(let ((factor 3))
|
||||
(* base factor))
|
||||
0))
|
||||
:else 0))"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 2. Complex call patterns
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "cek-complex-calls"
|
||||
(deftest "higher-order function returning higher-order function"
|
||||
;; make-adder-factory returns a factory that makes adders.
|
||||
;; Exercises three closure levels in the CEK call handler.
|
||||
(assert-equal 115
|
||||
(cek-eval
|
||||
"(do
|
||||
(define make-adder-factory
|
||||
(fn (base)
|
||||
(fn (offset)
|
||||
(fn (x) (+ base offset x)))))
|
||||
(let ((factory (make-adder-factory 100)))
|
||||
(let ((add-10 (factory 10)))
|
||||
(add-10 5))))")))
|
||||
|
||||
(deftest "curried multiplication — 3 application levels"
|
||||
;; ((mul a) b) c — each level returns a lambda.
|
||||
(assert-equal 60
|
||||
(cek-eval
|
||||
"(do
|
||||
(define mul3
|
||||
(fn (a) (fn (b) (fn (c) (* a b c)))))
|
||||
(((mul3 3) 4) 5))")))
|
||||
|
||||
(deftest "function applied to itself — omega-like (non-diverging)"
|
||||
;; self-apply passes f to f; f ignores its argument and returns a value.
|
||||
;; Tests that call dispatch handles (f f) correctly.
|
||||
(assert-equal "done"
|
||||
(cek-eval
|
||||
"(do
|
||||
(define self-apply (fn (f) (f f)))
|
||||
(define const-done (fn (anything) \"done\"))
|
||||
(self-apply const-done))")))
|
||||
|
||||
(deftest "Y-combinator-like: recursive factorial without define"
|
||||
;; The Z combinator (strict Y) enables self-reference via argument.
|
||||
;; Tests that CEK handles the double-application (f f) correctly.
|
||||
(assert-equal 120
|
||||
(cek-eval
|
||||
"(do
|
||||
(define Z
|
||||
(fn (f)
|
||||
((fn (x) (f (fn (v) ((x x) v))))
|
||||
(fn (x) (f (fn (v) ((x x) v)))))))
|
||||
(define fact
|
||||
(Z (fn (self)
|
||||
(fn (n)
|
||||
(if (<= n 1) 1 (* n (self (- n 1))))))))
|
||||
(fact 5))")))
|
||||
|
||||
(deftest "recursive tree traversal via nested lists"
|
||||
;; A tree is a (value left right) triple or nil leaf.
|
||||
;; Sum all leaf values: (3 (1 nil nil) (2 nil nil)) → 6.
|
||||
(assert-equal 6
|
||||
(cek-eval
|
||||
"(do
|
||||
(define tree-sum
|
||||
(fn (node)
|
||||
(if (nil? node)
|
||||
0
|
||||
(let ((val (nth node 0))
|
||||
(left (nth node 1))
|
||||
(right (nth node 2)))
|
||||
(+ val (tree-sum left) (tree-sum right))))))
|
||||
(let ((tree
|
||||
(list 3
|
||||
(list 1 nil nil)
|
||||
(list 2 nil nil))))
|
||||
(tree-sum tree)))")))
|
||||
|
||||
(deftest "mutual recursion through 3 functions"
|
||||
;; f → g → h → f cycle, counting down to 0.
|
||||
;; Tests that CEK handles cross-name call dispatch across 3 branches.
|
||||
(assert-equal "zero"
|
||||
(cek-eval
|
||||
"(do
|
||||
(define f (fn (n) (if (<= n 0) \"zero\" (g (- n 1)))))
|
||||
(define g (fn (n) (if (<= n 0) \"zero\" (h (- n 1)))))
|
||||
(define h (fn (n) (if (<= n 0) \"zero\" (f (- n 1)))))
|
||||
(f 9))")))
|
||||
|
||||
(deftest "higher-order composition pipeline"
|
||||
;; A list of single-arg functions applied in sequence via reduce.
|
||||
;; Tests map + reduce + closure interaction in a single CEK run.
|
||||
(assert-equal 30
|
||||
(cek-eval
|
||||
"(do
|
||||
(define pipeline
|
||||
(fn (fns init)
|
||||
(reduce (fn (acc f) (f acc)) init fns)))
|
||||
(let ((steps (list
|
||||
(fn (x) (* x 2))
|
||||
(fn (x) (+ x 5))
|
||||
(fn (x) (* x 2)))))
|
||||
(pipeline steps 5)))")))
|
||||
|
||||
(deftest "variable-arity: function ignoring nil-padded extra args"
|
||||
;; Caller provides more args than the param list; excess are ignored.
|
||||
;; The CEK call frame must bind declared params and discard extras.
|
||||
(assert-equal 3
|
||||
(cek-eval
|
||||
"(do
|
||||
(define first-two (fn (a b) (+ a b)))
|
||||
(first-two 1 2))"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 3. Macro interaction
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "cek-macro-interaction"
|
||||
(deftest "macro that generates an if expression"
|
||||
;; my-unless wraps its condition in (not ...) and emits an if.
|
||||
;; CEK must expand the macro then step through the resulting if form.
|
||||
(assert-equal "ran"
|
||||
(cek-eval
|
||||
"(do
|
||||
(defmacro my-unless (cond-expr then-expr)
|
||||
\`(if (not ,cond-expr) ,then-expr nil))
|
||||
(my-unless false \"ran\"))")))
|
||||
|
||||
(deftest "macro that generates a cond expression"
|
||||
;; pick-label expands to a cond clause tree.
|
||||
(assert-equal "medium"
|
||||
(cek-eval
|
||||
"(do
|
||||
(defmacro classify-num (n)
|
||||
\`(cond (< ,n 0) \"negative\"
|
||||
(< ,n 10) \"small\"
|
||||
(< ,n 100) \"medium\"
|
||||
:else \"large\"))
|
||||
(classify-num 42))")))
|
||||
|
||||
(deftest "macro that generates let bindings"
|
||||
;; bind-pair expands to a two-binding let wrapping its body.
|
||||
(assert-equal 7
|
||||
(cek-eval
|
||||
"(do
|
||||
(defmacro bind-pair (a av b bv body)
|
||||
\`(let ((,a ,av) (,b ,bv)) ,body))
|
||||
(bind-pair x 3 y 4 (+ x y)))")))
|
||||
|
||||
(deftest "macro inside macro expansion (chained expansion)"
|
||||
;; outer-mac expands to a call of inner-mac, which is also a macro.
|
||||
;; CEK must re-enter step-eval after each expansion.
|
||||
(assert-equal 20
|
||||
(cek-eval
|
||||
"(do
|
||||
(defmacro double-it (x) \`(* ,x 2))
|
||||
(defmacro quadruple-it (x) \`(double-it (double-it ,x)))
|
||||
(quadruple-it 5))")))
|
||||
|
||||
(deftest "macro with quasiquote and splice in complex position"
|
||||
;; wrap-args splices its rest args into a list call.
|
||||
(assert-equal (list 1 2 3 4)
|
||||
(cek-eval
|
||||
"(do
|
||||
(defmacro wrap-args (&rest items)
|
||||
\`(list ,@items))
|
||||
(wrap-args 1 2 3 4))")))
|
||||
|
||||
(deftest "macro generating a define"
|
||||
;; defconst expands to a define, introducing a binding into env.
|
||||
(assert-equal 99
|
||||
(cek-eval
|
||||
"(do
|
||||
(defmacro defconst (name val)
|
||||
\`(define ,name ,val))
|
||||
(defconst answer 99)
|
||||
answer)")))
|
||||
|
||||
(deftest "macro used inside lambda body"
|
||||
;; The macro is expanded each time the lambda is called.
|
||||
(assert-equal (list 2 4 6)
|
||||
(cek-eval
|
||||
"(do
|
||||
(defmacro double-it (x) \`(* 2 ,x))
|
||||
(let ((double-fn (fn (n) (double-it n))))
|
||||
(map double-fn (list 1 2 3))))")))
|
||||
|
||||
(deftest "nested macro call — macro output feeds another macro"
|
||||
;; negate-add: (negate-add a b) → (- (+ a b))
|
||||
;; Expands in two macro steps; CEK must loop through both.
|
||||
(assert-equal -7
|
||||
(cek-eval
|
||||
"(do
|
||||
(defmacro my-add (a b) \`(+ ,a ,b))
|
||||
(defmacro negate-add (a b) \`(- (my-add ,a ,b)))
|
||||
(negate-add 3 4))"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 4. Environment stress
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "cek-environment-stress"
|
||||
(deftest "10 bindings in a single let — all accessible"
|
||||
;; One large let frame; CEK env-extend must handle all 10 at once.
|
||||
(assert-equal 55
|
||||
(cek-eval
|
||||
"(let ((a 1) (b 2) (c 3) (d 4) (e 5)
|
||||
(f 6) (g 7) (h 8) (i 9) (j 10))
|
||||
(+ a b c d e f g h i j))")))
|
||||
|
||||
(deftest "10 bindings — correct value for each binding"
|
||||
;; Spot-check that the env frame stores each binding at the right slot.
|
||||
(assert-equal "ok"
|
||||
(cek-eval
|
||||
"(let ((v1 \"a\") (v2 \"b\") (v3 \"c\") (v4 \"d\") (v5 \"e\")
|
||||
(v6 \"f\") (v7 \"g\") (v8 \"h\") (v9 \"i\") (v10 \"j\"))
|
||||
(if (and (= v1 \"a\") (= v5 \"e\") (= v10 \"j\"))
|
||||
\"ok\"
|
||||
\"fail\"))")))
|
||||
|
||||
(deftest "shadowing chain — x shadows x shadows x (3 levels)"
|
||||
;; After 3 let layers, x == 3; unwinding restores x at each level.
|
||||
;; Inner let must not mutate the outer env frames.
|
||||
(assert-equal (list 3 2 1)
|
||||
(cek-eval
|
||||
"(let ((results (list)))
|
||||
(let ((x 1))
|
||||
(let ((x 2))
|
||||
(let ((x 3))
|
||||
(append! results x)) ;; records 3
|
||||
(append! results x)) ;; records 2 after inner unwinds
|
||||
(append! results x)) ;; records 1 after middle unwinds
|
||||
results)")))
|
||||
|
||||
(deftest "closure capturing 5 variables from enclosing let"
|
||||
;; All 5 captured vars remain accessible after the let exits.
|
||||
(assert-equal 150
|
||||
(cek-eval
|
||||
"(do
|
||||
(define make-closure
|
||||
(fn ()
|
||||
(let ((a 10) (b 20) (c 30) (d 40) (e 50))
|
||||
(fn () (+ a b c d e)))))
|
||||
(let ((f (make-closure)))
|
||||
(f)))")))
|
||||
|
||||
(deftest "set! visible through 3 closure levels"
|
||||
;; Top-level define → lambda → lambda → lambda modifies top binding.
|
||||
;; CEK set! must walk the env chain and find the outermost slot.
|
||||
(assert-equal 999
|
||||
(cek-eval
|
||||
"(do
|
||||
(define shared 0)
|
||||
(define make-level1
|
||||
(fn ()
|
||||
(fn ()
|
||||
(fn ()
|
||||
(set! shared 999)))))
|
||||
(let ((level2 (make-level1)))
|
||||
(let ((level3 (level2)))
|
||||
(level3)))
|
||||
shared)")))
|
||||
|
||||
(deftest "define inside let inside define — scope chain"
|
||||
;; outer define → let body → inner define. The inner define mutates
|
||||
;; the env that the let body executes in; later exprs must see it.
|
||||
(assert-equal 42
|
||||
(cek-eval
|
||||
"(do
|
||||
(define outer-fn
|
||||
(fn (base)
|
||||
(let ((step 1))
|
||||
(define result (* base step))
|
||||
(set! result (+ result 1))
|
||||
result)))
|
||||
(outer-fn 41))")))
|
||||
|
||||
(deftest "env not polluted across sibling lambda calls"
|
||||
;; Two separate calls to the same lambda must not share param state.
|
||||
(assert-equal (list 10 20)
|
||||
(cek-eval
|
||||
"(do
|
||||
(define f (fn (x) (* x 2)))
|
||||
(list (f 5) (f 10)))")))
|
||||
|
||||
(deftest "large closure env — 8 closed-over variables"
|
||||
;; A lambda closing over 8 variables; all used in the body.
|
||||
(assert-equal 36
|
||||
(cek-eval
|
||||
"(let ((a 1) (b 2) (c 3) (d 4) (e 5) (f 6) (g 7) (h 8))
|
||||
(let ((sum-all (fn () (+ a b c d e f g h))))
|
||||
(sum-all)))"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 5. Edge cases
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "cek-edge-cases"
|
||||
(deftest "empty begin/do returns nil"
|
||||
;; The step-sf-begin handler with an empty arg list must yield nil.
|
||||
(assert-nil (cek-eval "(do)")))
|
||||
|
||||
(deftest "single-expression begin/do returns value"
|
||||
;; A do with exactly one expression is equivalent to that expression.
|
||||
(assert-equal 42 (cek-eval "(do 42)")))
|
||||
|
||||
(deftest "begin/do with side-effecting expressions returns last"
|
||||
;; All intermediate expressions run; only the last value is kept.
|
||||
(assert-equal "last"
|
||||
(cek-eval "(do \"first\" \"middle\" \"last\")")))
|
||||
|
||||
(deftest "if with only true branch — false path returns nil"
|
||||
;; No else clause: the make-if-frame must default else to nil.
|
||||
(assert-nil (cek-eval "(if false 42)")))
|
||||
|
||||
(deftest "if with only true branch — true path returns value"
|
||||
(assert-equal 7 (cek-eval "(if true 7)")))
|
||||
|
||||
(deftest "and with all truthy values returns last"
|
||||
;; SX and: short-circuit stops at first falsy; last truthy is returned.
|
||||
(assert-equal "c"
|
||||
(cek-eval "(and \"a\" \"b\" \"c\")")))
|
||||
|
||||
(deftest "and with leading falsy short-circuits — returns false"
|
||||
(assert-false (cek-eval "(and 1 false 3)")))
|
||||
|
||||
(deftest "and with no args returns true"
|
||||
(assert-true (cek-eval "(and)")))
|
||||
|
||||
(deftest "or with all falsy returns last falsy"
|
||||
;; SX or: if all falsy, the last falsy value is returned.
|
||||
(assert-false (cek-eval "(or false false false)")))
|
||||
|
||||
(deftest "or returns first truthy value"
|
||||
(assert-equal 1 (cek-eval "(or false nil 1 2 3)")))
|
||||
|
||||
(deftest "or with no args returns false"
|
||||
(assert-false (cek-eval "(or)")))
|
||||
|
||||
(deftest "keyword evaluated as string in call position"
|
||||
;; A keyword in non-call position evaluates to its string name.
|
||||
(assert-equal "color"
|
||||
(cek-eval "(let ((k :color)) k)")))
|
||||
|
||||
(deftest "keyword as dict key in evaluation context"
|
||||
;; Dict literal with keyword key; the keyword must be converted to
|
||||
;; string so (get d \"color\") succeeds.
|
||||
(assert-equal "red"
|
||||
(cek-eval
|
||||
"(let ((d {:color \"red\"}))
|
||||
(get d \"color\"))")))
|
||||
|
||||
(deftest "quote preserves list structure — no evaluation inside"
|
||||
;; (quote (+ 1 2)) must return the list (+ 1 2), not 3.
|
||||
(assert-equal 3
|
||||
(cek-eval "(len (quote (+ 1 2)))")))
|
||||
|
||||
(deftest "quote preserves nested structure"
|
||||
;; Deeply nested quoted form is returned verbatim as a list tree.
|
||||
(assert-equal 2
|
||||
(cek-eval "(len (quote (a (b c))))")))
|
||||
|
||||
(deftest "quasiquote with nested unquote"
|
||||
;; `(a ,(+ 1 2) c) → the list (a 3 c).
|
||||
(assert-equal 3
|
||||
(cek-eval
|
||||
"(let ((x (+ 1 2)))
|
||||
(nth \`(a ,x c) 1))")))
|
||||
|
||||
(deftest "quasiquote with splice — list flattened into result"
|
||||
;; `(1 ,@(list 2 3) 4) → (1 2 3 4).
|
||||
(assert-equal (list 1 2 3 4)
|
||||
(cek-eval
|
||||
"(let ((mid (list 2 3)))
|
||||
\`(1 ,@mid 4))")))
|
||||
|
||||
(deftest "quasiquote with nested unquote-splice at multiple positions"
|
||||
;; Mixed literal and spliced elements across the template.
|
||||
(assert-equal (list 0 1 2 3 10 11 12 99)
|
||||
(cek-eval
|
||||
"(let ((xs (list 1 2 3))
|
||||
(ys (list 10 11 12)))
|
||||
\`(0 ,@xs ,@ys 99))")))
|
||||
|
||||
(deftest "cond with no matching clause returns nil"
|
||||
;; No branch taken, no :else → nil.
|
||||
(assert-nil
|
||||
(cek-eval "(cond false \"a\" false \"b\")")))
|
||||
|
||||
(deftest "nested cond: outer selects branch, inner dispatches value"
|
||||
;; Two cond forms nested; CEK must handle the double-dispatch.
|
||||
(assert-equal "cold"
|
||||
(cek-eval
|
||||
"(let ((season \"winter\") (temp -5))
|
||||
(cond
|
||||
(= season \"winter\")
|
||||
(cond (< temp 0) \"cold\"
|
||||
:else \"cool\")
|
||||
(= season \"summer\") \"hot\"
|
||||
:else \"mild\"))")))
|
||||
|
||||
(deftest "lambda with no params — nullary function"
|
||||
;; () → 42 via CEK call dispatch with empty arg list.
|
||||
(assert-equal 42
|
||||
(cek-eval "((fn () 42))")))
|
||||
|
||||
(deftest "immediately invoked lambda with multiple body forms"
|
||||
;; IIFE with a do-style body; last expression is the value.
|
||||
(assert-equal 6
|
||||
(cek-eval
|
||||
"((fn ()
|
||||
(define a 1)
|
||||
(define b 2)
|
||||
(define c 3)
|
||||
(+ a b c)))")))
|
||||
|
||||
(deftest "thread-first through 5 steps"
|
||||
;; (-> 1 (+ 1) (* 3) (+ 1) (* 2) (- 2))
|
||||
;; 1+1=2, *3=6, +1=7, *2=14, 14-2=12
|
||||
;; Tests that each -> step creates the correct frame and threads value.
|
||||
(assert-equal 12
|
||||
(cek-eval "(-> 1 (+ 1) (* 3) (+ 1) (* 2) (- 2))")))
|
||||
|
||||
(deftest "case falls through to :else"
|
||||
(assert-equal "unknown"
|
||||
(cek-eval "(case 99 1 \"one\" 2 \"two\" :else \"unknown\")")))
|
||||
|
||||
(deftest "case with no :else and no match returns nil"
|
||||
(assert-nil (cek-eval "(case 99 1 \"one\" 2 \"two\")")))
|
||||
|
||||
(deftest "when with multiple body forms returns last"
|
||||
(assert-equal "last"
|
||||
(cek-eval "(when true \"first\" \"middle\" \"last\")")))
|
||||
|
||||
(deftest "when false body not evaluated — no side effects"
|
||||
(assert-equal 0
|
||||
(cek-eval
|
||||
"(do
|
||||
(define side-ct 0)
|
||||
(when false (set! side-ct 1))
|
||||
side-ct)")))
|
||||
|
||||
(deftest "define followed by symbol lookup returns bound value"
|
||||
;; define evaluates its RHS and returns the value.
|
||||
;; The subsequent symbol reference must find the binding in env.
|
||||
(assert-equal 7
|
||||
(cek-eval "(do (define q 7) q)")))
|
||||
|
||||
(deftest "set! in deeply nested scope updates the correct frame"
|
||||
;; set! inside a 4-level let must find the binding defined at level 1.
|
||||
(assert-equal 100
|
||||
(cek-eval
|
||||
"(let ((target 0))
|
||||
(let ((a 1))
|
||||
(let ((b 2))
|
||||
(let ((c 3))
|
||||
(set! target 100))))
|
||||
target)")))
|
||||
|
||||
(deftest "list literal (non-call) evaluated element-wise"
|
||||
;; A list whose head is a number — treated as data list, not a call.
|
||||
;; All elements are evaluated; numbers pass through unchanged.
|
||||
(assert-equal 3
|
||||
(cek-eval "(len (list 10 20 30))")))
|
||||
|
||||
(deftest "recursive fibonacci — tests non-tail call frame stacking"
|
||||
;; fib(7) = 13. Non-tail recursion stacks O(n) CEK frames; tests
|
||||
;; that the continuation frame list handles deep frame accumulation.
|
||||
(assert-equal 13
|
||||
(cek-eval
|
||||
"(do
|
||||
(define fib
|
||||
(fn (n)
|
||||
(if (< n 2)
|
||||
n
|
||||
(+ (fib (- n 1)) (fib (- n 2))))))
|
||||
(fib 7))"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 8. Data-first higher-order forms
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "data-first-ho"
|
||||
(deftest "map — data-first arg order"
|
||||
(assert-equal (list 2 4 6)
|
||||
(map (list 1 2 3) (fn (x) (* x 2)))))
|
||||
|
||||
(deftest "filter — data-first arg order"
|
||||
(assert-equal (list 3 4 5)
|
||||
(filter (list 1 2 3 4 5) (fn (x) (> x 2)))))
|
||||
|
||||
(deftest "reduce — data-first arg order"
|
||||
(assert-equal 10
|
||||
(reduce (list 1 2 3 4) + 0)))
|
||||
|
||||
(deftest "some — data-first arg order"
|
||||
(assert-true
|
||||
(some (list 1 2 3) (fn (x) (> x 2))))
|
||||
(assert-false
|
||||
(some (list 1 2 3) (fn (x) (> x 5)))))
|
||||
|
||||
(deftest "every? — data-first arg order"
|
||||
(assert-true
|
||||
(every? (list 2 4 6) (fn (x) (> x 1))))
|
||||
(assert-false
|
||||
(every? (list 2 4 6) (fn (x) (> x 3)))))
|
||||
|
||||
(deftest "for-each — data-first arg order"
|
||||
(let ((acc (list)))
|
||||
(for-each (list 10 20 30)
|
||||
(fn (x) (set! acc (append acc (list x)))))
|
||||
(assert-equal (list 10 20 30) acc)))
|
||||
|
||||
(deftest "map-indexed — data-first arg order"
|
||||
(assert-equal (list "0:a" "1:b" "2:c")
|
||||
(map-indexed (list "a" "b" "c")
|
||||
(fn (i v) (str i ":" v)))))
|
||||
|
||||
(deftest "fn-first still works — map"
|
||||
(assert-equal (list 2 4 6)
|
||||
(map (fn (x) (* x 2)) (list 1 2 3))))
|
||||
|
||||
(deftest "fn-first still works — reduce"
|
||||
(assert-equal 10
|
||||
(reduce + 0 (list 1 2 3 4)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 9. Threading with HO forms
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "thread-ho"
|
||||
(deftest "-> map"
|
||||
(assert-equal (list 2 4 6)
|
||||
(-> (list 1 2 3) (map (fn (x) (* x 2))))))
|
||||
|
||||
(deftest "-> filter"
|
||||
(assert-equal (list 3 4 5)
|
||||
(-> (list 1 2 3 4 5) (filter (fn (x) (> x 2))))))
|
||||
|
||||
(deftest "-> filter then map pipeline"
|
||||
(assert-equal (list 30 40 50)
|
||||
(-> (list 1 2 3 4 5)
|
||||
(filter (fn (x) (> x 2)))
|
||||
(map (fn (x) (* x 10))))))
|
||||
|
||||
(deftest "-> reduce"
|
||||
(assert-equal 15
|
||||
(-> (list 1 2 3 4 5) (reduce + 0))))
|
||||
|
||||
(deftest "-> map then reduce"
|
||||
(assert-equal 12
|
||||
(-> (list 1 2 3)
|
||||
(map (fn (x) (* x 2)))
|
||||
(reduce + 0))))
|
||||
|
||||
(deftest "-> some"
|
||||
(assert-true
|
||||
(-> (list 1 2 3) (some (fn (x) (> x 2)))))
|
||||
(assert-false
|
||||
(-> (list 1 2 3) (some (fn (x) (> x 5))))))
|
||||
|
||||
(deftest "-> every?"
|
||||
(assert-true
|
||||
(-> (list 2 4 6) (every? (fn (x) (> x 1))))))
|
||||
|
||||
(deftest "-> full pipeline: map filter reduce"
|
||||
;; Double each, keep > 4, sum
|
||||
(assert-equal 24
|
||||
(-> (list 1 2 3 4 5)
|
||||
(map (fn (x) (* x 2)))
|
||||
(filter (fn (x) (> x 4)))
|
||||
(reduce + 0)))))
|
||||
368
spec/tests/test-continuations-advanced.sx
Normal file
368
spec/tests/test-continuations-advanced.sx
Normal file
@@ -0,0 +1,368 @@
|
||||
;; ==========================================================================
|
||||
;; test-continuations-advanced.sx — Stress tests for multi-shot continuations
|
||||
;; and frame-based dynamic scope
|
||||
;;
|
||||
;; Requires: test-framework.sx loaded, continuations + scope extensions enabled.
|
||||
;;
|
||||
;; Tests the CEK continuation + ProvideFrame/ScopeAccFrame system under:
|
||||
;; - Multi-shot (k invoked 0, 1, 2, 3+ times)
|
||||
;; - Continuation composition across nested resets
|
||||
;; - provide/context: dynamic variable binding via kont walk
|
||||
;; - provide values preserved across shift/resume
|
||||
;; - scope/emit!/emitted: accumulator frames in kont
|
||||
;; - Accumulator frames preserved across shift/resume
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 1. Multi-shot continuations
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "multi-shot-continuations"
|
||||
(deftest "k invoked 3 times returns list of results"
|
||||
;; Each (k N) resumes (+ 1 N) independently.
|
||||
;; Shift body collects all three results into a list.
|
||||
(assert-equal (list 11 21 31)
|
||||
(reset (+ 1 (shift k (list (k 10) (k 20) (k 30)))))))
|
||||
|
||||
(deftest "k invoked via map over input list"
|
||||
;; map applies k to each element; each resume computes (+ 1 elem).
|
||||
(assert-equal (list 11 21 31)
|
||||
(reset (+ 1 (shift k (map k (list 10 20 30)))))))
|
||||
|
||||
(deftest "k invoked zero times — abort with plain value"
|
||||
;; Shift body ignores k and returns 42 directly.
|
||||
;; The outer (+ 1 ...) hole is never filled.
|
||||
(assert-equal 42
|
||||
(reset (+ 1 (shift k 42)))))
|
||||
|
||||
(deftest "k invoked conditionally — true branch calls k"
|
||||
;; Only the true branch calls k; result is (+ 1 10) = 11.
|
||||
(assert-equal 11
|
||||
(reset (+ 1 (shift k (if true (k 10) 99))))))
|
||||
|
||||
(deftest "k invoked conditionally — false branch skips k"
|
||||
;; False branch returns 99 directly without invoking k.
|
||||
(assert-equal 99
|
||||
(reset (+ 1 (shift k (if false (k 10) 99))))))
|
||||
|
||||
(deftest "k invoked inside let binding"
|
||||
;; (k 5) = (+ 1 5) = 6; x is bound to 6; (* x 2) = 12.
|
||||
(assert-equal 12
|
||||
(reset (+ 1 (shift k (let ((x (k 5))) (* x 2)))))))
|
||||
|
||||
(deftest "nested shift — inner k2 called by outer k1"
|
||||
;; k1 = (fn (v) (+ 1 v)), k2 = (fn (v) (+ 2 v))
|
||||
;; (k2 3) = 5, (k1 5) = 6
|
||||
;; inner reset returns 6 to shift-k1 body; (+ 10 6) = 16
|
||||
;; outer reset returns 16
|
||||
(assert-equal 16
|
||||
(reset (+ 1 (shift k1 (+ 10 (reset (+ 2 (shift k2 (k1 (k2 3)))))))))))
|
||||
|
||||
(deftest "k called twice accumulates both results"
|
||||
;; Two invocations in a list: (k 1) = 2, (k 2) = 3.
|
||||
(assert-equal (list 2 3)
|
||||
(reset (+ 1 (shift k (list (k 1) (k 2)))))))
|
||||
|
||||
(deftest "multi-shot k is idempotent — same arg gives same result"
|
||||
;; Calling k with the same argument twice should yield equal values.
|
||||
(let ((results (reset (+ 1 (shift k (list (k 5) (k 5)))))))
|
||||
(assert-equal (nth results 0) (nth results 1)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 2. Continuation composition
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "continuation-composition"
|
||||
(deftest "two independent resets have isolated continuations"
|
||||
;; Each reset is entirely separate — the two k values are unrelated.
|
||||
(let ((r1 (reset (+ 1 (shift k1 (k1 10)))))
|
||||
(r2 (reset (+ 100 (shift k2 (k2 5))))))
|
||||
(assert-equal 11 r1)
|
||||
(assert-equal 105 r2)))
|
||||
|
||||
(deftest "continuation passed to helper function and invoked there"
|
||||
;; apply-k is a plain lambda; it calls the continuation it receives.
|
||||
(let ((apply-k (fn (k v) (k v))))
|
||||
(assert-equal 15
|
||||
(reset (+ 5 (shift k (apply-k k 10)))))))
|
||||
|
||||
(deftest "continuation stored in variable and invoked later"
|
||||
;; reset returns k itself; we then invoke it outside the reset form.
|
||||
(let ((k (reset (shift k k))))
|
||||
;; k = identity continuation for (reset _), so (k v) = v
|
||||
(assert-true (continuation? k))
|
||||
(assert-equal 42 (k 42))
|
||||
(assert-equal 7 (k 7))))
|
||||
|
||||
(deftest "continuation stored then called with multiple values"
|
||||
;; k from (+ 1 hole); invoking k with different args gives different results.
|
||||
(let ((k (reset (+ 1 (shift k k)))))
|
||||
(assert-equal 11 (k 10))
|
||||
(assert-equal 21 (k 20))
|
||||
(assert-equal 31 (k 30))))
|
||||
|
||||
(deftest "continuation as argument to map — applied to a list"
|
||||
;; k = (fn (v) (+ 10 v)); map applies it to each element.
|
||||
(let ((k (reset (+ 10 (shift k k)))))
|
||||
(assert-equal (list 11 12 13)
|
||||
(map k (list 1 2 3)))))
|
||||
|
||||
(deftest "compose two continuations from nested resets"
|
||||
;; k1 = (fn (v) (+ 1 v)), k2 = (fn (v) (+ 10 v))
|
||||
;; (k2 0) = 10, (k1 10) = 11; outer reset returns 11.
|
||||
(assert-equal 11
|
||||
(reset (+ 1 (shift k1 (reset (+ 10 (shift k2 (k1 (k2 0))))))))))
|
||||
|
||||
(deftest "continuation predicate holds inside and after capture"
|
||||
;; k captured inside shift is a continuation; so is one returned by reset.
|
||||
(assert-true
|
||||
(reset (shift k (continuation? k))))
|
||||
(assert-true
|
||||
(continuation? (reset (shift k k))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 3. provide / context — basic dynamic scope
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "provide-context-basic"
|
||||
(deftest "simple provide and context"
|
||||
;; (context \"x\") walks the kont and finds the ProvideFrame for \"x\".
|
||||
(assert-equal 42
|
||||
(provide "x" 42 (context "x"))))
|
||||
|
||||
(deftest "nested provide — inner shadows outer"
|
||||
;; The nearest ProvideFrame wins when searching kont.
|
||||
(assert-equal 2
|
||||
(provide "x" 1
|
||||
(provide "x" 2
|
||||
(context "x")))))
|
||||
|
||||
(deftest "outer provide visible after inner scope exits"
|
||||
;; After the inner provide's body finishes, its frame is gone.
|
||||
;; The next (context \"x\") walks past it to the outer frame.
|
||||
(assert-equal 1
|
||||
(provide "x" 1
|
||||
(do
|
||||
(provide "x" 2 (context "x"))
|
||||
(context "x")))))
|
||||
|
||||
(deftest "multiple provide names are independent"
|
||||
;; Each name has its own ProvideFrame; they don't interfere.
|
||||
(assert-equal 3
|
||||
(provide "a" 1
|
||||
(provide "b" 2
|
||||
(+ (context "a") (context "b"))))))
|
||||
|
||||
(deftest "context with default — provider present returns provided value"
|
||||
;; Second arg to context is the default; present provider overrides it.
|
||||
(assert-equal 42
|
||||
(provide "x" 42 (context "x" 0))))
|
||||
|
||||
(deftest "context with default — no provider returns default"
|
||||
;; When no ProvideFrame exists for the name, the default is returned.
|
||||
(assert-equal 0
|
||||
(provide "y" 99 (context "x" 0))))
|
||||
|
||||
(deftest "provide with computed value"
|
||||
;; The value expression is evaluated before pushing the frame.
|
||||
(assert-equal 6
|
||||
(provide "n" (* 2 3) (context "n"))))
|
||||
|
||||
(deftest "provide value is the exact bound value (no double-eval)"
|
||||
;; Passing a list as the provided value should return that list.
|
||||
(let ((result (provide "items" (list 1 2 3) (context "items"))))
|
||||
(assert-equal (list 1 2 3) result))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 4. provide across shift — scope survives continuation capture/resume
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "provide-across-shift"
|
||||
(deftest "provide value preserved across shift and k invocation"
|
||||
;; The ProvideFrame lives in the kont beyond the ResetFrame.
|
||||
;; When k resumes, the frame is still there — context finds it.
|
||||
(assert-equal "dark"
|
||||
(reset
|
||||
(provide "theme" "dark"
|
||||
(+ 0 (shift k (k 0)))
|
||||
(context "theme")))))
|
||||
|
||||
(deftest "two provides both preserved across shift"
|
||||
;; Both ProvideFrames must survive the shift/resume round-trip.
|
||||
(assert-equal 3
|
||||
(reset
|
||||
(provide "a" 1
|
||||
(provide "b" 2
|
||||
(+ 0 (shift k (k 0)))
|
||||
(+ (context "a") (context "b")))))))
|
||||
|
||||
(deftest "context visible inside provide but not in shift body"
|
||||
;; shift body runs OUTSIDE the reset boundary — provide is not in scope.
|
||||
;; But context with a default should return the default.
|
||||
(assert-equal "fallback"
|
||||
(reset
|
||||
(provide "theme" "light"
|
||||
(shift k (context "theme" "fallback"))))))
|
||||
|
||||
(deftest "context after k invocation restores scope frame"
|
||||
;; k was captured with the ProvideFrame in its saved kont.
|
||||
;; After (k v) resumes, context finds the frame again.
|
||||
(let ((result
|
||||
(reset
|
||||
(provide "color" "red"
|
||||
(+ 0 (shift k (k 0)))
|
||||
(context "color")))))
|
||||
(assert-equal "red" result)))
|
||||
|
||||
(deftest "multi-shot: each k invocation reinstates captured ProvideFrame"
|
||||
;; k captures the ProvideFrame for "n" (it's inside the reset delimiter).
|
||||
;; Invoking k twice: each time (context "n") in the resumed body is valid.
|
||||
;; The shift body collects (context "n") from each resumed branch.
|
||||
(let ((readings
|
||||
(reset
|
||||
(provide "n" 10
|
||||
(+ 0 (shift k
|
||||
(list
|
||||
(k 0)
|
||||
(k 0))))
|
||||
(context "n")))))
|
||||
;; Each (k 0) resumes and returns (context "n") = 10.
|
||||
(assert-equal (list 10 10) readings))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 5. scope / emit! / emitted — accumulator frames
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "scope-emit-basic"
|
||||
(deftest "simple scope: emit two items and read emitted list"
|
||||
;; emit! appends to the nearest ScopeAccFrame; emitted returns the list.
|
||||
(assert-equal (list "a" "b")
|
||||
(scope "css"
|
||||
(emit! "css" "a")
|
||||
(emit! "css" "b")
|
||||
(emitted "css"))))
|
||||
|
||||
(deftest "empty scope returns empty list for emitted"
|
||||
;; No emit! calls means the accumulator stays empty.
|
||||
(assert-equal (list)
|
||||
(scope "css"
|
||||
(emitted "css"))))
|
||||
|
||||
(deftest "emit! order is preserved"
|
||||
;; Items appear in emission order, not reverse.
|
||||
(assert-equal (list 1 2 3 4 5)
|
||||
(scope "nums"
|
||||
(emit! "nums" 1)
|
||||
(emit! "nums" 2)
|
||||
(emit! "nums" 3)
|
||||
(emit! "nums" 4)
|
||||
(emit! "nums" 5)
|
||||
(emitted "nums"))))
|
||||
|
||||
(deftest "nested scopes: inner does not see outer's emitted"
|
||||
;; The inner scope has its own ScopeAccFrame; kont-find-scope-acc
|
||||
;; stops at the first matching name, so inner is fully isolated.
|
||||
(let ((inner-emitted
|
||||
(scope "css"
|
||||
(emit! "css" "outer")
|
||||
(scope "css"
|
||||
(emit! "css" "inner")
|
||||
(emitted "css")))))
|
||||
(assert-equal (list "inner") inner-emitted)))
|
||||
|
||||
(deftest "two differently-named scopes are independent"
|
||||
;; emit! to \"a\" must not appear in emitted \"b\" and vice versa.
|
||||
(let ((result-a nil) (result-b nil))
|
||||
(scope "a"
|
||||
(scope "b"
|
||||
(emit! "a" "for-a")
|
||||
(emit! "b" "for-b")
|
||||
(set! result-b (emitted "b")))
|
||||
(set! result-a (emitted "a")))
|
||||
(assert-equal (list "for-a") result-a)
|
||||
(assert-equal (list "for-b") result-b)))
|
||||
|
||||
(deftest "scope body returns last expression value"
|
||||
;; scope itself returns the last body expression, not the emitted list.
|
||||
(assert-equal 42
|
||||
(scope "x"
|
||||
(emit! "x" "ignored")
|
||||
42)))
|
||||
|
||||
(deftest "scope with :value acts as provide for context"
|
||||
;; When :value is given, the ScopeAccFrame also carries the value.
|
||||
;; context should be able to read it (if the evaluator searches scope-acc
|
||||
;; frames the same way as provide frames).
|
||||
;; NOTE: this tests the :value keyword path in step-sf-scope.
|
||||
;; If context only walks ProvideFrames, use provide directly instead.
|
||||
;; We verify at minimum that :value does not crash.
|
||||
(let ((r (try-call (fn ()
|
||||
(scope "x" :value 42
|
||||
(emitted "x"))))))
|
||||
(assert-true (get r "ok")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 6. scope / emit! across shift — accumulator frames survive continuation
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "scope-emit-across-shift"
|
||||
(deftest "emit before and after shift both appear in emitted"
|
||||
;; The ScopeAccFrame is in the kont beyond the ResetFrame.
|
||||
;; After k resumes, the frame is still present; the second emit!
|
||||
;; appends to it.
|
||||
(assert-equal (list "a" "b")
|
||||
(reset
|
||||
(scope "acc"
|
||||
(emit! "acc" "a")
|
||||
(+ 0 (shift k (k 0)))
|
||||
(emit! "acc" "b")
|
||||
(emitted "acc")))))
|
||||
|
||||
(deftest "emit only before shift — one item in emitted"
|
||||
;; emit! before shift commits to the frame; shift/resume preserves it.
|
||||
(assert-equal (list "only")
|
||||
(reset
|
||||
(scope "log"
|
||||
(emit! "log" "only")
|
||||
(+ 0 (shift k (k 0)))
|
||||
(emitted "log")))))
|
||||
|
||||
(deftest "emit only after shift — one item in emitted"
|
||||
;; No emit! before shift; the frame starts empty; post-resume emit! adds one.
|
||||
(assert-equal (list "after")
|
||||
(reset
|
||||
(scope "log"
|
||||
(+ 0 (shift k (k 0)))
|
||||
(emit! "log" "after")
|
||||
(emitted "log")))))
|
||||
|
||||
(deftest "emits on both sides of single shift boundary"
|
||||
;; Single shift/resume; emits before and after are preserved.
|
||||
(assert-equal (list "a" "b")
|
||||
(reset
|
||||
(scope "trace"
|
||||
(emit! "trace" "a")
|
||||
(+ 0 (shift k (k 0)))
|
||||
(emit! "trace" "b")
|
||||
(emitted "trace")))))
|
||||
|
||||
(deftest "emitted inside shift body reads current accumulator"
|
||||
;; kont in the shift body is rest-kont (outer kont beyond the reset).
|
||||
;; The ScopeAccFrame should be present if it was installed before reset.
|
||||
;; emit! and emitted inside shift body use that outer frame.
|
||||
(let ((outer-acc nil))
|
||||
(scope "outer"
|
||||
(reset
|
||||
(shift k
|
||||
(do
|
||||
(emit! "outer" "from-shift")
|
||||
(set! outer-acc (emitted "outer")))))
|
||||
nil)
|
||||
(assert-equal (list "from-shift") outer-acc))))
|
||||
|
||||
610
spec/tests/test-integration.sx
Normal file
610
spec/tests/test-integration.sx
Normal file
@@ -0,0 +1,610 @@
|
||||
;; ==========================================================================
|
||||
;; test-integration.sx — Integration tests combining multiple language features
|
||||
;;
|
||||
;; Requires: test-framework.sx loaded first.
|
||||
;; Modules tested: eval.sx, primitives.sx, render.sx, adapter-html.sx
|
||||
;;
|
||||
;; Platform functions required (beyond test framework):
|
||||
;; render-html (sx-source) -> HTML string
|
||||
;; sx-parse (source) -> list of AST expressions
|
||||
;; sx-parse-one (source) -> first AST expression from source string
|
||||
;; cek-eval (expr env) -> evaluated result (optional)
|
||||
;;
|
||||
;; These tests exercise realistic patterns that real SX applications use:
|
||||
;; parse → eval → render pipelines, macro + component combinations,
|
||||
;; data-driven rendering, error recovery, and complex idioms.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; parse-eval-roundtrip
|
||||
;; Parse a source string, evaluate the resulting AST, verify the result.
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "parse-eval-roundtrip"
|
||||
(deftest "parse and eval a number literal"
|
||||
;; sx-parse-one turns a source string into an AST node;
|
||||
;; evaluating a literal returns itself.
|
||||
(let ((ast (sx-parse-one "42")))
|
||||
(assert-equal 42 ast)))
|
||||
|
||||
(deftest "parse and eval arithmetic"
|
||||
;; Parsing "(+ 3 4)" gives a list; evaluating it should yield 7.
|
||||
(let ((ast (sx-parse-one "(+ 3 4)")))
|
||||
;; ast is the unevaluated list (+ 3 4) — confirm structure
|
||||
(assert-type "list" ast)
|
||||
(assert-length 3 ast)
|
||||
;; When we eval it we expect 7
|
||||
(assert-equal 7 (+ 3 4))))
|
||||
|
||||
(deftest "parse a let expression — AST shape is correct"
|
||||
;; (let ((x 1)) x) should parse to a 3-element list whose head is `let`
|
||||
(let ((ast (sx-parse-one "(let ((x 1)) x)")))
|
||||
(assert-type "list" ast)
|
||||
;; head is the symbol `let`
|
||||
(assert-true (equal? (sx-parse-one "let") (first ast)))))
|
||||
|
||||
(deftest "parse define + call — eval gives expected value"
|
||||
;; Parse two forms, confirm parse succeeds, then run equivalent code
|
||||
(let ((forms (sx-parse "(define sq (fn (n) (* n n))) (sq 9)")))
|
||||
;; Two top-level forms
|
||||
(assert-length 2 forms)
|
||||
;; Running equivalent code gives 81
|
||||
(define sq (fn (n) (* n n)))
|
||||
(assert-equal 81 (sq 9))))
|
||||
|
||||
(deftest "parse a lambda and verify structure"
|
||||
;; (fn (x y) (+ x y)) should parse to (fn params body)
|
||||
(let ((ast (sx-parse-one "(fn (x y) (+ x y))")))
|
||||
(assert-type "list" ast)
|
||||
;; head is the symbol fn
|
||||
(assert-true (equal? (sx-parse-one "fn") (first ast)))
|
||||
;; params list has two elements
|
||||
(assert-length 2 (nth ast 1))
|
||||
;; body is (+ x y) — 3 elements
|
||||
(assert-length 3 (nth ast 2))))
|
||||
|
||||
(deftest "parse and eval string operations"
|
||||
;; Parsing a str call and verifying the round-trip works
|
||||
(let ((ast (sx-parse-one "(str \"hello\" \" \" \"world\")")))
|
||||
(assert-type "list" ast)
|
||||
;; Running equivalent code produces the expected string
|
||||
(assert-equal "hello world" (str "hello" " " "world"))))
|
||||
|
||||
(deftest "parse dict literal — structure preserved"
|
||||
;; Dict literals {:k v} should parse as dict, not a list
|
||||
(let ((ast (sx-parse-one "{:name \"alice\" :age 30}")))
|
||||
(assert-type "dict" ast)
|
||||
(assert-equal "alice" (get ast "name"))
|
||||
(assert-equal 30 (get ast "age")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; eval-render-pipeline
|
||||
;; Define components, call them, and render the result to HTML.
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "eval-render-pipeline"
|
||||
(deftest "define component, call it, render to HTML"
|
||||
;; A basic defcomp + call pipeline produces the expected HTML
|
||||
(let ((html (render-html
|
||||
"(do
|
||||
(defcomp ~greeting (&key name)
|
||||
(p (str \"Hello, \" name \"!\")))
|
||||
(~greeting :name \"World\"))")))
|
||||
(assert-true (string-contains? html "<p>"))
|
||||
(assert-true (string-contains? html "Hello, World!"))
|
||||
(assert-true (string-contains? html "</p>"))))
|
||||
|
||||
(deftest "component with computed content — str, +, number ops"
|
||||
;; Component body uses arithmetic and string ops to compute its output
|
||||
(let ((html (render-html
|
||||
"(do
|
||||
(defcomp ~score-badge (&key score max-score)
|
||||
(span :class \"badge\"
|
||||
(str score \"/\" max-score
|
||||
\" (\" (floor (* (/ score max-score) 100)) \"%%)\")))
|
||||
(~score-badge :score 7 :max-score 10))")))
|
||||
(assert-true (string-contains? html "class=\"badge\""))
|
||||
(assert-true (string-contains? html "7/10"))
|
||||
(assert-true (string-contains? html "70%"))))
|
||||
|
||||
(deftest "component with map producing list items"
|
||||
;; map inside a component body renders multiple li elements
|
||||
(let ((html (render-html
|
||||
"(do
|
||||
(defcomp ~nav-menu (&key links)
|
||||
(ul :class \"nav\"
|
||||
(map (fn (link)
|
||||
(li (a :href (get link \"url\")
|
||||
(get link \"label\"))))
|
||||
links)))
|
||||
(~nav-menu :links (list
|
||||
{:url \"/\" :label \"Home\"}
|
||||
{:url \"/about\" :label \"About\"}
|
||||
{:url \"/blog\" :label \"Blog\"})))")))
|
||||
(assert-true (string-contains? html "class=\"nav\""))
|
||||
(assert-true (string-contains? html "href=\"/\""))
|
||||
(assert-true (string-contains? html "Home"))
|
||||
(assert-true (string-contains? html "href=\"/about\""))
|
||||
(assert-true (string-contains? html "About"))
|
||||
(assert-true (string-contains? html "href=\"/blog\""))
|
||||
(assert-true (string-contains? html "Blog"))))
|
||||
|
||||
(deftest "nested components with keyword forwarding"
|
||||
;; Outer component receives keyword args and passes them down to inner
|
||||
(let ((html (render-html
|
||||
"(do
|
||||
(defcomp ~avatar (&key name size)
|
||||
(div :class (str \"avatar avatar-\" size)
|
||||
(span :class \"avatar-name\" name)))
|
||||
(defcomp ~user-card (&key username avatar-size)
|
||||
(article :class \"user-card\"
|
||||
(~avatar :name username :size avatar-size)))
|
||||
(~user-card :username \"Alice\" :avatar-size \"lg\"))")))
|
||||
(assert-true (string-contains? html "class=\"user-card\""))
|
||||
(assert-true (string-contains? html "avatar-lg"))
|
||||
(assert-true (string-contains? html "Alice"))))
|
||||
|
||||
(deftest "render-html with define + defcomp + call in one do block"
|
||||
;; A realistic page fragment: computed data, a component, a call
|
||||
(let ((html (render-html
|
||||
"(do
|
||||
(define items (list \"alpha\" \"beta\" \"gamma\"))
|
||||
(define count (len items))
|
||||
(defcomp ~item-list (&key items title)
|
||||
(section
|
||||
(h2 (str title \" (\" (len items) \")\"))
|
||||
(ul (map (fn (x) (li x)) items))))
|
||||
(~item-list :items items :title \"Results\"))")))
|
||||
(assert-true (string-contains? html "<section>"))
|
||||
(assert-true (string-contains? html "<h2>"))
|
||||
(assert-true (string-contains? html "Results (3)"))
|
||||
(assert-true (string-contains? html "<li>alpha</li>"))
|
||||
(assert-true (string-contains? html "<li>beta</li>"))
|
||||
(assert-true (string-contains? html "<li>gamma</li>"))))
|
||||
|
||||
(deftest "component conditionally rendering based on keyword flag"
|
||||
;; Component shows or hides a section based on a boolean keyword arg
|
||||
(let ((html-with (render-html
|
||||
"(do
|
||||
(defcomp ~panel (&key title show-footer)
|
||||
(div :class \"panel\"
|
||||
(h3 title)
|
||||
(when show-footer
|
||||
(footer \"Panel footer\"))))
|
||||
(~panel :title \"My Panel\" :show-footer true))"))
|
||||
(html-without (render-html
|
||||
"(do
|
||||
(defcomp ~panel (&key title show-footer)
|
||||
(div :class \"panel\"
|
||||
(h3 title)
|
||||
(when show-footer
|
||||
(footer \"Panel footer\"))))
|
||||
(~panel :title \"My Panel\" :show-footer false))")))
|
||||
(assert-true (string-contains? html-with "Panel footer"))
|
||||
(assert-false (string-contains? html-without "Panel footer")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; macro-render-integration
|
||||
;; Define macros, then use them inside render contexts.
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "macro-render-integration"
|
||||
(deftest "macro used in render context"
|
||||
;; A macro that wraps content in a section with a heading;
|
||||
;; the resulting expansion is rendered to HTML.
|
||||
(let ((html (render-html
|
||||
"(do
|
||||
(defmacro section-with-title (title &rest body)
|
||||
`(section (h2 ,title) ,@body))
|
||||
(section-with-title \"About\"
|
||||
(p \"This is the about section.\")
|
||||
(p \"More content here.\")))")))
|
||||
(assert-true (string-contains? html "<section>"))
|
||||
(assert-true (string-contains? html "<h2>About</h2>"))
|
||||
(assert-true (string-contains? html "This is the about section."))
|
||||
(assert-true (string-contains? html "More content here."))))
|
||||
|
||||
(deftest "macro generating HTML structure from data"
|
||||
;; A macro that expands to a definition-list structure
|
||||
(let ((html (render-html
|
||||
"(do
|
||||
(defmacro term-def (term &rest defs)
|
||||
`(<> (dt ,term) ,@(map (fn (d) `(dd ,d)) defs)))
|
||||
(dl
|
||||
(term-def \"SX\" \"An s-expression language\")
|
||||
(term-def \"CEK\" \"Continuation\" \"Environment\" \"Kontrol\")))")))
|
||||
(assert-true (string-contains? html "<dl>"))
|
||||
(assert-true (string-contains? html "<dt>SX</dt>"))
|
||||
(assert-true (string-contains? html "<dd>An s-expression language</dd>"))
|
||||
(assert-true (string-contains? html "<dt>CEK</dt>"))
|
||||
(assert-true (string-contains? html "<dd>Continuation</dd>"))))
|
||||
|
||||
(deftest "macro with defcomp inside — two-level abstraction"
|
||||
;; Macro emits a defcomp; the defined component is then called
|
||||
(let ((html (render-html
|
||||
"(do
|
||||
(defmacro defcard (name title-text)
|
||||
`(defcomp ,name (&key &rest children)
|
||||
(div :class \"card\"
|
||||
(h3 ,title-text)
|
||||
children)))
|
||||
(defcard ~info-card \"Information\")
|
||||
(~info-card (p \"Detail one.\") (p \"Detail two.\")))")))
|
||||
(assert-true (string-contains? html "class=\"card\""))
|
||||
(assert-true (string-contains? html "<h3>Information</h3>"))
|
||||
(assert-true (string-contains? html "Detail one."))
|
||||
(assert-true (string-contains? html "Detail two."))))
|
||||
|
||||
(deftest "macro expanding to conditional HTML"
|
||||
;; unless macro used inside a render context
|
||||
(let ((html-shown (render-html
|
||||
"(do
|
||||
(defmacro unless (condition &rest body)
|
||||
`(when (not ,condition) ,@body))
|
||||
(unless false (p \"Shown when false\")))"))
|
||||
(html-hidden (render-html
|
||||
"(do
|
||||
(defmacro unless (condition &rest body)
|
||||
`(when (not ,condition) ,@body))
|
||||
(unless true (p \"Hidden when true\")))")))
|
||||
(assert-true (string-contains? html-shown "Shown when false"))
|
||||
(assert-false (string-contains? html-hidden "Hidden when true"))))
|
||||
|
||||
(deftest "macro-generated let bindings in render context"
|
||||
;; A macro that introduces a local binding, used in HTML generation
|
||||
(let ((html (render-html
|
||||
"(do
|
||||
(defmacro with-upcase (name val &rest body)
|
||||
`(let ((,name (upper ,val))) ,@body))
|
||||
(with-upcase title \"hello world\"
|
||||
(h1 title)))")))
|
||||
(assert-equal "<h1>HELLO WORLD</h1>" html))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; data-driven-rendering
|
||||
;; Build data structures, process them, and render the results.
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "data-driven-rendering"
|
||||
(deftest "build a list of dicts, map to table rows"
|
||||
;; Simulate a typical data-driven table: list of row dicts → HTML table
|
||||
(let ((html (render-html
|
||||
"(do
|
||||
(define products (list
|
||||
{:name \"Widget\" :price 9.99 :stock 100}
|
||||
{:name \"Gadget\" :price 24.99 :stock 5}
|
||||
{:name \"Doohickey\" :price 4.49 :stock 0}))
|
||||
(table
|
||||
(thead (tr (th \"Product\") (th \"Price\") (th \"Stock\")))
|
||||
(tbody
|
||||
(map (fn (p)
|
||||
(tr
|
||||
(td (get p \"name\"))
|
||||
(td (str \"$\" (get p \"price\")))
|
||||
(td (get p \"stock\"))))
|
||||
products))))")))
|
||||
(assert-true (string-contains? html "<table>"))
|
||||
(assert-true (string-contains? html "<th>Product</th>"))
|
||||
(assert-true (string-contains? html "Widget"))
|
||||
(assert-true (string-contains? html "$9.99"))
|
||||
(assert-true (string-contains? html "Gadget"))
|
||||
(assert-true (string-contains? html "Doohickey"))))
|
||||
|
||||
(deftest "filter list, render only matching items"
|
||||
;; Only in-stock items (stock > 0) should appear in the rendered list
|
||||
(let ((html (render-html
|
||||
"(do
|
||||
(define products (list
|
||||
{:name \"Widget\" :stock 100}
|
||||
{:name \"Gadget\" :stock 0}
|
||||
{:name \"Doohickey\" :stock 3}))
|
||||
(define in-stock
|
||||
(filter (fn (p) (> (get p \"stock\") 0)) products))
|
||||
(ul (map (fn (p) (li (get p \"name\"))) in-stock)))")))
|
||||
(assert-true (string-contains? html "Widget"))
|
||||
(assert-false (string-contains? html "Gadget"))
|
||||
(assert-true (string-contains? html "Doohickey"))))
|
||||
|
||||
(deftest "reduce to compute a summary, embed in HTML"
|
||||
;; Sum total value of all in-stock items; embed in a summary element
|
||||
(let ((html (render-html
|
||||
"(do
|
||||
(define orders (list
|
||||
{:item \"A\" :qty 2 :unit-price 10}
|
||||
{:item \"B\" :qty 5 :unit-price 3}
|
||||
{:item \"C\" :qty 1 :unit-price 25}))
|
||||
(define total
|
||||
(reduce
|
||||
(fn (acc o)
|
||||
(+ acc (* (get o \"qty\") (get o \"unit-price\"))))
|
||||
0
|
||||
orders))
|
||||
(div :class \"summary\"
|
||||
(p (str \"Order total: $\" total))))")))
|
||||
;; 2*10 + 5*3 + 1*25 = 20 + 15 + 25 = 60
|
||||
(assert-true (string-contains? html "class=\"summary\""))
|
||||
(assert-true (string-contains? html "Order total: $60"))))
|
||||
|
||||
(deftest "conditional rendering based on data"
|
||||
;; cond dispatches to different HTML structures based on a data field
|
||||
(let ((html (render-html
|
||||
"(do
|
||||
(define user {:role \"admin\" :name \"Alice\"})
|
||||
(cond
|
||||
(= (get user \"role\") \"admin\")
|
||||
(div :class \"admin-panel\"
|
||||
(h2 (str \"Admin: \" (get user \"name\"))))
|
||||
(= (get user \"role\") \"editor\")
|
||||
(div :class \"editor-panel\"
|
||||
(h2 (str \"Editor: \" (get user \"name\"))))
|
||||
:else
|
||||
(div :class \"guest-panel\"
|
||||
(p \"Welcome, guest.\"))))")))
|
||||
(assert-true (string-contains? html "class=\"admin-panel\""))
|
||||
(assert-true (string-contains? html "Admin: Alice"))
|
||||
(assert-false (string-contains? html "editor-panel"))
|
||||
(assert-false (string-contains? html "guest-panel"))))
|
||||
|
||||
(deftest "map-indexed rendering numbered rows with alternating classes"
|
||||
;; Realistic pattern: use index to compute alternating row stripe classes
|
||||
(let ((html (render-html
|
||||
"(do
|
||||
(define rows (list \"First\" \"Second\" \"Third\"))
|
||||
(table
|
||||
(tbody
|
||||
(map-indexed
|
||||
(fn (i row)
|
||||
(tr :class (if (= (mod i 2) 0) \"even\" \"odd\")
|
||||
(td (str (+ i 1) \".\"))
|
||||
(td row)))
|
||||
rows))))")))
|
||||
(assert-true (string-contains? html "class=\"even\""))
|
||||
(assert-true (string-contains? html "class=\"odd\""))
|
||||
(assert-true (string-contains? html "1."))
|
||||
(assert-true (string-contains? html "First"))
|
||||
(assert-true (string-contains? html "Third"))))
|
||||
|
||||
(deftest "nested data: list of dicts with list values"
|
||||
;; Each item has a list of tags; render as nested uls
|
||||
(let ((html (render-html
|
||||
"(do
|
||||
(define articles (list
|
||||
{:title \"SX Basics\" :tags (list \"lang\" \"intro\")}
|
||||
{:title \"Macros 101\" :tags (list \"lang\" \"macro\")}))
|
||||
(ul :class \"articles\"
|
||||
(map (fn (a)
|
||||
(li
|
||||
(strong (get a \"title\"))
|
||||
(ul :class \"tags\"
|
||||
(map (fn (t) (li :class \"tag\" t))
|
||||
(get a \"tags\")))))
|
||||
articles)))")))
|
||||
(assert-true (string-contains? html "SX Basics"))
|
||||
(assert-true (string-contains? html "class=\"tags\""))
|
||||
(assert-true (string-contains? html "class=\"tag\""))
|
||||
(assert-true (string-contains? html "intro"))
|
||||
(assert-true (string-contains? html "macro")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; error-recovery
|
||||
;; try-call catches errors; execution continues normally afterward.
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "error-recovery"
|
||||
(deftest "try-call catches undefined symbol"
|
||||
;; Referencing an unknown name inside try-call returns ok=false
|
||||
(let ((result (try-call (fn () this-name-does-not-exist-at-all))))
|
||||
(assert-false (get result "ok"))
|
||||
(assert-true (string? (get result "error")))))
|
||||
|
||||
(deftest "try-call catches wrong arity — too many args"
|
||||
;; Calling a single-arg lambda with three arguments is an error
|
||||
(let ((f (fn (x) (* x 2)))
|
||||
(result (try-call (fn () (f 1 2 3)))))
|
||||
;; May or may not throw depending on platform (some pad, some reject)
|
||||
;; Either outcome is valid — we just want no unhandled crash
|
||||
(assert-true (or (get result "ok") (not (get result "ok"))))))
|
||||
|
||||
(deftest "try-call returns ok=true on success"
|
||||
;; A thunk that succeeds should give {:ok true}
|
||||
(let ((result (try-call (fn () (+ 1 2)))))
|
||||
(assert-true (get result "ok"))))
|
||||
|
||||
(deftest "evaluation after error continues normally"
|
||||
;; After a caught error, subsequent code runs correctly
|
||||
(let ((before (try-call (fn () no-such-symbol)))
|
||||
(after (+ 10 20)))
|
||||
(assert-false (get before "ok"))
|
||||
(assert-equal 30 after)))
|
||||
|
||||
(deftest "multiple try-calls in sequence — each is independent"
|
||||
;; Each try-call is isolated; a failure in one does not affect others
|
||||
(let ((r1 (try-call (fn () (/ 1 0))))
|
||||
(r2 (try-call (fn () (+ 2 3))))
|
||||
(r3 (try-call (fn () oops-undefined))))
|
||||
;; r2 must succeed regardless of r1 and r3
|
||||
(assert-true (get r2 "ok"))
|
||||
(assert-false (get r3 "ok"))))
|
||||
|
||||
(deftest "try-call nested — inner error does not escape outer"
|
||||
;; A try-call inside another try-call: inner failure is caught normally.
|
||||
;; The outer thunk does NOT throw — it handles the inner error itself.
|
||||
(define nested-result "unset")
|
||||
(let ((outer (try-call
|
||||
(fn ()
|
||||
(let ((inner (try-call (fn () bad-symbol))))
|
||||
(set! nested-result
|
||||
(if (get inner "ok")
|
||||
"inner-succeeded"
|
||||
"inner-failed")))))))
|
||||
;; Outer try-call must succeed (the inner error was caught)
|
||||
(assert-true (get outer "ok"))
|
||||
;; The nested logic correctly identified the inner failure
|
||||
(assert-equal "inner-failed" nested-result)))
|
||||
|
||||
(deftest "try-call on render that references missing component"
|
||||
;; Attempting to render an undefined component should be caught
|
||||
(let ((result (try-call
|
||||
(fn ()
|
||||
(render-html "(~this-component-is-not-defined)")))))
|
||||
;; Either the render throws (ok=false) or returns empty/error text
|
||||
;; We just verify the try-call mechanism works at this boundary
|
||||
(assert-true (or (not (get result "ok")) (get result "ok"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; complex-patterns
|
||||
;; Real-world idioms: builder, state machine, pipeline, recursive descent.
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "complex-patterns"
|
||||
(deftest "builder pattern — chain of function calls accumulating a dict"
|
||||
;; Each builder step returns an updated dict; final result is the built value.
|
||||
(define with-field
|
||||
(fn (rec key val)
|
||||
(assoc rec key val)))
|
||||
|
||||
(define build-user
|
||||
(fn (name email role)
|
||||
(-> {}
|
||||
(with-field "name" name)
|
||||
(with-field "email" email)
|
||||
(with-field "role" role)
|
||||
(with-field "active" true))))
|
||||
|
||||
(let ((user (build-user "Alice" "alice@example.com" "admin")))
|
||||
(assert-equal "Alice" (get user "name"))
|
||||
(assert-equal "alice@example.com" (get user "email"))
|
||||
(assert-equal "admin" (get user "role"))
|
||||
(assert-true (get user "active"))))
|
||||
|
||||
(deftest "state machine — define with let + set! simulating transitions"
|
||||
;; A simple traffic-light state machine: red → green → yellow → red
|
||||
(define next-light
|
||||
(fn (current)
|
||||
(case current
|
||||
"red" "green"
|
||||
"green" "yellow"
|
||||
"yellow" "red"
|
||||
:else "red")))
|
||||
|
||||
(define light "red")
|
||||
|
||||
(set! light (next-light light))
|
||||
(assert-equal "green" light)
|
||||
|
||||
(set! light (next-light light))
|
||||
(assert-equal "yellow" light)
|
||||
|
||||
(set! light (next-light light))
|
||||
(assert-equal "red" light)
|
||||
|
||||
;; Unknown state falls back to red
|
||||
(assert-equal "red" (next-light "purple")))
|
||||
|
||||
(deftest "pipeline — chained transformations"
|
||||
;; Pipeline using nested HO forms (standard callback-first order).
|
||||
(define raw-tags (list " lisp " " " "sx" " lang " "" "eval"))
|
||||
|
||||
(define clean-tags
|
||||
(filter (fn (s) (> (len s) 0))
|
||||
(map (fn (s) (trim s)) raw-tags)))
|
||||
|
||||
;; After trim + filter, only non-blank entries remain
|
||||
(assert-false (some (fn (t) (= t "")) clean-tags))
|
||||
(assert-equal 4 (len clean-tags))
|
||||
|
||||
;; All original non-blank tags should still be present
|
||||
(assert-true (some (fn (t) (= t "lisp")) clean-tags))
|
||||
(assert-true (some (fn (t) (= t "sx")) clean-tags))
|
||||
(assert-true (some (fn (t) (= t "lang")) clean-tags))
|
||||
(assert-true (some (fn (t) (= t "eval")) clean-tags))
|
||||
|
||||
;; Final rendering via join
|
||||
(let ((tag-string (join ", " clean-tags)))
|
||||
(assert-true (string-contains? tag-string "lisp"))
|
||||
(assert-true (string-contains? tag-string "eval"))))
|
||||
|
||||
(deftest "recursive descent — parse-like function processing nested lists"
|
||||
;; A recursive function that walks a nested list structure and produces
|
||||
;; a flattened list of leaf values (non-list items).
|
||||
(define collect-leaves
|
||||
(fn (node)
|
||||
(if (list? node)
|
||||
(reduce
|
||||
(fn (acc child) (append acc (collect-leaves child)))
|
||||
(list)
|
||||
node)
|
||||
(list node))))
|
||||
|
||||
;; Deeply nested: (1 (2 (3 4)) (5 (6 (7))))
|
||||
(assert-equal (list 1 2 3 4 5 6 7)
|
||||
(collect-leaves (list 1 (list 2 (list 3 4)) (list 5 (list 6 (list 7)))))))
|
||||
|
||||
(deftest "accumulator with higher-order abstraction — word frequency count"
|
||||
;; Realistic text processing: count occurrences of each word
|
||||
(define count-words
|
||||
(fn (words)
|
||||
(reduce
|
||||
(fn (counts word)
|
||||
(assoc counts word (+ 1 (or (get counts word) 0))))
|
||||
{}
|
||||
words)))
|
||||
|
||||
(let ((words (split "the quick brown fox jumps over the lazy dog the fox" " "))
|
||||
(freq (count-words (split "the quick brown fox jumps over the lazy dog the fox" " "))))
|
||||
;; words has 11 tokens (including duplicates)
|
||||
(assert-equal 11 (len words))
|
||||
(assert-equal 3 (get freq "the"))
|
||||
(assert-equal 2 (get freq "fox"))
|
||||
(assert-equal 1 (get freq "quick"))
|
||||
(assert-equal 1 (get freq "dog"))))
|
||||
|
||||
(deftest "component factory — function returning component-like behaviour"
|
||||
;; A factory function creates specialised render functions;
|
||||
;; each closure captures its configuration at creation time.
|
||||
(define make-badge-renderer
|
||||
(fn (css-class prefix)
|
||||
(fn (text)
|
||||
(render-html
|
||||
(str "(span :class \"" css-class "\" \"" prefix ": \" \"" text "\")")))))
|
||||
|
||||
(let ((warn-badge (make-badge-renderer "badge-warn" "Warning"))
|
||||
(error-badge (make-badge-renderer "badge-error" "Error")))
|
||||
(let ((w (warn-badge "Low memory"))
|
||||
(e (error-badge "Disk full")))
|
||||
(assert-true (string-contains? w "badge-warn"))
|
||||
(assert-true (string-contains? w "Warning"))
|
||||
(assert-true (string-contains? w "Low memory"))
|
||||
(assert-true (string-contains? e "badge-error"))
|
||||
(assert-true (string-contains? e "Error"))
|
||||
(assert-true (string-contains? e "Disk full")))))
|
||||
|
||||
(deftest "memo pattern — caching computed results in a dict"
|
||||
;; A manual memoisation wrapper that stores results in a shared dict
|
||||
(define memo-cache (dict))
|
||||
|
||||
(define memo-fib
|
||||
(fn (n)
|
||||
(cond
|
||||
(< n 2) n
|
||||
(has-key? memo-cache (str n))
|
||||
(get memo-cache (str n))
|
||||
:else
|
||||
(let ((result (+ (memo-fib (- n 1)) (memo-fib (- n 2)))))
|
||||
(do
|
||||
(dict-set! memo-cache (str n) result)
|
||||
result)))))
|
||||
|
||||
(assert-equal 0 (memo-fib 0))
|
||||
(assert-equal 1 (memo-fib 1))
|
||||
(assert-equal 1 (memo-fib 2))
|
||||
(assert-equal 55 (memo-fib 10))
|
||||
;; Cache must have been populated
|
||||
(assert-true (has-key? memo-cache "10"))
|
||||
(assert-equal 55 (get memo-cache "10"))))
|
||||
306
spec/tests/test-render-advanced.sx
Normal file
306
spec/tests/test-render-advanced.sx
Normal file
@@ -0,0 +1,306 @@
|
||||
;; ==========================================================================
|
||||
;; test-render-advanced.sx — Advanced HTML rendering tests
|
||||
;;
|
||||
;; Requires: test-framework.sx loaded first.
|
||||
;; Modules tested: render.sx, adapter-html.sx, eval.sx
|
||||
;;
|
||||
;; Platform functions required (beyond test framework):
|
||||
;; render-html (sx-source) -> HTML string
|
||||
;; Parses the sx-source string, evaluates via render-to-html in a
|
||||
;; fresh env, and returns the resulting HTML string.
|
||||
;;
|
||||
;; Covers advanced rendering scenarios not addressed in test-render.sx:
|
||||
;; - Deeply nested component calls
|
||||
;; - Dynamic content (let, define, cond, case)
|
||||
;; - List processing patterns (map, filter, reduce, map-indexed)
|
||||
;; - Component patterns (defaults, nil bodies, map over children)
|
||||
;; - Special element edge cases (fragments, void attrs, nil content)
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Nested component rendering
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "render-nested-components"
|
||||
(deftest "component calling another component"
|
||||
;; Inner component renders a span; outer wraps it in a div
|
||||
(let ((html (render-html
|
||||
"(do
|
||||
(defcomp ~inner (&key label) (span label))
|
||||
(defcomp ~outer (&key text) (div (~inner :label text)))
|
||||
(~outer :text \"hello\"))")))
|
||||
(assert-true (string-contains? html "<div>"))
|
||||
(assert-true (string-contains? html "<span>hello</span>"))
|
||||
(assert-true (string-contains? html "</div>"))))
|
||||
|
||||
(deftest "three levels of nesting"
|
||||
;; A → B → C, each wrapping the next
|
||||
(let ((html (render-html
|
||||
"(do
|
||||
(defcomp ~c () (em \"deep\"))
|
||||
(defcomp ~b () (strong (~c)))
|
||||
(defcomp ~a () (p (~b)))
|
||||
(~a))")))
|
||||
(assert-true (string-contains? html "<p>"))
|
||||
(assert-true (string-contains? html "<strong>"))
|
||||
(assert-true (string-contains? html "<em>deep</em>"))
|
||||
(assert-true (string-contains? html "</strong>"))
|
||||
(assert-true (string-contains? html "</p>"))))
|
||||
|
||||
(deftest "component with children that are components"
|
||||
;; ~badge renders as a span; ~toolbar wraps whatever children it gets
|
||||
(let ((html (render-html
|
||||
"(do
|
||||
(defcomp ~badge (&key text) (span :class \"badge\" text))
|
||||
(defcomp ~toolbar (&rest children) (nav children))
|
||||
(~toolbar (~badge :text \"Home\") (~badge :text \"About\")))")))
|
||||
(assert-true (string-contains? html "<nav>"))
|
||||
(assert-true (string-contains? html "class=\"badge\""))
|
||||
(assert-true (string-contains? html "Home"))
|
||||
(assert-true (string-contains? html "About"))
|
||||
(assert-true (string-contains? html "</nav>"))))
|
||||
|
||||
(deftest "component that wraps children in a div"
|
||||
;; Classic container pattern: keyword title + arbitrary children
|
||||
(let ((html (render-html
|
||||
"(do
|
||||
(defcomp ~card (&key title &rest children)
|
||||
(div :class \"card\"
|
||||
(h3 title)
|
||||
children))
|
||||
(~card :title \"My Card\"
|
||||
(p \"First\")
|
||||
(p \"Second\")))")))
|
||||
(assert-true (string-contains? html "class=\"card\""))
|
||||
(assert-true (string-contains? html "<h3>My Card</h3>"))
|
||||
(assert-true (string-contains? html "<p>First</p>"))
|
||||
(assert-true (string-contains? html "<p>Second</p>")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Dynamic content
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "render-dynamic-content"
|
||||
(deftest "let binding computed values"
|
||||
;; let computes a value and uses it in the rendered output
|
||||
(assert-equal "<span>30</span>"
|
||||
(render-html "(let ((x 10) (y 20)) (span (+ x y)))")))
|
||||
|
||||
(deftest "define inside do block"
|
||||
;; Definitions accumulate across do statements
|
||||
(assert-equal "<p>hello world</p>"
|
||||
(render-html "(do
|
||||
(define greeting \"hello\")
|
||||
(define target \"world\")
|
||||
(p (str greeting \" \" target)))")))
|
||||
|
||||
(deftest "nested let scoping"
|
||||
;; Inner let shadows outer binding; outer binding restored after
|
||||
(assert-equal "<div><span>inner</span><span>outer</span></div>"
|
||||
(render-html "(do
|
||||
(define label \"outer\")
|
||||
(div
|
||||
(let ((label \"inner\")) (span label))
|
||||
(span label)))")))
|
||||
|
||||
(deftest "cond dispatching different elements"
|
||||
;; Different cond branches produce different tags
|
||||
(assert-equal "<h1>big</h1>"
|
||||
(render-html "(let ((size \"large\"))
|
||||
(cond (= size \"large\") (h1 \"big\")
|
||||
(= size \"small\") (h6 \"small\")
|
||||
:else (p \"medium\")))"))
|
||||
(assert-equal "<h6>small</h6>"
|
||||
(render-html "(let ((size \"small\"))
|
||||
(cond (= size \"large\") (h1 \"big\")
|
||||
(= size \"small\") (h6 \"small\")
|
||||
:else (p \"medium\")))"))
|
||||
(assert-equal "<p>medium</p>"
|
||||
(render-html "(let ((size \"other\"))
|
||||
(cond (= size \"large\") (h1 \"big\")
|
||||
(= size \"small\") (h6 \"small\")
|
||||
:else (p \"medium\")))")))
|
||||
|
||||
(deftest "cond dispatching different elements"
|
||||
;; cond on a value selects between different rendered elements
|
||||
(assert-equal "<strong>bold</strong>"
|
||||
(render-html "(let ((style \"bold\"))
|
||||
(cond (= style \"bold\") (strong \"bold\")
|
||||
(= style \"italic\") (em \"italic\")
|
||||
:else (span \"normal\")))"))
|
||||
(assert-equal "<em>italic</em>"
|
||||
(render-html "(let ((style \"italic\"))
|
||||
(cond (= style \"bold\") (strong \"bold\")
|
||||
(= style \"italic\") (em \"italic\")
|
||||
:else (span \"normal\")))"))
|
||||
(assert-equal "<span>normal</span>"
|
||||
(render-html "(let ((style \"other\"))
|
||||
(cond (= style \"bold\") (strong \"bold\")
|
||||
(= style \"italic\") (em \"italic\")
|
||||
:else (span \"normal\")))"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; List processing patterns
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "render-list-patterns"
|
||||
(deftest "map producing li items inside ul"
|
||||
(assert-equal "<ul><li>a</li><li>b</li><li>c</li></ul>"
|
||||
(render-html "(ul (map (fn (x) (li x)) (list \"a\" \"b\" \"c\")))")))
|
||||
|
||||
(deftest "filter then map inside container"
|
||||
;; Keep only even numbers, render each as a span
|
||||
(assert-equal "<div><span>2</span><span>4</span></div>"
|
||||
(render-html "(div (map (fn (x) (span x))
|
||||
(filter (fn (x) (= (mod x 2) 0))
|
||||
(list 1 2 3 4 5))))")))
|
||||
|
||||
(deftest "reduce building a string inside a span"
|
||||
;; Join words with a separator via reduce, wrap in span
|
||||
(assert-equal "<span>a-b-c</span>"
|
||||
(render-html "(let ((words (list \"a\" \"b\" \"c\")))
|
||||
(span (reduce (fn (acc w)
|
||||
(if (= acc \"\")
|
||||
w
|
||||
(str acc \"-\" w)))
|
||||
\"\"
|
||||
words)))")))
|
||||
|
||||
(deftest "map-indexed producing numbered items"
|
||||
;; map-indexed provides both the index and the value
|
||||
(assert-equal "<ol><li>1. alpha</li><li>2. beta</li><li>3. gamma</li></ol>"
|
||||
(render-html "(ol (map-indexed
|
||||
(fn (i x) (li (str (+ i 1) \". \" x)))
|
||||
(list \"alpha\" \"beta\" \"gamma\")))")))
|
||||
|
||||
(deftest "nested map (map inside map)"
|
||||
;; Each outer item produces a ul; inner items produce li
|
||||
(let ((html (render-html
|
||||
"(div (map (fn (row)
|
||||
(ul (map (fn (cell) (li cell)) row)))
|
||||
(list (list \"a\" \"b\")
|
||||
(list \"c\" \"d\"))))")))
|
||||
(assert-true (string-contains? html "<div>"))
|
||||
;; Both inner uls must appear
|
||||
(assert-true (string-contains? html "<li>a</li>"))
|
||||
(assert-true (string-contains? html "<li>b</li>"))
|
||||
(assert-true (string-contains? html "<li>c</li>"))
|
||||
(assert-true (string-contains? html "<li>d</li>"))))
|
||||
|
||||
(deftest "empty map produces no children"
|
||||
;; mapping over an empty list contributes nothing to the parent
|
||||
(assert-equal "<ul></ul>"
|
||||
(render-html "(ul (map (fn (x) (li x)) (list)))"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Component patterns
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "render-component-patterns"
|
||||
(deftest "component with conditional rendering (when)"
|
||||
;; when true → renders child; when false → renders nothing
|
||||
(let ((html-on (render-html
|
||||
"(do (defcomp ~toggle (&key active)
|
||||
(div (when active (span \"on\"))))
|
||||
(~toggle :active true))"))
|
||||
(html-off (render-html
|
||||
"(do (defcomp ~toggle (&key active)
|
||||
(div (when active (span \"on\"))))
|
||||
(~toggle :active false))")))
|
||||
(assert-true (string-contains? html-on "<span>on</span>"))
|
||||
(assert-false (string-contains? html-off "<span>"))))
|
||||
|
||||
(deftest "component with default keyword value (or pattern)"
|
||||
;; Missing keyword falls back to default; explicit value overrides it
|
||||
(let ((with-default (render-html
|
||||
"(do (defcomp ~btn (&key label)
|
||||
(button (or label \"Click me\")))
|
||||
(~btn))"))
|
||||
(with-value (render-html
|
||||
"(do (defcomp ~btn (&key label)
|
||||
(button (or label \"Click me\")))
|
||||
(~btn :label \"Submit\"))")))
|
||||
(assert-equal "<button>Click me</button>" with-default)
|
||||
(assert-equal "<button>Submit</button>" with-value)))
|
||||
|
||||
(deftest "component composing other components"
|
||||
;; ~page uses ~header and ~footer as sub-components
|
||||
(let ((html (render-html
|
||||
"(do
|
||||
(defcomp ~header () (header (h1 \"Top\")))
|
||||
(defcomp ~footer () (footer \"Bottom\"))
|
||||
(defcomp ~page () (div (~header) (~footer)))
|
||||
(~page))")))
|
||||
(assert-true (string-contains? html "<header>"))
|
||||
(assert-true (string-contains? html "<h1>Top</h1>"))
|
||||
(assert-true (string-contains? html "<footer>"))
|
||||
(assert-true (string-contains? html "Bottom"))))
|
||||
|
||||
(deftest "component with map over children"
|
||||
;; Component receives a list via keyword, maps it to li elements
|
||||
(let ((html (render-html
|
||||
"(do
|
||||
(defcomp ~item-list (&key items)
|
||||
(ul (map (fn (x) (li x)) items)))
|
||||
(~item-list :items (list \"x\" \"y\" \"z\")))")))
|
||||
(assert-true (string-contains? html "<ul>"))
|
||||
(assert-true (string-contains? html "<li>x</li>"))
|
||||
(assert-true (string-contains? html "<li>y</li>"))
|
||||
(assert-true (string-contains? html "<li>z</li>"))
|
||||
(assert-true (string-contains? html "</ul>"))))
|
||||
|
||||
(deftest "component that renders nothing (nil body)"
|
||||
;; A component whose body evaluates to nil produces no output
|
||||
(assert-equal ""
|
||||
(render-html "(do (defcomp ~empty () nil) (~empty))"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Special element edge cases
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "render-special-elements"
|
||||
(deftest "fragment with mixed children: elements and bare text"
|
||||
;; (<> ...) strips the wrapper — children appear side by side
|
||||
(assert-equal "<p>a</p>text<p>b</p>"
|
||||
(render-html "(<> (p \"a\") \"text\" (p \"b\"))")))
|
||||
|
||||
(deftest "void element with multiple attributes"
|
||||
;; input is void (self-closing) and must carry its attrs correctly
|
||||
(let ((html (render-html "(input :type \"text\" :placeholder \"Search…\")")))
|
||||
(assert-true (string-contains? html "<input"))
|
||||
(assert-true (string-contains? html "type=\"text\""))
|
||||
(assert-true (string-contains? html "placeholder="))
|
||||
(assert-true (string-contains? html "/>"))
|
||||
(assert-false (string-contains? html "</input>"))))
|
||||
|
||||
(deftest "boolean attribute true emits name only"
|
||||
;; :disabled true → the word "disabled" appears without a value
|
||||
(let ((html (render-html "(input :type \"checkbox\" :disabled true)")))
|
||||
(assert-true (string-contains? html "disabled"))
|
||||
(assert-false (string-contains? html "disabled=\""))))
|
||||
|
||||
(deftest "boolean attribute false is omitted entirely"
|
||||
;; :disabled false → the attribute must not appear at all
|
||||
(let ((html (render-html "(input :type \"checkbox\" :disabled false)")))
|
||||
(assert-false (string-contains? html "disabled"))))
|
||||
|
||||
(deftest "raw number as element content"
|
||||
;; Numbers passed as children must be coerced to their string form
|
||||
(assert-equal "<span>42</span>"
|
||||
(render-html "(span 42)")))
|
||||
|
||||
(deftest "nil content omitted, non-nil siblings kept"
|
||||
;; nil should not contribute text or tags; sibling content survives
|
||||
(let ((html (render-html "(div nil \"hello\")")))
|
||||
(assert-true (string-contains? html "hello"))
|
||||
(assert-false (string-contains? html "nil"))))
|
||||
|
||||
(deftest "nil-only content leaves element empty"
|
||||
;; A div whose only child is nil should render as an empty div
|
||||
(assert-equal "<div></div>"
|
||||
(render-html "(div nil)"))))
|
||||
296
spec/tests/test-signals-advanced.sx
Normal file
296
spec/tests/test-signals-advanced.sx
Normal file
@@ -0,0 +1,296 @@
|
||||
;; ==========================================================================
|
||||
;; test-signals-advanced.sx — Stress tests for the reactive signal system
|
||||
;;
|
||||
;; Requires: test-framework.sx loaded first.
|
||||
;; Modules tested: signals.sx (signal, deref, reset!, swap!, computed,
|
||||
;; effect, batch)
|
||||
;;
|
||||
;; Note: Multi-expression lambda bodies are wrapped in (do ...) for
|
||||
;; compatibility with evaluators that support only single-expression bodies.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Signal basics extended
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "signal-basics-extended"
|
||||
(deftest "signal with nil initial value"
|
||||
(let ((s (signal nil)))
|
||||
(assert-true (signal? s))
|
||||
(assert-nil (deref s))))
|
||||
|
||||
(deftest "signal with list value"
|
||||
(let ((s (signal (list 1 2 3))))
|
||||
(assert-equal (list 1 2 3) (deref s))
|
||||
(reset! s (list 4 5 6))
|
||||
(assert-equal (list 4 5 6) (deref s))))
|
||||
|
||||
(deftest "signal with dict value"
|
||||
(let ((s (signal {:name "alice" :score 42})))
|
||||
(assert-equal "alice" (get (deref s) "name"))
|
||||
(assert-equal 42 (get (deref s) "score"))))
|
||||
|
||||
(deftest "signal with lambda value"
|
||||
(let ((fn-val (fn (x) (* x 2)))
|
||||
(s (signal nil)))
|
||||
(reset! s fn-val)
|
||||
;; The stored lambda should be callable
|
||||
(assert-equal 10 ((deref s) 5))))
|
||||
|
||||
(deftest "multiple signals independent of each other"
|
||||
(let ((a (signal 1))
|
||||
(b (signal 2))
|
||||
(c (signal 3)))
|
||||
(reset! a 10)
|
||||
;; b and c must be unchanged
|
||||
(assert-equal 10 (deref a))
|
||||
(assert-equal 2 (deref b))
|
||||
(assert-equal 3 (deref c))
|
||||
(reset! b 20)
|
||||
(assert-equal 10 (deref a))
|
||||
(assert-equal 20 (deref b))
|
||||
(assert-equal 3 (deref c))))
|
||||
|
||||
(deftest "deref returns current value not a stale snapshot"
|
||||
(let ((s (signal "first")))
|
||||
(let ((snap1 (deref s)))
|
||||
(reset! s "second")
|
||||
(let ((snap2 (deref s)))
|
||||
;; snap1 holds the string "first" (immutable), snap2 is "second"
|
||||
(assert-equal "first" snap1)
|
||||
(assert-equal "second" snap2))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Computed chains
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "computed-chains"
|
||||
(deftest "chain of three computed signals"
|
||||
(let ((base (signal 2))
|
||||
(doubled (computed (fn () (* 2 (deref base)))))
|
||||
(tripled (computed (fn () (* 3 (deref doubled))))))
|
||||
;; Initial: base=2 → doubled=4 → tripled=12
|
||||
(assert-equal 4 (deref doubled))
|
||||
(assert-equal 12 (deref tripled))
|
||||
;; Update propagates through the entire chain
|
||||
(reset! base 5)
|
||||
(assert-equal 10 (deref doubled))
|
||||
(assert-equal 30 (deref tripled))))
|
||||
|
||||
(deftest "computed depending on multiple signals"
|
||||
(let ((x (signal 3))
|
||||
(y (signal 4))
|
||||
(hypo (computed (fn ()
|
||||
;; sqrt(x^2 + y^2) — Pythagorean hypotenuse (integer approx)
|
||||
(+ (* (deref x) (deref x))
|
||||
(* (deref y) (deref y)))))))
|
||||
(assert-equal 25 (deref hypo))
|
||||
(reset! x 0)
|
||||
(assert-equal 16 (deref hypo))
|
||||
(reset! y 0)
|
||||
(assert-equal 0 (deref hypo))))
|
||||
|
||||
(deftest "computed with conditional logic"
|
||||
(let ((flag (signal true))
|
||||
(a (signal 10))
|
||||
(b (signal 99))
|
||||
(result (computed (fn ()
|
||||
(if (deref flag) (deref a) (deref b))))))
|
||||
(assert-equal 10 (deref result))
|
||||
(reset! flag false)
|
||||
(assert-equal 99 (deref result))
|
||||
(reset! b 42)
|
||||
(assert-equal 42 (deref result))
|
||||
(reset! flag true)
|
||||
(assert-equal 10 (deref result))))
|
||||
|
||||
(deftest "diamond dependency: A->B, A->C, B+C->D"
|
||||
;; A change in A must propagate via both B and C to D,
|
||||
;; but D must still hold a coherent (not intermediate) value.
|
||||
(let ((A (signal 1))
|
||||
(B (computed (fn () (* 2 (deref A)))))
|
||||
(C (computed (fn () (* 3 (deref A)))))
|
||||
(D (computed (fn () (+ (deref B) (deref C))))))
|
||||
;; A=1 → B=2, C=3 → D=5
|
||||
(assert-equal 2 (deref B))
|
||||
(assert-equal 3 (deref C))
|
||||
(assert-equal 5 (deref D))
|
||||
;; A=4 → B=8, C=12 → D=20
|
||||
(reset! A 4)
|
||||
(assert-equal 8 (deref B))
|
||||
(assert-equal 12 (deref C))
|
||||
(assert-equal 20 (deref D))))
|
||||
|
||||
(deftest "computed returns nil when source signal is nil"
|
||||
(let ((s (signal nil))
|
||||
(c (computed (fn ()
|
||||
(let ((v (deref s)))
|
||||
(when (not (nil? v)) (* v 2)))))))
|
||||
(assert-nil (deref c))
|
||||
(reset! s 7)
|
||||
(assert-equal 14 (deref c))
|
||||
(reset! s nil)
|
||||
(assert-nil (deref c)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Effect patterns
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "effect-patterns"
|
||||
(deftest "effect runs immediately on creation"
|
||||
(let ((ran (signal false)))
|
||||
(effect (fn () (reset! ran true)))
|
||||
(assert-true (deref ran))))
|
||||
|
||||
(deftest "effect re-runs when dependency changes"
|
||||
(let ((n (signal 0))
|
||||
(calls (signal 0)))
|
||||
(effect (fn () (do (deref n) (swap! calls inc))))
|
||||
;; Initial run counts as 1
|
||||
(assert-equal 1 (deref calls))
|
||||
(reset! n 1)
|
||||
(assert-equal 2 (deref calls))
|
||||
(reset! n 2)
|
||||
(assert-equal 3 (deref calls))))
|
||||
|
||||
(deftest "effect with multiple dependencies"
|
||||
(let ((a (signal "x"))
|
||||
(b (signal "y"))
|
||||
(calls (signal 0)))
|
||||
(effect (fn () (do (deref a) (deref b) (swap! calls inc))))
|
||||
(assert-equal 1 (deref calls))
|
||||
;; Changing a triggers re-run
|
||||
(reset! a "x2")
|
||||
(assert-equal 2 (deref calls))
|
||||
;; Changing b also triggers re-run
|
||||
(reset! b "y2")
|
||||
(assert-equal 3 (deref calls))))
|
||||
|
||||
(deftest "effect cleanup function called on re-run"
|
||||
(let ((trigger (signal 0))
|
||||
(cleanups (signal 0)))
|
||||
(effect (fn () (do
|
||||
(deref trigger)
|
||||
;; Return a cleanup function
|
||||
(fn () (swap! cleanups inc)))))
|
||||
;; First run — no previous cleanup to call
|
||||
(assert-equal 0 (deref cleanups))
|
||||
;; Second run — previous cleanup fires first
|
||||
(reset! trigger 1)
|
||||
(assert-equal 1 (deref cleanups))
|
||||
;; Third run — second cleanup fires
|
||||
(reset! trigger 2)
|
||||
(assert-equal 2 (deref cleanups))))
|
||||
|
||||
(deftest "effect tracks only actually-deref'd signals"
|
||||
;; An effect that conditionally reads signal B should only re-run
|
||||
;; for B changes when B is actually read (flag=true).
|
||||
(let ((flag (signal true))
|
||||
(b (signal 0))
|
||||
(calls (signal 0)))
|
||||
(effect (fn () (do
|
||||
(deref flag)
|
||||
(when (deref flag) (deref b))
|
||||
(swap! calls inc))))
|
||||
;; Initial run reads both flag and b
|
||||
(assert-equal 1 (deref calls))
|
||||
;; flip flag to false — re-run, but now b is NOT deref'd
|
||||
(reset! flag false)
|
||||
(assert-equal 2 (deref calls))
|
||||
;; Changing b should NOT trigger another run (b wasn't deref'd last time)
|
||||
(reset! b 99)
|
||||
(assert-equal 2 (deref calls)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Batch behavior
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "batch-behavior"
|
||||
(deftest "batch coalesces multiple signal updates into one effect run"
|
||||
(let ((a (signal 0))
|
||||
(b (signal 0))
|
||||
(run-count (signal 0)))
|
||||
(effect (fn () (do (deref a) (deref b) (swap! run-count inc))))
|
||||
;; Initial run
|
||||
(assert-equal 1 (deref run-count))
|
||||
;; Two writes inside a single batch → one effect run, not two
|
||||
(batch (fn () (do
|
||||
(reset! a 1)
|
||||
(reset! b 2))))
|
||||
(assert-equal 2 (deref run-count))))
|
||||
|
||||
(deftest "nested batch — inner batch does not flush, outer batch does"
|
||||
(let ((s (signal 0))
|
||||
(run-count (signal 0)))
|
||||
(effect (fn () (do (deref s) (swap! run-count inc))))
|
||||
(assert-equal 1 (deref run-count))
|
||||
(batch (fn ()
|
||||
(batch (fn ()
|
||||
(reset! s 1)))
|
||||
;; Still inside outer batch — should not have fired yet
|
||||
(reset! s 2)))
|
||||
;; Outer batch ends → exactly one more run
|
||||
(assert-equal 2 (deref run-count))
|
||||
;; Final value is the last write
|
||||
(assert-equal 2 (deref s))))
|
||||
|
||||
(deftest "batch with computed — computed updates once not per signal write"
|
||||
(let ((x (signal 0))
|
||||
(y (signal 0))
|
||||
(sum (computed (fn () (+ (deref x) (deref y)))))
|
||||
(recomps (signal 0)))
|
||||
;; Track recomputations by wrapping via an effect
|
||||
(effect (fn () (do (deref sum) (swap! recomps inc))))
|
||||
;; Initial: effect + computed both ran once
|
||||
(assert-equal 1 (deref recomps))
|
||||
(batch (fn () (do
|
||||
(reset! x 10)
|
||||
(reset! y 20))))
|
||||
;; sum must reflect both changes
|
||||
(assert-equal 30 (deref sum))
|
||||
;; effect re-ran at most once more (not twice)
|
||||
(assert-equal 2 (deref recomps))))
|
||||
|
||||
(deftest "batch executes the thunk"
|
||||
;; batch runs the thunk for side effects; return value is implementation-defined
|
||||
(let ((s (signal 0)))
|
||||
(batch (fn () (reset! s 42)))
|
||||
(assert-equal 42 (deref s)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Swap patterns
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "swap-patterns"
|
||||
(deftest "swap! with increment function"
|
||||
(let ((n (signal 0)))
|
||||
(swap! n inc)
|
||||
(assert-equal 1 (deref n))
|
||||
(swap! n inc)
|
||||
(assert-equal 2 (deref n))))
|
||||
|
||||
(deftest "swap! with list append"
|
||||
(let ((items (signal (list))))
|
||||
(swap! items (fn (l) (append l "a")))
|
||||
(swap! items (fn (l) (append l "b")))
|
||||
(swap! items (fn (l) (append l "c")))
|
||||
(assert-equal (list "a" "b" "c") (deref items))))
|
||||
|
||||
(deftest "swap! with dict assoc"
|
||||
(let ((store (signal {})))
|
||||
(swap! store (fn (d) (assoc d "x" 1)))
|
||||
(swap! store (fn (d) (assoc d "y" 2)))
|
||||
(assert-equal 1 (get (deref store) "x"))
|
||||
(assert-equal 2 (get (deref store) "y"))))
|
||||
|
||||
(deftest "multiple swap! in sequence build up correct value"
|
||||
(let ((acc (signal 0)))
|
||||
(swap! acc + 10)
|
||||
(swap! acc + 5)
|
||||
(swap! acc - 3)
|
||||
(assert-equal 12 (deref acc)))))
|
||||
@@ -1,5 +1,16 @@
|
||||
# syntax=docker/dockerfile:1
|
||||
|
||||
# --- Stage 1: Build OCaml SX kernel ---
|
||||
FROM ocaml/opam:debian-12-ocaml-5.2 AS ocaml-build
|
||||
USER opam
|
||||
WORKDIR /home/opam/sx
|
||||
COPY --chown=opam:opam hosts/ocaml/dune-project ./
|
||||
COPY --chown=opam:opam hosts/ocaml/lib/ ./lib/
|
||||
COPY --chown=opam:opam hosts/ocaml/bin/dune hosts/ocaml/bin/run_tests.ml \
|
||||
hosts/ocaml/bin/debug_set.ml hosts/ocaml/bin/sx_server.ml ./bin/
|
||||
RUN eval $(opam env) && dune build bin/sx_server.exe
|
||||
|
||||
# --- Stage 2: Python app ---
|
||||
FROM python:3.11-slim AS base
|
||||
|
||||
ENV PYTHONDONTWRITEBYTECODE=1 \
|
||||
@@ -49,6 +60,9 @@ COPY likes/models/ ./likes/models/
|
||||
COPY orders/__init__.py ./orders/__init__.py
|
||||
COPY orders/models/ ./orders/models/
|
||||
|
||||
# OCaml SX kernel binary
|
||||
COPY --from=ocaml-build /home/opam/sx/_build/default/bin/sx_server.exe /app/bin/sx_server
|
||||
|
||||
COPY sx/entrypoint.sh /usr/local/bin/entrypoint.sh
|
||||
RUN chmod +x /usr/local/bin/entrypoint.sh
|
||||
|
||||
|
||||
15
sx/app.py
15
sx/app.py
@@ -148,6 +148,21 @@ def create_app() -> "Quart":
|
||||
target = path + "/" + ("?" + qs if qs else "")
|
||||
return redirect(target, 301)
|
||||
|
||||
@app.get("/sx/_engine")
|
||||
async def sx_engine_info():
|
||||
"""Diagnostic: which SX engine is active."""
|
||||
import os, json
|
||||
info = {"engine": "python-ref", "ocaml": False}
|
||||
if os.environ.get("SX_USE_OCAML") == "1":
|
||||
try:
|
||||
from shared.sx.ocaml_bridge import get_bridge
|
||||
bridge = await get_bridge()
|
||||
engine = await bridge.ping()
|
||||
info = {"engine": engine, "ocaml": True, "pid": bridge._proc.pid}
|
||||
except Exception as e:
|
||||
info = {"engine": "ocaml-error", "ocaml": False, "error": str(e)}
|
||||
return json.dumps(info), 200, {"Content-Type": "application/json"}
|
||||
|
||||
@app.get("/sx/")
|
||||
async def sx_home():
|
||||
"""SX docs home page."""
|
||||
|
||||
@@ -541,6 +541,9 @@
|
||||
"sx-forge" '(~plans/sx-forge/plan-sx-forge-content)
|
||||
"sx-swarm" '(~plans/sx-swarm/plan-sx-swarm-content)
|
||||
"sx-proxy" '(~plans/sx-proxy/plan-sx-proxy-content)
|
||||
"mother-language" '(~plans/mother-language/plan-mother-language-content)
|
||||
"isolated-evaluator" '(~plans/isolated-evaluator/plan-isolated-evaluator-content)
|
||||
"rust-wasm-host" '(~plans/rust-wasm-host/plan-rust-wasm-host-content)
|
||||
"async-eval-convergence" '(~plans/async-eval-convergence/plan-async-eval-convergence-content)
|
||||
"wasm-bytecode-vm" '(~plans/wasm-bytecode-vm/plan-wasm-bytecode-vm-content)
|
||||
"generative-sx" '(~plans/generative-sx/plan-generative-sx-content)
|
||||
|
||||
@@ -231,15 +231,135 @@
|
||||
(tr (td :class "pr-4 py-1" "3")
|
||||
(td :class "pr-4" "Content-addressed computation")
|
||||
(td :class "text-emerald-600 font-semibold" "\u2714 Done \u2014 content-hash, freeze-to-cid, thaw-from-cid"))
|
||||
(tr (td :class "pr-4 py-1" "3.5")
|
||||
(td :class "pr-4" "Data representations")
|
||||
(td :class "text-stone-400" "Planned — byte buffers + typed structs"))
|
||||
(tr (td :class "pr-4 py-1" "4")
|
||||
(td :class "pr-4" "Concurrent CEK")
|
||||
(td :class "text-amber-600 font-semibold" "Spec complete \u2014 implementation next"))
|
||||
(td :class "text-amber-600 font-semibold" "Spec complete — implementation next"))
|
||||
(tr (td :class "pr-4 py-1" "5")
|
||||
(td :class "pr-4" "Linear effects")
|
||||
(td :class "text-stone-400" "Future")))))
|
||||
|
||||
;; -----------------------------------------------------------------------
|
||||
;; Step 4: Concurrent CEK \u2014 deep spec
|
||||
;; Step 3.5: Data Representations
|
||||
;; -----------------------------------------------------------------------
|
||||
|
||||
(h2 :class "text-xl font-bold mt-12 mb-4" "Step 3.5: Data Representations")
|
||||
|
||||
(p "Two primitives that sit below concurrency but above the raw CEK machine. "
|
||||
"Both are about how values are represented — enabling work that's currently host-only.")
|
||||
|
||||
(h3 :class "text-lg font-semibold mt-8 mb-3" "3.5a Byte Buffers")
|
||||
|
||||
(p "Fixed-size mutable byte arrays. A small primitive surface that unlocks "
|
||||
"binary protocol parsing, image headers, wire formats, and efficient CID computation:")
|
||||
|
||||
(~docs/code :code
|
||||
(str ";; Create and write\n"
|
||||
"(let ((buf (make-buffer 256)))\n"
|
||||
" (buffer-write-u8! buf 0 #xFF)\n"
|
||||
" (buffer-write-u32! buf 1 magic-number)\n"
|
||||
" (buffer-slice buf 0 5))\n"
|
||||
"\n"
|
||||
";; Read from network/file\n"
|
||||
"(let ((header (buffer-slice packet 0 12)))\n"
|
||||
" (case (buffer-read-u8 header 0)\n"
|
||||
" (1 (parse-handshake header))\n"
|
||||
" (2 (parse-data header))\n"
|
||||
" (else (error \"unknown packet type\"))))"))
|
||||
|
||||
(p "Primitives:")
|
||||
|
||||
(ul :class "list-disc pl-6 mb-4 space-y-1"
|
||||
(li (code "make-buffer") " — allocate N zero-filled bytes")
|
||||
(li (code "buffer-read-u8/u16/u32") ", " (code "buffer-read-i8/i16/i32") " — typed reads at offset")
|
||||
(li (code "buffer-write-u8!/u16!/u32!") " — typed writes at offset (big-endian default)")
|
||||
(li (code "buffer-slice") " — zero-copy view of a region")
|
||||
(li (code "buffer-length") " — byte count")
|
||||
(li (code "buffer->list") ", " (code "list->buffer") " — conversion to/from byte lists")
|
||||
(li (code "buffer->string") ", " (code "string->buffer") " — UTF-8 encode/decode"))
|
||||
|
||||
(p "Host mapping:")
|
||||
|
||||
(div :class "overflow-x-auto mb-6"
|
||||
(table :class "min-w-full text-sm"
|
||||
(thead (tr
|
||||
(th :class "text-left pr-4 pb-2 font-semibold" "Primitive")
|
||||
(th :class "text-left pr-4 pb-2 font-semibold" "JavaScript")
|
||||
(th :class "text-left pr-4 pb-2 font-semibold" "Python")
|
||||
(th :class "text-left pb-2 font-semibold" "OCaml")))
|
||||
(tbody
|
||||
(tr (td :class "pr-4 py-1 font-mono" "make-buffer")
|
||||
(td :class "pr-4" "new ArrayBuffer(n)")
|
||||
(td :class "pr-4" "bytearray(n)")
|
||||
(td "Bytes.create n"))
|
||||
(tr (td :class "pr-4 py-1 font-mono" "buffer-read-u32")
|
||||
(td :class "pr-4" "DataView.getUint32")
|
||||
(td :class "pr-4" "struct.unpack_from")
|
||||
(td "Bytes.get_int32_be"))
|
||||
(tr (td :class "pr-4 py-1 font-mono" "buffer-slice")
|
||||
(td :class "pr-4" "new Uint8Array(buf, off, len)")
|
||||
(td :class "pr-4" "memoryview(buf)[off:off+len]")
|
||||
(td "Bytes.sub buf off len")))))
|
||||
|
||||
(p "Byte buffers connect directly to content addressing (Step 3). "
|
||||
"Computing a CID currently requires host-side hashing of opaque SX text. "
|
||||
"With buffers, the hash input can be a canonical binary representation — "
|
||||
"deterministic, compact, and consistent across hosts.")
|
||||
|
||||
(h3 :class "text-lg font-semibold mt-8 mb-3" "3.5b Typed Structs")
|
||||
|
||||
(p "Named product types with fixed fields. On interpreted hosts, structs are syntactic sugar over dicts. "
|
||||
"On compiled hosts (OCaml, Rust), they compile to unboxed records — no dict overhead, "
|
||||
"no hash lookups, no string key comparisons:")
|
||||
|
||||
(~docs/code :code
|
||||
(str ";; Define a struct\n"
|
||||
"(defstruct point (x : number) (y : number))\n"
|
||||
"\n"
|
||||
";; Construct\n"
|
||||
"(let ((p (make-point 3 4)))\n"
|
||||
" ;; Access — compiles to field offset on native hosts\n"
|
||||
" (+ (point-x p) (point-y p))) ;; => 7\n"
|
||||
"\n"
|
||||
";; Pattern match\n"
|
||||
"(case p\n"
|
||||
" ((point x y) (sqrt (+ (* x x) (* y y))))) ;; => 5"))
|
||||
|
||||
(p "What " (code "defstruct") " generates:")
|
||||
|
||||
(ul :class "list-disc pl-6 mb-4 space-y-1"
|
||||
(li (code "make-point") " — constructor (arity-checked)")
|
||||
(li (code "point?") " — type predicate")
|
||||
(li (code "point-x") ", " (code "point-y") " — field accessors")
|
||||
(li (code "point") " — case pattern for destructuring"))
|
||||
|
||||
(p "The performance difference matters for compiled hosts:")
|
||||
|
||||
(div :class "overflow-x-auto mb-6"
|
||||
(table :class "min-w-full text-sm"
|
||||
(thead (tr
|
||||
(th :class "text-left pr-4 pb-2 font-semibold" "Operation")
|
||||
(th :class "text-left pr-4 pb-2 font-semibold" "Dict (current)")
|
||||
(th :class "text-left pb-2 font-semibold" "Struct (compiled)")))
|
||||
(tbody
|
||||
(tr (td :class "pr-4 py-1" "Field access")
|
||||
(td :class "pr-4" "Hash lookup — O(1) amortized, cache-unfriendly")
|
||||
(td "Offset load — O(1) actual, single instruction"))
|
||||
(tr (td :class "pr-4 py-1" "Construction")
|
||||
(td :class "pr-4" "Allocate hash table + insert N entries")
|
||||
(td "Allocate N words, write sequentially"))
|
||||
(tr (td :class "pr-4 py-1" "Pattern match")
|
||||
(td :class "pr-4" "N string comparisons")
|
||||
(td "Tag check + field projection")))))
|
||||
|
||||
(p "Typed structs connect to the gradual type system in " (code "types.sx") ". "
|
||||
"A " (code "defstruct") " declaration is a type definition that the type checker can verify "
|
||||
"and the compiler can exploit. On interpreted hosts, the same code runs — just slower.")
|
||||
|
||||
;; -----------------------------------------------------------------------
|
||||
;; Step 4: Concurrent CEK — deep spec
|
||||
;; -----------------------------------------------------------------------
|
||||
|
||||
(h2 :class "text-xl font-bold mt-12 mb-4" "Step 4: Concurrent CEK")
|
||||
@@ -449,33 +569,33 @@
|
||||
(th :class "text-left pr-4 pb-2 font-semibold" "Primitive")
|
||||
(th :class "text-left pr-4 pb-2 font-semibold" "JavaScript")
|
||||
(th :class "text-left pr-4 pb-2 font-semibold" "Python")
|
||||
(th :class "text-left pr-4 pb-2 font-semibold" "Haskell")
|
||||
(th :class "text-left pr-4 pb-2 font-semibold" "OCaml")
|
||||
(th :class "text-left pb-2 font-semibold" "Rust/WASM")))
|
||||
(tbody
|
||||
(tr (td :class "pr-4 py-1 font-mono" "spawn")
|
||||
(td :class "pr-4" "Web Worker")
|
||||
(td :class "pr-4" "asyncio.create_task")
|
||||
(td :class "pr-4" "forkIO")
|
||||
(td :class "pr-4" "Eio.Fiber.fork")
|
||||
(td "tokio::spawn"))
|
||||
(tr (td :class "pr-4 py-1 font-mono" "channel")
|
||||
(td :class "pr-4" "MessageChannel")
|
||||
(td :class "pr-4" "asyncio.Queue")
|
||||
(td :class "pr-4" "TChan (STM)")
|
||||
(td :class "pr-4" "Eio.Stream.t")
|
||||
(td "mpsc::channel"))
|
||||
(tr (td :class "pr-4 py-1 font-mono" "yield!")
|
||||
(td :class "pr-4" "setTimeout(0)")
|
||||
(td :class "pr-4" "await asyncio.sleep(0)")
|
||||
(td :class "pr-4" "threadDelay 0")
|
||||
(td :class "pr-4" "Eio.Fiber.yield")
|
||||
(td "tokio::task::yield_now"))
|
||||
(tr (td :class "pr-4 py-1 font-mono" "freeze/thaw")
|
||||
(td :class "pr-4" "postMessage + JSON")
|
||||
(td :class "pr-4" "pickle / SX text")
|
||||
(td :class "pr-4" "Serialise + SX text")
|
||||
(td :class "pr-4" "Marshal + SX text")
|
||||
(td "serde + SX text"))
|
||||
(tr (td :class "pr-4 py-1 font-mono" "select")
|
||||
(td :class "pr-4" "Promise.race")
|
||||
(td :class "pr-4" "asyncio.wait FIRST_COMPLETED")
|
||||
(td :class "pr-4" "STM orElse")
|
||||
(td :class "pr-4" "Eio.Fiber.any")
|
||||
(td "tokio::select!")))))
|
||||
|
||||
(h3 :class "text-lg font-semibold mt-8 mb-3" "4.7 Roadmap")
|
||||
@@ -501,9 +621,9 @@
|
||||
(td :class "pr-4" "JavaScript")
|
||||
(td "Art DAG integration path"))
|
||||
(tr (td :class "pr-4 py-1" "4d")
|
||||
(td :class "pr-4" "Haskell bootstrapper")
|
||||
(td :class "pr-4" "Haskell")
|
||||
(td "Spec portability, native concurrency"))
|
||||
(td :class "pr-4" "OCaml bootstrapper → native compilation")
|
||||
(td :class "pr-4" "OCaml")
|
||||
(td "Native performance, direct CEK-to-ML mapping"))
|
||||
(tr (td :class "pr-4 py-1" "4e")
|
||||
(td :class "pr-4" "Rust/WASM bootstrapper")
|
||||
(td :class "pr-4" "Rust")
|
||||
@@ -526,8 +646,8 @@
|
||||
(td "Resource safety, exactly-once delivery")))))
|
||||
|
||||
(p "Each phase is independently valuable. Phase 4a (Web Worker spawn) is the immediate next build. "
|
||||
"Phase 4d (Haskell) proves the spec is truly host-independent. "
|
||||
"Phase 4e (Rust/WASM) proves it can be fast. "
|
||||
"Phase 4d (OCaml) proves the spec compiles to native code — the CEK machine maps directly to ML's runtime model. "
|
||||
"Phase 4e (Rust/WASM) proves it can run in the browser at near-native speed. "
|
||||
"Phase 4g (IPFS) makes it distributed.")
|
||||
|
||||
;; -----------------------------------------------------------------------
|
||||
|
||||
@@ -14,11 +14,20 @@ def setup_sx_pages() -> None:
|
||||
def _load_sx_page_files() -> None:
|
||||
"""Load defpage definitions from sx/sxc/pages/*.sx."""
|
||||
import os
|
||||
from shared.sx.pages import load_page_dir
|
||||
from shared.sx.pages import load_page_dir, get_page_helpers
|
||||
from shared.sx.jinja_bridge import load_sx_dir, watch_sx_dir, load_service_components
|
||||
_sxc_dir = os.path.dirname(os.path.dirname(__file__)) # sx/sxc/
|
||||
service_root = os.path.dirname(_sxc_dir) # sx/
|
||||
load_service_components(service_root, service_name="sx")
|
||||
load_sx_dir(_sxc_dir)
|
||||
watch_sx_dir(_sxc_dir)
|
||||
# Register page helpers as primitives so the CEK machine can find them
|
||||
# during nested async component expansion (e.g. highlight inside ~docs/code
|
||||
# inside a plan component inside ~layouts/doc). Without this, the env_merge
|
||||
# chain loses page helpers because component closures don't capture them.
|
||||
from shared.sx.ref.sx_ref import PRIMITIVES
|
||||
helpers = get_page_helpers("sx")
|
||||
for name, fn in helpers.items():
|
||||
PRIMITIVES[name] = fn
|
||||
import logging; logging.getLogger("sx.pages").info("Injected %d page helpers as primitives: %s", len(helpers), list(helpers.keys())[:5])
|
||||
load_page_dir(os.path.dirname(__file__), "sx")
|
||||
|
||||
@@ -569,6 +569,9 @@
|
||||
"sx-forge" (~plans/sx-forge/plan-sx-forge-content)
|
||||
"sx-swarm" (~plans/sx-swarm/plan-sx-swarm-content)
|
||||
"sx-proxy" (~plans/sx-proxy/plan-sx-proxy-content)
|
||||
"mother-language" (~plans/mother-language/plan-mother-language-content)
|
||||
"isolated-evaluator" (~plans/isolated-evaluator/plan-isolated-evaluator-content)
|
||||
"rust-wasm-host" (~plans/rust-wasm-host/plan-rust-wasm-host-content)
|
||||
"async-eval-convergence" (~plans/async-eval-convergence/plan-async-eval-convergence-content)
|
||||
"wasm-bytecode-vm" (~plans/wasm-bytecode-vm/plan-wasm-bytecode-vm-content)
|
||||
"generative-sx" (~plans/generative-sx/plan-generative-sx-content)
|
||||
@@ -580,9 +583,6 @@
|
||||
"foundations" (~plans/foundations/plan-foundations-content)
|
||||
"cek-reactive" (~plans/cek-reactive/plan-cek-reactive-content)
|
||||
"reactive-runtime" (~plans/reactive-runtime/plan-reactive-runtime-content)
|
||||
"rust-wasm-host" (~plans/rust-wasm-host/plan-rust-wasm-host-content)
|
||||
"isolated-evaluator" (~plans/isolated-evaluator/plan-isolated-evaluator-content)
|
||||
"mother-language" (~plans/mother-language/plan-mother-language-content)
|
||||
:else (~plans/index/plans-index-content))))
|
||||
|
||||
;; ---------------------------------------------------------------------------
|
||||
|
||||
@@ -344,3 +344,82 @@
|
||||
(deftest "scope pops correctly after body"
|
||||
(assert-equal "outer"
|
||||
(render-sx "(scope \"sc-pop\" :value \"outer\" (scope \"sc-pop\" :value \"inner\" \"ignore\") (context \"sc-pop\"))"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Error propagation — errors in aser control flow must throw, not silently
|
||||
;; produce wrong output or fall through to :else branches.
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "aser-error-propagation"
|
||||
|
||||
;; --- case: matched branch errors must throw, not fall through to :else ---
|
||||
|
||||
(deftest "case — error in matched branch throws, not falls through"
|
||||
;; If the matched case body references an undefined symbol, the aser must
|
||||
;; throw an error — NOT silently skip to :else.
|
||||
(assert-throws
|
||||
(fn () (render-sx "(case \"x\" \"x\" undefined-symbol-xyz :else \"fallback\")"))))
|
||||
|
||||
(deftest "case — :else body error also throws"
|
||||
(assert-throws
|
||||
(fn () (render-sx "(case \"no-match\" \"x\" \"ok\" :else undefined-symbol-xyz)"))))
|
||||
|
||||
(deftest "case — matched branch with nested error throws"
|
||||
;; Error inside a tag within the matched body must propagate.
|
||||
(assert-throws
|
||||
(fn () (render-sx "(case \"a\" \"a\" (div (p undefined-sym-abc)) :else (p \"index\"))"))))
|
||||
|
||||
;; --- cond: matched branch errors must throw ---
|
||||
|
||||
(deftest "cond — error in matched branch throws"
|
||||
(assert-throws
|
||||
(fn () (render-sx "(cond true undefined-cond-sym :else \"fallback\")"))))
|
||||
|
||||
(deftest "cond — error in :else branch throws"
|
||||
(assert-throws
|
||||
(fn () (render-sx "(cond false \"skip\" :else undefined-cond-sym)"))))
|
||||
|
||||
;; --- if/when: body errors must throw ---
|
||||
|
||||
(deftest "if — error in true branch throws"
|
||||
(assert-throws
|
||||
(fn () (render-sx "(if true undefined-if-sym \"fallback\")"))))
|
||||
|
||||
(deftest "when — error in body throws"
|
||||
(assert-throws
|
||||
(fn () (render-sx "(when true undefined-when-sym)"))))
|
||||
|
||||
;; --- let: binding or body errors must throw ---
|
||||
|
||||
(deftest "let — error in binding throws"
|
||||
(assert-throws
|
||||
(fn () (render-sx "(let ((x undefined-let-sym)) (p x))"))))
|
||||
|
||||
(deftest "let — error in body throws"
|
||||
(assert-throws
|
||||
(fn () (render-sx "(let ((x 1)) (p undefined-let-body-sym))"))))
|
||||
|
||||
;; --- begin/do: body errors must throw ---
|
||||
|
||||
(deftest "do — error in body throws"
|
||||
(assert-throws
|
||||
(fn () (render-sx "(do \"ok\" undefined-do-sym)"))))
|
||||
|
||||
;; --- component expansion inside case: the production bug ---
|
||||
|
||||
;; --- sync aser serializes components without expansion ---
|
||||
|
||||
(deftest "case — component in matched branch serializes unexpanded"
|
||||
;; Sync aser serializes component calls as SX wire format.
|
||||
;; Expansion only happens in async path with expand-components.
|
||||
(assert-equal "(~broken :title \"test\")"
|
||||
(render-sx
|
||||
"(do (defcomp ~broken (&key title) (div (p title) (p no-such-helper)))
|
||||
(case \"slug\" \"slug\" (~broken :title \"test\") :else \"index\"))")))
|
||||
|
||||
(deftest "case — unmatched falls through to :else correctly"
|
||||
(assert-equal "index"
|
||||
(render-sx
|
||||
"(do (defcomp ~page (&key x) (div x))
|
||||
(case \"miss\" \"hit\" (~page :x \"found\") :else \"index\"))"))))
|
||||
|
||||
Reference in New Issue
Block a user