diff --git a/hosts/ocaml/bin/integration_tests.ml b/hosts/ocaml/bin/integration_tests.ml index f741177a..463f248c 100644 --- a/hosts/ocaml/bin/integration_tests.ml +++ b/hosts/ocaml/bin/integration_tests.ml @@ -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)")); diff --git a/hosts/ocaml/bin/mcp_tree.ml b/hosts/ocaml/bin/mcp_tree.ml index f91a92ce..8f5222b6 100644 --- a/hosts/ocaml/bin/mcp_tree.ml +++ b/hosts/ocaml/bin/mcp_tree.ml @@ -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")])] diff --git a/hosts/ocaml/bin/sx_server.ml b/hosts/ocaml/bin/sx_server.ml index 33007d9c..15b9c87b 100644 --- a/hosts/ocaml/bin/sx_server.ml +++ b/hosts/ocaml/bin/sx_server.ml @@ -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 diff --git a/hosts/ocaml/browser/bundle.sh b/hosts/ocaml/browser/bundle.sh index ddb7bb09..711dd5d3 100755 --- a/hosts/ocaml/browser/bundle.sh +++ b/hosts/ocaml/browser/bundle.sh @@ -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/" diff --git a/hosts/ocaml/browser/dune b/hosts/ocaml/browser/dune new file mode 100644 index 00000000..af379269 --- /dev/null +++ b/hosts/ocaml/browser/dune @@ -0,0 +1,5 @@ +(executable + (name sx_browser) + (libraries sx js_of_ocaml) + (modes byte js wasm) + (preprocess (pps js_of_ocaml-ppx))) diff --git a/hosts/ocaml/lib/sx_types.ml b/hosts/ocaml/lib/sx_types.ml index b4315774..f2a8e3ad 100644 --- a/hosts/ocaml/lib/sx_types.ml +++ b/hosts/ocaml/lib/sx_types.ml @@ -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 -> "" + + (** {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 diff --git a/hosts/ocaml/lib/sx_vm.ml b/hosts/ocaml/lib/sx_vm.ml index 0adf7247..8fd5ed44 100644 --- a/hosts/ocaml/lib/sx_vm.ml +++ b/hosts/ocaml/lib/sx_vm.ml @@ -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; diff --git a/shared/static/wasm/sx-platform.js b/shared/static/wasm/sx-platform.js index c89df0c0..506061f0 100644 --- a/shared/static/wasm/sx-platform.js +++ b/shared/static/wasm/sx-platform.js @@ -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); })(); diff --git a/shared/static/wasm/sx/adapter-html.sx b/shared/static/wasm/sx/adapter-html.sx new file mode 100644 index 00000000..f07bfa26 --- /dev/null +++ b/shared/static/wasm/sx/adapter-html.sx @@ -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 ""))))))) + +(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 "")))))) + +(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 "")))))) + +(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 "" body-html "")))))) + +(define serialize-island-state :effects () (fn ((kwargs :as dict)) (if (empty-dict? kwargs) nil (sx-serialize kwargs)))) diff --git a/shared/static/wasm/sx/adapter-sx.sx b/shared/static/wasm/sx/adapter-sx.sx new file mode 100644 index 00000000..b510f3d2 --- /dev/null +++ b/shared/static/wasm/sx/adapter-sx.sx @@ -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 +;; -------------------------------------------------------------------------- diff --git a/shared/static/wasm/sx/bytecode.sx b/shared/static/wasm/sx/bytecode.sx new file mode 100644 index 00000000..8e70b146 --- /dev/null +++ b/shared/static/wasm/sx/bytecode.sx @@ -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)))) diff --git a/shared/static/wasm/sx/compiler.sx b/shared/static/wasm/sx/compiler.sx new file mode 100644 index 00000000..c1aa987b --- /dev/null +++ b/shared/static/wasm/sx/compiler.sx @@ -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")}))) diff --git a/shared/static/wasm/sx/core-signals.sx b/shared/static/wasm/sx/core-signals.sx new file mode 100644 index 00000000..c0b5f776 --- /dev/null +++ b/shared/static/wasm/sx/core-signals.sx @@ -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)))))) diff --git a/shared/static/wasm/sx/deps.sx b/shared/static/wasm/sx/deps.sx new file mode 100644 index 00000000..92bf5595 --- /dev/null +++ b/shared/static/wasm/sx/deps.sx @@ -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)))) diff --git a/shared/static/wasm/sx/freeze.sx b/shared/static/wasm/sx/freeze.sx new file mode 100644 index 00000000..f3c2e972 --- /dev/null +++ b/shared/static/wasm/sx/freeze.sx @@ -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)))))) diff --git a/shared/static/wasm/sx/harness-reactive.sx b/shared/static/wasm/sx/harness-reactive.sx new file mode 100644 index 00000000..1478bc2f --- /dev/null +++ b/shared/static/wasm/sx/harness-reactive.sx @@ -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))))) diff --git a/shared/static/wasm/sx/harness-web.sx b/shared/static/wasm/sx/harness-web.sx new file mode 100644 index 00000000..871acd6a --- /dev/null +++ b/shared/static/wasm/sx/harness-web.sx @@ -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") ">")))) diff --git a/shared/static/wasm/sx/harness.sx b/shared/static/wasm/sx/harness.sx new file mode 100644 index 00000000..2ff94dc9 --- /dev/null +++ b/shared/static/wasm/sx/harness.sx @@ -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)))))) diff --git a/shared/static/wasm/sx/hypersx.sx b/shared/static/wasm/sx/hypersx.sx new file mode 100644 index 00000000..1082d8fe --- /dev/null +++ b/shared/static/wasm/sx/hypersx.sx @@ -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)))) diff --git a/shared/static/wasm/sx/page-helpers.sx b/shared/static/wasm/sx/page-helpers.sx new file mode 100644 index 00000000..530d8869 --- /dev/null +++ b/shared/static/wasm/sx/page-helpers.sx @@ -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})) diff --git a/shared/static/wasm/sx/render.sx b/shared/static/wasm/sx/render.sx new file mode 100644 index 00000000..039c328f --- /dev/null +++ b/shared/static/wasm/sx/render.sx @@ -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 "&" "&")) + (set! r (replace r "<" "<")) + (set! r (replace r ">" ">")) + (set! r (replace r "\"" """)) + 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) +;; -------------------------------------------------------------------------- diff --git a/shared/static/wasm/sx/router.sx b/shared/static/wasm/sx/router.sx new file mode 100644 index 00000000..862c18a1 --- /dev/null +++ b/shared/static/wasm/sx/router.sx @@ -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/" → ({"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/" "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" "keywords" } + (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 +;; -------------------------------------------------------------------------- diff --git a/shared/static/wasm/sx/signals.sx b/shared/static/wasm/sx/signals.sx new file mode 100644 index 00000000..14d4280b --- /dev/null +++ b/shared/static/wasm/sx/signals.sx @@ -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))) diff --git a/shared/static/wasm/sx/vm.sx b/shared/static/wasm/sx/vm.sx new file mode 100644 index 00000000..691ea5ac --- /dev/null +++ b/shared/static/wasm/sx/vm.sx @@ -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 diff --git a/shared/sx/templates/shell.sx b/shared/sx/templates/shell.sx index bb12899f..a1c2e4a7 100644 --- a/shared/sx/templates/shell.sx +++ b/shared/sx/templates/shell.sx @@ -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