Compare commits
5 Commits
3a268e7277
...
wasm
| Author | SHA1 | Date | |
|---|---|---|---|
| 0caa965de0 | |||
| 5ab3ecb7e0 | |||
| 313f7d6be1 | |||
| 16fa813d6d | |||
| 818e5d53f0 |
1
.gitignore
vendored
1
.gitignore
vendored
@@ -14,3 +14,4 @@ _debug/
|
||||
sx-haskell/
|
||||
sx-rust/
|
||||
shared/static/scripts/sx-full-test.js
|
||||
hosts/ocaml/_build/
|
||||
|
||||
@@ -13,7 +13,10 @@ 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_USE_WASM: "1"
|
||||
SX_DEV: "1"
|
||||
volumes:
|
||||
- /root/rose-ash/_config/dev-sh-config.yaml:/app/config/app-config.yaml:ro
|
||||
@@ -26,6 +29,8 @@ services:
|
||||
- ./sx/sx:/app/sx
|
||||
- ./sx/path_setup.py:/app/path_setup.py
|
||||
- ./sx/entrypoint.sh:/usr/local/bin/entrypoint.sh
|
||||
# OCaml SX kernel binary (built with: cd hosts/ocaml && eval $(opam env) && dune build)
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./sx/__init__.py:/app/__init__.py:ro
|
||||
# sibling models for cross-domain SQLAlchemy imports
|
||||
- ./blog/__init__.py:/app/blog/__init__.py:ro
|
||||
|
||||
@@ -228,6 +228,8 @@ services:
|
||||
<<: *app-env
|
||||
REDIS_URL: redis://redis:6379/10
|
||||
WORKERS: "1"
|
||||
SX_USE_OCAML: "1"
|
||||
SX_OCAML_BIN: "/app/bin/sx_server"
|
||||
|
||||
db:
|
||||
image: postgres:16
|
||||
|
||||
36
hosts/ocaml/bin/debug_set.ml
Normal file
36
hosts/ocaml/bin/debug_set.ml
Normal file
@@ -0,0 +1,36 @@
|
||||
module T = Sx_types
|
||||
module P = Sx_parser
|
||||
module R = Sx_ref
|
||||
open T
|
||||
|
||||
let () =
|
||||
let env = T.make_env () in
|
||||
let eval src =
|
||||
let exprs = P.parse_all src in
|
||||
let result = ref Nil in
|
||||
List.iter (fun e -> result := R.eval_expr e (Env env)) exprs;
|
||||
!result
|
||||
in
|
||||
(* Test 1: basic set! in closure *)
|
||||
let r = eval "(let ((x 0)) (set! x 42) x)" in
|
||||
Printf.printf "basic set!: %s (expect 42)\n%!" (T.inspect r);
|
||||
|
||||
(* Test 2: set! through lambda call *)
|
||||
let r = eval "(let ((x 0)) (let ((f (fn () (set! x 99)))) (f) x))" in
|
||||
Printf.printf "set! via lambda: %s (expect 99)\n%!" (T.inspect r);
|
||||
|
||||
(* Test 3: counter pattern *)
|
||||
let r = eval "(do (define make-counter (fn () (let ((c 0)) (fn () (set! c (+ c 1)) c)))) (let ((counter (make-counter))) (counter) (counter) (counter)))" in
|
||||
Printf.printf "counter: %s (expect 3)\n%!" (T.inspect r);
|
||||
|
||||
(* Test 4: set! in for-each *)
|
||||
let r = eval "(let ((total 0)) (for-each (fn (n) (set! total (+ total n))) (list 1 2 3 4 5)) total)" in
|
||||
Printf.printf "set! in for-each: %s (expect 15)\n%!" (T.inspect r);
|
||||
|
||||
(* Test 5: append! in for-each *)
|
||||
ignore (T.env_bind env "append!" (NativeFn ("append!", fun args ->
|
||||
match args with
|
||||
| [List items; v] -> List (items @ [v])
|
||||
| _ -> raise (Eval_error "append!: expected list and value"))));
|
||||
let r = eval "(let ((log (list))) (for-each (fn (x) (append! log x)) (list 1 2 3)) log)" in
|
||||
Printf.printf "append! in for-each: %s (expect (1 2 3))\n%!" (T.inspect r)
|
||||
3
hosts/ocaml/bin/dune
Normal file
3
hosts/ocaml/bin/dune
Normal file
@@ -0,0 +1,3 @@
|
||||
(executables
|
||||
(names run_tests debug_set sx_server)
|
||||
(libraries sx))
|
||||
1
hosts/ocaml/bin/dune_debug
Normal file
1
hosts/ocaml/bin/dune_debug
Normal file
@@ -0,0 +1 @@
|
||||
(executable (name debug_macro) (libraries sx))
|
||||
694
hosts/ocaml/bin/run_tests.ml
Normal file
694
hosts/ocaml/bin/run_tests.ml
Normal file
@@ -0,0 +1,694 @@
|
||||
(** 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 *)
|
||||
|
||||
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_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
|
||||
420
hosts/ocaml/bin/sx_server.ml
Normal file
420
hosts/ocaml/bin/sx_server.ml
Normal file
@@ -0,0 +1,420 @@
|
||||
(** 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 ...). *)
|
||||
|
||||
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 -> ()
|
||||
373
hosts/ocaml/bootstrap.py
Normal file
373
hosts/ocaml/bootstrap.py
Normal file
@@ -0,0 +1,373 @@
|
||||
#!/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.
|
||||
Strips :effects [...] annotations from defines."""
|
||||
from shared.sx.types import Keyword
|
||||
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])
|
||||
# Strip :effects [...] annotation if present
|
||||
# (define name :effects [...] body) → (define name body)
|
||||
cleaned = list(expr)
|
||||
if (len(cleaned) >= 4 and isinstance(cleaned[2], Keyword)
|
||||
and cleaned[2].name == "effects"):
|
||||
cleaned = [cleaned[0], cleaned[1]] + cleaned[4:]
|
||||
defines.append((name, cleaned))
|
||||
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 + reactive subscriber fix
|
||||
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
|
||||
|
||||
(* Strict mode refs — used by test runner, stubbed here *)
|
||||
let _strict_ref = ref Nil
|
||||
let _prim_param_types_ref = ref Nil
|
||||
let value_matches_type_p _v _t = Bool true
|
||||
|
||||
(* Override reactive_shift_deref to wrap subscriber as NativeFn.
|
||||
The transpiler emits bare OCaml closures for (fn () ...) but
|
||||
signal_add_sub_b expects SX values. *)
|
||||
let reactive_shift_deref sig' env kont =
|
||||
let scan_result = kont_capture_to_reactive_reset kont in
|
||||
let captured_frames = first scan_result in
|
||||
let reset_frame = nth scan_result (Number 1.0) in
|
||||
let remaining_kont = nth scan_result (Number 2.0) in
|
||||
let update_fn = get reset_frame (String "update-fn") in
|
||||
let sub_disposers = ref (List []) in
|
||||
let subscriber_fn () =
|
||||
List.iter (fun d -> ignore (cek_call d Nil)) (sx_to_list !sub_disposers);
|
||||
sub_disposers := List [];
|
||||
let new_reset = make_reactive_reset_frame env update_fn (Bool false) in
|
||||
let new_kont = prim_call "concat" [captured_frames; List [new_reset]; remaining_kont] in
|
||||
ignore (with_island_scope
|
||||
(fun d -> sub_disposers := sx_append_b !sub_disposers d; Nil)
|
||||
(fun () -> cek_run (make_cek_value (signal_value sig') env new_kont)));
|
||||
Nil
|
||||
in
|
||||
let subscriber = NativeFn ("reactive-subscriber", fun _args -> subscriber_fn ()) in
|
||||
ignore (signal_add_sub_b sig' subscriber);
|
||||
ignore (register_in_scope (fun () ->
|
||||
ignore (signal_remove_sub_b sig' subscriber);
|
||||
List.iter (fun d -> ignore (cek_call d Nil)) (sx_to_list !sub_disposers);
|
||||
Nil));
|
||||
let initial_kont = prim_call "concat" [captured_frames; List [reset_frame]; remaining_kont] in
|
||||
make_cek_value (signal_value sig') env initial_kont
|
||||
|
||||
"""
|
||||
|
||||
|
||||
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/fixups or that belong in web module
|
||||
skip = {"trampoline",
|
||||
# Freeze functions depend on signals.sx (web spec)
|
||||
"freeze-registry", "freeze-signal", "freeze-scope",
|
||||
"cek-freeze-scope", "cek-freeze-all",
|
||||
"cek-thaw-scope", "cek-thaw-all",
|
||||
"freeze-to-sx", "thaw-from-sx",
|
||||
"freeze-to-cid", "thaw-from-cid",
|
||||
"content-hash", "content-put", "content-get", "content-store"}
|
||||
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)
|
||||
|
||||
|
||||
WEB_PREAMBLE = """\
|
||||
(* sx_web.ml — Auto-generated from web adapters by hosts/ocaml/bootstrap.py *)
|
||||
(* Do not edit — regenerate with: python3 hosts/ocaml/bootstrap.py --web *)
|
||||
|
||||
[@@@warning "-26-27"]
|
||||
|
||||
open Sx_types
|
||||
open Sx_runtime
|
||||
|
||||
"""
|
||||
|
||||
# Web adapter files to transpile (dependency order)
|
||||
WEB_ADAPTER_FILES = [
|
||||
("signals.sx", "signals (reactive signal runtime)"),
|
||||
("deps.sx", "deps (component dependency analysis)"),
|
||||
("page-helpers.sx", "page-helpers (pure data transformation helpers)"),
|
||||
("router.sx", "router (client-side route matching)"),
|
||||
("adapter-html.sx", "adapter-html (HTML rendering adapter)"),
|
||||
]
|
||||
|
||||
|
||||
def compile_web_to_ml(web_dir: str | None = None) -> str:
|
||||
"""Compile web adapter SX files to OCaml source."""
|
||||
from shared.sx.ref.sx_ref import eval_expr, trampoline, make_env, sx_parse
|
||||
|
||||
if web_dir is None:
|
||||
web_dir = os.path.join(_PROJECT, "web")
|
||||
|
||||
# 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))
|
||||
|
||||
# Also load the evaluator defines so the transpiler knows about them
|
||||
spec_dir = os.path.join(_PROJECT, "spec")
|
||||
eval_path = os.path.join(spec_dir, "evaluator.sx")
|
||||
if os.path.exists(eval_path):
|
||||
with open(eval_path) as f:
|
||||
eval_defines = extract_defines(f.read())
|
||||
eval_names = [n for n, _ in eval_defines]
|
||||
else:
|
||||
eval_names = []
|
||||
|
||||
parts = [WEB_PREAMBLE]
|
||||
|
||||
# Collect all web adapter defines
|
||||
all_defines = []
|
||||
for filename, label in WEB_ADAPTER_FILES:
|
||||
filepath = os.path.join(web_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)
|
||||
|
||||
# Deduplicate within file
|
||||
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]
|
||||
|
||||
all_defines.extend(defines)
|
||||
print(f" {filename}: {len(defines)} defines", file=sys.stderr)
|
||||
|
||||
# Deduplicate across files (last wins)
|
||||
seen = {}
|
||||
for i, (n, e) in enumerate(all_defines):
|
||||
seen[n] = i
|
||||
all_defines = [(n, e) for i, (n, e) in enumerate(all_defines) if seen[n] == i]
|
||||
|
||||
print(f" Total: {len(all_defines)} unique defines", file=sys.stderr)
|
||||
|
||||
# Build the defines list for the transpiler
|
||||
defines_list = [[name, expr] for name, expr in all_defines]
|
||||
env["_defines"] = defines_list
|
||||
|
||||
# Known defines = evaluator names + web adapter names
|
||||
env["_known_defines"] = eval_names + [name for name, _ in all_defines]
|
||||
|
||||
# Translate
|
||||
translate_expr = sx_parse("(ml-translate-file _defines)")[0]
|
||||
result = trampoline(eval_expr(translate_expr, env))
|
||||
|
||||
parts.append("\n(* === Transpiled from web adapters === *)\n")
|
||||
parts.append(result)
|
||||
|
||||
# Registration function — extract actual OCaml names from transpiled output
|
||||
# by using the same transpiler mangling.
|
||||
# Ask the transpiler for the mangled name of each define.
|
||||
name_map = {}
|
||||
for name, _ in all_defines:
|
||||
mangle_expr = sx_parse(f'(ml-mangle "{name}")')[0]
|
||||
mangled = trampoline(eval_expr(mangle_expr, env))
|
||||
name_map[name] = mangled
|
||||
|
||||
def count_params(expr):
|
||||
"""Count actual params from a (define name [annotations] (fn (params...) body)) form."""
|
||||
# Find the (fn ...) form — it might be at index 2, 3, or 4 depending on annotations
|
||||
fn_expr = None
|
||||
for i in range(2, min(len(expr), 6)):
|
||||
if (isinstance(expr[i], list) and expr[i] and
|
||||
isinstance(expr[i][0], Symbol) and expr[i][0].name in ("fn", "lambda")):
|
||||
fn_expr = expr[i]
|
||||
break
|
||||
if fn_expr is None:
|
||||
return -1 # not a function
|
||||
params = fn_expr[1] if isinstance(fn_expr[1], list) else []
|
||||
n = 0
|
||||
skip = False
|
||||
for p in params:
|
||||
if skip:
|
||||
skip = False
|
||||
continue
|
||||
if isinstance(p, Symbol) and p.name in ("&key", "&rest"):
|
||||
skip = True
|
||||
continue
|
||||
if isinstance(p, list) and len(p) >= 3: # (name :as type)
|
||||
n += 1
|
||||
elif isinstance(p, Symbol):
|
||||
n += 1
|
||||
return n
|
||||
|
||||
parts.append("\n\n(* Register all web adapter functions into an environment *)\n")
|
||||
parts.append("let register_web_adapters env =\n")
|
||||
for name, expr in all_defines:
|
||||
mangled = name_map[name]
|
||||
n = count_params(expr)
|
||||
if n < 0:
|
||||
# Non-function define (constant)
|
||||
parts.append(f' ignore (Sx_types.env_bind env "{name}" {mangled});\n')
|
||||
elif n == 0:
|
||||
parts.append(f' ignore (Sx_types.env_bind env "{name}" '
|
||||
f'(NativeFn ("{name}", fun _args -> {mangled} Nil)));\n')
|
||||
else:
|
||||
# Generate match with correct arity
|
||||
arg_names = [chr(97 + i) for i in range(n)] # a, b, c, ...
|
||||
pat = "; ".join(arg_names)
|
||||
call = " ".join(arg_names)
|
||||
# Pad with Nil for partial application
|
||||
pad_call = " ".join(arg_names[:1] + ["Nil"] * (n - 1)) if n > 1 else arg_names[0]
|
||||
parts.append(f' ignore (Sx_types.env_bind env "{name}" '
|
||||
f'(NativeFn ("{name}", fun args -> match args with '
|
||||
f'| [{pat}] -> {mangled} {call} '
|
||||
f'| _ -> raise (Eval_error "{name}: expected {n} args"))));\n')
|
||||
parts.append(" ()\n")
|
||||
|
||||
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)",
|
||||
)
|
||||
parser.add_argument(
|
||||
"--web",
|
||||
action="store_true",
|
||||
help="Compile web adapters instead of evaluator spec",
|
||||
)
|
||||
parser.add_argument(
|
||||
"--web-output",
|
||||
default=None,
|
||||
help="Output file for web adapters (default: stdout)",
|
||||
)
|
||||
args = parser.parse_args()
|
||||
|
||||
if args.web or args.web_output:
|
||||
result = compile_web_to_ml()
|
||||
out = args.web_output or args.output
|
||||
if out:
|
||||
with open(out, "w") as f:
|
||||
f.write(result)
|
||||
size = os.path.getsize(out)
|
||||
print(f"Wrote {out} ({size} bytes)", file=sys.stderr)
|
||||
else:
|
||||
print(result)
|
||||
else:
|
||||
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()
|
||||
37
hosts/ocaml/browser/build.sh
Executable file
37
hosts/ocaml/browser/build.sh
Executable file
@@ -0,0 +1,37 @@
|
||||
#!/usr/bin/env bash
|
||||
# Build the OCaml SX engine for browser use (WASM + JS fallback).
|
||||
#
|
||||
# Outputs:
|
||||
# _build/default/browser/sx_browser.bc.wasm.js WASM loader
|
||||
# _build/default/browser/sx_browser.bc.wasm.assets/ WASM modules
|
||||
# _build/default/browser/sx_browser.bc.js JS fallback
|
||||
#
|
||||
# Usage:
|
||||
# cd hosts/ocaml && ./browser/build.sh
|
||||
|
||||
set -euo pipefail
|
||||
cd "$(dirname "$0")/.."
|
||||
|
||||
eval $(opam env 2>/dev/null || true)
|
||||
|
||||
echo "=== Building OCaml SX browser engine ==="
|
||||
|
||||
# Build all targets: bytecode, JS, WASM
|
||||
dune build browser/sx_browser.bc.js browser/sx_browser.bc.wasm.js
|
||||
|
||||
echo ""
|
||||
echo "--- Output sizes ---"
|
||||
echo -n "JS (unoptimized): "; ls -lh _build/default/browser/sx_browser.bc.js | awk '{print $5}'
|
||||
echo -n "WASM loader: "; ls -lh _build/default/browser/sx_browser.bc.wasm.js | awk '{print $5}'
|
||||
echo -n "WASM modules: "; du -sh _build/default/browser/sx_browser.bc.wasm.assets/*.wasm | awk '{s+=$1}END{print s"K"}'
|
||||
|
||||
# Optimized JS build
|
||||
js_of_ocaml --opt=3 -o _build/default/browser/sx_browser.opt.js _build/default/browser/sx_browser.bc
|
||||
echo -n "JS (optimized): "; ls -lh _build/default/browser/sx_browser.opt.js | awk '{print $5}'
|
||||
|
||||
echo ""
|
||||
echo "=== Build complete ==="
|
||||
echo ""
|
||||
echo "Test with:"
|
||||
echo " node hosts/ocaml/browser/run_tests_js.js # JS"
|
||||
echo " node --experimental-wasm-imported-strings hosts/ocaml/browser/run_tests_wasm.js # WASM"
|
||||
139
hosts/ocaml/browser/bundle.sh
Executable file
139
hosts/ocaml/browser/bundle.sh
Executable file
@@ -0,0 +1,139 @@
|
||||
#!/usr/bin/env bash
|
||||
# Bundle the WASM engine + platform + web adapters into shared/static/scripts/
|
||||
#
|
||||
# Usage: hosts/ocaml/browser/bundle.sh
|
||||
|
||||
set -euo pipefail
|
||||
cd "$(dirname "$0")/../../.."
|
||||
|
||||
WASM_LOADER="hosts/ocaml/_build/default/browser/sx_browser.bc.wasm.js"
|
||||
WASM_ASSETS="hosts/ocaml/_build/default/browser/sx_browser.bc.wasm.assets"
|
||||
PLATFORM="hosts/ocaml/browser/sx-platform.js"
|
||||
OUT="shared/static/scripts/sx-wasm.js"
|
||||
ASSET_DIR="shared/static/scripts/sx-wasm-assets"
|
||||
|
||||
if [ ! -f "$WASM_LOADER" ]; then
|
||||
echo "Build first: cd hosts/ocaml && eval \$(opam env) && dune build browser/sx_browser.bc.wasm.js"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
# 1. WASM loader (patched asset path)
|
||||
sed 's|"src":"sx_browser.bc.wasm.assets"|"src":"sx-wasm-assets"|' \
|
||||
"$WASM_LOADER" > "$OUT"
|
||||
|
||||
# 2. Platform layer
|
||||
echo "" >> "$OUT"
|
||||
cat "$PLATFORM" >> "$OUT"
|
||||
|
||||
# 3. Embedded web adapters — SX source as JS string constants
|
||||
echo "" >> "$OUT"
|
||||
echo "// =========================================================================" >> "$OUT"
|
||||
echo "// Embedded web adapters (loaded into WASM engine at boot)" >> "$OUT"
|
||||
echo "// =========================================================================" >> "$OUT"
|
||||
echo "globalThis.__sxAdapters = {};" >> "$OUT"
|
||||
|
||||
# Adapters to embed (order matters for dependencies)
|
||||
ADAPTERS="signals deps page-helpers router adapter-html"
|
||||
|
||||
for name in $ADAPTERS; do
|
||||
file="web/${name}.sx"
|
||||
if [ -f "$file" ]; then
|
||||
echo -n "globalThis.__sxAdapters[\"${name}\"] = " >> "$OUT"
|
||||
# Escape the SX source for embedding in a JS string
|
||||
python3 -c "
|
||||
import json, sys
|
||||
with open('$file') as f:
|
||||
print(json.dumps(f.read()) + ';')
|
||||
" >> "$OUT"
|
||||
fi
|
||||
done
|
||||
|
||||
# 4. Boot shim
|
||||
cat >> "$OUT" << 'BOOT'
|
||||
|
||||
// =========================================================================
|
||||
// WASM Boot: load adapters, then process inline <script type="text/sx">
|
||||
// =========================================================================
|
||||
(function() {
|
||||
"use strict";
|
||||
if (typeof document === "undefined") return;
|
||||
|
||||
function sxWasmBoot() {
|
||||
var K = globalThis.SxKernel;
|
||||
if (!K || !globalThis.Sx) { setTimeout(sxWasmBoot, 50); return; }
|
||||
|
||||
console.log("[sx-wasm] booting, engine:", K.engine());
|
||||
|
||||
// Load embedded web adapters
|
||||
var adapters = globalThis.__sxAdapters || {};
|
||||
var adapterOrder = ["signals", "deps", "page-helpers", "router", "adapter-html"];
|
||||
for (var j = 0; j < adapterOrder.length; j++) {
|
||||
var name = adapterOrder[j];
|
||||
if (adapters[name]) {
|
||||
var r = K.loadSource(adapters[name]);
|
||||
if (typeof r === "string" && r.startsWith("Error:")) {
|
||||
console.error("[sx-wasm] adapter " + name + " error:", r);
|
||||
} else {
|
||||
console.log("[sx-wasm] loaded " + name + " (" + r + " defs)");
|
||||
}
|
||||
}
|
||||
}
|
||||
delete globalThis.__sxAdapters; // Free memory
|
||||
|
||||
// Process <script type="text/sx" data-components>
|
||||
var scripts = document.querySelectorAll('script[type="text/sx"]');
|
||||
for (var i = 0; i < scripts.length; i++) {
|
||||
var s = scripts[i], src = s.textContent.trim();
|
||||
if (!src) continue;
|
||||
if (s.hasAttribute("data-components")) {
|
||||
var result = K.loadSource(src);
|
||||
if (typeof result === "string" && result.startsWith("Error:"))
|
||||
console.error("[sx-wasm] component load error:", result);
|
||||
}
|
||||
}
|
||||
|
||||
// Process <script type="text/sx" data-init>
|
||||
for (var i = 0; i < scripts.length; i++) {
|
||||
var s = scripts[i];
|
||||
if (s.hasAttribute("data-init")) {
|
||||
var src = s.textContent.trim();
|
||||
if (src) K.loadSource(src);
|
||||
}
|
||||
}
|
||||
|
||||
// Process <script type="text/sx" data-mount="...">
|
||||
for (var i = 0; i < scripts.length; i++) {
|
||||
var s = scripts[i];
|
||||
if (s.hasAttribute("data-mount")) {
|
||||
var mount = s.getAttribute("data-mount"), src = s.textContent.trim();
|
||||
if (!src) continue;
|
||||
var target = mount === "body" ? document.body : document.querySelector(mount);
|
||||
if (!target) continue;
|
||||
try {
|
||||
var parsed = K.parse(src);
|
||||
if (parsed && parsed.length > 0) {
|
||||
var html = K.renderToHtml(parsed[0]);
|
||||
if (html && typeof html === "string") {
|
||||
target.innerHTML = html;
|
||||
console.log("[sx-wasm] mounted to", mount);
|
||||
}
|
||||
}
|
||||
} catch(e) { console.error("[sx-wasm] mount error:", e); }
|
||||
}
|
||||
}
|
||||
|
||||
console.log("[sx-wasm] boot complete");
|
||||
}
|
||||
|
||||
if (document.readyState === "loading") document.addEventListener("DOMContentLoaded", sxWasmBoot);
|
||||
else sxWasmBoot();
|
||||
})();
|
||||
BOOT
|
||||
|
||||
# 5. Copy WASM assets
|
||||
mkdir -p "$ASSET_DIR"
|
||||
cp "$WASM_ASSETS"/*.wasm "$ASSET_DIR/"
|
||||
|
||||
echo "=== Bundle complete ==="
|
||||
ls -lh "$OUT"
|
||||
echo -n "WASM assets: "; du -sh "$ASSET_DIR" | awk '{print $1}'
|
||||
5
hosts/ocaml/browser/dune
Normal file
5
hosts/ocaml/browser/dune
Normal file
@@ -0,0 +1,5 @@
|
||||
(executable
|
||||
(name sx_browser)
|
||||
(libraries sx js_of_ocaml)
|
||||
(modes byte js wasm)
|
||||
(preprocess (pps js_of_ocaml-ppx)))
|
||||
149
hosts/ocaml/browser/run_tests_js.js
Normal file
149
hosts/ocaml/browser/run_tests_js.js
Normal file
@@ -0,0 +1,149 @@
|
||||
#!/usr/bin/env node
|
||||
/**
|
||||
* Test runner for the js_of_ocaml-compiled SX engine.
|
||||
*
|
||||
* Loads the OCaml CEK machine (compiled to JS) and runs the spec test suite.
|
||||
*
|
||||
* Usage:
|
||||
* node hosts/ocaml/browser/run_tests_js.js # standard tests
|
||||
* node hosts/ocaml/browser/run_tests_js.js --full # full suite
|
||||
*/
|
||||
|
||||
const fs = require("fs");
|
||||
const path = require("path");
|
||||
|
||||
// Load the compiled OCaml engine
|
||||
const enginePath = path.join(__dirname, "../_build/default/browser/sx_browser.bc.js");
|
||||
if (!fs.existsSync(enginePath)) {
|
||||
console.error("Build first: cd hosts/ocaml && eval $(opam env) && dune build browser/sx_browser.bc.js");
|
||||
process.exit(1);
|
||||
}
|
||||
require(enginePath);
|
||||
|
||||
const K = globalThis.SxKernel;
|
||||
const full = process.argv.includes("--full");
|
||||
|
||||
// Test state
|
||||
let passed = 0;
|
||||
let failed = 0;
|
||||
let errors = [];
|
||||
let suiteStack = [];
|
||||
|
||||
function currentSuite() {
|
||||
return suiteStack.length > 0 ? suiteStack.join(" > ") : "";
|
||||
}
|
||||
|
||||
// Register platform test functions
|
||||
K.registerNative("report-pass", (args) => {
|
||||
const name = typeof args[0] === "string" ? args[0] : JSON.stringify(args[0]);
|
||||
passed++;
|
||||
if (process.env.VERBOSE) {
|
||||
console.log(` PASS: ${currentSuite()} > ${name}`);
|
||||
} else {
|
||||
process.stdout.write(".");
|
||||
if (passed % 80 === 0) process.stdout.write("\n");
|
||||
}
|
||||
return null;
|
||||
});
|
||||
|
||||
K.registerNative("report-fail", (args) => {
|
||||
const name = typeof args[0] === "string" ? args[0] : JSON.stringify(args[0]);
|
||||
const error = args.length > 1 && args[1] != null
|
||||
? (typeof args[1] === "string" ? args[1] : JSON.stringify(args[1]))
|
||||
: "unknown";
|
||||
failed++;
|
||||
const fullName = currentSuite() ? `${currentSuite()} > ${name}` : name;
|
||||
errors.push(`FAIL: ${fullName}\n ${error}`);
|
||||
process.stdout.write("F");
|
||||
});
|
||||
|
||||
K.registerNative("push-suite", (args) => {
|
||||
const name = typeof args[0] === "string" ? args[0] : String(args[0]);
|
||||
suiteStack.push(name);
|
||||
return null;
|
||||
});
|
||||
|
||||
K.registerNative("pop-suite", (_args) => {
|
||||
suiteStack.pop();
|
||||
return null;
|
||||
});
|
||||
|
||||
console.log(`=== SX OCaml→JS Engine Test Runner ===`);
|
||||
console.log(`Engine: ${K.engine()}`);
|
||||
console.log(`Mode: ${full ? "full" : "standard"}`);
|
||||
console.log("");
|
||||
|
||||
// Load a .sx file by reading it from disk and evaluating via loadSource
|
||||
function loadFile(filePath) {
|
||||
const src = fs.readFileSync(filePath, "utf8");
|
||||
return K.loadSource(src);
|
||||
}
|
||||
|
||||
// Test files
|
||||
const specDir = path.join(__dirname, "../../../spec");
|
||||
const testDir = path.join(specDir, "tests");
|
||||
|
||||
const standardTests = [
|
||||
"test-framework.sx",
|
||||
"test-eval.sx",
|
||||
"test-parser.sx",
|
||||
"test-primitives.sx",
|
||||
"test-collections.sx",
|
||||
"test-closures.sx",
|
||||
"test-defcomp.sx",
|
||||
"test-macros.sx",
|
||||
"test-errors.sx",
|
||||
"test-render.sx",
|
||||
"test-tco.sx",
|
||||
"test-scope.sx",
|
||||
"test-cek.sx",
|
||||
"test-advanced.sx",
|
||||
];
|
||||
|
||||
const fullOnlyTests = [
|
||||
"test-freeze.sx",
|
||||
"test-continuations.sx",
|
||||
"test-continuations-advanced.sx",
|
||||
"test-cek-advanced.sx",
|
||||
"test-signals-advanced.sx",
|
||||
"test-render-advanced.sx",
|
||||
"test-integration.sx",
|
||||
"test-strict.sx",
|
||||
"test-types.sx",
|
||||
];
|
||||
|
||||
const testFiles = full ? [...standardTests, ...fullOnlyTests] : standardTests;
|
||||
|
||||
for (const file of testFiles) {
|
||||
const filePath = path.join(testDir, file);
|
||||
if (!fs.existsSync(filePath)) {
|
||||
console.log(`\nSkipping ${file} (not found)`);
|
||||
continue;
|
||||
}
|
||||
|
||||
const label = file.replace(".sx", "").replace("test-", "");
|
||||
process.stdout.write(`\n[${label}] `);
|
||||
|
||||
const result = loadFile(filePath);
|
||||
if (typeof result === "string" && result.startsWith("Error:")) {
|
||||
console.log(`\n LOAD ERROR: ${result}`);
|
||||
failed++;
|
||||
errors.push(`LOAD ERROR: ${file}\n ${result}`);
|
||||
}
|
||||
}
|
||||
|
||||
console.log("\n");
|
||||
|
||||
if (errors.length > 0) {
|
||||
console.log(`--- Failures (${errors.length}) ---`);
|
||||
for (const e of errors.slice(0, 20)) {
|
||||
console.log(e);
|
||||
}
|
||||
if (errors.length > 20) {
|
||||
console.log(`... and ${errors.length - 20} more`);
|
||||
}
|
||||
console.log("");
|
||||
}
|
||||
|
||||
console.log(`Results: ${passed} passed, ${failed} failed, ${passed + failed} total`);
|
||||
process.exit(failed > 0 ? 1 : 0);
|
||||
146
hosts/ocaml/browser/run_tests_wasm.js
Normal file
146
hosts/ocaml/browser/run_tests_wasm.js
Normal file
@@ -0,0 +1,146 @@
|
||||
#!/usr/bin/env node
|
||||
/**
|
||||
* Test runner for the wasm_of_ocaml-compiled SX engine.
|
||||
*
|
||||
* Loads the OCaml CEK machine (compiled to WASM) and runs the spec test suite.
|
||||
* Requires Node.js 22+ with --experimental-wasm-imported-strings flag.
|
||||
*
|
||||
* Usage:
|
||||
* node --experimental-wasm-imported-strings hosts/ocaml/browser/run_tests_wasm.js
|
||||
* node --experimental-wasm-imported-strings hosts/ocaml/browser/run_tests_wasm.js --full
|
||||
*/
|
||||
|
||||
const fs = require("fs");
|
||||
const path = require("path");
|
||||
|
||||
const wasmDir = path.join(__dirname, "../_build/default/browser");
|
||||
const loaderPath = path.join(wasmDir, "sx_browser.bc.wasm.js");
|
||||
|
||||
if (!fs.existsSync(loaderPath)) {
|
||||
console.error("Build first: cd hosts/ocaml && eval $(opam env) && dune build browser/sx_browser.bc.wasm.js");
|
||||
process.exit(1);
|
||||
}
|
||||
|
||||
// Set require.main.filename so the WASM loader can find .wasm assets
|
||||
if (!require.main) {
|
||||
require.main = { filename: path.join(wasmDir, "test.js") };
|
||||
} else {
|
||||
require.main.filename = path.join(wasmDir, "test.js");
|
||||
}
|
||||
|
||||
require(loaderPath);
|
||||
|
||||
const full = process.argv.includes("--full");
|
||||
|
||||
// WASM loader is async — wait for SxKernel to be available
|
||||
setTimeout(() => {
|
||||
const K = globalThis.SxKernel;
|
||||
if (!K) {
|
||||
console.error("SxKernel not available — WASM initialization failed");
|
||||
process.exit(1);
|
||||
}
|
||||
|
||||
let passed = 0;
|
||||
let failed = 0;
|
||||
let errors = [];
|
||||
let suiteStack = [];
|
||||
|
||||
function currentSuite() {
|
||||
return suiteStack.length > 0 ? suiteStack.join(" > ") : "";
|
||||
}
|
||||
|
||||
// Register platform test functions
|
||||
K.registerNative("report-pass", (args) => {
|
||||
const name = typeof args[0] === "string" ? args[0] : JSON.stringify(args[0]);
|
||||
passed++;
|
||||
if (process.env.VERBOSE) {
|
||||
console.log(` PASS: ${currentSuite()} > ${name}`);
|
||||
} else {
|
||||
process.stdout.write(".");
|
||||
if (passed % 80 === 0) process.stdout.write("\n");
|
||||
}
|
||||
return null;
|
||||
});
|
||||
|
||||
K.registerNative("report-fail", (args) => {
|
||||
const name = typeof args[0] === "string" ? args[0] : JSON.stringify(args[0]);
|
||||
const error = args.length > 1 && args[1] != null
|
||||
? (typeof args[1] === "string" ? args[1] : JSON.stringify(args[1]))
|
||||
: "unknown";
|
||||
failed++;
|
||||
const fullName = currentSuite() ? `${currentSuite()} > ${name}` : name;
|
||||
errors.push(`FAIL: ${fullName}\n ${error}`);
|
||||
process.stdout.write("F");
|
||||
});
|
||||
|
||||
K.registerNative("push-suite", (args) => {
|
||||
const name = typeof args[0] === "string" ? args[0] : String(args[0]);
|
||||
suiteStack.push(name);
|
||||
return null;
|
||||
});
|
||||
|
||||
K.registerNative("pop-suite", (_args) => {
|
||||
suiteStack.pop();
|
||||
return null;
|
||||
});
|
||||
|
||||
console.log(`=== SX OCaml→WASM Engine Test Runner ===`);
|
||||
console.log(`Engine: ${K.engine()}`);
|
||||
console.log(`Mode: ${full ? "full" : "standard"}`);
|
||||
console.log("");
|
||||
|
||||
const specDir = path.join(__dirname, "../../../spec");
|
||||
const testDir = path.join(specDir, "tests");
|
||||
|
||||
const standardTests = [
|
||||
"test-framework.sx", "test-eval.sx", "test-parser.sx",
|
||||
"test-primitives.sx", "test-collections.sx", "test-closures.sx",
|
||||
"test-defcomp.sx", "test-macros.sx", "test-errors.sx",
|
||||
"test-render.sx", "test-tco.sx", "test-scope.sx",
|
||||
"test-cek.sx", "test-advanced.sx",
|
||||
];
|
||||
|
||||
const fullOnlyTests = [
|
||||
"test-freeze.sx", "test-continuations.sx",
|
||||
"test-continuations-advanced.sx", "test-cek-advanced.sx",
|
||||
"test-signals-advanced.sx", "test-render-advanced.sx",
|
||||
"test-integration.sx", "test-strict.sx", "test-types.sx",
|
||||
];
|
||||
|
||||
const testFiles = full ? [...standardTests, ...fullOnlyTests] : standardTests;
|
||||
|
||||
for (const file of testFiles) {
|
||||
const filePath = path.join(testDir, file);
|
||||
if (!fs.existsSync(filePath)) {
|
||||
console.log(`\nSkipping ${file} (not found)`);
|
||||
continue;
|
||||
}
|
||||
|
||||
const label = file.replace(".sx", "").replace("test-", "");
|
||||
process.stdout.write(`\n[${label}] `);
|
||||
|
||||
const src = fs.readFileSync(filePath, "utf8");
|
||||
const result = K.loadSource(src);
|
||||
if (typeof result === "string" && result.startsWith("Error:")) {
|
||||
console.log(`\n LOAD ERROR: ${result}`);
|
||||
failed++;
|
||||
errors.push(`LOAD ERROR: ${file}\n ${result}`);
|
||||
}
|
||||
}
|
||||
|
||||
console.log("\n");
|
||||
|
||||
if (errors.length > 0) {
|
||||
console.log(`--- Failures (${errors.length}) ---`);
|
||||
for (const e of errors.slice(0, 20)) {
|
||||
console.log(e);
|
||||
}
|
||||
if (errors.length > 20) {
|
||||
console.log(`... and ${errors.length - 20} more`);
|
||||
}
|
||||
console.log("");
|
||||
}
|
||||
|
||||
console.log(`Results: ${passed} passed, ${failed} failed, ${passed + failed} total`);
|
||||
process.exit(failed > 0 ? 1 : 0);
|
||||
}, 1000);
|
||||
676
hosts/ocaml/browser/sx-platform.js
Normal file
676
hosts/ocaml/browser/sx-platform.js
Normal file
@@ -0,0 +1,676 @@
|
||||
/**
|
||||
* sx-platform.js — Thin JS platform layer for the OCaml SX WASM engine.
|
||||
*
|
||||
* This file provides browser-native primitives (DOM, fetch, timers, etc.)
|
||||
* to the WASM-compiled OCaml CEK machine. It:
|
||||
* 1. Loads the WASM module (SxKernel)
|
||||
* 2. Registers ~80 native browser functions via registerNative
|
||||
* 3. Loads web adapters (.sx files) into the engine
|
||||
* 4. Exports the public Sx API
|
||||
*
|
||||
* Both wasm_of_ocaml and js_of_ocaml targets bind to this same layer.
|
||||
*/
|
||||
|
||||
(function(global) {
|
||||
"use strict";
|
||||
|
||||
function initPlatform() {
|
||||
var K = global.SxKernel;
|
||||
if (!K) {
|
||||
// WASM loader is async — wait and retry
|
||||
setTimeout(initPlatform, 20);
|
||||
return;
|
||||
}
|
||||
|
||||
var _hasDom = typeof document !== "undefined";
|
||||
var NIL = null;
|
||||
var SVG_NS = "http://www.w3.org/2000/svg";
|
||||
|
||||
// =========================================================================
|
||||
// Helper: wrap SX lambda for use as JS callback
|
||||
// =========================================================================
|
||||
|
||||
function wrapLambda(fn) {
|
||||
// For now, SX lambdas from registerNative are opaque — we can't call them
|
||||
// directly from JS. They need to go through the engine.
|
||||
// TODO: add callLambda API to SxKernel
|
||||
return fn;
|
||||
}
|
||||
|
||||
// =========================================================================
|
||||
// 1. DOM Creation & Manipulation
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-create-element", function(args) {
|
||||
if (!_hasDom) return NIL;
|
||||
var tag = args[0], ns = args[1];
|
||||
if (ns && ns !== NIL) return document.createElementNS(ns, tag);
|
||||
return document.createElement(tag);
|
||||
});
|
||||
|
||||
K.registerNative("create-text-node", function(args) {
|
||||
return _hasDom ? document.createTextNode(args[0] || "") : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("create-comment", function(args) {
|
||||
return _hasDom ? document.createComment(args[0] || "") : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("create-fragment", function(_args) {
|
||||
return _hasDom ? document.createDocumentFragment() : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-clone", function(args) {
|
||||
var node = args[0];
|
||||
return node && node.cloneNode ? node.cloneNode(true) : node;
|
||||
});
|
||||
|
||||
K.registerNative("dom-parse-html", function(args) {
|
||||
if (!_hasDom) return NIL;
|
||||
var tpl = document.createElement("template");
|
||||
tpl.innerHTML = args[0] || "";
|
||||
return tpl.content;
|
||||
});
|
||||
|
||||
K.registerNative("dom-parse-html-document", function(args) {
|
||||
if (!_hasDom) return NIL;
|
||||
var parser = new DOMParser();
|
||||
return parser.parseFromString(args[0] || "", "text/html");
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 2. DOM Queries
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-query", function(args) {
|
||||
return _hasDom ? document.querySelector(args[0]) || NIL : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-query-all", function(args) {
|
||||
var root = args[0] || (_hasDom ? document : null);
|
||||
if (!root || !root.querySelectorAll) return [];
|
||||
return Array.prototype.slice.call(root.querySelectorAll(args[1] || args[0]));
|
||||
});
|
||||
|
||||
K.registerNative("dom-query-by-id", function(args) {
|
||||
return _hasDom ? document.getElementById(args[0]) || NIL : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-body", function(_args) {
|
||||
return _hasDom ? document.body : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-ensure-element", function(args) {
|
||||
if (!_hasDom) return NIL;
|
||||
var sel = args[0];
|
||||
var el = document.querySelector(sel);
|
||||
if (el) return el;
|
||||
if (sel.charAt(0) === "#") {
|
||||
el = document.createElement("div");
|
||||
el.id = sel.slice(1);
|
||||
document.body.appendChild(el);
|
||||
return el;
|
||||
}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 3. DOM Attributes
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-get-attr", function(args) {
|
||||
var el = args[0], name = args[1];
|
||||
if (!el || !el.getAttribute) return NIL;
|
||||
var v = el.getAttribute(name);
|
||||
return v === null ? NIL : v;
|
||||
});
|
||||
|
||||
K.registerNative("dom-set-attr", function(args) {
|
||||
var el = args[0], name = args[1], val = args[2];
|
||||
if (el && el.setAttribute) el.setAttribute(name, val);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-remove-attr", function(args) {
|
||||
if (args[0] && args[0].removeAttribute) args[0].removeAttribute(args[1]);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-has-attr?", function(args) {
|
||||
return !!(args[0] && args[0].hasAttribute && args[0].hasAttribute(args[1]));
|
||||
});
|
||||
|
||||
K.registerNative("dom-attr-list", function(args) {
|
||||
var el = args[0];
|
||||
if (!el || !el.attributes) return [];
|
||||
var r = [];
|
||||
for (var i = 0; i < el.attributes.length; i++) {
|
||||
r.push([el.attributes[i].name, el.attributes[i].value]);
|
||||
}
|
||||
return r;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 4. DOM Content
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-text-content", function(args) {
|
||||
var el = args[0];
|
||||
return el ? el.textContent || el.nodeValue || "" : "";
|
||||
});
|
||||
|
||||
K.registerNative("dom-set-text-content", function(args) {
|
||||
var el = args[0], s = args[1];
|
||||
if (el) {
|
||||
if (el.nodeType === 3 || el.nodeType === 8) el.nodeValue = s;
|
||||
else el.textContent = s;
|
||||
}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-inner-html", function(args) {
|
||||
return args[0] && args[0].innerHTML != null ? args[0].innerHTML : "";
|
||||
});
|
||||
|
||||
K.registerNative("dom-set-inner-html", function(args) {
|
||||
if (args[0]) args[0].innerHTML = args[1] || "";
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-insert-adjacent-html", function(args) {
|
||||
var el = args[0], pos = args[1], html = args[2];
|
||||
if (el && el.insertAdjacentHTML) el.insertAdjacentHTML(pos, html);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-body-inner-html", function(args) {
|
||||
var doc = args[0];
|
||||
return doc && doc.body ? doc.body.innerHTML : "";
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 5. DOM Structure & Navigation
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-parent", function(args) { return args[0] ? args[0].parentNode || NIL : NIL; });
|
||||
K.registerNative("dom-first-child", function(args) { return args[0] ? args[0].firstChild || NIL : NIL; });
|
||||
K.registerNative("dom-next-sibling", function(args) { return args[0] ? args[0].nextSibling || NIL : NIL; });
|
||||
K.registerNative("dom-id", function(args) { return args[0] && args[0].id ? args[0].id : NIL; });
|
||||
K.registerNative("dom-node-type", function(args) { return args[0] ? args[0].nodeType : 0; });
|
||||
K.registerNative("dom-node-name", function(args) { return args[0] ? args[0].nodeName : ""; });
|
||||
K.registerNative("dom-tag-name", function(args) { return args[0] && args[0].tagName ? args[0].tagName : ""; });
|
||||
|
||||
K.registerNative("dom-child-list", function(args) {
|
||||
var el = args[0];
|
||||
if (!el || !el.childNodes) return [];
|
||||
return Array.prototype.slice.call(el.childNodes);
|
||||
});
|
||||
|
||||
K.registerNative("dom-child-nodes", function(args) {
|
||||
var el = args[0];
|
||||
if (!el || !el.childNodes) return [];
|
||||
return Array.prototype.slice.call(el.childNodes);
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 6. DOM Insertion & Removal
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-append", function(args) {
|
||||
var parent = args[0], child = args[1];
|
||||
if (parent && child) parent.appendChild(child);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-prepend", function(args) {
|
||||
var parent = args[0], child = args[1];
|
||||
if (parent && child) parent.insertBefore(child, parent.firstChild);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-insert-before", function(args) {
|
||||
var parent = args[0], node = args[1], ref = args[2];
|
||||
if (parent && node) parent.insertBefore(node, ref || null);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-insert-after", function(args) {
|
||||
var ref = args[0], node = args[1];
|
||||
if (ref && ref.parentNode && node) {
|
||||
ref.parentNode.insertBefore(node, ref.nextSibling);
|
||||
}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-remove", function(args) {
|
||||
var node = args[0];
|
||||
if (node && node.parentNode) node.parentNode.removeChild(node);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-remove-child", function(args) {
|
||||
var parent = args[0], child = args[1];
|
||||
if (parent && child && child.parentNode === parent) parent.removeChild(child);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-replace-child", function(args) {
|
||||
var parent = args[0], newC = args[1], oldC = args[2];
|
||||
if (parent && newC && oldC) parent.replaceChild(newC, oldC);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-remove-children-after", function(args) {
|
||||
var marker = args[0];
|
||||
if (!marker || !marker.parentNode) return NIL;
|
||||
var parent = marker.parentNode;
|
||||
while (marker.nextSibling) parent.removeChild(marker.nextSibling);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-append-to-head", function(args) {
|
||||
if (_hasDom && args[0]) document.head.appendChild(args[0]);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 7. DOM Type Checks
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-is-fragment?", function(args) { return args[0] ? args[0].nodeType === 11 : false; });
|
||||
K.registerNative("dom-is-child-of?", function(args) { return !!(args[1] && args[0] && args[0].parentNode === args[1]); });
|
||||
K.registerNative("dom-is-active-element?", function(args) { return _hasDom && args[0] === document.activeElement; });
|
||||
K.registerNative("dom-is-input-element?", function(args) {
|
||||
if (!args[0] || !args[0].tagName) return false;
|
||||
var t = args[0].tagName;
|
||||
return t === "INPUT" || t === "TEXTAREA" || t === "SELECT";
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 8. DOM Styles & Classes
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-get-style", function(args) {
|
||||
return args[0] && args[0].style ? args[0].style[args[1]] || "" : "";
|
||||
});
|
||||
|
||||
K.registerNative("dom-set-style", function(args) {
|
||||
if (args[0] && args[0].style) args[0].style[args[1]] = args[2];
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-add-class", function(args) {
|
||||
if (args[0] && args[0].classList) args[0].classList.add(args[1]);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-remove-class", function(args) {
|
||||
if (args[0] && args[0].classList) args[0].classList.remove(args[1]);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-has-class?", function(args) {
|
||||
return !!(args[0] && args[0].classList && args[0].classList.contains(args[1]));
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 9. DOM Properties & Data
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-get-prop", function(args) { return args[0] ? args[0][args[1]] : NIL; });
|
||||
K.registerNative("dom-set-prop", function(args) { if (args[0]) args[0][args[1]] = args[2]; return NIL; });
|
||||
|
||||
K.registerNative("dom-set-data", function(args) {
|
||||
var el = args[0], key = args[1], val = args[2];
|
||||
if (el) { if (!el._sxData) el._sxData = {}; el._sxData[key] = val; }
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-get-data", function(args) {
|
||||
var el = args[0], key = args[1];
|
||||
return (el && el._sxData) ? (el._sxData[key] != null ? el._sxData[key] : NIL) : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-call-method", function(args) {
|
||||
var obj = args[0], method = args[1];
|
||||
var callArgs = args.slice(2);
|
||||
if (obj && typeof obj[method] === "function") {
|
||||
try { return obj[method].apply(obj, callArgs); }
|
||||
catch(e) { return NIL; }
|
||||
}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 10. DOM Events
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-listen", function(args) {
|
||||
var el = args[0], name = args[1], handler = args[2];
|
||||
if (!_hasDom || !el) return function() {};
|
||||
|
||||
// handler is a wrapped SX lambda (JS function with __sx_handle).
|
||||
// Wrap it to:
|
||||
// - Pass the event object as arg (or no args for 0-arity handlers)
|
||||
// - Catch errors from the CEK machine
|
||||
var arity = K.fnArity(handler);
|
||||
var wrapped;
|
||||
if (arity === 0) {
|
||||
wrapped = function(_e) {
|
||||
try { K.callFn(handler, []); }
|
||||
catch(err) { console.error("[sx] event handler error:", name, err); }
|
||||
};
|
||||
} else {
|
||||
wrapped = function(e) {
|
||||
try { K.callFn(handler, [e]); }
|
||||
catch(err) { console.error("[sx] event handler error:", name, err); }
|
||||
};
|
||||
}
|
||||
el.addEventListener(name, wrapped);
|
||||
return function() { el.removeEventListener(name, wrapped); };
|
||||
});
|
||||
|
||||
K.registerNative("dom-dispatch", function(args) {
|
||||
if (!_hasDom || !args[0]) return false;
|
||||
var evt = new CustomEvent(args[1], { bubbles: true, cancelable: true, detail: args[2] || {} });
|
||||
return args[0].dispatchEvent(evt);
|
||||
});
|
||||
|
||||
K.registerNative("event-detail", function(args) {
|
||||
return (args[0] && args[0].detail != null) ? args[0].detail : NIL;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 11. Browser Navigation & History
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("browser-location-href", function(_args) {
|
||||
return typeof location !== "undefined" ? location.href : "";
|
||||
});
|
||||
|
||||
K.registerNative("browser-same-origin?", function(args) {
|
||||
try { return new URL(args[0], location.href).origin === location.origin; }
|
||||
catch (e) { return true; }
|
||||
});
|
||||
|
||||
K.registerNative("browser-push-state", function(args) {
|
||||
if (typeof history !== "undefined") {
|
||||
try { history.pushState({ sxUrl: args[0], scrollY: typeof window !== "undefined" ? window.scrollY : 0 }, "", args[0]); }
|
||||
catch (e) {}
|
||||
}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("browser-replace-state", function(args) {
|
||||
if (typeof history !== "undefined") {
|
||||
try { history.replaceState({ sxUrl: args[0], scrollY: typeof window !== "undefined" ? window.scrollY : 0 }, "", args[0]); }
|
||||
catch (e) {}
|
||||
}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("browser-navigate", function(args) {
|
||||
if (typeof location !== "undefined") location.assign(args[0]);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("browser-reload", function(_args) {
|
||||
if (typeof location !== "undefined") location.reload();
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("browser-scroll-to", function(args) {
|
||||
if (typeof window !== "undefined") window.scrollTo(args[0] || 0, args[1] || 0);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("browser-media-matches?", function(args) {
|
||||
if (typeof window === "undefined") return false;
|
||||
return window.matchMedia(args[0]).matches;
|
||||
});
|
||||
|
||||
K.registerNative("browser-confirm", function(args) {
|
||||
if (typeof window === "undefined") return false;
|
||||
return window.confirm(args[0]);
|
||||
});
|
||||
|
||||
K.registerNative("browser-prompt", function(args) {
|
||||
if (typeof window === "undefined") return NIL;
|
||||
var r = window.prompt(args[0]);
|
||||
return r === null ? NIL : r;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 12. Timers
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("set-timeout", function(args) {
|
||||
var fn = args[0], ms = args[1] || 0;
|
||||
var cb = (typeof fn === "function" && fn.__sx_handle != null)
|
||||
? function() { try { K.callFn(fn, []); } catch(e) { console.error("[sx] timeout error:", e); } }
|
||||
: fn;
|
||||
return setTimeout(cb, ms);
|
||||
});
|
||||
|
||||
K.registerNative("set-interval", function(args) {
|
||||
var fn = args[0], ms = args[1] || 1000;
|
||||
var cb = (typeof fn === "function" && fn.__sx_handle != null)
|
||||
? function() { try { K.callFn(fn, []); } catch(e) { console.error("[sx] interval error:", e); } }
|
||||
: fn;
|
||||
return setInterval(cb, ms);
|
||||
});
|
||||
|
||||
K.registerNative("clear-timeout", function(args) { clearTimeout(args[0]); return NIL; });
|
||||
K.registerNative("clear-interval", function(args) { clearInterval(args[0]); return NIL; });
|
||||
K.registerNative("now-ms", function(_args) {
|
||||
return (typeof performance !== "undefined") ? performance.now() : Date.now();
|
||||
});
|
||||
|
||||
K.registerNative("request-animation-frame", function(args) {
|
||||
var fn = args[0];
|
||||
var cb = (typeof fn === "function" && fn.__sx_handle != null)
|
||||
? function() { try { K.callFn(fn, []); } catch(e) { console.error("[sx] raf error:", e); } }
|
||||
: fn;
|
||||
if (typeof requestAnimationFrame !== "undefined") requestAnimationFrame(cb);
|
||||
else setTimeout(cb, 16);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 13. Promises
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("promise-resolve", function(args) { return Promise.resolve(args[0]); });
|
||||
|
||||
K.registerNative("promise-then", function(args) {
|
||||
var p = args[0];
|
||||
if (!p || !p.then) return p;
|
||||
var onResolve = function(v) { return K.callFn(args[1], [v]); };
|
||||
var onReject = args[2] ? function(e) { return K.callFn(args[2], [e]); } : undefined;
|
||||
return onReject ? p.then(onResolve, onReject) : p.then(onResolve);
|
||||
});
|
||||
|
||||
K.registerNative("promise-catch", function(args) {
|
||||
if (!args[0] || !args[0].catch) return args[0];
|
||||
return args[0].catch(function(e) { return K.callFn(args[1], [e]); });
|
||||
});
|
||||
|
||||
K.registerNative("promise-delayed", function(args) {
|
||||
return new Promise(function(resolve) {
|
||||
setTimeout(function() { resolve(args[1]); }, args[0]);
|
||||
});
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 14. Abort Controllers
|
||||
// =========================================================================
|
||||
|
||||
var _controllers = typeof WeakMap !== "undefined" ? new WeakMap() : null;
|
||||
var _targetControllers = typeof WeakMap !== "undefined" ? new WeakMap() : null;
|
||||
|
||||
K.registerNative("new-abort-controller", function(_args) {
|
||||
return typeof AbortController !== "undefined" ? new AbortController() : { signal: null, abort: function() {} };
|
||||
});
|
||||
|
||||
K.registerNative("abort-previous", function(args) {
|
||||
if (_controllers) { var prev = _controllers.get(args[0]); if (prev) prev.abort(); }
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("track-controller", function(args) {
|
||||
if (_controllers) _controllers.set(args[0], args[1]);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("abort-previous-target", function(args) {
|
||||
if (_targetControllers) { var prev = _targetControllers.get(args[0]); if (prev) prev.abort(); }
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("track-controller-target", function(args) {
|
||||
if (_targetControllers) _targetControllers.set(args[0], args[1]);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("controller-signal", function(args) { return args[0] ? args[0].signal : NIL; });
|
||||
K.registerNative("is-abort-error", function(args) { return args[0] && args[0].name === "AbortError"; });
|
||||
|
||||
// =========================================================================
|
||||
// 15. Fetch
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("fetch-request", function(args) {
|
||||
var config = args[0], successFn = args[1], errorFn = args[2];
|
||||
var opts = { method: config.method, headers: config.headers };
|
||||
if (config.signal) opts.signal = config.signal;
|
||||
if (config.body && config.method !== "GET") opts.body = config.body;
|
||||
if (config["cross-origin"]) opts.credentials = "include";
|
||||
|
||||
return fetch(config.url, opts).then(function(resp) {
|
||||
return resp.text().then(function(text) {
|
||||
var getHeader = function(name) {
|
||||
var v = resp.headers.get(name);
|
||||
return v === null ? NIL : v;
|
||||
};
|
||||
return K.callFn(successFn, [resp.ok, resp.status, getHeader, text]);
|
||||
});
|
||||
}).catch(function(err) {
|
||||
return K.callFn(errorFn, [err]);
|
||||
});
|
||||
});
|
||||
|
||||
K.registerNative("csrf-token", function(_args) {
|
||||
if (!_hasDom) return NIL;
|
||||
var m = document.querySelector('meta[name="csrf-token"]');
|
||||
return m ? m.getAttribute("content") : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("is-cross-origin", function(args) {
|
||||
try {
|
||||
var h = new URL(args[0], location.href).hostname;
|
||||
return h !== location.hostname &&
|
||||
(h.indexOf(".rose-ash.com") >= 0 || h.indexOf(".localhost") >= 0);
|
||||
} catch (e) { return false; }
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 16. localStorage
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("local-storage-get", function(args) {
|
||||
try { var v = localStorage.getItem(args[0]); return v === null ? NIL : v; }
|
||||
catch(e) { return NIL; }
|
||||
});
|
||||
|
||||
K.registerNative("local-storage-set", function(args) {
|
||||
try { localStorage.setItem(args[0], args[1]); } catch(e) {}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("local-storage-remove", function(args) {
|
||||
try { localStorage.removeItem(args[0]); } catch(e) {}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 17. Document Head & Title
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("set-document-title", function(args) {
|
||||
if (_hasDom) document.title = args[0] || "";
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("remove-head-element", function(args) {
|
||||
if (_hasDom) {
|
||||
var el = document.head.querySelector(args[0]);
|
||||
if (el) el.remove();
|
||||
}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 18. Logging
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("log-info", function(args) { console.log("[sx]", args[0]); return NIL; });
|
||||
K.registerNative("log-warn", function(args) { console.warn("[sx]", args[0]); return NIL; });
|
||||
K.registerNative("log-error", function(args) { console.error("[sx]", args[0]); return NIL; });
|
||||
|
||||
// =========================================================================
|
||||
// 19. JSON
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("json-parse", function(args) {
|
||||
try { return JSON.parse(args[0]); } catch(e) { return {}; }
|
||||
});
|
||||
|
||||
K.registerNative("try-parse-json", function(args) {
|
||||
try { return JSON.parse(args[0]); } catch(e) { return NIL; }
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 20. Processing markers
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("mark-processed!", function(args) {
|
||||
var el = args[0], key = args[1] || "sx";
|
||||
if (el) { if (!el._sxProcessed) el._sxProcessed = {}; el._sxProcessed[key] = true; }
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("is-processed?", function(args) {
|
||||
var el = args[0], key = args[1] || "sx";
|
||||
return !!(el && el._sxProcessed && el._sxProcessed[key]);
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// Public Sx API (wraps SxKernel for compatibility with existing code)
|
||||
// =========================================================================
|
||||
|
||||
var Sx = {
|
||||
// Core (delegated to WASM engine)
|
||||
parse: K.parse,
|
||||
eval: K.eval,
|
||||
evalExpr: K.evalExpr,
|
||||
load: K.load,
|
||||
loadSource: K.loadSource,
|
||||
renderToHtml: K.renderToHtml,
|
||||
typeOf: K.typeOf,
|
||||
inspect: K.inspect,
|
||||
engine: K.engine,
|
||||
|
||||
// Will be populated after web adapters load:
|
||||
// mount, hydrate, processElements, etc.
|
||||
};
|
||||
|
||||
global.Sx = Sx;
|
||||
global.SxKernel = K; // Keep kernel available for direct access
|
||||
|
||||
console.log("[sx-platform] registered, engine:", K.engine());
|
||||
|
||||
} // end initPlatform
|
||||
|
||||
initPlatform();
|
||||
|
||||
})(typeof globalThis !== "undefined" ? globalThis : this);
|
||||
946
hosts/ocaml/browser/sx_browser.ml
Normal file
946
hosts/ocaml/browser/sx_browser.ml
Normal file
@@ -0,0 +1,946 @@
|
||||
(** sx_browser.ml — OCaml SX engine compiled to WASM/JS for browser use.
|
||||
|
||||
Exposes the CEK machine, parser, and primitives as a global [Sx] object
|
||||
that the thin JS platform layer binds to. *)
|
||||
|
||||
open Js_of_ocaml
|
||||
open Sx_types
|
||||
|
||||
(* ================================================================== *)
|
||||
(* Value conversion: OCaml <-> JS *)
|
||||
(* ================================================================== *)
|
||||
|
||||
(* ------------------------------------------------------------------ *)
|
||||
(* Opaque value handle table *)
|
||||
(* *)
|
||||
(* Non-primitive SX values (lambdas, components, signals, etc.) are *)
|
||||
(* stored in a handle table and represented on the JS side as objects *)
|
||||
(* with an __sx_handle integer key. This preserves identity across *)
|
||||
(* the JS↔OCaml boundary — the same handle always resolves to the *)
|
||||
(* same OCaml value. *)
|
||||
(* *)
|
||||
(* Callable values (Lambda, NativeFn, Continuation) are additionally *)
|
||||
(* wrapped as JS functions so they can be used directly as event *)
|
||||
(* listeners, setTimeout callbacks, etc. *)
|
||||
(* ------------------------------------------------------------------ *)
|
||||
|
||||
let _next_handle = ref 0
|
||||
let _handle_table : (int, value) Hashtbl.t = Hashtbl.create 256
|
||||
|
||||
(** Store a value in the handle table, return its handle id. *)
|
||||
let alloc_handle (v : value) : int =
|
||||
let id = !_next_handle in
|
||||
incr _next_handle;
|
||||
Hashtbl.replace _handle_table id v;
|
||||
id
|
||||
|
||||
(** Look up a value by handle. *)
|
||||
let get_handle (id : int) : value =
|
||||
match Hashtbl.find_opt _handle_table id with
|
||||
| Some v -> v
|
||||
| None -> raise (Eval_error (Printf.sprintf "Invalid SX handle: %d" id))
|
||||
|
||||
(** Late-bound reference to global env (set after global_env is created). *)
|
||||
let _global_env_ref : env option ref = ref None
|
||||
let get_global_env () = match !_global_env_ref with
|
||||
| Some e -> e | None -> raise (Eval_error "Global env not initialized")
|
||||
|
||||
(** Call an SX callable through the CEK machine.
|
||||
Constructs (fn arg1 arg2 ...) and evaluates it. *)
|
||||
let call_sx_fn (fn : value) (args : value list) : value =
|
||||
Sx_ref.eval_expr (List (fn :: args)) (Env (get_global_env ()))
|
||||
|
||||
(** Convert an OCaml SX value to a JS representation.
|
||||
Primitive types map directly.
|
||||
Callable values become JS functions (with __sx_handle).
|
||||
Other compound types become tagged objects (with __sx_handle). *)
|
||||
let rec value_to_js (v : value) : Js.Unsafe.any =
|
||||
match v with
|
||||
| Nil -> Js.Unsafe.inject Js.null
|
||||
| Bool b -> Js.Unsafe.inject (Js.bool b)
|
||||
| Number n -> Js.Unsafe.inject (Js.number_of_float n)
|
||||
| String s -> Js.Unsafe.inject (Js.string s)
|
||||
| Symbol s ->
|
||||
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string "symbol"));
|
||||
("name", Js.Unsafe.inject (Js.string s)) |] in
|
||||
Js.Unsafe.inject obj
|
||||
| Keyword k ->
|
||||
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string "keyword"));
|
||||
("name", Js.Unsafe.inject (Js.string k)) |] in
|
||||
Js.Unsafe.inject obj
|
||||
| List items ->
|
||||
let arr = items |> List.map value_to_js |> Array.of_list in
|
||||
let js_arr = Js.array arr in
|
||||
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string "list"));
|
||||
("items", Js.Unsafe.inject js_arr) |] in
|
||||
Js.Unsafe.inject obj
|
||||
| ListRef r ->
|
||||
let arr = !r |> List.map value_to_js |> Array.of_list in
|
||||
let js_arr = Js.array arr in
|
||||
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string "list"));
|
||||
("items", Js.Unsafe.inject js_arr) |] in
|
||||
Js.Unsafe.inject obj
|
||||
| Dict d ->
|
||||
let obj = Js.Unsafe.obj [||] in
|
||||
Js.Unsafe.set obj (Js.string "_type") (Js.string "dict");
|
||||
Hashtbl.iter (fun k v ->
|
||||
Js.Unsafe.set obj (Js.string k) (value_to_js v)
|
||||
) d;
|
||||
Js.Unsafe.inject obj
|
||||
| RawHTML s -> Js.Unsafe.inject (Js.string s)
|
||||
(* Callable values: wrap as JS functions *)
|
||||
| Lambda _ | NativeFn _ | Continuation _ ->
|
||||
let handle = alloc_handle v in
|
||||
(* Create a JS function that calls back into the CEK machine.
|
||||
Use _tagFn helper (registered on globalThis) to create a function
|
||||
with __sx_handle and _type properties that survive js_of_ocaml
|
||||
return-value wrapping. *)
|
||||
let inner = Js.wrap_callback (fun args_js ->
|
||||
try
|
||||
let arg = js_to_value args_js in
|
||||
let args = match arg with Nil -> [] | _ -> [arg] in
|
||||
let result = call_sx_fn v args in
|
||||
value_to_js result
|
||||
with Eval_error msg ->
|
||||
ignore (Js.Unsafe.meth_call (Js.Unsafe.get Js.Unsafe.global (Js.string "console"))
|
||||
"error" [| Js.Unsafe.inject (Js.string (Printf.sprintf "[sx] callback error: %s" msg)) |]);
|
||||
Js.Unsafe.inject Js.null
|
||||
) in
|
||||
let tag_fn = Js.Unsafe.get Js.Unsafe.global (Js.string "__sxTagFn") in
|
||||
Js.Unsafe.fun_call tag_fn [|
|
||||
Js.Unsafe.inject inner;
|
||||
Js.Unsafe.inject handle;
|
||||
Js.Unsafe.inject (Js.string (type_of v))
|
||||
|]
|
||||
(* Non-callable compound values: tagged objects with handle *)
|
||||
| Component c ->
|
||||
let handle = alloc_handle v in
|
||||
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string "component"));
|
||||
("name", Js.Unsafe.inject (Js.string c.c_name));
|
||||
("__sx_handle", Js.Unsafe.inject handle) |] in
|
||||
Js.Unsafe.inject obj
|
||||
| Island i ->
|
||||
let handle = alloc_handle v in
|
||||
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string "island"));
|
||||
("name", Js.Unsafe.inject (Js.string i.i_name));
|
||||
("__sx_handle", Js.Unsafe.inject handle) |] in
|
||||
Js.Unsafe.inject obj
|
||||
| Signal _ ->
|
||||
let handle = alloc_handle v in
|
||||
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string "signal"));
|
||||
("__sx_handle", Js.Unsafe.inject handle) |] in
|
||||
Js.Unsafe.inject obj
|
||||
| _ ->
|
||||
let handle = alloc_handle v in
|
||||
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string (type_of v)));
|
||||
("__sx_handle", Js.Unsafe.inject handle) |] in
|
||||
Js.Unsafe.inject obj
|
||||
|
||||
(** Convert a JS value back to an OCaml SX value. *)
|
||||
and js_to_value (js : Js.Unsafe.any) : value =
|
||||
(* Check null/undefined *)
|
||||
if Js.Unsafe.equals js Js.null || Js.Unsafe.equals js Js.undefined then
|
||||
Nil
|
||||
else
|
||||
let ty = Js.to_string (Js.typeof js) in
|
||||
match ty with
|
||||
| "number" ->
|
||||
Number (Js.float_of_number (Js.Unsafe.coerce js))
|
||||
| "boolean" ->
|
||||
Bool (Js.to_bool (Js.Unsafe.coerce js))
|
||||
| "string" ->
|
||||
String (Js.to_string (Js.Unsafe.coerce js))
|
||||
| "function" ->
|
||||
(* Check for __sx_handle — this is a wrapped SX callable *)
|
||||
let handle_field = Js.Unsafe.get js (Js.string "__sx_handle") in
|
||||
if not (Js.Unsafe.equals handle_field Js.undefined) then
|
||||
let id = Js.float_of_number (Js.Unsafe.coerce handle_field) |> int_of_float in
|
||||
get_handle id
|
||||
else
|
||||
(* Plain JS function — wrap as NativeFn *)
|
||||
NativeFn ("js-callback", fun args ->
|
||||
let js_args = args |> List.map value_to_js |> Array.of_list in
|
||||
let result = Js.Unsafe.fun_call js
|
||||
(Array.map (fun a -> a) js_args) in
|
||||
js_to_value result)
|
||||
| "object" ->
|
||||
(* Check for __sx_handle — this is a wrapped SX value *)
|
||||
let handle_field = Js.Unsafe.get js (Js.string "__sx_handle") in
|
||||
if not (Js.Unsafe.equals handle_field Js.undefined) then begin
|
||||
let id = Js.float_of_number (Js.Unsafe.coerce handle_field) |> int_of_float in
|
||||
get_handle id
|
||||
end else begin
|
||||
(* Check for _type tag *)
|
||||
let type_field = Js.Unsafe.get js (Js.string "_type") in
|
||||
if Js.Unsafe.equals type_field Js.undefined then begin
|
||||
(* Check if it's an array *)
|
||||
let is_arr = Js.to_bool (Js.Unsafe.global##._Array##isArray js) in
|
||||
if is_arr then begin
|
||||
let len_js = Js.Unsafe.get js (Js.string "length") in
|
||||
let n = Js.float_of_number (Js.Unsafe.coerce len_js) |> int_of_float in
|
||||
let items = List.init n (fun i ->
|
||||
js_to_value (Js.array_get (Js.Unsafe.coerce js) i
|
||||
|> Js.Optdef.to_option |> Option.get)
|
||||
) in
|
||||
List items
|
||||
end else begin
|
||||
(* Plain JS object — convert to dict *)
|
||||
let d = Hashtbl.create 8 in
|
||||
let keys = Js.Unsafe.global##._Object##keys js in
|
||||
let len = keys##.length in
|
||||
for i = 0 to len - 1 do
|
||||
let k = Js.to_string (Js.array_get keys i |> Js.Optdef.to_option |> Option.get) in
|
||||
let v = Js.Unsafe.get js (Js.string k) in
|
||||
Hashtbl.replace d k (js_to_value v)
|
||||
done;
|
||||
Dict d
|
||||
end
|
||||
end else begin
|
||||
let tag = Js.to_string (Js.Unsafe.coerce type_field) in
|
||||
match tag with
|
||||
| "symbol" ->
|
||||
Symbol (Js.to_string (Js.Unsafe.get js (Js.string "name")))
|
||||
| "keyword" ->
|
||||
Keyword (Js.to_string (Js.Unsafe.get js (Js.string "name")))
|
||||
| "list" ->
|
||||
let items_js = Js.Unsafe.get js (Js.string "items") in
|
||||
let len = Js.Unsafe.get items_js (Js.string "length") in
|
||||
let n = Js.float_of_number (Js.Unsafe.coerce len) |> int_of_float in
|
||||
let items = List.init n (fun i ->
|
||||
js_to_value (Js.array_get (Js.Unsafe.coerce items_js) i
|
||||
|> Js.Optdef.to_option |> Option.get)
|
||||
) in
|
||||
List items
|
||||
| "dict" ->
|
||||
let d = Hashtbl.create 8 in
|
||||
let keys = Js.Unsafe.global##._Object##keys js in
|
||||
let len = keys##.length in
|
||||
for i = 0 to len - 1 do
|
||||
let k = Js.to_string (Js.array_get keys i |> Js.Optdef.to_option |> Option.get) in
|
||||
if k <> "_type" then begin
|
||||
let v = Js.Unsafe.get js (Js.string k) in
|
||||
Hashtbl.replace d k (js_to_value v)
|
||||
end
|
||||
done;
|
||||
Dict d
|
||||
| _ -> Nil
|
||||
end
|
||||
end
|
||||
| _ -> Nil
|
||||
|
||||
(* ================================================================== *)
|
||||
(* Global environment *)
|
||||
(* ================================================================== *)
|
||||
|
||||
let global_env = make_env ()
|
||||
let () = _global_env_ref := Some global_env
|
||||
|
||||
(* Render mode flag — set true during renderToHtml/loadSource calls
|
||||
that should dispatch HTML tags to the renderer. *)
|
||||
let _sx_render_mode = ref false
|
||||
|
||||
(* Register JS helpers.
|
||||
__sxTagFn: tag a function with __sx_handle and _type properties.
|
||||
__sxR: side-channel for return values (bypasses Js.wrap_callback
|
||||
which strips custom properties from function objects). *)
|
||||
let () =
|
||||
let tag_fn = Js.Unsafe.pure_js_expr
|
||||
"(function(fn, handle, type) { fn.__sx_handle = handle; fn._type = type; return fn; })" in
|
||||
Js.Unsafe.set Js.Unsafe.global (Js.string "__sxTagFn") tag_fn
|
||||
|
||||
(** Store a value in the side-channel and return a sentinel.
|
||||
The JS wrapper picks up __sxR instead of the return value. *)
|
||||
let return_via_side_channel (v : Js.Unsafe.any) : Js.Unsafe.any =
|
||||
Js.Unsafe.set Js.Unsafe.global (Js.string "__sxR") v;
|
||||
v
|
||||
|
||||
(* ================================================================== *)
|
||||
(* Core API functions *)
|
||||
(* ================================================================== *)
|
||||
|
||||
(** Parse SX source string into a list of values. *)
|
||||
let api_parse src_js =
|
||||
let src = Js.to_string src_js in
|
||||
try
|
||||
let values = Sx_parser.parse_all src in
|
||||
let arr = values |> List.map value_to_js |> Array.of_list in
|
||||
Js.Unsafe.inject (Js.array arr)
|
||||
with Parse_error msg ->
|
||||
Js.Unsafe.inject (Js.string ("Parse error: " ^ msg))
|
||||
|
||||
(** Serialize an SX value to source text. *)
|
||||
let api_stringify v_js =
|
||||
let v = js_to_value v_js in
|
||||
Js.Unsafe.inject (Js.string (inspect v))
|
||||
|
||||
(** Evaluate a single SX expression in the global environment. *)
|
||||
let api_eval_expr expr_js env_js =
|
||||
let expr = js_to_value expr_js in
|
||||
let _env = if Js.Unsafe.equals env_js Js.undefined then global_env
|
||||
else global_env in
|
||||
try
|
||||
let result = Sx_ref.eval_expr expr (Env _env) in
|
||||
return_via_side_channel (value_to_js result)
|
||||
with Eval_error msg ->
|
||||
Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
||||
|
||||
(** Evaluate SX source string and return the last result. *)
|
||||
let api_eval src_js =
|
||||
let src = Js.to_string src_js in
|
||||
try
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let env = Env global_env in
|
||||
let result = List.fold_left (fun _acc expr ->
|
||||
Sx_ref.eval_expr expr env
|
||||
) Nil exprs in
|
||||
return_via_side_channel (value_to_js result)
|
||||
with
|
||||
| Eval_error msg -> Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
||||
| Parse_error msg -> Js.Unsafe.inject (Js.string ("Parse error: " ^ msg))
|
||||
|
||||
(** Run the CEK machine on an expression, return result. *)
|
||||
let api_cek_run expr_js =
|
||||
let expr = js_to_value expr_js in
|
||||
try
|
||||
let state = Sx_ref.make_cek_state expr (Env global_env) Nil in
|
||||
let result = Sx_ref.cek_run_iterative state in
|
||||
return_via_side_channel (value_to_js result)
|
||||
with Eval_error msg ->
|
||||
Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
||||
|
||||
(** Render SX expression to HTML string. *)
|
||||
let api_render_to_html expr_js =
|
||||
let expr = js_to_value expr_js in
|
||||
let prev = !_sx_render_mode in
|
||||
_sx_render_mode := true;
|
||||
try
|
||||
let html = Sx_render.render_to_html expr global_env in
|
||||
_sx_render_mode := prev;
|
||||
Js.Unsafe.inject (Js.string html)
|
||||
with Eval_error msg ->
|
||||
_sx_render_mode := prev;
|
||||
Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
||||
|
||||
(** Load SX source for side effects (define, defcomp, defmacro). *)
|
||||
let api_load src_js =
|
||||
let src = Js.to_string src_js in
|
||||
try
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let env = Env global_env in
|
||||
let count = ref 0 in
|
||||
List.iter (fun expr ->
|
||||
ignore (Sx_ref.eval_expr expr env);
|
||||
incr count
|
||||
) exprs;
|
||||
Js.Unsafe.inject !count
|
||||
with
|
||||
| Eval_error msg -> Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
||||
| Parse_error msg -> Js.Unsafe.inject (Js.string ("Parse error: " ^ msg))
|
||||
|
||||
(** Get the type of an SX value. *)
|
||||
let api_type_of v_js =
|
||||
let v = js_to_value v_js in
|
||||
Js.Unsafe.inject (Js.string (type_of v))
|
||||
|
||||
(** Inspect an SX value (debug string). *)
|
||||
let api_inspect v_js =
|
||||
let v = js_to_value v_js in
|
||||
Js.Unsafe.inject (Js.string (inspect v))
|
||||
|
||||
(** Get engine identity. *)
|
||||
let api_engine () =
|
||||
Js.Unsafe.inject (Js.string "ocaml-cek-wasm")
|
||||
|
||||
(** Register a JS callback as a named native function in the global env.
|
||||
JS callback receives JS-converted args and should return a JS value. *)
|
||||
let api_register_native name_js callback_js =
|
||||
let name = Js.to_string name_js in
|
||||
let native_fn args =
|
||||
let js_args = args |> List.map value_to_js |> Array.of_list in
|
||||
let result = Js.Unsafe.fun_call callback_js
|
||||
[| Js.Unsafe.inject (Js.array js_args) |] in
|
||||
js_to_value result
|
||||
in
|
||||
ignore (env_bind global_env name (NativeFn (name, native_fn)));
|
||||
Js.Unsafe.inject Js.null
|
||||
|
||||
(** Call an SX callable (lambda, native fn) with JS args.
|
||||
fn_js can be a wrapped SX callable (with __sx_handle) or a JS value.
|
||||
args_js is a JS array of arguments. *)
|
||||
let api_call_fn fn_js args_js =
|
||||
try
|
||||
let fn = js_to_value fn_js in
|
||||
let args_arr = Js.to_array (Js.Unsafe.coerce args_js) in
|
||||
let args = Array.to_list (Array.map js_to_value args_arr) in
|
||||
let result = call_sx_fn fn args in
|
||||
return_via_side_channel (value_to_js result)
|
||||
with
|
||||
| Eval_error msg ->
|
||||
ignore (Js.Unsafe.meth_call (Js.Unsafe.get Js.Unsafe.global (Js.string "console"))
|
||||
"error" [| Js.Unsafe.inject (Js.string (Printf.sprintf "[sx] callFn error: %s" msg)) |]);
|
||||
Js.Unsafe.inject Js.null
|
||||
| exn ->
|
||||
ignore (Js.Unsafe.meth_call (Js.Unsafe.get Js.Unsafe.global (Js.string "console"))
|
||||
"error" [| Js.Unsafe.inject (Js.string (Printf.sprintf "[sx] callFn error: %s" (Printexc.to_string exn))) |]);
|
||||
Js.Unsafe.inject Js.null
|
||||
|
||||
(** Check if a JS value is a wrapped SX callable. *)
|
||||
let api_is_callable fn_js =
|
||||
if Js.Unsafe.equals fn_js Js.null || Js.Unsafe.equals fn_js Js.undefined then
|
||||
Js.Unsafe.inject (Js.bool false)
|
||||
else
|
||||
let handle_field = Js.Unsafe.get fn_js (Js.string "__sx_handle") in
|
||||
if not (Js.Unsafe.equals handle_field Js.undefined) then begin
|
||||
let id = Js.float_of_number (Js.Unsafe.coerce handle_field) |> int_of_float in
|
||||
let v = get_handle id in
|
||||
Js.Unsafe.inject (Js.bool (is_callable v))
|
||||
end else
|
||||
Js.Unsafe.inject (Js.bool false)
|
||||
|
||||
(** Get the parameter count of an SX callable (for zero-arg optimization). *)
|
||||
let api_fn_arity fn_js =
|
||||
let handle_field = Js.Unsafe.get fn_js (Js.string "__sx_handle") in
|
||||
if Js.Unsafe.equals handle_field Js.undefined then
|
||||
Js.Unsafe.inject (Js.number_of_float (-1.0))
|
||||
else
|
||||
let id = Js.float_of_number (Js.Unsafe.coerce handle_field) |> int_of_float in
|
||||
let v = get_handle id in
|
||||
match v with
|
||||
| Lambda l -> Js.Unsafe.inject (Js.number_of_float (float_of_int (List.length l.l_params)))
|
||||
| _ -> Js.Unsafe.inject (Js.number_of_float (-1.0))
|
||||
|
||||
(** Load and evaluate SX source string with error wrapping (for test runner). *)
|
||||
let api_load_source src_js =
|
||||
let src = Js.to_string src_js in
|
||||
try
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let env = Env global_env in
|
||||
let count = ref 0 in
|
||||
List.iter (fun expr ->
|
||||
ignore (Sx_ref.eval_expr expr env);
|
||||
incr count
|
||||
) exprs;
|
||||
Js.Unsafe.inject !count
|
||||
with
|
||||
| Eval_error msg -> Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
||||
| Parse_error msg -> Js.Unsafe.inject (Js.string ("Parse error: " ^ msg))
|
||||
| exn -> Js.Unsafe.inject (Js.string ("Error: " ^ Printexc.to_string exn))
|
||||
|
||||
(* ================================================================== *)
|
||||
(* Register global Sx object *)
|
||||
(* ================================================================== *)
|
||||
|
||||
(* ================================================================== *)
|
||||
(* Platform test functions (registered in global env) *)
|
||||
(* ================================================================== *)
|
||||
|
||||
let () =
|
||||
let bind name fn =
|
||||
ignore (env_bind global_env name (NativeFn (name, fn)))
|
||||
in
|
||||
|
||||
(* --- Deep equality --- *)
|
||||
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
|
||||
| NativeFn _, NativeFn _ -> a == b
|
||||
| _ -> false
|
||||
in
|
||||
|
||||
(* --- try-call --- *)
|
||||
bind "try-call" (fun args ->
|
||||
match args with
|
||||
| [thunk] ->
|
||||
(try
|
||||
ignore (Sx_ref.eval_expr (List [thunk]) (Env global_env));
|
||||
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"));
|
||||
|
||||
(* --- Evaluation --- *)
|
||||
bind "cek-eval" (fun args ->
|
||||
match args with
|
||||
| [expr] -> Sx_ref.eval_expr expr (Env global_env)
|
||||
| [expr; env_val] -> Sx_ref.eval_expr expr env_val
|
||||
| _ -> raise (Eval_error "cek-eval: expected 1-2 args"));
|
||||
|
||||
bind "eval-expr-cek" (fun args ->
|
||||
match args with
|
||||
| [expr] -> Sx_ref.eval_expr expr (Env global_env)
|
||||
| [expr; env_val] -> Sx_ref.eval_expr expr env_val
|
||||
| _ -> raise (Eval_error "eval-expr-cek: expected 1-2 args"));
|
||||
|
||||
bind "sx-parse" (fun args ->
|
||||
match args with
|
||||
| [String src] -> List (Sx_parser.parse_all src)
|
||||
| _ -> raise (Eval_error "sx-parse: expected string"));
|
||||
|
||||
(* --- Equality and assertions --- *)
|
||||
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"));
|
||||
|
||||
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"));
|
||||
|
||||
(* --- List mutation --- *)
|
||||
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"));
|
||||
|
||||
(* --- Environment ops --- *)
|
||||
bind "make-env" (fun _args -> Env (make_env ()));
|
||||
|
||||
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 key"));
|
||||
|
||||
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 key"));
|
||||
|
||||
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"));
|
||||
|
||||
(* --- Continuation support --- *)
|
||||
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 "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"));
|
||||
|
||||
(* --- Missing primitives --- *)
|
||||
bind "make-keyword" (fun args ->
|
||||
match args with
|
||||
| [String s] -> Keyword s
|
||||
| _ -> raise (Eval_error "make-keyword: expected string"));
|
||||
|
||||
(* --- Test helpers --- *)
|
||||
bind "sx-parse-one" (fun args ->
|
||||
match args with
|
||||
| [String src] ->
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
(match exprs with e :: _ -> e | [] -> Nil)
|
||||
| _ -> raise (Eval_error "sx-parse-one: expected string"));
|
||||
|
||||
bind "test-env" (fun _args -> Env (env_extend global_env));
|
||||
|
||||
(* cek-eval takes a string in the native runner *)
|
||||
bind "cek-eval" (fun args ->
|
||||
match args with
|
||||
| [String s] ->
|
||||
let exprs = Sx_parser.parse_all s in
|
||||
(match exprs with
|
||||
| e :: _ -> Sx_ref.eval_expr e (Env global_env)
|
||||
| [] -> Nil)
|
||||
| [expr] -> Sx_ref.eval_expr expr (Env global_env)
|
||||
| [expr; env_val] -> Sx_ref.eval_expr expr env_val
|
||||
| _ -> raise (Eval_error "cek-eval: expected 1-2 args"));
|
||||
|
||||
bind "eval-expr-cek" (fun args ->
|
||||
match args with
|
||||
| [expr; e] -> Sx_ref.eval_expr expr e
|
||||
| [expr] -> Sx_ref.eval_expr expr (Env global_env)
|
||||
| _ -> raise (Eval_error "eval-expr-cek: expected 1-2 args"));
|
||||
|
||||
(* --- Component accessors --- *)
|
||||
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 "component-param-types" (fun _args -> Nil);
|
||||
bind "component-set-param-types!" (fun _args -> Nil);
|
||||
|
||||
(* --- Parser/symbol 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 (inspect v)
|
||||
| _ -> raise (Eval_error "sx-serialize: 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"));
|
||||
|
||||
(* --- 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 --- *)
|
||||
ignore (env_bind global_env "*strict*" (Bool false));
|
||||
ignore (env_bind global_env "*prim-param-types*" Nil);
|
||||
|
||||
bind "set-strict!" (fun args ->
|
||||
match args with
|
||||
| [v] ->
|
||||
Sx_ref._strict_ref := v;
|
||||
ignore (env_set global_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 global_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"));
|
||||
|
||||
(* --- Apply --- *)
|
||||
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"));
|
||||
|
||||
(* --- Type system test 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);
|
||||
|
||||
(* --- HTML renderer --- *)
|
||||
Sx_render.setup_render_env global_env;
|
||||
|
||||
(* Web adapters loaded as SX source at boot time via bundle.sh *)
|
||||
|
||||
(* Wire up render mode — the CEK machine checks these to dispatch
|
||||
HTML tags and components to the renderer instead of eval. *)
|
||||
Sx_runtime._render_active_p_fn :=
|
||||
(fun () -> Bool !_sx_render_mode);
|
||||
Sx_runtime._is_render_expr_fn :=
|
||||
(fun expr -> match expr with
|
||||
| List (Symbol tag :: _) ->
|
||||
Bool (Sx_render.is_html_tag tag || tag = "<>" || tag = "raw!")
|
||||
| _ -> Bool false);
|
||||
Sx_runtime._render_expr_fn :=
|
||||
(fun expr env -> match env with
|
||||
| Env e -> RawHTML (Sx_render.render_to_html expr e)
|
||||
| _ -> RawHTML (Sx_render.render_to_html expr global_env));
|
||||
|
||||
(* --- Scope stack primitives (called by transpiled evaluator via prim_call) --- *)
|
||||
Sx_primitives.register "collect!" (fun args ->
|
||||
match args with [a; b] -> Sx_runtime.sx_collect a b | _ -> Nil);
|
||||
Sx_primitives.register "collected" (fun args ->
|
||||
match args with [a] -> Sx_runtime.sx_collected a | _ -> List []);
|
||||
Sx_primitives.register "clear-collected!" (fun args ->
|
||||
match args with [a] -> Sx_runtime.sx_clear_collected a | _ -> Nil);
|
||||
Sx_primitives.register "emit!" (fun args ->
|
||||
match args with [a; b] -> Sx_runtime.sx_emit a b | _ -> Nil);
|
||||
Sx_primitives.register "emitted" (fun args ->
|
||||
match args with [a] -> Sx_runtime.sx_emitted a | _ -> List []);
|
||||
Sx_primitives.register "context" (fun args ->
|
||||
match args with [a; b] -> Sx_runtime.sx_context a b | [a] -> Sx_runtime.sx_context a Nil | _ -> Nil);
|
||||
|
||||
(* --- Fragment and raw HTML (always available, not just in render mode) --- *)
|
||||
bind "<>" (fun args ->
|
||||
let parts = List.map (fun a ->
|
||||
match a with
|
||||
| String s -> s
|
||||
| RawHTML s -> s
|
||||
| Nil -> ""
|
||||
| List _ -> Sx_render.render_to_html a global_env
|
||||
| _ -> value_to_string a
|
||||
) args in
|
||||
RawHTML (String.concat "" parts));
|
||||
|
||||
bind "raw!" (fun args ->
|
||||
match args with
|
||||
| [String s] -> RawHTML s
|
||||
| [RawHTML s] -> RawHTML s
|
||||
| [Nil] -> RawHTML ""
|
||||
| _ -> RawHTML (String.concat "" (List.map (fun a ->
|
||||
match a with String s | RawHTML s -> s | _ -> value_to_string a
|
||||
) args)));
|
||||
|
||||
(* --- Scope stack functions (used by signals.sx, evaluator scope forms) --- *)
|
||||
bind "scope-push!" (fun args ->
|
||||
match args with
|
||||
| [name; value] -> Sx_runtime.scope_push name value
|
||||
| _ -> raise (Eval_error "scope-push!: expected 2 args"));
|
||||
|
||||
bind "scope-pop!" (fun args ->
|
||||
match args with
|
||||
| [_name] -> Sx_runtime.scope_pop _name
|
||||
| _ -> raise (Eval_error "scope-pop!: expected 1 arg"));
|
||||
|
||||
bind "provide-push!" (fun args ->
|
||||
match args with
|
||||
| [name; value] -> Sx_runtime.provide_push name value
|
||||
| _ -> raise (Eval_error "provide-push!: expected 2 args"));
|
||||
|
||||
bind "provide-pop!" (fun args ->
|
||||
match args with
|
||||
| [_name] -> Sx_runtime.provide_pop _name
|
||||
| _ -> raise (Eval_error "provide-pop!: expected 1 arg"));
|
||||
|
||||
(* define-page-helper: registers a named page helper — stub for browser *)
|
||||
bind "define-page-helper" (fun args ->
|
||||
match args with
|
||||
| [String _name; _body] -> Nil (* Page helpers are server-side; noop in browser *)
|
||||
| _ -> Nil);
|
||||
|
||||
(* cek-call: call a function via the CEK machine (used by signals, orchestration)
|
||||
(cek-call fn nil) → call with no args
|
||||
(cek-call fn (list a)) → call with args list
|
||||
(cek-call fn a) → call with single arg *)
|
||||
bind "cek-call" (fun args ->
|
||||
match args with
|
||||
| [f; Nil] -> Sx_ref.eval_expr (List [f]) (Env global_env)
|
||||
| [f; List arg_list] -> Sx_ref.eval_expr (List (f :: arg_list)) (Env global_env)
|
||||
| [f; a] -> Sx_ref.eval_expr (List [f; a]) (Env global_env)
|
||||
| [f] -> Sx_ref.eval_expr (List [f]) (Env global_env)
|
||||
| f :: rest -> Sx_ref.eval_expr (List (f :: rest)) (Env global_env)
|
||||
| _ -> raise (Eval_error "cek-call: expected function and args"));
|
||||
|
||||
(* not : logical negation (sometimes missing from evaluator prims) *)
|
||||
(if not (Sx_primitives.is_primitive "not") then
|
||||
bind "not" (fun args ->
|
||||
match args with
|
||||
| [v] -> Bool (not (sx_truthy v))
|
||||
| _ -> raise (Eval_error "not: expected 1 arg")))
|
||||
|
||||
let () =
|
||||
let sx = Js.Unsafe.obj [||] in
|
||||
|
||||
(* __sxWrap: wraps an OCaml API function so that after calling it,
|
||||
the JS side picks up the result from globalThis.__sxR if set.
|
||||
This bypasses js_of_ocaml stripping properties from function return values. *)
|
||||
let wrap = Js.Unsafe.pure_js_expr
|
||||
{|(function(fn) {
|
||||
return function() {
|
||||
globalThis.__sxR = undefined;
|
||||
var r = fn.apply(null, arguments);
|
||||
return globalThis.__sxR !== undefined ? globalThis.__sxR : r;
|
||||
};
|
||||
})|} in
|
||||
let w fn = Js.Unsafe.fun_call wrap [| Js.Unsafe.inject (Js.wrap_callback fn) |] in
|
||||
|
||||
(* Core evaluation *)
|
||||
Js.Unsafe.set sx (Js.string "parse")
|
||||
(Js.wrap_callback api_parse);
|
||||
Js.Unsafe.set sx (Js.string "stringify")
|
||||
(Js.wrap_callback api_stringify);
|
||||
Js.Unsafe.set sx (Js.string "eval")
|
||||
(w api_eval);
|
||||
Js.Unsafe.set sx (Js.string "evalExpr")
|
||||
(w api_eval_expr);
|
||||
Js.Unsafe.set sx (Js.string "cekRun")
|
||||
(w api_cek_run);
|
||||
Js.Unsafe.set sx (Js.string "renderToHtml")
|
||||
(Js.wrap_callback api_render_to_html);
|
||||
Js.Unsafe.set sx (Js.string "load")
|
||||
(Js.wrap_callback api_load);
|
||||
Js.Unsafe.set sx (Js.string "typeOf")
|
||||
(Js.wrap_callback api_type_of);
|
||||
Js.Unsafe.set sx (Js.string "inspect")
|
||||
(Js.wrap_callback api_inspect);
|
||||
Js.Unsafe.set sx (Js.string "engine")
|
||||
(Js.wrap_callback api_engine);
|
||||
Js.Unsafe.set sx (Js.string "registerNative")
|
||||
(Js.wrap_callback api_register_native);
|
||||
Js.Unsafe.set sx (Js.string "loadSource")
|
||||
(Js.wrap_callback api_load_source);
|
||||
Js.Unsafe.set sx (Js.string "callFn")
|
||||
(w api_call_fn);
|
||||
Js.Unsafe.set sx (Js.string "isCallable")
|
||||
(Js.wrap_callback api_is_callable);
|
||||
Js.Unsafe.set sx (Js.string "fnArity")
|
||||
(Js.wrap_callback api_fn_arity);
|
||||
|
||||
(* Expose globally *)
|
||||
Js.Unsafe.set Js.Unsafe.global (Js.string "SxKernel") sx
|
||||
2
hosts/ocaml/dune-project
Normal file
2
hosts/ocaml/dune-project
Normal file
@@ -0,0 +1,2 @@
|
||||
(lang dune 3.19)
|
||||
(name sx)
|
||||
3
hosts/ocaml/lib/dune
Normal file
3
hosts/ocaml/lib/dune
Normal file
@@ -0,0 +1,3 @@
|
||||
(library
|
||||
(name sx)
|
||||
(wrapped false))
|
||||
206
hosts/ocaml/lib/sx_parser.ml
Normal file
206
hosts/ocaml/lib/sx_parser.ml
Normal file
@@ -0,0 +1,206 @@
|
||||
(** S-expression parser.
|
||||
|
||||
Recursive descent over a string, producing [Sx_types.value list].
|
||||
Supports: lists, dicts, symbols, keywords, strings (with escapes),
|
||||
numbers, booleans, nil, comments, quote/quasiquote/unquote sugar. *)
|
||||
|
||||
open Sx_types
|
||||
|
||||
type state = {
|
||||
src : string;
|
||||
len : int;
|
||||
mutable pos : int;
|
||||
}
|
||||
|
||||
let make_state src = { src; len = String.length src; pos = 0 }
|
||||
|
||||
let peek s = if s.pos < s.len then Some s.src.[s.pos] else None
|
||||
let advance s = s.pos <- s.pos + 1
|
||||
let at_end s = s.pos >= s.len
|
||||
|
||||
let skip_whitespace_and_comments s =
|
||||
let rec go () =
|
||||
if at_end s then ()
|
||||
else match s.src.[s.pos] with
|
||||
| ' ' | '\t' | '\n' | '\r' -> advance s; go ()
|
||||
| ';' ->
|
||||
while s.pos < s.len && s.src.[s.pos] <> '\n' do advance s done;
|
||||
if s.pos < s.len then advance s;
|
||||
go ()
|
||||
| _ -> ()
|
||||
in go ()
|
||||
|
||||
let is_symbol_char = function
|
||||
| '(' | ')' | '[' | ']' | '{' | '}' | '"' | '\'' | '`'
|
||||
| ' ' | '\t' | '\n' | '\r' | ',' | ';' -> false
|
||||
| _ -> true
|
||||
|
||||
let read_string s =
|
||||
(* s.pos is on the opening quote *)
|
||||
advance s;
|
||||
let buf = Buffer.create 64 in
|
||||
let rec go () =
|
||||
if at_end s then raise (Parse_error "Unterminated string");
|
||||
let c = s.src.[s.pos] in
|
||||
advance s;
|
||||
if c = '"' then Buffer.contents buf
|
||||
else if c = '\\' then begin
|
||||
if at_end s then raise (Parse_error "Unterminated string escape");
|
||||
let esc = s.src.[s.pos] in
|
||||
advance s;
|
||||
(match esc with
|
||||
| 'n' -> Buffer.add_char buf '\n'
|
||||
| 't' -> Buffer.add_char buf '\t'
|
||||
| 'r' -> Buffer.add_char buf '\r'
|
||||
| '"' -> Buffer.add_char buf '"'
|
||||
| '\\' -> Buffer.add_char buf '\\'
|
||||
| 'u' ->
|
||||
(* \uXXXX — read 4 hex digits, encode as UTF-8 *)
|
||||
if s.pos + 4 > s.len then raise (Parse_error "Incomplete \\u escape");
|
||||
let hex = String.sub s.src s.pos 4 in
|
||||
s.pos <- s.pos + 4;
|
||||
let code = int_of_string ("0x" ^ hex) in
|
||||
let ubuf = Buffer.create 4 in
|
||||
Buffer.add_utf_8_uchar ubuf (Uchar.of_int code);
|
||||
Buffer.add_string buf (Buffer.contents ubuf)
|
||||
| '`' -> Buffer.add_char buf '`'
|
||||
| _ -> Buffer.add_char buf '\\'; Buffer.add_char buf esc);
|
||||
go ()
|
||||
end else begin
|
||||
Buffer.add_char buf c;
|
||||
go ()
|
||||
end
|
||||
in go ()
|
||||
|
||||
let read_symbol s =
|
||||
let start = s.pos in
|
||||
while s.pos < s.len && is_symbol_char s.src.[s.pos] do advance s done;
|
||||
String.sub s.src start (s.pos - start)
|
||||
|
||||
let try_number str =
|
||||
match float_of_string_opt str with
|
||||
| Some n -> Some (Number n)
|
||||
| None -> None
|
||||
|
||||
let rec read_value s : value =
|
||||
skip_whitespace_and_comments s;
|
||||
if at_end s then raise (Parse_error "Unexpected end of input");
|
||||
match s.src.[s.pos] with
|
||||
| '(' -> read_list s ')'
|
||||
| '[' -> read_list s ']'
|
||||
| '{' -> read_dict s
|
||||
| '"' -> String (read_string s)
|
||||
| '\'' -> advance s; List [Symbol "quote"; read_value s]
|
||||
| '`' -> advance s; List [Symbol "quasiquote"; read_value s]
|
||||
| '#' when s.pos + 1 < s.len && s.src.[s.pos + 1] = ';' ->
|
||||
(* Datum comment: #; discards next expression *)
|
||||
advance s; advance s;
|
||||
ignore (read_value s);
|
||||
read_value s
|
||||
| '#' when s.pos + 1 < s.len && s.src.[s.pos + 1] = '\'' ->
|
||||
(* Quote shorthand: #'expr -> (quote expr) *)
|
||||
advance s; advance s;
|
||||
List [Symbol "quote"; read_value s]
|
||||
| '#' when s.pos + 1 < s.len && s.src.[s.pos + 1] = '|' ->
|
||||
(* Raw string: #|...| — ends at next | *)
|
||||
advance s; advance s;
|
||||
let buf = Buffer.create 64 in
|
||||
let rec go () =
|
||||
if at_end s then raise (Parse_error "Unterminated raw string");
|
||||
let c = s.src.[s.pos] in
|
||||
advance s;
|
||||
if c = '|' then
|
||||
String (Buffer.contents buf)
|
||||
else begin
|
||||
Buffer.add_char buf c;
|
||||
go ()
|
||||
end
|
||||
in go ()
|
||||
| '~' when s.pos + 1 < s.len && s.src.[s.pos + 1] = '@' ->
|
||||
advance s; advance s; (* skip ~@ *)
|
||||
List [Symbol "splice-unquote"; read_value s]
|
||||
| _ ->
|
||||
(* Check for unquote: , followed by non-whitespace *)
|
||||
if s.src.[s.pos] = ',' && s.pos + 1 < s.len &&
|
||||
s.src.[s.pos + 1] <> ' ' && s.src.[s.pos + 1] <> '\n' then begin
|
||||
advance s;
|
||||
if s.pos < s.len && s.src.[s.pos] = '@' then begin
|
||||
advance s;
|
||||
List [Symbol "splice-unquote"; read_value s]
|
||||
end else
|
||||
List [Symbol "unquote"; read_value s]
|
||||
end else begin
|
||||
(* Symbol, keyword, number, or boolean *)
|
||||
let token = read_symbol s in
|
||||
if token = "" then raise (Parse_error ("Unexpected char: " ^ String.make 1 s.src.[s.pos]));
|
||||
match token with
|
||||
| "true" -> Bool true
|
||||
| "false" -> Bool false
|
||||
| "nil" -> Nil
|
||||
| _ when token.[0] = ':' ->
|
||||
Keyword (String.sub token 1 (String.length token - 1))
|
||||
| _ ->
|
||||
match try_number token with
|
||||
| Some n -> n
|
||||
| None -> Symbol token
|
||||
end
|
||||
|
||||
and read_list s close_char =
|
||||
advance s; (* skip opening paren/bracket *)
|
||||
let items = ref [] in
|
||||
let rec go () =
|
||||
skip_whitespace_and_comments s;
|
||||
if at_end s then raise (Parse_error "Unterminated list");
|
||||
if s.src.[s.pos] = close_char then begin
|
||||
advance s;
|
||||
List (List.rev !items)
|
||||
end else begin
|
||||
items := read_value s :: !items;
|
||||
go ()
|
||||
end
|
||||
in go ()
|
||||
|
||||
and read_dict s =
|
||||
advance s; (* skip { *)
|
||||
let d = make_dict () in
|
||||
let rec go () =
|
||||
skip_whitespace_and_comments s;
|
||||
if at_end s then raise (Parse_error "Unterminated dict");
|
||||
if s.src.[s.pos] = '}' then begin
|
||||
advance s;
|
||||
Dict d
|
||||
end else begin
|
||||
let key = read_value s in
|
||||
let key_str = match key with
|
||||
| Keyword k -> k
|
||||
| String k -> k
|
||||
| Symbol k -> k
|
||||
| _ -> raise (Parse_error "Dict key must be keyword, string, or symbol")
|
||||
in
|
||||
let v = read_value s in
|
||||
dict_set d key_str v;
|
||||
go ()
|
||||
end
|
||||
in go ()
|
||||
|
||||
|
||||
(** Parse a string into a list of SX values. *)
|
||||
let parse_all src =
|
||||
let s = make_state src in
|
||||
let results = ref [] in
|
||||
let rec go () =
|
||||
skip_whitespace_and_comments s;
|
||||
if at_end s then List.rev !results
|
||||
else begin
|
||||
results := read_value s :: !results;
|
||||
go ()
|
||||
end
|
||||
in go ()
|
||||
|
||||
(** Parse a file into a list of SX values. *)
|
||||
let parse_file path =
|
||||
let ic = open_in path in
|
||||
let n = in_channel_length ic in
|
||||
let src = really_input_string ic n in
|
||||
close_in ic;
|
||||
parse_all src
|
||||
578
hosts/ocaml/lib/sx_primitives.ml
Normal file
578
hosts/ocaml/lib/sx_primitives.ml
Normal file
@@ -0,0 +1,578 @@
|
||||
(** Built-in primitive functions (~80 pure functions).
|
||||
|
||||
Registered in a global table; the evaluator checks this table
|
||||
when a symbol isn't found in the lexical environment. *)
|
||||
|
||||
open Sx_types
|
||||
|
||||
let primitives : (string, value list -> value) Hashtbl.t = Hashtbl.create 128
|
||||
|
||||
let register name fn = Hashtbl.replace primitives name fn
|
||||
|
||||
let is_primitive name = Hashtbl.mem primitives name
|
||||
|
||||
let get_primitive name =
|
||||
match Hashtbl.find_opt primitives name with
|
||||
| Some fn -> NativeFn (name, fn)
|
||||
| None -> raise (Eval_error ("Unknown primitive: " ^ name))
|
||||
|
||||
(* --- Helpers --- *)
|
||||
|
||||
let as_number = function
|
||||
| Number n -> n
|
||||
| Bool true -> 1.0
|
||||
| Bool false -> 0.0
|
||||
| Nil -> 0.0
|
||||
| String s -> (match float_of_string_opt s with Some n -> n | None -> Float.nan)
|
||||
| v -> raise (Eval_error ("Expected number, got " ^ type_of v))
|
||||
|
||||
let as_string = function
|
||||
| String s -> s
|
||||
| v -> raise (Eval_error ("Expected string, got " ^ type_of v))
|
||||
|
||||
let as_list = function
|
||||
| List l -> l
|
||||
| ListRef r -> !r
|
||||
| Nil -> []
|
||||
| v -> raise (Eval_error ("Expected list, got " ^ type_of v))
|
||||
|
||||
let as_bool = function
|
||||
| Bool b -> b
|
||||
| v -> sx_truthy v
|
||||
|
||||
let to_string = function
|
||||
| String s -> s
|
||||
| Number n ->
|
||||
if Float.is_integer n then string_of_int (int_of_float n)
|
||||
else Printf.sprintf "%g" n
|
||||
| Bool true -> "true"
|
||||
| Bool false -> "false"
|
||||
| Nil -> ""
|
||||
| Symbol s -> s
|
||||
| Keyword k -> k
|
||||
| v -> inspect v
|
||||
|
||||
let () =
|
||||
(* === Arithmetic === *)
|
||||
register "+" (fun args ->
|
||||
Number (List.fold_left (fun acc a -> acc +. as_number a) 0.0 args));
|
||||
register "-" (fun args ->
|
||||
match args with
|
||||
| [] -> Number 0.0
|
||||
| [a] -> Number (-. (as_number a))
|
||||
| a :: rest -> Number (List.fold_left (fun acc x -> acc -. as_number x) (as_number a) rest));
|
||||
register "*" (fun args ->
|
||||
Number (List.fold_left (fun acc a -> acc *. as_number a) 1.0 args));
|
||||
register "/" (fun args ->
|
||||
match args with
|
||||
| [a; b] -> Number (as_number a /. as_number b)
|
||||
| _ -> raise (Eval_error "/: expected 2 args"));
|
||||
register "mod" (fun args ->
|
||||
match args with
|
||||
| [a; b] -> Number (Float.rem (as_number a) (as_number b))
|
||||
| _ -> raise (Eval_error "mod: expected 2 args"));
|
||||
register "inc" (fun args ->
|
||||
match args with [a] -> Number (as_number a +. 1.0) | _ -> raise (Eval_error "inc: 1 arg"));
|
||||
register "dec" (fun args ->
|
||||
match args with [a] -> Number (as_number a -. 1.0) | _ -> raise (Eval_error "dec: 1 arg"));
|
||||
register "abs" (fun args ->
|
||||
match args with [a] -> Number (Float.abs (as_number a)) | _ -> raise (Eval_error "abs: 1 arg"));
|
||||
register "floor" (fun args ->
|
||||
match args with [a] -> Number (Float.of_int (int_of_float (Float.round (as_number a -. 0.5))))
|
||||
| _ -> raise (Eval_error "floor: 1 arg"));
|
||||
register "ceil" (fun args ->
|
||||
match args with [a] -> Number (Float.of_int (int_of_float (Float.round (as_number a +. 0.5))))
|
||||
| _ -> raise (Eval_error "ceil: 1 arg"));
|
||||
register "round" (fun args ->
|
||||
match args with
|
||||
| [a] -> Number (Float.round (as_number a))
|
||||
| [a; b] ->
|
||||
let n = as_number a and places = int_of_float (as_number b) in
|
||||
let factor = 10.0 ** float_of_int places in
|
||||
Number (Float.round (n *. factor) /. factor)
|
||||
| _ -> raise (Eval_error "round: 1-2 args"));
|
||||
register "min" (fun args ->
|
||||
match args with
|
||||
| [] -> raise (Eval_error "min: at least 1 arg")
|
||||
| _ -> Number (List.fold_left (fun acc a -> Float.min acc (as_number a)) Float.infinity args));
|
||||
register "max" (fun args ->
|
||||
match args with
|
||||
| [] -> raise (Eval_error "max: at least 1 arg")
|
||||
| _ -> Number (List.fold_left (fun acc a -> Float.max acc (as_number a)) Float.neg_infinity args));
|
||||
register "sqrt" (fun args ->
|
||||
match args with [a] -> Number (Float.sqrt (as_number a)) | _ -> raise (Eval_error "sqrt: 1 arg"));
|
||||
register "pow" (fun args ->
|
||||
match args with [a; b] -> Number (as_number a ** as_number b)
|
||||
| _ -> raise (Eval_error "pow: 2 args"));
|
||||
register "clamp" (fun args ->
|
||||
match args with
|
||||
| [x; lo; hi] ->
|
||||
let x = as_number x and lo = as_number lo and hi = as_number hi in
|
||||
Number (Float.max lo (Float.min hi x))
|
||||
| _ -> raise (Eval_error "clamp: 3 args"));
|
||||
register "parse-int" (fun args ->
|
||||
match args with
|
||||
| [String s] -> (match int_of_string_opt s with Some n -> Number (float_of_int n) | None -> Nil)
|
||||
| [Number n] -> Number (float_of_int (int_of_float n))
|
||||
| _ -> Nil);
|
||||
register "parse-float" (fun args ->
|
||||
match args with
|
||||
| [String s] -> (match float_of_string_opt s with Some n -> Number n | None -> Nil)
|
||||
| [Number n] -> Number n
|
||||
| _ -> Nil);
|
||||
|
||||
(* === Comparison === *)
|
||||
(* Normalize ListRef to List for structural equality *)
|
||||
let rec normalize_for_eq = function
|
||||
| ListRef { contents = items } -> List (List.map normalize_for_eq items)
|
||||
| List items -> List (List.map normalize_for_eq items)
|
||||
| v -> v
|
||||
in
|
||||
register "=" (fun args ->
|
||||
match args with
|
||||
| [a; b] -> Bool (normalize_for_eq a = normalize_for_eq b)
|
||||
| _ -> raise (Eval_error "=: 2 args"));
|
||||
register "!=" (fun args ->
|
||||
match args with
|
||||
| [a; b] -> Bool (normalize_for_eq a <> normalize_for_eq b)
|
||||
| _ -> raise (Eval_error "!=: 2 args"));
|
||||
register "<" (fun args ->
|
||||
match args with
|
||||
| [String a; String b] -> Bool (a < b)
|
||||
| [a; b] -> Bool (as_number a < as_number b)
|
||||
| _ -> raise (Eval_error "<: 2 args"));
|
||||
register ">" (fun args ->
|
||||
match args with
|
||||
| [String a; String b] -> Bool (a > b)
|
||||
| [a; b] -> Bool (as_number a > as_number b)
|
||||
| _ -> raise (Eval_error ">: 2 args"));
|
||||
register "<=" (fun args ->
|
||||
match args with
|
||||
| [String a; String b] -> Bool (a <= b)
|
||||
| [a; b] -> Bool (as_number a <= as_number b)
|
||||
| _ -> raise (Eval_error "<=: 2 args"));
|
||||
register ">=" (fun args ->
|
||||
match args with
|
||||
| [String a; String b] -> Bool (a >= b)
|
||||
| [a; b] -> Bool (as_number a >= as_number b)
|
||||
| _ -> raise (Eval_error ">=: 2 args"));
|
||||
|
||||
(* === Logic === *)
|
||||
register "not" (fun args ->
|
||||
match args with [a] -> Bool (not (sx_truthy a)) | _ -> raise (Eval_error "not: 1 arg"));
|
||||
|
||||
(* === Predicates === *)
|
||||
register "nil?" (fun args ->
|
||||
match args with [a] -> Bool (is_nil a) | _ -> raise (Eval_error "nil?: 1 arg"));
|
||||
register "number?" (fun args ->
|
||||
match args with [Number _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "number?: 1 arg"));
|
||||
register "string?" (fun args ->
|
||||
match args with [String _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "string?: 1 arg"));
|
||||
register "boolean?" (fun args ->
|
||||
match args with [Bool _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "boolean?: 1 arg"));
|
||||
register "list?" (fun args ->
|
||||
match args with [List _] | [ListRef _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "list?: 1 arg"));
|
||||
register "dict?" (fun args ->
|
||||
match args with [Dict _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "dict?: 1 arg"));
|
||||
register "symbol?" (fun args ->
|
||||
match args with [Symbol _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "symbol?: 1 arg"));
|
||||
register "keyword?" (fun args ->
|
||||
match args with [Keyword _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "keyword?: 1 arg"));
|
||||
register "empty?" (fun args ->
|
||||
match args with
|
||||
| [List []] | [ListRef { contents = [] }] -> Bool true
|
||||
| [List _] | [ListRef _] -> Bool false
|
||||
| [String ""] -> Bool true | [String _] -> Bool false
|
||||
| [Dict d] -> Bool (Hashtbl.length d = 0)
|
||||
| [Nil] -> Bool true
|
||||
| [_] -> Bool false
|
||||
| _ -> raise (Eval_error "empty?: 1 arg"));
|
||||
register "odd?" (fun args ->
|
||||
match args with [a] -> Bool (int_of_float (as_number a) mod 2 <> 0) | _ -> raise (Eval_error "odd?: 1 arg"));
|
||||
register "even?" (fun args ->
|
||||
match args with [a] -> Bool (int_of_float (as_number a) mod 2 = 0) | _ -> raise (Eval_error "even?: 1 arg"));
|
||||
register "zero?" (fun args ->
|
||||
match args with [a] -> Bool (as_number a = 0.0) | _ -> raise (Eval_error "zero?: 1 arg"));
|
||||
|
||||
(* === Strings === *)
|
||||
register "str" (fun args -> String (String.concat "" (List.map to_string args)));
|
||||
register "upper" (fun args ->
|
||||
match args with [a] -> String (String.uppercase_ascii (as_string a)) | _ -> raise (Eval_error "upper: 1 arg"));
|
||||
register "upcase" (fun args ->
|
||||
match args with [a] -> String (String.uppercase_ascii (as_string a)) | _ -> raise (Eval_error "upcase: 1 arg"));
|
||||
register "lower" (fun args ->
|
||||
match args with [a] -> String (String.lowercase_ascii (as_string a)) | _ -> raise (Eval_error "lower: 1 arg"));
|
||||
register "downcase" (fun args ->
|
||||
match args with [a] -> String (String.lowercase_ascii (as_string a)) | _ -> raise (Eval_error "downcase: 1 arg"));
|
||||
register "trim" (fun args ->
|
||||
match args with [a] -> String (String.trim (as_string a)) | _ -> raise (Eval_error "trim: 1 arg"));
|
||||
register "string-length" (fun args ->
|
||||
match args with [a] -> Number (float_of_int (String.length (as_string a)))
|
||||
| _ -> raise (Eval_error "string-length: 1 arg"));
|
||||
register "string-contains?" (fun args ->
|
||||
match args with
|
||||
| [String haystack; String needle] ->
|
||||
let rec find i =
|
||||
if i + String.length needle > String.length haystack then false
|
||||
else if String.sub haystack i (String.length needle) = needle then true
|
||||
else find (i + 1)
|
||||
in Bool (find 0)
|
||||
| _ -> raise (Eval_error "string-contains?: 2 string args"));
|
||||
register "starts-with?" (fun args ->
|
||||
match args with
|
||||
| [String s; String prefix] ->
|
||||
Bool (String.length s >= String.length prefix &&
|
||||
String.sub s 0 (String.length prefix) = prefix)
|
||||
| _ -> raise (Eval_error "starts-with?: 2 string args"));
|
||||
register "ends-with?" (fun args ->
|
||||
match args with
|
||||
| [String s; String suffix] ->
|
||||
let sl = String.length s and xl = String.length suffix in
|
||||
Bool (sl >= xl && String.sub s (sl - xl) xl = suffix)
|
||||
| _ -> raise (Eval_error "ends-with?: 2 string args"));
|
||||
register "index-of" (fun args ->
|
||||
match args with
|
||||
| [String haystack; String needle] ->
|
||||
let nl = String.length needle and hl = String.length haystack in
|
||||
let rec find i =
|
||||
if i + nl > hl then Number (-1.0)
|
||||
else if String.sub haystack i nl = needle then Number (float_of_int i)
|
||||
else find (i + 1)
|
||||
in find 0
|
||||
| _ -> raise (Eval_error "index-of: 2 string args"));
|
||||
register "substring" (fun args ->
|
||||
match args with
|
||||
| [String s; Number start; Number end_] ->
|
||||
let i = int_of_float start and j = int_of_float end_ in
|
||||
let len = String.length s in
|
||||
let i = max 0 (min i len) and j = max 0 (min j len) in
|
||||
String (String.sub s i (max 0 (j - i)))
|
||||
| _ -> raise (Eval_error "substring: 3 args"));
|
||||
register "substr" (fun args ->
|
||||
match args with
|
||||
| [String s; Number start; Number len] ->
|
||||
let i = int_of_float start and n = int_of_float len in
|
||||
let sl = String.length s in
|
||||
let i = max 0 (min i sl) in
|
||||
let n = max 0 (min n (sl - i)) in
|
||||
String (String.sub s i n)
|
||||
| [String s; Number start] ->
|
||||
let i = int_of_float start in
|
||||
let sl = String.length s in
|
||||
let i = max 0 (min i sl) in
|
||||
String (String.sub s i (sl - i))
|
||||
| _ -> raise (Eval_error "substr: 2-3 args"));
|
||||
register "split" (fun args ->
|
||||
match args with
|
||||
| [String s; String sep] ->
|
||||
List (List.map (fun p -> String p) (String.split_on_char sep.[0] s))
|
||||
| _ -> raise (Eval_error "split: 2 args"));
|
||||
register "join" (fun args ->
|
||||
match args with
|
||||
| [String sep; (List items | ListRef { contents = items })] ->
|
||||
String (String.concat sep (List.map to_string items))
|
||||
| _ -> raise (Eval_error "join: 2 args"));
|
||||
register "replace" (fun args ->
|
||||
match args with
|
||||
| [String s; String old_s; String new_s] ->
|
||||
let ol = String.length old_s in
|
||||
if ol = 0 then String s
|
||||
else begin
|
||||
let buf = Buffer.create (String.length s) in
|
||||
let rec go i =
|
||||
if i >= String.length s then ()
|
||||
else if i + ol <= String.length s && String.sub s i ol = old_s then begin
|
||||
Buffer.add_string buf new_s;
|
||||
go (i + ol)
|
||||
end else begin
|
||||
Buffer.add_char buf s.[i];
|
||||
go (i + 1)
|
||||
end
|
||||
in go 0;
|
||||
String (Buffer.contents buf)
|
||||
end
|
||||
| _ -> raise (Eval_error "replace: 3 string args"));
|
||||
register "char-from-code" (fun args ->
|
||||
match args with
|
||||
| [Number n] ->
|
||||
let buf = Buffer.create 4 in
|
||||
Buffer.add_utf_8_uchar buf (Uchar.of_int (int_of_float n));
|
||||
String (Buffer.contents buf)
|
||||
| _ -> raise (Eval_error "char-from-code: 1 arg"));
|
||||
|
||||
(* === Collections === *)
|
||||
register "list" (fun args -> ListRef (ref args));
|
||||
register "len" (fun args ->
|
||||
match args with
|
||||
| [List l] | [ListRef { contents = l }] -> Number (float_of_int (List.length l))
|
||||
| [String s] -> Number (float_of_int (String.length s))
|
||||
| [Dict d] -> Number (float_of_int (Hashtbl.length d))
|
||||
| [Nil] -> Number 0.0
|
||||
| _ -> raise (Eval_error "len: 1 arg"));
|
||||
register "first" (fun args ->
|
||||
match args with
|
||||
| [List (x :: _)] | [ListRef { contents = x :: _ }] -> x
|
||||
| [List []] | [ListRef { contents = [] }] -> Nil | [Nil] -> Nil
|
||||
| _ -> raise (Eval_error "first: 1 list arg"));
|
||||
register "rest" (fun args ->
|
||||
match args with
|
||||
| [List (_ :: xs)] | [ListRef { contents = _ :: xs }] -> List xs
|
||||
| [List []] | [ListRef { contents = [] }] -> List [] | [Nil] -> List []
|
||||
| _ -> raise (Eval_error "rest: 1 list arg"));
|
||||
register "last" (fun args ->
|
||||
match args with
|
||||
| [List l] | [ListRef { contents = l }] ->
|
||||
(match List.rev l with x :: _ -> x | [] -> Nil)
|
||||
| _ -> raise (Eval_error "last: 1 list arg"));
|
||||
register "nth" (fun args ->
|
||||
match args with
|
||||
| [List l; Number n] | [ListRef { contents = l }; Number n] ->
|
||||
(try List.nth l (int_of_float n) with _ -> Nil)
|
||||
| _ -> raise (Eval_error "nth: list and number"));
|
||||
register "cons" (fun args ->
|
||||
match args with
|
||||
| [x; List l] | [x; ListRef { contents = l }] -> List (x :: l)
|
||||
| [x; Nil] -> List [x]
|
||||
| _ -> raise (Eval_error "cons: value and list"));
|
||||
register "append" (fun args ->
|
||||
let all = List.concat_map (fun a -> as_list a) args in
|
||||
List all);
|
||||
register "reverse" (fun args ->
|
||||
match args with
|
||||
| [List l] | [ListRef { contents = l }] -> List (List.rev l)
|
||||
| _ -> raise (Eval_error "reverse: 1 list"));
|
||||
register "flatten" (fun args ->
|
||||
let rec flat = function
|
||||
| List items | ListRef { contents = items } -> List.concat_map flat items
|
||||
| x -> [x]
|
||||
in
|
||||
match args with
|
||||
| [List l] | [ListRef { contents = l }] -> List (List.concat_map flat l)
|
||||
| _ -> raise (Eval_error "flatten: 1 list"));
|
||||
register "concat" (fun args -> List (List.concat_map as_list args));
|
||||
register "contains?" (fun args ->
|
||||
match args with
|
||||
| [List l; item] | [ListRef { contents = l }; item] -> Bool (List.mem item l)
|
||||
| [String s; String sub] ->
|
||||
let rec find i =
|
||||
if i + String.length sub > String.length s then false
|
||||
else if String.sub s i (String.length sub) = sub then true
|
||||
else find (i + 1)
|
||||
in Bool (find 0)
|
||||
| _ -> raise (Eval_error "contains?: 2 args"));
|
||||
register "range" (fun args ->
|
||||
match args with
|
||||
| [Number stop] ->
|
||||
let n = int_of_float stop in
|
||||
List (List.init (max 0 n) (fun i -> Number (float_of_int i)))
|
||||
| [Number start; Number stop] ->
|
||||
let s = int_of_float start and e = int_of_float stop in
|
||||
let len = max 0 (e - s) in
|
||||
List (List.init len (fun i -> Number (float_of_int (s + i))))
|
||||
| [Number start; Number stop; Number step] ->
|
||||
let s = start and e = stop and st = step in
|
||||
if st = 0.0 then List []
|
||||
else
|
||||
let items = ref [] in
|
||||
let i = ref s in
|
||||
if st > 0.0 then
|
||||
(while !i < e do items := Number !i :: !items; i := !i +. st done)
|
||||
else
|
||||
(while !i > e do items := Number !i :: !items; i := !i +. st done);
|
||||
List (List.rev !items)
|
||||
| _ -> raise (Eval_error "range: 1-3 args"));
|
||||
register "slice" (fun args ->
|
||||
match args with
|
||||
| [(List l | ListRef { contents = l }); Number start] ->
|
||||
let i = max 0 (int_of_float start) in
|
||||
let rec drop n = function _ :: xs when n > 0 -> drop (n-1) xs | l -> l in
|
||||
List (drop i l)
|
||||
| [(List l | ListRef { contents = l }); Number start; Number end_] ->
|
||||
let i = max 0 (int_of_float start) and j = int_of_float end_ in
|
||||
let len = List.length l in
|
||||
let j = min j len in
|
||||
let rec take_range idx = function
|
||||
| [] -> []
|
||||
| x :: xs ->
|
||||
if idx >= j then []
|
||||
else if idx >= i then x :: take_range (idx+1) xs
|
||||
else take_range (idx+1) xs
|
||||
in List (take_range 0 l)
|
||||
| [String s; Number start] ->
|
||||
let i = max 0 (int_of_float start) in
|
||||
String (String.sub s i (max 0 (String.length s - i)))
|
||||
| [String s; Number start; Number end_] ->
|
||||
let i = max 0 (int_of_float start) and j = int_of_float end_ in
|
||||
let sl = String.length s in
|
||||
let j = min j sl in
|
||||
String (String.sub s i (max 0 (j - i)))
|
||||
| _ -> raise (Eval_error "slice: 2-3 args"));
|
||||
register "sort" (fun args ->
|
||||
match args with
|
||||
| [List l] | [ListRef { contents = l }] -> List (List.sort compare l)
|
||||
| _ -> raise (Eval_error "sort: 1 list"));
|
||||
register "zip" (fun args ->
|
||||
match args with
|
||||
| [a; b] ->
|
||||
let la = as_list a and lb = as_list b in
|
||||
let rec go l1 l2 acc = match l1, l2 with
|
||||
| x :: xs, y :: ys -> go xs ys (List [x; y] :: acc)
|
||||
| _ -> List.rev acc
|
||||
in List (go la lb [])
|
||||
| _ -> raise (Eval_error "zip: 2 lists"));
|
||||
register "zip-pairs" (fun args ->
|
||||
match args with
|
||||
| [v] ->
|
||||
let l = as_list v in
|
||||
let rec go = function
|
||||
| a :: b :: rest -> List [a; b] :: go rest
|
||||
| _ -> []
|
||||
in List (go l)
|
||||
| _ -> raise (Eval_error "zip-pairs: 1 list"));
|
||||
register "take" (fun args ->
|
||||
match args with
|
||||
| [(List l | ListRef { contents = l }); Number n] ->
|
||||
let rec take_n i = function
|
||||
| x :: xs when i > 0 -> x :: take_n (i-1) xs
|
||||
| _ -> []
|
||||
in List (take_n (int_of_float n) l)
|
||||
| _ -> raise (Eval_error "take: list and number"));
|
||||
register "drop" (fun args ->
|
||||
match args with
|
||||
| [(List l | ListRef { contents = l }); Number n] ->
|
||||
let rec drop_n i = function
|
||||
| _ :: xs when i > 0 -> drop_n (i-1) xs
|
||||
| l -> l
|
||||
in List (drop_n (int_of_float n) l)
|
||||
| _ -> raise (Eval_error "drop: list and number"));
|
||||
register "chunk-every" (fun args ->
|
||||
match args with
|
||||
| [(List l | ListRef { contents = l }); Number n] ->
|
||||
let size = int_of_float n in
|
||||
let rec go = function
|
||||
| [] -> []
|
||||
| l ->
|
||||
let rec take_n i = function
|
||||
| x :: xs when i > 0 -> x :: take_n (i-1) xs
|
||||
| _ -> []
|
||||
in
|
||||
let rec drop_n i = function
|
||||
| _ :: xs when i > 0 -> drop_n (i-1) xs
|
||||
| l -> l
|
||||
in
|
||||
List (take_n size l) :: go (drop_n size l)
|
||||
in List (go l)
|
||||
| _ -> raise (Eval_error "chunk-every: list and number"));
|
||||
register "unique" (fun args ->
|
||||
match args with
|
||||
| [(List l | ListRef { contents = l })] ->
|
||||
let seen = Hashtbl.create 16 in
|
||||
let result = List.filter (fun x ->
|
||||
let key = inspect x in
|
||||
if Hashtbl.mem seen key then false
|
||||
else (Hashtbl.replace seen key true; true)
|
||||
) l in
|
||||
List result
|
||||
| _ -> raise (Eval_error "unique: 1 list"));
|
||||
|
||||
(* === Dict === *)
|
||||
register "dict" (fun args ->
|
||||
let d = make_dict () in
|
||||
let rec go = function
|
||||
| [] -> Dict d
|
||||
| Keyword k :: v :: rest -> dict_set d k v; go rest
|
||||
| String k :: v :: rest -> dict_set d k v; go rest
|
||||
| _ -> raise (Eval_error "dict: pairs of key value")
|
||||
in go args);
|
||||
register "get" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k] -> dict_get d k
|
||||
| [Dict d; Keyword k] -> dict_get d k
|
||||
| [List l; Number n] | [ListRef { contents = l }; Number n] ->
|
||||
(try List.nth l (int_of_float n) with _ -> Nil)
|
||||
| _ -> raise (Eval_error "get: dict+key or list+index"));
|
||||
register "has-key?" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k] -> Bool (dict_has d k)
|
||||
| [Dict d; Keyword k] -> Bool (dict_has d k)
|
||||
| _ -> raise (Eval_error "has-key?: dict and key"));
|
||||
register "assoc" (fun args ->
|
||||
match args with
|
||||
| Dict d :: rest ->
|
||||
let d2 = Hashtbl.copy d in
|
||||
let rec go = function
|
||||
| [] -> Dict d2
|
||||
| String k :: v :: rest -> Hashtbl.replace d2 k v; go rest
|
||||
| Keyword k :: v :: rest -> Hashtbl.replace d2 k v; go rest
|
||||
| _ -> raise (Eval_error "assoc: pairs")
|
||||
in go rest
|
||||
| _ -> raise (Eval_error "assoc: dict + pairs"));
|
||||
register "dissoc" (fun args ->
|
||||
match args with
|
||||
| Dict d :: keys ->
|
||||
let d2 = Hashtbl.copy d in
|
||||
List.iter (fun k -> Hashtbl.remove d2 (to_string k)) keys;
|
||||
Dict d2
|
||||
| _ -> raise (Eval_error "dissoc: dict + keys"));
|
||||
register "merge" (fun args ->
|
||||
let d = make_dict () in
|
||||
List.iter (function
|
||||
| Dict src -> Hashtbl.iter (fun k v -> Hashtbl.replace d k v) src
|
||||
| _ -> raise (Eval_error "merge: all args must be dicts")
|
||||
) args;
|
||||
Dict d);
|
||||
register "keys" (fun args ->
|
||||
match args with [Dict d] -> List (dict_keys d) | _ -> raise (Eval_error "keys: 1 dict"));
|
||||
register "vals" (fun args ->
|
||||
match args with [Dict d] -> List (dict_vals d) | _ -> raise (Eval_error "vals: 1 dict"));
|
||||
register "dict-set!" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k; v] -> dict_set d k v; v
|
||||
| [Dict d; Keyword k; v] -> dict_set d k v; v
|
||||
| _ -> raise (Eval_error "dict-set!: dict key val"));
|
||||
register "dict-get" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k] -> dict_get d k
|
||||
| [Dict d; Keyword k] -> dict_get d k
|
||||
| _ -> raise (Eval_error "dict-get: dict and key"));
|
||||
register "dict-has?" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k] -> Bool (dict_has d k)
|
||||
| _ -> raise (Eval_error "dict-has?: dict and key"));
|
||||
register "dict-delete!" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k] -> dict_delete d k; Nil
|
||||
| _ -> raise (Eval_error "dict-delete!: dict and key"));
|
||||
|
||||
(* === Misc === *)
|
||||
register "type-of" (fun args ->
|
||||
match args with [a] -> String (type_of a) | _ -> raise (Eval_error "type-of: 1 arg"));
|
||||
register "inspect" (fun args ->
|
||||
match args with [a] -> String (inspect a) | _ -> raise (Eval_error "inspect: 1 arg"));
|
||||
register "error" (fun args ->
|
||||
match args with [String msg] -> raise (Eval_error msg)
|
||||
| [a] -> raise (Eval_error (to_string a))
|
||||
| _ -> raise (Eval_error "error: 1 arg"));
|
||||
register "apply" (fun args ->
|
||||
match args with
|
||||
| [NativeFn (_, f); List a] -> f a
|
||||
| _ -> raise (Eval_error "apply: function and list"));
|
||||
register "identical?" (fun args ->
|
||||
match args with [a; b] -> Bool (a == b) | _ -> raise (Eval_error "identical?: 2 args"));
|
||||
register "make-spread" (fun args ->
|
||||
match args with
|
||||
| [Dict d] ->
|
||||
let pairs = Hashtbl.fold (fun k v acc -> (k, v) :: acc) d [] in
|
||||
Spread pairs
|
||||
| _ -> raise (Eval_error "make-spread: 1 dict"));
|
||||
register "spread?" (fun args ->
|
||||
match args with [Spread _] -> Bool true | [_] -> Bool false
|
||||
| _ -> raise (Eval_error "spread?: 1 arg"));
|
||||
register "spread-attrs" (fun args ->
|
||||
match args with
|
||||
| [Spread pairs] ->
|
||||
let d = make_dict () in
|
||||
List.iter (fun (k, v) -> dict_set d k v) pairs;
|
||||
Dict d
|
||||
| _ -> raise (Eval_error "spread-attrs: 1 spread"));
|
||||
()
|
||||
539
hosts/ocaml/lib/sx_ref.ml
Normal file
539
hosts/ocaml/lib/sx_ref.ml
Normal file
File diff suppressed because one or more lines are too long
444
hosts/ocaml/lib/sx_render.ml
Normal file
444
hosts/ocaml/lib/sx_render.ml
Normal file
@@ -0,0 +1,444 @@
|
||||
(** HTML renderer for SX values.
|
||||
|
||||
Extracted from run_tests.ml — renders an SX expression tree to an
|
||||
HTML string, expanding components and macros along the way.
|
||||
|
||||
Depends on [Sx_ref.eval_expr] for evaluating sub-expressions
|
||||
during rendering (keyword arg values, conditionals, etc.). *)
|
||||
|
||||
open Sx_types
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Tag / attribute registries *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let html_tags = [
|
||||
"html"; "head"; "body"; "title"; "meta"; "link"; "script"; "style"; "noscript";
|
||||
"header"; "nav"; "main"; "section"; "article"; "aside"; "footer";
|
||||
"h1"; "h2"; "h3"; "h4"; "h5"; "h6"; "hgroup";
|
||||
"div"; "p"; "blockquote"; "pre"; "figure"; "figcaption"; "address"; "hr";
|
||||
"ul"; "ol"; "li"; "dl"; "dt"; "dd"; "menu";
|
||||
"a"; "span"; "em"; "strong"; "small"; "b"; "i"; "u"; "s"; "sub"; "sup";
|
||||
"mark"; "del"; "ins"; "q"; "cite"; "dfn"; "abbr"; "code"; "var"; "samp";
|
||||
"kbd"; "data"; "time"; "ruby"; "rt"; "rp"; "bdi"; "bdo"; "wbr"; "br";
|
||||
"table"; "thead"; "tbody"; "tfoot"; "tr"; "th"; "td"; "caption"; "colgroup"; "col";
|
||||
"form"; "input"; "textarea"; "select"; "option"; "optgroup"; "button"; "label";
|
||||
"fieldset"; "legend"; "datalist"; "output"; "progress"; "meter";
|
||||
"details"; "summary"; "dialog";
|
||||
"img"; "video"; "audio"; "source"; "picture"; "canvas"; "iframe"; "embed"; "object"; "param";
|
||||
"svg"; "path"; "circle"; "rect"; "line"; "polyline"; "polygon"; "ellipse";
|
||||
"g"; "defs"; "use"; "text"; "tspan"; "clipPath"; "mask"; "pattern";
|
||||
"linearGradient"; "radialGradient"; "stop"; "filter"; "feBlend"; "feFlood";
|
||||
"feGaussianBlur"; "feOffset"; "feMerge"; "feMergeNode"; "feComposite";
|
||||
"template"; "slot";
|
||||
]
|
||||
|
||||
let void_elements = [
|
||||
"area"; "base"; "br"; "col"; "embed"; "hr"; "img"; "input";
|
||||
"link"; "meta"; "param"; "source"; "track"; "wbr"
|
||||
]
|
||||
|
||||
let boolean_attrs = [
|
||||
"async"; "autofocus"; "autoplay"; "checked"; "controls"; "default";
|
||||
"defer"; "disabled"; "formnovalidate"; "hidden"; "inert"; "ismap";
|
||||
"loop"; "multiple"; "muted"; "nomodule"; "novalidate"; "open";
|
||||
"playsinline"; "readonly"; "required"; "reversed"; "selected"
|
||||
]
|
||||
|
||||
let is_html_tag name = List.mem name html_tags
|
||||
let is_void name = List.mem name void_elements
|
||||
let is_boolean_attr name = List.mem name boolean_attrs
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* HTML escaping *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let escape_html s =
|
||||
let buf = Buffer.create (String.length s) in
|
||||
String.iter (function
|
||||
| '&' -> Buffer.add_string buf "&"
|
||||
| '<' -> Buffer.add_string buf "<"
|
||||
| '>' -> Buffer.add_string buf ">"
|
||||
| '"' -> Buffer.add_string buf """
|
||||
| c -> Buffer.add_char buf c) s;
|
||||
Buffer.contents buf
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Attribute rendering *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let render_attrs attrs =
|
||||
let buf = Buffer.create 64 in
|
||||
Hashtbl.iter (fun k v ->
|
||||
if is_boolean_attr k then begin
|
||||
if sx_truthy v then begin
|
||||
Buffer.add_char buf ' ';
|
||||
Buffer.add_string buf k
|
||||
end
|
||||
end else if not (is_nil v) then begin
|
||||
Buffer.add_char buf ' ';
|
||||
Buffer.add_string buf k;
|
||||
Buffer.add_string buf "=\"";
|
||||
Buffer.add_string buf (escape_html (value_to_string v));
|
||||
Buffer.add_char buf '"'
|
||||
end) attrs;
|
||||
Buffer.contents buf
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* HTML renderer *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
(* Forward ref — resolved at setup time *)
|
||||
let render_to_html_ref : (value -> env -> string) ref =
|
||||
ref (fun _expr _env -> "")
|
||||
|
||||
let render_to_html expr env = !render_to_html_ref expr env
|
||||
|
||||
let render_children children env =
|
||||
String.concat "" (List.map (fun c -> render_to_html c env) children)
|
||||
|
||||
(** Parse keyword attrs and positional children from an element call's args.
|
||||
Attrs are evaluated; children are returned UNEVALUATED for render dispatch. *)
|
||||
let parse_element_args args env =
|
||||
let attrs = Hashtbl.create 8 in
|
||||
let children = ref [] in
|
||||
let skip = ref false in
|
||||
let len = List.length args in
|
||||
List.iteri (fun idx arg ->
|
||||
if !skip then skip := false
|
||||
else match arg with
|
||||
| Keyword k when idx + 1 < len ->
|
||||
let v = Sx_ref.eval_expr (List.nth args (idx + 1)) (Env env) in
|
||||
Hashtbl.replace attrs k v;
|
||||
skip := true
|
||||
| Spread pairs ->
|
||||
List.iter (fun (k, v) -> Hashtbl.replace attrs k v) pairs
|
||||
| _ ->
|
||||
children := arg :: !children
|
||||
) args;
|
||||
(attrs, List.rev !children)
|
||||
|
||||
let render_html_element tag args env =
|
||||
let (attrs, children) = parse_element_args args env in
|
||||
let attr_str = render_attrs attrs in
|
||||
if is_void tag then
|
||||
"<" ^ tag ^ attr_str ^ " />"
|
||||
else
|
||||
let content = String.concat ""
|
||||
(List.map (fun c -> render_to_html c env) children) in
|
||||
"<" ^ tag ^ attr_str ^ ">" ^ content ^ "</" ^ tag ^ ">"
|
||||
|
||||
let render_component_generic ~params ~has_children ~body ~closure args env =
|
||||
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 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)
|
||||
) params;
|
||||
if 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 body local
|
||||
|
||||
let render_component comp args env =
|
||||
match comp with
|
||||
| Component c ->
|
||||
render_component_generic
|
||||
~params:c.c_params ~has_children:c.c_has_children
|
||||
~body:c.c_body ~closure:c.c_closure args env
|
||||
| Island i ->
|
||||
render_component_generic
|
||||
~params:i.i_params ~has_children:i.i_has_children
|
||||
~body:i.i_body ~closure:i.i_closure args env
|
||||
| _ -> ""
|
||||
|
||||
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 _ | Island _ -> 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 "")
|
||||
470
hosts/ocaml/lib/sx_runtime.ml
Normal file
470
hosts/ocaml/lib/sx_runtime.ml
Normal file
@@ -0,0 +1,470 @@
|
||||
(** 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 stacks — thread-local stacks keyed by name string.
|
||||
collect!/collected implement accumulator scopes.
|
||||
emit!/emitted implement event emission scopes.
|
||||
context reads the top of a named scope stack. *)
|
||||
let _scope_stacks : (string, value list) Hashtbl.t = Hashtbl.create 8
|
||||
|
||||
let sx_collect name value =
|
||||
let key = value_to_str name in
|
||||
let stack = match Hashtbl.find_opt _scope_stacks key with
|
||||
| Some s -> s | None -> [] in
|
||||
(* Push value onto the top list of the stack *)
|
||||
(match stack with
|
||||
| List items :: rest ->
|
||||
Hashtbl.replace _scope_stacks key (List (items @ [value]) :: rest)
|
||||
| _ ->
|
||||
Hashtbl.replace _scope_stacks key (List [value] :: stack));
|
||||
Nil
|
||||
|
||||
let sx_collected name =
|
||||
let key = value_to_str name in
|
||||
match Hashtbl.find_opt _scope_stacks key with
|
||||
| Some (List items :: _) -> List items
|
||||
| _ -> List []
|
||||
|
||||
let sx_clear_collected name =
|
||||
let key = value_to_str name in
|
||||
(match Hashtbl.find_opt _scope_stacks key with
|
||||
| Some (_ :: rest) -> Hashtbl.replace _scope_stacks key (List [] :: rest)
|
||||
| _ -> ());
|
||||
Nil
|
||||
|
||||
let sx_emit name value =
|
||||
let key = value_to_str name in
|
||||
let stack = match Hashtbl.find_opt _scope_stacks key with
|
||||
| Some s -> s | None -> [] in
|
||||
(match stack with
|
||||
| List items :: rest ->
|
||||
Hashtbl.replace _scope_stacks key (List (items @ [value]) :: rest)
|
||||
| _ ->
|
||||
Hashtbl.replace _scope_stacks key (List [value] :: stack));
|
||||
Nil
|
||||
|
||||
let sx_emitted name =
|
||||
let key = value_to_str name in
|
||||
match Hashtbl.find_opt _scope_stacks key with
|
||||
| Some (List items :: _) -> List items
|
||||
| _ -> List []
|
||||
|
||||
let sx_context name default =
|
||||
let key = value_to_str name in
|
||||
match Hashtbl.find_opt _scope_stacks key with
|
||||
| Some (v :: _) -> v
|
||||
| _ -> default
|
||||
|
||||
(* 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 =
|
||||
let key = value_to_str name in
|
||||
let stack = match Hashtbl.find_opt _scope_stacks key with
|
||||
| Some s -> s | None -> [] in
|
||||
Hashtbl.replace _scope_stacks key (value :: stack);
|
||||
Nil
|
||||
|
||||
let scope_pop name =
|
||||
let key = value_to_str name in
|
||||
(match Hashtbl.find_opt _scope_stacks key with
|
||||
| Some (_ :: rest) -> Hashtbl.replace _scope_stacks key rest
|
||||
| _ -> ());
|
||||
Nil
|
||||
|
||||
let provide_push name value = scope_push name value
|
||||
let provide_pop name = scope_pop name
|
||||
|
||||
(* Render mode — mutable refs so browser entry point can wire up the renderer *)
|
||||
let _render_active_p_fn : (unit -> value) ref = ref (fun () -> Bool false)
|
||||
let _render_expr_fn : (value -> value -> value) ref = ref (fun _expr _env -> Nil)
|
||||
let _is_render_expr_fn : (value -> value) ref = ref (fun _expr -> Bool false)
|
||||
|
||||
let render_active_p () = !_render_active_p_fn ()
|
||||
let render_expr expr env = !_render_expr_fn expr env
|
||||
let is_render_expr expr = !_is_render_expr_fn expr
|
||||
|
||||
(* Signal accessors — handle both native Signal type and dict-based signals
|
||||
from web/signals.sx which use {__signal: true, value: ..., subscribers: ..., deps: ...} *)
|
||||
let is_dict_signal d = Hashtbl.mem d "__signal"
|
||||
|
||||
let signal_value s = match s with
|
||||
| Signal sig' -> sig'.s_value
|
||||
| Dict d when is_dict_signal d -> Sx_types.dict_get d "value"
|
||||
| _ -> raise (Eval_error ("not a signal: " ^ Sx_types.type_of s))
|
||||
|
||||
let signal_set_value s v = match s with
|
||||
| Signal sig' -> sig'.s_value <- v; v
|
||||
| Dict d when is_dict_signal d -> Hashtbl.replace d "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)
|
||||
| Dict d when is_dict_signal d -> Sx_types.dict_get d "subscribers"
|
||||
| _ -> List []
|
||||
|
||||
(* These use Obj.magic to accept both SX values and OCaml closures.
|
||||
The transpiler generates bare (fun () -> ...) for reactive subscribers
|
||||
but signal_add_sub_b expects value. This is a known transpiler limitation. *)
|
||||
let signal_add_sub_b s (f : _ ) = match s with
|
||||
| Dict d when is_dict_signal d ->
|
||||
let f_val : value = Obj.magic f in
|
||||
let subs = match Sx_types.dict_get d "subscribers" with
|
||||
| List l -> l | ListRef r -> !r | _ -> [] in
|
||||
Hashtbl.replace d "subscribers" (List (subs @ [f_val])); Nil
|
||||
| _ -> Nil
|
||||
|
||||
let signal_remove_sub_b s (f : _) = match s with
|
||||
| Dict d when is_dict_signal d ->
|
||||
let f_val : value = Obj.magic f in
|
||||
let subs = match Sx_types.dict_get d "subscribers" with
|
||||
| List l -> l | ListRef r -> !r | _ -> [] in
|
||||
Hashtbl.replace d "subscribers" (List (List.filter (fun x -> x != f_val) subs)); Nil
|
||||
| _ -> Nil
|
||||
|
||||
let signal_deps s = match s with
|
||||
| Dict d when is_dict_signal d -> Sx_types.dict_get d "deps"
|
||||
| _ -> List []
|
||||
|
||||
let signal_set_deps s deps = match s with
|
||||
| Dict d when is_dict_signal d -> Hashtbl.replace d "deps" deps; Nil
|
||||
| _ -> Nil
|
||||
|
||||
let notify_subscribers s = match s with
|
||||
| Dict d when is_dict_signal d ->
|
||||
let subs = match Sx_types.dict_get d "subscribers" with
|
||||
| List l -> l | ListRef r -> !r | _ -> [] in
|
||||
List.iter (fun sub ->
|
||||
match sub with
|
||||
| NativeFn (_, f) -> ignore (f [])
|
||||
| Lambda _ -> ignore (Sx_types.env_bind (Sx_types.make_env ()) "_" Nil) (* TODO: call through CEK *)
|
||||
| _ -> ()
|
||||
) subs; Nil
|
||||
| _ -> Nil
|
||||
|
||||
let flush_subscribers _s = Nil
|
||||
let dispose_computed _s = Nil
|
||||
|
||||
(* Island scope stubs — accept OCaml functions from transpiled code.
|
||||
Use Obj.magic for the same reason as signal_add_sub_b. *)
|
||||
let with_island_scope (_register_fn : _) (body_fn : _) =
|
||||
let body : unit -> value = Obj.magic body_fn in
|
||||
body ()
|
||||
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
|
||||
401
hosts/ocaml/lib/sx_types.ml
Normal file
401
hosts/ocaml/lib/sx_types.ml
Normal file
@@ -0,0 +1,401 @@
|
||||
(** 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
|
||||
| Dict d -> Hashtbl.mem d "__signal"
|
||||
| _ -> 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
|
||||
| Island i -> String i.i_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)
|
||||
| Island i -> List (List.map (fun s -> String s) i.i_params)
|
||||
| v -> raise (Eval_error ("Expected component, got " ^ type_of v))
|
||||
|
||||
let component_body = function
|
||||
| Component c -> c.c_body
|
||||
| Island i -> i.i_body
|
||||
| v -> raise (Eval_error ("Expected component, got " ^ type_of v))
|
||||
|
||||
let component_closure = function
|
||||
| Component c -> Env c.c_closure
|
||||
| Island i -> Env i.i_closure
|
||||
| v -> raise (Eval_error ("Expected component, got " ^ type_of v))
|
||||
|
||||
let component_has_children = function
|
||||
| Component c -> Bool c.c_has_children
|
||||
| Island i -> Bool i.i_has_children
|
||||
| v -> raise (Eval_error ("Expected component, got " ^ type_of v))
|
||||
|
||||
let component_affinity = function
|
||||
| Component c -> String c.c_affinity
|
||||
| Island _ -> String "client"
|
||||
| _ -> String "auto"
|
||||
|
||||
let macro_params = function
|
||||
| Macro m -> List (List.map (fun s -> String s) m.m_params)
|
||||
| v -> raise (Eval_error ("Expected macro, got " ^ type_of v))
|
||||
|
||||
let macro_rest_param = function
|
||||
| Macro m -> (match m.m_rest_param with Some s -> String s | None -> Nil)
|
||||
| v -> raise (Eval_error ("Expected macro, got " ^ type_of v))
|
||||
|
||||
let macro_body = function
|
||||
| Macro m -> m.m_body
|
||||
| v -> raise (Eval_error ("Expected macro, got " ^ type_of v))
|
||||
|
||||
let macro_closure = function
|
||||
| Macro m -> Env m.m_closure
|
||||
| v -> raise (Eval_error ("Expected macro, got " ^ type_of v))
|
||||
|
||||
let thunk_expr = function
|
||||
| Thunk (e, _) -> e
|
||||
| v -> raise (Eval_error ("Expected thunk, got " ^ type_of v))
|
||||
|
||||
let thunk_env = function
|
||||
| Thunk (_, e) -> Env e
|
||||
| v -> raise (Eval_error ("Expected thunk, got " ^ type_of v))
|
||||
|
||||
|
||||
(** {1 Dict operations} *)
|
||||
|
||||
let make_dict () : dict = Hashtbl.create 8
|
||||
|
||||
let dict_get (d : dict) key =
|
||||
match Hashtbl.find_opt d key with Some v -> v | None -> Nil
|
||||
|
||||
let dict_has (d : dict) key = Hashtbl.mem d key
|
||||
|
||||
let dict_set (d : dict) key v = Hashtbl.replace d key v
|
||||
|
||||
let dict_delete (d : dict) key = Hashtbl.remove d key
|
||||
|
||||
let dict_keys (d : dict) =
|
||||
Hashtbl.fold (fun k _ acc -> String k :: acc) d []
|
||||
|
||||
let dict_vals (d : dict) =
|
||||
Hashtbl.fold (fun _ v acc -> v :: acc) d []
|
||||
|
||||
|
||||
(** {1 Value display} *)
|
||||
|
||||
let rec inspect = function
|
||||
| Nil -> "nil"
|
||||
| Bool true -> "true"
|
||||
| Bool false -> "false"
|
||||
| Number n ->
|
||||
if Float.is_integer n then Printf.sprintf "%d" (int_of_float n)
|
||||
else Printf.sprintf "%g" n
|
||||
| String s -> Printf.sprintf "%S" s
|
||||
| Symbol s -> s
|
||||
| Keyword k -> ":" ^ k
|
||||
| List items | ListRef { contents = items } ->
|
||||
"(" ^ String.concat " " (List.map inspect items) ^ ")"
|
||||
| Dict d ->
|
||||
let pairs = Hashtbl.fold (fun k v acc ->
|
||||
(Printf.sprintf ":%s %s" k (inspect v)) :: acc) d [] in
|
||||
"{" ^ String.concat " " pairs ^ "}"
|
||||
| Lambda l ->
|
||||
let tag = match l.l_name with Some n -> n | None -> "lambda" in
|
||||
Printf.sprintf "<%s(%s)>" tag (String.concat ", " l.l_params)
|
||||
| Component c ->
|
||||
Printf.sprintf "<Component ~%s(%s)>" c.c_name (String.concat ", " c.c_params)
|
||||
| Island i ->
|
||||
Printf.sprintf "<Island ~%s(%s)>" i.i_name (String.concat ", " i.i_params)
|
||||
| Macro m ->
|
||||
let tag = match m.m_name with Some n -> n | None -> "macro" in
|
||||
Printf.sprintf "<%s(%s)>" tag (String.concat ", " m.m_params)
|
||||
| Thunk _ -> "<thunk>"
|
||||
| Continuation (_, _) -> "<continuation>"
|
||||
| NativeFn (name, _) -> Printf.sprintf "<native:%s>" name
|
||||
| Signal _ -> "<signal>"
|
||||
| RawHTML s -> Printf.sprintf "<raw-html:%d chars>" (String.length s)
|
||||
| Spread _ -> "<spread>"
|
||||
| SxExpr s -> Printf.sprintf "<sx-expr:%d chars>" (String.length s)
|
||||
| Env _ -> "<env>"
|
||||
1230
hosts/ocaml/transpiler.sx
Normal file
1230
hosts/ocaml/transpiler.sx
Normal file
File diff suppressed because it is too large
Load Diff
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/js_of_ocaml-651f6707.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/js_of_ocaml-651f6707.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/jsoo_runtime-f96b44a8.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/jsoo_runtime-f96b44a8.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/prelude-d7e4b000.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/prelude-d7e4b000.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/runtime-0db9b496.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/runtime-0db9b496.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/start-9afa06f6.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/start-9afa06f6.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/std_exit-10fb8830.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/std_exit-10fb8830.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/stdlib-23ce0836.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/stdlib-23ce0836.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/sx-2f171299.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/sx-2f171299.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/sx-340f03ca.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/sx-340f03ca.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/sx-4d3c7bfa.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/sx-4d3c7bfa.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/sx-a462ed04.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/sx-a462ed04.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/sx-ca2dce12.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/sx-ca2dce12.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/sx-fc47a7a0.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/sx-fc47a7a0.wasm
Normal file
Binary file not shown.
2584
shared/static/scripts/sx-wasm.js
Normal file
2584
shared/static/scripts/sx-wasm.js
Normal file
File diff suppressed because one or more lines are too long
@@ -852,6 +852,9 @@ async def sx_page(ctx: dict, page_sx: str, *,
|
||||
if body_scripts is None:
|
||||
body_scripts = _shell_cfg.get("body_scripts")
|
||||
|
||||
import os as _os
|
||||
_sx_js_file = "sx-wasm.js" if _os.environ.get("SX_USE_WASM") == "1" else "sx-browser.js"
|
||||
|
||||
shell_kwargs: dict[str, Any] = dict(
|
||||
title=_html_escape(title),
|
||||
asset_url=asset_url,
|
||||
@@ -863,7 +866,8 @@ async def sx_page(ctx: dict, page_sx: str, *,
|
||||
page_sx=page_sx,
|
||||
sx_css=sx_css,
|
||||
sx_css_classes=sx_css_classes,
|
||||
sx_js_hash=_script_hash("sx-browser.js"),
|
||||
sx_js_file=_sx_js_file,
|
||||
sx_js_hash=_script_hash(_sx_js_file),
|
||||
body_js_hash=_script_hash("body.js"),
|
||||
)
|
||||
if head_scripts is not None:
|
||||
|
||||
@@ -31,7 +31,13 @@ from typing import Any
|
||||
from .types import NIL, Component, Island, Keyword, Lambda, Macro, Symbol
|
||||
from .parser import parse
|
||||
import os as _os
|
||||
if _os.environ.get("SX_USE_REF") == "1":
|
||||
if _os.environ.get("SX_USE_OCAML") == "1":
|
||||
# OCaml kernel bridge — render via persistent subprocess.
|
||||
# html_render and _render_component are set up lazily since the bridge
|
||||
# requires an async event loop. The sync sx() function falls back to
|
||||
# the ref renderer; async callers use ocaml_bridge directly.
|
||||
from .ref.sx_ref import render as html_render, render_html_component as _render_component
|
||||
elif _os.environ.get("SX_USE_REF") == "1":
|
||||
from .ref.sx_ref import render as html_render, render_html_component as _render_component
|
||||
else:
|
||||
from .html import render as html_render, _render_component
|
||||
@@ -348,6 +354,12 @@ def reload_if_changed() -> None:
|
||||
reload_logger.info("Reloaded %d file(s), components in %.1fms",
|
||||
len(changed_files), (t1 - t0) * 1000)
|
||||
|
||||
# Invalidate OCaml bridge component cache so next render reloads
|
||||
if _os.environ.get("SX_USE_OCAML") == "1":
|
||||
from .ocaml_bridge import _bridge
|
||||
if _bridge is not None:
|
||||
_bridge._components_loaded = False
|
||||
|
||||
# Recompute render plans for all services that have pages
|
||||
from .pages import _PAGE_REGISTRY, compute_page_render_plans
|
||||
for svc in _PAGE_REGISTRY:
|
||||
@@ -430,6 +442,9 @@ def finalize_components() -> None:
|
||||
compute_all_io_refs(_COMPONENT_ENV, get_all_io_names())
|
||||
_compute_component_hash()
|
||||
|
||||
# OCaml bridge loads components lazily on first render via
|
||||
# OcamlBridge._ensure_components() — no sync needed here.
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# sx() — render s-expression from Jinja template
|
||||
@@ -482,7 +497,16 @@ async def sx_async(source: str, **kwargs: Any) -> str:
|
||||
Use when the s-expression contains I/O nodes::
|
||||
|
||||
{{ sx_async('(frag "blog" "card" :slug "apple")') | safe }}
|
||||
|
||||
When SX_USE_OCAML=1, renders via the OCaml kernel subprocess which
|
||||
yields io-requests back to Python for async fulfillment.
|
||||
"""
|
||||
if _os.environ.get("SX_USE_OCAML") == "1":
|
||||
from .ocaml_bridge import get_bridge
|
||||
bridge = await get_bridge()
|
||||
ctx = dict(kwargs)
|
||||
return await bridge.render(source, ctx=ctx)
|
||||
|
||||
from .resolver import resolve, RequestContext
|
||||
|
||||
env = dict(_COMPONENT_ENV)
|
||||
|
||||
408
shared/sx/ocaml_bridge.py
Normal file
408
shared/sx/ocaml_bridge.py
Normal file
@@ -0,0 +1,408 @@
|
||||
"""
|
||||
OCaml SX kernel ↔ Python coroutine bridge.
|
||||
|
||||
Manages a persistent OCaml subprocess (sx_server) that evaluates SX
|
||||
expressions. When the OCaml kernel needs IO (database queries, service
|
||||
calls), it yields an ``(io-request ...)`` back to Python, which fulfills
|
||||
it asynchronously and sends an ``(io-response ...)`` back.
|
||||
|
||||
Usage::
|
||||
|
||||
bridge = OcamlBridge()
|
||||
await bridge.start()
|
||||
html = await bridge.render('(div (p "hello"))')
|
||||
await bridge.stop()
|
||||
"""
|
||||
|
||||
from __future__ import annotations
|
||||
|
||||
import asyncio
|
||||
import logging
|
||||
import os
|
||||
from typing import Any
|
||||
|
||||
_logger = logging.getLogger("sx.ocaml")
|
||||
|
||||
# Default binary path — can be overridden via SX_OCAML_BIN env var
|
||||
_DEFAULT_BIN = os.path.join(
|
||||
os.path.dirname(__file__),
|
||||
"../../hosts/ocaml/_build/default/bin/sx_server.exe",
|
||||
)
|
||||
|
||||
|
||||
class OcamlBridgeError(Exception):
|
||||
"""Error from the OCaml SX kernel."""
|
||||
|
||||
|
||||
class OcamlBridge:
|
||||
"""Async bridge to a persistent OCaml SX subprocess."""
|
||||
|
||||
def __init__(self, binary: str | None = None):
|
||||
self._binary = binary or os.environ.get("SX_OCAML_BIN") or _DEFAULT_BIN
|
||||
self._proc: asyncio.subprocess.Process | None = None
|
||||
self._lock = asyncio.Lock()
|
||||
self._started = False
|
||||
self._components_loaded = False
|
||||
|
||||
async def start(self) -> None:
|
||||
"""Launch the OCaml subprocess and wait for (ready)."""
|
||||
if self._started:
|
||||
return
|
||||
|
||||
bin_path = os.path.abspath(self._binary)
|
||||
if not os.path.isfile(bin_path):
|
||||
raise FileNotFoundError(
|
||||
f"OCaml SX server binary not found: {bin_path}\n"
|
||||
f"Build with: cd hosts/ocaml && eval $(opam env) && dune build"
|
||||
)
|
||||
|
||||
_logger.info("Starting OCaml SX kernel: %s", bin_path)
|
||||
self._proc = await asyncio.create_subprocess_exec(
|
||||
bin_path,
|
||||
stdin=asyncio.subprocess.PIPE,
|
||||
stdout=asyncio.subprocess.PIPE,
|
||||
stderr=asyncio.subprocess.PIPE,
|
||||
)
|
||||
|
||||
# Wait for (ready)
|
||||
line = await self._readline()
|
||||
if line != "(ready)":
|
||||
raise OcamlBridgeError(f"Expected (ready), got: {line!r}")
|
||||
|
||||
self._started = True
|
||||
|
||||
# Verify engine identity
|
||||
self._send("(ping)")
|
||||
kind, engine = await self._read_response()
|
||||
engine_name = engine if kind == "ok" else "unknown"
|
||||
_logger.info("OCaml SX kernel ready (pid=%d, engine=%s)", self._proc.pid, engine_name)
|
||||
|
||||
async def stop(self) -> None:
|
||||
"""Terminate the subprocess."""
|
||||
if self._proc and self._proc.returncode is None:
|
||||
self._proc.stdin.close()
|
||||
try:
|
||||
await asyncio.wait_for(self._proc.wait(), timeout=5.0)
|
||||
except asyncio.TimeoutError:
|
||||
self._proc.kill()
|
||||
await self._proc.wait()
|
||||
_logger.info("OCaml SX kernel stopped")
|
||||
self._proc = None
|
||||
self._started = False
|
||||
|
||||
async def ping(self) -> str:
|
||||
"""Health check — returns engine name (e.g. 'ocaml-cek')."""
|
||||
async with self._lock:
|
||||
self._send("(ping)")
|
||||
kind, value = await self._read_response()
|
||||
return value or "" if kind == "ok" else ""
|
||||
|
||||
async def load(self, path: str) -> int:
|
||||
"""Load an .sx file for side effects (defcomp, define, defmacro)."""
|
||||
async with self._lock:
|
||||
self._send(f'(load "{_escape(path)}")')
|
||||
kind, value = await self._read_response()
|
||||
if kind == "error":
|
||||
raise OcamlBridgeError(f"load {path}: {value}")
|
||||
return int(float(value)) if value else 0
|
||||
|
||||
async def load_source(self, source: str) -> int:
|
||||
"""Evaluate SX source for side effects."""
|
||||
async with self._lock:
|
||||
self._send(f'(load-source "{_escape(source)}")')
|
||||
kind, value = await self._read_response()
|
||||
if kind == "error":
|
||||
raise OcamlBridgeError(f"load-source: {value}")
|
||||
return int(float(value)) if value else 0
|
||||
|
||||
async def eval(self, source: str) -> str:
|
||||
"""Evaluate SX expression, return serialized result."""
|
||||
async with self._lock:
|
||||
self._send(f'(eval "{_escape(source)}")')
|
||||
kind, value = await self._read_response()
|
||||
if kind == "error":
|
||||
raise OcamlBridgeError(f"eval: {value}")
|
||||
return value or ""
|
||||
|
||||
async def render(
|
||||
self,
|
||||
source: str,
|
||||
ctx: dict[str, Any] | None = None,
|
||||
) -> str:
|
||||
"""Render SX to HTML, handling io-requests via Python async IO."""
|
||||
await self._ensure_components()
|
||||
async with self._lock:
|
||||
self._send(f'(render "{_escape(source)}")')
|
||||
return await self._read_until_ok(ctx)
|
||||
|
||||
async def _ensure_components(self) -> None:
|
||||
"""Load component definitions into the kernel on first use."""
|
||||
if self._components_loaded:
|
||||
return
|
||||
self._components_loaded = True
|
||||
try:
|
||||
from .jinja_bridge import get_component_env, _CLIENT_LIBRARY_SOURCES
|
||||
from .parser import serialize
|
||||
from .types import Component, Island, Macro
|
||||
|
||||
env = get_component_env()
|
||||
parts: list[str] = list(_CLIENT_LIBRARY_SOURCES)
|
||||
for key, val in env.items():
|
||||
if isinstance(val, Island):
|
||||
ps = ["&key"] + list(val.params)
|
||||
if val.has_children:
|
||||
ps.extend(["&rest", "children"])
|
||||
parts.append(f"(defisland ~{val.name} ({' '.join(ps)}) {serialize(val.body)})")
|
||||
elif isinstance(val, Component):
|
||||
ps = ["&key"] + list(val.params)
|
||||
if val.has_children:
|
||||
ps.extend(["&rest", "children"])
|
||||
parts.append(f"(defcomp ~{val.name} ({' '.join(ps)}) {serialize(val.body)})")
|
||||
elif isinstance(val, Macro):
|
||||
ps = list(val.params)
|
||||
if val.rest_param:
|
||||
ps.extend(["&rest", val.rest_param])
|
||||
parts.append(f"(defmacro {val.name} ({' '.join(ps)}) {serialize(val.body)})")
|
||||
if parts:
|
||||
source = "\n".join(parts)
|
||||
await self.load_source(source)
|
||||
_logger.info("Loaded %d definitions into OCaml kernel", len(parts))
|
||||
except Exception as e:
|
||||
_logger.error("Failed to load components into OCaml kernel: %s", e)
|
||||
self._components_loaded = False # retry next time
|
||||
|
||||
async def reset(self) -> None:
|
||||
"""Reset the kernel environment to pristine state."""
|
||||
async with self._lock:
|
||||
self._send("(reset)")
|
||||
kind, value = await self._read_response()
|
||||
if kind == "error":
|
||||
raise OcamlBridgeError(f"reset: {value}")
|
||||
|
||||
# ------------------------------------------------------------------
|
||||
# Internal protocol handling
|
||||
# ------------------------------------------------------------------
|
||||
|
||||
def _send(self, line: str) -> None:
|
||||
"""Write a line to the subprocess stdin."""
|
||||
assert self._proc and self._proc.stdin
|
||||
self._proc.stdin.write((line + "\n").encode())
|
||||
|
||||
async def _readline(self) -> str:
|
||||
"""Read a line from the subprocess stdout."""
|
||||
assert self._proc and self._proc.stdout
|
||||
data = await self._proc.stdout.readline()
|
||||
if not data:
|
||||
# Process died — collect stderr for diagnostics
|
||||
stderr = b""
|
||||
if self._proc.stderr:
|
||||
stderr = await self._proc.stderr.read()
|
||||
raise OcamlBridgeError(
|
||||
f"OCaml subprocess died unexpectedly. stderr: {stderr.decode(errors='replace')}"
|
||||
)
|
||||
return data.decode().rstrip("\n")
|
||||
|
||||
async def _read_response(self) -> tuple[str, str | None]:
|
||||
"""Read a single (ok ...) or (error ...) response.
|
||||
|
||||
Returns (kind, value) where kind is "ok" or "error".
|
||||
"""
|
||||
line = await self._readline()
|
||||
return _parse_response(line)
|
||||
|
||||
async def _read_until_ok(
|
||||
self,
|
||||
ctx: dict[str, Any] | None = None,
|
||||
) -> str:
|
||||
"""Read lines until (ok ...) or (error ...).
|
||||
|
||||
Handles (io-request ...) by fulfilling IO and sending (io-response ...).
|
||||
"""
|
||||
while True:
|
||||
line = await self._readline()
|
||||
|
||||
if line.startswith("(io-request "):
|
||||
result = await self._handle_io_request(line, ctx)
|
||||
# Send response back to OCaml
|
||||
self._send(f"(io-response {_serialize_for_ocaml(result)})")
|
||||
continue
|
||||
|
||||
kind, value = _parse_response(line)
|
||||
if kind == "error":
|
||||
raise OcamlBridgeError(value or "Unknown error")
|
||||
# kind == "ok"
|
||||
return value or ""
|
||||
|
||||
async def _handle_io_request(
|
||||
self,
|
||||
line: str,
|
||||
ctx: dict[str, Any] | None,
|
||||
) -> Any:
|
||||
"""Dispatch an io-request to the appropriate Python handler."""
|
||||
from .parser import parse_all
|
||||
|
||||
# Parse the io-request
|
||||
parsed = parse_all(line)
|
||||
if not parsed or not isinstance(parsed[0], list):
|
||||
raise OcamlBridgeError(f"Malformed io-request: {line}")
|
||||
|
||||
parts = parsed[0]
|
||||
# parts = [Symbol("io-request"), name_str, ...args]
|
||||
if len(parts) < 2:
|
||||
raise OcamlBridgeError(f"Malformed io-request: {line}")
|
||||
|
||||
req_name = _to_str(parts[1])
|
||||
args = parts[2:]
|
||||
|
||||
if req_name == "query":
|
||||
return await self._io_query(args)
|
||||
elif req_name == "action":
|
||||
return await self._io_action(args)
|
||||
elif req_name == "request-arg":
|
||||
return self._io_request_arg(args)
|
||||
elif req_name == "request-method":
|
||||
return self._io_request_method()
|
||||
elif req_name == "ctx":
|
||||
return self._io_ctx(args, ctx)
|
||||
else:
|
||||
raise OcamlBridgeError(f"Unknown io-request type: {req_name}")
|
||||
|
||||
async def _io_query(self, args: list) -> Any:
|
||||
"""Handle (io-request "query" service name params...)."""
|
||||
from shared.infrastructure.internal import fetch_data
|
||||
|
||||
service = _to_str(args[0]) if len(args) > 0 else ""
|
||||
query = _to_str(args[1]) if len(args) > 1 else ""
|
||||
params = _to_dict(args[2]) if len(args) > 2 else {}
|
||||
return await fetch_data(service, query, params)
|
||||
|
||||
async def _io_action(self, args: list) -> Any:
|
||||
"""Handle (io-request "action" service name payload...)."""
|
||||
from shared.infrastructure.internal import call_action
|
||||
|
||||
service = _to_str(args[0]) if len(args) > 0 else ""
|
||||
action = _to_str(args[1]) if len(args) > 1 else ""
|
||||
payload = _to_dict(args[2]) if len(args) > 2 else {}
|
||||
return await call_action(service, action, payload)
|
||||
|
||||
def _io_request_arg(self, args: list) -> Any:
|
||||
"""Handle (io-request "request-arg" name)."""
|
||||
try:
|
||||
from quart import request
|
||||
name = _to_str(args[0]) if args else ""
|
||||
return request.args.get(name)
|
||||
except RuntimeError:
|
||||
return None
|
||||
|
||||
def _io_request_method(self) -> str:
|
||||
"""Handle (io-request "request-method")."""
|
||||
try:
|
||||
from quart import request
|
||||
return request.method
|
||||
except RuntimeError:
|
||||
return "GET"
|
||||
|
||||
def _io_ctx(self, args: list, ctx: dict[str, Any] | None) -> Any:
|
||||
"""Handle (io-request "ctx" key)."""
|
||||
if ctx is None:
|
||||
return None
|
||||
key = _to_str(args[0]) if args else ""
|
||||
return ctx.get(key)
|
||||
|
||||
|
||||
# ------------------------------------------------------------------
|
||||
# Module-level singleton
|
||||
# ------------------------------------------------------------------
|
||||
|
||||
_bridge: OcamlBridge | None = None
|
||||
|
||||
|
||||
async def get_bridge() -> OcamlBridge:
|
||||
"""Get or create the singleton bridge instance."""
|
||||
global _bridge
|
||||
if _bridge is None:
|
||||
_bridge = OcamlBridge()
|
||||
if not _bridge._started:
|
||||
await _bridge.start()
|
||||
return _bridge
|
||||
|
||||
|
||||
# ------------------------------------------------------------------
|
||||
# Helpers
|
||||
# ------------------------------------------------------------------
|
||||
|
||||
def _escape(s: str) -> str:
|
||||
"""Escape a string for embedding in an SX string literal."""
|
||||
return s.replace("\\", "\\\\").replace('"', '\\"').replace("\n", "\\n").replace("\r", "\\r").replace("\t", "\\t")
|
||||
|
||||
|
||||
def _parse_response(line: str) -> tuple[str, str | None]:
|
||||
"""Parse an (ok ...) or (error ...) response line.
|
||||
|
||||
Returns (kind, value) tuple.
|
||||
"""
|
||||
line = line.strip()
|
||||
if line == "(ok)":
|
||||
return ("ok", None)
|
||||
if line.startswith("(ok "):
|
||||
value = line[4:-1] # strip (ok and )
|
||||
# If the value is a quoted string, unquote it
|
||||
if value.startswith('"') and value.endswith('"'):
|
||||
value = _unescape(value[1:-1])
|
||||
return ("ok", value)
|
||||
if line.startswith("(error "):
|
||||
msg = line[7:-1]
|
||||
if msg.startswith('"') and msg.endswith('"'):
|
||||
msg = _unescape(msg[1:-1])
|
||||
return ("error", msg)
|
||||
return ("error", f"Unexpected response: {line}")
|
||||
|
||||
|
||||
def _unescape(s: str) -> str:
|
||||
"""Unescape an SX string literal."""
|
||||
return (
|
||||
s.replace("\\n", "\n")
|
||||
.replace("\\r", "\r")
|
||||
.replace("\\t", "\t")
|
||||
.replace('\\"', '"')
|
||||
.replace("\\\\", "\\")
|
||||
)
|
||||
|
||||
|
||||
def _to_str(val: Any) -> str:
|
||||
"""Convert an SX parsed value to a Python string."""
|
||||
if isinstance(val, str):
|
||||
return val
|
||||
if hasattr(val, "name"):
|
||||
return val.name
|
||||
return str(val)
|
||||
|
||||
|
||||
def _to_dict(val: Any) -> dict:
|
||||
"""Convert an SX parsed value to a Python dict."""
|
||||
if isinstance(val, dict):
|
||||
return val
|
||||
return {}
|
||||
|
||||
|
||||
def _serialize_for_ocaml(val: Any) -> str:
|
||||
"""Serialize a Python value to SX text for sending to OCaml."""
|
||||
if val is None:
|
||||
return "nil"
|
||||
if isinstance(val, bool):
|
||||
return "true" if val else "false"
|
||||
if isinstance(val, (int, float)):
|
||||
if isinstance(val, float) and val == int(val):
|
||||
return str(int(val))
|
||||
return str(val)
|
||||
if isinstance(val, str):
|
||||
return f'"{_escape(val)}"'
|
||||
if isinstance(val, (list, tuple)):
|
||||
items = " ".join(_serialize_for_ocaml(v) for v in val)
|
||||
return f"(list {items})"
|
||||
if isinstance(val, dict):
|
||||
pairs = " ".join(
|
||||
f":{k} {_serialize_for_ocaml(v)}" for k, v in val.items()
|
||||
)
|
||||
return "{" + pairs + "}"
|
||||
return f'"{_escape(str(val))}"'
|
||||
@@ -16,6 +16,7 @@
|
||||
(component-hash :as string?) (component-defs :as string?)
|
||||
(pages-sx :as string?) (page-sx :as string?)
|
||||
(asset-url :as string) (sx-js-hash :as string) (body-js-hash :as string?)
|
||||
(sx-js-file :as string?)
|
||||
(head-scripts :as list?) (inline-css :as string?) (inline-head-js :as string?)
|
||||
(init-sx :as string?) (body-scripts :as list?))
|
||||
(<>
|
||||
@@ -74,7 +75,7 @@ details.group{overflow:hidden}details.group>summary{list-style:none}details.grou
|
||||
(raw! (or pages-sx "")))
|
||||
(script :type "text/sx" :data-mount "body"
|
||||
(raw! (or page-sx "")))
|
||||
(script :src (str asset-url "/scripts/sx-browser.js?v=" sx-js-hash))
|
||||
(script :src (str asset-url "/scripts/" (or sx-js-file "sx-browser.js") "?v=" sx-js-hash))
|
||||
;; Body scripts — configurable per app
|
||||
;; Pass a list (even empty) to override defaults; nil = use defaults
|
||||
(if (not (nil? body-scripts))
|
||||
|
||||
220
shared/sx/tests/test_ocaml_bridge.py
Normal file
220
shared/sx/tests/test_ocaml_bridge.py
Normal file
@@ -0,0 +1,220 @@
|
||||
"""Tests for the OCaml SX bridge."""
|
||||
|
||||
import asyncio
|
||||
import os
|
||||
import sys
|
||||
import unittest
|
||||
|
||||
# Add project root to path
|
||||
_project_root = os.path.abspath(os.path.join(os.path.dirname(__file__), "../../.."))
|
||||
if _project_root not in sys.path:
|
||||
sys.path.insert(0, _project_root)
|
||||
|
||||
from shared.sx.ocaml_bridge import OcamlBridge, OcamlBridgeError, _escape, _parse_response, _serialize_for_ocaml
|
||||
|
||||
|
||||
class TestHelpers(unittest.TestCase):
|
||||
"""Test helper functions (no subprocess needed)."""
|
||||
|
||||
def test_escape_basic(self):
|
||||
self.assertEqual(_escape('hello'), 'hello')
|
||||
self.assertEqual(_escape('say "hi"'), 'say \\"hi\\"')
|
||||
self.assertEqual(_escape('a\\b'), 'a\\\\b')
|
||||
self.assertEqual(_escape('line\nbreak'), 'line\\nbreak')
|
||||
|
||||
def test_parse_response_ok_empty(self):
|
||||
self.assertEqual(_parse_response("(ok)"), ("ok", None))
|
||||
|
||||
def test_parse_response_ok_number(self):
|
||||
self.assertEqual(_parse_response("(ok 3)"), ("ok", "3"))
|
||||
|
||||
def test_parse_response_ok_string(self):
|
||||
kind, val = _parse_response('(ok "<div>hi</div>")')
|
||||
self.assertEqual(kind, "ok")
|
||||
self.assertEqual(val, "<div>hi</div>")
|
||||
|
||||
def test_parse_response_error(self):
|
||||
kind, val = _parse_response('(error "something broke")')
|
||||
self.assertEqual(kind, "error")
|
||||
self.assertEqual(val, "something broke")
|
||||
|
||||
def test_serialize_none(self):
|
||||
self.assertEqual(_serialize_for_ocaml(None), "nil")
|
||||
|
||||
def test_serialize_bool(self):
|
||||
self.assertEqual(_serialize_for_ocaml(True), "true")
|
||||
self.assertEqual(_serialize_for_ocaml(False), "false")
|
||||
|
||||
def test_serialize_number(self):
|
||||
self.assertEqual(_serialize_for_ocaml(42), "42")
|
||||
self.assertEqual(_serialize_for_ocaml(3.14), "3.14")
|
||||
|
||||
def test_serialize_string(self):
|
||||
self.assertEqual(_serialize_for_ocaml("hello"), '"hello"')
|
||||
self.assertEqual(_serialize_for_ocaml('say "hi"'), '"say \\"hi\\""')
|
||||
|
||||
def test_serialize_list(self):
|
||||
self.assertEqual(_serialize_for_ocaml([1, 2, 3]), "(list 1 2 3)")
|
||||
|
||||
def test_serialize_dict(self):
|
||||
result = _serialize_for_ocaml({"a": 1})
|
||||
self.assertEqual(result, "{:a 1}")
|
||||
|
||||
|
||||
class TestBridge(unittest.IsolatedAsyncioTestCase):
|
||||
"""Integration tests — require the OCaml binary to be built."""
|
||||
|
||||
@classmethod
|
||||
def setUpClass(cls):
|
||||
# Check if binary exists
|
||||
from shared.sx.ocaml_bridge import _DEFAULT_BIN
|
||||
bin_path = os.path.abspath(_DEFAULT_BIN)
|
||||
if not os.path.isfile(bin_path):
|
||||
raise unittest.SkipTest(
|
||||
f"OCaml binary not found at {bin_path}. "
|
||||
f"Build with: cd hosts/ocaml && eval $(opam env) && dune build"
|
||||
)
|
||||
|
||||
async def asyncSetUp(self):
|
||||
self.bridge = OcamlBridge()
|
||||
await self.bridge.start()
|
||||
|
||||
async def asyncTearDown(self):
|
||||
await self.bridge.stop()
|
||||
|
||||
async def test_ping(self):
|
||||
self.assertTrue(await self.bridge.ping())
|
||||
|
||||
async def test_eval_arithmetic(self):
|
||||
result = await self.bridge.eval("(+ 1 2)")
|
||||
self.assertEqual(result, "3")
|
||||
|
||||
async def test_eval_string(self):
|
||||
result = await self.bridge.eval('(str "hello" " " "world")')
|
||||
self.assertIn("hello world", result)
|
||||
|
||||
async def test_render_simple(self):
|
||||
html = await self.bridge.render('(div (p "hello"))')
|
||||
self.assertEqual(html, "<div><p>hello</p></div>")
|
||||
|
||||
async def test_render_attrs(self):
|
||||
html = await self.bridge.render('(div :class "card" (p "hi"))')
|
||||
self.assertIn('class="card"', html)
|
||||
self.assertIn("<p>hi</p>", html)
|
||||
|
||||
async def test_render_void_element(self):
|
||||
html = await self.bridge.render("(br)")
|
||||
self.assertEqual(html, "<br />")
|
||||
|
||||
async def test_load_source_defcomp(self):
|
||||
count = await self.bridge.load_source(
|
||||
'(defcomp ~test-card (&key title) (div :class "card" (h2 title)))'
|
||||
)
|
||||
self.assertEqual(count, 1)
|
||||
html = await self.bridge.render('(~test-card :title "Hello")')
|
||||
self.assertIn("Hello", html)
|
||||
self.assertIn("card", html)
|
||||
|
||||
async def test_reset(self):
|
||||
await self.bridge.load_source("(define x 42)")
|
||||
result = await self.bridge.eval("x")
|
||||
self.assertEqual(result, "42")
|
||||
await self.bridge.reset()
|
||||
with self.assertRaises(OcamlBridgeError):
|
||||
await self.bridge.eval("x")
|
||||
|
||||
async def test_render_conditional(self):
|
||||
html = await self.bridge.render('(if true (p "yes") (p "no"))')
|
||||
self.assertEqual(html, "<p>yes</p>")
|
||||
|
||||
async def test_render_let(self):
|
||||
html = await self.bridge.render('(let (x "hi") (p x))')
|
||||
self.assertEqual(html, "<p>hi</p>")
|
||||
|
||||
async def test_render_map(self):
|
||||
html = await self.bridge.render(
|
||||
"(map (lambda (x) (li x)) (list \"a\" \"b\" \"c\"))"
|
||||
)
|
||||
self.assertEqual(html, "<li>a</li><li>b</li><li>c</li>")
|
||||
|
||||
async def test_render_fragment(self):
|
||||
html = await self.bridge.render('(<> (p "a") (p "b"))')
|
||||
self.assertEqual(html, "<p>a</p><p>b</p>")
|
||||
|
||||
async def test_eval_error(self):
|
||||
with self.assertRaises(OcamlBridgeError):
|
||||
await self.bridge.eval("(undefined-symbol-xyz)")
|
||||
|
||||
async def test_render_component_with_children(self):
|
||||
await self.bridge.load_source(
|
||||
'(defcomp ~wrapper (&rest children) (div :class "wrap" children))'
|
||||
)
|
||||
html = await self.bridge.render('(~wrapper (p "inside"))')
|
||||
self.assertIn("wrap", html)
|
||||
self.assertIn("<p>inside</p>", html)
|
||||
|
||||
async def test_render_macro(self):
|
||||
await self.bridge.load_source(
|
||||
"(defmacro unless (cond &rest body) (list 'if (list 'not cond) (cons 'do body)))"
|
||||
)
|
||||
html = await self.bridge.render('(unless false (p "shown"))')
|
||||
self.assertEqual(html, "<p>shown</p>")
|
||||
|
||||
# ------------------------------------------------------------------
|
||||
# ListRef regression tests — the `list` primitive returns ListRef
|
||||
# (mutable), not List (immutable). Macro expansions that construct
|
||||
# AST via `list` produce ListRef nodes. The renderer must handle
|
||||
# both List and ListRef at every structural match point.
|
||||
# ------------------------------------------------------------------
|
||||
|
||||
async def test_render_macro_generates_cond(self):
|
||||
"""Macro that programmatically builds a (cond ...) with list."""
|
||||
await self.bridge.load_source(
|
||||
"(defmacro pick (x) "
|
||||
" (list 'cond "
|
||||
" (list (list '= x 1) '(p \"one\")) "
|
||||
" (list (list '= x 2) '(p \"two\")) "
|
||||
" (list ':else '(p \"other\"))))"
|
||||
)
|
||||
html = await self.bridge.render("(pick 2)")
|
||||
self.assertEqual(html, "<p>two</p>")
|
||||
|
||||
async def test_render_macro_generates_let(self):
|
||||
"""Macro that programmatically builds a (let ...) with list."""
|
||||
await self.bridge.load_source(
|
||||
"(defmacro with-greeting (name &rest body) "
|
||||
" (list 'let (list (list 'greeting (list 'str \"Hello \" name))) "
|
||||
" (cons 'do body)))"
|
||||
)
|
||||
html = await self.bridge.render('(with-greeting "World" (p greeting))')
|
||||
self.assertEqual(html, "<p>Hello World</p>")
|
||||
|
||||
async def test_render_macro_nested_html_tags(self):
|
||||
"""Macro expansion containing nested HTML tags via list."""
|
||||
await self.bridge.load_source(
|
||||
"(defmacro card (title &rest body) "
|
||||
" (list 'div ':class \"card\" "
|
||||
" (list 'h2 title) "
|
||||
" (cons 'do body)))"
|
||||
)
|
||||
html = await self.bridge.render('(card "Title" (p "content"))')
|
||||
self.assertIn('<div class="card">', html)
|
||||
self.assertIn("<h2>Title</h2>", html)
|
||||
self.assertIn("<p>content</p>", html)
|
||||
|
||||
async def test_render_eval_returns_listref(self):
|
||||
"""Values created at runtime via (list ...) are ListRef."""
|
||||
await self.bridge.load_source(
|
||||
"(define make-items (lambda () (list "
|
||||
' (list "a") (list "b") (list "c"))))'
|
||||
)
|
||||
html = await self.bridge.render(
|
||||
"(ul (map (lambda (x) (li (first x))) (make-items)))"
|
||||
)
|
||||
self.assertIn("<li>a</li>", html)
|
||||
self.assertIn("<li>b</li>", html)
|
||||
self.assertIn("<li>c</li>", html)
|
||||
|
||||
|
||||
if __name__ == "__main__":
|
||||
unittest.main()
|
||||
@@ -1,5 +1,16 @@
|
||||
# syntax=docker/dockerfile:1
|
||||
|
||||
# --- Stage 1: Build OCaml SX kernel ---
|
||||
FROM ocaml/opam:debian-12-ocaml-5.2 AS ocaml-build
|
||||
USER opam
|
||||
WORKDIR /home/opam/sx
|
||||
COPY --chown=opam:opam hosts/ocaml/dune-project ./
|
||||
COPY --chown=opam:opam hosts/ocaml/lib/ ./lib/
|
||||
COPY --chown=opam:opam hosts/ocaml/bin/dune hosts/ocaml/bin/run_tests.ml \
|
||||
hosts/ocaml/bin/debug_set.ml hosts/ocaml/bin/sx_server.ml ./bin/
|
||||
RUN eval $(opam env) && dune build bin/sx_server.exe
|
||||
|
||||
# --- Stage 2: Python app ---
|
||||
FROM python:3.11-slim AS base
|
||||
|
||||
ENV PYTHONDONTWRITEBYTECODE=1 \
|
||||
@@ -49,6 +60,9 @@ COPY likes/models/ ./likes/models/
|
||||
COPY orders/__init__.py ./orders/__init__.py
|
||||
COPY orders/models/ ./orders/models/
|
||||
|
||||
# OCaml SX kernel binary
|
||||
COPY --from=ocaml-build /home/opam/sx/_build/default/bin/sx_server.exe /app/bin/sx_server
|
||||
|
||||
COPY sx/entrypoint.sh /usr/local/bin/entrypoint.sh
|
||||
RUN chmod +x /usr/local/bin/entrypoint.sh
|
||||
|
||||
|
||||
15
sx/app.py
15
sx/app.py
@@ -148,6 +148,21 @@ def create_app() -> "Quart":
|
||||
target = path + "/" + ("?" + qs if qs else "")
|
||||
return redirect(target, 301)
|
||||
|
||||
@app.get("/sx/_engine")
|
||||
async def sx_engine_info():
|
||||
"""Diagnostic: which SX engine is active."""
|
||||
import os, json
|
||||
info = {"engine": "python-ref", "ocaml": False}
|
||||
if os.environ.get("SX_USE_OCAML") == "1":
|
||||
try:
|
||||
from shared.sx.ocaml_bridge import get_bridge
|
||||
bridge = await get_bridge()
|
||||
engine = await bridge.ping()
|
||||
info = {"engine": engine, "ocaml": True, "pid": bridge._proc.pid}
|
||||
except Exception as e:
|
||||
info = {"engine": "ocaml-error", "ocaml": False, "error": str(e)}
|
||||
return json.dumps(info), 200, {"Content-Type": "application/json"}
|
||||
|
||||
@app.get("/sx/")
|
||||
async def sx_home():
|
||||
"""SX docs home page."""
|
||||
|
||||
@@ -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.")
|
||||
|
||||
;; -----------------------------------------------------------------------
|
||||
|
||||
Reference in New Issue
Block a user