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

Step 5.5 phases 1-2: merge sx_scope into sx_primitives, 4-child define support

Browse Source 
Phase 1: Absorb sx_scope.ml (180 lines) into sx_primitives.ml. Scope stacks,
cookies, and trace infrastructure now live alongside other primitives. All 20
scope primitive registrations moved. References updated in sx_server.ml and
sx_browser.ml. sx_scope.ml deleted.

Phase 2: Transpiler handles (define name :effects (...) (fn ...)) forms.
ml-emit-define and ml-emit-define-body detect keyword at position 2 and use
(last expr) instead. Unblocks transpilation of spec/render.sx and
web/adapter-html.sx which use 4-child defines extensively.

2598/2598 tests passing.

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-03 19:43:26 +00:00
parent 1dd4c87d64
commit 19e7a6ee2d
5 changed files with 189 additions and 195 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -140,11 +140,10 @@ let io_batch_mode = ref false
let io_queue : (int * string * value list) list ref = ref []
let io_counter = ref 0
(* Scope stacks and cookies — all primitives registered in sx_scope.ml.
We just reference the shared state for the IO bridge. *)
(* Sx_scope accessed directly — library is unwrapped *)
let _request_cookies = Sx_scope.request_cookies
let _scope_stacks = Sx_scope.scope_stacks
(* Scope stacks and cookies — primitives registered in sx_primitives.ml.
We reference the shared state for the IO bridge. *)
let _request_cookies = Sx_primitives._request_cookies
let _scope_stacks = Sx_primitives._scope_stacks
(* ── App config ─────────────────────────────────────────────────────── *)
(* Populated from __app-config dict after SX files load. *)

13
hosts/ocaml/browser/sx_browser.ml
View File

@@ -50,9 +50,8 @@ let host_get_js (id : int) : Js.Unsafe.any =
(* Global environment *)
(* ================================================================== *)
(* Force module initialization — these modules register primitives
in their let () = ... blocks but aren't referenced directly. *)
let () = Sx_scope.clear_all ()
(* Clear scope stacks at startup *)
let () = Sx_primitives.scope_clear_all ()
let global_env = make_env ()
let _sx_render_mode = ref false
@@ -641,7 +640,7 @@ let () =
(* --- Scope stack --- *)
(* Scope primitives (scope-push!, scope-pop!, context, collect!, collected,
emit!, emitted, scope-emit!, scope-emitted, etc.) are registered by
Sx_scope module initialization in the primitives table.
Sx_primitives module initialization in the primitives table.
The CEK evaluator falls through to the primitives table when a symbol
isn't in the env, so these work automatically.
Only provide-push!/provide-pop! need explicit env bindings as aliases. *)
@@ -921,11 +920,11 @@ let () =
(* Scope tracing API *)
Js.Unsafe.set sx (Js.string "scopeTraceOn") (Js.wrap_callback (fun () ->
Sx_scope.scope_trace_enable (); Js.Unsafe.inject Js.null));
Sx_primitives.scope_trace_enable (); Js.Unsafe.inject Js.null));
Js.Unsafe.set sx (Js.string "scopeTraceOff") (Js.wrap_callback (fun () ->
Sx_scope.scope_trace_disable (); Js.Unsafe.inject Js.null));
Sx_primitives.scope_trace_disable (); Js.Unsafe.inject Js.null));
Js.Unsafe.set sx (Js.string "scopeTraceDrain") (Js.wrap_callback (fun () ->
let log = Sx_scope.scope_trace_drain () in
let log = Sx_primitives.scope_trace_drain () in
Js.Unsafe.inject (Js.array (Array.of_list (List.map (fun s -> Js.Unsafe.inject (Js.string s)) log)))));
Js.Unsafe.set Js.Unsafe.global (Js.string "SxKernel") sx

176
hosts/ocaml/lib/sx_primitives.ml
View File

@@ -14,6 +14,29 @@ let _sx_trampoline_fn : (value -> value) ref =
ref (fun v -> v)
let _is_client : bool ref = ref false
(** Scope stacks — dynamic scope for render-time effects.
Each key maps to a stack of values. Used by aser for
spread/provide/emit patterns, CSSX collect/flush, etc.
Migrated from sx_scope.ml. *)
let _scope_stacks : (string, value list) Hashtbl.t = Hashtbl.create 8
(** Debug trace for scope operations *)
let _scope_trace = ref false
let _scope_log : string list ref = ref []
let scope_trace_enable () = _scope_trace := true; _scope_log := []
let scope_trace_disable () = _scope_trace := false
let scope_trace_drain () =
let log = List.rev !_scope_log in
_scope_log := [];
log
(** Request cookies — set by the Python bridge before each render.
get-cookie reads from here; set-cookie is a no-op on the server. *)
let _request_cookies : (string, string) Hashtbl.t = Hashtbl.create 8
(** Clear all scope stacks. Called between requests if needed. *)
let scope_clear_all () = Hashtbl.clear _scope_stacks
let register name fn = Hashtbl.replace primitives name fn
let is_primitive name = Hashtbl.mem primitives name
@@ -976,4 +999,155 @@ let () =
| Some fn -> fn []
| None -> raise (Eval_error ("VM undefined: " ^ name)))
| _ -> raise (Eval_error "call-primitive: expected (name args-list)"));
()
();
(* ================================================================ *)
(* Scope stacks — dynamic scope for render-time effects. *)
(* Migrated from sx_scope.ml — Phase 1 of step 5.5 *)
(* ================================================================ *)
(* --- Cookies --- *)
register "get-cookie" (fun args ->
match args with
| [String name] ->
(match Hashtbl.find_opt _request_cookies name with
| Some v -> String v
| None -> Nil)
| _ -> Nil);
register "set-cookie" (fun _args -> Nil);
(* --- Core scope stack operations --- *)
register "scope-push!" (fun args ->
match args with
| [String name; value] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
if !_scope_trace then
_scope_log := Printf.sprintf "PUSH %s depth=%d->%d" name (List.length stack) (List.length stack + 1) :: !_scope_log;
Hashtbl.replace _scope_stacks name (value :: stack); Nil
| _ -> Nil);
register "scope-pop!" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
if !_scope_trace then
_scope_log := Printf.sprintf "POP %s depth=%d->%d" name (List.length stack) (max 0 (List.length stack - 1)) :: !_scope_log;
(match stack with _ :: rest -> Hashtbl.replace _scope_stacks name rest | [] -> ()); Nil
| _ -> Nil);
register "scope-peek" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
if !_scope_trace then
_scope_log := Printf.sprintf "PEEK %s depth=%d found=%b" name (List.length stack) (stack <> []) :: !_scope_log;
(match stack with v :: _ -> v | [] -> Nil)
| _ -> Nil);
(* --- Context (scope lookup with optional default) --- *)
register "context" (fun args ->
match args with
| (String name) :: rest ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
if !_scope_trace then
_scope_log := Printf.sprintf "CTX %s depth=%d found=%b" name (List.length stack) (stack <> []) :: !_scope_log;
(match stack with
| v :: _ -> v
| [] -> (match rest with default_val :: _ -> default_val | [] -> Nil))
| _ -> Nil);
register "context-debug" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
let all_keys = Hashtbl.fold (fun k _ acc -> k :: acc) _scope_stacks [] in
String (Printf.sprintf "name=%s stack_len=%d all_keys=[%s]"
name (List.length stack) (String.concat "," all_keys))
| _ -> String "bad args");
(* --- Collect / collected / clear-collected! --- *)
register "collect!" (fun args ->
match args with
| [String name; value] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with
| List items :: rest ->
if not (List.mem value items) then
Hashtbl.replace _scope_stacks name (List (items @ [value]) :: rest)
| [] ->
Hashtbl.replace _scope_stacks name [List [value]]
| _ :: _ -> ());
Nil
| _ -> Nil);
register "collected" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with List items :: _ -> List items | _ -> List [])
| _ -> List []);
register "clear-collected!" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with
| _ :: rest -> Hashtbl.replace _scope_stacks name (List [] :: rest)
| [] -> Hashtbl.replace _scope_stacks name [List []]);
Nil
| _ -> Nil);
(* --- Emit / emitted --- *)
register "scope-emit!" (fun args ->
match args with
| [String name; value] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with
| List items :: rest ->
Hashtbl.replace _scope_stacks name (List (items @ [value]) :: rest)
| Nil :: rest ->
Hashtbl.replace _scope_stacks name (List [value] :: rest)
| [] ->
Hashtbl.replace _scope_stacks name [List [value]]
| _ :: _ -> ());
Nil
| _ -> Nil);
register "emit!" (fun args ->
match Hashtbl.find_opt primitives "scope-emit!" with
| Some fn -> fn args | None -> Nil);
register "emitted" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with List items :: _ -> List items | _ -> List [])
| _ -> List []);
register "scope-emitted" (fun args ->
match Hashtbl.find_opt primitives "emitted" with
| Some fn -> fn args | None -> List []);
register "scope-collected" (fun args ->
match Hashtbl.find_opt primitives "collected" with
| Some fn -> fn args | None -> List []);
register "scope-clear-collected!" (fun args ->
match Hashtbl.find_opt primitives "clear-collected!" with
| Some fn -> fn args | None -> Nil);
(* --- Provide aliases --- *)
register "provide-push!" (fun args ->
match Hashtbl.find_opt primitives "scope-push!" with
| Some fn -> fn args | None -> Nil);
register "provide-pop!" (fun args ->
match Hashtbl.find_opt primitives "scope-pop!" with
| Some fn -> fn args | None -> Nil)

180
hosts/ocaml/lib/sx_scope.ml
View File

@@ -1,180 +0,0 @@
(** Scope stacks — dynamic scope for render-time effects.
Provides scope-push!/pop!/peek, collect!/collected/clear-collected!,
scope-emit!/emitted/scope-emitted, context, and cookie access.
All functions are registered as primitives so both the CEK evaluator
and the JIT VM can find them in the same place. *)
open Sx_types
(** The shared scope stacks hashtable. Each key maps to a stack of values.
Used by aser for spread/provide/emit patterns, CSSX collect/flush, etc. *)
let scope_stacks : (string, value list) Hashtbl.t = Hashtbl.create 8
(** Debug trace for scope operations — enabled from JS *)
let _scope_trace = ref false
let _scope_log : string list ref = ref []
let scope_trace_enable () = _scope_trace := true; _scope_log := []
let scope_trace_disable () = _scope_trace := false
let scope_trace_drain () =
let log = List.rev !_scope_log in
_scope_log := [];
log
(** Request cookies — set by the Python bridge before each render.
get-cookie reads from here; set-cookie is a no-op on the server. *)
let request_cookies : (string, string) Hashtbl.t = Hashtbl.create 8
(** Clear all scope stacks. Called between requests if needed. *)
let clear_all () = Hashtbl.clear scope_stacks
let () =
let register = Sx_primitives.register in
(* --- Cookies --- *)
register "get-cookie" (fun args ->
match args with
| [String name] ->
(match Hashtbl.find_opt request_cookies name with
| Some v -> String v
| None -> Nil)
| _ -> Nil);
register "set-cookie" (fun _args -> Nil);
(* --- Core scope stack operations --- *)
register "scope-push!" (fun args ->
match args with
| [String name; value] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
if !_scope_trace then
_scope_log := Printf.sprintf "PUSH %s depth=%d->%d" name (List.length stack) (List.length stack + 1) :: !_scope_log;
Hashtbl.replace scope_stacks name (value :: stack); Nil
| _ -> Nil);
register "scope-pop!" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
if !_scope_trace then
_scope_log := Printf.sprintf "POP %s depth=%d->%d" name (List.length stack) (max 0 (List.length stack - 1)) :: !_scope_log;
(match stack with _ :: rest -> Hashtbl.replace scope_stacks name rest | [] -> ()); Nil
| _ -> Nil);
register "scope-peek" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
if !_scope_trace then
_scope_log := Printf.sprintf "PEEK %s depth=%d found=%b" name (List.length stack) (stack <> []) :: !_scope_log;
(match stack with v :: _ -> v | [] -> Nil)
| _ -> Nil);
(* --- Context (scope lookup with optional default) --- *)
register "context" (fun args ->
match args with
| (String name) :: rest ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
if !_scope_trace then
_scope_log := Printf.sprintf "CTX %s depth=%d found=%b" name (List.length stack) (stack <> []) :: !_scope_log;
(match stack with
| v :: _ -> v
| [] -> (match rest with default_val :: _ -> default_val | [] -> Nil))
| _ -> Nil);
register "context-debug" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
let all_keys = Hashtbl.fold (fun k _ acc -> k :: acc) scope_stacks [] in
String (Printf.sprintf "name=%s stack_len=%d all_keys=[%s]"
name (List.length stack) (String.concat "," all_keys))
| _ -> String "bad args");
(* --- Collect / collected / clear-collected! --- *)
register "collect!" (fun args ->
match args with
| [String name; value] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
(match stack with
| List items :: rest ->
if not (List.mem value items) then
Hashtbl.replace scope_stacks name (List (items @ [value]) :: rest)
| [] ->
Hashtbl.replace scope_stacks name [List [value]]
| _ :: _ -> ());
Nil
| _ -> Nil);
register "collected" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
(match stack with List items :: _ -> List items | _ -> List [])
| _ -> List []);
register "clear-collected!" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
(match stack with
| _ :: rest -> Hashtbl.replace scope_stacks name (List [] :: rest)
| [] -> Hashtbl.replace scope_stacks name [List []]);
Nil
| _ -> Nil);
(* --- Emit / emitted (for spread attrs in adapter-html.sx) --- *)
register "scope-emit!" (fun args ->
match args with
| [String name; value] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
(match stack with
| List items :: rest ->
Hashtbl.replace scope_stacks name (List (items @ [value]) :: rest)
| Nil :: rest ->
Hashtbl.replace scope_stacks name (List [value] :: rest)
| [] ->
Hashtbl.replace scope_stacks name [List [value]]
| _ :: _ -> ());
Nil
| _ -> Nil);
register "emit!" (fun args ->
(* Alias for scope-emit! *)
match Sx_primitives.get_primitive "scope-emit!" with
| NativeFn (_, fn) -> fn args | _ -> Nil);
register "emitted" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
(match stack with List items :: _ -> List items | _ -> List [])
| _ -> List []);
register "scope-emitted" (fun args ->
match Sx_primitives.get_primitive "emitted" with
| NativeFn (_, fn) -> fn args | _ -> List []);
register "scope-collected" (fun args ->
match Sx_primitives.get_primitive "collected" with
| NativeFn (_, fn) -> fn args | _ -> List []);
register "scope-clear-collected!" (fun args ->
match Sx_primitives.get_primitive "clear-collected!" with
| NativeFn (_, fn) -> fn args | _ -> Nil);
(* --- Provide aliases --- *)
register "provide-push!" (fun args ->
match Sx_primitives.get_primitive "scope-push!" with
| NativeFn (_, fn) -> fn args | _ -> Nil);
register "provide-pop!" (fun args ->
match Sx_primitives.get_primitive "scope-pop!" with
| NativeFn (_, fn) -> fn args | _ -> Nil)

6
hosts/ocaml/transpiler.sx
View File

@@ -1712,7 +1712,8 @@
(expr)
(let
((name (if (= (type-of (nth expr 1)) "symbol") (symbol-name (nth expr 1)) (str (nth expr 1))))
(val-expr (nth expr 2)))
(val-expr
(let ((raw (nth expr 2))) (if (keyword? raw) (last expr) raw))))
(let
((ml-name (ml-mangle name))
(is-fn
@@ -1825,7 +1826,8 @@
(expr)
(let
((name (if (= (type-of (nth expr 1)) "symbol") (symbol-name (nth expr 1)) (str (nth expr 1))))
(val-expr (nth expr 2)))
(val-expr
(let ((raw (nth expr 2))) (if (keyword? raw) (last expr) raw))))
(let
((ml-name (ml-mangle name))
(is-fn