giles
0caa965de0
All checks were successful
Build and Deploy / build-and-deploy (push) Successful in 23m17s
- wasm_of_ocaml compiles OCaml SX engine to WASM (722/722 spec tests) - js_of_ocaml fallback also working (722/722 spec tests) - Thin JS platform layer (sx-platform.js) with ~80 DOM/browser natives - Lambda callback bridge: SX lambdas callable from JS via handle table - Side-channel pattern bypasses js_of_ocaml return-value property stripping - Web adapters (signals, deps, router, adapter-html) load as SX source - Render mode dispatch: HTML tags + fragments route to OCaml renderer - Island/component accessors handle both Component and Island types - Dict-based signal support (signals.sx creates dicts, not native Signal) - Scope stack implementation (collect!/collected/emit!/emitted/context) - Bundle script embeds web adapters + WASM loader + platform layer - SX_USE_WASM env var toggles WASM engine in dev/production - Bootstrap extended: --web flag transpiles web adapters, :effects stripping Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
947 lines
36 KiB
OCaml
947 lines
36 KiB
OCaml
(** sx_browser.ml — OCaml SX engine compiled to WASM/JS for browser use.
|
|
|
|
Exposes the CEK machine, parser, and primitives as a global [Sx] object
|
|
that the thin JS platform layer binds to. *)
|
|
|
|
open Js_of_ocaml
|
|
open Sx_types
|
|
|
|
(* ================================================================== *)
|
|
(* Value conversion: OCaml <-> JS *)
|
|
(* ================================================================== *)
|
|
|
|
(* ------------------------------------------------------------------ *)
|
|
(* Opaque value handle table *)
|
|
(* *)
|
|
(* Non-primitive SX values (lambdas, components, signals, etc.) are *)
|
|
(* stored in a handle table and represented on the JS side as objects *)
|
|
(* with an __sx_handle integer key. This preserves identity across *)
|
|
(* the JS↔OCaml boundary — the same handle always resolves to the *)
|
|
(* same OCaml value. *)
|
|
(* *)
|
|
(* Callable values (Lambda, NativeFn, Continuation) are additionally *)
|
|
(* wrapped as JS functions so they can be used directly as event *)
|
|
(* listeners, setTimeout callbacks, etc. *)
|
|
(* ------------------------------------------------------------------ *)
|
|
|
|
let _next_handle = ref 0
|
|
let _handle_table : (int, value) Hashtbl.t = Hashtbl.create 256
|
|
|
|
(** Store a value in the handle table, return its handle id. *)
|
|
let alloc_handle (v : value) : int =
|
|
let id = !_next_handle in
|
|
incr _next_handle;
|
|
Hashtbl.replace _handle_table id v;
|
|
id
|
|
|
|
(** Look up a value by handle. *)
|
|
let get_handle (id : int) : value =
|
|
match Hashtbl.find_opt _handle_table id with
|
|
| Some v -> v
|
|
| None -> raise (Eval_error (Printf.sprintf "Invalid SX handle: %d" id))
|
|
|
|
(** Late-bound reference to global env (set after global_env is created). *)
|
|
let _global_env_ref : env option ref = ref None
|
|
let get_global_env () = match !_global_env_ref with
|
|
| Some e -> e | None -> raise (Eval_error "Global env not initialized")
|
|
|
|
(** Call an SX callable through the CEK machine.
|
|
Constructs (fn arg1 arg2 ...) and evaluates it. *)
|
|
let call_sx_fn (fn : value) (args : value list) : value =
|
|
Sx_ref.eval_expr (List (fn :: args)) (Env (get_global_env ()))
|
|
|
|
(** Convert an OCaml SX value to a JS representation.
|
|
Primitive types map directly.
|
|
Callable values become JS functions (with __sx_handle).
|
|
Other compound types become tagged objects (with __sx_handle). *)
|
|
let rec value_to_js (v : value) : Js.Unsafe.any =
|
|
match v with
|
|
| Nil -> Js.Unsafe.inject Js.null
|
|
| Bool b -> Js.Unsafe.inject (Js.bool b)
|
|
| Number n -> Js.Unsafe.inject (Js.number_of_float n)
|
|
| String s -> Js.Unsafe.inject (Js.string s)
|
|
| Symbol s ->
|
|
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string "symbol"));
|
|
("name", Js.Unsafe.inject (Js.string s)) |] in
|
|
Js.Unsafe.inject obj
|
|
| Keyword k ->
|
|
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string "keyword"));
|
|
("name", Js.Unsafe.inject (Js.string k)) |] in
|
|
Js.Unsafe.inject obj
|
|
| List items ->
|
|
let arr = items |> List.map value_to_js |> Array.of_list in
|
|
let js_arr = Js.array arr in
|
|
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string "list"));
|
|
("items", Js.Unsafe.inject js_arr) |] in
|
|
Js.Unsafe.inject obj
|
|
| ListRef r ->
|
|
let arr = !r |> List.map value_to_js |> Array.of_list in
|
|
let js_arr = Js.array arr in
|
|
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string "list"));
|
|
("items", Js.Unsafe.inject js_arr) |] in
|
|
Js.Unsafe.inject obj
|
|
| Dict d ->
|
|
let obj = Js.Unsafe.obj [||] in
|
|
Js.Unsafe.set obj (Js.string "_type") (Js.string "dict");
|
|
Hashtbl.iter (fun k v ->
|
|
Js.Unsafe.set obj (Js.string k) (value_to_js v)
|
|
) d;
|
|
Js.Unsafe.inject obj
|
|
| RawHTML s -> Js.Unsafe.inject (Js.string s)
|
|
(* Callable values: wrap as JS functions *)
|
|
| Lambda _ | NativeFn _ | Continuation _ ->
|
|
let handle = alloc_handle v in
|
|
(* Create a JS function that calls back into the CEK machine.
|
|
Use _tagFn helper (registered on globalThis) to create a function
|
|
with __sx_handle and _type properties that survive js_of_ocaml
|
|
return-value wrapping. *)
|
|
let inner = Js.wrap_callback (fun args_js ->
|
|
try
|
|
let arg = js_to_value args_js in
|
|
let args = match arg with Nil -> [] | _ -> [arg] in
|
|
let result = call_sx_fn v args in
|
|
value_to_js result
|
|
with Eval_error msg ->
|
|
ignore (Js.Unsafe.meth_call (Js.Unsafe.get Js.Unsafe.global (Js.string "console"))
|
|
"error" [| Js.Unsafe.inject (Js.string (Printf.sprintf "[sx] callback error: %s" msg)) |]);
|
|
Js.Unsafe.inject Js.null
|
|
) in
|
|
let tag_fn = Js.Unsafe.get Js.Unsafe.global (Js.string "__sxTagFn") in
|
|
Js.Unsafe.fun_call tag_fn [|
|
|
Js.Unsafe.inject inner;
|
|
Js.Unsafe.inject handle;
|
|
Js.Unsafe.inject (Js.string (type_of v))
|
|
|]
|
|
(* Non-callable compound values: tagged objects with handle *)
|
|
| Component c ->
|
|
let handle = alloc_handle v in
|
|
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string "component"));
|
|
("name", Js.Unsafe.inject (Js.string c.c_name));
|
|
("__sx_handle", Js.Unsafe.inject handle) |] in
|
|
Js.Unsafe.inject obj
|
|
| Island i ->
|
|
let handle = alloc_handle v in
|
|
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string "island"));
|
|
("name", Js.Unsafe.inject (Js.string i.i_name));
|
|
("__sx_handle", Js.Unsafe.inject handle) |] in
|
|
Js.Unsafe.inject obj
|
|
| Signal _ ->
|
|
let handle = alloc_handle v in
|
|
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string "signal"));
|
|
("__sx_handle", Js.Unsafe.inject handle) |] in
|
|
Js.Unsafe.inject obj
|
|
| _ ->
|
|
let handle = alloc_handle v in
|
|
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string (type_of v)));
|
|
("__sx_handle", Js.Unsafe.inject handle) |] in
|
|
Js.Unsafe.inject obj
|
|
|
|
(** Convert a JS value back to an OCaml SX value. *)
|
|
and js_to_value (js : Js.Unsafe.any) : value =
|
|
(* Check null/undefined *)
|
|
if Js.Unsafe.equals js Js.null || Js.Unsafe.equals js Js.undefined then
|
|
Nil
|
|
else
|
|
let ty = Js.to_string (Js.typeof js) in
|
|
match ty with
|
|
| "number" ->
|
|
Number (Js.float_of_number (Js.Unsafe.coerce js))
|
|
| "boolean" ->
|
|
Bool (Js.to_bool (Js.Unsafe.coerce js))
|
|
| "string" ->
|
|
String (Js.to_string (Js.Unsafe.coerce js))
|
|
| "function" ->
|
|
(* Check for __sx_handle — this is a wrapped SX callable *)
|
|
let handle_field = Js.Unsafe.get js (Js.string "__sx_handle") in
|
|
if not (Js.Unsafe.equals handle_field Js.undefined) then
|
|
let id = Js.float_of_number (Js.Unsafe.coerce handle_field) |> int_of_float in
|
|
get_handle id
|
|
else
|
|
(* Plain JS function — wrap as NativeFn *)
|
|
NativeFn ("js-callback", fun args ->
|
|
let js_args = args |> List.map value_to_js |> Array.of_list in
|
|
let result = Js.Unsafe.fun_call js
|
|
(Array.map (fun a -> a) js_args) in
|
|
js_to_value result)
|
|
| "object" ->
|
|
(* Check for __sx_handle — this is a wrapped SX value *)
|
|
let handle_field = Js.Unsafe.get js (Js.string "__sx_handle") in
|
|
if not (Js.Unsafe.equals handle_field Js.undefined) then begin
|
|
let id = Js.float_of_number (Js.Unsafe.coerce handle_field) |> int_of_float in
|
|
get_handle id
|
|
end else begin
|
|
(* Check for _type tag *)
|
|
let type_field = Js.Unsafe.get js (Js.string "_type") in
|
|
if Js.Unsafe.equals type_field Js.undefined then begin
|
|
(* Check if it's an array *)
|
|
let is_arr = Js.to_bool (Js.Unsafe.global##._Array##isArray js) in
|
|
if is_arr then begin
|
|
let len_js = Js.Unsafe.get js (Js.string "length") in
|
|
let n = Js.float_of_number (Js.Unsafe.coerce len_js) |> int_of_float in
|
|
let items = List.init n (fun i ->
|
|
js_to_value (Js.array_get (Js.Unsafe.coerce js) i
|
|
|> Js.Optdef.to_option |> Option.get)
|
|
) in
|
|
List items
|
|
end else begin
|
|
(* Plain JS object — convert to dict *)
|
|
let d = Hashtbl.create 8 in
|
|
let keys = Js.Unsafe.global##._Object##keys js in
|
|
let len = keys##.length in
|
|
for i = 0 to len - 1 do
|
|
let k = Js.to_string (Js.array_get keys i |> Js.Optdef.to_option |> Option.get) in
|
|
let v = Js.Unsafe.get js (Js.string k) in
|
|
Hashtbl.replace d k (js_to_value v)
|
|
done;
|
|
Dict d
|
|
end
|
|
end else begin
|
|
let tag = Js.to_string (Js.Unsafe.coerce type_field) in
|
|
match tag with
|
|
| "symbol" ->
|
|
Symbol (Js.to_string (Js.Unsafe.get js (Js.string "name")))
|
|
| "keyword" ->
|
|
Keyword (Js.to_string (Js.Unsafe.get js (Js.string "name")))
|
|
| "list" ->
|
|
let items_js = Js.Unsafe.get js (Js.string "items") in
|
|
let len = Js.Unsafe.get items_js (Js.string "length") in
|
|
let n = Js.float_of_number (Js.Unsafe.coerce len) |> int_of_float in
|
|
let items = List.init n (fun i ->
|
|
js_to_value (Js.array_get (Js.Unsafe.coerce items_js) i
|
|
|> Js.Optdef.to_option |> Option.get)
|
|
) in
|
|
List items
|
|
| "dict" ->
|
|
let d = Hashtbl.create 8 in
|
|
let keys = Js.Unsafe.global##._Object##keys js in
|
|
let len = keys##.length in
|
|
for i = 0 to len - 1 do
|
|
let k = Js.to_string (Js.array_get keys i |> Js.Optdef.to_option |> Option.get) in
|
|
if k <> "_type" then begin
|
|
let v = Js.Unsafe.get js (Js.string k) in
|
|
Hashtbl.replace d k (js_to_value v)
|
|
end
|
|
done;
|
|
Dict d
|
|
| _ -> Nil
|
|
end
|
|
end
|
|
| _ -> Nil
|
|
|
|
(* ================================================================== *)
|
|
(* Global environment *)
|
|
(* ================================================================== *)
|
|
|
|
let global_env = make_env ()
|
|
let () = _global_env_ref := Some global_env
|
|
|
|
(* Render mode flag — set true during renderToHtml/loadSource calls
|
|
that should dispatch HTML tags to the renderer. *)
|
|
let _sx_render_mode = ref false
|
|
|
|
(* Register JS helpers.
|
|
__sxTagFn: tag a function with __sx_handle and _type properties.
|
|
__sxR: side-channel for return values (bypasses Js.wrap_callback
|
|
which strips custom properties from function objects). *)
|
|
let () =
|
|
let tag_fn = Js.Unsafe.pure_js_expr
|
|
"(function(fn, handle, type) { fn.__sx_handle = handle; fn._type = type; return fn; })" in
|
|
Js.Unsafe.set Js.Unsafe.global (Js.string "__sxTagFn") tag_fn
|
|
|
|
(** Store a value in the side-channel and return a sentinel.
|
|
The JS wrapper picks up __sxR instead of the return value. *)
|
|
let return_via_side_channel (v : Js.Unsafe.any) : Js.Unsafe.any =
|
|
Js.Unsafe.set Js.Unsafe.global (Js.string "__sxR") v;
|
|
v
|
|
|
|
(* ================================================================== *)
|
|
(* Core API functions *)
|
|
(* ================================================================== *)
|
|
|
|
(** Parse SX source string into a list of values. *)
|
|
let api_parse src_js =
|
|
let src = Js.to_string src_js in
|
|
try
|
|
let values = Sx_parser.parse_all src in
|
|
let arr = values |> List.map value_to_js |> Array.of_list in
|
|
Js.Unsafe.inject (Js.array arr)
|
|
with Parse_error msg ->
|
|
Js.Unsafe.inject (Js.string ("Parse error: " ^ msg))
|
|
|
|
(** Serialize an SX value to source text. *)
|
|
let api_stringify v_js =
|
|
let v = js_to_value v_js in
|
|
Js.Unsafe.inject (Js.string (inspect v))
|
|
|
|
(** Evaluate a single SX expression in the global environment. *)
|
|
let api_eval_expr expr_js env_js =
|
|
let expr = js_to_value expr_js in
|
|
let _env = if Js.Unsafe.equals env_js Js.undefined then global_env
|
|
else global_env in
|
|
try
|
|
let result = Sx_ref.eval_expr expr (Env _env) in
|
|
return_via_side_channel (value_to_js result)
|
|
with Eval_error msg ->
|
|
Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
|
|
|
(** Evaluate SX source string and return the last result. *)
|
|
let api_eval src_js =
|
|
let src = Js.to_string src_js in
|
|
try
|
|
let exprs = Sx_parser.parse_all src in
|
|
let env = Env global_env in
|
|
let result = List.fold_left (fun _acc expr ->
|
|
Sx_ref.eval_expr expr env
|
|
) Nil exprs in
|
|
return_via_side_channel (value_to_js result)
|
|
with
|
|
| Eval_error msg -> Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
|
| Parse_error msg -> Js.Unsafe.inject (Js.string ("Parse error: " ^ msg))
|
|
|
|
(** Run the CEK machine on an expression, return result. *)
|
|
let api_cek_run expr_js =
|
|
let expr = js_to_value expr_js in
|
|
try
|
|
let state = Sx_ref.make_cek_state expr (Env global_env) Nil in
|
|
let result = Sx_ref.cek_run_iterative state in
|
|
return_via_side_channel (value_to_js result)
|
|
with Eval_error msg ->
|
|
Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
|
|
|
(** Render SX expression to HTML string. *)
|
|
let api_render_to_html expr_js =
|
|
let expr = js_to_value expr_js in
|
|
let prev = !_sx_render_mode in
|
|
_sx_render_mode := true;
|
|
try
|
|
let html = Sx_render.render_to_html expr global_env in
|
|
_sx_render_mode := prev;
|
|
Js.Unsafe.inject (Js.string html)
|
|
with Eval_error msg ->
|
|
_sx_render_mode := prev;
|
|
Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
|
|
|
(** Load SX source for side effects (define, defcomp, defmacro). *)
|
|
let api_load src_js =
|
|
let src = Js.to_string src_js in
|
|
try
|
|
let exprs = Sx_parser.parse_all src in
|
|
let env = Env global_env in
|
|
let count = ref 0 in
|
|
List.iter (fun expr ->
|
|
ignore (Sx_ref.eval_expr expr env);
|
|
incr count
|
|
) exprs;
|
|
Js.Unsafe.inject !count
|
|
with
|
|
| Eval_error msg -> Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
|
| Parse_error msg -> Js.Unsafe.inject (Js.string ("Parse error: " ^ msg))
|
|
|
|
(** Get the type of an SX value. *)
|
|
let api_type_of v_js =
|
|
let v = js_to_value v_js in
|
|
Js.Unsafe.inject (Js.string (type_of v))
|
|
|
|
(** Inspect an SX value (debug string). *)
|
|
let api_inspect v_js =
|
|
let v = js_to_value v_js in
|
|
Js.Unsafe.inject (Js.string (inspect v))
|
|
|
|
(** Get engine identity. *)
|
|
let api_engine () =
|
|
Js.Unsafe.inject (Js.string "ocaml-cek-wasm")
|
|
|
|
(** Register a JS callback as a named native function in the global env.
|
|
JS callback receives JS-converted args and should return a JS value. *)
|
|
let api_register_native name_js callback_js =
|
|
let name = Js.to_string name_js in
|
|
let native_fn args =
|
|
let js_args = args |> List.map value_to_js |> Array.of_list in
|
|
let result = Js.Unsafe.fun_call callback_js
|
|
[| Js.Unsafe.inject (Js.array js_args) |] in
|
|
js_to_value result
|
|
in
|
|
ignore (env_bind global_env name (NativeFn (name, native_fn)));
|
|
Js.Unsafe.inject Js.null
|
|
|
|
(** Call an SX callable (lambda, native fn) with JS args.
|
|
fn_js can be a wrapped SX callable (with __sx_handle) or a JS value.
|
|
args_js is a JS array of arguments. *)
|
|
let api_call_fn fn_js args_js =
|
|
try
|
|
let fn = js_to_value fn_js in
|
|
let args_arr = Js.to_array (Js.Unsafe.coerce args_js) in
|
|
let args = Array.to_list (Array.map js_to_value args_arr) in
|
|
let result = call_sx_fn fn args in
|
|
return_via_side_channel (value_to_js result)
|
|
with
|
|
| Eval_error msg ->
|
|
ignore (Js.Unsafe.meth_call (Js.Unsafe.get Js.Unsafe.global (Js.string "console"))
|
|
"error" [| Js.Unsafe.inject (Js.string (Printf.sprintf "[sx] callFn error: %s" msg)) |]);
|
|
Js.Unsafe.inject Js.null
|
|
| exn ->
|
|
ignore (Js.Unsafe.meth_call (Js.Unsafe.get Js.Unsafe.global (Js.string "console"))
|
|
"error" [| Js.Unsafe.inject (Js.string (Printf.sprintf "[sx] callFn error: %s" (Printexc.to_string exn))) |]);
|
|
Js.Unsafe.inject Js.null
|
|
|
|
(** Check if a JS value is a wrapped SX callable. *)
|
|
let api_is_callable fn_js =
|
|
if Js.Unsafe.equals fn_js Js.null || Js.Unsafe.equals fn_js Js.undefined then
|
|
Js.Unsafe.inject (Js.bool false)
|
|
else
|
|
let handle_field = Js.Unsafe.get fn_js (Js.string "__sx_handle") in
|
|
if not (Js.Unsafe.equals handle_field Js.undefined) then begin
|
|
let id = Js.float_of_number (Js.Unsafe.coerce handle_field) |> int_of_float in
|
|
let v = get_handle id in
|
|
Js.Unsafe.inject (Js.bool (is_callable v))
|
|
end else
|
|
Js.Unsafe.inject (Js.bool false)
|
|
|
|
(** Get the parameter count of an SX callable (for zero-arg optimization). *)
|
|
let api_fn_arity fn_js =
|
|
let handle_field = Js.Unsafe.get fn_js (Js.string "__sx_handle") in
|
|
if Js.Unsafe.equals handle_field Js.undefined then
|
|
Js.Unsafe.inject (Js.number_of_float (-1.0))
|
|
else
|
|
let id = Js.float_of_number (Js.Unsafe.coerce handle_field) |> int_of_float in
|
|
let v = get_handle id in
|
|
match v with
|
|
| Lambda l -> Js.Unsafe.inject (Js.number_of_float (float_of_int (List.length l.l_params)))
|
|
| _ -> Js.Unsafe.inject (Js.number_of_float (-1.0))
|
|
|
|
(** Load and evaluate SX source string with error wrapping (for test runner). *)
|
|
let api_load_source src_js =
|
|
let src = Js.to_string src_js in
|
|
try
|
|
let exprs = Sx_parser.parse_all src in
|
|
let env = Env global_env in
|
|
let count = ref 0 in
|
|
List.iter (fun expr ->
|
|
ignore (Sx_ref.eval_expr expr env);
|
|
incr count
|
|
) exprs;
|
|
Js.Unsafe.inject !count
|
|
with
|
|
| Eval_error msg -> Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
|
| Parse_error msg -> Js.Unsafe.inject (Js.string ("Parse error: " ^ msg))
|
|
| exn -> Js.Unsafe.inject (Js.string ("Error: " ^ Printexc.to_string exn))
|
|
|
|
(* ================================================================== *)
|
|
(* Register global Sx object *)
|
|
(* ================================================================== *)
|
|
|
|
(* ================================================================== *)
|
|
(* Platform test functions (registered in global env) *)
|
|
(* ================================================================== *)
|
|
|
|
let () =
|
|
let bind name fn =
|
|
ignore (env_bind global_env name (NativeFn (name, fn)))
|
|
in
|
|
|
|
(* --- Deep equality --- *)
|
|
let rec deep_equal a b =
|
|
match a, b with
|
|
| Nil, Nil -> true
|
|
| Bool a, Bool b -> a = b
|
|
| Number a, Number b -> a = b
|
|
| String a, String b -> a = b
|
|
| Symbol a, Symbol b -> a = b
|
|
| Keyword a, Keyword b -> a = b
|
|
| (List a | ListRef { contents = a }), (List b | ListRef { contents = b }) ->
|
|
List.length a = List.length b && List.for_all2 deep_equal a b
|
|
| Dict a, Dict b ->
|
|
let ka = Hashtbl.fold (fun k _ acc -> k :: acc) a [] in
|
|
let kb = Hashtbl.fold (fun k _ acc -> k :: acc) b [] in
|
|
List.length ka = List.length kb &&
|
|
List.for_all (fun k ->
|
|
Hashtbl.mem b k &&
|
|
deep_equal
|
|
(match Hashtbl.find_opt a k with Some v -> v | None -> Nil)
|
|
(match Hashtbl.find_opt b k with Some v -> v | None -> Nil)) ka
|
|
| Lambda _, Lambda _ -> a == b
|
|
| NativeFn _, NativeFn _ -> a == b
|
|
| _ -> false
|
|
in
|
|
|
|
(* --- try-call --- *)
|
|
bind "try-call" (fun args ->
|
|
match args with
|
|
| [thunk] ->
|
|
(try
|
|
ignore (Sx_ref.eval_expr (List [thunk]) (Env global_env));
|
|
let d = Hashtbl.create 2 in
|
|
Hashtbl.replace d "ok" (Bool true); Dict d
|
|
with
|
|
| Eval_error msg ->
|
|
let d = Hashtbl.create 2 in
|
|
Hashtbl.replace d "ok" (Bool false);
|
|
Hashtbl.replace d "error" (String msg); Dict d
|
|
| exn ->
|
|
let d = Hashtbl.create 2 in
|
|
Hashtbl.replace d "ok" (Bool false);
|
|
Hashtbl.replace d "error" (String (Printexc.to_string exn)); Dict d)
|
|
| _ -> raise (Eval_error "try-call: expected 1 arg"));
|
|
|
|
(* --- Evaluation --- *)
|
|
bind "cek-eval" (fun args ->
|
|
match args with
|
|
| [expr] -> Sx_ref.eval_expr expr (Env global_env)
|
|
| [expr; env_val] -> Sx_ref.eval_expr expr env_val
|
|
| _ -> raise (Eval_error "cek-eval: expected 1-2 args"));
|
|
|
|
bind "eval-expr-cek" (fun args ->
|
|
match args with
|
|
| [expr] -> Sx_ref.eval_expr expr (Env global_env)
|
|
| [expr; env_val] -> Sx_ref.eval_expr expr env_val
|
|
| _ -> raise (Eval_error "eval-expr-cek: expected 1-2 args"));
|
|
|
|
bind "sx-parse" (fun args ->
|
|
match args with
|
|
| [String src] -> List (Sx_parser.parse_all src)
|
|
| _ -> raise (Eval_error "sx-parse: expected string"));
|
|
|
|
(* --- Equality and assertions --- *)
|
|
bind "equal?" (fun args ->
|
|
match args with
|
|
| [a; b] -> Bool (deep_equal a b)
|
|
| _ -> raise (Eval_error "equal?: expected 2 args"));
|
|
|
|
bind "identical?" (fun args ->
|
|
match args with
|
|
| [a; b] -> Bool (a == b)
|
|
| _ -> raise (Eval_error "identical?: expected 2 args"));
|
|
|
|
bind "assert" (fun args ->
|
|
match args with
|
|
| [cond] ->
|
|
if not (sx_truthy cond) then raise (Eval_error "Assertion failed");
|
|
Bool true
|
|
| [cond; String msg] ->
|
|
if not (sx_truthy cond) then raise (Eval_error ("Assertion error: " ^ msg));
|
|
Bool true
|
|
| [cond; msg] ->
|
|
if not (sx_truthy cond) then
|
|
raise (Eval_error ("Assertion error: " ^ value_to_string msg));
|
|
Bool true
|
|
| _ -> raise (Eval_error "assert: expected 1-2 args"));
|
|
|
|
(* --- List mutation --- *)
|
|
bind "append!" (fun args ->
|
|
match args with
|
|
| [ListRef r; v] -> r := !r @ [v]; ListRef r
|
|
| [List items; v] -> List (items @ [v])
|
|
| _ -> raise (Eval_error "append!: expected list and value"));
|
|
|
|
(* --- Environment ops --- *)
|
|
bind "make-env" (fun _args -> Env (make_env ()));
|
|
|
|
bind "env-has?" (fun args ->
|
|
match args with
|
|
| [Env e; String k] -> Bool (env_has e k)
|
|
| [Env e; Keyword k] -> Bool (env_has e k)
|
|
| _ -> raise (Eval_error "env-has?: expected env and key"));
|
|
|
|
bind "env-get" (fun args ->
|
|
match args with
|
|
| [Env e; String k] -> env_get e k
|
|
| [Env e; Keyword k] -> env_get e k
|
|
| _ -> raise (Eval_error "env-get: expected env and key"));
|
|
|
|
bind "env-bind!" (fun args ->
|
|
match args with
|
|
| [Env e; String k; v] -> env_bind e k v
|
|
| [Env e; Keyword k; v] -> env_bind e k v
|
|
| _ -> raise (Eval_error "env-bind!: expected env, key, value"));
|
|
|
|
bind "env-set!" (fun args ->
|
|
match args with
|
|
| [Env e; String k; v] -> env_set e k v
|
|
| [Env e; Keyword k; v] -> env_set e k v
|
|
| _ -> raise (Eval_error "env-set!: expected env, key, value"));
|
|
|
|
bind "env-extend" (fun args ->
|
|
match args with
|
|
| [Env e] -> Env (env_extend e)
|
|
| _ -> raise (Eval_error "env-extend: expected env"));
|
|
|
|
bind "env-merge" (fun args ->
|
|
match args with
|
|
| [Env a; Env b] -> Env (env_merge a b)
|
|
| _ -> raise (Eval_error "env-merge: expected 2 envs"));
|
|
|
|
(* --- Continuation support --- *)
|
|
bind "make-continuation" (fun args ->
|
|
match args with
|
|
| [f] ->
|
|
let k v = Sx_runtime.sx_call f [v] in
|
|
Continuation (k, None)
|
|
| _ -> raise (Eval_error "make-continuation: expected 1 arg"));
|
|
|
|
bind "continuation?" (fun args ->
|
|
match args with
|
|
| [Continuation _] -> Bool true
|
|
| [_] -> Bool false
|
|
| _ -> raise (Eval_error "continuation?: expected 1 arg"));
|
|
|
|
bind "continuation-fn" (fun args ->
|
|
match args with
|
|
| [Continuation (f, _)] -> NativeFn ("continuation-fn-result", fun args ->
|
|
(match args with [v] -> f v | _ -> f Nil))
|
|
| _ -> raise (Eval_error "continuation-fn: expected continuation"));
|
|
|
|
(* --- Missing primitives --- *)
|
|
bind "make-keyword" (fun args ->
|
|
match args with
|
|
| [String s] -> Keyword s
|
|
| _ -> raise (Eval_error "make-keyword: expected string"));
|
|
|
|
(* --- Test helpers --- *)
|
|
bind "sx-parse-one" (fun args ->
|
|
match args with
|
|
| [String src] ->
|
|
let exprs = Sx_parser.parse_all src in
|
|
(match exprs with e :: _ -> e | [] -> Nil)
|
|
| _ -> raise (Eval_error "sx-parse-one: expected string"));
|
|
|
|
bind "test-env" (fun _args -> Env (env_extend global_env));
|
|
|
|
(* cek-eval takes a string in the native runner *)
|
|
bind "cek-eval" (fun args ->
|
|
match args with
|
|
| [String s] ->
|
|
let exprs = Sx_parser.parse_all s in
|
|
(match exprs with
|
|
| e :: _ -> Sx_ref.eval_expr e (Env global_env)
|
|
| [] -> Nil)
|
|
| [expr] -> Sx_ref.eval_expr expr (Env global_env)
|
|
| [expr; env_val] -> Sx_ref.eval_expr expr env_val
|
|
| _ -> raise (Eval_error "cek-eval: expected 1-2 args"));
|
|
|
|
bind "eval-expr-cek" (fun args ->
|
|
match args with
|
|
| [expr; e] -> Sx_ref.eval_expr expr e
|
|
| [expr] -> Sx_ref.eval_expr expr (Env global_env)
|
|
| _ -> raise (Eval_error "eval-expr-cek: expected 1-2 args"));
|
|
|
|
(* --- Component accessors --- *)
|
|
bind "component-params" (fun args ->
|
|
match args with
|
|
| [Component c] -> List (List.map (fun s -> String s) c.c_params)
|
|
| _ -> Nil);
|
|
|
|
bind "component-body" (fun args ->
|
|
match args with
|
|
| [Component c] -> c.c_body
|
|
| _ -> Nil);
|
|
|
|
bind "component-has-children" (fun args ->
|
|
match args with
|
|
| [Component c] -> Bool c.c_has_children
|
|
| _ -> Bool false);
|
|
|
|
bind "component-affinity" (fun args ->
|
|
match args with
|
|
| [Component c] -> String c.c_affinity
|
|
| _ -> String "auto");
|
|
|
|
bind "component-param-types" (fun _args -> Nil);
|
|
bind "component-set-param-types!" (fun _args -> Nil);
|
|
|
|
(* --- Parser/symbol helpers --- *)
|
|
bind "keyword-name" (fun args ->
|
|
match args with
|
|
| [Keyword k] -> String k
|
|
| _ -> raise (Eval_error "keyword-name: expected keyword"));
|
|
|
|
bind "symbol-name" (fun args ->
|
|
match args with
|
|
| [Symbol s] -> String s
|
|
| _ -> raise (Eval_error "symbol-name: expected symbol"));
|
|
|
|
bind "sx-serialize" (fun args ->
|
|
match args with
|
|
| [v] -> String (inspect v)
|
|
| _ -> raise (Eval_error "sx-serialize: expected 1 arg"));
|
|
|
|
bind "make-symbol" (fun args ->
|
|
match args with
|
|
| [String s] -> Symbol s
|
|
| [v] -> Symbol (value_to_string v)
|
|
| _ -> raise (Eval_error "make-symbol: expected 1 arg"));
|
|
|
|
(* --- CEK stepping / introspection --- *)
|
|
bind "make-cek-state" (fun args ->
|
|
match args with
|
|
| [ctrl; env'; kont] -> Sx_ref.make_cek_state ctrl env' kont
|
|
| _ -> raise (Eval_error "make-cek-state: expected 3 args"));
|
|
|
|
bind "cek-step" (fun args ->
|
|
match args with
|
|
| [state] -> Sx_ref.cek_step state
|
|
| _ -> raise (Eval_error "cek-step: expected 1 arg"));
|
|
|
|
bind "cek-phase" (fun args ->
|
|
match args with
|
|
| [state] -> Sx_ref.cek_phase state
|
|
| _ -> raise (Eval_error "cek-phase: expected 1 arg"));
|
|
|
|
bind "cek-value" (fun args ->
|
|
match args with
|
|
| [state] -> Sx_ref.cek_value state
|
|
| _ -> raise (Eval_error "cek-value: expected 1 arg"));
|
|
|
|
bind "cek-terminal?" (fun args ->
|
|
match args with
|
|
| [state] -> Sx_ref.cek_terminal_p state
|
|
| _ -> raise (Eval_error "cek-terminal?: expected 1 arg"));
|
|
|
|
bind "cek-kont" (fun args ->
|
|
match args with
|
|
| [state] -> Sx_ref.cek_kont state
|
|
| _ -> raise (Eval_error "cek-kont: expected 1 arg"));
|
|
|
|
bind "frame-type" (fun args ->
|
|
match args with
|
|
| [frame] -> Sx_ref.frame_type frame
|
|
| _ -> raise (Eval_error "frame-type: expected 1 arg"));
|
|
|
|
(* --- Strict mode --- *)
|
|
ignore (env_bind global_env "*strict*" (Bool false));
|
|
ignore (env_bind global_env "*prim-param-types*" Nil);
|
|
|
|
bind "set-strict!" (fun args ->
|
|
match args with
|
|
| [v] ->
|
|
Sx_ref._strict_ref := v;
|
|
ignore (env_set global_env "*strict*" v); Nil
|
|
| _ -> raise (Eval_error "set-strict!: expected 1 arg"));
|
|
|
|
bind "set-prim-param-types!" (fun args ->
|
|
match args with
|
|
| [v] ->
|
|
Sx_ref._prim_param_types_ref := v;
|
|
ignore (env_set global_env "*prim-param-types*" v); Nil
|
|
| _ -> raise (Eval_error "set-prim-param-types!: expected 1 arg"));
|
|
|
|
bind "value-matches-type?" (fun args ->
|
|
match args with
|
|
| [v; String expected] -> Sx_ref.value_matches_type_p v (String expected)
|
|
| _ -> raise (Eval_error "value-matches-type?: expected value and type string"));
|
|
|
|
(* --- Apply --- *)
|
|
bind "apply" (fun args ->
|
|
match args with
|
|
| f :: rest ->
|
|
let all_args = match List.rev rest with
|
|
| List last :: prefix -> List.rev prefix @ last
|
|
| _ -> rest
|
|
in
|
|
Sx_runtime.sx_call f all_args
|
|
| _ -> raise (Eval_error "apply: expected function and args"));
|
|
|
|
(* --- Type system test helpers (for --full tests) --- *)
|
|
bind "test-prim-types" (fun _args ->
|
|
let d = Hashtbl.create 40 in
|
|
List.iter (fun (k, v) -> Hashtbl.replace d k (String v)) [
|
|
"+", "number"; "-", "number"; "*", "number"; "/", "number";
|
|
"mod", "number"; "inc", "number"; "dec", "number";
|
|
"abs", "number"; "min", "number"; "max", "number";
|
|
"floor", "number"; "ceil", "number"; "round", "number";
|
|
"str", "string"; "upper", "string"; "lower", "string";
|
|
"trim", "string"; "join", "string"; "replace", "string";
|
|
"format", "string"; "substr", "string";
|
|
"=", "boolean"; "<", "boolean"; ">", "boolean";
|
|
"<=", "boolean"; ">=", "boolean"; "!=", "boolean";
|
|
"not", "boolean"; "nil?", "boolean"; "empty?", "boolean";
|
|
"number?", "boolean"; "string?", "boolean"; "boolean?", "boolean";
|
|
"list?", "boolean"; "dict?", "boolean"; "symbol?", "boolean";
|
|
"keyword?", "boolean"; "contains?", "boolean"; "has-key?", "boolean";
|
|
"starts-with?", "boolean"; "ends-with?", "boolean";
|
|
"len", "number"; "first", "any"; "rest", "list";
|
|
"last", "any"; "nth", "any"; "cons", "list";
|
|
"append", "list"; "concat", "list"; "reverse", "list";
|
|
"sort", "list"; "slice", "list"; "range", "list";
|
|
"flatten", "list"; "keys", "list"; "vals", "list";
|
|
"map-dict", "dict"; "assoc", "dict"; "dissoc", "dict";
|
|
"merge", "dict"; "dict", "dict";
|
|
"get", "any"; "type-of", "string";
|
|
];
|
|
Dict d);
|
|
|
|
bind "test-prim-param-types" (fun _args ->
|
|
let d = Hashtbl.create 10 in
|
|
let pos name typ =
|
|
let d2 = Hashtbl.create 2 in
|
|
Hashtbl.replace d2 "positional" (List [List [String name; String typ]]);
|
|
Hashtbl.replace d2 "rest-type" Nil; Dict d2
|
|
in
|
|
let pos_rest name typ rt =
|
|
let d2 = Hashtbl.create 2 in
|
|
Hashtbl.replace d2 "positional" (List [List [String name; String typ]]);
|
|
Hashtbl.replace d2 "rest-type" (String rt); Dict d2
|
|
in
|
|
Hashtbl.replace d "+" (pos_rest "a" "number" "number");
|
|
Hashtbl.replace d "-" (pos_rest "a" "number" "number");
|
|
Hashtbl.replace d "*" (pos_rest "a" "number" "number");
|
|
Hashtbl.replace d "/" (pos_rest "a" "number" "number");
|
|
Hashtbl.replace d "inc" (pos "n" "number");
|
|
Hashtbl.replace d "dec" (pos "n" "number");
|
|
Hashtbl.replace d "upper" (pos "s" "string");
|
|
Hashtbl.replace d "lower" (pos "s" "string");
|
|
Hashtbl.replace d "keys" (pos "d" "dict");
|
|
Hashtbl.replace d "vals" (pos "d" "dict");
|
|
Dict d);
|
|
|
|
(* --- HTML renderer --- *)
|
|
Sx_render.setup_render_env global_env;
|
|
|
|
(* Web adapters loaded as SX source at boot time via bundle.sh *)
|
|
|
|
(* Wire up render mode — the CEK machine checks these to dispatch
|
|
HTML tags and components to the renderer instead of eval. *)
|
|
Sx_runtime._render_active_p_fn :=
|
|
(fun () -> Bool !_sx_render_mode);
|
|
Sx_runtime._is_render_expr_fn :=
|
|
(fun expr -> match expr with
|
|
| List (Symbol tag :: _) ->
|
|
Bool (Sx_render.is_html_tag tag || tag = "<>" || tag = "raw!")
|
|
| _ -> Bool false);
|
|
Sx_runtime._render_expr_fn :=
|
|
(fun expr env -> match env with
|
|
| Env e -> RawHTML (Sx_render.render_to_html expr e)
|
|
| _ -> RawHTML (Sx_render.render_to_html expr global_env));
|
|
|
|
(* --- Scope stack primitives (called by transpiled evaluator via prim_call) --- *)
|
|
Sx_primitives.register "collect!" (fun args ->
|
|
match args with [a; b] -> Sx_runtime.sx_collect a b | _ -> Nil);
|
|
Sx_primitives.register "collected" (fun args ->
|
|
match args with [a] -> Sx_runtime.sx_collected a | _ -> List []);
|
|
Sx_primitives.register "clear-collected!" (fun args ->
|
|
match args with [a] -> Sx_runtime.sx_clear_collected a | _ -> Nil);
|
|
Sx_primitives.register "emit!" (fun args ->
|
|
match args with [a; b] -> Sx_runtime.sx_emit a b | _ -> Nil);
|
|
Sx_primitives.register "emitted" (fun args ->
|
|
match args with [a] -> Sx_runtime.sx_emitted a | _ -> List []);
|
|
Sx_primitives.register "context" (fun args ->
|
|
match args with [a; b] -> Sx_runtime.sx_context a b | [a] -> Sx_runtime.sx_context a Nil | _ -> Nil);
|
|
|
|
(* --- Fragment and raw HTML (always available, not just in render mode) --- *)
|
|
bind "<>" (fun args ->
|
|
let parts = List.map (fun a ->
|
|
match a with
|
|
| String s -> s
|
|
| RawHTML s -> s
|
|
| Nil -> ""
|
|
| List _ -> Sx_render.render_to_html a global_env
|
|
| _ -> value_to_string a
|
|
) args in
|
|
RawHTML (String.concat "" parts));
|
|
|
|
bind "raw!" (fun args ->
|
|
match args with
|
|
| [String s] -> RawHTML s
|
|
| [RawHTML s] -> RawHTML s
|
|
| [Nil] -> RawHTML ""
|
|
| _ -> RawHTML (String.concat "" (List.map (fun a ->
|
|
match a with String s | RawHTML s -> s | _ -> value_to_string a
|
|
) args)));
|
|
|
|
(* --- Scope stack functions (used by signals.sx, evaluator scope forms) --- *)
|
|
bind "scope-push!" (fun args ->
|
|
match args with
|
|
| [name; value] -> Sx_runtime.scope_push name value
|
|
| _ -> raise (Eval_error "scope-push!: expected 2 args"));
|
|
|
|
bind "scope-pop!" (fun args ->
|
|
match args with
|
|
| [_name] -> Sx_runtime.scope_pop _name
|
|
| _ -> raise (Eval_error "scope-pop!: expected 1 arg"));
|
|
|
|
bind "provide-push!" (fun args ->
|
|
match args with
|
|
| [name; value] -> Sx_runtime.provide_push name value
|
|
| _ -> raise (Eval_error "provide-push!: expected 2 args"));
|
|
|
|
bind "provide-pop!" (fun args ->
|
|
match args with
|
|
| [_name] -> Sx_runtime.provide_pop _name
|
|
| _ -> raise (Eval_error "provide-pop!: expected 1 arg"));
|
|
|
|
(* define-page-helper: registers a named page helper — stub for browser *)
|
|
bind "define-page-helper" (fun args ->
|
|
match args with
|
|
| [String _name; _body] -> Nil (* Page helpers are server-side; noop in browser *)
|
|
| _ -> Nil);
|
|
|
|
(* cek-call: call a function via the CEK machine (used by signals, orchestration)
|
|
(cek-call fn nil) → call with no args
|
|
(cek-call fn (list a)) → call with args list
|
|
(cek-call fn a) → call with single arg *)
|
|
bind "cek-call" (fun args ->
|
|
match args with
|
|
| [f; Nil] -> Sx_ref.eval_expr (List [f]) (Env global_env)
|
|
| [f; List arg_list] -> Sx_ref.eval_expr (List (f :: arg_list)) (Env global_env)
|
|
| [f; a] -> Sx_ref.eval_expr (List [f; a]) (Env global_env)
|
|
| [f] -> Sx_ref.eval_expr (List [f]) (Env global_env)
|
|
| f :: rest -> Sx_ref.eval_expr (List (f :: rest)) (Env global_env)
|
|
| _ -> raise (Eval_error "cek-call: expected function and args"));
|
|
|
|
(* not : logical negation (sometimes missing from evaluator prims) *)
|
|
(if not (Sx_primitives.is_primitive "not") then
|
|
bind "not" (fun args ->
|
|
match args with
|
|
| [v] -> Bool (not (sx_truthy v))
|
|
| _ -> raise (Eval_error "not: expected 1 arg")))
|
|
|
|
let () =
|
|
let sx = Js.Unsafe.obj [||] in
|
|
|
|
(* __sxWrap: wraps an OCaml API function so that after calling it,
|
|
the JS side picks up the result from globalThis.__sxR if set.
|
|
This bypasses js_of_ocaml stripping properties from function return values. *)
|
|
let wrap = Js.Unsafe.pure_js_expr
|
|
{|(function(fn) {
|
|
return function() {
|
|
globalThis.__sxR = undefined;
|
|
var r = fn.apply(null, arguments);
|
|
return globalThis.__sxR !== undefined ? globalThis.__sxR : r;
|
|
};
|
|
})|} in
|
|
let w fn = Js.Unsafe.fun_call wrap [| Js.Unsafe.inject (Js.wrap_callback fn) |] in
|
|
|
|
(* Core evaluation *)
|
|
Js.Unsafe.set sx (Js.string "parse")
|
|
(Js.wrap_callback api_parse);
|
|
Js.Unsafe.set sx (Js.string "stringify")
|
|
(Js.wrap_callback api_stringify);
|
|
Js.Unsafe.set sx (Js.string "eval")
|
|
(w api_eval);
|
|
Js.Unsafe.set sx (Js.string "evalExpr")
|
|
(w api_eval_expr);
|
|
Js.Unsafe.set sx (Js.string "cekRun")
|
|
(w api_cek_run);
|
|
Js.Unsafe.set sx (Js.string "renderToHtml")
|
|
(Js.wrap_callback api_render_to_html);
|
|
Js.Unsafe.set sx (Js.string "load")
|
|
(Js.wrap_callback api_load);
|
|
Js.Unsafe.set sx (Js.string "typeOf")
|
|
(Js.wrap_callback api_type_of);
|
|
Js.Unsafe.set sx (Js.string "inspect")
|
|
(Js.wrap_callback api_inspect);
|
|
Js.Unsafe.set sx (Js.string "engine")
|
|
(Js.wrap_callback api_engine);
|
|
Js.Unsafe.set sx (Js.string "registerNative")
|
|
(Js.wrap_callback api_register_native);
|
|
Js.Unsafe.set sx (Js.string "loadSource")
|
|
(Js.wrap_callback api_load_source);
|
|
Js.Unsafe.set sx (Js.string "callFn")
|
|
(w api_call_fn);
|
|
Js.Unsafe.set sx (Js.string "isCallable")
|
|
(Js.wrap_callback api_is_callable);
|
|
Js.Unsafe.set sx (Js.string "fnArity")
|
|
(Js.wrap_callback api_fn_arity);
|
|
|
|
(* Expose globally *)
|
|
Js.Unsafe.set Js.Unsafe.global (Js.string "SxKernel") sx
|