OCaml CEK machine compiled to WebAssembly for browser execution
All checks were successful
Build and Deploy / build-and-deploy (push) Successful in 23m17s
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>
This commit is contained in:
@@ -1,6 +1,6 @@
|
||||
module T = Sx.Sx_types
|
||||
module P = Sx.Sx_parser
|
||||
module R = Sx.Sx_ref
|
||||
module T = Sx_types
|
||||
module P = Sx_parser
|
||||
module R = Sx_ref
|
||||
open T
|
||||
|
||||
let () =
|
||||
|
||||
@@ -10,13 +10,6 @@
|
||||
dune exec bin/run_tests.exe -- test-primitives # specific test
|
||||
dune exec bin/run_tests.exe -- --foundation # foundation only *)
|
||||
|
||||
module Sx_types = Sx.Sx_types
|
||||
module Sx_parser = Sx.Sx_parser
|
||||
module Sx_primitives = Sx.Sx_primitives
|
||||
module Sx_runtime = Sx.Sx_runtime
|
||||
module Sx_ref = Sx.Sx_ref
|
||||
module Sx_render = Sx.Sx_render
|
||||
|
||||
open Sx_types
|
||||
open Sx_parser
|
||||
open Sx_primitives
|
||||
@@ -267,7 +260,7 @@ let make_test_env () =
|
||||
| _ -> raise (Eval_error "append!: expected list and value"));
|
||||
|
||||
(* --- HTML Renderer (from sx_render.ml library module) --- *)
|
||||
Sx.Sx_render.setup_render_env env;
|
||||
Sx_render.setup_render_env env;
|
||||
|
||||
(* --- Missing primitives referenced by tests --- *)
|
||||
|
||||
|
||||
@@ -14,13 +14,6 @@
|
||||
IO primitives (query, action, request-arg, request-method, ctx)
|
||||
yield (io-request ...) and block on stdin for (io-response ...). *)
|
||||
|
||||
module Sx_types = Sx.Sx_types
|
||||
module Sx_parser = Sx.Sx_parser
|
||||
module Sx_primitives = Sx.Sx_primitives
|
||||
module Sx_runtime = Sx.Sx_runtime
|
||||
module Sx_ref = Sx.Sx_ref
|
||||
module Sx_render = Sx.Sx_render
|
||||
|
||||
open Sx_types
|
||||
|
||||
|
||||
|
||||
@@ -22,14 +22,22 @@ from shared.sx.types import Symbol
|
||||
|
||||
|
||||
def extract_defines(source: str) -> list[tuple[str, list]]:
|
||||
"""Parse .sx source, return list of (name, define-expr) for top-level defines."""
|
||||
"""Parse .sx source, return list of (name, define-expr) for top-level defines.
|
||||
Strips :effects [...] annotations from defines."""
|
||||
from shared.sx.types import Keyword
|
||||
exprs = parse_all(source)
|
||||
defines = []
|
||||
for expr in exprs:
|
||||
if isinstance(expr, list) and expr and isinstance(expr[0], Symbol):
|
||||
if expr[0].name == "define":
|
||||
name = expr[1].name if isinstance(expr[1], Symbol) else str(expr[1])
|
||||
defines.append((name, expr))
|
||||
# Strip :effects [...] annotation if present
|
||||
# (define name :effects [...] body) → (define name body)
|
||||
cleaned = list(expr)
|
||||
if (len(cleaned) >= 4 and isinstance(cleaned[2], Keyword)
|
||||
and cleaned[2].name == "effects"):
|
||||
cleaned = [cleaned[0], cleaned[1]] + cleaned[4:]
|
||||
defines.append((name, cleaned))
|
||||
return defines
|
||||
|
||||
|
||||
@@ -50,7 +58,7 @@ let trampoline v = v (* CEK machine doesn't produce thunks *)
|
||||
"""
|
||||
|
||||
|
||||
# OCaml fixups — override iterative CEK run
|
||||
# OCaml fixups — override iterative CEK run + reactive subscriber fix
|
||||
FIXUPS = """\
|
||||
|
||||
(* Override recursive cek_run with iterative loop *)
|
||||
@@ -61,6 +69,40 @@ let cek_run_iterative state =
|
||||
done;
|
||||
cek_value !s
|
||||
|
||||
(* Strict mode refs — used by test runner, stubbed here *)
|
||||
let _strict_ref = ref Nil
|
||||
let _prim_param_types_ref = ref Nil
|
||||
let value_matches_type_p _v _t = Bool true
|
||||
|
||||
(* Override reactive_shift_deref to wrap subscriber as NativeFn.
|
||||
The transpiler emits bare OCaml closures for (fn () ...) but
|
||||
signal_add_sub_b expects SX values. *)
|
||||
let reactive_shift_deref sig' env kont =
|
||||
let scan_result = kont_capture_to_reactive_reset kont in
|
||||
let captured_frames = first scan_result in
|
||||
let reset_frame = nth scan_result (Number 1.0) in
|
||||
let remaining_kont = nth scan_result (Number 2.0) in
|
||||
let update_fn = get reset_frame (String "update-fn") in
|
||||
let sub_disposers = ref (List []) in
|
||||
let subscriber_fn () =
|
||||
List.iter (fun d -> ignore (cek_call d Nil)) (sx_to_list !sub_disposers);
|
||||
sub_disposers := List [];
|
||||
let new_reset = make_reactive_reset_frame env update_fn (Bool false) in
|
||||
let new_kont = prim_call "concat" [captured_frames; List [new_reset]; remaining_kont] in
|
||||
ignore (with_island_scope
|
||||
(fun d -> sub_disposers := sx_append_b !sub_disposers d; Nil)
|
||||
(fun () -> cek_run (make_cek_value (signal_value sig') env new_kont)));
|
||||
Nil
|
||||
in
|
||||
let subscriber = NativeFn ("reactive-subscriber", fun _args -> subscriber_fn ()) in
|
||||
ignore (signal_add_sub_b sig' subscriber);
|
||||
ignore (register_in_scope (fun () ->
|
||||
ignore (signal_remove_sub_b sig' subscriber);
|
||||
List.iter (fun d -> ignore (cek_call d Nil)) (sx_to_list !sub_disposers);
|
||||
Nil));
|
||||
let initial_kont = prim_call "concat" [captured_frames; List [reset_frame]; remaining_kont] in
|
||||
make_cek_value (signal_value sig') env initial_kont
|
||||
|
||||
"""
|
||||
|
||||
|
||||
@@ -96,8 +138,15 @@ def compile_spec_to_ml(spec_dir: str | None = None) -> str:
|
||||
src = f.read()
|
||||
defines = extract_defines(src)
|
||||
|
||||
# Skip defines provided by preamble or fixups
|
||||
skip = {"trampoline"}
|
||||
# Skip defines provided by preamble/fixups or that belong in web module
|
||||
skip = {"trampoline",
|
||||
# Freeze functions depend on signals.sx (web spec)
|
||||
"freeze-registry", "freeze-signal", "freeze-scope",
|
||||
"cek-freeze-scope", "cek-freeze-all",
|
||||
"cek-thaw-scope", "cek-thaw-all",
|
||||
"freeze-to-sx", "thaw-from-sx",
|
||||
"freeze-to-cid", "thaw-from-cid",
|
||||
"content-hash", "content-put", "content-get", "content-store"}
|
||||
defines = [(n, e) for n, e in defines if n not in skip]
|
||||
|
||||
# Deduplicate — keep last definition for each name (CEK overrides tree-walk)
|
||||
@@ -125,6 +174,160 @@ def compile_spec_to_ml(spec_dir: str | None = None) -> str:
|
||||
return "\n".join(parts)
|
||||
|
||||
|
||||
WEB_PREAMBLE = """\
|
||||
(* sx_web.ml — Auto-generated from web adapters by hosts/ocaml/bootstrap.py *)
|
||||
(* Do not edit — regenerate with: python3 hosts/ocaml/bootstrap.py --web *)
|
||||
|
||||
[@@@warning "-26-27"]
|
||||
|
||||
open Sx_types
|
||||
open Sx_runtime
|
||||
|
||||
"""
|
||||
|
||||
# Web adapter files to transpile (dependency order)
|
||||
WEB_ADAPTER_FILES = [
|
||||
("signals.sx", "signals (reactive signal runtime)"),
|
||||
("deps.sx", "deps (component dependency analysis)"),
|
||||
("page-helpers.sx", "page-helpers (pure data transformation helpers)"),
|
||||
("router.sx", "router (client-side route matching)"),
|
||||
("adapter-html.sx", "adapter-html (HTML rendering adapter)"),
|
||||
]
|
||||
|
||||
|
||||
def compile_web_to_ml(web_dir: str | None = None) -> str:
|
||||
"""Compile web adapter SX files to OCaml source."""
|
||||
from shared.sx.ref.sx_ref import eval_expr, trampoline, make_env, sx_parse
|
||||
|
||||
if web_dir is None:
|
||||
web_dir = os.path.join(_PROJECT, "web")
|
||||
|
||||
# Load the transpiler
|
||||
env = make_env()
|
||||
transpiler_path = os.path.join(_HERE, "transpiler.sx")
|
||||
with open(transpiler_path) as f:
|
||||
transpiler_src = f.read()
|
||||
for expr in sx_parse(transpiler_src):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Also load the evaluator defines so the transpiler knows about them
|
||||
spec_dir = os.path.join(_PROJECT, "spec")
|
||||
eval_path = os.path.join(spec_dir, "evaluator.sx")
|
||||
if os.path.exists(eval_path):
|
||||
with open(eval_path) as f:
|
||||
eval_defines = extract_defines(f.read())
|
||||
eval_names = [n for n, _ in eval_defines]
|
||||
else:
|
||||
eval_names = []
|
||||
|
||||
parts = [WEB_PREAMBLE]
|
||||
|
||||
# Collect all web adapter defines
|
||||
all_defines = []
|
||||
for filename, label in WEB_ADAPTER_FILES:
|
||||
filepath = os.path.join(web_dir, filename)
|
||||
if not os.path.exists(filepath):
|
||||
print(f"Warning: {filepath} not found, skipping", file=sys.stderr)
|
||||
continue
|
||||
|
||||
with open(filepath) as f:
|
||||
src = f.read()
|
||||
defines = extract_defines(src)
|
||||
|
||||
# Deduplicate within file
|
||||
seen = {}
|
||||
for i, (n, e) in enumerate(defines):
|
||||
seen[n] = i
|
||||
defines = [(n, e) for i, (n, e) in enumerate(defines) if seen[n] == i]
|
||||
|
||||
all_defines.extend(defines)
|
||||
print(f" {filename}: {len(defines)} defines", file=sys.stderr)
|
||||
|
||||
# Deduplicate across files (last wins)
|
||||
seen = {}
|
||||
for i, (n, e) in enumerate(all_defines):
|
||||
seen[n] = i
|
||||
all_defines = [(n, e) for i, (n, e) in enumerate(all_defines) if seen[n] == i]
|
||||
|
||||
print(f" Total: {len(all_defines)} unique defines", file=sys.stderr)
|
||||
|
||||
# Build the defines list for the transpiler
|
||||
defines_list = [[name, expr] for name, expr in all_defines]
|
||||
env["_defines"] = defines_list
|
||||
|
||||
# Known defines = evaluator names + web adapter names
|
||||
env["_known_defines"] = eval_names + [name for name, _ in all_defines]
|
||||
|
||||
# Translate
|
||||
translate_expr = sx_parse("(ml-translate-file _defines)")[0]
|
||||
result = trampoline(eval_expr(translate_expr, env))
|
||||
|
||||
parts.append("\n(* === Transpiled from web adapters === *)\n")
|
||||
parts.append(result)
|
||||
|
||||
# Registration function — extract actual OCaml names from transpiled output
|
||||
# by using the same transpiler mangling.
|
||||
# Ask the transpiler for the mangled name of each define.
|
||||
name_map = {}
|
||||
for name, _ in all_defines:
|
||||
mangle_expr = sx_parse(f'(ml-mangle "{name}")')[0]
|
||||
mangled = trampoline(eval_expr(mangle_expr, env))
|
||||
name_map[name] = mangled
|
||||
|
||||
def count_params(expr):
|
||||
"""Count actual params from a (define name [annotations] (fn (params...) body)) form."""
|
||||
# Find the (fn ...) form — it might be at index 2, 3, or 4 depending on annotations
|
||||
fn_expr = None
|
||||
for i in range(2, min(len(expr), 6)):
|
||||
if (isinstance(expr[i], list) and expr[i] and
|
||||
isinstance(expr[i][0], Symbol) and expr[i][0].name in ("fn", "lambda")):
|
||||
fn_expr = expr[i]
|
||||
break
|
||||
if fn_expr is None:
|
||||
return -1 # not a function
|
||||
params = fn_expr[1] if isinstance(fn_expr[1], list) else []
|
||||
n = 0
|
||||
skip = False
|
||||
for p in params:
|
||||
if skip:
|
||||
skip = False
|
||||
continue
|
||||
if isinstance(p, Symbol) and p.name in ("&key", "&rest"):
|
||||
skip = True
|
||||
continue
|
||||
if isinstance(p, list) and len(p) >= 3: # (name :as type)
|
||||
n += 1
|
||||
elif isinstance(p, Symbol):
|
||||
n += 1
|
||||
return n
|
||||
|
||||
parts.append("\n\n(* Register all web adapter functions into an environment *)\n")
|
||||
parts.append("let register_web_adapters env =\n")
|
||||
for name, expr in all_defines:
|
||||
mangled = name_map[name]
|
||||
n = count_params(expr)
|
||||
if n < 0:
|
||||
# Non-function define (constant)
|
||||
parts.append(f' ignore (Sx_types.env_bind env "{name}" {mangled});\n')
|
||||
elif n == 0:
|
||||
parts.append(f' ignore (Sx_types.env_bind env "{name}" '
|
||||
f'(NativeFn ("{name}", fun _args -> {mangled} Nil)));\n')
|
||||
else:
|
||||
# Generate match with correct arity
|
||||
arg_names = [chr(97 + i) for i in range(n)] # a, b, c, ...
|
||||
pat = "; ".join(arg_names)
|
||||
call = " ".join(arg_names)
|
||||
# Pad with Nil for partial application
|
||||
pad_call = " ".join(arg_names[:1] + ["Nil"] * (n - 1)) if n > 1 else arg_names[0]
|
||||
parts.append(f' ignore (Sx_types.env_bind env "{name}" '
|
||||
f'(NativeFn ("{name}", fun args -> match args with '
|
||||
f'| [{pat}] -> {mangled} {call} '
|
||||
f'| _ -> raise (Eval_error "{name}: expected {n} args"))));\n')
|
||||
parts.append(" ()\n")
|
||||
|
||||
return "\n".join(parts)
|
||||
|
||||
|
||||
def main():
|
||||
import argparse
|
||||
parser = argparse.ArgumentParser(description="Bootstrap SX spec -> OCaml")
|
||||
@@ -133,17 +336,37 @@ def main():
|
||||
default=None,
|
||||
help="Output file (default: stdout)",
|
||||
)
|
||||
parser.add_argument(
|
||||
"--web",
|
||||
action="store_true",
|
||||
help="Compile web adapters instead of evaluator spec",
|
||||
)
|
||||
parser.add_argument(
|
||||
"--web-output",
|
||||
default=None,
|
||||
help="Output file for web adapters (default: stdout)",
|
||||
)
|
||||
args = parser.parse_args()
|
||||
|
||||
result = compile_spec_to_ml()
|
||||
|
||||
if args.output:
|
||||
with open(args.output, "w") as f:
|
||||
f.write(result)
|
||||
size = os.path.getsize(args.output)
|
||||
print(f"Wrote {args.output} ({size} bytes)", file=sys.stderr)
|
||||
if args.web or args.web_output:
|
||||
result = compile_web_to_ml()
|
||||
out = args.web_output or args.output
|
||||
if out:
|
||||
with open(out, "w") as f:
|
||||
f.write(result)
|
||||
size = os.path.getsize(out)
|
||||
print(f"Wrote {out} ({size} bytes)", file=sys.stderr)
|
||||
else:
|
||||
print(result)
|
||||
else:
|
||||
print(result)
|
||||
result = compile_spec_to_ml()
|
||||
if args.output:
|
||||
with open(args.output, "w") as f:
|
||||
f.write(result)
|
||||
size = os.path.getsize(args.output)
|
||||
print(f"Wrote {args.output} ({size} bytes)", file=sys.stderr)
|
||||
else:
|
||||
print(result)
|
||||
|
||||
|
||||
if __name__ == "__main__":
|
||||
|
||||
37
hosts/ocaml/browser/build.sh
Executable file
37
hosts/ocaml/browser/build.sh
Executable file
@@ -0,0 +1,37 @@
|
||||
#!/usr/bin/env bash
|
||||
# Build the OCaml SX engine for browser use (WASM + JS fallback).
|
||||
#
|
||||
# Outputs:
|
||||
# _build/default/browser/sx_browser.bc.wasm.js WASM loader
|
||||
# _build/default/browser/sx_browser.bc.wasm.assets/ WASM modules
|
||||
# _build/default/browser/sx_browser.bc.js JS fallback
|
||||
#
|
||||
# Usage:
|
||||
# cd hosts/ocaml && ./browser/build.sh
|
||||
|
||||
set -euo pipefail
|
||||
cd "$(dirname "$0")/.."
|
||||
|
||||
eval $(opam env 2>/dev/null || true)
|
||||
|
||||
echo "=== Building OCaml SX browser engine ==="
|
||||
|
||||
# Build all targets: bytecode, JS, WASM
|
||||
dune build browser/sx_browser.bc.js browser/sx_browser.bc.wasm.js
|
||||
|
||||
echo ""
|
||||
echo "--- Output sizes ---"
|
||||
echo -n "JS (unoptimized): "; ls -lh _build/default/browser/sx_browser.bc.js | awk '{print $5}'
|
||||
echo -n "WASM loader: "; ls -lh _build/default/browser/sx_browser.bc.wasm.js | awk '{print $5}'
|
||||
echo -n "WASM modules: "; du -sh _build/default/browser/sx_browser.bc.wasm.assets/*.wasm | awk '{s+=$1}END{print s"K"}'
|
||||
|
||||
# Optimized JS build
|
||||
js_of_ocaml --opt=3 -o _build/default/browser/sx_browser.opt.js _build/default/browser/sx_browser.bc
|
||||
echo -n "JS (optimized): "; ls -lh _build/default/browser/sx_browser.opt.js | awk '{print $5}'
|
||||
|
||||
echo ""
|
||||
echo "=== Build complete ==="
|
||||
echo ""
|
||||
echo "Test with:"
|
||||
echo " node hosts/ocaml/browser/run_tests_js.js # JS"
|
||||
echo " node --experimental-wasm-imported-strings hosts/ocaml/browser/run_tests_wasm.js # WASM"
|
||||
139
hosts/ocaml/browser/bundle.sh
Executable file
139
hosts/ocaml/browser/bundle.sh
Executable file
@@ -0,0 +1,139 @@
|
||||
#!/usr/bin/env bash
|
||||
# Bundle the WASM engine + platform + web adapters into shared/static/scripts/
|
||||
#
|
||||
# Usage: hosts/ocaml/browser/bundle.sh
|
||||
|
||||
set -euo pipefail
|
||||
cd "$(dirname "$0")/../../.."
|
||||
|
||||
WASM_LOADER="hosts/ocaml/_build/default/browser/sx_browser.bc.wasm.js"
|
||||
WASM_ASSETS="hosts/ocaml/_build/default/browser/sx_browser.bc.wasm.assets"
|
||||
PLATFORM="hosts/ocaml/browser/sx-platform.js"
|
||||
OUT="shared/static/scripts/sx-wasm.js"
|
||||
ASSET_DIR="shared/static/scripts/sx-wasm-assets"
|
||||
|
||||
if [ ! -f "$WASM_LOADER" ]; then
|
||||
echo "Build first: cd hosts/ocaml && eval \$(opam env) && dune build browser/sx_browser.bc.wasm.js"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
# 1. WASM loader (patched asset path)
|
||||
sed 's|"src":"sx_browser.bc.wasm.assets"|"src":"sx-wasm-assets"|' \
|
||||
"$WASM_LOADER" > "$OUT"
|
||||
|
||||
# 2. Platform layer
|
||||
echo "" >> "$OUT"
|
||||
cat "$PLATFORM" >> "$OUT"
|
||||
|
||||
# 3. Embedded web adapters — SX source as JS string constants
|
||||
echo "" >> "$OUT"
|
||||
echo "// =========================================================================" >> "$OUT"
|
||||
echo "// Embedded web adapters (loaded into WASM engine at boot)" >> "$OUT"
|
||||
echo "// =========================================================================" >> "$OUT"
|
||||
echo "globalThis.__sxAdapters = {};" >> "$OUT"
|
||||
|
||||
# Adapters to embed (order matters for dependencies)
|
||||
ADAPTERS="signals deps page-helpers router adapter-html"
|
||||
|
||||
for name in $ADAPTERS; do
|
||||
file="web/${name}.sx"
|
||||
if [ -f "$file" ]; then
|
||||
echo -n "globalThis.__sxAdapters[\"${name}\"] = " >> "$OUT"
|
||||
# Escape the SX source for embedding in a JS string
|
||||
python3 -c "
|
||||
import json, sys
|
||||
with open('$file') as f:
|
||||
print(json.dumps(f.read()) + ';')
|
||||
" >> "$OUT"
|
||||
fi
|
||||
done
|
||||
|
||||
# 4. Boot shim
|
||||
cat >> "$OUT" << 'BOOT'
|
||||
|
||||
// =========================================================================
|
||||
// WASM Boot: load adapters, then process inline <script type="text/sx">
|
||||
// =========================================================================
|
||||
(function() {
|
||||
"use strict";
|
||||
if (typeof document === "undefined") return;
|
||||
|
||||
function sxWasmBoot() {
|
||||
var K = globalThis.SxKernel;
|
||||
if (!K || !globalThis.Sx) { setTimeout(sxWasmBoot, 50); return; }
|
||||
|
||||
console.log("[sx-wasm] booting, engine:", K.engine());
|
||||
|
||||
// Load embedded web adapters
|
||||
var adapters = globalThis.__sxAdapters || {};
|
||||
var adapterOrder = ["signals", "deps", "page-helpers", "router", "adapter-html"];
|
||||
for (var j = 0; j < adapterOrder.length; j++) {
|
||||
var name = adapterOrder[j];
|
||||
if (adapters[name]) {
|
||||
var r = K.loadSource(adapters[name]);
|
||||
if (typeof r === "string" && r.startsWith("Error:")) {
|
||||
console.error("[sx-wasm] adapter " + name + " error:", r);
|
||||
} else {
|
||||
console.log("[sx-wasm] loaded " + name + " (" + r + " defs)");
|
||||
}
|
||||
}
|
||||
}
|
||||
delete globalThis.__sxAdapters; // Free memory
|
||||
|
||||
// Process <script type="text/sx" data-components>
|
||||
var scripts = document.querySelectorAll('script[type="text/sx"]');
|
||||
for (var i = 0; i < scripts.length; i++) {
|
||||
var s = scripts[i], src = s.textContent.trim();
|
||||
if (!src) continue;
|
||||
if (s.hasAttribute("data-components")) {
|
||||
var result = K.loadSource(src);
|
||||
if (typeof result === "string" && result.startsWith("Error:"))
|
||||
console.error("[sx-wasm] component load error:", result);
|
||||
}
|
||||
}
|
||||
|
||||
// Process <script type="text/sx" data-init>
|
||||
for (var i = 0; i < scripts.length; i++) {
|
||||
var s = scripts[i];
|
||||
if (s.hasAttribute("data-init")) {
|
||||
var src = s.textContent.trim();
|
||||
if (src) K.loadSource(src);
|
||||
}
|
||||
}
|
||||
|
||||
// Process <script type="text/sx" data-mount="...">
|
||||
for (var i = 0; i < scripts.length; i++) {
|
||||
var s = scripts[i];
|
||||
if (s.hasAttribute("data-mount")) {
|
||||
var mount = s.getAttribute("data-mount"), src = s.textContent.trim();
|
||||
if (!src) continue;
|
||||
var target = mount === "body" ? document.body : document.querySelector(mount);
|
||||
if (!target) continue;
|
||||
try {
|
||||
var parsed = K.parse(src);
|
||||
if (parsed && parsed.length > 0) {
|
||||
var html = K.renderToHtml(parsed[0]);
|
||||
if (html && typeof html === "string") {
|
||||
target.innerHTML = html;
|
||||
console.log("[sx-wasm] mounted to", mount);
|
||||
}
|
||||
}
|
||||
} catch(e) { console.error("[sx-wasm] mount error:", e); }
|
||||
}
|
||||
}
|
||||
|
||||
console.log("[sx-wasm] boot complete");
|
||||
}
|
||||
|
||||
if (document.readyState === "loading") document.addEventListener("DOMContentLoaded", sxWasmBoot);
|
||||
else sxWasmBoot();
|
||||
})();
|
||||
BOOT
|
||||
|
||||
# 5. Copy WASM assets
|
||||
mkdir -p "$ASSET_DIR"
|
||||
cp "$WASM_ASSETS"/*.wasm "$ASSET_DIR/"
|
||||
|
||||
echo "=== Bundle complete ==="
|
||||
ls -lh "$OUT"
|
||||
echo -n "WASM assets: "; du -sh "$ASSET_DIR" | awk '{print $1}'
|
||||
5
hosts/ocaml/browser/dune
Normal file
5
hosts/ocaml/browser/dune
Normal file
@@ -0,0 +1,5 @@
|
||||
(executable
|
||||
(name sx_browser)
|
||||
(libraries sx js_of_ocaml)
|
||||
(modes byte js wasm)
|
||||
(preprocess (pps js_of_ocaml-ppx)))
|
||||
149
hosts/ocaml/browser/run_tests_js.js
Normal file
149
hosts/ocaml/browser/run_tests_js.js
Normal file
@@ -0,0 +1,149 @@
|
||||
#!/usr/bin/env node
|
||||
/**
|
||||
* Test runner for the js_of_ocaml-compiled SX engine.
|
||||
*
|
||||
* Loads the OCaml CEK machine (compiled to JS) and runs the spec test suite.
|
||||
*
|
||||
* Usage:
|
||||
* node hosts/ocaml/browser/run_tests_js.js # standard tests
|
||||
* node hosts/ocaml/browser/run_tests_js.js --full # full suite
|
||||
*/
|
||||
|
||||
const fs = require("fs");
|
||||
const path = require("path");
|
||||
|
||||
// Load the compiled OCaml engine
|
||||
const enginePath = path.join(__dirname, "../_build/default/browser/sx_browser.bc.js");
|
||||
if (!fs.existsSync(enginePath)) {
|
||||
console.error("Build first: cd hosts/ocaml && eval $(opam env) && dune build browser/sx_browser.bc.js");
|
||||
process.exit(1);
|
||||
}
|
||||
require(enginePath);
|
||||
|
||||
const K = globalThis.SxKernel;
|
||||
const full = process.argv.includes("--full");
|
||||
|
||||
// Test state
|
||||
let passed = 0;
|
||||
let failed = 0;
|
||||
let errors = [];
|
||||
let suiteStack = [];
|
||||
|
||||
function currentSuite() {
|
||||
return suiteStack.length > 0 ? suiteStack.join(" > ") : "";
|
||||
}
|
||||
|
||||
// Register platform test functions
|
||||
K.registerNative("report-pass", (args) => {
|
||||
const name = typeof args[0] === "string" ? args[0] : JSON.stringify(args[0]);
|
||||
passed++;
|
||||
if (process.env.VERBOSE) {
|
||||
console.log(` PASS: ${currentSuite()} > ${name}`);
|
||||
} else {
|
||||
process.stdout.write(".");
|
||||
if (passed % 80 === 0) process.stdout.write("\n");
|
||||
}
|
||||
return null;
|
||||
});
|
||||
|
||||
K.registerNative("report-fail", (args) => {
|
||||
const name = typeof args[0] === "string" ? args[0] : JSON.stringify(args[0]);
|
||||
const error = args.length > 1 && args[1] != null
|
||||
? (typeof args[1] === "string" ? args[1] : JSON.stringify(args[1]))
|
||||
: "unknown";
|
||||
failed++;
|
||||
const fullName = currentSuite() ? `${currentSuite()} > ${name}` : name;
|
||||
errors.push(`FAIL: ${fullName}\n ${error}`);
|
||||
process.stdout.write("F");
|
||||
});
|
||||
|
||||
K.registerNative("push-suite", (args) => {
|
||||
const name = typeof args[0] === "string" ? args[0] : String(args[0]);
|
||||
suiteStack.push(name);
|
||||
return null;
|
||||
});
|
||||
|
||||
K.registerNative("pop-suite", (_args) => {
|
||||
suiteStack.pop();
|
||||
return null;
|
||||
});
|
||||
|
||||
console.log(`=== SX OCaml→JS Engine Test Runner ===`);
|
||||
console.log(`Engine: ${K.engine()}`);
|
||||
console.log(`Mode: ${full ? "full" : "standard"}`);
|
||||
console.log("");
|
||||
|
||||
// Load a .sx file by reading it from disk and evaluating via loadSource
|
||||
function loadFile(filePath) {
|
||||
const src = fs.readFileSync(filePath, "utf8");
|
||||
return K.loadSource(src);
|
||||
}
|
||||
|
||||
// Test files
|
||||
const specDir = path.join(__dirname, "../../../spec");
|
||||
const testDir = path.join(specDir, "tests");
|
||||
|
||||
const standardTests = [
|
||||
"test-framework.sx",
|
||||
"test-eval.sx",
|
||||
"test-parser.sx",
|
||||
"test-primitives.sx",
|
||||
"test-collections.sx",
|
||||
"test-closures.sx",
|
||||
"test-defcomp.sx",
|
||||
"test-macros.sx",
|
||||
"test-errors.sx",
|
||||
"test-render.sx",
|
||||
"test-tco.sx",
|
||||
"test-scope.sx",
|
||||
"test-cek.sx",
|
||||
"test-advanced.sx",
|
||||
];
|
||||
|
||||
const fullOnlyTests = [
|
||||
"test-freeze.sx",
|
||||
"test-continuations.sx",
|
||||
"test-continuations-advanced.sx",
|
||||
"test-cek-advanced.sx",
|
||||
"test-signals-advanced.sx",
|
||||
"test-render-advanced.sx",
|
||||
"test-integration.sx",
|
||||
"test-strict.sx",
|
||||
"test-types.sx",
|
||||
];
|
||||
|
||||
const testFiles = full ? [...standardTests, ...fullOnlyTests] : standardTests;
|
||||
|
||||
for (const file of testFiles) {
|
||||
const filePath = path.join(testDir, file);
|
||||
if (!fs.existsSync(filePath)) {
|
||||
console.log(`\nSkipping ${file} (not found)`);
|
||||
continue;
|
||||
}
|
||||
|
||||
const label = file.replace(".sx", "").replace("test-", "");
|
||||
process.stdout.write(`\n[${label}] `);
|
||||
|
||||
const result = loadFile(filePath);
|
||||
if (typeof result === "string" && result.startsWith("Error:")) {
|
||||
console.log(`\n LOAD ERROR: ${result}`);
|
||||
failed++;
|
||||
errors.push(`LOAD ERROR: ${file}\n ${result}`);
|
||||
}
|
||||
}
|
||||
|
||||
console.log("\n");
|
||||
|
||||
if (errors.length > 0) {
|
||||
console.log(`--- Failures (${errors.length}) ---`);
|
||||
for (const e of errors.slice(0, 20)) {
|
||||
console.log(e);
|
||||
}
|
||||
if (errors.length > 20) {
|
||||
console.log(`... and ${errors.length - 20} more`);
|
||||
}
|
||||
console.log("");
|
||||
}
|
||||
|
||||
console.log(`Results: ${passed} passed, ${failed} failed, ${passed + failed} total`);
|
||||
process.exit(failed > 0 ? 1 : 0);
|
||||
146
hosts/ocaml/browser/run_tests_wasm.js
Normal file
146
hosts/ocaml/browser/run_tests_wasm.js
Normal file
@@ -0,0 +1,146 @@
|
||||
#!/usr/bin/env node
|
||||
/**
|
||||
* Test runner for the wasm_of_ocaml-compiled SX engine.
|
||||
*
|
||||
* Loads the OCaml CEK machine (compiled to WASM) and runs the spec test suite.
|
||||
* Requires Node.js 22+ with --experimental-wasm-imported-strings flag.
|
||||
*
|
||||
* Usage:
|
||||
* node --experimental-wasm-imported-strings hosts/ocaml/browser/run_tests_wasm.js
|
||||
* node --experimental-wasm-imported-strings hosts/ocaml/browser/run_tests_wasm.js --full
|
||||
*/
|
||||
|
||||
const fs = require("fs");
|
||||
const path = require("path");
|
||||
|
||||
const wasmDir = path.join(__dirname, "../_build/default/browser");
|
||||
const loaderPath = path.join(wasmDir, "sx_browser.bc.wasm.js");
|
||||
|
||||
if (!fs.existsSync(loaderPath)) {
|
||||
console.error("Build first: cd hosts/ocaml && eval $(opam env) && dune build browser/sx_browser.bc.wasm.js");
|
||||
process.exit(1);
|
||||
}
|
||||
|
||||
// Set require.main.filename so the WASM loader can find .wasm assets
|
||||
if (!require.main) {
|
||||
require.main = { filename: path.join(wasmDir, "test.js") };
|
||||
} else {
|
||||
require.main.filename = path.join(wasmDir, "test.js");
|
||||
}
|
||||
|
||||
require(loaderPath);
|
||||
|
||||
const full = process.argv.includes("--full");
|
||||
|
||||
// WASM loader is async — wait for SxKernel to be available
|
||||
setTimeout(() => {
|
||||
const K = globalThis.SxKernel;
|
||||
if (!K) {
|
||||
console.error("SxKernel not available — WASM initialization failed");
|
||||
process.exit(1);
|
||||
}
|
||||
|
||||
let passed = 0;
|
||||
let failed = 0;
|
||||
let errors = [];
|
||||
let suiteStack = [];
|
||||
|
||||
function currentSuite() {
|
||||
return suiteStack.length > 0 ? suiteStack.join(" > ") : "";
|
||||
}
|
||||
|
||||
// Register platform test functions
|
||||
K.registerNative("report-pass", (args) => {
|
||||
const name = typeof args[0] === "string" ? args[0] : JSON.stringify(args[0]);
|
||||
passed++;
|
||||
if (process.env.VERBOSE) {
|
||||
console.log(` PASS: ${currentSuite()} > ${name}`);
|
||||
} else {
|
||||
process.stdout.write(".");
|
||||
if (passed % 80 === 0) process.stdout.write("\n");
|
||||
}
|
||||
return null;
|
||||
});
|
||||
|
||||
K.registerNative("report-fail", (args) => {
|
||||
const name = typeof args[0] === "string" ? args[0] : JSON.stringify(args[0]);
|
||||
const error = args.length > 1 && args[1] != null
|
||||
? (typeof args[1] === "string" ? args[1] : JSON.stringify(args[1]))
|
||||
: "unknown";
|
||||
failed++;
|
||||
const fullName = currentSuite() ? `${currentSuite()} > ${name}` : name;
|
||||
errors.push(`FAIL: ${fullName}\n ${error}`);
|
||||
process.stdout.write("F");
|
||||
});
|
||||
|
||||
K.registerNative("push-suite", (args) => {
|
||||
const name = typeof args[0] === "string" ? args[0] : String(args[0]);
|
||||
suiteStack.push(name);
|
||||
return null;
|
||||
});
|
||||
|
||||
K.registerNative("pop-suite", (_args) => {
|
||||
suiteStack.pop();
|
||||
return null;
|
||||
});
|
||||
|
||||
console.log(`=== SX OCaml→WASM Engine Test Runner ===`);
|
||||
console.log(`Engine: ${K.engine()}`);
|
||||
console.log(`Mode: ${full ? "full" : "standard"}`);
|
||||
console.log("");
|
||||
|
||||
const specDir = path.join(__dirname, "../../../spec");
|
||||
const testDir = path.join(specDir, "tests");
|
||||
|
||||
const standardTests = [
|
||||
"test-framework.sx", "test-eval.sx", "test-parser.sx",
|
||||
"test-primitives.sx", "test-collections.sx", "test-closures.sx",
|
||||
"test-defcomp.sx", "test-macros.sx", "test-errors.sx",
|
||||
"test-render.sx", "test-tco.sx", "test-scope.sx",
|
||||
"test-cek.sx", "test-advanced.sx",
|
||||
];
|
||||
|
||||
const fullOnlyTests = [
|
||||
"test-freeze.sx", "test-continuations.sx",
|
||||
"test-continuations-advanced.sx", "test-cek-advanced.sx",
|
||||
"test-signals-advanced.sx", "test-render-advanced.sx",
|
||||
"test-integration.sx", "test-strict.sx", "test-types.sx",
|
||||
];
|
||||
|
||||
const testFiles = full ? [...standardTests, ...fullOnlyTests] : standardTests;
|
||||
|
||||
for (const file of testFiles) {
|
||||
const filePath = path.join(testDir, file);
|
||||
if (!fs.existsSync(filePath)) {
|
||||
console.log(`\nSkipping ${file} (not found)`);
|
||||
continue;
|
||||
}
|
||||
|
||||
const label = file.replace(".sx", "").replace("test-", "");
|
||||
process.stdout.write(`\n[${label}] `);
|
||||
|
||||
const src = fs.readFileSync(filePath, "utf8");
|
||||
const result = K.loadSource(src);
|
||||
if (typeof result === "string" && result.startsWith("Error:")) {
|
||||
console.log(`\n LOAD ERROR: ${result}`);
|
||||
failed++;
|
||||
errors.push(`LOAD ERROR: ${file}\n ${result}`);
|
||||
}
|
||||
}
|
||||
|
||||
console.log("\n");
|
||||
|
||||
if (errors.length > 0) {
|
||||
console.log(`--- Failures (${errors.length}) ---`);
|
||||
for (const e of errors.slice(0, 20)) {
|
||||
console.log(e);
|
||||
}
|
||||
if (errors.length > 20) {
|
||||
console.log(`... and ${errors.length - 20} more`);
|
||||
}
|
||||
console.log("");
|
||||
}
|
||||
|
||||
console.log(`Results: ${passed} passed, ${failed} failed, ${passed + failed} total`);
|
||||
process.exit(failed > 0 ? 1 : 0);
|
||||
}, 1000);
|
||||
676
hosts/ocaml/browser/sx-platform.js
Normal file
676
hosts/ocaml/browser/sx-platform.js
Normal file
@@ -0,0 +1,676 @@
|
||||
/**
|
||||
* sx-platform.js — Thin JS platform layer for the OCaml SX WASM engine.
|
||||
*
|
||||
* This file provides browser-native primitives (DOM, fetch, timers, etc.)
|
||||
* to the WASM-compiled OCaml CEK machine. It:
|
||||
* 1. Loads the WASM module (SxKernel)
|
||||
* 2. Registers ~80 native browser functions via registerNative
|
||||
* 3. Loads web adapters (.sx files) into the engine
|
||||
* 4. Exports the public Sx API
|
||||
*
|
||||
* Both wasm_of_ocaml and js_of_ocaml targets bind to this same layer.
|
||||
*/
|
||||
|
||||
(function(global) {
|
||||
"use strict";
|
||||
|
||||
function initPlatform() {
|
||||
var K = global.SxKernel;
|
||||
if (!K) {
|
||||
// WASM loader is async — wait and retry
|
||||
setTimeout(initPlatform, 20);
|
||||
return;
|
||||
}
|
||||
|
||||
var _hasDom = typeof document !== "undefined";
|
||||
var NIL = null;
|
||||
var SVG_NS = "http://www.w3.org/2000/svg";
|
||||
|
||||
// =========================================================================
|
||||
// Helper: wrap SX lambda for use as JS callback
|
||||
// =========================================================================
|
||||
|
||||
function wrapLambda(fn) {
|
||||
// For now, SX lambdas from registerNative are opaque — we can't call them
|
||||
// directly from JS. They need to go through the engine.
|
||||
// TODO: add callLambda API to SxKernel
|
||||
return fn;
|
||||
}
|
||||
|
||||
// =========================================================================
|
||||
// 1. DOM Creation & Manipulation
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-create-element", function(args) {
|
||||
if (!_hasDom) return NIL;
|
||||
var tag = args[0], ns = args[1];
|
||||
if (ns && ns !== NIL) return document.createElementNS(ns, tag);
|
||||
return document.createElement(tag);
|
||||
});
|
||||
|
||||
K.registerNative("create-text-node", function(args) {
|
||||
return _hasDom ? document.createTextNode(args[0] || "") : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("create-comment", function(args) {
|
||||
return _hasDom ? document.createComment(args[0] || "") : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("create-fragment", function(_args) {
|
||||
return _hasDom ? document.createDocumentFragment() : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-clone", function(args) {
|
||||
var node = args[0];
|
||||
return node && node.cloneNode ? node.cloneNode(true) : node;
|
||||
});
|
||||
|
||||
K.registerNative("dom-parse-html", function(args) {
|
||||
if (!_hasDom) return NIL;
|
||||
var tpl = document.createElement("template");
|
||||
tpl.innerHTML = args[0] || "";
|
||||
return tpl.content;
|
||||
});
|
||||
|
||||
K.registerNative("dom-parse-html-document", function(args) {
|
||||
if (!_hasDom) return NIL;
|
||||
var parser = new DOMParser();
|
||||
return parser.parseFromString(args[0] || "", "text/html");
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 2. DOM Queries
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-query", function(args) {
|
||||
return _hasDom ? document.querySelector(args[0]) || NIL : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-query-all", function(args) {
|
||||
var root = args[0] || (_hasDom ? document : null);
|
||||
if (!root || !root.querySelectorAll) return [];
|
||||
return Array.prototype.slice.call(root.querySelectorAll(args[1] || args[0]));
|
||||
});
|
||||
|
||||
K.registerNative("dom-query-by-id", function(args) {
|
||||
return _hasDom ? document.getElementById(args[0]) || NIL : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-body", function(_args) {
|
||||
return _hasDom ? document.body : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-ensure-element", function(args) {
|
||||
if (!_hasDom) return NIL;
|
||||
var sel = args[0];
|
||||
var el = document.querySelector(sel);
|
||||
if (el) return el;
|
||||
if (sel.charAt(0) === "#") {
|
||||
el = document.createElement("div");
|
||||
el.id = sel.slice(1);
|
||||
document.body.appendChild(el);
|
||||
return el;
|
||||
}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 3. DOM Attributes
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-get-attr", function(args) {
|
||||
var el = args[0], name = args[1];
|
||||
if (!el || !el.getAttribute) return NIL;
|
||||
var v = el.getAttribute(name);
|
||||
return v === null ? NIL : v;
|
||||
});
|
||||
|
||||
K.registerNative("dom-set-attr", function(args) {
|
||||
var el = args[0], name = args[1], val = args[2];
|
||||
if (el && el.setAttribute) el.setAttribute(name, val);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-remove-attr", function(args) {
|
||||
if (args[0] && args[0].removeAttribute) args[0].removeAttribute(args[1]);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-has-attr?", function(args) {
|
||||
return !!(args[0] && args[0].hasAttribute && args[0].hasAttribute(args[1]));
|
||||
});
|
||||
|
||||
K.registerNative("dom-attr-list", function(args) {
|
||||
var el = args[0];
|
||||
if (!el || !el.attributes) return [];
|
||||
var r = [];
|
||||
for (var i = 0; i < el.attributes.length; i++) {
|
||||
r.push([el.attributes[i].name, el.attributes[i].value]);
|
||||
}
|
||||
return r;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 4. DOM Content
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-text-content", function(args) {
|
||||
var el = args[0];
|
||||
return el ? el.textContent || el.nodeValue || "" : "";
|
||||
});
|
||||
|
||||
K.registerNative("dom-set-text-content", function(args) {
|
||||
var el = args[0], s = args[1];
|
||||
if (el) {
|
||||
if (el.nodeType === 3 || el.nodeType === 8) el.nodeValue = s;
|
||||
else el.textContent = s;
|
||||
}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-inner-html", function(args) {
|
||||
return args[0] && args[0].innerHTML != null ? args[0].innerHTML : "";
|
||||
});
|
||||
|
||||
K.registerNative("dom-set-inner-html", function(args) {
|
||||
if (args[0]) args[0].innerHTML = args[1] || "";
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-insert-adjacent-html", function(args) {
|
||||
var el = args[0], pos = args[1], html = args[2];
|
||||
if (el && el.insertAdjacentHTML) el.insertAdjacentHTML(pos, html);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-body-inner-html", function(args) {
|
||||
var doc = args[0];
|
||||
return doc && doc.body ? doc.body.innerHTML : "";
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 5. DOM Structure & Navigation
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-parent", function(args) { return args[0] ? args[0].parentNode || NIL : NIL; });
|
||||
K.registerNative("dom-first-child", function(args) { return args[0] ? args[0].firstChild || NIL : NIL; });
|
||||
K.registerNative("dom-next-sibling", function(args) { return args[0] ? args[0].nextSibling || NIL : NIL; });
|
||||
K.registerNative("dom-id", function(args) { return args[0] && args[0].id ? args[0].id : NIL; });
|
||||
K.registerNative("dom-node-type", function(args) { return args[0] ? args[0].nodeType : 0; });
|
||||
K.registerNative("dom-node-name", function(args) { return args[0] ? args[0].nodeName : ""; });
|
||||
K.registerNative("dom-tag-name", function(args) { return args[0] && args[0].tagName ? args[0].tagName : ""; });
|
||||
|
||||
K.registerNative("dom-child-list", function(args) {
|
||||
var el = args[0];
|
||||
if (!el || !el.childNodes) return [];
|
||||
return Array.prototype.slice.call(el.childNodes);
|
||||
});
|
||||
|
||||
K.registerNative("dom-child-nodes", function(args) {
|
||||
var el = args[0];
|
||||
if (!el || !el.childNodes) return [];
|
||||
return Array.prototype.slice.call(el.childNodes);
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 6. DOM Insertion & Removal
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-append", function(args) {
|
||||
var parent = args[0], child = args[1];
|
||||
if (parent && child) parent.appendChild(child);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-prepend", function(args) {
|
||||
var parent = args[0], child = args[1];
|
||||
if (parent && child) parent.insertBefore(child, parent.firstChild);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-insert-before", function(args) {
|
||||
var parent = args[0], node = args[1], ref = args[2];
|
||||
if (parent && node) parent.insertBefore(node, ref || null);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-insert-after", function(args) {
|
||||
var ref = args[0], node = args[1];
|
||||
if (ref && ref.parentNode && node) {
|
||||
ref.parentNode.insertBefore(node, ref.nextSibling);
|
||||
}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-remove", function(args) {
|
||||
var node = args[0];
|
||||
if (node && node.parentNode) node.parentNode.removeChild(node);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-remove-child", function(args) {
|
||||
var parent = args[0], child = args[1];
|
||||
if (parent && child && child.parentNode === parent) parent.removeChild(child);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-replace-child", function(args) {
|
||||
var parent = args[0], newC = args[1], oldC = args[2];
|
||||
if (parent && newC && oldC) parent.replaceChild(newC, oldC);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-remove-children-after", function(args) {
|
||||
var marker = args[0];
|
||||
if (!marker || !marker.parentNode) return NIL;
|
||||
var parent = marker.parentNode;
|
||||
while (marker.nextSibling) parent.removeChild(marker.nextSibling);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-append-to-head", function(args) {
|
||||
if (_hasDom && args[0]) document.head.appendChild(args[0]);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 7. DOM Type Checks
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-is-fragment?", function(args) { return args[0] ? args[0].nodeType === 11 : false; });
|
||||
K.registerNative("dom-is-child-of?", function(args) { return !!(args[1] && args[0] && args[0].parentNode === args[1]); });
|
||||
K.registerNative("dom-is-active-element?", function(args) { return _hasDom && args[0] === document.activeElement; });
|
||||
K.registerNative("dom-is-input-element?", function(args) {
|
||||
if (!args[0] || !args[0].tagName) return false;
|
||||
var t = args[0].tagName;
|
||||
return t === "INPUT" || t === "TEXTAREA" || t === "SELECT";
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 8. DOM Styles & Classes
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-get-style", function(args) {
|
||||
return args[0] && args[0].style ? args[0].style[args[1]] || "" : "";
|
||||
});
|
||||
|
||||
K.registerNative("dom-set-style", function(args) {
|
||||
if (args[0] && args[0].style) args[0].style[args[1]] = args[2];
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-add-class", function(args) {
|
||||
if (args[0] && args[0].classList) args[0].classList.add(args[1]);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-remove-class", function(args) {
|
||||
if (args[0] && args[0].classList) args[0].classList.remove(args[1]);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-has-class?", function(args) {
|
||||
return !!(args[0] && args[0].classList && args[0].classList.contains(args[1]));
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 9. DOM Properties & Data
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-get-prop", function(args) { return args[0] ? args[0][args[1]] : NIL; });
|
||||
K.registerNative("dom-set-prop", function(args) { if (args[0]) args[0][args[1]] = args[2]; return NIL; });
|
||||
|
||||
K.registerNative("dom-set-data", function(args) {
|
||||
var el = args[0], key = args[1], val = args[2];
|
||||
if (el) { if (!el._sxData) el._sxData = {}; el._sxData[key] = val; }
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-get-data", function(args) {
|
||||
var el = args[0], key = args[1];
|
||||
return (el && el._sxData) ? (el._sxData[key] != null ? el._sxData[key] : NIL) : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-call-method", function(args) {
|
||||
var obj = args[0], method = args[1];
|
||||
var callArgs = args.slice(2);
|
||||
if (obj && typeof obj[method] === "function") {
|
||||
try { return obj[method].apply(obj, callArgs); }
|
||||
catch(e) { return NIL; }
|
||||
}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 10. DOM Events
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-listen", function(args) {
|
||||
var el = args[0], name = args[1], handler = args[2];
|
||||
if (!_hasDom || !el) return function() {};
|
||||
|
||||
// handler is a wrapped SX lambda (JS function with __sx_handle).
|
||||
// Wrap it to:
|
||||
// - Pass the event object as arg (or no args for 0-arity handlers)
|
||||
// - Catch errors from the CEK machine
|
||||
var arity = K.fnArity(handler);
|
||||
var wrapped;
|
||||
if (arity === 0) {
|
||||
wrapped = function(_e) {
|
||||
try { K.callFn(handler, []); }
|
||||
catch(err) { console.error("[sx] event handler error:", name, err); }
|
||||
};
|
||||
} else {
|
||||
wrapped = function(e) {
|
||||
try { K.callFn(handler, [e]); }
|
||||
catch(err) { console.error("[sx] event handler error:", name, err); }
|
||||
};
|
||||
}
|
||||
el.addEventListener(name, wrapped);
|
||||
return function() { el.removeEventListener(name, wrapped); };
|
||||
});
|
||||
|
||||
K.registerNative("dom-dispatch", function(args) {
|
||||
if (!_hasDom || !args[0]) return false;
|
||||
var evt = new CustomEvent(args[1], { bubbles: true, cancelable: true, detail: args[2] || {} });
|
||||
return args[0].dispatchEvent(evt);
|
||||
});
|
||||
|
||||
K.registerNative("event-detail", function(args) {
|
||||
return (args[0] && args[0].detail != null) ? args[0].detail : NIL;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 11. Browser Navigation & History
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("browser-location-href", function(_args) {
|
||||
return typeof location !== "undefined" ? location.href : "";
|
||||
});
|
||||
|
||||
K.registerNative("browser-same-origin?", function(args) {
|
||||
try { return new URL(args[0], location.href).origin === location.origin; }
|
||||
catch (e) { return true; }
|
||||
});
|
||||
|
||||
K.registerNative("browser-push-state", function(args) {
|
||||
if (typeof history !== "undefined") {
|
||||
try { history.pushState({ sxUrl: args[0], scrollY: typeof window !== "undefined" ? window.scrollY : 0 }, "", args[0]); }
|
||||
catch (e) {}
|
||||
}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("browser-replace-state", function(args) {
|
||||
if (typeof history !== "undefined") {
|
||||
try { history.replaceState({ sxUrl: args[0], scrollY: typeof window !== "undefined" ? window.scrollY : 0 }, "", args[0]); }
|
||||
catch (e) {}
|
||||
}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("browser-navigate", function(args) {
|
||||
if (typeof location !== "undefined") location.assign(args[0]);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("browser-reload", function(_args) {
|
||||
if (typeof location !== "undefined") location.reload();
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("browser-scroll-to", function(args) {
|
||||
if (typeof window !== "undefined") window.scrollTo(args[0] || 0, args[1] || 0);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("browser-media-matches?", function(args) {
|
||||
if (typeof window === "undefined") return false;
|
||||
return window.matchMedia(args[0]).matches;
|
||||
});
|
||||
|
||||
K.registerNative("browser-confirm", function(args) {
|
||||
if (typeof window === "undefined") return false;
|
||||
return window.confirm(args[0]);
|
||||
});
|
||||
|
||||
K.registerNative("browser-prompt", function(args) {
|
||||
if (typeof window === "undefined") return NIL;
|
||||
var r = window.prompt(args[0]);
|
||||
return r === null ? NIL : r;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 12. Timers
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("set-timeout", function(args) {
|
||||
var fn = args[0], ms = args[1] || 0;
|
||||
var cb = (typeof fn === "function" && fn.__sx_handle != null)
|
||||
? function() { try { K.callFn(fn, []); } catch(e) { console.error("[sx] timeout error:", e); } }
|
||||
: fn;
|
||||
return setTimeout(cb, ms);
|
||||
});
|
||||
|
||||
K.registerNative("set-interval", function(args) {
|
||||
var fn = args[0], ms = args[1] || 1000;
|
||||
var cb = (typeof fn === "function" && fn.__sx_handle != null)
|
||||
? function() { try { K.callFn(fn, []); } catch(e) { console.error("[sx] interval error:", e); } }
|
||||
: fn;
|
||||
return setInterval(cb, ms);
|
||||
});
|
||||
|
||||
K.registerNative("clear-timeout", function(args) { clearTimeout(args[0]); return NIL; });
|
||||
K.registerNative("clear-interval", function(args) { clearInterval(args[0]); return NIL; });
|
||||
K.registerNative("now-ms", function(_args) {
|
||||
return (typeof performance !== "undefined") ? performance.now() : Date.now();
|
||||
});
|
||||
|
||||
K.registerNative("request-animation-frame", function(args) {
|
||||
var fn = args[0];
|
||||
var cb = (typeof fn === "function" && fn.__sx_handle != null)
|
||||
? function() { try { K.callFn(fn, []); } catch(e) { console.error("[sx] raf error:", e); } }
|
||||
: fn;
|
||||
if (typeof requestAnimationFrame !== "undefined") requestAnimationFrame(cb);
|
||||
else setTimeout(cb, 16);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 13. Promises
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("promise-resolve", function(args) { return Promise.resolve(args[0]); });
|
||||
|
||||
K.registerNative("promise-then", function(args) {
|
||||
var p = args[0];
|
||||
if (!p || !p.then) return p;
|
||||
var onResolve = function(v) { return K.callFn(args[1], [v]); };
|
||||
var onReject = args[2] ? function(e) { return K.callFn(args[2], [e]); } : undefined;
|
||||
return onReject ? p.then(onResolve, onReject) : p.then(onResolve);
|
||||
});
|
||||
|
||||
K.registerNative("promise-catch", function(args) {
|
||||
if (!args[0] || !args[0].catch) return args[0];
|
||||
return args[0].catch(function(e) { return K.callFn(args[1], [e]); });
|
||||
});
|
||||
|
||||
K.registerNative("promise-delayed", function(args) {
|
||||
return new Promise(function(resolve) {
|
||||
setTimeout(function() { resolve(args[1]); }, args[0]);
|
||||
});
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 14. Abort Controllers
|
||||
// =========================================================================
|
||||
|
||||
var _controllers = typeof WeakMap !== "undefined" ? new WeakMap() : null;
|
||||
var _targetControllers = typeof WeakMap !== "undefined" ? new WeakMap() : null;
|
||||
|
||||
K.registerNative("new-abort-controller", function(_args) {
|
||||
return typeof AbortController !== "undefined" ? new AbortController() : { signal: null, abort: function() {} };
|
||||
});
|
||||
|
||||
K.registerNative("abort-previous", function(args) {
|
||||
if (_controllers) { var prev = _controllers.get(args[0]); if (prev) prev.abort(); }
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("track-controller", function(args) {
|
||||
if (_controllers) _controllers.set(args[0], args[1]);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("abort-previous-target", function(args) {
|
||||
if (_targetControllers) { var prev = _targetControllers.get(args[0]); if (prev) prev.abort(); }
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("track-controller-target", function(args) {
|
||||
if (_targetControllers) _targetControllers.set(args[0], args[1]);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("controller-signal", function(args) { return args[0] ? args[0].signal : NIL; });
|
||||
K.registerNative("is-abort-error", function(args) { return args[0] && args[0].name === "AbortError"; });
|
||||
|
||||
// =========================================================================
|
||||
// 15. Fetch
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("fetch-request", function(args) {
|
||||
var config = args[0], successFn = args[1], errorFn = args[2];
|
||||
var opts = { method: config.method, headers: config.headers };
|
||||
if (config.signal) opts.signal = config.signal;
|
||||
if (config.body && config.method !== "GET") opts.body = config.body;
|
||||
if (config["cross-origin"]) opts.credentials = "include";
|
||||
|
||||
return fetch(config.url, opts).then(function(resp) {
|
||||
return resp.text().then(function(text) {
|
||||
var getHeader = function(name) {
|
||||
var v = resp.headers.get(name);
|
||||
return v === null ? NIL : v;
|
||||
};
|
||||
return K.callFn(successFn, [resp.ok, resp.status, getHeader, text]);
|
||||
});
|
||||
}).catch(function(err) {
|
||||
return K.callFn(errorFn, [err]);
|
||||
});
|
||||
});
|
||||
|
||||
K.registerNative("csrf-token", function(_args) {
|
||||
if (!_hasDom) return NIL;
|
||||
var m = document.querySelector('meta[name="csrf-token"]');
|
||||
return m ? m.getAttribute("content") : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("is-cross-origin", function(args) {
|
||||
try {
|
||||
var h = new URL(args[0], location.href).hostname;
|
||||
return h !== location.hostname &&
|
||||
(h.indexOf(".rose-ash.com") >= 0 || h.indexOf(".localhost") >= 0);
|
||||
} catch (e) { return false; }
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 16. localStorage
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("local-storage-get", function(args) {
|
||||
try { var v = localStorage.getItem(args[0]); return v === null ? NIL : v; }
|
||||
catch(e) { return NIL; }
|
||||
});
|
||||
|
||||
K.registerNative("local-storage-set", function(args) {
|
||||
try { localStorage.setItem(args[0], args[1]); } catch(e) {}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("local-storage-remove", function(args) {
|
||||
try { localStorage.removeItem(args[0]); } catch(e) {}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 17. Document Head & Title
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("set-document-title", function(args) {
|
||||
if (_hasDom) document.title = args[0] || "";
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("remove-head-element", function(args) {
|
||||
if (_hasDom) {
|
||||
var el = document.head.querySelector(args[0]);
|
||||
if (el) el.remove();
|
||||
}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 18. Logging
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("log-info", function(args) { console.log("[sx]", args[0]); return NIL; });
|
||||
K.registerNative("log-warn", function(args) { console.warn("[sx]", args[0]); return NIL; });
|
||||
K.registerNative("log-error", function(args) { console.error("[sx]", args[0]); return NIL; });
|
||||
|
||||
// =========================================================================
|
||||
// 19. JSON
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("json-parse", function(args) {
|
||||
try { return JSON.parse(args[0]); } catch(e) { return {}; }
|
||||
});
|
||||
|
||||
K.registerNative("try-parse-json", function(args) {
|
||||
try { return JSON.parse(args[0]); } catch(e) { return NIL; }
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 20. Processing markers
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("mark-processed!", function(args) {
|
||||
var el = args[0], key = args[1] || "sx";
|
||||
if (el) { if (!el._sxProcessed) el._sxProcessed = {}; el._sxProcessed[key] = true; }
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("is-processed?", function(args) {
|
||||
var el = args[0], key = args[1] || "sx";
|
||||
return !!(el && el._sxProcessed && el._sxProcessed[key]);
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// Public Sx API (wraps SxKernel for compatibility with existing code)
|
||||
// =========================================================================
|
||||
|
||||
var Sx = {
|
||||
// Core (delegated to WASM engine)
|
||||
parse: K.parse,
|
||||
eval: K.eval,
|
||||
evalExpr: K.evalExpr,
|
||||
load: K.load,
|
||||
loadSource: K.loadSource,
|
||||
renderToHtml: K.renderToHtml,
|
||||
typeOf: K.typeOf,
|
||||
inspect: K.inspect,
|
||||
engine: K.engine,
|
||||
|
||||
// Will be populated after web adapters load:
|
||||
// mount, hydrate, processElements, etc.
|
||||
};
|
||||
|
||||
global.Sx = Sx;
|
||||
global.SxKernel = K; // Keep kernel available for direct access
|
||||
|
||||
console.log("[sx-platform] registered, engine:", K.engine());
|
||||
|
||||
} // end initPlatform
|
||||
|
||||
initPlatform();
|
||||
|
||||
})(typeof globalThis !== "undefined" ? globalThis : this);
|
||||
946
hosts/ocaml/browser/sx_browser.ml
Normal file
946
hosts/ocaml/browser/sx_browser.ml
Normal file
@@ -0,0 +1,946 @@
|
||||
(** 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
|
||||
@@ -1,2 +1,2 @@
|
||||
(lang dune 3.0)
|
||||
(lang dune 3.19)
|
||||
(name sx)
|
||||
|
||||
@@ -1,2 +1,3 @@
|
||||
(library
|
||||
(name sx))
|
||||
(name sx)
|
||||
(wrapped false))
|
||||
|
||||
File diff suppressed because one or more lines are too long
@@ -131,35 +131,44 @@ let render_html_element tag args env =
|
||||
(List.map (fun c -> render_to_html c env) children) in
|
||||
"<" ^ tag ^ attr_str ^ ">" ^ content ^ "</" ^ tag ^ ">"
|
||||
|
||||
let render_component_generic ~params ~has_children ~body ~closure args env =
|
||||
let kwargs = Hashtbl.create 8 in
|
||||
let children_exprs = ref [] in
|
||||
let skip = ref false in
|
||||
let len = List.length args in
|
||||
List.iteri (fun idx arg ->
|
||||
if !skip then skip := false
|
||||
else match arg with
|
||||
| Keyword k when idx + 1 < len ->
|
||||
let v = Sx_ref.eval_expr (List.nth args (idx + 1)) (Env env) in
|
||||
Hashtbl.replace kwargs k v;
|
||||
skip := true
|
||||
| _ ->
|
||||
children_exprs := arg :: !children_exprs
|
||||
) args;
|
||||
let children = List.rev !children_exprs in
|
||||
let local = env_merge closure env in
|
||||
List.iter (fun p ->
|
||||
let v = match Hashtbl.find_opt kwargs p with Some v -> v | None -> Nil in
|
||||
ignore (env_bind local p v)
|
||||
) params;
|
||||
if has_children then begin
|
||||
let rendered_children = String.concat ""
|
||||
(List.map (fun c -> render_to_html c env) children) in
|
||||
ignore (env_bind local "children" (RawHTML rendered_children))
|
||||
end;
|
||||
render_to_html body local
|
||||
|
||||
let render_component comp args env =
|
||||
match comp with
|
||||
| Component c ->
|
||||
let kwargs = Hashtbl.create 8 in
|
||||
let children_exprs = ref [] in
|
||||
let skip = ref false in
|
||||
let len = List.length args in
|
||||
List.iteri (fun idx arg ->
|
||||
if !skip then skip := false
|
||||
else match arg with
|
||||
| Keyword k when idx + 1 < len ->
|
||||
let v = Sx_ref.eval_expr (List.nth args (idx + 1)) (Env env) in
|
||||
Hashtbl.replace kwargs k v;
|
||||
skip := true
|
||||
| _ ->
|
||||
children_exprs := arg :: !children_exprs
|
||||
) args;
|
||||
let children = List.rev !children_exprs in
|
||||
let local = env_merge c.c_closure env in
|
||||
List.iter (fun p ->
|
||||
let v = match Hashtbl.find_opt kwargs p with Some v -> v | None -> Nil in
|
||||
ignore (env_bind local p v)
|
||||
) c.c_params;
|
||||
if c.c_has_children then begin
|
||||
let rendered_children = String.concat ""
|
||||
(List.map (fun c -> render_to_html c env) children) in
|
||||
ignore (env_bind local "children" (RawHTML rendered_children))
|
||||
end;
|
||||
render_to_html c.c_body local
|
||||
render_component_generic
|
||||
~params:c.c_params ~has_children:c.c_has_children
|
||||
~body:c.c_body ~closure:c.c_closure args env
|
||||
| Island i ->
|
||||
render_component_generic
|
||||
~params:i.i_params ~has_children:i.i_has_children
|
||||
~body:i.i_body ~closure:i.i_closure args env
|
||||
| _ -> ""
|
||||
|
||||
let expand_macro (m : macro) args _env =
|
||||
@@ -249,7 +258,7 @@ and render_list_to_html head args env =
|
||||
(try
|
||||
let v = env_get env name in
|
||||
(match v with
|
||||
| Component _ -> render_component v args env
|
||||
| Component _ | Island _ -> render_component v args env
|
||||
| Macro m ->
|
||||
let expanded = expand_macro m args env in
|
||||
do_render_to_html expanded env
|
||||
|
||||
@@ -195,13 +195,59 @@ 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]
|
||||
(* 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 *)
|
||||
@@ -292,31 +338,99 @@ let dynamic_wind_call before body after _env =
|
||||
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
|
||||
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
|
||||
|
||||
(* Render mode stubs *)
|
||||
let render_active_p () = Bool false
|
||||
let render_expr _expr _env = Nil
|
||||
let is_render_expr _expr = Bool false
|
||||
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
|
||||
|
||||
(* 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
|
||||
(* 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
|
||||
|
||||
@@ -240,7 +240,10 @@ let is_component = function Component _ -> true | _ -> false
|
||||
let is_island = function Island _ -> true | _ -> false
|
||||
let is_macro = function Macro _ -> true | _ -> false
|
||||
let is_thunk = function Thunk _ -> true | _ -> false
|
||||
let is_signal = function Signal _ -> true | _ -> false
|
||||
let is_signal = function
|
||||
| Signal _ -> true
|
||||
| Dict d -> Hashtbl.mem d "__signal"
|
||||
| _ -> false
|
||||
|
||||
let is_callable = function
|
||||
| Lambda _ | NativeFn _ | Continuation (_, _) -> true
|
||||
@@ -287,26 +290,32 @@ let set_lambda_name l n = match l with
|
||||
|
||||
let component_name = function
|
||||
| Component c -> String c.c_name
|
||||
| Island i -> String i.i_name
|
||||
| v -> raise (Eval_error ("Expected component, got " ^ type_of v))
|
||||
|
||||
let component_params = function
|
||||
| Component c -> List (List.map (fun s -> String s) c.c_params)
|
||||
| Island i -> List (List.map (fun s -> String s) i.i_params)
|
||||
| v -> raise (Eval_error ("Expected component, got " ^ type_of v))
|
||||
|
||||
let component_body = function
|
||||
| Component c -> c.c_body
|
||||
| Island i -> i.i_body
|
||||
| v -> raise (Eval_error ("Expected component, got " ^ type_of v))
|
||||
|
||||
let component_closure = function
|
||||
| Component c -> Env c.c_closure
|
||||
| Island i -> Env i.i_closure
|
||||
| v -> raise (Eval_error ("Expected component, got " ^ type_of v))
|
||||
|
||||
let component_has_children = function
|
||||
| Component c -> Bool c.c_has_children
|
||||
| Island i -> Bool i.i_has_children
|
||||
| v -> raise (Eval_error ("Expected component, got " ^ type_of v))
|
||||
|
||||
let component_affinity = function
|
||||
| Component c -> String c.c_affinity
|
||||
| Island _ -> String "client"
|
||||
| _ -> String "auto"
|
||||
|
||||
let macro_params = function
|
||||
|
||||
Reference in New Issue
Block a user