From 07bbcaf1bb3876e60bfab92e15b65265765dd777 Mon Sep 17 00:00:00 2001 From: giles Date: Wed, 25 Mar 2026 12:57:24 +0000 Subject: [PATCH] OCaml VM browser: safe equality, thunk trampolining, platform functions, nav pipeline Core runtime fixes: - Safe equality (=, !=): physical equality for dicts/lambdas/signals, structural only for acyclic types. Prevents infinite loops on circular signal subscriber chains. - contains?: same safe comparison (physical first, structural for simple types) - Thunk trampolining in as_number and to_string: leaked thunks auto-resolve instead of showing or erroring "Expected number, got thunk" - Diagnostic first error: shows actual type received Island hydration fixes: - adapter-dom.sx: skip scope-emit for spreads inside islands (was tripling classes) - schedule-idle: wrap callback to absorb requestIdleCallback deadline arg - home-stepper: remove spread-specific highlighting (all tokens same style per step) Platform functions (boot-helpers.sx): - fetch-request: 3-arg interface (config, success-fn, error-fn) with promise chain - build-request-body: form serialization for GET/POST - strip-component-scripts / extract-response-css: SX text processing - Navigation: bind-boost-link, bind-client-route-click via execute-request - Loading state: show-indicator, disable-elements, clear-loading-state - DOM extras: dom-remove, dom-attr-list (name/value pairs), dom-child-list (SX list), dom-is-active-element?, dom-is-input-element?, dom-is-child-of?, dom-on, dom-parse-html-document, dom-body-inner-html, create-script-clone - All remaining stubs: csrf-token, loaded-component-names, observe-intersection, event-source-connect/listen, with-transition, cross-origin?, etc. Navigation pipeline: - browser-push-state/replace-state: accept 1-arg (URL only) or 3-arg - boot.sx: wire popstate listener to handle-popstate - URL updates working via handle-history + pushState fix Morph debugging (WIP): - dom-child-list returns proper SX list (was JS Array) - dom-query accepts optional root element for scoped queries - Navigation fetches and renders SX responses, URL updates, but morph doesn't replace content div (investigating dom-child-list on new elements) Co-Authored-By: Claude Opus 4.6 (1M context) --- hosts/ocaml/lib/sx_primitives.ml | 56 +- hosts/ocaml/lib/sx_ref.ml | 53 +- shared/static/wasm/sx/adapter-dom.sx | 1366 + shared/static/wasm/sx/boot-helpers.sx | 696 + shared/static/wasm/sx/boot.sx | 574 + shared/static/wasm/sx/browser.sx | 227 + shared/static/wasm/sx/dom.sx | 429 + shared/static/wasm/sx_browser.bc.js | 37634 ++++++++++++++++++++++++ sx/sx/home-stepper.sx | 4 - web/adapter-dom.sx | 58 +- web/boot.sx | 9 +- web/lib/boot-helpers.sx | 696 + web/lib/browser.sx | 21 +- web/lib/dom.sx | 132 +- 14 files changed, 41905 insertions(+), 50 deletions(-) create mode 100644 shared/static/wasm/sx/adapter-dom.sx create mode 100644 shared/static/wasm/sx/boot-helpers.sx create mode 100644 shared/static/wasm/sx/boot.sx create mode 100644 shared/static/wasm/sx/browser.sx create mode 100644 shared/static/wasm/sx/dom.sx create mode 100644 shared/static/wasm/sx_browser.bc.js create mode 100644 web/lib/boot-helpers.sx diff --git a/hosts/ocaml/lib/sx_primitives.ml b/hosts/ocaml/lib/sx_primitives.ml index 3eb3c52d..5d3b4240 100644 --- a/hosts/ocaml/lib/sx_primitives.ml +++ b/hosts/ocaml/lib/sx_primitives.ml @@ -24,12 +24,18 @@ let get_primitive name = (* --- Helpers --- *) -let as_number = function +(* Trampoline hook — set by sx_ref after initialization to break circular dep *) +let trampoline_hook : (value -> value) ref = ref (fun v -> v) + +let rec as_number = function | Number n -> n | Bool true -> 1.0 | Bool false -> 0.0 | Nil -> 0.0 | String s -> (match float_of_string_opt s with Some n -> n | None -> Float.nan) + | Thunk _ as t -> + (* Trampoline thunks — they shouldn't leak but sometimes do *) + as_number (!trampoline_hook t) | v -> raise (Eval_error ("Expected number, got " ^ type_of v ^ ": " ^ (match v with Dict d -> (match Hashtbl.find_opt d "__signal" with Some _ -> "signal{value=" ^ (match Hashtbl.find_opt d "value" with Some v' -> value_to_string v' | None -> "?") ^ "}" | None -> "dict") | _ -> ""))) let as_string = function @@ -47,7 +53,7 @@ let as_bool = function | Bool b -> b | v -> sx_truthy v -let to_string = function +let rec to_string = function | String s -> s | Number n -> if Float.is_integer n then string_of_int (int_of_float n) @@ -57,6 +63,7 @@ let to_string = function | Nil -> "" | Symbol s -> s | Keyword k -> k + | Thunk _ as t -> to_string (!trampoline_hook t) | v -> inspect v let () = @@ -132,19 +139,33 @@ let () = | _ -> Nil); (* === Comparison === *) - (* Normalize ListRef to List for structural equality *) - let rec normalize_for_eq = function - | ListRef { contents = items } -> List (List.map normalize_for_eq items) - | List items -> List (List.map normalize_for_eq items) - | v -> v + (* Safe equality: physical equality for potentially-circular types + (Dict, Lambda, Component, Island, Signal, NativeFn), + structural equality for acyclic types (Number, String, Bool, etc.). + Lists are compared element-wise recursively with the same safety. *) + let rec safe_eq a b = + if a == b then true (* physical equality fast path *) + else match a, b with + | Number x, Number y -> x = y + | String x, String y -> x = y + | Bool x, Bool y -> x = y + | Nil, Nil -> true + | Symbol x, Symbol y -> x = y + | Keyword x, Keyword y -> x = y + | (List la | ListRef { contents = la }), + (List lb | ListRef { contents = lb }) -> + List.length la = List.length lb && + List.for_all2 safe_eq la lb + (* Dict/Lambda/Component/Island/Signal/NativeFn: physical only *) + | _ -> false in register "=" (fun args -> match args with - | [a; b] -> Bool (normalize_for_eq a = normalize_for_eq b) + | [a; b] -> Bool (safe_eq a b) | _ -> raise (Eval_error "=: 2 args")); register "!=" (fun args -> match args with - | [a; b] -> Bool (normalize_for_eq a <> normalize_for_eq b) + | [a; b] -> Bool (not (safe_eq a b)) | _ -> raise (Eval_error "!=: 2 args")); register "<" (fun args -> match args with @@ -340,6 +361,7 @@ let () = match args with | [List (x :: _)] | [ListRef { contents = x :: _ }] -> x | [List []] | [ListRef { contents = [] }] -> Nil | [Nil] -> Nil + | [x] -> raise (Eval_error ("first: expected list, got " ^ inspect x)) | _ -> raise (Eval_error "first: 1 list arg")); register "rest" (fun args -> match args with @@ -396,7 +418,21 @@ let () = register "concat" (fun args -> List (List.concat_map as_list args)); register "contains?" (fun args -> match args with - | [List l; item] | [ListRef { contents = l }; item] -> Bool (List.mem item l) + | [List l; item] | [ListRef { contents = l }; item] -> + (* Physical equality first (handles signals/dicts/closures safely), + structural fallback only for acyclic types (string/number/bool/nil/symbol/keyword) *) + let safe_eq a b = + a == b || + (match a, b with + | Number x, Number y -> x = y + | String x, String y -> x = y + | Bool x, Bool y -> x = y + | Nil, Nil -> true + | Symbol x, Symbol y -> x = y + | Keyword x, Keyword y -> x = y + | _ -> false) + in + Bool (List.exists (fun x -> safe_eq x item) l) | [String s; String sub] -> let rec find i = if i + String.length sub > String.length s then false diff --git a/hosts/ocaml/lib/sx_ref.ml b/hosts/ocaml/lib/sx_ref.ml index 17bc9eea..e95e580a 100644 --- a/hosts/ocaml/lib/sx_ref.ml +++ b/hosts/ocaml/lib/sx_ref.ml @@ -253,9 +253,43 @@ and value_matches_type_p val' expected_type = and strict_check_args name args = (if sx_truthy ((let _and = !_strict_ref in if not (sx_truthy _and) then _and else !_prim_param_types_ref)) then (let spec = (get (!_prim_param_types_ref) (name)) in (if sx_truthy (spec) then (let positional = (get (spec) ((String "positional"))) in let rest_type = (get (spec) ((String "rest-type"))) in (let () = ignore ((if sx_truthy (positional) then (List.iter (fun pair -> ignore ((let idx = (first (pair)) in let param = (nth (pair) ((Number 1.0))) in let p_name = (first (param)) in let p_type = (nth (param) ((Number 1.0))) in (if sx_truthy ((prim_call "<" [idx; (len (args))])) then (let val' = (nth (args) (idx)) in (if sx_truthy ((Bool (not (sx_truthy ((value_matches_type_p (val') (p_type))))))) then (raise (Eval_error (value_to_str (String (sx_str [(String "Type error: "); name; (String " expected "); p_type; (String " for param "); p_name; (String ", got "); (type_of (val')); (String " ("); (String (sx_str [val'])); (String ")")]))))) else Nil)) else Nil)))) (sx_to_list (List (List.mapi (fun i p -> let i = Number (float_of_int i) in (List [i; p])) (sx_to_list positional)))); Nil) else Nil)) in (if sx_truthy ((let _and = rest_type in if not (sx_truthy _and) then _and else (prim_call ">" [(len (args)); (len ((let _or = positional in if sx_truthy _or then _or else (List []))))]))) then (List.iter (fun pair -> ignore ((let idx = (first (pair)) in let val' = (nth (pair) ((Number 1.0))) in (if sx_truthy ((Bool (not (sx_truthy ((value_matches_type_p (val') (rest_type))))))) then (raise (Eval_error (value_to_str (String (sx_str [(String "Type error: "); name; (String " expected "); rest_type; (String " for rest arg "); idx; (String ", got "); (type_of (val')); (String " ("); (String (sx_str [val'])); (String ")")]))))) else Nil)))) (sx_to_list (List (List.mapi (fun i v -> let i = Number (float_of_int i) in (List [i; v])) (sx_to_list (prim_call "slice" [args; (len ((let _or = positional in if sx_truthy _or then _or else (List []))))]))))); Nil) else Nil))) else Nil)) else Nil) -(* call-lambda *) +(* bind_lambda_params — shared helper for call-lambda and CEK dispatch. + Handles &rest params: binds required params, collects rest into list. *) +and bind_lambda_params f args local = + let params = lambda_params f in + let param_list = match params with List l | ListRef { contents = l } -> l | _ -> [] in + let args_list = match args with List l | ListRef { contents = l } -> l | _ -> [] in + let rest_idx = ref (-1) in + List.iteri (fun i p -> match p with Symbol "&rest" | String "&rest" -> rest_idx := i | _ -> ()) param_list; + if !rest_idx >= 0 then begin + let required = List.filteri (fun i _ -> i < !rest_idx) param_list in + let rest_name = (match List.nth_opt param_list (!rest_idx + 1) with + | Some (Symbol s | String s) -> s | _ -> "rest") in + List.iteri (fun i p -> + let name = sx_to_string p in + let v = match List.nth_opt args_list i with Some v -> v | None -> Nil in + ignore (env_bind local name v)) required; + let rest_vals = if !rest_idx <= List.length args_list + then List (List.filteri (fun i _ -> i >= !rest_idx) args_list) else List [] in + ignore (env_bind local (String rest_name) rest_vals) + end else begin + if sx_truthy (prim_call ">" [len args; len params]) then + raise (Eval_error (value_to_str (String (sx_str [ + (let _or = lambda_name f in if sx_truthy _or then _or else String "lambda"); + String " expects "; len params; String " args, got "; len args])))); + ignore (List.iter (fun pair -> + ignore (env_bind local (sx_to_string (first pair)) (nth pair (Number 1.0)))) + (sx_to_list (prim_call "zip" [params; args]))); + ignore (List.iter (fun p -> + ignore (env_bind local (sx_to_string p) Nil)) + (sx_to_list (prim_call "slice" [params; len args]))) + end + +(* call-lambda — uses shared bind_lambda_params for &rest support *) and call_lambda f args caller_env = - (let params = (lambda_params (f)) in let local = (env_merge ((lambda_closure (f))) (caller_env)) in (if sx_truthy ((prim_call ">" [(len (args)); (len (params))])) then (raise (Eval_error (value_to_str (String (sx_str [(let _or = (lambda_name (f)) in if sx_truthy _or then _or else (String "lambda")); (String " expects "); (len (params)); (String " args, got "); (len (args))]))))) else (let () = ignore ((List.iter (fun pair -> ignore ((env_bind local (sx_to_string (first (pair))) (nth (pair) ((Number 1.0)))))) (sx_to_list (prim_call "zip" [params; args])); Nil)) in (let () = ignore ((List.iter (fun p -> ignore ((env_bind local (sx_to_string p) Nil))) (sx_to_list (prim_call "slice" [params; (len (args))])); Nil)) in (make_thunk ((lambda_body (f))) (local)))))) + let local = env_merge (lambda_closure f) caller_env in + bind_lambda_params f args local; + make_thunk (lambda_body f) local (* call-component *) and call_component comp raw_args env = @@ -333,9 +367,13 @@ and sf_provide args env = and expand_macro mac raw_args env = (let local = (env_merge ((macro_closure (mac))) (env)) in (let () = ignore ((List.iter (fun pair -> ignore ((env_bind local (sx_to_string (first (pair))) (if sx_truthy ((prim_call "<" [(nth (pair) ((Number 1.0))); (len (raw_args))])) then (nth (raw_args) ((nth (pair) ((Number 1.0))))) else Nil)))) (sx_to_list (List (List.mapi (fun i p -> let i = Number (float_of_int i) in (List [p; i])) (sx_to_list (macro_params (mac)))))); Nil)) in (let () = ignore ((if sx_truthy ((macro_rest_param (mac))) then (env_bind local (sx_to_string (macro_rest_param (mac))) (prim_call "slice" [raw_args; (len ((macro_params (mac))))])) else Nil)) in (trampoline ((eval_expr ((macro_body (mac))) (local))))))) -(* cek-run *) +(* cek-run — iterative to avoid OCaml stack overflow in js_of_ocaml/WASM *) and cek_run state = - (if sx_truthy ((cek_terminal_p (state))) then (cek_value (state)) else (cek_run ((cek_step (state))))) + let s = ref state in + while not (match cek_terminal_p !s with Bool true -> true | _ -> false) do + s := cek_step !s + done; + cek_value !s (* cek-step *) and cek_step state = @@ -363,7 +401,7 @@ and step_sf_begin args env kont = (* step-sf-let *) and step_sf_let args env kont = - let pairs = ref Nil in (if sx_truthy ((prim_call "=" [(type_of ((first (args)))); (String "symbol")])) then (make_cek_value ((sf_named_let (args) (env))) (env) (kont)) else (let bindings = (first (args)) in let body = (rest (args)) in let local = (env_extend (env)) in (if sx_truthy ((empty_p (bindings))) then (step_sf_begin (body) (local) (kont)) else (let first_binding = (if sx_truthy ((let _and = (prim_call "=" [(type_of ((first (bindings)))); (String "list")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(len ((first (bindings)))); (Number 2.0)]))) then (first (bindings)) else (List [(first (bindings)); (nth (bindings) ((Number 1.0)))])) in let rest_bindings = (if sx_truthy ((let _and = (prim_call "=" [(type_of ((first (bindings)))); (String "list")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(len ((first (bindings)))); (Number 2.0)]))) then (rest (bindings)) else (let pairs = ref ((List [])) in (let () = ignore ((List.fold_left (fun _acc i -> (pairs := sx_append_b !pairs (List [(nth (bindings) ((prim_call "*" [i; (Number 2.0)]))); (nth (bindings) ((prim_call "inc" [(prim_call "*" [i; (Number 2.0)])])))]); Nil)) Nil (sx_to_list (prim_call "range" [(Number 1.0); (prim_call "/" [(len (bindings)); (Number 2.0)])])))) in !pairs))) in (let vname = (if sx_truthy ((prim_call "=" [(type_of ((first (first_binding)))); (String "symbol")])) then (symbol_name ((first (first_binding)))) else (first (first_binding))) in (make_cek_state ((nth (first_binding) ((Number 1.0)))) (local) ((kont_push ((make_let_frame (vname) (rest_bindings) (body) (local))) (kont))))))))) + let pairs = ref Nil in (if sx_truthy ((prim_call "=" [(type_of ((first (args)))); (String "symbol")])) then (make_cek_value ((trampoline ((sf_named_let (args) (env))))) (env) (kont)) else (let bindings = (first (args)) in let body = (rest (args)) in let local = (env_extend (env)) in (if sx_truthy ((empty_p (bindings))) then (step_sf_begin (body) (local) (kont)) else (let first_binding = (if sx_truthy ((let _and = (prim_call "=" [(type_of ((first (bindings)))); (String "list")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(len ((first (bindings)))); (Number 2.0)]))) then (first (bindings)) else (List [(first (bindings)); (nth (bindings) ((Number 1.0)))])) in let rest_bindings = (if sx_truthy ((let _and = (prim_call "=" [(type_of ((first (bindings)))); (String "list")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(len ((first (bindings)))); (Number 2.0)]))) then (rest (bindings)) else (let pairs = ref ((List [])) in (let () = ignore ((List.fold_left (fun _acc i -> (pairs := sx_append_b !pairs (List [(nth (bindings) ((prim_call "*" [i; (Number 2.0)]))); (nth (bindings) ((prim_call "inc" [(prim_call "*" [i; (Number 2.0)])])))]); Nil)) Nil (sx_to_list (prim_call "range" [(Number 1.0); (prim_call "/" [(len (bindings)); (Number 2.0)])])))) in !pairs))) in (let vname = (if sx_truthy ((prim_call "=" [(type_of ((first (first_binding)))); (String "symbol")])) then (symbol_name ((first (first_binding)))) else (first (first_binding))) in (make_cek_state ((nth (first_binding) ((Number 1.0)))) (local) ((kont_push ((make_let_frame (vname) (rest_bindings) (body) (local))) (kont))))))))) (* step-sf-define *) and step_sf_define args env kont = @@ -491,7 +529,7 @@ and step_continue state = (* continue-with-call *) and continue_with_call f args env raw_args kont = - (if sx_truthy ((continuation_p (f))) then (let arg = (if sx_truthy ((empty_p (args))) then Nil else (first (args))) in let cont_data = (continuation_data (f)) in (let captured = (get (cont_data) ((String "captured"))) in (let result' = (cek_run ((make_cek_value (arg) (env) (captured)))) in (make_cek_value (result') (env) (kont))))) else (if sx_truthy ((let _and = (is_callable (f)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((is_lambda (f)))))) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((is_component (f)))))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_island (f)))))))))) then (make_cek_value ((sx_apply f args)) (env) (kont)) else (if sx_truthy ((is_lambda (f))) then (let params = (lambda_params (f)) in let local = (env_merge ((lambda_closure (f))) (env)) in (if sx_truthy ((prim_call ">" [(len (args)); (len (params))])) then (raise (Eval_error (value_to_str (String (sx_str [(let _or = (lambda_name (f)) in if sx_truthy _or then _or else (String "lambda")); (String " expects "); (len (params)); (String " args, got "); (len (args))]))))) else (let () = ignore ((List.iter (fun pair -> ignore ((env_bind local (sx_to_string (first (pair))) (nth (pair) ((Number 1.0)))))) (sx_to_list (prim_call "zip" [params; args])); Nil)) in (let () = ignore ((List.iter (fun p -> ignore ((env_bind local (sx_to_string p) Nil))) (sx_to_list (prim_call "slice" [params; (len (args))])); Nil)) in (match !jit_call_hook, f with | Some hook, Lambda l when l.l_name <> None -> let args_list = match args with List a | ListRef { contents = a } -> a | _ -> [] in (match hook f args_list with Some result -> make_cek_value result local kont | None -> make_cek_state (lambda_body f) local kont) | _ -> make_cek_state ((lambda_body (f))) (local) (kont)))))) else (if sx_truthy ((let _or = (is_component (f)) in if sx_truthy _or then _or else (is_island (f)))) then (let parsed = (parse_keyword_args (raw_args) (env)) in let kwargs = (first (parsed)) in let children = (nth (parsed) ((Number 1.0))) in let local = (env_merge ((component_closure (f))) (env)) in (let () = ignore ((List.iter (fun p -> ignore ((env_bind local (sx_to_string p) (let _or = (dict_get (kwargs) (p)) in if sx_truthy _or then _or else Nil)))) (sx_to_list (component_params (f))); Nil)) in (let () = ignore ((if sx_truthy ((component_has_children (f))) then (env_bind local (sx_to_string (String "children")) children) else Nil)) in (make_cek_state ((component_body (f))) (local) (kont))))) else (raise (Eval_error (value_to_str (String (sx_str [(String "Not callable: "); (inspect (f))]))))))))) + (if sx_truthy ((continuation_p (f))) then (let arg = (if sx_truthy ((empty_p (args))) then Nil else (first (args))) in let cont_data = (continuation_data (f)) in (let captured = (get (cont_data) ((String "captured"))) in (let result' = (cek_run ((make_cek_value (arg) (env) (captured)))) in (make_cek_value (result') (env) (kont))))) else (if sx_truthy ((let _and = (is_callable (f)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((is_lambda (f)))))) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((is_component (f)))))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_island (f)))))))))) then (make_cek_value ((sx_apply f args)) (env) (kont)) else (if sx_truthy ((is_lambda (f))) then (let local = (env_merge ((lambda_closure (f))) (env)) in let () = bind_lambda_params f args local in (match !jit_call_hook, f with | Some hook, Lambda l when l.l_name <> None -> let args_list = match args with List a | ListRef { contents = a } -> a | _ -> [] in (match hook f args_list with Some result -> make_cek_value result local kont | None -> make_cek_state (lambda_body f) local kont) | _ -> make_cek_state ((lambda_body (f))) (local) (kont))) else (if sx_truthy ((let _or = (is_component (f)) in if sx_truthy _or then _or else (is_island (f)))) then (let parsed = (parse_keyword_args (raw_args) (env)) in let kwargs = (first (parsed)) in let children = (nth (parsed) ((Number 1.0))) in let local = (env_merge ((component_closure (f))) (env)) in (let () = ignore ((List.iter (fun p -> ignore ((env_bind local (sx_to_string p) (let _or = (dict_get (kwargs) (p)) in if sx_truthy _or then _or else Nil)))) (sx_to_list (component_params (f))); Nil)) in (let () = ignore ((if sx_truthy ((component_has_children (f))) then (env_bind local (sx_to_string (String "children")) children) else Nil)) in (make_cek_state ((component_body (f))) (local) (kont))))) else (raise (Eval_error (value_to_str (String (sx_str [(String "Not callable: "); (inspect (f))]))))))))) (* sf-case-step-loop *) and sf_case_step_loop match_val clauses env kont = @@ -519,6 +557,9 @@ let () = trampoline_fn := (fun v -> (* Wire up the primitives trampoline so call_any in HO forms resolves Thunks *) let () = Sx_primitives._sx_trampoline_fn := !trampoline_fn +(* Wire up as_number trampoline so arithmetic on leaked thunks auto-resolves *) +let () = Sx_primitives.trampoline_hook := !trampoline_fn + (* Override recursive cek_run with iterative loop *) let cek_run_iterative state = let s = ref state in diff --git a/shared/static/wasm/sx/adapter-dom.sx b/shared/static/wasm/sx/adapter-dom.sx new file mode 100644 index 00000000..fe84e191 --- /dev/null +++ b/shared/static/wasm/sx/adapter-dom.sx @@ -0,0 +1,1366 @@ +;; ========================================================================== +;; adapter-dom.sx — DOM rendering adapter +;; +;; Renders SX expressions to live DOM nodes. Browser-only. +;; Mirrors the render-to-html adapter but produces Element/Text/Fragment +;; nodes instead of HTML strings. +;; +;; Depends on: +;; render.sx — HTML_TAGS, VOID_ELEMENTS, BOOLEAN_ATTRS, definition-form? +;; eval.sx — eval-expr, trampoline, call-component, expand-macro +;; ========================================================================== + +(define SVG_NS "http://www.w3.org/2000/svg") +(define MATH_NS "http://www.w3.org/1998/Math/MathML") + +;; Check if we're inside an island scope. +;; Uses scope-peek (mutable scope stack) rather than context (CEK continuation) +;; because with-island-scope uses scope-push!, not provide. +(define island-scope? + (fn () (not (nil? (scope-peek "sx-island-scope"))))) + + +;; -------------------------------------------------------------------------- +;; dom-on — dom-listen with post-render hooks +;; +;; Wraps dom-listen so that run-post-render-hooks fires after every SX +;; event handler invocation. This is the SX-level hook integration; +;; the native dom-listen primitive is a clean addEventListener wrapper. +;; -------------------------------------------------------------------------- + +(define dom-on :effects [io] + (fn (el name handler) + (dom-listen el name + (if (lambda? handler) + (if (= 0 (len (lambda-params handler))) + (fn (_e) (trampoline (call-lambda handler (list))) (run-post-render-hooks)) + (fn (e) (trampoline (call-lambda handler (list e))) (run-post-render-hooks))) + handler)))) + + +;; -------------------------------------------------------------------------- +;; render-to-dom — main entry point +;; -------------------------------------------------------------------------- + +(define render-to-dom :effects [render] + (fn (expr (env :as dict) (ns :as string)) + (set-render-active! true) + (case (type-of expr) + ;; nil / boolean false / boolean true → empty fragment + "nil" (create-fragment) + "boolean" (create-fragment) + + ;; Pre-rendered raw HTML → parse into fragment + "raw-html" (dom-parse-html (raw-html-content expr)) + + ;; String → text node + "string" (create-text-node expr) + + ;; Number → text node + "number" (create-text-node (str expr)) + + ;; Symbol → evaluate then render + "symbol" (render-to-dom (trampoline (eval-expr expr env)) env ns) + + ;; Keyword → text + "keyword" (create-text-node (keyword-name expr)) + + ;; Pre-rendered DOM node → pass through + "dom-node" expr + + ;; Spread → emit attrs to nearest element provider, pass through for reactive-spread + ;; Inside islands, reactive-spread handles attr application directly — + ;; skip scope emission to avoid double/triple application. + "spread" (do (when (not (island-scope?)) + (scope-emit! "element-attrs" (spread-attrs expr))) + expr) + + ;; Dict → empty + "dict" (create-fragment) + + ;; List → dispatch + "list" + (if (empty? expr) + (create-fragment) + (render-dom-list expr env ns)) + + ;; Signal → reactive text in island scope, deref outside + :else + (if (signal? expr) + (if (island-scope?) + (reactive-text expr) + (create-text-node (str (deref expr)))) + (create-text-node (str expr)))))) + + +;; -------------------------------------------------------------------------- +;; render-dom-list — dispatch on list head +;; -------------------------------------------------------------------------- + +(define render-dom-list :effects [render] + (fn (expr (env :as dict) (ns :as string)) + (let ((head (first expr))) + (cond + ;; Symbol head — dispatch on name + (= (type-of head) "symbol") + (let ((name (symbol-name head)) + (args (rest expr))) + (cond + ;; raw! → insert unescaped HTML + (= name "raw!") + (render-dom-raw args env) + + ;; <> → fragment + (= name "<>") + (render-dom-fragment args env ns) + + ;; lake — server-morphable slot within an island + (= name "lake") + (render-dom-lake args env ns) + + ;; marsh — reactive server-morphable slot within an island + (= name "marsh") + (render-dom-marsh args env ns) + + ;; html: prefix → force element rendering + (starts-with? name "html:") + (render-dom-element (slice name 5) args env ns) + + ;; Render-aware special forms + (render-dom-form? name) + (if (and (contains? HTML_TAGS name) + (or (and (> (len args) 0) + (= (type-of (first args)) "keyword")) + ns)) + ;; Ambiguous: tag name that's also a form — treat as tag + ;; when keyword arg or namespace present + (render-dom-element name args env ns) + (dispatch-render-form name expr env ns)) + + ;; Macro expansion + (and (env-has? env name) (macro? (env-get env name))) + (render-to-dom + (expand-macro (env-get env name) args env) + env ns) + + ;; HTML tag + (contains? HTML_TAGS name) + (render-dom-element name args env ns) + + ;; Island (~name) — reactive component + (and (starts-with? name "~") + (env-has? env name) + (island? (env-get env name))) + (render-dom-island (env-get env name) args env ns) + + ;; Component (~name) + (starts-with? name "~") + (let ((comp (env-get env name))) + (if (component? comp) + (render-dom-component comp args env ns) + (render-dom-unknown-component name))) + + ;; Custom element (hyphenated with keyword attrs) + (and (> (index-of name "-") 0) + (> (len args) 0) + (= (type-of (first args)) "keyword")) + (render-dom-element name args env ns) + + ;; Inside SVG/MathML namespace — treat as element + ns + (render-dom-element name args env ns) + + ;; deref in island scope → reactive text node + (and (= name "deref") (island-scope?)) + (let ((sig-or-val (trampoline (eval-expr (first args) env)))) + (if (signal? sig-or-val) + (reactive-text sig-or-val) + (create-text-node (str (deref sig-or-val))))) + + ;; Fallback — evaluate then render + :else + (render-to-dom (trampoline (eval-expr expr env)) env ns))) + + ;; Lambda or list head → evaluate + (or (lambda? head) (= (type-of head) "list")) + (render-to-dom (trampoline (eval-expr expr env)) env ns) + + ;; Data list + :else + (let ((frag (create-fragment))) + (for-each (fn (x) + (let ((result (render-to-dom x env ns))) + (when (not (spread? result)) + (dom-append frag result)))) + expr) + frag))))) + + +;; -------------------------------------------------------------------------- +;; render-dom-element — create a DOM element with attrs and children +;; -------------------------------------------------------------------------- + +(define render-dom-element :effects [render] + (fn ((tag :as string) (args :as list) (env :as dict) (ns :as string)) + ;; Detect namespace from tag + (let ((new-ns (cond (= tag "svg") SVG_NS + (= tag "math") MATH_NS + :else ns)) + (el (dom-create-element tag new-ns))) + + ;; Provide scope for spread emit! — deeply nested spreads emit here + (scope-push! "element-attrs" nil) + + ;; Process args: keywords → attrs, others → children + (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))) + ;; Keyword arg → attribute + (let ((attr-name (keyword-name arg)) + (attr-expr (nth args (inc (get state "i"))))) + (cond + ;; Event handler: evaluate eagerly, bind listener + (starts-with? attr-name "on-") + (let ((attr-val (trampoline (eval-expr attr-expr env)))) + (when (callable? attr-val) + (dom-on el (slice attr-name 3) attr-val))) + ;; Two-way input binding: :bind signal + (= attr-name "bind") + (let ((attr-val (trampoline (eval-expr attr-expr env)))) + (when (signal? attr-val) (bind-input el attr-val))) + ;; ref: set ref.current to this element + (= attr-name "ref") + (let ((attr-val (trampoline (eval-expr attr-expr env)))) + (dict-set! attr-val "current" el)) + ;; key: reconciliation hint, evaluate eagerly (not reactive) + (= attr-name "key") + (let ((attr-val (trampoline (eval-expr attr-expr env)))) + (dom-set-attr el "key" (str attr-val))) + ;; Inside island scope: reactive attribute binding. + ;; The effect tracks signal deps automatically — if none + ;; are deref'd, it fires once and never again (safe). + (island-scope?) + (reactive-attr el attr-name + (fn () (trampoline (eval-expr attr-expr env)))) + ;; Static attribute (outside islands) + :else + (let ((attr-val (trampoline (eval-expr attr-expr env)))) + (cond + (or (nil? attr-val) (= attr-val false)) nil + (contains? BOOLEAN_ATTRS attr-name) + (when attr-val (dom-set-attr el attr-name "")) + (= attr-val true) + (dom-set-attr el attr-name "") + :else + (dom-set-attr el attr-name (str attr-val))))) + (assoc state "skip" true "i" (inc (get state "i")))) + + ;; Positional arg → child (or spread → merge attrs onto element) + (do + (when (not (contains? VOID_ELEMENTS tag)) + (let ((child (render-to-dom arg env new-ns))) + (cond + ;; Reactive spread: track signal deps, update attrs on change + (and (spread? child) (island-scope?)) + (reactive-spread el (fn () (render-to-dom arg env new-ns))) + ;; Static spread: already emitted via provide, skip + (spread? child) nil + ;; Normal child: append to element + :else + (dom-append el child)))) + (assoc state "i" (inc (get state "i")))))))) + (dict "i" 0 "skip" false) + args) + + ;; Collect emitted spread attrs and merge onto DOM element + (for-each + (fn (spread-dict) + (for-each + (fn ((key :as string)) + (let ((val (dict-get spread-dict key))) + (if (= key "class") + (let ((existing (dom-get-attr el "class"))) + (dom-set-attr el "class" + (if (and existing (not (= existing ""))) + (str existing " " val) + val))) + (if (= key "style") + (let ((existing (dom-get-attr el "style"))) + (dom-set-attr el "style" + (if (and existing (not (= existing ""))) + (str existing ";" val) + val))) + (dom-set-attr el key (str val)))))) + (keys spread-dict))) + (scope-emitted "element-attrs")) + (scope-pop! "element-attrs") + + el))) + + +;; -------------------------------------------------------------------------- +;; render-dom-component — expand and render a component +;; -------------------------------------------------------------------------- + +(define render-dom-component :effects [render] + (fn ((comp :as component) (args :as list) (env :as dict) (ns :as string)) + ;; Parse kwargs and children, bind into component env, render body. + (let ((kwargs (dict)) + (children (list))) + ;; Separate keyword args from positional children + (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))) + ;; Keyword arg — evaluate in caller's env + (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) + + ;; Build component env: closure + caller env + params + (let ((local (env-merge (component-closure comp) env))) + ;; Bind params from kwargs + (for-each + (fn (p) + (env-bind! local p (if (dict-has? kwargs p) (dict-get kwargs p) nil))) + (component-params comp)) + + ;; If component accepts children, pre-render them to a fragment + ;; Spread values are filtered out (no parent element to merge onto) + (when (component-has-children? comp) + (let ((child-frag (create-fragment))) + (for-each + (fn (c) + (let ((result (render-to-dom c env ns))) + (when (not (spread? result)) + (dom-append child-frag result)))) + children) + (env-bind! local "children" child-frag))) + + (render-to-dom (component-body comp) local ns))))) + + +;; -------------------------------------------------------------------------- +;; render-dom-fragment — render children into a DocumentFragment +;; -------------------------------------------------------------------------- + +(define render-dom-fragment :effects [render] + (fn ((args :as list) (env :as dict) (ns :as string)) + (let ((frag (create-fragment))) + (for-each + (fn (x) + (let ((result (render-to-dom x env ns))) + (when (not (spread? result)) + (dom-append frag result)))) + args) + frag))) + + +;; -------------------------------------------------------------------------- +;; render-dom-raw — insert unescaped content +;; -------------------------------------------------------------------------- + +(define render-dom-raw :effects [render] + (fn ((args :as list) (env :as dict)) + (let ((frag (create-fragment))) + (for-each + (fn (arg) + (let ((val (trampoline (eval-expr arg env)))) + (cond + (= (type-of val) "string") + (dom-append frag (dom-parse-html val)) + (= (type-of val) "dom-node") + (dom-append frag (dom-clone val)) + (not (nil? val)) + (dom-append frag (create-text-node (str val)))))) + args) + frag))) + + +;; -------------------------------------------------------------------------- +;; render-dom-unknown-component — visible warning element +;; -------------------------------------------------------------------------- + +(define render-dom-unknown-component :effects [render] + (fn ((name :as string)) + (error (str "Unknown component: " name)))) + + +;; -------------------------------------------------------------------------- +;; Render-aware special forms for DOM output +;; -------------------------------------------------------------------------- +;; These forms need special handling in DOM rendering because they +;; produce DOM nodes rather than evaluated values. + +(define RENDER_DOM_FORMS + (list "if" "when" "cond" "case" "let" "let*" "letrec" "begin" "do" + "define" "defcomp" "defisland" "defmacro" "defstyle" + "map" "map-indexed" "filter" "for-each" "portal" + "error-boundary" "scope" "provide")) + +(define render-dom-form? :effects [] + (fn ((name :as string)) + (contains? RENDER_DOM_FORMS name))) + +(define dispatch-render-form :effects [render] + (fn ((name :as string) expr (env :as dict) (ns :as string)) + (cond + ;; if — reactive inside islands (re-renders when signal deps change) + (= name "if") + (if (island-scope?) + (let ((marker (create-comment "r-if")) + (current-nodes (list)) + (initial-result nil)) + ;; Effect runs synchronously on first call, tracking signal deps. + ;; On first run, store result in initial-result (marker has no parent yet). + ;; On subsequent runs, swap DOM nodes after marker. + (effect (fn () + (let ((result (let ((cond-val (trampoline (eval-expr (nth expr 1) env)))) + (if cond-val + (render-to-dom (nth expr 2) env ns) + (if (> (len expr) 3) + (render-to-dom (nth expr 3) env ns) + (create-fragment)))))) + (if (dom-parent marker) + ;; Marker is in DOM — swap nodes + (do + (for-each (fn (n) (dom-remove n)) current-nodes) + (set! current-nodes + (if (dom-is-fragment? result) + (dom-child-nodes result) + (list result))) + (dom-insert-after marker result)) + ;; Marker not yet in DOM (first run) — just save result + (set! initial-result result))))) + ;; Spread pass-through: spreads aren't DOM nodes, can't live + ;; in fragments. Return directly so parent element merges attrs. + (if (spread? initial-result) + initial-result + (let ((frag (create-fragment))) + (dom-append frag marker) + (when initial-result + (set! current-nodes + (if (dom-is-fragment? initial-result) + (dom-child-nodes initial-result) + (list initial-result))) + (dom-append frag initial-result)) + frag))) + ;; Static if + (let ((cond-val (trampoline (eval-expr (nth expr 1) env)))) + (if cond-val + (render-to-dom (nth expr 2) env ns) + (if (> (len expr) 3) + (render-to-dom (nth expr 3) env ns) + (create-fragment))))) + + ;; when — reactive inside islands + (= name "when") + (if (island-scope?) + (let ((marker (create-comment "r-when")) + (current-nodes (list)) + (initial-result nil)) + (effect (fn () + (if (dom-parent marker) + ;; In DOM — swap nodes + (do + (for-each (fn (n) (dom-remove n)) current-nodes) + (set! current-nodes (list)) + (when (trampoline (eval-expr (nth expr 1) env)) + (let ((frag (create-fragment))) + (for-each + (fn (i) + (dom-append frag (render-to-dom (nth expr i) env ns))) + (range 2 (len expr))) + (set! current-nodes (dom-child-nodes frag)) + (dom-insert-after marker frag)))) + ;; First run — save result for fragment + (when (trampoline (eval-expr (nth expr 1) env)) + (let ((frag (create-fragment))) + (for-each + (fn (i) + (dom-append frag (render-to-dom (nth expr i) env ns))) + (range 2 (len expr))) + (set! current-nodes (dom-child-nodes frag)) + (set! initial-result frag)))))) + ;; Spread pass-through + (if (spread? initial-result) + initial-result + (let ((frag (create-fragment))) + (dom-append frag marker) + (when initial-result (dom-append frag initial-result)) + frag))) + ;; Static when + (if (not (trampoline (eval-expr (nth expr 1) env))) + (create-fragment) + (let ((frag (create-fragment))) + (for-each + (fn (i) + (dom-append frag (render-to-dom (nth expr i) env ns))) + (range 2 (len expr))) + frag))) + + ;; cond — reactive inside islands + (= name "cond") + (if (island-scope?) + (let ((marker (create-comment "r-cond")) + (current-nodes (list)) + (initial-result nil)) + (effect (fn () + (let ((branch (eval-cond (rest expr) env))) + (if (dom-parent marker) + ;; In DOM — swap nodes + (do + (for-each (fn (n) (dom-remove n)) current-nodes) + (set! current-nodes (list)) + (when branch + (let ((result (render-to-dom branch env ns))) + (set! current-nodes + (if (dom-is-fragment? result) + (dom-child-nodes result) + (list result))) + (dom-insert-after marker result)))) + ;; First run — save result for fragment + (when branch + (let ((result (render-to-dom branch env ns))) + (set! current-nodes + (if (dom-is-fragment? result) + (dom-child-nodes result) + (list result))) + (set! initial-result result))))))) + ;; Spread pass-through + (if (spread? initial-result) + initial-result + (let ((frag (create-fragment))) + (dom-append frag marker) + (when initial-result (dom-append frag initial-result)) + frag))) + ;; Static cond + (let ((branch (eval-cond (rest expr) env))) + (if branch + (render-to-dom branch env ns) + (create-fragment)))) + + ;; case + (= name "case") + (render-to-dom (trampoline (eval-expr expr env)) env ns) + + ;; let / let* — single body: pass through (spread propagates). Multi: fragment. + (or (= name "let") (= name "let*")) + (let ((local (process-bindings (nth expr 1) env))) + (if (= (len expr) 3) + (render-to-dom (nth expr 2) local ns) + (let ((frag (create-fragment))) + (for-each + (fn (i) + (let ((result (render-to-dom (nth expr i) local ns))) + (when (not (spread? result)) + (dom-append frag result)))) + (range 2 (len expr))) + frag))) + + ;; letrec — pre-bind all names (nil), evaluate values, render body. + (= name "letrec") + (let ((bindings (nth expr 1)) + (body (slice expr 2)) + (local (env-extend env))) + ;; Phase 1: pre-bind all names to nil + (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) + ;; Phase 2: evaluate values (all names in scope for mutual recursion) + (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) + ;; Phase 3: eval non-last body exprs for side effects, render last + (when (> (len body) 1) + (for-each (fn (e) (trampoline (eval-expr e local))) (init body))) + (render-to-dom (last body) local ns)) + + ;; begin / do — single body: pass through. Multi: fragment. + (or (= name "begin") (= name "do")) + (if (= (len expr) 2) + (render-to-dom (nth expr 1) env ns) + (let ((frag (create-fragment))) + (for-each + (fn (i) + (let ((result (render-to-dom (nth expr i) env ns))) + (when (not (spread? result)) + (dom-append frag result)))) + (range 1 (len expr))) + frag)) + + ;; Definition forms — eval for side effects + (definition-form? name) + (do (trampoline (eval-expr expr env)) (create-fragment)) + + ;; map — reactive-list when mapping over a signal inside an island + (= name "map") + (let ((coll-expr (nth expr 2))) + (if (and (island-scope?) + (= (type-of coll-expr) "list") + (> (len coll-expr) 1) + (= (type-of (first coll-expr)) "symbol") + (= (symbol-name (first coll-expr)) "deref")) + ;; Reactive path: pass signal to reactive-list + (let ((f (trampoline (eval-expr (nth expr 1) env))) + (sig (trampoline (eval-expr (nth coll-expr 1) env)))) + (if (signal? sig) + (reactive-list f sig env ns) + ;; deref on non-signal: fall through to static + (let ((coll (deref sig)) + (frag (create-fragment))) + (for-each + (fn (item) + (let ((val (if (lambda? f) + (render-lambda-dom f (list item) env ns) + (render-to-dom (apply f (list item)) env ns)))) + (dom-append frag val))) + coll) + frag))) + ;; Static path: no island scope or no deref + (let ((f (trampoline (eval-expr (nth expr 1) env))) + (coll (trampoline (eval-expr (nth expr 2) env))) + (frag (create-fragment))) + (for-each + (fn (item) + (let ((val (if (lambda? f) + (render-lambda-dom f (list item) env ns) + (render-to-dom (apply f (list item)) env ns)))) + (dom-append frag val))) + coll) + frag))) + + ;; map-indexed + (= name "map-indexed") + (let ((f (trampoline (eval-expr (nth expr 1) env))) + (coll (trampoline (eval-expr (nth expr 2) env))) + (frag (create-fragment))) + (for-each-indexed + (fn (i item) + (let ((val (if (lambda? f) + (render-lambda-dom f (list i item) env ns) + (render-to-dom (apply f (list i item)) env ns)))) + (dom-append frag val))) + coll) + frag) + + ;; filter — evaluate fully then render + (= name "filter") + (render-to-dom (trampoline (eval-expr expr env)) env ns) + + ;; portal — render children into a remote target element + (= name "portal") + (render-dom-portal (rest expr) env ns) + + ;; error-boundary — catch errors, render fallback + (= name "error-boundary") + (render-dom-error-boundary (rest expr) env ns) + + ;; for-each (render variant) + (= name "for-each") + (let ((f (trampoline (eval-expr (nth expr 1) env))) + (coll (trampoline (eval-expr (nth expr 2) env))) + (frag (create-fragment))) + (for-each + (fn (item) + (let ((val (if (lambda? f) + (render-lambda-dom f (list item) env ns) + (render-to-dom (apply f (list item)) env ns)))) + (dom-append frag val))) + coll) + frag) + + ;; scope — unified render-time dynamic scope + (= name "scope") + (let ((scope-name (trampoline (eval-expr (nth expr 1) env))) + (rest-args (slice expr 2)) + (scope-val nil) + (body-exprs nil) + (frag (create-fragment))) + ;; 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-exprs (slice rest-args 2))) + (set! body-exprs rest-args)) + (scope-push! scope-name scope-val) + (for-each + (fn (e) + (dom-append frag (render-to-dom e env ns))) + body-exprs) + (scope-pop! scope-name) + frag) + + ;; provide — sugar for scope with value + (= name "provide") + (let ((prov-name (trampoline (eval-expr (nth expr 1) env))) + (prov-val (trampoline (eval-expr (nth expr 2) env))) + (frag (create-fragment))) + (scope-push! prov-name prov-val) + (for-each + (fn (i) + (dom-append frag (render-to-dom (nth expr i) env ns))) + (range 3 (len expr))) + (scope-pop! prov-name) + frag) + + ;; Fallback + :else + (render-to-dom (trampoline (eval-expr expr env)) env ns)))) + + +;; -------------------------------------------------------------------------- +;; render-lambda-dom — render a lambda body in DOM context +;; -------------------------------------------------------------------------- + +(define render-lambda-dom :effects [render] + (fn ((f :as lambda) (args :as list) (env :as dict) (ns :as string)) + ;; Bind lambda params and render body as DOM + (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-dom (lambda-body f) local ns)))) + + +;; -------------------------------------------------------------------------- +;; render-dom-island — render a reactive island +;; -------------------------------------------------------------------------- +;; +;; Islands render like components but wrapped in a reactive context. +;; The island container element gets data-sx-island and data-sx-state +;; attributes for identification and hydration. +;; +;; Inside the island body, deref calls create reactive DOM subscriptions: +;; - Text bindings: (deref sig) in text position → reactive text node +;; - Attribute bindings: (deref sig) in attr → reactive attribute +;; - Conditional fragments: (when (deref sig) ...) → reactive show/hide + +(define render-dom-island :effects [render mutation] + (fn ((island :as island) (args :as list) (env :as dict) (ns :as string)) + ;; Parse kwargs and children (same as component) + (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) + + ;; Build island env: closure + caller env + params + (let ((local (env-merge (component-closure island) env)) + (island-name (component-name island))) + + ;; Bind params from kwargs + (for-each + (fn (p) + (env-bind! local p (if (dict-has? kwargs p) (dict-get kwargs p) nil))) + (component-params island)) + + ;; If island accepts children, pre-render them to a fragment + (when (component-has-children? island) + (let ((child-frag (create-fragment))) + (for-each + (fn (c) (dom-append child-frag (render-to-dom c env ns))) + children) + (env-bind! local "children" child-frag))) + + ;; Create the island container element + (let ((container (dom-create-element "span" nil)) + (disposers (list))) + + ;; Mark as island + already hydrated (so boot.sx skips it) + (dom-set-attr container "data-sx-island" island-name) + (mark-processed! container "island-hydrated") + + ;; Render island body inside a scope that tracks disposers + (let ((body-dom + (with-island-scope + (fn (disposable) (append! disposers disposable)) + (fn () (render-to-dom (component-body island) local ns))))) + (dom-append container body-dom) + + ;; Store disposers on the container for cleanup + (dom-set-data container "sx-disposers" disposers) + + container)))))) + + +;; -------------------------------------------------------------------------- +;; render-dom-lake — server-morphable slot within an island +;; -------------------------------------------------------------------------- +;; +;; (lake :id "name" children...) +;; +;; Renders as
children
. +;; During morph, the server can replace lake content while the surrounding +;; reactive island DOM is preserved. This is the "water around the rocks" — +;; server substance flowing through client territory. +;; +;; Supports :tag keyword to change wrapper element (default "div"). + +(define render-dom-lake :effects [render] + (fn ((args :as list) (env :as dict) (ns :as string)) + (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 ((el (dom-create-element lake-tag nil))) + (dom-set-attr el "data-sx-lake" (or lake-id "")) + (for-each + (fn (c) (dom-append el (render-to-dom c env ns))) + children) + el)))) + + +;; -------------------------------------------------------------------------- +;; render-dom-marsh — reactive server-morphable slot within an island +;; -------------------------------------------------------------------------- +;; +;; (marsh :id "name" :tag "div" :transform fn children...) +;; +;; Like a lake but reactive: during morph, new content is parsed as SX and +;; re-evaluated in the island's signal scope. The :transform function (if +;; present) reshapes server content before evaluation. +;; +;; Renders as
children
. +;; Stores the island env and transform on the element for morph retrieval. + +(define render-dom-marsh :effects [render] + (fn ((args :as list) (env :as dict) (ns :as string)) + (let ((marsh-id nil) + (marsh-tag "div") + (marsh-transform nil) + (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") (set! marsh-transform 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 ((el (dom-create-element marsh-tag nil))) + (dom-set-attr el "data-sx-marsh" (or marsh-id "")) + ;; Store transform function and island env for morph retrieval + (when marsh-transform + (dom-set-data el "sx-marsh-transform" marsh-transform)) + (dom-set-data el "sx-marsh-env" env) + (for-each + (fn (c) (dom-append el (render-to-dom c env ns))) + children) + el)))) + + +;; -------------------------------------------------------------------------- +;; Reactive DOM rendering helpers +;; -------------------------------------------------------------------------- +;; +;; These functions create reactive bindings between signals and DOM nodes. +;; They are called by the platform's renderDOM when it detects deref +;; calls inside an island context. + +;; reactive-text — create a text node bound to a signal +;; Used when (deref sig) appears in a text position inside an island. +(define reactive-text :effects [render mutation] + (fn (sig) + (let ((node (create-text-node (str (deref sig))))) + (effect (fn () + (dom-set-text-content node (str (deref sig))))) + node))) + +;; reactive-attr — bind an element attribute to a signal expression +;; Used when an attribute value contains (deref sig) inside an island. +;; Marks the attribute name on the element via data-sx-reactive-attrs so +;; the morph algorithm knows not to overwrite it with server content. +(define reactive-attr :effects [render mutation] + (fn (el (attr-name :as string) (compute-fn :as lambda)) + ;; Mark this attribute as reactively managed + (let ((existing (or (dom-get-attr el "data-sx-reactive-attrs") "")) + (updated (if (empty? existing) attr-name (str existing "," attr-name)))) + (dom-set-attr el "data-sx-reactive-attrs" updated)) + (effect (fn () + (let ((raw (compute-fn))) + ;; If compute-fn returned a signal (e.g. from computed), deref it + ;; to get the actual value and track the dependency + (let ((val (if (signal? raw) (deref raw) raw))) + (cond + (or (nil? val) (= val false)) + (dom-remove-attr el attr-name) + (= val true) + (dom-set-attr el attr-name "") + :else + (dom-set-attr el attr-name (str val))))))))) + +;; reactive-spread — reactively bind spread attrs to parent element. +;; Used when a child of an element produces a spread inside an island. +;; Tracks signal deps in the spread expression. When signals change: +;; old classes are removed, new ones applied. Non-class attrs (data-tw etc.) +;; are overwritten. Flushes newly collected CSS rules to live stylesheet. +;; +;; Multiple reactive spreads on the same element are safe — each tracks +;; its own class contribution and only removes/adds its own tokens. +(define reactive-spread :effects [render mutation] + (fn (el (render-fn :as lambda)) + (let ((prev-classes (list)) + (prev-extra-keys (list))) + ;; Mark for morph protection + (let ((existing (or (dom-get-attr el "data-sx-reactive-attrs") ""))) + (dom-set-attr el "data-sx-reactive-attrs" + (if (empty? existing) "_spread" (str existing ",_spread")))) + (effect (fn () + ;; 1. Remove previously applied classes from element's class list + (when (not (empty? prev-classes)) + (let ((current (or (dom-get-attr el "class") "")) + (tokens (filter (fn (c) (not (= c ""))) (split current " "))) + (kept (filter (fn (c) + (not (some (fn (pc) (= pc c)) prev-classes))) + tokens))) + (if (empty? kept) + (dom-remove-attr el "class") + (dom-set-attr el "class" (join " " kept))))) + ;; 2. Remove previously applied extra attrs + (for-each (fn (k) (dom-remove-attr el k)) prev-extra-keys) + ;; 3. Re-evaluate the spread expression (tracks signal deps) + (let ((result (render-fn))) + (if (spread? result) + (let ((attrs (spread-attrs result)) + (cls-str (or (dict-get attrs "class") "")) + (new-classes (filter (fn (c) (not (= c ""))) + (split cls-str " "))) + (extra-keys (filter (fn (k) (not (= k "class"))) + (keys attrs)))) + (set! prev-classes new-classes) + (set! prev-extra-keys extra-keys) + ;; Append new classes to element + (when (not (empty? new-classes)) + (let ((current (or (dom-get-attr el "class") ""))) + (dom-set-attr el "class" + (if (and current (not (= current ""))) + (str current " " cls-str) + cls-str)))) + ;; Set extra attrs (data-tw, etc.) — simple overwrite + (for-each (fn (k) + (dom-set-attr el k (str (dict-get attrs k)))) + extra-keys) + ;; Flush any newly collected CSS rules to live stylesheet + (run-post-render-hooks)) + ;; No longer a spread — clear tracked state + (do + (set! prev-classes (list)) + (set! prev-extra-keys (list)))))))))) + +;; reactive-fragment — conditionally render a fragment based on a signal +;; Used for (when (deref sig) ...) or (if (deref sig) ...) inside an island. +(define reactive-fragment :effects [render mutation] + (fn ((test-fn :as lambda) (render-fn :as lambda) (env :as dict) (ns :as string)) + (let ((marker (create-comment "island-fragment")) + (current-nodes (list))) + (effect (fn () + ;; Remove previous nodes + (for-each (fn (n) (dom-remove n)) current-nodes) + (set! current-nodes (list)) + ;; If test passes, render and insert after marker + (when (test-fn) + (let ((frag (render-fn))) + (set! current-nodes (dom-child-nodes frag)) + (dom-insert-after marker frag))))) + marker))) + +;; reactive-list — render a keyed list bound to a signal +;; Used for (map fn (deref items)) inside an island. +;; +;; Keyed reconciliation: if rendered elements have a "key" attribute, +;; existing DOM nodes are reused across updates. Only additions, removals, +;; and reorderings touch the DOM. Without keys, falls back to clear+rerender. + +(define render-list-item :effects [render] + (fn ((map-fn :as lambda) item (env :as dict) (ns :as string)) + (if (lambda? map-fn) + (render-lambda-dom map-fn (list item) env ns) + (render-to-dom (apply map-fn (list item)) env ns)))) + +(define extract-key :effects [render] + (fn (node (index :as number)) + ;; Extract key from rendered node: :key attr, data-key, or index fallback + (let ((k (dom-get-attr node "key"))) + (if k + (do (dom-remove-attr node "key") k) + (let ((dk (dom-get-data node "key"))) + (if dk (str dk) (str "__idx_" index))))))) + +(define reactive-list :effects [render mutation] + (fn ((map-fn :as lambda) (items-sig :as signal) (env :as dict) (ns :as string)) + (let ((container (create-fragment)) + (marker (create-comment "island-list")) + (key-map (dict)) + (key-order (list))) + (dom-append container marker) + (effect (fn () + (let ((items (deref items-sig))) + (if (dom-parent marker) + ;; Marker in DOM: reconcile + (let ((new-map (dict)) + (new-keys (list)) + (has-keys false)) + + ;; Render or reuse each item + (for-each-indexed + (fn (idx item) + (let ((rendered (render-list-item map-fn item env ns)) + (key (extract-key rendered idx))) + (when (and (not has-keys) + (not (starts-with? key "__idx_"))) + (set! has-keys true)) + ;; Reuse existing node if key matches, else use new + (if (dict-has? key-map key) + (dict-set! new-map key (dict-get key-map key)) + (dict-set! new-map key rendered)) + (append! new-keys key))) + items) + + (if (not has-keys) + ;; No keys: simple clear and re-render (original strategy) + (do + (dom-remove-children-after marker) + (let ((frag (create-fragment))) + (for-each + (fn (k) (dom-append frag (dict-get new-map k))) + new-keys) + (dom-insert-after marker frag))) + + ;; Keyed reconciliation + (do + ;; Remove stale nodes + (for-each + (fn (old-key) + (when (not (dict-has? new-map old-key)) + (dom-remove (dict-get key-map old-key)))) + key-order) + + ;; Reorder/insert to match new key order + (let ((cursor marker)) + (for-each + (fn (k) + (let ((node (dict-get new-map k)) + (next (dom-next-sibling cursor))) + (when (not (identical? node next)) + (dom-insert-after cursor node)) + (set! cursor node))) + new-keys)))) + + ;; Update state for next render + (set! key-map new-map) + (set! key-order new-keys)) + + ;; First run (marker not in DOM yet): render initial items into container + (for-each-indexed + (fn (idx item) + (let ((rendered (render-list-item map-fn item env ns)) + (key (extract-key rendered idx))) + (dict-set! key-map key rendered) + (append! key-order key) + (dom-append container rendered))) + items))))) + container))) + + +;; -------------------------------------------------------------------------- +;; bind-input — two-way signal binding for form elements +;; -------------------------------------------------------------------------- +;; +;; (bind-input el sig) creates a bidirectional link: +;; Signal → element: effect updates el.value (or el.checked) when sig changes +;; Element → signal: input/change listener updates sig when user types +;; +;; Handles: input[text/number/email/...], textarea, select, checkbox, radio + +(define bind-input :effects [render mutation] + (fn (el (sig :as signal)) + (let ((input-type (lower (or (dom-get-attr el "type") ""))) + (is-checkbox (or (= input-type "checkbox") + (= input-type "radio")))) + ;; Set initial value from signal + (if is-checkbox + (dom-set-prop el "checked" (deref sig)) + (dom-set-prop el "value" (str (deref sig)))) + ;; Signal → element (reactive effect) + (effect (fn () + (if is-checkbox + (dom-set-prop el "checked" (deref sig)) + (let ((v (str (deref sig)))) + (when (!= (dom-get-prop el "value") v) + (dom-set-prop el "value" v)))))) + ;; Element → signal (event listener) + (dom-on el (if is-checkbox "change" "input") + (fn (e) + (if is-checkbox + (reset! sig (dom-get-prop el "checked")) + (reset! sig (dom-get-prop el "value")))))))) + + +;; -------------------------------------------------------------------------- +;; CEK-based reactive rendering (opt-in, deref-as-shift) +;; -------------------------------------------------------------------------- +;; +;; When enabled, (deref sig) inside a reactive-reset boundary performs +;; continuation capture: "the rest of this expression" becomes the subscriber. +;; No explicit effect() wrapping needed for text/attr bindings. + +(define *use-cek-reactive* true) +(define enable-cek-reactive! (fn () (set! *use-cek-reactive* true))) + +;; cek-reactive-text — create a text node bound via continuation capture +(define cek-reactive-text :effects [render mutation] + (fn (expr env) + (let ((node (create-text-node "")) + (update-fn (fn (val) + (dom-set-text-content node (str val))))) + (let ((initial (cek-run + (make-cek-state expr env + (list (make-reactive-reset-frame env update-fn true)))))) + (dom-set-text-content node (str initial)) + node)))) + +;; cek-reactive-attr — bind an attribute via continuation capture +(define cek-reactive-attr :effects [render mutation] + (fn (el attr-name expr env) + (let ((update-fn (fn (val) + (cond + (or (nil? val) (= val false)) (dom-remove-attr el attr-name) + (= val true) (dom-set-attr el attr-name "") + :else (dom-set-attr el attr-name (str val)))))) + ;; Mark for morph protection + (let ((existing (or (dom-get-attr el "data-sx-reactive-attrs") "")) + (updated (if (empty? existing) attr-name (str existing "," attr-name)))) + (dom-set-attr el "data-sx-reactive-attrs" updated)) + ;; Initial render via CEK with ReactiveResetFrame + (let ((initial (cek-run + (make-cek-state expr env + (list (make-reactive-reset-frame env update-fn true)))))) + (cek-call update-fn (list initial)))))) + + +;; -------------------------------------------------------------------------- +;; render-dom-portal — render children into a remote target element +;; -------------------------------------------------------------------------- +;; +;; (portal "#modal-root" (div "content")) +;; +;; Renders children into the DOM node matched by the selector, rather than +;; into the current position. Returns a comment marker at the original +;; position. Registers a disposer to clean up portal content on island +;; teardown. + +(define render-dom-portal :effects [render] + (fn ((args :as list) (env :as dict) (ns :as string)) + (let ((selector (trampoline (eval-expr (first args) env))) + (target (or (dom-query selector) + (dom-ensure-element selector)))) + (if (not target) + (create-comment (str "portal: " selector " (not found)")) + (let ((marker (create-comment (str "portal: " selector))) + (frag (create-fragment))) + ;; Render children into the fragment + (for-each + (fn (child) (dom-append frag (render-to-dom child env ns))) + (rest args)) + ;; Track portal nodes for disposal + (let ((portal-nodes (dom-child-nodes frag))) + ;; Append into remote target + (dom-append target frag) + ;; Register disposer: remove portal content on island teardown + (register-in-scope + (fn () + (for-each (fn (n) (dom-remove n)) portal-nodes)))) + ;; Return marker at original position + marker))))) + + +;; -------------------------------------------------------------------------- +;; render-dom-error-boundary — catch errors, render fallback UI +;; -------------------------------------------------------------------------- +;; +;; (error-boundary fallback-fn body...) +;; +;; Renders body children inside a try/catch. If any child throws during +;; rendering, the fallback function is called with the error object, and +;; its result is rendered instead. Effects within the boundary are disposed +;; on error. +;; +;; The fallback function receives the error and a retry thunk: +;; (fn (err retry) ...) +;; Calling (retry) re-renders the body, replacing the fallback. + +(define render-dom-error-boundary :effects [render] + (fn ((args :as list) (env :as dict) (ns :as string)) + (let ((fallback-expr (first args)) + (body-exprs (rest args)) + (container (dom-create-element "div" nil)) + ;; retry-version: bump this signal to force re-render after fallback + (retry-version (signal 0))) + (dom-set-attr container "data-sx-boundary" "true") + + ;; The entire body is rendered inside ONE effect + try-catch. + ;; Body renders WITHOUT island scope so that if/when/cond use static + ;; paths — their signal reads become direct deref calls tracked by THIS + ;; effect. Errors from signal changes throw synchronously within try-catch. + ;; The error boundary's own effect handles all reactivity for its subtree. + (effect (fn () + ;; Touch retry-version so the effect re-runs when retry is called + (deref retry-version) + + ;; Clear container + (dom-set-prop container "innerHTML" "") + + ;; Push nil island scope to suppress reactive rendering in body. + ;; Pop in both success and error paths. + (scope-push! "sx-island-scope" nil) + (try-catch + (fn () + ;; Body renders statically — signal reads tracked by THIS effect, + ;; throws propagate to our try-catch. + (let ((frag (create-fragment))) + (for-each + (fn (child) + (dom-append frag (render-to-dom child env ns))) + body-exprs) + (dom-append container frag)) + (scope-pop! "sx-island-scope")) + (fn (err) + ;; Pop scope first, then render fallback + (scope-pop! "sx-island-scope") + (let ((fallback-fn (trampoline (eval-expr fallback-expr env))) + (retry-fn (fn () (swap! retry-version (fn (n) (+ n 1)))))) + (let ((fallback-dom + (if (lambda? fallback-fn) + (render-lambda-dom fallback-fn (list err retry-fn) env ns) + (render-to-dom (apply fallback-fn (list err retry-fn)) env ns)))) + (dom-append container fallback-dom))))))) + + container))) + + +;; -------------------------------------------------------------------------- +;; Platform interface — DOM adapter +;; -------------------------------------------------------------------------- +;; +;; Element creation: +;; (dom-create-element tag ns) → Element (ns=nil for HTML, string for SVG/MathML) +;; (create-text-node s) → Text node +;; (create-fragment) → DocumentFragment +;; (create-comment s) → Comment node +;; +;; Tree mutation: +;; (dom-append parent child) → void (appendChild) +;; (dom-set-attr el name val) → void (setAttribute) +;; (dom-remove-attr el name) → void (removeAttribute) +;; (dom-get-attr el name) → string or nil (getAttribute) +;; (dom-set-text-content n s) → void (set textContent) +;; (dom-remove node) → void (remove from parent) +;; (dom-insert-after ref node) → void (insert node after ref) +;; (dom-parent node) → parent Element or nil +;; (dom-child-nodes frag) → list of child nodes +;; (dom-remove-children-after m)→ void (remove all siblings after marker) +;; (dom-set-data el key val) → void (store arbitrary data on element) +;; (dom-get-data el key) → any (retrieve data stored on element) +;; +;; Property access (for input binding): +;; (dom-set-prop el name val) → void (set JS property: el[name] = val) +;; (dom-get-prop el name) → any (read JS property: el[name]) +;; +;; Query (for portals): +;; (dom-query selector) → Element or nil (document.querySelector) +;; +;; Event handling: +;; (dom-listen el name handler) → remove-fn (addEventListener, returns remover) +;; (dom-dispatch el name detail)→ boolean (dispatch CustomEvent, bubbles: true) +;; +;; Content parsing: +;; (dom-parse-html s) → DocumentFragment from HTML string +;; (dom-clone node) → deep clone of a DOM node +;; +;; Type checking: +;; DOM nodes have type-of → "dom-node" +;; +;; From render.sx: +;; HTML_TAGS, VOID_ELEMENTS, BOOLEAN_ATTRS, definition-form? +;; +;; From eval.sx: +;; eval-expr, trampoline, expand-macro, process-bindings, eval-cond +;; env-has?, env-get, env-set!, env-merge +;; lambda?, component?, island?, macro? +;; lambda-closure, lambda-params, lambda-body +;; component-params, component-body, component-closure, +;; component-has-children?, component-name +;; +;; From signals.sx: +;; signal, deref, reset!, swap!, computed, effect, batch +;; signal?, with-island-scope, register-in-scope +;; +;; Pure primitives used: +;; keys, get, str +;; +;; Iteration: +;; (for-each-indexed fn coll) → call fn(index, item) for each element +;; -------------------------------------------------------------------------- diff --git a/shared/static/wasm/sx/boot-helpers.sx b/shared/static/wasm/sx/boot-helpers.sx new file mode 100644 index 00000000..c46cf2fc --- /dev/null +++ b/shared/static/wasm/sx/boot-helpers.sx @@ -0,0 +1,696 @@ +;; boot-helpers.sx — Platform helpers for boot/orchestration/engine +;; +;; These were JS-native functions in the transpiled bundle. Now pure SX +;; built on the 8 FFI host primitives + dom.sx/browser.sx. + +;; -------------------------------------------------------------------------- +;; Processing markers — track which DOM elements have been bound/hydrated +;; -------------------------------------------------------------------------- + +(define _sx-bound-prefix "_sxBound") + +(define mark-processed! + (fn (el key) + (host-set! el (str _sx-bound-prefix key) true))) + +(define is-processed? + (fn (el key) + (let ((v (host-get el (str _sx-bound-prefix key)))) + (if v true false)))) + +(define clear-processed! + (fn (el key) + (host-set! el (str _sx-bound-prefix key) nil))) + +;; -------------------------------------------------------------------------- +;; Callable check +;; -------------------------------------------------------------------------- + +(define callable? + (fn (v) + (let ((t (type-of v))) + (or (= t "lambda") (= t "native-fn") (= t "continuation"))))) + +;; -------------------------------------------------------------------------- +;; String helpers +;; -------------------------------------------------------------------------- + +(define to-kebab + (fn (s) + "Convert camelCase to kebab-case." + (let ((result (list)) + (i 0)) + (let loop ((i 0)) + (when (< i (len s)) + (let ((ch (nth s i))) + (if (and (>= ch "A") (<= ch "Z")) + (do + (when (> i 0) (append! result "-")) + (append! result (lower ch))) + (append! result ch)) + (loop (+ i 1))))) + (join "" result)))) + +;; -------------------------------------------------------------------------- +;; Component / rendering helpers +;; -------------------------------------------------------------------------- + +(define sx-load-components + (fn (text) + "Parse and evaluate component definitions from text." + (when (and text (> (len text) 0)) + (let ((exprs (sx-parse text))) + (for-each (fn (expr) (cek-eval expr)) exprs))))) + +(define call-expr + (fn (expr-text &rest env-bindings) + "Parse and evaluate an SX expression string." + (let ((exprs (sx-parse expr-text))) + (when (not (empty? exprs)) + (cek-eval (first exprs)))))) + +(define base-env + (fn () + "Return the current global environment." + (global-env))) + +(define get-render-env + (fn (&rest extra) + "Get the rendering environment (global env, optionally merged with extra)." + (let ((env (global-env))) + (if (and extra (not (nil? (first extra))) (not (empty? extra))) + (env-merge env (first extra)) + env)))) + +(define merge-envs + (fn (a b) + "Merge two environments." + (if (and a b) + (env-merge a b) + (or a b (global-env))))) + +(define sx-render-with-env + (fn (source extra-env) + "Parse SX source and render to DOM fragment." + (let ((doc (host-global "document")) + (frag (host-call doc "createDocumentFragment")) + (exprs (sx-parse source))) + (for-each (fn (expr) + (let ((html (render-to-html expr))) + (when (and html (> (len html) 0)) + (let ((temp (host-call doc "createElement" "template"))) + (host-set! temp "innerHTML" html) + (host-call frag "appendChild" (host-get temp "content")))))) + exprs) + frag))) + +(define parse-env-attr + (fn (el) + "Parse data-sx-env attribute (JSON key-value pairs)." + nil)) + +(define store-env-attr + (fn (el base new-env) + nil)) + +(define resolve-mount-target + (fn (target) + "Resolve a CSS selector string to a DOM element." + (if (string? target) + (dom-query target) + target))) + +(define remove-head-element + (fn (sel) + "Remove a element matching selector." + (let ((el (dom-query sel))) + (when el + (dom-remove el))))) + +;; -------------------------------------------------------------------------- +;; Cookie helpers for component caching +;; -------------------------------------------------------------------------- + +(define set-sx-comp-cookie + (fn (hash) + (set-cookie "sx-components" hash))) + +(define clear-sx-comp-cookie + (fn () + (set-cookie "sx-components" ""))) + +;; -------------------------------------------------------------------------- +;; Logging +;; -------------------------------------------------------------------------- + +(define log-parse-error + (fn (label text err) + (log-error (str "Parse error in " label ": " err)))) + +;; -------------------------------------------------------------------------- +;; Validation stub (orchestration.sx needs this) +;; -------------------------------------------------------------------------- + +;; -------------------------------------------------------------------------- +;; Loaded component tracking +;; -------------------------------------------------------------------------- +;; +;; Returns names of components/islands loaded client-side. +;; build-request-headers uses a DOM hash instead of this list, +;; and deps-satisfied? falls back to server fetch when empty. + +(define loaded-component-names + (fn () + ;; Scan data-components script tags for loaded component names + (let ((scripts (dom-query-all (dom-body) "script[data-components]")) + (names (list))) + (for-each (fn (script) + (let ((text (or (dom-get-attr script "data-components") ""))) + (when (> (len text) 0) + (for-each (fn (name) + (when (> (len (trim name)) 0) + (append! names (trim name)))) + (split text ","))))) + scripts) + names))) + +;; -------------------------------------------------------------------------- +;; CSRF token +;; -------------------------------------------------------------------------- + +(define csrf-token + (fn () + (let ((meta (dom-query "meta[name=\"csrf-token\"]"))) + (if meta (dom-get-attr meta "content") nil)))) + +(define validate-for-request + (fn (el) true)) + +;; -------------------------------------------------------------------------- +;; Request body builder +;; -------------------------------------------------------------------------- +;; +;; For GET/HEAD: no body. If element is a form, serialize inputs as query params. +;; For POST/PUT/etc: if element is a form, build FormData body. +;; Returns dict with "url", "body", "content-type". + +(define build-request-body + (fn (el method url) + (let ((m (upper method))) + (if (or (= m "GET") (= m "HEAD")) + ;; GET/HEAD — serialize form inputs into URL query params + (if (and el (= (upper (or (dom-tag-name el) "")) "FORM")) + (let ((fd (host-new "FormData" el)) + (params (host-new "URLSearchParams" fd)) + (qs (host-call params "toString"))) + (dict "url" (if (and qs (> (len qs) 0)) + (str url (if (contains? url "?") "&" "?") qs) + url) + "body" nil + "content-type" nil)) + (dict "url" url "body" nil "content-type" nil)) + ;; POST/PUT/etc — build form body if element is a form + (if (and el (= (upper (or (dom-tag-name el) "")) "FORM")) + (let ((enctype (or (dom-get-attr el "enctype") "application/x-www-form-urlencoded"))) + (if (= enctype "multipart/form-data") + ;; Multipart: let browser set Content-Type with boundary + (let ((fd (host-new "FormData" el))) + (dict "url" url "body" fd "content-type" nil)) + ;; URL-encoded + (let ((fd (host-new "FormData" el)) + (params (host-new "URLSearchParams" fd))) + (dict "url" url + "body" (host-call params "toString") + "content-type" "application/x-www-form-urlencoded")))) + ;; Not a form — no body + (dict "url" url "body" nil "content-type" nil)))))) + +(define abort-previous-target (fn (el) nil)) +(define abort-previous (fn (el) nil)) +(define track-controller (fn (el ctrl) nil)) +(define track-controller-target (fn (el ctrl) nil)) +(define new-abort-controller (fn () (host-new "AbortController"))) +(define abort-signal (fn (ctrl) (host-get ctrl "signal"))) +(define apply-optimistic (fn (el) nil)) +(define revert-optimistic (fn (el) nil)) + +;; -------------------------------------------------------------------------- +;; DOM query helpers (used by boot.sx) +;; -------------------------------------------------------------------------- + +(define dom-has-attr? + (fn (el name) + (host-call el "hasAttribute" name))) + +;; -------------------------------------------------------------------------- +;; Loading state (indicators, disabling) +;; -------------------------------------------------------------------------- + +(define show-indicator + (fn (el) + ;; Show loading indicator. Returns indicator state for cleanup. + (let ((indicator-sel (dom-get-attr el "sx-indicator"))) + (when indicator-sel + (let ((indicator (dom-query indicator-sel))) + (when indicator + (dom-remove-class indicator "hidden") + (dom-add-class indicator "sx-indicator-visible")))) + indicator-sel))) + +(define disable-elements + (fn (el) + ;; Disable elements during request. Returns list of disabled elements. + (let ((disable-sel (dom-get-attr el "sx-disabled-elt"))) + (if disable-sel + (let ((elts (dom-query-all (dom-body) disable-sel))) + (for-each (fn (e) (dom-set-attr e "disabled" "")) elts) + elts) + (list))))) + +(define clear-loading-state + (fn (el indicator disabled-elts) + ;; Reverse loading state: hide indicator, re-enable elements + (dom-remove-class el "sx-request") + (dom-remove-attr el "aria-busy") + (when indicator + (let ((ind (dom-query indicator))) + (when ind + (dom-add-class ind "hidden") + (dom-remove-class ind "sx-indicator-visible")))) + (when disabled-elts + (for-each (fn (e) (dom-remove-attr e "disabled")) disabled-elts)))) + +;; -------------------------------------------------------------------------- +;; Abort / error helpers +;; -------------------------------------------------------------------------- + +(define abort-error? + (fn (err) + (= (host-get err "name") "AbortError"))) + +;; -------------------------------------------------------------------------- +;; Promise helpers +;; -------------------------------------------------------------------------- + +(define promise-catch + (fn (p f) + (let ((cb (host-callback f))) + (host-call p "catch" cb)))) + +;; -------------------------------------------------------------------------- +;; Fetch helpers +;; -------------------------------------------------------------------------- + +;; Override browser.sx's raw fetch-request with the higher-level interface +;; that orchestration expects: (fetch-request config success-fn error-fn) +;; config: dict with url, method, headers, body, signal, cross-origin, preloaded +;; success-fn: (fn (resp-ok status get-header text) ...) +;; error-fn: (fn (err) ...) +(define fetch-request + (fn (config success-fn error-fn) + (let ((url (get config "url")) + (method (or (get config "method") "GET")) + (headers (or (get config "headers") (dict))) + (body (get config "body")) + (signal (get config "signal")) + (preloaded (get config "preloaded"))) + ;; If preloaded content is available, use it directly + (if preloaded + (success-fn true 200 (fn (name) nil) preloaded) + ;; Build fetch options as plain JS object + (let ((h (host-new "Headers")) + (js-opts (host-new "Object"))) + (for-each (fn (k) + (host-call h "set" k (get headers k))) + (keys headers)) + (host-set! js-opts "method" method) + (host-set! js-opts "headers" h) + (when body (host-set! js-opts "body" body)) + (when signal (host-set! js-opts "signal" signal)) + ;; Execute fetch + (promise-then + (host-call (dom-window) "fetch" url js-opts) + (fn (response) + (let ((ok (host-get response "ok")) + (status (host-get response "status")) + (get-header (fn (name) (host-call (host-get response "headers") "get" name)))) + (promise-then + (host-call response "text") + (fn (text) (success-fn ok status get-header text)) + error-fn))) + error-fn)))))) + +(define fetch-location + (fn (url) + ;; Navigate to URL via fetch + swap into boost target + (let ((target (or (dom-query "[sx-boost]") (dom-query "#main-panel")))) + (when target + (browser-navigate url))))) + +(define fetch-and-restore + (fn (main url headers scroll-y) + ;; Popstate: fetch URL, swap into main, restore scroll + (fetch-request + (dict "url" url "method" "GET" "headers" headers "body" nil "signal" nil) + (fn (resp-ok status get-header text) + (when resp-ok + (dom-set-inner-html main text) + (post-swap main) + (host-call (dom-window) "scrollTo" 0 scroll-y))) + (fn (err) (log-warn (str "fetch-and-restore error: " err)))))) + +(define fetch-preload + (fn (url headers cache) + ;; Preload URL into cache dict + (fetch-request + (dict "url" url "method" "GET" "headers" headers "body" nil "signal" nil) + (fn (resp-ok status get-header text) + (when resp-ok + (preload-cache-set cache url text))) + (fn (err) nil)))) + +(define fetch-streaming + (fn (target pathname headers swap-fn) + ;; Streaming fetch — fallback to non-streaming + (fetch-and-restore target pathname headers 0))) + +;; -------------------------------------------------------------------------- +;; DOM extras +;; -------------------------------------------------------------------------- + +(define dom-parse-html-document + (fn (text) + (let ((parser (host-new "DOMParser"))) + (host-call parser "parseFromString" text "text/html")))) + +(define dom-body-inner-html + (fn (doc) + (host-get (host-get doc "body") "innerHTML"))) + +(define create-script-clone + (fn (dead) + (let ((doc (host-global "document")) + (live (host-call doc "createElement" "script"))) + ;; Copy attributes + (let ((attrs (host-get dead "attributes"))) + (let loop ((i 0)) + (when (< i (host-get attrs "length")) + (let ((attr (host-call attrs "item" i))) + (host-call live "setAttribute" + (host-get attr "name") (host-get attr "value")) + (loop (+ i 1)))))) + ;; Copy content + (host-set! live "textContent" (host-get dead "textContent")) + live))) + +(define cross-origin? + (fn (url) + (if (or (starts-with? url "http://") (starts-with? url "https://")) + (not (starts-with? url (browser-location-origin))) + false))) + +(define browser-scroll-to + (fn (x y) + (host-call (dom-window) "scrollTo" x y))) + +;; -------------------------------------------------------------------------- +;; View transitions +;; -------------------------------------------------------------------------- + +(define with-transition + (fn (enabled thunk) + (if (and enabled (host-get (host-global "document") "startViewTransition")) + (host-call (host-global "document") "startViewTransition" + (host-callback thunk)) + (thunk)))) + +;; -------------------------------------------------------------------------- +;; IntersectionObserver +;; -------------------------------------------------------------------------- + +(define observe-intersection + (fn (el callback once? delay) + (let ((cb (host-callback + (fn (entries) + (for-each (fn (entry) + (when (host-get entry "isIntersecting") + (if delay + (set-timeout (fn () (callback entry)) delay) + (callback entry)) + (when once? + (host-call observer "unobserve" el)))) + (host-call entries "forEach" (host-callback (fn (e) e)))))))) + ;; Direct approach: create observer that calls back for each entry + (let ((observer (host-new "IntersectionObserver" + (host-callback (fn (entries) + (let ((arr-len (host-get entries "length"))) + (let loop ((i 0)) + (when (< i arr-len) + (let ((entry (host-call entries "item" i))) + (when (and entry (host-get entry "isIntersecting")) + (if delay + (set-timeout (fn () (callback entry)) delay) + (callback entry)) + (when once? + (host-call observer "unobserve" el)))) + (loop (+ i 1)))))))))) + (host-call observer "observe" el) + observer)))) + +;; -------------------------------------------------------------------------- +;; EventSource (SSE) +;; -------------------------------------------------------------------------- + +(define event-source-connect + (fn (url el) + (let ((source (host-new "EventSource" url))) + (host-set! source "_sxElement" el) + source))) + +(define event-source-listen + (fn (source event-name handler) + (host-call source "addEventListener" event-name + (host-callback (fn (e) (handler e)))))) + +;; -------------------------------------------------------------------------- +;; Boost bindings +;; -------------------------------------------------------------------------- + +(define bind-boost-link + (fn (el href) + (dom-listen el "click" + (fn (e) + (when (not (event-modifier-key? e)) + (prevent-default e) + ;; Set verb attrs so execute-request can process this as a GET + (when (not (dom-has-attr? el "sx-get")) + (dom-set-attr el "sx-get" href)) + (when (not (dom-has-attr? el "sx-push-url")) + (dom-set-attr el "sx-push-url" "true")) + (execute-request el nil nil)))))) + +(define bind-boost-form + (fn (form method action) + (dom-listen form "submit" + (fn (e) + (prevent-default e) + (execute-request form nil nil))))) + +(define bind-client-route-click + (fn (link href fallback-fn) + (dom-listen link "click" + (fn (e) + (when (not (event-modifier-key? e)) + (prevent-default e) + ;; Try client routing first, fall back to server fetch + (let ((boost-el (dom-query "[sx-boost]")) + (target-sel (if boost-el + (let ((attr (dom-get-attr boost-el "sx-boost"))) + (if (and attr (not (= attr "true"))) attr "#main-panel")) + "#main-panel"))) + (if (try-client-route (url-pathname href) target-sel) + (do + (browser-push-state nil "" href) + (browser-scroll-to 0 0)) + ;; Fallback: server fetch via execute-request + (do + (when (not (dom-has-attr? link "sx-get")) + (dom-set-attr link "sx-get" href)) + (when (not (dom-has-attr? link "sx-push-url")) + (dom-set-attr link "sx-push-url" "true")) + (execute-request link nil nil))))))))) + +;; -------------------------------------------------------------------------- +;; Service worker +;; -------------------------------------------------------------------------- + +(define sw-post-message (fn (msg) nil)) + +;; -------------------------------------------------------------------------- +;; Response processing (fetch/swap pipeline) +;; -------------------------------------------------------------------------- + +(define try-parse-json + (fn (text) + (json-parse text))) + +(define strip-component-scripts + (fn (text) + ;; Remove from response text. + ;; The text may be SX (not valid HTML), so use string matching. + ;; First, load the component definitions into the environment. + (let ((result text) + (start-tag "")) + ;; Find and extract component scripts + (let loop ((s result)) + (let ((start-idx (index-of s start-tag))) + (if (= start-idx -1) + (set! result s) + (let ((after-start (+ start-idx (len start-tag))) + (rest-str (slice s (+ start-idx (len start-tag))))) + (let ((end-offset (index-of rest-str end-tag))) + (if (= end-offset -1) + (set! result s) + (let ((comp-text (slice rest-str 0 end-offset)) + (before (slice s 0 start-idx)) + (after (slice rest-str (+ end-offset (len end-tag))))) + ;; Load component definitions + (sx-load-components comp-text) + (loop (str before after))))))))) + result))) + +(define extract-response-css + (fn (text) + ;; Extract tags from response text. + ;; Apply them to the document head, return remaining text. + (let ((result text) + (start-tag "")) + (let loop ((s result)) + (let ((start-idx (index-of s start-tag))) + (if (= start-idx -1) + (set! result s) + (let ((rest-str (slice s (+ start-idx (len start-tag))))) + (let ((end-offset (index-of rest-str end-tag))) + (if (= end-offset -1) + (set! result s) + (let ((css-text (slice rest-str 0 end-offset)) + (before (slice s 0 start-idx)) + (after (slice rest-str (+ end-offset (len end-tag))))) + ;; Apply CSS to head + (let ((doc (host-global "document")) + (style-el (host-call doc "createElement" "style"))) + (host-set! style-el "textContent" css-text) + (dom-append-to-head style-el)) + (loop (str before after))))))))) + result))) + +(define sx-render + (fn (text) + ;; Parse SX text and render to a DOM fragment. + (let ((doc (host-global "document")) + (frag (host-call doc "createDocumentFragment")) + (exprs (sx-parse text))) + (for-each (fn (expr) + (let ((result (render-to-dom expr (get-render-env nil) nil))) + (when result (dom-append frag result)))) + exprs) + frag))) + +(define sx-hydrate + (fn (root) + ;; Hydrate data-sx elements in root (or document). + (sx-hydrate-elements (or root (dom-body))))) + +(define sx-process-scripts + (fn (root) + ;; Find and evaluate from response text. + ;; The text may be SX (not valid HTML), so use string matching. + ;; First, load the component definitions into the environment. + (let ((result text) + (start-tag "")) + ;; Find and extract component scripts + (let loop ((s result)) + (let ((start-idx (index-of s start-tag))) + (if (= start-idx -1) + (set! result s) + (let ((after-start (+ start-idx (len start-tag))) + (rest-str (slice s (+ start-idx (len start-tag))))) + (let ((end-offset (index-of rest-str end-tag))) + (if (= end-offset -1) + (set! result s) + (let ((comp-text (slice rest-str 0 end-offset)) + (before (slice s 0 start-idx)) + (after (slice rest-str (+ end-offset (len end-tag))))) + ;; Load component definitions + (sx-load-components comp-text) + (loop (str before after))))))))) + result))) + +(define extract-response-css + (fn (text) + ;; Extract tags from response text. + ;; Apply them to the document head, return remaining text. + (let ((result text) + (start-tag "")) + (let loop ((s result)) + (let ((start-idx (index-of s start-tag))) + (if (= start-idx -1) + (set! result s) + (let ((rest-str (slice s (+ start-idx (len start-tag))))) + (let ((end-offset (index-of rest-str end-tag))) + (if (= end-offset -1) + (set! result s) + (let ((css-text (slice rest-str 0 end-offset)) + (before (slice s 0 start-idx)) + (after (slice rest-str (+ end-offset (len end-tag))))) + ;; Apply CSS to head + (let ((doc (host-global "document")) + (style-el (host-call doc "createElement" "style"))) + (host-set! style-el "textContent" css-text) + (dom-append-to-head style-el)) + (loop (str before after))))))))) + result))) + +(define sx-render + (fn (text) + ;; Parse SX text and render to a DOM fragment. + (let ((doc (host-global "document")) + (frag (host-call doc "createDocumentFragment")) + (exprs (sx-parse text))) + (for-each (fn (expr) + (let ((result (render-to-dom expr (get-render-env nil) nil))) + (when result (dom-append frag result)))) + exprs) + frag))) + +(define sx-hydrate + (fn (root) + ;; Hydrate data-sx elements in root (or document). + (sx-hydrate-elements (or root (dom-body))))) + +(define sx-process-scripts + (fn (root) + ;; Find and evaluate