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 <thunk> 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) <noreply@anthropic.com>
This commit is contained in:
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
1366
shared/static/wasm/sx/adapter-dom.sx
Normal file
1366
shared/static/wasm/sx/adapter-dom.sx
Normal file
File diff suppressed because it is too large
Load Diff
696
shared/static/wasm/sx/boot-helpers.sx
Normal file
696
shared/static/wasm/sx/boot-helpers.sx
Normal file
@@ -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 <head> 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 <script data-components>...</script> 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 "<script type=\"text/sx\" data-components>")
|
||||
(end-tag "</script>"))
|
||||
;; 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 <style data-sx-css>...</style> tags from response text.
|
||||
;; Apply them to the document head, return remaining text.
|
||||
(let ((result text)
|
||||
(start-tag "<style data-sx-css>")
|
||||
(end-tag "</style>"))
|
||||
(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 <script type="text/sx"> in root.
|
||||
(let ((scripts (dom-query-all (or root (dom-body)) "script[type=\"text/sx\"]")))
|
||||
(for-each (fn (s)
|
||||
(when (not (is-processed? s "sx-script"))
|
||||
(mark-processed! s "sx-script")
|
||||
(let ((text (host-get s "textContent")))
|
||||
(when (and text (> (len text) 0))
|
||||
(let ((exprs (sx-parse text)))
|
||||
(for-each (fn (expr) (cek-eval expr)) exprs))))))
|
||||
scripts))))
|
||||
|
||||
(define select-from-container
|
||||
(fn (container selector)
|
||||
;; Select matching element from container, return it (not just children).
|
||||
(if selector
|
||||
(let ((selected (dom-query container selector)))
|
||||
(if selected
|
||||
selected
|
||||
(children-to-fragment container)))
|
||||
(children-to-fragment container))))
|
||||
|
||||
(define children-to-fragment
|
||||
(fn (el)
|
||||
;; Move all children of el into a DocumentFragment.
|
||||
(let ((doc (host-global "document"))
|
||||
(frag (host-call doc "createDocumentFragment")))
|
||||
(let loop ()
|
||||
(let ((child (dom-first-child el)))
|
||||
(when child
|
||||
(dom-append frag child)
|
||||
(loop))))
|
||||
frag)))
|
||||
|
||||
(define select-html-from-doc
|
||||
(fn (doc selector)
|
||||
;; Extract HTML from a parsed document, optionally selecting.
|
||||
(if selector
|
||||
(let ((el (dom-query doc selector)))
|
||||
(if el (dom-inner-html el) (dom-body-inner-html doc)))
|
||||
(dom-body-inner-html doc))))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Client routing stubs
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define find-matching-route
|
||||
(fn (pathname routes)
|
||||
;; Match pathname against registered page routes.
|
||||
;; Returns match dict or nil.
|
||||
nil))
|
||||
|
||||
(define parse-route-pattern (fn (pattern) nil))
|
||||
|
||||
(define register-io-deps (fn (deps) nil))
|
||||
|
||||
(define resolve-page-data
|
||||
(fn (page-name params &rest rest)
|
||||
nil))
|
||||
|
||||
(define parse-sx-data
|
||||
(fn (text)
|
||||
(if (and text (> (len text) 0))
|
||||
(let ((exprs (sx-parse text)))
|
||||
(if (not (empty? exprs)) (first exprs) nil))
|
||||
nil)))
|
||||
|
||||
(define try-eval-content
|
||||
(fn (content-src env)
|
||||
;; Evaluate SX content source to DOM.
|
||||
(let ((exprs (sx-parse content-src)))
|
||||
(if (empty? exprs)
|
||||
nil
|
||||
(let ((frag (create-fragment)))
|
||||
(for-each (fn (expr)
|
||||
(let ((result (render-to-dom expr env nil)))
|
||||
(when result (dom-append frag result))))
|
||||
exprs)
|
||||
frag)))))
|
||||
|
||||
(define try-async-eval-content
|
||||
(fn (content-src env &rest rest)
|
||||
;; Async variant — for now, delegate to sync.
|
||||
(try-eval-content content-src env)))
|
||||
|
||||
(define try-rerender-page (fn (&rest args) nil))
|
||||
(define execute-action (fn (&rest args) nil))
|
||||
(define bind-preload (fn (&rest args) nil))
|
||||
(define persist-offline-data (fn (&rest args) nil))
|
||||
(define retrieve-offline-data (fn (&rest args) nil))
|
||||
574
shared/static/wasm/sx/boot.sx
Normal file
574
shared/static/wasm/sx/boot.sx
Normal file
@@ -0,0 +1,574 @@
|
||||
;; ==========================================================================
|
||||
;; boot.sx — Browser boot, mount, hydrate, script processing
|
||||
;;
|
||||
;; Handles the browser startup lifecycle:
|
||||
;; 1. CSS tracking init
|
||||
;; 2. Component script processing (from <script type="text/sx">)
|
||||
;; 3. Hydration of [data-sx] elements
|
||||
;; 4. Engine element processing
|
||||
;;
|
||||
;; Also provides the public mounting/hydration API:
|
||||
;; mount, hydrate, update, render-component
|
||||
;;
|
||||
;; Depends on:
|
||||
;; orchestration.sx — process-elements, engine-init
|
||||
;; adapter-dom.sx — render-to-dom
|
||||
;; render.sx — shared registries
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Head element hoisting (full version)
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Moves <meta>, <title>, <link rel=canonical>, <script type=application/ld+json>
|
||||
;; from rendered content to <head>, deduplicating as needed.
|
||||
|
||||
(define HEAD_HOIST_SELECTOR
|
||||
"meta, title, link[rel='canonical'], script[type='application/ld+json']")
|
||||
|
||||
(define hoist-head-elements-full :effects [mutation io]
|
||||
(fn (root)
|
||||
(let ((els (dom-query-all root HEAD_HOIST_SELECTOR)))
|
||||
(for-each
|
||||
(fn (el)
|
||||
(let ((tag (lower (dom-tag-name el))))
|
||||
(cond
|
||||
;; <title> — replace document title
|
||||
(= tag "title")
|
||||
(do
|
||||
(set-document-title (dom-text-content el))
|
||||
(dom-remove-child (dom-parent el) el))
|
||||
|
||||
;; <meta> — deduplicate by name or property
|
||||
(= tag "meta")
|
||||
(do
|
||||
(let ((name (dom-get-attr el "name"))
|
||||
(prop (dom-get-attr el "property")))
|
||||
(when name
|
||||
(remove-head-element (str "meta[name=\"" name "\"]")))
|
||||
(when prop
|
||||
(remove-head-element (str "meta[property=\"" prop "\"]"))))
|
||||
(dom-remove-child (dom-parent el) el)
|
||||
(dom-append-to-head el))
|
||||
|
||||
;; <link rel=canonical> — deduplicate
|
||||
(and (= tag "link")
|
||||
(= (dom-get-attr el "rel") "canonical"))
|
||||
(do
|
||||
(remove-head-element "link[rel=\"canonical\"]")
|
||||
(dom-remove-child (dom-parent el) el)
|
||||
(dom-append-to-head el))
|
||||
|
||||
;; Everything else (ld+json, etc.) — just move
|
||||
:else
|
||||
(do
|
||||
(dom-remove-child (dom-parent el) el)
|
||||
(dom-append-to-head el)))))
|
||||
els))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Mount — render SX source into a DOM element
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define sx-mount :effects [mutation io]
|
||||
(fn (target (source :as string) (extra-env :as dict))
|
||||
;; Render SX source string into target element.
|
||||
;; target: Element or CSS selector string
|
||||
;; source: SX source string
|
||||
;; extra-env: optional extra bindings dict
|
||||
(let ((el (resolve-mount-target target)))
|
||||
(when el
|
||||
;; If the server already rendered content (isomorphic SSR),
|
||||
;; skip re-render — just hydrate the existing DOM.
|
||||
(when (empty? (dom-child-list el))
|
||||
(let ((node (sx-render-with-env source extra-env)))
|
||||
(dom-set-text-content el "")
|
||||
(dom-append el node)
|
||||
;; Hoist head elements from rendered content
|
||||
(hoist-head-elements-full el)))
|
||||
;; Process sx- attributes, hydrate data-sx and islands
|
||||
(process-elements el)
|
||||
(sx-hydrate-elements el)
|
||||
(sx-hydrate-islands el)
|
||||
(run-post-render-hooks)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Resolve Suspense — replace streaming placeholder with resolved content
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Called by inline <script> tags that arrive during chunked transfer:
|
||||
;; __sxResolve("content", "(~article :title \"Hello\")")
|
||||
;;
|
||||
;; Finds the suspense wrapper by data-suspense attribute, renders the
|
||||
;; new SX content, and replaces the wrapper's children.
|
||||
|
||||
(define resolve-suspense :effects [mutation io]
|
||||
(fn ((id :as string) (sx :as string))
|
||||
;; Process any new <script type="text/sx"> tags that arrived via
|
||||
;; streaming (e.g. extra component defs) before resolving.
|
||||
(process-sx-scripts nil)
|
||||
(let ((el (dom-query (str "[data-suspense=\"" id "\"]"))))
|
||||
(if el
|
||||
(do
|
||||
;; parse returns a list of expressions — render each individually
|
||||
;; (mirroring the public render() API).
|
||||
(let ((exprs (parse sx))
|
||||
(env (get-render-env nil)))
|
||||
(dom-set-text-content el "")
|
||||
(for-each (fn (expr)
|
||||
(dom-append el (render-to-dom expr env nil)))
|
||||
exprs)
|
||||
(process-elements el)
|
||||
(sx-hydrate-elements el)
|
||||
(sx-hydrate-islands el)
|
||||
(run-post-render-hooks)
|
||||
(dom-dispatch el "sx:resolved" {:id id})))
|
||||
(log-warn (str "resolveSuspense: no element for id=" id))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Hydrate — render all [data-sx] elements
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define sx-hydrate-elements :effects [mutation io]
|
||||
(fn (root)
|
||||
;; Find all [data-sx] elements within root and render them.
|
||||
(let ((els (dom-query-all (or root (dom-body)) "[data-sx]")))
|
||||
(for-each
|
||||
(fn (el)
|
||||
(when (not (is-processed? el "hydrated"))
|
||||
(mark-processed! el "hydrated")
|
||||
(sx-update-element el nil)))
|
||||
els))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Update — re-render a [data-sx] element with new env data
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define sx-update-element :effects [mutation io]
|
||||
(fn (el new-env)
|
||||
;; Re-render a [data-sx] element.
|
||||
;; Reads source from data-sx attr, base env from data-sx-env attr.
|
||||
(let ((target (resolve-mount-target el)))
|
||||
(when target
|
||||
(let ((source (dom-get-attr target "data-sx")))
|
||||
(when source
|
||||
(let ((base-env (parse-env-attr target))
|
||||
(env (merge-envs base-env new-env)))
|
||||
(let ((node (sx-render-with-env source env)))
|
||||
(dom-set-text-content target "")
|
||||
(dom-append target node)
|
||||
;; Update stored env if new-env provided
|
||||
(when new-env
|
||||
(store-env-attr target base-env new-env))))))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Render component — build synthetic call from kwargs dict
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define sx-render-component :effects [mutation io]
|
||||
(fn ((name :as string) (kwargs :as dict) (extra-env :as dict))
|
||||
;; Render a named component with keyword args.
|
||||
;; name: component name (with or without ~ prefix)
|
||||
;; kwargs: dict of param-name → value
|
||||
;; extra-env: optional extra env bindings
|
||||
(let ((full-name (if (starts-with? name "~") name (str "~" name))))
|
||||
(let ((env (get-render-env extra-env))
|
||||
(comp (env-get env full-name)))
|
||||
(if (not (component? comp))
|
||||
(error (str "Unknown component: " full-name))
|
||||
;; Build synthetic call expression
|
||||
(let ((call-expr (list (make-symbol full-name))))
|
||||
(for-each
|
||||
(fn ((k :as string))
|
||||
(append! call-expr (make-keyword (to-kebab k)))
|
||||
(append! call-expr (dict-get kwargs k)))
|
||||
(keys kwargs))
|
||||
(render-to-dom call-expr env nil)))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Script processing — <script type="text/sx">
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define process-sx-scripts :effects [mutation io]
|
||||
(fn (root)
|
||||
;; Process all <script type="text/sx"> tags.
|
||||
;; - data-components + data-hash → localStorage cache
|
||||
;; - data-mount="<selector>" → render into target
|
||||
;; - Default: load as components
|
||||
(let ((scripts (query-sx-scripts root)))
|
||||
(for-each
|
||||
(fn (s)
|
||||
(when (not (is-processed? s "script"))
|
||||
(mark-processed! s "script")
|
||||
(let ((text (dom-text-content s)))
|
||||
(cond
|
||||
;; Component definitions
|
||||
(dom-has-attr? s "data-components")
|
||||
(process-component-script s text)
|
||||
|
||||
;; Empty script — skip
|
||||
(or (nil? text) (empty? (trim text)))
|
||||
nil
|
||||
|
||||
;; Init scripts — evaluate SX for side effects (event listeners etc.)
|
||||
(dom-has-attr? s "data-init")
|
||||
(let ((exprs (sx-parse text)))
|
||||
(for-each
|
||||
(fn (expr) (eval-expr expr (env-extend (dict))))
|
||||
exprs))
|
||||
|
||||
;; Mount directive
|
||||
(dom-has-attr? s "data-mount")
|
||||
(let ((mount-sel (dom-get-attr s "data-mount"))
|
||||
(target (dom-query mount-sel)))
|
||||
(when target
|
||||
(sx-mount target text nil)))
|
||||
|
||||
;; Default: load as components
|
||||
:else
|
||||
(sx-load-components text)))))
|
||||
scripts))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Component script with caching
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define process-component-script :effects [mutation io]
|
||||
(fn (script (text :as string))
|
||||
;; Handle <script type="text/sx" data-components data-hash="...">
|
||||
(let ((hash (dom-get-attr script "data-hash")))
|
||||
(if (nil? hash)
|
||||
;; Legacy: no hash — just load inline
|
||||
(when (and text (not (empty? (trim text))))
|
||||
(sx-load-components text))
|
||||
;; Hash-based caching
|
||||
(let ((has-inline (and text (not (empty? (trim text))))))
|
||||
(let ((cached-hash (local-storage-get "sx-components-hash")))
|
||||
(if (= cached-hash hash)
|
||||
;; Cache hit
|
||||
(if has-inline
|
||||
;; Server sent full source (cookie stale) — update cache
|
||||
(do
|
||||
(local-storage-set "sx-components-hash" hash)
|
||||
(local-storage-set "sx-components-src" text)
|
||||
(sx-load-components text)
|
||||
(log-info "components: downloaded (cookie stale)"))
|
||||
;; Server omitted source — load from cache
|
||||
(let ((cached (local-storage-get "sx-components-src")))
|
||||
(if cached
|
||||
(do
|
||||
(sx-load-components cached)
|
||||
(log-info (str "components: cached (" hash ")")))
|
||||
;; Cache entry missing — clear cookie and reload
|
||||
(do
|
||||
(clear-sx-comp-cookie)
|
||||
(browser-reload)))))
|
||||
;; Cache miss — hash mismatch
|
||||
(if has-inline
|
||||
;; Server sent full source — cache it
|
||||
(do
|
||||
(local-storage-set "sx-components-hash" hash)
|
||||
(local-storage-set "sx-components-src" text)
|
||||
(sx-load-components text)
|
||||
(log-info (str "components: downloaded (" hash ")")))
|
||||
;; Server omitted but cache stale — clear and reload
|
||||
(do
|
||||
(local-storage-remove "sx-components-hash")
|
||||
(local-storage-remove "sx-components-src")
|
||||
(clear-sx-comp-cookie)
|
||||
(browser-reload)))))
|
||||
(set-sx-comp-cookie hash))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Page registry for client-side routing
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define _page-routes (list))
|
||||
|
||||
(define process-page-scripts :effects [mutation io]
|
||||
(fn ()
|
||||
;; Process <script type="text/sx-pages"> tags.
|
||||
;; Parses SX page registry and builds route entries with parsed patterns.
|
||||
(let ((scripts (query-page-scripts)))
|
||||
(log-info (str "pages: found " (len scripts) " script tags"))
|
||||
(for-each
|
||||
(fn (s)
|
||||
(when (not (is-processed? s "pages"))
|
||||
(mark-processed! s "pages")
|
||||
(let ((text (dom-text-content s)))
|
||||
(log-info (str "pages: script text length=" (if text (len text) 0)))
|
||||
(if (and text (not (empty? (trim text))))
|
||||
(let ((pages (parse text)))
|
||||
(log-info (str "pages: parsed " (len pages) " entries"))
|
||||
(for-each
|
||||
(fn ((page :as dict))
|
||||
(append! _page-routes
|
||||
(merge page
|
||||
{"parsed" (parse-route-pattern (get page "path"))})))
|
||||
pages))
|
||||
(log-warn "pages: script tag is empty")))))
|
||||
scripts)
|
||||
(log-info (str "pages: " (len _page-routes) " routes loaded")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Island hydration — activate reactive islands from SSR output
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; The server renders islands as:
|
||||
;; <div data-sx-island="counter" data-sx-state='{"initial": 0}'>
|
||||
;; ...static HTML...
|
||||
;; </div>
|
||||
;;
|
||||
;; Hydration:
|
||||
;; 1. Find all [data-sx-island] elements
|
||||
;; 2. Look up the island component by name
|
||||
;; 3. Parse data-sx-state into kwargs
|
||||
;; 4. Re-render the island body in a reactive context
|
||||
;; 5. Morph existing DOM to preserve structure, focus, scroll
|
||||
;; 6. Store disposers on the element for cleanup
|
||||
|
||||
(define sx-hydrate-islands :effects [mutation io]
|
||||
(fn (root)
|
||||
(let ((els (dom-query-all (or root (dom-body)) "[data-sx-island]")))
|
||||
(log-info (str "sx-hydrate-islands: " (len els) " island(s) in " (if root "subtree" "document")))
|
||||
(for-each
|
||||
(fn (el)
|
||||
(if (is-processed? el "island-hydrated")
|
||||
(log-info (str " skip (already hydrated): " (dom-get-attr el "data-sx-island")))
|
||||
(do
|
||||
(log-info (str " hydrating: " (dom-get-attr el "data-sx-island")))
|
||||
(mark-processed! el "island-hydrated")
|
||||
(hydrate-island el))))
|
||||
els))))
|
||||
|
||||
(define hydrate-island :effects [mutation io]
|
||||
(fn (el)
|
||||
(let ((name (dom-get-attr el "data-sx-island"))
|
||||
(state-sx (or (dom-get-attr el "data-sx-state") "{}")))
|
||||
(let ((comp-name (str "~" name))
|
||||
(env (get-render-env nil)))
|
||||
(let ((comp (env-get env comp-name)))
|
||||
(if (not (or (component? comp) (island? comp)))
|
||||
(log-warn (str "hydrate-island: unknown island " comp-name))
|
||||
|
||||
;; Parse state and build keyword args — SX format, not JSON
|
||||
(let ((kwargs (or (first (sx-parse state-sx)) {}))
|
||||
(disposers (list))
|
||||
(local (env-merge (component-closure comp) env)))
|
||||
|
||||
;; Bind params from kwargs
|
||||
(for-each
|
||||
(fn ((p :as string))
|
||||
(env-bind! local p (if (dict-has? kwargs p) (dict-get kwargs p) nil)))
|
||||
(component-params comp))
|
||||
|
||||
;; Render the island body in a reactive scope
|
||||
(let ((body-dom
|
||||
(with-island-scope
|
||||
(fn (disposable) (append! disposers disposable))
|
||||
(fn () (render-to-dom (component-body comp) local nil)))))
|
||||
|
||||
;; Clear existing content and append reactive DOM directly.
|
||||
;; Unlike morph-children, this preserves addEventListener-based
|
||||
;; event handlers on the freshly rendered nodes.
|
||||
(dom-set-text-content el "")
|
||||
(dom-append el body-dom)
|
||||
|
||||
;; Store disposers for cleanup
|
||||
(dom-set-data el "sx-disposers" disposers)
|
||||
|
||||
;; Process any sx- attributes on new content
|
||||
(process-elements el)
|
||||
|
||||
(log-info (str "hydrated island: " comp-name
|
||||
" (" (len disposers) " disposers)"))))))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Island disposal — clean up when island removed from DOM
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define dispose-island :effects [mutation io]
|
||||
(fn (el)
|
||||
(let ((disposers (dom-get-data el "sx-disposers")))
|
||||
(when disposers
|
||||
(for-each
|
||||
(fn ((d :as lambda))
|
||||
(when (callable? d) (d)))
|
||||
disposers)
|
||||
(dom-set-data el "sx-disposers" nil)))
|
||||
;; Clear hydration marker so the island can be re-hydrated
|
||||
(clear-processed! el "island-hydrated")))
|
||||
|
||||
(define dispose-islands-in :effects [mutation io]
|
||||
(fn (root)
|
||||
;; Dispose islands within root, but SKIP hydrated islands —
|
||||
;; they may be preserved across morphs. Only dispose islands
|
||||
;; that are not currently hydrated (e.g. freshly parsed content
|
||||
;; being discarded) or that have been explicitly detached.
|
||||
(when root
|
||||
(let ((islands (dom-query-all root "[data-sx-island]")))
|
||||
(when (and islands (not (empty? islands)))
|
||||
(let ((to-dispose (filter
|
||||
(fn (el) (not (is-processed? el "island-hydrated")))
|
||||
islands)))
|
||||
(when (not (empty? to-dispose))
|
||||
(log-info (str "disposing " (len to-dispose) " island(s)"))
|
||||
(for-each dispose-island to-dispose))))))))
|
||||
|
||||
(define force-dispose-islands-in :effects [mutation io]
|
||||
(fn (root)
|
||||
;; Dispose ALL islands in root, including hydrated ones.
|
||||
;; Used when the target is being completely replaced (outerHTML swap).
|
||||
(when root
|
||||
(let ((islands (dom-query-all root "[data-sx-island]")))
|
||||
(when (and islands (not (empty? islands)))
|
||||
(log-info (str "force-disposing " (len islands) " island(s)"))
|
||||
(for-each dispose-island islands))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Render hooks — generic pre/post callbacks for hydration, swap, mount.
|
||||
;; The spec calls these at render boundaries; the app decides what to do.
|
||||
;; Pre-render: setup before DOM changes (e.g. prepare state).
|
||||
;; Post-render: cleanup after DOM changes (e.g. flush collected CSS).
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define *pre-render-hooks* (list))
|
||||
(define *post-render-hooks* (list))
|
||||
|
||||
(define register-pre-render-hook :effects [mutation]
|
||||
(fn ((hook-fn :as lambda))
|
||||
(append! *pre-render-hooks* hook-fn)))
|
||||
|
||||
(define register-post-render-hook :effects [mutation]
|
||||
(fn ((hook-fn :as lambda))
|
||||
(append! *post-render-hooks* hook-fn)))
|
||||
|
||||
(define run-pre-render-hooks :effects [mutation io]
|
||||
(fn ()
|
||||
(for-each (fn (hook) (cek-call hook nil)) *pre-render-hooks*)))
|
||||
|
||||
(define run-post-render-hooks :effects [mutation io]
|
||||
(fn ()
|
||||
(log-info (str "run-post-render-hooks: " (len *post-render-hooks*) " hooks"))
|
||||
(for-each (fn (hook)
|
||||
(log-info (str " hook type: " (type-of hook) " callable: " (callable? hook) " lambda: " (lambda? hook)))
|
||||
(cek-call hook nil))
|
||||
*post-render-hooks*)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Full boot sequence
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define boot-init :effects [mutation io]
|
||||
(fn ()
|
||||
;; Full browser initialization:
|
||||
;; 1. CSS tracking
|
||||
;; 2. Style dictionary
|
||||
;; 3. Process scripts (components + mounts)
|
||||
;; 4. Process page registry (client-side routing)
|
||||
;; 5. Hydrate [data-sx] elements
|
||||
;; 6. Hydrate [data-sx-island] elements (reactive islands)
|
||||
;; 7. Process engine elements
|
||||
(do
|
||||
(log-info (str "sx-browser " SX_VERSION))
|
||||
(init-css-tracking)
|
||||
(process-page-scripts)
|
||||
(process-sx-scripts nil)
|
||||
(sx-hydrate-elements nil)
|
||||
(sx-hydrate-islands nil)
|
||||
(run-post-render-hooks)
|
||||
(process-elements nil)
|
||||
;; Wire up popstate for back/forward navigation
|
||||
(dom-listen (dom-window) "popstate"
|
||||
(fn (e) (handle-popstate 0))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Platform interface — Boot
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; From orchestration.sx:
|
||||
;; process-elements, init-css-tracking
|
||||
;;
|
||||
;; === DOM / Render ===
|
||||
;; (resolve-mount-target target) → Element (string → querySelector, else identity)
|
||||
;; (sx-render-with-env source extra-env) → DOM node (parse + render with componentEnv + extra)
|
||||
;; (get-render-env extra-env) → merged component env + extra
|
||||
;; (merge-envs base new) → merged env dict
|
||||
;; (render-to-dom expr env ns) → DOM node
|
||||
;; (sx-load-components text) → void (parse + eval into componentEnv)
|
||||
;;
|
||||
;; === DOM queries ===
|
||||
;; (dom-query sel) → Element or nil
|
||||
;; (dom-query-all root sel) → list of Elements
|
||||
;; (dom-body) → document.body
|
||||
;; (dom-get-attr el name) → string or nil
|
||||
;; (dom-has-attr? el name) → boolean
|
||||
;; (dom-text-content el) → string
|
||||
;; (dom-set-text-content el s) → void
|
||||
;; (dom-append el child) → void
|
||||
;; (dom-remove-child parent el) → void
|
||||
;; (dom-parent el) → Element
|
||||
;; (dom-append-to-head el) → void
|
||||
;; (dom-tag-name el) → string
|
||||
;;
|
||||
;; === Head hoisting ===
|
||||
;; (set-document-title s) → void (document.title = s)
|
||||
;; (remove-head-element sel) → void (remove matching element from <head>)
|
||||
;;
|
||||
;; === Script queries ===
|
||||
;; (query-sx-scripts root) → list of <script type="text/sx"> elements
|
||||
;; (query-page-scripts) → list of <script type="text/sx-pages"> elements
|
||||
;;
|
||||
;; === localStorage ===
|
||||
;; (local-storage-get key) → string or nil
|
||||
;; (local-storage-set key val) → void
|
||||
;; (local-storage-remove key) → void
|
||||
;;
|
||||
;; === Cookies ===
|
||||
;; (set-sx-comp-cookie hash) → void
|
||||
;; (clear-sx-comp-cookie) → void
|
||||
;;
|
||||
;; === Env ===
|
||||
;; (parse-env-attr el) → dict (parse data-sx-env JSON attr)
|
||||
;; (store-env-attr el base new) → void (merge and store back as JSON)
|
||||
;; (to-kebab s) → string (underscore → kebab-case)
|
||||
;;
|
||||
;; === Logging ===
|
||||
;; (log-info msg) → void (console.log with prefix)
|
||||
;; (log-parse-error label text err) → void (diagnostic parse error)
|
||||
;;
|
||||
;; === Parsing (island state) ===
|
||||
;; (sx-parse str) → list of AST expressions (from parser.sx)
|
||||
;;
|
||||
;; === Processing markers ===
|
||||
;; (mark-processed! el key) → void
|
||||
;; (is-processed? el key) → boolean
|
||||
;;
|
||||
;; === Morph ===
|
||||
;; (morph-children target source) → void (morph target's children to match source)
|
||||
;;
|
||||
;; === Island support (from adapter-dom.sx / signals.sx) ===
|
||||
;; (island? x) → boolean
|
||||
;; (component-closure comp) → env
|
||||
;; (component-params comp) → list of param names
|
||||
;; (component-body comp) → AST
|
||||
;; (component-name comp) → string
|
||||
;; (component-has-children? comp) → boolean
|
||||
;; (with-island-scope scope-fn body-fn) → result (track disposables)
|
||||
;; (render-to-dom expr env ns) → DOM node
|
||||
;; (dom-get-data el key) → any (from el._sxData)
|
||||
;; (dom-set-data el key val) → void
|
||||
;; --------------------------------------------------------------------------
|
||||
227
shared/static/wasm/sx/browser.sx
Normal file
227
shared/static/wasm/sx/browser.sx
Normal file
@@ -0,0 +1,227 @@
|
||||
;; ==========================================================================
|
||||
;; browser.sx — Browser API library functions
|
||||
;;
|
||||
;; Location, history, storage, cookies, timers, fetch — all expressed
|
||||
;; using the host FFI primitives. Library functions, not primitives.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Location & navigation
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define browser-location-href
|
||||
(fn ()
|
||||
(host-get (host-get (dom-window) "location") "href")))
|
||||
|
||||
(define browser-location-pathname
|
||||
(fn ()
|
||||
(host-get (host-get (dom-window) "location") "pathname")))
|
||||
|
||||
(define browser-location-origin
|
||||
(fn ()
|
||||
(host-get (host-get (dom-window) "location") "origin")))
|
||||
|
||||
(define browser-same-origin?
|
||||
(fn (url)
|
||||
(starts-with? url (browser-location-origin))))
|
||||
|
||||
;; Extract pathname from a URL string using the URL API
|
||||
(define url-pathname
|
||||
(fn (url)
|
||||
(host-get (host-new "URL" url (browser-location-origin)) "pathname")))
|
||||
|
||||
(define browser-push-state
|
||||
(fn (url-or-state &rest rest)
|
||||
(if (empty? rest)
|
||||
;; Single arg: just URL
|
||||
(host-call (host-get (dom-window) "history") "pushState" nil "" url-or-state)
|
||||
;; Three args: state, title, url
|
||||
(host-call (host-get (dom-window) "history") "pushState" url-or-state (first rest) (nth rest 1)))))
|
||||
|
||||
(define browser-replace-state
|
||||
(fn (url-or-state &rest rest)
|
||||
(if (empty? rest)
|
||||
(host-call (host-get (dom-window) "history") "replaceState" nil "" url-or-state)
|
||||
(host-call (host-get (dom-window) "history") "replaceState" url-or-state (first rest) (nth rest 1)))))
|
||||
|
||||
(define browser-reload
|
||||
(fn ()
|
||||
(host-call (host-get (dom-window) "location") "reload")))
|
||||
|
||||
(define browser-navigate
|
||||
(fn (url)
|
||||
(host-set! (host-get (dom-window) "location") "href" url)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Storage
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define local-storage-get
|
||||
(fn (key)
|
||||
(host-call (host-get (dom-window) "localStorage") "getItem" key)))
|
||||
|
||||
(define local-storage-set
|
||||
(fn (key val)
|
||||
(host-call (host-get (dom-window) "localStorage") "setItem" key val)))
|
||||
|
||||
(define local-storage-remove
|
||||
(fn (key)
|
||||
(host-call (host-get (dom-window) "localStorage") "removeItem" key)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Timers
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define set-timeout
|
||||
(fn (fn-val ms)
|
||||
(host-call (dom-window) "setTimeout" (host-callback fn-val) ms)))
|
||||
|
||||
(define set-interval
|
||||
(fn (fn-val ms)
|
||||
(host-call (dom-window) "setInterval" (host-callback fn-val) ms)))
|
||||
|
||||
(define clear-timeout
|
||||
(fn (id)
|
||||
(host-call (dom-window) "clearTimeout" id)))
|
||||
|
||||
(define clear-interval
|
||||
(fn (id)
|
||||
(host-call (dom-window) "clearInterval" id)))
|
||||
|
||||
(define request-animation-frame
|
||||
(fn (fn-val)
|
||||
(host-call (dom-window) "requestAnimationFrame" (host-callback fn-val))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Fetch
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define fetch-request
|
||||
(fn (url opts)
|
||||
(host-call (dom-window) "fetch" url opts)))
|
||||
|
||||
(define new-abort-controller
|
||||
(fn ()
|
||||
(host-new "AbortController")))
|
||||
|
||||
(define controller-signal
|
||||
(fn (controller)
|
||||
(host-get controller "signal")))
|
||||
|
||||
(define controller-abort
|
||||
(fn (controller)
|
||||
(host-call controller "abort")))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Promises
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define promise-then
|
||||
(fn (p on-resolve on-reject)
|
||||
(let ((cb-resolve (host-callback on-resolve))
|
||||
(cb-reject (if on-reject (host-callback on-reject) nil)))
|
||||
(if cb-reject
|
||||
(host-call (host-call p "then" cb-resolve) "catch" cb-reject)
|
||||
(host-call p "then" cb-resolve)))))
|
||||
|
||||
(define promise-resolve
|
||||
(fn (val)
|
||||
(host-call (host-global "Promise") "resolve" val)))
|
||||
|
||||
(define promise-delayed
|
||||
(fn (ms val)
|
||||
(host-new "Promise" (host-callback
|
||||
(fn (resolve)
|
||||
(set-timeout (fn () (host-call resolve "call" nil val)) ms))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Dialogs & media
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define browser-confirm
|
||||
(fn (msg) (host-call (dom-window) "confirm" msg)))
|
||||
|
||||
(define browser-prompt
|
||||
(fn (msg default)
|
||||
(host-call (dom-window) "prompt" msg default)))
|
||||
|
||||
(define browser-media-matches?
|
||||
(fn (query)
|
||||
(host-get (host-call (dom-window) "matchMedia" query) "matches")))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; JSON
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define json-parse
|
||||
(fn (s)
|
||||
(host-call (host-global "JSON") "parse" s)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Console
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define log-info
|
||||
(fn (msg)
|
||||
(host-call (host-global "console") "log" (str "[sx] " msg))))
|
||||
|
||||
(define log-warn
|
||||
(fn (msg)
|
||||
(host-call (host-global "console") "warn" (str "[sx] " msg))))
|
||||
|
||||
(define console-log
|
||||
(fn (&rest args)
|
||||
(host-call (host-global "console") "log"
|
||||
(join " " (cons "[sx]" (map str args))))))
|
||||
|
||||
(define now-ms
|
||||
(fn ()
|
||||
(host-call (host-global "Date") "now")))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Scheduling
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define schedule-idle
|
||||
(fn (f)
|
||||
(let ((cb (host-callback (fn (_deadline) (f)))))
|
||||
(if (host-get (dom-window) "requestIdleCallback")
|
||||
(host-call (dom-window) "requestIdleCallback" cb)
|
||||
(set-timeout cb 0)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Cookies
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define set-cookie
|
||||
(fn (name value days)
|
||||
(let ((d (or days 365))
|
||||
(expires (host-call
|
||||
(host-new "Date"
|
||||
(+ (host-call (host-global "Date") "now")
|
||||
(* d 864e5)))
|
||||
"toUTCString")))
|
||||
(host-set! (dom-document) "cookie"
|
||||
(str name "="
|
||||
(host-call nil "encodeURIComponent" value)
|
||||
";expires=" expires ";path=/;SameSite=Lax")))))
|
||||
|
||||
(define get-cookie
|
||||
(fn (name)
|
||||
(let ((cookies (host-get (dom-document) "cookie"))
|
||||
(match (host-call cookies "match"
|
||||
(host-new "RegExp"
|
||||
(str "(?:^|;\\s*)" name "=([^;]*)")))))
|
||||
(if match
|
||||
(host-call nil "decodeURIComponent" (host-get match 1))
|
||||
nil))))
|
||||
429
shared/static/wasm/sx/dom.sx
Normal file
429
shared/static/wasm/sx/dom.sx
Normal file
@@ -0,0 +1,429 @@
|
||||
;; ==========================================================================
|
||||
;; dom.sx — DOM library functions
|
||||
;;
|
||||
;; All DOM operations expressed using the host FFI primitives:
|
||||
;; host-get — read property from host object
|
||||
;; host-set! — write property on host object
|
||||
;; host-call — call method on host object
|
||||
;; host-new — construct host object
|
||||
;; host-global — access global (window/document/etc.)
|
||||
;; host-callback — wrap SX function as host callback
|
||||
;; host-typeof — check host object type
|
||||
;;
|
||||
;; These are LIBRARY FUNCTIONS — portable, auditable, in-band SX.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Globals
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define dom-document (fn () (host-global "document")))
|
||||
(define dom-window (fn () (host-global "window")))
|
||||
(define dom-body (fn () (host-get (dom-document) "body")))
|
||||
(define dom-head (fn () (host-get (dom-document) "head")))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Node creation
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define dom-create-element
|
||||
(fn (tag &rest ns-arg)
|
||||
(let ((ns (if (and ns-arg (not (empty? ns-arg))) (first ns-arg) nil)))
|
||||
(if ns
|
||||
(host-call (dom-document) "createElementNS" ns tag)
|
||||
(host-call (dom-document) "createElement" tag)))))
|
||||
|
||||
(define create-text-node
|
||||
(fn (s)
|
||||
(host-call (dom-document) "createTextNode" s)))
|
||||
|
||||
(define create-fragment
|
||||
(fn ()
|
||||
(host-call (dom-document) "createDocumentFragment")))
|
||||
|
||||
(define create-comment
|
||||
(fn (text)
|
||||
(host-call (dom-document) "createComment" (or text ""))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Tree manipulation
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define dom-append
|
||||
(fn (parent child)
|
||||
(when (and parent child)
|
||||
(host-call parent "appendChild" child))))
|
||||
|
||||
(define dom-prepend
|
||||
(fn (parent child)
|
||||
(when (and parent child)
|
||||
(host-call parent "prepend" child))))
|
||||
|
||||
(define dom-insert-before
|
||||
(fn (parent child ref)
|
||||
(when (and parent child)
|
||||
(host-call parent "insertBefore" child ref))))
|
||||
|
||||
(define dom-insert-after
|
||||
(fn (ref node)
|
||||
"Insert node after ref in the same parent."
|
||||
(let ((parent (host-get ref "parentNode"))
|
||||
(next (host-get ref "nextSibling")))
|
||||
(when parent
|
||||
(if next
|
||||
(host-call parent "insertBefore" node next)
|
||||
(host-call parent "appendChild" node))))))
|
||||
|
||||
(define dom-remove
|
||||
(fn (el)
|
||||
(when el (host-call el "remove"))))
|
||||
|
||||
(define dom-is-active-element?
|
||||
(fn (el)
|
||||
(let ((active (host-get (dom-document) "activeElement")))
|
||||
(if (and active el)
|
||||
(identical? el active)
|
||||
false))))
|
||||
|
||||
(define dom-is-input-element?
|
||||
(fn (el)
|
||||
(let ((tag (upper (or (dom-tag-name el) ""))))
|
||||
(or (= tag "INPUT") (= tag "TEXTAREA") (= tag "SELECT")))))
|
||||
|
||||
(define dom-is-child-of?
|
||||
(fn (child parent)
|
||||
(and child parent (host-call parent "contains" child))))
|
||||
|
||||
(define dom-on
|
||||
(fn (el event-name handler)
|
||||
(host-call el "addEventListener" event-name (host-callback handler))))
|
||||
|
||||
(define dom-attr-list
|
||||
(fn (el)
|
||||
;; Return list of (name value) pairs for all attributes on the element.
|
||||
(let ((attrs (host-get el "attributes"))
|
||||
(result (list)))
|
||||
(when attrs
|
||||
(let ((n (host-get attrs "length")))
|
||||
(let loop ((i 0))
|
||||
(when (< i n)
|
||||
(let ((attr (host-call attrs "item" i)))
|
||||
(append! result (list (host-get attr "name") (host-get attr "value"))))
|
||||
(loop (+ i 1))))))
|
||||
result)))
|
||||
|
||||
(define dom-remove-child
|
||||
(fn (parent child)
|
||||
(when (and parent child)
|
||||
(host-call parent "removeChild" child))))
|
||||
|
||||
(define dom-replace-child
|
||||
(fn (parent new-child old-child)
|
||||
(when (and parent new-child old-child)
|
||||
(host-call parent "replaceChild" new-child old-child))))
|
||||
|
||||
(define dom-clone
|
||||
(fn (node deep)
|
||||
(host-call node "cloneNode" (if (nil? deep) true deep))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Queries
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define dom-query
|
||||
(fn (root-or-sel &rest rest)
|
||||
(if (empty? rest)
|
||||
;; Single arg: selector on document
|
||||
(host-call (dom-document) "querySelector" root-or-sel)
|
||||
;; Two args: root element + selector
|
||||
(host-call root-or-sel "querySelector" (first rest)))))
|
||||
|
||||
(define dom-query-all
|
||||
(fn (root sel)
|
||||
"Query DOM and return an SX list (not a host NodeList)."
|
||||
(let ((node-list (if (nil? sel)
|
||||
(host-call (dom-document) "querySelectorAll" root)
|
||||
(host-call root "querySelectorAll" sel))))
|
||||
;; Convert NodeList → SX list by indexing
|
||||
(if (nil? node-list)
|
||||
(list)
|
||||
(let ((n (host-get node-list "length"))
|
||||
(result (list)))
|
||||
(let loop ((i 0))
|
||||
(when (< i n)
|
||||
(append! result (host-call node-list "item" i))
|
||||
(loop (+ i 1))))
|
||||
result)))))
|
||||
|
||||
(define dom-query-by-id
|
||||
(fn (id)
|
||||
(host-call (dom-document) "getElementById" id)))
|
||||
|
||||
(define dom-closest
|
||||
(fn (el sel)
|
||||
(when el (host-call el "closest" sel))))
|
||||
|
||||
(define dom-matches?
|
||||
(fn (el sel)
|
||||
(if (and el (host-get el "matches"))
|
||||
(host-call el "matches" sel)
|
||||
false)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Attributes
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define dom-get-attr
|
||||
(fn (el name)
|
||||
(if (and el (host-get el "getAttribute"))
|
||||
(let ((v (host-call el "getAttribute" name)))
|
||||
(if (nil? v) nil v))
|
||||
nil)))
|
||||
|
||||
(define dom-set-attr
|
||||
(fn (el name val)
|
||||
(when (and el (host-get el "setAttribute"))
|
||||
(host-call el "setAttribute" name val))))
|
||||
|
||||
(define dom-remove-attr
|
||||
(fn (el name)
|
||||
(when (and el (host-get el "removeAttribute"))
|
||||
(host-call el "removeAttribute" name))))
|
||||
|
||||
(define dom-has-attr?
|
||||
(fn (el name)
|
||||
(if (and el (host-get el "hasAttribute"))
|
||||
(host-call el "hasAttribute" name)
|
||||
false)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Classes
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define dom-add-class
|
||||
(fn (el cls)
|
||||
(when el
|
||||
(host-call (host-get el "classList") "add" cls))))
|
||||
|
||||
(define dom-remove-class
|
||||
(fn (el cls)
|
||||
(when el
|
||||
(host-call (host-get el "classList") "remove" cls))))
|
||||
|
||||
(define dom-has-class?
|
||||
(fn (el cls)
|
||||
(if el
|
||||
(host-call (host-get el "classList") "contains" cls)
|
||||
false)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Content
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define dom-text-content
|
||||
(fn (el) (host-get el "textContent")))
|
||||
|
||||
(define dom-set-text-content
|
||||
(fn (el val) (host-set! el "textContent" val)))
|
||||
|
||||
(define dom-inner-html
|
||||
(fn (el) (host-get el "innerHTML")))
|
||||
|
||||
(define dom-set-inner-html
|
||||
(fn (el val) (host-set! el "innerHTML" val)))
|
||||
|
||||
(define dom-outer-html
|
||||
(fn (el) (host-get el "outerHTML")))
|
||||
|
||||
(define dom-insert-adjacent-html
|
||||
(fn (el position html)
|
||||
(host-call el "insertAdjacentHTML" position html)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Style & properties
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define dom-get-style
|
||||
(fn (el prop)
|
||||
(host-get (host-get el "style") prop)))
|
||||
|
||||
(define dom-set-style
|
||||
(fn (el prop val)
|
||||
(host-call (host-get el "style") "setProperty" prop val)))
|
||||
|
||||
(define dom-get-prop
|
||||
(fn (el name) (host-get el name)))
|
||||
|
||||
(define dom-set-prop
|
||||
(fn (el name val) (host-set! el name val)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Node info
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define dom-tag-name
|
||||
(fn (el)
|
||||
(if el (lower (or (host-get el "tagName") "")) "")))
|
||||
|
||||
(define dom-node-type
|
||||
(fn (el) (host-get el "nodeType")))
|
||||
|
||||
(define dom-node-name
|
||||
(fn (el) (host-get el "nodeName")))
|
||||
|
||||
(define dom-id
|
||||
(fn (el) (host-get el "id")))
|
||||
|
||||
(define dom-parent
|
||||
(fn (el) (host-get el "parentNode")))
|
||||
|
||||
(define dom-first-child
|
||||
(fn (el) (host-get el "firstChild")))
|
||||
|
||||
(define dom-next-sibling
|
||||
(fn (el) (host-get el "nextSibling")))
|
||||
|
||||
(define dom-child-list
|
||||
(fn (el)
|
||||
"Return child nodes as an SX list."
|
||||
(if el
|
||||
(let ((nl (host-get el "childNodes"))
|
||||
(n (host-get nl "length"))
|
||||
(result (list)))
|
||||
(let loop ((i 0))
|
||||
(when (< i n)
|
||||
(append! result (host-call nl "item" i))
|
||||
(loop (+ i 1))))
|
||||
result)
|
||||
(list))))
|
||||
|
||||
(define dom-is-fragment?
|
||||
(fn (el) (= (host-get el "nodeType") 11)))
|
||||
|
||||
(define dom-child-nodes
|
||||
(fn (el)
|
||||
"Return child nodes as an SX list."
|
||||
(if el
|
||||
(let ((nl (host-get el "childNodes"))
|
||||
(n (host-get nl "length"))
|
||||
(result (list)))
|
||||
(let loop ((i 0))
|
||||
(when (< i n)
|
||||
(append! result (host-call nl "item" i))
|
||||
(loop (+ i 1))))
|
||||
result)
|
||||
(list))))
|
||||
|
||||
(define dom-remove-children-after
|
||||
(fn (marker)
|
||||
"Remove all siblings after marker node."
|
||||
(let ((parent (dom-parent marker)))
|
||||
(when parent
|
||||
(let loop ()
|
||||
(let ((next (dom-next-sibling marker)))
|
||||
(when next
|
||||
(host-call parent "removeChild" next)
|
||||
(loop))))))))
|
||||
|
||||
(define dom-focus
|
||||
(fn (el) (when el (host-call el "focus"))))
|
||||
|
||||
(define dom-parse-html
|
||||
(fn (html)
|
||||
(let ((parser (host-new "DOMParser"))
|
||||
(doc (host-call parser "parseFromString" html "text/html")))
|
||||
(host-get (host-get doc "body") "childNodes"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Events
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define dom-listen
|
||||
(fn (el event-name handler)
|
||||
(let ((cb (host-callback handler)))
|
||||
(host-call el "addEventListener" event-name cb)
|
||||
;; Return cleanup function
|
||||
(fn () (host-call el "removeEventListener" event-name cb)))))
|
||||
|
||||
;; dom-add-listener — addEventListener with optional options
|
||||
;; Used by orchestration.sx: (dom-add-listener el event handler opts)
|
||||
(define dom-add-listener
|
||||
(fn (el event-name handler &rest opts)
|
||||
(let ((cb (host-callback handler)))
|
||||
(if (and opts (not (empty? opts)))
|
||||
(host-call el "addEventListener" event-name cb (first opts))
|
||||
(host-call el "addEventListener" event-name cb))
|
||||
;; Return cleanup function
|
||||
(fn () (host-call el "removeEventListener" event-name cb)))))
|
||||
|
||||
(define dom-dispatch
|
||||
(fn (el event-name detail)
|
||||
(let ((evt (host-new "CustomEvent" event-name
|
||||
(dict "detail" detail "bubbles" true))))
|
||||
(host-call el "dispatchEvent" evt))))
|
||||
|
||||
(define event-detail
|
||||
(fn (evt) (host-get evt "detail")))
|
||||
|
||||
(define prevent-default
|
||||
(fn (e) (when e (host-call e "preventDefault"))))
|
||||
|
||||
(define stop-propagation
|
||||
(fn (e) (when e (host-call e "stopPropagation"))))
|
||||
|
||||
(define event-modifier-key?
|
||||
(fn (e)
|
||||
(and e (or (host-get e "ctrlKey") (host-get e "metaKey")
|
||||
(host-get e "shiftKey") (host-get e "altKey")))))
|
||||
|
||||
(define element-value
|
||||
(fn (el)
|
||||
(if (and el (not (nil? (host-get el "value"))))
|
||||
(host-get el "value")
|
||||
nil)))
|
||||
|
||||
(define error-message
|
||||
(fn (e)
|
||||
(if (and e (host-get e "message"))
|
||||
(host-get e "message")
|
||||
(str e))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; DOM data storage
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define dom-get-data
|
||||
(fn (el key)
|
||||
(let ((store (host-get el "__sx_data")))
|
||||
(if store (host-get store key) nil))))
|
||||
|
||||
(define dom-set-data
|
||||
(fn (el key val)
|
||||
(when (not (host-get el "__sx_data"))
|
||||
(host-set! el "__sx_data" (dict)))
|
||||
(host-set! (host-get el "__sx_data") key val)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Head manipulation
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define dom-append-to-head
|
||||
(fn (el)
|
||||
(when (dom-head)
|
||||
(host-call (dom-head) "appendChild" el))))
|
||||
|
||||
(define set-document-title
|
||||
(fn (title)
|
||||
(host-set! (dom-document) "title" title)))
|
||||
37634
shared/static/wasm/sx_browser.bc.js
Normal file
37634
shared/static/wasm/sx_browser.bc.js
Normal file
File diff suppressed because one or more lines are too long
@@ -169,9 +169,7 @@
|
||||
(dom-set-attr sp "class"
|
||||
(str base
|
||||
(cond
|
||||
(and (= step-num cur) is-spread) " opacity-60"
|
||||
(= step-num cur) " bg-amber-100 rounded px-0.5 font-bold text-sm"
|
||||
(and (< step-num cur) is-spread) " opacity-60"
|
||||
(< step-num cur) " font-bold text-xs"
|
||||
:else " opacity-40")))))))
|
||||
(range 0 (min (len spans) (len tokens)))))))))
|
||||
@@ -277,9 +275,7 @@
|
||||
(cls (str (get tok "cls")
|
||||
(cond
|
||||
(= step -1) ""
|
||||
(and (= step cur) is-spread) " opacity-60"
|
||||
(= step cur) " bg-amber-100 rounded px-0.5 font-bold text-sm"
|
||||
(and (< step cur) is-spread) " opacity-60"
|
||||
(< step cur) " font-bold text-xs"
|
||||
:else " opacity-40"))))
|
||||
(span :class cls (get tok "text"))))
|
||||
|
||||
@@ -13,6 +13,12 @@
|
||||
(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
|
||||
@@ -27,7 +33,7 @@
|
||||
(dom-listen el name
|
||||
(if (lambda? handler)
|
||||
(if (= 0 (len (lambda-params handler)))
|
||||
(fn () (trampoline (call-lambda handler (list))) (run-post-render-hooks))
|
||||
(fn (_e) (trampoline (call-lambda handler (list))) (run-post-render-hooks))
|
||||
(fn (e) (trampoline (call-lambda handler (list e))) (run-post-render-hooks)))
|
||||
handler))))
|
||||
|
||||
@@ -63,7 +69,11 @@
|
||||
"dom-node" expr
|
||||
|
||||
;; Spread → emit attrs to nearest element provider, pass through for reactive-spread
|
||||
"spread" (do (emit! "element-attrs" (spread-attrs expr)) expr)
|
||||
;; 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)
|
||||
@@ -77,7 +87,7 @@
|
||||
;; Signal → reactive text in island scope, deref outside
|
||||
:else
|
||||
(if (signal? expr)
|
||||
(if (context "sx-island-scope" nil)
|
||||
(if (island-scope?)
|
||||
(reactive-text expr)
|
||||
(create-text-node (str (deref expr))))
|
||||
(create-text-node (str expr))))))
|
||||
@@ -161,7 +171,7 @@
|
||||
(render-dom-element name args env ns)
|
||||
|
||||
;; deref in island scope → reactive text node
|
||||
(and (= name "deref") (context "sx-island-scope" nil))
|
||||
(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)
|
||||
@@ -233,7 +243,7 @@
|
||||
;; Inside island scope: reactive attribute binding.
|
||||
;; The effect tracks signal deps automatically — if none
|
||||
;; are deref'd, it fires once and never again (safe).
|
||||
(context "sx-island-scope" nil)
|
||||
(island-scope?)
|
||||
(reactive-attr el attr-name
|
||||
(fn () (trampoline (eval-expr attr-expr env))))
|
||||
;; Static attribute (outside islands)
|
||||
@@ -255,7 +265,7 @@
|
||||
(let ((child (render-to-dom arg env new-ns)))
|
||||
(cond
|
||||
;; Reactive spread: track signal deps, update attrs on change
|
||||
(and (spread? child) (context "sx-island-scope" nil))
|
||||
(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
|
||||
@@ -286,7 +296,7 @@
|
||||
val)))
|
||||
(dom-set-attr el key (str val))))))
|
||||
(keys spread-dict)))
|
||||
(emitted "element-attrs"))
|
||||
(scope-emitted "element-attrs"))
|
||||
(scope-pop! "element-attrs")
|
||||
|
||||
el)))
|
||||
@@ -396,7 +406,7 @@
|
||||
;; produce DOM nodes rather than evaluated values.
|
||||
|
||||
(define RENDER_DOM_FORMS
|
||||
(list "if" "when" "cond" "case" "let" "let*" "begin" "do"
|
||||
(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"))
|
||||
@@ -410,7 +420,7 @@
|
||||
(cond
|
||||
;; if — reactive inside islands (re-renders when signal deps change)
|
||||
(= name "if")
|
||||
(if (context "sx-island-scope" nil)
|
||||
(if (island-scope?)
|
||||
(let ((marker (create-comment "r-if"))
|
||||
(current-nodes (list))
|
||||
(initial-result nil))
|
||||
@@ -458,7 +468,7 @@
|
||||
|
||||
;; when — reactive inside islands
|
||||
(= name "when")
|
||||
(if (context "sx-island-scope" nil)
|
||||
(if (island-scope?)
|
||||
(let ((marker (create-comment "r-when"))
|
||||
(current-nodes (list))
|
||||
(initial-result nil))
|
||||
@@ -504,7 +514,7 @@
|
||||
|
||||
;; cond — reactive inside islands
|
||||
(= name "cond")
|
||||
(if (context "sx-island-scope" nil)
|
||||
(if (island-scope?)
|
||||
(let ((marker (create-comment "r-cond"))
|
||||
(current-nodes (list))
|
||||
(initial-result nil))
|
||||
@@ -561,6 +571,30 @@
|
||||
(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)
|
||||
@@ -581,7 +615,7 @@
|
||||
;; map — reactive-list when mapping over a signal inside an island
|
||||
(= name "map")
|
||||
(let ((coll-expr (nth expr 2)))
|
||||
(if (and (context "sx-island-scope" nil)
|
||||
(if (and (island-scope?)
|
||||
(= (type-of coll-expr) "list")
|
||||
(> (len coll-expr) 1)
|
||||
(= (type-of (first coll-expr)) "symbol")
|
||||
|
||||
@@ -460,9 +460,9 @@
|
||||
|
||||
(define run-post-render-hooks :effects [mutation io]
|
||||
(fn ()
|
||||
(log-info "run-post-render-hooks:" (len *post-render-hooks*) "hooks")
|
||||
(log-info (str "run-post-render-hooks: " (len *post-render-hooks*) " hooks"))
|
||||
(for-each (fn (hook)
|
||||
(log-info " hook type:" (type-of hook) "callable:" (callable? hook) "lambda:" (lambda? hook))
|
||||
(log-info (str " hook type: " (type-of hook) " callable: " (callable? hook) " lambda: " (lambda? hook)))
|
||||
(cek-call hook nil))
|
||||
*post-render-hooks*)))
|
||||
|
||||
@@ -489,7 +489,10 @@
|
||||
(sx-hydrate-elements nil)
|
||||
(sx-hydrate-islands nil)
|
||||
(run-post-render-hooks)
|
||||
(process-elements nil))))
|
||||
(process-elements nil)
|
||||
;; Wire up popstate for back/forward navigation
|
||||
(dom-listen (dom-window) "popstate"
|
||||
(fn (e) (handle-popstate 0))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
696
web/lib/boot-helpers.sx
Normal file
696
web/lib/boot-helpers.sx
Normal file
@@ -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 <head> 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 <script data-components>...</script> 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 "<script type=\"text/sx\" data-components>")
|
||||
(end-tag "</script>"))
|
||||
;; 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 <style data-sx-css>...</style> tags from response text.
|
||||
;; Apply them to the document head, return remaining text.
|
||||
(let ((result text)
|
||||
(start-tag "<style data-sx-css>")
|
||||
(end-tag "</style>"))
|
||||
(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 <script type="text/sx"> in root.
|
||||
(let ((scripts (dom-query-all (or root (dom-body)) "script[type=\"text/sx\"]")))
|
||||
(for-each (fn (s)
|
||||
(when (not (is-processed? s "sx-script"))
|
||||
(mark-processed! s "sx-script")
|
||||
(let ((text (host-get s "textContent")))
|
||||
(when (and text (> (len text) 0))
|
||||
(let ((exprs (sx-parse text)))
|
||||
(for-each (fn (expr) (cek-eval expr)) exprs))))))
|
||||
scripts))))
|
||||
|
||||
(define select-from-container
|
||||
(fn (container selector)
|
||||
;; Select matching element from container, return it (not just children).
|
||||
(if selector
|
||||
(let ((selected (dom-query container selector)))
|
||||
(if selected
|
||||
selected
|
||||
(children-to-fragment container)))
|
||||
(children-to-fragment container))))
|
||||
|
||||
(define children-to-fragment
|
||||
(fn (el)
|
||||
;; Move all children of el into a DocumentFragment.
|
||||
(let ((doc (host-global "document"))
|
||||
(frag (host-call doc "createDocumentFragment")))
|
||||
(let loop ()
|
||||
(let ((child (dom-first-child el)))
|
||||
(when child
|
||||
(dom-append frag child)
|
||||
(loop))))
|
||||
frag)))
|
||||
|
||||
(define select-html-from-doc
|
||||
(fn (doc selector)
|
||||
;; Extract HTML from a parsed document, optionally selecting.
|
||||
(if selector
|
||||
(let ((el (dom-query doc selector)))
|
||||
(if el (dom-inner-html el) (dom-body-inner-html doc)))
|
||||
(dom-body-inner-html doc))))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Client routing stubs
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define find-matching-route
|
||||
(fn (pathname routes)
|
||||
;; Match pathname against registered page routes.
|
||||
;; Returns match dict or nil.
|
||||
nil))
|
||||
|
||||
(define parse-route-pattern (fn (pattern) nil))
|
||||
|
||||
(define register-io-deps (fn (deps) nil))
|
||||
|
||||
(define resolve-page-data
|
||||
(fn (page-name params &rest rest)
|
||||
nil))
|
||||
|
||||
(define parse-sx-data
|
||||
(fn (text)
|
||||
(if (and text (> (len text) 0))
|
||||
(let ((exprs (sx-parse text)))
|
||||
(if (not (empty? exprs)) (first exprs) nil))
|
||||
nil)))
|
||||
|
||||
(define try-eval-content
|
||||
(fn (content-src env)
|
||||
;; Evaluate SX content source to DOM.
|
||||
(let ((exprs (sx-parse content-src)))
|
||||
(if (empty? exprs)
|
||||
nil
|
||||
(let ((frag (create-fragment)))
|
||||
(for-each (fn (expr)
|
||||
(let ((result (render-to-dom expr env nil)))
|
||||
(when result (dom-append frag result))))
|
||||
exprs)
|
||||
frag)))))
|
||||
|
||||
(define try-async-eval-content
|
||||
(fn (content-src env &rest rest)
|
||||
;; Async variant — for now, delegate to sync.
|
||||
(try-eval-content content-src env)))
|
||||
|
||||
(define try-rerender-page (fn (&rest args) nil))
|
||||
(define execute-action (fn (&rest args) nil))
|
||||
(define bind-preload (fn (&rest args) nil))
|
||||
(define persist-offline-data (fn (&rest args) nil))
|
||||
(define retrieve-offline-data (fn (&rest args) nil))
|
||||
@@ -26,13 +26,24 @@
|
||||
(fn (url)
|
||||
(starts-with? url (browser-location-origin))))
|
||||
|
||||
;; Extract pathname from a URL string using the URL API
|
||||
(define url-pathname
|
||||
(fn (url)
|
||||
(host-get (host-new "URL" url (browser-location-origin)) "pathname")))
|
||||
|
||||
(define browser-push-state
|
||||
(fn (state title url)
|
||||
(host-call (host-get (dom-window) "history") "pushState" state title url)))
|
||||
(fn (url-or-state &rest rest)
|
||||
(if (empty? rest)
|
||||
;; Single arg: just URL
|
||||
(host-call (host-get (dom-window) "history") "pushState" nil "" url-or-state)
|
||||
;; Three args: state, title, url
|
||||
(host-call (host-get (dom-window) "history") "pushState" url-or-state (first rest) (nth rest 1)))))
|
||||
|
||||
(define browser-replace-state
|
||||
(fn (state title url)
|
||||
(host-call (host-get (dom-window) "history") "replaceState" state title url)))
|
||||
(fn (url-or-state &rest rest)
|
||||
(if (empty? rest)
|
||||
(host-call (host-get (dom-window) "history") "replaceState" nil "" url-or-state)
|
||||
(host-call (host-get (dom-window) "history") "replaceState" url-or-state (first rest) (nth rest 1)))))
|
||||
|
||||
(define browser-reload
|
||||
(fn ()
|
||||
@@ -182,7 +193,7 @@
|
||||
|
||||
(define schedule-idle
|
||||
(fn (f)
|
||||
(let ((cb (host-callback f)))
|
||||
(let ((cb (host-callback (fn (_deadline) (f)))))
|
||||
(if (host-get (dom-window) "requestIdleCallback")
|
||||
(host-call (dom-window) "requestIdleCallback" cb)
|
||||
(set-timeout cb 0)))))
|
||||
|
||||
132
web/lib/dom.sx
132
web/lib/dom.sx
@@ -29,8 +29,11 @@
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define dom-create-element
|
||||
(fn (tag)
|
||||
(host-call (dom-document) "createElement" tag)))
|
||||
(fn (tag &rest ns-arg)
|
||||
(let ((ns (if (and ns-arg (not (empty? ns-arg))) (first ns-arg) nil)))
|
||||
(if ns
|
||||
(host-call (dom-document) "createElementNS" ns tag)
|
||||
(host-call (dom-document) "createElement" tag)))))
|
||||
|
||||
(define create-text-node
|
||||
(fn (s)
|
||||
@@ -40,6 +43,10 @@
|
||||
(fn ()
|
||||
(host-call (dom-document) "createDocumentFragment")))
|
||||
|
||||
(define create-comment
|
||||
(fn (text)
|
||||
(host-call (dom-document) "createComment" (or text ""))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Tree manipulation
|
||||
@@ -60,6 +67,54 @@
|
||||
(when (and parent child)
|
||||
(host-call parent "insertBefore" child ref))))
|
||||
|
||||
(define dom-insert-after
|
||||
(fn (ref node)
|
||||
"Insert node after ref in the same parent."
|
||||
(let ((parent (host-get ref "parentNode"))
|
||||
(next (host-get ref "nextSibling")))
|
||||
(when parent
|
||||
(if next
|
||||
(host-call parent "insertBefore" node next)
|
||||
(host-call parent "appendChild" node))))))
|
||||
|
||||
(define dom-remove
|
||||
(fn (el)
|
||||
(when el (host-call el "remove"))))
|
||||
|
||||
(define dom-is-active-element?
|
||||
(fn (el)
|
||||
(let ((active (host-get (dom-document) "activeElement")))
|
||||
(if (and active el)
|
||||
(identical? el active)
|
||||
false))))
|
||||
|
||||
(define dom-is-input-element?
|
||||
(fn (el)
|
||||
(let ((tag (upper (or (dom-tag-name el) ""))))
|
||||
(or (= tag "INPUT") (= tag "TEXTAREA") (= tag "SELECT")))))
|
||||
|
||||
(define dom-is-child-of?
|
||||
(fn (child parent)
|
||||
(and child parent (host-call parent "contains" child))))
|
||||
|
||||
(define dom-on
|
||||
(fn (el event-name handler)
|
||||
(host-call el "addEventListener" event-name (host-callback handler))))
|
||||
|
||||
(define dom-attr-list
|
||||
(fn (el)
|
||||
;; Return list of (name value) pairs for all attributes on the element.
|
||||
(let ((attrs (host-get el "attributes"))
|
||||
(result (list)))
|
||||
(when attrs
|
||||
(let ((n (host-get attrs "length")))
|
||||
(let loop ((i 0))
|
||||
(when (< i n)
|
||||
(let ((attr (host-call attrs "item" i)))
|
||||
(append! result (list (host-get attr "name") (host-get attr "value"))))
|
||||
(loop (+ i 1))))))
|
||||
result)))
|
||||
|
||||
(define dom-remove-child
|
||||
(fn (parent child)
|
||||
(when (and parent child)
|
||||
@@ -80,16 +135,29 @@
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define dom-query
|
||||
(fn (sel)
|
||||
(host-call (dom-document) "querySelector" sel)))
|
||||
(fn (root-or-sel &rest rest)
|
||||
(if (empty? rest)
|
||||
;; Single arg: selector on document
|
||||
(host-call (dom-document) "querySelector" root-or-sel)
|
||||
;; Two args: root element + selector
|
||||
(host-call root-or-sel "querySelector" (first rest)))))
|
||||
|
||||
(define dom-query-all
|
||||
(fn (root sel)
|
||||
(if (nil? sel)
|
||||
;; Single arg: query document
|
||||
(host-call (dom-document) "querySelectorAll" root)
|
||||
;; Two args: query within root
|
||||
(host-call root "querySelectorAll" sel))))
|
||||
"Query DOM and return an SX list (not a host NodeList)."
|
||||
(let ((node-list (if (nil? sel)
|
||||
(host-call (dom-document) "querySelectorAll" root)
|
||||
(host-call root "querySelectorAll" sel))))
|
||||
;; Convert NodeList → SX list by indexing
|
||||
(if (nil? node-list)
|
||||
(list)
|
||||
(let ((n (host-get node-list "length"))
|
||||
(result (list)))
|
||||
(let loop ((i 0))
|
||||
(when (< i n)
|
||||
(append! result (host-call node-list "item" i))
|
||||
(loop (+ i 1))))
|
||||
result)))))
|
||||
|
||||
(define dom-query-by-id
|
||||
(fn (id)
|
||||
@@ -226,13 +294,46 @@
|
||||
|
||||
(define dom-child-list
|
||||
(fn (el)
|
||||
"Return child nodes as an SX list."
|
||||
(if el
|
||||
(host-call (host-global "Array") "from" (host-get el "childNodes"))
|
||||
(let ((nl (host-get el "childNodes"))
|
||||
(n (host-get nl "length"))
|
||||
(result (list)))
|
||||
(let loop ((i 0))
|
||||
(when (< i n)
|
||||
(append! result (host-call nl "item" i))
|
||||
(loop (+ i 1))))
|
||||
result)
|
||||
(list))))
|
||||
|
||||
(define dom-is-fragment?
|
||||
(fn (el) (= (host-get el "nodeType") 11)))
|
||||
|
||||
(define dom-child-nodes
|
||||
(fn (el)
|
||||
"Return child nodes as an SX list."
|
||||
(if el
|
||||
(let ((nl (host-get el "childNodes"))
|
||||
(n (host-get nl "length"))
|
||||
(result (list)))
|
||||
(let loop ((i 0))
|
||||
(when (< i n)
|
||||
(append! result (host-call nl "item" i))
|
||||
(loop (+ i 1))))
|
||||
result)
|
||||
(list))))
|
||||
|
||||
(define dom-remove-children-after
|
||||
(fn (marker)
|
||||
"Remove all siblings after marker node."
|
||||
(let ((parent (dom-parent marker)))
|
||||
(when parent
|
||||
(let loop ()
|
||||
(let ((next (dom-next-sibling marker)))
|
||||
(when next
|
||||
(host-call parent "removeChild" next)
|
||||
(loop))))))))
|
||||
|
||||
(define dom-focus
|
||||
(fn (el) (when el (host-call el "focus"))))
|
||||
|
||||
@@ -254,6 +355,17 @@
|
||||
;; Return cleanup function
|
||||
(fn () (host-call el "removeEventListener" event-name cb)))))
|
||||
|
||||
;; dom-add-listener — addEventListener with optional options
|
||||
;; Used by orchestration.sx: (dom-add-listener el event handler opts)
|
||||
(define dom-add-listener
|
||||
(fn (el event-name handler &rest opts)
|
||||
(let ((cb (host-callback handler)))
|
||||
(if (and opts (not (empty? opts)))
|
||||
(host-call el "addEventListener" event-name cb (first opts))
|
||||
(host-call el "addEventListener" event-name cb))
|
||||
;; Return cleanup function
|
||||
(fn () (host-call el "removeEventListener" event-name cb)))))
|
||||
|
||||
(define dom-dispatch
|
||||
(fn (el event-name detail)
|
||||
(let ((evt (host-new "CustomEvent" event-name
|
||||
|
||||
Reference in New Issue
Block a user