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

(** Runtime helpers for transpiled code.

    These bridge the gap between the transpiler's output and the
    foundation types/primitives. The transpiled evaluator calls these
    functions directly. *)

open Sx_types

(** Call a registered primitive by name. *)
let prim_call name args =
  match Hashtbl.find_opt Sx_primitives.primitives name with
  | Some f -> f args
  | None -> raise (Eval_error ("Unknown primitive: " ^ name))

(** Convert any SX value to an OCaml string (internal). *)
let value_to_str = function
  | String s -> s
  | Number n ->
    if Float.is_integer n then string_of_int (int_of_float n)
    else Printf.sprintf "%g" n
  | Bool true -> "true"
  | Bool false -> "false"
  | Nil -> ""
  | Symbol s -> s
  | Keyword k -> k
  | v -> inspect v

(** sx_to_string returns a value (String) for transpiled code. *)
let sx_to_string v = String (value_to_str v)

(** String concatenation helper — [sx_str] takes a list of values. *)
let sx_str args =
  String.concat "" (List.map value_to_str args)

(** Convert a value to a list. *)
let sx_to_list = function
  | List l -> l
  | ListRef r -> !r
  | Nil -> []
  | v -> raise (Eval_error ("Expected list, got " ^ type_of v))

(** Call an SX callable (lambda, native fn, continuation). *)
let sx_call f args =
  match f with
  | NativeFn (_, fn) -> fn args
  | Lambda l ->
    let local = Sx_types.env_extend l.l_closure in
    List.iter2 (fun p a -> ignore (Sx_types.env_bind local p a)) l.l_params args;
    (* Return the body + env for the trampoline to evaluate *)
    Thunk (l.l_body, local)
  | Continuation (k, _) ->
    k (match args with x :: _ -> x | [] -> Nil)
  | _ -> raise (Eval_error ("Not callable: " ^ inspect f))

(** Apply a function to a list of args. *)
let sx_apply f args_list =
  sx_call f (sx_to_list args_list)

(** Mutable append — add item to a list ref or accumulator.
    In transpiled code, lists that get appended to are mutable refs. *)
let sx_append_b lst item =
  match lst with
  | List items -> List (items @ [item])
  | ListRef r -> r := !r @ [item]; lst  (* mutate in place, return same ref *)
  | _ -> raise (Eval_error ("append!: expected list, got " ^ type_of lst))

(** Mutable dict-set — set key in dict, return value. *)
let sx_dict_set_b d k v =
  match d, k with
  | Dict tbl, String key -> Hashtbl.replace tbl key v; v
  | Dict tbl, Keyword key -> Hashtbl.replace tbl key v; v
  | _ -> raise (Eval_error "dict-set!: expected dict and string key")

(** Get from dict or list. *)
let get_val container key =
  match container, key with
  | Dict d, String k -> dict_get d k
  | Dict d, Keyword k -> dict_get d k
  | (List l | ListRef { contents = l }), Number n ->
    (try List.nth l (int_of_float n) with _ -> Nil)
  | _ -> raise (Eval_error ("get: unsupported " ^ type_of container ^ " / " ^ type_of key))

(** Register get as a primitive override — transpiled code calls (get d k). *)
let () =
  Sx_primitives.register "get" (fun args ->
    match args with
    | [c; k] -> get_val c k
    | [c; k; default] ->
      (try
        let v = get_val c k in
        if v = Nil then default else v
      with _ -> default)
    | _ -> raise (Eval_error "get: 2-3 args"))


(* ====================================================================== *)
(* Primitive aliases — top-level functions called by transpiled code       *)
(* ====================================================================== *)

(** The transpiled evaluator calls primitives directly by their mangled
    OCaml name. These aliases delegate to the primitives table so the
    transpiled code compiles without needing [prim_call] everywhere. *)

let _prim name = match Hashtbl.find_opt Sx_primitives.primitives name with
  | Some f -> f | None -> (fun _ -> raise (Eval_error ("Missing prim: " ^ name)))

(* Collection ops *)
let first args = _prim "first" [args]
let rest args = _prim "rest" [args]
let last args = _prim "last" [args]
let nth coll i = _prim "nth" [coll; i]
let cons x l = _prim "cons" [x; l]
let append a b = _prim "append" [a; b]
let reverse l = _prim "reverse" [l]
let flatten l = _prim "flatten" [l]
let concat a b = _prim "concat" [a; b]
let slice a b = _prim "slice" [a; b]
let len a = _prim "len" [a]
let get a b = get_val a b
let sort' a = _prim "sort" [a]
let range' a = _prim "range" [a]
let unique a = _prim "unique" [a]
let zip a b = _prim "zip" [a; b]
let zip_pairs a = _prim "zip-pairs" [a]
let take a b = _prim "take" [a; b]
let drop a b = _prim "drop" [a; b]
let chunk_every a b = _prim "chunk-every" [a; b]

(* Predicates *)
let empty_p a = _prim "empty?" [a]
let nil_p a = _prim "nil?" [a]
let number_p a = _prim "number?" [a]
let string_p a = _prim "string?" [a]
let boolean_p a = _prim "boolean?" [a]
let list_p a = _prim "list?" [a]
let dict_p a = _prim "dict?" [a]
let symbol_p a = _prim "symbol?" [a]
let keyword_p a = _prim "keyword?" [a]
let contains_p a b = _prim "contains?" [a; b]
let has_key_p a b = _prim "has-key?" [a; b]
let starts_with_p a b = _prim "starts-with?" [a; b]
let ends_with_p a b = _prim "ends-with?" [a; b]
let string_contains_p a b = _prim "string-contains?" [a; b]
let odd_p a = _prim "odd?" [a]
let even_p a = _prim "even?" [a]
let zero_p a = _prim "zero?" [a]

(* String ops *)
let str' args = String (sx_str args)
let upper a = _prim "upper" [a]
let upcase a = _prim "upcase" [a]
let lower a = _prim "lower" [a]
let downcase a = _prim "downcase" [a]
let trim a = _prim "trim" [a]
let split a b = _prim "split" [a; b]
let join a b = _prim "join" [a; b]
let replace a b c = _prim "replace" [a; b; c]
let index_of a b = _prim "index-of" [a; b]
let substring a b c = _prim "substring" [a; b; c]
let string_length a = _prim "string-length" [a]
let char_from_code a = _prim "char-from-code" [a]

(* Dict ops *)
let assoc d k v = _prim "assoc" [d; k; v]
let dissoc d k = _prim "dissoc" [d; k]
let merge' a b = _prim "merge" [a; b]
let keys a = _prim "keys" [a]
let vals a = _prim "vals" [a]
let dict_set a b c = _prim "dict-set!" [a; b; c]
let dict_get a b = _prim "dict-get" [a; b]
let dict_has_p a b = _prim "dict-has?" [a; b]
let dict_delete a b = _prim "dict-delete!" [a; b]

(* Math *)
let abs' a = _prim "abs" [a]
let sqrt' a = _prim "sqrt" [a]
let pow' a b = _prim "pow" [a; b]
let floor' a = _prim "floor" [a]
let ceil' a = _prim "ceil" [a]
let round' a = _prim "round" [a]
let min' a b = _prim "min" [a; b]
let max' a b = _prim "max" [a; b]
let clamp a b c = _prim "clamp" [a; b; c]
let parse_int a = _prim "parse-int" [a]
let parse_float a = _prim "parse-float" [a]

(* Misc *)
let error msg = raise (Eval_error (value_to_str msg))

(* inspect wrapper — returns String value instead of OCaml string *)
let inspect v = String (Sx_types.inspect v)
let apply' f args = sx_apply f args
let identical_p a b = _prim "identical?" [a; b]
let _is_spread_prim a = _prim "spread?" [a]
let spread_attrs a = _prim "spread-attrs" [a]
let make_spread a = _prim "make-spread" [a]

(* Scope stacks — thread-local stacks keyed by name string.
   collect!/collected implement accumulator scopes.
   emit!/emitted implement event emission scopes.
   context reads the top of a named scope stack. *)
let _scope_stacks : (string, value list) Hashtbl.t = Hashtbl.create 8

let sx_collect name value =
  let key = value_to_str name in
  let stack = match Hashtbl.find_opt _scope_stacks key with
    | Some s -> s | None -> [] in
  (* Push value onto the top list of the stack *)
  (match stack with
   | List items :: rest ->
     Hashtbl.replace _scope_stacks key (List (items @ [value]) :: rest)
   | _ ->
     Hashtbl.replace _scope_stacks key (List [value] :: stack));
  Nil

let sx_collected name =
  let key = value_to_str name in
  match Hashtbl.find_opt _scope_stacks key with
  | Some (List items :: _) -> List items
  | _ -> List []

let sx_clear_collected name =
  let key = value_to_str name in
  (match Hashtbl.find_opt _scope_stacks key with
   | Some (_ :: rest) -> Hashtbl.replace _scope_stacks key (List [] :: rest)
   | _ -> ());
  Nil

let sx_emit name value =
  let key = value_to_str name in
  let stack = match Hashtbl.find_opt _scope_stacks key with
    | Some s -> s | None -> [] in
  (match stack with
   | List items :: rest ->
     Hashtbl.replace _scope_stacks key (List (items @ [value]) :: rest)
   | _ ->
     Hashtbl.replace _scope_stacks key (List [value] :: stack));
  Nil

let sx_emitted name =
  let key = value_to_str name in
  match Hashtbl.find_opt _scope_stacks key with
  | Some (List items :: _) -> List items
  | _ -> List []

let sx_context name default =
  let key = value_to_str name in
  match Hashtbl.find_opt _scope_stacks key with
  | Some (v :: _) -> v
  | _ -> default

(* Trampoline — forward-declared in sx_ref.ml, delegates to CEK eval_expr *)
(* This is a stub; the real trampoline is wired up in sx_ref.ml after eval_expr is defined *)
let trampoline v = v

(* Value-returning type predicates — the transpiled code passes these through
   sx_truthy, so they need to return Bool, not OCaml bool. *)
(* type_of returns value, not string *)
let type_of v = String (Sx_types.type_of v)

(* Env operations — accept Env-wrapped values and value keys.
   The transpiled CEK machine stores envs in dicts as Env values. *)
let unwrap_env = function
  | Env e -> e
  | _ -> raise (Eval_error "Expected env")

let env_has e name = Bool (Sx_types.env_has (unwrap_env e) (value_to_str name))
let env_get e name = Sx_types.env_get (unwrap_env e) (value_to_str name)
let env_bind e name v = Sx_types.env_bind (unwrap_env e) (value_to_str name) v
let env_set e name v = Sx_types.env_set (unwrap_env e) (value_to_str name) v

let make_env () = Env (Sx_types.make_env ())
let env_extend e = Env (Sx_types.env_extend (unwrap_env e))
let env_merge a b = Env (Sx_types.env_merge (unwrap_env a) (unwrap_env b))

(* set_lambda_name wrapper — accepts value, extracts string *)
let set_lambda_name l n = Sx_types.set_lambda_name l (value_to_str n)

let is_nil v = Bool (Sx_types.is_nil v)
let is_thunk v = Bool (Sx_types.is_thunk v)
let is_lambda v = Bool (Sx_types.is_lambda v)
let is_component v = Bool (Sx_types.is_component v)
let is_island v = Bool (Sx_types.is_island v)
let is_macro v = Bool (Sx_types.is_macro v)
let is_signal v = Bool (Sx_types.is_signal v)
let is_callable v = Bool (Sx_types.is_callable v)
let is_identical a b = Bool (a == b)
let is_primitive name = Bool (Sx_primitives.is_primitive (value_to_str name))
let get_primitive name = Sx_primitives.get_primitive (value_to_str name)
let is_spread v = match v with Spread _ -> Bool true | _ -> Bool false

(* Stubs for functions defined in sx_ref.ml — resolved at link time *)
(* These are forward-declared here; sx_ref.ml defines the actual implementations *)

(* strip-prefix *)
(* Stubs for evaluator functions — defined in sx_ref.ml but
   sometimes referenced before their definition via forward calls.
   These get overridden by the actual transpiled definitions. *)

let map_indexed fn coll =
  List (List.mapi (fun i x -> sx_call fn [Number (float_of_int i); x]) (sx_to_list coll))

let map_dict fn d =
  match d with
  | Dict tbl ->
    let result = Hashtbl.create (Hashtbl.length tbl) in
    Hashtbl.iter (fun k v -> Hashtbl.replace result k (sx_call fn [String k; v])) tbl;
    Dict result
  | _ -> raise (Eval_error "map-dict: expected dict")

let for_each fn coll =
  List.iter (fun x -> ignore (sx_call fn [x])) (sx_to_list coll);
  Nil

let for_each_indexed fn coll =
  List.iteri (fun i x -> ignore (sx_call fn [Number (float_of_int i); x])) (sx_to_list coll);
  Nil

(* Continuation support *)
let continuation_p v = match v with Continuation (_, _) -> Bool true | _ -> Bool false

let make_cek_continuation captured rest_kont =
  let data = Hashtbl.create 2 in
  Hashtbl.replace data "captured" captured;
  Hashtbl.replace data "rest-kont" rest_kont;
  Continuation ((fun v -> v), Some data)

let continuation_data v = match v with
  | Continuation (_, Some d) -> Dict d
  | Continuation (_, None) -> Dict (Hashtbl.create 0)
  | _ -> raise (Eval_error "not a continuation")

(* Dynamic wind — simplified for OCaml (no async) *)
let dynamic_wind_call before body after _env =
  ignore (sx_call before []);
  let result = sx_call body [] in
  ignore (sx_call after []);
  result

(* Scope stack stubs — delegated to primitives when available *)
let scope_push name value =
  let key = value_to_str name in
  let stack = match Hashtbl.find_opt _scope_stacks key with
    | Some s -> s | None -> [] in
  Hashtbl.replace _scope_stacks key (value :: stack);
  Nil

let scope_pop name =
  let key = value_to_str name in
  (match Hashtbl.find_opt _scope_stacks key with
   | Some (_ :: rest) -> Hashtbl.replace _scope_stacks key rest
   | _ -> ());
  Nil

let provide_push name value = scope_push name value
let provide_pop name = scope_pop name

(* Render mode — mutable refs so browser entry point can wire up the renderer *)
let _render_active_p_fn : (unit -> value) ref = ref (fun () -> Bool false)
let _render_expr_fn : (value -> value -> value) ref = ref (fun _expr _env -> Nil)
let _is_render_expr_fn : (value -> value) ref = ref (fun _expr -> Bool false)

let render_active_p () = !_render_active_p_fn ()
let render_expr expr env = !_render_expr_fn expr env
let is_render_expr expr = !_is_render_expr_fn expr

(* Signal accessors — handle both native Signal type and dict-based signals
   from web/signals.sx which use {__signal: true, value: ..., subscribers: ..., deps: ...} *)
let is_dict_signal d = Hashtbl.mem d "__signal"

let signal_value s = match s with
  | Signal sig' -> sig'.s_value
  | Dict d when is_dict_signal d -> Sx_types.dict_get d "value"
  | _ -> raise (Eval_error ("not a signal: " ^ Sx_types.type_of s))

let signal_set_value s v = match s with
  | Signal sig' -> sig'.s_value <- v; v
  | Dict d when is_dict_signal d -> Hashtbl.replace d "value" v; v
  | _ -> raise (Eval_error "not a signal")

let signal_subscribers s = match s with
  | Signal sig' -> List (List.map (fun _ -> Nil) sig'.s_subscribers)
  | Dict d when is_dict_signal d -> Sx_types.dict_get d "subscribers"
  | _ -> List []

(* These use Obj.magic to accept both SX values and OCaml closures.
   The transpiler generates bare (fun () -> ...) for reactive subscribers
   but signal_add_sub_b expects value. This is a known transpiler limitation. *)
let signal_add_sub_b s (f : _ ) = match s with
  | Dict d when is_dict_signal d ->
    let f_val : value = Obj.magic f in
    let subs = match Sx_types.dict_get d "subscribers" with
      | List l -> l | ListRef r -> !r | _ -> [] in
    Hashtbl.replace d "subscribers" (List (subs @ [f_val])); Nil
  | _ -> Nil

let signal_remove_sub_b s (f : _) = match s with
  | Dict d when is_dict_signal d ->
    let f_val : value = Obj.magic f in
    let subs = match Sx_types.dict_get d "subscribers" with
      | List l -> l | ListRef r -> !r | _ -> [] in
    Hashtbl.replace d "subscribers" (List (List.filter (fun x -> x != f_val) subs)); Nil
  | _ -> Nil

let signal_deps s = match s with
  | Dict d when is_dict_signal d -> Sx_types.dict_get d "deps"
  | _ -> List []

let signal_set_deps s deps = match s with
  | Dict d when is_dict_signal d -> Hashtbl.replace d "deps" deps; Nil
  | _ -> Nil

let notify_subscribers s = match s with
  | Dict d when is_dict_signal d ->
    let subs = match Sx_types.dict_get d "subscribers" with
      | List l -> l | ListRef r -> !r | _ -> [] in
    List.iter (fun sub ->
      match sub with
      | NativeFn (_, f) -> ignore (f [])
      | Lambda _ -> ignore (Sx_types.env_bind (Sx_types.make_env ()) "_" Nil) (* TODO: call through CEK *)
      | _ -> ()
    ) subs; Nil
  | _ -> Nil

let flush_subscribers _s = Nil
let dispose_computed _s = Nil

(* Island scope stubs — accept OCaml functions from transpiled code.
   Use Obj.magic for the same reason as signal_add_sub_b. *)
let with_island_scope (_register_fn : _) (body_fn : _) =
  let body : unit -> value = Obj.magic body_fn in
  body ()
let register_in_scope (_dispose_fn : _) = Nil

(* Component type annotation stub *)
let component_set_param_types_b _comp _types = Nil

(* Parse keyword args from a call — this is defined in evaluator.sx,
   the transpiled version will override this stub. *)
(* Forward-reference stubs for evaluator functions used before definition *)
let parse_comp_params _params = List [List []; Nil; Bool false]
let parse_macro_params _params = List [List []; Nil]

let parse_keyword_args _raw_args _env =
  (* Stub — the real implementation is transpiled from evaluator.sx *)
  List [Dict (Hashtbl.create 0); List []]

(* Make handler/query/action/page def stubs *)
let make_handler_def name params body _env = Dict (let d = Hashtbl.create 4 in Hashtbl.replace d "type" (String "handler"); Hashtbl.replace d "name" name; Hashtbl.replace d "params" params; Hashtbl.replace d "body" body; d)
let make_query_def name params body _env = make_handler_def name params body _env
let make_action_def name params body _env = make_handler_def name params body _env
let make_page_def name _opts = Dict (let d = Hashtbl.create 4 in Hashtbl.replace d "type" (String "page"); Hashtbl.replace d "name" name; d)

(* sf-def* stubs — platform-specific def-forms, not in the SX spec *)
let sf_defhandler args env =
  let name = first args in let rest_args = rest args in
  make_handler_def name (first rest_args) (nth rest_args (Number 1.0)) env
let sf_defquery args env = sf_defhandler args env
let sf_defaction args env = sf_defhandler args env
let sf_defpage args _env =
  let name = first args in make_page_def name (rest args)

let strip_prefix s prefix =
  match s, prefix with
  | String s, String p ->
    let pl = String.length p in
    if String.length s >= pl && String.sub s 0 pl = p
    then String (String.sub s pl (String.length s - pl))
    else String s
  | _ -> s