coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

WASM browser build: interned env keys, async kernel boot, bundled .sx platform

Browse Source 
- Symbol interning in sx_types.ml: env lookups use int keys (intern/unintern)
  to avoid repeated string hashing in scope chain walks
- sx-platform.js: poll for SxKernel availability (WASM init is async)
- shell.sx: load sx_browser.bc.wasm.js when SX_USE_WASM=1
- bundle.sh: fix .sx file paths (web-signals.sx rename)
- browser/dune: target byte+js+wasm modes
- Bundle 23 .sx platform files for browser (dom, signals, router, boot, etc.)

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-03-26 16:37:42 +00:00
parent 589507392c
commit 10576f86d1
25 changed files with 4808 additions and 68 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
hosts/ocaml/bin/integration_tests.ml
View File

@@ -315,7 +315,7 @@ let make_integration_env () =
let body_env = { bindings = Hashtbl.create 16; parent = Some e } in
List.iteri (fun i p ->
let v = if i < List.length macro_args then List.nth macro_args i else Nil in
Hashtbl.replace body_env.bindings p v
Hashtbl.replace body_env.bindings (Sx_types.intern p) v
) m.m_params;
Sx_ref.eval_expr m.m_body (Env body_env)
| _ -> raise (Eval_error "expand-macro: expected (macro args env)"));

14
hosts/ocaml/bin/mcp_tree.ml
View File

@@ -709,6 +709,7 @@ let rec handle_tool name args =
let selector = args |> member "selector" |> to_string_option in
let expr = args |> member "expr" |> to_string_option in
let actions = args |> member "actions" |> to_string_option in
let island = args |> member "island" |> to_string_option in
(* Determine whether to run specs or the inspector *)
let use_inspector = match mode with
| Some m when m <> "run" -> true
@@ -745,6 +746,7 @@ let rec handle_tool name args =
(match selector with Some s -> Some ("selector", `String s) | None -> None);
(match expr with Some e -> Some ("expr", `String e) | None -> None);
(match actions with Some a -> Some ("actions", `String a) | None -> None);
(match island with Some i -> Some ("island", `String i) | None -> None);
]) in
let args_json = Yojson.Safe.to_string (Yojson.Safe.from_string (Yojson.Basic.to_string inspector_args)) in
let cmd = Printf.sprintf "cd %s && node tests/playwright/sx-inspect.js '%s' 2>&1" project_dir (String.escaped args_json) in
@@ -1154,14 +1156,15 @@ let rec handle_tool name args =
let bindings = ref [] in
(* Walk env chain collecting all bindings *)
let rec collect_bindings env acc =
Hashtbl.iter (fun k v ->
if not (Hashtbl.mem acc k) then Hashtbl.replace acc k v
Hashtbl.iter (fun id v ->
if not (Hashtbl.mem acc id) then Hashtbl.replace acc id v
) env.bindings;
match env.parent with Some p -> collect_bindings p acc | None -> ()
in
let all = Hashtbl.create 256 in
collect_bindings e all;
Hashtbl.iter (fun k v ->
Hashtbl.iter (fun id v ->
let k = Sx_types.unintern id in
let kind = match v with
| NativeFn _ -> "native"
| Lambda _ -> "lambda"
@@ -1351,10 +1354,11 @@ let tool_definitions = `List [
("files", `Assoc [("type", `String "array"); ("items", `Assoc [("type", `String "string")]); ("description", `String "Multiple .sx files to load in order")]);
("setup", `Assoc [("type", `String "string"); ("description", `String "SX setup expression to run before main evaluation")])]
["expr"];
tool "sx_playwright" "Run Playwright browser tests or inspect SX pages interactively. Modes: run (spec files), inspect (page report), diff (SSR vs hydrated), eval (JS expression), interact (action sequence), screenshot."
tool "sx_playwright" "Run Playwright browser tests or inspect SX pages interactively. Modes: run (spec files), inspect (page/island report with leak detection and handler audit), diff (full SSR vs hydrated DOM), hydrate (lake-focused SSR vs hydrated comparison — detects clobbering), eval (JS expression), interact (action sequence), screenshot."
[("spec", `Assoc [("type", `String "string"); ("description", `String "Spec file to run (run mode). e.g. stepper.spec.js")]);
("mode", `Assoc [("type", `String "string"); ("description", `String "Mode: run, inspect, diff, eval, interact, screenshot")]);
("mode", `Assoc [("type", `String "string"); ("description", `String "Mode: run, inspect, diff, hydrate, eval, interact, screenshot")]);
("url", `Assoc [("type", `String "string"); ("description", `String "URL path to navigate to (default: /)")]);
("island", `Assoc [("type", `String "string"); ("description", `String "Filter inspect to a specific island by name (e.g. home/stepper)")]);
("selector", `Assoc [("type", `String "string"); ("description", `String "CSS selector to focus on (screenshot mode)")]);
("expr", `Assoc [("type", `String "string"); ("description", `String "JS expression to evaluate (eval mode)")]);
("actions", `Assoc [("type", `String "string"); ("description", `String "Semicolon-separated action sequence (interact mode). Actions: click:sel, fill:sel:val, wait:ms, text:sel, html:sel, attrs:sel, screenshot, screenshot:sel, count:sel, visible:sel")])]

39
hosts/ocaml/bin/sx_server.ml
View File

@@ -407,7 +407,7 @@ let setup_evaluator_bridge env =
let body_env = { bindings = Hashtbl.create 16; parent = Some e } in
List.iteri (fun i p ->
let v = if i < List.length macro_args then List.nth macro_args i else Nil in
Hashtbl.replace body_env.bindings p v
Hashtbl.replace body_env.bindings (Sx_types.intern p) v
) m.m_params;
Sx_ref.eval_expr m.m_body (Env body_env)
| _ -> raise (Eval_error "expand-macro: expected (macro args env)"));
@@ -629,6 +629,12 @@ let setup_html_tags env =
(* Compose environment *)
(* ====================================================================== *)
(** Convert int-keyed env.bindings to string-keyed Hashtbl for VM globals *)
let env_to_vm_globals env =
let g = Hashtbl.create (Hashtbl.length env.Sx_types.bindings) in
Hashtbl.iter (fun id v -> Hashtbl.replace g (Sx_types.unintern id) v) env.Sx_types.bindings;
g
let make_server_env () =
let env = make_env () in
Sx_render.setup_render_env env;
@@ -703,7 +709,7 @@ let register_jit_hook env =
else begin
_jit_compiling := true;
let t0 = Unix.gettimeofday () in
let compiled = Sx_vm.jit_compile_lambda l env.bindings in
let compiled = Sx_vm.jit_compile_lambda l (env_to_vm_globals env) in
let dt = Unix.gettimeofday () -. t0 in
_jit_compiling := false;
Printf.eprintf "[jit] %s compile %s in %.3fs\n%!"
@@ -726,7 +732,7 @@ let register_jit_hook env =
evaluator.sx defines *custom-special-forms* and register-special-form!
which shadow the native bindings from setup_evaluator_bridge. *)
let rebind_host_extensions env =
Hashtbl.replace env.bindings "register-special-form!"
Hashtbl.replace env.bindings (Sx_types.intern "register-special-form!")
(NativeFn ("register-special-form!", fun args ->
match args with
| [String name; handler] ->
@@ -814,7 +820,7 @@ let rec dispatch env cmd =
| List [Symbol "vm-reset-fn"; String name] ->
(* Reset a function's JIT-compiled bytecode, forcing CEK interpretation.
Used to work around JIT compilation bugs in specific functions. *)
(match Hashtbl.find_opt env.bindings name with
(match Hashtbl.find_opt env.bindings (Sx_types.intern name) with
| Some (Lambda l) ->
l.l_compiled <- Some Sx_vm.jit_failed_sentinel;
Printf.eprintf "[jit] reset %s (forced CEK)\n%!" name;
@@ -889,10 +895,10 @@ let rec dispatch env cmd =
"current-offset"; "patch-i16";
] in
List.iter (fun name ->
match Hashtbl.find_opt env.bindings name with
match Hashtbl.find_opt env.bindings (Sx_types.intern name) with
| Some (Lambda l) when l.l_compiled = None ->
l.l_compiled <- Some Sx_vm.jit_failed_sentinel;
(match Sx_vm.jit_compile_lambda l env.bindings with
(match Sx_vm.jit_compile_lambda l (env_to_vm_globals env) with
| Some cl -> l.l_compiled <- Some cl; incr count
| None -> ())
| _ -> ()
@@ -937,7 +943,7 @@ let rec dispatch env cmd =
in
let t1 = Unix.gettimeofday () in
io_batch_mode := false;
Hashtbl.remove env.bindings "expand-components?";
Hashtbl.remove env.bindings (Sx_types.intern "expand-components?");
let result_str = match result with
| String s | SxExpr s -> s
| _ -> serialize_value result
@@ -953,12 +959,12 @@ let rec dispatch env cmd =
| Eval_error msg ->
io_batch_mode := false;
io_queue := [];
Hashtbl.remove env.bindings "expand-components?";
Hashtbl.remove env.bindings (Sx_types.intern "expand-components?");
send_error msg
| exn ->
io_batch_mode := false;
io_queue := [];
Hashtbl.remove env.bindings "expand-components?";
Hashtbl.remove env.bindings (Sx_types.intern "expand-components?");
send_error (Printexc.to_string exn))
| List (Symbol "sx-page-full-blob" :: shell_kwargs) ->
@@ -991,7 +997,7 @@ let rec dispatch env cmd =
in
let t1 = Unix.gettimeofday () in
io_batch_mode := false;
Hashtbl.remove env.bindings "expand-components?";
Hashtbl.remove env.bindings (Sx_types.intern "expand-components?");
let body_str = match body_result with
| String s | SxExpr s -> s
| _ -> serialize_value body_result
@@ -1038,12 +1044,12 @@ let rec dispatch env cmd =
| Eval_error msg ->
io_batch_mode := false;
io_queue := [];
Hashtbl.remove env.bindings "expand-components?";
Hashtbl.remove env.bindings (Sx_types.intern "expand-components?");
send_error msg
| exn ->
io_batch_mode := false;
io_queue := [];
Hashtbl.remove env.bindings "expand-components?";
Hashtbl.remove env.bindings (Sx_types.intern "expand-components?");
send_error (Printexc.to_string exn))
| List [Symbol "render"; String src] ->
@@ -1065,8 +1071,7 @@ let rec dispatch env cmd =
code_val is a dict with {bytecode, pool} from compiler.sx *)
(try
let code = Sx_vm.code_from_value code_val in
let globals = Hashtbl.create 256 in
Hashtbl.iter (fun k v -> Hashtbl.replace globals k v) env.bindings;
let globals = env_to_vm_globals env in
let result = Sx_vm.execute_module code globals in
send_ok_value result
with
@@ -1081,8 +1086,10 @@ let rec dispatch env cmd =
(try
let code = Sx_vm.code_from_value code_val in
(* VM uses the LIVE kernel env — defines go directly into it *)
let _result = Sx_vm.execute_module code env.bindings in
(* Count how many defines the module added *)
let globals = env_to_vm_globals env in
let _result = Sx_vm.execute_module code globals in
(* Copy defines back into env *)
Hashtbl.iter (fun k v -> Hashtbl.replace env.bindings (Sx_types.intern k) v) globals;
send_ok ()
with
| Eval_error msg -> send_error msg

30
hosts/ocaml/browser/bundle.sh
View File

@@ -27,29 +27,29 @@ cp "$BUILD/sx_browser.bc.js" "$DIST/"
cp sx-platform.js "$DIST/"
# 3. Spec modules
cp "$ROOT/spec/signals.sx" "$DIST/sx/core-signals.sx"
cp "$ROOT/spec/render.sx" "$DIST/sx/"
cp "$ROOT/web/signals.sx" "$DIST/sx/"
cp "$ROOT/web/deps.sx" "$DIST/sx/"
cp "$ROOT/web/router.sx" "$DIST/sx/"
cp "$ROOT/web/page-helpers.sx" "$DIST/sx/"
cp "$ROOT/spec/signals.sx" "$DIST/sx/core-signals.sx"
cp "$ROOT/spec/render.sx" "$DIST/sx/"
cp "$ROOT/web/web-signals.sx" "$DIST/sx/signals.sx"
cp "$ROOT/web/deps.sx" "$DIST/sx/"
cp "$ROOT/web/router.sx" "$DIST/sx/"
cp "$ROOT/web/page-helpers.sx" "$DIST/sx/"
# 3b. Freeze scope (signal persistence)
cp "$ROOT/lib/freeze.sx" "$DIST/sx/"
cp "$ROOT/lib/freeze.sx" "$DIST/sx/"
# 4. Bytecode compiler + VM
cp "$ROOT/lib/bytecode.sx" "$DIST/sx/"
cp "$ROOT/lib/compiler.sx" "$DIST/sx/"
cp "$ROOT/lib/vm.sx" "$DIST/sx/"
cp "$ROOT/lib/bytecode.sx" "$DIST/sx/"
cp "$ROOT/lib/compiler.sx" "$DIST/sx/"
cp "$ROOT/lib/vm.sx" "$DIST/sx/"
# 5. Web libraries (8 FFI primitives)
cp "$ROOT/web/lib/dom.sx" "$DIST/sx/"
cp "$ROOT/web/lib/browser.sx" "$DIST/sx/"
cp "$ROOT/web/lib/dom.sx" "$DIST/sx/"
cp "$ROOT/web/lib/browser.sx" "$DIST/sx/"
# 6. Web adapters
cp "$ROOT/web/adapter-html.sx" "$DIST/sx/"
cp "$ROOT/web/adapter-sx.sx" "$DIST/sx/"
cp "$ROOT/web/adapter-dom.sx" "$DIST/sx/"
cp "$ROOT/web/adapter-html.sx" "$DIST/sx/"
cp "$ROOT/web/adapter-sx.sx" "$DIST/sx/"
cp "$ROOT/web/adapter-dom.sx" "$DIST/sx/"
# 7. Boot helpers (platform functions in pure SX)
cp "$ROOT/web/lib/boot-helpers.sx" "$DIST/sx/"

5
hosts/ocaml/browser/dune Normal file
View File

@@ -0,0 +1,5 @@
(executable
(name sx_browser)
(libraries sx js_of_ocaml)
(modes byte js wasm)
(preprocess (pps js_of_ocaml-ppx)))

76
hosts/ocaml/lib/sx_types.ml
View File

@@ -4,12 +4,38 @@
OCaml's algebraic types make the CEK machine's frame dispatch a
pattern match — exactly what the spec describes. *)
(** {1 Symbol interning} *)
(** Map symbol names to small integers for O(1) env lookups.
The intern table is populated once per unique symbol name;
all subsequent env operations use the integer key. *)
let sym_to_id : (string, int) Hashtbl.t = Hashtbl.create 512
let id_to_sym : (int, string) Hashtbl.t = Hashtbl.create 512
let sym_next = ref 0
let intern s =
match Hashtbl.find_opt sym_to_id s with
| Some id -> id
| None ->
let id = !sym_next in
incr sym_next;
Hashtbl.replace sym_to_id s id;
Hashtbl.replace id_to_sym id s;
id
let unintern id =
match Hashtbl.find_opt id_to_sym id with
| Some s -> s
| None -> "<sym:" ^ string_of_int id ^ ">"
(** {1 Environment} *)
(** Lexical scope chain. Each frame holds a mutable binding table and
an optional parent link for scope-chain lookup. *)
(** Lexical scope chain. Each frame holds a mutable binding table
keyed by interned symbol IDs for fast lookup. *)
type env = {
bindings : (string, value) Hashtbl.t;
bindings : (int, value) Hashtbl.t;
parent : env option;
}
@@ -160,36 +186,40 @@ let env_extend parent =
{ bindings = Hashtbl.create 16; parent = Some parent }
let env_bind env name v =
Hashtbl.replace env.bindings name v; Nil
Hashtbl.replace env.bindings (intern 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
(* Internal: scope-chain lookup with pre-interned ID *)
let rec env_has_id env id =
Hashtbl.mem env.bindings id ||
match env.parent with Some p -> env_has_id p id | None -> false
let rec env_get env name =
match Hashtbl.find_opt env.bindings name with
let env_has env name = env_has_id env (intern name)
let rec env_get_id env id name =
match Hashtbl.find_opt env.bindings id with
| Some v -> v
| None ->
match env.parent with
| Some p -> env_get p name
| None -> raise (Eval_error ("Undefined symbol: " ^ name))
| Some p -> env_get_id p id 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)
let env_get env name = env_get_id env (intern name) name
let rec env_set_id env id v =
if Hashtbl.mem env.bindings id then
(Hashtbl.replace env.bindings id v; Nil)
else
match env.parent with
| Some p -> env_set p name v
| None -> Hashtbl.replace env.bindings name v; Nil
| Some p -> env_set_id p id v
| None -> Hashtbl.replace env.bindings id v; Nil
let env_set env name v = env_set_id env (intern name) v
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
@@ -198,11 +228,9 @@ let env_merge base overlay =
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
Hashtbl.iter (fun id v ->
if not (env_has_id base id) then Hashtbl.replace e.bindings id v
) overlay.bindings;
e
end

10
hosts/ocaml/lib/sx_vm.ml
View File

@@ -242,8 +242,9 @@ and run vm =
let name = match consts.(idx) with String s -> s | _ -> "" in
let v = try Hashtbl.find vm.globals name with Not_found ->
(* Walk the closure env chain for inner functions *)
let id = Sx_types.intern name in
let rec env_lookup e =
try Hashtbl.find e.bindings name
try Hashtbl.find e.bindings id
with Not_found ->
match e.parent with Some p -> env_lookup p | None ->
try Sx_primitives.get_primitive name
@@ -262,9 +263,10 @@ and run vm =
(* Write to closure env if the name exists there (mutable closure vars) *)
let written = match frame.closure.vm_closure_env with
| Some env ->
let id = Sx_types.intern name in
let rec find_env e =
if Hashtbl.mem e.bindings name then
(Hashtbl.replace e.bindings name (peek vm); true)
if Hashtbl.mem e.bindings id then
(Hashtbl.replace e.bindings id (peek vm); true)
else match e.parent with Some p -> find_env p | None -> false
in find_env env
| None -> false
@@ -556,7 +558,7 @@ let jit_compile_lambda (l : lambda) globals =
Use a shallow copy so we don't pollute the real globals. *)
let merged = Hashtbl.copy globals in
let rec inject env =
Hashtbl.iter (fun k v -> Hashtbl.replace merged k v) env.bindings;
Hashtbl.iter (fun id v -> Hashtbl.replace merged (Sx_types.unintern id) v) env.bindings;
match env.parent with Some p -> inject p | None -> ()
in
inject closure;

21
shared/static/wasm/sx-platform.js
View File

@@ -16,8 +16,7 @@
(function() {
"use strict";
var K = globalThis.SxKernel;
if (!K) { console.error("[sx-platform] SxKernel not found"); return; }
function boot(K) {
// ================================================================
// 8 FFI Host Primitives
@@ -234,6 +233,7 @@
var files = [
// Spec modules
"sx/render.sx",
"sx/core-signals.sx",
"sx/signals.sx",
"sx/deps.sx",
"sx/router.sx",
@@ -253,6 +253,11 @@
"sx/adapter-dom.sx",
// Boot helpers (platform functions in pure SX)
"sx/boot-helpers.sx",
"sx/hypersx.sx",
// Test harness (for inline test runners)
"sx/harness.sx",
"sx/harness-reactive.sx",
"sx/harness-web.sx",
// Web framework
"sx/engine.sx",
"sx/orchestration.sx",
@@ -343,4 +348,16 @@
}
}
} // end boot
// SxKernel is available synchronously (js_of_ocaml) or after async
// WASM init. Poll briefly to handle both cases.
var K = globalThis.SxKernel;
if (K) { boot(K); return; }
var tries = 0;
var poll = setInterval(function() {
K = globalThis.SxKernel;
if (K) { clearInterval(poll); boot(K); }
else if (++tries > 100) { clearInterval(poll); console.error("[sx-platform] SxKernel not found after 5s"); }
}, 50);
})();

25
shared/static/wasm/sx/adapter-html.sx Normal file
View File

@@ -0,0 +1,25 @@
(define render-to-html :effects (render) (fn (expr (env :as dict)) (set-render-active! true) (case (type-of expr) "nil" "" "string" (escape-html expr) "number" (str expr) "boolean" (if expr "true" "false") "list" (if (empty? expr) "" (render-list-to-html expr env)) "symbol" (render-value-to-html (trampoline (eval-expr expr env)) env) "keyword" (escape-html (keyword-name expr)) "raw-html" (raw-html-content expr) "spread" (do (scope-emit! "element-attrs" (spread-attrs expr)) "") "thunk" (render-to-html (thunk-expr expr) (thunk-env expr)) :else (render-value-to-html (trampoline (eval-expr expr env)) env))))
(define render-value-to-html :effects (render) (fn (val (env :as dict)) (case (type-of val) "nil" "" "string" (escape-html val) "number" (str val) "boolean" (if val "true" "false") "list" (render-list-to-html val env) "raw-html" (raw-html-content val) "spread" (do (scope-emit! "element-attrs" (spread-attrs val)) "") "thunk" (render-to-html (thunk-expr val) (thunk-env val)) :else (escape-html (str val)))))
(define RENDER_HTML_FORMS (list "if" "when" "cond" "case" "let" "let*" "letrec" "begin" "do" "define" "defcomp" "defisland" "defmacro" "defstyle" "deftype" "defeffect" "map" "map-indexed" "filter" "for-each" "scope" "provide"))
(define render-html-form? :effects () (fn ((name :as string)) (contains? RENDER_HTML_FORMS name)))
(define render-list-to-html :effects (render) (fn ((expr :as list) (env :as dict)) (if (empty? expr) "" (let ((head (first expr))) (if (not (= (type-of head) "symbol")) (join "" (map (fn (x) (render-value-to-html x env)) expr)) (let ((name (symbol-name head)) (args (rest expr))) (cond (= name "<>") (join "" (map (fn (x) (render-to-html x env)) args)) (= name "raw!") (join "" (map (fn (x) (str (trampoline (eval-expr x env)))) args)) (= name "lake") (render-html-lake args env) (= name "marsh") (render-html-marsh args env) (or (= name "portal") (= name "error-boundary") (= name "promise-delayed")) (join "" (map (fn (x) (render-to-html x env)) args)) (contains? HTML_TAGS name) (render-html-element name args env) (and (starts-with? name "~") (env-has? env name) (island? (env-get env name))) (render-html-island (env-get env name) args env) (starts-with? name "~") (let ((val (env-get env name))) (cond (component? val) (render-html-component val args env) (macro? val) (render-to-html (expand-macro val args env) env) :else (error (str "Unknown component: " name)))) (render-html-form? name) (dispatch-html-form name expr env) (and (env-has? env name) (macro? (env-get env name))) (render-to-html (expand-macro (env-get env name) args env) env) :else (render-value-to-html (trampoline (eval-expr expr env)) env))))))))
(define dispatch-html-form :effects (render) (fn ((name :as string) (expr :as list) (env :as dict)) (cond (= name "if") (let ((cond-val (trampoline (eval-expr (nth expr 1) env)))) (if cond-val (render-to-html (nth expr 2) env) (if (> (len expr) 3) (render-to-html (nth expr 3) env) ""))) (= name "when") (if (not (trampoline (eval-expr (nth expr 1) env))) "" (if (= (len expr) 3) (render-to-html (nth expr 2) env) (join "" (map (fn (i) (render-to-html (nth expr i) env)) (range 2 (len expr)))))) (= name "cond") (let ((branch (eval-cond (rest expr) env))) (if branch (render-to-html branch env) "")) (= name "case") (render-to-html (trampoline (eval-expr expr env)) env) (= name "letrec") (let ((bindings (nth expr 1)) (body (slice expr 2)) (local (env-extend env))) (for-each (fn (pair) (let ((pname (if (= (type-of (first pair)) "symbol") (symbol-name (first pair)) (str (first pair))))) (env-bind! local pname nil))) bindings) (for-each (fn (pair) (let ((pname (if (= (type-of (first pair)) "symbol") (symbol-name (first pair)) (str (first pair))))) (env-set! local pname (trampoline (eval-expr (nth pair 1) local))))) bindings) (when (> (len body) 1) (for-each (fn (e) (trampoline (eval-expr e local))) (init body))) (render-to-html (last body) local)) (or (= name "let") (= name "let*")) (let ((local (process-bindings (nth expr 1) env))) (if (= (len expr) 3) (render-to-html (nth expr 2) local) (join "" (map (fn (i) (render-to-html (nth expr i) local)) (range 2 (len expr)))))) (or (= name "begin") (= name "do")) (if (= (len expr) 2) (render-to-html (nth expr 1) env) (join "" (map (fn (i) (render-to-html (nth expr i) env)) (range 1 (len expr))))) (definition-form? name) (do (trampoline (eval-expr expr env)) "") (= name "map") (let ((f (trampoline (eval-expr (nth expr 1) env))) (coll (trampoline (eval-expr (nth expr 2) env)))) (join "" (map (fn (item) (if (lambda? f) (render-lambda-html f (list item) env) (render-to-html (apply f (list item)) env))) coll))) (= name "map-indexed") (let ((f (trampoline (eval-expr (nth expr 1) env))) (coll (trampoline (eval-expr (nth expr 2) env)))) (join "" (map-indexed (fn (i item) (if (lambda? f) (render-lambda-html f (list i item) env) (render-to-html (apply f (list i item)) env))) coll))) (= name "filter") (render-to-html (trampoline (eval-expr expr env)) env) (= name "for-each") (let ((f (trampoline (eval-expr (nth expr 1) env))) (coll (trampoline (eval-expr (nth expr 2) env)))) (join "" (map (fn (item) (if (lambda? f) (render-lambda-html f (list item) env) (render-to-html (apply f (list item)) env))) coll))) (= name "scope") (let ((scope-name (trampoline (eval-expr (nth expr 1) env))) (rest-args (slice expr 2)) (scope-val nil) (body-exprs nil)) (if (and (>= (len rest-args) 2) (= (type-of (first rest-args)) "keyword") (= (keyword-name (first rest-args)) "value")) (do (set! scope-val (trampoline (eval-expr (nth rest-args 1) env))) (set! body-exprs (slice rest-args 2))) (set! body-exprs rest-args)) (scope-push! scope-name scope-val) (let ((result (if (= (len body-exprs) 1) (render-to-html (first body-exprs) env) (join "" (map (fn (e) (render-to-html e env)) body-exprs))))) (scope-pop! scope-name) result)) (= name "provide") (let ((prov-name (trampoline (eval-expr (nth expr 1) env))) (prov-val (trampoline (eval-expr (nth expr 2) env))) (body-start 3) (body-count (- (len expr) 3))) (scope-push! prov-name prov-val) (let ((result (if (= body-count 1) (render-to-html (nth expr body-start) env) (join "" (map (fn (i) (render-to-html (nth expr i) env)) (range body-start (+ body-start body-count))))))) (scope-pop! prov-name) result)) :else (render-value-to-html (trampoline (eval-expr expr env)) env))))
(define render-lambda-html :effects (render) (fn ((f :as lambda) (args :as list) (env :as dict)) (let ((local (env-merge (lambda-closure f) env))) (for-each-indexed (fn (i p) (env-bind! local p (nth args i))) (lambda-params f)) (render-to-html (lambda-body f) local))))
(define render-html-component :effects (render) (fn ((comp :as component) (args :as list) (env :as dict)) (let ((kwargs (dict)) (children (list))) (reduce (fn (state arg) (let ((skip (get state "skip"))) (if skip (assoc state "skip" false "i" (inc (get state "i"))) (if (and (= (type-of arg) "keyword") (< (inc (get state "i")) (len args))) (let ((val (trampoline (eval-expr (nth args (inc (get state "i"))) env)))) (dict-set! kwargs (keyword-name arg) val) (assoc state "skip" true "i" (inc (get state "i")))) (do (append! children arg) (assoc state "i" (inc (get state "i")))))))) (dict "i" 0 "skip" false) args) (let ((local (env-merge (component-closure comp) env))) (for-each (fn (p) (env-bind! local p (if (dict-has? kwargs p) (dict-get kwargs p) nil))) (component-params comp)) (when (component-has-children? comp) (env-bind! local "children" (make-raw-html (join "" (map (fn (c) (render-to-html c env)) children))))) (render-to-html (component-body comp) local)))))
(define render-html-element :effects (render) (fn ((tag :as string) (args :as list) (env :as dict)) (let ((parsed (parse-element-args args env)) (attrs (first parsed)) (children (nth parsed 1)) (is-void (contains? VOID_ELEMENTS tag))) (if is-void (str "<" tag (render-attrs attrs) " />") (do (scope-push! "element-attrs" nil) (let ((content (join "" (map (fn (c) (render-to-html c env)) children)))) (for-each (fn (spread-dict) (merge-spread-attrs attrs spread-dict)) (scope-emitted "element-attrs")) (scope-pop! "element-attrs") (str "<" tag (render-attrs attrs) ">" content "</" tag ">")))))))
(define render-html-lake :effects (render) (fn ((args :as list) (env :as dict)) (let ((lake-id nil) (lake-tag "div") (children (list))) (reduce (fn (state arg) (let ((skip (get state "skip"))) (if skip (assoc state "skip" false "i" (inc (get state "i"))) (if (and (= (type-of arg) "keyword") (< (inc (get state "i")) (len args))) (let ((kname (keyword-name arg)) (kval (trampoline (eval-expr (nth args (inc (get state "i"))) env)))) (cond (= kname "id") (set! lake-id kval) (= kname "tag") (set! lake-tag kval)) (assoc state "skip" true "i" (inc (get state "i")))) (do (append! children arg) (assoc state "i" (inc (get state "i")))))))) (dict "i" 0 "skip" false) args) (let ((lake-attrs (dict "data-sx-lake" (or lake-id "")))) (scope-push! "element-attrs" nil) (let ((content (join "" (map (fn (c) (render-to-html c env)) children)))) (for-each (fn (spread-dict) (merge-spread-attrs lake-attrs spread-dict)) (scope-emitted "element-attrs")) (scope-pop! "element-attrs") (str "<" lake-tag (render-attrs lake-attrs) ">" content "</" lake-tag ">"))))))
(define render-html-marsh :effects (render) (fn ((args :as list) (env :as dict)) (let ((marsh-id nil) (marsh-tag "div") (children (list))) (reduce (fn (state arg) (let ((skip (get state "skip"))) (if skip (assoc state "skip" false "i" (inc (get state "i"))) (if (and (= (type-of arg) "keyword") (< (inc (get state "i")) (len args))) (let ((kname (keyword-name arg)) (kval (trampoline (eval-expr (nth args (inc (get state "i"))) env)))) (cond (= kname "id") (set! marsh-id kval) (= kname "tag") (set! marsh-tag kval) (= kname "transform") nil) (assoc state "skip" true "i" (inc (get state "i")))) (do (append! children arg) (assoc state "i" (inc (get state "i")))))))) (dict "i" 0 "skip" false) args) (let ((marsh-attrs (dict "data-sx-marsh" (or marsh-id "")))) (scope-push! "element-attrs" nil) (let ((content (join "" (map (fn (c) (render-to-html c env)) children)))) (for-each (fn (spread-dict) (merge-spread-attrs marsh-attrs spread-dict)) (scope-emitted "element-attrs")) (scope-pop! "element-attrs") (str "<" marsh-tag (render-attrs marsh-attrs) ">" content "</" marsh-tag ">"))))))
(define render-html-island :effects (render) (fn ((island :as island) (args :as list) (env :as dict)) (let ((kwargs (dict)) (children (list))) (reduce (fn (state arg) (let ((skip (get state "skip"))) (if skip (assoc state "skip" false "i" (inc (get state "i"))) (if (and (= (type-of arg) "keyword") (< (inc (get state "i")) (len args))) (let ((val (trampoline (eval-expr (nth args (inc (get state "i"))) env)))) (dict-set! kwargs (keyword-name arg) val) (assoc state "skip" true "i" (inc (get state "i")))) (do (append! children arg) (assoc state "i" (inc (get state "i")))))))) (dict "i" 0 "skip" false) args) (let ((local (env-merge (component-closure island) env)) (island-name (component-name island))) (for-each (fn (p) (env-bind! local p (if (dict-has? kwargs p) (dict-get kwargs p) nil))) (component-params island)) (when (component-has-children? island) (env-bind! local "children" (make-raw-html (join "" (map (fn (c) (render-to-html c env)) children))))) (let ((body-html (cek-try (fn () (render-to-html (component-body island) local)) (fn (err) ""))) (state-sx (serialize-island-state kwargs))) (str "<span data-sx-island=\"" (escape-attr island-name) "\"" (if state-sx (str " data-sx-state=\"" (escape-attr state-sx) "\"") "") ">" body-html "</span>"))))))
(define serialize-island-state :effects () (fn ((kwargs :as dict)) (if (empty-dict? kwargs) nil (sx-serialize kwargs))))

583
shared/static/wasm/sx/adapter-sx.sx Normal file
View File

@@ -0,0 +1,583 @@
;; ==========================================================================
;; adapter-sx.sx — SX wire format rendering adapter
;;
;; Serializes SX expressions for client-side rendering.
;; Component calls are NOT expanded — they're sent to the client as-is.
;; HTML tags are serialized as SX source text. Special forms are evaluated.
;;
;; Depends on:
;; render.sx — HTML_TAGS
;; eval.sx — eval-expr, trampoline, call-lambda, expand-macro
;; ==========================================================================
(define render-to-sx :effects [render]
(fn (expr (env :as dict))
(let ((result (aser expr env)))
;; aser-call returns SxExpr which serialize passes through unquoted.
;; Plain strings from data need serialization (quoting).
(cond
(= (type-of result) "sx-expr") (sx-expr-source result)
(= (type-of result) "string") result
:else (serialize result)))))
(define aser :effects [render]
(fn ((expr :as any) (env :as dict))
;; Evaluate for SX wire format — serialize rendering forms,
;; evaluate control flow and function calls.
(set-render-active! true)
(let ((result
(case (type-of expr)
"number" expr
"string" expr
"boolean" expr
"nil" nil
"symbol"
(let ((name (symbol-name expr)))
(cond
(env-has? env name) (env-get env name)
(primitive? name) (get-primitive name)
(= name "true") true
(= name "false") false
(= name "nil") nil
:else (error (str "Undefined symbol: " name))))
"keyword" (keyword-name expr)
"list"
(if (empty? expr)
(list)
(aser-list expr env))
;; Spread — emit attrs to nearest element provider
"spread" (do (scope-emit! "element-attrs" (spread-attrs expr)) nil)
:else expr)))
;; Catch spread values from function calls and symbol lookups
(if (spread? result)
(do (scope-emit! "element-attrs" (spread-attrs result)) nil)
result))))
(define aser-list :effects [render]
(fn ((expr :as list) (env :as dict))
(let ((head (first expr))
(args (rest expr)))
(if (not (= (type-of head) "symbol"))
(map (fn (x) (aser x env)) expr)
(let ((name (symbol-name head)))
(cond
;; Fragment — serialize children
(= name "<>")
(aser-fragment args env)
;; raw! — pass through as serialized call
(= name "raw!")
(aser-call "raw!" args env)
;; Component call — expand if server-affinity or expand-components? is set.
;; expand-components? is a platform primitive (like eval-expr, trampoline);
;; adapter-async.sx uses the same pattern at line 684.
;; Guard with env-has? for backward compat with older kernels.
(starts-with? name "~")
(let ((comp (if (env-has? env name) (env-get env name) nil))
(expand-all (if (env-has? env "expand-components?")
(expand-components?) false)))
(cond
(and comp (macro? comp))
(aser (expand-macro comp args env) env)
(and comp (component? comp)
(not (island? comp))
(or expand-all
(= (component-affinity comp) "server"))
;; :affinity :client components are never expanded
;; server-side — they depend on browser-only state.
(not (= (component-affinity comp) "client")))
(aser-expand-component comp args env)
:else
(aser-call name args env)))
;; Lake — serialize (server-morphable slot)
(= name "lake")
(aser-call name args env)
;; Marsh — serialize (reactive server-morphable slot)
(= name "marsh")
(aser-call name args env)
;; HTML tag — serialize
(contains? HTML_TAGS name)
(aser-call name args env)
;; Special/HO forms — evaluate (produces data)
(or (special-form? name) (ho-form? name))
(aser-special name expr env)
;; Macro — expand then aser
(and (env-has? env name) (macro? (env-get env name)))
(aser (expand-macro (env-get env name) args env) env)
;; Function call — evaluate fully
:else
(let ((f (trampoline (eval-expr head env)))
(evaled-args (map (fn (a) (trampoline (eval-expr a env))) args)))
(cond
(and (callable? f) (not (lambda? f)) (not (component? f)) (not (island? f)))
(apply f evaled-args)
(lambda? f)
(trampoline (call-lambda f evaled-args env))
(component? f)
(aser-call (str "~" (component-name f)) args env)
(island? f)
(aser-call (str "~" (component-name f)) args env)
:else (error (str "Not callable: " (inspect f)))))))))))
;; Re-serialize an evaluated HTML element list, restoring keyword syntax.
;; The CEK evaluates keywords to strings, so (tr :class "row") becomes
;; (list Symbol("tr") String("class") String("row")). This function
;; detects string pairs where the first string is an HTML attribute name
;; and restores them as :keyword syntax for the SX wire format.
(define aser-reserialize :effects []
(fn (val)
(if (not (= (type-of val) "list"))
(serialize val)
(if (empty? val)
"()"
(let ((head (first val)))
(if (not (= (type-of head) "symbol"))
(serialize val)
(let ((tag (symbol-name head))
(parts (list tag))
(args (rest val))
(skip false)
(i 0))
(for-each
(fn (arg)
(if skip
(do (set! skip false) (set! i (inc i)))
(if (and (= (type-of arg) "string")
(< (inc i) (len args))
;; Heuristic: if the next arg is also a string or a list,
;; and this arg looks like an attribute name (no spaces,
;; starts with lowercase or is a known attr pattern)
(not (contains? arg " "))
(or (starts-with? arg "class")
(starts-with? arg "id")
(starts-with? arg "sx-")
(starts-with? arg "data-")
(starts-with? arg "style")
(starts-with? arg "href")
(starts-with? arg "src")
(starts-with? arg "type")
(starts-with? arg "name")
(starts-with? arg "value")
(starts-with? arg "placeholder")
(starts-with? arg "action")
(starts-with? arg "method")
(starts-with? arg "target")
(starts-with? arg "role")
(starts-with? arg "for")
(starts-with? arg "on")))
(do
(append! parts (str ":" arg))
(append! parts (serialize (nth args (inc i))))
(set! skip true)
(set! i (inc i)))
(do
(append! parts (aser-reserialize arg))
(set! i (inc i))))))
args)
(str "(" (join " " parts) ")"))))))))
(define aser-fragment :effects [render]
(fn ((children :as list) (env :as dict))
;; Serialize (<> child1 child2 ...) to sx source string
;; Must flatten list results (e.g. from map/filter) to avoid nested parens
(let ((parts (list)))
(for-each
(fn (c)
(let ((result (aser c env)))
(cond
(nil? result) nil
(= (type-of result) "sx-expr")
(append! parts (sx-expr-source result))
;; list results (from map etc.)
(= (type-of result) "list")
(for-each
(fn (item)
(when (not (nil? item))
(if (= (type-of item) "sx-expr")
(append! parts (sx-expr-source item))
(append! parts (aser-reserialize item)))))
result)
;; Everything else — serialize normally (quotes strings)
:else
(append! parts (serialize result)))))
children)
(if (empty? parts)
""
(if (= (len parts) 1)
(make-sx-expr (first parts))
(make-sx-expr (str "(<> " (join " " parts) ")")))))))
(define aser-call :effects [render]
(fn ((name :as string) (args :as list) (env :as dict))
;; Serialize (name :key val child ...) — evaluate args but keep as sx
;; Uses for-each + mutable state (not reduce) so bootstrapper emits for-loops
;; that can contain nested for-each for list flattening.
;; Separate attrs and children so emitted spread attrs go before children.
(let ((attr-parts (list))
(child-parts (list))
(skip false)
(i 0))
;; Provide scope for spread emit!
(scope-push! "element-attrs" nil)
(for-each
(fn (arg)
(if skip
(do (set! skip false)
(set! i (inc i)))
(if (and (= (type-of arg) "keyword")
(< (inc i) (len args)))
(let ((val (aser (nth args (inc i)) env)))
(when (not (nil? val))
(append! attr-parts (str ":" (keyword-name arg)))
(if (= (type-of val) "sx-expr")
(append! attr-parts (sx-expr-source val))
(append! attr-parts (serialize val))))
(set! skip true)
(set! i (inc i)))
(let ((val (aser arg env)))
(when (not (nil? val))
(cond
(= (type-of val) "sx-expr")
(append! child-parts (sx-expr-source val))
;; List results (from map etc.)
(= (type-of val) "list")
(for-each
(fn (item)
(when (not (nil? item))
(if (= (type-of item) "sx-expr")
(append! child-parts (sx-expr-source item))
(append! child-parts (serialize item)))))
val)
;; Plain values — serialize normally
:else
(append! child-parts (serialize val))))
(set! i (inc i))))))
args)
;; Collect emitted spread attrs — goes after explicit attrs, before children
(for-each
(fn (spread-dict)
(for-each
(fn (k)
(let ((v (dict-get spread-dict k)))
(append! attr-parts (str ":" k))
(append! attr-parts (serialize v))))
(keys spread-dict)))
(scope-peek "element-attrs"))
(scope-pop! "element-attrs")
(let ((parts (concat (list name) attr-parts child-parts)))
(make-sx-expr (str "(" (join " " parts) ")"))))))
;; --------------------------------------------------------------------------
;; Server-affinity component expansion
;; --------------------------------------------------------------------------
;;
;; When a component has :affinity :server, the aser expands it inline:
;; bind keyword args + children, then aser the body.
;; This is the aser equivalent of render-to-html's component expansion.
(define aser-expand-component :effects [render]
(fn ((comp :as any) (args :as list) (env :as dict))
(let ((params (component-params comp))
(local (env-merge env (component-closure comp)))
(i 0)
(skip false)
(children (list)))
;; Default all keyword params to nil (same as the CEK evaluator)
(for-each (fn (p) (env-bind! local p nil)) params)
;; Parse keyword args and positional children from args.
;; Keyword values are ASERED (not eval'd) — they may contain
;; rendering constructs (<>, HTML tags) that eval-expr can't
;; handle. The aser result is a string/value that the body's
;; aser will inline correctly (strings starting with "(" are
;; recognized as serialized SX by aserCall).
(for-each
(fn (arg)
(if skip
(do (set! skip false) (set! i (inc i)))
(if (and (= (type-of arg) "keyword")
(< (inc i) (len args)))
;; Keyword arg: bind name = aser'd next arg
;; SxExpr values pass through serialize unquoted automatically
(do
(env-bind! local (keyword-name arg)
(aser (nth args (inc i)) env))
(set! skip true)
(set! i (inc i)))
;; Positional child: keep as unevaluated AST for aser
(do
(append! children arg)
(set! i (inc i))))))
args)
;; Bind &rest children — aser each child first, then bind the result
(when (component-has-children comp)
(let ((asered-children
(map (fn (c) (aser c env)) children)))
(env-bind! local "children"
(if (= (len asered-children) 1)
(first asered-children)
asered-children))))
;; Aser the body in the merged env
(aser (component-body comp) local))))
;; --------------------------------------------------------------------------
;; Form classification
;; --------------------------------------------------------------------------
(define SPECIAL_FORM_NAMES
(list "if" "when" "cond" "case" "and" "or"
"let" "let*" "lambda" "fn"
"define" "defcomp" "defmacro" "defstyle"
"defhandler" "defpage" "defquery" "defaction" "defrelation"
"begin" "do" "quote" "quasiquote"
"->" "set!" "letrec" "dynamic-wind" "defisland"
"deftype" "defeffect" "scope" "provide"
"context" "emit!" "emitted"))
(define HO_FORM_NAMES
(list "map" "map-indexed" "filter" "reduce"
"some" "every?" "for-each"))
(define special-form? :effects []
(fn ((name :as string))
(contains? SPECIAL_FORM_NAMES name)))
(define ho-form? :effects []
(fn ((name :as string))
(contains? HO_FORM_NAMES name)))
;; --------------------------------------------------------------------------
;; aser-special — evaluate special/HO forms in aser mode
;; --------------------------------------------------------------------------
;;
;; Control flow forms evaluate conditions normally but render branches
;; through aser (serializing tags/components instead of rendering HTML).
;; Definition forms evaluate for side effects and return nil.
(define aser-special :effects [render]
(fn ((name :as string) (expr :as list) (env :as dict))
(let ((args (rest expr)))
(cond
;; if — evaluate condition, aser chosen branch
(= name "if")
(if (trampoline (eval-expr (first args) env))
(aser (nth args 1) env)
(if (> (len args) 2)
(aser (nth args 2) env)
nil))
;; when — evaluate condition, aser body if true
(= name "when")
(if (not (trampoline (eval-expr (first args) env)))
nil
(let ((result nil))
(for-each (fn (body) (set! result (aser body env)))
(rest args))
result))
;; cond — evaluate conditions, aser matching branch
(= name "cond")
(let ((branch (eval-cond args env)))
(if branch (aser branch env) nil))
;; case — evaluate match value, check each pair
(= name "case")
(let ((match-val (trampoline (eval-expr (first args) env)))
(clauses (rest args)))
(eval-case-aser match-val clauses env))
;; let / let*
(or (= name "let") (= name "let*"))
(let ((local (process-bindings (first args) env))
(result nil))
(for-each (fn (body) (set! result (aser body local)))
(rest args))
result)
;; begin / do
(or (= name "begin") (= name "do"))
(let ((result nil))
(for-each (fn (body) (set! result (aser body env))) args)
result)
;; and — short-circuit
(= name "and")
(let ((result true))
(some (fn (arg)
(set! result (trampoline (eval-expr arg env)))
(not result))
args)
result)
;; or — short-circuit
(= name "or")
(let ((result false))
(some (fn (arg)
(set! result (trampoline (eval-expr arg env)))
result)
args)
result)
;; map — evaluate function and collection, map through aser
(= name "map")
(let ((f (trampoline (eval-expr (first args) env)))
(coll (trampoline (eval-expr (nth args 1) env))))
(map (fn (item)
(if (lambda? f)
(let ((local (env-merge (lambda-closure f) env)))
(env-bind! local (first (lambda-params f)) item)
(aser (lambda-body f) local))
(cek-call f (list item))))
coll))
;; map-indexed
(= name "map-indexed")
(let ((f (trampoline (eval-expr (first args) env)))
(coll (trampoline (eval-expr (nth args 1) env))))
(map-indexed (fn (i item)
(if (lambda? f)
(let ((local (env-merge (lambda-closure f) env)))
(env-bind! local (first (lambda-params f)) i)
(env-bind! local (nth (lambda-params f) 1) item)
(aser (lambda-body f) local))
(cek-call f (list i item))))
coll))
;; for-each — evaluate for side effects, aser each body
(= name "for-each")
(let ((f (trampoline (eval-expr (first args) env)))
(coll (trampoline (eval-expr (nth args 1) env)))
(results (list)))
(for-each (fn (item)
(if (lambda? f)
(let ((local (env-merge (lambda-closure f) env)))
(env-bind! local (first (lambda-params f)) item)
(append! results (aser (lambda-body f) local)))
(cek-call f (list item))))
coll)
(if (empty? results) nil results))
;; defisland — evaluate AND serialize (client needs the definition)
(= name "defisland")
(do (trampoline (eval-expr expr env))
(serialize expr))
;; Definition forms — evaluate for side effects
(or (= name "define") (= name "defcomp") (= name "defmacro")
(= name "defstyle") (= name "defhandler") (= name "defpage")
(= name "defquery") (= name "defaction") (= name "defrelation")
(= name "deftype") (= name "defeffect"))
(do (trampoline (eval-expr expr env)) nil)
;; scope — unified render-time dynamic scope
(= name "scope")
(let ((scope-name (trampoline (eval-expr (first args) env)))
(rest-args (rest args))
(scope-val nil)
(body-args nil))
;; Check for :value keyword
(if (and (>= (len rest-args) 2)
(= (type-of (first rest-args)) "keyword")
(= (keyword-name (first rest-args)) "value"))
(do (set! scope-val (trampoline (eval-expr (nth rest-args 1) env)))
(set! body-args (slice rest-args 2)))
(set! body-args rest-args))
(scope-push! scope-name scope-val)
(let ((result nil))
(for-each (fn (body) (set! result (aser body env)))
body-args)
(scope-pop! scope-name)
result))
;; provide — sugar for scope with value
(= name "provide")
(let ((prov-name (trampoline (eval-expr (first args) env)))
(prov-val (trampoline (eval-expr (nth args 1) env)))
(result nil))
(scope-push! prov-name prov-val)
(for-each (fn (body) (set! result (aser body env)))
(slice args 2))
(scope-pop! prov-name)
result)
;; context — scope lookup (uses hashtable stack, not CEK kont)
(= name "context")
(let ((ctx-name (trampoline (eval-expr (first args) env)))
(default-val (if (>= (len args) 2)
(trampoline (eval-expr (nth args 1) env))
nil)))
(let ((val (scope-peek ctx-name)))
(if (nil? val) default-val val)))
;; emit! — scope accumulator
(= name "emit!")
(let ((emit-name (trampoline (eval-expr (first args) env)))
(emit-val (trampoline (eval-expr (nth args 1) env))))
(scope-emit! emit-name emit-val)
nil)
;; emitted — collect accumulated scope values
(= name "emitted")
(let ((emit-name (trampoline (eval-expr (first args) env))))
(or (scope-peek emit-name) (list)))
;; Everything else — evaluate normally
:else
(trampoline (eval-expr expr env))))))
;; Helper: case dispatch for aser mode
(define eval-case-aser :effects [render]
(fn (match-val (clauses :as list) (env :as dict))
(if (< (len clauses) 2)
nil
(let ((test (first clauses))
(body (nth clauses 1)))
(if (or (and (= (type-of test) "keyword") (= (keyword-name test) "else"))
(and (= (type-of test) "symbol")
(or (= (symbol-name test) ":else")
(= (symbol-name test) "else"))))
(aser body env)
(if (= match-val (trampoline (eval-expr test env)))
(aser body env)
(eval-case-aser match-val (slice clauses 2) env)))))))
;; --------------------------------------------------------------------------
;; Platform interface — SX wire adapter
;; --------------------------------------------------------------------------
;;
;; From eval.sx:
;; eval-expr, trampoline, call-lambda, expand-macro
;; env-has?, env-get, env-set!, env-merge, callable?, lambda?, component?,
;; macro?, island?, primitive?, get-primitive, component-name
;; lambda-closure, lambda-params, lambda-body
;;
;; From render.sx:
;; HTML_TAGS, eval-cond, process-bindings
;;
;; From parser.sx:
;; serialize (= sx-serialize)
;;
;; From signals.sx (optional):
;; invoke
;; --------------------------------------------------------------------------

163
shared/static/wasm/sx/bytecode.sx Normal file
View File

@@ -0,0 +1,163 @@
;; ==========================================================================
;; bytecode.sx — SX bytecode format definition
;;
;; Universal bytecode for SX evaluation. Produced by compiler.sx,
;; executed by platform-native VMs (OCaml, JS, WASM).
;;
;; Design principles:
;; - One byte per opcode (~65 ops, fits in u8)
;; - Variable-length encoding (1-5 bytes per instruction)
;; - Lexical scope resolved at compile time (no hash lookups)
;; - Tail calls detected statically (no thunks/trampoline)
;; - Control flow via jumps (no continuation frames for if/when/etc.)
;; - Content-addressable (deterministic binary for CID)
;; ==========================================================================
;; --------------------------------------------------------------------------
;; Opcode constants
;; --------------------------------------------------------------------------
;; Stack / Constants
(define OP_CONST 1) ;; u16 pool_idx — push constant
(define OP_NIL 2) ;; push nil
(define OP_TRUE 3) ;; push true
(define OP_FALSE 4) ;; push false
(define OP_POP 5) ;; discard TOS
(define OP_DUP 6) ;; duplicate TOS
;; Variable access (resolved at compile time)
(define OP_LOCAL_GET 16) ;; u8 slot
(define OP_LOCAL_SET 17) ;; u8 slot
(define OP_UPVALUE_GET 18) ;; u8 idx
(define OP_UPVALUE_SET 19) ;; u8 idx
(define OP_GLOBAL_GET 20) ;; u16 name_idx
(define OP_GLOBAL_SET 21) ;; u16 name_idx
;; Control flow (replaces if/when/cond/and/or frames)
(define OP_JUMP 32) ;; i16 offset
(define OP_JUMP_IF_FALSE 33) ;; i16 offset
(define OP_JUMP_IF_TRUE 34) ;; i16 offset
;; Function operations
(define OP_CALL 48) ;; u8 argc
(define OP_TAIL_CALL 49) ;; u8 argc — reuse frame (TCO)
(define OP_RETURN 50) ;; return TOS
(define OP_CLOSURE 51) ;; u16 code_idx — create closure
(define OP_CALL_PRIM 52) ;; u16 name_idx, u8 argc — direct primitive
(define OP_APPLY 53) ;; (apply f args-list)
;; Collection construction
(define OP_LIST 64) ;; u16 count — build list from stack
(define OP_DICT 65) ;; u16 count — build dict from stack pairs
(define OP_APPEND_BANG 66) ;; (append! TOS-1 TOS)
;; Higher-order forms (inlined loop)
(define OP_ITER_INIT 80) ;; init iterator on TOS list
(define OP_ITER_NEXT 81) ;; i16 end_offset — push next or jump
(define OP_MAP_OPEN 82) ;; push empty accumulator
(define OP_MAP_APPEND 83) ;; append TOS to accumulator
(define OP_MAP_CLOSE 84) ;; pop accumulator as list
(define OP_FILTER_TEST 85) ;; i16 skip — if falsy jump (skip append)
;; HO fallback (dynamic callback)
(define OP_HO_MAP 88) ;; (map fn coll)
(define OP_HO_FILTER 89) ;; (filter fn coll)
(define OP_HO_REDUCE 90) ;; (reduce fn init coll)
(define OP_HO_FOR_EACH 91) ;; (for-each fn coll)
(define OP_HO_SOME 92) ;; (some fn coll)
(define OP_HO_EVERY 93) ;; (every? fn coll)
;; Scope / dynamic binding
(define OP_SCOPE_PUSH 96) ;; TOS = name
(define OP_SCOPE_POP 97)
(define OP_PROVIDE_PUSH 98) ;; TOS-1 = name, TOS = value
(define OP_PROVIDE_POP 99)
(define OP_CONTEXT 100) ;; TOS = name → push value
(define OP_EMIT 101) ;; TOS-1 = name, TOS = value
(define OP_EMITTED 102) ;; TOS = name → push collected
;; Continuations
(define OP_RESET 112) ;; i16 body_len — push delimiter
(define OP_SHIFT 113) ;; u8 k_slot, i16 body_len — capture k
;; Define / component
(define OP_DEFINE 128) ;; u16 name_idx — bind TOS to name
(define OP_DEFCOMP 129) ;; u16 template_idx
(define OP_DEFISLAND 130) ;; u16 template_idx
(define OP_DEFMACRO 131) ;; u16 template_idx
(define OP_EXPAND_MACRO 132) ;; u8 argc — runtime macro expansion
;; String / serialize (hot path)
(define OP_STR_CONCAT 144) ;; u8 count — concat N values as strings
(define OP_STR_JOIN 145) ;; (join sep list)
(define OP_SERIALIZE 146) ;; serialize TOS to SX string
;; Inline primitives (hot path — no hashtable lookup)
(define OP_ADD 160) ;; TOS-1 + TOS → push
(define OP_SUB 161) ;; TOS-1 - TOS → push
(define OP_MUL 162) ;; TOS-1 * TOS → push
(define OP_DIV 163) ;; TOS-1 / TOS → push
(define OP_EQ 164) ;; TOS-1 = TOS → push bool
(define OP_LT 165) ;; TOS-1 < TOS → push bool
(define OP_GT 166) ;; TOS-1 > TOS → push bool
(define OP_NOT 167) ;; !TOS → push bool
(define OP_LEN 168) ;; len(TOS) → push number
(define OP_FIRST 169) ;; first(TOS) → push
(define OP_REST 170) ;; rest(TOS) → push list
(define OP_NTH 171) ;; nth(TOS-1, TOS) → push
(define OP_CONS 172) ;; cons(TOS-1, TOS) → push list
(define OP_NEG 173) ;; negate TOS → push number
(define OP_INC 174) ;; TOS + 1 → push
(define OP_DEC 175) ;; TOS - 1 → push
;; Aser specialization (optional, 224-239 reserved)
(define OP_ASER_TAG 224) ;; u16 tag_name_idx — serialize HTML tag
(define OP_ASER_FRAG 225) ;; u8 child_count — serialize fragment
;; --------------------------------------------------------------------------
;; Bytecode module structure
;; --------------------------------------------------------------------------
;; A module contains:
;; magic: "SXBC" (4 bytes)
;; version: u16
;; pool_count: u32
;; pool: constant pool entries (self-describing tagged values)
;; code_count: u32
;; codes: code objects
;; entry: u32 (index of entry-point code object)
(define BYTECODE_MAGIC "SXBC")
(define BYTECODE_VERSION 1)
;; Constant pool tags
(define CONST_NUMBER 1)
(define CONST_STRING 2)
(define CONST_BOOL 3)
(define CONST_NIL 4)
(define CONST_SYMBOL 5)
(define CONST_KEYWORD 6)
(define CONST_LIST 7)
(define CONST_DICT 8)
(define CONST_CODE 9)
;; --------------------------------------------------------------------------
;; Disassembler
;; --------------------------------------------------------------------------
(define opcode-name
(fn (op)
(cond
(= op 1) "CONST" (= op 2) "NIL"
(= op 3) "TRUE" (= op 4) "FALSE"
(= op 5) "POP" (= op 6) "DUP"
(= op 16) "LOCAL_GET" (= op 17) "LOCAL_SET"
(= op 20) "GLOBAL_GET" (= op 21) "GLOBAL_SET"
(= op 32) "JUMP" (= op 33) "JUMP_IF_FALSE"
(= op 48) "CALL" (= op 49) "TAIL_CALL"
(= op 50) "RETURN" (= op 52) "CALL_PRIM"
(= op 128) "DEFINE" (= op 144) "STR_CONCAT"
:else (str "OP_" op))))

826
shared/static/wasm/sx/compiler.sx Normal file
View File

@@ -0,0 +1,826 @@
;; ==========================================================================
;; compiler.sx — SX bytecode compiler
;;
;; Compiles SX AST to bytecode for the platform-native VM.
;; Written in SX — runs on any platform with an SX evaluator.
;;
;; Architecture:
;; Pass 1: Scope analysis — resolve variables, detect tail positions
;; Pass 2: Code generation — emit bytecode
;;
;; The compiler produces Code objects (bytecode + constant pool).
;; The VM executes them with a stack machine model.
;; ==========================================================================
;; --------------------------------------------------------------------------
;; Constant pool builder
;; --------------------------------------------------------------------------
(define make-pool
(fn ()
{:entries (if (primitive? "mutable-list") (mutable-list) (list))
:index {:_count 0}}))
(define pool-add
(fn (pool value)
"Add a value to the constant pool, return its index. Deduplicates."
(let ((key (serialize value))
(idx-map (get pool "index")))
(if (has-key? idx-map key)
(get idx-map key)
(let ((idx (get idx-map "_count")))
(dict-set! idx-map key idx)
(dict-set! idx-map "_count" (+ idx 1))
(append! (get pool "entries") value)
idx)))))
;; --------------------------------------------------------------------------
;; Scope analysis
;; --------------------------------------------------------------------------
(define make-scope
(fn (parent)
{:locals (list) ;; list of {name, slot, mutable?}
:upvalues (list) ;; list of {name, is-local, index}
:parent parent
:is-function false ;; true for fn/lambda scopes (create frames)
:next-slot 0}))
(define scope-define-local
(fn (scope name)
"Add a local variable, return its slot index.
Idempotent: if name already has a slot, return it."
(let ((existing (first (filter (fn (l) (= (get l "name") name))
(get scope "locals")))))
(if existing
(get existing "slot")
(let ((slot (get scope "next-slot")))
(append! (get scope "locals")
{:name name :slot slot :mutable false})
(dict-set! scope "next-slot" (+ slot 1))
slot)))))
(define scope-resolve
(fn (scope name)
"Resolve a variable name. Returns {:type \"local\"|\"upvalue\"|\"global\", :index N}.
Upvalue captures only happen at function boundaries (is-function=true).
Let scopes share the enclosing function's frame — their locals are
accessed directly without upvalue indirection."
(if (nil? scope)
{:type "global" :index name}
;; Check locals in this scope
(let ((locals (get scope "locals"))
(found (some (fn (l) (= (get l "name") name)) locals)))
(if found
(let ((local (first (filter (fn (l) (= (get l "name") name)) locals))))
{:type "local" :index (get local "slot")})
;; Check upvalues already captured at this scope
(let ((upvals (get scope "upvalues"))
(uv-found (some (fn (u) (= (get u "name") name)) upvals)))
(if uv-found
(let ((uv (first (filter (fn (u) (= (get u "name") name)) upvals))))
{:type "upvalue" :index (get uv "uv-index")})
;; Look in parent
(let ((parent (get scope "parent")))
(if (nil? parent)
{:type "global" :index name}
(let ((parent-result (scope-resolve parent name)))
(if (= (get parent-result "type") "global")
parent-result
;; Found in parent. Capture as upvalue only at function boundaries.
(if (get scope "is-function")
;; Function boundary — create upvalue capture
(let ((uv-idx (len (get scope "upvalues"))))
(append! (get scope "upvalues")
{:name name
:is-local (= (get parent-result "type") "local")
:index (get parent-result "index")
:uv-index uv-idx})
{:type "upvalue" :index uv-idx})
;; Let scope — pass through (same frame)
parent-result))))))))))))
;; --------------------------------------------------------------------------
;; Code emitter
;; --------------------------------------------------------------------------
(define make-emitter
(fn ()
{:bytecode (if (primitive? "mutable-list") (mutable-list) (list))
:pool (make-pool)}))
(define emit-byte
(fn (em byte)
(append! (get em "bytecode") byte)))
(define emit-u16
(fn (em value)
(emit-byte em (mod value 256))
(emit-byte em (mod (floor (/ value 256)) 256))))
(define emit-i16
(fn (em value)
(let ((v (if (< value 0) (+ value 65536) value)))
(emit-u16 em v))))
(define emit-op
(fn (em opcode)
(emit-byte em opcode)))
(define emit-const
(fn (em value)
(let ((idx (pool-add (get em "pool") value)))
(emit-op em 1) ;; OP_CONST
(emit-u16 em idx))))
(define current-offset
(fn (em)
(len (get em "bytecode"))))
(define patch-i16
(fn (em offset value)
"Patch a previously emitted i16 at the given bytecode offset."
(let ((v (if (< value 0) (+ value 65536) value))
(bc (get em "bytecode")))
;; Direct mutation of bytecode list at offset
(set-nth! bc offset (mod v 256))
(set-nth! bc (+ offset 1) (mod (floor (/ v 256)) 256)))))
;; --------------------------------------------------------------------------
;; Compilation — expression dispatch
;; --------------------------------------------------------------------------
(define compile-expr
(fn (em expr scope tail?)
"Compile an expression. tail? indicates tail position for TCO."
(cond
;; Nil
(nil? expr)
(emit-op em 2) ;; OP_NIL
;; Number
(= (type-of expr) "number")
(emit-const em expr)
;; String
(= (type-of expr) "string")
(emit-const em expr)
;; Boolean
(= (type-of expr) "boolean")
(emit-op em (if expr 3 4)) ;; OP_TRUE / OP_FALSE
;; Keyword
(= (type-of expr) "keyword")
(emit-const em (keyword-name expr))
;; Symbol — resolve to local/upvalue/global
(= (type-of expr) "symbol")
(compile-symbol em (symbol-name expr) scope)
;; List — dispatch on head
(= (type-of expr) "list")
(if (empty? expr)
(do (emit-op em 64) (emit-u16 em 0)) ;; OP_LIST 0
(compile-list em expr scope tail?))
;; Dict literal
(= (type-of expr) "dict")
(compile-dict em expr scope)
;; Fallback
:else
(emit-const em expr))))
(define compile-symbol
(fn (em name scope)
(let ((resolved (scope-resolve scope name)))
(cond
(= (get resolved "type") "local")
(do (emit-op em 16) ;; OP_LOCAL_GET
(emit-byte em (get resolved "index")))
(= (get resolved "type") "upvalue")
(do (emit-op em 18) ;; OP_UPVALUE_GET
(emit-byte em (get resolved "index")))
:else
;; Global or primitive
(let ((idx (pool-add (get em "pool") name)))
(emit-op em 20) ;; OP_GLOBAL_GET
(emit-u16 em idx))))))
(define compile-dict
(fn (em expr scope)
(let ((ks (keys expr))
(count (len ks)))
(for-each (fn (k)
(emit-const em k)
(compile-expr em (get expr k) scope false))
ks)
(emit-op em 65) ;; OP_DICT
(emit-u16 em count))))
;; --------------------------------------------------------------------------
;; List compilation — special forms, calls
;; --------------------------------------------------------------------------
(define compile-list
(fn (em expr scope tail?)
(let ((head (first expr))
(args (rest expr)))
(if (not (= (type-of head) "symbol"))
;; Non-symbol head — compile as call
(compile-call em head args scope tail?)
;; Symbol head — check for special forms
(let ((name (symbol-name head)))
(cond
(= name "if") (compile-if em args scope tail?)
(= name "when") (compile-when em args scope tail?)
(= name "and") (compile-and em args scope tail?)
(= name "or") (compile-or em args scope tail?)
(= name "let") (compile-let em args scope tail?)
(= name "let*") (compile-let em args scope tail?)
(= name "begin") (compile-begin em args scope tail?)
(= name "do") (compile-begin em args scope tail?)
(= name "lambda") (compile-lambda em args scope)
(= name "fn") (compile-lambda em args scope)
(= name "define") (compile-define em args scope)
(= name "set!") (compile-set em args scope)
(= name "quote") (compile-quote em args)
(= name "cond") (compile-cond em args scope tail?)
(= name "case") (compile-case em args scope tail?)
(= name "->") (compile-thread em args scope tail?)
(= name "defcomp") (compile-defcomp em args scope)
(= name "defisland") (compile-defcomp em args scope)
(= name "defmacro") (compile-defmacro em args scope)
(= name "defstyle") (emit-op em 2) ;; defstyle → nil (no-op at runtime)
(= name "defhandler") (emit-op em 2) ;; no-op
(= name "defpage") (emit-op em 2) ;; handled by page loader
(= name "defquery") (emit-op em 2)
(= name "defaction") (emit-op em 2)
(= name "defrelation") (emit-op em 2)
(= name "deftype") (emit-op em 2)
(= name "defeffect") (emit-op em 2)
(= name "defisland") (compile-defcomp em args scope)
(= name "quasiquote") (compile-quasiquote em (first args) scope)
(= name "letrec") (compile-letrec em args scope tail?)
;; Default — function call
:else
(compile-call em head args scope tail?)))))))
;; --------------------------------------------------------------------------
;; Special form compilation
;; --------------------------------------------------------------------------
(define compile-if
(fn (em args scope tail?)
(let ((test (first args))
(then-expr (nth args 1))
(else-expr (if (> (len args) 2) (nth args 2) nil)))
;; Compile test
(compile-expr em test scope false)
;; Jump if false to else
(emit-op em 33) ;; OP_JUMP_IF_FALSE
(let ((else-jump (current-offset em)))
(emit-i16 em 0) ;; placeholder
;; Compile then (in tail position if if is)
(compile-expr em then-expr scope tail?)
;; Jump over else
(emit-op em 32) ;; OP_JUMP
(let ((end-jump (current-offset em)))
(emit-i16 em 0) ;; placeholder
;; Patch else jump
(patch-i16 em else-jump (- (current-offset em) (+ else-jump 2)))
;; Compile else
(if (nil? else-expr)
(emit-op em 2) ;; OP_NIL
(compile-expr em else-expr scope tail?))
;; Patch end jump
(patch-i16 em end-jump (- (current-offset em) (+ end-jump 2))))))))
(define compile-when
(fn (em args scope tail?)
(let ((test (first args))
(body (rest args)))
(compile-expr em test scope false)
(emit-op em 33) ;; OP_JUMP_IF_FALSE
(let ((skip-jump (current-offset em)))
(emit-i16 em 0)
(compile-begin em body scope tail?)
(emit-op em 32) ;; OP_JUMP
(let ((end-jump (current-offset em)))
(emit-i16 em 0)
(patch-i16 em skip-jump (- (current-offset em) (+ skip-jump 2)))
(emit-op em 2) ;; OP_NIL
(patch-i16 em end-jump (- (current-offset em) (+ end-jump 2))))))))
(define compile-and
(fn (em args scope tail?)
(if (empty? args)
(emit-op em 3) ;; OP_TRUE
(if (= (len args) 1)
(compile-expr em (first args) scope tail?)
(do
(compile-expr em (first args) scope false)
(emit-op em 6) ;; OP_DUP
(emit-op em 33) ;; OP_JUMP_IF_FALSE
(let ((skip (current-offset em)))
(emit-i16 em 0)
(emit-op em 5) ;; OP_POP (discard duplicated truthy)
(compile-and em (rest args) scope tail?)
(patch-i16 em skip (- (current-offset em) (+ skip 2)))))))))
(define compile-or
(fn (em args scope tail?)
(if (empty? args)
(emit-op em 4) ;; OP_FALSE
(if (= (len args) 1)
(compile-expr em (first args) scope tail?)
(do
(compile-expr em (first args) scope false)
(emit-op em 6) ;; OP_DUP
(emit-op em 34) ;; OP_JUMP_IF_TRUE
(let ((skip (current-offset em)))
(emit-i16 em 0)
(emit-op em 5) ;; OP_POP
(compile-or em (rest args) scope tail?)
(patch-i16 em skip (- (current-offset em) (+ skip 2)))))))))
(define compile-begin
(fn (em exprs scope tail?)
;; Hoist: pre-allocate local slots for all define forms in this block.
;; Enables forward references between inner functions (e.g. sx-parse).
;; Only inside function bodies (scope has parent), not at top level.
(when (and (not (empty? exprs)) (not (nil? (get scope "parent"))))
(for-each (fn (expr)
(when (and (= (type-of expr) "list")
(>= (len expr) 2)
(= (type-of (first expr)) "symbol")
(= (symbol-name (first expr)) "define"))
(let ((name-expr (nth expr 1))
(name (if (= (type-of name-expr) "symbol")
(symbol-name name-expr)
name-expr)))
(scope-define-local scope name))))
exprs))
;; Compile expressions
(if (empty? exprs)
(emit-op em 2) ;; OP_NIL
(if (= (len exprs) 1)
(compile-expr em (first exprs) scope tail?)
(do
(compile-expr em (first exprs) scope false)
(emit-op em 5) ;; OP_POP
(compile-begin em (rest exprs) scope tail?))))))
(define compile-let
(fn (em args scope tail?)
;; Detect named let: (let loop ((x init) ...) body)
(if (= (type-of (first args)) "symbol")
;; Named let → desugar to letrec:
;; (letrec ((loop (fn (x ...) body))) (loop init ...))
(let ((loop-name (symbol-name (first args)))
(bindings (nth args 1))
(body (slice args 2))
(params (list))
(inits (list)))
(for-each (fn (binding)
(append! params (if (= (type-of (first binding)) "symbol")
(first binding)
(make-symbol (first binding))))
(append! inits (nth binding 1)))
bindings)
;; Compile as: (letrec ((loop (fn (params...) body...))) (loop inits...))
(let ((lambda-expr (concat (list (make-symbol "fn") params) body))
(letrec-bindings (list (list (make-symbol loop-name) lambda-expr)))
(call-expr (cons (make-symbol loop-name) inits)))
(compile-letrec em (list letrec-bindings call-expr) scope tail?)))
;; Normal let
(let ((bindings (first args))
(body (rest args))
(let-scope (make-scope scope)))
;; Let scopes share the enclosing function's frame.
;; Continue slot numbering from parent.
(dict-set! let-scope "next-slot" (get scope "next-slot"))
;; Compile each binding
(for-each (fn (binding)
(let ((name (if (= (type-of (first binding)) "symbol")
(symbol-name (first binding))
(first binding)))
(value (nth binding 1))
(slot (scope-define-local let-scope name)))
(compile-expr em value let-scope false)
(emit-op em 17) ;; OP_LOCAL_SET
(emit-byte em slot)))
bindings)
;; Compile body in let scope
(compile-begin em body let-scope tail?)))))
(define compile-letrec
(fn (em args scope tail?)
"Compile letrec: all names visible during value compilation.
1. Define all local slots (initialized to nil).
2. Compile each value and assign — names are already in scope
so mutually recursive functions can reference each other."
(let ((bindings (first args))
(body (rest args))
(let-scope (make-scope scope)))
(dict-set! let-scope "next-slot" (get scope "next-slot"))
;; Phase 1: define all slots (push nil for each)
(let ((slots (map (fn (binding)
(let ((name (if (= (type-of (first binding)) "symbol")
(symbol-name (first binding))
(first binding))))
(let ((slot (scope-define-local let-scope name)))
(emit-op em 2) ;; OP_NIL
(emit-op em 17) ;; OP_LOCAL_SET
(emit-byte em slot)
slot)))
bindings)))
;; Phase 2: compile values and assign (all names in scope)
(for-each (fn (pair)
(let ((binding (first pair))
(slot (nth pair 1)))
(compile-expr em (nth binding 1) let-scope false)
(emit-op em 17) ;; OP_LOCAL_SET
(emit-byte em slot)))
(map (fn (i) (list (nth bindings i) (nth slots i)))
(range 0 (len bindings)))))
;; Compile body
(compile-begin em body let-scope tail?))))
(define compile-lambda
(fn (em args scope)
(let ((params (first args))
(body (rest args))
(fn-scope (make-scope scope))
(fn-em (make-emitter)))
;; Mark as function boundary — upvalue captures happen here
(dict-set! fn-scope "is-function" true)
;; Define params as locals in fn scope.
;; Handle type annotations: (name :as type) → extract name
(for-each (fn (p)
(let ((name (cond
(= (type-of p) "symbol") (symbol-name p)
;; Type-annotated param: (name :as type)
(and (list? p) (not (empty? p))
(= (type-of (first p)) "symbol"))
(symbol-name (first p))
:else p)))
(when (and (not (= name "&key"))
(not (= name "&rest")))
(scope-define-local fn-scope name))))
params)
;; Compile body
(compile-begin fn-em body fn-scope true) ;; tail position
(emit-op fn-em 50) ;; OP_RETURN
;; Add code object to parent constant pool
(let ((upvals (get fn-scope "upvalues"))
(code {:arity (len (get fn-scope "locals"))
:bytecode (get fn-em "bytecode")
:constants (get (get fn-em "pool") "entries")
:upvalue-count (len upvals)})
(code-idx (pool-add (get em "pool") code)))
(emit-op em 51) ;; OP_CLOSURE
(emit-u16 em code-idx)
;; Emit upvalue descriptors: for each captured variable,
;; (is_local, index) — tells the VM where to find the value.
;; is_local=1: capture from enclosing frame's local slot
;; is_local=0: capture from enclosing frame's upvalue
(for-each (fn (uv)
(emit-byte em (if (get uv "is-local") 1 0))
(emit-byte em (get uv "index")))
upvals)))))
(define compile-define
(fn (em args scope)
(let ((name-expr (first args))
(name (if (= (type-of name-expr) "symbol")
(symbol-name name-expr)
name-expr))
;; Handle :effects annotation: (define name :effects [...] value)
;; Skip keyword-value pairs between name and body
(value (let ((rest-args (rest args)))
(if (and (not (empty? rest-args))
(= (type-of (first rest-args)) "keyword"))
;; Skip :keyword value pairs until we hit the body
(let ((skip-annotations
(fn (items)
(if (empty? items) nil
(if (= (type-of (first items)) "keyword")
(skip-annotations (rest (rest items)))
(first items))))))
(skip-annotations rest-args))
(first rest-args)))))
;; Inside a function body, define creates a LOCAL binding.
;; At top level (no enclosing function scope), define creates a global.
;; Local binding prevents recursive calls from overwriting
;; each other's defines in the flat globals hashtable.
(if (not (nil? (get scope "parent")))
;; Local define — allocate slot, compile value, set local
(let ((slot (scope-define-local scope name)))
(compile-expr em value scope false)
(emit-op em 17) ;; OP_LOCAL_SET
(emit-byte em slot))
;; Top-level define — global
(let ((name-idx (pool-add (get em "pool") name)))
(compile-expr em value scope false)
(emit-op em 128) ;; OP_DEFINE
(emit-u16 em name-idx))))))
(define compile-set
(fn (em args scope)
(let ((name (if (= (type-of (first args)) "symbol")
(symbol-name (first args))
(first args)))
(value (nth args 1))
(resolved (scope-resolve scope name)))
(compile-expr em value scope false)
(cond
(= (get resolved "type") "local")
(do (emit-op em 17) ;; OP_LOCAL_SET
(emit-byte em (get resolved "index")))
(= (get resolved "type") "upvalue")
(do (emit-op em 19) ;; OP_UPVALUE_SET
(emit-byte em (get resolved "index")))
:else
(let ((idx (pool-add (get em "pool") name)))
(emit-op em 21) ;; OP_GLOBAL_SET
(emit-u16 em idx))))))
(define compile-quote
(fn (em args)
(if (empty? args)
(emit-op em 2) ;; OP_NIL
(emit-const em (first args)))))
(define compile-cond
(fn (em args scope tail?)
"Compile (cond test1 body1 test2 body2 ... :else fallback)."
(if (< (len args) 2)
(emit-op em 2) ;; OP_NIL
(let ((test (first args))
(body (nth args 1))
(rest-clauses (if (> (len args) 2) (slice args 2) (list))))
(if (or (and (= (type-of test) "keyword") (= (keyword-name test) "else"))
(= test true))
;; else clause — just compile the body
(compile-expr em body scope tail?)
(do
(compile-expr em test scope false)
(emit-op em 33) ;; OP_JUMP_IF_FALSE
(let ((skip (current-offset em)))
(emit-i16 em 0)
(compile-expr em body scope tail?)
(emit-op em 32) ;; OP_JUMP
(let ((end-jump (current-offset em)))
(emit-i16 em 0)
(patch-i16 em skip (- (current-offset em) (+ skip 2)))
(compile-cond em rest-clauses scope tail?)
(patch-i16 em end-jump (- (current-offset em) (+ end-jump 2)))))))))))
(define compile-case
(fn (em args scope tail?)
"Compile (case expr val1 body1 val2 body2 ... :else fallback)."
;; Desugar to nested if: evaluate expr once, then compare
(compile-expr em (first args) scope false)
(let ((clauses (rest args)))
(compile-case-clauses em clauses scope tail?))))
(define compile-case-clauses
(fn (em clauses scope tail?)
(if (< (len clauses) 2)
(do (emit-op em 5) (emit-op em 2)) ;; POP match-val, push NIL
(let ((test (first clauses))
(body (nth clauses 1))
(rest-clauses (if (> (len clauses) 2) (slice clauses 2) (list))))
(if (or (and (= (type-of test) "keyword") (= (keyword-name test) "else"))
(= test true))
(do (emit-op em 5) ;; POP match-val
(compile-expr em body scope tail?))
(do
(emit-op em 6) ;; DUP match-val
(compile-expr em test scope false)
(let ((name-idx (pool-add (get em "pool") "=")))
(emit-op em 52) (emit-u16 em name-idx) (emit-byte em 2)) ;; CALL_PRIM "=" 2
(emit-op em 33) ;; JUMP_IF_FALSE
(let ((skip (current-offset em)))
(emit-i16 em 0)
(emit-op em 5) ;; POP match-val
(compile-expr em body scope tail?)
(emit-op em 32) ;; JUMP
(let ((end-jump (current-offset em)))
(emit-i16 em 0)
(patch-i16 em skip (- (current-offset em) (+ skip 2)))
(compile-case-clauses em rest-clauses scope tail?)
(patch-i16 em end-jump (- (current-offset em) (+ end-jump 2)))))))))))
(define compile-thread
(fn (em args scope tail?)
"Compile (-> val (f1 a) (f2 b)) by desugaring to nested calls."
(if (empty? args)
(emit-op em 2)
(if (= (len args) 1)
(compile-expr em (first args) scope tail?)
;; Desugar: (-> x (f a)) → (f x a)
(let ((val-expr (first args))
(forms (rest args)))
(compile-thread-step em val-expr forms scope tail?))))))
(define compile-thread-step
(fn (em val-expr forms scope tail?)
(if (empty? forms)
(compile-expr em val-expr scope tail?)
(let ((form (first forms))
(rest-forms (rest forms))
(is-tail (and tail? (empty? rest-forms))))
;; Build desugared call: (f val args...)
(let ((call-expr
(if (list? form)
;; (-> x (f a b)) → (f x a b)
(concat (list (first form) val-expr) (rest form))
;; (-> x f) → (f x)
(list form val-expr))))
(if (empty? rest-forms)
(compile-expr em call-expr scope is-tail)
(do
(compile-expr em call-expr scope false)
;; Thread result through remaining forms
;; Store in temp, compile next step
;; Actually, just compile sequentially — each step returns a value
(compile-thread-step em call-expr rest-forms scope tail?))))))))
(define compile-defcomp
(fn (em args scope)
"Compile defcomp/defisland — delegates to runtime via GLOBAL_GET + CALL."
(let ((name-idx (pool-add (get em "pool") "eval-defcomp")))
(emit-op em 20) (emit-u16 em name-idx)) ;; GLOBAL_GET fn
(emit-const em (concat (list (make-symbol "defcomp")) args))
(emit-op em 48) (emit-byte em 1))) ;; CALL 1
(define compile-defmacro
(fn (em args scope)
"Compile defmacro — delegates to runtime via GLOBAL_GET + CALL."
(let ((name-idx (pool-add (get em "pool") "eval-defmacro")))
(emit-op em 20) (emit-u16 em name-idx)) ;; GLOBAL_GET fn
(emit-const em (concat (list (make-symbol "defmacro")) args))
(emit-op em 48) (emit-byte em 1)))
(define compile-quasiquote
(fn (em expr scope)
"Compile quasiquote inline — walks the template at compile time,
emitting code that builds the structure at runtime. Unquoted
expressions are compiled normally (resolving locals/upvalues),
avoiding the qq-expand-runtime env-lookup limitation."
(compile-qq-expr em expr scope)))
(define compile-qq-expr
(fn (em expr scope)
"Compile a quasiquote sub-expression."
(if (not (= (type-of expr) "list"))
;; Atom — emit as constant
(emit-const em expr)
(if (empty? expr)
;; Empty list
(do (emit-op em 64) (emit-u16 em 0)) ;; OP_LIST 0
(let ((head (first expr)))
(if (and (= (type-of head) "symbol")
(= (symbol-name head) "unquote"))
;; (unquote expr) — compile the expression
(compile-expr em (nth expr 1) scope false)
;; List — compile elements, handling splice-unquote
(compile-qq-list em expr scope)))))))
(define compile-qq-list
(fn (em items scope)
"Compile a quasiquote list. Handles splice-unquote by building
segments and concatenating them."
(let ((has-splice (some (fn (item)
(and (= (type-of item) "list")
(>= (len item) 2)
(= (type-of (first item)) "symbol")
(= (symbol-name (first item)) "splice-unquote")))
items)))
(if (not has-splice)
;; No splicing — compile each element, then OP_LIST
(do
(for-each (fn (item) (compile-qq-expr em item scope)) items)
(emit-op em 64) (emit-u16 em (len items))) ;; OP_LIST N
;; Has splicing — build segments and concat
;; Strategy: accumulate non-spliced items into a pending list,
;; flush as OP_LIST when hitting a splice, concat all segments.
(let ((segment-count 0)
(pending 0))
(for-each
(fn (item)
(if (and (= (type-of item) "list")
(>= (len item) 2)
(= (type-of (first item)) "symbol")
(= (symbol-name (first item)) "splice-unquote"))
;; Splice-unquote: flush pending, compile spliced expr
(do
(when (> pending 0)
(emit-op em 64) (emit-u16 em pending) ;; OP_LIST for pending
(set! segment-count (+ segment-count 1))
(set! pending 0))
;; Compile the spliced expression
(compile-expr em (nth item 1) scope false)
(set! segment-count (+ segment-count 1)))
;; Normal element — compile and count as pending
(do
(compile-qq-expr em item scope)
(set! pending (+ pending 1)))))
items)
;; Flush remaining pending items
(when (> pending 0)
(emit-op em 64) (emit-u16 em pending)
(set! segment-count (+ segment-count 1)))
;; Concat all segments
(when (> segment-count 1)
(let ((concat-idx (pool-add (get em "pool") "concat")))
;; concat takes N args — call with all segments
(emit-op em 52) (emit-u16 em concat-idx)
(emit-byte em segment-count))))))))
;; --------------------------------------------------------------------------
;; Function call compilation
;; --------------------------------------------------------------------------
(define compile-call
(fn (em head args scope tail?)
;; Check for known primitives
(let ((is-prim (and (= (type-of head) "symbol")
(let ((name (symbol-name head)))
(and (not (= (get (scope-resolve scope name) "type") "local"))
(not (= (get (scope-resolve scope name) "type") "upvalue"))
(primitive? name))))))
(if is-prim
;; Direct primitive call via CALL_PRIM
(let ((name (symbol-name head))
(argc (len args))
(name-idx (pool-add (get em "pool") name)))
(for-each (fn (a) (compile-expr em a scope false)) args)
(emit-op em 52) ;; OP_CALL_PRIM
(emit-u16 em name-idx)
(emit-byte em argc))
;; General call
(do
(compile-expr em head scope false)
(for-each (fn (a) (compile-expr em a scope false)) args)
(if tail?
(do (emit-op em 49) ;; OP_TAIL_CALL
(emit-byte em (len args)))
(do (emit-op em 48) ;; OP_CALL
(emit-byte em (len args)))))))))
;; --------------------------------------------------------------------------
;; Top-level API
;; --------------------------------------------------------------------------
(define compile
(fn (expr)
"Compile a single SX expression to a bytecode module."
(let ((em (make-emitter))
(scope (make-scope nil)))
(compile-expr em expr scope false)
(emit-op em 50) ;; OP_RETURN
{:bytecode (get em "bytecode")
:constants (get (get em "pool") "entries")})))
(define compile-module
(fn (exprs)
"Compile a list of top-level expressions to a bytecode module."
(let ((em (make-emitter))
(scope (make-scope nil)))
(for-each (fn (expr)
(compile-expr em expr scope false)
(emit-op em 5)) ;; OP_POP between top-level exprs
(init exprs))
;; Last expression's value is the module result
(compile-expr em (last exprs) scope false)
(emit-op em 50) ;; OP_RETURN
{:bytecode (get em "bytecode")
:constants (get (get em "pool") "entries")})))

45
shared/static/wasm/sx/core-signals.sx Normal file
View File

@@ -0,0 +1,45 @@
(define make-signal (fn (value) (dict "__signal" true "value" value "subscribers" (list) "deps" (list))))
(define signal? (fn (x) (and (dict? x) (has-key? x "__signal"))))
(define signal-value (fn (s) (get s "value")))
(define signal-set-value! (fn (s v) (dict-set! s "value" v)))
(define signal-subscribers (fn (s) (get s "subscribers")))
(define signal-add-sub! (fn (s f) (when (not (contains? (get s "subscribers") f)) (append! (get s "subscribers") f))))
(define signal-remove-sub! (fn (s f) (dict-set! s "subscribers" (filter (fn (sub) (not (identical? sub f))) (get s "subscribers")))))
(define signal-deps (fn (s) (get s "deps")))
(define signal-set-deps! (fn (s deps) (dict-set! s "deps" deps)))
(define signal :effects () (fn ((initial-value :as any)) (make-signal initial-value)))
(define deref :effects () (fn ((s :as any)) (if (not (signal? s)) s (let ((ctx (context "sx-reactive" nil))) (when ctx (let ((dep-list (get ctx "deps")) (notify-fn (get ctx "notify"))) (when (not (contains? dep-list s)) (append! dep-list s) (signal-add-sub! s notify-fn)))) (signal-value s)))))
(define reset! :effects (mutation) (fn ((s :as signal) value) (when (signal? s) (let ((old (signal-value s))) (when (not (identical? old value)) (signal-set-value! s value) (notify-subscribers s))))))
(define swap! :effects (mutation) (fn ((s :as signal) (f :as lambda) &rest args) (when (signal? s) (let ((old (signal-value s)) (new-val (trampoline (apply f (cons old args))))) (when (not (identical? old new-val)) (signal-set-value! s new-val) (notify-subscribers s))))))
(define computed :effects (mutation) (fn ((compute-fn :as lambda)) (let ((s (make-signal nil)) (deps (list)) (compute-ctx nil)) (let ((recompute (fn () (for-each (fn ((dep :as signal)) (signal-remove-sub! dep recompute)) (signal-deps s)) (signal-set-deps! s (list)) (let ((ctx (dict "deps" (list) "notify" recompute))) (scope-push! "sx-reactive" ctx) (let ((new-val (cek-call compute-fn nil))) (scope-pop! "sx-reactive") (signal-set-deps! s (get ctx "deps")) (let ((old (signal-value s))) (signal-set-value! s new-val) (when (not (identical? old new-val)) (notify-subscribers s)))))))) (recompute) (register-in-scope (fn () (dispose-computed s))) s))))
(define effect :effects (mutation) (fn ((effect-fn :as lambda)) (let ((deps (list)) (disposed false) (cleanup-fn nil)) (let ((run-effect (fn () (when (not disposed) (when cleanup-fn (cek-call cleanup-fn nil)) (for-each (fn ((dep :as signal)) (signal-remove-sub! dep run-effect)) deps) (set! deps (list)) (let ((ctx (dict "deps" (list) "notify" run-effect))) (scope-push! "sx-reactive" ctx) (let ((result (cek-call effect-fn nil))) (scope-pop! "sx-reactive") (set! deps (get ctx "deps")) (when (callable? result) (set! cleanup-fn result)))))))) (run-effect) (let ((dispose-fn (fn () (set! disposed true) (when cleanup-fn (cek-call cleanup-fn nil)) (for-each (fn ((dep :as signal)) (signal-remove-sub! dep run-effect)) deps) (set! deps (list))))) (register-in-scope dispose-fn) dispose-fn)))))
(define *batch-depth* 0)
(define *batch-queue* (list))
(define batch :effects (mutation) (fn ((thunk :as lambda)) (set! *batch-depth* (+ *batch-depth* 1)) (cek-call thunk nil) (set! *batch-depth* (- *batch-depth* 1)) (when (= *batch-depth* 0) (let ((queue *batch-queue*)) (set! *batch-queue* (list)) (let ((seen (list)) (pending (list))) (for-each (fn ((s :as signal)) (for-each (fn ((sub :as lambda)) (when (not (contains? seen sub)) (append! seen sub) (append! pending sub))) (signal-subscribers s))) queue) (for-each (fn ((sub :as lambda)) (sub)) pending))))))
(define notify-subscribers :effects (mutation) (fn ((s :as signal)) (if (> *batch-depth* 0) (when (not (contains? *batch-queue* s)) (append! *batch-queue* s)) (flush-subscribers s))))
(define flush-subscribers :effects (mutation) (fn ((s :as signal)) (for-each (fn ((sub :as lambda)) (sub)) (signal-subscribers s))))
(define dispose-computed :effects (mutation) (fn ((s :as signal)) (when (signal? s) (for-each (fn ((dep :as signal)) (signal-remove-sub! dep nil)) (signal-deps s)) (signal-set-deps! s (list)))))
(define with-island-scope :effects (mutation) (fn ((scope-fn :as lambda) (body-fn :as lambda)) (scope-push! "sx-island-scope" scope-fn) (let ((result (body-fn))) (scope-pop! "sx-island-scope") result)))
(define register-in-scope :effects (mutation) (fn ((disposable :as lambda)) (let ((collector (scope-peek "sx-island-scope"))) (when collector (cek-call collector (list disposable))))))

459
shared/static/wasm/sx/deps.sx Normal file
View File

@@ -0,0 +1,459 @@
;; ==========================================================================
;; deps.sx — Component dependency analysis specification
;;
;; Pure functions for analyzing component dependency graphs.
;; Used by the bundling system to compute per-page component bundles
;; instead of sending every definition to every page.
;;
;; All functions are pure — no IO, no platform-specific operations.
;; Each host bootstraps this to native code alongside eval.sx/render.sx.
;;
;; From eval.sx platform (already provided by every host):
;; (type-of x) → type string
;; (symbol-name s) → string name of symbol
;; (component-body c) → unevaluated AST of component body
;; (component-name c) → string name (without ~)
;; (macro-body m) → macro body AST
;; (env-get env k) → value or nil
;;
;; New platform functions for deps (each host implements):
;; (component-deps c) → cached deps list (may be empty)
;; (component-set-deps! c d)→ cache deps on component
;; (component-css-classes c)→ pre-scanned CSS class list
;; (regex-find-all pat src) → list of capture group 1 matches
;; (scan-css-classes src) → list of CSS class strings from source
;; ==========================================================================
;; --------------------------------------------------------------------------
;; 1. AST scanning — collect ~component references from an AST node
;; --------------------------------------------------------------------------
;; Walks all branches of control flow (if/when/cond/case) to find
;; every component that *could* be rendered.
(define scan-refs :effects []
(fn (node)
(let ((refs (list)))
(scan-refs-walk node refs)
refs)))
(define scan-refs-walk :effects []
(fn (node (refs :as list))
(cond
;; Symbol starting with ~ → component reference
(= (type-of node) "symbol")
(let ((name (symbol-name node)))
(when (starts-with? name "~")
(when (not (contains? refs name))
(append! refs name))))
;; List → recurse into all elements (covers all control flow branches)
(= (type-of node) "list")
(for-each (fn (item) (scan-refs-walk item refs)) node)
;; Dict → recurse into values
(= (type-of node) "dict")
(for-each (fn (key) (scan-refs-walk (dict-get node key) refs))
(keys node))
;; Literals (number, string, boolean, nil, keyword) → no refs
:else nil)))
;; --------------------------------------------------------------------------
;; 2. Transitive dependency closure
;; --------------------------------------------------------------------------
;; Given a component name and an environment, compute all components
;; that it can transitively render. Handles cycles via seen-set.
(define transitive-deps-walk :effects []
(fn ((n :as string) (seen :as list) (env :as dict))
(when (not (contains? seen n))
(append! seen n)
(let ((val (env-get env n)))
(cond
(or (= (type-of val) "component") (= (type-of val) "island"))
(for-each (fn ((ref :as string)) (transitive-deps-walk ref seen env))
(scan-refs (component-body val)))
(= (type-of val) "macro")
(for-each (fn ((ref :as string)) (transitive-deps-walk ref seen env))
(scan-refs (macro-body val)))
:else nil)))))
(define transitive-deps :effects []
(fn ((name :as string) (env :as dict))
(let ((seen (list))
(key (if (starts-with? name "~") name (str "~" name))))
(transitive-deps-walk key seen env)
(filter (fn ((x :as string)) (not (= x key))) seen))))
;; --------------------------------------------------------------------------
;; 3. Compute deps for all components in an environment
;; --------------------------------------------------------------------------
;; Iterates env, calls transitive-deps for each component, and
;; stores the result via the platform's component-set-deps! function.
;;
;; Platform interface:
;; (env-components env) → list of component names in env
;; (component-set-deps! comp deps) → store deps on component
(define compute-all-deps :effects [mutation]
(fn ((env :as dict))
(for-each
(fn ((name :as string))
(let ((val (env-get env name)))
(when (or (= (type-of val) "component") (= (type-of val) "island"))
(component-set-deps! val (transitive-deps name env)))))
(env-components env))))
;; --------------------------------------------------------------------------
;; 4. Scan serialized SX source for component references
;; --------------------------------------------------------------------------
;; Regex-based extraction of (~name patterns from SX wire format.
;; Returns list of names WITH ~ prefix.
;;
;; Platform interface:
;; (regex-find-all pattern source) → list of matched group strings
(define scan-components-from-source :effects []
(fn ((source :as string))
(let ((matches (regex-find-all "\\(~([a-zA-Z_][a-zA-Z0-9_\\-:/]*)" source)))
(map (fn ((m :as string)) (str "~" m)) matches))))
;; --------------------------------------------------------------------------
;; 5. Components needed for a page
;; --------------------------------------------------------------------------
;; Scans page source for direct component references, then computes
;; the transitive closure. Returns list of ~names.
(define components-needed :effects []
(fn ((page-source :as string) (env :as dict))
(let ((direct (scan-components-from-source page-source))
(all-needed (list)))
;; Add each direct ref + its transitive deps
(for-each
(fn ((name :as string))
(when (not (contains? all-needed name))
(append! all-needed name))
(let ((val (env-get env name)))
(let ((deps (if (and (= (type-of val) "component")
(not (empty? (component-deps val))))
(component-deps val)
(transitive-deps name env))))
(for-each
(fn ((dep :as string))
(when (not (contains? all-needed dep))
(append! all-needed dep)))
deps))))
direct)
all-needed)))
;; --------------------------------------------------------------------------
;; 6. Build per-page component bundle
;; --------------------------------------------------------------------------
;; Given page source and env, returns list of component names needed.
;; The host uses this list to serialize only the needed definitions
;; and compute a page-specific hash.
;;
;; This replaces the "send everything" approach with per-page bundles.
(define page-component-bundle :effects []
(fn ((page-source :as string) (env :as dict))
(components-needed page-source env)))
;; --------------------------------------------------------------------------
;; 7. CSS classes for a page
;; --------------------------------------------------------------------------
;; Returns the union of CSS classes from components this page uses,
;; plus classes from the page source itself.
;;
;; Platform interface:
;; (component-css-classes c) → set/list of class strings
;; (scan-css-classes source) → set/list of class strings from source
(define page-css-classes :effects []
(fn ((page-source :as string) (env :as dict))
(let ((needed (components-needed page-source env))
(classes (list)))
;; Collect classes from needed components
(for-each
(fn ((name :as string))
(let ((val (env-get env name)))
(when (= (type-of val) "component")
(for-each
(fn ((cls :as string))
(when (not (contains? classes cls))
(append! classes cls)))
(component-css-classes val)))))
needed)
;; Add classes from page source
(for-each
(fn ((cls :as string))
(when (not (contains? classes cls))
(append! classes cls)))
(scan-css-classes page-source))
classes)))
;; --------------------------------------------------------------------------
;; 8. IO detection — scan component ASTs for IO primitive references
;; --------------------------------------------------------------------------
;; Extends the dependency walker to detect references to IO primitives.
;; IO names are provided by the host (from boundary.sx declarations).
;; A component is "pure" if it (transitively) references no IO primitives.
;;
;; Platform interface additions:
;; (component-io-refs c) → cached IO ref list (may be empty)
;; (component-set-io-refs! c r) → cache IO refs on component
(define scan-io-refs-walk :effects []
(fn (node (io-names :as list) (refs :as list))
(cond
;; Symbol → check if name is in the IO set
(= (type-of node) "symbol")
(let ((name (symbol-name node)))
(when (contains? io-names name)
(when (not (contains? refs name))
(append! refs name))))
;; List → recurse into all elements
(= (type-of node) "list")
(for-each (fn (item) (scan-io-refs-walk item io-names refs)) node)
;; Dict → recurse into values
(= (type-of node) "dict")
(for-each (fn (key) (scan-io-refs-walk (dict-get node key) io-names refs))
(keys node))
;; Literals → no IO refs
:else nil)))
(define scan-io-refs :effects []
(fn (node (io-names :as list))
(let ((refs (list)))
(scan-io-refs-walk node io-names refs)
refs)))
;; --------------------------------------------------------------------------
;; 9. Transitive IO refs — follow component deps and union IO refs
;; --------------------------------------------------------------------------
(define transitive-io-refs-walk :effects []
(fn ((n :as string) (seen :as list) (all-refs :as list) (env :as dict) (io-names :as list))
(when (not (contains? seen n))
(append! seen n)
(let ((val (env-get env n)))
(cond
(= (type-of val) "component")
(do
;; Scan this component's body for IO refs
(for-each
(fn ((ref :as string))
(when (not (contains? all-refs ref))
(append! all-refs ref)))
(scan-io-refs (component-body val) io-names))
;; Recurse into component deps
(for-each
(fn ((dep :as string)) (transitive-io-refs-walk dep seen all-refs env io-names))
(scan-refs (component-body val))))
(= (type-of val) "macro")
(do
(for-each
(fn ((ref :as string))
(when (not (contains? all-refs ref))
(append! all-refs ref)))
(scan-io-refs (macro-body val) io-names))
(for-each
(fn ((dep :as string)) (transitive-io-refs-walk dep seen all-refs env io-names))
(scan-refs (macro-body val))))
:else nil)))))
(define transitive-io-refs :effects []
(fn ((name :as string) (env :as dict) (io-names :as list))
(let ((all-refs (list))
(seen (list))
(key (if (starts-with? name "~") name (str "~" name))))
(transitive-io-refs-walk key seen all-refs env io-names)
all-refs)))
;; --------------------------------------------------------------------------
;; 10. Compute IO refs for all components in an environment
;; --------------------------------------------------------------------------
(define compute-all-io-refs :effects [mutation]
(fn ((env :as dict) (io-names :as list))
(for-each
(fn ((name :as string))
(let ((val (env-get env name)))
(when (= (type-of val) "component")
(component-set-io-refs! val (transitive-io-refs name env io-names)))))
(env-components env))))
(define component-io-refs-cached :effects []
(fn ((name :as string) (env :as dict) (io-names :as list))
(let ((key (if (starts-with? name "~") name (str "~" name))))
(let ((val (env-get env key)))
(if (and (= (type-of val) "component")
(not (nil? (component-io-refs val)))
(not (empty? (component-io-refs val))))
(component-io-refs val)
;; Fallback: not yet cached (shouldn't happen after compute-all-io-refs)
(transitive-io-refs name env io-names))))))
(define component-pure? :effects []
(fn ((name :as string) (env :as dict) (io-names :as list))
(let ((key (if (starts-with? name "~") name (str "~" name))))
(let ((val (env-get env key)))
(if (and (= (type-of val) "component")
(not (nil? (component-io-refs val))))
;; Use cached io-refs (empty list = pure)
(empty? (component-io-refs val))
;; Fallback
(empty? (transitive-io-refs name env io-names)))))))
;; --------------------------------------------------------------------------
;; 5. Render target — boundary decision per component
;; --------------------------------------------------------------------------
;; Combines IO analysis with affinity annotations to decide where a
;; component should render:
;;
;; :affinity :server → always "server" (auth-sensitive, secrets)
;; :affinity :client → "client" even if IO-dependent (IO proxy)
;; :affinity :auto → "server" if IO-dependent, "client" if pure
;;
;; Returns: "server" | "client"
(define render-target :effects []
(fn ((name :as string) (env :as dict) (io-names :as list))
(let ((key (if (starts-with? name "~") name (str "~" name))))
(let ((val (env-get env key)))
(if (not (= (type-of val) "component"))
"server"
(let ((affinity (component-affinity val)))
(cond
(= affinity "server") "server"
(= affinity "client") "client"
;; auto: decide from IO analysis
(not (component-pure? name env io-names)) "server"
:else "client")))))))
;; --------------------------------------------------------------------------
;; 6. Page render plan — pre-computed boundary decisions for a page
;; --------------------------------------------------------------------------
;; Given page source + env + IO names, returns a render plan dict:
;;
;; {:components {~name "server"|"client" ...}
;; :server (list of ~names that render server-side)
;; :client (list of ~names that render client-side)
;; :io-deps (list of IO primitives needed by server components)}
;;
;; This is computed once at page registration and cached on the page def.
;; The async evaluator and client router both use it to make decisions
;; without recomputing at every request.
(define page-render-plan :effects []
(fn ((page-source :as string) (env :as dict) (io-names :as list))
(let ((needed (components-needed page-source env))
(comp-targets (dict))
(server-list (list))
(client-list (list))
(io-deps (list)))
(for-each
(fn ((name :as string))
(let ((target (render-target name env io-names)))
(dict-set! comp-targets name target)
(if (= target "server")
(do
(append! server-list name)
;; Collect IO deps from server components (use cache)
(for-each
(fn ((io-ref :as string))
(when (not (contains? io-deps io-ref))
(append! io-deps io-ref)))
(component-io-refs-cached name env io-names)))
(append! client-list name))))
needed)
{:components comp-targets
:server server-list
:client client-list
:io-deps io-deps})))
;; --------------------------------------------------------------------------
;; Host obligation: selective expansion in async partial evaluation
;; --------------------------------------------------------------------------
;; The spec classifies components as pure or IO-dependent and provides
;; per-component render-target decisions. Each host's async partial
;; evaluator (the server-side rendering path that bridges sync evaluation
;; with async IO) must use this classification:
;;
;; render-target "server" → expand server-side (IO must resolve)
;; render-target "client" → serialize for client (can render anywhere)
;; Layout slot context → expand all (server needs full HTML)
;;
;; The spec provides: component-io-refs, component-pure?, render-target,
;; component-affinity. The host provides the async runtime that acts on it.
;; This is not SX semantics — it is host infrastructure. Every host
;; with a server-side async evaluator implements the same rule.
;; --------------------------------------------------------------------------
;; --------------------------------------------------------------------------
;; Platform interface summary
;; --------------------------------------------------------------------------
;;
;; From eval.sx (already provided):
;; (type-of x) → type string
;; (symbol-name s) → string name of symbol
;; (env-get env k) → value or nil
;;
;; New for deps.sx (each host implements):
;; (component-body c) → AST body of component
;; (component-name c) → name string
;; (component-deps c) → cached deps list (may be empty)
;; (component-set-deps! c d)→ cache deps on component
;; (component-css-classes c)→ pre-scanned CSS class list
;; (component-io-refs c) → cached IO ref list (may be empty)
;; (component-set-io-refs! c r)→ cache IO refs on component
;; (component-affinity c) → "auto" | "client" | "server"
;; (macro-body m) → AST body of macro
;; (regex-find-all pat src) → list of capture group matches
;; (scan-css-classes src) → list of CSS class strings from source
;; --------------------------------------------------------------------------
;; --------------------------------------------------------------------------
;; env-components — list component/macro names in an environment
;; --------------------------------------------------------------------------
;; Moved from platform to spec: pure logic using type predicates.
(define env-components :effects []
(fn ((env :as dict))
(filter
(fn ((k :as string))
(let ((v (env-get env k)))
(or (component? v) (macro? v))))
(keys env))))

94
shared/static/wasm/sx/freeze.sx Normal file
View File

@@ -0,0 +1,94 @@
;; ==========================================================================
;; freeze.sx — Serializable state boundaries
;;
;; Freeze scopes collect signals registered within them. On freeze,
;; their current values are serialized to SX. On thaw, values are
;; restored. Multiple named scopes can coexist independently.
;;
;; This is a library built on top of the evaluator's scoped effects
;; (scope-push!/scope-pop!/context) and signal system. It is NOT
;; part of the core evaluator — it loads after evaluator.sx.
;;
;; Usage:
;; (freeze-scope "editor"
;; (let ((doc (signal "hello")))
;; (freeze-signal "doc" doc)
;; ...))
;;
;; (cek-freeze-scope "editor") → {:name "editor" :signals {:doc "hello"}}
;; (cek-thaw-scope "editor" frozen-data) → restores signal values
;; ==========================================================================
;; Registry of freeze scopes: name → list of {name signal} entries
(define freeze-registry (dict))
;; Register a signal in the current freeze scope
(define freeze-signal :effects [mutation]
(fn (name sig)
(let ((scope-name (context "sx-freeze-scope" nil)))
(when scope-name
(let ((entries (or (get freeze-registry scope-name) (list))))
(append! entries (dict "name" name "signal" sig))
(dict-set! freeze-registry scope-name entries))))))
;; Freeze scope delimiter — collects signals registered within body
(define freeze-scope :effects [mutation]
(fn (name body-fn)
(scope-push! "sx-freeze-scope" name)
;; Initialize empty entry list for this scope
(dict-set! freeze-registry name (list))
(cek-call body-fn nil)
(scope-pop! "sx-freeze-scope")
nil))
;; Freeze a named scope → SX dict of signal values
(define cek-freeze-scope :effects []
(fn (name)
(let ((entries (or (get freeze-registry name) (list)))
(signals-dict (dict)))
(for-each (fn (entry)
(dict-set! signals-dict
(get entry "name")
(signal-value (get entry "signal"))))
entries)
(dict "name" name "signals" signals-dict))))
;; Freeze all scopes
(define cek-freeze-all :effects []
(fn ()
(map (fn (name) (cek-freeze-scope name))
(keys freeze-registry))))
;; Thaw a named scope — restore signal values from frozen data
(define cek-thaw-scope :effects [mutation]
(fn (name frozen)
(let ((entries (or (get freeze-registry name) (list)))
(values (get frozen "signals")))
(when values
(for-each (fn (entry)
(let ((sig-name (get entry "name"))
(sig (get entry "signal"))
(val (get values sig-name)))
(when (not (nil? val))
(reset! sig val))))
entries)))))
;; Thaw all scopes from a list of frozen scope dicts
(define cek-thaw-all :effects [mutation]
(fn (frozen-list)
(for-each (fn (frozen)
(cek-thaw-scope (get frozen "name") frozen))
frozen-list)))
;; Serialize a frozen scope to SX text
(define freeze-to-sx :effects []
(fn (name)
(sx-serialize (cek-freeze-scope name))))
;; Restore from SX text
(define thaw-from-sx :effects [mutation]
(fn (sx-text)
(let ((parsed (sx-parse sx-text)))
(when (not (empty? parsed))
(let ((frozen (first parsed)))
(cek-thaw-scope (get frozen "name") frozen))))))

21
shared/static/wasm/sx/harness-reactive.sx Normal file
View File

@@ -0,0 +1,21 @@
(define assert-signal-value :effects () (fn ((sig :as any) expected) (let ((actual (deref sig))) (assert= actual expected (str "Expected signal value " expected ", got " actual)))))
(define assert-signal-has-subscribers :effects () (fn ((sig :as any)) (assert (> (len (signal-subscribers sig)) 0) "Expected signal to have subscribers")))
(define assert-signal-no-subscribers :effects () (fn ((sig :as any)) (assert (= (len (signal-subscribers sig)) 0) "Expected signal to have no subscribers")))
(define assert-signal-subscriber-count :effects () (fn ((sig :as any) (n :as number)) (let ((actual (len (signal-subscribers sig)))) (assert= actual n (str "Expected " n " subscribers, got " actual)))))
(define simulate-signal-set! :effects (mutation) (fn ((sig :as any) value) (reset! sig value)))
(define simulate-signal-swap! :effects (mutation) (fn ((sig :as any) (f :as lambda) &rest args) (apply swap! (cons sig (cons f args)))))
(define assert-computed-dep-count :effects () (fn ((sig :as any) (n :as number)) (let ((actual (len (signal-deps sig)))) (assert= actual n (str "Expected " n " deps, got " actual)))))
(define assert-computed-depends-on :effects () (fn ((computed-sig :as any) (dep-sig :as any)) (assert (contains? (signal-deps computed-sig) dep-sig) "Expected computed to depend on the given signal")))
(define count-effect-runs :effects (mutation) (fn ((thunk :as lambda)) (let ((count (signal 0))) (effect (fn () (deref count))) (let ((run-count 0) (tracker (effect (fn () (set! run-count (+ run-count 1)) (cek-call thunk nil))))) run-count))))
(define make-test-signal :effects (mutation) (fn (initial-value) (let ((sig (signal initial-value)) (history (list))) (effect (fn () (append! history (deref sig)))) {:signal sig :history history})))
(define assert-batch-coalesces :effects (mutation) (fn ((thunk :as lambda) (expected-notify-count :as number)) (let ((notify-count 0) (sig (signal 0))) (effect (fn () (deref sig) (set! notify-count (+ notify-count 1)))) (set! notify-count 0) (batch thunk) (assert= notify-count expected-notify-count (str "Expected " expected-notify-count " notifications, got " notify-count)))))

320
shared/static/wasm/sx/harness-web.sx Normal file
View File

@@ -0,0 +1,320 @@
(define
mock-element
:effects ()
(fn ((tag :as string) &key class id) {:children (list) :listeners {} :event-log (list) :tag tag :text "" :attrs (merge {} (if class {:class class} {}) (if id {:id id} {}))}))
(define
mock-set-text!
:effects (mutation)
(fn (el (text :as string)) (dict-set! el "text" text)))
(define
mock-append-child!
:effects (mutation)
(fn (parent child) (append! (get parent "children") child)))
(define
mock-set-attr!
:effects (mutation)
(fn (el (name :as string) value) (dict-set! (get el "attrs") name value)))
(define
mock-get-attr
:effects ()
(fn (el (name :as string)) (get (get el "attrs") name)))
(define
mock-add-listener!
:effects (mutation)
(fn
(el (event-name :as string) (handler :as lambda))
(let
((listeners (get el "listeners")))
(when
(not (has-key? listeners event-name))
(dict-set! listeners event-name (list)))
(append! (get listeners event-name) handler))))
(define
simulate-click
:effects (mutation)
(fn
(el)
(let
((handlers (get (get el "listeners") "click")))
(when
handlers
(for-each (fn (h) (cek-call h (list {:target el :type "click"}))) handlers))
(append! (get el "event-log") {:type "click"}))))
(define
simulate-input
:effects (mutation)
(fn
(el (value :as string))
(mock-set-attr! el "value" value)
(let
((handlers (get (get el "listeners") "input")))
(when
handlers
(for-each (fn (h) (cek-call h (list {:target el :type "input"}))) handlers))
(append! (get el "event-log") {:value value :type "input"}))))
(define
simulate-event
:effects (mutation)
(fn
(el (event-name :as string) detail)
(let
((handlers (get (get el "listeners") event-name)))
(when
handlers
(for-each (fn (h) (cek-call h (list {:target el :detail detail :type event-name}))) handlers))
(append! (get el "event-log") {:detail detail :type event-name}))))
(define
assert-text
:effects ()
(fn
(el (expected :as string))
(let
((actual (get el "text")))
(assert=
actual
expected
(str "Expected text \"" expected "\", got \"" actual "\"")))))
(define
assert-attr
:effects ()
(fn
(el (name :as string) expected)
(let
((actual (mock-get-attr el name)))
(assert=
actual
expected
(str "Expected attr " name "=\"" expected "\", got \"" actual "\"")))))
(define
assert-class
:effects ()
(fn
(el (class-name :as string))
(let
((classes (or (mock-get-attr el "class") "")))
(assert
(contains? (split classes " ") class-name)
(str "Expected class \"" class-name "\" in \"" classes "\"")))))
(define
assert-no-class
:effects ()
(fn
(el (class-name :as string))
(let
((classes (or (mock-get-attr el "class") "")))
(assert
(not (contains? (split classes " ") class-name))
(str "Expected no class \"" class-name "\" but found in \"" classes "\"")))))
(define
assert-child-count
:effects ()
(fn
(el (n :as number))
(let
((actual (len (get el "children"))))
(assert= actual n (str "Expected " n " children, got " actual)))))
(define
assert-event-fired
:effects ()
(fn
(el (event-name :as string))
(assert
(some (fn (e) (= (get e "type") event-name)) (get el "event-log"))
(str "Expected event \"" event-name "\" to have been fired"))))
(define
assert-no-event
:effects ()
(fn
(el (event-name :as string))
(assert
(not
(some (fn (e) (= (get e "type") event-name)) (get el "event-log")))
(str "Expected event \"" event-name "\" to NOT have been fired"))))
(define
event-fire-count
:effects ()
(fn
(el (event-name :as string))
(len
(filter (fn (e) (= (get e "type") event-name)) (get el "event-log")))))
(define
make-web-harness
:effects ()
(fn
(&key platform)
(let
((h (make-harness :platform platform)))
(harness-set! h "dom" {:elements {} :root (mock-element "div" :id "root")})
h)))
(define
is-renderable?
:effects ()
(fn
(value)
(cond
(nil? value)
true
(string? value)
true
(number? value)
true
(boolean? value)
true
(dict? value)
false
(not (list? value))
false
(empty? value)
true
:else (let
((head (first value)))
(and (= (type-of head) "symbol") (not (dict? head)))))))
(define
is-render-leak?
:effects ()
(fn (value) (and (not (nil? value)) (not (is-renderable? value)))))
(define
assert-renderable
:effects ()
(fn
(value label)
(assert
(is-renderable? value)
(str
"Render leak in "
label
": "
(type-of value)
(cond
(dict? value)
" — dict would appear as {:key val} text in output"
(and (list? value) (not (empty? value)) (dict? (first value)))
" — list of dicts would appear as raw data in output"
:else " — non-renderable value would appear as text")))))
(define
render-body-audit
:effects ()
(fn
(values)
(let
((leaks (list)))
(for-each
(fn (v) (when (is-render-leak? v) (append! leaks {:leak-kind (cond (dict? v) "dict" (and (list? v) (not (empty? v)) (dict? (first v))) "list-of-dicts" :else "other") :value-type (type-of v)})))
values)
leaks)))
(define
assert-render-body-clean
:effects ()
(fn
(values label)
(let
((leaks (render-body-audit values)))
(assert
(empty? leaks)
(str
"Render body has "
(len leaks)
" leak(s) in "
label
". "
"render-to-html/render-to-dom render ALL body expressions — "
"put side effects in let bindings, not body expressions.")))))
(define
mock-render
:effects (mutation)
(fn
(expr)
(cond
(nil? expr)
nil
(string? expr)
(let ((el (mock-element "TEXT"))) (mock-set-text! el expr) el)
(number? expr)
(let ((el (mock-element "TEXT"))) (mock-set-text! el (str expr)) el)
(not (list? expr))
nil
(empty? expr)
nil
:else (let
((head (first expr)))
(if
(not (= (type-of head) "symbol"))
nil
(let
((el (mock-element (symbol-name head))))
(let
loop
((args (rest expr)))
(when
(not (empty? args))
(let
((arg (first args)))
(if
(= (type-of arg) "keyword")
(when
(not (empty? (rest args)))
(mock-set-attr! el (keyword-name arg) (nth args 1))
(loop (rest (rest args))))
(do
(let
((child-el (mock-render arg)))
(when child-el (mock-append-child! el child-el)))
(loop (rest args)))))))
el))))))
(define
mock-render-fragment
:effects (mutation)
(fn
(exprs)
(filter (fn (el) (not (nil? el))) (map mock-render exprs))))
(define
assert-single-render-root
:effects ()
(fn
(exprs label)
(let
((rendered (mock-render-fragment exprs)))
(assert
(= (len rendered) 1)
(str
"Expected single render root in "
label
" but got "
(len rendered)
" element(s). "
"Multi-body let/begin in render-to-html/render-to-dom renders "
"ALL expressions — put side effects in let bindings.")))))
(define
assert-tag
:effects ()
(fn
(el expected-tag)
(assert
(= (get el "tag") expected-tag)
(str "Expected <" expected-tag "> but got <" (get el "tag") ">"))))

41
shared/static/wasm/sx/harness.sx Normal file
View File

@@ -0,0 +1,41 @@
(define assert (fn (condition msg) (when (not condition) (error (or msg "Assertion failed")))))
(define assert= (fn (actual expected msg) (when (not (= actual expected)) (error (or msg (str "Expected " expected ", got " actual))))))
(define default-platform {:current-user (fn () nil) :csrf-token (fn () "test-csrf-token") :app-url (fn (service &rest path) "/mock-app-url") :frag (fn (service comp &rest args) "") :sleep (fn (ms) nil) :local-storage-set (fn (key val) nil) :set-cookie (fn (name val &rest opts) nil) :url-for (fn (endpoint &rest args) "/mock-url") :create-element (fn (tag) nil) :request-path (fn () "/") :config (fn (key) nil) :set-attr (fn (el name val) nil) :set-text (fn (el text) nil) :remove-child (fn (parent child) nil) :fetch (fn (url &rest opts) {:status 200 :body "" :ok true}) :query (fn (service name &rest args) (list)) :add-class (fn (el cls) nil) :get-element (fn (id) nil) :now (fn () 0) :abort (fn (code) nil) :action (fn (service name &rest args) {:ok true}) :remove-class (fn (el cls) nil) :append-child (fn (parent child) nil) :request-arg (fn (name) nil) :emit-dom (fn (op &rest args) nil) :local-storage-get (fn (key) nil) :get-cookie (fn (name) nil)})
(define make-harness :effects () (fn (&key platform) (let ((merged (if (nil? platform) default-platform (merge default-platform platform)))) {:log (list) :platform merged :state {:cookies {} :storage {} :dom nil}})))
(define harness-reset! :effects () (fn (session) (dict-set! session "log" (list)) (dict-set! session "state" {:cookies {} :storage {} :dom nil}) session))
(define harness-log :effects () (fn (session &key op) (let ((log (get session "log"))) (if (nil? op) log (filter (fn (entry) (= (get entry "op") op)) log)))))
(define harness-get :effects () (fn (session key) (get (get session "state") key)))
(define harness-set! :effects () (fn (session key value) (dict-set! (get session "state") key value) nil))
(define make-interceptor :effects () (fn (session op-name mock-fn) (fn (&rest args) (let ((result (if (empty? args) (mock-fn) (if (= 1 (len args)) (mock-fn (first args)) (if (= 2 (len args)) (mock-fn (first args) (nth args 1)) (if (= 3 (len args)) (mock-fn (first args) (nth args 1) (nth args 2)) (apply mock-fn args)))))) (log (get session "log"))) (append! log {:args args :result result :op op-name}) result))))
(define install-interceptors :effects () (fn (session env) (for-each (fn (key) (let ((mock-fn (get (get session "platform") key)) (interceptor (make-interceptor session key mock-fn))) (env-bind! env key interceptor))) (keys (get session "platform"))) env))
(define io-calls :effects () (fn (session op-name) (filter (fn (entry) (= (get entry "op") op-name)) (get session "log"))))
(define io-call-count :effects () (fn (session op-name) (len (io-calls session op-name))))
(define io-call-nth :effects () (fn (session op-name n) (let ((calls (io-calls session op-name))) (if (< n (len calls)) (nth calls n) nil))))
(define io-call-args :effects () (fn (session op-name n) (let ((call (io-call-nth session op-name n))) (if (nil? call) nil (get call "args")))))
(define io-call-result :effects () (fn (session op-name n) (let ((call (io-call-nth session op-name n))) (if (nil? call) nil (get call "result")))))
(define assert-io-called :effects () (fn (session op-name) (assert (> (io-call-count session op-name) 0) (str "Expected IO operation " op-name " to be called but it was not"))))
(define assert-no-io :effects () (fn (session op-name) (assert (= (io-call-count session op-name) 0) (str "Expected IO operation " op-name " not to be called but it was called " (io-call-count session op-name) " time(s)"))))
(define assert-io-count :effects () (fn (session op-name expected) (let ((actual (io-call-count session op-name))) (assert (= actual expected) (str "Expected " op-name " to be called " expected " time(s) but was called " actual " time(s)")))))
(define assert-io-args :effects () (fn (session op-name n expected-args) (let ((actual (io-call-args session op-name n))) (assert (equal? actual expected-args) (str "Expected call " n " to " op-name " with args " (str expected-args) " but got " (str actual))))))
(define assert-io-result :effects () (fn (session op-name n expected) (let ((actual (io-call-result session op-name n))) (assert (equal? actual expected) (str "Expected call " n " to " op-name " to return " (str expected) " but got " (str actual))))))
(define assert-state :effects () (fn (session key expected) (let ((actual (harness-get session key))) (assert (equal? actual expected) (str "Expected state " key " to be " (str expected) " but got " (str actual))))))

25
shared/static/wasm/sx/hypersx.sx Normal file
View File

@@ -0,0 +1,25 @@
(define hsx-indent (fn (depth) (let ((result "")) (for-each (fn (_) (set! result (str result " "))) (range 0 depth)) result)))
(define hsx-sym-name (fn (node) (if (= (type-of node) "symbol") (symbol-name node) nil)))
(define hsx-kw-name (fn (node) (if (= (type-of node) "keyword") (keyword-name node) nil)))
(define hsx-is-element? (fn (name) (and name (not (starts-with? name "~")) (is-html-tag? name))))
(define hsx-is-component? (fn (name) (and name (starts-with? name "~"))))
(define hsx-extract-css (fn (args) (let ((classes nil) (id nil) (rest-attrs (list)) (i 0) (n (len args))) (letrec ((walk (fn () (when (< i n) (let ((kn (hsx-kw-name (nth args i)))) (cond (= kn "class") (do (set! classes (nth args (+ i 1))) (set! i (+ i 2)) (walk)) (= kn "id") (do (set! id (nth args (+ i 1))) (set! i (+ i 2)) (walk)) kn (do (append! rest-attrs (nth args i)) (append! rest-attrs (nth args (+ i 1))) (set! i (+ i 2)) (walk)) :else nil)))))) (walk) (dict "classes" classes "id" id "attrs" rest-attrs "children" (if (< i n) (slice args i) (list)))))))
(define hsx-tag-str (fn (name css) (let ((s name) (cls (get css "classes")) (eid (get css "id"))) (when (and cls (string? cls)) (for-each (fn (c) (set! s (str s "." c))) (split cls " "))) (when eid (set! s (str s "#" eid))) s)))
(define hsx-atom (fn (node) (cond (nil? node) "nil" (string? node) (str "\"" node "\"") (number? node) (str node) (= (type-of node) "boolean") (if node "true" "false") (= (type-of node) "symbol") (str "{" (symbol-name node) "}") (= (type-of node) "keyword") (str ":" (keyword-name node)) :else (sx-serialize node))))
(define hsx-inline (fn (node) (cond (not (list? node)) (sx-serialize node) (empty? node) "()" :else (let ((hd (hsx-sym-name (first node)))) (cond (= hd "deref") (str "@" (sx-serialize (nth node 1))) (= hd "signal") (str "signal(" (if (> (len node) 1) (hsx-inline (nth node 1)) "") ")") (= hd "reset!") (str (sx-serialize (nth node 1)) " := " (hsx-inline (nth node 2))) (= hd "swap!") (str (sx-serialize (nth node 1)) " <- " (hsx-inline (nth node 2))) (= hd "str") (str "\"" (join "" (map (fn (a) (if (string? a) a (str "{" (hsx-inline a) "}"))) (rest node))) "\"") :else (str "(" (sx-serialize (first node)) (if (> (len node) 1) (str " " (join " " (map hsx-inline (rest node)))) "") ")"))))))
(define hsx-attrs-str (fn (attrs) (if (empty? attrs) "" (let ((parts (list)) (i 0)) (letrec ((walk (fn () (when (< i (len attrs)) (append! parts (str ":" (keyword-name (nth attrs i)) " " (hsx-atom (nth attrs (+ i 1))))) (set! i (+ i 2)) (walk))))) (walk)) (str " " (join " " parts))))))
(define hsx-children (fn (line kids depth) (if (empty? kids) line (if (and (= (len kids) 1) (not (list? (first kids)))) (str line " " (hsx-atom (first kids))) (str line "\n" (join "\n" (map (fn (c) (sx->hypersx-node c (+ depth 1))) kids)))))))
(define sx->hypersx-node (fn (node depth) (let ((pad (hsx-indent depth))) (cond (nil? node) (str pad "nil") (not (list? node)) (str pad (hsx-atom node)) (empty? node) (str pad "()") :else (let ((hd (hsx-sym-name (first node)))) (cond (= hd "str") (str pad (hsx-inline node)) (= hd "deref") (str pad (hsx-inline node)) (= hd "reset!") (str pad (hsx-inline node)) (= hd "swap!") (str pad (hsx-inline node)) (= hd "signal") (str pad (hsx-inline node)) (or (= hd "defcomp") (= hd "defisland")) (str pad hd " " (sx-serialize (nth node 1)) " " (sx-serialize (nth node 2)) "\n" (sx->hypersx-node (last node) (+ depth 1))) (= hd "when") (str pad "when " (hsx-inline (nth node 1)) "\n" (join "\n" (map (fn (c) (sx->hypersx-node c (+ depth 1))) (slice node 2)))) (= hd "if") (let ((test (nth node 1)) (then-b (nth node 2)) (else-b (if (> (len node) 3) (nth node 3) nil))) (if (and (not (list? then-b)) (or (nil? else-b) (not (list? else-b)))) (str pad "if " (hsx-inline test) " " (hsx-atom then-b) (if else-b (str " " (hsx-atom else-b)) "")) (str pad "if " (hsx-inline test) "\n" (sx->hypersx-node then-b (+ depth 1)) (if else-b (str "\n" pad "else\n" (sx->hypersx-node else-b (+ depth 1))) "")))) (or (= hd "let") (= hd "letrec") (= hd "let*")) (let ((binds (nth node 1)) (body (slice node 2))) (str pad hd " " (join ", " (map (fn (b) (if (and (list? b) (>= (len b) 2)) (str (sx-serialize (first b)) " = " (hsx-inline (nth b 1))) (sx-serialize b))) (if (and (list? binds) (not (empty? binds)) (list? (first binds))) binds (list binds)))) "\n" (join "\n" (map (fn (b) (sx->hypersx-node b (+ depth 1))) body)))) (and (= hd "map") (= (len node) 3) (list? (nth node 1)) (= (hsx-sym-name (first (nth node 1))) "fn")) (let ((fn-node (nth node 1)) (coll (nth node 2))) (str pad "map " (hsx-inline coll) " -> " (sx-serialize (nth fn-node 1)) "\n" (sx->hypersx-node (last fn-node) (+ depth 1)))) (and (= hd "for-each") (= (len node) 3) (list? (nth node 1)) (= (hsx-sym-name (first (nth node 1))) "fn")) (let ((fn-node (nth node 1)) (coll (nth node 2))) (str pad "for " (sx-serialize (nth fn-node 1)) " in " (hsx-inline coll) "\n" (sx->hypersx-node (last fn-node) (+ depth 1)))) (hsx-is-element? hd) (let ((css (hsx-extract-css (rest node)))) (hsx-children (str pad (hsx-tag-str hd css) (hsx-attrs-str (get css "attrs"))) (get css "children") depth)) (hsx-is-component? hd) (let ((css (hsx-extract-css (rest node)))) (hsx-children (str pad hd (hsx-attrs-str (get css "attrs"))) (get css "children") depth)) :else (str pad (sx-serialize node))))))))
(define sx->hypersx (fn (tree) (join "\n\n" (map (fn (expr) (sx->hypersx-node expr 0)) tree))))

368
shared/static/wasm/sx/page-helpers.sx Normal file
View File

@@ -0,0 +1,368 @@
;; ==========================================================================
;; page-helpers.sx — Pure data-transformation page helpers
;;
;; These functions take raw data (from Python I/O edge) and return
;; structured dicts for page rendering. No I/O — pure transformations
;; only. Bootstrapped to every host.
;; ==========================================================================
;; --------------------------------------------------------------------------
;; categorize-special-forms
;;
;; Parses define-special-form declarations from special-forms.sx AST,
;; categorizes each form by name lookup, returns dict of category → forms.
;; --------------------------------------------------------------------------
(define special-form-category-map
{"if" "Control Flow" "when" "Control Flow" "cond" "Control Flow"
"case" "Control Flow" "and" "Control Flow" "or" "Control Flow"
"let" "Binding" "let*" "Binding" "letrec" "Binding"
"define" "Binding" "set!" "Binding"
"lambda" "Functions & Components" "fn" "Functions & Components"
"defcomp" "Functions & Components" "defmacro" "Functions & Components"
"begin" "Sequencing & Threading" "do" "Sequencing & Threading"
"->" "Sequencing & Threading"
"quote" "Quoting" "quasiquote" "Quoting"
"reset" "Continuations" "shift" "Continuations"
"dynamic-wind" "Guards"
"map" "Higher-Order Forms" "map-indexed" "Higher-Order Forms"
"filter" "Higher-Order Forms" "reduce" "Higher-Order Forms"
"some" "Higher-Order Forms" "every?" "Higher-Order Forms"
"for-each" "Higher-Order Forms"
"defstyle" "Domain Definitions"
"defhandler" "Domain Definitions" "defpage" "Domain Definitions"
"defquery" "Domain Definitions" "defaction" "Domain Definitions"})
(define extract-define-kwargs
(fn ((expr :as list))
;; Extract keyword args from a define-special-form expression.
;; Returns dict of keyword-name → string value.
;; Walks items pairwise: when item[i] is a keyword, item[i+1] is its value.
(let ((result {})
(items (slice expr 2))
(n (len items)))
(for-each
(fn ((idx :as number))
(when (and (< (+ idx 1) n)
(= (type-of (nth items idx)) "keyword"))
(let ((key (keyword-name (nth items idx)))
(val (nth items (+ idx 1))))
(dict-set! result key
(if (= (type-of val) "list")
(str "(" (join " " (map serialize val)) ")")
(str val))))))
(range 0 n))
result)))
(define categorize-special-forms
(fn ((parsed-exprs :as list))
;; parsed-exprs: result of parse-all on special-forms.sx
;; Returns dict of category-name → list of form dicts.
(let ((categories {}))
(for-each
(fn (expr)
(when (and (= (type-of expr) "list")
(>= (len expr) 2)
(= (type-of (first expr)) "symbol")
(= (symbol-name (first expr)) "define-special-form"))
(let ((name (nth expr 1))
(kwargs (extract-define-kwargs expr))
(category (or (get special-form-category-map name) "Other")))
(when (not (has-key? categories category))
(dict-set! categories category (list)))
(append! (get categories category)
{"name" name
"syntax" (or (get kwargs "syntax") "")
"doc" (or (get kwargs "doc") "")
"tail-position" (or (get kwargs "tail-position") "")
"example" (or (get kwargs "example") "")}))))
parsed-exprs)
categories)))
;; --------------------------------------------------------------------------
;; build-reference-data
;;
;; Takes a slug and raw reference data, returns structured dict for rendering.
;; --------------------------------------------------------------------------
(define build-ref-items-with-href
(fn ((items :as list) (base-path :as string) (detail-keys :as list) (n-fields :as number))
;; items: list of lists (tuples), each with n-fields elements
;; base-path: e.g. "/geography/hypermedia/reference/attributes/"
;; detail-keys: list of strings (keys that have detail pages)
;; n-fields: 2 or 3 (number of fields per tuple)
(map
(fn ((item :as list))
(if (= n-fields 3)
;; [name, desc/value, exists/desc]
(let ((name (nth item 0))
(field2 (nth item 1))
(field3 (nth item 2)))
{"name" name
"desc" field2
"exists" field3
"href" (if (and field3 (some (fn ((k :as string)) (= k name)) detail-keys))
(str base-path name)
nil)})
;; [name, desc]
(let ((name (nth item 0))
(desc (nth item 1)))
{"name" name
"desc" desc
"href" (if (some (fn ((k :as string)) (= k name)) detail-keys)
(str base-path name)
nil)})))
items)))
(define build-reference-data
(fn ((slug :as string) (raw-data :as dict) (detail-keys :as list))
;; slug: "attributes", "headers", "events", "js-api"
;; raw-data: dict with the raw data lists for this slug
;; detail-keys: list of names that have detail pages
(case slug
"attributes"
{"req-attrs" (build-ref-items-with-href
(get raw-data "req-attrs")
"/geography/hypermedia/reference/attributes/" detail-keys 3)
"beh-attrs" (build-ref-items-with-href
(get raw-data "beh-attrs")
"/geography/hypermedia/reference/attributes/" detail-keys 3)
"uniq-attrs" (build-ref-items-with-href
(get raw-data "uniq-attrs")
"/geography/hypermedia/reference/attributes/" detail-keys 3)}
"headers"
{"req-headers" (build-ref-items-with-href
(get raw-data "req-headers")
"/geography/hypermedia/reference/headers/" detail-keys 3)
"resp-headers" (build-ref-items-with-href
(get raw-data "resp-headers")
"/geography/hypermedia/reference/headers/" detail-keys 3)}
"events"
{"events-list" (build-ref-items-with-href
(get raw-data "events-list")
"/geography/hypermedia/reference/events/" detail-keys 2)}
"js-api"
{"js-api-list" (map (fn ((item :as list)) {"name" (nth item 0) "desc" (nth item 1)})
(get raw-data "js-api-list"))}
;; default: attributes
:else
{"req-attrs" (build-ref-items-with-href
(get raw-data "req-attrs")
"/geography/hypermedia/reference/attributes/" detail-keys 3)
"beh-attrs" (build-ref-items-with-href
(get raw-data "beh-attrs")
"/geography/hypermedia/reference/attributes/" detail-keys 3)
"uniq-attrs" (build-ref-items-with-href
(get raw-data "uniq-attrs")
"/geography/hypermedia/reference/attributes/" detail-keys 3)})))
;; --------------------------------------------------------------------------
;; build-attr-detail / build-header-detail / build-event-detail
;;
;; Lookup a slug in a detail dict, reshape for page rendering.
;; --------------------------------------------------------------------------
(define build-attr-detail
(fn ((slug :as string) detail)
;; detail: dict with "description", "example", "handler", "demo" keys or nil
(if (nil? detail)
{"attr-not-found" true}
{"attr-not-found" nil
"attr-title" slug
"attr-description" (get detail "description")
"attr-example" (get detail "example")
"attr-handler" (get detail "handler")
"attr-demo" (get detail "demo")
"attr-wire-id" (if (has-key? detail "handler")
(str "ref-wire-"
(replace (replace slug ":" "-") "*" "star"))
nil)})))
(define build-header-detail
(fn ((slug :as string) detail)
(if (nil? detail)
{"header-not-found" true}
{"header-not-found" nil
"header-title" slug
"header-direction" (get detail "direction")
"header-description" (get detail "description")
"header-example" (get detail "example")
"header-demo" (get detail "demo")})))
(define build-event-detail
(fn ((slug :as string) detail)
(if (nil? detail)
{"event-not-found" true}
{"event-not-found" nil
"event-title" slug
"event-description" (get detail "description")
"event-example" (get detail "example")
"event-demo" (get detail "demo")})))
;; --------------------------------------------------------------------------
;; build-component-source
;;
;; Reconstruct defcomp/defisland source from component metadata.
;; --------------------------------------------------------------------------
(define build-component-source
(fn ((comp-data :as dict))
;; comp-data: dict with "type", "name", "params", "has-children", "body-sx", "affinity"
(let ((comp-type (get comp-data "type"))
(name (get comp-data "name"))
(params (get comp-data "params"))
(has-children (get comp-data "has-children"))
(body-sx (get comp-data "body-sx"))
(affinity (get comp-data "affinity")))
(if (= comp-type "not-found")
(str ";; component " name " not found")
(let ((param-strs (if (empty? params)
(if has-children
(list "&rest" "children")
(list))
(if has-children
(append (cons "&key" params) (list "&rest" "children"))
(cons "&key" params))))
(params-sx (str "(" (join " " param-strs) ")"))
(form-name (if (= comp-type "island") "defisland" "defcomp"))
(affinity-str (if (and (= comp-type "component")
(not (nil? affinity))
(not (= affinity "auto")))
(str " :affinity " affinity)
"")))
(str "(" form-name " " name " " params-sx affinity-str "\n " body-sx ")"))))))
;; --------------------------------------------------------------------------
;; build-bundle-analysis
;;
;; Compute per-page bundle stats from pre-extracted component data.
;; --------------------------------------------------------------------------
(define build-bundle-analysis
(fn ((pages-raw :as list) (components-raw :as dict) (total-components :as number) (total-macros :as number) (pure-count :as number) (io-count :as number))
;; pages-raw: list of {:name :path :direct :needed-names}
;; components-raw: dict of name → {:is-pure :affinity :render-target :io-refs :deps :source}
(let ((pages-data (list)))
(for-each
(fn ((page :as dict))
(let ((needed-names (get page "needed-names"))
(n (len needed-names))
(pct (if (> total-components 0)
(round (* (/ n total-components) 100))
0))
(savings (- 100 pct))
(pure-in-page 0)
(io-in-page 0)
(page-io-refs (list))
(comp-details (list)))
;; Walk needed components
(for-each
(fn ((comp-name :as string))
(let ((info (get components-raw comp-name)))
(when (not (nil? info))
(if (get info "is-pure")
(set! pure-in-page (+ pure-in-page 1))
(do
(set! io-in-page (+ io-in-page 1))
(for-each
(fn ((ref :as string)) (when (not (some (fn ((r :as string)) (= r ref)) page-io-refs))
(append! page-io-refs ref)))
(or (get info "io-refs") (list)))))
(append! comp-details
{"name" comp-name
"is-pure" (get info "is-pure")
"affinity" (get info "affinity")
"render-target" (get info "render-target")
"io-refs" (or (get info "io-refs") (list))
"deps" (or (get info "deps") (list))
"source" (get info "source")}))))
needed-names)
(append! pages-data
{"name" (get page "name")
"path" (get page "path")
"direct" (get page "direct")
"needed" n
"pct" pct
"savings" savings
"io-refs" (len page-io-refs)
"pure-in-page" pure-in-page
"io-in-page" io-in-page
"components" comp-details})))
pages-raw)
{"pages" pages-data
"total-components" total-components
"total-macros" total-macros
"pure-count" pure-count
"io-count" io-count})))
;; --------------------------------------------------------------------------
;; build-routing-analysis
;;
;; Classify pages by routing mode (client vs server).
;; --------------------------------------------------------------------------
(define build-routing-analysis
(fn ((pages-raw :as list))
;; pages-raw: list of {:name :path :has-data :content-src}
(let ((pages-data (list))
(client-count 0)
(server-count 0))
(for-each
(fn ((page :as dict))
(let ((has-data (get page "has-data"))
(content-src (or (get page "content-src") ""))
(mode nil)
(reason ""))
(cond
has-data
(do (set! mode "server")
(set! reason "Has :data expression — needs server IO")
(set! server-count (+ server-count 1)))
(empty? content-src)
(do (set! mode "server")
(set! reason "No content expression")
(set! server-count (+ server-count 1)))
:else
(do (set! mode "client")
(set! client-count (+ client-count 1))))
(append! pages-data
{"name" (get page "name")
"path" (get page "path")
"mode" mode
"has-data" has-data
"content-expr" (if (> (len content-src) 80)
(str (slice content-src 0 80) "...")
content-src)
"reason" reason})))
pages-raw)
{"pages" pages-data
"total-pages" (+ client-count server-count)
"client-count" client-count
"server-count" server-count})))
;; --------------------------------------------------------------------------
;; build-affinity-analysis
;;
;; Package component affinity info + page render plans for display.
;; --------------------------------------------------------------------------
(define build-affinity-analysis
(fn ((demo-components :as list) (page-plans :as list))
{"components" demo-components
"page-plans" page-plans}))

297
shared/static/wasm/sx/render.sx Normal file
View File

@@ -0,0 +1,297 @@
;; ==========================================================================
;; render.sx — Core rendering specification
;;
;; Shared registries and utilities used by all rendering adapters.
;; This file defines WHAT is renderable (tag registries, attribute rules)
;; and HOW arguments are parsed — but not the output format.
;;
;; Adapters:
;; adapter-html.sx — HTML string output (server)
;; adapter-sx.sx — SX wire format output (server → client)
;; adapter-dom.sx — Live DOM node output (browser)
;;
;; Each adapter imports these shared definitions and provides its own
;; render entry point (render-to-html, render-to-sx, render-to-dom).
;; ==========================================================================
;; --------------------------------------------------------------------------
;; HTML tag registry
;; --------------------------------------------------------------------------
;; Tags known to the renderer. Unknown names are treated as function calls.
;; Void elements self-close (no children). Boolean attrs emit name only.
(define HTML_TAGS
(list
;; Document
"html" "head" "body" "title" "meta" "link" "script" "style" "noscript"
;; Sections
"header" "nav" "main" "section" "article" "aside" "footer"
"h1" "h2" "h3" "h4" "h5" "h6" "hgroup"
;; Block
"div" "p" "blockquote" "pre" "figure" "figcaption" "address" "details" "summary"
;; Inline
"a" "span" "em" "strong" "small" "b" "i" "u" "s" "mark" "sub" "sup"
"abbr" "cite" "code" "kbd" "samp" "var" "time" "br" "wbr" "hr"
;; Lists
"ul" "ol" "li" "dl" "dt" "dd"
;; Tables
"table" "thead" "tbody" "tfoot" "tr" "th" "td" "caption" "colgroup" "col"
;; Forms
"form" "input" "textarea" "select" "option" "optgroup" "button" "label"
"fieldset" "legend" "output" "datalist"
;; Media
"img" "video" "audio" "source" "picture" "canvas" "iframe"
;; SVG
"svg" "math" "path" "circle" "ellipse" "rect" "line" "polyline" "polygon"
"text" "tspan" "g" "defs" "use" "clipPath" "mask" "pattern"
"linearGradient" "radialGradient" "stop" "filter"
"feGaussianBlur" "feOffset" "feBlend" "feColorMatrix" "feComposite"
"feMerge" "feMergeNode" "feTurbulence"
"feComponentTransfer" "feFuncR" "feFuncG" "feFuncB" "feFuncA"
"feDisplacementMap" "feFlood" "feImage" "feMorphology"
"feSpecularLighting" "feDiffuseLighting"
"fePointLight" "feSpotLight" "feDistantLight"
"animate" "animateTransform" "foreignObject"
;; Other
"template" "slot" "dialog" "menu"))
(define VOID_ELEMENTS
(list "area" "base" "br" "col" "embed" "hr" "img" "input"
"link" "meta" "param" "source" "track" "wbr"))
(define BOOLEAN_ATTRS
(list "async" "autofocus" "autoplay" "checked" "controls" "default"
"defer" "disabled" "formnovalidate" "hidden" "inert" "ismap"
"loop" "multiple" "muted" "nomodule" "novalidate" "open"
"playsinline" "readonly" "required" "reversed" "selected"))
;; --------------------------------------------------------------------------
;; Shared utilities
;; --------------------------------------------------------------------------
;; Extension point for definition forms — modules append names here.
;; Survives spec reloads (no function wrapping needed).
(define *definition-form-extensions* (list))
(define definition-form? :effects []
(fn ((name :as string))
(or (= name "define") (= name "defcomp") (= name "defisland")
(= name "defmacro") (= name "defstyle")
(= name "deftype") (= name "defeffect")
(contains? *definition-form-extensions* name))))
(define parse-element-args :effects [render]
(fn ((args :as list) (env :as dict))
;; Parse (:key val :key2 val2 child1 child2) into (attrs-dict children-list)
(let ((attrs (dict))
(children (list)))
(reduce
(fn ((state :as dict) arg)
(let ((skip (get state "skip")))
(if skip
(assoc state "skip" false "i" (inc (get state "i")))
(if (and (= (type-of arg) "keyword")
(< (inc (get state "i")) (len args)))
(let ((val (trampoline (eval-expr (nth args (inc (get state "i"))) env))))
(dict-set! attrs (keyword-name arg) val)
(assoc state "skip" true "i" (inc (get state "i"))))
(do
(append! children arg)
(assoc state "i" (inc (get state "i"))))))))
(dict "i" 0 "skip" false)
args)
(list attrs children))))
(define render-attrs :effects []
(fn ((attrs :as dict))
;; Render an attrs dict to an HTML attribute string.
;; Used by adapter-html.sx and adapter-sx.sx.
(join ""
(map
(fn ((key :as string))
(let ((val (dict-get attrs key)))
(cond
;; Boolean attrs
(and (contains? BOOLEAN_ATTRS key) val)
(str " " key)
(and (contains? BOOLEAN_ATTRS key) (not val))
""
;; Nil values — skip
(nil? val) ""
;; Normal attr
:else (str " " key "=\"" (escape-attr (str val)) "\""))))
(keys attrs)))))
;; --------------------------------------------------------------------------
;; Render adapter helpers
;; --------------------------------------------------------------------------
;; Shared by HTML and DOM adapters for evaluating control forms during
;; rendering. Unlike sf-cond (eval.sx) which returns a thunk for TCO,
;; eval-cond returns the unevaluated body expression so the adapter
;; can render it in its own mode (HTML string vs DOM nodes).
;; eval-cond: find matching cond branch, return unevaluated body expr.
;; Handles both scheme-style ((test body) ...) and clojure-style
;; (test body test body ...).
(define eval-cond :effects []
(fn ((clauses :as list) (env :as dict))
(if (cond-scheme? clauses)
(eval-cond-scheme clauses env)
(eval-cond-clojure clauses env))))
(define eval-cond-scheme :effects []
(fn ((clauses :as list) (env :as dict))
(if (empty? clauses)
nil
(let ((clause (first clauses))
(test (first clause))
(body (nth clause 1)))
(if (is-else-clause? test)
body
(if (trampoline (eval-expr test env))
body
(eval-cond-scheme (rest clauses) env)))))))
(define eval-cond-clojure :effects []
(fn ((clauses :as list) (env :as dict))
(if (< (len clauses) 2)
nil
(let ((test (first clauses))
(body (nth clauses 1)))
(if (is-else-clause? test)
body
(if (trampoline (eval-expr test env))
body
(eval-cond-clojure (slice clauses 2) env)))))))
;; process-bindings: evaluate let-binding pairs, return extended env.
;; bindings = ((name1 expr1) (name2 expr2) ...)
(define process-bindings :effects [mutation]
(fn ((bindings :as list) (env :as dict))
;; env-extend (not merge) — Env is not a dict subclass, so merge()
;; returns an empty dict, losing all parent scope bindings.
(let ((local (env-extend env)))
(for-each
(fn ((pair :as list))
(when (and (= (type-of pair) "list") (>= (len pair) 2))
(let ((name (if (= (type-of (first pair)) "symbol")
(symbol-name (first pair))
(str (first pair)))))
(env-bind! local name (trampoline (eval-expr (nth pair 1) local))))))
bindings)
local)))
;; --------------------------------------------------------------------------
;; is-render-expr? — check if expression is a rendering form
;; --------------------------------------------------------------------------
;; Used by eval-list to dispatch rendering forms to the active adapter
;; (HTML, SX wire, or DOM) rather than evaluating them as function calls.
(define is-render-expr? :effects []
(fn (expr)
(if (or (not (= (type-of expr) "list")) (empty? expr))
false
(let ((h (first expr)))
(if (not (= (type-of h) "symbol"))
false
(let ((n (symbol-name h)))
(or (= n "<>")
(= n "raw!")
(starts-with? n "~")
(starts-with? n "html:")
(contains? HTML_TAGS n)
(and (> (index-of n "-") 0)
(> (len expr) 1)
(= (type-of (nth expr 1)) "keyword")))))))))
;; --------------------------------------------------------------------------
;; Spread — attribute injection from children into parent elements
;; --------------------------------------------------------------------------
;;
;; A spread value is a dict of attributes that, when returned as a child
;; of an HTML element, merges its attrs onto the parent element.
;; This enables components to inject classes/styles/data-attrs onto their
;; parent without the parent knowing about the specific attrs.
;;
;; merge-spread-attrs: merge a spread's attrs into an element's attrs dict.
;; Class values are joined (space-separated); others overwrite.
;; Mutates the target attrs dict in place.
(define merge-spread-attrs :effects [mutation]
(fn ((target :as dict) (spread-dict :as dict))
(for-each
(fn ((key :as string))
(let ((val (dict-get spread-dict key)))
(if (= key "class")
;; Class: join existing + new with space
(let ((existing (dict-get target "class")))
(dict-set! target "class"
(if (and existing (not (= existing "")))
(str existing " " val)
val)))
;; Style: join with semicolons
(if (= key "style")
(let ((existing (dict-get target "style")))
(dict-set! target "style"
(if (and existing (not (= existing "")))
(str existing ";" val)
val)))
;; Everything else: overwrite
(dict-set! target key val)))))
(keys spread-dict))))
;; --------------------------------------------------------------------------
;; HTML escaping — library functions (pure text processing)
;; --------------------------------------------------------------------------
(define escape-html
(fn (s)
(let ((r (str s)))
(set! r (replace r "&" "&amp;"))
(set! r (replace r "<" "&lt;"))
(set! r (replace r ">" "&gt;"))
(set! r (replace r "\"" "&quot;"))
r)))
(define escape-attr
(fn (s)
(escape-html s)))
;; --------------------------------------------------------------------------
;; Platform interface (shared across adapters)
;; --------------------------------------------------------------------------
;;
;; Raw HTML (marker type for unescaped content):
;; (raw-html-content r) → unwrap RawHTML marker to string
;;
;; Spread (render-time attribute injection):
;; (make-spread attrs) → Spread value
;; (spread? x) → boolean
;; (spread-attrs s) → dict
;;
;; Render-time accumulators:
;; (collect! bucket value) → void
;; (collected bucket) → list
;; (clear-collected! bucket) → void
;;
;; Scoped effects (scope/provide/context/emit!):
;; (scope-push! name val) → void (general form)
;; (scope-pop! name) → void (general form)
;; (provide-push! name val) → alias for scope-push!
;; (provide-pop! name) → alias for scope-pop!
;; (context name &rest def) → value from nearest scope
;; (emit! name value) → void (append to scope accumulator)
;; (emitted name) → list of emitted values
;;
;; From parser.sx:
;; (sx-serialize val) → SX source string (aliased as serialize above)
;; --------------------------------------------------------------------------

680
shared/static/wasm/sx/router.sx Normal file
View File

@@ -0,0 +1,680 @@
;; ==========================================================================
;; router.sx — Client-side route matching specification
;;
;; Pure functions for matching URL paths against Flask-style route patterns.
;; Used by client-side routing to determine if a page can be rendered
;; locally without a server roundtrip.
;;
;; All functions are pure — no IO, no platform-specific operations.
;; Uses only primitives from primitives.sx (string ops, list ops).
;; ==========================================================================
;; --------------------------------------------------------------------------
;; 1. Split path into segments
;; --------------------------------------------------------------------------
;; "/docs/hello" → ("docs" "hello")
;; "/" → ()
;; "/docs/" → ("docs")
(define split-path-segments :effects []
(fn ((path :as string))
(let ((trimmed (if (starts-with? path "/") (slice path 1) path)))
(let ((trimmed2 (if (and (not (empty? trimmed))
(ends-with? trimmed "/"))
(slice trimmed 0 (- (len trimmed) 1))
trimmed)))
(if (empty? trimmed2)
(list)
(split trimmed2 "/"))))))
;; --------------------------------------------------------------------------
;; 2. Parse Flask-style route pattern into segment descriptors
;; --------------------------------------------------------------------------
;; "/docs/<slug>" → ({"type" "literal" "value" "docs"}
;; {"type" "param" "value" "slug"})
(define make-route-segment :effects []
(fn ((seg :as string))
(if (and (starts-with? seg "<") (ends-with? seg ">"))
(let ((param-name (slice seg 1 (- (len seg) 1))))
(let ((d {}))
(dict-set! d "type" "param")
(dict-set! d "value" param-name)
d))
(let ((d {}))
(dict-set! d "type" "literal")
(dict-set! d "value" seg)
d))))
(define parse-route-pattern :effects []
(fn ((pattern :as string))
(let ((segments (split-path-segments pattern)))
(map make-route-segment segments))))
;; --------------------------------------------------------------------------
;; 3. Match path segments against parsed pattern
;; --------------------------------------------------------------------------
;; Returns params dict if match, nil if no match.
(define match-route-segments :effects []
(fn ((path-segs :as list) (parsed-segs :as list))
(if (not (= (len path-segs) (len parsed-segs)))
nil
(let ((params {})
(matched true))
(for-each-indexed
(fn ((i :as number) (parsed-seg :as dict))
(when matched
(let ((path-seg (nth path-segs i))
(seg-type (get parsed-seg "type")))
(cond
(= seg-type "literal")
(when (not (= path-seg (get parsed-seg "value")))
(set! matched false))
(= seg-type "param")
(dict-set! params (get parsed-seg "value") path-seg)
:else
(set! matched false)))))
parsed-segs)
(if matched params nil)))))
;; --------------------------------------------------------------------------
;; 4. Public API: match a URL path against a pattern string
;; --------------------------------------------------------------------------
;; Returns params dict (may be empty for exact matches) or nil.
(define match-route :effects []
(fn ((path :as string) (pattern :as string))
(let ((path-segs (split-path-segments path))
(parsed-segs (parse-route-pattern pattern)))
(match-route-segments path-segs parsed-segs))))
;; --------------------------------------------------------------------------
;; 5. Search a list of route entries for first match
;; --------------------------------------------------------------------------
;; Each entry: {"pattern" "/docs/<slug>" "parsed" [...] "name" "docs-page" ...}
;; Returns matching entry with "params" added, or nil.
(define find-matching-route :effects []
(fn ((path :as string) (routes :as list))
;; If path is an SX expression URL, convert to old-style for matching.
(let ((match-path (if (starts-with? path "/(")
(or (sx-url-to-path path) path)
path)))
(let ((path-segs (split-path-segments match-path))
(result nil))
(for-each
(fn ((route :as dict))
(when (nil? result)
(let ((params (match-route-segments path-segs (get route "parsed"))))
(when (not (nil? params))
(let ((matched (merge route {})))
(dict-set! matched "params" params)
(set! result matched))))))
routes)
result))))
;; --------------------------------------------------------------------------
;; 6. SX expression URL → old-style path conversion
;; --------------------------------------------------------------------------
;; Converts /(language.(doc.introduction)) → /language/docs/introduction
;; so client-side routing can match SX URLs against Flask-style patterns.
(define _fn-to-segment :effects []
(fn ((name :as string))
(case name
"doc" "docs"
"spec" "specs"
"bootstrapper" "bootstrappers"
"test" "testing"
"example" "examples"
"protocol" "protocols"
"essay" "essays"
"plan" "plans"
"reference-detail" "reference"
:else name)))
(define sx-url-to-path :effects []
(fn ((url :as string))
;; Convert an SX expression URL to an old-style slash path.
;; "/(language.(doc.introduction))" → "/language/docs/introduction"
;; Returns nil for non-SX URLs (those not starting with "/(" ).
(if (not (and (starts-with? url "/(") (ends-with? url ")")))
nil
(let ((inner (slice url 2 (- (len url) 1))))
;; "language.(doc.introduction)" → dots to slashes, strip parens
(let ((s (replace (replace (replace inner "." "/") "(" "") ")" "")))
;; "language/doc/introduction" → split, map names, rejoin
(let ((segs (filter (fn (s) (not (empty? s))) (split s "/"))))
(str "/" (join "/" (map _fn-to-segment segs)))))))))
;; --------------------------------------------------------------------------
;; 7. Relative SX URL resolution
;; --------------------------------------------------------------------------
;; Resolves relative SX URLs against the current absolute URL.
;; This is a macro in the deepest sense: SX transforming SX into SX.
;; The URL is code. Relative resolution is code transformation.
;;
;; Relative URLs start with ( or . :
;; (.slug) → append slug as argument to innermost call
;; (..section) → up 1: replace innermost with new nested call
;; (...section) → up 2: replace 2 innermost levels
;;
;; Bare-dot shorthand (parens optional):
;; .slug → same as (.slug)
;; .. → same as (..) — go up one level
;; ... → same as (...) — go up two levels
;; .:page.4 → same as (.:page.4) — set keyword
;;
;; Dot count semantics (parallels filesystem . and ..):
;; 1 dot = current level (append argument / modify keyword)
;; 2 dots = up 1 level (sibling call)
;; 3 dots = up 2 levels
;; N dots = up N-1 levels
;;
;; Keyword operations (set, delta):
;; (.:page.4) → set :page to 4 at current level
;; (.:page.+1) → increment :page by 1 (delta)
;; (.:page.-1) → decrement :page by 1 (delta)
;; (.slug.:page.1) → append slug AND set :page=1
;;
;; Examples (current = "/(geography.(hypermedia.(example)))"):
;; (.progress-bar) → /(geography.(hypermedia.(example.progress-bar)))
;; (..reactive.demo) → /(geography.(hypermedia.(reactive.demo)))
;; (...marshes) → /(geography.(marshes))
;; (..) → /(geography.(hypermedia))
;; (...) → /(geography)
;;
;; Keyword examples (current = "/(language.(spec.(explore.signals.:page.3)))"):
;; (.:page.4) → /(language.(spec.(explore.signals.:page.4)))
;; (.:page.+1) → /(language.(spec.(explore.signals.:page.4)))
;; (.:page.-1) → /(language.(spec.(explore.signals.:page.2)))
;; (..eval) → /(language.(spec.(eval)))
;; (..eval.:page.1) → /(language.(spec.(eval.:page.1)))
(define _count-leading-dots :effects []
(fn ((s :as string))
(if (empty? s)
0
(if (starts-with? s ".")
(+ 1 (_count-leading-dots (slice s 1)))
0))))
(define _strip-trailing-close :effects []
(fn ((s :as string))
;; Strip trailing ) characters: "/(a.(b.(c" from "/(a.(b.(c)))"
(if (ends-with? s ")")
(_strip-trailing-close (slice s 0 (- (len s) 1)))
s)))
(define _index-of-safe :effects []
(fn ((s :as string) (needle :as string))
;; Wrapper around index-of that normalizes -1 to nil.
;; (index-of returns -1 on some platforms, nil on others.)
(let ((idx (index-of s needle)))
(if (or (nil? idx) (< idx 0)) nil idx))))
(define _last-index-of :effects []
(fn ((s :as string) (needle :as string))
;; Find the last occurrence of needle in s. Returns nil if not found.
(let ((idx (_index-of-safe s needle)))
(if (nil? idx)
nil
(let ((rest-idx (_last-index-of (slice s (+ idx 1)) needle)))
(if (nil? rest-idx)
idx
(+ (+ idx 1) rest-idx)))))))
(define _pop-sx-url-level :effects []
(fn ((url :as string))
;; Remove the innermost nesting level from an absolute SX URL.
;; "/(a.(b.(c)))" → "/(a.(b))"
;; "/(a.(b))" → "/(a)"
;; "/(a)" → "/"
(let ((stripped (_strip-trailing-close url))
(close-count (- (len url) (len (_strip-trailing-close url)))))
(if (<= close-count 1)
"/" ;; at root, popping goes to bare root
(let ((last-dp (_last-index-of stripped ".(")))
(if (nil? last-dp)
"/" ;; single-level URL, pop to root
;; Remove from .( to end of stripped, drop one closing paren
(str (slice stripped 0 last-dp)
(slice url (- (len url) (- close-count 1))))))))))
(define _pop-sx-url-levels :effects []
(fn ((url :as string) (n :as number))
(if (<= n 0)
url
(_pop-sx-url-levels (_pop-sx-url-level url) (- n 1)))))
;; --------------------------------------------------------------------------
;; 8. Relative URL body parsing — positional vs keyword tokens
;; --------------------------------------------------------------------------
;; Body "slug.:page.4" → positional "slug", keywords ((:page 4))
;; Body ":page.+1" → positional "", keywords ((:page +1))
(define _split-pos-kw :effects []
(fn ((tokens :as list) (i :as number) (pos :as list) (kw :as list))
;; Walk tokens: non-: tokens are positional, : tokens consume next as value
(if (>= i (len tokens))
{"positional" (join "." pos) "keywords" kw}
(let ((tok (nth tokens i)))
(if (starts-with? tok ":")
;; Keyword: take this + next token as a pair
(let ((val (if (< (+ i 1) (len tokens))
(nth tokens (+ i 1))
"")))
(_split-pos-kw tokens (+ i 2) pos
(append kw (list (list tok val)))))
;; Positional token
(_split-pos-kw tokens (+ i 1)
(append pos (list tok))
kw))))))
(define _parse-relative-body :effects []
(fn ((body :as string))
;; Returns {"positional" <string> "keywords" <list of (kw val) pairs>}
(if (empty? body)
{"positional" "" "keywords" (list)}
(_split-pos-kw (split body ".") 0 (list) (list)))))
;; --------------------------------------------------------------------------
;; 9. Keyword operations on URL expressions
;; --------------------------------------------------------------------------
;; Extract, find, and modify keyword arguments in the innermost expression.
(define _extract-innermost :effects []
(fn ((url :as string))
;; Returns {"before" ... "content" ... "suffix" ...}
;; where before + content + suffix = url
;; content = the innermost expression's dot-separated tokens
(let ((stripped (_strip-trailing-close url))
(suffix (slice url (len (_strip-trailing-close url)))))
(let ((last-dp (_last-index-of stripped ".(")))
(if (nil? last-dp)
;; Single-level: /(content)
{"before" "/("
"content" (slice stripped 2)
"suffix" suffix}
;; Multi-level: .../.(content)...)
{"before" (slice stripped 0 (+ last-dp 2))
"content" (slice stripped (+ last-dp 2))
"suffix" suffix})))))
(define _find-kw-in-tokens :effects []
(fn ((tokens :as list) (i :as number) (kw :as string))
;; Find value of keyword kw in token list. Returns nil if not found.
(if (>= i (len tokens))
nil
(if (and (= (nth tokens i) kw)
(< (+ i 1) (len tokens)))
(nth tokens (+ i 1))
(_find-kw-in-tokens tokens (+ i 1) kw)))))
(define _find-keyword-value :effects []
(fn ((content :as string) (kw :as string))
;; Find keyword's value in dot-separated content string.
;; "explore.signals.:page.3" ":page" → "3"
(_find-kw-in-tokens (split content ".") 0 kw)))
(define _replace-kw-in-tokens :effects []
(fn ((tokens :as list) (i :as number) (kw :as string) (value :as string))
;; Replace keyword's value in token list. Returns new token list.
(if (>= i (len tokens))
(list)
(if (and (= (nth tokens i) kw)
(< (+ i 1) (len tokens)))
;; Found — keep keyword, replace value, concat rest
(append (list kw value)
(_replace-kw-in-tokens tokens (+ i 2) kw value))
;; Not this keyword — keep token, continue
(cons (nth tokens i)
(_replace-kw-in-tokens tokens (+ i 1) kw value))))))
(define _set-keyword-in-content :effects []
(fn ((content :as string) (kw :as string) (value :as string))
;; Set or replace keyword value in dot-separated content.
;; "a.b.:page.3" ":page" "4" → "a.b.:page.4"
;; "a.b" ":page" "1" → "a.b.:page.1"
(let ((current (_find-keyword-value content kw)))
(if (nil? current)
;; Not found — append
(str content "." kw "." value)
;; Found — replace
(join "." (_replace-kw-in-tokens (split content ".") 0 kw value))))))
(define _is-delta-value? :effects []
(fn ((s :as string))
;; "+1", "-2", "+10" are deltas. "-" alone is not.
(and (not (empty? s))
(> (len s) 1)
(or (starts-with? s "+") (starts-with? s "-")))))
(define _apply-delta :effects []
(fn ((current-str :as string) (delta-str :as string))
;; Apply numeric delta to current value string.
;; "3" "+1" → "4", "3" "-1" → "2"
(let ((cur (parse-int current-str nil))
(delta (parse-int delta-str nil)))
(if (or (nil? cur) (nil? delta))
delta-str ;; fallback: use delta as literal value
(str (+ cur delta))))))
(define _apply-kw-pairs :effects []
(fn ((content :as string) (kw-pairs :as list))
;; Apply keyword modifications to content, one at a time.
(if (empty? kw-pairs)
content
(let ((pair (first kw-pairs))
(kw (first pair))
(raw-val (nth pair 1)))
(let ((actual-val
(if (_is-delta-value? raw-val)
(let ((current (_find-keyword-value content kw)))
(if (nil? current)
raw-val ;; no current value, treat delta as literal
(_apply-delta current raw-val)))
raw-val)))
(_apply-kw-pairs
(_set-keyword-in-content content kw actual-val)
(rest kw-pairs)))))))
(define _apply-keywords-to-url :effects []
(fn ((url :as string) (kw-pairs :as list))
;; Apply keyword modifications to the innermost expression of a URL.
(if (empty? kw-pairs)
url
(let ((parts (_extract-innermost url)))
(let ((new-content (_apply-kw-pairs (get parts "content") kw-pairs)))
(str (get parts "before") new-content (get parts "suffix")))))))
;; --------------------------------------------------------------------------
;; 10. Public API: resolve-relative-url (structural + keywords)
;; --------------------------------------------------------------------------
(define _normalize-relative :effects []
(fn ((url :as string))
;; Normalize bare-dot shorthand to paren form.
;; ".." → "(..)"
;; ".slug" → "(.slug)"
;; ".:page.4" → "(.:page.4)"
;; "(.slug)" → "(.slug)" (already canonical)
(if (starts-with? url "(")
url
(str "(" url ")"))))
(define resolve-relative-url :effects []
(fn ((current :as string) (relative :as string))
;; current: absolute SX URL "/(geography.(hypermedia.(example)))"
;; relative: relative SX URL "(.progress-bar)" or ".." or ".:page.+1"
;; Returns: absolute SX URL
(let ((canonical (_normalize-relative relative)))
(let ((rel-inner (slice canonical 1 (- (len canonical) 1))))
(let ((dots (_count-leading-dots rel-inner))
(body (slice rel-inner (_count-leading-dots rel-inner))))
(if (= dots 0)
current ;; no dots — not a relative URL
;; Parse body into positional part + keyword pairs
(let ((parsed (_parse-relative-body body))
(pos-body (get parsed "positional"))
(kw-pairs (get parsed "keywords")))
;; Step 1: structural navigation
(let ((after-nav
(if (= dots 1)
;; One dot = current level
(if (empty? pos-body)
current ;; no positional → stay here (keyword-only)
;; Append positional part at current level
(let ((stripped (_strip-trailing-close current))
(suffix (slice current (len (_strip-trailing-close current)))))
(str stripped "." pos-body suffix)))
;; Two+ dots = pop (dots-1) levels
(let ((base (_pop-sx-url-levels current (- dots 1))))
(if (empty? pos-body)
base ;; no positional → just pop (cd ..)
(if (= base "/")
(str "/(" pos-body ")")
(let ((stripped (_strip-trailing-close base))
(suffix (slice base (len (_strip-trailing-close base)))))
(str stripped ".(" pos-body ")" suffix))))))))
;; Step 2: apply keyword modifications
(_apply-keywords-to-url after-nav kw-pairs)))))))))
;; Check if a URL is relative (starts with ( but not /( , or starts with .)
(define relative-sx-url? :effects []
(fn ((url :as string))
(or (and (starts-with? url "(")
(not (starts-with? url "/(")))
(starts-with? url "."))))
;; --------------------------------------------------------------------------
;; 11. URL special forms (! prefix)
;; --------------------------------------------------------------------------
;; Special forms are meta-operations on URL expressions.
;; Distinguished by `!` prefix to avoid name collisions with sections/pages.
;;
;; Known forms:
;; !source — show defcomp source code
;; !inspect — deps, CSS footprint, render plan, IO
;; !diff — side-by-side comparison of two expressions
;; !search — grep within a page/spec
;; !raw — skip ~sx-doc wrapping, return raw content
;; !json — return content as JSON data
;;
;; URL examples:
;; /(!source.(~essay-sx-sucks))
;; /(!inspect.(language.(doc.primitives)))
;; /(!diff.(language.(spec.signals)).(language.(spec.eval)))
;; /(!search."define".:in.(language.(spec.signals)))
;; /(!raw.(~some-component))
;; /(!json.(language.(doc.primitives)))
(define _url-special-forms :effects []
(fn ()
;; Returns the set of known URL special form names.
(list "!source" "!inspect" "!diff" "!search" "!raw" "!json")))
(define url-special-form? :effects []
(fn ((name :as string))
;; Check if a name is a URL special form (starts with ! and is known).
(and (starts-with? name "!")
(contains? (_url-special-forms) name))))
(define parse-sx-url :effects []
(fn ((url :as string))
;; Parse an SX URL into a structured descriptor.
;; Returns a dict with:
;; "type" — "home" | "absolute" | "relative" | "special-form" | "direct-component"
;; "form" — special form name (for special-form type), e.g. "!source"
;; "inner" — inner URL expression string (without the special form wrapper)
;; "raw" — original URL string
;;
;; Examples:
;; "/" → {"type" "home" "raw" "/"}
;; "/(language.(doc.intro))" → {"type" "absolute" "raw" ...}
;; "(.slug)" → {"type" "relative" "raw" ...}
;; "..slug" → {"type" "relative" "raw" ...}
;; "/(!source.(~essay))" → {"type" "special-form" "form" "!source" "inner" "(~essay)" "raw" ...}
;; "/(~essay-sx-sucks)" → {"type" "direct-component" "name" "~essay-sx-sucks" "raw" ...}
(cond
(= url "/")
{"type" "home" "raw" url}
(relative-sx-url? url)
{"type" "relative" "raw" url}
(and (starts-with? url "/(!")
(ends-with? url ")"))
;; Special form: /(!source.(~essay)) or /(!diff.a.b)
;; Extract the form name (first dot-separated token after /()
(let ((inner (slice url 2 (- (len url) 1))))
;; inner = "!source.(~essay)" or "!diff.(a).(b)"
(let ((dot-pos (_index-of-safe inner "."))
(paren-pos (_index-of-safe inner "(")))
;; Form name ends at first . or ( (whichever comes first)
(let ((end-pos (cond
(and (nil? dot-pos) (nil? paren-pos)) (len inner)
(nil? dot-pos) paren-pos
(nil? paren-pos) dot-pos
:else (min dot-pos paren-pos))))
(let ((form-name (slice inner 0 end-pos))
(rest-part (slice inner end-pos)))
;; rest-part starts with "." → strip leading dot
(let ((inner-expr (if (starts-with? rest-part ".")
(slice rest-part 1)
rest-part)))
{"type" "special-form"
"form" form-name
"inner" inner-expr
"raw" url})))))
(and (starts-with? url "/(~")
(ends-with? url ")"))
;; Direct component: /(~essay-sx-sucks)
(let ((name (slice url 2 (- (len url) 1))))
{"type" "direct-component" "name" name "raw" url})
(and (starts-with? url "/(")
(ends-with? url ")"))
{"type" "absolute" "raw" url}
:else
{"type" "path" "raw" url})))
(define url-special-form-name :effects []
(fn ((url :as string))
;; Extract the special form name from a URL, or nil if not a special form.
;; "/(!source.(~essay))" → "!source"
;; "/(language.(doc))" → nil
(let ((parsed (parse-sx-url url)))
(if (= (get parsed "type") "special-form")
(get parsed "form")
nil))))
(define url-special-form-inner :effects []
(fn ((url :as string))
;; Extract the inner expression from a special form URL, or nil.
;; "/(!source.(~essay))" → "(~essay)"
;; "/(!diff.(a).(b))" → "(a).(b)"
(let ((parsed (parse-sx-url url)))
(if (= (get parsed "type") "special-form")
(get parsed "inner")
nil))))
;; --------------------------------------------------------------------------
;; 12. URL expression evaluation
;; --------------------------------------------------------------------------
;; A URL is an expression. The system is the environment.
;; eval(url, env) — that's it.
;;
;; The only URL-specific pre-processing:
;; 1. Surface syntax → AST (dots to spaces, parse as SX)
;; 2. Auto-quote unknowns (symbols not in env become strings)
;;
;; After that, it's standard eval. The host wires these into its route
;; handlers (Python catch-all, JS client-side navigation). The same
;; functions serve both.
(define url-to-expr :effects []
(fn ((url-path :as string))
;; Convert a URL path to an SX expression (AST).
;;
;; "/sx/(language.(doc.introduction))" → (language (doc introduction))
;; "/(language.(doc.introduction))" → (language (doc introduction))
;; "/" → (list) ; empty — home
;;
;; Steps:
;; 1. Strip URL prefix ("/sx/" or "/") — host passes the path after prefix
;; 2. Dots → spaces (URL-safe whitespace encoding)
;; 3. Parse as SX expression
;;
;; The caller is responsible for stripping any app-level prefix.
;; This function receives the raw expression portion: "(language.(doc.intro))"
;; or "/" for home.
(if (or (= url-path "/") (empty? url-path))
(list)
(let ((trimmed (if (starts-with? url-path "/")
(slice url-path 1)
url-path)))
;; Dots → spaces
(let ((sx-source (replace trimmed "." " ")))
;; Parse — returns list of expressions, take the first
(let ((exprs (sx-parse sx-source)))
(if (empty? exprs)
(list)
(first exprs))))))))
(define auto-quote-unknowns :effects []
(fn ((expr :as list) (env :as dict))
;; Walk an AST and replace symbols not in env with their name as a string.
;; This makes URL slugs work without quoting:
;; (language (doc introduction)) ; introduction is not a function
;; → (language (doc "introduction"))
;;
;; Rules:
;; - List head (call position) stays as-is — it's a function name
;; - Tail symbols: if in env, keep as symbol; otherwise, string
;; - Keywords, strings, numbers, nested lists: pass through
;; - Non-list expressions: pass through unchanged
(if (not (list? expr))
expr
(if (empty? expr)
expr
;; Head stays as symbol (function position), quote the rest
(cons (first expr)
(map (fn (child)
(cond
;; Nested list — recurse
(list? child)
(auto-quote-unknowns child env)
;; Symbol — check env
(= (type-of child) "symbol")
(let ((name (symbol-name child)))
(if (or (env-has? env name)
;; Keep keywords, component refs, special forms
(starts-with? name ":")
(starts-with? name "~")
(starts-with? name "!"))
child
name)) ;; unknown → string
;; Everything else passes through
:else child))
(rest expr)))))))
(define prepare-url-expr :effects []
(fn ((url-path :as string) (env :as dict))
;; Full pipeline: URL path → ready-to-eval AST.
;;
;; "(language.(doc.introduction))" + env
;; → (language (doc "introduction"))
;;
;; The result can be fed directly to eval:
;; (eval (prepare-url-expr path env) env)
(let ((expr (url-to-expr url-path)))
(if (empty? expr)
expr
(auto-quote-unknowns expr env)))))
;; --------------------------------------------------------------------------
;; Platform interface
;; --------------------------------------------------------------------------
;; Pure primitives used:
;; split, slice, starts-with?, ends-with?, len, empty?, replace,
;; map, filter, for-each, for-each-indexed, nth, get, dict-set!, merge,
;; list, nil?, not, =, case, join, str, index-of, and, or, cons,
;; first, rest, append, parse-int, contains?, min, cond,
;; symbol?, symbol-name, list?, env-has?, type-of
;;
;; From parser.sx: sx-parse, sx-serialize
;; --------------------------------------------------------------------------

97
shared/static/wasm/sx/signals.sx Normal file
View File

@@ -0,0 +1,97 @@
;; ==========================================================================
;; web/signals.sx — Web platform signal extensions
;;
;; Extends the core reactive signal spec (spec/signals.sx) with web-specific
;; features: marsh scopes (DOM lifecycle), named stores (page-level state),
;; event bridge (lake→island communication), and async resources.
;;
;; These depend on platform primitives:
;; dom-set-data, dom-get-data, dom-listen, dom-dispatch, event-detail,
;; promise-then
;; ==========================================================================
;; --------------------------------------------------------------------------
;; Marsh scopes — child scopes within islands
;; --------------------------------------------------------------------------
(define with-marsh-scope :effects [mutation io]
(fn (marsh-el (body-fn :as lambda))
(let ((disposers (list)))
(with-island-scope
(fn (d) (append! disposers d))
body-fn)
(dom-set-data marsh-el "sx-marsh-disposers" disposers))))
(define dispose-marsh-scope :effects [mutation io]
(fn (marsh-el)
(let ((disposers (dom-get-data marsh-el "sx-marsh-disposers")))
(when disposers
(for-each (fn ((d :as lambda)) (cek-call d nil)) disposers)
(dom-set-data marsh-el "sx-marsh-disposers" nil)))))
;; --------------------------------------------------------------------------
;; Named stores — page-level signal containers
;; --------------------------------------------------------------------------
(define *store-registry* (dict))
(define def-store :effects [mutation]
(fn ((name :as string) (init-fn :as lambda))
(let ((registry *store-registry*))
(when (not (has-key? registry name))
(set! *store-registry* (assoc registry name (cek-call init-fn nil))))
(get *store-registry* name))))
(define use-store :effects []
(fn ((name :as string))
(if (has-key? *store-registry* name)
(get *store-registry* name)
(error (str "Store not found: " name
". Call (def-store ...) before (use-store ...).")))))
(define clear-stores :effects [mutation]
(fn ()
(set! *store-registry* (dict))))
;; --------------------------------------------------------------------------
;; Event bridge — DOM event communication for lake→island
;; --------------------------------------------------------------------------
(define emit-event :effects [io]
(fn (el (event-name :as string) detail)
(dom-dispatch el event-name detail)))
(define on-event :effects [io]
(fn (el (event-name :as string) (handler :as lambda))
(dom-on el event-name handler)))
(define bridge-event :effects [mutation io]
(fn (el (event-name :as string) (target-signal :as signal) transform-fn)
(effect (fn ()
(let ((remove (dom-on el event-name
(fn (e)
(let ((detail (event-detail e))
(new-val (if transform-fn
(cek-call transform-fn (list detail))
detail)))
(reset! target-signal new-val))))))
remove)))))
;; --------------------------------------------------------------------------
;; Resource — async signal with loading/resolved/error states
;; --------------------------------------------------------------------------
(define resource :effects [mutation io]
(fn ((fetch-fn :as lambda))
(let ((state (signal (dict "loading" true "data" nil "error" nil))))
(promise-then
(cek-call fetch-fn nil)
(fn (data)
(reset! state (dict "loading" false "data" data "error" nil)))
(fn (err)
(reset! state (dict "loading" false "data" nil "error" err))))
state)))

633
shared/static/wasm/sx/vm.sx Normal file
View File

@@ -0,0 +1,633 @@
;; ==========================================================================
;; vm.sx — SX bytecode virtual machine
;;
;; Stack-based interpreter for bytecode produced by compiler.sx.
;; Written in SX — transpiled to each target (OCaml, JS, WASM).
;;
;; Architecture:
;; - Array-based value stack (no allocation per step)
;; - Frame list for call stack (one frame per function invocation)
;; - Upvalue cells for shared mutable closure variables
;; - Iterative dispatch loop (no host-stack growth)
;; - TCO via frame replacement on OP_TAIL_CALL
;;
;; Platform interface:
;; The host must provide:
;; - make-vm-stack, vm-stack-get, vm-stack-set!, vm-stack-grow
;; - cek-call (fallback for Lambda/Component)
;; - get-primitive (primitive lookup)
;; Everything else is defined here.
;; ==========================================================================
;; --------------------------------------------------------------------------
;; 1. Types — VM data structures
;; --------------------------------------------------------------------------
;; Upvalue cell — shared mutable reference for captured variables.
;; When a closure captures a local, both the parent frame and the
;; closure read/write through this cell.
(define make-upvalue-cell
(fn (value)
{:uv-value value}))
(define uv-get (fn (cell) (get cell "uv-value")))
(define uv-set! (fn (cell value) (dict-set! cell "uv-value" value)))
;; VM code object — compiled bytecode + constant pool.
;; Produced by compiler.sx, consumed by the VM.
(define make-vm-code
(fn (arity locals bytecode constants)
{:vc-arity arity
:vc-locals locals
:vc-bytecode bytecode
:vc-constants constants}))
;; VM closure — code + captured upvalues + globals reference.
(define make-vm-closure
(fn (code upvalues name globals closure-env)
{:vm-code code
:vm-upvalues upvalues
:vm-name name
:vm-globals globals
:vm-closure-env closure-env}))
;; VM frame — one per active function invocation.
(define make-vm-frame
(fn (closure base)
{:closure closure
:ip 0
:base base
:local-cells {}}))
;; VM state — the virtual machine.
(define make-vm
(fn (globals)
{:stack (make-vm-stack 4096)
:sp 0
:frames (list)
:globals globals}))
;; --------------------------------------------------------------------------
;; 2. Stack operations
;; --------------------------------------------------------------------------
(define vm-push
(fn (vm value)
(let ((sp (get vm "sp"))
(stack (get vm "stack")))
;; Grow stack if needed
(when (>= sp (vm-stack-length stack))
(let ((new-stack (make-vm-stack (* sp 2))))
(vm-stack-copy! stack new-stack sp)
(dict-set! vm "stack" new-stack)
(set! stack new-stack)))
(vm-stack-set! stack sp value)
(dict-set! vm "sp" (+ sp 1)))))
(define vm-pop
(fn (vm)
(let ((sp (- (get vm "sp") 1)))
(dict-set! vm "sp" sp)
(vm-stack-get (get vm "stack") sp))))
(define vm-peek
(fn (vm)
(vm-stack-get (get vm "stack") (- (get vm "sp") 1))))
;; --------------------------------------------------------------------------
;; 3. Operand reading — read from bytecode stream
;; --------------------------------------------------------------------------
(define frame-read-u8
(fn (frame)
(let ((ip (get frame "ip"))
(bc (get (get (get frame "closure") "vm-code") "vc-bytecode")))
(let ((v (nth bc ip)))
(dict-set! frame "ip" (+ ip 1))
v))))
(define frame-read-u16
(fn (frame)
(let ((lo (frame-read-u8 frame))
(hi (frame-read-u8 frame)))
(+ lo (* hi 256)))))
(define frame-read-i16
(fn (frame)
(let ((v (frame-read-u16 frame)))
(if (>= v 32768) (- v 65536) v))))
;; --------------------------------------------------------------------------
;; 4. Frame management
;; --------------------------------------------------------------------------
;; Push a closure frame onto the VM.
;; Lays out args as locals, pads remaining locals with nil.
(define vm-push-frame
(fn (vm closure args)
(let ((frame (make-vm-frame closure (get vm "sp"))))
(for-each (fn (a) (vm-push vm a)) args)
;; Pad remaining local slots with nil
(let ((arity (len args))
(total-locals (get (get closure "vm-code") "vc-locals")))
(let ((pad-count (- total-locals arity)))
(when (> pad-count 0)
(let ((i 0))
(define pad-loop
(fn ()
(when (< i pad-count)
(vm-push vm nil)
(set! i (+ i 1))
(pad-loop))))
(pad-loop)))))
(dict-set! vm "frames" (cons frame (get vm "frames"))))))
;; --------------------------------------------------------------------------
;; 5. Code loading — convert compiler output to VM structures
;; --------------------------------------------------------------------------
(define code-from-value
(fn (v)
"Convert a compiler output dict to a vm-code object."
(if (not (dict? v))
(make-vm-code 0 16 (list) (list))
(let ((bc-raw (get v "bytecode"))
(bc (if (nil? bc-raw) (list) bc-raw))
(consts-raw (get v "constants"))
(consts (if (nil? consts-raw) (list) consts-raw))
(arity-raw (get v "arity"))
(arity (if (nil? arity-raw) 0 arity-raw)))
(make-vm-code arity (+ arity 16) bc consts)))))
;; --------------------------------------------------------------------------
;; 6. Call dispatch — route calls by value type
;; --------------------------------------------------------------------------
;; vm-call dispatches a function call within the VM.
;; VmClosure: push frame on current VM (fast path, enables TCO).
;; NativeFn: call directly, push result.
;; Lambda/Component: fall back to CEK evaluator.
(define vm-closure?
(fn (v)
(and (dict? v) (has-key? v "vm-code"))))
(define vm-call
(fn (vm f args)
(cond
(vm-closure? f)
;; Fast path: push frame on current VM
(vm-push-frame vm f args)
(callable? f)
;; Native function or primitive
(vm-push vm (apply f args))
(or (= (type-of f) "lambda") (= (type-of f) "component") (= (type-of f) "island"))
;; CEK fallback — the host provides cek-call
(vm-push vm (cek-call f args))
:else
(error (str "VM: not callable: " (type-of f))))))
;; --------------------------------------------------------------------------
;; 7. Local/upvalue access helpers
;; --------------------------------------------------------------------------
(define frame-local-get
(fn (vm frame slot)
"Read a local variable — check shared cells first, then stack."
(let ((cells (get frame "local-cells"))
(key (str slot)))
(if (has-key? cells key)
(uv-get (get cells key))
(vm-stack-get (get vm "stack") (+ (get frame "base") slot))))))
(define frame-local-set
(fn (vm frame slot value)
"Write a local variable — to shared cell if captured, else to stack."
(let ((cells (get frame "local-cells"))
(key (str slot)))
(if (has-key? cells key)
(uv-set! (get cells key) value)
(vm-stack-set! (get vm "stack") (+ (get frame "base") slot) value)))))
(define frame-upvalue-get
(fn (frame idx)
(uv-get (nth (get (get frame "closure") "vm-upvalues") idx))))
(define frame-upvalue-set
(fn (frame idx value)
(uv-set! (nth (get (get frame "closure") "vm-upvalues") idx) value)))
;; --------------------------------------------------------------------------
;; 8. Global variable access with closure env chain
;; --------------------------------------------------------------------------
(define vm-global-get
(fn (vm frame name)
"Look up a global: globals table → closure env chain → primitives."
(let ((globals (get vm "globals")))
(if (has-key? globals name)
(get globals name)
;; Walk the closure env chain for inner functions
(let ((closure-env (get (get frame "closure") "vm-closure-env")))
(if (nil? closure-env)
(get-primitive name)
(let ((found (env-walk closure-env name)))
(if (nil? found)
(get-primitive name)
found))))))))
(define vm-global-set
(fn (vm frame name value)
"Set a global: write to closure env if name exists there, else globals."
(let ((closure-env (get (get frame "closure") "vm-closure-env"))
(written false))
(when (not (nil? closure-env))
(set! written (env-walk-set! closure-env name value)))
(when (not written)
(dict-set! (get vm "globals") name value)))))
;; env-walk: walk an environment chain looking for a binding.
;; Returns the value or nil if not found.
(define env-walk
(fn (env name)
(if (nil? env) nil
(if (env-has? env name)
(env-get env name)
(let ((parent (env-parent env)))
(if (nil? parent) nil
(env-walk parent name)))))))
;; env-walk-set!: walk an environment chain, set value if name found.
;; Returns true if set, false if not found.
(define env-walk-set!
(fn (env name value)
(if (nil? env) false
(if (env-has? env name)
(do (env-set! env name value) true)
(let ((parent (env-parent env)))
(if (nil? parent) false
(env-walk-set! parent name value)))))))
;; --------------------------------------------------------------------------
;; 9. Closure creation — OP_CLOSURE with upvalue capture
;; --------------------------------------------------------------------------
(define vm-create-closure
(fn (vm frame code-val)
"Create a closure from a code constant. Reads upvalue descriptors
from the bytecode stream and captures values from the enclosing frame."
(let ((code (code-from-value code-val))
(uv-count (if (dict? code-val)
(let ((n (get code-val "upvalue-count")))
(if (nil? n) 0 n))
0)))
(let ((upvalues
(let ((result (list))
(i 0))
(define capture-loop
(fn ()
(when (< i uv-count)
(let ((is-local (frame-read-u8 frame))
(index (frame-read-u8 frame)))
(let ((cell
(if (= is-local 1)
;; Capture from enclosing frame's local slot.
;; Create/reuse a shared cell so both parent
;; and closure read/write through it.
(let ((cells (get frame "local-cells"))
(key (str index)))
(if (has-key? cells key)
(get cells key)
(let ((c (make-upvalue-cell
(vm-stack-get (get vm "stack")
(+ (get frame "base") index)))))
(dict-set! cells key c)
c)))
;; Capture from enclosing frame's upvalue
(nth (get (get frame "closure") "vm-upvalues") index))))
(append! result cell)
(set! i (+ i 1))
(capture-loop))))))
(capture-loop)
result)))
(make-vm-closure code upvalues nil
(get vm "globals") nil)))))
;; --------------------------------------------------------------------------
;; 10. Main execution loop — iterative dispatch
;; --------------------------------------------------------------------------
(define vm-run
(fn (vm)
"Execute bytecode until all frames are exhausted.
VmClosure calls push new frames; the loop picks them up.
OP_TAIL_CALL + VmClosure = true TCO: drop frame, push new, loop."
(define loop
(fn ()
(when (not (empty? (get vm "frames")))
(let ((frame (first (get vm "frames")))
(rest-frames (rest (get vm "frames"))))
(let ((bc (get (get (get frame "closure") "vm-code") "vc-bytecode"))
(consts (get (get (get frame "closure") "vm-code") "vc-constants")))
(if (>= (get frame "ip") (len bc))
;; Bytecode exhausted — stop
(dict-set! vm "frames" (list))
(do
(vm-step vm frame rest-frames bc consts)
(loop))))))))
(loop)))
;; --------------------------------------------------------------------------
;; 11. Single step — opcode dispatch
;; --------------------------------------------------------------------------
(define vm-step
(fn (vm frame rest-frames bc consts)
(let ((op (frame-read-u8 frame)))
(cond
;; ---- Constants ----
(= op 1) ;; OP_CONST
(let ((idx (frame-read-u16 frame)))
(vm-push vm (nth consts idx)))
(= op 2) ;; OP_NIL
(vm-push vm nil)
(= op 3) ;; OP_TRUE
(vm-push vm true)
(= op 4) ;; OP_FALSE
(vm-push vm false)
(= op 5) ;; OP_POP
(vm-pop vm)
(= op 6) ;; OP_DUP
(vm-push vm (vm-peek vm))
;; ---- Variable access ----
(= op 16) ;; OP_LOCAL_GET
(let ((slot (frame-read-u8 frame)))
(vm-push vm (frame-local-get vm frame slot)))
(= op 17) ;; OP_LOCAL_SET
(let ((slot (frame-read-u8 frame)))
(frame-local-set vm frame slot (vm-peek vm)))
(= op 18) ;; OP_UPVALUE_GET
(let ((idx (frame-read-u8 frame)))
(vm-push vm (frame-upvalue-get frame idx)))
(= op 19) ;; OP_UPVALUE_SET
(let ((idx (frame-read-u8 frame)))
(frame-upvalue-set frame idx (vm-peek vm)))
(= op 20) ;; OP_GLOBAL_GET
(let ((idx (frame-read-u16 frame))
(name (nth consts idx)))
(vm-push vm (vm-global-get vm frame name)))
(= op 21) ;; OP_GLOBAL_SET
(let ((idx (frame-read-u16 frame))
(name (nth consts idx)))
(vm-global-set vm frame name (vm-peek vm)))
;; ---- Control flow ----
(= op 32) ;; OP_JUMP
(let ((offset (frame-read-i16 frame)))
(dict-set! frame "ip" (+ (get frame "ip") offset)))
(= op 33) ;; OP_JUMP_IF_FALSE
(let ((offset (frame-read-i16 frame))
(v (vm-pop vm)))
(when (not v)
(dict-set! frame "ip" (+ (get frame "ip") offset))))
(= op 34) ;; OP_JUMP_IF_TRUE
(let ((offset (frame-read-i16 frame))
(v (vm-pop vm)))
(when v
(dict-set! frame "ip" (+ (get frame "ip") offset))))
;; ---- Function calls ----
(= op 48) ;; OP_CALL
(let ((argc (frame-read-u8 frame))
(args-rev (list))
(i 0))
(define collect-args
(fn ()
(when (< i argc)
(set! args-rev (cons (vm-pop vm) args-rev))
(set! i (+ i 1))
(collect-args))))
(collect-args)
(let ((f (vm-pop vm)))
(vm-call vm f args-rev)))
(= op 49) ;; OP_TAIL_CALL
(let ((argc (frame-read-u8 frame))
(args-rev (list))
(i 0))
(define collect-args
(fn ()
(when (< i argc)
(set! args-rev (cons (vm-pop vm) args-rev))
(set! i (+ i 1))
(collect-args))))
(collect-args)
(let ((f (vm-pop vm)))
;; Drop current frame, reuse stack space — true TCO
(dict-set! vm "frames" rest-frames)
(dict-set! vm "sp" (get frame "base"))
(vm-call vm f args-rev)))
(= op 50) ;; OP_RETURN
(let ((result (vm-pop vm)))
(dict-set! vm "frames" rest-frames)
(dict-set! vm "sp" (get frame "base"))
(vm-push vm result))
(= op 51) ;; OP_CLOSURE
(let ((idx (frame-read-u16 frame))
(code-val (nth consts idx)))
(let ((cl (vm-create-closure vm frame code-val)))
(vm-push vm cl)))
(= op 52) ;; OP_CALL_PRIM
(let ((idx (frame-read-u16 frame))
(argc (frame-read-u8 frame))
(name (nth consts idx))
(args-rev (list))
(i 0))
(define collect-args
(fn ()
(when (< i argc)
(set! args-rev (cons (vm-pop vm) args-rev))
(set! i (+ i 1))
(collect-args))))
(collect-args)
(vm-push vm (call-primitive name args-rev)))
;; ---- Collections ----
(= op 64) ;; OP_LIST
(let ((count (frame-read-u16 frame))
(items-rev (list))
(i 0))
(define collect-items
(fn ()
(when (< i count)
(set! items-rev (cons (vm-pop vm) items-rev))
(set! i (+ i 1))
(collect-items))))
(collect-items)
(vm-push vm items-rev))
(= op 65) ;; OP_DICT
(let ((count (frame-read-u16 frame))
(d {})
(i 0))
(define collect-pairs
(fn ()
(when (< i count)
(let ((v (vm-pop vm))
(k (vm-pop vm)))
(dict-set! d k v)
(set! i (+ i 1))
(collect-pairs)))))
(collect-pairs)
(vm-push vm d))
;; ---- String ops ----
(= op 144) ;; OP_STR_CONCAT
(let ((count (frame-read-u8 frame))
(parts-rev (list))
(i 0))
(define collect-parts
(fn ()
(when (< i count)
(set! parts-rev (cons (vm-pop vm) parts-rev))
(set! i (+ i 1))
(collect-parts))))
(collect-parts)
(vm-push vm (apply str parts-rev)))
;; ---- Define ----
(= op 128) ;; OP_DEFINE
(let ((idx (frame-read-u16 frame))
(name (nth consts idx)))
(dict-set! (get vm "globals") name (vm-peek vm)))
;; ---- Inline primitives ----
(= op 160) ;; OP_ADD
(let ((b (vm-pop vm)) (a (vm-pop vm)))
(vm-push vm (+ a b)))
(= op 161) ;; OP_SUB
(let ((b (vm-pop vm)) (a (vm-pop vm)))
(vm-push vm (- a b)))
(= op 162) ;; OP_MUL
(let ((b (vm-pop vm)) (a (vm-pop vm)))
(vm-push vm (* a b)))
(= op 163) ;; OP_DIV
(let ((b (vm-pop vm)) (a (vm-pop vm)))
(vm-push vm (/ a b)))
(= op 164) ;; OP_EQ
(let ((b (vm-pop vm)) (a (vm-pop vm)))
(vm-push vm (= a b)))
(= op 165) ;; OP_LT
(let ((b (vm-pop vm)) (a (vm-pop vm)))
(vm-push vm (< a b)))
(= op 166) ;; OP_GT
(let ((b (vm-pop vm)) (a (vm-pop vm)))
(vm-push vm (> a b)))
(= op 167) ;; OP_NOT
(vm-push vm (not (vm-pop vm)))
(= op 168) ;; OP_LEN
(vm-push vm (len (vm-pop vm)))
(= op 169) ;; OP_FIRST
(vm-push vm (first (vm-pop vm)))
(= op 170) ;; OP_REST
(vm-push vm (rest (vm-pop vm)))
(= op 171) ;; OP_NTH
(let ((n (vm-pop vm)) (coll (vm-pop vm)))
(vm-push vm (nth coll n)))
(= op 172) ;; OP_CONS
(let ((coll (vm-pop vm)) (x (vm-pop vm)))
(vm-push vm (cons x coll)))
(= op 173) ;; OP_NEG
(vm-push vm (- 0 (vm-pop vm)))
(= op 174) ;; OP_INC
(vm-push vm (inc (vm-pop vm)))
(= op 175) ;; OP_DEC
(vm-push vm (dec (vm-pop vm)))
:else
(error (str "VM: unknown opcode " op))))))
;; --------------------------------------------------------------------------
;; 12. Entry points
;; --------------------------------------------------------------------------
;; Execute a closure with arguments — creates a fresh VM.
(define vm-call-closure
(fn (closure args globals)
(let ((vm (make-vm globals)))
(vm-push-frame vm closure args)
(vm-run vm)
(vm-pop vm))))
;; Execute a compiled module (top-level bytecode).
(define vm-execute-module
(fn (code globals)
(let ((closure (make-vm-closure code (list) "module" globals nil))
(vm (make-vm globals)))
(let ((frame (make-vm-frame closure 0)))
;; Pad local slots
(let ((i 0)
(total (get code "vc-locals")))
(define pad-loop
(fn ()
(when (< i total)
(vm-push vm nil)
(set! i (+ i 1))
(pad-loop))))
(pad-loop))
(dict-set! vm "frames" (list frame))
(vm-run vm)
(vm-pop vm)))))
;; --------------------------------------------------------------------------
;; 13. Platform interface
;; --------------------------------------------------------------------------
;;
;; Each target must provide:
;;
;; make-vm-stack(size) → opaque stack (array-like)
;; vm-stack-get(stack, idx) → value at index
;; vm-stack-set!(stack, idx, value) → mutate index
;; vm-stack-length(stack) → current capacity
;; vm-stack-copy!(src, dst, count) → copy first count elements
;;
;; cek-call(f, args) → evaluate via CEK machine (fallback)
;; get-primitive(name) → look up primitive by name (returns callable)
;; call-primitive(name, args) → call primitive directly with args list
;;
;; env-parent(env) → parent environment or nil
;; env-has?(env, name) → boolean
;; env-get(env, name) → value
;; env-set!(env, name, value) → mutate binding

2
shared/sx/templates/shell.sx
View File

@@ -90,7 +90,7 @@ details.group{overflow:hidden}details.group>summary{list-style:none}details.grou
(if use-wasm
(let ((wv (or wasm-hash "dev")))
(<>
(script :src (str asset-url "/wasm/sx_browser.bc.js?v=" wv))
(script :src (str asset-url "/wasm/sx_browser.bc.wasm.js?v=" wv))
(script :src (str asset-url "/wasm/sx-platform.js?v=" wv))))
(script :src (str asset-url "/scripts/sx-browser.js?v=" sx-js-hash)))
;; Body scripts — configurable per app