rose-ash/hosts/ocaml/lib/sx_scope.ml

(** 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)