4 Commits

Author SHA1 Message Date
5ab3ecb7e0 Add OCaml SX kernel build to sx_docs Docker image and enable in production
All checks were successful
Build and Deploy / build-and-deploy (push) Successful in 10m16s
Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
2026-03-15 23:34:50 +00:00
313f7d6be1 OCaml bootstrapper Phase 2: HTML renderer, SX server, Python bridge
Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
2026-03-15 23:28:48 +00:00
16fa813d6d Add hosts/ocaml/_build/ to .gitignore
Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
2026-03-15 20:52:43 +00:00
818e5d53f0 OCaml bootstrapper: transpiler compiles full CEK evaluator (61/61 tests)
SX-to-OCaml transpiler (transpiler.sx) generates sx_ref.ml (~90KB, ~135
mutually recursive functions) from the spec evaluator. Foundation tests
all pass: parser, primitives, env operations, type system.

Key design decisions:
- Env variant added to value type for CEK state dict storage
- Continuation carries optional data dict for captured frames
- Dynamic var tracking distinguishes OCaml fn calls from SX value dispatch
- Single let rec...and block for forward references between all defines
- Unused ref pre-declarations eliminated via let-bound name detection

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
2026-03-15 20:51:59 +00:00
24 changed files with 5914 additions and 14 deletions

1
.gitignore vendored
View File

@@ -14,3 +14,4 @@ _debug/
sx-haskell/
sx-rust/
shared/static/scripts/sx-full-test.js
hosts/ocaml/_build/

View File

@@ -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

View File

@@ -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

View 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
View File

@@ -0,0 +1,3 @@
(executables
(names run_tests debug_set sx_server)
(libraries sx))

View File

@@ -0,0 +1 @@
(executable (name debug_macro) (libraries sx))

View 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

View 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
View 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
View File

@@ -0,0 +1,2 @@
(lang dune 3.0)
(name sx)

2
hosts/ocaml/lib/dune Normal file
View File

@@ -0,0 +1,2 @@
(library
(name sx))

View 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

View 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

File diff suppressed because one or more lines are too long

View 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 "&amp;"
| '<' -> Buffer.add_string buf "&lt;"
| '>' -> Buffer.add_string buf "&gt;"
| '"' -> Buffer.add_string buf "&quot;"
| 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 "")

View 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
View 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

File diff suppressed because it is too large Load Diff

View File

@@ -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
View 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))}"'

View 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()

View File

@@ -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

View File

@@ -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."""

View File

@@ -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.")
;; -----------------------------------------------------------------------