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;
    Thunk (l.l_body, local)
  | Continuation (k, _) ->
    k (match args with x :: _ -> x | [] -> Nil)
  | _ -> raise (Eval_error ("Not callable: " ^ inspect f))

(* 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
     | _ -> 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)
  | _ -> 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 primitives — delegate to sx_ref.py's shared scope stacks *)
let sx_collect a b = prim_call "collect!" [a; b]
let sx_collected a = prim_call "collected" [a]
let sx_clear_collected a = prim_call "clear-collected!" [a]
let sx_emit a b = prim_call "emit!" [a; b]
let sx_emitted a = prim_call "emitted" [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
  | 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_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 = prim_call "collect!" [name; value]
let scope_pop _name = Nil
let provide_push name value = ignore name; ignore value; Nil
let provide_pop _name = Nil

(* 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 | _ -> raise (Eval_error "not a signal")
let signal_set_value s v = match s with Signal sig' -> sig'.s_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) | _ -> List []
let signal_add_sub_b _s _f = Nil
let signal_remove_sub_b _s _f = Nil
let signal_deps _s = List []
let signal_set_deps _s _d = Nil
let notify_subscribers _s = Nil
let flush_subscribers _s = Nil
let dispose_computed _s = Nil

(* Island scope stubs — accept OCaml functions from transpiled code *)
let with_island_scope _register_fn body_fn = body_fn ()
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

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