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
  | VmClosure cl -> !Sx_types._vm_call_closure_ref cl 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;
    Thunk (l.l_body, local)
  | Continuation (k, _) ->
    k (match args with x :: _ -> x | [] -> Nil)
  | CallccContinuation _ ->
    raise (Eval_error "callcc continuations must be invoked through the CEK machine")
  | _ ->
    let nargs = List.length args in
    let args_preview = if nargs = 0 then "" else
      let s = String.concat ", " (List.map (fun a -> let s = inspect a in if String.length s > 40 then String.sub s 0 40 ^ ".." else s) args) in
      " with args=[" ^ s ^ "]" in
    raise (Eval_error ("Not callable: " ^ inspect f ^ args_preview))

(* Initialize forward ref so primitives can call SX functions *)
let () = Sx_primitives._sx_call_fn := sx_call
(* Trampoline ref is set by sx_ref.ml after it's loaded *)

(** 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
  | CekState s, String k ->
    (match k with
     | "control" -> s.cs_control | "env" -> s.cs_env
     | "kont" -> s.cs_kont | "phase" -> String s.cs_phase
     | "value" -> s.cs_value | _ -> Nil)
  | CekFrame f, String k ->
    (match k with
     | "type" -> String f.cf_type | "env" -> f.cf_env
     | "name" -> f.cf_name | "body" -> f.cf_body
     | "remaining" -> f.cf_remaining | "f" -> f.cf_f
     | "args" -> f.cf_args | "evaled" -> f.cf_args
     | "results" -> f.cf_results | "raw-args" -> f.cf_results
     | "then" -> f.cf_body | "else" -> f.cf_name
     | "ho-type" -> f.cf_extra | "scheme" -> f.cf_extra
     | "indexed" -> f.cf_extra | "value" -> f.cf_extra
     | "phase" -> f.cf_extra | "has-effects" -> f.cf_extra
     | "match-val" -> f.cf_extra | "current-item" -> f.cf_extra
     | "update-fn" -> f.cf_extra | "head-name" -> f.cf_extra
     | "emitted" -> f.cf_extra2 | "effect-list" -> f.cf_extra2
     | "first-render" -> f.cf_extra2 | "file" -> f.cf_env
     | "extra" -> f.cf_extra | "extra2" -> f.cf_extra2
     | _ -> Nil)
  | 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)
  | Nil, _ -> Nil  (* nil.anything → nil *)
  | _, _ -> Nil    (* type mismatch → nil (matches JS/Python behavior) *)

(** 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 take a b = _prim "take" [a; b]
let drop a b = _prim "drop" [a; b]

(* Predicates *)
let empty_p a = _prim "empty?" [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]

(* 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 substring a b c = _prim "substring" [a; b; c]

(* 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_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]

(* 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 spread_attrs a = _prim "spread-attrs" [a]

let sx_context a b = prim_call "context" [a; b]

(* 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
  | Dict d ->
    (* Dict used as env — wrap it. Needed by adapter-html.sx which
       passes dicts as env args (e.g. empty {} as caller env). *)
    let e = Sx_types.make_env () in
    Hashtbl.iter (fun k v -> ignore (Sx_types.env_bind e k v)) d;
    e
  | Nil ->
    Sx_types.make_env ()
  | v -> raise (Eval_error ("Expected env, got " ^ Sx_types.type_of v))

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_primitive name = Bool (Sx_primitives.is_primitive (value_to_str name))
let get_primitive name = Sx_primitives.get_primitive (value_to_str name)

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

(* Callcc (undelimited) continuation support *)
let callcc_continuation_p v = match v with CallccContinuation _ -> Bool true | _ -> Bool false

let make_callcc_continuation captured =
  CallccContinuation (sx_to_list captured)

let callcc_continuation_data v = match v with
  | CallccContinuation frames -> List frames
  | _ -> raise (Eval_error "not a callcc continuation")

(* Dynamic wind — simplified for OCaml (no async) *)
let host_error msg =
  raise (Eval_error (value_to_str msg))

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 — all delegated to primitives registered in sx_server.ml *)
let scope_push name value = prim_call "scope-push!" [name; value]
let scope_pop name = prim_call "scope-pop!" [name]
let scope_peek name = prim_call "scope-peek" [name]
let scope_emit name value = prim_call "scope-emit!" [name; value]
let provide_push name value = prim_call "scope-push!" [name; value]
let provide_pop name = prim_call "scope-pop!" [name]

(* Custom special forms registry — mutable dict *)
let custom_special_forms = Dict (Hashtbl.create 4)

(* register-special-form! — add a handler to the custom registry *)
let register_special_form name handler =
  (match custom_special_forms with
   | Dict tbl -> Hashtbl.replace tbl (value_to_str name) handler; handler
   | _ -> raise (Eval_error "custom_special_forms not a dict"))

(* Render check/fn hooks — nil by default, set by platform if needed *)
let render_check = Nil
let render_fn = Nil

(* is-else-clause? — check if a cond/case test is an else marker *)
let is_else_clause v =
  match v with
  | Keyword k -> Bool (k = "else" || k = "default")
  | Symbol s -> Bool (s = "else" || s = "default")
  | Bool true -> Bool true
  | _ -> Bool false

(* Signal accessors *)
let signal_value s = match s with
  | Signal sig' -> sig'.s_value
  | Dict d -> (match Hashtbl.find_opt d "value" with Some v -> v | None -> Nil)
  | _ -> raise (Eval_error "not a signal")
let signal_add_sub_b s f =
  match s with
  | Dict d ->
    (match Hashtbl.find_opt d "subscribers" with
     | Some (ListRef r) -> r := !r @ [f]; Nil
     | Some (List items) -> Hashtbl.replace d "subscribers" (ListRef (ref (items @ [f]))); Nil
     | _ -> Hashtbl.replace d "subscribers" (ListRef (ref [f])); Nil)
  | _ -> Nil

let signal_remove_sub_b s f =
  match s with
  | Dict d ->
    (match Hashtbl.find_opt d "subscribers" with
     | Some (ListRef r) -> r := List.filter (fun x -> x != f) !r; Nil
     | Some (List items) -> Hashtbl.replace d "subscribers" (List (List.filter (fun x -> x != f) items)); Nil
     | _ -> Nil)
  | _ -> Nil

(* Island scope stubs — accept both bare OCaml fns and NativeFn values
   from transpiled code (NativeFn wrapping for value-storable lambdas). *)
let with_island_scope _register_fn body_fn =
  match body_fn with
  | NativeFn (_, f) -> f []
  | _ -> Nil
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 def — used by custom_special_forms *)
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_page_def name _opts = Dict (let d = Hashtbl.create 4 in Hashtbl.replace d "type" (String "page"); Hashtbl.replace d "name" name; d)

(* sf_defhandler — used by custom_special_forms *)
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 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

(* debug_log — no-op in production, used by CEK evaluator for component warnings *)
let debug_log _ _ = Nil

(* mutable_list — mutable list for bytecode compiler pool entries *)
let mutable_list () = ListRef (ref [])

(* JIT try-call — ref set by sx_server.ml after compiler loads.
   Returns Nil (no JIT) or the result value. Spec calls this. *)
let _jit_try_call_fn : (value -> value list -> value option) option ref = ref None
let jit_try_call f args =
  match !_jit_try_call_fn with
  | None -> Nil
  | Some hook ->
    match f with
    | Lambda l when l.l_name <> None ->
      let arg_list = match args with List a | ListRef { contents = a } -> a | _ -> [] in
      (match hook f arg_list with Some result -> result | None -> Nil)
    | _ -> Nil