Compare commits
130 Commits
5ab3ecb7e0
...
7d7de86034
| Author | SHA1 | Date | |
|---|---|---|---|
| 7d7de86034 | |||
| f3f70cc00b | |||
| 50871780a3 | |||
| 57cffb8bcc | |||
| eb4233ff36 | |||
| 5b2ef0a2af | |||
| 32df71abd4 | |||
| 91cf39153b | |||
| 953f0ec744 | |||
| 13ba5ee423 | |||
| a6e0e84521 | |||
| 3ae49b69f5 | |||
| 2d8741779e | |||
| 945b4c1dd7 | |||
| 33af6b9266 | |||
| c8280e156f | |||
| 732d733eac | |||
| 3df8c41ca1 | |||
| 6ef9688bd2 | |||
| f9f810ffd7 | |||
| e887c0d978 | |||
| 7434de53a6 | |||
| d735e28b39 | |||
| 482bc0ca5e | |||
| aa88c06c00 | |||
| ee868f686b | |||
| 96f2862385 | |||
| 26e16f6aa4 | |||
| 9caf8b6e94 | |||
| 8e6e7dce43 | |||
| bc7da977a0 | |||
| efb2d92b99 | |||
| 89543e0152 | |||
| 0c7567925e | |||
| 2a9a4b41bd | |||
| 8a08de26cd | |||
| 8ccf5f7c1e | |||
| bf305deae1 | |||
| e021184935 | |||
| 55061d6451 | |||
| ce9c5d3a08 | |||
| 49fd4a51d6 | |||
| 7d793ec76c | |||
| e4cabcbb59 | |||
| 284572c7a9 | |||
| 70a58bddd8 | |||
| 23c8b97cb1 | |||
| 5270d2e956 | |||
| dd057247a5 | |||
| 8958714c85 | |||
| 30cfbf777a | |||
| ffe849df8e | |||
| 49b03b246d | |||
| 33a02c8fe1 | |||
| a823e59376 | |||
| 96f50b9dfa | |||
| 890c472893 | |||
| 5cfeed81c1 | |||
| 2727a2ed8c | |||
| 6e804bbb5c | |||
| c4224925f9 | |||
| fe84b57bed | |||
| 5b370b69e3 | |||
| 639a6a2a53 | |||
| 3cce3df5b0 | |||
| 9ff913c312 | |||
| b1de591e9e | |||
| 364fbac9e1 | |||
| 8f2a51af9d | |||
| fa700e0202 | |||
| f4610e1799 | |||
| f3c0cbd8e2 | |||
| 6e1d28d1d7 | |||
| 2c8afd230d | |||
| 92bfef6406 | |||
| 894321db18 | |||
| 9bd4863ce1 | |||
| 2a5ef0ea09 | |||
| 1cc3e761a2 | |||
| e12b2eab6b | |||
| 09feb51762 | |||
| 4734d38f3b | |||
| a716e3f745 | |||
| 318c818728 | |||
| 7628659854 | |||
| bb34b4948b | |||
| df461beec2 | |||
| 6d73edf297 | |||
| 373a4f0134 | |||
| ae0e87fbf8 | |||
| 8dd3eaa1d9 | |||
| e6663a74ba | |||
| 231bfbecb5 | |||
| df256b5607 | |||
| 0ce23521b7 | |||
| c79aa880af | |||
| f12bbae6c9 | |||
| c8c4b322a9 | |||
| e7da397f8e | |||
| 1bb40415a8 | |||
| a62b7c8a5e | |||
| ceb2adfe50 | |||
| 5ca2ee92bc | |||
| e14fc9b0e1 | |||
| a8d1163aa6 | |||
| c8533181ab | |||
| 40d0f1a438 | |||
| d9e80d8544 | |||
| c16142d14c | |||
| 8707f21ca2 | |||
| 96e7bbbac1 | |||
| d3b3b4b720 | |||
| f819fda587 | |||
| d06de87bca | |||
| 109ca7c70b | |||
| 171c18d3be | |||
| 1c91680e63 | |||
| e61dc4974b | |||
| 8373c6cf16 | |||
| fac97883f9 | |||
| 71c2003a60 | |||
| 5b6e883e6d | |||
| 2203f56849 | |||
| ecbe670a6a | |||
| f9e65e1d17 | |||
| 4c54843542 | |||
| f7e4e3d762 | |||
| 4308591982 | |||
| 4ce4762237 | |||
| 06666ac8c4 |
@@ -0,0 +1,17 @@
|
||||
---
|
||||
name: SX navigation single-source-of-truth
|
||||
description: Navigation must be defined once in nav-data.sx — no fragment URLs, no duplicated case statements, use make-page-fn for convention-based routing
|
||||
type: feedback
|
||||
---
|
||||
|
||||
Never use fragment URLs (#anchors) in the SX docs nav system. Every navigable item must have its own Lisp URL.
|
||||
|
||||
**Why:** Fragment URLs don't work with the SX URL routing system — fragments are client-side only and never reach the server, so nav resolution can't identify the current page.
|
||||
|
||||
**How to apply:**
|
||||
- `nav-data.sx` is the single source of truth for all navigation labels, hrefs, summaries, and hierarchy
|
||||
- `page-functions.sx` uses `make-page-fn` (convention-based) or `slug->component` to derive component names from slugs — no hand-written case statements for simple pages
|
||||
- Overview/index pages should generate link lists from nav-data variables (e.g. `reactive-examples-nav-items`) rather than hardcoding URLs
|
||||
- To add a new simple page: add nav item to nav-data.sx, create the component file. That's it — the naming convention handles routing.
|
||||
- Pages that need server-side data fetching (reference, spec, test, bootstrapper, isomorphism) still use custom functions with explicit case clauses
|
||||
- Legacy Python nav lists in `content/pages.py` have been removed — nav-data.sx is canonical
|
||||
10
deploy.sh
10
deploy.sh
@@ -53,16 +53,10 @@ fi
|
||||
echo "Building: ${BUILD[*]}"
|
||||
echo ""
|
||||
|
||||
# --- Run unit tests before deploying ---
|
||||
echo "=== Running unit tests ==="
|
||||
docker build -f test/Dockerfile.unit -t rose-ash-test-unit:latest . -q
|
||||
if ! docker run --rm rose-ash-test-unit:latest; then
|
||||
echo ""
|
||||
echo "Unit tests FAILED — aborting deploy."
|
||||
# --- Run all tests before deploying ---
|
||||
if ! ./run-tests.sh; then
|
||||
exit 1
|
||||
fi
|
||||
echo "Unit tests passed."
|
||||
echo ""
|
||||
|
||||
for app in "${BUILD[@]}"; do
|
||||
dir=$(_app_dir "$app")
|
||||
|
||||
@@ -17,6 +17,9 @@ services:
|
||||
SX_OCAML_BIN: "/app/bin/sx_server"
|
||||
SX_BOUNDARY_STRICT: "1"
|
||||
SX_DEV: "1"
|
||||
OCAMLRUNPARAM: "b"
|
||||
ports:
|
||||
- "8013:8000"
|
||||
volumes:
|
||||
- /root/rose-ash/_config/dev-sh-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
@@ -28,6 +31,10 @@ services:
|
||||
- ./sx/sx:/app/sx
|
||||
- ./sx/path_setup.py:/app/path_setup.py
|
||||
- ./sx/entrypoint.sh:/usr/local/bin/entrypoint.sh
|
||||
# Spec + lib + web SX files (loaded by OCaml kernel)
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
# OCaml SX kernel binary (built with: cd hosts/ocaml && eval $(opam env) && dune build)
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./sx/__init__.py:/app/__init__.py:ro
|
||||
|
||||
@@ -12,6 +12,8 @@ x-dev-env: &dev-env
|
||||
WORKERS: "1"
|
||||
SX_USE_REF: "1"
|
||||
SX_BOUNDARY_STRICT: "1"
|
||||
SX_USE_OCAML: "1"
|
||||
SX_OCAML_BIN: "/app/bin/sx_server"
|
||||
|
||||
x-sibling-models: &sibling-models
|
||||
# Every app needs all sibling __init__.py + models/ for cross-domain SQLAlchemy imports
|
||||
@@ -44,6 +46,10 @@ services:
|
||||
volumes:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./blog/alembic.ini:/app/blog/alembic.ini:ro
|
||||
- ./blog/alembic:/app/blog/alembic:ro
|
||||
- ./blog/app.py:/app/app.py
|
||||
@@ -83,6 +89,10 @@ services:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- /root/rose-ash/_snapshot:/app/_snapshot
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./market/alembic.ini:/app/market/alembic.ini:ro
|
||||
- ./market/alembic:/app/market/alembic:ro
|
||||
- ./market/app.py:/app/app.py
|
||||
@@ -121,6 +131,10 @@ services:
|
||||
volumes:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./cart/alembic.ini:/app/cart/alembic.ini:ro
|
||||
- ./cart/alembic:/app/cart/alembic:ro
|
||||
- ./cart/app.py:/app/app.py
|
||||
@@ -159,6 +173,10 @@ services:
|
||||
volumes:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./events/alembic.ini:/app/events/alembic.ini:ro
|
||||
- ./events/alembic:/app/events/alembic:ro
|
||||
- ./events/app.py:/app/app.py
|
||||
@@ -197,6 +215,10 @@ services:
|
||||
volumes:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./federation/alembic.ini:/app/federation/alembic.ini:ro
|
||||
- ./federation/alembic:/app/federation/alembic:ro
|
||||
- ./federation/app.py:/app/app.py
|
||||
@@ -235,6 +257,10 @@ services:
|
||||
volumes:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./account/alembic.ini:/app/account/alembic.ini:ro
|
||||
- ./account/alembic:/app/account/alembic:ro
|
||||
- ./account/app.py:/app/app.py
|
||||
@@ -273,6 +299,10 @@ services:
|
||||
volumes:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./relations/alembic.ini:/app/relations/alembic.ini:ro
|
||||
- ./relations/alembic:/app/relations/alembic:ro
|
||||
- ./relations/app.py:/app/app.py
|
||||
@@ -304,6 +334,10 @@ services:
|
||||
volumes:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./likes/alembic.ini:/app/likes/alembic.ini:ro
|
||||
- ./likes/alembic:/app/likes/alembic:ro
|
||||
- ./likes/app.py:/app/app.py
|
||||
@@ -335,6 +369,10 @@ services:
|
||||
volumes:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./orders/alembic.ini:/app/orders/alembic.ini:ro
|
||||
- ./orders/alembic:/app/orders/alembic:ro
|
||||
- ./orders/app.py:/app/app.py
|
||||
@@ -369,6 +407,10 @@ services:
|
||||
volumes:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./test/app.py:/app/app.py
|
||||
- ./test/sx:/app/sx
|
||||
- ./test/bp:/app/bp
|
||||
@@ -393,9 +435,14 @@ services:
|
||||
- "8012:8000"
|
||||
environment:
|
||||
<<: *dev-env
|
||||
SX_STANDALONE: "true"
|
||||
volumes:
|
||||
- /root/rose-ash/_config/app-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./sx/app.py:/app/app.py
|
||||
- ./sx/sxc:/app/sxc
|
||||
- ./sx/bp:/app/bp
|
||||
@@ -431,6 +478,10 @@ services:
|
||||
dockerfile: test/Dockerfile.unit
|
||||
volumes:
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./artdag/core:/app/artdag/core
|
||||
- ./artdag/l1/tests:/app/artdag/l1/tests
|
||||
- ./artdag/l1/sexp_effects:/app/artdag/l1/sexp_effects
|
||||
@@ -456,6 +507,10 @@ services:
|
||||
dockerfile: test/Dockerfile.integration
|
||||
volumes:
|
||||
- ./shared:/app/shared
|
||||
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||
- ./spec:/app/spec:ro
|
||||
- ./lib:/app/lib:ro
|
||||
- ./web:/app/web:ro
|
||||
- ./artdag:/app/artdag
|
||||
profiles:
|
||||
- test
|
||||
|
||||
@@ -58,6 +58,8 @@ x-app-env: &app-env
|
||||
EXTERNAL_INBOXES: "artdag|https://celery-artdag.rose-ash.com/inbox"
|
||||
SX_BOUNDARY_STRICT: "1"
|
||||
SX_USE_REF: "1"
|
||||
SX_USE_OCAML: "1"
|
||||
SX_OCAML_BIN: "/app/bin/sx_server"
|
||||
|
||||
services:
|
||||
blog:
|
||||
@@ -228,8 +230,6 @@ services:
|
||||
<<: *app-env
|
||||
REDIS_URL: redis://redis:6379/10
|
||||
WORKERS: "1"
|
||||
SX_USE_OCAML: "1"
|
||||
SX_OCAML_BIN: "/app/bin/sx_server"
|
||||
|
||||
db:
|
||||
image: postgres:16
|
||||
|
||||
@@ -20,8 +20,8 @@ _PROJECT = os.path.abspath(os.path.join(_HERE, "..", ".."))
|
||||
if _PROJECT not in sys.path:
|
||||
sys.path.insert(0, _PROJECT)
|
||||
|
||||
from shared.sx.parser import parse_all
|
||||
from shared.sx.types import Symbol
|
||||
import tempfile
|
||||
from shared.sx.parser import serialize
|
||||
from hosts.javascript.platform import (
|
||||
extract_defines,
|
||||
ADAPTER_FILES, ADAPTER_DEPS, SPEC_MODULES, SPEC_MODULE_ORDER, EXTENSION_NAMES,
|
||||
@@ -35,29 +35,23 @@ from hosts.javascript.platform import (
|
||||
)
|
||||
|
||||
|
||||
_js_sx_env = None # cached
|
||||
_bridge = None # cached OcamlSync instance
|
||||
|
||||
|
||||
def load_js_sx() -> dict:
|
||||
"""Load js.sx into an evaluator environment and return it."""
|
||||
global _js_sx_env
|
||||
if _js_sx_env is not None:
|
||||
return _js_sx_env
|
||||
def _get_bridge():
|
||||
"""Get or create the OCaml sync bridge with transpiler loaded."""
|
||||
global _bridge
|
||||
if _bridge is not None:
|
||||
return _bridge
|
||||
from shared.sx.ocaml_sync import OcamlSync
|
||||
_bridge = OcamlSync()
|
||||
_bridge.load(os.path.join(_HERE, "transpiler.sx"))
|
||||
return _bridge
|
||||
|
||||
js_sx_path = os.path.join(_HERE, "transpiler.sx")
|
||||
with open(js_sx_path) as f:
|
||||
source = f.read()
|
||||
|
||||
exprs = parse_all(source)
|
||||
|
||||
from shared.sx.ref.sx_ref import evaluate, make_env
|
||||
|
||||
env = make_env()
|
||||
for expr in exprs:
|
||||
evaluate(expr, env)
|
||||
|
||||
_js_sx_env = env
|
||||
return env
|
||||
def load_js_sx():
|
||||
"""Load js.sx transpiler into the OCaml kernel. Returns the bridge."""
|
||||
return _get_bridge()
|
||||
|
||||
|
||||
def compile_ref_to_js(
|
||||
@@ -75,16 +69,14 @@ def compile_ref_to_js(
|
||||
spec_modules: List of spec modules (deps, router, signals). None = auto.
|
||||
"""
|
||||
from datetime import datetime, timezone
|
||||
from shared.sx.ref.sx_ref import evaluate
|
||||
|
||||
ref_dir = os.path.join(_PROJECT, "shared", "sx", "ref")
|
||||
# Source directories: core spec, web framework, and legacy ref (for bootstrapper tools)
|
||||
# Source directories: core spec, standard library, web framework
|
||||
_source_dirs = [
|
||||
os.path.join(_PROJECT, "spec"), # Core spec
|
||||
os.path.join(_PROJECT, "web"), # Web framework
|
||||
ref_dir, # Legacy location (fallback)
|
||||
os.path.join(_PROJECT, "spec"), # Core language spec
|
||||
os.path.join(_PROJECT, "lib"), # Standard library (stdlib, compiler, vm, ...)
|
||||
os.path.join(_PROJECT, "web"), # Web framework
|
||||
]
|
||||
env = load_js_sx()
|
||||
bridge = _get_bridge()
|
||||
|
||||
# Resolve adapter set
|
||||
if adapters is None:
|
||||
@@ -131,7 +123,12 @@ def compile_ref_to_js(
|
||||
# evaluator.sx = merged frames + eval utilities + CEK machine
|
||||
sx_files = [
|
||||
("evaluator.sx", "evaluator (frames + eval + CEK)"),
|
||||
# stdlib.sx is loaded at runtime via eval, not transpiled —
|
||||
# transpiling it would shadow native PRIMITIVES in module scope.
|
||||
("freeze.sx", "freeze (serializable state boundaries)"),
|
||||
("content.sx", "content (content-addressed computation)"),
|
||||
("render.sx", "render (core)"),
|
||||
("web-forms.sx", "web-forms (defstyle, deftype, defeffect, defrelation)"),
|
||||
]
|
||||
for name in ("parser", "html", "sx", "dom", "engine", "orchestration", "boot"):
|
||||
if name in adapter_set:
|
||||
@@ -214,11 +211,16 @@ def compile_ref_to_js(
|
||||
sx_defines = [[name, expr] for name, expr in defines]
|
||||
|
||||
parts.append(f"\n // === Transpiled from {label} ===\n")
|
||||
env["_defines"] = sx_defines
|
||||
result = evaluate(
|
||||
[Symbol("js-translate-file"), Symbol("_defines")],
|
||||
env,
|
||||
)
|
||||
# Serialize defines to SX, write to temp file, load into OCaml kernel
|
||||
defines_sx = serialize(sx_defines)
|
||||
with tempfile.NamedTemporaryFile(mode="w", suffix=".sx", delete=False) as tmp:
|
||||
tmp.write(f"(define _defines \'{defines_sx})\n")
|
||||
tmp_path = tmp.name
|
||||
try:
|
||||
bridge.load(tmp_path)
|
||||
finally:
|
||||
os.unlink(tmp_path)
|
||||
result = bridge.eval("(js-translate-file _defines)")
|
||||
parts.append(result)
|
||||
|
||||
# Platform JS for selected adapters
|
||||
@@ -230,6 +232,28 @@ def compile_ref_to_js(
|
||||
if has_cek:
|
||||
parts.append(CEK_FIXUPS_JS)
|
||||
|
||||
# Load stdlib.sx via eval (NOT transpiled) so defines go into the eval
|
||||
# env, not the module scope. This prevents stdlib functions from
|
||||
# shadowing native PRIMITIVES aliases used by transpiled evaluator code.
|
||||
stdlib_path = _find_sx("stdlib.sx")
|
||||
if stdlib_path:
|
||||
with open(stdlib_path) as f:
|
||||
stdlib_src = f.read()
|
||||
# Escape for JS string literal
|
||||
stdlib_escaped = stdlib_src.replace("\\", "\\\\").replace('"', '\\"').replace("\n", "\\n")
|
||||
parts.append(f'\n // === stdlib.sx (eval\'d at runtime, not transpiled) ===')
|
||||
parts.append(f' (function() {{')
|
||||
parts.append(f' var src = "{stdlib_escaped}";')
|
||||
parts.append(f' var forms = sxParse(src);')
|
||||
parts.append(f' var tmpEnv = merge({{}}, PRIMITIVES);')
|
||||
parts.append(f' for (var i = 0; i < forms.length; i++) {{')
|
||||
parts.append(f' trampoline(evalExpr(forms[i], tmpEnv));')
|
||||
parts.append(f' }}')
|
||||
parts.append(f' for (var k in tmpEnv) {{')
|
||||
parts.append(f' if (!PRIMITIVES[k]) PRIMITIVES[k] = tmpEnv[k];')
|
||||
parts.append(f' }}')
|
||||
parts.append(f' }})();\n')
|
||||
|
||||
for name in ("dom", "engine", "orchestration", "boot"):
|
||||
if name in adapter_set and name in adapter_platform:
|
||||
parts.append(adapter_platform[name])
|
||||
|
||||
@@ -13,7 +13,14 @@ 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, expr) for top-level forms.
|
||||
|
||||
Extracts (define name ...) forms with their name, plus selected
|
||||
non-define top-level expressions (e.g. register-special-form! calls)
|
||||
with a synthetic name for the comment.
|
||||
"""
|
||||
# Top-level calls that should be transpiled (not special forms)
|
||||
_TOPLEVEL_CALLS = {"register-special-form!"}
|
||||
exprs = parse_all(source)
|
||||
defines = []
|
||||
for expr in exprs:
|
||||
@@ -21,12 +28,18 @@ def extract_defines(source: str) -> list[tuple[str, list]]:
|
||||
if expr[0].name == "define":
|
||||
name = expr[1].name if isinstance(expr[1], Symbol) else str(expr[1])
|
||||
defines.append((name, expr))
|
||||
elif expr[0].name in _TOPLEVEL_CALLS:
|
||||
# Top-level call expression (e.g. register-special-form!)
|
||||
call_name = expr[0].name
|
||||
defines.append((f"({call_name} ...)", expr))
|
||||
return defines
|
||||
|
||||
ADAPTER_FILES = {
|
||||
"parser": ("parser.sx", "parser"),
|
||||
"html": ("adapter-html.sx", "adapter-html"),
|
||||
"sx": ("adapter-sx.sx", "adapter-sx"),
|
||||
"dom-lib": ("lib/dom.sx", "lib/dom (DOM library)"),
|
||||
"browser-lib": ("lib/browser.sx", "lib/browser (browser API library)"),
|
||||
"dom": ("adapter-dom.sx", "adapter-dom"),
|
||||
"engine": ("engine.sx", "engine"),
|
||||
"orchestration": ("orchestration.sx","orchestration"),
|
||||
@@ -35,6 +48,9 @@ ADAPTER_FILES = {
|
||||
|
||||
# Dependencies
|
||||
ADAPTER_DEPS = {
|
||||
"dom-lib": [],
|
||||
"browser-lib": ["dom-lib"],
|
||||
"dom": ["dom-lib", "browser-lib"],
|
||||
"engine": ["dom"],
|
||||
"orchestration": ["engine", "dom"],
|
||||
"boot": ["dom", "engine", "orchestration", "parser"],
|
||||
@@ -47,11 +63,12 @@ SPEC_MODULES = {
|
||||
"signals": ("signals.sx", "signals (reactive signal runtime)"),
|
||||
"page-helpers": ("page-helpers.sx", "page-helpers (pure data transformation helpers)"),
|
||||
"types": ("types.sx", "types (gradual type system)"),
|
||||
"vm": ("vm.sx", "vm (bytecode virtual machine)"),
|
||||
}
|
||||
# Note: frames and cek are now part of evaluator.sx (always loaded as core)
|
||||
|
||||
# Explicit ordering for spec modules with dependencies.
|
||||
SPEC_MODULE_ORDER = ["deps", "page-helpers", "router", "signals", "types"]
|
||||
SPEC_MODULE_ORDER = ["deps", "page-helpers", "router", "signals", "types", "vm"]
|
||||
|
||||
|
||||
EXTENSION_NAMES = {"continuations"}
|
||||
@@ -283,9 +300,11 @@ ASYNC_IO_JS = '''
|
||||
if (hname === "map-indexed") return asyncRenderMapIndexed(expr, env, ns);
|
||||
if (hname === "for-each") return asyncRenderMap(expr, env, ns);
|
||||
|
||||
// define/defcomp/defmacro — eval for side effects
|
||||
// define/defcomp/defmacro and custom special forms — eval for side effects
|
||||
if (hname === "define" || hname === "defcomp" || hname === "defmacro" ||
|
||||
hname === "defstyle" || hname === "defhandler") {
|
||||
hname === "defstyle" || hname === "defhandler" ||
|
||||
hname === "deftype" || hname === "defeffect" ||
|
||||
(typeof _customSpecialForms !== "undefined" && _customSpecialForms[hname])) {
|
||||
trampoline(evalExpr(expr, env));
|
||||
return null;
|
||||
}
|
||||
@@ -1111,6 +1130,58 @@ PRIMITIVES_JS_MODULES: dict[str, str] = {
|
||||
PRIMITIVES["context"] = sxContext;
|
||||
PRIMITIVES["emit!"] = sxEmit;
|
||||
PRIMITIVES["emitted"] = sxEmitted;
|
||||
// Aliases for aser adapter (avoids CEK special form conflict on server)
|
||||
var scopeEmit = sxEmit;
|
||||
function scopePeek(name) {
|
||||
if (_scopeStacks[name] && _scopeStacks[name].length) {
|
||||
return _scopeStacks[name][_scopeStacks[name].length - 1].value;
|
||||
}
|
||||
return NIL;
|
||||
}
|
||||
PRIMITIVES["scope-emit!"] = scopeEmit;
|
||||
PRIMITIVES["scope-peek"] = scopePeek;
|
||||
PRIMITIVES["scope-emitted"] = sxEmitted;
|
||||
PRIMITIVES["scope-collected"] = sxCollected;
|
||||
PRIMITIVES["scope-clear-collected!"] = sxClearCollected;
|
||||
|
||||
// ---- VM stack primitives ----
|
||||
// The VM spec (vm.sx) requires these array-like operations.
|
||||
// In JS, a plain Array serves as the stack.
|
||||
PRIMITIVES["make-vm-stack"] = function(size) {
|
||||
var a = new Array(size);
|
||||
for (var i = 0; i < size; i++) a[i] = NIL;
|
||||
return a;
|
||||
};
|
||||
PRIMITIVES["vm-stack-get"] = function(stack, idx) { return stack[idx]; };
|
||||
PRIMITIVES["vm-stack-set!"] = function(stack, idx, value) { stack[idx] = value; return NIL; };
|
||||
PRIMITIVES["vm-stack-length"] = function(stack) { return stack.length; };
|
||||
PRIMITIVES["vm-stack-copy!"] = function(src, dst, count) {
|
||||
for (var i = 0; i < count; i++) dst[i] = src[i];
|
||||
return NIL;
|
||||
};
|
||||
PRIMITIVES["get-primitive"] = function(name) {
|
||||
if (name in PRIMITIVES) return PRIMITIVES[name];
|
||||
throw new Error("VM undefined: " + name);
|
||||
};
|
||||
PRIMITIVES["call-primitive"] = function(name, args) {
|
||||
if (!(name in PRIMITIVES)) throw new Error("VM undefined: " + name);
|
||||
var fn = PRIMITIVES[name];
|
||||
return fn.apply(null, Array.isArray(args) ? args : []);
|
||||
};
|
||||
PRIMITIVES["primitive?"] = function(name) {
|
||||
return name in PRIMITIVES;
|
||||
};
|
||||
PRIMITIVES["set-nth!"] = function(lst, idx, val) {
|
||||
lst[idx] = val;
|
||||
return NIL;
|
||||
};
|
||||
|
||||
PRIMITIVES["env-parent"] = function(env) {
|
||||
if (env && Object.getPrototypeOf(env) !== Object.prototype &&
|
||||
Object.getPrototypeOf(env) !== null)
|
||||
return Object.getPrototypeOf(env);
|
||||
return NIL;
|
||||
};
|
||||
''',
|
||||
}
|
||||
# Modules to include by default (all)
|
||||
@@ -1149,6 +1220,7 @@ PLATFORM_JS_PRE = '''
|
||||
if (x._spread) return "spread";
|
||||
if (x._macro) return "macro";
|
||||
if (x._raw) return "raw-html";
|
||||
if (x._sx_expr) return "sx-expr";
|
||||
if (typeof Node !== "undefined" && x instanceof Node) return "dom-node";
|
||||
if (Array.isArray(x)) return "list";
|
||||
if (typeof x === "object") return "dict";
|
||||
@@ -1394,6 +1466,11 @@ PLATFORM_JS_POST = '''
|
||||
var get = PRIMITIVES["get"];
|
||||
var assoc = PRIMITIVES["assoc"];
|
||||
var range = PRIMITIVES["range"];
|
||||
var floor = PRIMITIVES["floor"];
|
||||
var pow = PRIMITIVES["pow"];
|
||||
var mod = PRIMITIVES["mod"];
|
||||
var indexOf_ = PRIMITIVES["index-of"];
|
||||
var hasKey = PRIMITIVES["has-key?"];
|
||||
function zip(a, b) { var r = []; for (var i = 0; i < Math.min(a.length, b.length); i++) r.push([a[i], b[i]]); return r; }
|
||||
function append_b(arr, x) { arr.push(x); return arr; }
|
||||
var apply = function(f, args) {
|
||||
@@ -1412,12 +1489,10 @@ PLATFORM_JS_POST = '''
|
||||
var dict_fn = PRIMITIVES["dict"];
|
||||
|
||||
// HTML rendering helpers
|
||||
function escapeHtml(s) {
|
||||
return String(s).replace(/&/g,"&").replace(/</g,"<").replace(/>/g,">").replace(/"/g,""");
|
||||
}
|
||||
function escapeAttr(s) { return escapeHtml(s); }
|
||||
// escape-html and escape-attr are now library functions defined in render.sx
|
||||
function rawHtmlContent(r) { return r.html; }
|
||||
function makeRawHtml(s) { return { _raw: true, html: s }; }
|
||||
function makeSxExpr(s) { return { _sx_expr: true, source: s }; }
|
||||
function sxExprSource(x) { return x && x.source ? x.source : String(x); }
|
||||
|
||||
// Placeholders — overridden by transpiled spec from parser.sx / adapter-sx.sx
|
||||
@@ -1425,11 +1500,102 @@ PLATFORM_JS_POST = '''
|
||||
function isSpecialForm(n) { return false; }
|
||||
function isHoForm(n) { return false; }
|
||||
|
||||
// -----------------------------------------------------------------------
|
||||
// Host FFI — the irreducible web platform primitives
|
||||
// All DOM/browser operations are built on these in web/lib/dom.sx
|
||||
// -----------------------------------------------------------------------
|
||||
PRIMITIVES["host-global"] = function(name) {
|
||||
if (typeof globalThis !== "undefined" && name in globalThis) return globalThis[name];
|
||||
if (typeof window !== "undefined" && name in window) return window[name];
|
||||
return NIL;
|
||||
};
|
||||
PRIMITIVES["host-get"] = function(obj, prop) {
|
||||
if (obj == null || obj === NIL) return NIL;
|
||||
var v = obj[prop];
|
||||
return v === undefined || v === null ? NIL : v;
|
||||
};
|
||||
PRIMITIVES["host-set!"] = function(obj, prop, val) {
|
||||
if (obj != null && obj !== NIL) obj[prop] = val === NIL ? null : val;
|
||||
};
|
||||
PRIMITIVES["host-call"] = function() {
|
||||
var obj = arguments[0], method = arguments[1];
|
||||
var args = [];
|
||||
for (var i = 2; i < arguments.length; i++) {
|
||||
var a = arguments[i];
|
||||
args.push(a === NIL ? null : a);
|
||||
}
|
||||
if (obj == null || obj === NIL) {
|
||||
// Global function call
|
||||
var fn = typeof globalThis !== "undefined" ? globalThis[method] : window[method];
|
||||
if (typeof fn === "function") return fn.apply(null, args);
|
||||
return NIL;
|
||||
}
|
||||
if (typeof obj[method] === "function") {
|
||||
try { return obj[method].apply(obj, args); }
|
||||
catch(e) { return NIL; }
|
||||
}
|
||||
return NIL;
|
||||
};
|
||||
PRIMITIVES["host-new"] = function() {
|
||||
var name = arguments[0];
|
||||
var args = Array.prototype.slice.call(arguments, 1).map(function(a) { return a === NIL ? null : a; });
|
||||
var Ctor = typeof globalThis !== "undefined" ? globalThis[name] : window[name];
|
||||
if (typeof Ctor !== "function") return NIL;
|
||||
// Support 0-4 args (covers all practical cases)
|
||||
switch (args.length) {
|
||||
case 0: return new Ctor();
|
||||
case 1: return new Ctor(args[0]);
|
||||
case 2: return new Ctor(args[0], args[1]);
|
||||
case 3: return new Ctor(args[0], args[1], args[2]);
|
||||
default: return new Ctor(args[0], args[1], args[2], args[3]);
|
||||
}
|
||||
};
|
||||
PRIMITIVES["host-callback"] = function(fn) {
|
||||
// Wrap SX function/lambda as a native JS callback
|
||||
if (typeof fn === "function") return fn;
|
||||
if (fn && fn._type === "lambda") {
|
||||
return function() {
|
||||
var a = Array.prototype.slice.call(arguments);
|
||||
return cekCall(fn, a);
|
||||
};
|
||||
}
|
||||
return function() {};
|
||||
};
|
||||
PRIMITIVES["host-typeof"] = function(obj) {
|
||||
if (obj == null || obj === NIL) return "nil";
|
||||
if (obj instanceof Element) return "element";
|
||||
if (obj instanceof Text) return "text";
|
||||
if (obj instanceof DocumentFragment) return "fragment";
|
||||
if (obj instanceof Document) return "document";
|
||||
if (obj instanceof Event) return "event";
|
||||
if (obj instanceof Promise) return "promise";
|
||||
if (obj instanceof AbortController) return "abort-controller";
|
||||
return typeof obj;
|
||||
};
|
||||
PRIMITIVES["host-await"] = function(promise, callback) {
|
||||
if (promise && typeof promise.then === "function") {
|
||||
var cb = typeof callback === "function" ? callback :
|
||||
(callback && callback._type === "lambda") ?
|
||||
function(v) { return cekCall(callback, [v]); } : function() {};
|
||||
promise.then(cb);
|
||||
}
|
||||
};
|
||||
// Aliases for transpiled dom.sx / browser.sx code (transpiler mangles host-* names)
|
||||
var hostGlobal = PRIMITIVES["host-global"];
|
||||
var hostGet = PRIMITIVES["host-get"];
|
||||
var hostSet = PRIMITIVES["host-set!"];
|
||||
var hostCall = PRIMITIVES["host-call"];
|
||||
var hostNew = PRIMITIVES["host-new"];
|
||||
var hostCallback = PRIMITIVES["host-callback"];
|
||||
var hostTypeof = PRIMITIVES["host-typeof"];
|
||||
var hostAwait = PRIMITIVES["host-await"];
|
||||
|
||||
// processBindings and evalCond — now specced in render.sx, bootstrapped above
|
||||
|
||||
function isDefinitionForm(name) {
|
||||
return name === "define" || name === "defcomp" || name === "defmacro" ||
|
||||
name === "defstyle" || name === "defhandler";
|
||||
name === "defstyle" || name === "defhandler" ||
|
||||
name === "deftype" || name === "defeffect";
|
||||
}
|
||||
|
||||
function indexOf_(s, ch) {
|
||||
@@ -1564,21 +1730,8 @@ CEK_FIXUPS_JS = '''
|
||||
PRIMITIVES["island?"] = isIsland;
|
||||
PRIMITIVES["make-symbol"] = function(n) { return new Symbol(n); };
|
||||
PRIMITIVES["is-html-tag?"] = function(n) { return HTML_TAGS.indexOf(n) >= 0; };
|
||||
PRIMITIVES["make-env"] = function() { return merge(componentEnv, PRIMITIVES); };
|
||||
|
||||
// localStorage — defined here (before boot) so islands can use at hydration
|
||||
PRIMITIVES["local-storage-get"] = function(key) {
|
||||
try { var v = localStorage.getItem(key); return v === null ? NIL : v; }
|
||||
catch (e) { return NIL; }
|
||||
};
|
||||
PRIMITIVES["local-storage-set"] = function(key, val) {
|
||||
try { localStorage.setItem(key, val); } catch (e) {}
|
||||
return NIL;
|
||||
};
|
||||
PRIMITIVES["local-storage-remove"] = function(key) {
|
||||
try { localStorage.removeItem(key); } catch (e) {}
|
||||
return NIL;
|
||||
};
|
||||
function makeEnv() { return merge(componentEnv, PRIMITIVES); }
|
||||
PRIMITIVES["make-env"] = makeEnv;
|
||||
'''
|
||||
|
||||
|
||||
@@ -1687,7 +1840,7 @@ PLATFORM_PARSER_JS = r"""
|
||||
function escapeString(s) {
|
||||
return s.replace(/\\/g, "\\\\").replace(/"/g, '\\"').replace(/\n/g, "\\n").replace(/\t/g, "\\t");
|
||||
}
|
||||
function sxExprSource(e) { return typeof e === "string" ? e : String(e); }
|
||||
function sxExprSource(e) { return typeof e === "string" ? e : (e && e.source ? e.source : String(e)); }
|
||||
var charFromCode = PRIMITIVES["char-from-code"];
|
||||
"""
|
||||
|
||||
@@ -1703,6 +1856,11 @@ PLATFORM_DOM_JS = """
|
||||
_renderExprFn = function(expr, env) { return renderToDom(expr, env, null); };
|
||||
_renderMode = true; // Browser always evaluates in render context.
|
||||
|
||||
// Wire CEK render hooks — evaluator checks _renderCheck/_renderFn instead of
|
||||
// the old renderActiveP()/isRenderExpr()/renderExpr() triple.
|
||||
_renderCheck = function(expr, env) { return _renderMode && isRenderExpr(expr); };
|
||||
_renderFn = function(expr, env) { return renderToDom(expr, env, null); };
|
||||
|
||||
var SVG_NS = "http://www.w3.org/2000/svg";
|
||||
var MATH_NS = "http://www.w3.org/1998/Math/MathML";
|
||||
|
||||
@@ -1869,12 +2027,14 @@ PLATFORM_DOM_JS = """
|
||||
// If lambda takes 0 params, call without event arg (convenience for on-click handlers)
|
||||
var wrapped = isLambda(handler)
|
||||
? (lambdaParams(handler).length === 0
|
||||
? function(e) { try { cekCall(handler, NIL); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } finally { runPostRenderHooks(); } }
|
||||
: function(e) { try { cekCall(handler, [e]); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } finally { runPostRenderHooks(); } })
|
||||
? function(e) { try { cekCall(handler, NIL); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } }
|
||||
: function(e) { try { cekCall(handler, [e]); } catch(err) { console.error("[sx-ref] domListen handler error:", name, err); } })
|
||||
: handler;
|
||||
if (name === "click") logInfo("domListen: click on <" + (el.tagName||"?").toLowerCase() + "> text=" + (el.textContent||"").substring(0,20) + " isLambda=" + isLambda(handler));
|
||||
el.addEventListener(name, wrapped);
|
||||
return function() { el.removeEventListener(name, wrapped); };
|
||||
var passiveEvents = { touchstart: 1, touchmove: 1, wheel: 1, scroll: 1 };
|
||||
var opts = passiveEvents[name] ? { passive: true } : undefined;
|
||||
el.addEventListener(name, wrapped, opts);
|
||||
return function() { el.removeEventListener(name, wrapped, opts); };
|
||||
}
|
||||
|
||||
function eventDetail(e) {
|
||||
@@ -2188,7 +2348,10 @@ PLATFORM_ORCHESTRATION_JS = """
|
||||
}
|
||||
}
|
||||
});
|
||||
}).catch(function() { location.reload(); });
|
||||
}).catch(function(err) {
|
||||
logWarn("sx:popstate fetch error " + url + " — " + (err && err.message ? err.message : err));
|
||||
location.reload();
|
||||
});
|
||||
}
|
||||
|
||||
function fetchStreaming(target, url, headers) {
|
||||
@@ -2326,7 +2489,9 @@ PLATFORM_ORCHESTRATION_JS = """
|
||||
return resp.text().then(function(text) {
|
||||
preloadCacheSet(cache, url, text, ct);
|
||||
});
|
||||
}).catch(function() { /* ignore */ });
|
||||
}).catch(function(err) {
|
||||
logInfo("sx:preload error " + url + " — " + (err && err.message ? err.message : err));
|
||||
});
|
||||
}
|
||||
|
||||
// --- Request body building ---
|
||||
@@ -2491,6 +2656,7 @@ PLATFORM_ORCHESTRATION_JS = """
|
||||
|
||||
function preventDefault_(e) { if (e && e.preventDefault) e.preventDefault(); }
|
||||
function stopPropagation_(e) { if (e && e.stopPropagation) e.stopPropagation(); }
|
||||
function eventModifierKey_p(e) { return !!(e && (e.ctrlKey || e.metaKey || e.shiftKey || e.altKey)); }
|
||||
function domFocus(el) { if (el && el.focus) el.focus(); }
|
||||
function tryCatch(tryFn, catchFn) {
|
||||
var t = _wrapSxFn(tryFn);
|
||||
@@ -2594,6 +2760,7 @@ PLATFORM_ORCHESTRATION_JS = """
|
||||
|
||||
function bindBoostLink(el, _href) {
|
||||
el.addEventListener("click", function(e) {
|
||||
if (e.ctrlKey || e.metaKey || e.shiftKey || e.altKey) return;
|
||||
e.preventDefault();
|
||||
// Re-read href from element at click time (not closed-over value)
|
||||
var liveHref = el.getAttribute("href") || _href;
|
||||
@@ -2615,6 +2782,8 @@ PLATFORM_ORCHESTRATION_JS = """
|
||||
var liveAction = form.getAttribute("action") || _action || location.href;
|
||||
executeRequest(form, { method: liveMethod, url: liveAction }).then(function() {
|
||||
try { history.pushState({ sxUrl: liveAction, scrollY: window.scrollY }, "", liveAction); } catch (err) {}
|
||||
}).catch(function(err) {
|
||||
logWarn("sx:boost form error " + liveMethod + " " + liveAction + " — " + (err && err.message ? err.message : err));
|
||||
});
|
||||
});
|
||||
}
|
||||
@@ -2623,6 +2792,7 @@ PLATFORM_ORCHESTRATION_JS = """
|
||||
|
||||
function bindClientRouteClick(link, _href, fallbackFn) {
|
||||
link.addEventListener("click", function(e) {
|
||||
if (e.ctrlKey || e.metaKey || e.shiftKey || e.altKey) return;
|
||||
e.preventDefault();
|
||||
// Re-read href from element at click time (not closed-over value)
|
||||
var liveHref = link.getAttribute("href") || _href;
|
||||
@@ -2773,7 +2943,7 @@ PLATFORM_ORCHESTRATION_JS = """
|
||||
} else {
|
||||
fn();
|
||||
}
|
||||
});
|
||||
}, { passive: true });
|
||||
});
|
||||
}
|
||||
|
||||
@@ -2783,6 +2953,7 @@ PLATFORM_ORCHESTRATION_JS = """
|
||||
|
||||
function markProcessed(el, key) { el[PROCESSED + key] = true; }
|
||||
function isProcessed(el, key) { return !!el[PROCESSED + key]; }
|
||||
function clearProcessed(el, key) { delete el[PROCESSED + key]; }
|
||||
|
||||
// --- Script cloning ---
|
||||
|
||||
@@ -3036,57 +3207,37 @@ def fixups_js(has_html, has_sx, has_dom, has_signals=False, has_deps=False, has_
|
||||
return _rawCallLambda(f, args, callerEnv);
|
||||
};
|
||||
|
||||
// Expose render functions as primitives so SX code can call them''']
|
||||
if has_html:
|
||||
lines.append(' if (typeof renderToHtml === "function") PRIMITIVES["render-to-html"] = renderToHtml;')
|
||||
if has_sx:
|
||||
lines.append(' if (typeof renderToSx === "function") PRIMITIVES["render-to-sx"] = renderToSx;')
|
||||
lines.append(' if (typeof aser === "function") PRIMITIVES["aser"] = aser;')
|
||||
if has_dom:
|
||||
lines.append(' if (typeof renderToDom === "function") PRIMITIVES["render-to-dom"] = renderToDom;')
|
||||
if has_signals:
|
||||
lines.append('''
|
||||
// Expose signal functions as primitives so runtime-evaluated SX code
|
||||
// (e.g. island bodies from .sx files) can call them
|
||||
PRIMITIVES["signal"] = signal;
|
||||
PRIMITIVES["signal?"] = isSignal;
|
||||
PRIMITIVES["deref"] = deref;
|
||||
PRIMITIVES["reset!"] = reset_b;
|
||||
PRIMITIVES["swap!"] = swap_b;
|
||||
PRIMITIVES["computed"] = computed;
|
||||
PRIMITIVES["effect"] = effect;
|
||||
PRIMITIVES["batch"] = batch;
|
||||
// Timer primitives for island code
|
||||
PRIMITIVES["set-interval"] = setInterval_;
|
||||
PRIMITIVES["clear-interval"] = clearInterval_;
|
||||
// Reactive DOM helpers for island code
|
||||
PRIMITIVES["reactive-text"] = reactiveText;
|
||||
PRIMITIVES["create-text-node"] = createTextNode;
|
||||
PRIMITIVES["dom-set-text-content"] = domSetTextContent;
|
||||
PRIMITIVES["dom-listen"] = domListen;
|
||||
PRIMITIVES["dom-dispatch"] = domDispatch;
|
||||
PRIMITIVES["event-detail"] = eventDetail;
|
||||
PRIMITIVES["resource"] = resource;
|
||||
PRIMITIVES["promise-delayed"] = promiseDelayed;
|
||||
PRIMITIVES["promise-then"] = promiseThen;
|
||||
PRIMITIVES["def-store"] = defStore;
|
||||
PRIMITIVES["use-store"] = useStore;
|
||||
PRIMITIVES["emit-event"] = emitEvent;
|
||||
PRIMITIVES["on-event"] = onEvent;
|
||||
PRIMITIVES["bridge-event"] = bridgeEvent;
|
||||
// DOM primitives for island code
|
||||
PRIMITIVES["dom-focus"] = domFocus;
|
||||
PRIMITIVES["dom-tag-name"] = domTagName;
|
||||
PRIMITIVES["dom-get-prop"] = domGetProp;
|
||||
PRIMITIVES["dom-set-prop"] = domSetProp;
|
||||
PRIMITIVES["dom-call-method"] = domCallMethod;
|
||||
PRIMITIVES["dom-post-message"] = domPostMessage;
|
||||
// -----------------------------------------------------------------------
|
||||
// Core primitives that require native JS (cannot be expressed via FFI)
|
||||
// -----------------------------------------------------------------------
|
||||
PRIMITIVES["error"] = function(msg) { throw new Error(msg); };
|
||||
|
||||
// FFI library functions — defined in dom.sx/browser.sx but not transpiled.
|
||||
// Registered here so runtime-evaluated SX code (data-init, islands) can use them.
|
||||
PRIMITIVES["prevent-default"] = preventDefault_;
|
||||
PRIMITIVES["stop-propagation"] = stopPropagation_;
|
||||
PRIMITIVES["event-modifier-key?"] = eventModifierKey_p;
|
||||
PRIMITIVES["element-value"] = elementValue;
|
||||
PRIMITIVES["error-message"] = errorMessage;
|
||||
PRIMITIVES["schedule-idle"] = scheduleIdle;
|
||||
PRIMITIVES["error"] = function(msg) { throw new Error(msg); };
|
||||
PRIMITIVES["filter"] = filter;
|
||||
// DOM primitives for sx-on:* handlers and data-init scripts
|
||||
PRIMITIVES["console-log"] = function() {
|
||||
var args = Array.prototype.slice.call(arguments);
|
||||
console.log.apply(console, ["[sx]"].concat(args));
|
||||
return args.length > 0 ? args[0] : NIL;
|
||||
};
|
||||
PRIMITIVES["set-cookie"] = function(name, value, days) {
|
||||
var d = days || 365;
|
||||
var expires = new Date(Date.now() + d * 864e5).toUTCString();
|
||||
document.cookie = name + "=" + encodeURIComponent(value) + ";expires=" + expires + ";path=/;SameSite=Lax";
|
||||
return NIL;
|
||||
};
|
||||
PRIMITIVES["get-cookie"] = function(name) {
|
||||
var m = document.cookie.match(new RegExp("(?:^|;\\\\s*)" + name + "=([^;]*)"));
|
||||
return m ? decodeURIComponent(m[1]) : NIL;
|
||||
};
|
||||
|
||||
// dom.sx / browser.sx library functions — not transpiled, registered from
|
||||
// native platform implementations so runtime-eval'd SX code can use them.
|
||||
if (typeof domBody === "function") PRIMITIVES["dom-body"] = domBody;
|
||||
if (typeof domQuery === "function") PRIMITIVES["dom-query"] = domQuery;
|
||||
if (typeof domQueryAll === "function") PRIMITIVES["dom-query-all"] = domQueryAll;
|
||||
@@ -3100,8 +3251,6 @@ def fixups_js(has_html, has_sx, has_dom, has_signals=False, has_deps=False, has_
|
||||
if (typeof domHasClass === "function") PRIMITIVES["dom-has-class?"] = domHasClass;
|
||||
if (typeof domClosest === "function") PRIMITIVES["dom-closest"] = domClosest;
|
||||
if (typeof domMatches === "function") PRIMITIVES["dom-matches?"] = domMatches;
|
||||
if (typeof preventDefault_ === "function") PRIMITIVES["prevent-default"] = preventDefault_;
|
||||
if (typeof elementValue === "function") PRIMITIVES["element-value"] = elementValue;
|
||||
if (typeof domOuterHtml === "function") PRIMITIVES["dom-outer-html"] = domOuterHtml;
|
||||
if (typeof domInnerHtml === "function") PRIMITIVES["dom-inner-html"] = domInnerHtml;
|
||||
if (typeof domTextContent === "function") PRIMITIVES["dom-text-content"] = domTextContent;
|
||||
@@ -3110,52 +3259,43 @@ def fixups_js(has_html, has_sx, has_dom, has_signals=False, has_deps=False, has_
|
||||
if (typeof domAppendToHead === "function") PRIMITIVES["dom-append-to-head"] = domAppendToHead;
|
||||
if (typeof jsonParse === "function") PRIMITIVES["json-parse"] = jsonParse;
|
||||
if (typeof nowMs === "function") PRIMITIVES["now-ms"] = nowMs;
|
||||
PRIMITIVES["sx-parse"] = sxParse;
|
||||
PRIMITIVES["console-log"] = function() { console.log.apply(console, ["[sx]"].concat(Array.prototype.slice.call(arguments))); return arguments.length > 0 ? arguments[0] : NIL; };''')
|
||||
PRIMITIVES["log-info"] = logInfo;
|
||||
PRIMITIVES["log-warn"] = logWarn;
|
||||
PRIMITIVES["dom-listen"] = domListen;
|
||||
PRIMITIVES["dom-dispatch"] = domDispatch;
|
||||
PRIMITIVES["event-detail"] = eventDetail;
|
||||
PRIMITIVES["create-text-node"] = createTextNode;
|
||||
PRIMITIVES["dom-set-text-content"] = domSetTextContent;
|
||||
PRIMITIVES["dom-focus"] = domFocus;
|
||||
PRIMITIVES["dom-tag-name"] = domTagName;
|
||||
PRIMITIVES["dom-get-prop"] = domGetProp;
|
||||
PRIMITIVES["dom-set-prop"] = domSetProp;
|
||||
PRIMITIVES["reactive-text"] = reactiveText;
|
||||
PRIMITIVES["set-interval"] = setInterval_;
|
||||
PRIMITIVES["clear-interval"] = clearInterval_;
|
||||
PRIMITIVES["promise-then"] = promiseThen;
|
||||
PRIMITIVES["promise-delayed"] = promiseDelayed;
|
||||
PRIMITIVES["local-storage-get"] = function(key) {
|
||||
try { var v = localStorage.getItem(key); return v === null ? NIL : v; }
|
||||
catch (e) { return NIL; }
|
||||
};
|
||||
PRIMITIVES["local-storage-set"] = function(key, val) {
|
||||
try { localStorage.setItem(key, val); } catch (e) {}
|
||||
return NIL;
|
||||
};
|
||||
PRIMITIVES["local-storage-remove"] = function(key) {
|
||||
try { localStorage.removeItem(key); } catch (e) {}
|
||||
return NIL;
|
||||
};
|
||||
if (typeof sxParse === "function") PRIMITIVES["sx-parse"] = sxParse;''']
|
||||
if has_deps:
|
||||
lines.append('''
|
||||
// Expose deps module functions as primitives so runtime-evaluated SX code
|
||||
// (e.g. test-deps.sx in browser) can call them
|
||||
// Platform functions (from PLATFORM_DEPS_JS)
|
||||
// Platform deps functions (native JS, not transpiled — need explicit registration)
|
||||
PRIMITIVES["component-deps"] = componentDeps;
|
||||
PRIMITIVES["component-set-deps!"] = componentSetDeps;
|
||||
PRIMITIVES["component-css-classes"] = componentCssClasses;
|
||||
PRIMITIVES["env-components"] = envComponents;
|
||||
PRIMITIVES["regex-find-all"] = regexFindAll;
|
||||
PRIMITIVES["scan-css-classes"] = scanCssClasses;
|
||||
// Transpiled functions (from deps.sx)
|
||||
PRIMITIVES["scan-refs"] = scanRefs;
|
||||
PRIMITIVES["scan-refs-walk"] = scanRefsWalk;
|
||||
PRIMITIVES["transitive-deps"] = transitiveDeps;
|
||||
PRIMITIVES["transitive-deps-walk"] = transitiveDepsWalk;
|
||||
PRIMITIVES["compute-all-deps"] = computeAllDeps;
|
||||
PRIMITIVES["scan-components-from-source"] = scanComponentsFromSource;
|
||||
PRIMITIVES["components-needed"] = componentsNeeded;
|
||||
PRIMITIVES["page-component-bundle"] = pageComponentBundle;
|
||||
PRIMITIVES["page-css-classes"] = pageCssClasses;
|
||||
PRIMITIVES["scan-io-refs-walk"] = scanIoRefsWalk;
|
||||
PRIMITIVES["scan-io-refs"] = scanIoRefs;
|
||||
PRIMITIVES["transitive-io-refs-walk"] = transitiveIoRefsWalk;
|
||||
PRIMITIVES["transitive-io-refs"] = transitiveIoRefs;
|
||||
PRIMITIVES["compute-all-io-refs"] = computeAllIoRefs;
|
||||
PRIMITIVES["component-io-refs-cached"] = componentIoRefsCached;
|
||||
PRIMITIVES["component-pure?"] = componentPure_p;
|
||||
PRIMITIVES["render-target"] = renderTarget;
|
||||
PRIMITIVES["page-render-plan"] = pageRenderPlan;''')
|
||||
if has_page_helpers:
|
||||
lines.append('''
|
||||
// Expose page-helper functions as primitives
|
||||
PRIMITIVES["categorize-special-forms"] = categorizeSpecialForms;
|
||||
PRIMITIVES["extract-define-kwargs"] = extractDefineKwargs;
|
||||
PRIMITIVES["build-reference-data"] = buildReferenceData;
|
||||
PRIMITIVES["build-ref-items-with-href"] = buildRefItemsWithHref;
|
||||
PRIMITIVES["build-attr-detail"] = buildAttrDetail;
|
||||
PRIMITIVES["build-header-detail"] = buildHeaderDetail;
|
||||
PRIMITIVES["build-event-detail"] = buildEventDetail;
|
||||
PRIMITIVES["build-component-source"] = buildComponentSource;
|
||||
PRIMITIVES["build-bundle-analysis"] = buildBundleAnalysis;
|
||||
PRIMITIVES["build-routing-analysis"] = buildRoutingAnalysis;
|
||||
PRIMITIVES["build-affinity-analysis"] = buildAffinityAnalysis;''')
|
||||
PRIMITIVES["scan-css-classes"] = scanCssClasses;''')
|
||||
return "\n".join(lines)
|
||||
|
||||
|
||||
|
||||
@@ -81,6 +81,7 @@ env["env-extend"] = function(e) { return Object.create(e); };
|
||||
env["env-merge"] = function(a, b) { return Object.assign({}, a, b); };
|
||||
|
||||
// Missing primitives referenced by tests
|
||||
// primitive? is now in platform.py PRIMITIVES
|
||||
env["upcase"] = function(s) { return s.toUpperCase(); };
|
||||
env["downcase"] = function(s) { return s.toLowerCase(); };
|
||||
env["make-keyword"] = function(name) { return new Sx.Keyword(name); };
|
||||
@@ -218,6 +219,19 @@ env["component-has-children"] = function(c) {
|
||||
return c && c.has_children ? c.has_children : false;
|
||||
};
|
||||
|
||||
// Aser test helper: parse SX source, evaluate via aser, return wire format string
|
||||
env["render-sx"] = function(source) {
|
||||
const exprs = Sx.parse(source);
|
||||
const parts = [];
|
||||
for (const expr of exprs) {
|
||||
const result = Sx.renderToSx(expr, env);
|
||||
if (result !== null && result !== undefined && result !== Sx.NIL) {
|
||||
parts.push(typeof result === "string" ? result : Sx.serialize(result));
|
||||
}
|
||||
}
|
||||
return parts.join("");
|
||||
};
|
||||
|
||||
// Platform test functions
|
||||
env["try-call"] = function(thunk) {
|
||||
try {
|
||||
@@ -256,6 +270,7 @@ env["pop-suite"] = function() {
|
||||
// Load test framework
|
||||
const projectDir = path.join(__dirname, "..", "..");
|
||||
const specTests = path.join(projectDir, "spec", "tests");
|
||||
const libTests = path.join(projectDir, "lib", "tests");
|
||||
const webTests = path.join(projectDir, "web", "tests");
|
||||
|
||||
const frameworkSrc = fs.readFileSync(path.join(specTests, "test-framework.sx"), "utf8");
|
||||
@@ -264,33 +279,54 @@ for (const expr of frameworkExprs) {
|
||||
Sx.eval(expr, env);
|
||||
}
|
||||
|
||||
// Load compiler + VM from lib/ when running full tests
|
||||
if (fullBuild) {
|
||||
const libDir = path.join(projectDir, "lib");
|
||||
for (const libFile of ["bytecode.sx", "compiler.sx", "vm.sx"]) {
|
||||
const libPath = path.join(libDir, libFile);
|
||||
if (fs.existsSync(libPath)) {
|
||||
const src = fs.readFileSync(libPath, "utf8");
|
||||
const exprs = Sx.parse(src);
|
||||
for (const expr of exprs) {
|
||||
try { Sx.eval(expr, env); } catch (e) {
|
||||
console.error(`Error loading ${libFile}: ${e.message}`);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
// Determine which tests to run
|
||||
const args = process.argv.slice(2).filter(a => !a.startsWith("--"));
|
||||
let testFiles = [];
|
||||
|
||||
if (args.length > 0) {
|
||||
// Specific test files
|
||||
// Specific test files — search spec, lib, and web test dirs
|
||||
for (const arg of args) {
|
||||
const name = arg.endsWith(".sx") ? arg : `${arg}.sx`;
|
||||
const specPath = path.join(specTests, name);
|
||||
const libPath = path.join(libTests, name);
|
||||
const webPath = path.join(webTests, name);
|
||||
if (fs.existsSync(specPath)) testFiles.push(specPath);
|
||||
else if (fs.existsSync(libPath)) testFiles.push(libPath);
|
||||
else if (fs.existsSync(webPath)) testFiles.push(webPath);
|
||||
else console.error(`Test file not found: ${name}`);
|
||||
}
|
||||
} else {
|
||||
// Tests requiring optional modules (only run with --full)
|
||||
const requiresFull = new Set(["test-continuations.sx", "test-types.sx", "test-freeze.sx"]);
|
||||
// All spec tests
|
||||
// All spec tests (core language — always run)
|
||||
for (const f of fs.readdirSync(specTests).sort()) {
|
||||
if (f.startsWith("test-") && f.endsWith(".sx") && f !== "test-framework.sx") {
|
||||
if (!fullBuild && requiresFull.has(f)) {
|
||||
console.log(`Skipping ${f} (requires --full)`);
|
||||
continue;
|
||||
}
|
||||
testFiles.push(path.join(specTests, f));
|
||||
}
|
||||
}
|
||||
// Library tests (only with --full — require compiler, vm, signals, etc.)
|
||||
if (fullBuild) {
|
||||
for (const f of fs.readdirSync(libTests).sort()) {
|
||||
if (f.startsWith("test-") && f.endsWith(".sx")) {
|
||||
testFiles.push(path.join(libTests, f));
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
// Run tests
|
||||
|
||||
@@ -54,6 +54,8 @@
|
||||
"make-action-def" "makeActionDef"
|
||||
"make-page-def" "makePageDef"
|
||||
"make-symbol" "makeSymbol"
|
||||
"make-env" "makeEnv"
|
||||
"make-sx-expr" "makeSxExpr"
|
||||
"make-keyword" "makeKeyword"
|
||||
"lambda-params" "lambdaParams"
|
||||
"lambda-body" "lambdaBody"
|
||||
@@ -93,6 +95,25 @@
|
||||
"dispose-computed" "disposeComputed"
|
||||
"with-island-scope" "withIslandScope"
|
||||
"register-in-scope" "registerInScope"
|
||||
"*custom-special-forms*" "_customSpecialForms"
|
||||
"register-special-form!" "registerSpecialForm"
|
||||
"*render-check*" "_renderCheck"
|
||||
"*render-fn*" "_renderFn"
|
||||
"is-else-clause?" "isElseClause"
|
||||
"host-global" "hostGlobal"
|
||||
"host-get" "hostGet"
|
||||
"host-set!" "hostSet"
|
||||
"host-call" "hostCall"
|
||||
"host-new" "hostNew"
|
||||
"host-callback" "hostCallback"
|
||||
"host-typeof" "hostTypeof"
|
||||
"host-await" "hostAwait"
|
||||
"dom-document" "domDocument"
|
||||
"dom-window" "domWindow"
|
||||
"dom-head" "domHead"
|
||||
"!=" "notEqual_"
|
||||
"<=" "lte_"
|
||||
">=" "gte_"
|
||||
"*batch-depth*" "_batchDepth"
|
||||
"*batch-queue*" "_batchQueue"
|
||||
"*store-registry*" "_storeRegistry"
|
||||
@@ -144,6 +165,7 @@
|
||||
"aser-special" "aserSpecial"
|
||||
"eval-case-aser" "evalCaseAser"
|
||||
"sx-serialize" "sxSerialize"
|
||||
|
||||
"sx-serialize-dict" "sxSerializeDict"
|
||||
"sx-expr-source" "sxExprSource"
|
||||
"sf-if" "sfIf"
|
||||
@@ -181,7 +203,6 @@
|
||||
"ho-some" "hoSome"
|
||||
"ho-every" "hoEvery"
|
||||
"ho-for-each" "hoForEach"
|
||||
"sf-defstyle" "sfDefstyle"
|
||||
"kf-name" "kfName"
|
||||
"special-form?" "isSpecialForm"
|
||||
"ho-form?" "isHoForm"
|
||||
@@ -402,6 +423,7 @@
|
||||
"bind-preload" "bindPreload"
|
||||
"mark-processed!" "markProcessed"
|
||||
"is-processed?" "isProcessed"
|
||||
"clear-processed!" "clearProcessed"
|
||||
"create-script-clone" "createScriptClone"
|
||||
"sx-render" "sxRender"
|
||||
"sx-process-scripts" "sxProcessScripts"
|
||||
@@ -601,6 +623,9 @@
|
||||
"cond-scheme?" "condScheme_p"
|
||||
"scope-push!" "scopePush"
|
||||
"scope-pop!" "scopePop"
|
||||
"scope-emit!" "scopeEmit"
|
||||
"scope-emitted" "sxEmitted"
|
||||
"scope-peek" "scopePeek"
|
||||
"provide-push!" "providePush"
|
||||
"provide-pop!" "providePop"
|
||||
"context" "sxContext"
|
||||
@@ -907,8 +932,11 @@
|
||||
(let ((head (first expr))
|
||||
(args (rest expr)))
|
||||
(if (not (= (type-of head) "symbol"))
|
||||
;; Data list — not a function call
|
||||
(str "[" (join ", " (map js-expr expr)) "]")
|
||||
(if (= (type-of head) "list")
|
||||
;; Head is a sub-expression (call) — emit as function call: (head)(args)
|
||||
(str "(" (js-expr head) ")(" (join ", " (map js-expr args)) ")")
|
||||
;; Data list — not a function call
|
||||
(str "[" (join ", " (map js-expr expr)) "]"))
|
||||
(let ((op (symbol-name head)))
|
||||
(cond
|
||||
;; fn/lambda
|
||||
@@ -1097,19 +1125,50 @@
|
||||
|
||||
(define js-emit-let
|
||||
(fn (expr)
|
||||
(let ((bindings (nth expr 1))
|
||||
(body (rest (rest expr))))
|
||||
(let ((binding-lines (js-parse-let-bindings bindings))
|
||||
(body-strs (list)))
|
||||
(begin
|
||||
(for-each (fn (b) (append! body-strs (str " " (js-statement b))))
|
||||
(slice body 0 (- (len body) 1)))
|
||||
(append! body-strs (str " return " (js-expr (last body)) ";"))
|
||||
(str "(function() {\n"
|
||||
(join "\n" binding-lines)
|
||||
(if (empty? binding-lines) "" "\n")
|
||||
(join "\n" body-strs)
|
||||
"\n})()"))))))
|
||||
;; Detect named let: (let name ((x init) ...) body...)
|
||||
(if (= (type-of (nth expr 1)) "symbol")
|
||||
(js-emit-named-let expr)
|
||||
(let ((bindings (nth expr 1))
|
||||
(body (rest (rest expr))))
|
||||
(let ((binding-lines (js-parse-let-bindings bindings))
|
||||
(body-strs (list)))
|
||||
(begin
|
||||
(for-each (fn (b) (append! body-strs (str " " (js-statement b))))
|
||||
(slice body 0 (- (len body) 1)))
|
||||
(append! body-strs (str " return " (js-expr (last body)) ";"))
|
||||
(str "(function() {\n"
|
||||
(join "\n" binding-lines)
|
||||
(if (empty? binding-lines) "" "\n")
|
||||
(join "\n" body-strs)
|
||||
"\n})()")))))))
|
||||
|
||||
;; Named let: (let loop-name ((param init) ...) body...)
|
||||
;; Emits a named IIFE: (function loop(p1, p2) { body })(init1, init2)
|
||||
(define js-emit-named-let
|
||||
(fn (expr)
|
||||
(let ((loop-name (symbol-name (nth expr 1)))
|
||||
(bindings (nth expr 2))
|
||||
(body (slice expr 3))
|
||||
(params (list))
|
||||
(inits (list)))
|
||||
;; Parse bindings — Scheme-style ((name val) ...)
|
||||
(for-each
|
||||
(fn (b)
|
||||
(let ((pname (if (= (type-of (first b)) "symbol")
|
||||
(symbol-name (first b))
|
||||
(str (first b)))))
|
||||
(append! params (js-mangle pname))
|
||||
(append! inits (js-expr (nth b 1)))))
|
||||
bindings)
|
||||
;; Emit body statements + return last
|
||||
(let ((body-strs (list))
|
||||
(mangled-name (js-mangle loop-name)))
|
||||
(for-each (fn (b) (append! body-strs (str " " (js-statement b))))
|
||||
(slice body 0 (- (len body) 1)))
|
||||
(append! body-strs (str " return " (js-expr (last body)) ";"))
|
||||
(str "(function " mangled-name "(" (join ", " params) ") {\n"
|
||||
(join "\n" body-strs)
|
||||
"\n})(" (join ", " inits) ")")))))
|
||||
|
||||
(define js-parse-let-bindings
|
||||
(fn (bindings)
|
||||
|
||||
25
hosts/ocaml/Dockerfile
Normal file
25
hosts/ocaml/Dockerfile
Normal file
@@ -0,0 +1,25 @@
|
||||
# OCaml SX kernel build image.
|
||||
#
|
||||
# Produces a statically-linked sx_server binary that can be COPY'd
|
||||
# into any service's Docker image.
|
||||
#
|
||||
# Usage:
|
||||
# docker build -t sx-kernel -f hosts/ocaml/Dockerfile .
|
||||
# docker build --target=export -o hosts/ocaml/_build/export -f hosts/ocaml/Dockerfile .
|
||||
|
||||
FROM ocaml/opam:debian-12-ocaml-5.2 AS build
|
||||
|
||||
USER opam
|
||||
WORKDIR /home/opam/sx
|
||||
|
||||
# Copy only what's needed for the OCaml build
|
||||
COPY --chown=opam:opam hosts/ocaml/dune-project ./
|
||||
COPY --chown=opam:opam hosts/ocaml/lib/ ./lib/
|
||||
COPY --chown=opam:opam hosts/ocaml/bin/ ./bin/
|
||||
|
||||
# Build the server binary
|
||||
RUN eval $(opam env) && dune build bin/sx_server.exe
|
||||
|
||||
# Export stage — just the binary
|
||||
FROM scratch AS export
|
||||
COPY --from=build /home/opam/sx/_build/default/bin/sx_server.exe /sx_server
|
||||
@@ -1,3 +1,3 @@
|
||||
(executables
|
||||
(names run_tests debug_set sx_server)
|
||||
(libraries sx))
|
||||
(names run_tests debug_set sx_server integration_tests)
|
||||
(libraries sx unix))
|
||||
|
||||
521
hosts/ocaml/bin/integration_tests.ml
Normal file
521
hosts/ocaml/bin/integration_tests.ml
Normal file
@@ -0,0 +1,521 @@
|
||||
(** Integration tests — exercises the full rendering pipeline.
|
||||
|
||||
Loads spec files + web adapters into a server-like env, then renders
|
||||
HTML expressions. Catches "Undefined symbol" errors that only surface
|
||||
when the full stack is loaded (not caught by spec unit tests).
|
||||
|
||||
Usage:
|
||||
dune exec bin/integration_tests.exe *)
|
||||
|
||||
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
|
||||
|
||||
let pass_count = ref 0
|
||||
let fail_count = ref 0
|
||||
|
||||
let assert_eq name expected actual =
|
||||
if expected = actual then begin
|
||||
incr pass_count;
|
||||
Printf.printf " PASS: %s\n%!" name
|
||||
end else begin
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: %s\n expected: %s\n got: %s\n%!" name expected actual
|
||||
end
|
||||
|
||||
let assert_contains name needle haystack =
|
||||
let rec find i =
|
||||
if i + String.length needle > String.length haystack then false
|
||||
else if String.sub haystack i (String.length needle) = needle then true
|
||||
else find (i + 1)
|
||||
in
|
||||
if String.length needle > 0 && find 0 then begin
|
||||
incr pass_count;
|
||||
Printf.printf " PASS: %s\n%!" name
|
||||
end else begin
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: %s — expected to contain %S in %S\n%!" name needle haystack
|
||||
end
|
||||
|
||||
let assert_no_error name f =
|
||||
try
|
||||
ignore (f ());
|
||||
incr pass_count;
|
||||
Printf.printf " PASS: %s\n%!" name
|
||||
with
|
||||
| Eval_error msg ->
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: %s — %s\n%!" name msg
|
||||
| exn ->
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: %s — %s\n%!" name (Printexc.to_string exn)
|
||||
|
||||
(* Build a server-like env with rendering support *)
|
||||
let make_integration_env () =
|
||||
let env = make_env () in
|
||||
let bind (n : string) fn =
|
||||
ignore (Sx_types.env_bind env n (NativeFn (n, fn)))
|
||||
in
|
||||
|
||||
Sx_render.setup_render_env env;
|
||||
|
||||
(* HTML tag functions — same as sx_server.ml *)
|
||||
List.iter (fun tag ->
|
||||
ignore (env_bind env tag
|
||||
(NativeFn ("html:" ^ tag, fun args -> List (Symbol tag :: args))))
|
||||
) Sx_render.html_tags;
|
||||
|
||||
(* Platform primitives needed by spec/render.sx and adapters *)
|
||||
bind "make-raw-html" (fun args ->
|
||||
match args with [String s] -> RawHTML s | [v] -> RawHTML (value_to_string v) | _ -> Nil);
|
||||
bind "raw-html-content" (fun args ->
|
||||
match args with [RawHTML s] -> String s | [String s] -> String s | _ -> String "");
|
||||
bind "escape-html" (fun args ->
|
||||
match args with [String s] -> String (Sx_render.escape_html s) | _ -> String "");
|
||||
bind "escape-attr" (fun args ->
|
||||
match args with [String s] -> String (Sx_render.escape_html s) | _ -> String "");
|
||||
bind "escape-string" (fun args ->
|
||||
match args with [String s] -> String (Sx_render.escape_html s) | _ -> String "");
|
||||
bind "is-html-tag?" (fun args ->
|
||||
match args with [String s] -> Bool (Sx_render.is_html_tag s) | _ -> Bool false);
|
||||
bind "is-void-element?" (fun args ->
|
||||
match args with [String s] -> Bool (Sx_render.is_void s) | _ -> Bool false);
|
||||
bind "is-boolean-attr?" (fun args ->
|
||||
match args with [String s] -> Bool (Sx_render.is_boolean_attr s) | _ -> Bool false);
|
||||
|
||||
(* Mutable operations needed by adapter code *)
|
||||
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"));
|
||||
bind "dict-set!" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k; v] -> Hashtbl.replace d k v; v
|
||||
| [Dict d; Keyword k; v] -> Hashtbl.replace d k v; v
|
||||
| _ -> Nil);
|
||||
bind "dict-has?" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k] -> Bool (Hashtbl.mem d k)
|
||||
| [Dict d; Keyword k] -> Bool (Hashtbl.mem d k)
|
||||
| _ -> Bool false);
|
||||
bind "dict-get" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k] -> (match Hashtbl.find_opt d k with Some v -> v | None -> Nil)
|
||||
| [Dict d; Keyword k] -> (match Hashtbl.find_opt d k with Some v -> v | None -> Nil)
|
||||
| _ -> Nil);
|
||||
bind "empty-dict?" (fun args ->
|
||||
match args with
|
||||
| [Dict d] -> Bool (Hashtbl.length d = 0)
|
||||
| _ -> Bool true);
|
||||
bind "mutable-list" (fun _args -> ListRef (ref []));
|
||||
|
||||
(* Symbol/keyword accessors needed by adapter-html.sx *)
|
||||
bind "symbol-name" (fun args ->
|
||||
match args with [Symbol s] -> String s | _ -> raise (Eval_error "symbol-name: expected symbol"));
|
||||
bind "keyword-name" (fun args ->
|
||||
match args with [Keyword k] -> String k | _ -> raise (Eval_error "keyword-name: expected keyword"));
|
||||
bind "make-symbol" (fun args ->
|
||||
match args with [String s] -> Symbol s | _ -> raise (Eval_error "make-symbol: expected string"));
|
||||
bind "make-keyword" (fun args ->
|
||||
match args with [String s] -> Keyword s | _ -> raise (Eval_error "make-keyword: expected string"));
|
||||
|
||||
(* Type predicates needed by adapters *)
|
||||
bind "island?" (fun args -> match args with [Island _] -> Bool true | _ -> Bool false);
|
||||
bind "component?" (fun args -> match args with [Component _] -> Bool true | _ -> Bool false);
|
||||
bind "macro?" (fun args -> match args with [Macro _] -> Bool true | _ -> Bool false);
|
||||
bind "lambda?" (fun args -> match args with [Lambda _] -> Bool true | _ -> Bool false);
|
||||
bind "spread?" (fun args -> match args with [Spread _] -> Bool true | _ -> Bool false);
|
||||
bind "spread-attrs" (fun args ->
|
||||
match args with
|
||||
| [Spread pairs] -> let d = Hashtbl.create 8 in
|
||||
List.iter (fun (k, v) -> Hashtbl.replace d k v) pairs; Dict d
|
||||
| _ -> Nil);
|
||||
bind "component-name" (fun args -> match args with [Component c] -> String c.c_name | [Island i] -> String i.i_name | _ -> Nil);
|
||||
bind "component-params" (fun args -> match args with [Component c] -> List (List.map (fun s -> String s) c.c_params) | _ -> List []);
|
||||
bind "component-body" (fun args -> match args with [Component c] -> c.c_body | _ -> Nil);
|
||||
bind "component-closure" (fun args -> match args with [Component c] -> Env c.c_closure | _ -> 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 "lambda-params" (fun args -> match args with [Lambda l] -> List (List.map (fun s -> String s) l.l_params) | _ -> List []);
|
||||
bind "lambda-body" (fun args -> match args with [Lambda l] -> l.l_body | _ -> Nil);
|
||||
bind "lambda-closure" (fun args -> match args with [Lambda l] -> Env l.l_closure | _ -> Nil);
|
||||
bind "lambda-name" (fun args -> match args with [Lambda l] -> (match l.l_name with Some n -> String n | None -> Nil) | _ -> Nil);
|
||||
bind "set-lambda-name!" (fun args -> match args with [Lambda l; String n] -> l.l_name <- Some n; Nil | _ -> Nil);
|
||||
|
||||
(* Environment operations *)
|
||||
bind "env-extend" (fun args ->
|
||||
match args with [Env e] -> Env (env_extend e) | _ -> Env (env_extend env));
|
||||
bind "env-bind!" (fun args ->
|
||||
match args with [Env e; String k; v] -> env_bind e k v | _ -> Nil);
|
||||
bind "env-set!" (fun args ->
|
||||
match args with [Env e; String k; v] -> env_set e k v | _ -> Nil);
|
||||
bind "env-get" (fun args ->
|
||||
match args with [Env e; String k] -> env_get e k | _ -> Nil);
|
||||
bind "env-has?" (fun args ->
|
||||
match args with [Env e; String k] -> Bool (env_has e k) | _ -> Bool false);
|
||||
bind "env-merge" (fun args ->
|
||||
match args with [Env a; Env b] -> Env (env_merge a b) | _ -> Nil);
|
||||
bind "make-env" (fun _args -> Env (make_env ()));
|
||||
|
||||
(* Eval/trampoline — needed by adapters *)
|
||||
bind "eval-expr" (fun args ->
|
||||
match args with
|
||||
| [expr; e] -> Sx_ref.eval_expr expr e
|
||||
| _ -> Nil);
|
||||
bind "trampoline" (fun args ->
|
||||
match args with
|
||||
| [Thunk (e, env)] -> Sx_ref.eval_expr e (Env env)
|
||||
| [v] -> v | _ -> Nil);
|
||||
bind "call-lambda" (fun args ->
|
||||
match args with
|
||||
| [f; List a] -> Sx_runtime.sx_call f a
|
||||
| [f; a] -> Sx_runtime.sx_call f [a]
|
||||
| _ -> Nil);
|
||||
bind "expand-macro" (fun args ->
|
||||
match args with
|
||||
| [Macro m; List macro_args; _env] ->
|
||||
let local = env_extend m.m_closure in
|
||||
let rec bind_params ps as' = match ps, as' with
|
||||
| [], rest ->
|
||||
(match m.m_rest_param with Some rp -> ignore (env_bind local rp (List rest)) | None -> ())
|
||||
| p :: ps_rest, a :: as_rest ->
|
||||
ignore (env_bind local p a); bind_params ps_rest as_rest
|
||||
| _ :: _, [] -> ()
|
||||
in
|
||||
bind_params m.m_params macro_args;
|
||||
Sx_ref.eval_expr m.m_body (Env local)
|
||||
| _ -> Nil);
|
||||
|
||||
(* Scope/provide — needed by adapter-html.sx and the CEK evaluator.
|
||||
Must be registered as primitives (prim_call) not just env bindings. *)
|
||||
let scope_stacks : (string, value list) Hashtbl.t = Hashtbl.create 8 in
|
||||
let scope_emitted : (string, value list) Hashtbl.t = Hashtbl.create 8 in
|
||||
let scope_push name v =
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
Hashtbl.replace scope_stacks name (v :: stack); Nil in
|
||||
let scope_pop name =
|
||||
(match Hashtbl.find_opt scope_stacks name with
|
||||
| Some (_ :: rest) -> Hashtbl.replace scope_stacks name rest
|
||||
| _ -> ()); Nil in
|
||||
let scope_peek name =
|
||||
match Hashtbl.find_opt scope_stacks name with
|
||||
| Some (v :: _) -> v | _ -> Nil in
|
||||
let scope_emit name v =
|
||||
let items = try Hashtbl.find scope_emitted name with Not_found -> [] in
|
||||
Hashtbl.replace scope_emitted name (items @ [v]); Nil in
|
||||
let emitted name =
|
||||
match Hashtbl.find_opt scope_emitted name with Some l -> List l | None -> List [] in
|
||||
(* Register as both env bindings AND primitives *)
|
||||
bind "scope-push!" (fun args -> match args with [String n; v] -> scope_push n v | _ -> Nil);
|
||||
bind "scope-pop!" (fun args -> match args with [String n] -> scope_pop n | _ -> Nil);
|
||||
bind "scope-peek" (fun args -> match args with [String n] -> scope_peek n | _ -> Nil);
|
||||
bind "scope-emit!" (fun args -> match args with [String n; v] -> scope_emit n v | _ -> Nil);
|
||||
bind "emitted" (fun args -> match args with [String n] -> emitted n | _ -> List []);
|
||||
bind "emit!" (fun args -> match args with [String n; v] -> scope_emit n v | _ -> Nil);
|
||||
bind "scope-emitted" (fun args -> match args with [String n] -> emitted n | _ -> List []);
|
||||
bind "collect!" (fun _args -> Nil);
|
||||
bind "collected" (fun _args -> List []);
|
||||
bind "clear-collected!" (fun _args -> Nil);
|
||||
bind "scope-collected" (fun _args -> List []);
|
||||
bind "scope-clear-collected!" (fun _args -> Nil);
|
||||
bind "provide-push!" (fun args -> match args with [String n; v] -> scope_push n v | _ -> Nil);
|
||||
bind "provide-pop!" (fun args -> match args with [String n] -> scope_pop n | _ -> Nil);
|
||||
bind "context" (fun args -> match args with [String n] -> scope_peek n | [String n; _] -> scope_peek n | _ -> Nil);
|
||||
bind "sx-context" (fun args -> match args with [String n] -> scope_peek n | [String n; _] -> scope_peek n | _ -> Nil);
|
||||
(* Also register as primitives for prim_call *)
|
||||
Sx_primitives.register "scope-push!" (fun args -> match args with [String n; v] -> scope_push n v | _ -> Nil);
|
||||
Sx_primitives.register "scope-pop!" (fun args -> match args with [String n] -> scope_pop n | _ -> Nil);
|
||||
Sx_primitives.register "scope-peek" (fun args -> match args with [String n] -> scope_peek n | _ -> Nil);
|
||||
Sx_primitives.register "scope-emit!" (fun args -> match args with [String n; v] -> scope_emit n v | _ -> Nil);
|
||||
Sx_primitives.register "emitted" (fun args -> match args with [String n] -> emitted n | _ -> List []);
|
||||
Sx_primitives.register "emit!" (fun args -> match args with [String n; v] -> scope_emit n v | _ -> Nil);
|
||||
Sx_primitives.register "scope-emitted" (fun args -> match args with [String n] -> emitted n | _ -> List []);
|
||||
Sx_primitives.register "collect!" (fun _args -> Nil);
|
||||
Sx_primitives.register "collected" (fun _args -> List []);
|
||||
Sx_primitives.register "clear-collected!" (fun _args -> Nil);
|
||||
Sx_primitives.register "scope-collected" (fun _args -> List []);
|
||||
Sx_primitives.register "scope-clear-collected!" (fun _args -> Nil);
|
||||
Sx_primitives.register "provide-push!" (fun args -> match args with [String n; v] -> scope_push n v | _ -> Nil);
|
||||
Sx_primitives.register "provide-pop!" (fun args -> match args with [String n] -> scope_pop n | _ -> Nil);
|
||||
Sx_primitives.register "context" (fun args -> match args with [String n] -> scope_peek n | [String n; _] -> scope_peek n | _ -> Nil);
|
||||
|
||||
(* Render-mode flags *)
|
||||
ignore (env_bind env "*render-active*" (Bool false));
|
||||
bind "set-render-active!" (fun args ->
|
||||
match args with [v] -> ignore (env_set env "*render-active*" v); Nil | _ -> Nil);
|
||||
bind "render-active?" (fun _args ->
|
||||
try env_get env "*render-active*" with _ -> Bool false);
|
||||
bind "definition-form?" (fun args ->
|
||||
match args with
|
||||
| [String s] -> Bool (List.mem s ["define"; "defcomp"; "defisland"; "defmacro";
|
||||
"defstyle"; "defhandler"; "deftype"; "defeffect"; "defquery"; "defaction"; "defrelation"])
|
||||
| _ -> Bool false);
|
||||
|
||||
(* Signal stubs for SSR — overridden when signals.sx is loaded *)
|
||||
bind "signal" (fun args -> match args with [v] -> v | _ -> Nil);
|
||||
bind "computed" (fun args -> match args with [f] -> Sx_runtime.sx_call f [] | _ -> Nil);
|
||||
bind "deref" (fun args -> match args with [v] -> v | _ -> Nil);
|
||||
bind "reset!" (fun _args -> Nil);
|
||||
bind "swap!" (fun _args -> Nil);
|
||||
bind "effect" (fun _args -> Nil);
|
||||
bind "batch" (fun _args -> Nil);
|
||||
|
||||
(* Type predicates — needed by adapter-sx.sx *)
|
||||
bind "callable?" (fun args ->
|
||||
match args with [NativeFn _] | [Lambda _] | [Component _] | [Island _] -> Bool true | _ -> Bool false);
|
||||
bind "lambda?" (fun args -> match args with [Lambda _] -> Bool true | _ -> Bool false);
|
||||
bind "macro?" (fun args -> match args with [Macro _] -> Bool true | _ -> Bool false);
|
||||
bind "island?" (fun args -> match args with [Island _] -> Bool true | _ -> Bool false);
|
||||
bind "component?" (fun args ->
|
||||
match args with [Component _] | [Island _] -> Bool true | _ -> Bool false);
|
||||
bind "spread?" (fun args -> match args with [Spread _] -> Bool true | _ -> Bool false);
|
||||
bind "lambda-params" (fun args ->
|
||||
match args with [Lambda l] -> List (List.map (fun s -> String s) l.l_params) | _ -> List []);
|
||||
bind "lambda-body" (fun args -> match args with [Lambda l] -> l.l_body | _ -> Nil);
|
||||
bind "lambda-closure" (fun args ->
|
||||
match args with [Lambda l] -> Env l.l_closure | _ -> Dict (Hashtbl.create 0));
|
||||
bind "component-name" (fun args ->
|
||||
match args with [Component c] -> String c.c_name | [Island i] -> String i.i_name | _ -> String "");
|
||||
bind "component-closure" (fun args ->
|
||||
match args with [Component c] -> Env c.c_closure | [Island i] -> Env i.i_closure | _ -> Dict (Hashtbl.create 0));
|
||||
bind "component-params" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> List (List.map (fun s -> String s) c.c_params)
|
||||
| [Island i] -> List (List.map (fun s -> String s) i.i_params)
|
||||
| _ -> Nil);
|
||||
bind "component-body" (fun args ->
|
||||
match args with [Component c] -> c.c_body | [Island i] -> i.i_body | _ -> Nil);
|
||||
bind "component-affinity" (fun args ->
|
||||
match args with [Component c] -> String c.c_affinity
|
||||
| [Island _] -> Nil | _ -> Nil);
|
||||
bind "component-has-children?" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> Bool (List.mem "children" c.c_params)
|
||||
| [Island i] -> Bool (List.mem "children" i.i_params)
|
||||
| _ -> Bool false);
|
||||
|
||||
(* Evaluator bridge — needed by adapter-sx.sx *)
|
||||
bind "call-lambda" (fun args ->
|
||||
match args with
|
||||
| [fn_val; List call_args; Env _e] ->
|
||||
Sx_ref.cek_call fn_val (List call_args)
|
||||
| [fn_val; List call_args] ->
|
||||
Sx_ref.cek_call fn_val (List call_args)
|
||||
| _ -> raise (Eval_error "call-lambda: expected (fn args env?)"));
|
||||
bind "cek-call" (fun args ->
|
||||
match args with
|
||||
| [fn_val; List call_args] -> Sx_ref.cek_call fn_val (List call_args)
|
||||
| [fn_val; Nil] -> Sx_ref.cek_call fn_val (List [])
|
||||
| [fn_val] -> Sx_ref.cek_call fn_val (List [])
|
||||
| _ -> Nil);
|
||||
bind "expand-macro" (fun args ->
|
||||
match args with
|
||||
| [Macro m; List macro_args; Env e] ->
|
||||
let body_env = { bindings = Hashtbl.create 16; parent = Some e } in
|
||||
List.iteri (fun i p ->
|
||||
let v = if i < List.length macro_args then List.nth macro_args i else Nil in
|
||||
Hashtbl.replace body_env.bindings p v
|
||||
) m.m_params;
|
||||
Sx_ref.eval_expr m.m_body (Env body_env)
|
||||
| _ -> raise (Eval_error "expand-macro: expected (macro args env)"));
|
||||
bind "eval-expr" (fun args ->
|
||||
match args with
|
||||
| [expr; e] -> Sx_ref.eval_expr expr (Env (Sx_runtime.unwrap_env e))
|
||||
| [expr] -> Sx_ref.eval_expr expr (Env env)
|
||||
| _ -> raise (Eval_error "eval-expr: expected (expr env?)"));
|
||||
bind "trampoline" (fun args ->
|
||||
match args with
|
||||
| [v] ->
|
||||
let rec resolve v = match v with
|
||||
| Thunk (body, closure_env) -> resolve (Sx_ref.eval_expr body (Env closure_env))
|
||||
| _ -> v
|
||||
in resolve v
|
||||
| _ -> raise (Eval_error "trampoline: expected 1 arg"));
|
||||
bind "expand-components?" (fun _args -> Bool false);
|
||||
bind "register-special-form!" (fun args ->
|
||||
match args with
|
||||
| [String name; handler] ->
|
||||
ignore (Sx_ref.register_special_form (String name) handler); Nil
|
||||
| _ -> raise (Eval_error "register-special-form!: expected (name handler)"));
|
||||
ignore (env_bind env "*custom-special-forms*" Sx_ref.custom_special_forms);
|
||||
|
||||
(* DOM stubs *)
|
||||
bind "create-text-node" (fun args -> match args with [String s] -> String s | _ -> Nil);
|
||||
bind "create-fragment" (fun _args -> Nil);
|
||||
bind "dom-create-element" (fun _args -> Nil);
|
||||
bind "dom-append" (fun _args -> Nil);
|
||||
bind "dom-set-attr" (fun _args -> Nil);
|
||||
bind "dom-set-prop" (fun _args -> Nil);
|
||||
bind "dom-get-attr" (fun _args -> Nil);
|
||||
bind "dom-query" (fun _args -> Nil);
|
||||
bind "dom-body" (fun _args -> Nil);
|
||||
|
||||
(* Misc stubs *)
|
||||
bind "random-int" (fun args ->
|
||||
match args with
|
||||
| [Number lo; Number hi] -> Number (lo +. Float.round (Random.float (hi -. lo)))
|
||||
| _ -> Number 0.0);
|
||||
bind "expand-components?" (fun _args -> Bool false);
|
||||
bind "freeze-scope" (fun _args -> Nil);
|
||||
bind "freeze-signal" (fun _args -> Nil);
|
||||
bind "thaw-from-sx" (fun _args -> Nil);
|
||||
bind "local-storage-get" (fun _args -> Nil);
|
||||
bind "local-storage-set" (fun _args -> Nil);
|
||||
bind "schedule-idle" (fun _args -> Nil);
|
||||
bind "run-post-render-hooks" (fun _args -> Nil);
|
||||
bind "freeze-to-sx" (fun _args -> String "");
|
||||
|
||||
env
|
||||
|
||||
|
||||
let () =
|
||||
Printexc.record_backtrace true;
|
||||
|
||||
(* Find project root *)
|
||||
let rec find_root dir =
|
||||
let candidate = Filename.concat dir "spec/render.sx" in
|
||||
if Sys.file_exists candidate then dir
|
||||
else let parent = Filename.dirname dir in
|
||||
if parent = dir then Sys.getcwd () else find_root parent
|
||||
in
|
||||
let root = find_root (Sys.getcwd ()) in
|
||||
let spec p = Filename.concat (Filename.concat root "spec") p in
|
||||
let lib p = Filename.concat (Filename.concat root "lib") p in
|
||||
let web p = Filename.concat (Filename.concat root "web") p in
|
||||
|
||||
let env = make_integration_env () in
|
||||
|
||||
(* Load spec + lib + adapters *)
|
||||
Printf.printf "Loading spec + lib + adapters...\n%!";
|
||||
let load path =
|
||||
if Sys.file_exists path then begin
|
||||
let exprs = Sx_parser.parse_file path in
|
||||
List.iter (fun expr -> ignore (Sx_ref.eval_expr expr (Env env))) exprs;
|
||||
Printf.printf " loaded %s (%d defs)\n%!" (Filename.basename path) (List.length exprs)
|
||||
end else
|
||||
Printf.printf " SKIP %s (not found)\n%!" path
|
||||
in
|
||||
load (spec "parser.sx");
|
||||
load (spec "render.sx");
|
||||
load (web "signals.sx");
|
||||
load (web "adapter-html.sx");
|
||||
load (web "adapter-sx.sx");
|
||||
ignore lib; (* available for future library loading *)
|
||||
|
||||
(* Helper: render SX source string to HTML *)
|
||||
let render_html src =
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let expr = match exprs with [e] -> e | _ -> Nil in
|
||||
Sx_render.render_to_html expr env
|
||||
in
|
||||
|
||||
(* Helper: call SX render-to-html via the adapter *)
|
||||
let sx_render_html src =
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let expr = match exprs with [e] -> e | _ -> Nil in
|
||||
let call = List [Symbol "render-to-html"; List [Symbol "quote"; expr]; Env env] in
|
||||
match Sx_ref.eval_expr call (Env env) with
|
||||
| String s | RawHTML s -> s
|
||||
| v -> value_to_string v
|
||||
in
|
||||
|
||||
(* ================================================================== *)
|
||||
Printf.printf "\nSuite: native renderer — HTML tags\n%!";
|
||||
assert_eq "div" "<div>hello</div>" (render_html "(div \"hello\")");
|
||||
assert_eq "div with class" "<div class=\"card\">text</div>" (render_html "(div :class \"card\" \"text\")");
|
||||
assert_eq "nested tags" "<div><p>inner</p></div>" (render_html "(div (p \"inner\"))");
|
||||
assert_eq "void element" "<br />" (render_html "(br)");
|
||||
assert_eq "h1" "<h1>Title</h1>" (render_html "(h1 \"Title\")");
|
||||
assert_eq "span with attrs" "<span class=\"bold\">text</span>" (render_html "(span :class \"bold\" \"text\")");
|
||||
|
||||
(* ================================================================== *)
|
||||
Printf.printf "\nSuite: SX adapter render-to-html — HTML tags\n%!";
|
||||
assert_no_error "div doesn't throw" (fun () -> sx_render_html "(div \"hello\")");
|
||||
assert_contains "div produces tag" "<div" (sx_render_html "(div \"hello\")");
|
||||
assert_contains "div with class" "class=\"card\"" (sx_render_html "(div :class \"card\" \"text\")");
|
||||
assert_contains "nested tags" "<p>" (sx_render_html "(div (p \"inner\"))");
|
||||
assert_no_error "h1 doesn't throw" (fun () -> sx_render_html "(h1 \"Title\")");
|
||||
assert_no_error "span doesn't throw" (fun () -> sx_render_html "(span :class \"bold\" \"text\")");
|
||||
assert_no_error "table doesn't throw" (fun () -> sx_render_html "(table (tr (td \"cell\")))");
|
||||
|
||||
(* ================================================================== *)
|
||||
Printf.printf "\nSuite: SX adapter — special forms in HTML context\n%!";
|
||||
assert_contains "when true renders" "<p>" (sx_render_html "(when true (p \"yes\"))");
|
||||
assert_eq "when false empty" "" (sx_render_html "(when false (p \"no\"))");
|
||||
assert_contains "if true branch" "yes" (sx_render_html "(if true (span \"yes\") (span \"no\"))");
|
||||
assert_contains "if false branch" "no" (sx_render_html "(if false (span \"yes\") (span \"no\"))");
|
||||
assert_contains "let in render" "hello" (sx_render_html "(let ((x \"hello\")) (p x))");
|
||||
|
||||
(* ================================================================== *)
|
||||
Printf.printf "\nSuite: SX adapter — letrec in HTML context\n%!";
|
||||
assert_no_error "letrec with div body" (fun () ->
|
||||
sx_render_html "(letrec ((x 42)) (div (str x)))");
|
||||
assert_contains "letrec renders body" "<div>" (sx_render_html "(letrec ((x 42)) (div (str x)))");
|
||||
assert_no_error "letrec with side effects then div" (fun () ->
|
||||
sx_render_html "(letrec ((x 1) (y 2)) (let ((z (+ x y))) (div (str z))))");
|
||||
|
||||
(* ================================================================== *)
|
||||
Printf.printf "\nSuite: SX adapter — components\n%!";
|
||||
(try
|
||||
assert_no_error "defcomp + render" (fun () ->
|
||||
ignore (Sx_ref.eval_expr
|
||||
(List.hd (Sx_parser.parse_all "(defcomp ~test-card (&key title &rest children) (div :class \"card\" (h2 title) children))"))
|
||||
(Env env));
|
||||
sx_render_html "(~test-card :title \"Hi\" (p \"body\"))");
|
||||
assert_contains "component renders div" "<div" (sx_render_html "(~test-card :title \"Hi\" (p \"body\"))");
|
||||
assert_contains "component renders title" "Hi" (sx_render_html "(~test-card :title \"Hi\" (p \"body\"))")
|
||||
with Eval_error msg -> incr fail_count; Printf.printf " FAIL: components — %s\n%!" msg);
|
||||
|
||||
(* ================================================================== *)
|
||||
Printf.printf "\nSuite: eval-expr with HTML tag functions\n%!";
|
||||
assert_no_error "eval (div) returns list" (fun () ->
|
||||
Sx_ref.eval_expr (List [Symbol "div"; Keyword "class"; String "foo"; String "hi"]) (Env env));
|
||||
assert_no_error "eval (span) returns list" (fun () ->
|
||||
Sx_ref.eval_expr (List [Symbol "span"; String "text"]) (Env env));
|
||||
|
||||
(* ================================================================== *)
|
||||
(* Regression: call-lambda re-evaluated Dict args through eval_expr,
|
||||
which copies dicts. Mutations inside the lambda (e.g. signal
|
||||
reset!) operated on the copy, not the original. This broke
|
||||
island SSR where aser processes multi-body let forms. *)
|
||||
Printf.printf "\nSuite: call-lambda dict identity (aser mode)\n%!";
|
||||
let aser_eval src =
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let expr = match exprs with [e] -> e | _ -> Nil in
|
||||
let call = List [Symbol "aser"; List [Symbol "quote"; expr]; Env env] in
|
||||
match Sx_ref.eval_expr call (Env env) with
|
||||
| String s | SxExpr s -> s
|
||||
| v -> value_to_string v
|
||||
in
|
||||
assert_eq "lambda dict mutation in aser multi-body let"
|
||||
"99"
|
||||
(aser_eval
|
||||
"(let ((mutate! (fn (d k v) (dict-set! d k v)))
|
||||
(d (dict \"x\" 1)))
|
||||
(mutate! d \"x\" 99)
|
||||
(get d \"x\"))");
|
||||
assert_eq "signal reset! in aser multi-body let"
|
||||
"99"
|
||||
(aser_eval
|
||||
"(let ((s (signal 42)))
|
||||
(reset! s 99)
|
||||
(deref s))");
|
||||
assert_eq "signal reset! then len of deref"
|
||||
"3"
|
||||
(aser_eval
|
||||
"(let ((s (signal (list))))
|
||||
(reset! s (list 1 2 3))
|
||||
(len (deref s)))");
|
||||
|
||||
(* ================================================================== *)
|
||||
Printf.printf "\n";
|
||||
Printf.printf "============================================================\n";
|
||||
Printf.printf "Integration: %d passed, %d failed\n" !pass_count !fail_count;
|
||||
Printf.printf "============================================================\n";
|
||||
if !fail_count > 0 then exit 1
|
||||
@@ -177,38 +177,44 @@ let make_test_env () =
|
||||
|
||||
(* --- Environment operations --- *)
|
||||
|
||||
(* Env operations — accept both Env and Dict *)
|
||||
let uw = Sx_runtime.unwrap_env in
|
||||
bind "env-get" (fun args ->
|
||||
match args with
|
||||
| [Env e; String k] -> Sx_types.env_get e k
|
||||
| [Env e; Keyword k] -> Sx_types.env_get e k
|
||||
| [e; String k] -> Sx_types.env_get (uw e) k
|
||||
| [e; Keyword k] -> Sx_types.env_get (uw e) k
|
||||
| _ -> raise (Eval_error "env-get: expected env and string"));
|
||||
|
||||
bind "env-has?" (fun args ->
|
||||
match args with
|
||||
| [Env e; String k] -> Bool (Sx_types.env_has e k)
|
||||
| [Env e; Keyword k] -> Bool (Sx_types.env_has e k)
|
||||
| [e; String k] -> Bool (Sx_types.env_has (uw e) k)
|
||||
| [e; Keyword k] -> Bool (Sx_types.env_has (uw e) k)
|
||||
| _ -> raise (Eval_error "env-has?: expected env and string"));
|
||||
|
||||
bind "env-bind!" (fun args ->
|
||||
match args with
|
||||
| [Env e; String k; v] -> Sx_types.env_bind e k v
|
||||
| [Env e; Keyword k; v] -> Sx_types.env_bind e k v
|
||||
| [e; String k; v] ->
|
||||
let ue = uw e in
|
||||
if k = "x" || k = "children" || k = "i" then
|
||||
Printf.eprintf "[env-bind!] '%s' env-id=%d bindings-before=%d\n%!" k (Obj.obj (Obj.repr ue) : int) (Hashtbl.length ue.Sx_types.bindings);
|
||||
Sx_types.env_bind ue k v
|
||||
| [e; Keyword k; v] -> Sx_types.env_bind (uw 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] -> Sx_types.env_set e k v
|
||||
| [Env e; Keyword k; v] -> Sx_types.env_set e k v
|
||||
| [e; String k; v] -> Sx_types.env_set (uw e) k v
|
||||
| [e; Keyword k; v] -> Sx_types.env_set (uw e) k v
|
||||
| _ -> raise (Eval_error "env-set!: expected env, key, value"));
|
||||
|
||||
bind "env-extend" (fun args ->
|
||||
match args with
|
||||
| [Env e] -> Env (Sx_types.env_extend e)
|
||||
| [e] -> Env (Sx_types.env_extend (uw e))
|
||||
| _ -> raise (Eval_error "env-extend: expected env"));
|
||||
|
||||
bind "env-merge" (fun args ->
|
||||
match args with
|
||||
| [Env a; Env b] -> Env (Sx_types.env_merge a b)
|
||||
| [a; b] -> Sx_runtime.env_merge a b
|
||||
| _ -> raise (Eval_error "env-merge: expected 2 envs"));
|
||||
|
||||
(* --- Equality --- *)
|
||||
@@ -269,6 +275,93 @@ let make_test_env () =
|
||||
(* --- HTML Renderer (from sx_render.ml library module) --- *)
|
||||
Sx.Sx_render.setup_render_env env;
|
||||
|
||||
(* Stubs needed by adapter-html.sx when loaded at test time *)
|
||||
bind "set-render-active!" (fun _args -> Nil);
|
||||
bind "render-active?" (fun _args -> Bool true);
|
||||
bind "trampoline" (fun args ->
|
||||
match args with
|
||||
| [Thunk (expr, e)] -> eval_expr expr (Env e)
|
||||
| [v] -> v
|
||||
| _ -> Nil);
|
||||
bind "eval-expr" (fun args ->
|
||||
match args with
|
||||
| [expr; e] ->
|
||||
let ue = Sx_runtime.unwrap_env e in
|
||||
eval_expr expr (Env ue)
|
||||
| [expr] -> eval_expr expr (Env env)
|
||||
| _ -> raise (Eval_error "eval-expr: expected (expr env)"));
|
||||
(* Scope primitives — use a local scope stacks table.
|
||||
Must match the same pattern as sx_server.ml's _scope_stacks. *)
|
||||
let _scope_stacks : (string, Sx_types.value list) Hashtbl.t = Hashtbl.create 8 in
|
||||
bind "scope-push!" (fun args ->
|
||||
match args with
|
||||
| [String name; value] ->
|
||||
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
||||
Hashtbl.replace _scope_stacks name (value :: stack); Nil
|
||||
| [String name] ->
|
||||
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
||||
Hashtbl.replace _scope_stacks name (Nil :: stack); Nil
|
||||
| _ -> Nil);
|
||||
bind "scope-pop!" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
||||
(match stack with _ :: rest -> Hashtbl.replace _scope_stacks name rest | [] -> ()); Nil
|
||||
| _ -> Nil);
|
||||
bind "scope-emit!" (fun args ->
|
||||
match args with
|
||||
| [String name; value] ->
|
||||
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
||||
(match stack with
|
||||
| List items :: rest ->
|
||||
Hashtbl.replace _scope_stacks name (List (items @ [value]) :: rest)
|
||||
| _ :: rest ->
|
||||
Hashtbl.replace _scope_stacks name (List [value] :: rest)
|
||||
| [] ->
|
||||
Hashtbl.replace _scope_stacks name [List [value]]);
|
||||
Nil
|
||||
| _ -> Nil);
|
||||
bind "emitted" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
||||
(match stack with List items :: _ -> List items | _ -> List [])
|
||||
| _ -> List []);
|
||||
bind "scope-emitted" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
||||
(match stack with List items :: _ -> List items | _ -> List [])
|
||||
| _ -> List []);
|
||||
bind "provide-push!" (fun args ->
|
||||
match args with
|
||||
| [String name; value] ->
|
||||
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
||||
Hashtbl.replace _scope_stacks name (value :: stack); Nil
|
||||
| _ -> Nil);
|
||||
bind "provide-pop!" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
|
||||
(match stack with _ :: rest -> Hashtbl.replace _scope_stacks name rest | [] -> ()); Nil
|
||||
| _ -> Nil);
|
||||
bind "cond-scheme?" (fun args ->
|
||||
match args with
|
||||
| [(List clauses | ListRef { contents = clauses })] ->
|
||||
(match clauses with
|
||||
| (List _ | ListRef _) :: _ -> Bool true
|
||||
| _ -> Bool false)
|
||||
| _ -> Bool false);
|
||||
bind "expand-macro" (fun args ->
|
||||
match args with
|
||||
| [Macro m; (List a | ListRef { contents = a }); _] ->
|
||||
let local = Sx_types.env_extend m.m_closure in
|
||||
List.iteri (fun i p ->
|
||||
ignore (Sx_types.env_bind local p (if i < List.length a then List.nth a i else Nil))
|
||||
) m.m_params;
|
||||
eval_expr m.m_body (Env local)
|
||||
| _ -> raise (Eval_error "expand-macro: expected (macro args env)"));
|
||||
|
||||
(* --- Missing primitives referenced by tests --- *)
|
||||
|
||||
bind "upcase" (fun args ->
|
||||
@@ -372,21 +465,25 @@ let make_test_env () =
|
||||
bind "component-params" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> List (List.map (fun s -> String s) c.c_params)
|
||||
| [Island i] -> List (List.map (fun s -> String s) i.i_params)
|
||||
| _ -> Nil);
|
||||
|
||||
bind "component-body" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> c.c_body
|
||||
| [Island i] -> i.i_body
|
||||
| _ -> Nil);
|
||||
|
||||
bind "component-has-children" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> Bool c.c_has_children
|
||||
| [Island i] -> Bool i.i_has_children
|
||||
| _ -> Bool false);
|
||||
|
||||
bind "component-affinity" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> String c.c_affinity
|
||||
| [Island _] -> String "client"
|
||||
| _ -> String "auto");
|
||||
|
||||
(* --- Parser test helpers --- *)
|
||||
@@ -591,7 +688,7 @@ let run_foundation_tests () =
|
||||
assert_true "sx_truthy \"\"" (Bool (sx_truthy (String "")));
|
||||
assert_eq "not truthy nil" (Bool false) (Bool (sx_truthy Nil));
|
||||
assert_eq "not truthy false" (Bool false) (Bool (sx_truthy (Bool false)));
|
||||
let l = { l_params = ["x"]; l_body = Symbol "x"; l_closure = Sx_types.make_env (); l_name = None } in
|
||||
let l = { l_params = ["x"]; l_body = Symbol "x"; l_closure = Sx_types.make_env (); l_name = None; l_compiled = None } in
|
||||
assert_true "is_lambda" (Bool (Sx_types.is_lambda (Lambda l)));
|
||||
ignore (Sx_types.set_lambda_name (Lambda l) "my-fn");
|
||||
assert_eq "lambda name mutated" (String "my-fn") (lambda_name (Lambda l))
|
||||
@@ -637,28 +734,60 @@ let run_spec_tests env test_files =
|
||||
Printf.printf "\nLoading test framework...\n%!";
|
||||
load_and_eval framework_path;
|
||||
|
||||
(* Determine test files *)
|
||||
(* Load modules needed by tests *)
|
||||
let spec_dir = Filename.concat project_dir "spec" in
|
||||
let lib_dir = Filename.concat project_dir "lib" in
|
||||
let web_dir = Filename.concat project_dir "web" in
|
||||
let load_module name dir =
|
||||
let path = Filename.concat dir name in
|
||||
if Sys.file_exists path then begin
|
||||
Printf.printf "Loading %s...\n%!" name;
|
||||
(try load_and_eval path
|
||||
with e -> Printf.eprintf "Warning: %s: %s\n%!" name (Printexc.to_string e))
|
||||
end
|
||||
in
|
||||
(* Render adapter for test-render-html.sx *)
|
||||
load_module "render.sx" spec_dir;
|
||||
load_module "adapter-html.sx" web_dir;
|
||||
(* Library modules for lib/tests/ *)
|
||||
load_module "bytecode.sx" lib_dir;
|
||||
load_module "compiler.sx" lib_dir;
|
||||
load_module "vm.sx" lib_dir;
|
||||
load_module "signals.sx" web_dir;
|
||||
load_module "freeze.sx" lib_dir;
|
||||
load_module "content.sx" lib_dir;
|
||||
load_module "types.sx" lib_dir;
|
||||
|
||||
(* Determine test files — scan spec/tests/ and lib/tests/ *)
|
||||
let lib_tests_dir = Filename.concat project_dir "lib/tests" in
|
||||
let files = if test_files = [] then begin
|
||||
let entries = Sys.readdir spec_tests_dir in
|
||||
Array.sort String.compare entries;
|
||||
let requires_full = ["test-continuations.sx"; "test-types.sx"; "test-freeze.sx";
|
||||
"test-continuations-advanced.sx"; "test-signals-advanced.sx"] in
|
||||
Array.to_list entries
|
||||
|> List.filter (fun f ->
|
||||
String.length f > 5 &&
|
||||
String.sub f 0 5 = "test-" &&
|
||||
Filename.check_suffix f ".sx" &&
|
||||
f <> "test-framework.sx" &&
|
||||
not (List.mem f requires_full))
|
||||
(* Spec tests (core language — always run) *)
|
||||
let spec_entries = Sys.readdir spec_tests_dir in
|
||||
Array.sort String.compare spec_entries;
|
||||
let spec_files = Array.to_list spec_entries
|
||||
|> List.filter (fun f ->
|
||||
String.length f > 5 &&
|
||||
String.sub f 0 5 = "test-" &&
|
||||
Filename.check_suffix f ".sx" &&
|
||||
f <> "test-framework.sx")
|
||||
|> List.map (fun f -> Filename.concat spec_tests_dir f)
|
||||
in
|
||||
spec_files
|
||||
end else
|
||||
(* Specific test files — search all test dirs *)
|
||||
List.map (fun name ->
|
||||
if Filename.check_suffix name ".sx" then name
|
||||
else name ^ ".sx") test_files
|
||||
let name = if Filename.check_suffix name ".sx" then name else name ^ ".sx" in
|
||||
let spec_path = Filename.concat spec_tests_dir name in
|
||||
let lib_path = Filename.concat lib_tests_dir name in
|
||||
if Sys.file_exists spec_path then spec_path
|
||||
else if Sys.file_exists lib_path then lib_path
|
||||
else Filename.concat spec_tests_dir name (* will fail with "not found" *)
|
||||
) test_files
|
||||
in
|
||||
|
||||
List.iter (fun name ->
|
||||
let path = Filename.concat spec_tests_dir name in
|
||||
List.iter (fun path ->
|
||||
if Sys.file_exists path then begin
|
||||
let name = Filename.basename path in
|
||||
Printf.printf "\n%s\n" (String.make 60 '=');
|
||||
Printf.printf "Running %s\n" name;
|
||||
Printf.printf "%s\n%!" (String.make 60 '=');
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -43,16 +43,38 @@ PREAMBLE = """\
|
||||
open Sx_types
|
||||
open Sx_runtime
|
||||
|
||||
(* Trampoline — evaluates thunks via the CEK machine.
|
||||
eval_expr is defined in the transpiled block below. *)
|
||||
let trampoline v = v (* CEK machine doesn't produce thunks *)
|
||||
(* Trampoline — forward ref, resolved after eval_expr is defined. *)
|
||||
let trampoline_fn : (value -> value) ref = ref (fun v -> v)
|
||||
let trampoline v = !trampoline_fn v
|
||||
|
||||
|
||||
|
||||
(* === Mutable state for strict mode === *)
|
||||
(* These are defined as top-level refs because the transpiler cannot handle
|
||||
global set! mutation (it creates local refs that shadow the global). *)
|
||||
let _strict_ref = ref (Bool false)
|
||||
let _prim_param_types_ref = ref Nil
|
||||
|
||||
(* JIT call hook — cek_call checks this before CEK dispatch for named
|
||||
lambdas. Registered by sx_server.ml after compiler loads. Tests
|
||||
run with hook = None (pure CEK, no compilation dependency). *)
|
||||
let jit_call_hook : (value -> value list -> value option) option ref = ref None
|
||||
|
||||
"""
|
||||
|
||||
|
||||
# OCaml fixups — override iterative CEK run
|
||||
# OCaml fixups — wire up trampoline + iterative CEK run + JIT hook
|
||||
FIXUPS = """\
|
||||
|
||||
(* Wire up trampoline to resolve thunks via the CEK machine *)
|
||||
let () = trampoline_fn := (fun v ->
|
||||
match v with
|
||||
| Thunk (expr, env) -> eval_expr expr (Env env)
|
||||
| _ -> v)
|
||||
|
||||
(* Wire up the primitives trampoline so call_any in HO forms resolves Thunks *)
|
||||
let () = Sx_primitives._sx_trampoline_fn := !trampoline_fn
|
||||
|
||||
(* Override recursive cek_run with iterative loop *)
|
||||
let cek_run_iterative state =
|
||||
let s = ref state in
|
||||
@@ -61,25 +83,28 @@ let cek_run_iterative state =
|
||||
done;
|
||||
cek_value !s
|
||||
|
||||
|
||||
|
||||
"""
|
||||
|
||||
|
||||
def compile_spec_to_ml(spec_dir: str | None = None) -> str:
|
||||
"""Compile the SX spec to OCaml source."""
|
||||
from shared.sx.ref.sx_ref import eval_expr, trampoline, make_env, sx_parse
|
||||
import tempfile
|
||||
from shared.sx.ocaml_sync import OcamlSync
|
||||
from shared.sx.parser import serialize
|
||||
|
||||
if spec_dir is None:
|
||||
spec_dir = os.path.join(_PROJECT, "spec")
|
||||
|
||||
# Load the transpiler
|
||||
env = make_env()
|
||||
# Load the transpiler into OCaml kernel
|
||||
bridge = OcamlSync()
|
||||
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))
|
||||
bridge.load(transpiler_path)
|
||||
|
||||
# Spec files to transpile (in dependency order)
|
||||
# stdlib.sx functions are already registered as OCaml primitives —
|
||||
# only the evaluator needs transpilation.
|
||||
sx_files = [
|
||||
("evaluator.sx", "evaluator (frames + eval + CEK)"),
|
||||
]
|
||||
@@ -96,8 +121,14 @@ 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 already-registered primitives
|
||||
# Skip: preamble-provided, math primitives, and stdlib functions
|
||||
# that use loop/named-let (transpiler can't handle those yet)
|
||||
skip = {"trampoline", "ceil", "floor", "round", "abs", "min", "max",
|
||||
"debug-log", "debug_log", "range", "chunk-every", "zip-pairs",
|
||||
"string-contains?", "starts-with?", "ends-with?",
|
||||
"string-replace", "trim", "split", "index-of",
|
||||
"pad-left", "pad-right", "char-at", "substring"}
|
||||
defines = [(n, e) for n, e in defines if n not in skip]
|
||||
|
||||
# Deduplicate — keep last definition for each name (CEK overrides tree-walk)
|
||||
@@ -106,23 +137,118 @@ def compile_spec_to_ml(spec_dir: str | None = None) -> str:
|
||||
seen[n] = i
|
||||
defines = [(n, e) for i, (n, e) in enumerate(defines) if seen[n] == i]
|
||||
|
||||
# Build the defines list for the transpiler
|
||||
# Build the defines list and known names for the transpiler
|
||||
defines_list = [[name, expr] for name, expr in defines]
|
||||
env["_defines"] = defines_list
|
||||
known_names = [name for name, _ in defines]
|
||||
|
||||
# Pass known define names so the transpiler can distinguish
|
||||
# static (OCaml fn) calls from dynamic (SX value) calls
|
||||
env["_known_defines"] = [name for name, _ in defines]
|
||||
# Serialize defines + known names to temp file, load into kernel
|
||||
defines_sx = serialize(defines_list)
|
||||
known_sx = serialize(known_names)
|
||||
with tempfile.NamedTemporaryFile(mode="w", suffix=".sx", delete=False) as tmp:
|
||||
tmp.write(f"(define _defines \'{defines_sx})\n")
|
||||
tmp.write(f"(define _known_defines \'{known_sx})\n")
|
||||
tmp_path = tmp.name
|
||||
try:
|
||||
bridge.load(tmp_path)
|
||||
finally:
|
||||
os.unlink(tmp_path)
|
||||
|
||||
# Call ml-translate-file — emits as single let rec block
|
||||
translate_expr = sx_parse("(ml-translate-file _defines)")[0]
|
||||
result = trampoline(eval_expr(translate_expr, env))
|
||||
result = bridge.eval("(ml-translate-file _defines)")
|
||||
|
||||
parts.append(f"\n(* === Transpiled from {label} === *)\n")
|
||||
parts.append(result)
|
||||
|
||||
bridge.stop()
|
||||
parts.append(FIXUPS)
|
||||
return "\n".join(parts)
|
||||
output = "\n".join(parts)
|
||||
|
||||
# Post-process: fix mutable globals that the transpiler can't handle.
|
||||
# The transpiler emits local refs for set! targets within functions,
|
||||
# but top-level globals (*strict*, *prim-param-types*) need to use
|
||||
# the pre-declared refs from the preamble.
|
||||
import re
|
||||
|
||||
# Fix *strict*: use _strict_ref instead of immutable let rec binding
|
||||
output = re.sub(
|
||||
r'and _strict_ =\n \(Bool false\)',
|
||||
'and _strict_ = !_strict_ref',
|
||||
output,
|
||||
)
|
||||
# Fix set-strict!: use _strict_ref instead of local ref
|
||||
output = re.sub(
|
||||
r'and set_strict_b val\' =\n let _strict_ = ref Nil in \(_strict_ := val\'; Nil\)',
|
||||
"and set_strict_b val' =\n _strict_ref := val'; Nil",
|
||||
output,
|
||||
)
|
||||
# Fix *prim-param-types*: use _prim_param_types_ref
|
||||
output = re.sub(
|
||||
r'and _prim_param_types_ =\n Nil',
|
||||
'and _prim_param_types_ = !_prim_param_types_ref',
|
||||
output,
|
||||
)
|
||||
# Fix set-prim-param-types!: use _prim_param_types_ref
|
||||
output = re.sub(
|
||||
r'and set_prim_param_types_b types =\n let _prim_param_types_ = ref Nil in \(_prim_param_types_ := types; Nil\)',
|
||||
"and set_prim_param_types_b types =\n _prim_param_types_ref := types; Nil",
|
||||
output,
|
||||
)
|
||||
|
||||
# Fix all runtime reads of _strict_ and _prim_param_types_ to deref
|
||||
# the mutable refs instead of using the stale let-rec bindings.
|
||||
# This is needed because let-rec value bindings capture initial values.
|
||||
# Use regex with word boundary to avoid replacing _strict_ref with
|
||||
# !_strict_refref.
|
||||
def fix_mutable_reads(text):
|
||||
lines = text.split('\n')
|
||||
fixed = []
|
||||
for line in lines:
|
||||
# Skip the definition lines
|
||||
stripped = line.strip()
|
||||
if stripped.startswith('and _strict_ =') or stripped.startswith('and _prim_param_types_ ='):
|
||||
fixed.append(line)
|
||||
continue
|
||||
# Replace _strict_ as a standalone identifier only (not inside
|
||||
# other names like set_strict_b). Match when preceded by space,
|
||||
# paren, or start-of-line, and followed by space, paren, or ;.
|
||||
line = re.sub(r'(?<=[ (])_strict_(?=[ );])', '!_strict_ref', line)
|
||||
line = re.sub(r'(?<=[ (])_prim_param_types_(?=[ );])', '!_prim_param_types_ref', line)
|
||||
fixed.append(line)
|
||||
return '\n'.join(fixed)
|
||||
output = fix_mutable_reads(output)
|
||||
|
||||
# Fix cek_call: the spec passes (make-env) as the env arg to
|
||||
# continue_with_call, but the transpiler evaluates make-env at
|
||||
# transpile time (it's a primitive), producing Dict instead of Env.
|
||||
output = output.replace(
|
||||
"((Dict (Hashtbl.create 0))) (a) ((List []))",
|
||||
"(Env (Sx_types.make_env ())) (a) ((List []))",
|
||||
)
|
||||
|
||||
# Inject JIT dispatch into continue_with_call's lambda branch.
|
||||
# After params are bound, check jit_call_hook before creating CEK state.
|
||||
lambda_body_pattern = (
|
||||
'(prim_call "slice" [params; (len (args))])); Nil)) in '
|
||||
'(make_cek_state ((lambda_body (f))) (local) (kont))'
|
||||
)
|
||||
lambda_body_jit = (
|
||||
'(prim_call "slice" [params; (len (args))])); Nil)) in '
|
||||
'(match !jit_call_hook, f with '
|
||||
'| Some hook, Lambda l when l.l_name <> None -> '
|
||||
'let args_list = match args with '
|
||||
'List a | ListRef { contents = a } -> a | _ -> [] in '
|
||||
'(match hook f args_list with '
|
||||
'Some result -> make_cek_value result local kont '
|
||||
'| None -> make_cek_state (lambda_body f) local kont) '
|
||||
'| _ -> make_cek_state ((lambda_body (f))) (local) (kont))'
|
||||
)
|
||||
if lambda_body_pattern in output:
|
||||
output = output.replace(lambda_body_pattern, lambda_body_jit, 1)
|
||||
else:
|
||||
import sys
|
||||
print("WARNING: Could not find lambda body pattern for JIT injection", file=sys.stderr)
|
||||
|
||||
return output
|
||||
|
||||
|
||||
def main():
|
||||
|
||||
18
hosts/ocaml/browser/test_page_render.js
Normal file
18
hosts/ocaml/browser/test_page_render.js
Normal file
@@ -0,0 +1,18 @@
|
||||
const path = require("path");
|
||||
const fs = require("fs");
|
||||
require(path.join(__dirname, "../_build/default/browser/sx_browser.bc.js"));
|
||||
require(path.join(__dirname, "sx-platform.js"));
|
||||
const K = globalThis.SxKernel;
|
||||
for (const n of ["signals","deps","page-helpers","router","adapter-html"])
|
||||
K.loadSource(fs.readFileSync(path.join(__dirname,`../../../web/${n}.sx`),"utf8"));
|
||||
K.loadSource(fs.readFileSync("/tmp/comp_defs.txt","utf8"));
|
||||
|
||||
const pageSx = fs.readFileSync("/tmp/page_sx.txt","utf8");
|
||||
const parsed = K.parse(pageSx);
|
||||
const html = K.renderToHtml(parsed[0]);
|
||||
if (typeof html === "string" && !html.startsWith("Error:")) {
|
||||
console.log("SUCCESS! Rendered", html.length, "chars of HTML");
|
||||
console.log("Preview:", html.substring(0, 200));
|
||||
} else {
|
||||
console.log("Error:", html);
|
||||
}
|
||||
25
hosts/ocaml/browser/test_signals.js
Normal file
25
hosts/ocaml/browser/test_signals.js
Normal file
@@ -0,0 +1,25 @@
|
||||
const path = require("path");
|
||||
const fs = require("fs");
|
||||
require(path.join(__dirname, "../_build/default/browser/sx_browser.bc.js"));
|
||||
require(path.join(__dirname, "sx-platform.js"));
|
||||
const K = globalThis.SxKernel;
|
||||
for (const n of ["signals","deps","page-helpers","router","adapter-html"])
|
||||
K.loadSource(fs.readFileSync(path.join(__dirname,`../../../web/${n}.sx`),"utf8"));
|
||||
|
||||
// Test signal basics
|
||||
const tests = [
|
||||
'(signal 42)',
|
||||
'(let ((s (signal 42))) (deref s))',
|
||||
'(let ((s (signal 42))) (reset! s 100) (deref s))',
|
||||
'(let ((s (signal 10))) (swap! s (fn (v) (* v 2))) (deref s))',
|
||||
'(let ((s (signal 0))) (computed (fn () (+ (deref s) 1))))',
|
||||
'(let ((idx (signal 0))) (let ((c (computed (fn () (+ (deref idx) 10))))) (deref c)))',
|
||||
];
|
||||
|
||||
for (const t of tests) {
|
||||
const r = K.eval(t);
|
||||
const s = JSON.stringify(r);
|
||||
console.log(`${t.substring(0,60)}`);
|
||||
console.log(` => ${s && s.length > 100 ? s.substring(0,100) + '...' : s}`);
|
||||
console.log();
|
||||
}
|
||||
@@ -30,10 +30,21 @@ let skip_whitespace_and_comments s =
|
||||
| _ -> ()
|
||||
in go ()
|
||||
|
||||
let is_symbol_char = function
|
||||
| '(' | ')' | '[' | ']' | '{' | '}' | '"' | '\'' | '`'
|
||||
| ' ' | '\t' | '\n' | '\r' | ',' | ';' -> false
|
||||
| _ -> true
|
||||
(* Character classification — matches spec/parser.sx ident-start/ident-char.
|
||||
ident-start: a-z A-Z _ ~ * + - > < = / ! ? &
|
||||
ident-char: ident-start plus 0-9 . : / # , *)
|
||||
let is_ident_start = function
|
||||
| 'a'..'z' | 'A'..'Z' | '_' | '~' | '*' | '+' | '-'
|
||||
| '>' | '<' | '=' | '/' | '!' | '?' | '&' -> true
|
||||
| _ -> false
|
||||
|
||||
let is_ident_char = function
|
||||
| c when is_ident_start c -> true
|
||||
| '0'..'9' | '.' | ':' | '#' | ',' -> true
|
||||
| _ -> false
|
||||
|
||||
(* Symbol reading uses ident_char; first char must be ident_start or digit/colon *)
|
||||
let is_symbol_char = is_ident_char
|
||||
|
||||
let read_string s =
|
||||
(* s.pos is on the opening quote *)
|
||||
@@ -116,20 +127,16 @@ let rec read_value s : value =
|
||||
go ()
|
||||
end
|
||||
in go ()
|
||||
| '~' when s.pos + 1 < s.len && s.src.[s.pos + 1] = '@' ->
|
||||
advance s; advance s; (* skip ~@ *)
|
||||
List [Symbol "splice-unquote"; read_value s]
|
||||
| _ ->
|
||||
(* Check for unquote: , followed by non-whitespace *)
|
||||
if s.src.[s.pos] = ',' && s.pos + 1 < s.len &&
|
||||
s.src.[s.pos + 1] <> ' ' && s.src.[s.pos + 1] <> '\n' then begin
|
||||
| ',' ->
|
||||
(* Unquote / splice-unquote — matches spec: , always triggers unquote *)
|
||||
advance s;
|
||||
if s.pos < s.len && s.src.[s.pos] = '@' then begin
|
||||
advance s;
|
||||
if s.pos < s.len && s.src.[s.pos] = '@' then begin
|
||||
advance s;
|
||||
List [Symbol "splice-unquote"; read_value s]
|
||||
end else
|
||||
List [Symbol "unquote"; read_value s]
|
||||
end else begin
|
||||
List [Symbol "splice-unquote"; read_value s]
|
||||
end else
|
||||
List [Symbol "unquote"; read_value s]
|
||||
| _ ->
|
||||
begin
|
||||
(* Symbol, keyword, number, or boolean *)
|
||||
let token = read_symbol s in
|
||||
if token = "" then raise (Parse_error ("Unexpected char: " ^ String.make 1 s.src.[s.pos]));
|
||||
|
||||
@@ -7,6 +7,12 @@ open Sx_types
|
||||
|
||||
let primitives : (string, value list -> value) Hashtbl.t = Hashtbl.create 128
|
||||
|
||||
(** Forward refs for calling SX functions from primitives (breaks cycle). *)
|
||||
let _sx_call_fn : (value -> value list -> value) ref =
|
||||
ref (fun _ _ -> raise (Eval_error "sx_call not initialized"))
|
||||
let _sx_trampoline_fn : (value -> value) ref =
|
||||
ref (fun v -> v)
|
||||
|
||||
let register name fn = Hashtbl.replace primitives name fn
|
||||
|
||||
let is_primitive name = Hashtbl.mem primitives name
|
||||
@@ -24,16 +30,17 @@ let as_number = function
|
||||
| Bool false -> 0.0
|
||||
| Nil -> 0.0
|
||||
| String s -> (match float_of_string_opt s with Some n -> n | None -> Float.nan)
|
||||
| v -> raise (Eval_error ("Expected number, got " ^ type_of v))
|
||||
| v -> raise (Eval_error ("Expected number, got " ^ type_of v ^ ": " ^ (match v with Dict d -> (match Hashtbl.find_opt d "__signal" with Some _ -> "signal{value=" ^ (match Hashtbl.find_opt d "value" with Some v' -> value_to_string v' | None -> "?") ^ "}" | None -> "dict") | _ -> "")))
|
||||
|
||||
let as_string = function
|
||||
| String s -> s
|
||||
| v -> raise (Eval_error ("Expected string, got " ^ type_of v))
|
||||
|
||||
let as_list = function
|
||||
let rec as_list = function
|
||||
| List l -> l
|
||||
| ListRef r -> !r
|
||||
| Nil -> []
|
||||
| Thunk _ as t -> as_list (!_sx_trampoline_fn t)
|
||||
| v -> raise (Eval_error ("Expected list, got " ^ type_of v))
|
||||
|
||||
let as_bool = function
|
||||
@@ -78,10 +85,10 @@ let () =
|
||||
register "abs" (fun args ->
|
||||
match args with [a] -> Number (Float.abs (as_number a)) | _ -> raise (Eval_error "abs: 1 arg"));
|
||||
register "floor" (fun args ->
|
||||
match args with [a] -> Number (Float.of_int (int_of_float (Float.round (as_number a -. 0.5))))
|
||||
match args with [a] -> Number (floor (as_number a))
|
||||
| _ -> raise (Eval_error "floor: 1 arg"));
|
||||
register "ceil" (fun args ->
|
||||
match args with [a] -> Number (Float.of_int (int_of_float (Float.round (as_number a +. 0.5))))
|
||||
match args with [a] -> Number (ceil (as_number a))
|
||||
| _ -> raise (Eval_error "ceil: 1 arg"));
|
||||
register "round" (fun args ->
|
||||
match args with
|
||||
@@ -113,7 +120,10 @@ let () =
|
||||
register "parse-int" (fun args ->
|
||||
match args with
|
||||
| [String s] -> (match int_of_string_opt s with Some n -> Number (float_of_int n) | None -> Nil)
|
||||
| [Number n] -> Number (float_of_int (int_of_float n))
|
||||
| [String s; default_val] ->
|
||||
(match int_of_string_opt s with Some n -> Number (float_of_int n) | None -> default_val)
|
||||
| [Number n] | [Number n; _] -> Number (float_of_int (int_of_float n))
|
||||
| [_; default_val] -> default_val
|
||||
| _ -> Nil);
|
||||
register "parse-float" (fun args ->
|
||||
match args with
|
||||
@@ -273,8 +283,17 @@ let () =
|
||||
String (String.concat sep (List.map to_string items))
|
||||
| _ -> raise (Eval_error "join: 2 args"));
|
||||
register "replace" (fun args ->
|
||||
let to_str = function
|
||||
| String s -> s | SxExpr s -> s | RawHTML s -> s
|
||||
| Keyword k -> k | Symbol s -> s
|
||||
| Nil -> "" | Bool true -> "true" | Bool false -> "false"
|
||||
| Number n -> if Float.is_integer n then string_of_int (int_of_float n) else Printf.sprintf "%g" n
|
||||
| Thunk _ as t -> (match !_sx_trampoline_fn t with String s -> s | v -> to_string v)
|
||||
| v -> to_string v
|
||||
in
|
||||
match args with
|
||||
| [String s; String old_s; String new_s] ->
|
||||
| [s; old_s; new_s] ->
|
||||
let s = to_str s and old_s = to_str old_s and new_s = to_str new_s in
|
||||
let ol = String.length old_s in
|
||||
if ol = 0 then String s
|
||||
else begin
|
||||
@@ -307,8 +326,16 @@ let () =
|
||||
| [List l] | [ListRef { contents = l }] -> Number (float_of_int (List.length l))
|
||||
| [String s] -> Number (float_of_int (String.length s))
|
||||
| [Dict d] -> Number (float_of_int (Hashtbl.length d))
|
||||
| [Nil] -> Number 0.0
|
||||
| _ -> raise (Eval_error "len: 1 arg"));
|
||||
| [Nil] | [Bool false] -> Number 0.0
|
||||
| [Bool true] -> Number 1.0
|
||||
| [Number _] -> Number 1.0
|
||||
| [RawHTML s] -> Number (float_of_int (String.length s))
|
||||
| [SxExpr s] -> Number (float_of_int (String.length s))
|
||||
| [Spread pairs] -> Number (float_of_int (List.length pairs))
|
||||
| [Component _] | [Island _] | [Lambda _] | [NativeFn _]
|
||||
| [Macro _] | [Thunk _] | [Keyword _] | [Symbol _] -> Number 0.0
|
||||
| _ -> raise (Eval_error (Printf.sprintf "len: %d args"
|
||||
(List.length args))));
|
||||
register "first" (fun args ->
|
||||
match args with
|
||||
| [List (x :: _)] | [ListRef { contents = x :: _ }] -> x
|
||||
@@ -324,19 +351,36 @@ let () =
|
||||
| [List l] | [ListRef { contents = l }] ->
|
||||
(match List.rev l with x :: _ -> x | [] -> Nil)
|
||||
| _ -> raise (Eval_error "last: 1 list arg"));
|
||||
register "init" (fun args ->
|
||||
match args with
|
||||
| [List l] | [ListRef { contents = l }] ->
|
||||
(match List.rev l with _ :: rest -> List (List.rev rest) | [] -> List [])
|
||||
| _ -> raise (Eval_error "init: 1 list arg"));
|
||||
register "nth" (fun args ->
|
||||
match args with
|
||||
| [List l; Number n] | [ListRef { contents = l }; Number n] ->
|
||||
(try List.nth l (int_of_float n) with _ -> Nil)
|
||||
| _ -> raise (Eval_error "nth: list and number"));
|
||||
| [String s; Number n] ->
|
||||
let i = int_of_float n in
|
||||
if i >= 0 && i < String.length s then String (String.make 1 s.[i])
|
||||
else Nil
|
||||
| _ -> raise (Eval_error "nth: list/string and number"));
|
||||
register "cons" (fun args ->
|
||||
match args with
|
||||
| [x; List l] | [x; ListRef { contents = l }] -> List (x :: l)
|
||||
| [x; Nil] -> List [x]
|
||||
| _ -> raise (Eval_error "cons: value and list"));
|
||||
register "append" (fun args ->
|
||||
let all = List.concat_map (fun a -> as_list a) args in
|
||||
List all);
|
||||
match args with
|
||||
| [List la | ListRef { contents = la }; List lb | ListRef { contents = lb }] ->
|
||||
List (la @ lb)
|
||||
| [List la | ListRef { contents = la }; Nil] -> List la
|
||||
| [Nil; List lb | ListRef { contents = lb }] -> List lb
|
||||
| [List la | ListRef { contents = la }; v] -> List (la @ [v])
|
||||
| [v; List lb | ListRef { contents = lb }] -> List ([v] @ lb)
|
||||
| _ ->
|
||||
let all = List.concat_map as_list args in
|
||||
List all);
|
||||
register "reverse" (fun args ->
|
||||
match args with
|
||||
| [List l] | [ListRef { contents = l }] -> List (List.rev l)
|
||||
@@ -490,7 +534,9 @@ let () =
|
||||
| [Dict d; Keyword k] -> dict_get d k
|
||||
| [List l; Number n] | [ListRef { contents = l }; Number n] ->
|
||||
(try List.nth l (int_of_float n) with _ -> Nil)
|
||||
| _ -> raise (Eval_error "get: dict+key or list+index"));
|
||||
| [Nil; _] -> Nil (* nil.anything → nil *)
|
||||
| [_; _] -> Nil (* type mismatch → nil (matches JS/Python behavior) *)
|
||||
| _ -> Nil);
|
||||
register "has-key?" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k] -> Bool (dict_has d k)
|
||||
@@ -525,6 +571,17 @@ let () =
|
||||
match args with [Dict d] -> List (dict_keys d) | _ -> raise (Eval_error "keys: 1 dict"));
|
||||
register "vals" (fun args ->
|
||||
match args with [Dict d] -> List (dict_vals d) | _ -> raise (Eval_error "vals: 1 dict"));
|
||||
register "mutable-list" (fun _args -> ListRef (ref []));
|
||||
register "set-nth!" (fun args ->
|
||||
match args with
|
||||
| [ListRef r; Number n; v] ->
|
||||
let i = int_of_float n in
|
||||
let l = !r in
|
||||
r := List.mapi (fun j x -> if j = i then v else x) l;
|
||||
Nil
|
||||
| [List _; _; _] ->
|
||||
raise (Eval_error "set-nth!: list is immutable, use ListRef")
|
||||
| _ -> raise (Eval_error "set-nth!: expected (list idx val)"));
|
||||
register "dict-set!" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k; v] -> dict_set d k v; v
|
||||
@@ -549,13 +606,22 @@ let () =
|
||||
match args with [a] -> String (type_of a) | _ -> raise (Eval_error "type-of: 1 arg"));
|
||||
register "inspect" (fun args ->
|
||||
match args with [a] -> String (inspect a) | _ -> raise (Eval_error "inspect: 1 arg"));
|
||||
register "serialize" (fun args ->
|
||||
match args with
|
||||
| [a] -> String (inspect a) (* used for dedup keys in compiler *)
|
||||
| _ -> raise (Eval_error "serialize: 1 arg"));
|
||||
register "make-symbol" (fun args ->
|
||||
match args with
|
||||
| [String s] -> Symbol s
|
||||
| _ -> raise (Eval_error "make-symbol: expected string"));
|
||||
register "error" (fun args ->
|
||||
match args with [String msg] -> raise (Eval_error msg)
|
||||
| [a] -> raise (Eval_error (to_string a))
|
||||
| _ -> raise (Eval_error "error: 1 arg"));
|
||||
register "apply" (fun args ->
|
||||
match args with
|
||||
| [NativeFn (_, f); List a] -> f a
|
||||
| [NativeFn (_, f); (List a | ListRef { contents = a })] -> f a
|
||||
| [NativeFn (_, f); Nil] -> f []
|
||||
| _ -> raise (Eval_error "apply: function and list"));
|
||||
register "identical?" (fun args ->
|
||||
match args with [a; b] -> Bool (a == b) | _ -> raise (Eval_error "identical?: 2 args"));
|
||||
@@ -575,4 +641,173 @@ let () =
|
||||
List.iter (fun (k, v) -> dict_set d k v) pairs;
|
||||
Dict d
|
||||
| _ -> raise (Eval_error "spread-attrs: 1 spread"));
|
||||
|
||||
(* Higher-order forms as callable primitives — used by the VM.
|
||||
The CEK machine handles these as special forms with dedicated frames;
|
||||
the VM needs them as plain callable values. *)
|
||||
(* Call any SX callable — handles NativeFn, Lambda (via trampoline), VM closures *)
|
||||
let call_any f args =
|
||||
match f with
|
||||
| NativeFn (_, fn) -> fn args
|
||||
| _ -> !_sx_trampoline_fn (!_sx_call_fn f args)
|
||||
in
|
||||
register "map" (fun args ->
|
||||
match args with
|
||||
| [f; (List items | ListRef { contents = items })] ->
|
||||
List (List.map (fun x -> call_any f [x]) items)
|
||||
| [_; Nil] -> List []
|
||||
| _ -> raise (Eval_error "map: expected (fn list)"));
|
||||
register "map-indexed" (fun args ->
|
||||
match args with
|
||||
| [f; (List items | ListRef { contents = items })] ->
|
||||
List (List.mapi (fun i x -> call_any f [Number (float_of_int i); x]) items)
|
||||
| [_; Nil] -> List []
|
||||
| _ -> raise (Eval_error "map-indexed: expected (fn list)"));
|
||||
register "filter" (fun args ->
|
||||
match args with
|
||||
| [f; (List items | ListRef { contents = items })] ->
|
||||
List (List.filter (fun x -> sx_truthy (call_any f [x])) items)
|
||||
| [_; Nil] -> List []
|
||||
| _ -> raise (Eval_error "filter: expected (fn list)"));
|
||||
register "for-each" (fun args ->
|
||||
match args with
|
||||
| [f; (List items | ListRef { contents = items })] ->
|
||||
List.iter (fun x -> ignore (call_any f [x])) items; Nil
|
||||
| [_; Nil] -> Nil (* nil collection = no-op *)
|
||||
| _ ->
|
||||
let types = String.concat ", " (List.map (fun v -> type_of v) args) in
|
||||
raise (Eval_error (Printf.sprintf "for-each: expected (fn list), got (%s) %d args" types (List.length args))));
|
||||
register "reduce" (fun args ->
|
||||
match args with
|
||||
| [f; init; (List items | ListRef { contents = items })] ->
|
||||
List.fold_left (fun acc x -> call_any f [acc; x]) init items
|
||||
| _ -> raise (Eval_error "reduce: expected (fn init list)"));
|
||||
register "some" (fun args ->
|
||||
match args with
|
||||
| [f; (List items | ListRef { contents = items })] ->
|
||||
(try List.find (fun x -> sx_truthy (call_any f [x])) items
|
||||
with Not_found -> Bool false)
|
||||
| [_; Nil] -> Bool false
|
||||
| _ -> raise (Eval_error "some: expected (fn list)"));
|
||||
register "every?" (fun args ->
|
||||
match args with
|
||||
| [f; (List items | ListRef { contents = items })] ->
|
||||
Bool (List.for_all (fun x -> sx_truthy (call_any f [x])) items)
|
||||
| [_; Nil] -> Bool true
|
||||
| _ -> raise (Eval_error "every?: expected (fn list)"));
|
||||
|
||||
(* ---- VM stack primitives (vm.sx platform interface) ---- *)
|
||||
register "make-vm-stack" (fun args ->
|
||||
match args with
|
||||
| [Number n] -> ListRef (ref (List.init (int_of_float n) (fun _ -> Nil)))
|
||||
| _ -> raise (Eval_error "make-vm-stack: expected (size)"));
|
||||
register "vm-stack-get" (fun args ->
|
||||
match args with
|
||||
| [ListRef r; Number n] -> List.nth !r (int_of_float n)
|
||||
| _ -> raise (Eval_error "vm-stack-get: expected (stack idx)"));
|
||||
register "vm-stack-set!" (fun args ->
|
||||
match args with
|
||||
| [ListRef r; Number n; v] ->
|
||||
let i = int_of_float n in
|
||||
r := List.mapi (fun j x -> if j = i then v else x) !r; Nil
|
||||
| _ -> raise (Eval_error "vm-stack-set!: expected (stack idx val)"));
|
||||
register "vm-stack-length" (fun args ->
|
||||
match args with
|
||||
| [ListRef r] -> Number (float_of_int (List.length !r))
|
||||
| _ -> raise (Eval_error "vm-stack-length: expected (stack)"));
|
||||
register "vm-stack-copy!" (fun args ->
|
||||
match args with
|
||||
| [ListRef src; ListRef dst; Number n] ->
|
||||
let count = int_of_float n in
|
||||
let src_items = !src in
|
||||
dst := List.mapi (fun i x -> if i < count then List.nth src_items i else x) !dst; Nil
|
||||
| _ -> raise (Eval_error "vm-stack-copy!: expected (src dst count)"));
|
||||
register "primitive?" (fun args ->
|
||||
match args with
|
||||
| [String name] -> Bool (Hashtbl.mem primitives name)
|
||||
| _ -> Bool false);
|
||||
|
||||
(* Scope stack primitives are registered by sx_server.ml / run_tests.ml
|
||||
because they use a shared scope stacks table with collect!/collected. *)
|
||||
|
||||
(* ---- Predicates needed by adapter-html.sx ---- *)
|
||||
register "lambda?" (fun args ->
|
||||
match args with [Lambda _] -> Bool true | _ -> Bool false);
|
||||
register "island?" (fun args ->
|
||||
match args with [Island _] -> Bool true | _ -> Bool false);
|
||||
register "is-else-clause?" (fun args ->
|
||||
match args with
|
||||
| [Keyword "else"] -> Bool true
|
||||
| [Bool true] -> Bool true
|
||||
| _ -> Bool false);
|
||||
register "component?" (fun args ->
|
||||
match args with [Component _] -> Bool true | [Island _] -> Bool true | _ -> Bool false);
|
||||
register "lambda-closure" (fun args ->
|
||||
match args with [Lambda l] -> Env l.l_closure | _ -> Nil);
|
||||
register "component-closure" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> Env c.c_closure
|
||||
| [Island i] -> Env i.i_closure
|
||||
| _ -> Nil);
|
||||
register "component-has-children?" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> Bool c.c_has_children
|
||||
| [Island i] -> Bool i.i_has_children
|
||||
| _ -> Bool false);
|
||||
register "component-name" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> String c.c_name
|
||||
| [Island i] -> String i.i_name
|
||||
| _ -> Nil);
|
||||
register "component-params" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> List (List.map (fun s -> String s) c.c_params)
|
||||
| [Island i] -> List (List.map (fun s -> String s) i.i_params)
|
||||
| _ -> List []);
|
||||
register "component-body" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> c.c_body
|
||||
| [Island i] -> i.i_body
|
||||
| _ -> Nil);
|
||||
register "macro?" (fun args ->
|
||||
match args with [Macro _] -> Bool true | _ -> Bool false);
|
||||
register "for-each-indexed" (fun args ->
|
||||
match args with
|
||||
| [f; (List items | ListRef { contents = items })] ->
|
||||
List.iteri (fun i x -> ignore (call_any f [Number (float_of_int i); x])) items; Nil
|
||||
| _ -> raise (Eval_error "for-each-indexed: expected (fn list)"));
|
||||
register "lambda-params" (fun args ->
|
||||
match args with
|
||||
| [Lambda l] -> List (List.map (fun s -> String s) l.l_params)
|
||||
| _ -> List []);
|
||||
register "lambda-body" (fun args ->
|
||||
match args with [Lambda l] -> l.l_body | _ -> Nil);
|
||||
(* expand-macro is registered later by run_tests.ml / sx_server.ml
|
||||
because it needs eval_expr which creates a dependency cycle *);
|
||||
register "empty-dict?" (fun args ->
|
||||
match args with
|
||||
| [Dict d] -> Bool (Hashtbl.length d = 0)
|
||||
| _ -> Bool true);
|
||||
register "make-raw-html" (fun args ->
|
||||
match args with [String s] -> RawHTML s | _ -> Nil);
|
||||
register "raw-html-content" (fun args ->
|
||||
match args with [RawHTML s] -> String s | _ -> String "");
|
||||
register "get-primitive" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
(match Hashtbl.find_opt primitives name with
|
||||
| Some fn -> NativeFn (name, fn)
|
||||
| None -> raise (Eval_error ("VM undefined: " ^ name)))
|
||||
| _ -> raise (Eval_error "get-primitive: expected (name)"));
|
||||
register "call-primitive" (fun args ->
|
||||
match args with
|
||||
| [String name; (List a | ListRef { contents = a })] ->
|
||||
(match Hashtbl.find_opt primitives name with
|
||||
| Some fn -> fn a
|
||||
| None -> raise (Eval_error ("VM undefined: " ^ name)))
|
||||
| [String name; Nil] ->
|
||||
(match Hashtbl.find_opt primitives name with
|
||||
| Some fn -> fn []
|
||||
| None -> raise (Eval_error ("VM undefined: " ^ name)))
|
||||
| _ -> raise (Eval_error "call-primitive: expected (name args-list)"));
|
||||
()
|
||||
|
||||
File diff suppressed because one or more lines are too long
@@ -205,6 +205,12 @@ and render_list_to_html head args env =
|
||||
match head with
|
||||
| Symbol "<>" ->
|
||||
render_children args env
|
||||
| Symbol "raw!" ->
|
||||
(* Inject pre-rendered HTML without escaping *)
|
||||
let v = Sx_ref.eval_expr (List.hd args) (Env env) in
|
||||
(match v with
|
||||
| String s | RawHTML s -> s
|
||||
| _ -> value_to_string v)
|
||||
| Symbol tag when is_html_tag tag ->
|
||||
render_html_element tag args env
|
||||
| Symbol "if" ->
|
||||
@@ -249,7 +255,23 @@ and render_list_to_html head args env =
|
||||
(try
|
||||
let v = env_get env name in
|
||||
(match v with
|
||||
| Component c when c.c_affinity = "client" -> "" (* skip client-only *)
|
||||
| Component _ -> render_component v args env
|
||||
| Island _i ->
|
||||
(* Islands: SSR via the SX render-to-html from adapter-html.sx.
|
||||
It handles deref/signal/computed through the CEK correctly,
|
||||
and renders island bodies with hydration markers. *)
|
||||
(try
|
||||
let call_expr = List (Symbol name :: args) in
|
||||
let quoted = List [Symbol "quote"; call_expr] in
|
||||
let render_call = List [Symbol "render-to-html"; quoted; Env env] in
|
||||
let result = Sx_ref.eval_expr render_call (Env env) in
|
||||
(match result with
|
||||
| String s | RawHTML s -> s
|
||||
| _ -> value_to_string result)
|
||||
with e ->
|
||||
Printf.eprintf "[ssr-island] ~%s FAILED: %s\n%s\n%!" _i.i_name (Printexc.to_string e) (Printexc.get_backtrace ());
|
||||
"")
|
||||
| Macro m ->
|
||||
let expanded = expand_macro m args env in
|
||||
do_render_to_html expanded env
|
||||
|
||||
@@ -43,15 +43,19 @@ let sx_to_list = function
|
||||
let sx_call f args =
|
||||
match f with
|
||||
| NativeFn (_, fn) -> fn args
|
||||
| VmClosure cl -> !Sx_types._vm_call_closure_ref cl args
|
||||
| Lambda l ->
|
||||
let local = Sx_types.env_extend l.l_closure in
|
||||
List.iter2 (fun p a -> ignore (Sx_types.env_bind local p a)) l.l_params args;
|
||||
(* Return the body + env for the trampoline to evaluate *)
|
||||
Thunk (l.l_body, local)
|
||||
| Continuation (k, _) ->
|
||||
k (match args with x :: _ -> x | [] -> Nil)
|
||||
| _ -> raise (Eval_error ("Not callable: " ^ inspect f))
|
||||
|
||||
(* Initialize forward ref so primitives can call SX functions *)
|
||||
let () = Sx_primitives._sx_call_fn := sx_call
|
||||
(* Trampoline ref is set by sx_ref.ml after it's loaded *)
|
||||
|
||||
(** Apply a function to a list of args. *)
|
||||
let sx_apply f args_list =
|
||||
sx_call f (sx_to_list args_list)
|
||||
@@ -74,11 +78,33 @@ let sx_dict_set_b d k v =
|
||||
(** Get from dict or list. *)
|
||||
let get_val container key =
|
||||
match container, key with
|
||||
| CekState s, String k ->
|
||||
(match k with
|
||||
| "control" -> s.cs_control | "env" -> s.cs_env
|
||||
| "kont" -> s.cs_kont | "phase" -> String s.cs_phase
|
||||
| "value" -> s.cs_value | _ -> Nil)
|
||||
| CekFrame f, String k ->
|
||||
(match k with
|
||||
| "type" -> String f.cf_type | "env" -> f.cf_env
|
||||
| "name" -> f.cf_name | "body" -> f.cf_body
|
||||
| "remaining" -> f.cf_remaining | "f" -> f.cf_f
|
||||
| "args" -> f.cf_args | "evaled" -> f.cf_args
|
||||
| "results" -> f.cf_results | "raw-args" -> f.cf_results
|
||||
| "then" -> f.cf_body | "else" -> f.cf_name
|
||||
| "ho-type" -> f.cf_extra | "scheme" -> f.cf_extra
|
||||
| "indexed" -> f.cf_extra | "value" -> f.cf_extra
|
||||
| "phase" -> f.cf_extra | "has-effects" -> f.cf_extra
|
||||
| "match-val" -> f.cf_extra | "current-item" -> f.cf_extra
|
||||
| "update-fn" -> f.cf_extra | "head-name" -> f.cf_extra
|
||||
| "emitted" -> f.cf_extra2 | "effect-list" -> f.cf_extra2
|
||||
| "first-render" -> f.cf_extra2
|
||||
| _ -> Nil)
|
||||
| Dict d, String k -> dict_get d k
|
||||
| Dict d, Keyword k -> dict_get d k
|
||||
| (List l | ListRef { contents = l }), Number n ->
|
||||
(try List.nth l (int_of_float n) with _ -> Nil)
|
||||
| _ -> raise (Eval_error ("get: unsupported " ^ type_of container ^ " / " ^ type_of key))
|
||||
| Nil, _ -> Nil (* nil.anything → nil *)
|
||||
| _, _ -> Nil (* type mismatch → nil (matches JS/Python behavior) *)
|
||||
|
||||
(** Register get as a primitive override — transpiled code calls (get d k). *)
|
||||
let () =
|
||||
@@ -216,7 +242,15 @@ let type_of v = String (Sx_types.type_of v)
|
||||
The transpiled CEK machine stores envs in dicts as Env values. *)
|
||||
let unwrap_env = function
|
||||
| Env e -> e
|
||||
| _ -> raise (Eval_error "Expected env")
|
||||
| Dict d ->
|
||||
(* Dict used as env — wrap it. Needed by adapter-html.sx which
|
||||
passes dicts as env args (e.g. empty {} as caller env). *)
|
||||
let e = Sx_types.make_env () in
|
||||
Hashtbl.iter (fun k v -> ignore (Sx_types.env_bind e k v)) d;
|
||||
e
|
||||
| Nil ->
|
||||
Sx_types.make_env ()
|
||||
| v -> raise (Eval_error ("Expected env, got " ^ Sx_types.type_of v))
|
||||
|
||||
let env_has e name = Bool (Sx_types.env_has (unwrap_env e) (value_to_str name))
|
||||
let env_get e name = Sx_types.env_get (unwrap_env e) (value_to_str name)
|
||||
@@ -291,19 +325,40 @@ let dynamic_wind_call before body after _env =
|
||||
ignore (sx_call after []);
|
||||
result
|
||||
|
||||
(* Scope stack stubs — delegated to primitives when available *)
|
||||
let scope_push name value = prim_call "collect!" [name; value]
|
||||
let scope_pop _name = Nil
|
||||
let provide_push name value = ignore name; ignore value; Nil
|
||||
let provide_pop _name = Nil
|
||||
(* Scope stack — all delegated to primitives registered in sx_server.ml *)
|
||||
let scope_push name value = prim_call "scope-push!" [name; value]
|
||||
let scope_pop name = prim_call "scope-pop!" [name]
|
||||
let scope_peek name = prim_call "scope-peek" [name]
|
||||
let scope_emit name value = prim_call "scope-emit!" [name; value]
|
||||
let provide_push name value = prim_call "scope-push!" [name; value]
|
||||
let provide_pop name = prim_call "scope-pop!" [name]
|
||||
|
||||
(* Render mode stubs *)
|
||||
let render_active_p () = Bool false
|
||||
let render_expr _expr _env = Nil
|
||||
let is_render_expr _expr = Bool false
|
||||
(* Custom special forms registry — mutable dict *)
|
||||
let custom_special_forms = Dict (Hashtbl.create 4)
|
||||
|
||||
(* register-special-form! — add a handler to the custom registry *)
|
||||
let register_special_form name handler =
|
||||
(match custom_special_forms with
|
||||
| Dict tbl -> Hashtbl.replace tbl (value_to_str name) handler; handler
|
||||
| _ -> raise (Eval_error "custom_special_forms not a dict"))
|
||||
|
||||
(* Render check/fn hooks — nil by default, set by platform if needed *)
|
||||
let render_check = Nil
|
||||
let render_fn = Nil
|
||||
|
||||
(* is-else-clause? — check if a cond/case test is an else marker *)
|
||||
let is_else_clause v =
|
||||
match v with
|
||||
| Keyword k -> Bool (k = "else" || k = "default")
|
||||
| Symbol s -> Bool (s = "else" || s = "default")
|
||||
| Bool true -> Bool true
|
||||
| _ -> Bool false
|
||||
|
||||
(* Signal accessors *)
|
||||
let signal_value s = match s with Signal sig' -> sig'.s_value | _ -> raise (Eval_error "not a signal")
|
||||
let signal_value s = match s with
|
||||
| Signal sig' -> sig'.s_value
|
||||
| Dict d -> (match Hashtbl.find_opt d "value" with Some v -> v | None -> Nil)
|
||||
| _ -> raise (Eval_error "not a signal")
|
||||
let signal_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
|
||||
@@ -314,8 +369,12 @@ 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 ()
|
||||
(* Island scope stubs — accept both bare OCaml fns and NativeFn values
|
||||
from transpiled code (NativeFn wrapping for value-storable lambdas). *)
|
||||
let with_island_scope _register_fn body_fn =
|
||||
match body_fn with
|
||||
| NativeFn (_, f) -> f []
|
||||
| _ -> Nil
|
||||
let register_in_scope _dispose_fn = Nil
|
||||
|
||||
(* Component type annotation stub *)
|
||||
@@ -354,3 +413,7 @@ let strip_prefix s prefix =
|
||||
then String (String.sub s pl (String.length s - pl))
|
||||
else String s
|
||||
| _ -> s
|
||||
|
||||
(* debug_log — no-op in production, used by CEK evaluator for component warnings *)
|
||||
let debug_log _ _ = Nil
|
||||
|
||||
|
||||
154
hosts/ocaml/lib/sx_scope.ml
Normal file
154
hosts/ocaml/lib/sx_scope.ml
Normal file
@@ -0,0 +1,154 @@
|
||||
(** Scope stacks — dynamic scope for render-time effects.
|
||||
|
||||
Provides scope-push!/pop!/peek, collect!/collected/clear-collected!,
|
||||
scope-emit!/emitted/scope-emitted, context, and cookie access.
|
||||
|
||||
All functions are registered as primitives so both the CEK evaluator
|
||||
and the JIT VM can find them in the same place. *)
|
||||
|
||||
open Sx_types
|
||||
|
||||
(** The shared scope stacks hashtable. Each key maps to a stack of values.
|
||||
Used by aser for spread/provide/emit patterns, CSSX collect/flush, etc. *)
|
||||
let scope_stacks : (string, value list) Hashtbl.t = Hashtbl.create 8
|
||||
|
||||
(** Request cookies — set by the Python bridge before each render.
|
||||
get-cookie reads from here; set-cookie is a no-op on the server. *)
|
||||
let request_cookies : (string, string) Hashtbl.t = Hashtbl.create 8
|
||||
|
||||
(** Clear all scope stacks. Called between requests if needed. *)
|
||||
let clear_all () = Hashtbl.clear scope_stacks
|
||||
|
||||
let () =
|
||||
let register = Sx_primitives.register in
|
||||
|
||||
(* --- Cookies --- *)
|
||||
|
||||
register "get-cookie" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
(match Hashtbl.find_opt request_cookies name with
|
||||
| Some v -> String v
|
||||
| None -> Nil)
|
||||
| _ -> Nil);
|
||||
|
||||
register "set-cookie" (fun _args -> Nil);
|
||||
|
||||
(* --- Core scope stack operations --- *)
|
||||
|
||||
register "scope-push!" (fun args ->
|
||||
match args with
|
||||
| [String name; value] ->
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
Hashtbl.replace scope_stacks name (value :: stack); Nil
|
||||
| _ -> Nil);
|
||||
|
||||
register "scope-pop!" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
(match stack with _ :: rest -> Hashtbl.replace scope_stacks name rest | [] -> ()); Nil
|
||||
| _ -> Nil);
|
||||
|
||||
register "scope-peek" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
(match stack with v :: _ -> v | [] -> Nil)
|
||||
| _ -> Nil);
|
||||
|
||||
(* --- Context (scope lookup with optional default) --- *)
|
||||
|
||||
register "context" (fun args ->
|
||||
match args with
|
||||
| [String name] | [String name; _] ->
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
(match stack, args with
|
||||
| v :: _, _ -> v
|
||||
| [], [_; default_val] -> default_val
|
||||
| [], _ -> Nil)
|
||||
| _ -> Nil);
|
||||
|
||||
(* --- Collect / collected / clear-collected! --- *)
|
||||
|
||||
register "collect!" (fun args ->
|
||||
match args with
|
||||
| [String name; value] ->
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
(match stack with
|
||||
| List items :: rest ->
|
||||
if not (List.mem value items) then
|
||||
Hashtbl.replace scope_stacks name (List (items @ [value]) :: rest)
|
||||
| [] ->
|
||||
Hashtbl.replace scope_stacks name [List [value]]
|
||||
| _ :: _ -> ());
|
||||
Nil
|
||||
| _ -> Nil);
|
||||
|
||||
register "collected" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
(match stack with List items :: _ -> List items | _ -> List [])
|
||||
| _ -> List []);
|
||||
|
||||
register "clear-collected!" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
(match stack with
|
||||
| _ :: rest -> Hashtbl.replace scope_stacks name (List [] :: rest)
|
||||
| [] -> Hashtbl.replace scope_stacks name [List []]);
|
||||
Nil
|
||||
| _ -> Nil);
|
||||
|
||||
(* --- Emit / emitted (for spread attrs in adapter-html.sx) --- *)
|
||||
|
||||
register "scope-emit!" (fun args ->
|
||||
match args with
|
||||
| [String name; value] ->
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
(match stack with
|
||||
| List items :: rest ->
|
||||
Hashtbl.replace scope_stacks name (List (items @ [value]) :: rest)
|
||||
| Nil :: rest ->
|
||||
Hashtbl.replace scope_stacks name (List [value] :: rest)
|
||||
| [] ->
|
||||
Hashtbl.replace scope_stacks name [List [value]]
|
||||
| _ :: _ -> ());
|
||||
Nil
|
||||
| _ -> Nil);
|
||||
|
||||
register "emit!" (fun args ->
|
||||
(* Alias for scope-emit! *)
|
||||
match Sx_primitives.get_primitive "scope-emit!" with
|
||||
| NativeFn (_, fn) -> fn args | _ -> Nil);
|
||||
|
||||
register "emitted" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
|
||||
(match stack with List items :: _ -> List items | _ -> List [])
|
||||
| _ -> List []);
|
||||
|
||||
register "scope-emitted" (fun args ->
|
||||
match Sx_primitives.get_primitive "emitted" with
|
||||
| NativeFn (_, fn) -> fn args | _ -> List []);
|
||||
|
||||
register "scope-collected" (fun args ->
|
||||
match Sx_primitives.get_primitive "collected" with
|
||||
| NativeFn (_, fn) -> fn args | _ -> List []);
|
||||
|
||||
register "scope-clear-collected!" (fun args ->
|
||||
match Sx_primitives.get_primitive "clear-collected!" with
|
||||
| NativeFn (_, fn) -> fn args | _ -> Nil);
|
||||
|
||||
(* --- Provide aliases --- *)
|
||||
|
||||
register "provide-push!" (fun args ->
|
||||
match Sx_primitives.get_primitive "scope-push!" with
|
||||
| NativeFn (_, fn) -> fn args | _ -> Nil);
|
||||
|
||||
register "provide-pop!" (fun args ->
|
||||
match Sx_primitives.get_primitive "scope-pop!" with
|
||||
| NativeFn (_, fn) -> fn args | _ -> Nil)
|
||||
@@ -37,6 +37,35 @@ and value =
|
||||
| SxExpr of string (** Opaque SX wire-format string — aser output. *)
|
||||
| Env of env (** First-class environment — used by CEK machine state dicts. *)
|
||||
| ListRef of value list ref (** Mutable list — JS-style array for append! *)
|
||||
| CekState of cek_state (** Optimized CEK machine state — avoids Dict allocation. *)
|
||||
| CekFrame of cek_frame (** Optimized CEK continuation frame. *)
|
||||
| VmClosure of vm_closure (** VM-compiled closure — callable within the VM without allocating a new VM. *)
|
||||
|
||||
(** CEK machine state — record instead of Dict for performance.
|
||||
5 fields × 55K steps/sec = 275K Hashtbl allocations/sec eliminated. *)
|
||||
and cek_state = {
|
||||
cs_control : value;
|
||||
cs_env : value;
|
||||
cs_kont : value;
|
||||
cs_phase : string;
|
||||
cs_value : value;
|
||||
}
|
||||
|
||||
(** CEK continuation frame — tagged record covering all 29 frame types.
|
||||
Fields are named generically; not all are used by every frame type.
|
||||
Eliminates ~100K Hashtbl allocations per page render. *)
|
||||
and cek_frame = {
|
||||
cf_type : string; (* frame type tag: "if", "let", "call", etc. *)
|
||||
cf_env : value; (* environment — every frame has this *)
|
||||
cf_name : value; (* let/define/set/scope: binding name *)
|
||||
cf_body : value; (* when/let: body expr *)
|
||||
cf_remaining : value; (* begin/cond/map/etc: remaining exprs *)
|
||||
cf_f : value; (* call/map/filter/etc: function *)
|
||||
cf_args : value; (* call: raw args; arg: evaled args *)
|
||||
cf_results : value; (* map/filter/dict: accumulated results *)
|
||||
cf_extra : value; (* extra field: scheme, indexed, value, phase, etc. *)
|
||||
cf_extra2 : value; (* second extra: emitted, etc. *)
|
||||
}
|
||||
|
||||
(** Mutable string-keyed table (SX dicts support [dict-set!]). *)
|
||||
and dict = (string, value) Hashtbl.t
|
||||
@@ -46,6 +75,7 @@ and lambda = {
|
||||
l_body : value;
|
||||
l_closure : env;
|
||||
mutable l_name : string option;
|
||||
mutable l_compiled : vm_closure option; (** Lazy JIT cache *)
|
||||
}
|
||||
|
||||
and component = {
|
||||
@@ -55,6 +85,7 @@ and component = {
|
||||
c_body : value;
|
||||
c_closure : env;
|
||||
c_affinity : string; (** "auto" | "client" | "server" *)
|
||||
mutable c_compiled : vm_closure option; (** Lazy JIT cache *)
|
||||
}
|
||||
|
||||
and island = {
|
||||
@@ -79,6 +110,40 @@ and signal = {
|
||||
mutable s_deps : signal list;
|
||||
}
|
||||
|
||||
(** {1 Bytecode VM types}
|
||||
|
||||
Defined here (not in sx_vm.ml) because [vm_code.constants] references
|
||||
[value] and [lambda.l_compiled] references [vm_closure] — mutual
|
||||
recursion requires all types in one [and] chain. *)
|
||||
|
||||
(** Compiled function body — bytecode + constant pool. *)
|
||||
and vm_code = {
|
||||
vc_arity : int;
|
||||
vc_locals : int;
|
||||
vc_bytecode : int array;
|
||||
vc_constants : value array;
|
||||
}
|
||||
|
||||
(** Upvalue cell — shared mutable reference to a captured variable. *)
|
||||
and vm_upvalue_cell = {
|
||||
mutable uv_value : value;
|
||||
}
|
||||
|
||||
(** Closure — compiled code + captured upvalues + live env reference. *)
|
||||
and vm_closure = {
|
||||
vm_code : vm_code;
|
||||
vm_upvalues : vm_upvalue_cell array;
|
||||
vm_name : string option;
|
||||
vm_env_ref : (string, value) Hashtbl.t;
|
||||
vm_closure_env : env option; (** Original closure env for inner functions *)
|
||||
}
|
||||
|
||||
|
||||
(** {1 Forward ref for calling VM closures from outside the VM} *)
|
||||
|
||||
let _vm_call_closure_ref : (vm_closure -> value list -> value) ref =
|
||||
ref (fun _ _ -> raise (Failure "VM call_closure not initialized"))
|
||||
|
||||
|
||||
(** {1 Errors} *)
|
||||
|
||||
@@ -174,7 +239,7 @@ let make_lambda params body closure =
|
||||
| List items -> List.map value_to_string items
|
||||
| _ -> value_to_string_list params
|
||||
in
|
||||
Lambda { l_params = ps; l_body = body; l_closure = unwrap_env_val closure; l_name = None }
|
||||
Lambda { l_params = ps; l_body = body; l_closure = unwrap_env_val closure; l_name = None; l_compiled = None }
|
||||
|
||||
let make_component name params has_children body closure affinity =
|
||||
let n = value_to_string name in
|
||||
@@ -184,6 +249,7 @@ let make_component name params has_children body closure affinity =
|
||||
Component {
|
||||
c_name = n; c_params = ps; c_has_children = hc;
|
||||
c_body = body; c_closure = unwrap_env_val closure; c_affinity = aff;
|
||||
c_compiled = None;
|
||||
}
|
||||
|
||||
let make_island name params has_children body closure =
|
||||
@@ -233,6 +299,9 @@ let type_of = function
|
||||
| Spread _ -> "spread"
|
||||
| SxExpr _ -> "sx-expr"
|
||||
| Env _ -> "env"
|
||||
| CekState _ -> "dict" (* CEK state behaves as a dict for type checks *)
|
||||
| CekFrame _ -> "dict"
|
||||
| VmClosure _ -> "function"
|
||||
|
||||
let is_nil = function Nil -> true | _ -> false
|
||||
let is_lambda = function Lambda _ -> true | _ -> false
|
||||
@@ -240,10 +309,13 @@ 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
|
||||
| Lambda _ | NativeFn _ | Continuation (_, _) | VmClosure _ -> true
|
||||
| _ -> false
|
||||
|
||||
|
||||
@@ -287,26 +359,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
|
||||
@@ -363,7 +441,18 @@ let rec inspect = function
|
||||
| Number n ->
|
||||
if Float.is_integer n then Printf.sprintf "%d" (int_of_float n)
|
||||
else Printf.sprintf "%g" n
|
||||
| String s -> Printf.sprintf "%S" s
|
||||
| String s ->
|
||||
let buf = Buffer.create (String.length s + 2) in
|
||||
Buffer.add_char buf '"';
|
||||
String.iter (function
|
||||
| '"' -> Buffer.add_string buf "\\\""
|
||||
| '\\' -> Buffer.add_string buf "\\\\"
|
||||
| '\n' -> Buffer.add_string buf "\\n"
|
||||
| '\r' -> Buffer.add_string buf "\\r"
|
||||
| '\t' -> Buffer.add_string buf "\\t"
|
||||
| c -> Buffer.add_char buf c) s;
|
||||
Buffer.add_char buf '"';
|
||||
Buffer.contents buf
|
||||
| Symbol s -> s
|
||||
| Keyword k -> ":" ^ k
|
||||
| List items | ListRef { contents = items } ->
|
||||
@@ -390,3 +479,6 @@ let rec inspect = function
|
||||
| Spread _ -> "<spread>"
|
||||
| SxExpr s -> Printf.sprintf "<sx-expr:%d chars>" (String.length s)
|
||||
| Env _ -> "<env>"
|
||||
| CekState _ -> "<cek-state>"
|
||||
| CekFrame f -> Printf.sprintf "<frame:%s>" f.cf_type
|
||||
| VmClosure cl -> Printf.sprintf "<vm:%s>" (match cl.vm_name with Some n -> n | None -> "anon")
|
||||
|
||||
584
hosts/ocaml/lib/sx_vm.ml
Normal file
584
hosts/ocaml/lib/sx_vm.ml
Normal file
@@ -0,0 +1,584 @@
|
||||
(** SX bytecode VM — stack-based interpreter.
|
||||
|
||||
Executes bytecode produced by compiler.sx.
|
||||
Designed for speed: array-based stack, direct dispatch,
|
||||
no allocation per step (unlike the CEK machine).
|
||||
|
||||
This is the platform-native execution engine. The same bytecode
|
||||
runs on all platforms (OCaml, JS, WASM).
|
||||
|
||||
VM types (vm_code, vm_upvalue_cell, vm_closure) are defined in
|
||||
sx_types.ml to share the mutual recursion block with [value]. *)
|
||||
|
||||
open Sx_types
|
||||
|
||||
(** Call frame — one per function invocation. *)
|
||||
type frame = {
|
||||
closure : vm_closure;
|
||||
mutable ip : int;
|
||||
base : int; (* base index in value stack for locals *)
|
||||
local_cells : (int, vm_upvalue_cell) Hashtbl.t; (* slot → shared cell for captured locals *)
|
||||
}
|
||||
|
||||
(** VM state. *)
|
||||
type vm = {
|
||||
mutable stack : value array;
|
||||
mutable sp : int;
|
||||
mutable frames : frame list;
|
||||
globals : (string, value) Hashtbl.t; (* live reference to kernel env *)
|
||||
}
|
||||
|
||||
(** Forward reference for JIT compilation — set after definition. *)
|
||||
let jit_compile_ref : (lambda -> (string, value) Hashtbl.t -> vm_closure option) ref =
|
||||
ref (fun _ _ -> None)
|
||||
|
||||
(** Sentinel closure indicating JIT compilation was attempted and failed.
|
||||
Prevents retrying compilation on every call. *)
|
||||
let jit_failed_sentinel = {
|
||||
vm_code = { vc_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||] };
|
||||
vm_upvalues = [||]; vm_name = Some "__jit_failed__"; vm_env_ref = Hashtbl.create 0; vm_closure_env = None
|
||||
}
|
||||
|
||||
let is_jit_failed cl = cl.vm_code.vc_arity = -1
|
||||
|
||||
let create globals =
|
||||
{ stack = Array.make 4096 Nil; sp = 0; frames = []; globals }
|
||||
|
||||
(** Stack ops — inlined for speed. *)
|
||||
let push vm v =
|
||||
if vm.sp >= Array.length vm.stack then begin
|
||||
let ns = Array.make (vm.sp * 2) Nil in
|
||||
Array.blit vm.stack 0 ns 0 vm.sp;
|
||||
vm.stack <- ns
|
||||
end;
|
||||
vm.stack.(vm.sp) <- v;
|
||||
vm.sp <- vm.sp + 1
|
||||
|
||||
let[@inline] pop vm =
|
||||
vm.sp <- vm.sp - 1;
|
||||
vm.stack.(vm.sp)
|
||||
|
||||
let[@inline] peek vm = vm.stack.(vm.sp - 1)
|
||||
|
||||
(** Read operands. *)
|
||||
let[@inline] read_u8 f =
|
||||
let v = f.closure.vm_code.vc_bytecode.(f.ip) in
|
||||
f.ip <- f.ip + 1; v
|
||||
|
||||
let[@inline] read_u16 f =
|
||||
let lo = f.closure.vm_code.vc_bytecode.(f.ip) in
|
||||
let hi = f.closure.vm_code.vc_bytecode.(f.ip + 1) in
|
||||
f.ip <- f.ip + 2;
|
||||
lo lor (hi lsl 8)
|
||||
|
||||
let[@inline] read_i16 f =
|
||||
let v = read_u16 f in
|
||||
if v >= 32768 then v - 65536 else v
|
||||
|
||||
(** Wrap a VM closure as an SX value (NativeFn). *)
|
||||
let closure_to_value cl =
|
||||
NativeFn ("vm:" ^ (match cl.vm_name with Some n -> n | None -> "anon"),
|
||||
fun args -> raise (Eval_error ("VM_CLOSURE_CALL:" ^ String.concat "," (List.map Sx_runtime.value_to_str args))))
|
||||
(* Placeholder — actual calls go through vm_call below *)
|
||||
|
||||
let _vm_insn_count = ref 0
|
||||
let _vm_call_count = ref 0
|
||||
let _vm_cek_count = ref 0
|
||||
let vm_reset_counters () = _vm_insn_count := 0; _vm_call_count := 0; _vm_cek_count := 0
|
||||
let vm_report_counters () =
|
||||
Printf.eprintf "[vm-perf] insns=%d calls=%d cek_fallbacks=%d\n%!"
|
||||
!_vm_insn_count !_vm_call_count !_vm_cek_count
|
||||
|
||||
(** Push a VM closure frame onto the current VM — no new VM allocation.
|
||||
This is the fast path for intra-VM closure calls. *)
|
||||
let push_closure_frame vm cl args =
|
||||
let frame = { closure = cl; ip = 0; base = vm.sp; local_cells = Hashtbl.create 4 } in
|
||||
List.iter (fun a -> push vm a) args;
|
||||
for _ = List.length args to cl.vm_code.vc_locals - 1 do push vm Nil done;
|
||||
vm.frames <- frame :: vm.frames
|
||||
|
||||
(** Convert compiler output (SX dict) to a vm_code object. *)
|
||||
let code_from_value v =
|
||||
match v with
|
||||
| Dict d ->
|
||||
let bc_list = match Hashtbl.find_opt d "bytecode" with
|
||||
| Some (List l | ListRef { contents = l }) ->
|
||||
Array.of_list (List.map (fun x -> match x with Number n -> int_of_float n | _ -> 0) l)
|
||||
| _ -> [||]
|
||||
in
|
||||
let entries = match Hashtbl.find_opt d "constants" with
|
||||
| Some (List l | ListRef { contents = l }) -> Array.of_list l
|
||||
| _ -> [||]
|
||||
in
|
||||
let constants = Array.map (fun entry ->
|
||||
match entry with
|
||||
| Dict ed when Hashtbl.mem ed "bytecode" -> entry (* nested code — convert lazily *)
|
||||
| _ -> entry
|
||||
) entries in
|
||||
let arity = match Hashtbl.find_opt d "arity" with
|
||||
| Some (Number n) -> int_of_float n | _ -> 0
|
||||
in
|
||||
{ vc_arity = arity; vc_locals = arity + 16; vc_bytecode = bc_list; vc_constants = constants }
|
||||
| _ -> { vc_arity = 0; vc_locals = 16; vc_bytecode = [||]; vc_constants = [||] }
|
||||
|
||||
(** Execute a closure with arguments — creates a fresh VM.
|
||||
Used for entry points: JIT Lambda calls, module execution, cross-boundary. *)
|
||||
let rec call_closure cl args globals =
|
||||
incr _vm_call_count;
|
||||
let vm = create globals in
|
||||
push_closure_frame vm cl args;
|
||||
(try run vm with e -> raise e);
|
||||
pop vm
|
||||
|
||||
(** Call a value as a function — dispatch by type.
|
||||
VmClosure: pushes frame on current VM (fast intra-VM path).
|
||||
Lambda: tries JIT then falls back to CEK.
|
||||
NativeFn: calls directly. *)
|
||||
and vm_call vm f args =
|
||||
match f with
|
||||
| VmClosure cl ->
|
||||
(* Fast path: push frame on current VM — no allocation, enables TCO *)
|
||||
push_closure_frame vm cl args
|
||||
| NativeFn (_name, fn) ->
|
||||
let result = fn args in
|
||||
push vm result
|
||||
| Lambda l ->
|
||||
(match l.l_compiled with
|
||||
| Some cl when not (is_jit_failed cl) ->
|
||||
(* Cached bytecode — run on VM, fall back to CEK on runtime error *)
|
||||
(try push vm (call_closure cl args vm.globals)
|
||||
with _ -> push vm (Sx_ref.cek_call f (List args)))
|
||||
| Some _ ->
|
||||
(* Compile failed — CEK *)
|
||||
push vm (Sx_ref.cek_call f (List args))
|
||||
| None ->
|
||||
if l.l_name <> None
|
||||
then begin
|
||||
(* Pre-mark before compile attempt to prevent re-entrancy *)
|
||||
l.l_compiled <- Some jit_failed_sentinel;
|
||||
match !jit_compile_ref l vm.globals with
|
||||
| Some cl ->
|
||||
l.l_compiled <- Some cl;
|
||||
(try push vm (call_closure cl args vm.globals)
|
||||
with _ ->
|
||||
l.l_compiled <- Some jit_failed_sentinel;
|
||||
push vm (Sx_ref.cek_call f (List args)))
|
||||
| None ->
|
||||
push vm (Sx_ref.cek_call f (List args))
|
||||
end
|
||||
else
|
||||
push vm (Sx_ref.cek_call f (List args)))
|
||||
| Component _ | Island _ ->
|
||||
(* Components use keyword-arg parsing — CEK handles this *)
|
||||
incr _vm_cek_count;
|
||||
let result = Sx_ref.cek_call f (List args) in
|
||||
push vm result
|
||||
| _ ->
|
||||
raise (Eval_error ("VM: not callable: " ^ Sx_runtime.value_to_str f))
|
||||
|
||||
(** Main execution loop — iterative (no OCaml stack growth).
|
||||
VmClosure calls push frames; the loop picks them up.
|
||||
OP_TAIL_CALL + VmClosure = true TCO: drop frame, push new, loop. *)
|
||||
and run vm =
|
||||
while vm.frames <> [] do
|
||||
match vm.frames with
|
||||
| [] -> () (* guard handled by while condition *)
|
||||
| frame :: rest_frames ->
|
||||
let bc = frame.closure.vm_code.vc_bytecode in
|
||||
let consts = frame.closure.vm_code.vc_constants in
|
||||
if frame.ip >= Array.length bc then
|
||||
vm.frames <- [] (* bytecode exhausted — stop *)
|
||||
else begin
|
||||
let saved_ip = frame.ip in
|
||||
let op = bc.(frame.ip) in
|
||||
frame.ip <- frame.ip + 1;
|
||||
(try match op with
|
||||
(* ---- Constants ---- *)
|
||||
| 1 (* OP_CONST *) ->
|
||||
let idx = read_u16 frame in
|
||||
if idx >= Array.length consts then
|
||||
raise (Eval_error (Printf.sprintf "VM: CONST index %d out of bounds (pool size %d)"
|
||||
idx (Array.length consts)));
|
||||
push vm consts.(idx)
|
||||
| 2 (* OP_NIL *) -> push vm Nil
|
||||
| 3 (* OP_TRUE *) -> push vm (Bool true)
|
||||
| 4 (* OP_FALSE *) -> push vm (Bool false)
|
||||
| 5 (* OP_POP *) -> ignore (pop vm)
|
||||
| 6 (* OP_DUP *) -> push vm (peek vm)
|
||||
|
||||
(* ---- Variable access ---- *)
|
||||
| 16 (* OP_LOCAL_GET *) ->
|
||||
let slot = read_u8 frame in
|
||||
let v = match Hashtbl.find_opt frame.local_cells slot with
|
||||
| Some cell -> cell.uv_value
|
||||
| None ->
|
||||
let idx = frame.base + slot in
|
||||
if idx >= vm.sp then
|
||||
raise (Eval_error (Printf.sprintf
|
||||
"VM: LOCAL_GET slot=%d base=%d sp=%d out of bounds" slot frame.base vm.sp));
|
||||
vm.stack.(idx)
|
||||
in
|
||||
push vm v
|
||||
| 17 (* OP_LOCAL_SET *) ->
|
||||
let slot = read_u8 frame in
|
||||
let v = peek vm in
|
||||
(* Write to shared cell if captured, else to stack *)
|
||||
(match Hashtbl.find_opt frame.local_cells slot with
|
||||
| Some cell -> cell.uv_value <- v
|
||||
| None -> vm.stack.(frame.base + slot) <- v)
|
||||
| 18 (* OP_UPVALUE_GET *) ->
|
||||
let idx = read_u8 frame in
|
||||
if idx >= Array.length frame.closure.vm_upvalues then
|
||||
raise (Eval_error (Printf.sprintf
|
||||
"VM: UPVALUE_GET idx=%d out of bounds (have %d)" idx
|
||||
(Array.length frame.closure.vm_upvalues)));
|
||||
push vm frame.closure.vm_upvalues.(idx).uv_value
|
||||
| 19 (* OP_UPVALUE_SET *) ->
|
||||
let idx = read_u8 frame in
|
||||
frame.closure.vm_upvalues.(idx).uv_value <- peek vm
|
||||
| 20 (* OP_GLOBAL_GET *) ->
|
||||
let idx = read_u16 frame in
|
||||
let name = match consts.(idx) with String s -> s | _ -> "" in
|
||||
let v = try Hashtbl.find vm.globals name with Not_found ->
|
||||
(* Walk the closure env chain for inner functions *)
|
||||
let rec env_lookup e =
|
||||
try Hashtbl.find e.bindings name
|
||||
with Not_found ->
|
||||
match e.parent with Some p -> env_lookup p | None ->
|
||||
try Sx_primitives.get_primitive name
|
||||
with _ -> raise (Eval_error ("VM undefined: " ^ name))
|
||||
in
|
||||
match frame.closure.vm_closure_env with
|
||||
| Some env -> env_lookup env
|
||||
| None ->
|
||||
try Sx_primitives.get_primitive name
|
||||
with _ -> raise (Eval_error ("VM undefined: " ^ name))
|
||||
in
|
||||
push vm v
|
||||
| 21 (* OP_GLOBAL_SET *) ->
|
||||
let idx = read_u16 frame in
|
||||
let name = match consts.(idx) with String s -> s | _ -> "" in
|
||||
(* Write to closure env if the name exists there (mutable closure vars) *)
|
||||
let written = match frame.closure.vm_closure_env with
|
||||
| Some env ->
|
||||
let rec find_env e =
|
||||
if Hashtbl.mem e.bindings name then
|
||||
(Hashtbl.replace e.bindings name (peek vm); true)
|
||||
else match e.parent with Some p -> find_env p | None -> false
|
||||
in find_env env
|
||||
| None -> false
|
||||
in
|
||||
if not written then Hashtbl.replace vm.globals name (peek vm)
|
||||
|
||||
(* ---- Control flow ---- *)
|
||||
| 32 (* OP_JUMP *) ->
|
||||
let offset = read_i16 frame in
|
||||
frame.ip <- frame.ip + offset
|
||||
| 33 (* OP_JUMP_IF_FALSE *) ->
|
||||
let offset = read_i16 frame in
|
||||
let v = pop vm in
|
||||
if not (sx_truthy v) then frame.ip <- frame.ip + offset
|
||||
| 34 (* OP_JUMP_IF_TRUE *) ->
|
||||
let offset = read_i16 frame in
|
||||
let v = pop vm in
|
||||
if sx_truthy v then frame.ip <- frame.ip + offset
|
||||
|
||||
(* ---- Function calls ---- *)
|
||||
| 48 (* OP_CALL *) ->
|
||||
let argc = read_u8 frame in
|
||||
let args = Array.init argc (fun _ -> pop vm) in
|
||||
let f = pop vm in
|
||||
let args_list = List.rev (Array.to_list args) in
|
||||
vm_call vm f args_list
|
||||
(* Loop continues — if VmClosure, new frame runs next iteration *)
|
||||
| 49 (* OP_TAIL_CALL *) ->
|
||||
let argc = read_u8 frame in
|
||||
let args = Array.init argc (fun _ -> pop vm) in
|
||||
let f = pop vm in
|
||||
let args_list = List.rev (Array.to_list args) in
|
||||
(* Drop current frame, reuse stack space — true TCO for VmClosure *)
|
||||
vm.frames <- rest_frames;
|
||||
vm.sp <- frame.base;
|
||||
vm_call vm f args_list
|
||||
| 50 (* OP_RETURN *) ->
|
||||
let result = pop vm in
|
||||
vm.frames <- rest_frames;
|
||||
vm.sp <- frame.base;
|
||||
push vm result
|
||||
(* Loop continues with caller frame *)
|
||||
| 51 (* OP_CLOSURE *) ->
|
||||
let idx = read_u16 frame in
|
||||
if idx >= Array.length consts then
|
||||
raise (Eval_error (Printf.sprintf "VM: CLOSURE idx %d >= consts %d" idx (Array.length consts)));
|
||||
let code_val = consts.(idx) in
|
||||
let code = code_from_value code_val in
|
||||
(* Read upvalue descriptors from bytecode *)
|
||||
let uv_count = match code_val with
|
||||
| Dict d -> (match Hashtbl.find_opt d "upvalue-count" with
|
||||
| Some (Number n) -> int_of_float n | _ -> 0)
|
||||
| _ -> 0
|
||||
in
|
||||
let upvalues = Array.init uv_count (fun _ ->
|
||||
let is_local = read_u8 frame in
|
||||
let index = read_u8 frame in
|
||||
if is_local = 1 then begin
|
||||
(* Capture from enclosing frame's local slot.
|
||||
Create a shared cell — both parent and closure
|
||||
read/write through this cell. *)
|
||||
let cell = match Hashtbl.find_opt frame.local_cells index with
|
||||
| Some existing -> existing (* reuse existing cell *)
|
||||
| None ->
|
||||
let c = { uv_value = vm.stack.(frame.base + index) } in
|
||||
Hashtbl.replace frame.local_cells index c;
|
||||
c
|
||||
in
|
||||
cell
|
||||
end else
|
||||
(* Capture from enclosing frame's upvalue — already a shared cell *)
|
||||
frame.closure.vm_upvalues.(index)
|
||||
) in
|
||||
let cl = { vm_code = code; vm_upvalues = upvalues; vm_name = None;
|
||||
vm_env_ref = vm.globals; vm_closure_env = None } in
|
||||
push vm (VmClosure cl)
|
||||
| 52 (* OP_CALL_PRIM *) ->
|
||||
let idx = read_u16 frame in
|
||||
let argc = read_u8 frame in
|
||||
let name = match consts.(idx) with String s -> s | _ -> "" in
|
||||
let args = List.init argc (fun _ -> pop vm) |> List.rev in
|
||||
(* Resolve thunks — the CEK evaluator does this automatically
|
||||
via trampoline, but the VM must do it explicitly before
|
||||
passing args to primitives. *)
|
||||
let args = List.map (fun v ->
|
||||
match v with
|
||||
| Thunk _ -> !Sx_primitives._sx_trampoline_fn v
|
||||
| _ -> v) args in
|
||||
let result =
|
||||
try
|
||||
(* Check primitives FIRST (native implementations of map/filter/etc.),
|
||||
then globals (which may have ho_via_cek wrappers that route
|
||||
through the CEK — these can't call VM closures). *)
|
||||
let fn_val = try Sx_primitives.get_primitive name with _ ->
|
||||
try Hashtbl.find vm.globals name with Not_found ->
|
||||
raise (Eval_error ("VM: unknown primitive " ^ name))
|
||||
in
|
||||
(match fn_val with
|
||||
| NativeFn (_, fn) -> fn args
|
||||
| _ -> Nil)
|
||||
with Eval_error msg ->
|
||||
raise (Eval_error (Printf.sprintf "%s (in CALL_PRIM \"%s\" with %d args)"
|
||||
msg name argc))
|
||||
in
|
||||
push vm result
|
||||
|
||||
(* ---- Collections ---- *)
|
||||
| 64 (* OP_LIST *) ->
|
||||
let count = read_u16 frame in
|
||||
let items = List.init count (fun _ -> pop vm) |> List.rev in
|
||||
push vm (List items)
|
||||
| 65 (* OP_DICT *) ->
|
||||
let count = read_u16 frame in
|
||||
let d = Hashtbl.create count in
|
||||
for _ = 1 to count do
|
||||
let v = pop vm in
|
||||
let k = pop vm in
|
||||
let key = match k with String s -> s | Keyword s -> s | _ -> Sx_runtime.value_to_str k in
|
||||
Hashtbl.replace d key v
|
||||
done;
|
||||
push vm (Dict d)
|
||||
|
||||
(* ---- String ops ---- *)
|
||||
| 144 (* OP_STR_CONCAT *) ->
|
||||
let count = read_u8 frame in
|
||||
let parts = List.init count (fun _ -> pop vm) |> List.rev in
|
||||
let s = String.concat "" (List.map Sx_runtime.value_to_str parts) in
|
||||
push vm (String s)
|
||||
|
||||
(* ---- Define ---- *)
|
||||
| 128 (* OP_DEFINE *) ->
|
||||
let idx = read_u16 frame in
|
||||
let name = match consts.(idx) with String s -> s | _ -> "" in
|
||||
let v = peek vm in
|
||||
Hashtbl.replace vm.globals name v
|
||||
|
||||
(* ---- Inline primitives (no hashtable lookup) ---- *)
|
||||
| 160 (* OP_ADD *) ->
|
||||
let b = pop vm and a = pop vm in
|
||||
push vm (match a, b with
|
||||
| Number x, Number y -> Number (x +. y)
|
||||
| String x, String y -> String (x ^ y)
|
||||
| _ -> Sx_primitives.(get_primitive "+" |> function NativeFn (_, f) -> f [a; b] | _ -> Nil))
|
||||
| 161 (* OP_SUB *) ->
|
||||
let b = pop vm and a = pop vm in
|
||||
push vm (match a, b with Number x, Number y -> Number (x -. y) | _ -> Nil)
|
||||
| 162 (* OP_MUL *) ->
|
||||
let b = pop vm and a = pop vm in
|
||||
push vm (match a, b with Number x, Number y -> Number (x *. y) | _ -> Nil)
|
||||
| 163 (* OP_DIV *) ->
|
||||
let b = pop vm and a = pop vm in
|
||||
push vm (match a, b with Number x, Number y -> Number (x /. y) | _ -> Nil)
|
||||
| 164 (* OP_EQ *) ->
|
||||
let b = pop vm and a = pop vm in
|
||||
(* Must normalize ListRef→List before structural compare,
|
||||
same as the "=" primitive in sx_primitives.ml *)
|
||||
let rec norm = function
|
||||
| ListRef { contents = l } -> List (List.map norm l)
|
||||
| List l -> List (List.map norm l) | v -> v in
|
||||
push vm (Bool (norm a = norm b))
|
||||
| 165 (* OP_LT *) ->
|
||||
let b = pop vm and a = pop vm in
|
||||
push vm (match a, b with Number x, Number y -> Bool (x < y) | String x, String y -> Bool (x < y) | _ -> Bool false)
|
||||
| 166 (* OP_GT *) ->
|
||||
let b = pop vm and a = pop vm in
|
||||
push vm (match a, b with Number x, Number y -> Bool (x > y) | String x, String y -> Bool (x > y) | _ -> Bool false)
|
||||
| 167 (* OP_NOT *) ->
|
||||
let v = pop vm in
|
||||
push vm (Bool (not (sx_truthy v)))
|
||||
| 168 (* OP_LEN *) ->
|
||||
let v = pop vm in
|
||||
push vm (match v with
|
||||
| List l | ListRef { contents = l } -> Number (float_of_int (List.length l))
|
||||
| String s -> Number (float_of_int (String.length s))
|
||||
| Dict d -> Number (float_of_int (Hashtbl.length d))
|
||||
| Nil -> Number 0.0 | _ -> Number 0.0)
|
||||
| 169 (* OP_FIRST *) ->
|
||||
let v = pop vm in
|
||||
push vm (match v with List (x :: _) | ListRef { contents = x :: _ } -> x | _ -> Nil)
|
||||
| 170 (* OP_REST *) ->
|
||||
let v = pop vm in
|
||||
push vm (match v with List (_ :: xs) | ListRef { contents = _ :: xs } -> List xs | _ -> List [])
|
||||
| 171 (* OP_NTH *) ->
|
||||
let n = pop vm and coll = pop vm in
|
||||
let i = match n with Number f -> int_of_float f | _ -> 0 in
|
||||
push vm (match coll with
|
||||
| List l | ListRef { contents = l } ->
|
||||
(try List.nth l i with _ -> Nil)
|
||||
| _ -> Nil)
|
||||
| 172 (* OP_CONS *) ->
|
||||
let coll = pop vm and x = pop vm in
|
||||
push vm (match coll with
|
||||
| List l -> List (x :: l)
|
||||
| ListRef { contents = l } -> List (x :: l)
|
||||
| Nil -> List [x]
|
||||
| _ -> List [x])
|
||||
| 173 (* OP_NEG *) ->
|
||||
let v = pop vm in
|
||||
push vm (match v with Number x -> Number (-.x) | _ -> Nil)
|
||||
| 174 (* OP_INC *) ->
|
||||
let v = pop vm in
|
||||
push vm (match v with Number x -> Number (x +. 1.0) | _ -> Nil)
|
||||
| 175 (* OP_DEC *) ->
|
||||
let v = pop vm in
|
||||
push vm (match v with Number x -> Number (x -. 1.0) | _ -> Nil)
|
||||
|
||||
| opcode ->
|
||||
raise (Eval_error (Printf.sprintf "VM: unknown opcode %d at ip=%d"
|
||||
opcode (frame.ip - 1)))
|
||||
with Invalid_argument msg ->
|
||||
let fn_name = match frame.closure.vm_name with Some n -> n | None -> "?" in
|
||||
raise (Eval_error (Printf.sprintf
|
||||
"VM: %s at ip=%d op=%d in %s (base=%d sp=%d bc_len=%d consts=%d)"
|
||||
msg saved_ip op fn_name frame.base vm.sp
|
||||
(Array.length bc) (Array.length consts))))
|
||||
end
|
||||
done
|
||||
|
||||
(** Execute a compiled module (top-level bytecode). *)
|
||||
let execute_module code globals =
|
||||
let cl = { vm_code = code; vm_upvalues = [||]; vm_name = Some "module"; vm_env_ref = globals; vm_closure_env = None } in
|
||||
let vm = create globals in
|
||||
let frame = { closure = cl; ip = 0; base = 0; local_cells = Hashtbl.create 4 } in
|
||||
for _ = 0 to code.vc_locals - 1 do push vm Nil done;
|
||||
vm.frames <- [frame];
|
||||
run vm;
|
||||
pop vm
|
||||
|
||||
|
||||
(** {1 Lazy JIT compilation} *)
|
||||
|
||||
(** Compile a lambda or component body to bytecode using the SX compiler.
|
||||
Invokes [compile] from spec/compiler.sx via the CEK machine.
|
||||
Returns a [vm_closure] ready for execution, or [None] on failure
|
||||
(safe fallback to CEK interpretation).
|
||||
|
||||
The compilation cost is a single CEK evaluation of the compiler —
|
||||
microseconds per function. The result is cached in the lambda/component
|
||||
record so subsequent calls go straight to the VM. *)
|
||||
let jit_compile_lambda (l : lambda) globals =
|
||||
let fn_name = match l.l_name with Some n -> n | None -> "<anon>" in
|
||||
try
|
||||
let compile_fn = try Hashtbl.find globals "compile"
|
||||
with Not_found -> raise (Eval_error "JIT: compiler not loaded") in
|
||||
(* Reconstruct the (fn (params) body) form so the compiler produces
|
||||
a proper closure. l.l_body is the inner body; we need the full
|
||||
function form with params so the compiled code binds them. *)
|
||||
let param_syms = List (List.map (fun s -> Symbol s) l.l_params) in
|
||||
let fn_expr = List [Symbol "fn"; param_syms; l.l_body] in
|
||||
let quoted = List [Symbol "quote"; fn_expr] in
|
||||
let result = Sx_ref.eval_expr (List [compile_fn; quoted]) (Env (make_env ())) in
|
||||
(* If the lambda has closure-captured variables, merge them into globals
|
||||
so the VM can find them via GLOBAL_GET. The compiler doesn't know
|
||||
about the enclosing scope, so closure vars get compiled as globals. *)
|
||||
let effective_globals =
|
||||
let closure = l.l_closure in
|
||||
if Hashtbl.length closure.bindings = 0 && closure.parent = None then
|
||||
globals (* no closure vars — use globals directly *)
|
||||
else begin
|
||||
(* Merge: closure bindings layered on top of globals.
|
||||
Use a shallow copy so we don't pollute the real globals. *)
|
||||
let merged = Hashtbl.copy globals in
|
||||
let rec inject env =
|
||||
Hashtbl.iter (fun k v -> Hashtbl.replace merged k v) env.bindings;
|
||||
match env.parent with Some p -> inject p | None -> ()
|
||||
in
|
||||
inject closure;
|
||||
let n = Hashtbl.length merged - Hashtbl.length globals in
|
||||
if n > 0 then
|
||||
Printf.eprintf "[jit] %s: injected %d closure bindings\n%!" fn_name n;
|
||||
merged
|
||||
end
|
||||
in
|
||||
(match result with
|
||||
| Dict d when Hashtbl.mem d "bytecode" ->
|
||||
let outer_code = code_from_value result in
|
||||
let bc = outer_code.vc_bytecode in
|
||||
if Array.length bc >= 4 && bc.(0) = 51 (* OP_CLOSURE *) then begin
|
||||
let idx = bc.(1) lor (bc.(2) lsl 8) in
|
||||
if idx < Array.length outer_code.vc_constants then
|
||||
let inner_val = outer_code.vc_constants.(idx) in
|
||||
let code = code_from_value inner_val in
|
||||
Some { vm_code = code; vm_upvalues = [||];
|
||||
vm_name = l.l_name; vm_env_ref = effective_globals; vm_closure_env = Some l.l_closure }
|
||||
else begin
|
||||
Printf.eprintf "[jit] FAIL %s: closure index %d out of bounds (pool=%d)\n%!"
|
||||
fn_name idx (Array.length outer_code.vc_constants);
|
||||
|
||||
None
|
||||
end
|
||||
end else begin
|
||||
(* Not a closure — constant expression, alias, or simple computation.
|
||||
Execute the bytecode as a module to get the value, then wrap
|
||||
as a NativeFn if it's callable (so the CEK can dispatch to it). *)
|
||||
(try
|
||||
let value = execute_module outer_code globals in
|
||||
Printf.eprintf "[jit] RESOLVED %s: %s (bc[0]=%d)\n%!"
|
||||
fn_name (type_of value) (if Array.length bc > 0 then bc.(0) else -1);
|
||||
(* If the resolved value is a NativeFn, we can't wrap it as a
|
||||
vm_closure — just let the CEK handle it directly. Return None
|
||||
so the lambda falls through to CEK, which will find the
|
||||
resolved value in the env on next lookup. *)
|
||||
None
|
||||
with _ ->
|
||||
Printf.eprintf "[jit] SKIP %s: non-closure execution failed (bc[0]=%d, len=%d)\n%!"
|
||||
fn_name (if Array.length bc > 0 then bc.(0) else -1) (Array.length bc);
|
||||
None)
|
||||
end
|
||||
| _ ->
|
||||
Printf.eprintf "[jit] FAIL %s: compiler returned %s\n%!" fn_name (type_of result);
|
||||
None)
|
||||
with e ->
|
||||
Printf.eprintf "[jit] FAIL %s: %s\n%!" fn_name (Printexc.to_string e);
|
||||
None
|
||||
|
||||
(* Wire up forward references *)
|
||||
let () = jit_compile_ref := jit_compile_lambda
|
||||
let () = _vm_call_closure_ref := (fun cl args -> call_closure cl args cl.vm_env_ref)
|
||||
@@ -120,12 +120,16 @@
|
||||
"emitted" "sx_emitted"
|
||||
"scope-push!" "scope_push"
|
||||
"scope-pop!" "scope_pop"
|
||||
"scope-peek" "scope_peek"
|
||||
"scope-emit!" "scope_emit"
|
||||
"provide-push!" "provide_push"
|
||||
"provide-pop!" "provide_pop"
|
||||
"sx-serialize" "sx_serialize"
|
||||
"render-active?" "render_active_p"
|
||||
"is-render-expr?" "is_render_expr"
|
||||
"render-expr" "render_expr"
|
||||
"*custom-special-forms*" "custom_special_forms"
|
||||
"register-special-form!" "register_special_form"
|
||||
"*render-check*" "render_check"
|
||||
"*render-fn*" "render_fn"
|
||||
"is-else-clause?" "is_else_clause"
|
||||
"HTML_TAGS" "html_tags"
|
||||
"VOID_ELEMENTS" "void_elements"
|
||||
"BOOLEAN_ATTRS" "boolean_attrs"
|
||||
@@ -192,15 +196,12 @@
|
||||
"cek-call" "cek-run" "sx-call" "sx-apply"
|
||||
"collect!" "collected" "clear-collected!" "context" "emit!" "emitted"
|
||||
"scope-push!" "scope-pop!" "provide-push!" "provide-pop!"
|
||||
"render-active?" "render-expr" "is-render-expr?"
|
||||
"with-island-scope" "register-in-scope"
|
||||
"signal-value" "signal-set-value" "signal-subscribers"
|
||||
"signal-add-sub!" "signal-remove-sub!" "signal-deps" "signal-set-deps"
|
||||
"notify-subscribers" "flush-subscribers" "dispose-computed"
|
||||
"continuation?" "continuation-data" "make-cek-continuation"
|
||||
"dynamic-wind-call" "strip-prefix"
|
||||
"sf-defhandler" "sf-defpage" "sf-defquery" "sf-defaction"
|
||||
"make-handler-def" "make-query-def" "make-action-def" "make-page-def"
|
||||
"component-set-param-types!" "parse-comp-params" "parse-macro-params"
|
||||
"parse-keyword-args"))
|
||||
|
||||
@@ -215,6 +216,15 @@
|
||||
;; Check _known_defines (set by bootstrap.py)
|
||||
(some (fn (d) (= d name)) _known_defines)))))
|
||||
|
||||
;; Dynamic globals — top-level defines that hold SX values (not functions).
|
||||
;; When these appear as callees, use cek_call for dynamic dispatch.
|
||||
(define ml-dynamic-globals
|
||||
(list "*render-check*" "*render-fn*"))
|
||||
|
||||
(define ml-is-dyn-global?
|
||||
(fn ((name :as string))
|
||||
(some (fn (g) (= g name)) ml-dynamic-globals)))
|
||||
|
||||
;; Check if a variable is "dynamic" — locally bound to a non-function expression.
|
||||
;; These variables hold SX values (from eval-expr, get, etc.) and need cek_call
|
||||
;; when used as callees. We encode this in the set-vars list as "dyn:name".
|
||||
@@ -404,12 +414,68 @@
|
||||
(define ml-emit-dict-native
|
||||
(fn ((d :as dict) (set-vars :as list))
|
||||
(let ((items (keys d)))
|
||||
(str "(let _d = Hashtbl.create " (str (round (len items)))
|
||||
" in " (join "; " (map (fn (k)
|
||||
(str "Hashtbl.replace _d " (ml-quote-string k)
|
||||
" " (ml-expr-inner (get d k) set-vars)))
|
||||
items))
|
||||
"; Dict _d)"))))
|
||||
;; Optimize CEK state dicts — emit CekState record instead of Hashtbl.
|
||||
;; Detected by having exactly {control, env, kont, phase, value} keys.
|
||||
(if (and (= (len items) 5)
|
||||
(some (fn (k) (= k "control")) items)
|
||||
(some (fn (k) (= k "phase")) items)
|
||||
(some (fn (k) (= k "kont")) items))
|
||||
(str "(CekState { cs_control = " (ml-expr-inner (get d "control") set-vars)
|
||||
"; cs_env = " (ml-expr-inner (get d "env") set-vars)
|
||||
"; cs_kont = " (ml-expr-inner (get d "kont") set-vars)
|
||||
"; cs_phase = " (let ((p (get d "phase")))
|
||||
(if (= (type-of p) "string")
|
||||
(ml-quote-string p)
|
||||
(str "(match " (ml-expr-inner p set-vars)
|
||||
" with String s -> s | _ -> \"\")")))
|
||||
"; cs_value = " (ml-expr-inner (get d "value") set-vars)
|
||||
" })")
|
||||
;; Optimize CEK frame dicts — detected by having a "type" string field.
|
||||
;; Maps frame fields to generic CekFrame record slots.
|
||||
(if (and (some (fn (k) (= k "type")) items)
|
||||
(= (type-of (get d "type")) "string"))
|
||||
(let ((frame-type (get d "type"))
|
||||
(ef (fn (field) (if (some (fn (k) (= k field)) items)
|
||||
(ml-expr-inner (get d field) set-vars) "Nil"))))
|
||||
(str "(CekFrame { cf_type = " (ml-quote-string frame-type)
|
||||
"; cf_env = " (ef "env")
|
||||
"; cf_name = " (if (= frame-type "if") (ef "else") (ef "name"))
|
||||
"; cf_body = " (if (= frame-type "if") (ef "then") (ef "body"))
|
||||
"; cf_remaining = " (ef "remaining")
|
||||
"; cf_f = " (ef "f")
|
||||
"; cf_args = " (cond
|
||||
(some (fn (k) (= k "evaled")) items) (ef "evaled")
|
||||
(some (fn (k) (= k "args")) items) (ef "args")
|
||||
:else "Nil")
|
||||
"; cf_results = " (cond
|
||||
(some (fn (k) (= k "results")) items) (ef "results")
|
||||
(some (fn (k) (= k "raw-args")) items) (ef "raw-args")
|
||||
:else "Nil")
|
||||
"; cf_extra = " (cond
|
||||
(some (fn (k) (= k "ho-type")) items) (ef "ho-type")
|
||||
(some (fn (k) (= k "scheme")) items) (ef "scheme")
|
||||
(some (fn (k) (= k "indexed")) items) (ef "indexed")
|
||||
(some (fn (k) (= k "value")) items) (ef "value")
|
||||
(some (fn (k) (= k "phase")) items) (ef "phase")
|
||||
(some (fn (k) (= k "has-effects")) items) (ef "has-effects")
|
||||
(some (fn (k) (= k "match-val")) items) (ef "match-val")
|
||||
(some (fn (k) (= k "current-item")) items) (ef "current-item")
|
||||
(some (fn (k) (= k "update-fn")) items) (ef "update-fn")
|
||||
(some (fn (k) (= k "head-name")) items) (ef "head-name")
|
||||
:else "Nil")
|
||||
"; cf_extra2 = " (cond
|
||||
(some (fn (k) (= k "emitted")) items) (ef "emitted")
|
||||
(some (fn (k) (= k "effect-list")) items) (ef "effect-list")
|
||||
(some (fn (k) (= k "first-render")) items) (ef "first-render")
|
||||
:else "Nil")
|
||||
" })"))
|
||||
;; Regular dict — Hashtbl
|
||||
(str "(let _d = Hashtbl.create " (str (round (len items)))
|
||||
" in " (join "; " (map (fn (k)
|
||||
(str "Hashtbl.replace _d " (ml-quote-string k)
|
||||
" " (ml-expr-inner (get d k) set-vars)))
|
||||
items))
|
||||
"; Dict _d)"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
@@ -421,8 +487,12 @@
|
||||
(let ((head (first expr))
|
||||
(args (rest expr)))
|
||||
(if (not (= (type-of head) "symbol"))
|
||||
;; Data list
|
||||
(str "[" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) expr)) "]")
|
||||
;; Non-symbol head: if head is a list (call expr), dispatch via cek_call;
|
||||
;; otherwise treat as data list
|
||||
(if (list? head)
|
||||
(str "(cek_call (" (ml-expr-inner head set-vars)
|
||||
") (List [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "]))")
|
||||
(str "[" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) expr)) "]"))
|
||||
(let ((op (symbol-name head)))
|
||||
(cond
|
||||
;; fn/lambda
|
||||
@@ -607,8 +677,8 @@
|
||||
;; Regular function call
|
||||
:else
|
||||
(let ((callee (ml-mangle op)))
|
||||
(if (ml-is-dyn-var? op set-vars)
|
||||
;; Dynamic callee (local var bound to non-fn expr) — dispatch via cek_call
|
||||
(if (or (ml-is-dyn-var? op set-vars) (ml-is-dyn-global? op))
|
||||
;; Dynamic callee (local var or dynamic global) — dispatch via cek_call
|
||||
(str "(cek_call (" callee ") (List [" (join "; " (map (fn (x) (ml-expr-inner x set-vars)) args)) "]))")
|
||||
;; Static callee — direct OCaml call
|
||||
(if (empty? args)
|
||||
@@ -620,7 +690,9 @@
|
||||
;; fn/lambda
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define ml-emit-fn
|
||||
;; ml-emit-fn-bare: emit a plain OCaml function (fun params -> body).
|
||||
;; Used by HO form inlining where a bare OCaml closure is needed.
|
||||
(define ml-emit-fn-bare
|
||||
(fn (expr (set-vars :as list))
|
||||
(let ((params (nth expr 1))
|
||||
(body (rest (rest expr)))
|
||||
@@ -644,6 +716,25 @@
|
||||
(ml-emit-do body all-set-vars))))
|
||||
(str "(fun " params-str " -> " ref-decls body-str ")")))))))
|
||||
|
||||
;; ml-emit-fn: emit an SX-compatible NativeFn value.
|
||||
;; Wraps the OCaml closure so it can be stored as a value, passed to
|
||||
;; signal-add-sub!, etc. The args pattern-match unpacks the value list.
|
||||
(define ml-emit-fn
|
||||
(fn (expr (set-vars :as list))
|
||||
(let ((params (nth expr 1))
|
||||
(param-strs (ml-collect-params params))
|
||||
(n (len param-strs))
|
||||
(bare (ml-emit-fn-bare expr set-vars)))
|
||||
(if (= n 0)
|
||||
;; Zero-arg: NativeFn("λ", fun _args -> body)
|
||||
(str "(NativeFn (\"\\206\\187\", fun _args -> " bare " ()))")
|
||||
;; N-arg: NativeFn("λ", fun args -> match args with [a;b;...] -> body | _ -> Nil)
|
||||
(let ((match-pat (str "[" (join "; " param-strs) "]"))
|
||||
(call-args (join " " param-strs)))
|
||||
(str "(NativeFn (\"\\206\\187\", fun _args -> match _args with "
|
||||
match-pat " -> " bare " " call-args
|
||||
" | _ -> Nil))"))))))
|
||||
|
||||
(define ml-collect-params
|
||||
(fn ((params :as list))
|
||||
(ml-collect-params-loop params 0 (list))))
|
||||
@@ -917,7 +1008,10 @@
|
||||
(= (symbol-name (first val-expr)) "lambda"))))
|
||||
(is-recursive (ml-is-self-recursive? name val-expr)))
|
||||
(let ((rec-kw (if is-recursive "rec " ""))
|
||||
(val-str (ml-expr-inner val-expr set-vars))
|
||||
;; Recursive fns must be bare OCaml functions (called directly)
|
||||
(val-str (if (and is-fn is-recursive)
|
||||
(ml-emit-fn-bare val-expr set-vars)
|
||||
(ml-expr-inner val-expr set-vars)))
|
||||
(rest-str (ml-emit-do-chain args (+ i 1) set-vars)))
|
||||
(str "(let " rec-kw ml-name " = " val-str " in " rest-str ")"))))
|
||||
;; Non-define expression
|
||||
@@ -961,12 +1055,12 @@
|
||||
body-str)))
|
||||
(str "(" result-wrap " (" ocaml-fn " (fun " param-str " -> " wrapped-body
|
||||
") (sx_to_list " (ml-expr-inner coll-arg set-vars) ")))"))))
|
||||
;; Named function — direct call (all defines are OCaml fns)
|
||||
;; Named function — dispatch via cek_call (fn may be NativeFn value)
|
||||
(let ((fn-str (ml-expr-inner fn-arg set-vars)))
|
||||
(if needs-bool
|
||||
(str "(" result-wrap " (" ocaml-fn " (fun _x -> sx_truthy (" fn-str " _x))"
|
||||
(str "(" result-wrap " (" ocaml-fn " (fun _x -> sx_truthy (cek_call " fn-str " (List [_x])))"
|
||||
" (sx_to_list " (ml-expr-inner coll-arg set-vars) ")))")
|
||||
(str "(" result-wrap " (" ocaml-fn " (fun _x -> " fn-str " _x)"
|
||||
(str "(" result-wrap " (" ocaml-fn " (fun _x -> cek_call " fn-str " (List [_x]))"
|
||||
" (sx_to_list " (ml-expr-inner coll-arg set-vars) ")))")))))))
|
||||
|
||||
(define ml-emit-ho-indexed
|
||||
@@ -984,8 +1078,8 @@
|
||||
(ml-emit-do body set-vars))))
|
||||
(str "(List (List.mapi (fun " i-param " " v-param " -> let " i-param " = Number (float_of_int " i-param ") in " body-str
|
||||
") (sx_to_list " (ml-expr-inner coll-arg set-vars) ")))")))
|
||||
(str "(List (List.mapi (fun _i _x -> " (ml-expr-inner fn-arg set-vars)
|
||||
" (Number (float_of_int _i)) _x) (sx_to_list " (ml-expr-inner coll-arg set-vars) ")))")))))
|
||||
(str "(List (List.mapi (fun _i _x -> cek_call " (ml-expr-inner fn-arg set-vars)
|
||||
" (List [Number (float_of_int _i); _x])) (sx_to_list " (ml-expr-inner coll-arg set-vars) ")))")))))
|
||||
|
||||
(define ml-emit-reduce
|
||||
(fn ((args :as list) (set-vars :as list))
|
||||
@@ -1007,8 +1101,8 @@
|
||||
(str "_" raw-acc)))))
|
||||
(str "(List.fold_left (fun " acc-param " " x-param " -> " body-str ") "
|
||||
(ml-expr-inner init-arg set-vars) " (sx_to_list " (ml-expr-inner coll-arg set-vars) "))")))
|
||||
(str "(List.fold_left (fun _acc _x -> " (ml-expr-inner fn-arg set-vars)
|
||||
" _acc _x) " (ml-expr-inner init-arg set-vars)
|
||||
(str "(List.fold_left (fun _acc _x -> cek_call " (ml-expr-inner fn-arg set-vars)
|
||||
" (List [_acc; _x])) " (ml-expr-inner init-arg set-vars)
|
||||
" (sx_to_list " (ml-expr-inner coll-arg set-vars) "))")))))
|
||||
|
||||
|
||||
@@ -1030,8 +1124,8 @@
|
||||
(ml-emit-do body set-vars))))
|
||||
(str "(List.iter (fun " param-str " -> ignore (" body-str
|
||||
")) (sx_to_list " (ml-expr-inner coll-arg set-vars) "); Nil)")))
|
||||
(str "(List.iter (fun _x -> ignore (" (ml-expr-inner fn-arg set-vars)
|
||||
" _x)) (sx_to_list " (ml-expr-inner coll-arg set-vars) "); Nil)")))))
|
||||
(str "(List.iter (fun _x -> ignore (cek_call " (ml-expr-inner fn-arg set-vars)
|
||||
" (List [_x]))) (sx_to_list " (ml-expr-inner coll-arg set-vars) "); Nil)")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
@@ -1061,7 +1155,7 @@
|
||||
(str "(match " (ml-expr-inner dict-arg set-vars) " with Dict _tbl -> "
|
||||
"let _r = Hashtbl.create (Hashtbl.length _tbl) in "
|
||||
"Hashtbl.iter (fun _k _v -> "
|
||||
"Hashtbl.replace _r _k (" fn-str " (String _k) _v)) _tbl; "
|
||||
"Hashtbl.replace _r _k (cek_call " fn-str " (List [String _k; _v]))) _tbl; "
|
||||
"Dict _r | _ -> raise (Eval_error \"map-dict: expected dict\"))"))))))
|
||||
|
||||
|
||||
|
||||
@@ -179,6 +179,11 @@ class PyEmitter:
|
||||
"*batch-depth*": "_batch_depth",
|
||||
"*batch-queue*": "_batch_queue",
|
||||
"*store-registry*": "_store_registry",
|
||||
"*custom-special-forms*": "_custom_special_forms",
|
||||
"*render-check*": "_render_check",
|
||||
"*render-fn*": "_render_fn",
|
||||
"register-special-form!": "register_special_form_b",
|
||||
"is-else-clause?": "is_else_clause_p",
|
||||
"def-store": "def_store",
|
||||
"use-store": "use_store",
|
||||
"clear-stores": "clear_stores",
|
||||
@@ -1443,6 +1448,7 @@ def compile_ref_to_py(
|
||||
_project = os.path.abspath(os.path.join(ref_dir, "..", "..", ".."))
|
||||
_source_dirs = [
|
||||
os.path.join(_project, "spec"),
|
||||
os.path.join(_project, "lib"),
|
||||
os.path.join(_project, "web"),
|
||||
ref_dir,
|
||||
]
|
||||
@@ -1493,6 +1499,7 @@ def compile_ref_to_py(
|
||||
sx_files = [
|
||||
("evaluator.sx", "evaluator (frames + eval + CEK)"),
|
||||
("forms.sx", "forms (server definition forms)"),
|
||||
("web-forms.sx", "web-forms (defstyle, deftype, defeffect, defrelation)"),
|
||||
("render.sx", "render (core)"),
|
||||
]
|
||||
# Parser before html/sx — provides serialize used by adapters
|
||||
|
||||
@@ -612,13 +612,7 @@ def inspect(x):
|
||||
return repr(x)
|
||||
|
||||
|
||||
def escape_html(s):
|
||||
s = str(s)
|
||||
return s.replace("&", "&").replace("<", "<").replace(">", ">").replace('"', """)
|
||||
|
||||
|
||||
def escape_attr(s):
|
||||
return escape_html(s)
|
||||
# escape_html and escape_attr are now library functions defined in render.sx
|
||||
|
||||
|
||||
def raw_html_content(x):
|
||||
@@ -842,7 +836,7 @@ def _sx_parse_int(v, default=0):
|
||||
"stdlib.text": '''
|
||||
# stdlib.text
|
||||
PRIMITIVES["pluralize"] = lambda n, s="", p="s": s if n == 1 else p
|
||||
PRIMITIVES["escape"] = escape_html
|
||||
PRIMITIVES["escape"] = lambda s: str(s).replace("&", "&").replace("<", "<").replace(">", ">").replace('"', """)
|
||||
PRIMITIVES["strip-tags"] = lambda s: _strip_tags(str(s))
|
||||
|
||||
import re as _re
|
||||
@@ -1646,13 +1640,18 @@ SPEC_MODULES = {
|
||||
"engine": ("engine.sx", "engine (fetch/swap/trigger pure logic)"),
|
||||
"signals": ("signals.sx", "signals (reactive signal runtime)"),
|
||||
"page-helpers": ("page-helpers.sx", "page-helpers (pure data transformation helpers)"),
|
||||
"stdlib": ("stdlib.sx", "stdlib (library functions from former primitives)"),
|
||||
"types": ("types.sx", "types (gradual type system)"),
|
||||
"freeze": ("freeze.sx", "freeze (serializable state boundaries)"),
|
||||
"content": ("content.sx", "content (content-addressed computation)"),
|
||||
}
|
||||
# Note: frames and cek are now part of evaluator.sx (always loaded as core)
|
||||
|
||||
# Explicit ordering for spec modules with dependencies.
|
||||
# stdlib must come first — other modules use its functions.
|
||||
# freeze depends on signals; content depends on freeze.
|
||||
SPEC_MODULE_ORDER = [
|
||||
"deps", "engine", "page-helpers", "router", "signals", "types",
|
||||
"stdlib", "deps", "engine", "page-helpers", "router", "signals", "types", "freeze", "content",
|
||||
]
|
||||
|
||||
EXTENSION_NAMES = {"continuations"}
|
||||
|
||||
@@ -1,251 +0,0 @@
|
||||
#!/usr/bin/env python3
|
||||
"""Run test-cek-reactive.sx — tests for deref-as-shift reactive rendering."""
|
||||
from __future__ import annotations
|
||||
import os, sys
|
||||
|
||||
_HERE = os.path.dirname(os.path.abspath(__file__))
|
||||
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", "..", ".."))
|
||||
_SPEC_TESTS = os.path.join(_PROJECT, "spec", "tests")
|
||||
_WEB_TESTS = os.path.join(_PROJECT, "web", "tests")
|
||||
sys.path.insert(0, _PROJECT)
|
||||
sys.setrecursionlimit(20000)
|
||||
|
||||
from shared.sx.parser import parse_all
|
||||
from shared.sx.ref import sx_ref
|
||||
from shared.sx.ref.sx_ref import (
|
||||
make_env, env_get, env_has, env_set,
|
||||
env_extend, env_merge,
|
||||
)
|
||||
# Use tree-walk evaluator for interpreting .sx test files.
|
||||
# The CEK override (eval_expr = cek_run) would cause the interpreted cek.sx
|
||||
# to delegate to the transpiled CEK, not the interpreted one being tested.
|
||||
# Override both the local names AND the module-level names so that transpiled
|
||||
# functions (ho_map, call_lambda, etc.) also use tree-walk internally.
|
||||
eval_expr = sx_ref._tree_walk_eval_expr
|
||||
trampoline = sx_ref._tree_walk_trampoline
|
||||
sx_ref.eval_expr = eval_expr
|
||||
sx_ref.trampoline = trampoline
|
||||
from shared.sx.types import (
|
||||
NIL, Symbol, Keyword, Lambda, Component, Island, Continuation, Macro,
|
||||
_ShiftSignal,
|
||||
)
|
||||
|
||||
# Build env with primitives
|
||||
env = make_env()
|
||||
|
||||
# Platform test functions
|
||||
_suite_stack: list[str] = []
|
||||
_pass_count = 0
|
||||
_fail_count = 0
|
||||
|
||||
def _try_call(thunk):
|
||||
try:
|
||||
trampoline(eval_expr([thunk], env))
|
||||
return {"ok": True}
|
||||
except Exception as e:
|
||||
return {"ok": False, "error": str(e)}
|
||||
|
||||
def _report_pass(name):
|
||||
global _pass_count
|
||||
_pass_count += 1
|
||||
ctx = " > ".join(_suite_stack)
|
||||
print(f" PASS: {ctx} > {name}")
|
||||
return NIL
|
||||
|
||||
def _report_fail(name, error):
|
||||
global _fail_count
|
||||
_fail_count += 1
|
||||
ctx = " > ".join(_suite_stack)
|
||||
print(f" FAIL: {ctx} > {name}: {error}")
|
||||
return NIL
|
||||
|
||||
def _push_suite(name):
|
||||
_suite_stack.append(name)
|
||||
print(f"{' ' * (len(_suite_stack)-1)}Suite: {name}")
|
||||
return NIL
|
||||
|
||||
def _pop_suite():
|
||||
if _suite_stack:
|
||||
_suite_stack.pop()
|
||||
return NIL
|
||||
|
||||
def _test_env():
|
||||
return env
|
||||
|
||||
def _sx_parse(source):
|
||||
return parse_all(source)
|
||||
|
||||
def _sx_parse_one(source):
|
||||
"""Parse a single expression."""
|
||||
exprs = parse_all(source)
|
||||
return exprs[0] if exprs else NIL
|
||||
|
||||
def _make_continuation(fn):
|
||||
return Continuation(fn)
|
||||
|
||||
env["try-call"] = _try_call
|
||||
env["report-pass"] = _report_pass
|
||||
env["report-fail"] = _report_fail
|
||||
env["push-suite"] = _push_suite
|
||||
env["pop-suite"] = _pop_suite
|
||||
env["test-env"] = _test_env
|
||||
env["sx-parse"] = _sx_parse
|
||||
env["sx-parse-one"] = _sx_parse_one
|
||||
env["env-get"] = env_get
|
||||
env["env-has?"] = env_has
|
||||
env["env-set!"] = env_set
|
||||
env["env-extend"] = env_extend
|
||||
env["make-continuation"] = _make_continuation
|
||||
env["continuation?"] = lambda x: isinstance(x, Continuation)
|
||||
env["continuation-fn"] = lambda c: c.fn
|
||||
|
||||
def _make_cek_continuation_with_data(captured, rest_kont):
|
||||
c = Continuation(lambda v=NIL: v)
|
||||
c._cek_data = {"captured": captured, "rest-kont": rest_kont}
|
||||
return c
|
||||
|
||||
env["make-cek-continuation"] = _make_cek_continuation_with_data
|
||||
env["continuation-data"] = lambda c: getattr(c, '_cek_data', {})
|
||||
|
||||
# Type predicates and constructors
|
||||
env["callable?"] = lambda x: callable(x) or isinstance(x, (Lambda, Component, Island, Continuation))
|
||||
env["lambda?"] = lambda x: isinstance(x, Lambda)
|
||||
env["component?"] = lambda x: isinstance(x, Component)
|
||||
env["island?"] = lambda x: isinstance(x, Island)
|
||||
env["macro?"] = lambda x: isinstance(x, Macro)
|
||||
env["thunk?"] = sx_ref.is_thunk
|
||||
env["thunk-expr"] = sx_ref.thunk_expr
|
||||
env["thunk-env"] = sx_ref.thunk_env
|
||||
env["make-thunk"] = sx_ref.make_thunk
|
||||
env["make-lambda"] = sx_ref.make_lambda
|
||||
env["make-component"] = sx_ref.make_component
|
||||
env["make-island"] = sx_ref.make_island
|
||||
env["make-macro"] = sx_ref.make_macro
|
||||
env["make-symbol"] = lambda n: Symbol(n)
|
||||
env["lambda-params"] = lambda f: f.params
|
||||
env["lambda-body"] = lambda f: f.body
|
||||
env["lambda-closure"] = lambda f: f.closure
|
||||
env["lambda-name"] = lambda f: f.name
|
||||
env["set-lambda-name!"] = lambda f, n: setattr(f, 'name', n) or NIL
|
||||
env["component-params"] = lambda c: c.params
|
||||
env["component-body"] = lambda c: c.body
|
||||
env["component-closure"] = lambda c: c.closure
|
||||
env["component-has-children?"] = lambda c: c.has_children
|
||||
env["component-affinity"] = lambda c: getattr(c, 'affinity', 'auto')
|
||||
env["component-set-param-types!"] = lambda c, t: setattr(c, 'param_types', t) or NIL
|
||||
env["macro-params"] = lambda m: m.params
|
||||
env["macro-rest-param"] = lambda m: m.rest_param
|
||||
env["macro-body"] = lambda m: m.body
|
||||
env["macro-closure"] = lambda m: m.closure
|
||||
env["env-merge"] = env_merge
|
||||
env["symbol-name"] = lambda s: s.name if isinstance(s, Symbol) else str(s)
|
||||
env["keyword-name"] = lambda k: k.name if isinstance(k, Keyword) else str(k)
|
||||
env["type-of"] = sx_ref.type_of
|
||||
env["primitive?"] = sx_ref.is_primitive
|
||||
env["get-primitive"] = sx_ref.get_primitive
|
||||
env["strip-prefix"] = lambda s, p: s[len(p):] if s.startswith(p) else s
|
||||
env["inspect"] = repr
|
||||
env["debug-log"] = lambda *args: None
|
||||
env["error"] = sx_ref.error
|
||||
env["apply"] = lambda f, args: f(*args)
|
||||
|
||||
# Functions from eval.sx that cek.sx references
|
||||
env["trampoline"] = trampoline
|
||||
env["eval-expr"] = eval_expr
|
||||
env["eval-list"] = sx_ref.eval_list
|
||||
env["eval-call"] = sx_ref.eval_call
|
||||
env["call-lambda"] = sx_ref.call_lambda
|
||||
env["call-component"] = sx_ref.call_component
|
||||
env["parse-keyword-args"] = sx_ref.parse_keyword_args
|
||||
env["sf-lambda"] = sx_ref.sf_lambda
|
||||
env["sf-defcomp"] = sx_ref.sf_defcomp
|
||||
env["sf-defisland"] = sx_ref.sf_defisland
|
||||
env["sf-defmacro"] = sx_ref.sf_defmacro
|
||||
env["sf-defstyle"] = sx_ref.sf_defstyle
|
||||
env["sf-deftype"] = sx_ref.sf_deftype
|
||||
env["sf-defeffect"] = sx_ref.sf_defeffect
|
||||
env["sf-letrec"] = sx_ref.sf_letrec
|
||||
env["sf-named-let"] = sx_ref.sf_named_let
|
||||
env["sf-dynamic-wind"] = sx_ref.sf_dynamic_wind
|
||||
env["sf-scope"] = sx_ref.sf_scope
|
||||
env["sf-provide"] = sx_ref.sf_provide
|
||||
env["qq-expand"] = sx_ref.qq_expand
|
||||
env["expand-macro"] = sx_ref.expand_macro
|
||||
env["cond-scheme?"] = sx_ref.cond_scheme_p
|
||||
|
||||
# Higher-order form handlers
|
||||
env["ho-map"] = sx_ref.ho_map
|
||||
env["ho-map-indexed"] = sx_ref.ho_map_indexed
|
||||
env["ho-filter"] = sx_ref.ho_filter
|
||||
env["ho-reduce"] = sx_ref.ho_reduce
|
||||
env["ho-some"] = sx_ref.ho_some
|
||||
env["ho-every"] = sx_ref.ho_every
|
||||
env["ho-for-each"] = sx_ref.ho_for_each
|
||||
env["call-fn"] = sx_ref.call_fn
|
||||
|
||||
# Render-related (stub for testing — no active rendering)
|
||||
env["render-active?"] = lambda: False
|
||||
env["is-render-expr?"] = lambda expr: False
|
||||
env["render-expr"] = lambda expr, env: NIL
|
||||
|
||||
# Scope primitives (needed for reactive-shift-deref island cleanup)
|
||||
env["scope-push!"] = sx_ref.PRIMITIVES.get("scope-push!", lambda *a: NIL)
|
||||
env["scope-pop!"] = sx_ref.PRIMITIVES.get("scope-pop!", lambda *a: NIL)
|
||||
env["context"] = sx_ref.PRIMITIVES.get("context", lambda *a: NIL)
|
||||
env["emit!"] = sx_ref.PRIMITIVES.get("emit!", lambda *a: NIL)
|
||||
env["emitted"] = sx_ref.PRIMITIVES.get("emitted", lambda *a: [])
|
||||
|
||||
# Dynamic wind
|
||||
env["push-wind!"] = lambda before, after: NIL
|
||||
env["pop-wind!"] = lambda: NIL
|
||||
env["call-thunk"] = lambda f, e: f() if callable(f) else trampoline(eval_expr([f], e))
|
||||
|
||||
# Mutation helpers
|
||||
env["dict-get"] = lambda d, k: d.get(k, NIL) if isinstance(d, dict) else NIL
|
||||
env["identical?"] = lambda a, b: a is b
|
||||
|
||||
# defhandler, defpage, defquery, defaction stubs
|
||||
for name in ["sf-defhandler", "sf-defpage", "sf-defquery", "sf-defaction"]:
|
||||
pyname = name.replace("-", "_")
|
||||
fn = getattr(sx_ref, pyname, None)
|
||||
if fn:
|
||||
env[name] = fn
|
||||
else:
|
||||
env[name] = lambda args, e, _n=name: NIL
|
||||
|
||||
# Load test framework
|
||||
with open(os.path.join(_SPEC_TESTS, "test-framework.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Load signals module
|
||||
print("Loading signals.sx ...")
|
||||
with open(os.path.join(_PROJECT, "web", "signals.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Load frames module
|
||||
print("Loading frames.sx ...")
|
||||
with open(os.path.join(_PROJECT, "spec", "frames.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Load CEK module
|
||||
print("Loading cek.sx ...")
|
||||
with open(os.path.join(_PROJECT, "spec", "cek.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Run tests
|
||||
print("=" * 60)
|
||||
print("Running test-cek-reactive.sx")
|
||||
print("=" * 60)
|
||||
|
||||
with open(os.path.join(_WEB_TESTS, "test-cek-reactive.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
print("=" * 60)
|
||||
print(f"Results: {_pass_count} passed, {_fail_count} failed")
|
||||
print("=" * 60)
|
||||
sys.exit(1 if _fail_count > 0 else 0)
|
||||
@@ -1,267 +0,0 @@
|
||||
#!/usr/bin/env python3
|
||||
"""Run test-cek.sx using the bootstrapped evaluator with CEK module loaded."""
|
||||
from __future__ import annotations
|
||||
import os, sys
|
||||
|
||||
_HERE = os.path.dirname(os.path.abspath(__file__))
|
||||
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", "..", ".."))
|
||||
_SPEC_TESTS = os.path.join(_PROJECT, "spec", "tests")
|
||||
_WEB_TESTS = os.path.join(_PROJECT, "web", "tests")
|
||||
sys.path.insert(0, _PROJECT)
|
||||
|
||||
from shared.sx.ref.sx_ref import sx_parse as parse_all
|
||||
from shared.sx.ref import sx_ref
|
||||
from shared.sx.ref.sx_ref import (
|
||||
make_env, env_get, env_has, env_set,
|
||||
env_extend, env_merge,
|
||||
)
|
||||
# Use tree-walk evaluator for interpreting .sx test files.
|
||||
# The CEK override (eval_expr = cek_run) would cause the interpreted cek.sx
|
||||
# to delegate to the transpiled CEK, not the interpreted one being tested.
|
||||
# Override both the local names AND the module-level names so that transpiled
|
||||
# functions (ho_map, call_lambda, etc.) also use tree-walk internally.
|
||||
eval_expr = sx_ref._tree_walk_eval_expr
|
||||
trampoline = sx_ref._tree_walk_trampoline
|
||||
sx_ref.eval_expr = eval_expr
|
||||
sx_ref.trampoline = trampoline
|
||||
from shared.sx.types import (
|
||||
NIL, Symbol, Keyword, Lambda, Component, Island, Continuation, Macro,
|
||||
_ShiftSignal,
|
||||
)
|
||||
|
||||
# Build env with primitives
|
||||
env = make_env()
|
||||
|
||||
# Platform test functions
|
||||
_suite_stack: list[str] = []
|
||||
_pass_count = 0
|
||||
_fail_count = 0
|
||||
|
||||
def _try_call(thunk):
|
||||
try:
|
||||
trampoline(eval_expr([thunk], env))
|
||||
return {"ok": True}
|
||||
except Exception as e:
|
||||
return {"ok": False, "error": str(e)}
|
||||
|
||||
def _report_pass(name):
|
||||
global _pass_count
|
||||
_pass_count += 1
|
||||
ctx = " > ".join(_suite_stack)
|
||||
print(f" PASS: {ctx} > {name}")
|
||||
return NIL
|
||||
|
||||
def _report_fail(name, error):
|
||||
global _fail_count
|
||||
_fail_count += 1
|
||||
ctx = " > ".join(_suite_stack)
|
||||
print(f" FAIL: {ctx} > {name}: {error}")
|
||||
return NIL
|
||||
|
||||
def _push_suite(name):
|
||||
_suite_stack.append(name)
|
||||
print(f"{' ' * (len(_suite_stack)-1)}Suite: {name}")
|
||||
return NIL
|
||||
|
||||
def _pop_suite():
|
||||
if _suite_stack:
|
||||
_suite_stack.pop()
|
||||
return NIL
|
||||
|
||||
def _test_env():
|
||||
return env
|
||||
|
||||
def _sx_parse(source):
|
||||
return parse_all(source)
|
||||
|
||||
def _sx_parse_one(source):
|
||||
"""Parse a single expression."""
|
||||
exprs = parse_all(source)
|
||||
return exprs[0] if exprs else NIL
|
||||
|
||||
def _make_continuation(fn):
|
||||
return Continuation(fn)
|
||||
|
||||
env["try-call"] = _try_call
|
||||
env["report-pass"] = _report_pass
|
||||
env["report-fail"] = _report_fail
|
||||
env["push-suite"] = _push_suite
|
||||
env["pop-suite"] = _pop_suite
|
||||
env["test-env"] = _test_env
|
||||
env["sx-parse"] = _sx_parse
|
||||
env["sx-parse-one"] = _sx_parse_one
|
||||
env["env-get"] = env_get
|
||||
env["env-has?"] = env_has
|
||||
env["env-set!"] = env_set
|
||||
env["env-extend"] = env_extend
|
||||
env["make-continuation"] = _make_continuation
|
||||
env["continuation?"] = lambda x: isinstance(x, Continuation)
|
||||
env["continuation-fn"] = lambda c: c.fn
|
||||
|
||||
def _make_cek_continuation(captured, rest_kont):
|
||||
"""Create a Continuation that stores captured CEK frames as data."""
|
||||
data = {"captured": captured, "rest-kont": rest_kont}
|
||||
# The fn is a dummy — invocation happens via CEK's continue-with-call
|
||||
return Continuation(lambda v=NIL: v)
|
||||
|
||||
# Monkey-patch to store data
|
||||
_orig_make_cek_cont = _make_cek_continuation
|
||||
def _make_cek_continuation_with_data(captured, rest_kont):
|
||||
c = _orig_make_cek_cont(captured, rest_kont)
|
||||
c._cek_data = {"captured": captured, "rest-kont": rest_kont}
|
||||
return c
|
||||
|
||||
env["make-cek-continuation"] = _make_cek_continuation_with_data
|
||||
env["continuation-data"] = lambda c: getattr(c, '_cek_data', {})
|
||||
|
||||
# Register platform functions from sx_ref that cek.sx and eval.sx need
|
||||
# These are normally available as transpiled Python but need to be in the
|
||||
# SX env when interpreting .sx files directly.
|
||||
|
||||
# Type predicates and constructors
|
||||
env["callable?"] = lambda x: callable(x) or isinstance(x, (Lambda, Component, Island, Continuation))
|
||||
env["lambda?"] = lambda x: isinstance(x, Lambda)
|
||||
env["component?"] = lambda x: isinstance(x, Component)
|
||||
env["island?"] = lambda x: isinstance(x, Island)
|
||||
env["macro?"] = lambda x: isinstance(x, Macro)
|
||||
env["thunk?"] = sx_ref.is_thunk
|
||||
env["thunk-expr"] = sx_ref.thunk_expr
|
||||
env["thunk-env"] = sx_ref.thunk_env
|
||||
env["make-thunk"] = sx_ref.make_thunk
|
||||
env["make-lambda"] = sx_ref.make_lambda
|
||||
env["make-component"] = sx_ref.make_component
|
||||
env["make-island"] = sx_ref.make_island
|
||||
env["make-macro"] = sx_ref.make_macro
|
||||
env["make-symbol"] = lambda n: Symbol(n)
|
||||
env["lambda-params"] = lambda f: f.params
|
||||
env["lambda-body"] = lambda f: f.body
|
||||
env["lambda-closure"] = lambda f: f.closure
|
||||
env["lambda-name"] = lambda f: f.name
|
||||
env["set-lambda-name!"] = lambda f, n: setattr(f, 'name', n) or NIL
|
||||
env["component-params"] = lambda c: c.params
|
||||
env["component-body"] = lambda c: c.body
|
||||
env["component-closure"] = lambda c: c.closure
|
||||
env["component-has-children?"] = lambda c: c.has_children
|
||||
env["component-affinity"] = lambda c: getattr(c, 'affinity', 'auto')
|
||||
env["component-set-param-types!"] = lambda c, t: setattr(c, 'param_types', t) or NIL
|
||||
env["macro-params"] = lambda m: m.params
|
||||
env["macro-rest-param"] = lambda m: m.rest_param
|
||||
env["macro-body"] = lambda m: m.body
|
||||
env["macro-closure"] = lambda m: m.closure
|
||||
env["env-merge"] = env_merge
|
||||
env["symbol-name"] = lambda s: s.name if isinstance(s, Symbol) else str(s)
|
||||
env["keyword-name"] = lambda k: k.name if isinstance(k, Keyword) else str(k)
|
||||
env["type-of"] = sx_ref.type_of
|
||||
env["primitive?"] = lambda n: n in sx_ref.PRIMITIVES
|
||||
env["get-primitive"] = lambda n: sx_ref.PRIMITIVES.get(n)
|
||||
env["strip-prefix"] = lambda s, p: s[len(p):] if s.startswith(p) else s
|
||||
env["inspect"] = repr
|
||||
env["debug-log"] = lambda *args: None
|
||||
env["error"] = sx_ref.error
|
||||
env["apply"] = lambda f, args: f(*args)
|
||||
|
||||
# Functions from eval.sx that cek.sx references
|
||||
env["trampoline"] = trampoline
|
||||
env["eval-expr"] = eval_expr
|
||||
env["eval-list"] = sx_ref.eval_list
|
||||
env["eval-call"] = sx_ref.eval_call
|
||||
env["call-lambda"] = sx_ref.call_lambda
|
||||
env["call-component"] = sx_ref.call_component
|
||||
env["parse-keyword-args"] = sx_ref.parse_keyword_args
|
||||
env["sf-lambda"] = sx_ref.sf_lambda
|
||||
env["sf-defcomp"] = sx_ref.sf_defcomp
|
||||
env["sf-defisland"] = sx_ref.sf_defisland
|
||||
env["sf-defmacro"] = sx_ref.sf_defmacro
|
||||
env["sf-defstyle"] = sx_ref.sf_defstyle
|
||||
env["sf-deftype"] = sx_ref.sf_deftype
|
||||
env["sf-defeffect"] = sx_ref.sf_defeffect
|
||||
env["sf-letrec"] = sx_ref.sf_letrec
|
||||
env["sf-named-let"] = sx_ref.sf_named_let
|
||||
env["sf-dynamic-wind"] = sx_ref.sf_dynamic_wind
|
||||
env["sf-scope"] = sx_ref.sf_scope
|
||||
env["sf-provide"] = sx_ref.sf_provide
|
||||
env["qq-expand"] = sx_ref.qq_expand
|
||||
env["expand-macro"] = sx_ref.expand_macro
|
||||
env["cond-scheme?"] = sx_ref.cond_scheme_p
|
||||
|
||||
# Higher-order form handlers
|
||||
env["ho-map"] = sx_ref.ho_map
|
||||
env["ho-map-indexed"] = sx_ref.ho_map_indexed
|
||||
env["ho-filter"] = sx_ref.ho_filter
|
||||
env["ho-reduce"] = sx_ref.ho_reduce
|
||||
env["ho-some"] = sx_ref.ho_some
|
||||
env["ho-every"] = sx_ref.ho_every
|
||||
env["ho-for-each"] = sx_ref.ho_for_each
|
||||
env["call-fn"] = sx_ref.call_fn
|
||||
|
||||
# Render-related (stub for testing — no active rendering)
|
||||
env["render-active?"] = lambda: False
|
||||
env["is-render-expr?"] = lambda expr: False
|
||||
env["render-expr"] = lambda expr, env: NIL
|
||||
|
||||
# Scope primitives
|
||||
env["scope-push!"] = sx_ref.PRIMITIVES.get("scope-push!", lambda *a: NIL)
|
||||
env["scope-pop!"] = sx_ref.PRIMITIVES.get("scope-pop!", lambda *a: NIL)
|
||||
env["context"] = sx_ref.PRIMITIVES.get("context", lambda *a: NIL)
|
||||
env["emit!"] = sx_ref.PRIMITIVES.get("emit!", lambda *a: NIL)
|
||||
env["emitted"] = sx_ref.PRIMITIVES.get("emitted", lambda *a: [])
|
||||
|
||||
# Dynamic wind
|
||||
env["push-wind!"] = lambda before, after: NIL
|
||||
env["pop-wind!"] = lambda: NIL
|
||||
env["call-thunk"] = lambda f, e: f() if callable(f) else trampoline(eval_expr([f], e))
|
||||
|
||||
# Mutation helpers used by parse-keyword-args etc
|
||||
env["dict-get"] = lambda d, k: d.get(k, NIL) if isinstance(d, dict) else NIL
|
||||
|
||||
# defhandler, defpage, defquery, defaction — these are registrations
|
||||
# Use the bootstrapped versions if they exist, otherwise stub
|
||||
for name in ["sf-defhandler", "sf-defpage", "sf-defquery", "sf-defaction"]:
|
||||
pyname = name.replace("-", "_")
|
||||
fn = getattr(sx_ref, pyname, None)
|
||||
if fn:
|
||||
env[name] = fn
|
||||
else:
|
||||
env[name] = lambda args, e, _n=name: NIL
|
||||
|
||||
# Load test framework
|
||||
with open(os.path.join(_SPEC_TESTS, "test-framework.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Load frames module
|
||||
print("Loading frames.sx ...")
|
||||
with open(os.path.join(_PROJECT, "spec", "frames.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Load CEK module
|
||||
print("Loading cek.sx ...")
|
||||
with open(os.path.join(_PROJECT, "spec", "cek.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Define cek-eval helper in SX
|
||||
for expr in parse_all("""
|
||||
(define cek-eval
|
||||
(fn (source)
|
||||
(let ((exprs (sx-parse source)))
|
||||
(let ((result nil))
|
||||
(for-each (fn (e) (set! result (eval-expr-cek e (test-env)))) exprs)
|
||||
result))))
|
||||
"""):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Run tests
|
||||
print("=" * 60)
|
||||
print("Running test-cek.sx")
|
||||
print("=" * 60)
|
||||
|
||||
with open(os.path.join(_SPEC_TESTS, "test-cek.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
print("=" * 60)
|
||||
print(f"Results: {_pass_count} passed, {_fail_count} failed")
|
||||
print("=" * 60)
|
||||
sys.exit(1 if _fail_count > 0 else 0)
|
||||
@@ -1,108 +0,0 @@
|
||||
#!/usr/bin/env python3
|
||||
"""Run test-continuations.sx using the bootstrapped evaluator with continuations enabled."""
|
||||
from __future__ import annotations
|
||||
import os, sys, subprocess, tempfile
|
||||
|
||||
_HERE = os.path.dirname(os.path.abspath(__file__))
|
||||
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", "..", ".."))
|
||||
_SPEC_TESTS = os.path.join(_PROJECT, "spec", "tests")
|
||||
_WEB_TESTS = os.path.join(_PROJECT, "web", "tests")
|
||||
sys.path.insert(0, _PROJECT)
|
||||
|
||||
# Bootstrap a fresh sx_ref with continuations enabled
|
||||
print("Bootstrapping with --extensions continuations ...")
|
||||
result = subprocess.run(
|
||||
[sys.executable, os.path.join(_HERE, "..", "bootstrap.py"),
|
||||
"--extensions", "continuations"],
|
||||
capture_output=True, text=True, cwd=_PROJECT,
|
||||
)
|
||||
if result.returncode != 0:
|
||||
print("Bootstrap FAILED:")
|
||||
print(result.stderr)
|
||||
sys.exit(1)
|
||||
|
||||
# Write to temp file and import
|
||||
tmp = tempfile.NamedTemporaryFile(mode="w", suffix=".py", delete=False, dir=_HERE)
|
||||
tmp.write(result.stdout)
|
||||
tmp.close()
|
||||
|
||||
try:
|
||||
import importlib.util
|
||||
spec = importlib.util.spec_from_file_location("sx_ref_cont", tmp.name)
|
||||
mod = importlib.util.module_from_spec(spec)
|
||||
spec.loader.exec_module(mod)
|
||||
finally:
|
||||
os.unlink(tmp.name)
|
||||
|
||||
from shared.sx.types import NIL
|
||||
parse_all = mod.sx_parse
|
||||
|
||||
# Use tree-walk evaluator for interpreting .sx test files.
|
||||
# CEK is now the default, but test runners need tree-walk so that
|
||||
# transpiled HO forms (ho_map, etc.) don't re-enter CEK mid-evaluation.
|
||||
eval_expr = mod._tree_walk_eval_expr
|
||||
trampoline = mod._tree_walk_trampoline
|
||||
mod.eval_expr = eval_expr
|
||||
mod.trampoline = trampoline
|
||||
env = mod.make_env()
|
||||
|
||||
# Platform test functions
|
||||
_suite_stack: list[str] = []
|
||||
_pass_count = 0
|
||||
_fail_count = 0
|
||||
|
||||
def _try_call(thunk):
|
||||
try:
|
||||
trampoline(eval_expr([thunk], env))
|
||||
return {"ok": True}
|
||||
except Exception as e:
|
||||
return {"ok": False, "error": str(e)}
|
||||
|
||||
def _report_pass(name):
|
||||
global _pass_count
|
||||
_pass_count += 1
|
||||
ctx = " > ".join(_suite_stack)
|
||||
print(f" PASS: {ctx} > {name}")
|
||||
return NIL
|
||||
|
||||
def _report_fail(name, error):
|
||||
global _fail_count
|
||||
_fail_count += 1
|
||||
ctx = " > ".join(_suite_stack)
|
||||
print(f" FAIL: {ctx} > {name}: {error}")
|
||||
return NIL
|
||||
|
||||
def _push_suite(name):
|
||||
_suite_stack.append(name)
|
||||
print(f"{' ' * (len(_suite_stack)-1)}Suite: {name}")
|
||||
return NIL
|
||||
|
||||
def _pop_suite():
|
||||
if _suite_stack:
|
||||
_suite_stack.pop()
|
||||
return NIL
|
||||
|
||||
env["try-call"] = _try_call
|
||||
env["report-pass"] = _report_pass
|
||||
env["report-fail"] = _report_fail
|
||||
env["push-suite"] = _push_suite
|
||||
env["pop-suite"] = _pop_suite
|
||||
|
||||
# Load test framework
|
||||
with open(os.path.join(_SPEC_TESTS, "test-framework.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Run tests
|
||||
print("=" * 60)
|
||||
print("Running test-continuations.sx")
|
||||
print("=" * 60)
|
||||
|
||||
with open(os.path.join(_SPEC_TESTS, "test-continuations.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
print("=" * 60)
|
||||
print(f"Results: {_pass_count} passed, {_fail_count} failed")
|
||||
print("=" * 60)
|
||||
sys.exit(1 if _fail_count > 0 else 0)
|
||||
@@ -1,164 +0,0 @@
|
||||
#!/usr/bin/env python3
|
||||
"""Run test-signals.sx using the bootstrapped evaluator with signal primitives.
|
||||
|
||||
Uses bootstrapped signal functions from sx_ref.py directly, patching apply
|
||||
to handle SX lambdas from the interpreter (test expressions create lambdas
|
||||
that need evaluator dispatch).
|
||||
"""
|
||||
from __future__ import annotations
|
||||
import os, sys
|
||||
|
||||
_HERE = os.path.dirname(os.path.abspath(__file__))
|
||||
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", "..", ".."))
|
||||
_SPEC_TESTS = os.path.join(_PROJECT, "spec", "tests")
|
||||
_WEB_TESTS = os.path.join(_PROJECT, "web", "tests")
|
||||
sys.path.insert(0, _PROJECT)
|
||||
|
||||
from shared.sx.ref.sx_ref import sx_parse as parse_all
|
||||
from shared.sx.ref import sx_ref
|
||||
from shared.sx.ref.sx_ref import make_env, scope_push, scope_pop, sx_context
|
||||
from shared.sx.types import NIL, Island, Lambda
|
||||
# Use tree-walk evaluator for interpreting .sx test files.
|
||||
eval_expr = sx_ref._tree_walk_eval_expr
|
||||
trampoline = sx_ref._tree_walk_trampoline
|
||||
sx_ref.eval_expr = eval_expr
|
||||
sx_ref.trampoline = trampoline
|
||||
|
||||
# Build env with primitives
|
||||
env = make_env()
|
||||
|
||||
# --- Patch apply BEFORE anything else ---
|
||||
# Test expressions create SX Lambdas that bootstrapped code calls via apply.
|
||||
# Patch the module-level function so all bootstrapped functions see it.
|
||||
|
||||
# apply is used by swap! and other forms to call functions with arg lists
|
||||
def _apply(f, args):
|
||||
if isinstance(f, Lambda):
|
||||
return trampoline(eval_expr([f] + list(args), env))
|
||||
return f(*args)
|
||||
sx_ref.__dict__["apply"] = _apply
|
||||
|
||||
# cons needs to handle tuples from Python *args (swap! passes &rest as tuple)
|
||||
_orig_cons = sx_ref.PRIMITIVES.get("cons")
|
||||
def _cons(x, c):
|
||||
if isinstance(c, tuple):
|
||||
c = list(c)
|
||||
return [x] + (c or [])
|
||||
sx_ref.__dict__["cons"] = _cons
|
||||
sx_ref.PRIMITIVES["cons"] = _cons
|
||||
|
||||
# Platform test functions
|
||||
_suite_stack: list[str] = []
|
||||
_pass_count = 0
|
||||
_fail_count = 0
|
||||
|
||||
def _try_call(thunk):
|
||||
try:
|
||||
trampoline(eval_expr([thunk], env))
|
||||
return {"ok": True}
|
||||
except Exception as e:
|
||||
return {"ok": False, "error": str(e)}
|
||||
|
||||
def _report_pass(name):
|
||||
global _pass_count
|
||||
_pass_count += 1
|
||||
ctx = " > ".join(_suite_stack)
|
||||
print(f" PASS: {ctx} > {name}")
|
||||
return NIL
|
||||
|
||||
def _report_fail(name, error):
|
||||
global _fail_count
|
||||
_fail_count += 1
|
||||
ctx = " > ".join(_suite_stack)
|
||||
print(f" FAIL: {ctx} > {name}: {error}")
|
||||
return NIL
|
||||
|
||||
def _push_suite(name):
|
||||
_suite_stack.append(name)
|
||||
print(f"{' ' * (len(_suite_stack)-1)}Suite: {name}")
|
||||
return NIL
|
||||
|
||||
def _pop_suite():
|
||||
if _suite_stack:
|
||||
_suite_stack.pop()
|
||||
return NIL
|
||||
|
||||
env["try-call"] = _try_call
|
||||
env["report-pass"] = _report_pass
|
||||
env["report-fail"] = _report_fail
|
||||
env["push-suite"] = _push_suite
|
||||
env["pop-suite"] = _pop_suite
|
||||
|
||||
# Signal functions are now pure SX (transpiled into sx_ref.py from signals.sx)
|
||||
# Wire both low-level dict-based signal functions and high-level API
|
||||
env["identical?"] = sx_ref.is_identical
|
||||
env["island?"] = lambda x: isinstance(x, Island)
|
||||
|
||||
# Scope primitives (used by signals.sx for reactive tracking)
|
||||
env["scope-push!"] = scope_push
|
||||
env["scope-pop!"] = scope_pop
|
||||
env["context"] = sx_context
|
||||
|
||||
# Low-level signal functions (now pure SX, transpiled from signals.sx)
|
||||
env["make-signal"] = sx_ref.make_signal
|
||||
env["signal?"] = sx_ref.is_signal
|
||||
env["signal-value"] = sx_ref.signal_value
|
||||
env["signal-set-value!"] = sx_ref.signal_set_value
|
||||
env["signal-subscribers"] = sx_ref.signal_subscribers
|
||||
env["signal-add-sub!"] = sx_ref.signal_add_sub
|
||||
env["signal-remove-sub!"] = sx_ref.signal_remove_sub
|
||||
env["signal-deps"] = sx_ref.signal_deps
|
||||
env["signal-set-deps!"] = sx_ref.signal_set_deps
|
||||
|
||||
# Bootstrapped signal functions from sx_ref.py
|
||||
env["signal"] = sx_ref.signal
|
||||
env["deref"] = sx_ref.deref
|
||||
env["reset!"] = sx_ref.reset_b
|
||||
env["swap!"] = sx_ref.swap_b
|
||||
env["computed"] = sx_ref.computed
|
||||
env["effect"] = sx_ref.effect
|
||||
# batch has a bootstrapper issue with _batch_depth global variable access.
|
||||
# Wrap it to work correctly in the test context.
|
||||
def _batch(thunk):
|
||||
sx_ref._batch_depth = getattr(sx_ref, '_batch_depth', 0) + 1
|
||||
sx_ref.cek_call(thunk, None)
|
||||
sx_ref._batch_depth -= 1
|
||||
if sx_ref._batch_depth == 0:
|
||||
queue = list(sx_ref._batch_queue)
|
||||
sx_ref._batch_queue = []
|
||||
seen = []
|
||||
pending = []
|
||||
for s in queue:
|
||||
for sub in sx_ref.signal_subscribers(s):
|
||||
if sub not in seen:
|
||||
seen.append(sub)
|
||||
pending.append(sub)
|
||||
for sub in pending:
|
||||
sub()
|
||||
return NIL
|
||||
env["batch"] = _batch
|
||||
env["notify-subscribers"] = sx_ref.notify_subscribers
|
||||
env["flush-subscribers"] = sx_ref.flush_subscribers
|
||||
env["dispose-computed"] = sx_ref.dispose_computed
|
||||
env["with-island-scope"] = sx_ref.with_island_scope
|
||||
env["register-in-scope"] = sx_ref.register_in_scope
|
||||
env["callable?"] = sx_ref.is_callable
|
||||
|
||||
# Load test framework
|
||||
with open(os.path.join(_SPEC_TESTS, "test-framework.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Run tests
|
||||
print("=" * 60)
|
||||
print("Running test-signals.sx")
|
||||
print("=" * 60)
|
||||
|
||||
with open(os.path.join(_WEB_TESTS, "test-signals.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
print("=" * 60)
|
||||
print(f"Results: {_pass_count} passed, {_fail_count} failed")
|
||||
print("=" * 60)
|
||||
sys.exit(1 if _fail_count > 0 else 0)
|
||||
@@ -1,316 +0,0 @@
|
||||
#!/usr/bin/env python3
|
||||
"""
|
||||
Run SX spec tests using the bootstrapped Python evaluator.
|
||||
|
||||
Usage:
|
||||
python3 hosts/python/tests/run_tests.py # all spec tests
|
||||
python3 hosts/python/tests/run_tests.py test-primitives # specific test
|
||||
python3 hosts/python/tests/run_tests.py --full # include optional modules
|
||||
"""
|
||||
from __future__ import annotations
|
||||
import os, sys
|
||||
|
||||
# Increase recursion limit for TCO tests (Python's default 1000 is too low)
|
||||
sys.setrecursionlimit(5000)
|
||||
|
||||
_HERE = os.path.dirname(os.path.abspath(__file__))
|
||||
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", "..", ".."))
|
||||
_SPEC_TESTS = os.path.join(_PROJECT, "spec", "tests")
|
||||
sys.path.insert(0, _PROJECT)
|
||||
|
||||
from shared.sx.ref.sx_ref import sx_parse as parse_all
|
||||
from shared.sx.ref import sx_ref
|
||||
from shared.sx.ref.sx_ref import (
|
||||
make_env, env_get, env_has, env_set, env_extend, env_merge,
|
||||
)
|
||||
from shared.sx.types import (
|
||||
NIL, Symbol, Keyword, Lambda, Component, Island, Macro,
|
||||
)
|
||||
|
||||
# Use tree-walk evaluator
|
||||
eval_expr = sx_ref._tree_walk_eval_expr
|
||||
trampoline = sx_ref._tree_walk_trampoline
|
||||
sx_ref.eval_expr = eval_expr
|
||||
sx_ref.trampoline = trampoline
|
||||
|
||||
# Check for --full flag
|
||||
full_build = "--full" in sys.argv
|
||||
|
||||
# Build env with primitives
|
||||
env = make_env()
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Test infrastructure
|
||||
# ---------------------------------------------------------------------------
|
||||
_suite_stack: list[str] = []
|
||||
_pass_count = 0
|
||||
_fail_count = 0
|
||||
|
||||
|
||||
def _try_call(thunk):
|
||||
try:
|
||||
trampoline(eval_expr([thunk], env))
|
||||
return {"ok": True}
|
||||
except Exception as e:
|
||||
return {"ok": False, "error": str(e)}
|
||||
|
||||
|
||||
def _report_pass(name):
|
||||
global _pass_count
|
||||
_pass_count += 1
|
||||
ctx = " > ".join(_suite_stack)
|
||||
print(f" PASS: {ctx} > {name}")
|
||||
return NIL
|
||||
|
||||
|
||||
def _report_fail(name, error):
|
||||
global _fail_count
|
||||
_fail_count += 1
|
||||
ctx = " > ".join(_suite_stack)
|
||||
print(f" FAIL: {ctx} > {name}: {error}")
|
||||
return NIL
|
||||
|
||||
|
||||
def _push_suite(name):
|
||||
_suite_stack.append(name)
|
||||
print(f"{' ' * (len(_suite_stack)-1)}Suite: {name}")
|
||||
return NIL
|
||||
|
||||
|
||||
def _pop_suite():
|
||||
if _suite_stack:
|
||||
_suite_stack.pop()
|
||||
return NIL
|
||||
|
||||
|
||||
env["try-call"] = _try_call
|
||||
env["report-pass"] = _report_pass
|
||||
env["report-fail"] = _report_fail
|
||||
env["push-suite"] = _push_suite
|
||||
env["pop-suite"] = _pop_suite
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Test helpers
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
|
||||
def _deep_equal(a, b):
|
||||
if a is b:
|
||||
return True
|
||||
if a is NIL and b is NIL:
|
||||
return True
|
||||
if a is NIL or b is NIL:
|
||||
return a is None and b is NIL or b is None and a is NIL
|
||||
if type(a) != type(b):
|
||||
# number comparison: int vs float
|
||||
if isinstance(a, (int, float)) and isinstance(b, (int, float)):
|
||||
return a == b
|
||||
return False
|
||||
if isinstance(a, list):
|
||||
if len(a) != len(b):
|
||||
return False
|
||||
return all(_deep_equal(x, y) for x, y in zip(a, b))
|
||||
if isinstance(a, dict):
|
||||
ka = {k for k in a if k != "_nil"}
|
||||
kb = {k for k in b if k != "_nil"}
|
||||
if ka != kb:
|
||||
return False
|
||||
return all(_deep_equal(a[k], b[k]) for k in ka)
|
||||
return a == b
|
||||
|
||||
|
||||
env["equal?"] = _deep_equal
|
||||
env["identical?"] = lambda a, b: a is b
|
||||
|
||||
|
||||
def _test_env():
|
||||
return make_env()
|
||||
|
||||
|
||||
def _sx_parse(source):
|
||||
return parse_all(source)
|
||||
|
||||
|
||||
def _sx_parse_one(source):
|
||||
exprs = parse_all(source)
|
||||
return exprs[0] if exprs else NIL
|
||||
|
||||
|
||||
env["test-env"] = _test_env
|
||||
env["sx-parse"] = _sx_parse
|
||||
env["sx-parse-one"] = _sx_parse_one
|
||||
env["cek-eval"] = lambda s: trampoline(eval_expr(parse_all(s)[0], make_env())) if parse_all(s) else NIL
|
||||
env["eval-expr-cek"] = lambda expr, e=None: trampoline(eval_expr(expr, e or env))
|
||||
|
||||
# Env operations
|
||||
env["env-get"] = env_get
|
||||
env["env-has?"] = env_has
|
||||
env["env-set!"] = env_set
|
||||
env["env-bind!"] = lambda e, k, v: e.__setitem__(k, v) or v
|
||||
env["env-extend"] = env_extend
|
||||
env["env-merge"] = env_merge
|
||||
|
||||
# Missing primitives
|
||||
env["upcase"] = lambda s: str(s).upper()
|
||||
env["downcase"] = lambda s: str(s).lower()
|
||||
env["make-keyword"] = lambda name: Keyword(name)
|
||||
env["make-symbol"] = lambda name: Symbol(name)
|
||||
env["string-length"] = lambda s: len(str(s))
|
||||
env["dict-get"] = lambda d, k: d.get(k, NIL) if isinstance(d, dict) else NIL
|
||||
env["apply"] = lambda f, *args: f(*args[-1]) if args and isinstance(args[-1], list) else f()
|
||||
|
||||
# Render helpers
|
||||
def _render_html(src, e=None):
|
||||
if isinstance(src, str):
|
||||
parsed = parse_all(src)
|
||||
if not parsed:
|
||||
return ""
|
||||
expr = parsed[0] if len(parsed) == 1 else [Symbol("do")] + parsed
|
||||
result = sx_ref.render_to_html(expr, e or make_env())
|
||||
# Reset render mode
|
||||
sx_ref._render_mode = False
|
||||
return result
|
||||
result = sx_ref.render_to_html(src, e or env)
|
||||
sx_ref._render_mode = False
|
||||
return result
|
||||
|
||||
|
||||
env["render-html"] = _render_html
|
||||
env["render-to-html"] = _render_html
|
||||
env["string-contains?"] = lambda s, sub: str(sub) in str(s)
|
||||
|
||||
# Type system helpers
|
||||
env["test-prim-types"] = lambda: {
|
||||
"+": "number", "-": "number", "*": "number", "/": "number",
|
||||
"mod": "number", "inc": "number", "dec": "number",
|
||||
"abs": "number", "min": "number", "max": "number",
|
||||
"str": "string", "upper": "string", "lower": "string",
|
||||
"trim": "string", "join": "string", "replace": "string",
|
||||
"=": "boolean", "<": "boolean", ">": "boolean",
|
||||
"<=": "boolean", ">=": "boolean",
|
||||
"not": "boolean", "nil?": "boolean", "empty?": "boolean",
|
||||
"number?": "boolean", "string?": "boolean", "boolean?": "boolean",
|
||||
"list?": "boolean", "dict?": "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",
|
||||
"assoc": "dict", "dissoc": "dict", "merge": "dict", "dict": "dict",
|
||||
"get": "any", "type-of": "string",
|
||||
}
|
||||
env["test-prim-param-types"] = lambda: {
|
||||
"+": {"positional": [["a", "number"]], "rest-type": "number"},
|
||||
"-": {"positional": [["a", "number"]], "rest-type": "number"},
|
||||
"*": {"positional": [["a", "number"]], "rest-type": "number"},
|
||||
"/": {"positional": [["a", "number"]], "rest-type": "number"},
|
||||
"inc": {"positional": [["n", "number"]], "rest-type": NIL},
|
||||
"dec": {"positional": [["n", "number"]], "rest-type": NIL},
|
||||
"upper": {"positional": [["s", "string"]], "rest-type": NIL},
|
||||
"lower": {"positional": [["s", "string"]], "rest-type": NIL},
|
||||
"keys": {"positional": [["d", "dict"]], "rest-type": NIL},
|
||||
"vals": {"positional": [["d", "dict"]], "rest-type": NIL},
|
||||
}
|
||||
env["component-param-types"] = lambda c: getattr(c, "_param_types", NIL)
|
||||
env["component-set-param-types!"] = lambda c, t: setattr(c, "_param_types", t) or NIL
|
||||
env["component-params"] = lambda c: c.params
|
||||
env["component-body"] = lambda c: c.body
|
||||
env["component-has-children"] = lambda c: c.has_children
|
||||
env["component-affinity"] = lambda c: getattr(c, "affinity", "auto")
|
||||
|
||||
# Type accessors
|
||||
env["callable?"] = lambda x: callable(x) or isinstance(x, (Lambda, Component, Island))
|
||||
env["lambda?"] = lambda x: isinstance(x, Lambda)
|
||||
env["component?"] = lambda x: isinstance(x, Component)
|
||||
env["island?"] = lambda x: isinstance(x, Island)
|
||||
env["macro?"] = lambda x: isinstance(x, Macro)
|
||||
env["thunk?"] = sx_ref.is_thunk
|
||||
env["thunk-expr"] = sx_ref.thunk_expr
|
||||
env["thunk-env"] = sx_ref.thunk_env
|
||||
env["make-thunk"] = sx_ref.make_thunk
|
||||
env["make-lambda"] = sx_ref.make_lambda
|
||||
env["make-component"] = sx_ref.make_component
|
||||
env["make-macro"] = sx_ref.make_macro
|
||||
env["lambda-params"] = lambda f: f.params
|
||||
env["lambda-body"] = lambda f: f.body
|
||||
env["lambda-closure"] = lambda f: f.closure
|
||||
env["lambda-name"] = lambda f: f.name
|
||||
env["set-lambda-name!"] = lambda f, n: setattr(f, "name", n) or NIL
|
||||
env["component-closure"] = lambda c: c.closure
|
||||
env["component-name"] = lambda c: c.name
|
||||
env["component-has-children?"] = lambda c: c.has_children
|
||||
env["macro-params"] = lambda m: m.params
|
||||
env["macro-rest-param"] = lambda m: m.rest_param
|
||||
env["macro-body"] = lambda m: m.body
|
||||
env["macro-closure"] = lambda m: m.closure
|
||||
env["symbol-name"] = lambda s: s.name if isinstance(s, Symbol) else str(s)
|
||||
env["keyword-name"] = lambda k: k.name if isinstance(k, Keyword) else str(k)
|
||||
env["sx-serialize"] = sx_ref.sx_serialize if hasattr(sx_ref, "sx_serialize") else lambda x: str(x)
|
||||
env["is-render-expr?"] = lambda expr: False
|
||||
env["render-active?"] = lambda: False
|
||||
env["render-expr"] = lambda expr, env: NIL
|
||||
|
||||
# Strict mode stubs (not yet bootstrapped to Python — no-ops for now)
|
||||
env["set-strict!"] = lambda val: NIL
|
||||
env["set-prim-param-types!"] = lambda types: NIL
|
||||
env["value-matches-type?"] = lambda val, t: True
|
||||
env["*strict*"] = False
|
||||
env["primitive?"] = lambda name: name in env
|
||||
env["get-primitive"] = lambda name: env.get(name, NIL)
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Load test framework
|
||||
# ---------------------------------------------------------------------------
|
||||
framework_src = open(os.path.join(_SPEC_TESTS, "test-framework.sx")).read()
|
||||
for expr in parse_all(framework_src):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Determine which tests to run
|
||||
# ---------------------------------------------------------------------------
|
||||
args = [a for a in sys.argv[1:] if not a.startswith("--")]
|
||||
|
||||
# Tests requiring optional modules (only with --full)
|
||||
REQUIRES_FULL = {"test-continuations.sx", "test-continuations-advanced.sx", "test-types.sx", "test-freeze.sx", "test-strict.sx", "test-cek.sx", "test-cek-advanced.sx", "test-signals-advanced.sx"}
|
||||
|
||||
test_files = []
|
||||
if args:
|
||||
for arg in args:
|
||||
name = arg if arg.endswith(".sx") else f"{arg}.sx"
|
||||
p = os.path.join(_SPEC_TESTS, name)
|
||||
if os.path.exists(p):
|
||||
test_files.append(p)
|
||||
else:
|
||||
print(f"Test file not found: {name}")
|
||||
else:
|
||||
for f in sorted(os.listdir(_SPEC_TESTS)):
|
||||
if f.startswith("test-") and f.endswith(".sx") and f != "test-framework.sx":
|
||||
if not full_build and f in REQUIRES_FULL:
|
||||
print(f"Skipping {f} (requires --full)")
|
||||
continue
|
||||
test_files.append(os.path.join(_SPEC_TESTS, f))
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Run tests
|
||||
# ---------------------------------------------------------------------------
|
||||
for test_file in test_files:
|
||||
name = os.path.basename(test_file)
|
||||
print("=" * 60)
|
||||
print(f"Running {name}")
|
||||
print("=" * 60)
|
||||
try:
|
||||
src = open(test_file).read()
|
||||
exprs = parse_all(src)
|
||||
for expr in exprs:
|
||||
trampoline(eval_expr(expr, env))
|
||||
except Exception as e:
|
||||
print(f"ERROR in {name}: {e}")
|
||||
_fail_count += 1
|
||||
|
||||
# Summary
|
||||
print("=" * 60)
|
||||
print(f"Results: {_pass_count} passed, {_fail_count} failed")
|
||||
print("=" * 60)
|
||||
sys.exit(1 if _fail_count > 0 else 0)
|
||||
@@ -1,194 +0,0 @@
|
||||
#!/usr/bin/env python3
|
||||
"""Run test-types.sx using the bootstrapped evaluator with types module loaded."""
|
||||
from __future__ import annotations
|
||||
import os, sys
|
||||
|
||||
_HERE = os.path.dirname(os.path.abspath(__file__))
|
||||
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", "..", ".."))
|
||||
_SPEC_DIR = os.path.join(_PROJECT, "spec")
|
||||
_SPEC_TESTS = os.path.join(_PROJECT, "spec", "tests")
|
||||
_WEB_TESTS = os.path.join(_PROJECT, "web", "tests")
|
||||
sys.path.insert(0, _PROJECT)
|
||||
|
||||
from shared.sx.ref.sx_ref import sx_parse as parse_all
|
||||
from shared.sx.ref import sx_ref
|
||||
from shared.sx.ref.sx_ref import make_env, env_get, env_has, env_set
|
||||
from shared.sx.types import NIL, Component
|
||||
# Use tree-walk evaluator for interpreting .sx test files.
|
||||
# CEK is now the default, but the test runners need tree-walk so that
|
||||
# transpiled HO forms (ho_map, etc.) don't re-enter CEK mid-evaluation.
|
||||
eval_expr = sx_ref._tree_walk_eval_expr
|
||||
trampoline = sx_ref._tree_walk_trampoline
|
||||
sx_ref.eval_expr = eval_expr
|
||||
sx_ref.trampoline = trampoline
|
||||
|
||||
# Build env with primitives
|
||||
env = make_env()
|
||||
|
||||
# Platform test functions
|
||||
_suite_stack: list[str] = []
|
||||
_pass_count = 0
|
||||
_fail_count = 0
|
||||
|
||||
def _try_call(thunk):
|
||||
try:
|
||||
trampoline(eval_expr([thunk], env)) # call the thunk
|
||||
return {"ok": True}
|
||||
except Exception as e:
|
||||
return {"ok": False, "error": str(e)}
|
||||
|
||||
def _report_pass(name):
|
||||
global _pass_count
|
||||
_pass_count += 1
|
||||
ctx = " > ".join(_suite_stack)
|
||||
print(f" PASS: {ctx} > {name}")
|
||||
return NIL
|
||||
|
||||
def _report_fail(name, error):
|
||||
global _fail_count
|
||||
_fail_count += 1
|
||||
ctx = " > ".join(_suite_stack)
|
||||
print(f" FAIL: {ctx} > {name}: {error}")
|
||||
return NIL
|
||||
|
||||
def _push_suite(name):
|
||||
_suite_stack.append(name)
|
||||
print(f"{' ' * (len(_suite_stack)-1)}Suite: {name}")
|
||||
return NIL
|
||||
|
||||
def _pop_suite():
|
||||
if _suite_stack:
|
||||
_suite_stack.pop()
|
||||
return NIL
|
||||
|
||||
env["try-call"] = _try_call
|
||||
env["report-pass"] = _report_pass
|
||||
env["report-fail"] = _report_fail
|
||||
env["push-suite"] = _push_suite
|
||||
env["pop-suite"] = _pop_suite
|
||||
|
||||
# Test fixtures — provide the functions that tests expect
|
||||
|
||||
# test-prim-types: dict of primitive return types for type inference
|
||||
def _test_prim_types():
|
||||
return {
|
||||
"+": "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",
|
||||
}
|
||||
|
||||
# test-prim-param-types: dict of primitive param type specs
|
||||
# Format: {name → {"positional" [["name" "type"] ...] "rest-type" type-or-nil}}
|
||||
def _test_prim_param_types():
|
||||
return {
|
||||
"+": {"positional": [["a", "number"]], "rest-type": "number"},
|
||||
"-": {"positional": [["a", "number"]], "rest-type": "number"},
|
||||
"*": {"positional": [["a", "number"]], "rest-type": "number"},
|
||||
"/": {"positional": [["a", "number"]], "rest-type": "number"},
|
||||
"inc": {"positional": [["n", "number"]], "rest-type": NIL},
|
||||
"dec": {"positional": [["n", "number"]], "rest-type": NIL},
|
||||
"upper": {"positional": [["s", "string"]], "rest-type": NIL},
|
||||
"lower": {"positional": [["s", "string"]], "rest-type": NIL},
|
||||
"keys": {"positional": [["d", "dict"]], "rest-type": NIL},
|
||||
"vals": {"positional": [["d", "dict"]], "rest-type": NIL},
|
||||
}
|
||||
|
||||
# test-env: returns a fresh env for use in tests (same as the test env)
|
||||
def _test_env():
|
||||
return env
|
||||
|
||||
# sx-parse: parse an SX string and return list of AST nodes
|
||||
def _sx_parse(source):
|
||||
return parse_all(source)
|
||||
|
||||
# dict-get: used in some legacy tests
|
||||
def _dict_get(d, k):
|
||||
v = d.get(k) if isinstance(d, dict) else NIL
|
||||
return v if v is not None else NIL
|
||||
|
||||
# component-set-param-types! and component-param-types: type annotation accessors
|
||||
def _component_set_param_types(comp, types_dict):
|
||||
comp.param_types = types_dict
|
||||
return NIL
|
||||
|
||||
def _component_param_types(comp):
|
||||
return getattr(comp, 'param_types', NIL)
|
||||
|
||||
# Platform functions used by types.sx but not SX primitives
|
||||
def _component_params(c):
|
||||
return c.params
|
||||
|
||||
def _component_body(c):
|
||||
return c.body
|
||||
|
||||
def _component_has_children(c):
|
||||
return c.has_children
|
||||
|
||||
def _map_dict(fn, d):
|
||||
from shared.sx.types import Lambda as _Lambda
|
||||
result = {}
|
||||
for k, v in d.items():
|
||||
if isinstance(fn, _Lambda):
|
||||
# Call SX lambda through the evaluator
|
||||
result[k] = trampoline(eval_expr([fn, k, v], env))
|
||||
else:
|
||||
result[k] = fn(k, v)
|
||||
return result
|
||||
|
||||
env["test-prim-types"] = _test_prim_types
|
||||
env["test-prim-param-types"] = _test_prim_param_types
|
||||
env["test-env"] = _test_env
|
||||
env["sx-parse"] = _sx_parse
|
||||
env["dict-get"] = _dict_get
|
||||
env["component-set-param-types!"] = _component_set_param_types
|
||||
env["component-param-types"] = _component_param_types
|
||||
env["component-params"] = _component_params
|
||||
env["component-body"] = _component_body
|
||||
env["component-has-children"] = _component_has_children
|
||||
env["map-dict"] = _map_dict
|
||||
env["env-get"] = env_get
|
||||
env["env-has?"] = env_has
|
||||
env["env-set!"] = env_set
|
||||
|
||||
# Load test framework (macros + assertion helpers)
|
||||
with open(os.path.join(_SPEC_TESTS, "test-framework.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Load types module
|
||||
with open(os.path.join(_SPEC_DIR, "types.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Run tests
|
||||
print("=" * 60)
|
||||
print("Running test-types.sx")
|
||||
print("=" * 60)
|
||||
|
||||
with open(os.path.join(_SPEC_TESTS, "test-types.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
print("=" * 60)
|
||||
print(f"Results: {_pass_count} passed, {_fail_count} failed")
|
||||
print("=" * 60)
|
||||
sys.exit(1 if _fail_count > 0 else 0)
|
||||
@@ -93,6 +93,11 @@
|
||||
"*batch-depth*" "_batch_depth"
|
||||
"*batch-queue*" "_batch_queue"
|
||||
"*store-registry*" "_store_registry"
|
||||
"*custom-special-forms*" "_custom_special_forms"
|
||||
"*render-check*" "_render_check"
|
||||
"*render-fn*" "_render_fn"
|
||||
"register-special-form!" "register_special_form_b"
|
||||
"is-else-clause?" "is_else_clause_p"
|
||||
"def-store" "def_store"
|
||||
"use-store" "use_store"
|
||||
"clear-stores" "clear_stores"
|
||||
|
||||
163
lib/bytecode.sx
Normal file
163
lib/bytecode.sx
Normal file
@@ -0,0 +1,163 @@
|
||||
;; ==========================================================================
|
||||
;; bytecode.sx — SX bytecode format definition
|
||||
;;
|
||||
;; Universal bytecode for SX evaluation. Produced by compiler.sx,
|
||||
;; executed by platform-native VMs (OCaml, JS, WASM).
|
||||
;;
|
||||
;; Design principles:
|
||||
;; - One byte per opcode (~65 ops, fits in u8)
|
||||
;; - Variable-length encoding (1-5 bytes per instruction)
|
||||
;; - Lexical scope resolved at compile time (no hash lookups)
|
||||
;; - Tail calls detected statically (no thunks/trampoline)
|
||||
;; - Control flow via jumps (no continuation frames for if/when/etc.)
|
||||
;; - Content-addressable (deterministic binary for CID)
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Opcode constants
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Stack / Constants
|
||||
(define OP_CONST 1) ;; u16 pool_idx — push constant
|
||||
(define OP_NIL 2) ;; push nil
|
||||
(define OP_TRUE 3) ;; push true
|
||||
(define OP_FALSE 4) ;; push false
|
||||
(define OP_POP 5) ;; discard TOS
|
||||
(define OP_DUP 6) ;; duplicate TOS
|
||||
|
||||
;; Variable access (resolved at compile time)
|
||||
(define OP_LOCAL_GET 16) ;; u8 slot
|
||||
(define OP_LOCAL_SET 17) ;; u8 slot
|
||||
(define OP_UPVALUE_GET 18) ;; u8 idx
|
||||
(define OP_UPVALUE_SET 19) ;; u8 idx
|
||||
(define OP_GLOBAL_GET 20) ;; u16 name_idx
|
||||
(define OP_GLOBAL_SET 21) ;; u16 name_idx
|
||||
|
||||
;; Control flow (replaces if/when/cond/and/or frames)
|
||||
(define OP_JUMP 32) ;; i16 offset
|
||||
(define OP_JUMP_IF_FALSE 33) ;; i16 offset
|
||||
(define OP_JUMP_IF_TRUE 34) ;; i16 offset
|
||||
|
||||
;; Function operations
|
||||
(define OP_CALL 48) ;; u8 argc
|
||||
(define OP_TAIL_CALL 49) ;; u8 argc — reuse frame (TCO)
|
||||
(define OP_RETURN 50) ;; return TOS
|
||||
(define OP_CLOSURE 51) ;; u16 code_idx — create closure
|
||||
(define OP_CALL_PRIM 52) ;; u16 name_idx, u8 argc — direct primitive
|
||||
(define OP_APPLY 53) ;; (apply f args-list)
|
||||
|
||||
;; Collection construction
|
||||
(define OP_LIST 64) ;; u16 count — build list from stack
|
||||
(define OP_DICT 65) ;; u16 count — build dict from stack pairs
|
||||
(define OP_APPEND_BANG 66) ;; (append! TOS-1 TOS)
|
||||
|
||||
;; Higher-order forms (inlined loop)
|
||||
(define OP_ITER_INIT 80) ;; init iterator on TOS list
|
||||
(define OP_ITER_NEXT 81) ;; i16 end_offset — push next or jump
|
||||
(define OP_MAP_OPEN 82) ;; push empty accumulator
|
||||
(define OP_MAP_APPEND 83) ;; append TOS to accumulator
|
||||
(define OP_MAP_CLOSE 84) ;; pop accumulator as list
|
||||
(define OP_FILTER_TEST 85) ;; i16 skip — if falsy jump (skip append)
|
||||
|
||||
;; HO fallback (dynamic callback)
|
||||
(define OP_HO_MAP 88) ;; (map fn coll)
|
||||
(define OP_HO_FILTER 89) ;; (filter fn coll)
|
||||
(define OP_HO_REDUCE 90) ;; (reduce fn init coll)
|
||||
(define OP_HO_FOR_EACH 91) ;; (for-each fn coll)
|
||||
(define OP_HO_SOME 92) ;; (some fn coll)
|
||||
(define OP_HO_EVERY 93) ;; (every? fn coll)
|
||||
|
||||
;; Scope / dynamic binding
|
||||
(define OP_SCOPE_PUSH 96) ;; TOS = name
|
||||
(define OP_SCOPE_POP 97)
|
||||
(define OP_PROVIDE_PUSH 98) ;; TOS-1 = name, TOS = value
|
||||
(define OP_PROVIDE_POP 99)
|
||||
(define OP_CONTEXT 100) ;; TOS = name → push value
|
||||
(define OP_EMIT 101) ;; TOS-1 = name, TOS = value
|
||||
(define OP_EMITTED 102) ;; TOS = name → push collected
|
||||
|
||||
;; Continuations
|
||||
(define OP_RESET 112) ;; i16 body_len — push delimiter
|
||||
(define OP_SHIFT 113) ;; u8 k_slot, i16 body_len — capture k
|
||||
|
||||
;; Define / component
|
||||
(define OP_DEFINE 128) ;; u16 name_idx — bind TOS to name
|
||||
(define OP_DEFCOMP 129) ;; u16 template_idx
|
||||
(define OP_DEFISLAND 130) ;; u16 template_idx
|
||||
(define OP_DEFMACRO 131) ;; u16 template_idx
|
||||
(define OP_EXPAND_MACRO 132) ;; u8 argc — runtime macro expansion
|
||||
|
||||
;; String / serialize (hot path)
|
||||
(define OP_STR_CONCAT 144) ;; u8 count — concat N values as strings
|
||||
(define OP_STR_JOIN 145) ;; (join sep list)
|
||||
(define OP_SERIALIZE 146) ;; serialize TOS to SX string
|
||||
|
||||
;; Inline primitives (hot path — no hashtable lookup)
|
||||
(define OP_ADD 160) ;; TOS-1 + TOS → push
|
||||
(define OP_SUB 161) ;; TOS-1 - TOS → push
|
||||
(define OP_MUL 162) ;; TOS-1 * TOS → push
|
||||
(define OP_DIV 163) ;; TOS-1 / TOS → push
|
||||
(define OP_EQ 164) ;; TOS-1 = TOS → push bool
|
||||
(define OP_LT 165) ;; TOS-1 < TOS → push bool
|
||||
(define OP_GT 166) ;; TOS-1 > TOS → push bool
|
||||
(define OP_NOT 167) ;; !TOS → push bool
|
||||
(define OP_LEN 168) ;; len(TOS) → push number
|
||||
(define OP_FIRST 169) ;; first(TOS) → push
|
||||
(define OP_REST 170) ;; rest(TOS) → push list
|
||||
(define OP_NTH 171) ;; nth(TOS-1, TOS) → push
|
||||
(define OP_CONS 172) ;; cons(TOS-1, TOS) → push list
|
||||
(define OP_NEG 173) ;; negate TOS → push number
|
||||
(define OP_INC 174) ;; TOS + 1 → push
|
||||
(define OP_DEC 175) ;; TOS - 1 → push
|
||||
|
||||
;; Aser specialization (optional, 224-239 reserved)
|
||||
(define OP_ASER_TAG 224) ;; u16 tag_name_idx — serialize HTML tag
|
||||
(define OP_ASER_FRAG 225) ;; u8 child_count — serialize fragment
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Bytecode module structure
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; A module contains:
|
||||
;; magic: "SXBC" (4 bytes)
|
||||
;; version: u16
|
||||
;; pool_count: u32
|
||||
;; pool: constant pool entries (self-describing tagged values)
|
||||
;; code_count: u32
|
||||
;; codes: code objects
|
||||
;; entry: u32 (index of entry-point code object)
|
||||
|
||||
(define BYTECODE_MAGIC "SXBC")
|
||||
(define BYTECODE_VERSION 1)
|
||||
|
||||
;; Constant pool tags
|
||||
(define CONST_NUMBER 1)
|
||||
(define CONST_STRING 2)
|
||||
(define CONST_BOOL 3)
|
||||
(define CONST_NIL 4)
|
||||
(define CONST_SYMBOL 5)
|
||||
(define CONST_KEYWORD 6)
|
||||
(define CONST_LIST 7)
|
||||
(define CONST_DICT 8)
|
||||
(define CONST_CODE 9)
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Disassembler
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define opcode-name
|
||||
(fn (op)
|
||||
(cond
|
||||
(= op 1) "CONST" (= op 2) "NIL"
|
||||
(= op 3) "TRUE" (= op 4) "FALSE"
|
||||
(= op 5) "POP" (= op 6) "DUP"
|
||||
(= op 16) "LOCAL_GET" (= op 17) "LOCAL_SET"
|
||||
(= op 20) "GLOBAL_GET" (= op 21) "GLOBAL_SET"
|
||||
(= op 32) "JUMP" (= op 33) "JUMP_IF_FALSE"
|
||||
(= op 48) "CALL" (= op 49) "TAIL_CALL"
|
||||
(= op 50) "RETURN" (= op 52) "CALL_PRIM"
|
||||
(= op 128) "DEFINE" (= op 144) "STR_CONCAT"
|
||||
:else (str "OP_" op))))
|
||||
826
lib/compiler.sx
Normal file
826
lib/compiler.sx
Normal file
@@ -0,0 +1,826 @@
|
||||
;; ==========================================================================
|
||||
;; compiler.sx — SX bytecode compiler
|
||||
;;
|
||||
;; Compiles SX AST to bytecode for the platform-native VM.
|
||||
;; Written in SX — runs on any platform with an SX evaluator.
|
||||
;;
|
||||
;; Architecture:
|
||||
;; Pass 1: Scope analysis — resolve variables, detect tail positions
|
||||
;; Pass 2: Code generation — emit bytecode
|
||||
;;
|
||||
;; The compiler produces Code objects (bytecode + constant pool).
|
||||
;; The VM executes them with a stack machine model.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Constant pool builder
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define make-pool
|
||||
(fn ()
|
||||
{:entries (if (primitive? "mutable-list") (mutable-list) (list))
|
||||
:index {:_count 0}}))
|
||||
|
||||
(define pool-add
|
||||
(fn (pool value)
|
||||
"Add a value to the constant pool, return its index. Deduplicates."
|
||||
(let ((key (serialize value))
|
||||
(idx-map (get pool "index")))
|
||||
(if (has-key? idx-map key)
|
||||
(get idx-map key)
|
||||
(let ((idx (get idx-map "_count")))
|
||||
(dict-set! idx-map key idx)
|
||||
(dict-set! idx-map "_count" (+ idx 1))
|
||||
(append! (get pool "entries") value)
|
||||
idx)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Scope analysis
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define make-scope
|
||||
(fn (parent)
|
||||
{:locals (list) ;; list of {name, slot, mutable?}
|
||||
:upvalues (list) ;; list of {name, is-local, index}
|
||||
:parent parent
|
||||
:is-function false ;; true for fn/lambda scopes (create frames)
|
||||
:next-slot 0}))
|
||||
|
||||
(define scope-define-local
|
||||
(fn (scope name)
|
||||
"Add a local variable, return its slot index.
|
||||
Idempotent: if name already has a slot, return it."
|
||||
(let ((existing (first (filter (fn (l) (= (get l "name") name))
|
||||
(get scope "locals")))))
|
||||
(if existing
|
||||
(get existing "slot")
|
||||
(let ((slot (get scope "next-slot")))
|
||||
(append! (get scope "locals")
|
||||
{:name name :slot slot :mutable false})
|
||||
(dict-set! scope "next-slot" (+ slot 1))
|
||||
slot)))))
|
||||
|
||||
(define scope-resolve
|
||||
(fn (scope name)
|
||||
"Resolve a variable name. Returns {:type \"local\"|\"upvalue\"|\"global\", :index N}.
|
||||
Upvalue captures only happen at function boundaries (is-function=true).
|
||||
Let scopes share the enclosing function's frame — their locals are
|
||||
accessed directly without upvalue indirection."
|
||||
(if (nil? scope)
|
||||
{:type "global" :index name}
|
||||
;; Check locals in this scope
|
||||
(let ((locals (get scope "locals"))
|
||||
(found (some (fn (l) (= (get l "name") name)) locals)))
|
||||
(if found
|
||||
(let ((local (first (filter (fn (l) (= (get l "name") name)) locals))))
|
||||
{:type "local" :index (get local "slot")})
|
||||
;; Check upvalues already captured at this scope
|
||||
(let ((upvals (get scope "upvalues"))
|
||||
(uv-found (some (fn (u) (= (get u "name") name)) upvals)))
|
||||
(if uv-found
|
||||
(let ((uv (first (filter (fn (u) (= (get u "name") name)) upvals))))
|
||||
{:type "upvalue" :index (get uv "uv-index")})
|
||||
;; Look in parent
|
||||
(let ((parent (get scope "parent")))
|
||||
(if (nil? parent)
|
||||
{:type "global" :index name}
|
||||
(let ((parent-result (scope-resolve parent name)))
|
||||
(if (= (get parent-result "type") "global")
|
||||
parent-result
|
||||
;; Found in parent. Capture as upvalue only at function boundaries.
|
||||
(if (get scope "is-function")
|
||||
;; Function boundary — create upvalue capture
|
||||
(let ((uv-idx (len (get scope "upvalues"))))
|
||||
(append! (get scope "upvalues")
|
||||
{:name name
|
||||
:is-local (= (get parent-result "type") "local")
|
||||
:index (get parent-result "index")
|
||||
:uv-index uv-idx})
|
||||
{:type "upvalue" :index uv-idx})
|
||||
;; Let scope — pass through (same frame)
|
||||
parent-result))))))))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Code emitter
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define make-emitter
|
||||
(fn ()
|
||||
{:bytecode (if (primitive? "mutable-list") (mutable-list) (list))
|
||||
:pool (make-pool)}))
|
||||
|
||||
(define emit-byte
|
||||
(fn (em byte)
|
||||
(append! (get em "bytecode") byte)))
|
||||
|
||||
(define emit-u16
|
||||
(fn (em value)
|
||||
(emit-byte em (mod value 256))
|
||||
(emit-byte em (mod (floor (/ value 256)) 256))))
|
||||
|
||||
(define emit-i16
|
||||
(fn (em value)
|
||||
(let ((v (if (< value 0) (+ value 65536) value)))
|
||||
(emit-u16 em v))))
|
||||
|
||||
(define emit-op
|
||||
(fn (em opcode)
|
||||
(emit-byte em opcode)))
|
||||
|
||||
(define emit-const
|
||||
(fn (em value)
|
||||
(let ((idx (pool-add (get em "pool") value)))
|
||||
(emit-op em 1) ;; OP_CONST
|
||||
(emit-u16 em idx))))
|
||||
|
||||
(define current-offset
|
||||
(fn (em)
|
||||
(len (get em "bytecode"))))
|
||||
|
||||
(define patch-i16
|
||||
(fn (em offset value)
|
||||
"Patch a previously emitted i16 at the given bytecode offset."
|
||||
(let ((v (if (< value 0) (+ value 65536) value))
|
||||
(bc (get em "bytecode")))
|
||||
;; Direct mutation of bytecode list at offset
|
||||
(set-nth! bc offset (mod v 256))
|
||||
(set-nth! bc (+ offset 1) (mod (floor (/ v 256)) 256)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Compilation — expression dispatch
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define compile-expr
|
||||
(fn (em expr scope tail?)
|
||||
"Compile an expression. tail? indicates tail position for TCO."
|
||||
(cond
|
||||
;; Nil
|
||||
(nil? expr)
|
||||
(emit-op em 2) ;; OP_NIL
|
||||
|
||||
;; Number
|
||||
(= (type-of expr) "number")
|
||||
(emit-const em expr)
|
||||
|
||||
;; String
|
||||
(= (type-of expr) "string")
|
||||
(emit-const em expr)
|
||||
|
||||
;; Boolean
|
||||
(= (type-of expr) "boolean")
|
||||
(emit-op em (if expr 3 4)) ;; OP_TRUE / OP_FALSE
|
||||
|
||||
;; Keyword
|
||||
(= (type-of expr) "keyword")
|
||||
(emit-const em (keyword-name expr))
|
||||
|
||||
;; Symbol — resolve to local/upvalue/global
|
||||
(= (type-of expr) "symbol")
|
||||
(compile-symbol em (symbol-name expr) scope)
|
||||
|
||||
;; List — dispatch on head
|
||||
(= (type-of expr) "list")
|
||||
(if (empty? expr)
|
||||
(do (emit-op em 64) (emit-u16 em 0)) ;; OP_LIST 0
|
||||
(compile-list em expr scope tail?))
|
||||
|
||||
;; Dict literal
|
||||
(= (type-of expr) "dict")
|
||||
(compile-dict em expr scope)
|
||||
|
||||
;; Fallback
|
||||
:else
|
||||
(emit-const em expr))))
|
||||
|
||||
|
||||
(define compile-symbol
|
||||
(fn (em name scope)
|
||||
(let ((resolved (scope-resolve scope name)))
|
||||
(cond
|
||||
(= (get resolved "type") "local")
|
||||
(do (emit-op em 16) ;; OP_LOCAL_GET
|
||||
(emit-byte em (get resolved "index")))
|
||||
(= (get resolved "type") "upvalue")
|
||||
(do (emit-op em 18) ;; OP_UPVALUE_GET
|
||||
(emit-byte em (get resolved "index")))
|
||||
:else
|
||||
;; Global or primitive
|
||||
(let ((idx (pool-add (get em "pool") name)))
|
||||
(emit-op em 20) ;; OP_GLOBAL_GET
|
||||
(emit-u16 em idx))))))
|
||||
|
||||
|
||||
(define compile-dict
|
||||
(fn (em expr scope)
|
||||
(let ((ks (keys expr))
|
||||
(count (len ks)))
|
||||
(for-each (fn (k)
|
||||
(emit-const em k)
|
||||
(compile-expr em (get expr k) scope false))
|
||||
ks)
|
||||
(emit-op em 65) ;; OP_DICT
|
||||
(emit-u16 em count))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; List compilation — special forms, calls
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define compile-list
|
||||
(fn (em expr scope tail?)
|
||||
(let ((head (first expr))
|
||||
(args (rest expr)))
|
||||
(if (not (= (type-of head) "symbol"))
|
||||
;; Non-symbol head — compile as call
|
||||
(compile-call em head args scope tail?)
|
||||
;; Symbol head — check for special forms
|
||||
(let ((name (symbol-name head)))
|
||||
(cond
|
||||
(= name "if") (compile-if em args scope tail?)
|
||||
(= name "when") (compile-when em args scope tail?)
|
||||
(= name "and") (compile-and em args scope tail?)
|
||||
(= name "or") (compile-or em args scope tail?)
|
||||
(= name "let") (compile-let em args scope tail?)
|
||||
(= name "let*") (compile-let em args scope tail?)
|
||||
(= name "begin") (compile-begin em args scope tail?)
|
||||
(= name "do") (compile-begin em args scope tail?)
|
||||
(= name "lambda") (compile-lambda em args scope)
|
||||
(= name "fn") (compile-lambda em args scope)
|
||||
(= name "define") (compile-define em args scope)
|
||||
(= name "set!") (compile-set em args scope)
|
||||
(= name "quote") (compile-quote em args)
|
||||
(= name "cond") (compile-cond em args scope tail?)
|
||||
(= name "case") (compile-case em args scope tail?)
|
||||
(= name "->") (compile-thread em args scope tail?)
|
||||
(= name "defcomp") (compile-defcomp em args scope)
|
||||
(= name "defisland") (compile-defcomp em args scope)
|
||||
(= name "defmacro") (compile-defmacro em args scope)
|
||||
(= name "defstyle") (emit-op em 2) ;; defstyle → nil (no-op at runtime)
|
||||
(= name "defhandler") (emit-op em 2) ;; no-op
|
||||
(= name "defpage") (emit-op em 2) ;; handled by page loader
|
||||
(= name "defquery") (emit-op em 2)
|
||||
(= name "defaction") (emit-op em 2)
|
||||
(= name "defrelation") (emit-op em 2)
|
||||
(= name "deftype") (emit-op em 2)
|
||||
(= name "defeffect") (emit-op em 2)
|
||||
(= name "defisland") (compile-defcomp em args scope)
|
||||
(= name "quasiquote") (compile-quasiquote em (first args) scope)
|
||||
(= name "letrec") (compile-letrec em args scope tail?)
|
||||
;; Default — function call
|
||||
:else
|
||||
(compile-call em head args scope tail?)))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Special form compilation
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define compile-if
|
||||
(fn (em args scope tail?)
|
||||
(let ((test (first args))
|
||||
(then-expr (nth args 1))
|
||||
(else-expr (if (> (len args) 2) (nth args 2) nil)))
|
||||
;; Compile test
|
||||
(compile-expr em test scope false)
|
||||
;; Jump if false to else
|
||||
(emit-op em 33) ;; OP_JUMP_IF_FALSE
|
||||
(let ((else-jump (current-offset em)))
|
||||
(emit-i16 em 0) ;; placeholder
|
||||
;; Compile then (in tail position if if is)
|
||||
(compile-expr em then-expr scope tail?)
|
||||
;; Jump over else
|
||||
(emit-op em 32) ;; OP_JUMP
|
||||
(let ((end-jump (current-offset em)))
|
||||
(emit-i16 em 0) ;; placeholder
|
||||
;; Patch else jump
|
||||
(patch-i16 em else-jump (- (current-offset em) (+ else-jump 2)))
|
||||
;; Compile else
|
||||
(if (nil? else-expr)
|
||||
(emit-op em 2) ;; OP_NIL
|
||||
(compile-expr em else-expr scope tail?))
|
||||
;; Patch end jump
|
||||
(patch-i16 em end-jump (- (current-offset em) (+ end-jump 2))))))))
|
||||
|
||||
|
||||
(define compile-when
|
||||
(fn (em args scope tail?)
|
||||
(let ((test (first args))
|
||||
(body (rest args)))
|
||||
(compile-expr em test scope false)
|
||||
(emit-op em 33) ;; OP_JUMP_IF_FALSE
|
||||
(let ((skip-jump (current-offset em)))
|
||||
(emit-i16 em 0)
|
||||
(compile-begin em body scope tail?)
|
||||
(emit-op em 32) ;; OP_JUMP
|
||||
(let ((end-jump (current-offset em)))
|
||||
(emit-i16 em 0)
|
||||
(patch-i16 em skip-jump (- (current-offset em) (+ skip-jump 2)))
|
||||
(emit-op em 2) ;; OP_NIL
|
||||
(patch-i16 em end-jump (- (current-offset em) (+ end-jump 2))))))))
|
||||
|
||||
|
||||
(define compile-and
|
||||
(fn (em args scope tail?)
|
||||
(if (empty? args)
|
||||
(emit-op em 3) ;; OP_TRUE
|
||||
(if (= (len args) 1)
|
||||
(compile-expr em (first args) scope tail?)
|
||||
(do
|
||||
(compile-expr em (first args) scope false)
|
||||
(emit-op em 6) ;; OP_DUP
|
||||
(emit-op em 33) ;; OP_JUMP_IF_FALSE
|
||||
(let ((skip (current-offset em)))
|
||||
(emit-i16 em 0)
|
||||
(emit-op em 5) ;; OP_POP (discard duplicated truthy)
|
||||
(compile-and em (rest args) scope tail?)
|
||||
(patch-i16 em skip (- (current-offset em) (+ skip 2)))))))))
|
||||
|
||||
|
||||
(define compile-or
|
||||
(fn (em args scope tail?)
|
||||
(if (empty? args)
|
||||
(emit-op em 4) ;; OP_FALSE
|
||||
(if (= (len args) 1)
|
||||
(compile-expr em (first args) scope tail?)
|
||||
(do
|
||||
(compile-expr em (first args) scope false)
|
||||
(emit-op em 6) ;; OP_DUP
|
||||
(emit-op em 34) ;; OP_JUMP_IF_TRUE
|
||||
(let ((skip (current-offset em)))
|
||||
(emit-i16 em 0)
|
||||
(emit-op em 5) ;; OP_POP
|
||||
(compile-or em (rest args) scope tail?)
|
||||
(patch-i16 em skip (- (current-offset em) (+ skip 2)))))))))
|
||||
|
||||
|
||||
(define compile-begin
|
||||
(fn (em exprs scope tail?)
|
||||
;; Hoist: pre-allocate local slots for all define forms in this block.
|
||||
;; Enables forward references between inner functions (e.g. sx-parse).
|
||||
;; Only inside function bodies (scope has parent), not at top level.
|
||||
(when (and (not (empty? exprs)) (not (nil? (get scope "parent"))))
|
||||
(for-each (fn (expr)
|
||||
(when (and (= (type-of expr) "list")
|
||||
(>= (len expr) 2)
|
||||
(= (type-of (first expr)) "symbol")
|
||||
(= (symbol-name (first expr)) "define"))
|
||||
(let ((name-expr (nth expr 1))
|
||||
(name (if (= (type-of name-expr) "symbol")
|
||||
(symbol-name name-expr)
|
||||
name-expr)))
|
||||
(scope-define-local scope name))))
|
||||
exprs))
|
||||
;; Compile expressions
|
||||
(if (empty? exprs)
|
||||
(emit-op em 2) ;; OP_NIL
|
||||
(if (= (len exprs) 1)
|
||||
(compile-expr em (first exprs) scope tail?)
|
||||
(do
|
||||
(compile-expr em (first exprs) scope false)
|
||||
(emit-op em 5) ;; OP_POP
|
||||
(compile-begin em (rest exprs) scope tail?))))))
|
||||
|
||||
|
||||
(define compile-let
|
||||
(fn (em args scope tail?)
|
||||
;; Detect named let: (let loop ((x init) ...) body)
|
||||
(if (= (type-of (first args)) "symbol")
|
||||
;; Named let → desugar to letrec:
|
||||
;; (letrec ((loop (fn (x ...) body))) (loop init ...))
|
||||
(let ((loop-name (symbol-name (first args)))
|
||||
(bindings (nth args 1))
|
||||
(body (slice args 2))
|
||||
(params (list))
|
||||
(inits (list)))
|
||||
(for-each (fn (binding)
|
||||
(append! params (if (= (type-of (first binding)) "symbol")
|
||||
(first binding)
|
||||
(make-symbol (first binding))))
|
||||
(append! inits (nth binding 1)))
|
||||
bindings)
|
||||
;; Compile as: (letrec ((loop (fn (params...) body...))) (loop inits...))
|
||||
(let ((lambda-expr (concat (list (make-symbol "fn") params) body))
|
||||
(letrec-bindings (list (list (make-symbol loop-name) lambda-expr)))
|
||||
(call-expr (cons (make-symbol loop-name) inits)))
|
||||
(compile-letrec em (list letrec-bindings call-expr) scope tail?)))
|
||||
;; Normal let
|
||||
(let ((bindings (first args))
|
||||
(body (rest args))
|
||||
(let-scope (make-scope scope)))
|
||||
;; Let scopes share the enclosing function's frame.
|
||||
;; Continue slot numbering from parent.
|
||||
(dict-set! let-scope "next-slot" (get scope "next-slot"))
|
||||
;; Compile each binding
|
||||
(for-each (fn (binding)
|
||||
(let ((name (if (= (type-of (first binding)) "symbol")
|
||||
(symbol-name (first binding))
|
||||
(first binding)))
|
||||
(value (nth binding 1))
|
||||
(slot (scope-define-local let-scope name)))
|
||||
(compile-expr em value let-scope false)
|
||||
(emit-op em 17) ;; OP_LOCAL_SET
|
||||
(emit-byte em slot)))
|
||||
bindings)
|
||||
;; Compile body in let scope
|
||||
(compile-begin em body let-scope tail?)))))
|
||||
|
||||
|
||||
(define compile-letrec
|
||||
(fn (em args scope tail?)
|
||||
"Compile letrec: all names visible during value compilation.
|
||||
1. Define all local slots (initialized to nil).
|
||||
2. Compile each value and assign — names are already in scope
|
||||
so mutually recursive functions can reference each other."
|
||||
(let ((bindings (first args))
|
||||
(body (rest args))
|
||||
(let-scope (make-scope scope)))
|
||||
(dict-set! let-scope "next-slot" (get scope "next-slot"))
|
||||
;; Phase 1: define all slots (push nil for each)
|
||||
(let ((slots (map (fn (binding)
|
||||
(let ((name (if (= (type-of (first binding)) "symbol")
|
||||
(symbol-name (first binding))
|
||||
(first binding))))
|
||||
(let ((slot (scope-define-local let-scope name)))
|
||||
(emit-op em 2) ;; OP_NIL
|
||||
(emit-op em 17) ;; OP_LOCAL_SET
|
||||
(emit-byte em slot)
|
||||
slot)))
|
||||
bindings)))
|
||||
;; Phase 2: compile values and assign (all names in scope)
|
||||
(for-each (fn (pair)
|
||||
(let ((binding (first pair))
|
||||
(slot (nth pair 1)))
|
||||
(compile-expr em (nth binding 1) let-scope false)
|
||||
(emit-op em 17) ;; OP_LOCAL_SET
|
||||
(emit-byte em slot)))
|
||||
(map (fn (i) (list (nth bindings i) (nth slots i)))
|
||||
(range 0 (len bindings)))))
|
||||
;; Compile body
|
||||
(compile-begin em body let-scope tail?))))
|
||||
|
||||
(define compile-lambda
|
||||
(fn (em args scope)
|
||||
(let ((params (first args))
|
||||
(body (rest args))
|
||||
(fn-scope (make-scope scope))
|
||||
(fn-em (make-emitter)))
|
||||
;; Mark as function boundary — upvalue captures happen here
|
||||
(dict-set! fn-scope "is-function" true)
|
||||
;; Define params as locals in fn scope.
|
||||
;; Handle type annotations: (name :as type) → extract name
|
||||
(for-each (fn (p)
|
||||
(let ((name (cond
|
||||
(= (type-of p) "symbol") (symbol-name p)
|
||||
;; Type-annotated param: (name :as type)
|
||||
(and (list? p) (not (empty? p))
|
||||
(= (type-of (first p)) "symbol"))
|
||||
(symbol-name (first p))
|
||||
:else p)))
|
||||
(when (and (not (= name "&key"))
|
||||
(not (= name "&rest")))
|
||||
(scope-define-local fn-scope name))))
|
||||
params)
|
||||
;; Compile body
|
||||
(compile-begin fn-em body fn-scope true) ;; tail position
|
||||
(emit-op fn-em 50) ;; OP_RETURN
|
||||
;; Add code object to parent constant pool
|
||||
(let ((upvals (get fn-scope "upvalues"))
|
||||
(code {:arity (len (get fn-scope "locals"))
|
||||
:bytecode (get fn-em "bytecode")
|
||||
:constants (get (get fn-em "pool") "entries")
|
||||
:upvalue-count (len upvals)})
|
||||
(code-idx (pool-add (get em "pool") code)))
|
||||
(emit-op em 51) ;; OP_CLOSURE
|
||||
(emit-u16 em code-idx)
|
||||
;; Emit upvalue descriptors: for each captured variable,
|
||||
;; (is_local, index) — tells the VM where to find the value.
|
||||
;; is_local=1: capture from enclosing frame's local slot
|
||||
;; is_local=0: capture from enclosing frame's upvalue
|
||||
(for-each (fn (uv)
|
||||
(emit-byte em (if (get uv "is-local") 1 0))
|
||||
(emit-byte em (get uv "index")))
|
||||
upvals)))))
|
||||
|
||||
|
||||
(define compile-define
|
||||
(fn (em args scope)
|
||||
(let ((name-expr (first args))
|
||||
(name (if (= (type-of name-expr) "symbol")
|
||||
(symbol-name name-expr)
|
||||
name-expr))
|
||||
;; Handle :effects annotation: (define name :effects [...] value)
|
||||
;; Skip keyword-value pairs between name and body
|
||||
(value (let ((rest-args (rest args)))
|
||||
(if (and (not (empty? rest-args))
|
||||
(= (type-of (first rest-args)) "keyword"))
|
||||
;; Skip :keyword value pairs until we hit the body
|
||||
(let ((skip-annotations
|
||||
(fn (items)
|
||||
(if (empty? items) nil
|
||||
(if (= (type-of (first items)) "keyword")
|
||||
(skip-annotations (rest (rest items)))
|
||||
(first items))))))
|
||||
(skip-annotations rest-args))
|
||||
(first rest-args)))))
|
||||
;; Inside a function body, define creates a LOCAL binding.
|
||||
;; At top level (no enclosing function scope), define creates a global.
|
||||
;; Local binding prevents recursive calls from overwriting
|
||||
;; each other's defines in the flat globals hashtable.
|
||||
(if (not (nil? (get scope "parent")))
|
||||
;; Local define — allocate slot, compile value, set local
|
||||
(let ((slot (scope-define-local scope name)))
|
||||
(compile-expr em value scope false)
|
||||
(emit-op em 17) ;; OP_LOCAL_SET
|
||||
(emit-byte em slot))
|
||||
;; Top-level define — global
|
||||
(let ((name-idx (pool-add (get em "pool") name)))
|
||||
(compile-expr em value scope false)
|
||||
(emit-op em 128) ;; OP_DEFINE
|
||||
(emit-u16 em name-idx))))))
|
||||
|
||||
|
||||
(define compile-set
|
||||
(fn (em args scope)
|
||||
(let ((name (if (= (type-of (first args)) "symbol")
|
||||
(symbol-name (first args))
|
||||
(first args)))
|
||||
(value (nth args 1))
|
||||
(resolved (scope-resolve scope name)))
|
||||
(compile-expr em value scope false)
|
||||
(cond
|
||||
(= (get resolved "type") "local")
|
||||
(do (emit-op em 17) ;; OP_LOCAL_SET
|
||||
(emit-byte em (get resolved "index")))
|
||||
(= (get resolved "type") "upvalue")
|
||||
(do (emit-op em 19) ;; OP_UPVALUE_SET
|
||||
(emit-byte em (get resolved "index")))
|
||||
:else
|
||||
(let ((idx (pool-add (get em "pool") name)))
|
||||
(emit-op em 21) ;; OP_GLOBAL_SET
|
||||
(emit-u16 em idx))))))
|
||||
|
||||
|
||||
(define compile-quote
|
||||
(fn (em args)
|
||||
(if (empty? args)
|
||||
(emit-op em 2) ;; OP_NIL
|
||||
(emit-const em (first args)))))
|
||||
|
||||
|
||||
(define compile-cond
|
||||
(fn (em args scope tail?)
|
||||
"Compile (cond test1 body1 test2 body2 ... :else fallback)."
|
||||
(if (< (len args) 2)
|
||||
(emit-op em 2) ;; OP_NIL
|
||||
(let ((test (first args))
|
||||
(body (nth args 1))
|
||||
(rest-clauses (if (> (len args) 2) (slice args 2) (list))))
|
||||
(if (or (and (= (type-of test) "keyword") (= (keyword-name test) "else"))
|
||||
(= test true))
|
||||
;; else clause — just compile the body
|
||||
(compile-expr em body scope tail?)
|
||||
(do
|
||||
(compile-expr em test scope false)
|
||||
(emit-op em 33) ;; OP_JUMP_IF_FALSE
|
||||
(let ((skip (current-offset em)))
|
||||
(emit-i16 em 0)
|
||||
(compile-expr em body scope tail?)
|
||||
(emit-op em 32) ;; OP_JUMP
|
||||
(let ((end-jump (current-offset em)))
|
||||
(emit-i16 em 0)
|
||||
(patch-i16 em skip (- (current-offset em) (+ skip 2)))
|
||||
(compile-cond em rest-clauses scope tail?)
|
||||
(patch-i16 em end-jump (- (current-offset em) (+ end-jump 2)))))))))))
|
||||
|
||||
|
||||
(define compile-case
|
||||
(fn (em args scope tail?)
|
||||
"Compile (case expr val1 body1 val2 body2 ... :else fallback)."
|
||||
;; Desugar to nested if: evaluate expr once, then compare
|
||||
(compile-expr em (first args) scope false)
|
||||
(let ((clauses (rest args)))
|
||||
(compile-case-clauses em clauses scope tail?))))
|
||||
|
||||
(define compile-case-clauses
|
||||
(fn (em clauses scope tail?)
|
||||
(if (< (len clauses) 2)
|
||||
(do (emit-op em 5) (emit-op em 2)) ;; POP match-val, push NIL
|
||||
(let ((test (first clauses))
|
||||
(body (nth clauses 1))
|
||||
(rest-clauses (if (> (len clauses) 2) (slice clauses 2) (list))))
|
||||
(if (or (and (= (type-of test) "keyword") (= (keyword-name test) "else"))
|
||||
(= test true))
|
||||
(do (emit-op em 5) ;; POP match-val
|
||||
(compile-expr em body scope tail?))
|
||||
(do
|
||||
(emit-op em 6) ;; DUP match-val
|
||||
(compile-expr em test scope false)
|
||||
(let ((name-idx (pool-add (get em "pool") "=")))
|
||||
(emit-op em 52) (emit-u16 em name-idx) (emit-byte em 2)) ;; CALL_PRIM "=" 2
|
||||
(emit-op em 33) ;; JUMP_IF_FALSE
|
||||
(let ((skip (current-offset em)))
|
||||
(emit-i16 em 0)
|
||||
(emit-op em 5) ;; POP match-val
|
||||
(compile-expr em body scope tail?)
|
||||
(emit-op em 32) ;; JUMP
|
||||
(let ((end-jump (current-offset em)))
|
||||
(emit-i16 em 0)
|
||||
(patch-i16 em skip (- (current-offset em) (+ skip 2)))
|
||||
(compile-case-clauses em rest-clauses scope tail?)
|
||||
(patch-i16 em end-jump (- (current-offset em) (+ end-jump 2)))))))))))
|
||||
|
||||
|
||||
(define compile-thread
|
||||
(fn (em args scope tail?)
|
||||
"Compile (-> val (f1 a) (f2 b)) by desugaring to nested calls."
|
||||
(if (empty? args)
|
||||
(emit-op em 2)
|
||||
(if (= (len args) 1)
|
||||
(compile-expr em (first args) scope tail?)
|
||||
;; Desugar: (-> x (f a)) → (f x a)
|
||||
(let ((val-expr (first args))
|
||||
(forms (rest args)))
|
||||
(compile-thread-step em val-expr forms scope tail?))))))
|
||||
|
||||
(define compile-thread-step
|
||||
(fn (em val-expr forms scope tail?)
|
||||
(if (empty? forms)
|
||||
(compile-expr em val-expr scope tail?)
|
||||
(let ((form (first forms))
|
||||
(rest-forms (rest forms))
|
||||
(is-tail (and tail? (empty? rest-forms))))
|
||||
;; Build desugared call: (f val args...)
|
||||
(let ((call-expr
|
||||
(if (list? form)
|
||||
;; (-> x (f a b)) → (f x a b)
|
||||
(concat (list (first form) val-expr) (rest form))
|
||||
;; (-> x f) → (f x)
|
||||
(list form val-expr))))
|
||||
(if (empty? rest-forms)
|
||||
(compile-expr em call-expr scope is-tail)
|
||||
(do
|
||||
(compile-expr em call-expr scope false)
|
||||
;; Thread result through remaining forms
|
||||
;; Store in temp, compile next step
|
||||
;; Actually, just compile sequentially — each step returns a value
|
||||
(compile-thread-step em call-expr rest-forms scope tail?))))))))
|
||||
|
||||
|
||||
(define compile-defcomp
|
||||
(fn (em args scope)
|
||||
"Compile defcomp/defisland — delegates to runtime via GLOBAL_GET + CALL."
|
||||
(let ((name-idx (pool-add (get em "pool") "eval-defcomp")))
|
||||
(emit-op em 20) (emit-u16 em name-idx)) ;; GLOBAL_GET fn
|
||||
(emit-const em (concat (list (make-symbol "defcomp")) args))
|
||||
(emit-op em 48) (emit-byte em 1))) ;; CALL 1
|
||||
|
||||
(define compile-defmacro
|
||||
(fn (em args scope)
|
||||
"Compile defmacro — delegates to runtime via GLOBAL_GET + CALL."
|
||||
(let ((name-idx (pool-add (get em "pool") "eval-defmacro")))
|
||||
(emit-op em 20) (emit-u16 em name-idx)) ;; GLOBAL_GET fn
|
||||
(emit-const em (concat (list (make-symbol "defmacro")) args))
|
||||
(emit-op em 48) (emit-byte em 1)))
|
||||
|
||||
|
||||
(define compile-quasiquote
|
||||
(fn (em expr scope)
|
||||
"Compile quasiquote inline — walks the template at compile time,
|
||||
emitting code that builds the structure at runtime. Unquoted
|
||||
expressions are compiled normally (resolving locals/upvalues),
|
||||
avoiding the qq-expand-runtime env-lookup limitation."
|
||||
(compile-qq-expr em expr scope)))
|
||||
|
||||
(define compile-qq-expr
|
||||
(fn (em expr scope)
|
||||
"Compile a quasiquote sub-expression."
|
||||
(if (not (= (type-of expr) "list"))
|
||||
;; Atom — emit as constant
|
||||
(emit-const em expr)
|
||||
(if (empty? expr)
|
||||
;; Empty list
|
||||
(do (emit-op em 64) (emit-u16 em 0)) ;; OP_LIST 0
|
||||
(let ((head (first expr)))
|
||||
(if (and (= (type-of head) "symbol")
|
||||
(= (symbol-name head) "unquote"))
|
||||
;; (unquote expr) — compile the expression
|
||||
(compile-expr em (nth expr 1) scope false)
|
||||
;; List — compile elements, handling splice-unquote
|
||||
(compile-qq-list em expr scope)))))))
|
||||
|
||||
(define compile-qq-list
|
||||
(fn (em items scope)
|
||||
"Compile a quasiquote list. Handles splice-unquote by building
|
||||
segments and concatenating them."
|
||||
(let ((has-splice (some (fn (item)
|
||||
(and (= (type-of item) "list")
|
||||
(>= (len item) 2)
|
||||
(= (type-of (first item)) "symbol")
|
||||
(= (symbol-name (first item)) "splice-unquote")))
|
||||
items)))
|
||||
(if (not has-splice)
|
||||
;; No splicing — compile each element, then OP_LIST
|
||||
(do
|
||||
(for-each (fn (item) (compile-qq-expr em item scope)) items)
|
||||
(emit-op em 64) (emit-u16 em (len items))) ;; OP_LIST N
|
||||
;; Has splicing — build segments and concat
|
||||
;; Strategy: accumulate non-spliced items into a pending list,
|
||||
;; flush as OP_LIST when hitting a splice, concat all segments.
|
||||
(let ((segment-count 0)
|
||||
(pending 0))
|
||||
(for-each
|
||||
(fn (item)
|
||||
(if (and (= (type-of item) "list")
|
||||
(>= (len item) 2)
|
||||
(= (type-of (first item)) "symbol")
|
||||
(= (symbol-name (first item)) "splice-unquote"))
|
||||
;; Splice-unquote: flush pending, compile spliced expr
|
||||
(do
|
||||
(when (> pending 0)
|
||||
(emit-op em 64) (emit-u16 em pending) ;; OP_LIST for pending
|
||||
(set! segment-count (+ segment-count 1))
|
||||
(set! pending 0))
|
||||
;; Compile the spliced expression
|
||||
(compile-expr em (nth item 1) scope false)
|
||||
(set! segment-count (+ segment-count 1)))
|
||||
;; Normal element — compile and count as pending
|
||||
(do
|
||||
(compile-qq-expr em item scope)
|
||||
(set! pending (+ pending 1)))))
|
||||
items)
|
||||
;; Flush remaining pending items
|
||||
(when (> pending 0)
|
||||
(emit-op em 64) (emit-u16 em pending)
|
||||
(set! segment-count (+ segment-count 1)))
|
||||
;; Concat all segments
|
||||
(when (> segment-count 1)
|
||||
(let ((concat-idx (pool-add (get em "pool") "concat")))
|
||||
;; concat takes N args — call with all segments
|
||||
(emit-op em 52) (emit-u16 em concat-idx)
|
||||
(emit-byte em segment-count))))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Function call compilation
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define compile-call
|
||||
(fn (em head args scope tail?)
|
||||
;; Check for known primitives
|
||||
(let ((is-prim (and (= (type-of head) "symbol")
|
||||
(let ((name (symbol-name head)))
|
||||
(and (not (= (get (scope-resolve scope name) "type") "local"))
|
||||
(not (= (get (scope-resolve scope name) "type") "upvalue"))
|
||||
(primitive? name))))))
|
||||
(if is-prim
|
||||
;; Direct primitive call via CALL_PRIM
|
||||
(let ((name (symbol-name head))
|
||||
(argc (len args))
|
||||
(name-idx (pool-add (get em "pool") name)))
|
||||
(for-each (fn (a) (compile-expr em a scope false)) args)
|
||||
(emit-op em 52) ;; OP_CALL_PRIM
|
||||
(emit-u16 em name-idx)
|
||||
(emit-byte em argc))
|
||||
;; General call
|
||||
(do
|
||||
(compile-expr em head scope false)
|
||||
(for-each (fn (a) (compile-expr em a scope false)) args)
|
||||
(if tail?
|
||||
(do (emit-op em 49) ;; OP_TAIL_CALL
|
||||
(emit-byte em (len args)))
|
||||
(do (emit-op em 48) ;; OP_CALL
|
||||
(emit-byte em (len args)))))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Top-level API
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define compile
|
||||
(fn (expr)
|
||||
"Compile a single SX expression to a bytecode module."
|
||||
(let ((em (make-emitter))
|
||||
(scope (make-scope nil)))
|
||||
(compile-expr em expr scope false)
|
||||
(emit-op em 50) ;; OP_RETURN
|
||||
{:bytecode (get em "bytecode")
|
||||
:constants (get (get em "pool") "entries")})))
|
||||
|
||||
(define compile-module
|
||||
(fn (exprs)
|
||||
"Compile a list of top-level expressions to a bytecode module."
|
||||
(let ((em (make-emitter))
|
||||
(scope (make-scope nil)))
|
||||
(for-each (fn (expr)
|
||||
(compile-expr em expr scope false)
|
||||
(emit-op em 5)) ;; OP_POP between top-level exprs
|
||||
(init exprs))
|
||||
;; Last expression's value is the module result
|
||||
(compile-expr em (last exprs) scope false)
|
||||
(emit-op em 50) ;; OP_RETURN
|
||||
{:bytecode (get em "bytecode")
|
||||
:constants (get (get em "pool") "entries")})))
|
||||
48
lib/content.sx
Normal file
48
lib/content.sx
Normal file
@@ -0,0 +1,48 @@
|
||||
;; ==========================================================================
|
||||
;; content.sx — Content-addressed computation
|
||||
;;
|
||||
;; Hash frozen SX to a content identifier. Store and retrieve by CID.
|
||||
;; The content IS the address — same SX always produces the same CID.
|
||||
;;
|
||||
;; This is a library built on top of freeze.sx. It is NOT part of the
|
||||
;; core evaluator. Load order: evaluator.sx → freeze.sx → content.sx
|
||||
;;
|
||||
;; Uses an in-memory content store. Applications can persist to
|
||||
;; localStorage or IPFS by providing their own store backend.
|
||||
;; ==========================================================================
|
||||
|
||||
(define content-store (dict))
|
||||
|
||||
(define content-hash :effects []
|
||||
(fn (sx-text)
|
||||
;; djb2 hash → hex string. Simple, deterministic, fast.
|
||||
;; Real deployment would use SHA-256 / multihash.
|
||||
(let ((hash 5381))
|
||||
(for-each (fn (i)
|
||||
(set! hash (mod (+ (* hash 33) (char-code-at sx-text i)) 4294967296)))
|
||||
(range 0 (len sx-text)))
|
||||
(to-hex hash))))
|
||||
|
||||
(define content-put :effects [mutation]
|
||||
(fn (sx-text)
|
||||
(let ((cid (content-hash sx-text)))
|
||||
(dict-set! content-store cid sx-text)
|
||||
cid)))
|
||||
|
||||
(define content-get :effects []
|
||||
(fn (cid)
|
||||
(get content-store cid)))
|
||||
|
||||
;; Freeze a scope → store → return CID
|
||||
(define freeze-to-cid :effects [mutation]
|
||||
(fn (scope-name)
|
||||
(let ((sx-text (freeze-to-sx scope-name)))
|
||||
(content-put sx-text))))
|
||||
|
||||
;; Thaw from CID → look up → restore
|
||||
(define thaw-from-cid :effects [mutation]
|
||||
(fn (cid)
|
||||
(let ((sx-text (content-get cid)))
|
||||
(when sx-text
|
||||
(thaw-from-sx sx-text)
|
||||
true))))
|
||||
94
lib/freeze.sx
Normal file
94
lib/freeze.sx
Normal file
@@ -0,0 +1,94 @@
|
||||
;; ==========================================================================
|
||||
;; freeze.sx — Serializable state boundaries
|
||||
;;
|
||||
;; Freeze scopes collect signals registered within them. On freeze,
|
||||
;; their current values are serialized to SX. On thaw, values are
|
||||
;; restored. Multiple named scopes can coexist independently.
|
||||
;;
|
||||
;; This is a library built on top of the evaluator's scoped effects
|
||||
;; (scope-push!/scope-pop!/context) and signal system. It is NOT
|
||||
;; part of the core evaluator — it loads after evaluator.sx.
|
||||
;;
|
||||
;; Usage:
|
||||
;; (freeze-scope "editor"
|
||||
;; (let ((doc (signal "hello")))
|
||||
;; (freeze-signal "doc" doc)
|
||||
;; ...))
|
||||
;;
|
||||
;; (cek-freeze-scope "editor") → {:name "editor" :signals {:doc "hello"}}
|
||||
;; (cek-thaw-scope "editor" frozen-data) → restores signal values
|
||||
;; ==========================================================================
|
||||
|
||||
;; Registry of freeze scopes: name → list of {name signal} entries
|
||||
(define freeze-registry (dict))
|
||||
|
||||
;; Register a signal in the current freeze scope
|
||||
(define freeze-signal :effects [mutation]
|
||||
(fn (name sig)
|
||||
(let ((scope-name (context "sx-freeze-scope" nil)))
|
||||
(when scope-name
|
||||
(let ((entries (or (get freeze-registry scope-name) (list))))
|
||||
(append! entries (dict "name" name "signal" sig))
|
||||
(dict-set! freeze-registry scope-name entries))))))
|
||||
|
||||
;; Freeze scope delimiter — collects signals registered within body
|
||||
(define freeze-scope :effects [mutation]
|
||||
(fn (name body-fn)
|
||||
(scope-push! "sx-freeze-scope" name)
|
||||
;; Initialize empty entry list for this scope
|
||||
(dict-set! freeze-registry name (list))
|
||||
(cek-call body-fn nil)
|
||||
(scope-pop! "sx-freeze-scope")
|
||||
nil))
|
||||
|
||||
;; Freeze a named scope → SX dict of signal values
|
||||
(define cek-freeze-scope :effects []
|
||||
(fn (name)
|
||||
(let ((entries (or (get freeze-registry name) (list)))
|
||||
(signals-dict (dict)))
|
||||
(for-each (fn (entry)
|
||||
(dict-set! signals-dict
|
||||
(get entry "name")
|
||||
(signal-value (get entry "signal"))))
|
||||
entries)
|
||||
(dict "name" name "signals" signals-dict))))
|
||||
|
||||
;; Freeze all scopes
|
||||
(define cek-freeze-all :effects []
|
||||
(fn ()
|
||||
(map (fn (name) (cek-freeze-scope name))
|
||||
(keys freeze-registry))))
|
||||
|
||||
;; Thaw a named scope — restore signal values from frozen data
|
||||
(define cek-thaw-scope :effects [mutation]
|
||||
(fn (name frozen)
|
||||
(let ((entries (or (get freeze-registry name) (list)))
|
||||
(values (get frozen "signals")))
|
||||
(when values
|
||||
(for-each (fn (entry)
|
||||
(let ((sig-name (get entry "name"))
|
||||
(sig (get entry "signal"))
|
||||
(val (get values sig-name)))
|
||||
(when (not (nil? val))
|
||||
(reset! sig val))))
|
||||
entries)))))
|
||||
|
||||
;; Thaw all scopes from a list of frozen scope dicts
|
||||
(define cek-thaw-all :effects [mutation]
|
||||
(fn (frozen-list)
|
||||
(for-each (fn (frozen)
|
||||
(cek-thaw-scope (get frozen "name") frozen))
|
||||
frozen-list)))
|
||||
|
||||
;; Serialize a frozen scope to SX text
|
||||
(define freeze-to-sx :effects []
|
||||
(fn (name)
|
||||
(sx-serialize (cek-freeze-scope name))))
|
||||
|
||||
;; Restore from SX text
|
||||
(define thaw-from-sx :effects [mutation]
|
||||
(fn (sx-text)
|
||||
(let ((parsed (sx-parse sx-text)))
|
||||
(when (not (empty? parsed))
|
||||
(let ((frozen (first parsed)))
|
||||
(cek-thaw-scope (get frozen "name") frozen))))))
|
||||
275
lib/stdlib.sx
Normal file
275
lib/stdlib.sx
Normal file
@@ -0,0 +1,275 @@
|
||||
;; ==========================================================================
|
||||
;; stdlib.sx — Standard library functions
|
||||
;;
|
||||
;; Every function here is expressed in SX using the irreducible primitive
|
||||
;; set. They are library functions — in band, auditable, portable.
|
||||
;;
|
||||
;; Depends on: evaluator.sx (special forms)
|
||||
;; Must load before: render.sx, freeze.sx, types.sx, user code
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; Logic + comparison: not, !=, <=, >= stay as primitives.
|
||||
;; Replacing them with SX lambdas changes behavior inside shift/reset
|
||||
;; because the transpiled evaluator code uses them directly.
|
||||
|
||||
(define eq? (fn (a b) (= a b)))
|
||||
(define eqv? (fn (a b) (= a b)))
|
||||
(define equal? (fn (a b) (= a b)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Type predicates
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; nil? stays as primitive — host's type-of uses it internally.
|
||||
|
||||
(define boolean?
|
||||
(fn (x) (= (type-of x) "boolean")))
|
||||
|
||||
(define number?
|
||||
(fn (x) (= (type-of x) "number")))
|
||||
|
||||
(define string?
|
||||
(fn (x) (= (type-of x) "string")))
|
||||
|
||||
(define list?
|
||||
(fn (x) (= (type-of x) "list")))
|
||||
|
||||
(define dict?
|
||||
(fn (x) (= (type-of x) "dict")))
|
||||
|
||||
(define continuation?
|
||||
(fn (x) (= (type-of x) "continuation")))
|
||||
|
||||
(define zero?
|
||||
(fn (n) (= n 0)))
|
||||
|
||||
(define odd?
|
||||
(fn (n) (= (mod n 2) 1)))
|
||||
|
||||
(define even?
|
||||
(fn (n) (= (mod n 2) 0)))
|
||||
|
||||
(define empty?
|
||||
(fn (coll) (or (nil? coll) (= (len coll) 0))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Arithmetic
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; inc and dec stay as primitives — used inside continuation contexts.
|
||||
|
||||
(define abs
|
||||
(fn (x) (if (< x 0) (- x) x)))
|
||||
|
||||
(define ceil
|
||||
(fn (x)
|
||||
(let ((f (floor x)))
|
||||
(if (= x f) f (+ f 1)))))
|
||||
|
||||
(define round
|
||||
(fn (x ndigits)
|
||||
(if (nil? ndigits)
|
||||
(floor (+ x 0.5))
|
||||
(let ((f (pow 10 ndigits)))
|
||||
(/ (floor (+ (* x f) 0.5)) f)))))
|
||||
|
||||
(define min
|
||||
(fn (a b) (if (< a b) a b)))
|
||||
|
||||
(define max
|
||||
(fn (a b) (if (> a b) a b)))
|
||||
|
||||
(define clamp
|
||||
(fn (x lo hi) (max lo (min hi x))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Collection accessors
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define first
|
||||
(fn (coll)
|
||||
(if (and coll (> (len coll) 0)) (get coll 0) nil)))
|
||||
|
||||
(define last
|
||||
(fn (coll)
|
||||
(if (and coll (> (len coll) 0))
|
||||
(get coll (- (len coll) 1))
|
||||
nil)))
|
||||
|
||||
(define rest
|
||||
(fn (coll) (if coll (slice coll 1) (list))))
|
||||
|
||||
(define nth
|
||||
(fn (coll n)
|
||||
(if (and coll (>= n 0) (< n (len coll)))
|
||||
(get coll n)
|
||||
nil)))
|
||||
|
||||
(define cons
|
||||
(fn (x coll) (concat (list x) (or coll (list)))))
|
||||
|
||||
(define append
|
||||
(fn (coll x)
|
||||
(if (list? x) (concat coll x) (concat coll (list x)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Collection transforms
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define reverse
|
||||
(fn (coll)
|
||||
(reduce (fn (acc x) (cons x acc)) (list) coll)))
|
||||
|
||||
(define flatten
|
||||
(fn (coll)
|
||||
(reduce
|
||||
(fn (acc x)
|
||||
(if (list? x) (concat acc x) (concat acc (list x))))
|
||||
(list) coll)))
|
||||
|
||||
(define range
|
||||
(fn (start end step)
|
||||
(let ((s (if (nil? step) 1 step))
|
||||
(result (list)))
|
||||
(let loop ((i start))
|
||||
(when (< i end)
|
||||
(append! result i)
|
||||
(loop (+ i s))))
|
||||
result)))
|
||||
|
||||
(define chunk-every
|
||||
(fn (coll n)
|
||||
(let ((result (list))
|
||||
(clen (len coll)))
|
||||
(let loop ((i 0))
|
||||
(when (< i clen)
|
||||
(append! result (slice coll i (min (+ i n) clen)))
|
||||
(loop (+ i n))))
|
||||
result)))
|
||||
|
||||
(define zip-pairs
|
||||
(fn (coll)
|
||||
(let ((result (list))
|
||||
(clen (len coll)))
|
||||
(let loop ((i 0))
|
||||
(when (< i (- clen 1))
|
||||
(append! result (list (get coll i) (get coll (+ i 1))))
|
||||
(loop (+ i 1))))
|
||||
result)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Dict operations
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define vals
|
||||
(fn (d)
|
||||
(map (fn (k) (get d k)) (keys d))))
|
||||
|
||||
(define has-key?
|
||||
(fn (d key)
|
||||
(some (fn (k) (= k key)) (keys d))))
|
||||
|
||||
(define assoc
|
||||
(fn (d key val)
|
||||
(let ((result (merge d (dict))))
|
||||
(dict-set! result key val)
|
||||
result)))
|
||||
|
||||
(define dissoc
|
||||
(fn (d key)
|
||||
(let ((result (dict)))
|
||||
(for-each
|
||||
(fn (k)
|
||||
(when (!= k key)
|
||||
(dict-set! result k (get d k))))
|
||||
(keys d))
|
||||
result)))
|
||||
|
||||
(define into
|
||||
(fn (target coll)
|
||||
(cond
|
||||
(list? target)
|
||||
(if (list? coll)
|
||||
(concat coll (list))
|
||||
(let ((result (list)))
|
||||
(for-each (fn (k) (append! result (list k (get coll k)))) (keys coll))
|
||||
result))
|
||||
(dict? target)
|
||||
(let ((result (dict)))
|
||||
(for-each
|
||||
(fn (pair)
|
||||
(when (and (list? pair) (>= (len pair) 2))
|
||||
(dict-set! result (get pair 0) (get pair 1))))
|
||||
coll)
|
||||
result)
|
||||
:else target)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; String operations
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define upcase (fn (s) (upper s)))
|
||||
(define downcase (fn (s) (lower s)))
|
||||
(define string-length (fn (s) (len s)))
|
||||
(define substring (fn (s start end) (slice s start end)))
|
||||
|
||||
(define string-contains?
|
||||
(fn (s needle) (!= (index-of s needle) -1)))
|
||||
|
||||
(define starts-with?
|
||||
(fn (s prefix) (= (index-of s prefix) 0)))
|
||||
|
||||
(define ends-with?
|
||||
(fn (s suffix)
|
||||
(let ((slen (len s))
|
||||
(plen (len suffix)))
|
||||
(if (< slen plen) false
|
||||
(= (slice s (- slen plen)) suffix)))))
|
||||
|
||||
;; split, join, replace stay as primitives — the stdlib versions cause
|
||||
;; stack overflows due to PRIMITIVES entry shadowing in the transpiled output.
|
||||
|
||||
(define contains?
|
||||
(fn (coll key)
|
||||
(cond
|
||||
(string? coll) (!= (index-of coll (str key)) -1)
|
||||
(dict? coll) (has-key? coll key)
|
||||
(list? coll) (some (fn (x) (= x key)) coll)
|
||||
:else false)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Text utilities
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define pluralize
|
||||
(fn (count singular plural)
|
||||
(if (= count 1)
|
||||
(or singular "")
|
||||
(or plural "s"))))
|
||||
|
||||
(define escape
|
||||
(fn (s)
|
||||
(let ((r (str s)))
|
||||
(set! r (replace r "&" "&"))
|
||||
(set! r (replace r "<" "<"))
|
||||
(set! r (replace r ">" ">"))
|
||||
(set! r (replace r "\"" """))
|
||||
(set! r (replace r "'" "'"))
|
||||
r)))
|
||||
|
||||
(define parse-datetime
|
||||
(fn (s) (if s (str s) nil)))
|
||||
|
||||
(define assert
|
||||
(fn (condition message)
|
||||
(when (not condition)
|
||||
(error (or message "Assertion failed")))
|
||||
true))
|
||||
@@ -294,3 +294,55 @@
|
||||
(swap! acc + 5)
|
||||
(swap! acc - 3)
|
||||
(assert-equal 12 (deref acc)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; call-lambda + trampoline — event handler pattern
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Regression: dom-on wraps Lambda event handlers in JS functions that
|
||||
;; call callLambda. callLambda returns a Thunk (TCO), but the wrapper
|
||||
;; never trampolined it, so the handler body (swap!, reset!, etc.)
|
||||
;; never executed. Buttons rendered but clicks had no effect.
|
||||
;;
|
||||
;; These tests verify the pattern that dom-on uses:
|
||||
;; (trampoline (call-lambda handler (list arg)))
|
||||
;; must resolve thunks and execute side effects.
|
||||
|
||||
(defsuite "call-lambda-trampoline-handlers"
|
||||
(deftest "call-lambda + trampoline executes signal mutation"
|
||||
(let ((count (signal 0))
|
||||
(handler (fn () (swap! count + 1))))
|
||||
(trampoline (call-lambda handler (list)))
|
||||
(assert-equal 1 (deref count))))
|
||||
|
||||
(deftest "call-lambda + trampoline with event arg"
|
||||
(let ((last-val (signal nil))
|
||||
(handler (fn (e) (reset! last-val e))))
|
||||
(trampoline (call-lambda handler (list "click-event")))
|
||||
(assert-equal "click-event" (deref last-val))))
|
||||
|
||||
(deftest "call-lambda + trampoline executes multi-statement body"
|
||||
(let ((a (signal 0))
|
||||
(b (signal 0))
|
||||
(handler (fn ()
|
||||
(reset! a 10)
|
||||
(reset! b 20))))
|
||||
(trampoline (call-lambda handler (list)))
|
||||
(assert-equal 10 (deref a))
|
||||
(assert-equal 20 (deref b))))
|
||||
|
||||
(deftest "repeated call-lambda accumulates side effects"
|
||||
(let ((count (signal 0))
|
||||
(handler (fn () (swap! count + 1))))
|
||||
(trampoline (call-lambda handler (list)))
|
||||
(trampoline (call-lambda handler (list)))
|
||||
(trampoline (call-lambda handler (list)))
|
||||
(assert-equal 3 (deref count))))
|
||||
|
||||
(deftest "call-lambda handler calling another lambda"
|
||||
(let ((log (signal (list)))
|
||||
(inner (fn (msg) (reset! log (append (deref log) (list msg)))))
|
||||
(outer (fn () (inner "hello") (inner "world"))))
|
||||
(trampoline (call-lambda outer (list)))
|
||||
(assert-equal (list "hello" "world") (deref log)))))
|
||||
244
lib/tests/test-vm-closures.sx
Normal file
244
lib/tests/test-vm-closures.sx
Normal file
@@ -0,0 +1,244 @@
|
||||
;; ==========================================================================
|
||||
;; test-vm-closures.sx — Tests for inner closure recursion patterns
|
||||
;;
|
||||
;; Requires: test-framework.sx loaded first.
|
||||
;;
|
||||
;; These tests exercise patterns where inner closures recurse deeply
|
||||
;; while sharing mutable state via upvalues. This is the sx-parse
|
||||
;; pattern: many inner functions close over a mutable cursor variable.
|
||||
;; Without proper VM closure support, each recursive call would
|
||||
;; allocate a fresh VM — blowing the stack or hanging.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Inner closure recursion with mutable upvalues
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "inner-closure-recursion"
|
||||
(deftest "self-recursive inner closure with set! on captured variable"
|
||||
;; Pattern: closure mutates captured var on each recursive call.
|
||||
;; This is the core pattern in skip-ws, read-str-loop, etc.
|
||||
(let ((counter 0))
|
||||
(define count-up
|
||||
(fn (n)
|
||||
(when (> n 0)
|
||||
(set! counter (+ counter 1))
|
||||
(count-up (- n 1)))))
|
||||
(count-up 100)
|
||||
(assert-equal 100 counter)))
|
||||
|
||||
(deftest "deep inner closure recursion (500 iterations)"
|
||||
;; Stress test: 500 recursive calls through an inner closure
|
||||
;; mutating a shared upvalue. Would stack-overflow without TCO.
|
||||
(let ((acc 0))
|
||||
(define sum-up
|
||||
(fn (n)
|
||||
(if (<= n 0)
|
||||
acc
|
||||
(do (set! acc (+ acc n))
|
||||
(sum-up (- n 1))))))
|
||||
(assert-equal 125250 (sum-up 500))))
|
||||
|
||||
(deftest "inner closure reading captured variable updated by another"
|
||||
;; Two closures: one writes, one reads, sharing the same binding.
|
||||
(let ((pos 0))
|
||||
(define advance! (fn () (set! pos (+ pos 1))))
|
||||
(define current (fn () pos))
|
||||
(advance!)
|
||||
(advance!)
|
||||
(advance!)
|
||||
(assert-equal 3 (current))))
|
||||
|
||||
(deftest "recursive closure with multiple mutable upvalues"
|
||||
;; Like sx-parse: multiple cursor variables mutated during recursion.
|
||||
(let ((pos 0)
|
||||
(count 0))
|
||||
(define scan
|
||||
(fn (source)
|
||||
(when (< pos (len source))
|
||||
(set! count (+ count 1))
|
||||
(set! pos (+ pos 1))
|
||||
(scan source))))
|
||||
(scan "hello world")
|
||||
(assert-equal 11 pos)
|
||||
(assert-equal 11 count))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Mutual recursion between inner closures
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "mutual-inner-closures"
|
||||
(deftest "two inner closures calling each other"
|
||||
;; Pattern: read-expr calls read-list, read-list calls read-expr.
|
||||
(let ((result (list)))
|
||||
(define process-a
|
||||
(fn (items)
|
||||
(when (not (empty? items))
|
||||
(append! result (str "a:" (first items)))
|
||||
(process-b (rest items)))))
|
||||
(define process-b
|
||||
(fn (items)
|
||||
(when (not (empty? items))
|
||||
(append! result (str "b:" (first items)))
|
||||
(process-a (rest items)))))
|
||||
(process-a (list 1 2 3 4))
|
||||
(assert-equal 4 (len result))
|
||||
(assert-equal "a:1" (nth result 0))
|
||||
(assert-equal "b:2" (nth result 1))
|
||||
(assert-equal "a:3" (nth result 2))
|
||||
(assert-equal "b:4" (nth result 3))))
|
||||
|
||||
(deftest "mutual recursion with shared mutable state"
|
||||
;; Both closures read and write the same captured variable.
|
||||
(let ((pos 0)
|
||||
(source "aAbBcC"))
|
||||
(define skip-lower
|
||||
(fn ()
|
||||
(when (and (< pos (len source))
|
||||
(>= (nth source pos) "a")
|
||||
(<= (nth source pos) "z"))
|
||||
(set! pos (+ pos 1))
|
||||
(skip-upper))))
|
||||
(define skip-upper
|
||||
(fn ()
|
||||
(when (and (< pos (len source))
|
||||
(>= (nth source pos) "A")
|
||||
(<= (nth source pos) "Z"))
|
||||
(set! pos (+ pos 1))
|
||||
(skip-lower))))
|
||||
(skip-lower)
|
||||
(assert-equal 6 pos)))
|
||||
|
||||
(deftest "three-way mutual recursion"
|
||||
(let ((n 30)
|
||||
(result nil))
|
||||
(define step-a
|
||||
(fn (i)
|
||||
(if (>= i n)
|
||||
(set! result "done")
|
||||
(step-b (+ i 1)))))
|
||||
(define step-b
|
||||
(fn (i)
|
||||
(step-c (+ i 1))))
|
||||
(define step-c
|
||||
(fn (i)
|
||||
(step-a (+ i 1))))
|
||||
(step-a 0)
|
||||
(assert-equal "done" result))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Parser-like patterns (the sx-parse structure)
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "parser-pattern"
|
||||
(deftest "mini-parser: tokenize digits from string"
|
||||
;; Simplified sx-parse pattern: closure over pos + source,
|
||||
;; multiple inner functions sharing the mutable cursor.
|
||||
(let ((pos 0)
|
||||
(source "12 34 56")
|
||||
(len-src 8))
|
||||
|
||||
(define skip-ws
|
||||
(fn ()
|
||||
(when (and (< pos len-src) (= (nth source pos) " "))
|
||||
(set! pos (+ pos 1))
|
||||
(skip-ws))))
|
||||
|
||||
(define read-digits
|
||||
(fn ()
|
||||
(let ((start pos))
|
||||
(define digit-loop
|
||||
(fn ()
|
||||
(when (and (< pos len-src)
|
||||
(>= (nth source pos) "0")
|
||||
(<= (nth source pos) "9"))
|
||||
(set! pos (+ pos 1))
|
||||
(digit-loop))))
|
||||
(digit-loop)
|
||||
(slice source start pos))))
|
||||
|
||||
(define read-all
|
||||
(fn ()
|
||||
(let ((tokens (list)))
|
||||
(define parse-loop
|
||||
(fn ()
|
||||
(skip-ws)
|
||||
(when (< pos len-src)
|
||||
(append! tokens (read-digits))
|
||||
(parse-loop))))
|
||||
(parse-loop)
|
||||
tokens)))
|
||||
|
||||
(let ((tokens (read-all)))
|
||||
(assert-equal 3 (len tokens))
|
||||
(assert-equal "12" (nth tokens 0))
|
||||
(assert-equal "34" (nth tokens 1))
|
||||
(assert-equal "56" (nth tokens 2)))))
|
||||
|
||||
(deftest "nested inner closures with upvalue chain"
|
||||
;; Inner function defines its own inner function,
|
||||
;; both closing over the outer mutable variable.
|
||||
(let ((total 0))
|
||||
(define outer-fn
|
||||
(fn (items)
|
||||
(for-each
|
||||
(fn (item)
|
||||
(let ((sub-total 0))
|
||||
(define inner-loop
|
||||
(fn (n)
|
||||
(when (> n 0)
|
||||
(set! sub-total (+ sub-total 1))
|
||||
(set! total (+ total 1))
|
||||
(inner-loop (- n 1)))))
|
||||
(inner-loop item)))
|
||||
items)))
|
||||
(outer-fn (list 3 2 1))
|
||||
(assert-equal 6 total)))
|
||||
|
||||
(deftest "closure returning accumulated list via append!"
|
||||
;; Pattern from read-list: loop appends to mutable list, returns it.
|
||||
(let ((items (list)))
|
||||
(define collect
|
||||
(fn (source pos)
|
||||
(if (>= pos (len source))
|
||||
items
|
||||
(do (append! items (nth source pos))
|
||||
(collect source (+ pos 1))))))
|
||||
(let ((result (collect (list "a" "b" "c" "d") 0)))
|
||||
(assert-equal 4 (len result))
|
||||
(assert-equal "a" (first result))
|
||||
(assert-equal "d" (last result))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Closures as callbacks to higher-order functions
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "closure-ho-callbacks"
|
||||
(deftest "map with closure that mutates captured variable"
|
||||
(let ((running-total 0))
|
||||
(let ((results (map (fn (x)
|
||||
(set! running-total (+ running-total x))
|
||||
running-total)
|
||||
(list 1 2 3 4))))
|
||||
(assert-equal (list 1 3 6 10) results)
|
||||
(assert-equal 10 running-total))))
|
||||
|
||||
(deftest "reduce with closure over external state"
|
||||
(let ((call-count 0))
|
||||
(let ((sum (reduce (fn (acc x)
|
||||
(set! call-count (+ call-count 1))
|
||||
(+ acc x))
|
||||
0
|
||||
(list 10 20 30))))
|
||||
(assert-equal 60 sum)
|
||||
(assert-equal 3 call-count))))
|
||||
|
||||
(deftest "filter with closure reading shared state"
|
||||
(let ((threshold 3))
|
||||
(let ((result (filter (fn (x) (> x threshold))
|
||||
(list 1 2 3 4 5))))
|
||||
(assert-equal (list 4 5) result)))))
|
||||
495
lib/tests/test-vm.sx
Normal file
495
lib/tests/test-vm.sx
Normal file
@@ -0,0 +1,495 @@
|
||||
;; ==========================================================================
|
||||
;; test-vm.sx — Tests for the bytecode VM (spec/vm.sx)
|
||||
;;
|
||||
;; Requires: test-framework.sx, compiler.sx, vm.sx loaded.
|
||||
;; Tests the compile → bytecode → VM execution pipeline.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; Helper: compile an SX expression and execute it on the VM.
|
||||
;; Returns the result value.
|
||||
(define vm-eval
|
||||
(fn (expr)
|
||||
(let ((code (compile expr)))
|
||||
(vm-execute-module
|
||||
(code-from-value code)
|
||||
{}))))
|
||||
|
||||
;; Helper: compile and run with a pre-populated globals dict.
|
||||
(define vm-eval-with
|
||||
(fn (expr globals)
|
||||
(let ((code (compile expr)))
|
||||
(vm-execute-module (code-from-value code) globals))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Constants and literals
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-constants"
|
||||
(deftest "number constant"
|
||||
(assert-equal 42 (vm-eval 42)))
|
||||
|
||||
(deftest "string constant"
|
||||
(assert-equal "hello" (vm-eval "hello")))
|
||||
|
||||
(deftest "boolean true"
|
||||
(assert-equal true (vm-eval true)))
|
||||
|
||||
(deftest "boolean false"
|
||||
(assert-equal false (vm-eval false)))
|
||||
|
||||
(deftest "nil constant"
|
||||
(assert-nil (vm-eval nil)))
|
||||
|
||||
(deftest "negative number"
|
||||
(assert-equal -7 (vm-eval -7)))
|
||||
|
||||
(deftest "float constant"
|
||||
(assert-equal 3.14 (vm-eval 3.14))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Arithmetic via primitives
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-arithmetic"
|
||||
(deftest "addition"
|
||||
(assert-equal 5 (vm-eval '(+ 2 3))))
|
||||
|
||||
(deftest "subtraction"
|
||||
(assert-equal 7 (vm-eval '(- 10 3))))
|
||||
|
||||
(deftest "multiplication"
|
||||
(assert-equal 24 (vm-eval '(* 6 4))))
|
||||
|
||||
(deftest "division"
|
||||
(assert-equal 5 (vm-eval '(/ 10 2))))
|
||||
|
||||
(deftest "nested arithmetic"
|
||||
(assert-equal 14 (vm-eval '(+ (* 3 4) 2))))
|
||||
|
||||
(deftest "three-arg addition"
|
||||
(assert-equal 15 (vm-eval '(+ 5 4 6)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Comparison and logic
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-comparison"
|
||||
(deftest "equal numbers"
|
||||
(assert-equal true (vm-eval '(= 1 1))))
|
||||
|
||||
(deftest "unequal numbers"
|
||||
(assert-equal false (vm-eval '(= 1 2))))
|
||||
|
||||
(deftest "less than"
|
||||
(assert-equal true (vm-eval '(< 1 2))))
|
||||
|
||||
(deftest "greater than"
|
||||
(assert-equal true (vm-eval '(> 5 3))))
|
||||
|
||||
(deftest "not"
|
||||
(assert-equal true (vm-eval '(not false))))
|
||||
|
||||
(deftest "not truthy"
|
||||
(assert-equal false (vm-eval '(not 42)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Control flow — if, when, cond, and, or
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-control-flow"
|
||||
(deftest "if true branch"
|
||||
(assert-equal 1 (vm-eval '(if true 1 2))))
|
||||
|
||||
(deftest "if false branch"
|
||||
(assert-equal 2 (vm-eval '(if false 1 2))))
|
||||
|
||||
(deftest "if without else returns nil"
|
||||
(assert-nil (vm-eval '(if false 1))))
|
||||
|
||||
(deftest "when true evaluates body"
|
||||
(assert-equal 42 (vm-eval '(when true 42))))
|
||||
|
||||
(deftest "when false returns nil"
|
||||
(assert-nil (vm-eval '(when false 42))))
|
||||
|
||||
(deftest "and short-circuits on false"
|
||||
(assert-equal false (vm-eval '(and true false 42))))
|
||||
|
||||
(deftest "and returns last truthy"
|
||||
(assert-equal 3 (vm-eval '(and 1 2 3))))
|
||||
|
||||
(deftest "or short-circuits on true"
|
||||
(assert-equal 1 (vm-eval '(or 1 false 2))))
|
||||
|
||||
(deftest "or returns false when all falsy"
|
||||
(assert-equal false (vm-eval '(or false false false))))
|
||||
|
||||
(deftest "cond first match"
|
||||
(assert-equal "one" (vm-eval '(cond (= 1 1) "one" (= 2 2) "two"))))
|
||||
|
||||
(deftest "cond else clause"
|
||||
(assert-equal "none" (vm-eval '(cond (= 1 2) "one" :else "none"))))
|
||||
|
||||
(deftest "case match"
|
||||
(assert-equal "two" (vm-eval '(case 2 1 "one" 2 "two" :else "other"))))
|
||||
|
||||
(deftest "case else"
|
||||
(assert-equal "other" (vm-eval '(case 99 1 "one" 2 "two" :else "other")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Let bindings
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-let"
|
||||
(deftest "single binding"
|
||||
(assert-equal 10 (vm-eval '(let ((x 10)) x))))
|
||||
|
||||
(deftest "multiple bindings"
|
||||
(assert-equal 30 (vm-eval '(let ((x 10) (y 20)) (+ x y)))))
|
||||
|
||||
(deftest "bindings are sequential"
|
||||
(assert-equal 11 (vm-eval '(let ((x 10) (y (+ x 1))) y))))
|
||||
|
||||
(deftest "nested let"
|
||||
(assert-equal 3 (vm-eval '(let ((x 1)) (let ((y 2)) (+ x y))))))
|
||||
|
||||
(deftest "inner let shadows outer"
|
||||
(assert-equal 99 (vm-eval '(let ((x 1)) (let ((x 99)) x)))))
|
||||
|
||||
(deftest "let body returns last expression"
|
||||
(assert-equal 3 (vm-eval '(let ((x 1)) 1 2 3)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Lambda and function calls
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-lambda"
|
||||
(deftest "lambda call"
|
||||
(assert-equal 7 (vm-eval '(let ((f (fn (x) (+ x 2)))) (f 5)))))
|
||||
|
||||
(deftest "lambda with multiple params"
|
||||
(assert-equal 11 (vm-eval '(let ((add (fn (a b) (+ a b)))) (add 5 6)))))
|
||||
|
||||
(deftest "higher-order: pass lambda to lambda"
|
||||
(assert-equal 10
|
||||
(vm-eval '(let ((apply-fn (fn (f x) (f x)))
|
||||
(double (fn (n) (* n 2))))
|
||||
(apply-fn double 5)))))
|
||||
|
||||
(deftest "lambda returns lambda"
|
||||
(assert-equal 15
|
||||
(vm-eval '(let ((make-adder (fn (n) (fn (x) (+ n x)))))
|
||||
(let ((add10 (make-adder 10)))
|
||||
(add10 5))))))
|
||||
|
||||
(deftest "immediately invoked lambda"
|
||||
(assert-equal 42 (vm-eval '((fn (x) (* x 2)) 21)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Closures and upvalues
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-closures"
|
||||
(deftest "closure captures local"
|
||||
(assert-equal 10
|
||||
(vm-eval '(let ((x 10))
|
||||
(let ((f (fn () x)))
|
||||
(f))))))
|
||||
|
||||
(deftest "closure captures through two levels"
|
||||
(assert-equal 30
|
||||
(vm-eval '(let ((x 10))
|
||||
(let ((y 20))
|
||||
(let ((f (fn () (+ x y))))
|
||||
(f)))))))
|
||||
|
||||
(deftest "two closures share upvalue"
|
||||
(assert-equal 42
|
||||
(vm-eval '(let ((x 0))
|
||||
(let ((set-x (fn (v) (set! x v)))
|
||||
(get-x (fn () x)))
|
||||
(set-x 42)
|
||||
(get-x))))))
|
||||
|
||||
(deftest "closure mutation visible to sibling"
|
||||
(assert-equal 3
|
||||
(vm-eval '(let ((counter 0))
|
||||
(let ((inc! (fn () (set! counter (+ counter 1)))))
|
||||
(inc!)
|
||||
(inc!)
|
||||
(inc!)
|
||||
counter))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Tail call optimization
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-tco"
|
||||
(deftest "tail-recursive loop doesn't overflow"
|
||||
;; Count down from 10000 — would overflow without TCO
|
||||
(assert-equal 0
|
||||
(vm-eval '(let ((loop (fn (n)
|
||||
(if (<= n 0) 0
|
||||
(loop (- n 1))))))
|
||||
(loop 10000)))))
|
||||
|
||||
(deftest "tail-recursive accumulator"
|
||||
(assert-equal 5050
|
||||
(vm-eval '(let ((sum (fn (n acc)
|
||||
(if (<= n 0) acc
|
||||
(sum (- n 1) (+ acc n))))))
|
||||
(sum 100 0))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Collections
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-collections"
|
||||
(deftest "list construction"
|
||||
(assert-equal (list 1 2 3) (vm-eval '(list 1 2 3))))
|
||||
|
||||
(deftest "empty list"
|
||||
(assert-equal (list) (vm-eval '(list))))
|
||||
|
||||
(deftest "dict construction"
|
||||
(let ((d (vm-eval '{:a 1 :b 2})))
|
||||
(assert-equal 1 (get d "a"))
|
||||
(assert-equal 2 (get d "b"))))
|
||||
|
||||
(deftest "list operations"
|
||||
(assert-equal 1 (vm-eval '(first (list 1 2 3))))
|
||||
(assert-equal 3 (vm-eval '(len (list 1 2 3)))))
|
||||
|
||||
(deftest "nested list"
|
||||
(assert-equal (list 1 (list 2 3))
|
||||
(vm-eval '(list 1 (list 2 3))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; String operations
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-strings"
|
||||
(deftest "str concat"
|
||||
(assert-equal "hello world" (vm-eval '(str "hello" " " "world"))))
|
||||
|
||||
(deftest "string-length"
|
||||
(assert-equal 5 (vm-eval '(string-length "hello"))))
|
||||
|
||||
(deftest "str coerces numbers"
|
||||
(assert-equal "42" (vm-eval '(str 42)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Define — top-level and local
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-define"
|
||||
(deftest "top-level define"
|
||||
(assert-equal 42
|
||||
(vm-eval '(do (define x 42) x))))
|
||||
|
||||
(deftest "define function then call"
|
||||
(assert-equal 10
|
||||
(vm-eval '(do
|
||||
(define double (fn (n) (* n 2)))
|
||||
(double 5)))))
|
||||
|
||||
(deftest "local define inside fn"
|
||||
(assert-equal 30
|
||||
(vm-eval '(let ((f (fn (x)
|
||||
(define y (* x 2))
|
||||
(+ x y))))
|
||||
(f 10)))))
|
||||
|
||||
(deftest "define with forward reference"
|
||||
(assert-equal 120
|
||||
(vm-eval '(do
|
||||
(define fact (fn (n)
|
||||
(if (<= n 1) 1 (* n (fact (- n 1))))))
|
||||
(fact 5))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Letrec — mutual recursion
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-letrec"
|
||||
(deftest "letrec self-recursion"
|
||||
(assert-equal 55
|
||||
(vm-eval '(letrec ((sum-to (fn (n)
|
||||
(if (<= n 0) 0
|
||||
(+ n (sum-to (- n 1)))))))
|
||||
(sum-to 10)))))
|
||||
|
||||
(deftest "letrec mutual recursion"
|
||||
(assert-equal true
|
||||
(vm-eval '(letrec ((my-even? (fn (n)
|
||||
(if (= n 0) true (my-odd? (- n 1)))))
|
||||
(my-odd? (fn (n)
|
||||
(if (= n 0) false (my-even? (- n 1))))))
|
||||
(my-even? 10))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Quasiquote
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-quasiquote"
|
||||
(deftest "simple quasiquote"
|
||||
(assert-equal (list 1 2 3)
|
||||
(vm-eval '(let ((x 2)) `(1 ,x 3)))))
|
||||
|
||||
(deftest "quasiquote with splice"
|
||||
(assert-equal (list 1 2 3 4)
|
||||
(vm-eval '(let ((xs (list 2 3))) `(1 ,@xs 4))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Thread macro
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-threading"
|
||||
(deftest "thread-first"
|
||||
(assert-equal 7
|
||||
(vm-eval '(-> 5 (+ 2)))))
|
||||
|
||||
(deftest "thread-first chain"
|
||||
(assert-equal 12
|
||||
(vm-eval '(-> 10 (+ 5) (- 3))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Integration: compile then execute
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "vm-integration"
|
||||
(deftest "fibonacci"
|
||||
(assert-equal 55
|
||||
(vm-eval '(do
|
||||
(define fib (fn (n)
|
||||
(if (<= n 1) n
|
||||
(+ (fib (- n 1)) (fib (- n 2))))))
|
||||
(fib 10)))))
|
||||
|
||||
(deftest "map via recursive define"
|
||||
(assert-equal (list 2 4 6)
|
||||
(vm-eval '(do
|
||||
(define my-map (fn (f lst)
|
||||
(if (empty? lst) (list)
|
||||
(cons (f (first lst)) (my-map f (rest lst))))))
|
||||
(my-map (fn (x) (* x 2)) (list 1 2 3))))))
|
||||
|
||||
(deftest "filter via recursive define"
|
||||
(assert-equal (list 2 4)
|
||||
(vm-eval '(do
|
||||
(define my-filter (fn (pred lst)
|
||||
(if (empty? lst) (list)
|
||||
(if (pred (first lst))
|
||||
(cons (first lst) (my-filter pred (rest lst)))
|
||||
(my-filter pred (rest lst))))))
|
||||
(my-filter (fn (x) (even? x)) (list 1 2 3 4 5))))))
|
||||
|
||||
(deftest "reduce via recursive define"
|
||||
(assert-equal 15
|
||||
(vm-eval '(do
|
||||
(define my-reduce (fn (f acc lst)
|
||||
(if (empty? lst) acc
|
||||
(my-reduce f (f acc (first lst)) (rest lst)))))
|
||||
(my-reduce (fn (acc x) (+ acc x)) 0 (list 1 2 3 4 5))))))
|
||||
|
||||
(deftest "nested function calls"
|
||||
(assert-equal 42
|
||||
(vm-eval '(do
|
||||
(define compose (fn (f g) (fn (x) (f (g x)))))
|
||||
(define inc (fn (x) (+ x 1)))
|
||||
(define double (fn (x) (* x 2)))
|
||||
(let ((inc-then-double (compose double inc)))
|
||||
(inc-then-double 20)))))))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; VM recursive mutation — closure capture must preserve mutable references
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Regression: recursive functions that append! to a shared mutable list
|
||||
;; lost mutations after the first call under JIT. The stepper island's
|
||||
;; split-tag function produced 1 step instead of 16, breaking SSR.
|
||||
|
||||
(defsuite "vm-recursive-mutation"
|
||||
(deftest "recursive append! to shared list"
|
||||
(assert-equal 3
|
||||
(vm-eval '(do
|
||||
(define walk (fn (items result)
|
||||
(when (not (empty? items))
|
||||
(append! result (first items))
|
||||
(walk (rest items) result))))
|
||||
(let ((result (list)))
|
||||
(walk (list "a" "b" "c") result)
|
||||
(len result))))))
|
||||
|
||||
(deftest "recursive tree walk with append!"
|
||||
(assert-equal 7
|
||||
(vm-eval '(do
|
||||
(define walk-children (fn (items result walk-fn)
|
||||
(when (not (empty? items))
|
||||
(walk-fn (first items) result)
|
||||
(walk-children (rest items) result walk-fn))))
|
||||
(define walk (fn (expr result)
|
||||
(cond
|
||||
(not (list? expr))
|
||||
(append! result "leaf")
|
||||
(empty? expr) nil
|
||||
:else
|
||||
(do (append! result "open")
|
||||
(walk-children (rest expr) result walk)
|
||||
(append! result "close")))))
|
||||
(let ((tree (first (sx-parse "(div \"a\" (span \"b\") \"c\")")))
|
||||
(result (list)))
|
||||
(walk tree result)
|
||||
(len result))))))
|
||||
|
||||
(deftest "recursive walk matching stepper split-tag pattern"
|
||||
(assert-equal 16
|
||||
(vm-eval '(do
|
||||
(define walk-each (fn (items result walk-fn)
|
||||
(when (not (empty? items))
|
||||
(walk-fn (first items) result)
|
||||
(walk-each (rest items) result walk-fn))))
|
||||
(define collect-children (fn (items cch)
|
||||
(when (not (empty? items))
|
||||
(let ((a (first items)))
|
||||
(if (and (list? a) (not (empty? a))
|
||||
(= (type-of (first a)) "symbol")
|
||||
(starts-with? (symbol-name (first a)) "~"))
|
||||
nil ;; skip component spreads
|
||||
(append! cch a))
|
||||
(collect-children (rest items) cch)))))
|
||||
(define split-tag (fn (expr result)
|
||||
(cond
|
||||
(not (list? expr))
|
||||
(append! result "leaf")
|
||||
(empty? expr) nil
|
||||
(not (= (type-of (first expr)) "symbol"))
|
||||
(append! result "leaf")
|
||||
(is-html-tag? (symbol-name (first expr)))
|
||||
(let ((cch (list)))
|
||||
(collect-children (rest expr) cch)
|
||||
(append! result "open")
|
||||
(walk-each cch result split-tag)
|
||||
(append! result "close"))
|
||||
:else
|
||||
(append! result "expr"))))
|
||||
(let ((parsed (sx-parse "(div (~cssx/tw :tokens \"text-center\")\n (h1 (~cssx/tw :tokens \"text-3xl font-bold mb-2\")\n (span (~cssx/tw :tokens \"text-rose-500\") \"the \")\n (span (~cssx/tw :tokens \"text-amber-500\") \"joy \")\n (span (~cssx/tw :tokens \"text-emerald-500\") \"of \")\n (span (~cssx/tw :tokens \"text-violet-600 text-4xl\") \"sx\")))"))
|
||||
(result (list)))
|
||||
(split-tag (first parsed) result)
|
||||
(len result)))))))
|
||||
117
lib/tests/vm-inline.sx
Normal file
117
lib/tests/vm-inline.sx
Normal file
@@ -0,0 +1,117 @@
|
||||
;; vm-inline.sx — Tests for inline VM opcodes (OP_ADD, OP_EQ, etc.)
|
||||
;;
|
||||
;; These verify that the JIT-compiled inline opcodes produce
|
||||
;; identical results to the CALL_PRIM fallback.
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Arithmetic
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(test "inline + integers" (= (+ 3 4) 7))
|
||||
(test "inline + floats" (= (+ 1.5 2.5) 4.0))
|
||||
(test "inline + string concat" (= (+ "hello" " world") "hello world"))
|
||||
(test "inline - integers" (= (- 10 3) 7))
|
||||
(test "inline - negative" (= (- 3 10) -7))
|
||||
(test "inline * integers" (= (* 6 7) 42))
|
||||
(test "inline * float" (= (* 2.5 4.0) 10.0))
|
||||
(test "inline / integers" (= (/ 10 2) 5))
|
||||
(test "inline / float" (= (/ 7.0 2.0) 3.5))
|
||||
(test "inline inc" (= (inc 5) 6))
|
||||
(test "inline dec" (= (dec 5) 4))
|
||||
(test "inline inc float" (= (inc 2.5) 3.5))
|
||||
(test "inline dec zero" (= (dec 0) -1))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Comparison
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(test "inline = numbers" (= 5 5))
|
||||
(test "inline = strings" (= "hello" "hello"))
|
||||
(test "inline = false" (not (= 5 6)))
|
||||
(test "inline = nil" (= nil nil))
|
||||
(test "inline = mixed false" (not (= 5 "5")))
|
||||
(test "inline < numbers" (< 3 5))
|
||||
(test "inline < false" (not (< 5 3)))
|
||||
(test "inline < equal" (not (< 5 5)))
|
||||
(test "inline < strings" (< "abc" "def"))
|
||||
(test "inline > numbers" (> 5 3))
|
||||
(test "inline > false" (not (> 3 5)))
|
||||
(test "inline > equal" (not (> 5 5)))
|
||||
(test "inline not true" (= (not true) false))
|
||||
(test "inline not false" (= (not false) true))
|
||||
(test "inline not nil" (= (not nil) true))
|
||||
(test "inline not number" (= (not 0) true))
|
||||
(test "inline not string" (= (not "") true))
|
||||
(test "inline not nonempty" (= (not "x") false))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Collection ops
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(test "inline len list" (= (len (list 1 2 3)) 3))
|
||||
(test "inline len string" (= (len "hello") 5))
|
||||
(test "inline len empty" (= (len (list)) 0))
|
||||
(test "inline len nil" (= (len nil) 0))
|
||||
(test "inline first" (= (first (list 10 20 30)) 10))
|
||||
(test "inline first empty" (= (first (list)) nil))
|
||||
(test "inline rest" (= (rest (list 1 2 3)) (list 2 3)))
|
||||
(test "inline rest single" (= (rest (list 1)) (list)))
|
||||
(test "inline nth" (= (nth (list 10 20 30) 1) 20))
|
||||
(test "inline nth zero" (= (nth (list 10 20 30) 0) 10))
|
||||
(test "inline nth out of bounds" (= (nth (list 1 2) 5) nil))
|
||||
(test "inline cons" (= (cons 1 (list 2 3)) (list 1 2 3)))
|
||||
(test "inline cons to empty" (= (cons 1 (list)) (list 1)))
|
||||
(test "inline cons to nil" (= (cons 1 nil) (list 1)))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Composition — inline ops in expressions
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(test "nested arithmetic" (= (+ (* 3 4) (- 10 5)) 17))
|
||||
(test "comparison in if" (if (< 3 5) "yes" "no") (= "yes"))
|
||||
(test "len in condition" (if (> (len (list 1 2 3)) 2) true false))
|
||||
(test "inc in loop" (= (let ((x 0)) (for-each (fn (_) (set! x (inc x))) (list 1 2 3)) x) 3))
|
||||
(test "first + rest roundtrip" (= (cons (first (list 1 2 3)) (rest (list 1 2 3))) (list 1 2 3)))
|
||||
(test "nested comparison" (= (and (< 1 2) (> 3 0) (= 5 5)) true))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Edge cases
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(test "+ with nil" (= (+ 5 nil) 5))
|
||||
(test "len of dict" (= (len {:a 1 :b 2}) 2))
|
||||
(test "= with booleans" (= (= true true) true))
|
||||
(test "= with keywords" (= (= :foo :foo) true))
|
||||
(test "not with list" (= (not (list 1)) false))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Recursive mutation — VM closure capture must preserve mutable state
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Regression: recursive functions that append! to a shared mutable list
|
||||
;; lost mutations after the first call under JIT. The VM closure capture
|
||||
;; was copying the list value instead of sharing the mutable reference.
|
||||
|
||||
(test "recursive append! to shared list"
|
||||
(let ((walk (fn (items result)
|
||||
(when (not (empty? items))
|
||||
(append! result (first items))
|
||||
(walk (rest items) result)))))
|
||||
(let ((result (list)))
|
||||
(walk (list "a" "b" "c") result)
|
||||
(= (len result) 3))))
|
||||
|
||||
(test "recursive tree walk with append!"
|
||||
(let ((walk (fn (expr result)
|
||||
(cond
|
||||
(not (list? expr))
|
||||
(append! result "leaf")
|
||||
(empty? expr) nil
|
||||
:else
|
||||
(do (append! result "open")
|
||||
(for-each (fn (c) (walk c result)) (rest expr))
|
||||
(append! result "close"))))))
|
||||
(let ((tree (first (sx-parse "(div \"a\" (span \"b\") \"c\")")))
|
||||
(result (list)))
|
||||
(walk tree result)
|
||||
(= (len result) 7))))
|
||||
@@ -4,10 +4,13 @@
|
||||
;; Registration-time type checking: zero runtime cost.
|
||||
;; Annotations are optional — unannotated code defaults to `any`.
|
||||
;;
|
||||
;; Depends on: eval.sx (type-of, component accessors, env ops)
|
||||
;; This is an optional spec module — NOT part of the core evaluator.
|
||||
;; It registers deftype and defeffect via register-special-form! at load time.
|
||||
;;
|
||||
;; Depends on: evaluator.sx (type-of, component accessors, env ops)
|
||||
;; primitives.sx, boundary.sx (return type declarations)
|
||||
;;
|
||||
;; Platform interface (from eval.sx, already provided):
|
||||
;; Platform interface (from evaluator.sx, already provided):
|
||||
;; (type-of x) → type string
|
||||
;; (symbol-name s) → string
|
||||
;; (keyword-name k) → string
|
||||
@@ -22,6 +25,13 @@
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; NOTE: deftype and defeffect definition forms have moved to web/web-forms.sx
|
||||
;; (alongside defhandler, defpage, etc.) — they are domain forms, not core.
|
||||
;; The type system below uses them but does not define them.
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 1. Type representation
|
||||
;; --------------------------------------------------------------------------
|
||||
633
lib/vm.sx
Normal file
633
lib/vm.sx
Normal file
@@ -0,0 +1,633 @@
|
||||
;; ==========================================================================
|
||||
;; vm.sx — SX bytecode virtual machine
|
||||
;;
|
||||
;; Stack-based interpreter for bytecode produced by compiler.sx.
|
||||
;; Written in SX — transpiled to each target (OCaml, JS, WASM).
|
||||
;;
|
||||
;; Architecture:
|
||||
;; - Array-based value stack (no allocation per step)
|
||||
;; - Frame list for call stack (one frame per function invocation)
|
||||
;; - Upvalue cells for shared mutable closure variables
|
||||
;; - Iterative dispatch loop (no host-stack growth)
|
||||
;; - TCO via frame replacement on OP_TAIL_CALL
|
||||
;;
|
||||
;; Platform interface:
|
||||
;; The host must provide:
|
||||
;; - make-vm-stack, vm-stack-get, vm-stack-set!, vm-stack-grow
|
||||
;; - cek-call (fallback for Lambda/Component)
|
||||
;; - get-primitive (primitive lookup)
|
||||
;; Everything else is defined here.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 1. Types — VM data structures
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Upvalue cell — shared mutable reference for captured variables.
|
||||
;; When a closure captures a local, both the parent frame and the
|
||||
;; closure read/write through this cell.
|
||||
(define make-upvalue-cell
|
||||
(fn (value)
|
||||
{:uv-value value}))
|
||||
|
||||
(define uv-get (fn (cell) (get cell "uv-value")))
|
||||
(define uv-set! (fn (cell value) (dict-set! cell "uv-value" value)))
|
||||
|
||||
;; VM code object — compiled bytecode + constant pool.
|
||||
;; Produced by compiler.sx, consumed by the VM.
|
||||
(define make-vm-code
|
||||
(fn (arity locals bytecode constants)
|
||||
{:vc-arity arity
|
||||
:vc-locals locals
|
||||
:vc-bytecode bytecode
|
||||
:vc-constants constants}))
|
||||
|
||||
;; VM closure — code + captured upvalues + globals reference.
|
||||
(define make-vm-closure
|
||||
(fn (code upvalues name globals closure-env)
|
||||
{:vm-code code
|
||||
:vm-upvalues upvalues
|
||||
:vm-name name
|
||||
:vm-globals globals
|
||||
:vm-closure-env closure-env}))
|
||||
|
||||
;; VM frame — one per active function invocation.
|
||||
(define make-vm-frame
|
||||
(fn (closure base)
|
||||
{:closure closure
|
||||
:ip 0
|
||||
:base base
|
||||
:local-cells {}}))
|
||||
|
||||
;; VM state — the virtual machine.
|
||||
(define make-vm
|
||||
(fn (globals)
|
||||
{:stack (make-vm-stack 4096)
|
||||
:sp 0
|
||||
:frames (list)
|
||||
:globals globals}))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 2. Stack operations
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define vm-push
|
||||
(fn (vm value)
|
||||
(let ((sp (get vm "sp"))
|
||||
(stack (get vm "stack")))
|
||||
;; Grow stack if needed
|
||||
(when (>= sp (vm-stack-length stack))
|
||||
(let ((new-stack (make-vm-stack (* sp 2))))
|
||||
(vm-stack-copy! stack new-stack sp)
|
||||
(dict-set! vm "stack" new-stack)
|
||||
(set! stack new-stack)))
|
||||
(vm-stack-set! stack sp value)
|
||||
(dict-set! vm "sp" (+ sp 1)))))
|
||||
|
||||
(define vm-pop
|
||||
(fn (vm)
|
||||
(let ((sp (- (get vm "sp") 1)))
|
||||
(dict-set! vm "sp" sp)
|
||||
(vm-stack-get (get vm "stack") sp))))
|
||||
|
||||
(define vm-peek
|
||||
(fn (vm)
|
||||
(vm-stack-get (get vm "stack") (- (get vm "sp") 1))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 3. Operand reading — read from bytecode stream
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define frame-read-u8
|
||||
(fn (frame)
|
||||
(let ((ip (get frame "ip"))
|
||||
(bc (get (get (get frame "closure") "vm-code") "vc-bytecode")))
|
||||
(let ((v (nth bc ip)))
|
||||
(dict-set! frame "ip" (+ ip 1))
|
||||
v))))
|
||||
|
||||
(define frame-read-u16
|
||||
(fn (frame)
|
||||
(let ((lo (frame-read-u8 frame))
|
||||
(hi (frame-read-u8 frame)))
|
||||
(+ lo (* hi 256)))))
|
||||
|
||||
(define frame-read-i16
|
||||
(fn (frame)
|
||||
(let ((v (frame-read-u16 frame)))
|
||||
(if (>= v 32768) (- v 65536) v))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 4. Frame management
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Push a closure frame onto the VM.
|
||||
;; Lays out args as locals, pads remaining locals with nil.
|
||||
(define vm-push-frame
|
||||
(fn (vm closure args)
|
||||
(let ((frame (make-vm-frame closure (get vm "sp"))))
|
||||
(for-each (fn (a) (vm-push vm a)) args)
|
||||
;; Pad remaining local slots with nil
|
||||
(let ((arity (len args))
|
||||
(total-locals (get (get closure "vm-code") "vc-locals")))
|
||||
(let ((pad-count (- total-locals arity)))
|
||||
(when (> pad-count 0)
|
||||
(let ((i 0))
|
||||
(define pad-loop
|
||||
(fn ()
|
||||
(when (< i pad-count)
|
||||
(vm-push vm nil)
|
||||
(set! i (+ i 1))
|
||||
(pad-loop))))
|
||||
(pad-loop)))))
|
||||
(dict-set! vm "frames" (cons frame (get vm "frames"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 5. Code loading — convert compiler output to VM structures
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define code-from-value
|
||||
(fn (v)
|
||||
"Convert a compiler output dict to a vm-code object."
|
||||
(if (not (dict? v))
|
||||
(make-vm-code 0 16 (list) (list))
|
||||
(let ((bc-raw (get v "bytecode"))
|
||||
(bc (if (nil? bc-raw) (list) bc-raw))
|
||||
(consts-raw (get v "constants"))
|
||||
(consts (if (nil? consts-raw) (list) consts-raw))
|
||||
(arity-raw (get v "arity"))
|
||||
(arity (if (nil? arity-raw) 0 arity-raw)))
|
||||
(make-vm-code arity (+ arity 16) bc consts)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 6. Call dispatch — route calls by value type
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; vm-call dispatches a function call within the VM.
|
||||
;; VmClosure: push frame on current VM (fast path, enables TCO).
|
||||
;; NativeFn: call directly, push result.
|
||||
;; Lambda/Component: fall back to CEK evaluator.
|
||||
(define vm-closure?
|
||||
(fn (v)
|
||||
(and (dict? v) (has-key? v "vm-code"))))
|
||||
|
||||
(define vm-call
|
||||
(fn (vm f args)
|
||||
(cond
|
||||
(vm-closure? f)
|
||||
;; Fast path: push frame on current VM
|
||||
(vm-push-frame vm f args)
|
||||
|
||||
(callable? f)
|
||||
;; Native function or primitive
|
||||
(vm-push vm (apply f args))
|
||||
|
||||
(or (= (type-of f) "lambda") (= (type-of f) "component") (= (type-of f) "island"))
|
||||
;; CEK fallback — the host provides cek-call
|
||||
(vm-push vm (cek-call f args))
|
||||
|
||||
:else
|
||||
(error (str "VM: not callable: " (type-of f))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 7. Local/upvalue access helpers
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define frame-local-get
|
||||
(fn (vm frame slot)
|
||||
"Read a local variable — check shared cells first, then stack."
|
||||
(let ((cells (get frame "local-cells"))
|
||||
(key (str slot)))
|
||||
(if (has-key? cells key)
|
||||
(uv-get (get cells key))
|
||||
(vm-stack-get (get vm "stack") (+ (get frame "base") slot))))))
|
||||
|
||||
(define frame-local-set
|
||||
(fn (vm frame slot value)
|
||||
"Write a local variable — to shared cell if captured, else to stack."
|
||||
(let ((cells (get frame "local-cells"))
|
||||
(key (str slot)))
|
||||
(if (has-key? cells key)
|
||||
(uv-set! (get cells key) value)
|
||||
(vm-stack-set! (get vm "stack") (+ (get frame "base") slot) value)))))
|
||||
|
||||
(define frame-upvalue-get
|
||||
(fn (frame idx)
|
||||
(uv-get (nth (get (get frame "closure") "vm-upvalues") idx))))
|
||||
|
||||
(define frame-upvalue-set
|
||||
(fn (frame idx value)
|
||||
(uv-set! (nth (get (get frame "closure") "vm-upvalues") idx) value)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 8. Global variable access with closure env chain
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define vm-global-get
|
||||
(fn (vm frame name)
|
||||
"Look up a global: globals table → closure env chain → primitives."
|
||||
(let ((globals (get vm "globals")))
|
||||
(if (has-key? globals name)
|
||||
(get globals name)
|
||||
;; Walk the closure env chain for inner functions
|
||||
(let ((closure-env (get (get frame "closure") "vm-closure-env")))
|
||||
(if (nil? closure-env)
|
||||
(get-primitive name)
|
||||
(let ((found (env-walk closure-env name)))
|
||||
(if (nil? found)
|
||||
(get-primitive name)
|
||||
found))))))))
|
||||
|
||||
(define vm-global-set
|
||||
(fn (vm frame name value)
|
||||
"Set a global: write to closure env if name exists there, else globals."
|
||||
(let ((closure-env (get (get frame "closure") "vm-closure-env"))
|
||||
(written false))
|
||||
(when (not (nil? closure-env))
|
||||
(set! written (env-walk-set! closure-env name value)))
|
||||
(when (not written)
|
||||
(dict-set! (get vm "globals") name value)))))
|
||||
|
||||
;; env-walk: walk an environment chain looking for a binding.
|
||||
;; Returns the value or nil if not found.
|
||||
(define env-walk
|
||||
(fn (env name)
|
||||
(if (nil? env) nil
|
||||
(if (env-has? env name)
|
||||
(env-get env name)
|
||||
(let ((parent (env-parent env)))
|
||||
(if (nil? parent) nil
|
||||
(env-walk parent name)))))))
|
||||
|
||||
;; env-walk-set!: walk an environment chain, set value if name found.
|
||||
;; Returns true if set, false if not found.
|
||||
(define env-walk-set!
|
||||
(fn (env name value)
|
||||
(if (nil? env) false
|
||||
(if (env-has? env name)
|
||||
(do (env-set! env name value) true)
|
||||
(let ((parent (env-parent env)))
|
||||
(if (nil? parent) false
|
||||
(env-walk-set! parent name value)))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 9. Closure creation — OP_CLOSURE with upvalue capture
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define vm-create-closure
|
||||
(fn (vm frame code-val)
|
||||
"Create a closure from a code constant. Reads upvalue descriptors
|
||||
from the bytecode stream and captures values from the enclosing frame."
|
||||
(let ((code (code-from-value code-val))
|
||||
(uv-count (if (dict? code-val)
|
||||
(let ((n (get code-val "upvalue-count")))
|
||||
(if (nil? n) 0 n))
|
||||
0)))
|
||||
(let ((upvalues
|
||||
(let ((result (list))
|
||||
(i 0))
|
||||
(define capture-loop
|
||||
(fn ()
|
||||
(when (< i uv-count)
|
||||
(let ((is-local (frame-read-u8 frame))
|
||||
(index (frame-read-u8 frame)))
|
||||
(let ((cell
|
||||
(if (= is-local 1)
|
||||
;; Capture from enclosing frame's local slot.
|
||||
;; Create/reuse a shared cell so both parent
|
||||
;; and closure read/write through it.
|
||||
(let ((cells (get frame "local-cells"))
|
||||
(key (str index)))
|
||||
(if (has-key? cells key)
|
||||
(get cells key)
|
||||
(let ((c (make-upvalue-cell
|
||||
(vm-stack-get (get vm "stack")
|
||||
(+ (get frame "base") index)))))
|
||||
(dict-set! cells key c)
|
||||
c)))
|
||||
;; Capture from enclosing frame's upvalue
|
||||
(nth (get (get frame "closure") "vm-upvalues") index))))
|
||||
(append! result cell)
|
||||
(set! i (+ i 1))
|
||||
(capture-loop))))))
|
||||
(capture-loop)
|
||||
result)))
|
||||
(make-vm-closure code upvalues nil
|
||||
(get vm "globals") nil)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 10. Main execution loop — iterative dispatch
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define vm-run
|
||||
(fn (vm)
|
||||
"Execute bytecode until all frames are exhausted.
|
||||
VmClosure calls push new frames; the loop picks them up.
|
||||
OP_TAIL_CALL + VmClosure = true TCO: drop frame, push new, loop."
|
||||
(define loop
|
||||
(fn ()
|
||||
(when (not (empty? (get vm "frames")))
|
||||
(let ((frame (first (get vm "frames")))
|
||||
(rest-frames (rest (get vm "frames"))))
|
||||
(let ((bc (get (get (get frame "closure") "vm-code") "vc-bytecode"))
|
||||
(consts (get (get (get frame "closure") "vm-code") "vc-constants")))
|
||||
(if (>= (get frame "ip") (len bc))
|
||||
;; Bytecode exhausted — stop
|
||||
(dict-set! vm "frames" (list))
|
||||
(do
|
||||
(vm-step vm frame rest-frames bc consts)
|
||||
(loop))))))))
|
||||
(loop)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 11. Single step — opcode dispatch
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define vm-step
|
||||
(fn (vm frame rest-frames bc consts)
|
||||
(let ((op (frame-read-u8 frame)))
|
||||
(cond
|
||||
|
||||
;; ---- Constants ----
|
||||
(= op 1) ;; OP_CONST
|
||||
(let ((idx (frame-read-u16 frame)))
|
||||
(vm-push vm (nth consts idx)))
|
||||
|
||||
(= op 2) ;; OP_NIL
|
||||
(vm-push vm nil)
|
||||
|
||||
(= op 3) ;; OP_TRUE
|
||||
(vm-push vm true)
|
||||
|
||||
(= op 4) ;; OP_FALSE
|
||||
(vm-push vm false)
|
||||
|
||||
(= op 5) ;; OP_POP
|
||||
(vm-pop vm)
|
||||
|
||||
(= op 6) ;; OP_DUP
|
||||
(vm-push vm (vm-peek vm))
|
||||
|
||||
;; ---- Variable access ----
|
||||
(= op 16) ;; OP_LOCAL_GET
|
||||
(let ((slot (frame-read-u8 frame)))
|
||||
(vm-push vm (frame-local-get vm frame slot)))
|
||||
|
||||
(= op 17) ;; OP_LOCAL_SET
|
||||
(let ((slot (frame-read-u8 frame)))
|
||||
(frame-local-set vm frame slot (vm-peek vm)))
|
||||
|
||||
(= op 18) ;; OP_UPVALUE_GET
|
||||
(let ((idx (frame-read-u8 frame)))
|
||||
(vm-push vm (frame-upvalue-get frame idx)))
|
||||
|
||||
(= op 19) ;; OP_UPVALUE_SET
|
||||
(let ((idx (frame-read-u8 frame)))
|
||||
(frame-upvalue-set frame idx (vm-peek vm)))
|
||||
|
||||
(= op 20) ;; OP_GLOBAL_GET
|
||||
(let ((idx (frame-read-u16 frame))
|
||||
(name (nth consts idx)))
|
||||
(vm-push vm (vm-global-get vm frame name)))
|
||||
|
||||
(= op 21) ;; OP_GLOBAL_SET
|
||||
(let ((idx (frame-read-u16 frame))
|
||||
(name (nth consts idx)))
|
||||
(vm-global-set vm frame name (vm-peek vm)))
|
||||
|
||||
;; ---- Control flow ----
|
||||
(= op 32) ;; OP_JUMP
|
||||
(let ((offset (frame-read-i16 frame)))
|
||||
(dict-set! frame "ip" (+ (get frame "ip") offset)))
|
||||
|
||||
(= op 33) ;; OP_JUMP_IF_FALSE
|
||||
(let ((offset (frame-read-i16 frame))
|
||||
(v (vm-pop vm)))
|
||||
(when (not v)
|
||||
(dict-set! frame "ip" (+ (get frame "ip") offset))))
|
||||
|
||||
(= op 34) ;; OP_JUMP_IF_TRUE
|
||||
(let ((offset (frame-read-i16 frame))
|
||||
(v (vm-pop vm)))
|
||||
(when v
|
||||
(dict-set! frame "ip" (+ (get frame "ip") offset))))
|
||||
|
||||
;; ---- Function calls ----
|
||||
(= op 48) ;; OP_CALL
|
||||
(let ((argc (frame-read-u8 frame))
|
||||
(args-rev (list))
|
||||
(i 0))
|
||||
(define collect-args
|
||||
(fn ()
|
||||
(when (< i argc)
|
||||
(set! args-rev (cons (vm-pop vm) args-rev))
|
||||
(set! i (+ i 1))
|
||||
(collect-args))))
|
||||
(collect-args)
|
||||
(let ((f (vm-pop vm)))
|
||||
(vm-call vm f args-rev)))
|
||||
|
||||
(= op 49) ;; OP_TAIL_CALL
|
||||
(let ((argc (frame-read-u8 frame))
|
||||
(args-rev (list))
|
||||
(i 0))
|
||||
(define collect-args
|
||||
(fn ()
|
||||
(when (< i argc)
|
||||
(set! args-rev (cons (vm-pop vm) args-rev))
|
||||
(set! i (+ i 1))
|
||||
(collect-args))))
|
||||
(collect-args)
|
||||
(let ((f (vm-pop vm)))
|
||||
;; Drop current frame, reuse stack space — true TCO
|
||||
(dict-set! vm "frames" rest-frames)
|
||||
(dict-set! vm "sp" (get frame "base"))
|
||||
(vm-call vm f args-rev)))
|
||||
|
||||
(= op 50) ;; OP_RETURN
|
||||
(let ((result (vm-pop vm)))
|
||||
(dict-set! vm "frames" rest-frames)
|
||||
(dict-set! vm "sp" (get frame "base"))
|
||||
(vm-push vm result))
|
||||
|
||||
(= op 51) ;; OP_CLOSURE
|
||||
(let ((idx (frame-read-u16 frame))
|
||||
(code-val (nth consts idx)))
|
||||
(let ((cl (vm-create-closure vm frame code-val)))
|
||||
(vm-push vm cl)))
|
||||
|
||||
(= op 52) ;; OP_CALL_PRIM
|
||||
(let ((idx (frame-read-u16 frame))
|
||||
(argc (frame-read-u8 frame))
|
||||
(name (nth consts idx))
|
||||
(args-rev (list))
|
||||
(i 0))
|
||||
(define collect-args
|
||||
(fn ()
|
||||
(when (< i argc)
|
||||
(set! args-rev (cons (vm-pop vm) args-rev))
|
||||
(set! i (+ i 1))
|
||||
(collect-args))))
|
||||
(collect-args)
|
||||
(vm-push vm (call-primitive name args-rev)))
|
||||
|
||||
;; ---- Collections ----
|
||||
(= op 64) ;; OP_LIST
|
||||
(let ((count (frame-read-u16 frame))
|
||||
(items-rev (list))
|
||||
(i 0))
|
||||
(define collect-items
|
||||
(fn ()
|
||||
(when (< i count)
|
||||
(set! items-rev (cons (vm-pop vm) items-rev))
|
||||
(set! i (+ i 1))
|
||||
(collect-items))))
|
||||
(collect-items)
|
||||
(vm-push vm items-rev))
|
||||
|
||||
(= op 65) ;; OP_DICT
|
||||
(let ((count (frame-read-u16 frame))
|
||||
(d {})
|
||||
(i 0))
|
||||
(define collect-pairs
|
||||
(fn ()
|
||||
(when (< i count)
|
||||
(let ((v (vm-pop vm))
|
||||
(k (vm-pop vm)))
|
||||
(dict-set! d k v)
|
||||
(set! i (+ i 1))
|
||||
(collect-pairs)))))
|
||||
(collect-pairs)
|
||||
(vm-push vm d))
|
||||
|
||||
;; ---- String ops ----
|
||||
(= op 144) ;; OP_STR_CONCAT
|
||||
(let ((count (frame-read-u8 frame))
|
||||
(parts-rev (list))
|
||||
(i 0))
|
||||
(define collect-parts
|
||||
(fn ()
|
||||
(when (< i count)
|
||||
(set! parts-rev (cons (vm-pop vm) parts-rev))
|
||||
(set! i (+ i 1))
|
||||
(collect-parts))))
|
||||
(collect-parts)
|
||||
(vm-push vm (apply str parts-rev)))
|
||||
|
||||
;; ---- Define ----
|
||||
(= op 128) ;; OP_DEFINE
|
||||
(let ((idx (frame-read-u16 frame))
|
||||
(name (nth consts idx)))
|
||||
(dict-set! (get vm "globals") name (vm-peek vm)))
|
||||
|
||||
;; ---- Inline primitives ----
|
||||
(= op 160) ;; OP_ADD
|
||||
(let ((b (vm-pop vm)) (a (vm-pop vm)))
|
||||
(vm-push vm (+ a b)))
|
||||
(= op 161) ;; OP_SUB
|
||||
(let ((b (vm-pop vm)) (a (vm-pop vm)))
|
||||
(vm-push vm (- a b)))
|
||||
(= op 162) ;; OP_MUL
|
||||
(let ((b (vm-pop vm)) (a (vm-pop vm)))
|
||||
(vm-push vm (* a b)))
|
||||
(= op 163) ;; OP_DIV
|
||||
(let ((b (vm-pop vm)) (a (vm-pop vm)))
|
||||
(vm-push vm (/ a b)))
|
||||
(= op 164) ;; OP_EQ
|
||||
(let ((b (vm-pop vm)) (a (vm-pop vm)))
|
||||
(vm-push vm (= a b)))
|
||||
(= op 165) ;; OP_LT
|
||||
(let ((b (vm-pop vm)) (a (vm-pop vm)))
|
||||
(vm-push vm (< a b)))
|
||||
(= op 166) ;; OP_GT
|
||||
(let ((b (vm-pop vm)) (a (vm-pop vm)))
|
||||
(vm-push vm (> a b)))
|
||||
(= op 167) ;; OP_NOT
|
||||
(vm-push vm (not (vm-pop vm)))
|
||||
(= op 168) ;; OP_LEN
|
||||
(vm-push vm (len (vm-pop vm)))
|
||||
(= op 169) ;; OP_FIRST
|
||||
(vm-push vm (first (vm-pop vm)))
|
||||
(= op 170) ;; OP_REST
|
||||
(vm-push vm (rest (vm-pop vm)))
|
||||
(= op 171) ;; OP_NTH
|
||||
(let ((n (vm-pop vm)) (coll (vm-pop vm)))
|
||||
(vm-push vm (nth coll n)))
|
||||
(= op 172) ;; OP_CONS
|
||||
(let ((coll (vm-pop vm)) (x (vm-pop vm)))
|
||||
(vm-push vm (cons x coll)))
|
||||
(= op 173) ;; OP_NEG
|
||||
(vm-push vm (- 0 (vm-pop vm)))
|
||||
(= op 174) ;; OP_INC
|
||||
(vm-push vm (inc (vm-pop vm)))
|
||||
(= op 175) ;; OP_DEC
|
||||
(vm-push vm (dec (vm-pop vm)))
|
||||
|
||||
:else
|
||||
(error (str "VM: unknown opcode " op))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 12. Entry points
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Execute a closure with arguments — creates a fresh VM.
|
||||
(define vm-call-closure
|
||||
(fn (closure args globals)
|
||||
(let ((vm (make-vm globals)))
|
||||
(vm-push-frame vm closure args)
|
||||
(vm-run vm)
|
||||
(vm-pop vm))))
|
||||
|
||||
;; Execute a compiled module (top-level bytecode).
|
||||
(define vm-execute-module
|
||||
(fn (code globals)
|
||||
(let ((closure (make-vm-closure code (list) "module" globals nil))
|
||||
(vm (make-vm globals)))
|
||||
(let ((frame (make-vm-frame closure 0)))
|
||||
;; Pad local slots
|
||||
(let ((i 0)
|
||||
(total (get code "vc-locals")))
|
||||
(define pad-loop
|
||||
(fn ()
|
||||
(when (< i total)
|
||||
(vm-push vm nil)
|
||||
(set! i (+ i 1))
|
||||
(pad-loop))))
|
||||
(pad-loop))
|
||||
(dict-set! vm "frames" (list frame))
|
||||
(vm-run vm)
|
||||
(vm-pop vm)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 13. Platform interface
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Each target must provide:
|
||||
;;
|
||||
;; make-vm-stack(size) → opaque stack (array-like)
|
||||
;; vm-stack-get(stack, idx) → value at index
|
||||
;; vm-stack-set!(stack, idx, value) → mutate index
|
||||
;; vm-stack-length(stack) → current capacity
|
||||
;; vm-stack-copy!(src, dst, count) → copy first count elements
|
||||
;;
|
||||
;; cek-call(f, args) → evaluate via CEK machine (fallback)
|
||||
;; get-primitive(name) → look up primitive by name (returns callable)
|
||||
;; call-primitive(name, args) → call primitive directly with args list
|
||||
;;
|
||||
;; env-parent(env) → parent environment or nil
|
||||
;; env-has?(env, name) → boolean
|
||||
;; env-get(env, name) → value
|
||||
;; env-set!(env, name, value) → mutate binding
|
||||
166
run-tests.sh
Executable file
166
run-tests.sh
Executable file
@@ -0,0 +1,166 @@
|
||||
#!/usr/bin/env bash
|
||||
# ===========================================================================
|
||||
# run-tests.sh — Run ALL test suites. Exit non-zero if any fail.
|
||||
#
|
||||
# Usage:
|
||||
# ./run-tests.sh # run everything
|
||||
# ./run-tests.sh --quick # skip Playwright (fast CI check)
|
||||
# ./run-tests.sh --sx-only # SX language tests only (JS + Python + OCaml)
|
||||
# ===========================================================================
|
||||
set -euo pipefail
|
||||
|
||||
cd "$(dirname "$0")"
|
||||
|
||||
QUICK=false
|
||||
SX_ONLY=false
|
||||
for arg in "$@"; do
|
||||
case "$arg" in
|
||||
--quick) QUICK=true ;;
|
||||
--sx-only) SX_ONLY=true ;;
|
||||
esac
|
||||
done
|
||||
|
||||
FAILURES=()
|
||||
PASSES=()
|
||||
|
||||
run_suite() {
|
||||
local name="$1"
|
||||
shift
|
||||
echo ""
|
||||
echo "============================================================"
|
||||
echo " $name"
|
||||
echo "============================================================"
|
||||
if "$@"; then
|
||||
PASSES+=("$name")
|
||||
else
|
||||
FAILURES+=("$name")
|
||||
fi
|
||||
}
|
||||
|
||||
# -------------------------------------------------------------------
|
||||
# 1. Build SX bundles
|
||||
# -------------------------------------------------------------------
|
||||
echo "=== Building SX bundles ==="
|
||||
python3 hosts/javascript/cli.py --output shared/static/scripts/sx-browser.js
|
||||
python3 hosts/javascript/cli.py --extensions continuations --spec-modules types \
|
||||
--output shared/static/scripts/sx-full-test.js
|
||||
|
||||
# -------------------------------------------------------------------
|
||||
# 2. JavaScript SX tests (standard + full)
|
||||
# -------------------------------------------------------------------
|
||||
run_suite "JS standard (spec tests)" \
|
||||
node hosts/javascript/run_tests.js
|
||||
|
||||
run_suite "JS full (spec + continuations + types + VM)" \
|
||||
node hosts/javascript/run_tests.js --full
|
||||
|
||||
# -------------------------------------------------------------------
|
||||
# 3. OCaml SX tests
|
||||
# -------------------------------------------------------------------
|
||||
if [ -x hosts/ocaml/_build/default/bin/run_tests.exe ]; then
|
||||
run_suite "OCaml (spec tests)" \
|
||||
hosts/ocaml/_build/default/bin/run_tests.exe
|
||||
else
|
||||
echo ""
|
||||
echo "[SKIP] OCaml tests — binary not built (run: cd hosts/ocaml && dune build)"
|
||||
fi
|
||||
|
||||
# -------------------------------------------------------------------
|
||||
# 4. OCaml bridge integration (custom special forms, web-forms.sx)
|
||||
# -------------------------------------------------------------------
|
||||
run_suite "OCaml bridge — custom special forms + web-forms" \
|
||||
python3 -c "
|
||||
from shared.sx.ocaml_sync import OcamlSync
|
||||
bridge = OcamlSync()
|
||||
# Load exactly what the server does (no evaluator.sx!)
|
||||
for f in ['spec/parser.sx', 'spec/render.sx', 'web/adapter-html.sx', 'web/adapter-sx.sx', 'web/web-forms.sx', 'spec/freeze.sx']:
|
||||
bridge.load(f)
|
||||
ok = 0; fail = 0
|
||||
def check(name, expr, expected=None):
|
||||
global ok, fail
|
||||
try:
|
||||
r = bridge.eval(expr)
|
||||
if expected is not None and r != expected:
|
||||
print(f' FAIL: {name}: expected {expected!r}, got {r!r}'); fail += 1
|
||||
else:
|
||||
print(f' PASS: {name}'); ok += 1
|
||||
except Exception as e:
|
||||
print(f' FAIL: {name}: {e}'); fail += 1
|
||||
|
||||
# Custom special forms registered by web-forms.sx
|
||||
for form in ['defhandler', 'defquery', 'defaction', 'defpage', 'defrelation', 'defstyle', 'deftype', 'defeffect']:
|
||||
check(f'{form} registered', f'(has-key? *custom-special-forms* \"{form}\")', 'true')
|
||||
|
||||
# Custom forms callable via eval (not just via load)
|
||||
check('deftype via eval', '(deftype test-t number)', 'nil')
|
||||
check('defeffect via eval', '(defeffect test-e)', 'nil')
|
||||
check('defstyle via eval', '(defstyle my-s \"bold\")', 'bold')
|
||||
check('defhandler via eval', '(has-key? (defhandler test-h (&key x) x) \"__type\")', 'true')
|
||||
|
||||
# Extension lists populated
|
||||
check('definition-form-extensions populated', '(> (len *definition-form-extensions*) 0)', 'true')
|
||||
check('RENDER_HTML_FORMS has defstyle', '(contains? RENDER_HTML_FORMS \"defstyle\")', 'true')
|
||||
|
||||
# Env-shadowing regression: custom forms survive evaluator.sx load
|
||||
bridge2 = OcamlSync()
|
||||
bridge2.eval('(register-special-form! \"shadow-test\" (fn (args env) 42))')
|
||||
bridge2.load('spec/evaluator.sx')
|
||||
check('custom form survives evaluator.sx load',
|
||||
bridge2.eval('(has-key? *custom-special-forms* \"shadow-test\")'), 'true')
|
||||
bridge2.eval('(register-special-form! \"post-load\" (fn (args env) 99))')
|
||||
check('custom form callable after evaluator.sx load',
|
||||
bridge2.eval('(post-load 1)'), '99')
|
||||
|
||||
print(f'\\nResults: {ok} passed, {fail} failed')
|
||||
import sys; sys.exit(1 if fail > 0 else 0)
|
||||
"
|
||||
|
||||
# -------------------------------------------------------------------
|
||||
# 5. Python SX tests (post-removal regression, components, parser)
|
||||
# -------------------------------------------------------------------
|
||||
run_suite "Python — post-removal regression" \
|
||||
python3 -m pytest shared/sx/tests/test_post_removal_bugs.py -v --tb=short
|
||||
|
||||
run_suite "Python — component rendering" \
|
||||
python3 -m pytest shared/sx/tests/test_components.py -v --tb=short
|
||||
|
||||
run_suite "Python — parser" \
|
||||
python3 -m pytest shared/sx/tests/test_parser.py -v --tb=short
|
||||
|
||||
# -------------------------------------------------------------------
|
||||
# 5. Playwright tests (browser)
|
||||
# -------------------------------------------------------------------
|
||||
if [ "$QUICK" = false ] && [ "$SX_ONLY" = false ]; then
|
||||
run_suite "Playwright — isomorphic SSR" \
|
||||
npx playwright test --reporter=list
|
||||
|
||||
run_suite "Playwright — SX demos (98 tests)" \
|
||||
python3 -m pytest sx/tests/test_demos.py -v --tb=short
|
||||
fi
|
||||
|
||||
# -------------------------------------------------------------------
|
||||
# Summary
|
||||
# -------------------------------------------------------------------
|
||||
echo ""
|
||||
echo "============================================================"
|
||||
echo " TEST SUMMARY"
|
||||
echo "============================================================"
|
||||
for p in "${PASSES[@]}"; do
|
||||
echo " PASS: $p"
|
||||
done
|
||||
for f in "${FAILURES[@]}"; do
|
||||
echo " FAIL: $f"
|
||||
done
|
||||
echo "============================================================"
|
||||
|
||||
if [ ${#FAILURES[@]} -gt 0 ]; then
|
||||
echo ""
|
||||
echo " ${#FAILURES[@]} suite(s) FAILED — deploy blocked."
|
||||
echo ""
|
||||
exit 1
|
||||
else
|
||||
echo ""
|
||||
echo " All ${#PASSES[@]} suites passed."
|
||||
echo ""
|
||||
exit 0
|
||||
fi
|
||||
@@ -344,7 +344,7 @@ def create_base_app(
|
||||
response.headers["Access-Control-Allow-Origin"] = origin
|
||||
response.headers["Access-Control-Allow-Credentials"] = "true"
|
||||
response.headers["Access-Control-Allow-Headers"] = (
|
||||
"SX-Request, SX-Target, SX-Current-URL, SX-Components, SX-Css, "
|
||||
"SX-Request, SX-Target, SX-Current-URL, SX-Components, SX-Components-Hash, SX-Css, "
|
||||
"HX-Request, HX-Target, HX-Current-URL, HX-Trigger, "
|
||||
"Content-Type, X-CSRFToken"
|
||||
)
|
||||
|
||||
File diff suppressed because one or more lines are too long
@@ -32,7 +32,6 @@ from .parser import (
|
||||
serialize,
|
||||
)
|
||||
from .types import EvalError
|
||||
from .ref.sx_ref import evaluate, make_env
|
||||
|
||||
from .primitives import (
|
||||
all_primitives,
|
||||
|
||||
@@ -53,7 +53,9 @@ from .types import Component, Island, Keyword, Lambda, Macro, NIL, Symbol
|
||||
_expand_components: contextvars.ContextVar[bool] = contextvars.ContextVar(
|
||||
"_expand_components", default=False
|
||||
)
|
||||
from .ref.sx_ref import expand_macro as _expand_macro
|
||||
# sx_ref.py removed — stub so module loads. OCaml bridge handles macro expansion.
|
||||
def _expand_macro(*a, **kw):
|
||||
raise RuntimeError("sx_ref.py has been removed — use SX_USE_OCAML=1")
|
||||
from .types import EvalError
|
||||
from .primitives import _PRIMITIVES
|
||||
from .primitives_io import IO_PRIMITIVES, RequestContext, execute_io
|
||||
@@ -421,23 +423,39 @@ async def _asf_define(expr, env, ctx):
|
||||
|
||||
|
||||
async def _asf_defcomp(expr, env, ctx):
|
||||
from .ref.sx_ref import sf_defcomp
|
||||
return sf_defcomp(expr[1:], env)
|
||||
# Component definitions are handled by OCaml kernel at load time.
|
||||
# Python-side: just store a minimal Component in env for reference.
|
||||
from .types import Component
|
||||
name_sym = expr[1]
|
||||
name = name_sym.name if hasattr(name_sym, 'name') else str(name_sym)
|
||||
env[name] = Component(name=name.lstrip("~"), params=[], has_children=False,
|
||||
body=expr[-1], closure={})
|
||||
return NIL
|
||||
|
||||
|
||||
async def _asf_defstyle(expr, env, ctx):
|
||||
from .ref.sx_ref import sf_defstyle
|
||||
return sf_defstyle(expr[1:], env)
|
||||
# Style definitions handled by OCaml kernel.
|
||||
return NIL
|
||||
|
||||
|
||||
async def _asf_defmacro(expr, env, ctx):
|
||||
from .ref.sx_ref import sf_defmacro
|
||||
return sf_defmacro(expr[1:], env)
|
||||
# Macro definitions handled by OCaml kernel.
|
||||
from .types import Macro
|
||||
name_sym = expr[1]
|
||||
name = name_sym.name if hasattr(name_sym, 'name') else str(name_sym)
|
||||
params_form = expr[2] if len(expr) > 3 else []
|
||||
param_names = [p.name for p in params_form if isinstance(p, Symbol) and not p.name.startswith("&")]
|
||||
rest_param = None
|
||||
for i, p in enumerate(params_form):
|
||||
if isinstance(p, Symbol) and p.name == "&rest" and i + 1 < len(params_form):
|
||||
rest_param = params_form[i + 1].name if isinstance(params_form[i + 1], Symbol) else None
|
||||
env[name] = Macro(name=name, params=param_names, rest_param=rest_param, body=expr[-1])
|
||||
return NIL
|
||||
|
||||
|
||||
async def _asf_defhandler(expr, env, ctx):
|
||||
from .ref.sx_ref import sf_defhandler
|
||||
return sf_defhandler(expr[1:], env)
|
||||
# Handler definitions handled by OCaml kernel.
|
||||
return NIL
|
||||
|
||||
|
||||
async def _asf_begin(expr, env, ctx):
|
||||
@@ -599,9 +617,12 @@ async def _asf_reset(expr, env, ctx):
|
||||
from .types import NIL
|
||||
_ASYNC_RESET_RESUME.append(value if value is not None else NIL)
|
||||
try:
|
||||
# Sync re-evaluation; the async caller will trampoline
|
||||
from .ref.sx_ref import eval_expr as sync_eval, trampoline as _trampoline
|
||||
return _trampoline(sync_eval(body, env))
|
||||
# Continuations are handled by OCaml kernel.
|
||||
# Python-side cont_fn should not be called in normal operation.
|
||||
raise RuntimeError(
|
||||
"Python-side continuation invocation not supported — "
|
||||
"use OCaml bridge for shift/reset"
|
||||
)
|
||||
finally:
|
||||
_ASYNC_RESET_RESUME.pop()
|
||||
k = Continuation(cont_fn)
|
||||
|
||||
@@ -14,7 +14,7 @@ from .types import Component, Island, Macro, Symbol
|
||||
|
||||
|
||||
def _use_ref() -> bool:
|
||||
return os.environ.get("SX_USE_REF") == "1"
|
||||
return False # sx_ref.py removed — always use fallback
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
@@ -152,18 +152,11 @@ def transitive_deps(name: str, env: dict[str, Any]) -> set[str]:
|
||||
Returns the set of all component names (with ~ prefix) that
|
||||
*name* can transitively render, NOT including *name* itself.
|
||||
"""
|
||||
if _use_ref():
|
||||
from .ref.sx_ref import transitive_deps as _ref_td
|
||||
return set(_ref_td(name, env))
|
||||
return _transitive_deps_fallback(name, env)
|
||||
|
||||
|
||||
def compute_all_deps(env: dict[str, Any]) -> None:
|
||||
"""Compute and cache deps for all Component entries in *env*."""
|
||||
if _use_ref():
|
||||
from .ref.sx_ref import compute_all_deps as _ref_cad
|
||||
_ref_cad(env)
|
||||
return
|
||||
_compute_all_deps_fallback(env)
|
||||
|
||||
|
||||
@@ -172,9 +165,6 @@ def scan_components_from_sx(source: str) -> set[str]:
|
||||
|
||||
Returns names with ~ prefix, e.g. {"~card", "~shared:layout/nav-link"}.
|
||||
"""
|
||||
if _use_ref():
|
||||
from .ref.sx_ref import scan_components_from_source as _ref_sc
|
||||
return set(_ref_sc(source))
|
||||
return _scan_components_from_sx_fallback(source)
|
||||
|
||||
|
||||
@@ -183,18 +173,11 @@ def components_needed(page_sx: str, env: dict[str, Any]) -> set[str]:
|
||||
|
||||
Returns names with ~ prefix.
|
||||
"""
|
||||
if _use_ref():
|
||||
from .ref.sx_ref import components_needed as _ref_cn
|
||||
return set(_ref_cn(page_sx, env))
|
||||
return _components_needed_fallback(page_sx, env)
|
||||
|
||||
|
||||
def compute_all_io_refs(env: dict[str, Any], io_names: set[str]) -> None:
|
||||
"""Compute and cache transitive IO refs for all Component entries in *env*."""
|
||||
if _use_ref():
|
||||
from .ref.sx_ref import compute_all_io_refs as _ref_cio
|
||||
_ref_cio(env, list(io_names))
|
||||
return
|
||||
_compute_all_io_refs_fallback(env, io_names)
|
||||
|
||||
|
||||
@@ -209,9 +192,17 @@ def page_render_plan(page_sx: str, env: dict[str, Any], io_names: set[str] | Non
|
||||
"""
|
||||
if io_names is None:
|
||||
io_names = get_all_io_names()
|
||||
from .ref.sx_ref import page_render_plan as _ref_prp
|
||||
plan = _ref_prp(page_sx, env, list(io_names))
|
||||
return plan
|
||||
# Use fallback implementation (sx_ref.py removed)
|
||||
needed = _components_needed_fallback(page_sx, env)
|
||||
server, client, io_deps = [], [], []
|
||||
for name in needed:
|
||||
comp = env.get(name)
|
||||
if comp and hasattr(comp, 'io_refs') and comp.io_refs:
|
||||
client.append(name)
|
||||
else:
|
||||
server.append(name)
|
||||
return {"components": {n: ("server" if n in server else "client") for n in needed},
|
||||
"server": server, "client": client, "io-deps": io_deps}
|
||||
|
||||
|
||||
def get_all_io_names() -> set[str]:
|
||||
|
||||
@@ -80,30 +80,76 @@ def clear_handlers(service: str | None = None) -> None:
|
||||
# Loading — parse .sx files and collect HandlerDef instances
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
def _parse_defhandler(expr: list) -> HandlerDef | None:
|
||||
"""Extract HandlerDef from a (defhandler name :path ... (&key ...) body) form."""
|
||||
from .types import Keyword
|
||||
if len(expr) < 3:
|
||||
return None
|
||||
name = expr[1].name if hasattr(expr[1], 'name') else str(expr[1])
|
||||
|
||||
# Parse keyword options and find params/body
|
||||
path = None
|
||||
method = "get"
|
||||
csrf = True
|
||||
returns = "element"
|
||||
params_list = None
|
||||
body = None
|
||||
|
||||
i = 2
|
||||
while i < len(expr):
|
||||
item = expr[i]
|
||||
if isinstance(item, Keyword) and i + 1 < len(expr):
|
||||
kn = item.name
|
||||
val = expr[i + 1]
|
||||
if kn == "path":
|
||||
path = val if isinstance(val, str) else str(val)
|
||||
elif kn == "method":
|
||||
method = val.name if hasattr(val, 'name') else str(val)
|
||||
elif kn == "csrf":
|
||||
csrf = val not in (False, "false")
|
||||
elif kn == "returns":
|
||||
returns = val if isinstance(val, str) else str(val)
|
||||
i += 2
|
||||
elif isinstance(item, list) and not params_list:
|
||||
# This is the params list (&key ...)
|
||||
params_list = item
|
||||
i += 1
|
||||
else:
|
||||
body = item
|
||||
i += 1
|
||||
|
||||
param_names = []
|
||||
if params_list:
|
||||
for p in params_list:
|
||||
if hasattr(p, 'name') and p.name not in ("&key", "&rest"):
|
||||
param_names.append(p.name)
|
||||
|
||||
return HandlerDef(
|
||||
name=name, params=param_names, body=body or [],
|
||||
path=path, method=method, csrf=csrf, returns=returns,
|
||||
)
|
||||
|
||||
|
||||
def load_handler_file(filepath: str, service_name: str) -> list[HandlerDef]:
|
||||
"""Parse an .sx file, evaluate it, and register any HandlerDef values."""
|
||||
from .parser import parse_all
|
||||
import os
|
||||
from .ref.sx_ref import eval_expr as _raw_eval, trampoline as _trampoline
|
||||
_eval = lambda expr, env: _trampoline(_raw_eval(expr, env))
|
||||
from .jinja_bridge import get_component_env
|
||||
|
||||
with open(filepath, encoding="utf-8") as f:
|
||||
source = f.read()
|
||||
|
||||
# Seed env with component definitions so handlers can reference components
|
||||
env = dict(get_component_env())
|
||||
# Parse defhandler forms from the AST to extract handler registration info
|
||||
exprs = parse_all(source)
|
||||
handlers: list[HandlerDef] = []
|
||||
|
||||
for expr in exprs:
|
||||
_eval(expr, env)
|
||||
|
||||
# Collect all HandlerDef values from the env
|
||||
for key, val in env.items():
|
||||
if isinstance(val, HandlerDef):
|
||||
register_handler(service_name, val)
|
||||
handlers.append(val)
|
||||
if (isinstance(expr, list) and expr
|
||||
and hasattr(expr[0], 'name') and expr[0].name == "defhandler"):
|
||||
hd = _parse_defhandler(expr)
|
||||
if hd:
|
||||
register_handler(service_name, hd)
|
||||
handlers.append(hd)
|
||||
|
||||
return handlers
|
||||
|
||||
@@ -137,36 +183,54 @@ async def execute_handler(
|
||||
|
||||
1. Build env from component env + handler closure
|
||||
2. Bind handler params from args (typically request.args)
|
||||
3. Evaluate via ``async_eval_to_sx`` (I/O inline, components serialized)
|
||||
3. Evaluate via OCaml kernel (or Python fallback)
|
||||
4. Return ``SxExpr`` wire format
|
||||
"""
|
||||
from .jinja_bridge import get_component_env, _get_request_context
|
||||
from .pages import get_page_helpers
|
||||
from .parser import serialize
|
||||
from .types import NIL, SxExpr
|
||||
import os
|
||||
if os.environ.get("SX_USE_REF") == "1":
|
||||
from .ref.async_eval_ref import async_eval_to_sx
|
||||
else:
|
||||
from .async_eval import async_eval_to_sx
|
||||
from .types import NIL
|
||||
|
||||
if args is None:
|
||||
args = {}
|
||||
|
||||
# Build environment
|
||||
env = dict(get_component_env())
|
||||
env.update(get_page_helpers(service_name))
|
||||
env.update(handler_def.closure)
|
||||
use_ocaml = os.environ.get("SX_USE_OCAML") == "1"
|
||||
|
||||
# Bind handler params from request args
|
||||
for param in handler_def.params:
|
||||
env[param] = args.get(param, args.get(param.replace("-", "_"), NIL))
|
||||
if use_ocaml:
|
||||
from .ocaml_bridge import get_bridge
|
||||
|
||||
# Get request context for I/O primitives
|
||||
ctx = _get_request_context()
|
||||
# Serialize handler body with bound params as a let expression.
|
||||
# Define constants and defcomps from the handler file are available
|
||||
# in the kernel's global env (loaded by _ensure_components).
|
||||
param_bindings = []
|
||||
for param in handler_def.params:
|
||||
val = args.get(param, args.get(param.replace("-", "_"), NIL))
|
||||
param_bindings.append(f"({param} {serialize(val)})")
|
||||
|
||||
# Async eval → sx source — I/O primitives are awaited inline,
|
||||
# but component/tag calls serialize to sx wire format (not HTML).
|
||||
return await async_eval_to_sx(handler_def.body, env, ctx)
|
||||
body_sx = serialize(handler_def.body)
|
||||
if param_bindings:
|
||||
sx_text = f"(let ({' '.join(param_bindings)}) {body_sx})"
|
||||
else:
|
||||
sx_text = body_sx
|
||||
|
||||
bridge = await get_bridge()
|
||||
ocaml_ctx = {"_helper_service": service_name}
|
||||
result_sx = await bridge.aser(sx_text, ctx=ocaml_ctx)
|
||||
return SxExpr(result_sx or "")
|
||||
else:
|
||||
# Python fallback (async_eval)
|
||||
from .async_eval import async_eval_to_sx
|
||||
|
||||
env = dict(get_component_env())
|
||||
env.update(get_page_helpers(service_name))
|
||||
env.update(handler_def.closure)
|
||||
|
||||
for param in handler_def.params:
|
||||
env[param] = args.get(param, args.get(param.replace("-", "_"), NIL))
|
||||
|
||||
ctx = _get_request_context()
|
||||
return await async_eval_to_sx(handler_def.body, env, ctx)
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
@@ -364,10 +364,6 @@ async def _render_to_sx_with_env(__name: str, extra_env: dict, **kwargs: Any) ->
|
||||
"""
|
||||
from .jinja_bridge import get_component_env, _get_request_context
|
||||
import os
|
||||
if os.environ.get("SX_USE_REF") == "1":
|
||||
from .ref.async_eval_ref import async_eval_slot_to_sx
|
||||
else:
|
||||
from .async_eval import async_eval_slot_to_sx
|
||||
from .types import Symbol, Keyword, NIL as _NIL
|
||||
|
||||
# Build AST with extra_env entries as keyword args so _aser_component
|
||||
@@ -381,6 +377,16 @@ async def _render_to_sx_with_env(__name: str, extra_env: dict, **kwargs: Any) ->
|
||||
ast.append(Keyword(k.replace("_", "-")))
|
||||
ast.append(v if v is not None else _NIL)
|
||||
|
||||
if os.environ.get("SX_USE_OCAML") == "1":
|
||||
from .ocaml_bridge import get_bridge
|
||||
from .parser import serialize
|
||||
bridge = await get_bridge()
|
||||
sx_text = serialize(ast)
|
||||
ocaml_ctx = {"_helper_service": _get_request_context().get("_helper_service", "")} if isinstance(_get_request_context(), dict) else {}
|
||||
return SxExpr(await bridge.aser_slot(sx_text, ctx=ocaml_ctx))
|
||||
|
||||
from .async_eval import async_eval_slot_to_sx
|
||||
|
||||
env = dict(get_component_env())
|
||||
env.update(extra_env)
|
||||
ctx = _get_request_context()
|
||||
@@ -399,12 +405,21 @@ async def _render_to_sx(__name: str, **kwargs: Any) -> str:
|
||||
"""
|
||||
from .jinja_bridge import get_component_env, _get_request_context
|
||||
import os
|
||||
if os.environ.get("SX_USE_REF") == "1":
|
||||
from .ref.async_eval_ref import async_eval_to_sx
|
||||
else:
|
||||
from .async_eval import async_eval_to_sx
|
||||
|
||||
ast = _build_component_ast(__name, **kwargs)
|
||||
|
||||
if os.environ.get("SX_USE_OCAML") == "1":
|
||||
from .ocaml_bridge import get_bridge
|
||||
from .parser import serialize
|
||||
bridge = await get_bridge()
|
||||
sx_text = serialize(ast)
|
||||
# aser_slot (not aser) — layout wrappers contain re-parsed
|
||||
# content from earlier aser_slot calls. Regular aser fails on
|
||||
# symbols like `title` that were bound during the earlier expansion.
|
||||
return SxExpr(await bridge.aser_slot(sx_text))
|
||||
|
||||
from .async_eval import async_eval_to_sx
|
||||
|
||||
env = dict(get_component_env())
|
||||
ctx = _get_request_context()
|
||||
return SxExpr(await async_eval_to_sx(ast, env, ctx))
|
||||
@@ -420,15 +435,24 @@ async def render_to_html(__name: str, **kwargs: Any) -> str:
|
||||
|
||||
Same as render_to_sx() but produces HTML output instead of SX wire
|
||||
format. Used by route renders that need HTML (full pages, fragments).
|
||||
|
||||
Routes through the OCaml bridge (render mode) which handles component
|
||||
parameter binding, scope primitives, and all evaluation.
|
||||
"""
|
||||
from .jinja_bridge import get_component_env, _get_request_context
|
||||
import os
|
||||
if os.environ.get("SX_USE_REF") == "1":
|
||||
from .ref.async_eval_ref import async_render
|
||||
else:
|
||||
from .async_eval import async_render
|
||||
|
||||
ast = _build_component_ast(__name, **kwargs)
|
||||
|
||||
if os.environ.get("SX_USE_OCAML") == "1":
|
||||
from .ocaml_bridge import get_bridge
|
||||
from .parser import serialize
|
||||
bridge = await get_bridge()
|
||||
sx_text = serialize(ast)
|
||||
return await bridge.render(sx_text)
|
||||
|
||||
# Fallback: Python async_eval (requires working evaluator)
|
||||
from .jinja_bridge import get_component_env, _get_request_context
|
||||
from .async_eval import async_render
|
||||
env = dict(get_component_env())
|
||||
ctx = _get_request_context()
|
||||
return await async_render(ast, env, ctx)
|
||||
@@ -496,8 +520,18 @@ def components_for_request(source: str = "",
|
||||
elif extra_names:
|
||||
needed = extra_names
|
||||
|
||||
loaded_raw = request.headers.get("SX-Components", "")
|
||||
loaded = set(loaded_raw.split(",")) if loaded_raw else set()
|
||||
# Check hash first (new): if client hash matches current, skip all defs.
|
||||
# Fall back to legacy name list (SX-Components) for backward compat.
|
||||
comp_hash_header = request.headers.get("SX-Components-Hash", "")
|
||||
if comp_hash_header:
|
||||
from .jinja_bridge import components_for_page
|
||||
_, current_hash = components_for_page("", service=None)
|
||||
if comp_hash_header == current_hash:
|
||||
return "" # client has everything
|
||||
loaded = set() # hash mismatch — send all needed
|
||||
else:
|
||||
loaded_raw = request.headers.get("SX-Components", "")
|
||||
loaded = set(loaded_raw.split(",")) if loaded_raw else set()
|
||||
|
||||
parts = []
|
||||
for key, val in _COMPONENT_ENV.items():
|
||||
@@ -767,6 +801,162 @@ def _sx_literal(v: object) -> str:
|
||||
|
||||
|
||||
|
||||
_cached_shell_static: dict[str, Any] | None = None
|
||||
_cached_shell_comp_hash: str | None = None
|
||||
|
||||
|
||||
def invalidate_shell_cache():
|
||||
"""Call on component hot-reload to recompute shell statics."""
|
||||
global _cached_shell_static, _cached_shell_comp_hash
|
||||
_cached_shell_static = None
|
||||
_cached_shell_comp_hash = None
|
||||
|
||||
|
||||
def _get_shell_static() -> dict[str, Any]:
|
||||
"""Compute and cache all shell kwargs that don't change per-request.
|
||||
|
||||
This is the expensive part: component dep scanning, serialization,
|
||||
CSS class scanning, rule lookup, pages registry. All stable until
|
||||
components are hot-reloaded.
|
||||
"""
|
||||
global _cached_shell_static, _cached_shell_comp_hash
|
||||
from .jinja_bridge import components_for_page, css_classes_for_page, _component_env_hash
|
||||
from .css_registry import lookup_rules, get_preamble, registry_loaded, store_css_hash
|
||||
|
||||
current_hash = _component_env_hash()
|
||||
if _cached_shell_static is not None and _cached_shell_comp_hash == current_hash:
|
||||
return _cached_shell_static
|
||||
|
||||
import time
|
||||
t0 = time.monotonic()
|
||||
|
||||
from quart import current_app as _ca
|
||||
from .jinja_bridge import client_components_tag, _COMPONENT_ENV, _CLIENT_LIBRARY_SOURCES
|
||||
from .jinja_bridge import _component_env_hash
|
||||
from .parser import serialize as _serialize
|
||||
|
||||
# Send ALL component definitions — the hash is stable per env so the
|
||||
# browser caches them across all pages. Server-side expansion handles
|
||||
# the per-page subset; the client needs the full set for client-side
|
||||
# routing to any page.
|
||||
parts = []
|
||||
for key, val in _COMPONENT_ENV.items():
|
||||
from .types import Island, Component, Macro
|
||||
if isinstance(val, Island):
|
||||
ps = ["&key"] + list(val.params)
|
||||
if val.has_children: ps.extend(["&rest", "children"])
|
||||
parts.append(f"(defisland ~{val.name} ({' '.join(ps)}) {_serialize(val.body, pretty=True)})")
|
||||
elif isinstance(val, Component):
|
||||
ps = ["&key"] + list(val.params)
|
||||
if val.has_children: ps.extend(["&rest", "children"])
|
||||
parts.append(f"(defcomp ~{val.name} ({' '.join(ps)}) {_serialize(val.body, pretty=True)})")
|
||||
elif isinstance(val, Macro):
|
||||
ps = list(val.params)
|
||||
if val.rest_param: ps.extend(["&rest", val.rest_param])
|
||||
parts.append(f"(defmacro {val.name} ({' '.join(ps)}) {_serialize(val.body, pretty=True)})")
|
||||
all_parts = list(_CLIENT_LIBRARY_SOURCES) + parts
|
||||
component_defs = "\n".join(all_parts)
|
||||
component_hash = _component_env_hash()
|
||||
|
||||
# CSS: scan ALL components (not per-page) for the static cache
|
||||
sx_css = ""
|
||||
sx_css_classes = ""
|
||||
if registry_loaded():
|
||||
classes: set[str] = set()
|
||||
from .types import Island as _I, Component as _C
|
||||
for val in _COMPONENT_ENV.values():
|
||||
if isinstance(val, (_I, _C)) and val.css_classes:
|
||||
classes.update(val.css_classes)
|
||||
classes.update(["bg-stone-50", "text-stone-900"])
|
||||
rules = lookup_rules(classes)
|
||||
sx_css = get_preamble() + rules
|
||||
sx_css_classes = store_css_hash(classes)
|
||||
|
||||
pages_sx = _build_pages_sx(_ca.name)
|
||||
|
||||
_shell_cfg = _ca.config.get("SX_SHELL", {})
|
||||
|
||||
static = dict(
|
||||
component_hash=component_hash,
|
||||
component_defs=component_defs,
|
||||
pages_sx=pages_sx,
|
||||
sx_css=sx_css,
|
||||
sx_css_classes=sx_css_classes,
|
||||
sx_js_hash=_script_hash("sx-browser.js"),
|
||||
body_js_hash=_script_hash("body.js"),
|
||||
asset_url=_ca.config.get("ASSET_URL", "/static"),
|
||||
head_scripts=_shell_cfg.get("head_scripts"),
|
||||
inline_css=_shell_cfg.get("inline_css"),
|
||||
inline_head_js=_shell_cfg.get("inline_head_js"),
|
||||
init_sx=_shell_cfg.get("init_sx"),
|
||||
body_scripts=_shell_cfg.get("body_scripts"),
|
||||
)
|
||||
|
||||
t1 = time.monotonic()
|
||||
import logging
|
||||
logging.getLogger("sx.pages").info(
|
||||
"[shell-static] computed in %.3fs, comp_defs=%d css=%d pages=%d",
|
||||
t1 - t0, len(component_defs), len(sx_css), len(pages_sx))
|
||||
|
||||
_cached_shell_static = static
|
||||
_cached_shell_comp_hash = current_hash
|
||||
return static
|
||||
|
||||
|
||||
async def _build_shell_kwargs(ctx: dict, page_sx: str, *,
|
||||
meta_html: str = "",
|
||||
head_scripts: list[str] | None = None,
|
||||
inline_css: str | None = None,
|
||||
inline_head_js: str | None = None,
|
||||
init_sx: str | None = None,
|
||||
body_scripts: list[str] | None = None) -> dict[str, Any]:
|
||||
"""Compute all shell kwargs for sx-page-shell.
|
||||
|
||||
Static parts (components, CSS, pages) are cached. Only per-request
|
||||
values (title, csrf) are computed fresh.
|
||||
"""
|
||||
static = _get_shell_static()
|
||||
|
||||
asset_url = get_asset_url(ctx) or static["asset_url"]
|
||||
title = ctx.get("base_title", "Rose Ash")
|
||||
csrf = _get_csrf_token()
|
||||
|
||||
kwargs: dict[str, Any] = dict(static)
|
||||
kwargs.update(
|
||||
title=_html_escape(title),
|
||||
asset_url=asset_url,
|
||||
meta_html=meta_html,
|
||||
csrf=_html_escape(csrf),
|
||||
)
|
||||
|
||||
# Per-page CSS: scan THIS page's classes and add to cached CSS
|
||||
from .css_registry import scan_classes_from_sx, lookup_rules, registry_loaded
|
||||
if registry_loaded() and page_sx:
|
||||
page_classes = scan_classes_from_sx(page_sx)
|
||||
if page_classes:
|
||||
extra_rules = lookup_rules(page_classes)
|
||||
if extra_rules:
|
||||
kwargs["sx_css"] = static["sx_css"] + extra_rules
|
||||
|
||||
# Cookie-based component caching
|
||||
client_hash = _get_sx_comp_cookie()
|
||||
if not _is_dev_mode() and client_hash and client_hash == static["component_hash"]:
|
||||
kwargs["component_defs"] = ""
|
||||
|
||||
# Per-call overrides
|
||||
if head_scripts is not None:
|
||||
kwargs["head_scripts"] = head_scripts
|
||||
if inline_css is not None:
|
||||
kwargs["inline_css"] = inline_css
|
||||
if inline_head_js is not None:
|
||||
kwargs["inline_head_js"] = inline_head_js
|
||||
if init_sx is not None:
|
||||
kwargs["init_sx"] = init_sx
|
||||
if body_scripts is not None:
|
||||
kwargs["body_scripts"] = body_scripts
|
||||
return kwargs
|
||||
|
||||
|
||||
async def sx_page(ctx: dict, page_sx: str, *,
|
||||
meta_html: str = "",
|
||||
head_scripts: list[str] | None = None,
|
||||
@@ -774,109 +964,18 @@ async def sx_page(ctx: dict, page_sx: str, *,
|
||||
inline_head_js: str | None = None,
|
||||
init_sx: str | None = None,
|
||||
body_scripts: list[str] | None = None) -> str:
|
||||
"""Return a minimal HTML shell that boots the page from sx source.
|
||||
|
||||
The browser loads component definitions and page sx, then sx.js
|
||||
renders everything client-side. CSS rules are scanned from the sx
|
||||
source and component defs, then injected as a <style> block.
|
||||
|
||||
The shell is rendered from the ~shared:shell/sx-page-shell SX component
|
||||
(shared/sx/templates/shell.sx).
|
||||
"""
|
||||
from .jinja_bridge import components_for_page, css_classes_for_page
|
||||
from .css_registry import lookup_rules, get_preamble, registry_loaded, store_css_hash
|
||||
|
||||
# Per-page component bundle: this page's deps + all :data page deps
|
||||
from quart import current_app as _ca
|
||||
component_defs, component_hash = components_for_page(page_sx, service=_ca.name)
|
||||
|
||||
# Check if client already has this version cached (via cookie)
|
||||
# In dev mode, always send full source so edits are visible immediately
|
||||
client_hash = _get_sx_comp_cookie()
|
||||
if not _is_dev_mode() and client_hash and client_hash == component_hash:
|
||||
# Client has current components cached — send empty source
|
||||
component_defs = ""
|
||||
|
||||
# Scan for CSS classes — only from components this page uses + page source
|
||||
sx_css = ""
|
||||
sx_css_classes = ""
|
||||
sx_css_hash = ""
|
||||
if registry_loaded():
|
||||
classes = css_classes_for_page(page_sx, service=_ca.name)
|
||||
# Always include body classes
|
||||
classes.update(["bg-stone-50", "text-stone-900"])
|
||||
rules = lookup_rules(classes)
|
||||
sx_css = get_preamble() + rules
|
||||
sx_css_hash = store_css_hash(classes)
|
||||
sx_css_classes = sx_css_hash
|
||||
|
||||
asset_url = get_asset_url(ctx)
|
||||
title = ctx.get("base_title", "Rose Ash")
|
||||
csrf = _get_csrf_token()
|
||||
|
||||
# Dev mode: pretty-print page sx for readable View Source
|
||||
if _is_dev_mode() and page_sx and page_sx.startswith("("):
|
||||
from .parser import parse as _parse, serialize as _serialize
|
||||
try:
|
||||
page_sx = _serialize(_parse(page_sx), pretty=True)
|
||||
except Exception as e:
|
||||
import logging
|
||||
logging.getLogger("sx").warning("Pretty-print page_sx failed: %s", e)
|
||||
|
||||
# Page registry for client-side routing
|
||||
import logging
|
||||
_plog = logging.getLogger("sx.pages")
|
||||
from quart import current_app
|
||||
pages_sx = _build_pages_sx(current_app.name)
|
||||
_plog.debug("sx_page: pages_sx %d bytes for service %s", len(pages_sx), current_app.name)
|
||||
if pages_sx:
|
||||
_plog.debug("sx_page: pages_sx first 200 chars: %s", pages_sx[:200])
|
||||
|
||||
# Ensure page_sx is a plain str, not SxExpr — _build_component_ast
|
||||
# parses SxExpr back into AST, which _arender then evaluates as HTML
|
||||
# instead of passing through as raw content for the script tag.
|
||||
"""Return a minimal HTML shell that boots the page from sx source."""
|
||||
# Ensure page_sx is a plain str
|
||||
if isinstance(page_sx, SxExpr):
|
||||
page_sx = "".join([page_sx])
|
||||
|
||||
# Per-app shell config: check explicit args, then app config, then defaults
|
||||
from quart import current_app as _app
|
||||
_shell_cfg = _app.config.get("SX_SHELL", {})
|
||||
if head_scripts is None:
|
||||
head_scripts = _shell_cfg.get("head_scripts")
|
||||
if inline_css is None:
|
||||
inline_css = _shell_cfg.get("inline_css")
|
||||
if inline_head_js is None:
|
||||
inline_head_js = _shell_cfg.get("inline_head_js")
|
||||
if init_sx is None:
|
||||
init_sx = _shell_cfg.get("init_sx")
|
||||
if body_scripts is None:
|
||||
body_scripts = _shell_cfg.get("body_scripts")
|
||||
|
||||
shell_kwargs: dict[str, Any] = dict(
|
||||
title=_html_escape(title),
|
||||
asset_url=asset_url,
|
||||
meta_html=meta_html,
|
||||
csrf=_html_escape(csrf),
|
||||
component_hash=component_hash,
|
||||
component_defs=component_defs,
|
||||
pages_sx=pages_sx,
|
||||
page_sx=page_sx,
|
||||
sx_css=sx_css,
|
||||
sx_css_classes=sx_css_classes,
|
||||
sx_js_hash=_script_hash("sx-browser.js"),
|
||||
body_js_hash=_script_hash("body.js"),
|
||||
)
|
||||
if head_scripts is not None:
|
||||
shell_kwargs["head_scripts"] = head_scripts
|
||||
if inline_css is not None:
|
||||
shell_kwargs["inline_css"] = inline_css
|
||||
if inline_head_js is not None:
|
||||
shell_kwargs["inline_head_js"] = inline_head_js
|
||||
if init_sx is not None:
|
||||
shell_kwargs["init_sx"] = init_sx
|
||||
if body_scripts is not None:
|
||||
shell_kwargs["body_scripts"] = body_scripts
|
||||
return await render_to_html("shared:shell/sx-page-shell", **shell_kwargs)
|
||||
kwargs = await _build_shell_kwargs(
|
||||
ctx, page_sx, meta_html=meta_html,
|
||||
head_scripts=head_scripts, inline_css=inline_css,
|
||||
inline_head_js=inline_head_js, init_sx=init_sx,
|
||||
body_scripts=body_scripts)
|
||||
kwargs["page_sx"] = page_sx
|
||||
return await render_to_html("shared:shell/sx-page-shell", **kwargs)
|
||||
|
||||
|
||||
_SX_STREAMING_RESOLVE = """\
|
||||
|
||||
@@ -28,15 +28,163 @@ import contextvars
|
||||
from typing import Any
|
||||
|
||||
from .types import Component, Island, Keyword, Lambda, Macro, NIL, Symbol
|
||||
from .ref.sx_ref import eval_expr as _raw_eval, call_component as _raw_call_component, expand_macro as _expand_macro, trampoline as _trampoline
|
||||
|
||||
|
||||
def _eval(expr, env):
|
||||
"""Evaluate and unwrap thunks — all html.py _eval calls are non-tail."""
|
||||
return _trampoline(_raw_eval(expr, env))
|
||||
"""Minimal Python evaluator for sync html.py rendering.
|
||||
|
||||
def _call_component(comp, raw_args, env):
|
||||
"""Call component and unwrap thunks — non-tail in html.py."""
|
||||
return _trampoline(_raw_call_component(comp, raw_args, env))
|
||||
Handles: literals, symbols, keywords, dicts, special forms (if, when,
|
||||
cond, let, begin/do, and, or, str, not, list), lambda calls, and
|
||||
primitive function calls. Enough for the sync sx() Jinja function.
|
||||
"""
|
||||
from .primitives import _PRIMITIVES
|
||||
|
||||
# Literals
|
||||
if isinstance(expr, (int, float, str, bool)):
|
||||
return expr
|
||||
if expr is None or expr is NIL:
|
||||
return NIL
|
||||
|
||||
# Symbol lookup
|
||||
if isinstance(expr, Symbol):
|
||||
name = expr.name
|
||||
if name in env:
|
||||
return env[name]
|
||||
if name in _PRIMITIVES:
|
||||
return _PRIMITIVES[name]
|
||||
if name == "true":
|
||||
return True
|
||||
if name == "false":
|
||||
return False
|
||||
if name == "nil":
|
||||
return NIL
|
||||
from .types import EvalError
|
||||
raise EvalError(f"Undefined symbol: {name}")
|
||||
|
||||
# Keyword
|
||||
if isinstance(expr, Keyword):
|
||||
return expr.name
|
||||
|
||||
# Dict
|
||||
if isinstance(expr, dict):
|
||||
return {k: _eval(v, env) for k, v in expr.items()}
|
||||
|
||||
# List — dispatch
|
||||
if not isinstance(expr, list):
|
||||
return expr
|
||||
if not expr:
|
||||
return []
|
||||
|
||||
head = expr[0]
|
||||
if isinstance(head, Symbol):
|
||||
name = head.name
|
||||
|
||||
# Special forms
|
||||
if name == "if":
|
||||
cond = _eval(expr[1], env)
|
||||
if cond and cond is not NIL:
|
||||
return _eval(expr[2], env)
|
||||
return _eval(expr[3], env) if len(expr) > 3 else NIL
|
||||
|
||||
if name == "when":
|
||||
cond = _eval(expr[1], env)
|
||||
if cond and cond is not NIL:
|
||||
result = NIL
|
||||
for body in expr[2:]:
|
||||
result = _eval(body, env)
|
||||
return result
|
||||
return NIL
|
||||
|
||||
if name == "let":
|
||||
bindings = expr[1]
|
||||
local = dict(env)
|
||||
if isinstance(bindings, list):
|
||||
if bindings and isinstance(bindings[0], list):
|
||||
for b in bindings:
|
||||
vname = b[0].name if isinstance(b[0], Symbol) else b[0]
|
||||
local[vname] = _eval(b[1], local)
|
||||
elif len(bindings) % 2 == 0:
|
||||
for i in range(0, len(bindings), 2):
|
||||
vname = bindings[i].name if isinstance(bindings[i], Symbol) else bindings[i]
|
||||
local[vname] = _eval(bindings[i + 1], local)
|
||||
result = NIL
|
||||
for body in expr[2:]:
|
||||
result = _eval(body, local)
|
||||
return result
|
||||
|
||||
if name in ("begin", "do"):
|
||||
result = NIL
|
||||
for body in expr[1:]:
|
||||
result = _eval(body, env)
|
||||
return result
|
||||
|
||||
if name == "and":
|
||||
result = True
|
||||
for arg in expr[1:]:
|
||||
result = _eval(arg, env)
|
||||
if not result or result is NIL:
|
||||
return result
|
||||
return result
|
||||
|
||||
if name == "or":
|
||||
for arg in expr[1:]:
|
||||
result = _eval(arg, env)
|
||||
if result and result is not NIL:
|
||||
return result
|
||||
return NIL
|
||||
|
||||
if name == "not":
|
||||
val = _eval(expr[1], env)
|
||||
return val is NIL or val is False or val is None
|
||||
|
||||
if name == "lambda" or name == "fn":
|
||||
params_form = expr[1]
|
||||
param_names = [p.name if isinstance(p, Symbol) else str(p) for p in params_form]
|
||||
return Lambda(params=param_names, body=expr[2], closure=dict(env))
|
||||
|
||||
if name == "define":
|
||||
var_name = expr[1].name if isinstance(expr[1], Symbol) else str(expr[1])
|
||||
env[var_name] = _eval(expr[2], env)
|
||||
return NIL
|
||||
|
||||
if name == "quote":
|
||||
return expr[1]
|
||||
|
||||
if name == "str":
|
||||
parts = []
|
||||
for arg in expr[1:]:
|
||||
val = _eval(arg, env)
|
||||
if val is NIL or val is None:
|
||||
parts.append("")
|
||||
else:
|
||||
parts.append(str(val))
|
||||
return "".join(parts)
|
||||
|
||||
if name == "list":
|
||||
return [_eval(arg, env) for arg in expr[1:]]
|
||||
|
||||
# Primitive or function call
|
||||
fn = _eval(head, env)
|
||||
else:
|
||||
fn = _eval(head, env)
|
||||
|
||||
# Evaluate args
|
||||
args = [_eval(a, env) for a in expr[1:]]
|
||||
|
||||
# Call
|
||||
if callable(fn):
|
||||
return fn(*args)
|
||||
if isinstance(fn, Lambda):
|
||||
local = dict(fn.closure)
|
||||
local.update(env)
|
||||
for p, v in zip(fn.params, args):
|
||||
local[p] = v
|
||||
return _eval(fn.body, local)
|
||||
return NIL
|
||||
|
||||
|
||||
def _expand_macro(*a, **kw):
|
||||
raise RuntimeError("Macro expansion requires OCaml bridge")
|
||||
|
||||
# ContextVar for collecting CSS class names during render.
|
||||
# Set to a set[str] to collect; None to skip.
|
||||
|
||||
@@ -30,17 +30,7 @@ from typing import Any
|
||||
|
||||
from .types import NIL, Component, Island, Keyword, Lambda, Macro, Symbol
|
||||
from .parser import parse
|
||||
import os as _os
|
||||
if _os.environ.get("SX_USE_OCAML") == "1":
|
||||
# OCaml kernel bridge — render via persistent subprocess.
|
||||
# html_render and _render_component are set up lazily since the bridge
|
||||
# requires an async event loop. The sync sx() function falls back to
|
||||
# the ref renderer; async callers use ocaml_bridge directly.
|
||||
from .ref.sx_ref import render as html_render, render_html_component as _render_component
|
||||
elif _os.environ.get("SX_USE_REF") == "1":
|
||||
from .ref.sx_ref import render as html_render, render_html_component as _render_component
|
||||
else:
|
||||
from .html import render as html_render, _render_component
|
||||
from .html import render as html_render, _render_component
|
||||
|
||||
_logger = logging.getLogger("sx.bridge")
|
||||
|
||||
@@ -341,6 +331,9 @@ def reload_if_changed() -> None:
|
||||
_COMPONENT_ENV.clear()
|
||||
_CLIENT_LIBRARY_SOURCES.clear()
|
||||
_dirs_from_cache.clear()
|
||||
invalidate_component_hash()
|
||||
from .helpers import invalidate_shell_cache
|
||||
invalidate_shell_cache()
|
||||
# Reload SX libraries first (e.g. z3.sx) so reader macros resolve
|
||||
for cb in _reload_callbacks:
|
||||
cb()
|
||||
@@ -359,6 +352,8 @@ def reload_if_changed() -> None:
|
||||
from .ocaml_bridge import _bridge
|
||||
if _bridge is not None:
|
||||
_bridge._components_loaded = False
|
||||
_bridge._shell_statics_injected = False
|
||||
_bridge._helpers_injected = False
|
||||
|
||||
# Recompute render plans for all services that have pages
|
||||
from .pages import _PAGE_REGISTRY, compute_page_render_plans
|
||||
@@ -401,6 +396,40 @@ def load_handler_dir(directory: str, service_name: str) -> None:
|
||||
_load(directory, service_name)
|
||||
|
||||
|
||||
def _parse_defcomp_params(param_form: list) -> tuple[list[str], bool]:
|
||||
"""Extract keyword param names and has_children from a defcomp param list.
|
||||
|
||||
Handles: (&key p1 p2 &rest children), (&key (p1 :as type) &rest children),
|
||||
(p1 p2), () etc.
|
||||
|
||||
Returns (param_names, has_children).
|
||||
"""
|
||||
if not isinstance(param_form, list):
|
||||
return [], False
|
||||
|
||||
params: list[str] = []
|
||||
has_children = False
|
||||
in_key = False
|
||||
i = 0
|
||||
while i < len(param_form):
|
||||
item = param_form[i]
|
||||
if isinstance(item, Symbol):
|
||||
sname = item.name
|
||||
if sname == "&key":
|
||||
in_key = True
|
||||
elif sname == "&rest":
|
||||
has_children = True
|
||||
i += 1 # skip the rest-param name (e.g. 'children')
|
||||
else:
|
||||
params.append(sname)
|
||||
elif isinstance(item, list):
|
||||
# Typed param: (name :as type)
|
||||
if item and isinstance(item[0], Symbol):
|
||||
params.append(item[0].name)
|
||||
i += 1
|
||||
return params, has_children
|
||||
|
||||
|
||||
def register_components(sx_source: str, *, _defer_postprocess: bool = False) -> None:
|
||||
"""Parse and evaluate s-expression component definitions into the
|
||||
shared environment.
|
||||
@@ -408,17 +437,30 @@ def register_components(sx_source: str, *, _defer_postprocess: bool = False) ->
|
||||
When *_defer_postprocess* is True, skip deps/io_refs/hash computation.
|
||||
Call ``finalize_components()`` once after all files are loaded.
|
||||
"""
|
||||
from .ref.sx_ref import eval_expr as _raw_eval, trampoline as _trampoline
|
||||
_eval = lambda expr, env: _trampoline(_raw_eval(expr, env))
|
||||
from .parser import parse_all
|
||||
from .css_registry import scan_classes_from_sx
|
||||
|
||||
# Snapshot existing component names before eval
|
||||
existing = set(_COMPONENT_ENV.keys())
|
||||
|
||||
# Evaluate definitions — OCaml kernel handles everything.
|
||||
# Python-side component registry is populated with parsed params for CSS/deps.
|
||||
exprs = parse_all(sx_source)
|
||||
for expr in exprs:
|
||||
_eval(expr, _COMPONENT_ENV)
|
||||
if (isinstance(expr, list) and expr and isinstance(expr[0], Symbol)
|
||||
and expr[0].name in ("defcomp", "defisland", "defmacro",
|
||||
"define", "defstyle", "deftype",
|
||||
"defeffect", "defrelation", "defhandler")):
|
||||
name_sym = expr[1] if len(expr) > 1 else None
|
||||
name = name_sym.name if hasattr(name_sym, 'name') else str(name_sym) if name_sym else None
|
||||
if name and expr[0].name in ("defcomp", "defisland"):
|
||||
params, has_children = _parse_defcomp_params(expr[2] if len(expr) > 3 else [])
|
||||
cls = Island if expr[0].name == "defisland" else Component
|
||||
_COMPONENT_ENV[name] = cls(
|
||||
name=name.lstrip("~"),
|
||||
params=params, has_children=has_children,
|
||||
body=expr[-1], closure={},
|
||||
)
|
||||
|
||||
# Pre-scan CSS classes for newly registered components.
|
||||
all_classes: set[str] | None = None
|
||||
@@ -587,25 +629,23 @@ def client_components_tag(*names: str) -> str:
|
||||
|
||||
|
||||
def components_for_page(page_sx: str, service: str | None = None) -> tuple[str, str]:
|
||||
"""Return (component_defs_source, page_hash) for a page.
|
||||
"""Return (component_defs_source, stable_hash) for a page.
|
||||
|
||||
Scans *page_sx* for component references, computes the transitive
|
||||
closure, and returns only the definitions needed for this page.
|
||||
Sends per-page component subsets for bandwidth, but the hash is
|
||||
computed from the FULL component env — stable across all pages.
|
||||
Browser caches once on first page load, subsequent navigations
|
||||
hit the cache (same hash) without re-downloading.
|
||||
|
||||
When *service* is given, also includes deps for all :data pages
|
||||
in that service so the client can render them without a server
|
||||
roundtrip on navigation.
|
||||
|
||||
The hash is computed from the page-specific bundle for caching.
|
||||
Components go to the client for: hydration, client-side routing,
|
||||
data binding, and future CID-based caching.
|
||||
"""
|
||||
from .deps import components_needed
|
||||
from .parser import serialize
|
||||
|
||||
needed = components_needed(page_sx, _COMPONENT_ENV)
|
||||
|
||||
# Include deps for all :data pages so the client can render them.
|
||||
# Pages with IO deps use the async render path (Phase 5) — the IO
|
||||
# primitives are proxied via /sx/io/<name>.
|
||||
# Include deps for all :data pages so the client can render them
|
||||
# during client-side navigation.
|
||||
if service:
|
||||
from .pages import get_all_pages
|
||||
for page_def in get_all_pages(service).values():
|
||||
@@ -616,7 +656,6 @@ def components_for_page(page_sx: str, service: str | None = None) -> tuple[str,
|
||||
if not needed:
|
||||
return "", ""
|
||||
|
||||
# Also include macros — they're needed for client-side expansion
|
||||
parts = []
|
||||
for key, val in _COMPONENT_ENV.items():
|
||||
if isinstance(val, Island):
|
||||
@@ -629,10 +668,6 @@ def components_for_page(page_sx: str, service: str | None = None) -> tuple[str,
|
||||
parts.append(f"(defisland ~{val.name} {params_sx} {body_sx})")
|
||||
elif isinstance(val, Component):
|
||||
if f"~{val.name}" in needed or key in needed:
|
||||
# Skip server-affinity components — they're expanded server-side
|
||||
# and the client doesn't have the define values they depend on.
|
||||
if val.render_target == "server":
|
||||
continue
|
||||
param_strs = ["&key"] + list(val.params)
|
||||
if val.has_children:
|
||||
param_strs.extend(["&rest", "children"])
|
||||
@@ -640,8 +675,7 @@ def components_for_page(page_sx: str, service: str | None = None) -> tuple[str,
|
||||
body_sx = serialize(val.body, pretty=True)
|
||||
parts.append(f"(defcomp ~{val.name} {params_sx} {body_sx})")
|
||||
elif isinstance(val, Macro):
|
||||
# Include macros that are referenced in needed components' bodies
|
||||
# For now, include all macros (they're small and often shared)
|
||||
# Include all macros — small and often shared across pages
|
||||
param_strs = list(val.params)
|
||||
if val.rest_param:
|
||||
param_strs.extend(["&rest", val.rest_param])
|
||||
@@ -655,10 +689,39 @@ def components_for_page(page_sx: str, service: str | None = None) -> tuple[str,
|
||||
# Prepend client library sources (define forms) before component defs
|
||||
all_parts = list(_CLIENT_LIBRARY_SOURCES) + parts
|
||||
source = "\n".join(all_parts)
|
||||
digest = hashlib.sha256(source.encode()).hexdigest()[:12]
|
||||
|
||||
# Hash from FULL component env — stable across all pages.
|
||||
# Browser caches by this hash; same hash = cache hit on navigation.
|
||||
digest = _component_env_hash()
|
||||
return source, digest
|
||||
|
||||
|
||||
# Cached full-env hash — invalidated when components are reloaded.
|
||||
_env_hash_cache: str | None = None
|
||||
|
||||
|
||||
def _component_env_hash() -> str:
|
||||
"""Compute a stable hash from all loaded component names + bodies."""
|
||||
global _env_hash_cache
|
||||
if _env_hash_cache is not None:
|
||||
return _env_hash_cache
|
||||
from .parser import serialize
|
||||
h = hashlib.sha256()
|
||||
for key in sorted(_COMPONENT_ENV.keys()):
|
||||
val = _COMPONENT_ENV[key]
|
||||
if isinstance(val, (Island, Component, Macro)):
|
||||
h.update(key.encode())
|
||||
h.update(serialize(val.body).encode())
|
||||
_env_hash_cache = h.hexdigest()[:12]
|
||||
return _env_hash_cache
|
||||
|
||||
|
||||
def invalidate_component_hash():
|
||||
"""Call when components are reloaded (hot-reload, file change)."""
|
||||
global _env_hash_cache
|
||||
_env_hash_cache = None
|
||||
|
||||
|
||||
def css_classes_for_page(page_sx: str, service: str | None = None) -> set[str]:
|
||||
"""Return CSS classes needed for a page's component bundle + page source.
|
||||
|
||||
|
||||
@@ -41,8 +41,12 @@ class OcamlBridge:
|
||||
self._binary = binary or os.environ.get("SX_OCAML_BIN") or _DEFAULT_BIN
|
||||
self._proc: asyncio.subprocess.Process | None = None
|
||||
self._lock = asyncio.Lock()
|
||||
self._in_io_handler = False # re-entrancy guard
|
||||
self._started = False
|
||||
self._components_loaded = False
|
||||
self._helpers_injected = False
|
||||
self._io_cache: dict[tuple, Any] = {} # (name, args...) → cached result
|
||||
self._epoch: int = 0 # request epoch — monotonically increasing
|
||||
|
||||
async def start(self) -> None:
|
||||
"""Launch the OCaml subprocess and wait for (ready)."""
|
||||
@@ -57,11 +61,13 @@ class OcamlBridge:
|
||||
)
|
||||
|
||||
_logger.info("Starting OCaml SX kernel: %s", bin_path)
|
||||
import sys
|
||||
self._proc = await asyncio.create_subprocess_exec(
|
||||
bin_path,
|
||||
stdin=asyncio.subprocess.PIPE,
|
||||
stdout=asyncio.subprocess.PIPE,
|
||||
stderr=asyncio.subprocess.PIPE,
|
||||
stderr=sys.stderr, # kernel timing/debug to container logs
|
||||
limit=10 * 1024 * 1024, # 10MB readline buffer for large spec data
|
||||
)
|
||||
|
||||
# Wait for (ready)
|
||||
@@ -72,7 +78,7 @@ class OcamlBridge:
|
||||
self._started = True
|
||||
|
||||
# Verify engine identity
|
||||
self._send("(ping)")
|
||||
await self._send_command("(ping)")
|
||||
kind, engine = await self._read_response()
|
||||
engine_name = engine if kind == "ok" else "unknown"
|
||||
_logger.info("OCaml SX kernel ready (pid=%d, engine=%s)", self._proc.pid, engine_name)
|
||||
@@ -90,39 +96,50 @@ class OcamlBridge:
|
||||
self._proc = None
|
||||
self._started = False
|
||||
|
||||
async def _restart(self) -> None:
|
||||
"""Kill and restart the OCaml subprocess to recover from pipe desync."""
|
||||
_logger.warning("Restarting OCaml SX kernel (pipe recovery)")
|
||||
if self._proc and self._proc.returncode is None:
|
||||
self._proc.kill()
|
||||
await self._proc.wait()
|
||||
self._proc = None
|
||||
self._started = False
|
||||
self._components_loaded = False
|
||||
self._helpers_injected = False
|
||||
await self.start()
|
||||
|
||||
async def ping(self) -> str:
|
||||
"""Health check — returns engine name (e.g. 'ocaml-cek')."""
|
||||
async with self._lock:
|
||||
self._send("(ping)")
|
||||
await self._send_command("(ping)")
|
||||
kind, value = await self._read_response()
|
||||
return value or "" if kind == "ok" else ""
|
||||
|
||||
async def load(self, path: str) -> int:
|
||||
"""Load an .sx file for side effects (defcomp, define, defmacro)."""
|
||||
async with self._lock:
|
||||
self._send(f'(load "{_escape(path)}")')
|
||||
kind, value = await self._read_response()
|
||||
if kind == "error":
|
||||
raise OcamlBridgeError(f"load {path}: {value}")
|
||||
await self._send_command(f'(load "{_escape(path)}")')
|
||||
value = await self._read_until_ok(ctx=None)
|
||||
return int(float(value)) if value else 0
|
||||
|
||||
async def load_source(self, source: str) -> int:
|
||||
"""Evaluate SX source for side effects."""
|
||||
async with self._lock:
|
||||
self._send(f'(load-source "{_escape(source)}")')
|
||||
kind, value = await self._read_response()
|
||||
if kind == "error":
|
||||
raise OcamlBridgeError(f"load-source: {value}")
|
||||
await self._send_command(f'(load-source "{_escape(source)}")')
|
||||
value = await self._read_until_ok(ctx=None)
|
||||
return int(float(value)) if value else 0
|
||||
|
||||
async def eval(self, source: str) -> str:
|
||||
"""Evaluate SX expression, return serialized result."""
|
||||
async def eval(self, source: str, ctx: dict[str, Any] | None = None) -> str:
|
||||
"""Evaluate SX expression, return serialized result.
|
||||
|
||||
Supports io-requests (helper calls, query, action, etc.) via the
|
||||
coroutine bridge, just like render().
|
||||
"""
|
||||
await self._ensure_components()
|
||||
async with self._lock:
|
||||
self._send(f'(eval "{_escape(source)}")')
|
||||
kind, value = await self._read_response()
|
||||
if kind == "error":
|
||||
raise OcamlBridgeError(f"eval: {value}")
|
||||
return value or ""
|
||||
await self._send_command('(eval-blob)')
|
||||
await self._send_blob(source)
|
||||
return await self._read_until_ok(ctx)
|
||||
|
||||
async def render(
|
||||
self,
|
||||
@@ -132,49 +149,332 @@ class OcamlBridge:
|
||||
"""Render SX to HTML, handling io-requests via Python async IO."""
|
||||
await self._ensure_components()
|
||||
async with self._lock:
|
||||
self._send(f'(render "{_escape(source)}")')
|
||||
await self._send_command(f'(render "{_escape(source)}")')
|
||||
return await self._read_until_ok(ctx)
|
||||
|
||||
async def aser(self, source: str, ctx: dict[str, Any] | None = None) -> str:
|
||||
"""Evaluate SX and return SX wire format, handling io-requests."""
|
||||
await self._ensure_components()
|
||||
async with self._lock:
|
||||
await self._send_command('(aser-blob)')
|
||||
await self._send_blob(source)
|
||||
return await self._read_until_ok(ctx)
|
||||
|
||||
async def aser_slot(self, source: str, ctx: dict[str, Any] | None = None) -> str:
|
||||
"""Like aser() but expands ALL components server-side.
|
||||
|
||||
Equivalent to Python's async_eval_slot_to_sx — used for layout
|
||||
slots where component bodies need server-side IO evaluation.
|
||||
"""
|
||||
await self._ensure_components()
|
||||
async with self._lock:
|
||||
# Inject helpers inside the lock to avoid pipe desync —
|
||||
# a separate lock acquisition could let another coroutine
|
||||
# interleave commands between injection and aser-slot.
|
||||
await self._inject_helpers_locked()
|
||||
await self._send_command('(aser-slot-blob)')
|
||||
await self._send_blob(source)
|
||||
return await self._read_until_ok(ctx)
|
||||
|
||||
_shell_statics_injected: bool = False
|
||||
|
||||
async def _inject_shell_statics_locked(self) -> None:
|
||||
"""Inject cached shell static data into kernel. MUST hold lock."""
|
||||
if self._shell_statics_injected:
|
||||
return
|
||||
from .helpers import _get_shell_static
|
||||
try:
|
||||
static = _get_shell_static()
|
||||
except Exception:
|
||||
return # not ready yet (no app context)
|
||||
# Only inject small, safe values as kernel variables.
|
||||
# Large/complex blobs use placeholder tokens at render time.
|
||||
for key in ("component_hash", "sx_css_classes", "asset_url",
|
||||
"sx_js_hash", "body_js_hash"):
|
||||
val = static.get(key) or ""
|
||||
var = f"__shell-{key.replace('_', '-')}"
|
||||
defn = f'(define {var} "{_escape(str(val))}")'
|
||||
try:
|
||||
await self._send_command(f'(load-source "{_escape(defn)}")')
|
||||
await self._read_until_ok(ctx=None)
|
||||
except OcamlBridgeError as e:
|
||||
_logger.warning("Shell static inject failed for %s: %s", key, e)
|
||||
# List/nil values
|
||||
for key in ("head_scripts", "body_scripts"):
|
||||
val = static.get(key)
|
||||
var = f"__shell-{key.replace('_', '-')}"
|
||||
if val is None:
|
||||
defn = f'(define {var} nil)'
|
||||
elif isinstance(val, list):
|
||||
items = " ".join(f'"{_escape(str(v))}"' for v in val)
|
||||
defn = f'(define {var} (list {items}))'
|
||||
else:
|
||||
defn = f'(define {var} "{_escape(str(val))}")'
|
||||
try:
|
||||
await self._send_command(f'(load-source "{_escape(defn)}")')
|
||||
await self._read_until_ok(ctx=None)
|
||||
except OcamlBridgeError as e:
|
||||
_logger.warning("Shell static inject failed for %s: %s", key, e)
|
||||
self._shell_statics_injected = True
|
||||
_logger.info("Injected shell statics into OCaml kernel")
|
||||
|
||||
async def _inject_request_cookies_locked(self) -> None:
|
||||
"""Send current request cookies to kernel for get-cookie primitive."""
|
||||
try:
|
||||
from quart import request
|
||||
cookies = request.cookies
|
||||
except Exception:
|
||||
return # no request context (CLI mode, tests)
|
||||
if not cookies:
|
||||
return
|
||||
# Build SX dict: {:name1 "val1" :name2 "val2"}
|
||||
# Cookie values may be URL-encoded (client set-cookie uses
|
||||
# encodeURIComponent) — decode before sending to kernel.
|
||||
from urllib.parse import unquote
|
||||
pairs = []
|
||||
for k, v in cookies.items():
|
||||
pairs.append(f':{k} "{_escape(unquote(str(v)))}"')
|
||||
if pairs:
|
||||
cmd = f'(set-request-cookies {{{" ".join(pairs)}}})'
|
||||
try:
|
||||
await self._send_command(cmd)
|
||||
await self._read_until_ok(ctx=None)
|
||||
except OcamlBridgeError as e:
|
||||
_logger.debug("Cookie inject failed: %s", e)
|
||||
|
||||
async def sx_page_full(
|
||||
self,
|
||||
page_source: str,
|
||||
shell_kwargs: dict[str, Any],
|
||||
ctx: dict[str, Any] | None = None,
|
||||
) -> str:
|
||||
"""Render full page HTML in one OCaml call: aser-slot + shell render.
|
||||
|
||||
Static data (component_defs, CSS, pages_sx) is pre-injected as
|
||||
kernel vars on first call. Per-request command sends only small
|
||||
values (title, csrf) + references to the kernel vars.
|
||||
"""
|
||||
await self._ensure_components()
|
||||
async with self._lock:
|
||||
await self._inject_helpers_locked()
|
||||
await self._inject_shell_statics_locked()
|
||||
# Send request cookies so get-cookie works during SSR
|
||||
await self._inject_request_cookies_locked()
|
||||
# Large/complex blobs use placeholders — OCaml renders the shell
|
||||
# with short tokens; Python splices in the real values post-render.
|
||||
# This avoids piping large strings or strings with special chars
|
||||
# through the SX parser.
|
||||
PLACEHOLDER_KEYS = {"component_defs", "pages_sx", "init_sx",
|
||||
"sx_css", "inline_css", "inline_head_js"}
|
||||
placeholders = {}
|
||||
static_keys = {"component_hash", "sx_css_classes", "asset_url",
|
||||
"sx_js_hash", "body_js_hash",
|
||||
"head_scripts", "body_scripts"}
|
||||
# page_source is SX wire format that may contain \" escapes.
|
||||
# Send via binary blob protocol to avoid double-escaping
|
||||
# through the SX string parser round-trip.
|
||||
parts = ['(sx-page-full-blob']
|
||||
for key, val in shell_kwargs.items():
|
||||
k = key.replace("_", "-")
|
||||
if key in PLACEHOLDER_KEYS:
|
||||
token = f"__SLOT_{key.upper()}__"
|
||||
placeholders[token] = str(val) if val else ""
|
||||
parts.append(f' :{k} "{token}"')
|
||||
elif key in static_keys:
|
||||
parts.append(f' :{k} __shell-{k}')
|
||||
elif val is None:
|
||||
parts.append(f' :{k} nil')
|
||||
elif isinstance(val, bool):
|
||||
parts.append(f' :{k} {"true" if val else "false"}')
|
||||
elif isinstance(val, list):
|
||||
items = " ".join(f'"{_escape(str(v))}"' for v in val)
|
||||
parts.append(f' :{k} ({items})')
|
||||
else:
|
||||
parts.append(f' :{k} "{_escape(str(val))}"')
|
||||
parts.append(")")
|
||||
cmd = "".join(parts)
|
||||
await self._send_command(cmd)
|
||||
# Send page source as binary blob (avoids string-escape issues)
|
||||
await self._send_blob(page_source)
|
||||
html = await self._read_until_ok(ctx)
|
||||
# Splice in large blobs
|
||||
for token, blob in placeholders.items():
|
||||
html = html.replace(token, blob)
|
||||
return html
|
||||
|
||||
async def _inject_helpers_locked(self) -> None:
|
||||
"""Inject page helpers into the kernel. MUST be called with lock held."""
|
||||
if self._helpers_injected:
|
||||
return
|
||||
self._helpers_injected = True
|
||||
try:
|
||||
from .pages import get_page_helpers
|
||||
import inspect
|
||||
helpers = get_page_helpers("sx")
|
||||
if not helpers:
|
||||
self._helpers_injected = False
|
||||
return
|
||||
count = 0
|
||||
for name, fn in helpers.items():
|
||||
if callable(fn) and not name.startswith("~"):
|
||||
try:
|
||||
sig = inspect.signature(fn)
|
||||
nargs = sum(1 for p in sig.parameters.values()
|
||||
if p.kind in (p.POSITIONAL_ONLY, p.POSITIONAL_OR_KEYWORD))
|
||||
except (ValueError, TypeError):
|
||||
nargs = 2
|
||||
nargs = max(nargs, 1)
|
||||
param_names = " ".join(chr(97 + i) for i in range(nargs))
|
||||
arg_list = " ".join(chr(97 + i) for i in range(nargs))
|
||||
sx_def = f'(define {name} (fn ({param_names}) (helper "{name}" {arg_list})))'
|
||||
try:
|
||||
await self._send_command(f'(load-source "{_escape(sx_def)}")')
|
||||
await self._read_until_ok(ctx=None)
|
||||
count += 1
|
||||
except OcamlBridgeError:
|
||||
pass
|
||||
_logger.info("Injected %d page helpers into OCaml kernel", count)
|
||||
except Exception as e:
|
||||
_logger.warning("Helper injection failed: %s", e)
|
||||
self._helpers_injected = False
|
||||
|
||||
async def _compile_adapter_module(self) -> None:
|
||||
"""Compile adapter-sx.sx to bytecode and load as a VM module.
|
||||
|
||||
Previously used Python's sx_ref.py evaluator for compilation.
|
||||
Now the OCaml kernel handles JIT compilation natively — this method
|
||||
is a no-op. The kernel's own JIT hook compiles functions on first call.
|
||||
"""
|
||||
_logger.info("Adapter module compilation delegated to OCaml kernel JIT")
|
||||
|
||||
async def _ensure_components(self) -> None:
|
||||
"""Load component definitions into the kernel on first use."""
|
||||
"""Load all .sx source files into the kernel on first use.
|
||||
|
||||
Errors during loading are handled gracefully — IO responses are
|
||||
always sent back to keep the pipe clean.
|
||||
"""
|
||||
if self._components_loaded:
|
||||
return
|
||||
self._components_loaded = True
|
||||
try:
|
||||
from .jinja_bridge import get_component_env, _CLIENT_LIBRARY_SOURCES
|
||||
from .parser import serialize
|
||||
from .types import Component, Island, Macro
|
||||
from .jinja_bridge import _watched_dirs, _dirs_from_cache
|
||||
import glob
|
||||
|
||||
env = get_component_env()
|
||||
parts: list[str] = list(_CLIENT_LIBRARY_SOURCES)
|
||||
for key, val in env.items():
|
||||
if isinstance(val, Island):
|
||||
ps = ["&key"] + list(val.params)
|
||||
if val.has_children:
|
||||
ps.extend(["&rest", "children"])
|
||||
parts.append(f"(defisland ~{val.name} ({' '.join(ps)}) {serialize(val.body)})")
|
||||
elif isinstance(val, Component):
|
||||
ps = ["&key"] + list(val.params)
|
||||
if val.has_children:
|
||||
ps.extend(["&rest", "children"])
|
||||
parts.append(f"(defcomp ~{val.name} ({' '.join(ps)}) {serialize(val.body)})")
|
||||
elif isinstance(val, Macro):
|
||||
ps = list(val.params)
|
||||
if val.rest_param:
|
||||
ps.extend(["&rest", val.rest_param])
|
||||
parts.append(f"(defmacro {val.name} ({' '.join(ps)}) {serialize(val.body)})")
|
||||
if parts:
|
||||
source = "\n".join(parts)
|
||||
await self.load_source(source)
|
||||
_logger.info("Loaded %d definitions into OCaml kernel", len(parts))
|
||||
# Skip patterns — files that use constructs not available in the kernel
|
||||
skip_names = {"boundary.sx", "forms.sx"}
|
||||
skip_dirs = {"tests"}
|
||||
|
||||
# Collect files to load
|
||||
all_files: list[str] = []
|
||||
|
||||
# Core spec files
|
||||
spec_dir = os.path.join(os.path.dirname(__file__), "../../spec")
|
||||
for spec_file in ["parser.sx", "render.sx"]:
|
||||
path = os.path.normpath(os.path.join(spec_dir, spec_file))
|
||||
if os.path.isfile(path):
|
||||
all_files.append(path)
|
||||
|
||||
# Library files (compiler, vm, freeze — written in the language)
|
||||
lib_dir = os.path.join(os.path.dirname(__file__), "../../lib")
|
||||
for lib_file in ["bytecode.sx", "compiler.sx"]:
|
||||
path = os.path.normpath(os.path.join(lib_dir, lib_file))
|
||||
if os.path.isfile(path):
|
||||
all_files.append(path)
|
||||
|
||||
# All directories loaded into the Python env
|
||||
all_dirs = list(set(_watched_dirs) | _dirs_from_cache)
|
||||
|
||||
# Isomorphic libraries: signals, rendering, web forms
|
||||
web_dir = os.path.join(os.path.dirname(__file__), "../../web")
|
||||
if os.path.isdir(web_dir):
|
||||
for web_file in ["signals.sx", "adapter-html.sx", "adapter-sx.sx",
|
||||
"web-forms.sx"]:
|
||||
path = os.path.normpath(os.path.join(web_dir, web_file))
|
||||
if os.path.isfile(path):
|
||||
all_files.append(path)
|
||||
# Library files loaded after adapters (depend on scope primitives)
|
||||
for lib_file in ["freeze.sx"]:
|
||||
path = os.path.normpath(os.path.join(lib_dir, lib_file))
|
||||
if os.path.isfile(path):
|
||||
all_files.append(path)
|
||||
|
||||
for directory in sorted(all_dirs):
|
||||
files = sorted(
|
||||
glob.glob(os.path.join(directory, "**", "*.sx"), recursive=True)
|
||||
)
|
||||
for filepath in files:
|
||||
basename = os.path.basename(filepath)
|
||||
# Skip known-bad files
|
||||
if basename in skip_names:
|
||||
continue
|
||||
# Skip test and handler directories
|
||||
parts = filepath.replace("\\", "/").split("/")
|
||||
if any(d in skip_dirs for d in parts):
|
||||
continue
|
||||
all_files.append(filepath)
|
||||
|
||||
# Load all files under a single lock
|
||||
count = 0
|
||||
skipped = 0
|
||||
async with self._lock:
|
||||
for filepath in all_files:
|
||||
try:
|
||||
await self._send_command(f'(load "{_escape(filepath)}")')
|
||||
value = await self._read_until_ok(ctx=None)
|
||||
# Response may be a number (count) or a value — just count files
|
||||
count += 1
|
||||
except OcamlBridgeError as e:
|
||||
skipped += 1
|
||||
_logger.warning("OCaml load skipped %s: %s",
|
||||
filepath, e)
|
||||
|
||||
# SSR overrides: effect is a no-op on the server (prevents
|
||||
# reactive loops during island SSR — effects are DOM side-effects)
|
||||
try:
|
||||
noop_dispose = '(fn () nil)'
|
||||
await self._send_command(f'(load-source "(define effect (fn (f) {noop_dispose}))")')
|
||||
await self._read_until_ok(ctx=None)
|
||||
except OcamlBridgeError:
|
||||
pass
|
||||
|
||||
# Register JIT hook — lambdas compile on first call
|
||||
try:
|
||||
await self._send_command('(vm-compile-adapter)')
|
||||
await self._read_until_ok(ctx=None)
|
||||
_logger.info("JIT hook registered — lambdas compile on first call")
|
||||
except OcamlBridgeError as e:
|
||||
_logger.warning("JIT hook registration skipped: %s", e)
|
||||
_logger.info("Loaded %d definitions from .sx files into OCaml kernel (%d skipped)",
|
||||
count, skipped)
|
||||
except Exception as e:
|
||||
_logger.error("Failed to load components into OCaml kernel: %s", e)
|
||||
_logger.error("Failed to load .sx files into OCaml kernel: %s", e)
|
||||
self._components_loaded = False # retry next time
|
||||
|
||||
async def inject_page_helpers(self, helpers: dict) -> None:
|
||||
"""Register page helpers as IO-routing definitions in the kernel.
|
||||
|
||||
Each helper becomes a function that yields (io-request "helper" name ...),
|
||||
routing the call back to Python via the coroutine bridge.
|
||||
"""
|
||||
await self._ensure_components()
|
||||
async with self._lock:
|
||||
count = 0
|
||||
for name, fn in helpers.items():
|
||||
if callable(fn) and not name.startswith("~"):
|
||||
sx_def = f'(define {name} (fn (&rest args) (apply helper (concat (list "{name}") args))))'
|
||||
try:
|
||||
await self._send_command(f'(load-source "{_escape(sx_def)}")')
|
||||
await self._read_until_ok(ctx=None)
|
||||
count += 1
|
||||
except OcamlBridgeError:
|
||||
pass # non-fatal
|
||||
if count:
|
||||
_logger.info("Injected %d page helpers into OCaml kernel", count)
|
||||
|
||||
async def reset(self) -> None:
|
||||
"""Reset the kernel environment to pristine state."""
|
||||
async with self._lock:
|
||||
self._send("(reset)")
|
||||
await self._send_command("(reset)")
|
||||
kind, value = await self._read_response()
|
||||
if kind == "error":
|
||||
raise OcamlBridgeError(f"reset: {value}")
|
||||
@@ -183,32 +483,102 @@ class OcamlBridge:
|
||||
# Internal protocol handling
|
||||
# ------------------------------------------------------------------
|
||||
|
||||
def _send(self, line: str) -> None:
|
||||
"""Write a line to the subprocess stdin."""
|
||||
async def _send(self, line: str) -> None:
|
||||
"""Write a line to the subprocess stdin and flush."""
|
||||
if self._in_io_handler:
|
||||
raise OcamlBridgeError(
|
||||
f"Re-entrant bridge call from IO handler: {line[:80]}. "
|
||||
f"IO handlers must not call the bridge — use Python-only code."
|
||||
)
|
||||
assert self._proc and self._proc.stdin
|
||||
_logger.debug("SEND: %s", line[:120])
|
||||
self._proc.stdin.write((line + "\n").encode())
|
||||
await self._proc.stdin.drain()
|
||||
|
||||
async def _send_command(self, line: str) -> None:
|
||||
"""Send a command with a fresh epoch prefix.
|
||||
|
||||
Increments the epoch counter and sends (epoch N) before the
|
||||
actual command. The OCaml kernel tags all responses with this
|
||||
epoch so stale messages from previous requests are discarded.
|
||||
"""
|
||||
self._epoch += 1
|
||||
assert self._proc and self._proc.stdin
|
||||
_logger.debug("EPOCH %d SEND: %s", self._epoch, line[:120])
|
||||
self._proc.stdin.write(f"(epoch {self._epoch})\n".encode())
|
||||
self._proc.stdin.write((line + "\n").encode())
|
||||
await self._proc.stdin.drain()
|
||||
|
||||
async def _send_blob(self, data: str) -> None:
|
||||
"""Send a length-prefixed binary blob to the subprocess.
|
||||
|
||||
Protocol: sends "(blob N)\\n" followed by exactly N bytes, then "\\n".
|
||||
The OCaml side reads the length, then reads exactly N bytes.
|
||||
This avoids string-escape round-trip issues for SX wire format.
|
||||
"""
|
||||
assert self._proc and self._proc.stdin
|
||||
encoded = data.encode()
|
||||
self._proc.stdin.write(f"(blob {len(encoded)})\n".encode())
|
||||
self._proc.stdin.write(encoded)
|
||||
self._proc.stdin.write(b"\n")
|
||||
await self._proc.stdin.drain()
|
||||
|
||||
async def _readline(self) -> str:
|
||||
"""Read a line from the subprocess stdout."""
|
||||
assert self._proc and self._proc.stdout
|
||||
data = await self._proc.stdout.readline()
|
||||
if not data:
|
||||
# Process died — collect stderr for diagnostics
|
||||
stderr = b""
|
||||
if self._proc.stderr:
|
||||
stderr = await self._proc.stderr.read()
|
||||
# Process died
|
||||
raise OcamlBridgeError(
|
||||
f"OCaml subprocess died unexpectedly. stderr: {stderr.decode(errors='replace')}"
|
||||
"OCaml subprocess died unexpectedly (check container stderr)"
|
||||
)
|
||||
return data.decode().rstrip("\n")
|
||||
line = data.decode().rstrip("\n")
|
||||
_logger.debug("RECV: %s", line[:120])
|
||||
return line
|
||||
|
||||
async def _read_response(self) -> tuple[str, str | None]:
|
||||
"""Read a single (ok ...) or (error ...) response.
|
||||
|
||||
Returns (kind, value) where kind is "ok" or "error".
|
||||
Discards stale epoch messages.
|
||||
"""
|
||||
line = await self._readline()
|
||||
return _parse_response(line)
|
||||
while True:
|
||||
line = await self._readline()
|
||||
if not self._is_current_epoch(line):
|
||||
_logger.debug("Discarding stale response: %s", line[:80])
|
||||
if line.startswith("(ok-len "):
|
||||
parts = line[1:-1].split()
|
||||
if len(parts) >= 3:
|
||||
n = int(parts[-1])
|
||||
assert self._proc and self._proc.stdout
|
||||
await self._proc.stdout.readexactly(n)
|
||||
await self._proc.stdout.readline()
|
||||
continue
|
||||
# Length-prefixed blob: (ok-len EPOCH N) or (ok-len N)
|
||||
if line.startswith("(ok-len "):
|
||||
parts = line[1:-1].split()
|
||||
n = int(parts[-1])
|
||||
assert self._proc and self._proc.stdout
|
||||
data = await self._proc.stdout.readexactly(n)
|
||||
await self._proc.stdout.readline() # trailing newline
|
||||
return ("ok", data.decode())
|
||||
return _parse_response(line)
|
||||
|
||||
def _is_current_epoch(self, line: str) -> bool:
|
||||
"""Check if a response line belongs to the current epoch.
|
||||
|
||||
Lines tagged with a stale epoch are discarded. Untagged lines
|
||||
(from a kernel that predates the epoch protocol) are accepted.
|
||||
"""
|
||||
# Extract epoch number from known tagged formats:
|
||||
# (ok EPOCH ...), (error EPOCH ...), (ok-len EPOCH N),
|
||||
# (io-request EPOCH ...), (io-done EPOCH N)
|
||||
import re
|
||||
m = re.match(r'\((?:ok|error|ok-len|ok-raw|io-request|io-done)\s+(\d+)\b', line)
|
||||
if m:
|
||||
return int(m.group(1)) == self._epoch
|
||||
# Untagged (legacy) — accept
|
||||
return True
|
||||
|
||||
async def _read_until_ok(
|
||||
self,
|
||||
@@ -216,17 +586,94 @@ class OcamlBridge:
|
||||
) -> str:
|
||||
"""Read lines until (ok ...) or (error ...).
|
||||
|
||||
Handles (io-request ...) by fulfilling IO and sending (io-response ...).
|
||||
Handles IO requests in two modes:
|
||||
- Legacy (blocking): single io-request → immediate io-response
|
||||
- Batched: collect io-requests until (io-done N), process ALL
|
||||
concurrently with asyncio.gather, send responses in order
|
||||
|
||||
Lines tagged with a stale epoch are silently discarded, making
|
||||
pipe desync from previous failed requests impossible.
|
||||
"""
|
||||
import asyncio
|
||||
pending_batch: list[str] = []
|
||||
|
||||
while True:
|
||||
line = await self._readline()
|
||||
|
||||
if line.startswith("(io-request "):
|
||||
result = await self._handle_io_request(line, ctx)
|
||||
# Send response back to OCaml
|
||||
self._send(f"(io-response {_serialize_for_ocaml(result)})")
|
||||
# Discard stale epoch messages
|
||||
if not self._is_current_epoch(line):
|
||||
_logger.debug("Discarding stale epoch message: %s", line[:80])
|
||||
# If it's a stale ok-len, drain the blob bytes too
|
||||
if line.startswith("(ok-len "):
|
||||
parts = line[1:-1].split()
|
||||
if len(parts) >= 3:
|
||||
n = int(parts[2])
|
||||
assert self._proc and self._proc.stdout
|
||||
await self._proc.stdout.readexactly(n)
|
||||
await self._proc.stdout.readline()
|
||||
continue
|
||||
|
||||
if line.startswith("(io-request "):
|
||||
# New format: (io-request EPOCH ...) or (io-request EPOCH ID ...)
|
||||
# Strip epoch from the line for IO dispatch
|
||||
after = line[len("(io-request "):].lstrip()
|
||||
# Skip epoch number if present
|
||||
if after and after[0].isdigit():
|
||||
# Could be epoch or batch ID — check for second number
|
||||
parts = after.split(None, 2)
|
||||
if len(parts) >= 2 and parts[1][0].isdigit():
|
||||
# (io-request EPOCH ID "name" args...) — batched with epoch
|
||||
pending_batch.append(line)
|
||||
continue
|
||||
elif len(parts) >= 2 and parts[1].startswith('"'):
|
||||
# (io-request EPOCH "name" args...) — legacy with epoch
|
||||
try:
|
||||
result = await self._handle_io_request(line, ctx)
|
||||
await self._send(
|
||||
f"(io-response {self._epoch} {_serialize_for_ocaml(result)})")
|
||||
except Exception as e:
|
||||
_logger.warning("IO request failed, sending nil: %s", e)
|
||||
await self._send(f"(io-response {self._epoch} nil)")
|
||||
continue
|
||||
else:
|
||||
# Old format: (io-request ID "name" ...) — batched, no epoch
|
||||
pending_batch.append(line)
|
||||
continue
|
||||
# Legacy blocking mode — respond immediately
|
||||
try:
|
||||
result = await self._handle_io_request(line, ctx)
|
||||
await self._send(
|
||||
f"(io-response {self._epoch} {_serialize_for_ocaml(result)})")
|
||||
except Exception as e:
|
||||
_logger.warning("IO request failed, sending nil: %s", e)
|
||||
await self._send(f"(io-response {self._epoch} nil)")
|
||||
continue
|
||||
|
||||
if line.startswith("(io-done "):
|
||||
# Batch complete — process all pending IO concurrently
|
||||
tasks = [self._handle_io_request(req, ctx)
|
||||
for req in pending_batch]
|
||||
results = await asyncio.gather(*tasks, return_exceptions=True)
|
||||
for result in results:
|
||||
if isinstance(result, BaseException):
|
||||
_logger.warning("Batched IO failed: %s", result)
|
||||
await self._send(f"(io-response {self._epoch} nil)")
|
||||
else:
|
||||
await self._send(
|
||||
f"(io-response {self._epoch} {_serialize_for_ocaml(result)})")
|
||||
pending_batch = []
|
||||
continue
|
||||
|
||||
# Length-prefixed blob: (ok-len EPOCH N) or (ok-len N)
|
||||
if line.startswith("(ok-len "):
|
||||
parts = line[1:-1].split() # ["ok-len", epoch, n] or ["ok-len", n]
|
||||
n = int(parts[-1]) # last number is always byte count
|
||||
assert self._proc and self._proc.stdout
|
||||
data = await self._proc.stdout.readexactly(n)
|
||||
# Read trailing newline
|
||||
await self._proc.stdout.readline()
|
||||
return data.decode()
|
||||
|
||||
kind, value = _parse_response(line)
|
||||
if kind == "error":
|
||||
raise OcamlBridgeError(value or "Unknown error")
|
||||
@@ -238,7 +685,24 @@ class OcamlBridge:
|
||||
line: str,
|
||||
ctx: dict[str, Any] | None,
|
||||
) -> Any:
|
||||
"""Dispatch an io-request to the appropriate Python handler."""
|
||||
"""Dispatch an io-request to the appropriate Python handler.
|
||||
|
||||
IO handlers MUST NOT call the bridge (eval/aser/render) — doing so
|
||||
would deadlock since the lock is already held. The _in_io_handler
|
||||
flag triggers an immediate error if this rule is violated.
|
||||
"""
|
||||
self._in_io_handler = True
|
||||
try:
|
||||
return await self._dispatch_io(line, ctx)
|
||||
finally:
|
||||
self._in_io_handler = False
|
||||
|
||||
async def _dispatch_io(
|
||||
self,
|
||||
line: str,
|
||||
ctx: dict[str, Any] | None,
|
||||
) -> Any:
|
||||
"""Inner dispatch for IO requests."""
|
||||
from .parser import parse_all
|
||||
|
||||
# Parse the io-request
|
||||
@@ -247,12 +711,17 @@ class OcamlBridge:
|
||||
raise OcamlBridgeError(f"Malformed io-request: {line}")
|
||||
|
||||
parts = parsed[0]
|
||||
# parts = [Symbol("io-request"), name_str, ...args]
|
||||
# Legacy: [Symbol("io-request"), name_str, ...args]
|
||||
# Batched: [Symbol("io-request"), id_num, name_str, ...args]
|
||||
if len(parts) < 2:
|
||||
raise OcamlBridgeError(f"Malformed io-request: {line}")
|
||||
|
||||
req_name = _to_str(parts[1])
|
||||
args = parts[2:]
|
||||
# Skip numeric batch ID if present
|
||||
offset = 1
|
||||
if isinstance(parts[1], (int, float)):
|
||||
offset = 2
|
||||
req_name = _to_str(parts[offset])
|
||||
args = parts[offset + 1:]
|
||||
|
||||
if req_name == "query":
|
||||
return await self._io_query(args)
|
||||
@@ -264,7 +733,15 @@ class OcamlBridge:
|
||||
return self._io_request_method()
|
||||
elif req_name == "ctx":
|
||||
return self._io_ctx(args, ctx)
|
||||
elif req_name == "helper":
|
||||
return await self._io_helper(args, ctx)
|
||||
else:
|
||||
# Fall back to registered IO handlers (set-response-status, sleep, etc.)
|
||||
from .primitives_io import _IO_HANDLERS, RequestContext
|
||||
io_handler = _IO_HANDLERS.get(req_name)
|
||||
if io_handler is not None:
|
||||
helper_args = [_to_python(a) for a in args]
|
||||
return await io_handler(helper_args, {}, ctx or RequestContext())
|
||||
raise OcamlBridgeError(f"Unknown io-request type: {req_name}")
|
||||
|
||||
async def _io_query(self, args: list) -> Any:
|
||||
@@ -309,6 +786,63 @@ class OcamlBridge:
|
||||
key = _to_str(args[0]) if args else ""
|
||||
return ctx.get(key)
|
||||
|
||||
# Helpers that are pure functions — safe to cache by args.
|
||||
_CACHEABLE_HELPERS = frozenset({
|
||||
"highlight", "component-source", "primitives-data",
|
||||
"special-forms-data", "reference-data", "read-spec-file",
|
||||
"bootstrapper-data", "bundle-analyzer-data", "routing-analyzer-data",
|
||||
})
|
||||
|
||||
async def _io_helper(self, args: list, ctx: dict[str, Any] | None) -> Any:
|
||||
"""Handle (io-request "helper" name arg1 arg2 ...).
|
||||
|
||||
Dispatches to registered page helpers — Python functions like
|
||||
read-spec-file, bootstrapper-data, etc. The helper service name
|
||||
is passed via ctx["_helper_service"].
|
||||
|
||||
Pure helpers (highlight etc.) are cached — same input always
|
||||
produces same output. Eliminates blocking round-trips for
|
||||
repeat calls across pages.
|
||||
"""
|
||||
import asyncio
|
||||
from .pages import get_page_helpers
|
||||
from .primitives_io import _IO_HANDLERS, RequestContext
|
||||
|
||||
name = _to_str(args[0]) if args else ""
|
||||
helper_args = [_to_python(a) for a in args[1:]]
|
||||
|
||||
# Cache lookup for pure helpers
|
||||
if name in self._CACHEABLE_HELPERS:
|
||||
cache_key = (name, *[repr(a) for a in helper_args])
|
||||
if cache_key in self._io_cache:
|
||||
return self._io_cache[cache_key]
|
||||
|
||||
# Check page helpers first (application-level)
|
||||
service = (ctx or {}).get("_helper_service", "sx")
|
||||
helpers = get_page_helpers(service)
|
||||
fn = helpers.get(name)
|
||||
if fn is not None:
|
||||
result = fn(*helper_args)
|
||||
if asyncio.iscoroutine(result):
|
||||
result = await result
|
||||
# Cache pure helper results
|
||||
if name in self._CACHEABLE_HELPERS:
|
||||
self._io_cache[cache_key] = result
|
||||
return result
|
||||
|
||||
# Fall back to IO primitives (now, state-get, state-set!, etc.)
|
||||
io_handler = _IO_HANDLERS.get(name)
|
||||
if io_handler is not None:
|
||||
return await io_handler(helper_args, {}, RequestContext())
|
||||
|
||||
# Fall back to regular primitives (json-encode, into, etc.)
|
||||
from .primitives import get_primitive as _get_prim
|
||||
prim = _get_prim(name)
|
||||
if prim is not None:
|
||||
return prim(*helper_args)
|
||||
|
||||
raise OcamlBridgeError(f"Unknown helper: {name!r}")
|
||||
|
||||
|
||||
# ------------------------------------------------------------------
|
||||
# Module-level singleton
|
||||
@@ -339,22 +873,50 @@ def _escape(s: str) -> str:
|
||||
def _parse_response(line: str) -> tuple[str, str | None]:
|
||||
"""Parse an (ok ...) or (error ...) response line.
|
||||
|
||||
Handles epoch-tagged responses: (ok EPOCH), (ok EPOCH value),
|
||||
(error EPOCH "msg"), as well as legacy untagged responses.
|
||||
|
||||
Returns (kind, value) tuple.
|
||||
"""
|
||||
line = line.strip()
|
||||
if line == "(ok)":
|
||||
# (ok EPOCH) — tagged no-value
|
||||
if line == "(ok)" or (line.startswith("(ok ") and line[4:-1].isdigit()):
|
||||
return ("ok", None)
|
||||
if line.startswith("(ok-raw "):
|
||||
# (ok-raw EPOCH value) or (ok-raw value)
|
||||
inner = line[8:-1]
|
||||
# Strip epoch if present
|
||||
if inner and inner[0].isdigit():
|
||||
space = inner.find(" ")
|
||||
if space > 0:
|
||||
inner = inner[space + 1:]
|
||||
else:
|
||||
return ("ok", None)
|
||||
return ("ok", inner)
|
||||
if line.startswith("(ok "):
|
||||
value = line[4:-1] # strip (ok and )
|
||||
inner = line[4:-1] # strip (ok and )
|
||||
# Strip epoch number if present: (ok 42 "value") → "value"
|
||||
if inner and inner[0].isdigit():
|
||||
space = inner.find(" ")
|
||||
if space > 0:
|
||||
inner = inner[space + 1:]
|
||||
else:
|
||||
# (ok EPOCH) with no value
|
||||
return ("ok", None)
|
||||
# If the value is a quoted string, unquote it
|
||||
if value.startswith('"') and value.endswith('"'):
|
||||
value = _unescape(value[1:-1])
|
||||
return ("ok", value)
|
||||
if inner.startswith('"') and inner.endswith('"'):
|
||||
inner = _unescape(inner[1:-1])
|
||||
return ("ok", inner)
|
||||
if line.startswith("(error "):
|
||||
msg = line[7:-1]
|
||||
if msg.startswith('"') and msg.endswith('"'):
|
||||
msg = _unescape(msg[1:-1])
|
||||
return ("error", msg)
|
||||
inner = line[7:-1]
|
||||
# Strip epoch number if present: (error 42 "msg") → "msg"
|
||||
if inner and inner[0].isdigit():
|
||||
space = inner.find(" ")
|
||||
if space > 0:
|
||||
inner = inner[space + 1:]
|
||||
if inner.startswith('"') and inner.endswith('"'):
|
||||
inner = _unescape(inner[1:-1])
|
||||
return ("error", inner)
|
||||
return ("error", f"Unexpected response: {line}")
|
||||
|
||||
|
||||
@@ -369,6 +931,16 @@ def _unescape(s: str) -> str:
|
||||
)
|
||||
|
||||
|
||||
def _to_python(val: Any) -> Any:
|
||||
"""Convert an SX parsed value to a plain Python value."""
|
||||
from .types import NIL as _NIL
|
||||
if val is None or val is _NIL:
|
||||
return None
|
||||
if hasattr(val, "name"): # Symbol or Keyword
|
||||
return val.name
|
||||
return val
|
||||
|
||||
|
||||
def _to_str(val: Any) -> str:
|
||||
"""Convert an SX parsed value to a Python string."""
|
||||
if isinstance(val, str):
|
||||
|
||||
167
shared/sx/ocaml_sync.py
Normal file
167
shared/sx/ocaml_sync.py
Normal file
@@ -0,0 +1,167 @@
|
||||
"""
|
||||
Synchronous OCaml bridge — persistent subprocess for build-time evaluation.
|
||||
|
||||
Used by bootstrappers (JS cli.py, OCaml bootstrap.py) that need a sync
|
||||
evaluator to run transpiler.sx. For async runtime use, see ocaml_bridge.py.
|
||||
"""
|
||||
from __future__ import annotations
|
||||
|
||||
import os
|
||||
import subprocess
|
||||
import sys
|
||||
|
||||
_DEFAULT_BIN = os.path.join(
|
||||
os.path.dirname(__file__),
|
||||
"../../hosts/ocaml/_build/default/bin/sx_server.exe",
|
||||
)
|
||||
|
||||
|
||||
class OcamlSyncError(Exception):
|
||||
"""Error from the OCaml SX kernel."""
|
||||
|
||||
|
||||
def _sx_unescape(s: str) -> str:
|
||||
"""Unescape an SX string literal (left-to-right, one pass)."""
|
||||
out = []
|
||||
i = 0
|
||||
while i < len(s):
|
||||
if s[i] == '\\' and i + 1 < len(s):
|
||||
c = s[i + 1]
|
||||
if c == 'n':
|
||||
out.append('\n')
|
||||
elif c == 'r':
|
||||
out.append('\r')
|
||||
elif c == 't':
|
||||
out.append('\t')
|
||||
elif c == '"':
|
||||
out.append('"')
|
||||
elif c == '\\':
|
||||
out.append('\\')
|
||||
else:
|
||||
out.append(c)
|
||||
i += 2
|
||||
else:
|
||||
out.append(s[i])
|
||||
i += 1
|
||||
return ''.join(out)
|
||||
|
||||
|
||||
class OcamlSync:
|
||||
"""Synchronous bridge to the OCaml sx_server subprocess."""
|
||||
|
||||
def __init__(self, binary: str | None = None):
|
||||
self._binary = binary or os.environ.get("SX_OCAML_BIN") or _DEFAULT_BIN
|
||||
self._proc: subprocess.Popen | None = None
|
||||
self._epoch: int = 0
|
||||
|
||||
def _ensure(self):
|
||||
if self._proc is not None and self._proc.poll() is None:
|
||||
return
|
||||
self._proc = subprocess.Popen(
|
||||
[self._binary],
|
||||
stdin=subprocess.PIPE,
|
||||
stdout=subprocess.PIPE,
|
||||
stderr=subprocess.PIPE,
|
||||
)
|
||||
self._epoch = 0
|
||||
# Wait for (ready)
|
||||
line = self._readline()
|
||||
if line != "(ready)":
|
||||
raise OcamlSyncError(f"Expected (ready), got: {line}")
|
||||
|
||||
def _send(self, command: str):
|
||||
"""Send a command with epoch prefix."""
|
||||
assert self._proc and self._proc.stdin
|
||||
self._epoch += 1
|
||||
self._proc.stdin.write(f"(epoch {self._epoch})\n".encode())
|
||||
self._proc.stdin.write((command + "\n").encode())
|
||||
self._proc.stdin.flush()
|
||||
|
||||
def _readline(self) -> str:
|
||||
assert self._proc and self._proc.stdout
|
||||
data = self._proc.stdout.readline()
|
||||
if not data:
|
||||
raise OcamlSyncError("OCaml subprocess died unexpectedly")
|
||||
return data.decode().rstrip("\n")
|
||||
|
||||
def _strip_epoch(self, inner: str) -> str:
|
||||
"""Strip leading epoch number from a response value: '42 value' → 'value'."""
|
||||
if inner and inner[0].isdigit():
|
||||
space = inner.find(" ")
|
||||
if space > 0:
|
||||
return inner[space + 1:]
|
||||
return "" # epoch only, no value
|
||||
return inner
|
||||
|
||||
def _read_response(self) -> str:
|
||||
"""Read a single response. Returns the value string or raises on error.
|
||||
|
||||
Handles epoch-tagged responses: (ok EPOCH), (ok EPOCH value),
|
||||
(ok-len EPOCH N), (error EPOCH "msg").
|
||||
"""
|
||||
line = self._readline()
|
||||
# Length-prefixed blob: (ok-len N) or (ok-len EPOCH N)
|
||||
if line.startswith("(ok-len "):
|
||||
parts = line[1:-1].split() # ["ok-len", ...]
|
||||
n = int(parts[-1]) # last number is always byte count
|
||||
assert self._proc and self._proc.stdout
|
||||
data = self._proc.stdout.read(n)
|
||||
self._proc.stdout.readline() # trailing newline
|
||||
value = data.decode()
|
||||
# Blob is SX-serialized — strip string quotes and unescape
|
||||
if value.startswith('"') and value.endswith('"'):
|
||||
value = _sx_unescape(value[1:-1])
|
||||
return value
|
||||
if line == "(ok)" or (line.startswith("(ok ") and line[4:-1].isdigit()):
|
||||
return ""
|
||||
if line.startswith("(ok-raw "):
|
||||
inner = self._strip_epoch(line[8:-1])
|
||||
return inner
|
||||
if line.startswith("(ok "):
|
||||
value = self._strip_epoch(line[4:-1])
|
||||
if value.startswith('"') and value.endswith('"'):
|
||||
value = _sx_unescape(value[1:-1])
|
||||
return value
|
||||
if line.startswith("(error "):
|
||||
msg = self._strip_epoch(line[7:-1])
|
||||
if msg.startswith('"') and msg.endswith('"'):
|
||||
msg = _sx_unescape(msg[1:-1])
|
||||
raise OcamlSyncError(msg)
|
||||
raise OcamlSyncError(f"Unexpected response: {line}")
|
||||
|
||||
def eval(self, source: str) -> str:
|
||||
"""Evaluate SX source, return result as string."""
|
||||
self._ensure()
|
||||
escaped = source.replace("\\", "\\\\").replace('"', '\\"')
|
||||
self._send(f'(eval "{escaped}")')
|
||||
return self._read_response()
|
||||
|
||||
def load(self, path: str) -> str:
|
||||
"""Load an .sx file into the kernel."""
|
||||
self._ensure()
|
||||
self._send(f'(load "{path}")')
|
||||
return self._read_response()
|
||||
|
||||
def load_source(self, source: str) -> str:
|
||||
"""Load SX source directly into the kernel."""
|
||||
self._ensure()
|
||||
escaped = source.replace("\\", "\\\\").replace('"', '\\"')
|
||||
self._send(f'(load-source "{escaped}")')
|
||||
return self._read_response()
|
||||
|
||||
def stop(self):
|
||||
if self._proc and self._proc.poll() is None:
|
||||
self._proc.terminate()
|
||||
self._proc.wait(timeout=5)
|
||||
self._proc = None
|
||||
|
||||
|
||||
# Singleton
|
||||
_global: OcamlSync | None = None
|
||||
|
||||
|
||||
def get_sync_bridge() -> OcamlSync:
|
||||
global _global
|
||||
if _global is None:
|
||||
_global = OcamlSync()
|
||||
return _global
|
||||
@@ -32,7 +32,7 @@ logger = logging.getLogger("sx.pages")
|
||||
|
||||
def _eval_error_sx(e: EvalError, context: str) -> str:
|
||||
"""Render an EvalError as SX content that's visible to the developer."""
|
||||
from .ref.sx_ref import escape_html as _esc
|
||||
from html import escape as _esc
|
||||
msg = _esc(str(e))
|
||||
ctx = _esc(context)
|
||||
return (
|
||||
@@ -141,29 +141,60 @@ def get_page_helpers(service: str) -> dict[str, Any]:
|
||||
# Loading — parse .sx files and collect PageDef instances
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
def _parse_defpage(expr: list) -> PageDef | None:
|
||||
"""Extract PageDef from a (defpage name :path ... :content ...) form."""
|
||||
from .types import Keyword
|
||||
if len(expr) < 3:
|
||||
return None
|
||||
name = expr[1].name if hasattr(expr[1], 'name') else str(expr[1])
|
||||
|
||||
kwargs: dict[str, Any] = {}
|
||||
i = 2
|
||||
while i < len(expr):
|
||||
item = expr[i]
|
||||
if isinstance(item, Keyword) and i + 1 < len(expr):
|
||||
kwargs[item.name] = expr[i + 1]
|
||||
i += 2
|
||||
else:
|
||||
i += 1
|
||||
|
||||
path = kwargs.get("path")
|
||||
if not path or not isinstance(path, str):
|
||||
return None
|
||||
|
||||
auth = kwargs.get("auth", "public")
|
||||
if hasattr(auth, 'name'):
|
||||
auth = auth.name
|
||||
|
||||
return PageDef(
|
||||
name=name, path=path, auth=auth,
|
||||
layout=kwargs.get("layout"),
|
||||
cache=None,
|
||||
data_expr=kwargs.get("data"),
|
||||
content_expr=kwargs.get("content"),
|
||||
filter_expr=kwargs.get("filter"),
|
||||
aside_expr=kwargs.get("aside"),
|
||||
menu_expr=kwargs.get("menu"),
|
||||
)
|
||||
|
||||
|
||||
def load_page_file(filepath: str, service_name: str) -> list[PageDef]:
|
||||
"""Parse an .sx file, evaluate it, and register any PageDef values."""
|
||||
"""Parse an .sx file and register any defpage definitions."""
|
||||
from .parser import parse_all
|
||||
from .ref.sx_ref import eval_expr as _raw_eval, trampoline as _trampoline
|
||||
_eval = lambda expr, env: _trampoline(_raw_eval(expr, env))
|
||||
from .jinja_bridge import get_component_env
|
||||
|
||||
with open(filepath, encoding="utf-8") as f:
|
||||
source = f.read()
|
||||
|
||||
# Seed env with component definitions so pages can reference components
|
||||
env = dict(get_component_env())
|
||||
exprs = parse_all(source)
|
||||
pages: list[PageDef] = []
|
||||
|
||||
for expr in exprs:
|
||||
_eval(expr, env)
|
||||
|
||||
# Collect all PageDef values from the env
|
||||
for key, val in env.items():
|
||||
if isinstance(val, PageDef):
|
||||
register_page(service_name, val)
|
||||
pages.append(val)
|
||||
if (isinstance(expr, list) and expr
|
||||
and hasattr(expr[0], 'name') and expr[0].name == "defpage"):
|
||||
pd = _parse_defpage(expr)
|
||||
if pd:
|
||||
register_page(service_name, pd)
|
||||
pages.append(pd)
|
||||
|
||||
return pages
|
||||
|
||||
@@ -177,10 +208,95 @@ def load_page_dir(directory: str, service_name: str) -> list[PageDef]:
|
||||
return pages
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# URL → SX expression conversion (was in sx_ref.py, pure logic)
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
def prepare_url_expr(url_path: str, env: dict) -> list:
|
||||
"""Convert a URL path to an SX expression, quoting unknown symbols."""
|
||||
from .parser import parse_all
|
||||
from .types import Symbol
|
||||
|
||||
if not url_path or url_path == "/":
|
||||
return []
|
||||
trimmed = url_path.lstrip("/")
|
||||
sx_source = trimmed.replace(".", " ")
|
||||
exprs = parse_all(sx_source)
|
||||
if not exprs:
|
||||
return []
|
||||
expr = exprs[0]
|
||||
if not isinstance(expr, list):
|
||||
return expr
|
||||
# Auto-quote unknown symbols (not in env, not keywords/components)
|
||||
return _auto_quote(expr, env)
|
||||
|
||||
|
||||
def _auto_quote(expr, env: dict):
|
||||
from .types import Symbol
|
||||
if not isinstance(expr, list) or not expr:
|
||||
return expr
|
||||
head = expr[0]
|
||||
children = []
|
||||
for child in expr[1:]:
|
||||
if isinstance(child, list):
|
||||
children.append(_auto_quote(child, env))
|
||||
elif isinstance(child, Symbol):
|
||||
name = child.name
|
||||
if (name in env or name.startswith(":") or
|
||||
name.startswith("~") or name.startswith("!")):
|
||||
children.append(child)
|
||||
else:
|
||||
children.append(name) # quote as string
|
||||
else:
|
||||
children.append(child)
|
||||
return [head] + children
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Page execution
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
def _wrap_with_env(expr: Any, env: dict) -> str:
|
||||
"""Serialize an expression wrapped with let-bindings from env.
|
||||
|
||||
Injects page env values (URL params, data results) as let-bindings
|
||||
so the OCaml kernel can evaluate the expression with those bindings.
|
||||
Only injects non-component, non-callable values that pages add dynamically.
|
||||
"""
|
||||
from .parser import serialize
|
||||
from .ocaml_bridge import _serialize_for_ocaml
|
||||
from .types import Symbol, Keyword, NIL
|
||||
|
||||
body = serialize(expr)
|
||||
bindings = []
|
||||
for k, v in env.items():
|
||||
# Skip component definitions — already loaded in kernel
|
||||
if k.startswith("~") or callable(v):
|
||||
continue
|
||||
# Skip env keys that are component-env infrastructure
|
||||
if isinstance(v, (type, type(None))) and v is not None:
|
||||
continue
|
||||
# Serialize the value
|
||||
if v is NIL or v is None:
|
||||
sv = "nil"
|
||||
elif isinstance(v, bool):
|
||||
sv = "true" if v else "false"
|
||||
elif isinstance(v, (int, float)):
|
||||
sv = str(int(v)) if isinstance(v, float) and v == int(v) else str(v)
|
||||
elif isinstance(v, str):
|
||||
sv = _serialize_for_ocaml(v)
|
||||
elif isinstance(v, (list, dict)):
|
||||
sv = _serialize_for_ocaml(v)
|
||||
else:
|
||||
# Component, Lambda, etc — skip, already in kernel
|
||||
continue
|
||||
bindings.append(f"({k} {sv})")
|
||||
|
||||
if not bindings:
|
||||
return body
|
||||
return f"(let ({' '.join(bindings)}) {body})"
|
||||
|
||||
|
||||
async def _eval_slot(expr: Any, env: dict, ctx: Any) -> str:
|
||||
"""Evaluate a page slot expression and return an sx source string.
|
||||
|
||||
@@ -188,10 +304,16 @@ async def _eval_slot(expr: Any, env: dict, ctx: Any) -> str:
|
||||
the result as SX wire format, not HTML.
|
||||
"""
|
||||
import os
|
||||
if os.environ.get("SX_USE_REF") == "1":
|
||||
from .ref.async_eval_ref import async_eval_slot_to_sx
|
||||
else:
|
||||
from .async_eval import async_eval_slot_to_sx
|
||||
if os.environ.get("SX_USE_OCAML") == "1":
|
||||
from .ocaml_bridge import get_bridge
|
||||
from .parser import serialize
|
||||
bridge = await get_bridge()
|
||||
# Wrap expression with let-bindings for env values that pages
|
||||
# inject (URL params, data results, etc.)
|
||||
sx_text = _wrap_with_env(expr, env)
|
||||
service = ctx.get("_helper_service", "") if isinstance(ctx, dict) else ""
|
||||
return await bridge.aser_slot(sx_text, ctx={"_helper_service": service})
|
||||
from .async_eval import async_eval_slot_to_sx
|
||||
return await async_eval_slot_to_sx(expr, env, ctx)
|
||||
|
||||
|
||||
@@ -248,12 +370,19 @@ async def execute_page(
|
||||
6. Branch: full_page_sx() vs oob_page_sx() based on is_htmx_request()
|
||||
"""
|
||||
from .jinja_bridge import get_component_env, _get_request_context
|
||||
from .async_eval import async_eval
|
||||
from .page import get_template_context
|
||||
from .helpers import full_page_sx, oob_page_sx, sx_response
|
||||
from .layouts import get_layout
|
||||
from shared.browser.app.utils.htmx import is_htmx_request
|
||||
|
||||
_use_ocaml = os.environ.get("SX_USE_OCAML") == "1"
|
||||
if _use_ocaml:
|
||||
from .ocaml_bridge import get_bridge
|
||||
from .parser import serialize, parse_all
|
||||
from .ocaml_bridge import _serialize_for_ocaml
|
||||
else:
|
||||
from .async_eval import async_eval
|
||||
|
||||
if url_params is None:
|
||||
url_params = {}
|
||||
|
||||
@@ -275,7 +404,19 @@ async def execute_page(
|
||||
# Evaluate :data expression if present
|
||||
_multi_stream_content = None
|
||||
if page_def.data_expr is not None:
|
||||
data_result = await async_eval(page_def.data_expr, env, ctx)
|
||||
if _use_ocaml:
|
||||
bridge = await get_bridge()
|
||||
sx_text = _wrap_with_env(page_def.data_expr, env)
|
||||
ocaml_ctx = {"_helper_service": service_name}
|
||||
raw = await bridge.eval(sx_text, ctx=ocaml_ctx)
|
||||
# Parse result back to Python dict/value
|
||||
if raw:
|
||||
parsed = parse_all(raw)
|
||||
data_result = parsed[0] if parsed else {}
|
||||
else:
|
||||
data_result = {}
|
||||
else:
|
||||
data_result = await async_eval(page_def.data_expr, env, ctx)
|
||||
if hasattr(data_result, '__aiter__'):
|
||||
# Multi-stream: consume generator, eval :content per chunk,
|
||||
# combine into shell with resolved suspense slots.
|
||||
@@ -358,7 +499,18 @@ async def execute_page(
|
||||
k = raw[i]
|
||||
if isinstance(k, SxKeyword) and i + 1 < len(raw):
|
||||
raw_val = raw[i + 1]
|
||||
resolved = await async_eval(raw_val, env, ctx)
|
||||
if _use_ocaml:
|
||||
bridge = await get_bridge()
|
||||
sx_text = _wrap_with_env(raw_val, env)
|
||||
ocaml_ctx = {"_helper_service": service_name}
|
||||
raw_result = await bridge.eval(sx_text, ctx=ocaml_ctx)
|
||||
if raw_result:
|
||||
parsed = parse_all(raw_result)
|
||||
resolved = parsed[0] if parsed else None
|
||||
else:
|
||||
resolved = None
|
||||
else:
|
||||
resolved = await async_eval(raw_val, env, ctx)
|
||||
layout_kwargs[k.name.replace("-", "_")] = resolved
|
||||
i += 2
|
||||
else:
|
||||
|
||||
@@ -38,10 +38,11 @@ def _resolve_sx_reader_macro(name: str):
|
||||
If a file like z3.sx defines (define z3-translate ...), then #z3 is
|
||||
automatically available as a reader macro without any Python registration.
|
||||
Looks for {name}-translate as a Lambda in the component env.
|
||||
|
||||
Uses the synchronous OCaml bridge (ocaml_sync) when available.
|
||||
"""
|
||||
try:
|
||||
from .jinja_bridge import get_component_env
|
||||
from .ref.sx_ref import trampoline as _trampoline, call_lambda as _call_lambda
|
||||
from .types import Lambda
|
||||
except ImportError:
|
||||
return None
|
||||
@@ -49,10 +50,18 @@ def _resolve_sx_reader_macro(name: str):
|
||||
fn = env.get(f"{name}-translate")
|
||||
if fn is None or not isinstance(fn, Lambda):
|
||||
return None
|
||||
# Return a Python callable that invokes the SX lambda
|
||||
def _sx_handler(expr):
|
||||
return _trampoline(_call_lambda(fn, [expr], env))
|
||||
return _sx_handler
|
||||
# Use sync OCaml bridge to invoke the lambda
|
||||
try:
|
||||
from .ocaml_sync import OcamlSync
|
||||
_sync = OcamlSync()
|
||||
_sync.start()
|
||||
def _sx_handler(expr):
|
||||
from .parser import serialize as _ser
|
||||
result = _sync.eval(f"({name}-translate {_ser(expr)})")
|
||||
return parse(result) if result else expr
|
||||
return _sx_handler
|
||||
except Exception:
|
||||
return None
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
@@ -579,26 +579,54 @@ def prim_json_encode(value) -> str:
|
||||
# (shared global state between transpiled and hand-written evaluators)
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
def _lazy_scope_primitives():
|
||||
"""Register scope/provide/collect primitives from sx_ref.py.
|
||||
def _register_scope_primitives():
|
||||
"""Register scope/provide/collect primitive stubs.
|
||||
|
||||
Called at import time — if sx_ref.py isn't built yet, silently skip.
|
||||
These are needed by the hand-written _aser in async_eval.py when
|
||||
expanding components that use scoped effects (e.g. ~cssx/flush).
|
||||
The OCaml kernel provides the real implementations. These stubs exist
|
||||
so _PRIMITIVES contains the names for dependency analysis, and so
|
||||
any Python-side code that checks for their existence finds them.
|
||||
"""
|
||||
try:
|
||||
from .ref.sx_ref import (
|
||||
sx_collect, sx_collected, sx_clear_collected,
|
||||
sx_emitted, sx_emit, sx_context,
|
||||
)
|
||||
_PRIMITIVES["collect!"] = sx_collect
|
||||
_PRIMITIVES["collected"] = sx_collected
|
||||
_PRIMITIVES["clear-collected!"] = sx_clear_collected
|
||||
_PRIMITIVES["emitted"] = sx_emitted
|
||||
_PRIMITIVES["emit!"] = sx_emit
|
||||
_PRIMITIVES["context"] = sx_context
|
||||
except ImportError:
|
||||
pass
|
||||
import threading
|
||||
_scope_data = threading.local()
|
||||
|
||||
_lazy_scope_primitives()
|
||||
def _collect(channel, value):
|
||||
if not hasattr(_scope_data, 'collected'):
|
||||
_scope_data.collected = {}
|
||||
_scope_data.collected.setdefault(channel, []).append(value)
|
||||
return NIL
|
||||
|
||||
def _collected(channel):
|
||||
if not hasattr(_scope_data, 'collected'):
|
||||
return []
|
||||
return list(_scope_data.collected.get(channel, []))
|
||||
|
||||
def _clear_collected(channel):
|
||||
if hasattr(_scope_data, 'collected'):
|
||||
_scope_data.collected.pop(channel, None)
|
||||
return NIL
|
||||
|
||||
def _emit(channel, value):
|
||||
if not hasattr(_scope_data, 'emitted'):
|
||||
_scope_data.emitted = {}
|
||||
_scope_data.emitted.setdefault(channel, []).append(value)
|
||||
return NIL
|
||||
|
||||
def _emitted(channel):
|
||||
if not hasattr(_scope_data, 'emitted'):
|
||||
return []
|
||||
return list(_scope_data.emitted.get(channel, []))
|
||||
|
||||
def _context(key):
|
||||
if not hasattr(_scope_data, 'context'):
|
||||
return NIL
|
||||
return _scope_data.context.get(key, NIL) if isinstance(_scope_data.context, dict) else NIL
|
||||
|
||||
_PRIMITIVES["collect!"] = _collect
|
||||
_PRIMITIVES["collected"] = _collected
|
||||
_PRIMITIVES["clear-collected!"] = _clear_collected
|
||||
_PRIMITIVES["emitted"] = _emitted
|
||||
_PRIMITIVES["emit!"] = _emit
|
||||
_PRIMITIVES["context"] = _context
|
||||
|
||||
_register_scope_primitives()
|
||||
|
||||
|
||||
@@ -642,7 +642,8 @@ from . import primitives_ctx # noqa: E402, F401
|
||||
# Auto-derive IO_PRIMITIVES from registered handlers
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
IO_PRIMITIVES: frozenset[str] = frozenset(_IO_HANDLERS.keys())
|
||||
# Placeholder — rebuilt at end of file after all handlers are registered
|
||||
IO_PRIMITIVES: frozenset[str] = frozenset()
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
@@ -703,9 +704,45 @@ _PRIMITIVES["relations-from"] = _bridge_relations_from
|
||||
# Validate all IO handlers against boundary.sx
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
@register_io_handler("helper")
|
||||
async def _io_helper(
|
||||
args: list[Any], kwargs: dict[str, Any], ctx: RequestContext
|
||||
) -> Any:
|
||||
"""``(helper "name" args...)`` → dispatch to page helpers or IO handlers.
|
||||
|
||||
Universal IO dispatcher — same interface as the OCaml kernel's helper
|
||||
IO primitive. Checks page helpers first, then IO handlers.
|
||||
"""
|
||||
if not args:
|
||||
raise ValueError("helper requires a name")
|
||||
name = str(args[0])
|
||||
helper_args = args[1:]
|
||||
|
||||
# Check page helpers first
|
||||
from .pages import get_page_helpers
|
||||
helpers = get_page_helpers("sx")
|
||||
fn = helpers.get(name)
|
||||
if fn is not None:
|
||||
import asyncio
|
||||
result = fn(*helper_args)
|
||||
if asyncio.iscoroutine(result):
|
||||
result = await result
|
||||
return result
|
||||
|
||||
# Fall back to IO handlers
|
||||
io_handler = _IO_HANDLERS.get(name)
|
||||
if io_handler is not None:
|
||||
return await io_handler(helper_args, {}, ctx)
|
||||
|
||||
raise ValueError(f"Unknown helper: {name!r}")
|
||||
|
||||
|
||||
def _validate_io_handlers() -> None:
|
||||
from .boundary import validate_io
|
||||
for name in _IO_HANDLERS:
|
||||
validate_io(name)
|
||||
|
||||
_validate_io_handlers()
|
||||
|
||||
# Rebuild IO_PRIMITIVES now that all handlers (including helper) are registered
|
||||
IO_PRIMITIVES = frozenset(_IO_HANDLERS.keys())
|
||||
|
||||
@@ -21,10 +21,6 @@ async def execute_query(query_def: QueryDef, params: dict[str, str]) -> Any:
|
||||
"""
|
||||
from .jinja_bridge import get_component_env, _get_request_context
|
||||
import os
|
||||
if os.environ.get("SX_USE_REF") == "1":
|
||||
from .ref.async_eval_ref import async_eval
|
||||
else:
|
||||
from .async_eval import async_eval
|
||||
|
||||
env = dict(get_component_env())
|
||||
env.update(query_def.closure)
|
||||
@@ -38,6 +34,23 @@ async def execute_query(query_def: QueryDef, params: dict[str, str]) -> Any:
|
||||
val = int(val)
|
||||
env[param] = val
|
||||
|
||||
if os.environ.get("SX_USE_OCAML") == "1":
|
||||
from .ocaml_bridge import get_bridge
|
||||
from .parser import serialize, parse_all
|
||||
from .pages import _wrap_with_env
|
||||
bridge = await get_bridge()
|
||||
sx_text = _wrap_with_env(query_def.body, env)
|
||||
ctx = {"_helper_service": ""}
|
||||
raw = await bridge.eval(sx_text, ctx=ctx)
|
||||
if raw:
|
||||
parsed = parse_all(raw)
|
||||
result = parsed[0] if parsed else None
|
||||
else:
|
||||
result = None
|
||||
return _normalize(result)
|
||||
|
||||
from .async_eval import async_eval
|
||||
|
||||
ctx = _get_request_context()
|
||||
result = await async_eval(query_def.body, env, ctx)
|
||||
return _normalize(result)
|
||||
@@ -50,10 +63,6 @@ async def execute_action(action_def: ActionDef, payload: dict[str, Any]) -> Any:
|
||||
"""
|
||||
from .jinja_bridge import get_component_env, _get_request_context
|
||||
import os
|
||||
if os.environ.get("SX_USE_REF") == "1":
|
||||
from .ref.async_eval_ref import async_eval
|
||||
else:
|
||||
from .async_eval import async_eval
|
||||
|
||||
env = dict(get_component_env())
|
||||
env.update(action_def.closure)
|
||||
@@ -64,6 +73,23 @@ async def execute_action(action_def: ActionDef, payload: dict[str, Any]) -> Any:
|
||||
val = payload.get(param, payload.get(snake, NIL))
|
||||
env[param] = val
|
||||
|
||||
if os.environ.get("SX_USE_OCAML") == "1":
|
||||
from .ocaml_bridge import get_bridge
|
||||
from .parser import serialize, parse_all
|
||||
from .pages import _wrap_with_env
|
||||
bridge = await get_bridge()
|
||||
sx_text = _wrap_with_env(action_def.body, env)
|
||||
ctx = {"_helper_service": ""}
|
||||
raw = await bridge.eval(sx_text, ctx=ctx)
|
||||
if raw:
|
||||
parsed = parse_all(raw)
|
||||
result = parsed[0] if parsed else None
|
||||
else:
|
||||
result = None
|
||||
return _normalize(result)
|
||||
|
||||
from .async_eval import async_eval
|
||||
|
||||
ctx = _get_request_context()
|
||||
result = await async_eval(action_def.body, env, ctx)
|
||||
return _normalize(result)
|
||||
|
||||
@@ -78,19 +78,18 @@ def clear(service: str | None = None) -> None:
|
||||
def load_query_file(filepath: str, service_name: str) -> list[QueryDef]:
|
||||
"""Parse an .sx file and register any defquery definitions."""
|
||||
from .parser import parse_all
|
||||
from .ref.sx_ref import eval_expr as _raw_eval, trampoline as _trampoline
|
||||
_eval = lambda expr, env: _trampoline(_raw_eval(expr, env))
|
||||
from .jinja_bridge import get_component_env
|
||||
|
||||
with open(filepath, encoding="utf-8") as f:
|
||||
source = f.read()
|
||||
|
||||
env = dict(get_component_env())
|
||||
exprs = parse_all(source)
|
||||
queries: list[QueryDef] = []
|
||||
# Use the jinja_bridge register_components path which handles
|
||||
# defquery/defaction via the OCaml kernel
|
||||
from .jinja_bridge import register_components
|
||||
register_components(source, _defer_postprocess=True)
|
||||
|
||||
for expr in exprs:
|
||||
_eval(expr, env)
|
||||
env = get_component_env()
|
||||
queries: list[QueryDef] = []
|
||||
|
||||
for val in env.values():
|
||||
if isinstance(val, QueryDef):
|
||||
@@ -102,20 +101,15 @@ def load_query_file(filepath: str, service_name: str) -> list[QueryDef]:
|
||||
|
||||
def load_action_file(filepath: str, service_name: str) -> list[ActionDef]:
|
||||
"""Parse an .sx file and register any defaction definitions."""
|
||||
from .parser import parse_all
|
||||
from .ref.sx_ref import eval_expr as _raw_eval, trampoline as _trampoline
|
||||
_eval = lambda expr, env: _trampoline(_raw_eval(expr, env))
|
||||
from .jinja_bridge import get_component_env
|
||||
from .jinja_bridge import get_component_env, register_components
|
||||
|
||||
with open(filepath, encoding="utf-8") as f:
|
||||
source = f.read()
|
||||
|
||||
env = dict(get_component_env())
|
||||
exprs = parse_all(source)
|
||||
actions: list[ActionDef] = []
|
||||
register_components(source, _defer_postprocess=True)
|
||||
|
||||
for expr in exprs:
|
||||
_eval(expr, env)
|
||||
env = get_component_env()
|
||||
actions: list[ActionDef] = []
|
||||
|
||||
for val in env.values():
|
||||
if isinstance(val, ActionDef):
|
||||
|
||||
@@ -1,22 +0,0 @@
|
||||
"""Async evaluation — thin re-export from bootstrapped sx_ref.py.
|
||||
|
||||
The async adapter (adapter-async.sx) is now bootstrapped directly into
|
||||
sx_ref.py alongside the sync evaluator. This file re-exports the public
|
||||
API so existing imports keep working.
|
||||
|
||||
All async rendering, serialization, and evaluation logic lives in the spec:
|
||||
- shared/sx/ref/adapter-async.sx (canonical SX source)
|
||||
- shared/sx/ref/sx_ref.py (bootstrapped Python)
|
||||
|
||||
Platform async primitives (I/O dispatch, context vars, RequestContext)
|
||||
are in shared/sx/ref/platform_py.py → PLATFORM_ASYNC_PY.
|
||||
"""
|
||||
|
||||
from . import sx_ref
|
||||
|
||||
# Re-export the public API used by handlers.py, helpers.py, pages.py, etc.
|
||||
EvalError = sx_ref.EvalError
|
||||
async_eval = sx_ref.async_eval
|
||||
async_render = sx_ref.async_render
|
||||
async_eval_to_sx = sx_ref.async_eval_to_sx
|
||||
async_eval_slot_to_sx = sx_ref.async_eval_slot_to_sx
|
||||
@@ -1,245 +0,0 @@
|
||||
#!/usr/bin/env python3
|
||||
"""
|
||||
Bootstrap compiler: test.sx -> pytest test module.
|
||||
|
||||
Reads test.sx and emits a Python test file that runs each deftest
|
||||
as a pytest test case, grouped into classes by defsuite.
|
||||
|
||||
The emitted tests use the SX evaluator to run SX test bodies,
|
||||
verifying that the Python implementation matches the spec.
|
||||
|
||||
Usage:
|
||||
python bootstrap_test.py --output shared/sx/tests/test_sx_spec.py
|
||||
pytest shared/sx/tests/test_sx_spec.py -v
|
||||
"""
|
||||
from __future__ import annotations
|
||||
|
||||
import os
|
||||
import re
|
||||
import sys
|
||||
import argparse
|
||||
|
||||
_HERE = os.path.dirname(os.path.abspath(__file__))
|
||||
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", "..", ".."))
|
||||
sys.path.insert(0, _PROJECT)
|
||||
|
||||
from shared.sx.parser import parse_all
|
||||
from shared.sx.types import Symbol, Keyword, NIL as SX_NIL
|
||||
|
||||
|
||||
def _slugify(name: str) -> str:
|
||||
"""Convert a test/suite name to a valid Python identifier."""
|
||||
s = name.lower().strip()
|
||||
s = re.sub(r'[^a-z0-9]+', '_', s)
|
||||
s = s.strip('_')
|
||||
return s
|
||||
|
||||
|
||||
def _sx_to_source(expr) -> str:
|
||||
"""Convert an SX AST node back to SX source string."""
|
||||
if isinstance(expr, bool):
|
||||
return "true" if expr else "false"
|
||||
if isinstance(expr, (int, float)):
|
||||
return str(expr)
|
||||
if isinstance(expr, str):
|
||||
escaped = expr.replace('\\', '\\\\').replace('"', '\\"')
|
||||
return f'"{escaped}"'
|
||||
if expr is None or expr is SX_NIL:
|
||||
return "nil"
|
||||
if isinstance(expr, Symbol):
|
||||
return expr.name
|
||||
if isinstance(expr, Keyword):
|
||||
return f":{expr.name}"
|
||||
if isinstance(expr, dict):
|
||||
pairs = []
|
||||
for k, v in expr.items():
|
||||
pairs.append(f":{k} {_sx_to_source(v)}")
|
||||
return "{" + " ".join(pairs) + "}"
|
||||
if isinstance(expr, list):
|
||||
if not expr:
|
||||
return "()"
|
||||
return "(" + " ".join(_sx_to_source(e) for e in expr) + ")"
|
||||
return str(expr)
|
||||
|
||||
|
||||
def _parse_test_sx(path: str) -> tuple[list[dict], list]:
|
||||
"""Parse test.sx and return (suites, preamble_exprs).
|
||||
|
||||
Preamble exprs are define forms (assertion helpers) that must be
|
||||
evaluated before tests run. Suites contain the actual test cases.
|
||||
"""
|
||||
with open(path) as f:
|
||||
content = f.read()
|
||||
|
||||
exprs = parse_all(content)
|
||||
suites = []
|
||||
preamble = []
|
||||
|
||||
for expr in exprs:
|
||||
if not isinstance(expr, list) or not expr:
|
||||
continue
|
||||
head = expr[0]
|
||||
if isinstance(head, Symbol) and head.name == "defsuite":
|
||||
suite = _parse_suite(expr)
|
||||
if suite:
|
||||
suites.append(suite)
|
||||
elif isinstance(head, Symbol) and head.name == "define":
|
||||
preamble.append(expr)
|
||||
|
||||
return suites, preamble
|
||||
|
||||
|
||||
def _parse_suite(expr: list) -> dict | None:
|
||||
"""Parse a (defsuite "name" ...) form."""
|
||||
if len(expr) < 2:
|
||||
return None
|
||||
|
||||
name = expr[1]
|
||||
if not isinstance(name, str):
|
||||
return None
|
||||
|
||||
tests = []
|
||||
for child in expr[2:]:
|
||||
if not isinstance(child, list) or not child:
|
||||
continue
|
||||
head = child[0]
|
||||
if isinstance(head, Symbol):
|
||||
if head.name == "deftest":
|
||||
test = _parse_test(child)
|
||||
if test:
|
||||
tests.append(test)
|
||||
elif head.name == "defsuite":
|
||||
sub = _parse_suite(child)
|
||||
if sub:
|
||||
tests.append(sub)
|
||||
|
||||
return {"type": "suite", "name": name, "tests": tests}
|
||||
|
||||
|
||||
def _parse_test(expr: list) -> dict | None:
|
||||
"""Parse a (deftest "name" body ...) form."""
|
||||
if len(expr) < 3:
|
||||
return None
|
||||
name = expr[1]
|
||||
if not isinstance(name, str):
|
||||
return None
|
||||
body = expr[2:]
|
||||
return {"type": "test", "name": name, "body": body}
|
||||
|
||||
|
||||
def _emit_py(suites: list[dict], preamble: list) -> str:
|
||||
"""Emit a pytest module from parsed suites."""
|
||||
# Serialize preamble (assertion helpers) as SX source
|
||||
preamble_sx = "\n".join(_sx_to_source(expr) for expr in preamble)
|
||||
preamble_escaped = preamble_sx.replace('\\', '\\\\').replace("'", "\\'")
|
||||
|
||||
lines = []
|
||||
lines.append('"""Auto-generated from test.sx — SX spec self-tests.')
|
||||
lines.append('')
|
||||
lines.append('DO NOT EDIT. Regenerate with:')
|
||||
lines.append(' python shared/sx/ref/bootstrap_test.py --output shared/sx/tests/test_sx_spec.py')
|
||||
lines.append('"""')
|
||||
lines.append('from __future__ import annotations')
|
||||
lines.append('')
|
||||
lines.append('import pytest')
|
||||
lines.append('from shared.sx.parser import parse_all')
|
||||
lines.append('from shared.sx.ref.sx_ref import eval_expr as _eval, trampoline as _trampoline')
|
||||
lines.append('')
|
||||
lines.append('')
|
||||
lines.append(f"_PREAMBLE = '''{preamble_escaped}'''")
|
||||
lines.append('')
|
||||
lines.append('')
|
||||
lines.append('def _make_env() -> dict:')
|
||||
lines.append(' """Create a fresh env with assertion helpers loaded."""')
|
||||
lines.append(' env = {}')
|
||||
lines.append(' for expr in parse_all(_PREAMBLE):')
|
||||
lines.append(' _trampoline(_eval(expr, env))')
|
||||
lines.append(' return env')
|
||||
lines.append('')
|
||||
lines.append('')
|
||||
lines.append('def _run(sx_source: str, env: dict | None = None) -> object:')
|
||||
lines.append(' """Evaluate SX source and return the result."""')
|
||||
lines.append(' if env is None:')
|
||||
lines.append(' env = _make_env()')
|
||||
lines.append(' exprs = parse_all(sx_source)')
|
||||
lines.append(' result = None')
|
||||
lines.append(' for expr in exprs:')
|
||||
lines.append(' result = _trampoline(_eval(expr, env))')
|
||||
lines.append(' return result')
|
||||
lines.append('')
|
||||
|
||||
for suite in suites:
|
||||
_emit_suite(suite, lines, indent=0)
|
||||
|
||||
return "\n".join(lines)
|
||||
|
||||
|
||||
def _emit_suite(suite: dict, lines: list[str], indent: int):
|
||||
"""Emit a pytest class for a suite."""
|
||||
class_name = f"TestSpec{_slugify(suite['name']).title().replace('_', '')}"
|
||||
pad = " " * indent
|
||||
lines.append(f'{pad}class {class_name}:')
|
||||
lines.append(f'{pad} """test.sx suite: {suite["name"]}"""')
|
||||
lines.append('')
|
||||
|
||||
for item in suite["tests"]:
|
||||
if item["type"] == "test":
|
||||
_emit_test(item, lines, indent + 1)
|
||||
elif item["type"] == "suite":
|
||||
_emit_suite(item, lines, indent + 1)
|
||||
|
||||
lines.append('')
|
||||
|
||||
|
||||
def _emit_test(test: dict, lines: list[str], indent: int):
|
||||
"""Emit a pytest test method."""
|
||||
method_name = f"test_{_slugify(test['name'])}"
|
||||
pad = " " * indent
|
||||
|
||||
# Convert body expressions to SX source
|
||||
body_parts = []
|
||||
for expr in test["body"]:
|
||||
body_parts.append(_sx_to_source(expr))
|
||||
|
||||
# Wrap in (do ...) if multiple expressions, or use single
|
||||
if len(body_parts) == 1:
|
||||
sx_source = body_parts[0]
|
||||
else:
|
||||
sx_source = "(do " + " ".join(body_parts) + ")"
|
||||
|
||||
# Escape for Python string
|
||||
sx_escaped = sx_source.replace('\\', '\\\\').replace("'", "\\'")
|
||||
|
||||
lines.append(f"{pad}def {method_name}(self):")
|
||||
lines.append(f"{pad} _run('{sx_escaped}')")
|
||||
lines.append('')
|
||||
|
||||
|
||||
def main():
|
||||
parser = argparse.ArgumentParser(description="Bootstrap test.sx to pytest")
|
||||
parser.add_argument("--output", "-o", help="Output file path")
|
||||
parser.add_argument("--dry-run", action="store_true", help="Print to stdout")
|
||||
args = parser.parse_args()
|
||||
|
||||
test_sx = os.path.join(_HERE, "test.sx")
|
||||
suites, preamble = _parse_test_sx(test_sx)
|
||||
|
||||
print(f"Parsed {len(suites)} suites, {len(preamble)} preamble defines from test.sx", file=sys.stderr)
|
||||
total_tests = sum(
|
||||
sum(1 for t in s["tests"] if t["type"] == "test")
|
||||
for s in suites
|
||||
)
|
||||
print(f"Total test cases: {total_tests}", file=sys.stderr)
|
||||
|
||||
output = _emit_py(suites, preamble)
|
||||
|
||||
if args.output and not args.dry_run:
|
||||
with open(args.output, "w") as f:
|
||||
f.write(output)
|
||||
print(f"Wrote {args.output}", file=sys.stderr)
|
||||
else:
|
||||
print(output)
|
||||
|
||||
|
||||
if __name__ == "__main__":
|
||||
main()
|
||||
@@ -1,182 +0,0 @@
|
||||
<!DOCTYPE html>
|
||||
<html lang="en">
|
||||
<head>
|
||||
<meta charset="utf-8">
|
||||
<title>SX Reactive Islands Demo</title>
|
||||
<style>
|
||||
* { box-sizing: border-box; margin: 0; padding: 0; }
|
||||
body { font-family: system-ui, sans-serif; max-width: 640px; margin: 40px auto; padding: 0 20px; color: #1a1a2e; background: #f8f8fc; }
|
||||
h1 { margin-bottom: 8px; font-size: 1.5rem; }
|
||||
.subtitle { color: #666; margin-bottom: 32px; font-size: 0.9rem; }
|
||||
.demo { background: white; border: 1px solid #e2e2ea; border-radius: 8px; padding: 20px; margin-bottom: 20px; }
|
||||
.demo h2 { font-size: 1.1rem; margin-bottom: 12px; color: #2d2d4e; }
|
||||
.demo-row { display: flex; align-items: center; gap: 12px; margin-bottom: 8px; }
|
||||
button { background: #4a3f8a; color: white; border: none; border-radius: 4px; padding: 6px 16px; cursor: pointer; font-size: 0.9rem; }
|
||||
button:hover { background: #5b4fa0; }
|
||||
button:active { background: #3a2f7a; }
|
||||
.value { font-size: 1.4rem; font-weight: 600; min-width: 3ch; text-align: center; }
|
||||
.derived { color: #666; font-size: 0.85rem; }
|
||||
.effect-log { background: #f0f0f8; border-radius: 4px; padding: 8px 12px; font-family: monospace; font-size: 0.8rem; max-height: 120px; overflow-y: auto; white-space: pre-wrap; }
|
||||
.batch-indicator { display: inline-block; background: #e8f5e9; color: #2e7d32; padding: 2px 8px; border-radius: 3px; font-size: 0.8rem; }
|
||||
code { background: #f0f0f8; padding: 2px 6px; border-radius: 3px; font-size: 0.85rem; }
|
||||
.note { color: #888; font-size: 0.8rem; margin-top: 8px; }
|
||||
</style>
|
||||
</head>
|
||||
<body>
|
||||
<h1>SX Reactive Islands</h1>
|
||||
<p class="subtitle">Signals transpiled from <code>signals.sx</code> spec via <code>bootstrap_js.py</code></p>
|
||||
|
||||
<!-- Demo 1: Basic signal -->
|
||||
<div class="demo" id="demo-counter">
|
||||
<h2>1. Signal: Counter</h2>
|
||||
<div class="demo-row">
|
||||
<button onclick="decr()">-</button>
|
||||
<span class="value" id="count-display">0</span>
|
||||
<button onclick="incr()">+</button>
|
||||
</div>
|
||||
<div class="derived" id="doubled-display"></div>
|
||||
<p class="note"><code>signal</code> + <code>computed</code> + <code>effect</code></p>
|
||||
</div>
|
||||
|
||||
<!-- Demo 2: Batch -->
|
||||
<div class="demo" id="demo-batch">
|
||||
<h2>2. Batch: Two signals, one notification</h2>
|
||||
<div class="demo-row">
|
||||
<span>first: <strong id="first-display">0</strong></span>
|
||||
<span>second: <strong id="second-display">0</strong></span>
|
||||
<span class="batch-indicator" id="render-count"></span>
|
||||
</div>
|
||||
<div class="demo-row">
|
||||
<button onclick="batchBoth()">Batch increment both</button>
|
||||
<button onclick="noBatchBoth()">No-batch increment both</button>
|
||||
</div>
|
||||
<p class="note"><code>batch</code> coalesces writes: 2 updates, 1 re-render</p>
|
||||
</div>
|
||||
|
||||
<!-- Demo 3: Effect with cleanup -->
|
||||
<div class="demo" id="demo-effect">
|
||||
<h2>3. Effect: Auto-tracking + Cleanup</h2>
|
||||
<div class="demo-row">
|
||||
<button onclick="togglePolling()">Toggle polling</button>
|
||||
<span id="poll-status"></span>
|
||||
</div>
|
||||
<div class="effect-log" id="effect-log"></div>
|
||||
<p class="note"><code>effect</code> returns cleanup fn; dispose stops tracking</p>
|
||||
</div>
|
||||
|
||||
<!-- Demo 4: Computed chains -->
|
||||
<div class="demo" id="demo-chain">
|
||||
<h2>4. Computed chain: base → doubled → quadrupled</h2>
|
||||
<div class="demo-row">
|
||||
<button onclick="chainDecr()">-</button>
|
||||
<span>base: <strong id="chain-base">1</strong></span>
|
||||
<button onclick="chainIncr()">+</button>
|
||||
</div>
|
||||
<div class="derived">
|
||||
doubled: <strong id="chain-doubled"></strong>
|
||||
quadrupled: <strong id="chain-quad"></strong>
|
||||
</div>
|
||||
<p class="note">Three-level computed dependency graph, auto-propagation</p>
|
||||
</div>
|
||||
|
||||
<script src="sx-ref.js"></script>
|
||||
<script>
|
||||
// Grab signal primitives from transpiled runtime
|
||||
var S = window.Sx;
|
||||
var signal = S.signal;
|
||||
var deref = S.deref;
|
||||
var reset = S.reset;
|
||||
var swap = S.swap;
|
||||
var computed = S.computed;
|
||||
var effect = S.effect;
|
||||
var batch = S.batch;
|
||||
|
||||
// ---- Demo 1: Counter ----
|
||||
var count = signal(0);
|
||||
var doubled = computed(function() { return deref(count) * 2; });
|
||||
|
||||
effect(function() {
|
||||
document.getElementById("count-display").textContent = deref(count);
|
||||
});
|
||||
effect(function() {
|
||||
document.getElementById("doubled-display").textContent = "doubled: " + deref(doubled);
|
||||
});
|
||||
|
||||
function incr() { swap(count, function(n) { return n + 1; }); }
|
||||
function decr() { swap(count, function(n) { return n - 1; }); }
|
||||
|
||||
// ---- Demo 2: Batch ----
|
||||
var first = signal(0);
|
||||
var second = signal(0);
|
||||
var renders = signal(0);
|
||||
|
||||
effect(function() {
|
||||
document.getElementById("first-display").textContent = deref(first);
|
||||
document.getElementById("second-display").textContent = deref(second);
|
||||
swap(renders, function(n) { return n + 1; });
|
||||
});
|
||||
effect(function() {
|
||||
document.getElementById("render-count").textContent = "renders: " + deref(renders);
|
||||
});
|
||||
|
||||
function batchBoth() {
|
||||
batch(function() {
|
||||
swap(first, function(n) { return n + 1; });
|
||||
swap(second, function(n) { return n + 1; });
|
||||
});
|
||||
}
|
||||
function noBatchBoth() {
|
||||
swap(first, function(n) { return n + 1; });
|
||||
swap(second, function(n) { return n + 1; });
|
||||
}
|
||||
|
||||
// ---- Demo 3: Effect with cleanup ----
|
||||
var polling = signal(false);
|
||||
var pollDispose = null;
|
||||
var logEl = document.getElementById("effect-log");
|
||||
|
||||
function log(msg) {
|
||||
logEl.textContent += msg + "\n";
|
||||
logEl.scrollTop = logEl.scrollHeight;
|
||||
}
|
||||
|
||||
effect(function() {
|
||||
var active = deref(polling);
|
||||
document.getElementById("poll-status").textContent = active ? "polling..." : "stopped";
|
||||
if (active) {
|
||||
var n = 0;
|
||||
var id = setInterval(function() {
|
||||
n++;
|
||||
log("poll #" + n);
|
||||
}, 500);
|
||||
log("effect: started interval");
|
||||
// Return cleanup function
|
||||
return function() {
|
||||
clearInterval(id);
|
||||
log("cleanup: cleared interval");
|
||||
};
|
||||
}
|
||||
});
|
||||
|
||||
function togglePolling() { swap(polling, function(v) { return !v; }); }
|
||||
|
||||
// ---- Demo 4: Computed chain ----
|
||||
var base = signal(1);
|
||||
var chainDoubled = computed(function() { return deref(base) * 2; });
|
||||
var quadrupled = computed(function() { return deref(chainDoubled) * 2; });
|
||||
|
||||
effect(function() {
|
||||
document.getElementById("chain-base").textContent = deref(base);
|
||||
});
|
||||
effect(function() {
|
||||
document.getElementById("chain-doubled").textContent = deref(chainDoubled);
|
||||
});
|
||||
effect(function() {
|
||||
document.getElementById("chain-quad").textContent = deref(quadrupled);
|
||||
});
|
||||
|
||||
function chainIncr() { swap(base, function(n) { return n + 1; }); }
|
||||
function chainDecr() { swap(base, function(n) { return n - 1; }); }
|
||||
</script>
|
||||
</body>
|
||||
</html>
|
||||
@@ -1,782 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; prove.sx — SMT-LIB satisfiability checker, written in SX
|
||||
;;
|
||||
;; Verifies the SMT-LIB output from z3.sx. For the class of assertions
|
||||
;; z3.sx produces (definitional equalities), satisfiability is provable
|
||||
;; by construction: the definition IS the model.
|
||||
;;
|
||||
;; This closes the loop:
|
||||
;; primitives.sx → z3.sx → SMT-LIB → prove.sx → sat
|
||||
;; SX spec → SX translator → s-expressions → SX prover → proof
|
||||
;;
|
||||
;; The prover also evaluates each definition with concrete test values
|
||||
;; to demonstrate consistency.
|
||||
;;
|
||||
;; Usage:
|
||||
;; (prove-check smtlib-string) — verify a single check-sat block
|
||||
;; (prove-translate expr) — translate + verify a define-* form
|
||||
;; (prove-file exprs) — verify all define-* forms
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; SMT-LIB expression evaluator
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Evaluate an SMT-LIB expression in a variable environment
|
||||
(define smt-eval
|
||||
(fn (expr (env :as dict))
|
||||
(cond
|
||||
;; Numbers
|
||||
(number? expr) expr
|
||||
|
||||
;; String literals
|
||||
(string? expr)
|
||||
(cond
|
||||
(= expr "true") true
|
||||
(= expr "false") false
|
||||
:else expr)
|
||||
|
||||
;; Booleans
|
||||
(= expr true) true
|
||||
(= expr false) false
|
||||
|
||||
;; Symbols — look up in env
|
||||
(= (type-of expr) "symbol")
|
||||
(let ((name (symbol-name expr)))
|
||||
(cond
|
||||
(= name "true") true
|
||||
(= name "false") false
|
||||
:else (get env name expr)))
|
||||
|
||||
;; Lists — function application
|
||||
(list? expr)
|
||||
(if (empty? expr) nil
|
||||
(let ((head (first expr))
|
||||
(args (rest expr)))
|
||||
(if (not (= (type-of head) "symbol"))
|
||||
expr
|
||||
(let ((op (symbol-name head)))
|
||||
(cond
|
||||
;; Arithmetic
|
||||
(= op "+")
|
||||
(reduce (fn (a b) (+ a b)) 0
|
||||
(map (fn (a) (smt-eval a env)) args))
|
||||
(= op "-")
|
||||
(if (= (len args) 1)
|
||||
(- 0 (smt-eval (first args) env))
|
||||
(- (smt-eval (nth args 0) env)
|
||||
(smt-eval (nth args 1) env)))
|
||||
(= op "*")
|
||||
(reduce (fn (a b) (* a b)) 1
|
||||
(map (fn (a) (smt-eval a env)) args))
|
||||
(= op "/")
|
||||
(let ((a (smt-eval (nth args 0) env))
|
||||
(b (smt-eval (nth args 1) env)))
|
||||
(if (= b 0) 0 (/ a b)))
|
||||
(= op "div")
|
||||
(let ((a (smt-eval (nth args 0) env))
|
||||
(b (smt-eval (nth args 1) env)))
|
||||
(if (= b 0) 0 (/ a b)))
|
||||
(= op "mod")
|
||||
(let ((a (smt-eval (nth args 0) env))
|
||||
(b (smt-eval (nth args 1) env)))
|
||||
(if (= b 0) 0 (mod a b)))
|
||||
|
||||
;; Comparison
|
||||
(= op "=")
|
||||
(= (smt-eval (nth args 0) env)
|
||||
(smt-eval (nth args 1) env))
|
||||
(= op "<")
|
||||
(< (smt-eval (nth args 0) env)
|
||||
(smt-eval (nth args 1) env))
|
||||
(= op ">")
|
||||
(> (smt-eval (nth args 0) env)
|
||||
(smt-eval (nth args 1) env))
|
||||
(= op "<=")
|
||||
(<= (smt-eval (nth args 0) env)
|
||||
(smt-eval (nth args 1) env))
|
||||
(= op ">=")
|
||||
(>= (smt-eval (nth args 0) env)
|
||||
(smt-eval (nth args 1) env))
|
||||
|
||||
;; Logic
|
||||
(= op "and")
|
||||
(every? (fn (a) (smt-eval a env)) args)
|
||||
(= op "or")
|
||||
(some (fn (a) (smt-eval a env)) args)
|
||||
(= op "not")
|
||||
(not (smt-eval (first args) env))
|
||||
|
||||
;; ite (if-then-else)
|
||||
(= op "ite")
|
||||
(if (smt-eval (nth args 0) env)
|
||||
(smt-eval (nth args 1) env)
|
||||
(smt-eval (nth args 2) env))
|
||||
|
||||
;; Function call — look up in env
|
||||
:else
|
||||
(let ((fn-def (get env op nil)))
|
||||
(if (nil? fn-def)
|
||||
(list op (map (fn (a) (smt-eval a env)) args))
|
||||
;; fn-def is {:params [...] :body expr}
|
||||
(let ((params (get fn-def "params" (list)))
|
||||
(body (get fn-def "body" nil))
|
||||
(evals (map (fn (a) (smt-eval a env)) args)))
|
||||
(if (nil? body)
|
||||
;; Uninterpreted — return symbolic
|
||||
(list op evals)
|
||||
;; Evaluate body with params bound
|
||||
(smt-eval body
|
||||
(merge env
|
||||
(smt-bind-params params evals))))))))))))
|
||||
|
||||
:else expr)))
|
||||
|
||||
|
||||
;; Bind parameter names to values
|
||||
(define smt-bind-params
|
||||
(fn ((params :as list) (vals :as list))
|
||||
(smt-bind-loop params vals {})))
|
||||
|
||||
(define smt-bind-loop
|
||||
(fn ((params :as list) (vals :as list) (acc :as dict))
|
||||
(if (or (empty? params) (empty? vals))
|
||||
acc
|
||||
(smt-bind-loop (rest params) (rest vals)
|
||||
(assoc acc (first params) (first vals))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; SMT-LIB statement parser
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Extract declarations and assertions from parsed SMT-LIB
|
||||
(define smt-extract-statements
|
||||
(fn ((exprs :as list))
|
||||
(smt-extract-loop exprs {} (list))))
|
||||
|
||||
(define smt-extract-loop
|
||||
(fn ((exprs :as list) (decls :as dict) (assertions :as list))
|
||||
(if (empty? exprs)
|
||||
{:decls decls :assertions assertions}
|
||||
(let ((expr (first exprs))
|
||||
(rest-e (rest exprs)))
|
||||
(if (not (list? expr))
|
||||
(smt-extract-loop rest-e decls assertions)
|
||||
(if (empty? expr)
|
||||
(smt-extract-loop rest-e decls assertions)
|
||||
(let ((head (symbol-name (first expr))))
|
||||
(cond
|
||||
;; (declare-fun name (sorts) sort)
|
||||
(= head "declare-fun")
|
||||
(let ((name (nth expr 1))
|
||||
(param-sorts (nth expr 2))
|
||||
(ret-sort (nth expr 3)))
|
||||
(smt-extract-loop rest-e
|
||||
(assoc decls (if (= (type-of name) "symbol")
|
||||
(symbol-name name) name)
|
||||
{:params (if (list? param-sorts)
|
||||
(map (fn (s) (if (= (type-of s) "symbol")
|
||||
(symbol-name s) (str s)))
|
||||
param-sorts)
|
||||
(list))
|
||||
:ret (if (= (type-of ret-sort) "symbol")
|
||||
(symbol-name ret-sort) (str ret-sort))})
|
||||
assertions))
|
||||
|
||||
;; (assert ...)
|
||||
(= head "assert")
|
||||
(smt-extract-loop rest-e decls
|
||||
(append assertions (list (nth expr 1))))
|
||||
|
||||
;; (check-sat) — skip
|
||||
(= head "check-sat")
|
||||
(smt-extract-loop rest-e decls assertions)
|
||||
|
||||
;; comments (strings starting with ;) — skip
|
||||
:else
|
||||
(smt-extract-loop rest-e decls assertions)))))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Assertion classifier
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Check if an assertion is definitional: (forall (...) (= (f ...) body))
|
||||
;; or (= (f) body) for nullary
|
||||
(define smt-definitional?
|
||||
(fn (assertion)
|
||||
(if (not (list? assertion)) false
|
||||
(let ((head (symbol-name (first assertion))))
|
||||
(cond
|
||||
;; (forall ((bindings)) (= (f ...) body))
|
||||
(= head "forall")
|
||||
(let ((body (nth assertion 2)))
|
||||
(and (list? body)
|
||||
(= (symbol-name (first body)) "=")))
|
||||
;; (= (f ...) body)
|
||||
(= head "=")
|
||||
true
|
||||
:else false)))))
|
||||
|
||||
|
||||
;; Extract the function name, parameters, and body from a definitional assertion
|
||||
(define smt-extract-definition
|
||||
(fn (assertion)
|
||||
(let ((head (symbol-name (first assertion))))
|
||||
(cond
|
||||
;; (forall (((x Int) (y Int))) (= (f x y) body))
|
||||
(= head "forall")
|
||||
(let ((bindings (first (nth assertion 1)))
|
||||
(eq-expr (nth assertion 2))
|
||||
(call (nth eq-expr 1))
|
||||
(body (nth eq-expr 2)))
|
||||
{:name (if (= (type-of (first call)) "symbol")
|
||||
(symbol-name (first call)) (str (first call)))
|
||||
:params (map (fn (b)
|
||||
(if (list? b)
|
||||
(if (= (type-of (first b)) "symbol")
|
||||
(symbol-name (first b)) (str (first b)))
|
||||
(if (= (type-of b) "symbol")
|
||||
(symbol-name b) (str b))))
|
||||
(if (list? bindings) bindings (list bindings)))
|
||||
:body body})
|
||||
|
||||
;; (= (f) body)
|
||||
(= head "=")
|
||||
(let ((call (nth assertion 1))
|
||||
(body (nth assertion 2)))
|
||||
{:name (if (list? call)
|
||||
(if (= (type-of (first call)) "symbol")
|
||||
(symbol-name (first call)) (str (first call)))
|
||||
(str call))
|
||||
:params (list)
|
||||
:body body})
|
||||
|
||||
:else nil))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Test value generation
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define smt-test-values
|
||||
(list
|
||||
(list 0)
|
||||
(list 1)
|
||||
(list -1)
|
||||
(list 5)
|
||||
(list 42)
|
||||
(list 1 2)
|
||||
(list -3 7)
|
||||
(list 5 5)
|
||||
(list 100 -50)
|
||||
(list 3 1)
|
||||
(list 1 1 10)
|
||||
(list 5 1 3)
|
||||
(list -5 1 10)
|
||||
(list 3 3 3)
|
||||
(list 7 2 9)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Proof engine
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Verify a single definitional assertion by construction + evaluation
|
||||
(define smt-verify-definition
|
||||
(fn ((def-info :as dict) (decls :as dict))
|
||||
(let ((name (get def-info "name"))
|
||||
(params (get def-info "params"))
|
||||
(body (get def-info "body"))
|
||||
(n-params (len params)))
|
||||
|
||||
;; Build the model: define f = λparams.body
|
||||
(let ((model (assoc decls name {:params params :body body}))
|
||||
;; Select test values matching arity
|
||||
(tests (filter (fn ((tv :as list)) (= (len tv) n-params)) smt-test-values))
|
||||
;; Run tests
|
||||
(results (map
|
||||
(fn ((test-vals :as list))
|
||||
(let ((env (merge model (smt-bind-params params test-vals)))
|
||||
;; Evaluate body directly
|
||||
(body-result (smt-eval body env))
|
||||
;; Evaluate via function call
|
||||
(call-expr (cons (first (sx-parse name)) test-vals))
|
||||
(call-result (smt-eval call-expr env)))
|
||||
{:vals test-vals
|
||||
:body-result body-result
|
||||
:call-result call-result
|
||||
:equal (= body-result call-result)}))
|
||||
tests)))
|
||||
{:name name
|
||||
:status (if (every? (fn ((r :as dict)) (get r "equal")) results) "sat" "FAIL")
|
||||
:proof "by construction (definition is the model)"
|
||||
:tests-passed (len (filter (fn ((r :as dict)) (get r "equal")) results))
|
||||
:tests-total (len results)
|
||||
:sample (if (empty? results) nil (first results))}))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Public API
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Strip SMT-LIB comment lines (starting with ;) and return only actual forms.
|
||||
;; Handles comments that contain ( characters.
|
||||
(define smt-strip-comments
|
||||
(fn ((s :as string))
|
||||
(let ((lines (split s "\n"))
|
||||
(non-comment (filter
|
||||
(fn ((line :as string)) (not (starts-with? (trim line) ";")))
|
||||
lines)))
|
||||
(join "\n" non-comment))))
|
||||
|
||||
;; Verify SMT-LIB output (string) — parse, classify, prove
|
||||
(define prove-check
|
||||
(fn ((smtlib-str :as string))
|
||||
(let ((parsed (sx-parse (smt-strip-comments smtlib-str)))
|
||||
(stmts (smt-extract-statements parsed))
|
||||
(decls (get stmts "decls"))
|
||||
(assertions (get stmts "assertions")))
|
||||
(if (empty? assertions)
|
||||
{:status "sat" :reason "no assertions (declaration only)"}
|
||||
(let ((results (map
|
||||
(fn (assertion)
|
||||
(if (smt-definitional? assertion)
|
||||
(let ((def-info (smt-extract-definition assertion)))
|
||||
(if (nil? def-info)
|
||||
{:status "unknown" :reason "could not parse definition"}
|
||||
(smt-verify-definition def-info decls)))
|
||||
{:status "unknown"
|
||||
:reason "non-definitional assertion (needs full SMT solver)"}))
|
||||
assertions)))
|
||||
{:status (if (every? (fn ((r :as dict)) (= (get r "status") "sat")) results)
|
||||
"sat" "unknown")
|
||||
:assertions (len assertions)
|
||||
:results results})))))
|
||||
|
||||
|
||||
;; Translate a define-* form AND verify it — the full pipeline
|
||||
(define prove-translate
|
||||
(fn (expr)
|
||||
(let ((smtlib (z3-translate expr))
|
||||
(proof (prove-check smtlib))
|
||||
(status (get proof "status"))
|
||||
(results (get proof "results" (list))))
|
||||
(str smtlib "\n"
|
||||
";; ─── prove.sx ───\n"
|
||||
";; status: " status "\n"
|
||||
(if (empty? results) ""
|
||||
(let ((r (first results)))
|
||||
(str ";; proof: " (get r "proof" "") "\n"
|
||||
";; tested: " (str (get r "tests-passed" 0))
|
||||
"/" (str (get r "tests-total" 0))
|
||||
" ground instances\n")))))))
|
||||
|
||||
|
||||
;; Batch verify: translate and prove all define-* forms
|
||||
(define prove-file
|
||||
(fn ((exprs :as list))
|
||||
(let ((translatable
|
||||
(filter
|
||||
(fn (expr)
|
||||
(and (list? expr)
|
||||
(>= (len expr) 2)
|
||||
(= (type-of (first expr)) "symbol")
|
||||
(let ((name (symbol-name (first expr))))
|
||||
(or (= name "define-primitive")
|
||||
(= name "define-io-primitive")
|
||||
(= name "define-special-form")))))
|
||||
exprs))
|
||||
(results (map
|
||||
(fn (expr)
|
||||
(let ((smtlib (z3-translate expr))
|
||||
(proof (prove-check smtlib))
|
||||
(name (nth expr 1)))
|
||||
(assoc proof "name" name)))
|
||||
translatable))
|
||||
(sat-count (len (filter (fn ((r :as dict)) (= (get r "status") "sat")) results)))
|
||||
(total (len results)))
|
||||
{:total total
|
||||
:sat sat-count
|
||||
:all-sat (= sat-count total)
|
||||
:results results})))
|
||||
|
||||
|
||||
;; ==========================================================================
|
||||
;; Phase 2: Property-based constraint solving
|
||||
;; ==========================================================================
|
||||
;;
|
||||
;; Properties are dicts:
|
||||
;; {:name "+-commutative"
|
||||
;; :vars ("a" "b")
|
||||
;; :test (fn (a b) (= (+ a b) (+ b a))) — for bounded checking
|
||||
;; :holds (= (+ a b) (+ b a)) — quoted AST for SMT-LIB
|
||||
;; :given (fn (lo hi) (<= lo hi)) — optional precondition
|
||||
;; :given-expr (<= lo hi) — quoted AST of precondition
|
||||
;; :domain (-20 21)} — optional custom range
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Domain generation
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Default domain bounds by arity — balance coverage vs. combinatorics
|
||||
(define prove-domain-for
|
||||
(fn ((arity :as number))
|
||||
(cond
|
||||
(<= arity 1) (range -50 51) ;; 101 values
|
||||
(= arity 2) (range -20 21) ;; 41^2 = 1,681 pairs
|
||||
(= arity 3) (range -8 9) ;; 17^3 = 4,913 triples
|
||||
:else (range -5 6)))) ;; 11^n for n >= 4
|
||||
|
||||
;; Cartesian product: all n-tuples from a domain
|
||||
(define prove-tuples
|
||||
(fn ((domain :as list) (arity :as number))
|
||||
(if (<= arity 0) (list (list))
|
||||
(if (= arity 1)
|
||||
(map (fn (x) (list x)) domain)
|
||||
(let ((sub (prove-tuples domain (- arity 1))))
|
||||
(prove-tuples-expand domain sub (list)))))))
|
||||
|
||||
(define prove-tuples-expand
|
||||
(fn ((domain :as list) (sub :as list) (acc :as list))
|
||||
(if (empty? domain) acc
|
||||
(prove-tuples-expand
|
||||
(rest domain) sub
|
||||
(append acc
|
||||
(map (fn ((t :as list)) (cons (first domain) t)) sub))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Function application by arity (no apply primitive available)
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define prove-call
|
||||
(fn ((f :as lambda) (vals :as list))
|
||||
(let ((n (len vals)))
|
||||
(cond
|
||||
(= n 0) (f)
|
||||
(= n 1) (f (nth vals 0))
|
||||
(= n 2) (f (nth vals 0) (nth vals 1))
|
||||
(= n 3) (f (nth vals 0) (nth vals 1) (nth vals 2))
|
||||
(= n 4) (f (nth vals 0) (nth vals 1) (nth vals 2) (nth vals 3))
|
||||
:else nil))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Bounded model checker
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Search for a counterexample. Returns nil if property holds for all tested
|
||||
;; values, or the first counterexample found.
|
||||
(define prove-search
|
||||
(fn ((test-fn :as lambda) given-fn (domain :as list) (vars :as list))
|
||||
(let ((arity (len vars))
|
||||
(tuples (prove-tuples domain arity)))
|
||||
(prove-search-loop test-fn given-fn tuples 0 0))))
|
||||
|
||||
(define prove-search-loop
|
||||
(fn ((test-fn :as lambda) given-fn (tuples :as list) (tested :as number) (skipped :as number))
|
||||
(if (empty? tuples)
|
||||
{:status "verified" :tested tested :skipped skipped}
|
||||
(let ((vals (first tuples))
|
||||
(rest-t (rest tuples)))
|
||||
;; Check precondition (if any)
|
||||
(if (and (not (nil? given-fn))
|
||||
(not (prove-call given-fn vals)))
|
||||
;; Precondition not met — skip this combination
|
||||
(prove-search-loop test-fn given-fn rest-t tested (+ skipped 1))
|
||||
;; Evaluate the property
|
||||
(if (prove-call test-fn vals)
|
||||
;; Passed — continue
|
||||
(prove-search-loop test-fn given-fn rest-t (+ tested 1) skipped)
|
||||
;; Failed — counterexample found
|
||||
{:status "falsified"
|
||||
:tested tested
|
||||
:skipped skipped
|
||||
:counterexample vals}))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Property verification (public API)
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Verify a single property via bounded model checking
|
||||
(define prove-property
|
||||
(fn ((prop :as dict))
|
||||
(let ((name (get prop "name"))
|
||||
(vars (get prop "vars"))
|
||||
(test-fn (get prop "test"))
|
||||
(given-fn (get prop "given" nil))
|
||||
(custom (get prop "domain" nil))
|
||||
(domain (if (nil? custom)
|
||||
(prove-domain-for (len vars))
|
||||
(range (nth custom 0) (nth custom 1)))))
|
||||
(let ((result (prove-search test-fn given-fn domain vars)))
|
||||
(assoc result "name" name)))))
|
||||
|
||||
;; Batch verify a list of properties
|
||||
(define prove-properties
|
||||
(fn ((props :as list))
|
||||
(let ((results (map prove-property props))
|
||||
(verified (filter (fn ((r :as dict)) (= (get r "status") "verified")) results))
|
||||
(falsified (filter (fn ((r :as dict)) (= (get r "status") "falsified")) results)))
|
||||
{:total (len results)
|
||||
:verified (len verified)
|
||||
:falsified (len falsified)
|
||||
:all-verified (= (len falsified) 0)
|
||||
:results results})))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; SMT-LIB generation for properties
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Generate SMT-LIB for a property — asserts (not (forall ...)) so that
|
||||
;; Z3 returning "unsat" proves the property holds universally.
|
||||
(define prove-property-smtlib
|
||||
(fn ((prop :as dict))
|
||||
(let ((name (get prop "name"))
|
||||
(vars (get prop "vars"))
|
||||
(holds (get prop "holds"))
|
||||
(given-e (get prop "given-expr" nil))
|
||||
(bindings (join " "
|
||||
(map (fn ((v :as string)) (str "(" v " Int)")) vars)))
|
||||
(holds-smt (z3-expr holds))
|
||||
(body (if (nil? given-e)
|
||||
holds-smt
|
||||
(str "(=> " (z3-expr given-e) " " holds-smt ")"))))
|
||||
(str "; Property: " name "\n"
|
||||
"; Strategy: assert negation, check for unsat\n"
|
||||
"(assert (not (forall ((" bindings "))\n"
|
||||
" " body ")))\n"
|
||||
"(check-sat) ; expect unsat\n"))))
|
||||
|
||||
;; Generate SMT-LIB for all properties, including necessary definitions
|
||||
(define prove-properties-smtlib
|
||||
(fn ((props :as list) (primitives-exprs :as list))
|
||||
(let ((defs (z3-translate-file primitives-exprs))
|
||||
(prop-smts (map prove-property-smtlib props)))
|
||||
(str ";; ================================================================\n"
|
||||
";; Auto-generated by prove.sx — property verification conditions\n"
|
||||
";; Feed to Z3 for unbounded proofs\n"
|
||||
";; ================================================================\n\n"
|
||||
";; --- Primitive definitions ---\n"
|
||||
defs "\n\n"
|
||||
";; --- Properties ---\n"
|
||||
(join "\n" prop-smts)))))
|
||||
|
||||
|
||||
;; ==========================================================================
|
||||
;; Property library: algebraic laws of SX primitives
|
||||
;; ==========================================================================
|
||||
|
||||
(define sx-properties
|
||||
(list
|
||||
|
||||
;; ----- Arithmetic identities -----
|
||||
|
||||
{:name "+-commutative"
|
||||
:vars (list "a" "b")
|
||||
:test (fn (a b) (= (+ a b) (+ b a)))
|
||||
:holds '(= (+ a b) (+ b a))}
|
||||
|
||||
{:name "+-associative"
|
||||
:vars (list "a" "b" "c")
|
||||
:test (fn (a b c) (= (+ (+ a b) c) (+ a (+ b c))))
|
||||
:holds '(= (+ (+ a b) c) (+ a (+ b c)))}
|
||||
|
||||
{:name "+-identity"
|
||||
:vars (list "a")
|
||||
:test (fn (a) (= (+ a 0) a))
|
||||
:holds '(= (+ a 0) a)}
|
||||
|
||||
{:name "*-commutative"
|
||||
:vars (list "a" "b")
|
||||
:test (fn (a b) (= (* a b) (* b a)))
|
||||
:holds '(= (* a b) (* b a))}
|
||||
|
||||
{:name "*-associative"
|
||||
:vars (list "a" "b" "c")
|
||||
:test (fn (a b c) (= (* (* a b) c) (* a (* b c))))
|
||||
:holds '(= (* (* a b) c) (* a (* b c)))}
|
||||
|
||||
{:name "*-identity"
|
||||
:vars (list "a")
|
||||
:test (fn (a) (= (* a 1) a))
|
||||
:holds '(= (* a 1) a)}
|
||||
|
||||
{:name "*-zero"
|
||||
:vars (list "a")
|
||||
:test (fn (a) (= (* a 0) 0))
|
||||
:holds '(= (* a 0) 0)}
|
||||
|
||||
{:name "distributive"
|
||||
:vars (list "a" "b" "c")
|
||||
:test (fn (a b c) (= (* a (+ b c)) (+ (* a b) (* a c))))
|
||||
:holds '(= (* a (+ b c)) (+ (* a b) (* a c)))}
|
||||
|
||||
{:name "--inverse"
|
||||
:vars (list "a")
|
||||
:test (fn (a) (= (- a a) 0))
|
||||
:holds '(= (- a a) 0)}
|
||||
|
||||
;; ----- inc / dec -----
|
||||
|
||||
{:name "inc-is-plus-1"
|
||||
:vars (list "n")
|
||||
:test (fn (n) (= (inc n) (+ n 1)))
|
||||
:holds '(= (inc n) (+ n 1))}
|
||||
|
||||
{:name "dec-is-minus-1"
|
||||
:vars (list "n")
|
||||
:test (fn (n) (= (dec n) (- n 1)))
|
||||
:holds '(= (dec n) (- n 1))}
|
||||
|
||||
{:name "inc-dec-inverse"
|
||||
:vars (list "n")
|
||||
:test (fn (n) (= (dec (inc n)) n))
|
||||
:holds '(= (dec (inc n)) n)}
|
||||
|
||||
{:name "dec-inc-inverse"
|
||||
:vars (list "n")
|
||||
:test (fn (n) (= (inc (dec n)) n))
|
||||
:holds '(= (inc (dec n)) n)}
|
||||
|
||||
;; ----- abs -----
|
||||
|
||||
{:name "abs-non-negative"
|
||||
:vars (list "n")
|
||||
:test (fn (n) (>= (abs n) 0))
|
||||
:holds '(>= (abs n) 0)}
|
||||
|
||||
{:name "abs-idempotent"
|
||||
:vars (list "n")
|
||||
:test (fn (n) (= (abs (abs n)) (abs n)))
|
||||
:holds '(= (abs (abs n)) (abs n))}
|
||||
|
||||
{:name "abs-symmetric"
|
||||
:vars (list "n")
|
||||
:test (fn (n) (= (abs n) (abs (- 0 n))))
|
||||
:holds '(= (abs n) (abs (- 0 n)))}
|
||||
|
||||
;; ----- Predicates -----
|
||||
|
||||
{:name "odd-not-even"
|
||||
:vars (list "n")
|
||||
:test (fn (n) (= (odd? n) (not (even? n))))
|
||||
:holds '(= (odd? n) (not (even? n)))}
|
||||
|
||||
{:name "even-mod-2"
|
||||
:vars (list "n")
|
||||
:test (fn (n) (= (even? n) (= (mod n 2) 0)))
|
||||
:holds '(= (even? n) (= (mod n 2) 0))}
|
||||
|
||||
{:name "zero-is-zero"
|
||||
:vars (list "n")
|
||||
:test (fn (n) (= (zero? n) (= n 0)))
|
||||
:holds '(= (zero? n) (= n 0))}
|
||||
|
||||
{:name "not-involution"
|
||||
:vars (list "n")
|
||||
:test (fn (n) (= (not (not (zero? n))) (zero? n)))
|
||||
:holds '(= (not (not (zero? n))) (zero? n))}
|
||||
|
||||
;; ----- min / max -----
|
||||
|
||||
{:name "min-commutative"
|
||||
:vars (list "a" "b")
|
||||
:test (fn (a b) (= (min a b) (min b a)))
|
||||
:holds '(= (min a b) (min b a))}
|
||||
|
||||
{:name "max-commutative"
|
||||
:vars (list "a" "b")
|
||||
:test (fn (a b) (= (max a b) (max b a)))
|
||||
:holds '(= (max a b) (max b a))}
|
||||
|
||||
{:name "min-le-both"
|
||||
:vars (list "a" "b")
|
||||
:test (fn (a b) (and (<= (min a b) a) (<= (min a b) b)))
|
||||
:holds '(and (<= (min a b) a) (<= (min a b) b))}
|
||||
|
||||
{:name "max-ge-both"
|
||||
:vars (list "a" "b")
|
||||
:test (fn (a b) (and (>= (max a b) a) (>= (max a b) b)))
|
||||
:holds '(and (>= (max a b) a) (>= (max a b) b))}
|
||||
|
||||
{:name "min-max-identity"
|
||||
:vars (list "a" "b")
|
||||
:test (fn (a b) (= (+ (min a b) (max a b)) (+ a b)))
|
||||
:holds '(= (+ (min a b) (max a b)) (+ a b))}
|
||||
|
||||
;; ----- clamp -----
|
||||
|
||||
{:name "clamp-in-range"
|
||||
:vars (list "x" "lo" "hi")
|
||||
:test (fn (x lo hi) (and (<= lo (clamp x lo hi))
|
||||
(<= (clamp x lo hi) hi)))
|
||||
:given (fn (x lo hi) (<= lo hi))
|
||||
:holds '(and (<= lo (clamp x lo hi)) (<= (clamp x lo hi) hi))
|
||||
:given-expr '(<= lo hi)}
|
||||
|
||||
{:name "clamp-identity-in-range"
|
||||
:vars (list "x" "lo" "hi")
|
||||
:test (fn (x lo hi) (= (clamp x lo hi) x))
|
||||
:given (fn (x lo hi) (and (<= lo hi) (<= lo x) (<= x hi)))
|
||||
:holds '(= (clamp x lo hi) x)
|
||||
:given-expr '(and (<= lo hi) (<= lo x) (<= x hi))}
|
||||
|
||||
{:name "clamp-idempotent"
|
||||
:vars (list "x" "lo" "hi")
|
||||
:test (fn (x lo hi) (= (clamp (clamp x lo hi) lo hi)
|
||||
(clamp x lo hi)))
|
||||
:given (fn (x lo hi) (<= lo hi))
|
||||
:holds '(= (clamp (clamp x lo hi) lo hi) (clamp x lo hi))
|
||||
:given-expr '(<= lo hi)}
|
||||
|
||||
;; ----- Comparison -----
|
||||
|
||||
{:name "lt-gt-flip"
|
||||
:vars (list "a" "b")
|
||||
:test (fn (a b) (= (< a b) (> b a)))
|
||||
:holds '(= (< a b) (> b a))}
|
||||
|
||||
{:name "le-not-gt"
|
||||
:vars (list "a" "b")
|
||||
:test (fn (a b) (= (<= a b) (not (> a b))))
|
||||
:holds '(= (<= a b) (not (> a b)))}
|
||||
|
||||
{:name "ge-not-lt"
|
||||
:vars (list "a" "b")
|
||||
:test (fn (a b) (= (>= a b) (not (< a b))))
|
||||
:holds '(= (>= a b) (not (< a b)))}
|
||||
|
||||
{:name "trichotomy"
|
||||
:vars (list "a" "b")
|
||||
:test (fn (a b) (or (< a b) (= a b) (> a b)))
|
||||
:holds '(or (< a b) (= a b) (> a b))}
|
||||
|
||||
{:name "lt-transitive"
|
||||
:vars (list "a" "b" "c")
|
||||
:test (fn (a b c) (if (and (< a b) (< b c)) (< a c) true))
|
||||
:given (fn (a b c) (and (< a b) (< b c)))
|
||||
:holds '(< a c)
|
||||
:given-expr '(and (< a b) (< b c))}
|
||||
|
||||
;; ----- Inequality -----
|
||||
|
||||
{:name "neq-is-not-eq"
|
||||
:vars (list "a" "b")
|
||||
:test (fn (a b) (= (!= a b) (not (= a b))))
|
||||
:holds '(= (!= a b) (not (= a b)))}))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Run all built-in properties
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define prove-all-properties
|
||||
(fn ()
|
||||
(prove-properties sx-properties)))
|
||||
@@ -1,89 +0,0 @@
|
||||
"""
|
||||
#z3 reader macro — translates SX spec declarations to SMT-LIB format.
|
||||
|
||||
Self-hosted: loads z3.sx (the translator written in SX) and executes it
|
||||
via the SX evaluator. The Python code here is pure host infrastructure —
|
||||
all translation logic lives in z3.sx.
|
||||
|
||||
Usage:
|
||||
from shared.sx.ref.reader_z3 import z3_translate, register_z3_macro
|
||||
|
||||
# Register as reader macro (enables #z3 in parser)
|
||||
register_z3_macro()
|
||||
|
||||
# Or call directly
|
||||
smtlib = z3_translate(parse('(define-primitive "inc" :params (n) ...)'))
|
||||
"""
|
||||
from __future__ import annotations
|
||||
|
||||
import os
|
||||
from typing import Any
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Load z3.sx into an evaluator environment (cached)
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
_z3_env: dict[str, Any] | None = None
|
||||
|
||||
|
||||
def _get_z3_env() -> dict[str, Any]:
|
||||
"""Load and evaluate z3.sx, returning the environment with all z3-* functions.
|
||||
|
||||
Platform primitives (type-of, symbol-name, keyword-name) are registered
|
||||
in primitives.py. z3.sx uses canonical primitive names (get, assoc) so
|
||||
no additional bindings are needed.
|
||||
"""
|
||||
global _z3_env
|
||||
if _z3_env is not None:
|
||||
return _z3_env
|
||||
|
||||
from shared.sx.parser import parse_all
|
||||
from shared.sx.ref.sx_ref import make_env, eval_expr as _eval, trampoline as _trampoline
|
||||
|
||||
env = make_env()
|
||||
z3_path = os.path.join(os.path.dirname(__file__), "z3.sx")
|
||||
with open(z3_path, encoding="utf-8") as f:
|
||||
for expr in parse_all(f.read()):
|
||||
_trampoline(_eval(expr, env))
|
||||
|
||||
_z3_env = env
|
||||
return env
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Public API
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
def z3_translate(expr: Any) -> str:
|
||||
"""Translate an SX define-* form to SMT-LIB.
|
||||
|
||||
Delegates to z3-translate defined in z3.sx.
|
||||
"""
|
||||
from shared.sx.ref.sx_ref import trampoline as _trampoline, call_lambda as _call_lambda
|
||||
|
||||
env = _get_z3_env()
|
||||
return _trampoline(_call_lambda(env["z3-translate"], [expr], env))
|
||||
|
||||
|
||||
def z3_translate_file(source: str) -> str:
|
||||
"""Parse an SX spec file and translate all define-* forms to SMT-LIB.
|
||||
|
||||
Delegates to z3-translate-file defined in z3.sx.
|
||||
"""
|
||||
from shared.sx.parser import parse_all
|
||||
from shared.sx.ref.sx_ref import trampoline as _trampoline, call_lambda as _call_lambda
|
||||
|
||||
env = _get_z3_env()
|
||||
exprs = parse_all(source)
|
||||
return _trampoline(_call_lambda(env["z3-translate-file"], [exprs], env))
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Reader macro registration
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
def register_z3_macro():
|
||||
"""Register #z3 as a reader macro in the SX parser."""
|
||||
from shared.sx.parser import register_reader_macro
|
||||
register_reader_macro("z3", z3_translate)
|
||||
@@ -1,122 +0,0 @@
|
||||
#!/usr/bin/env python3
|
||||
"""
|
||||
Bootstrap runner: execute py.sx against spec files to produce sx_ref.py.
|
||||
|
||||
This is the G1 bootstrapper — py.sx (SX-to-Python translator written in SX)
|
||||
is loaded into the Python evaluator, which then uses it to translate the
|
||||
spec .sx files into Python.
|
||||
|
||||
The output should be identical to: python bootstrap_py.py
|
||||
|
||||
Usage:
|
||||
python run_py_sx.py > sx_ref_g1.py
|
||||
"""
|
||||
from __future__ import annotations
|
||||
|
||||
import os
|
||||
import sys
|
||||
|
||||
_HERE = os.path.dirname(os.path.abspath(__file__))
|
||||
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", "..", ".."))
|
||||
sys.path.insert(0, _PROJECT)
|
||||
|
||||
from shared.sx.parser import parse_all
|
||||
from shared.sx.types import Symbol
|
||||
from shared.sx.ref.platform_py import (
|
||||
PREAMBLE, PLATFORM_PY, PRIMITIVES_PY_PRE, PRIMITIVES_PY_POST,
|
||||
PLATFORM_DEPS_PY, FIXUPS_PY, CONTINUATIONS_PY,
|
||||
_assemble_primitives_py, public_api_py,
|
||||
)
|
||||
|
||||
|
||||
def load_py_sx(evaluator_env: dict) -> dict:
|
||||
"""Load py.sx into an evaluator environment and return it."""
|
||||
py_sx_path = os.path.join(_HERE, "py.sx")
|
||||
with open(py_sx_path) as f:
|
||||
source = f.read()
|
||||
|
||||
exprs = parse_all(source)
|
||||
|
||||
# Import the evaluator
|
||||
from shared.sx.ref.sx_ref import evaluate, make_env
|
||||
|
||||
env = make_env()
|
||||
for expr in exprs:
|
||||
evaluate(expr, env)
|
||||
|
||||
return env
|
||||
|
||||
|
||||
def extract_defines(source: str) -> list[tuple[str, list]]:
|
||||
"""Parse .sx source, return list of (name, define-expr) for top-level defines."""
|
||||
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))
|
||||
return defines
|
||||
|
||||
|
||||
def main():
|
||||
from shared.sx.ref.sx_ref import evaluate
|
||||
|
||||
# Load py.sx into evaluator
|
||||
env = load_py_sx({})
|
||||
|
||||
# Get the py-translate-file function
|
||||
py_translate_file = env.get("py-translate-file")
|
||||
if py_translate_file is None:
|
||||
print("ERROR: py-translate-file not found in py.sx environment", file=sys.stderr)
|
||||
sys.exit(1)
|
||||
|
||||
# Same file list and order as bootstrap_py.py compile_ref_to_py()
|
||||
sx_files = [
|
||||
("eval.sx", "eval"),
|
||||
("forms.sx", "forms (server definition forms)"),
|
||||
("render.sx", "render (core)"),
|
||||
("adapter-html.sx", "adapter-html"),
|
||||
("adapter-sx.sx", "adapter-sx"),
|
||||
("deps.sx", "deps (component dependency analysis)"),
|
||||
("signals.sx", "signals (reactive signal runtime)"),
|
||||
]
|
||||
|
||||
# Build output — static sections are identical
|
||||
parts = []
|
||||
parts.append(PREAMBLE)
|
||||
parts.append(PLATFORM_PY)
|
||||
parts.append(PRIMITIVES_PY_PRE)
|
||||
parts.append(_assemble_primitives_py(None))
|
||||
parts.append(PRIMITIVES_PY_POST)
|
||||
parts.append(PLATFORM_DEPS_PY)
|
||||
|
||||
# Translate each spec file using py.sx
|
||||
for filename, label in sx_files:
|
||||
filepath = os.path.join(_HERE, filename)
|
||||
if not os.path.exists(filepath):
|
||||
continue
|
||||
with open(filepath) as f:
|
||||
src = f.read()
|
||||
defines = extract_defines(src)
|
||||
|
||||
# Convert defines to SX-compatible format: list of [name, expr] pairs
|
||||
sx_defines = [[name, expr] for name, expr in defines]
|
||||
|
||||
parts.append(f"\n# === Transpiled from {label} ===\n")
|
||||
# Bind defines as data in env to avoid evaluator trying to execute AST
|
||||
env["_defines"] = sx_defines
|
||||
result = evaluate(
|
||||
[Symbol("py-translate-file"), Symbol("_defines")],
|
||||
env,
|
||||
)
|
||||
parts.append(result)
|
||||
|
||||
parts.append(FIXUPS_PY)
|
||||
parts.append(public_api_py(True, True, True))
|
||||
|
||||
print("\n".join(parts))
|
||||
|
||||
|
||||
if __name__ == "__main__":
|
||||
main()
|
||||
File diff suppressed because it is too large
Load Diff
@@ -1,358 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; z3.sx — SX spec to SMT-LIB translator, written in SX
|
||||
;;
|
||||
;; Translates define-primitive, define-io-primitive, and define-special-form
|
||||
;; declarations from the SX spec into SMT-LIB verification conditions for
|
||||
;; Z3 and other theorem provers.
|
||||
;;
|
||||
;; This is the first self-hosted bootstrapper: the SX evaluator (itself
|
||||
;; bootstrapped from eval.sx) executes this file against the spec to
|
||||
;; produce output in a different language. Same pattern as bootstrap_js.py
|
||||
;; and bootstrap_py.py, but written in SX instead of Python.
|
||||
;;
|
||||
;; Usage (from SX):
|
||||
;; (z3-translate expr) — translate one define-* form
|
||||
;; (z3-translate-file exprs) — translate a list of parsed expressions
|
||||
;;
|
||||
;; Usage (as reader macro):
|
||||
;; #z3(define-primitive "inc" :params (n) :returns "number" :body (+ n 1))
|
||||
;; → "; inc — ...\n(declare-fun inc (Int) Int)\n..."
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Type mapping: SX type names → SMT-LIB sorts
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define z3-sort
|
||||
(fn ((sx-type :as string))
|
||||
(case sx-type
|
||||
"number" "Int"
|
||||
"boolean" "Bool"
|
||||
"string" "String"
|
||||
"list" "(List Value)"
|
||||
"dict" "(Array String Value)"
|
||||
:else "Value")))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Name translation: SX identifiers → SMT-LIB identifiers
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define z3-name
|
||||
(fn ((name :as string))
|
||||
(cond
|
||||
(= name "!=") "neq"
|
||||
(= name "+") "+"
|
||||
(= name "-") "-"
|
||||
(= name "*") "*"
|
||||
(= name "/") "/"
|
||||
(= name "=") "="
|
||||
(= name "<") "<"
|
||||
(= name ">") ">"
|
||||
(= name "<=") "<="
|
||||
(= name ">=") ">="
|
||||
:else (replace (replace (replace name "-" "_") "?" "_p") "!" "_bang"))))
|
||||
|
||||
(define z3-sym
|
||||
(fn (sym)
|
||||
(let ((name (symbol-name sym)))
|
||||
(cond
|
||||
(ends-with? name "?")
|
||||
(str "is_" (replace (slice name 0 (- (string-length name) 1)) "-" "_"))
|
||||
:else
|
||||
(replace (replace name "-" "_") "!" "_bang")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Expression translation: SX body expressions → SMT-LIB s-expressions
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Operators that pass through unchanged
|
||||
(define z3-identity-ops
|
||||
(list "+" "-" "*" "/" "=" "!=" "<" ">" "<=" ">=" "and" "or" "not" "mod"))
|
||||
|
||||
;; Operators that get renamed
|
||||
(define z3-rename-op
|
||||
(fn ((op :as string))
|
||||
(case op
|
||||
"if" "ite"
|
||||
"str" "str.++"
|
||||
:else nil)))
|
||||
|
||||
(define z3-expr
|
||||
(fn (expr)
|
||||
(cond
|
||||
;; Numbers
|
||||
(number? expr)
|
||||
(str expr)
|
||||
|
||||
;; Strings
|
||||
(string? expr)
|
||||
(str "\"" expr "\"")
|
||||
|
||||
;; Booleans
|
||||
(= expr true) "true"
|
||||
(= expr false) "false"
|
||||
|
||||
;; Nil
|
||||
(nil? expr)
|
||||
"nil_val"
|
||||
|
||||
;; Symbols
|
||||
(= (type-of expr) "symbol")
|
||||
(z3-sym expr)
|
||||
|
||||
;; Lists (function calls / special forms)
|
||||
(list? expr)
|
||||
(if (empty? expr)
|
||||
"()"
|
||||
(let ((head (first expr))
|
||||
(args (rest expr)))
|
||||
(if (not (= (type-of head) "symbol"))
|
||||
(str expr)
|
||||
(let ((op (symbol-name head)))
|
||||
(cond
|
||||
;; Identity ops: same syntax in both languages
|
||||
(some (fn (x) (= x op)) z3-identity-ops)
|
||||
(str "(" op " " (join " " (map z3-expr args)) ")")
|
||||
|
||||
;; Renamed ops
|
||||
(not (nil? (z3-rename-op op)))
|
||||
(str "(" (z3-rename-op op) " " (join " " (map z3-expr args)) ")")
|
||||
|
||||
;; max → ite
|
||||
(and (= op "max") (= (len args) 2))
|
||||
(let ((a (z3-expr (nth args 0)))
|
||||
(b (z3-expr (nth args 1))))
|
||||
(str "(ite (>= " a " " b ") " a " " b ")"))
|
||||
|
||||
;; min → ite
|
||||
(and (= op "min") (= (len args) 2))
|
||||
(let ((a (z3-expr (nth args 0)))
|
||||
(b (z3-expr (nth args 1))))
|
||||
(str "(ite (<= " a " " b ") " a " " b ")"))
|
||||
|
||||
;; empty? → length check
|
||||
(= op "empty?")
|
||||
(str "(= (len " (z3-expr (first args)) ") 0)")
|
||||
|
||||
;; first/rest → list ops
|
||||
(= op "first")
|
||||
(str "(head " (z3-expr (first args)) ")")
|
||||
(= op "rest")
|
||||
(str "(tail " (z3-expr (first args)) ")")
|
||||
|
||||
;; reduce with initial value
|
||||
(and (= op "reduce") (>= (len args) 3))
|
||||
(str "(reduce " (z3-expr (nth args 0)) " "
|
||||
(z3-expr (nth args 2)) " "
|
||||
(z3-expr (nth args 1)) ")")
|
||||
|
||||
;; fn (lambda)
|
||||
(= op "fn")
|
||||
(let ((params (first args))
|
||||
(body (nth args 1)))
|
||||
(str "(lambda (("
|
||||
(join " " (map (fn (p) (str "(" (z3-sym p) " Int)")) params))
|
||||
")) " (z3-expr body) ")"))
|
||||
|
||||
;; native-* → strip prefix
|
||||
(starts-with? op "native-")
|
||||
(str "(" (slice op 7 (string-length op)) " "
|
||||
(join " " (map z3-expr args)) ")")
|
||||
|
||||
;; Generic function call
|
||||
:else
|
||||
(str "(" (z3-name op) " "
|
||||
(join " " (map z3-expr args)) ")"))))))
|
||||
|
||||
;; Fallback
|
||||
:else (str expr))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Keyword argument extraction from define-* forms
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define z3-extract-kwargs
|
||||
(fn ((expr :as list))
|
||||
;; Returns a dict of keyword args from a define-* form
|
||||
;; (define-primitive "name" :params (...) :returns "type" ...) → {:params ... :returns ...}
|
||||
(let ((result {})
|
||||
(items (rest (rest expr)))) ;; skip head and name
|
||||
(z3-extract-kwargs-loop items result))))
|
||||
|
||||
(define z3-extract-kwargs-loop
|
||||
(fn ((items :as list) (result :as dict))
|
||||
(if (or (empty? items) (< (len items) 2))
|
||||
result
|
||||
(if (= (type-of (first items)) "keyword")
|
||||
(z3-extract-kwargs-loop
|
||||
(rest (rest items))
|
||||
(assoc result (keyword-name (first items)) (nth items 1)))
|
||||
(z3-extract-kwargs-loop (rest items) result)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Parameter processing
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define z3-params-to-sorts
|
||||
(fn ((params :as list))
|
||||
;; Convert SX param list to list of (name sort) pairs, skipping &rest/&key
|
||||
(z3-params-loop params false (list))))
|
||||
|
||||
(define z3-params-loop
|
||||
(fn ((params :as list) (skip-next :as boolean) (acc :as list))
|
||||
(if (empty? params)
|
||||
acc
|
||||
(let ((p (first params))
|
||||
(rest-p (rest params)))
|
||||
(cond
|
||||
;; &rest or &key marker — skip it and the next param
|
||||
(and (= (type-of p) "symbol")
|
||||
(or (= (symbol-name p) "&rest")
|
||||
(= (symbol-name p) "&key")))
|
||||
(z3-params-loop rest-p true acc)
|
||||
;; Skipping the param after &rest/&key
|
||||
skip-next
|
||||
(z3-params-loop rest-p false acc)
|
||||
;; Normal parameter
|
||||
(= (type-of p) "symbol")
|
||||
(z3-params-loop rest-p false
|
||||
(append acc (list (list (symbol-name p) "Int"))))
|
||||
;; Something else — skip
|
||||
:else
|
||||
(z3-params-loop rest-p false acc))))))
|
||||
|
||||
(define z3-has-rest?
|
||||
(fn ((params :as list))
|
||||
(some (fn (p) (and (= (type-of p) "symbol") (= (symbol-name p) "&rest")))
|
||||
params)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; define-primitive → SMT-LIB
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define z3-translate-primitive
|
||||
(fn ((expr :as list))
|
||||
(let ((name (nth expr 1))
|
||||
(kwargs (z3-extract-kwargs expr))
|
||||
(params (or (get kwargs "params") (list)))
|
||||
(returns (or (get kwargs "returns") "any"))
|
||||
(doc (or (get kwargs "doc") ""))
|
||||
(body (get kwargs "body"))
|
||||
(pairs (z3-params-to-sorts params))
|
||||
(has-rest (z3-has-rest? params))
|
||||
(smt-name (z3-name name)))
|
||||
|
||||
(str
|
||||
;; Comment header
|
||||
"; " name " — " doc "\n"
|
||||
|
||||
;; Declaration
|
||||
(if has-rest
|
||||
(str "; (variadic — modeled as uninterpreted)\n"
|
||||
"(declare-fun " smt-name " (Int Int) " (z3-sort returns) ")")
|
||||
(str "(declare-fun " smt-name " ("
|
||||
(join " " (map (fn (pair) (nth pair 1)) pairs))
|
||||
") " (z3-sort returns) ")"))
|
||||
"\n"
|
||||
|
||||
;; Assertion (if body exists and not variadic)
|
||||
(if (and (not (nil? body)) (not has-rest))
|
||||
(if (empty? pairs)
|
||||
;; No params — simple assertion
|
||||
(str "(assert (= (" smt-name ") " (z3-expr body) "))\n")
|
||||
;; With params — forall
|
||||
(let ((bindings (join " " (map (fn (pair) (str "(" (nth pair 0) " Int)")) pairs)))
|
||||
(call-args (join " " (map (fn (pair) (nth pair 0)) pairs))))
|
||||
(str "(assert (forall ((" bindings "))\n"
|
||||
" (= (" smt-name " " call-args ") " (z3-expr body) ")))\n")))
|
||||
"")
|
||||
|
||||
;; Check satisfiability
|
||||
"(check-sat)"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; define-io-primitive → SMT-LIB
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define z3-translate-io
|
||||
(fn ((expr :as list))
|
||||
(let ((name (nth expr 1))
|
||||
(kwargs (z3-extract-kwargs expr))
|
||||
(doc (or (get kwargs "doc") ""))
|
||||
(smt-name (replace (replace name "-" "_") "?" "_p")))
|
||||
(str "; IO primitive: " name " — " doc "\n"
|
||||
"; (uninterpreted — IO cannot be verified statically)\n"
|
||||
"(declare-fun " smt-name " () Value)"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; define-special-form → SMT-LIB
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define z3-translate-special-form
|
||||
(fn ((expr :as list))
|
||||
(let ((name (nth expr 1))
|
||||
(kwargs (z3-extract-kwargs expr))
|
||||
(doc (or (get kwargs "doc") "")))
|
||||
(case name
|
||||
"if"
|
||||
(str "; Special form: if — " doc "\n"
|
||||
"(assert (forall ((c Bool) (t Value) (e Value))\n"
|
||||
" (= (sx_if c t e) (ite c t e))))\n"
|
||||
"(check-sat)")
|
||||
"when"
|
||||
(str "; Special form: when — " doc "\n"
|
||||
"(assert (forall ((c Bool) (body Value))\n"
|
||||
" (= (sx_when c body) (ite c body nil_val))))\n"
|
||||
"(check-sat)")
|
||||
:else
|
||||
(str "; Special form: " name " — " doc "\n"
|
||||
"; (not directly expressible in SMT-LIB)")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Top-level dispatch
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define z3-translate
|
||||
(fn (expr)
|
||||
(if (not (list? expr))
|
||||
"; Cannot translate: not a list form"
|
||||
(if (< (len expr) 2)
|
||||
"; Cannot translate: too short"
|
||||
(let ((head (first expr)))
|
||||
(if (not (= (type-of head) "symbol"))
|
||||
"; Cannot translate: head is not a symbol"
|
||||
(case (symbol-name head)
|
||||
"define-primitive" (z3-translate-primitive expr)
|
||||
"define-io-primitive" (z3-translate-io expr)
|
||||
"define-special-form" (z3-translate-special-form expr)
|
||||
:else (z3-expr expr))))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Batch translation: process a list of parsed expressions
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define z3-translate-file
|
||||
(fn ((exprs :as list))
|
||||
;; Filter to translatable forms and translate each
|
||||
(let ((translatable
|
||||
(filter
|
||||
(fn (expr)
|
||||
(and (list? expr)
|
||||
(>= (len expr) 2)
|
||||
(= (type-of (first expr)) "symbol")
|
||||
(let ((name (symbol-name (first expr))))
|
||||
(or (= name "define-primitive")
|
||||
(= name "define-io-primitive")
|
||||
(= name "define-special-form")))))
|
||||
exprs)))
|
||||
(join "\n\n" (map z3-translate translatable)))))
|
||||
@@ -31,7 +31,10 @@ import asyncio
|
||||
from typing import Any
|
||||
|
||||
from .types import Component, Keyword, Lambda, NIL, Symbol
|
||||
from .ref.sx_ref import eval_expr as _raw_eval, trampoline as _trampoline
|
||||
# sx_ref.py removed — stub so module loads. OCaml bridge handles evaluation.
|
||||
def _not_available(*a, **kw):
|
||||
raise RuntimeError("sx_ref.py has been removed — use SX_USE_OCAML=1")
|
||||
_raw_eval = _trampoline = _not_available
|
||||
|
||||
def _eval(expr, env):
|
||||
"""Evaluate and unwrap thunks — all resolver.py _eval calls are non-tail."""
|
||||
|
||||
@@ -468,7 +468,7 @@
|
||||
;; (div (~cssx/tw "bg-red-500") (~cssx/tw "p-4") "content")
|
||||
;; =========================================================================
|
||||
|
||||
(defcomp ~cssx/tw (tokens)
|
||||
(defcomp ~cssx/tw (&key tokens)
|
||||
(let ((token-list (filter (fn (t) (not (= t "")))
|
||||
(split (or tokens "") " ")))
|
||||
(results (map cssx-process-token token-list))
|
||||
@@ -493,8 +493,14 @@
|
||||
;; (~cssx/flush)
|
||||
;; =========================================================================
|
||||
|
||||
(defcomp ~cssx/flush ()
|
||||
(let ((rules (collected "cssx")))
|
||||
(clear-collected! "cssx")
|
||||
(when (not (empty? rules))
|
||||
(raw! (str "<style data-cssx>" (join "" rules) "</style>")))))
|
||||
(defcomp ~cssx/flush () :affinity :client
|
||||
(let ((rules (collected "cssx"))
|
||||
(head-style (dom-query "#sx-css")))
|
||||
;; On client: append rules to <style id="sx-css"> in <head>.
|
||||
;; On server: head-style is nil (no DOM). Don't clear the bucket —
|
||||
;; the shell's <head> template reads collected("cssx") and emits them.
|
||||
(when head-style
|
||||
(clear-collected! "cssx")
|
||||
(when (not (empty? rules))
|
||||
(dom-set-prop head-style "textContent"
|
||||
(str (dom-get-prop head-style "textContent") (join "" rules)))))))
|
||||
|
||||
@@ -1,4 +1,4 @@
|
||||
(defcomp ~shared:layout/app-body (&key header-rows filter aside menu content)
|
||||
(defcomp ~shared:layout/app-body (&key header-rows filter aside menu content) :affinity :server
|
||||
(div :class "max-w-screen-2xl mx-auto py-1 px-1"
|
||||
(when header-rows
|
||||
(div :class "w-full"
|
||||
@@ -24,7 +24,7 @@
|
||||
(when content content)
|
||||
(div :class "pb-8")))))))
|
||||
|
||||
(defcomp ~shared:layout/oob-sx (&key oobs filter aside menu content)
|
||||
(defcomp ~shared:layout/oob-sx (&key oobs filter aside menu content) :affinity :server
|
||||
(<>
|
||||
(when oobs oobs)
|
||||
(div :id "filter" :sx-swap-oob "outerHTML"
|
||||
|
||||
@@ -15,6 +15,7 @@
|
||||
(sx-css :as string?) (sx-css-classes :as string?)
|
||||
(component-hash :as string?) (component-defs :as string?)
|
||||
(pages-sx :as string?) (page-sx :as string?)
|
||||
(body-html :as string?)
|
||||
(asset-url :as string) (sx-js-hash :as string) (body-js-hash :as string?)
|
||||
(head-scripts :as list?) (inline-css :as string?) (inline-head-js :as string?)
|
||||
(init-sx :as string?) (body-scripts :as list?))
|
||||
@@ -30,6 +31,12 @@
|
||||
(when meta-html (raw! meta-html))
|
||||
(meta :name "csrf-token" :content csrf)
|
||||
(style :id "sx-css" (raw! (or sx-css "")))
|
||||
;; CSSX rules from island SSR — must be in <head> so they survive
|
||||
;; #main-panel morphs during SPA navigation.
|
||||
(let ((cssx-rules (collected "cssx")))
|
||||
(clear-collected! "cssx")
|
||||
(when (not (empty? cssx-rules))
|
||||
(style :data-cssx true (raw! (join "" cssx-rules)))))
|
||||
(meta :name "sx-css-classes" :content (or sx-css-classes ""))
|
||||
;; CDN / head scripts — configurable per app
|
||||
;; Pass a list (even empty) to override defaults; nil = use defaults
|
||||
@@ -65,6 +72,8 @@ details.group{overflow:hidden}details.group>summary{list-style:none}details.grou
|
||||
.sx-error .sx-indicator{display:none}.sx-loading .sx-indicator{display:inline-flex}
|
||||
.js-wrap.open .js-pop{display:block}.js-wrap.open .js-backdrop{display:block}"))))
|
||||
(body :class "bg-stone-50 text-stone-900"
|
||||
;; Server-rendered HTML — visible immediately before JS loads
|
||||
(div :id "sx-root" (raw! (or body-html "")))
|
||||
(script :type "text/sx" :data-components true :data-hash component-hash
|
||||
(raw! (or component-defs "")))
|
||||
(when init-sx
|
||||
@@ -72,7 +81,7 @@ details.group{overflow:hidden}details.group>summary{list-style:none}details.grou
|
||||
(raw! init-sx)))
|
||||
(script :type "text/sx-pages"
|
||||
(raw! (or pages-sx "")))
|
||||
(script :type "text/sx" :data-mount "body"
|
||||
(script :type "text/sx" :data-mount "#sx-root"
|
||||
(raw! (or page-sx "")))
|
||||
(script :src (str asset-url "/scripts/sx-browser.js?v=" sx-js-hash))
|
||||
;; Body scripts — configurable per app
|
||||
|
||||
168
shared/sx/tests/generate_golden.py
Normal file
168
shared/sx/tests/generate_golden.py
Normal file
@@ -0,0 +1,168 @@
|
||||
"""Generate golden HTML/aser test data from the Python evaluator.
|
||||
|
||||
Evaluates curated component calls through the Python ref evaluator and
|
||||
writes golden_data.json — a list of {name, sx_input, expected_html,
|
||||
expected_aser} triples.
|
||||
|
||||
Usage:
|
||||
python3 shared/sx/tests/generate_golden.py
|
||||
"""
|
||||
|
||||
import asyncio
|
||||
import json
|
||||
import os
|
||||
import sys
|
||||
|
||||
_project_root = os.path.abspath(os.path.join(os.path.dirname(__file__), "../../.."))
|
||||
if _project_root not in sys.path:
|
||||
sys.path.insert(0, _project_root)
|
||||
|
||||
|
||||
# Curated test cases — component calls and plain expressions that
|
||||
# exercise the rendering pipeline. Each entry is (name, sx_input).
|
||||
GOLDEN_CASES = [
|
||||
# --- Basic HTML rendering ---
|
||||
("div_simple", '(div "hello")'),
|
||||
("div_class", '(div :class "card" "content")'),
|
||||
("p_text", '(p "paragraph text")'),
|
||||
("nested_tags", '(div (p "a") (p "b"))'),
|
||||
("void_br", "(br)"),
|
||||
("void_hr", "(hr)"),
|
||||
("void_img", '(img :src "/photo.jpg" :alt "A photo")'),
|
||||
("void_input", '(input :type "text" :name "q" :placeholder "Search")'),
|
||||
("fragment", '(<> (p "a") (p "b"))'),
|
||||
("boolean_attr", '(input :type "checkbox" :checked true)'),
|
||||
("nil_attr", '(div :class nil "content")'),
|
||||
("empty_string_attr", '(div :class "" "visible")'),
|
||||
|
||||
# --- Control flow ---
|
||||
("if_true", '(if true (p "yes") (p "no"))'),
|
||||
("if_false", '(if false (p "yes") (p "no"))'),
|
||||
("when_true", '(when true (p "shown"))'),
|
||||
("when_false", '(when false (p "hidden"))'),
|
||||
("let_binding", '(let ((x "hi")) (p x))'),
|
||||
("let_multiple", '(let ((x "a") (y "b")) (div (p x) (p y)))'),
|
||||
("cond_form", '(cond (= 1 2) (p "no") (= 1 1) (p "yes") :else (p "default"))'),
|
||||
("case_form", '(case "b" "a" "A" "b" "B" :else "?")'),
|
||||
("and_short", '(and true false)'),
|
||||
("or_short", '(or false "found")'),
|
||||
|
||||
# --- Higher-order forms ---
|
||||
("map_li", '(map (fn (x) (li x)) (list "a" "b" "c"))'),
|
||||
("filter_even", '(filter even? (list 1 2 3 4 5))'),
|
||||
("reduce_sum", '(reduce + 0 (list 1 2 3 4 5))'),
|
||||
|
||||
# --- String operations ---
|
||||
("str_concat", '(str "hello" " " "world")'),
|
||||
("str_upcase", '(upcase "hello")'),
|
||||
|
||||
# --- Component definitions and calls ---
|
||||
("defcomp_simple",
|
||||
'(do (defcomp ~test-badge (&key label) (span :class "badge" label)) (~test-badge :label "New"))'),
|
||||
("defcomp_children",
|
||||
'(do (defcomp ~test-wrap (&rest children) (div :class "wrap" children)) (~test-wrap (p "inside")))'),
|
||||
("defcomp_multi_key",
|
||||
'(do (defcomp ~test-card (&key title subtitle) (div (h2 title) (when subtitle (p subtitle)))) '
|
||||
'(~test-card :title "Title" :subtitle "Sub"))'),
|
||||
("defcomp_no_optional",
|
||||
'(do (defcomp ~test-card2 (&key title subtitle) (div (h2 title) (when subtitle (p subtitle)))) '
|
||||
'(~test-card2 :title "Only Title"))'),
|
||||
|
||||
# --- Nested components ---
|
||||
("nested_components",
|
||||
'(do (defcomp ~inner (&key text) (span :class "inner" text)) '
|
||||
'(defcomp ~outer (&key title &rest children) (div :class "outer" (h2 title) children)) '
|
||||
'(~outer :title "Hello" (~inner :text "World")))'),
|
||||
|
||||
# --- Macros ---
|
||||
("macro_unless",
|
||||
'(do (defmacro unless (cond &rest body) (list \'if (list \'not cond) (cons \'do body))) '
|
||||
'(unless false (p "shown")))'),
|
||||
|
||||
# --- Special rendering patterns ---
|
||||
("do_block", '(div (do (p "a") (p "b")))'),
|
||||
("nil_child", '(div nil "after-nil")'),
|
||||
("number_child", '(div 42)'),
|
||||
("bool_child", '(div true)'),
|
||||
|
||||
# --- Data attributes ---
|
||||
("data_attr", '(div :data-id "123" :data-name "test" "content")'),
|
||||
|
||||
# --- raw! (inject pre-rendered HTML) ---
|
||||
("raw_simple", '(raw! "<b>bold</b>")'),
|
||||
("raw_in_div", '(div (raw! "<em>italic</em>"))'),
|
||||
("raw_component",
|
||||
'(do (defcomp ~rich (&key html) (raw! html)) '
|
||||
'(~rich :html "<p>CMS</p>"))'),
|
||||
|
||||
# --- Shared template components (if available) ---
|
||||
("misc_error_inline",
|
||||
'(do (defcomp ~shared:misc/error-inline (&key (message :as string)) '
|
||||
'(div :class "text-red-600 text-sm" message)) '
|
||||
'(~shared:misc/error-inline :message "Something went wrong"))'),
|
||||
("misc_notification_badge",
|
||||
'(do (defcomp ~shared:misc/notification-badge (&key (count :as number)) '
|
||||
'(span :class "bg-red-500 text-white text-xs rounded-full px-1.5 py-0.5" count)) '
|
||||
'(~shared:misc/notification-badge :count 5))'),
|
||||
("misc_cache_cleared",
|
||||
'(do (defcomp ~shared:misc/cache-cleared (&key (time-str :as string)) '
|
||||
'(span :class "text-green-600 font-bold" "Cache cleared at " time-str)) '
|
||||
'(~shared:misc/cache-cleared :time-str "12:00"))'),
|
||||
("misc_error_list_item",
|
||||
'(do (defcomp ~shared:misc/error-list-item (&key (message :as string)) (li message)) '
|
||||
'(~shared:misc/error-list-item :message "Bad input"))'),
|
||||
("misc_fragment_error",
|
||||
'(do (defcomp ~shared:misc/fragment-error (&key (service :as string)) '
|
||||
'(p :class "text-sm text-red-600" "Service " (b service) " is unavailable.")) '
|
||||
'(~shared:misc/fragment-error :service "blog"))'),
|
||||
]
|
||||
|
||||
|
||||
def _generate_html(sx_input: str) -> str:
|
||||
"""Evaluate SX and render to HTML using the Python evaluator."""
|
||||
from shared.sx.ref.sx_ref import evaluate, render
|
||||
from shared.sx.parser import parse_all
|
||||
|
||||
env = {}
|
||||
exprs = parse_all(sx_input)
|
||||
|
||||
# For multi-expression inputs (defcomp then call), use evaluate
|
||||
# to process all defs, then render the final expression
|
||||
if len(exprs) > 1:
|
||||
# Evaluate all expressions — defs install into env
|
||||
result = None
|
||||
for expr in exprs:
|
||||
result = evaluate(expr, env)
|
||||
# Render the final result
|
||||
return render(result, env)
|
||||
else:
|
||||
# Single expression — render directly
|
||||
return render(exprs[0], env)
|
||||
|
||||
|
||||
def main():
|
||||
golden = []
|
||||
ok = 0
|
||||
failed = 0
|
||||
for name, sx_input in GOLDEN_CASES:
|
||||
try:
|
||||
html = _generate_html(sx_input)
|
||||
golden.append({
|
||||
"name": name,
|
||||
"sx_input": sx_input,
|
||||
"expected_html": html,
|
||||
})
|
||||
ok += 1
|
||||
except Exception as e:
|
||||
print(f" SKIP {name}: {e}")
|
||||
failed += 1
|
||||
|
||||
outpath = os.path.join(os.path.dirname(__file__), "golden_data.json")
|
||||
with open(outpath, "w") as f:
|
||||
json.dump(golden, f, indent=2, ensure_ascii=False)
|
||||
|
||||
print(f"Generated {ok} golden cases ({failed} skipped) → {outpath}")
|
||||
|
||||
|
||||
if __name__ == "__main__":
|
||||
main()
|
||||
232
shared/sx/tests/golden_data.json
Normal file
232
shared/sx/tests/golden_data.json
Normal file
@@ -0,0 +1,232 @@
|
||||
[
|
||||
{
|
||||
"name": "div_simple",
|
||||
"sx_input": "(div \"hello\")",
|
||||
"expected_html": "<div>hello</div>"
|
||||
},
|
||||
{
|
||||
"name": "div_class",
|
||||
"sx_input": "(div :class \"card\" \"content\")",
|
||||
"expected_html": "<div class=\"card\">content</div>"
|
||||
},
|
||||
{
|
||||
"name": "p_text",
|
||||
"sx_input": "(p \"paragraph text\")",
|
||||
"expected_html": "<p>paragraph text</p>"
|
||||
},
|
||||
{
|
||||
"name": "nested_tags",
|
||||
"sx_input": "(div (p \"a\") (p \"b\"))",
|
||||
"expected_html": "<div><p>a</p><p>b</p></div>"
|
||||
},
|
||||
{
|
||||
"name": "void_br",
|
||||
"sx_input": "(br)",
|
||||
"expected_html": "<br />"
|
||||
},
|
||||
{
|
||||
"name": "void_hr",
|
||||
"sx_input": "(hr)",
|
||||
"expected_html": "<hr />"
|
||||
},
|
||||
{
|
||||
"name": "void_img",
|
||||
"sx_input": "(img :src \"/photo.jpg\" :alt \"A photo\")",
|
||||
"expected_html": "<img src=\"/photo.jpg\" alt=\"A photo\" />"
|
||||
},
|
||||
{
|
||||
"name": "void_input",
|
||||
"sx_input": "(input :type \"text\" :name \"q\" :placeholder \"Search\")",
|
||||
"expected_html": "<input type=\"text\" name=\"q\" placeholder=\"Search\" />"
|
||||
},
|
||||
{
|
||||
"name": "fragment",
|
||||
"sx_input": "(<> (p \"a\") (p \"b\"))",
|
||||
"expected_html": "<p>a</p><p>b</p>"
|
||||
},
|
||||
{
|
||||
"name": "boolean_attr",
|
||||
"sx_input": "(input :type \"checkbox\" :checked true)",
|
||||
"expected_html": "<input type=\"checkbox\" checked />"
|
||||
},
|
||||
{
|
||||
"name": "nil_attr",
|
||||
"sx_input": "(div :class nil \"content\")",
|
||||
"expected_html": "<div>content</div>"
|
||||
},
|
||||
{
|
||||
"name": "empty_string_attr",
|
||||
"sx_input": "(div :class \"\" \"visible\")",
|
||||
"expected_html": "<div class=\"\">visible</div>"
|
||||
},
|
||||
{
|
||||
"name": "if_true",
|
||||
"sx_input": "(if true (p \"yes\") (p \"no\"))",
|
||||
"expected_html": "<p>yes</p>"
|
||||
},
|
||||
{
|
||||
"name": "if_false",
|
||||
"sx_input": "(if false (p \"yes\") (p \"no\"))",
|
||||
"expected_html": "<p>no</p>"
|
||||
},
|
||||
{
|
||||
"name": "when_true",
|
||||
"sx_input": "(when true (p \"shown\"))",
|
||||
"expected_html": "<p>shown</p>"
|
||||
},
|
||||
{
|
||||
"name": "when_false",
|
||||
"sx_input": "(when false (p \"hidden\"))",
|
||||
"expected_html": ""
|
||||
},
|
||||
{
|
||||
"name": "let_binding",
|
||||
"sx_input": "(let ((x \"hi\")) (p x))",
|
||||
"expected_html": "<p>hi</p>"
|
||||
},
|
||||
{
|
||||
"name": "let_multiple",
|
||||
"sx_input": "(let ((x \"a\") (y \"b\")) (div (p x) (p y)))",
|
||||
"expected_html": "<div><p>a</p><p>b</p></div>"
|
||||
},
|
||||
{
|
||||
"name": "cond_form",
|
||||
"sx_input": "(cond (= 1 2) (p \"no\") (= 1 1) (p \"yes\") :else (p \"default\"))",
|
||||
"expected_html": "<p>yes</p>"
|
||||
},
|
||||
{
|
||||
"name": "case_form",
|
||||
"sx_input": "(case \"b\" \"a\" \"A\" \"b\" \"B\" :else \"?\")",
|
||||
"expected_html": "B"
|
||||
},
|
||||
{
|
||||
"name": "and_short",
|
||||
"sx_input": "(and true false)",
|
||||
"expected_html": "false"
|
||||
},
|
||||
{
|
||||
"name": "or_short",
|
||||
"sx_input": "(or false \"found\")",
|
||||
"expected_html": "found"
|
||||
},
|
||||
{
|
||||
"name": "map_li",
|
||||
"sx_input": "(map (fn (x) (li x)) (list \"a\" \"b\" \"c\"))",
|
||||
"expected_html": "<li>a</li><li>b</li><li>c</li>"
|
||||
},
|
||||
{
|
||||
"name": "filter_even",
|
||||
"sx_input": "(filter even? (list 1 2 3 4 5))",
|
||||
"expected_html": "<filter><function <lambda> at 0x7c1551c5fe20>12345</filter>"
|
||||
},
|
||||
{
|
||||
"name": "reduce_sum",
|
||||
"sx_input": "(reduce + 0 (list 1 2 3 4 5))",
|
||||
"expected_html": "15"
|
||||
},
|
||||
{
|
||||
"name": "str_concat",
|
||||
"sx_input": "(str \"hello\" \" \" \"world\")",
|
||||
"expected_html": "hello world"
|
||||
},
|
||||
{
|
||||
"name": "str_upcase",
|
||||
"sx_input": "(upcase \"hello\")",
|
||||
"expected_html": "HELLO"
|
||||
},
|
||||
{
|
||||
"name": "defcomp_simple",
|
||||
"sx_input": "(do (defcomp ~test-badge (&key label) (span :class \"badge\" label)) (~test-badge :label \"New\"))",
|
||||
"expected_html": "<span class=\"badge\">New</span>"
|
||||
},
|
||||
{
|
||||
"name": "defcomp_children",
|
||||
"sx_input": "(do (defcomp ~test-wrap (&rest children) (div :class \"wrap\" children)) (~test-wrap (p \"inside\")))",
|
||||
"expected_html": "<div class=\"wrap\"><p>inside</p></div>"
|
||||
},
|
||||
{
|
||||
"name": "defcomp_multi_key",
|
||||
"sx_input": "(do (defcomp ~test-card (&key title subtitle) (div (h2 title) (when subtitle (p subtitle)))) (~test-card :title \"Title\" :subtitle \"Sub\"))",
|
||||
"expected_html": "<div><h2>Title</h2><p>Sub</p></div>"
|
||||
},
|
||||
{
|
||||
"name": "defcomp_no_optional",
|
||||
"sx_input": "(do (defcomp ~test-card2 (&key title subtitle) (div (h2 title) (when subtitle (p subtitle)))) (~test-card2 :title \"Only Title\"))",
|
||||
"expected_html": "<div><h2>Only Title</h2></div>"
|
||||
},
|
||||
{
|
||||
"name": "nested_components",
|
||||
"sx_input": "(do (defcomp ~inner (&key text) (span :class \"inner\" text)) (defcomp ~outer (&key title &rest children) (div :class \"outer\" (h2 title) children)) (~outer :title \"Hello\" (~inner :text \"World\")))",
|
||||
"expected_html": "<div class=\"outer\"><h2>Hello</h2><span class=\"inner\">World</span></div>"
|
||||
},
|
||||
{
|
||||
"name": "macro_unless",
|
||||
"sx_input": "(do (defmacro unless (cond &rest body) (list 'if (list 'not cond) (cons 'do body))) (unless false (p \"shown\")))",
|
||||
"expected_html": "<p>shown</p>"
|
||||
},
|
||||
{
|
||||
"name": "do_block",
|
||||
"sx_input": "(div (do (p \"a\") (p \"b\")))",
|
||||
"expected_html": "<div><p>a</p><p>b</p></div>"
|
||||
},
|
||||
{
|
||||
"name": "nil_child",
|
||||
"sx_input": "(div nil \"after-nil\")",
|
||||
"expected_html": "<div>after-nil</div>"
|
||||
},
|
||||
{
|
||||
"name": "number_child",
|
||||
"sx_input": "(div 42)",
|
||||
"expected_html": "<div>42</div>"
|
||||
},
|
||||
{
|
||||
"name": "bool_child",
|
||||
"sx_input": "(div true)",
|
||||
"expected_html": "<div>true</div>"
|
||||
},
|
||||
{
|
||||
"name": "data_attr",
|
||||
"sx_input": "(div :data-id \"123\" :data-name \"test\" \"content\")",
|
||||
"expected_html": "<div data-id=\"123\" data-name=\"test\">content</div>"
|
||||
},
|
||||
{
|
||||
"name": "raw_simple",
|
||||
"sx_input": "(raw! \"<b>bold</b>\")",
|
||||
"expected_html": "<b>bold</b>"
|
||||
},
|
||||
{
|
||||
"name": "raw_in_div",
|
||||
"sx_input": "(div (raw! \"<em>italic</em>\"))",
|
||||
"expected_html": "<div><em>italic</em></div>"
|
||||
},
|
||||
{
|
||||
"name": "raw_component",
|
||||
"sx_input": "(do (defcomp ~rich (&key html) (raw! html)) (~rich :html \"<p>CMS</p>\"))",
|
||||
"expected_html": "<p>CMS</p>"
|
||||
},
|
||||
{
|
||||
"name": "misc_error_inline",
|
||||
"sx_input": "(do (defcomp ~shared:misc/error-inline (&key (message :as string)) (div :class \"text-red-600 text-sm\" message)) (~shared:misc/error-inline :message \"Something went wrong\"))",
|
||||
"expected_html": "<div class=\"text-red-600 text-sm\">Something went wrong</div>"
|
||||
},
|
||||
{
|
||||
"name": "misc_notification_badge",
|
||||
"sx_input": "(do (defcomp ~shared:misc/notification-badge (&key (count :as number)) (span :class \"bg-red-500 text-white text-xs rounded-full px-1.5 py-0.5\" count)) (~shared:misc/notification-badge :count 5))",
|
||||
"expected_html": "<span class=\"bg-red-500 text-white text-xs rounded-full px-1.5 py-0.5\">5</span>"
|
||||
},
|
||||
{
|
||||
"name": "misc_cache_cleared",
|
||||
"sx_input": "(do (defcomp ~shared:misc/cache-cleared (&key (time-str :as string)) (span :class \"text-green-600 font-bold\" \"Cache cleared at \" time-str)) (~shared:misc/cache-cleared :time-str \"12:00\"))",
|
||||
"expected_html": "<span class=\"text-green-600 font-bold\">Cache cleared at 12:00</span>"
|
||||
},
|
||||
{
|
||||
"name": "misc_error_list_item",
|
||||
"sx_input": "(do (defcomp ~shared:misc/error-list-item (&key (message :as string)) (li message)) (~shared:misc/error-list-item :message \"Bad input\"))",
|
||||
"expected_html": "<li>Bad input</li>"
|
||||
},
|
||||
{
|
||||
"name": "misc_fragment_error",
|
||||
"sx_input": "(do (defcomp ~shared:misc/fragment-error (&key (service :as string)) (p :class \"text-sm text-red-600\" \"Service \" (b service) \" is unavailable.\")) (~shared:misc/fragment-error :service \"blog\"))",
|
||||
"expected_html": "<p class=\"text-sm text-red-600\">Service <b>blog</b> is unavailable.</p>"
|
||||
}
|
||||
]
|
||||
@@ -59,7 +59,7 @@ class TestCartMini:
|
||||
class TestAuthMenu:
|
||||
def test_logged_in(self):
|
||||
html = sx(
|
||||
'(~auth-menu :user-email user-email :account-url account-url)',
|
||||
'(~shared:fragments/auth-menu :user-email user-email :account-url account-url)',
|
||||
**{"user-email": "alice@example.com", "account-url": "https://account.example.com/"},
|
||||
)
|
||||
assert 'id="auth-menu-desktop"' in html
|
||||
@@ -70,7 +70,7 @@ class TestAuthMenu:
|
||||
|
||||
def test_logged_out(self):
|
||||
html = sx(
|
||||
'(~auth-menu :account-url account-url)',
|
||||
'(~shared:fragments/auth-menu :account-url account-url)',
|
||||
**{"account-url": "https://account.example.com/"},
|
||||
)
|
||||
assert "fa-solid fa-key" in html
|
||||
@@ -78,7 +78,7 @@ class TestAuthMenu:
|
||||
|
||||
def test_desktop_has_data_close_details(self):
|
||||
html = sx(
|
||||
'(~auth-menu :user-email "x@y.com" :account-url "http://a")',
|
||||
'(~shared:fragments/auth-menu :user-email "x@y.com" :account-url "http://a")',
|
||||
)
|
||||
assert "data-close-details" in html
|
||||
|
||||
@@ -86,7 +86,7 @@ class TestAuthMenu:
|
||||
"""Both desktop and mobile spans are always rendered."""
|
||||
for email in ["user@test.com", None]:
|
||||
html = sx(
|
||||
'(~auth-menu :user-email user-email :account-url account-url)',
|
||||
'(~shared:fragments/auth-menu :user-email user-email :account-url account-url)',
|
||||
**{"user-email": email, "account-url": "http://a"},
|
||||
)
|
||||
assert 'id="auth-menu-desktop"' in html
|
||||
|
||||
436
shared/sx/tests/test_ocaml_helpers.py
Normal file
436
shared/sx/tests/test_ocaml_helpers.py
Normal file
@@ -0,0 +1,436 @@
|
||||
"""Tests for OCaml kernel ↔ Python page helper IO bridge.
|
||||
|
||||
Verifies that:
|
||||
1. Helper injection registers functions in the OCaml kernel
|
||||
2. The kernel can call helpers via (io-request "helper" ...)
|
||||
3. aser_slot expands components that use helpers
|
||||
4. Caching eliminates redundant IO round-trips
|
||||
|
||||
Usage:
|
||||
pytest shared/sx/tests/test_ocaml_helpers.py -v
|
||||
"""
|
||||
|
||||
import asyncio
|
||||
import os
|
||||
import sys
|
||||
import time
|
||||
import unittest
|
||||
|
||||
_project_root = os.path.abspath(os.path.join(os.path.dirname(__file__), "../../.."))
|
||||
if _project_root not in sys.path:
|
||||
sys.path.insert(0, _project_root)
|
||||
|
||||
from shared.sx.ocaml_bridge import OcamlBridge, OcamlBridgeError, _DEFAULT_BIN, _escape
|
||||
|
||||
|
||||
def _skip_if_no_binary():
|
||||
bin_path = os.path.abspath(_DEFAULT_BIN)
|
||||
if not os.path.isfile(bin_path):
|
||||
raise unittest.SkipTest(
|
||||
f"OCaml binary not found at {bin_path}. "
|
||||
f"Build with: cd hosts/ocaml && eval $(opam env) && dune build"
|
||||
)
|
||||
|
||||
|
||||
class TestHelperInjection(unittest.IsolatedAsyncioTestCase):
|
||||
"""Test that page helpers can be injected into the OCaml kernel."""
|
||||
|
||||
@classmethod
|
||||
def setUpClass(cls):
|
||||
_skip_if_no_binary()
|
||||
|
||||
async def asyncSetUp(self):
|
||||
self.bridge = OcamlBridge()
|
||||
await self.bridge.start()
|
||||
# Load spec + adapter (needed for aser)
|
||||
spec_dir = os.path.join(_project_root, "spec")
|
||||
web_dir = os.path.join(_project_root, "web")
|
||||
for f in ["parser.sx", "render.sx"]:
|
||||
path = os.path.join(spec_dir, f)
|
||||
if os.path.isfile(path):
|
||||
async with self.bridge._lock:
|
||||
await self.bridge._send(f'(load "{_escape(path)}")')
|
||||
await self.bridge._read_until_ok(ctx=None)
|
||||
adapter = os.path.join(web_dir, "adapter-sx.sx")
|
||||
if os.path.isfile(adapter):
|
||||
async with self.bridge._lock:
|
||||
await self.bridge._send(f'(load "{_escape(adapter)}")')
|
||||
await self.bridge._read_until_ok(ctx=None)
|
||||
|
||||
async def asyncTearDown(self):
|
||||
await self.bridge.stop()
|
||||
|
||||
async def _inject_test_helper(self, name: str, nargs: int):
|
||||
"""Inject a single helper proxy into the kernel."""
|
||||
param_names = " ".join(chr(97 + i) for i in range(nargs))
|
||||
arg_list = " ".join(chr(97 + i) for i in range(nargs))
|
||||
sx_def = f'(define {name} (fn ({param_names}) (helper "{name}" {arg_list})))'
|
||||
async with self.bridge._lock:
|
||||
await self.bridge._send(f'(load-source "{_escape(sx_def)}")')
|
||||
await self.bridge._read_until_ok(ctx=None)
|
||||
|
||||
async def test_helper_call_returns_value(self):
|
||||
"""Injected helper can be called and returns IO result."""
|
||||
# The "helper" native binding is already in the kernel.
|
||||
# Define a test helper that calls (helper "json-encode" value)
|
||||
await self._inject_test_helper("json-encode", 1)
|
||||
|
||||
# Call it via eval — should yield io-request, Python dispatches
|
||||
result = await self.bridge.eval(
|
||||
'(json-encode "hello")',
|
||||
ctx={"_helper_service": "sx"}
|
||||
)
|
||||
self.assertIn("hello", result)
|
||||
|
||||
async def test_helper_with_two_args(self):
|
||||
"""Helper with 2 args works (e.g. highlight pattern)."""
|
||||
# Define a 2-arg test helper via the generic helper binding
|
||||
sx_def = '(define test-two-args (fn (a b) (helper "json-encode" (str a ":" b))))'
|
||||
async with self.bridge._lock:
|
||||
await self.bridge._send(f'(load-source "{_escape(sx_def)}")')
|
||||
await self.bridge._read_until_ok(ctx=None)
|
||||
|
||||
result = await self.bridge.eval(
|
||||
'(test-two-args "hello" "world")',
|
||||
ctx={"_helper_service": "sx"}
|
||||
)
|
||||
self.assertIn("hello:world", result)
|
||||
|
||||
async def test_undefined_helper_errors(self):
|
||||
"""Calling an uninjected helper raises an error."""
|
||||
with self.assertRaises(OcamlBridgeError) as cm:
|
||||
await self.bridge.eval('(nonexistent-helper "arg")')
|
||||
self.assertIn("Undefined symbol", str(cm.exception))
|
||||
|
||||
async def test_helper_in_aser(self):
|
||||
"""Helper works inside aser — result inlined in SX output."""
|
||||
await self._inject_test_helper("json-encode", 1)
|
||||
|
||||
# aser a component-like expression that calls the helper
|
||||
result = await self.bridge.aser(
|
||||
'(div :class "test" (json-encode "hello"))',
|
||||
ctx={"_helper_service": "sx"}
|
||||
)
|
||||
# The aser should evaluate json-encode and inline the result
|
||||
self.assertIn("div", result)
|
||||
self.assertIn("hello", result)
|
||||
|
||||
async def test_helper_in_aser_slot_component(self):
|
||||
"""aser_slot expands component containing helper call."""
|
||||
await self._inject_test_helper("json-encode", 1)
|
||||
|
||||
# Define a component that calls the helper
|
||||
async with self.bridge._lock:
|
||||
await self.bridge._send(
|
||||
'(load-source "(defcomp ~test/code-display (&key code) '
|
||||
'(pre (code code)))")'
|
||||
)
|
||||
await self.bridge._read_until_ok(ctx=None)
|
||||
|
||||
# aser_slot should expand the component, evaluating the body
|
||||
result = await self.bridge.aser_slot(
|
||||
'(~test/code-display :code (json-encode "test-value"))',
|
||||
ctx={"_helper_service": "sx"}
|
||||
)
|
||||
# Should contain expanded HTML tags, not component call
|
||||
self.assertIn("pre", result)
|
||||
self.assertIn("test-value", result)
|
||||
# Should NOT contain the component call
|
||||
self.assertNotIn("~test/code-display", result)
|
||||
|
||||
|
||||
class TestBatchIO(unittest.IsolatedAsyncioTestCase):
|
||||
"""Test that batchable helper calls are collected and resolved concurrently."""
|
||||
|
||||
@classmethod
|
||||
def setUpClass(cls):
|
||||
_skip_if_no_binary()
|
||||
|
||||
async def asyncSetUp(self):
|
||||
self.bridge = OcamlBridge()
|
||||
await self.bridge.start()
|
||||
spec_dir = os.path.join(_project_root, "spec")
|
||||
web_dir = os.path.join(_project_root, "web")
|
||||
for f in ["parser.sx", "render.sx"]:
|
||||
path = os.path.join(spec_dir, f)
|
||||
if os.path.isfile(path):
|
||||
async with self.bridge._lock:
|
||||
await self.bridge._send(f'(load "{_escape(path)}")')
|
||||
await self.bridge._read_until_ok(ctx=None)
|
||||
adapter = os.path.join(web_dir, "adapter-sx.sx")
|
||||
if os.path.isfile(adapter):
|
||||
async with self.bridge._lock:
|
||||
await self.bridge._send(f'(load "{_escape(adapter)}")')
|
||||
await self.bridge._read_until_ok(ctx=None)
|
||||
|
||||
async def asyncTearDown(self):
|
||||
await self.bridge.stop()
|
||||
|
||||
async def test_batch_highlight_calls(self):
|
||||
"""Multiple highlight calls in aser_slot are batched, not sequential."""
|
||||
# Map highlight to json-encode (available without Quart app)
|
||||
sx = '(define highlight (fn (a b) (helper "json-encode" a)))'
|
||||
async with self.bridge._lock:
|
||||
await self.bridge._send(f'(load-source "{_escape(sx)}")')
|
||||
await self.bridge._read_until_ok(ctx=None)
|
||||
|
||||
comp = (
|
||||
'(defcomp ~test/batch (&key)'
|
||||
' (div (p (highlight "aaa" "x"))'
|
||||
' (p (highlight "bbb" "x"))'
|
||||
' (p (highlight "ccc" "x"))))'
|
||||
)
|
||||
async with self.bridge._lock:
|
||||
await self.bridge._send(f'(load-source "{_escape(comp)}")')
|
||||
await self.bridge._read_until_ok(ctx=None)
|
||||
|
||||
result = await self.bridge.aser_slot(
|
||||
'(~test/batch)', ctx={"_helper_service": "sx"})
|
||||
# All 3 values present — placeholders replaced
|
||||
self.assertIn("aaa", result)
|
||||
self.assertIn("bbb", result)
|
||||
self.assertIn("ccc", result)
|
||||
# No placeholder markers remaining
|
||||
self.assertNotIn("\u00ab", result) # «
|
||||
self.assertNotIn("\u00bb", result) # »
|
||||
|
||||
async def test_batch_faster_than_sequential(self):
|
||||
"""Batched IO should be faster than N sequential round-trips."""
|
||||
sx = '(define highlight (fn (a b) (helper "json-encode" a)))'
|
||||
async with self.bridge._lock:
|
||||
await self.bridge._send(f'(load-source "{_escape(sx)}")')
|
||||
await self.bridge._read_until_ok(ctx=None)
|
||||
|
||||
calls = " ".join(f'(p (highlight "v{i}" "x"))' for i in range(10))
|
||||
comp = f'(defcomp ~test/perf (&key) (div {calls}))'
|
||||
async with self.bridge._lock:
|
||||
await self.bridge._send(f'(load-source "{_escape(comp)}")')
|
||||
await self.bridge._read_until_ok(ctx=None)
|
||||
|
||||
t0 = time.monotonic()
|
||||
result = await self.bridge.aser_slot(
|
||||
'(~test/perf)', ctx={"_helper_service": "sx"})
|
||||
elapsed = time.monotonic() - t0
|
||||
|
||||
# All 10 values present
|
||||
for i in range(10):
|
||||
self.assertIn(f"v{i}", result)
|
||||
# Should complete in under 2 seconds (batched, not 10 × round-trip)
|
||||
self.assertLess(elapsed, 2.0,
|
||||
f"10 batched IO calls took {elapsed:.1f}s (target: <2s)")
|
||||
|
||||
|
||||
class TestHelperIOPerformance(unittest.IsolatedAsyncioTestCase):
|
||||
"""Test that helper IO round-trips are fast enough for production."""
|
||||
|
||||
@classmethod
|
||||
def setUpClass(cls):
|
||||
_skip_if_no_binary()
|
||||
|
||||
async def asyncSetUp(self):
|
||||
self.bridge = OcamlBridge()
|
||||
await self.bridge.start()
|
||||
spec_dir = os.path.join(_project_root, "spec")
|
||||
web_dir = os.path.join(_project_root, "web")
|
||||
for f in ["parser.sx", "render.sx"]:
|
||||
path = os.path.join(spec_dir, f)
|
||||
if os.path.isfile(path):
|
||||
async with self.bridge._lock:
|
||||
await self.bridge._send(f'(load "{_escape(path)}")')
|
||||
await self.bridge._read_until_ok(ctx=None)
|
||||
adapter = os.path.join(web_dir, "adapter-sx.sx")
|
||||
if os.path.isfile(adapter):
|
||||
async with self.bridge._lock:
|
||||
await self.bridge._send(f'(load "{_escape(adapter)}")')
|
||||
await self.bridge._read_until_ok(ctx=None)
|
||||
|
||||
async def asyncTearDown(self):
|
||||
await self.bridge.stop()
|
||||
|
||||
async def test_sequential_helper_calls_timing(self):
|
||||
"""Measure round-trip time for sequential helper calls."""
|
||||
# Inject json-encode as a fast helper
|
||||
param_names = "a"
|
||||
sx_def = '(define json-encode (fn (a) (helper "json-encode" a)))'
|
||||
async with self.bridge._lock:
|
||||
await self.bridge._send(f'(load-source "{_escape(sx_def)}")')
|
||||
await self.bridge._read_until_ok(ctx=None)
|
||||
|
||||
# Time 20 sequential calls (simulating a page with 20 highlight calls)
|
||||
n_calls = 20
|
||||
calls = " ".join(f'(json-encode "{i}")' for i in range(n_calls))
|
||||
expr = f'(list {calls})'
|
||||
|
||||
start = time.monotonic()
|
||||
result = await self.bridge.eval(expr, ctx={"_helper_service": "sx"})
|
||||
elapsed = time.monotonic() - start
|
||||
|
||||
# Should complete in under 5 seconds (generous for 20 IO round-trips)
|
||||
self.assertLess(elapsed, 5.0,
|
||||
f"20 helper IO round-trips took {elapsed:.1f}s (target: <5s)")
|
||||
|
||||
async def test_aser_slot_with_many_helper_calls(self):
|
||||
"""aser_slot with multiple helper calls completes in reasonable time."""
|
||||
sx_def = '(define json-encode (fn (a) (helper "json-encode" a)))'
|
||||
async with self.bridge._lock:
|
||||
await self.bridge._send(f'(load-source "{_escape(sx_def)}")')
|
||||
await self.bridge._read_until_ok(ctx=None)
|
||||
|
||||
# Define a component with multiple helper calls
|
||||
comp_def = (
|
||||
'(defcomp ~test/multi-helper (&key)'
|
||||
' (div'
|
||||
' (p (json-encode "a"))'
|
||||
' (p (json-encode "b"))'
|
||||
' (p (json-encode "c"))'
|
||||
' (p (json-encode "d"))'
|
||||
' (p (json-encode "e"))))'
|
||||
)
|
||||
async with self.bridge._lock:
|
||||
await self.bridge._send(f'(load-source "{_escape(comp_def)}")')
|
||||
await self.bridge._read_until_ok(ctx=None)
|
||||
|
||||
start = time.monotonic()
|
||||
result = await self.bridge.aser_slot(
|
||||
'(~test/multi-helper)',
|
||||
ctx={"_helper_service": "sx"}
|
||||
)
|
||||
elapsed = time.monotonic() - start
|
||||
|
||||
self.assertIn("div", result)
|
||||
self.assertLess(elapsed, 3.0,
|
||||
f"aser_slot with 5 helpers took {elapsed:.1f}s (target: <3s)")
|
||||
|
||||
|
||||
class TestAserSlotClientAffinity(unittest.IsolatedAsyncioTestCase):
|
||||
"""Test that :affinity :client components are NOT expanded by aser_slot."""
|
||||
|
||||
@classmethod
|
||||
def setUpClass(cls):
|
||||
_skip_if_no_binary()
|
||||
|
||||
async def asyncSetUp(self):
|
||||
self.bridge = OcamlBridge()
|
||||
await self.bridge.start()
|
||||
spec_dir = os.path.join(_project_root, "spec")
|
||||
web_dir = os.path.join(_project_root, "web")
|
||||
for f in ["parser.sx", "render.sx"]:
|
||||
path = os.path.join(spec_dir, f)
|
||||
if os.path.isfile(path):
|
||||
async with self.bridge._lock:
|
||||
await self.bridge._send(f'(load "{_escape(path)}")')
|
||||
await self.bridge._read_until_ok(ctx=None)
|
||||
adapter = os.path.join(web_dir, "adapter-sx.sx")
|
||||
if os.path.isfile(adapter):
|
||||
async with self.bridge._lock:
|
||||
await self.bridge._send(f'(load "{_escape(adapter)}")')
|
||||
await self.bridge._read_until_ok(ctx=None)
|
||||
|
||||
async def asyncTearDown(self):
|
||||
await self.bridge.stop()
|
||||
|
||||
async def test_client_affinity_not_expanded(self):
|
||||
"""Components with :affinity :client stay as calls in aser_slot."""
|
||||
comp_def = (
|
||||
'(defcomp ~test/client-only () :affinity :client'
|
||||
' (div "browser-only-content"))'
|
||||
)
|
||||
async with self.bridge._lock:
|
||||
await self.bridge._send(f'(load-source "{_escape(comp_def)}")')
|
||||
await self.bridge._read_until_ok(ctx=None)
|
||||
|
||||
result = await self.bridge.aser_slot('(~test/client-only)')
|
||||
# Should remain as a component call, NOT expanded
|
||||
self.assertIn("~test/client-only", result)
|
||||
self.assertNotIn("browser-only-content", result)
|
||||
|
||||
async def test_server_affinity_expanded(self):
|
||||
"""Components with :affinity :server are expanded by regular aser."""
|
||||
comp_def = (
|
||||
'(defcomp ~test/server-only (&key label) :affinity :server'
|
||||
' (div :class "server" label))'
|
||||
)
|
||||
async with self.bridge._lock:
|
||||
await self.bridge._send(f'(load-source "{_escape(comp_def)}")')
|
||||
await self.bridge._read_until_ok(ctx=None)
|
||||
|
||||
result = await self.bridge.aser(
|
||||
'(~test/server-only :label "hello")')
|
||||
# Should be expanded — div with class, not component call
|
||||
self.assertIn("div", result)
|
||||
self.assertIn("server", result)
|
||||
self.assertNotIn("~test/server-only", result)
|
||||
|
||||
async def test_auto_affinity_not_expanded_by_aser(self):
|
||||
"""Default affinity components are NOT expanded by regular aser."""
|
||||
comp_def = (
|
||||
'(defcomp ~test/auto-comp (&key label)'
|
||||
' (div "auto-content" label))'
|
||||
)
|
||||
async with self.bridge._lock:
|
||||
await self.bridge._send(f'(load-source "{_escape(comp_def)}")')
|
||||
await self.bridge._read_until_ok(ctx=None)
|
||||
|
||||
result = await self.bridge.aser(
|
||||
'(~test/auto-comp :label "hi")')
|
||||
# Should remain as component call
|
||||
self.assertIn("~test/auto-comp", result)
|
||||
|
||||
async def test_island_not_expanded_by_aser_slot(self):
|
||||
"""Islands are NEVER expanded server-side, even with expand-all."""
|
||||
island_def = (
|
||||
'(defisland ~test/reactive-isle (&key label)'
|
||||
' (div (deref (signal 0)) label))'
|
||||
)
|
||||
async with self.bridge._lock:
|
||||
await self.bridge._send(f'(load-source "{_escape(island_def)}")')
|
||||
await self.bridge._read_until_ok(ctx=None)
|
||||
|
||||
result = await self.bridge.aser_slot(
|
||||
'(~test/reactive-isle :label "hello")')
|
||||
# Island should be serialized as a call, NOT expanded
|
||||
self.assertIn("~test/reactive-isle", result)
|
||||
# Body content (deref, signal) should NOT appear
|
||||
self.assertNotIn("deref", result)
|
||||
self.assertNotIn("signal", result)
|
||||
|
||||
async def test_island_preserved_inside_expanded_component(self):
|
||||
"""Island calls survive inside aser_slot-expanded components."""
|
||||
src = (
|
||||
'(defisland ~test/inner-isle (&key v) (span (deref (signal v))))'
|
||||
'(defcomp ~test/outer-comp (&key title)'
|
||||
' (div (h1 title) (~test/inner-isle :v 42)))'
|
||||
)
|
||||
async with self.bridge._lock:
|
||||
await self.bridge._send(f'(load-source "{_escape(src)}")')
|
||||
await self.bridge._read_until_ok(ctx=None)
|
||||
|
||||
result = await self.bridge.aser_slot(
|
||||
'(~test/outer-comp :title "Test")')
|
||||
# Outer component expanded
|
||||
self.assertNotIn("~test/outer-comp", result)
|
||||
self.assertIn("div", result)
|
||||
self.assertIn("Test", result)
|
||||
# Inner island preserved as call
|
||||
self.assertIn("~test/inner-isle", result)
|
||||
|
||||
async def test_auto_affinity_expanded_by_aser_slot(self):
|
||||
"""Default affinity components ARE expanded by aser_slot."""
|
||||
comp_def = (
|
||||
'(defcomp ~test/auto-comp2 (&key label)'
|
||||
' (div "expanded" label))'
|
||||
)
|
||||
async with self.bridge._lock:
|
||||
await self.bridge._send(f'(load-source "{_escape(comp_def)}")')
|
||||
await self.bridge._read_until_ok(ctx=None)
|
||||
|
||||
result = await self.bridge.aser_slot(
|
||||
'(~test/auto-comp2 :label "hi")')
|
||||
# Should be expanded
|
||||
self.assertIn("div", result)
|
||||
self.assertIn("expanded", result)
|
||||
self.assertNotIn("~test/auto-comp2", result)
|
||||
|
||||
|
||||
if __name__ == "__main__":
|
||||
unittest.main()
|
||||
353
shared/sx/tests/test_ocaml_render.py
Normal file
353
shared/sx/tests/test_ocaml_render.py
Normal file
@@ -0,0 +1,353 @@
|
||||
"""Golden HTML rendering tests against the OCaml SX kernel.
|
||||
|
||||
Loads curated test cases from golden_data.json and verifies the OCaml
|
||||
kernel produces identical HTML output. Also tests aser and aser-slot
|
||||
modes.
|
||||
|
||||
Usage:
|
||||
pytest shared/sx/tests/test_ocaml_render.py -v
|
||||
"""
|
||||
|
||||
import asyncio
|
||||
import json
|
||||
import os
|
||||
import sys
|
||||
import unittest
|
||||
|
||||
_project_root = os.path.abspath(os.path.join(os.path.dirname(__file__), "../../.."))
|
||||
if _project_root not in sys.path:
|
||||
sys.path.insert(0, _project_root)
|
||||
|
||||
from shared.sx.ocaml_bridge import OcamlBridge, OcamlBridgeError, _DEFAULT_BIN
|
||||
|
||||
_GOLDEN_PATH = os.path.join(os.path.dirname(__file__), "golden_data.json")
|
||||
|
||||
|
||||
def _load_golden() -> list[dict]:
|
||||
"""Load golden test data."""
|
||||
if not os.path.isfile(_GOLDEN_PATH):
|
||||
return []
|
||||
with open(_GOLDEN_PATH) as f:
|
||||
return json.load(f)
|
||||
|
||||
|
||||
class TestOcamlGoldenRender(unittest.IsolatedAsyncioTestCase):
|
||||
"""Golden HTML tests — compare OCaml render output to Python-generated HTML."""
|
||||
|
||||
@classmethod
|
||||
def setUpClass(cls):
|
||||
bin_path = os.path.abspath(_DEFAULT_BIN)
|
||||
if not os.path.isfile(bin_path):
|
||||
raise unittest.SkipTest(
|
||||
f"OCaml binary not found at {bin_path}. "
|
||||
f"Build with: cd hosts/ocaml && eval $(opam env) && dune build"
|
||||
)
|
||||
cls.golden = _load_golden()
|
||||
if not cls.golden:
|
||||
raise unittest.SkipTest(
|
||||
f"No golden data at {_GOLDEN_PATH}. "
|
||||
f"Generate with: python3 shared/sx/tests/generate_golden.py"
|
||||
)
|
||||
|
||||
async def asyncSetUp(self):
|
||||
self.bridge = OcamlBridge()
|
||||
await self.bridge.start()
|
||||
|
||||
async def asyncTearDown(self):
|
||||
await self.bridge.stop()
|
||||
|
||||
# Cases with known issues (spec-only functions, attribute order, etc.)
|
||||
_RENDER_SKIP = {"filter_even", "void_input", "do_block"}
|
||||
|
||||
async def test_golden_render(self):
|
||||
"""Each golden case: OCaml render matches Python HTML."""
|
||||
passed = 0
|
||||
failed = []
|
||||
for case in self.golden:
|
||||
name = case["name"]
|
||||
if name in self._RENDER_SKIP:
|
||||
continue
|
||||
sx_input = case["sx_input"]
|
||||
expected = case["expected_html"]
|
||||
try:
|
||||
actual = await asyncio.wait_for(
|
||||
self.bridge.render(sx_input), timeout=5.0
|
||||
)
|
||||
if actual.strip() == expected.strip():
|
||||
passed += 1
|
||||
else:
|
||||
failed.append((name, expected, actual))
|
||||
except asyncio.TimeoutError:
|
||||
failed.append((name, expected, "TIMEOUT"))
|
||||
# Bridge may be desynced — stop and restart
|
||||
await self.bridge.stop()
|
||||
self.bridge = OcamlBridge()
|
||||
await self.bridge.start()
|
||||
except OcamlBridgeError as e:
|
||||
failed.append((name, expected, f"ERROR: {e}"))
|
||||
|
||||
if failed:
|
||||
msg_parts = [f"\n{len(failed)} golden render mismatches:\n"]
|
||||
for name, expected, actual in failed[:10]:
|
||||
msg_parts.append(f" {name}:")
|
||||
msg_parts.append(f" expected: {expected[:120]}")
|
||||
msg_parts.append(f" actual: {actual[:120]}")
|
||||
self.fail("\n".join(msg_parts))
|
||||
|
||||
# Cases that use spec-only functions or macros with &rest that don't
|
||||
# round-trip through aser cleanly (render still works fine).
|
||||
# Cases that use spec-only functions, macros with &rest, or trigger
|
||||
# known parity issues in aser expansion (render still works fine).
|
||||
_ASER_SKIP = {"filter_even", "macro_unless"}
|
||||
_ASER_SLOT_SKIP = {"filter_even", "macro_unless", "defcomp_no_optional"}
|
||||
|
||||
async def test_golden_aser(self):
|
||||
"""Each golden case: OCaml aser produces valid SX wire format."""
|
||||
passed = 0
|
||||
errors = []
|
||||
for case in self.golden:
|
||||
name = case["name"]
|
||||
if name in self._ASER_SKIP:
|
||||
continue
|
||||
sx_input = case["sx_input"]
|
||||
try:
|
||||
result = await self.bridge.aser(sx_input)
|
||||
# aser should produce some output (string, not empty)
|
||||
if result is not None:
|
||||
passed += 1
|
||||
else:
|
||||
errors.append((name, "returned None"))
|
||||
except OcamlBridgeError as e:
|
||||
errors.append((name, str(e)))
|
||||
|
||||
if errors:
|
||||
msg_parts = [f"\n{len(errors)} aser errors:\n"]
|
||||
for name, err in errors[:10]:
|
||||
msg_parts.append(f" {name}: {err[:120]}")
|
||||
self.fail("\n".join(msg_parts))
|
||||
|
||||
async def test_golden_aser_slot(self):
|
||||
"""Each golden case: OCaml aser-slot produces valid SX wire format."""
|
||||
passed = 0
|
||||
errors = []
|
||||
for case in self.golden:
|
||||
name = case["name"]
|
||||
if name in self._ASER_SLOT_SKIP:
|
||||
continue
|
||||
sx_input = case["sx_input"]
|
||||
try:
|
||||
result = await self.bridge.aser_slot(sx_input)
|
||||
if result is not None:
|
||||
passed += 1
|
||||
else:
|
||||
errors.append((name, "returned None"))
|
||||
except OcamlBridgeError as e:
|
||||
errors.append((name, str(e)))
|
||||
|
||||
if errors:
|
||||
msg_parts = [f"\n{len(errors)} aser-slot errors:\n"]
|
||||
for name, err in errors[:10]:
|
||||
msg_parts.append(f" {name}: {err[:120]}")
|
||||
self.fail("\n".join(msg_parts))
|
||||
|
||||
async def test_aser_slot_expands_components(self):
|
||||
"""aser-slot expands component calls while aser does not."""
|
||||
await self.bridge.load_source(
|
||||
'(defcomp ~golden-test (&key label) (span :class "tag" label))'
|
||||
)
|
||||
# aser should preserve the component call
|
||||
aser_result = await self.bridge.aser('(~golden-test :label "Hi")')
|
||||
self.assertTrue(
|
||||
aser_result.startswith("(~golden-test"),
|
||||
f"aser should preserve component call, got: {aser_result}",
|
||||
)
|
||||
|
||||
# aser-slot should expand the component
|
||||
slot_result = await self.bridge.aser_slot('(~golden-test :label "Hi")')
|
||||
self.assertTrue(
|
||||
slot_result.startswith("(span"),
|
||||
f"aser-slot should expand component, got: {slot_result}",
|
||||
)
|
||||
|
||||
async def test_aser_does_not_crash_on_component_call(self):
|
||||
"""Regression: aser with a component call must not crash.
|
||||
|
||||
This catches the bug where adapter-sx.sx called expand-components?
|
||||
without guarding env-has?, causing 'Undefined symbol' on kernels
|
||||
that don't bind it or when aser (not aser-slot) is used.
|
||||
"""
|
||||
await self.bridge.load_source(
|
||||
'(defcomp ~regress-comp (&key title &rest children) '
|
||||
'(div :class "box" (h2 title) children))'
|
||||
)
|
||||
# aser must succeed (serialize the component call, not expand it)
|
||||
result = await self.bridge.aser(
|
||||
'(~regress-comp :title "Hello" (p "world"))'
|
||||
)
|
||||
self.assertIn("~regress-comp", result)
|
||||
self.assertIn('"Hello"', result)
|
||||
|
||||
async def test_render_raw_html(self):
|
||||
"""Regression: raw! must inject HTML without escaping."""
|
||||
html = await self.bridge.render('(raw! "<b>bold</b>")')
|
||||
self.assertEqual(html, "<b>bold</b>")
|
||||
|
||||
async def test_render_component_with_raw(self):
|
||||
"""Regression: component using raw! (like ~shared:misc/rich-text)."""
|
||||
await self.bridge.load_source(
|
||||
'(defcomp ~rich-text (&key html) (raw! html))'
|
||||
)
|
||||
html = await self.bridge.render('(~rich-text :html "<p>CMS content</p>")')
|
||||
self.assertEqual(html, "<p>CMS content</p>")
|
||||
|
||||
async def test_aser_nested_components_no_crash(self):
|
||||
"""Regression: aser with nested component calls must not crash."""
|
||||
await self.bridge.load_source(
|
||||
'(defcomp ~outer-reg (&key title &rest children) '
|
||||
'(section (h1 title) children))'
|
||||
)
|
||||
await self.bridge.load_source(
|
||||
'(defcomp ~inner-reg (&key text) (span text))'
|
||||
)
|
||||
result = await self.bridge.aser(
|
||||
'(~outer-reg :title "Outer" (~inner-reg :text "Inner"))'
|
||||
)
|
||||
self.assertIn("~outer-reg", result)
|
||||
self.assertIn("~inner-reg", result)
|
||||
|
||||
async def test_render_shell_with_raw(self):
|
||||
"""Integration: shell component with raw! renders full HTML page.
|
||||
|
||||
The page shell uses raw! extensively for script content, CSS,
|
||||
pre-rendered HTML, etc. This catches missing raw! in the renderer.
|
||||
"""
|
||||
await self.bridge.load_source(
|
||||
'(defcomp ~test-shell (&key title page-sx css) '
|
||||
'(<> (raw! "<!doctype html>") '
|
||||
'(html (head (title title) (style (raw! (or css "")))) '
|
||||
'(body (script :type "text/sx" (raw! (or page-sx "")))))))'
|
||||
)
|
||||
html = await self.bridge.render(
|
||||
'(~test-shell :title "Test" '
|
||||
':page-sx "(div :class \\"card\\" \\"hello\\")" '
|
||||
':css "body{margin:0}")'
|
||||
)
|
||||
self.assertIn("<!doctype html>", html)
|
||||
self.assertIn("<title>Test</title>", html)
|
||||
self.assertIn('(div :class "card" "hello")', html)
|
||||
self.assertIn("body{margin:0}", html)
|
||||
|
||||
async def test_render_never_returns_raw_sx(self):
|
||||
"""The render command must never return raw SX as the response.
|
||||
|
||||
Even if the shell component fails, the bridge.render() should
|
||||
either return HTML or raise — never return SX wire format.
|
||||
"""
|
||||
# Component that produces HTML, not SX
|
||||
await self.bridge.load_source(
|
||||
'(defcomp ~test-page (&key content) '
|
||||
'(<> (raw! "<!doctype html>") (html (body (raw! content)))))'
|
||||
)
|
||||
html = await self.bridge.render(
|
||||
'(~test-page :content "(div \\"hello\\")")'
|
||||
)
|
||||
# Must start with <!doctype, not with (
|
||||
self.assertTrue(
|
||||
html.startswith("<!doctype"),
|
||||
f"render returned SX instead of HTML: {html[:100]}",
|
||||
)
|
||||
# Must not contain bare SX component calls as visible text
|
||||
self.assertNotIn("(~test-page", html)
|
||||
|
||||
async def test_aser_slot_server_affinity_always_expands(self):
|
||||
"""Server-affinity components expand in both aser and aser-slot."""
|
||||
await self.bridge.load_source(
|
||||
'(defcomp ~golden-server (&key x) :affinity :server (div x))'
|
||||
)
|
||||
# Both modes should expand server-affinity components
|
||||
aser_result = await self.bridge.aser('(~golden-server :x "test")')
|
||||
self.assertTrue(
|
||||
"(div" in aser_result,
|
||||
f"aser should expand server-affinity, got: {aser_result}",
|
||||
)
|
||||
slot_result = await self.bridge.aser_slot('(~golden-server :x "test")')
|
||||
self.assertTrue(
|
||||
"(div" in slot_result,
|
||||
f"aser-slot should expand server-affinity, got: {slot_result}",
|
||||
)
|
||||
|
||||
|
||||
class TestOcamlCLI(unittest.TestCase):
|
||||
"""Test the --render and --aser CLI modes."""
|
||||
|
||||
@classmethod
|
||||
def setUpClass(cls):
|
||||
cls.bin_path = os.path.abspath(_DEFAULT_BIN)
|
||||
if not os.path.isfile(cls.bin_path):
|
||||
raise unittest.SkipTest("OCaml binary not found")
|
||||
|
||||
def _run_cli(self, mode: str, sx_input: str) -> str:
|
||||
import subprocess
|
||||
result = subprocess.run(
|
||||
[self.bin_path, f"--{mode}"],
|
||||
input=sx_input,
|
||||
capture_output=True,
|
||||
text=True,
|
||||
timeout=10,
|
||||
)
|
||||
if result.returncode != 0:
|
||||
raise RuntimeError(f"CLI {mode} failed: {result.stderr}")
|
||||
return result.stdout
|
||||
|
||||
def test_cli_render_simple(self):
|
||||
html = self._run_cli("render", '(div :class "card" (p "hello"))')
|
||||
self.assertEqual(html, '<div class="card"><p>hello</p></div>')
|
||||
|
||||
def test_cli_render_fragment(self):
|
||||
html = self._run_cli("render", '(<> (p "a") (p "b"))')
|
||||
self.assertEqual(html, "<p>a</p><p>b</p>")
|
||||
|
||||
def test_cli_render_void(self):
|
||||
html = self._run_cli("render", "(br)")
|
||||
self.assertEqual(html, "<br />")
|
||||
|
||||
def test_cli_render_conditional(self):
|
||||
html = self._run_cli("render", '(if true (p "yes") (p "no"))')
|
||||
self.assertEqual(html, "<p>yes</p>")
|
||||
|
||||
def test_cli_aser_with_defcomp(self):
|
||||
"""CLI --aser with component def + call must not crash."""
|
||||
sx = ('(do (defcomp ~cli-test (&key title) (div title)) '
|
||||
'(~cli-test :title "Hi"))')
|
||||
result = self._run_cli("aser", sx)
|
||||
self.assertIn("~cli-test", result)
|
||||
|
||||
# Same skip list as the bridge golden tests
|
||||
_CLI_RENDER_SKIP = {"filter_even", "void_input", "do_block"}
|
||||
|
||||
def test_cli_golden_render(self):
|
||||
"""Run all golden cases through CLI --render."""
|
||||
golden = _load_golden()
|
||||
if not golden:
|
||||
self.skipTest("No golden data")
|
||||
failed = []
|
||||
for case in golden:
|
||||
if case["name"] in self._CLI_RENDER_SKIP:
|
||||
continue
|
||||
try:
|
||||
actual = self._run_cli("render", case["sx_input"])
|
||||
if actual.strip() != case["expected_html"].strip():
|
||||
failed.append((case["name"], case["expected_html"], actual))
|
||||
except Exception as e:
|
||||
failed.append((case["name"], case["expected_html"], str(e)))
|
||||
if failed:
|
||||
msg_parts = [f"\n{len(failed)} CLI golden render mismatches:\n"]
|
||||
for name, expected, actual in failed[:10]:
|
||||
msg_parts.append(f" {name}:")
|
||||
msg_parts.append(f" expected: {expected[:120]}")
|
||||
msg_parts.append(f" actual: {actual[:120]}")
|
||||
self.fail("\n".join(msg_parts))
|
||||
|
||||
|
||||
if __name__ == "__main__":
|
||||
unittest.main()
|
||||
558
shared/sx/tests/test_post_removal_bugs.py
Normal file
558
shared/sx/tests/test_post_removal_bugs.py
Normal file
@@ -0,0 +1,558 @@
|
||||
"""Tests exposing bugs after sx_ref.py removal.
|
||||
|
||||
These tests document all known breakages from removing the Python SX evaluator.
|
||||
Each test targets a specific codepath that was depending on sx_ref.py and is now
|
||||
broken.
|
||||
|
||||
Usage:
|
||||
pytest shared/sx/tests/test_post_removal_bugs.py -v
|
||||
"""
|
||||
|
||||
import asyncio
|
||||
import os
|
||||
import sys
|
||||
import unittest
|
||||
|
||||
_project_root = os.path.abspath(os.path.join(os.path.dirname(__file__), "../../.."))
|
||||
if _project_root not in sys.path:
|
||||
sys.path.insert(0, _project_root)
|
||||
|
||||
from shared.sx.parser import parse, parse_all, serialize
|
||||
from shared.sx.types import Component, Symbol, Keyword, NIL
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Helper: load shared components fresh (no cache)
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
def _load_components_fresh():
|
||||
"""Load shared components, clearing cache to force re-parse."""
|
||||
from shared.sx.jinja_bridge import _COMPONENT_ENV
|
||||
_COMPONENT_ENV.clear()
|
||||
from shared.sx.components import load_shared_components
|
||||
load_shared_components()
|
||||
return _COMPONENT_ENV
|
||||
|
||||
|
||||
# ===========================================================================
|
||||
# 1. register_components() loses all parameter information
|
||||
# ===========================================================================
|
||||
|
||||
class TestComponentRegistration(unittest.TestCase):
|
||||
"""register_components() hardcodes params=[] and has_children=False
|
||||
for every component, losing all parameter metadata."""
|
||||
|
||||
@classmethod
|
||||
def setUpClass(cls):
|
||||
cls.env = _load_components_fresh()
|
||||
|
||||
def test_shell_component_should_have_params(self):
|
||||
"""~shared:shell/sx-page-shell has 17+ &key params but gets params=[]."""
|
||||
comp = self.env.get("~shared:shell/sx-page-shell")
|
||||
self.assertIsNotNone(comp, "Shell component not found")
|
||||
self.assertIsInstance(comp, Component)
|
||||
# BUG: params is [] — should include title, meta-html, csrf, etc.
|
||||
self.assertGreater(
|
||||
len(comp.params), 0,
|
||||
f"Shell component has params={comp.params} — expected 17+ keyword params"
|
||||
)
|
||||
|
||||
def test_cssx_tw_should_have_tokens_param(self):
|
||||
"""~cssx/tw needs a 'tokens' parameter."""
|
||||
comp = self.env.get("~cssx/tw")
|
||||
self.assertIsNotNone(comp, "~cssx/tw component not found")
|
||||
self.assertIn(
|
||||
"tokens", comp.params,
|
||||
f"~cssx/tw has params={comp.params} — expected 'tokens'"
|
||||
)
|
||||
|
||||
def test_cart_mini_should_have_params(self):
|
||||
"""~shared:fragments/cart-mini has &key params."""
|
||||
comp = self.env.get("~shared:fragments/cart-mini")
|
||||
self.assertIsNotNone(comp, "cart-mini component not found")
|
||||
self.assertGreater(
|
||||
len(comp.params), 0,
|
||||
f"cart-mini has params={comp.params} — expected keyword params"
|
||||
)
|
||||
|
||||
def test_has_children_flag(self):
|
||||
"""Components with &rest children should have has_children=True."""
|
||||
comp = self.env.get("~shared:shell/sx-page-shell")
|
||||
self.assertIsNotNone(comp)
|
||||
# Many components accept children but has_children is always False
|
||||
# Check any component that is known to accept &rest children
|
||||
# e.g. a layout component
|
||||
for name, val in self.env.items():
|
||||
if isinstance(val, Component):
|
||||
# Every component has has_children=False — at least some should be True
|
||||
pass
|
||||
# Count how many have has_children=True
|
||||
with_children = sum(
|
||||
1 for v in self.env.values()
|
||||
if isinstance(v, Component) and v.has_children
|
||||
)
|
||||
total = sum(1 for v in self.env.values() if isinstance(v, Component))
|
||||
# BUG: with_children is 0 — at least some components accept children
|
||||
self.assertGreater(
|
||||
with_children, 0,
|
||||
f"0/{total} components have has_children=True — at least some should"
|
||||
)
|
||||
|
||||
def test_all_components_have_empty_params(self):
|
||||
"""Show the scale of the bug — every single component has params=[]."""
|
||||
components_with_params = []
|
||||
components_without = []
|
||||
for name, val in self.env.items():
|
||||
if isinstance(val, Component):
|
||||
if val.params:
|
||||
components_with_params.append(name)
|
||||
else:
|
||||
components_without.append(name)
|
||||
# BUG: ALL components have empty params
|
||||
self.assertGreater(
|
||||
len(components_with_params), 0,
|
||||
f"ALL {len(components_without)} components have params=[] — none have parameters parsed"
|
||||
)
|
||||
|
||||
|
||||
# ===========================================================================
|
||||
# 2. Sync html.py rendering is completely broken
|
||||
# ===========================================================================
|
||||
|
||||
class TestSyncHtmlRendering(unittest.TestCase):
|
||||
"""html.py render() stubs _raw_eval/_trampoline — any evaluation crashes."""
|
||||
|
||||
def test_html_render_simple_element(self):
|
||||
"""Even simple elements with keyword attrs need _eval, which is stubbed."""
|
||||
from shared.sx.html import render
|
||||
# This should work — (div "hello") needs no eval
|
||||
result = render(parse('(div "hello")'), {})
|
||||
self.assertIn("hello", result)
|
||||
|
||||
def test_html_render_with_keyword_attr(self):
|
||||
"""Keyword attrs go through _eval, which raises RuntimeError."""
|
||||
from shared.sx.html import render
|
||||
try:
|
||||
result = render(parse('(div :class "test" "hello")'), {})
|
||||
# If it works, great
|
||||
self.assertIn("test", result)
|
||||
except RuntimeError as e:
|
||||
self.assertIn("sx_ref.py has been removed", str(e))
|
||||
self.fail(f"html.py render crashes on keyword attrs: {e}")
|
||||
|
||||
def test_html_render_symbol_lookup(self):
|
||||
"""Symbol lookup goes through _eval, which is stubbed."""
|
||||
from shared.sx.html import render
|
||||
try:
|
||||
result = render(parse('(div title)'), {"title": "Hello"})
|
||||
self.assertIn("Hello", result)
|
||||
except RuntimeError as e:
|
||||
self.assertIn("sx_ref.py has been removed", str(e))
|
||||
self.fail(f"html.py render crashes on symbol lookup: {e}")
|
||||
|
||||
def test_html_render_component(self):
|
||||
"""Component rendering needs _eval for kwarg evaluation."""
|
||||
from shared.sx.html import render
|
||||
env = _load_components_fresh()
|
||||
try:
|
||||
result = render(
|
||||
parse('(~shared:fragments/cart-mini :cart-count 0 :blog-url "" :cart-url "")'),
|
||||
env,
|
||||
)
|
||||
self.assertIn("cart-mini", result)
|
||||
except RuntimeError as e:
|
||||
self.assertIn("sx_ref.py has been removed", str(e))
|
||||
self.fail(f"html.py render crashes on component calls: {e}")
|
||||
|
||||
def test_sx_jinja_function_broken(self):
|
||||
"""The sx() Jinja helper is broken — it uses html_render internally."""
|
||||
from shared.sx.jinja_bridge import sx
|
||||
env = _load_components_fresh()
|
||||
try:
|
||||
result = sx('(div "hello")')
|
||||
self.assertIn("hello", result)
|
||||
except RuntimeError as e:
|
||||
self.assertIn("sx_ref.py has been removed", str(e))
|
||||
self.fail(f"sx() Jinja function is broken: {e}")
|
||||
|
||||
|
||||
# ===========================================================================
|
||||
# 3. Async render_to_html uses Python path, not OCaml
|
||||
# ===========================================================================
|
||||
|
||||
class TestAsyncRenderToHtml(unittest.IsolatedAsyncioTestCase):
|
||||
"""helpers.py render_to_html() deliberately uses Python async_eval,
|
||||
not the OCaml bridge. But Python eval is now broken."""
|
||||
|
||||
async def test_render_to_html_uses_python_path(self):
|
||||
"""render_to_html goes through async_render, not OCaml bridge."""
|
||||
from shared.sx.helpers import render_to_html
|
||||
env = _load_components_fresh()
|
||||
# The shell component has many &key params — none are bound because params=[]
|
||||
try:
|
||||
html = await render_to_html(
|
||||
"shared:shell/sx-page-shell",
|
||||
title="Test", csrf="abc", asset_url="/static",
|
||||
sx_js_hash="abc123",
|
||||
)
|
||||
self.assertIn("Test", html)
|
||||
except Exception as e:
|
||||
# Expected: either RuntimeError from stubs or EvalError from undefined symbols
|
||||
self.fail(
|
||||
f"render_to_html (Python path) failed: {type(e).__name__}: {e}\n"
|
||||
f"This should go through OCaml bridge instead"
|
||||
)
|
||||
|
||||
async def test_async_render_component_no_params_bound(self):
|
||||
"""async_eval.py _arender_component can't bind params because comp.params=[]."""
|
||||
from shared.sx.async_eval import async_render
|
||||
from shared.sx.primitives_io import RequestContext
|
||||
env = _load_components_fresh()
|
||||
# Create a simple component manually with correct params
|
||||
test_comp = Component(
|
||||
name="test/greeting",
|
||||
params=["name"],
|
||||
has_children=False,
|
||||
body=parse('(div (str "Hello " name))'),
|
||||
)
|
||||
env["~test/greeting"] = test_comp
|
||||
try:
|
||||
result = await async_render(
|
||||
parse('(~test/greeting :name "World")'),
|
||||
env,
|
||||
RequestContext(),
|
||||
)
|
||||
self.assertIn("Hello World", result)
|
||||
except Exception as e:
|
||||
self.fail(
|
||||
f"async_render failed even with correct params: {type(e).__name__}: {e}"
|
||||
)
|
||||
|
||||
|
||||
# ===========================================================================
|
||||
# 4. Dead imports from removed sx_ref.py
|
||||
# ===========================================================================
|
||||
|
||||
class TestDeadImports(unittest.TestCase):
|
||||
"""Files that import from sx_ref.py will crash when their codepaths execute."""
|
||||
|
||||
def test_async_eval_defcomp(self):
|
||||
"""async_eval.py _asf_defcomp should work as a stub (no sx_ref import)."""
|
||||
from shared.sx.async_eval import _asf_defcomp
|
||||
env = {}
|
||||
asyncio.run(_asf_defcomp(
|
||||
[Symbol("defcomp"), Symbol("~test"), [], [Symbol("div")]],
|
||||
env, None
|
||||
))
|
||||
# Should register a minimal component in env
|
||||
self.assertIn("~test", env)
|
||||
|
||||
def test_async_eval_defmacro(self):
|
||||
"""async_eval.py _asf_defmacro should work as a stub (no sx_ref import)."""
|
||||
from shared.sx.async_eval import _asf_defmacro
|
||||
env = {}
|
||||
asyncio.run(_asf_defmacro(
|
||||
[Symbol("defmacro"), Symbol("test"), [], [Symbol("div")]],
|
||||
env, None
|
||||
))
|
||||
self.assertIn("test", env)
|
||||
|
||||
def test_async_eval_defstyle(self):
|
||||
"""async_eval.py _asf_defstyle should be a no-op (no sx_ref import)."""
|
||||
from shared.sx.async_eval import _asf_defstyle
|
||||
result = asyncio.run(_asf_defstyle(
|
||||
[Symbol("defstyle"), Symbol("test"), [], [Symbol("div")]],
|
||||
{}, None
|
||||
))
|
||||
# Should return NIL without crashing
|
||||
self.assertIsNotNone(result)
|
||||
|
||||
def test_async_eval_defhandler(self):
|
||||
"""async_eval.py _asf_defhandler should be a no-op (no sx_ref import)."""
|
||||
from shared.sx.async_eval import _asf_defhandler
|
||||
result = asyncio.run(_asf_defhandler(
|
||||
[Symbol("defhandler"), Symbol("test"), [], [Symbol("div")]],
|
||||
{}, None
|
||||
))
|
||||
self.assertIsNotNone(result)
|
||||
|
||||
def test_async_eval_continuation_reset(self):
|
||||
"""async_eval.py _asf_reset imports eval_expr/trampoline from sx_ref."""
|
||||
# The cont_fn inside _asf_reset will crash when invoked
|
||||
from shared.sx.async_eval import _ASYNC_RENDER_FORMS
|
||||
reset_fn = _ASYNC_RENDER_FORMS.get("reset")
|
||||
# reset is defined in async_eval — the import is deferred to execution
|
||||
# Just verify the module doesn't have the import available
|
||||
try:
|
||||
from shared.sx.ref.sx_ref import eval_expr
|
||||
self.fail("sx_ref.py should not exist")
|
||||
except (ImportError, ModuleNotFoundError):
|
||||
pass # Expected
|
||||
|
||||
def test_ocaml_bridge_jit_compile(self):
|
||||
"""ocaml_bridge.py _compile_adapter_module imports from sx_ref."""
|
||||
try:
|
||||
from shared.sx.ref.sx_ref import eval_expr, trampoline, PRIMITIVES
|
||||
self.fail("sx_ref.py should not exist — JIT compilation path is broken")
|
||||
except (ImportError, ModuleNotFoundError):
|
||||
pass # Expected — confirms the bug
|
||||
|
||||
def test_parser_reader_macro(self):
|
||||
"""parser.py _try_reader_macro imports trampoline/call_lambda from sx_ref."""
|
||||
try:
|
||||
from shared.sx.ref.sx_ref import trampoline, call_lambda
|
||||
self.fail("sx_ref.py should not exist — reader macros are broken")
|
||||
except (ImportError, ModuleNotFoundError):
|
||||
pass # Expected — confirms the bug
|
||||
|
||||
def test_primitives_scope_prims(self):
|
||||
"""primitives.py _lazy_scope_primitives silently fails to load scope prims."""
|
||||
from shared.sx.primitives import _PRIMITIVES
|
||||
# collect!, collected, clear-collected!, emitted, emit!, context
|
||||
# These are needed for CSSX but the import from sx_ref silently fails
|
||||
missing = []
|
||||
for name in ("collect!", "collected", "clear-collected!", "emitted", "emit!", "context"):
|
||||
if name not in _PRIMITIVES:
|
||||
missing.append(name)
|
||||
if missing:
|
||||
self.fail(
|
||||
f"Scope primitives missing from _PRIMITIVES (sx_ref import failed silently): {missing}\n"
|
||||
f"CSSX components depend on these for collect!/collected"
|
||||
)
|
||||
|
||||
def test_deps_transitive_deps_ref_path(self):
|
||||
"""deps.py transitive_deps imports from sx_ref when SX_USE_REF=1."""
|
||||
# The fallback path should still work
|
||||
from shared.sx.deps import transitive_deps
|
||||
env = _load_components_fresh()
|
||||
# Should work via fallback, not crash
|
||||
try:
|
||||
result = transitive_deps("~cssx/tw", env)
|
||||
self.assertIsInstance(result, set)
|
||||
except (ImportError, ModuleNotFoundError) as e:
|
||||
self.fail(f"transitive_deps crashed: {e}")
|
||||
|
||||
def test_handlers_python_fallback(self):
|
||||
"""handlers.py eval_handler Python fallback imports async_eval_ref."""
|
||||
# When not using OCaml, handler evaluation falls through to async_eval
|
||||
# The ref path (SX_USE_REF=1) would crash
|
||||
try:
|
||||
from shared.sx.ref.async_eval_ref import async_eval_to_sx
|
||||
self.fail("async_eval_ref.py should not exist")
|
||||
except (ImportError, ModuleNotFoundError):
|
||||
pass # Expected
|
||||
|
||||
|
||||
# ===========================================================================
|
||||
# 5. ~cssx/tw signature mismatch
|
||||
# ===========================================================================
|
||||
|
||||
class TestCssxTwSignature(unittest.TestCase):
|
||||
"""~cssx/tw changed from (&key tokens) to (tokens) positional,
|
||||
but callers use :tokens keyword syntax."""
|
||||
|
||||
@classmethod
|
||||
def setUpClass(cls):
|
||||
cls.env = _load_components_fresh()
|
||||
|
||||
def test_cssx_tw_source_uses_positional(self):
|
||||
"""Verify the current source has positional (tokens) not (&key tokens)."""
|
||||
import os
|
||||
cssx_path = os.path.join(
|
||||
os.path.dirname(__file__), "..", "templates", "cssx.sx"
|
||||
)
|
||||
with open(cssx_path) as f:
|
||||
source = f.read()
|
||||
# Check if it's positional or keyword
|
||||
if "(defcomp ~cssx/tw (tokens)" in source:
|
||||
# Positional — callers using :tokens will break
|
||||
self.fail(
|
||||
"~cssx/tw uses positional (tokens) but callers use :tokens keyword syntax.\n"
|
||||
"Should be: (defcomp ~cssx/tw (&key tokens) ...)"
|
||||
)
|
||||
elif "(defcomp ~cssx/tw (&key tokens)" in source:
|
||||
pass # Correct
|
||||
else:
|
||||
# Unknown signature
|
||||
for line in source.split("\n"):
|
||||
if "defcomp ~cssx/tw" in line:
|
||||
self.fail(f"Unexpected ~cssx/tw signature: {line.strip()}")
|
||||
|
||||
def test_cssx_tw_callers_use_keyword(self):
|
||||
"""Scan for callers that use :tokens keyword syntax."""
|
||||
import glob as glob_mod
|
||||
sx_dir = os.path.join(os.path.dirname(__file__), "../../..")
|
||||
keyword_callers = []
|
||||
positional_callers = []
|
||||
for fp in glob_mod.glob(os.path.join(sx_dir, "**/*.sx"), recursive=True):
|
||||
try:
|
||||
with open(fp) as f:
|
||||
content = f.read()
|
||||
except Exception:
|
||||
continue
|
||||
if "~cssx/tw" not in content:
|
||||
continue
|
||||
for line_no, line in enumerate(content.split("\n"), 1):
|
||||
if "~cssx/tw" in line and "defcomp" not in line:
|
||||
if ":tokens" in line:
|
||||
keyword_callers.append(f"{fp}:{line_no}")
|
||||
elif "(~cssx/tw " in line:
|
||||
positional_callers.append(f"{fp}:{line_no}")
|
||||
|
||||
if keyword_callers:
|
||||
# If signature is positional but callers use :tokens, that's a bug
|
||||
import os as os_mod
|
||||
cssx_path = os.path.join(
|
||||
os.path.dirname(__file__), "..", "templates", "cssx.sx"
|
||||
)
|
||||
with open(cssx_path) as f:
|
||||
source = f.read()
|
||||
if "(defcomp ~cssx/tw (tokens)" in source:
|
||||
self.fail(
|
||||
f"~cssx/tw uses positional params but {len(keyword_callers)} callers use :tokens:\n"
|
||||
+ "\n".join(keyword_callers[:5])
|
||||
)
|
||||
|
||||
|
||||
# ===========================================================================
|
||||
# 6. OCaml bridge rendering (should work — this is the good path)
|
||||
# ===========================================================================
|
||||
|
||||
class TestOcamlBridgeRendering(unittest.IsolatedAsyncioTestCase):
|
||||
"""The OCaml bridge should handle all rendering correctly."""
|
||||
|
||||
@classmethod
|
||||
def setUpClass(cls):
|
||||
from shared.sx.ocaml_bridge import _DEFAULT_BIN
|
||||
bin_path = os.path.abspath(_DEFAULT_BIN)
|
||||
if not os.path.isfile(bin_path):
|
||||
raise unittest.SkipTest("OCaml binary not found")
|
||||
|
||||
async def asyncSetUp(self):
|
||||
from shared.sx.ocaml_bridge import OcamlBridge
|
||||
self.bridge = OcamlBridge()
|
||||
await self.bridge.start()
|
||||
|
||||
async def asyncTearDown(self):
|
||||
if hasattr(self, 'bridge'):
|
||||
await self.bridge.stop()
|
||||
|
||||
async def test_simple_element(self):
|
||||
result = await self.bridge.render('(div "hello")')
|
||||
self.assertIn("hello", result)
|
||||
|
||||
async def test_element_with_keyword_attrs(self):
|
||||
result = await self.bridge.render('(div :class "test" "hello")')
|
||||
self.assertIn('class="test"', result)
|
||||
self.assertIn("hello", result)
|
||||
|
||||
async def test_component_with_params(self):
|
||||
"""OCaml should handle component parameter binding correctly."""
|
||||
# Use load_source to define a component (bypasses _ensure_components lock)
|
||||
await self.bridge.load_source('(defcomp ~test/greet (&key name) (div (str "Hello " name)))')
|
||||
result = await self.bridge.render('(~test/greet :name "World")')
|
||||
self.assertIn("Hello World", result)
|
||||
|
||||
async def test_let_binding(self):
|
||||
result = await self.bridge.render('(let ((x "hello")) (div x))')
|
||||
self.assertIn("hello", result)
|
||||
|
||||
async def test_conditional(self):
|
||||
result = await self.bridge.render('(if true (div "yes") (div "no"))')
|
||||
self.assertIn("yes", result)
|
||||
self.assertNotIn("no", result)
|
||||
|
||||
async def test_cssx_tw_keyword_call(self):
|
||||
"""Test that ~cssx/tw works when called with :tokens keyword.
|
||||
Components are loaded by _ensure_components() automatically."""
|
||||
try:
|
||||
result = await self.bridge.render('(div (~cssx/tw :tokens "bg-red-500") "content")')
|
||||
# Should produce a spread with CSS class, not an error
|
||||
self.assertNotIn("error", result.lower())
|
||||
except Exception as e:
|
||||
self.fail(f"~cssx/tw :tokens keyword call failed: {e}")
|
||||
|
||||
async def test_cssx_tw_positional_call(self):
|
||||
"""Test that ~cssx/tw works when called positionally."""
|
||||
try:
|
||||
result = await self.bridge.render('(div (~cssx/tw "bg-red-500") "content")')
|
||||
self.assertNotIn("error", result.lower())
|
||||
except Exception as e:
|
||||
self.fail(f"~cssx/tw positional call failed: {e}")
|
||||
|
||||
async def test_repeated_renders_dont_crash(self):
|
||||
"""Verify OCaml bridge handles multiple sequential renders."""
|
||||
for i in range(5):
|
||||
result = await self.bridge.render(f'(div "iter-{i}")')
|
||||
self.assertIn(f"iter-{i}", result)
|
||||
|
||||
|
||||
# ===========================================================================
|
||||
# 7. Scope primitives missing (collect!, collected, etc.)
|
||||
# ===========================================================================
|
||||
|
||||
class TestScopePrimitives(unittest.TestCase):
|
||||
"""Scope primitives needed by CSSX are missing because the import
|
||||
from sx_ref.py silently fails."""
|
||||
|
||||
def test_python_primitives_have_scope_ops(self):
|
||||
"""Check that collect!/collected/etc. are in _PRIMITIVES."""
|
||||
from shared.sx.primitives import _PRIMITIVES
|
||||
required = ["collect!", "collected", "clear-collected!",
|
||||
"emitted", "emit!", "context"]
|
||||
missing = [p for p in required if p not in _PRIMITIVES]
|
||||
if missing:
|
||||
self.fail(
|
||||
f"Missing Python-side scope primitives: {missing}\n"
|
||||
f"These were provided by sx_ref.py — need OCaml bridge or Python stubs"
|
||||
)
|
||||
|
||||
|
||||
# ===========================================================================
|
||||
# 8. Query executor fallback path
|
||||
# ===========================================================================
|
||||
|
||||
class TestQueryExecutorFallback(unittest.TestCase):
|
||||
"""query_executor.py imports async_eval for its fallback path."""
|
||||
|
||||
def test_query_executor_import(self):
|
||||
"""query_executor can be imported without crashing."""
|
||||
try:
|
||||
import shared.sx.query_executor
|
||||
except Exception as e:
|
||||
self.fail(f"query_executor import crashed: {e}")
|
||||
|
||||
|
||||
# ===========================================================================
|
||||
# 9. End-to-end: sx_page shell rendering
|
||||
# ===========================================================================
|
||||
|
||||
class TestShellRendering(unittest.IsolatedAsyncioTestCase):
|
||||
"""The shell template needs to render through some path that works."""
|
||||
|
||||
async def test_sx_page_shell_via_python(self):
|
||||
"""render_to_html('shared:shell/sx-page-shell', ...) uses Python path.
|
||||
This is the actual failure from the production error log."""
|
||||
from shared.sx.helpers import render_to_html
|
||||
_load_components_fresh()
|
||||
try:
|
||||
html = await render_to_html(
|
||||
"shared:shell/sx-page-shell",
|
||||
title="Test Page",
|
||||
csrf="test-csrf",
|
||||
asset_url="/static",
|
||||
sx_js_hash="abc",
|
||||
)
|
||||
# Should produce full HTML document
|
||||
self.assertIn("<!doctype html>", html.lower())
|
||||
self.assertIn("Test Page", html)
|
||||
except Exception as e:
|
||||
self.fail(
|
||||
f"Shell rendering via Python path failed: {type(e).__name__}: {e}\n"
|
||||
f"This is the exact error seen in production — "
|
||||
f"render_to_html should use OCaml bridge"
|
||||
)
|
||||
|
||||
|
||||
if __name__ == "__main__":
|
||||
unittest.main()
|
||||
374
shared/sx/tests/test_vm_compile.py
Normal file
374
shared/sx/tests/test_vm_compile.py
Normal file
@@ -0,0 +1,374 @@
|
||||
"""Tests for the SX bytecode compiler + VM execution.
|
||||
|
||||
Compiles SX expressions with compiler.sx (Python-side), executes
|
||||
on the OCaml VM via the bridge, verifies results match CEK evaluation.
|
||||
|
||||
Usage:
|
||||
pytest shared/sx/tests/test_vm_compile.py -v
|
||||
"""
|
||||
|
||||
import asyncio
|
||||
import os
|
||||
import sys
|
||||
import time
|
||||
import unittest
|
||||
|
||||
_project_root = os.path.abspath(os.path.join(os.path.dirname(__file__), "../../.."))
|
||||
if _project_root not in sys.path:
|
||||
sys.path.insert(0, _project_root)
|
||||
|
||||
from shared.sx.parser import parse_all, serialize
|
||||
from shared.sx.ref.sx_ref import eval_expr, trampoline, PRIMITIVES
|
||||
from shared.sx.types import Symbol, Keyword, NIL
|
||||
from shared.sx.ocaml_bridge import OcamlBridge, OcamlBridgeError, _DEFAULT_BIN
|
||||
|
||||
|
||||
def _skip_if_no_binary():
|
||||
bin_path = os.path.abspath(_DEFAULT_BIN)
|
||||
if not os.path.isfile(bin_path):
|
||||
raise unittest.SkipTest(f"OCaml binary not found at {bin_path}")
|
||||
|
||||
|
||||
# Register primitives needed by compiler.sx
|
||||
PRIMITIVES['serialize'] = lambda x: serialize(x)
|
||||
PRIMITIVES['primitive?'] = lambda name: isinstance(name, str) and name in PRIMITIVES
|
||||
PRIMITIVES['has-key?'] = lambda *a: isinstance(a[0], dict) and str(a[1]) in a[0]
|
||||
PRIMITIVES['set-nth!'] = lambda *a: (a[0].__setitem__(int(a[1]), a[2]), NIL)[-1]
|
||||
PRIMITIVES['init'] = lambda *a: a[0][:-1] if isinstance(a[0], list) else a[0]
|
||||
|
||||
# Register HO forms as primitives so compiler emits CALL_PRIM (direct dispatch)
|
||||
# instead of CALL (which routes through CEK HO special forms)
|
||||
for _ho_name in ['map', 'map-indexed', 'filter', 'reduce', 'for-each', 'some', 'every?']:
|
||||
PRIMITIVES[_ho_name] = lambda *a: NIL # placeholder — OCaml primitives handle actual work
|
||||
PRIMITIVES['make-symbol'] = lambda name: Symbol(name)
|
||||
PRIMITIVES['concat'] = lambda *a: (a[0] or []) + (a[1] or [])
|
||||
PRIMITIVES['slice'] = lambda *a: a[0][int(a[1]):int(a[2])] if len(a) == 3 else a[0][int(a[1]):]
|
||||
|
||||
|
||||
def _load_compiler():
|
||||
"""Load compiler.sx into a Python env, return the compile function."""
|
||||
env = {}
|
||||
for f in ['spec/bytecode.sx', 'spec/compiler.sx']:
|
||||
path = os.path.join(_project_root, f)
|
||||
with open(path) as fh:
|
||||
for expr in parse_all(fh.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
return env
|
||||
|
||||
|
||||
def _compile(env, src):
|
||||
"""Compile an SX source string to bytecode dict."""
|
||||
ast = parse_all(src)[0]
|
||||
return trampoline(eval_expr(
|
||||
[Symbol('compile'), [Symbol('quote'), ast]], env))
|
||||
|
||||
|
||||
# Load compiler once for all tests
|
||||
_compiler_env = _load_compiler()
|
||||
|
||||
|
||||
class TestCompilerOutput(unittest.TestCase):
|
||||
"""Test that the compiler produces valid bytecode for various SX patterns."""
|
||||
|
||||
def _compile(self, src):
|
||||
return _compile(_compiler_env, src)
|
||||
|
||||
def test_arithmetic(self):
|
||||
result = self._compile('(+ 1 2)')
|
||||
self.assertIn('bytecode', result)
|
||||
self.assertIn('constants', result)
|
||||
bc = list(result['bytecode'])
|
||||
self.assertTrue(len(bc) > 0)
|
||||
|
||||
def test_if_produces_jumps(self):
|
||||
result = self._compile('(if true "a" "b")')
|
||||
bc = list(result['bytecode'])
|
||||
# Should contain OP_JUMP_IF_FALSE (33)
|
||||
self.assertIn(33, bc)
|
||||
|
||||
def test_let_uses_local_slots(self):
|
||||
result = self._compile('(let ((x 1)) x)')
|
||||
bc = list(result['bytecode'])
|
||||
# Should contain OP_LOCAL_SET (17) and OP_LOCAL_GET (16)
|
||||
self.assertIn(17, bc)
|
||||
self.assertIn(16, bc)
|
||||
|
||||
def test_lambda_produces_closure(self):
|
||||
result = self._compile('(fn (x) (+ x 1))')
|
||||
bc = list(result['bytecode'])
|
||||
# Should contain OP_CLOSURE (51)
|
||||
self.assertIn(51, bc)
|
||||
|
||||
def test_closure_captures_upvalue(self):
|
||||
result = self._compile('(let ((x 10)) (fn (y) (+ x y)))')
|
||||
bc = list(result['bytecode'])
|
||||
# Should have OP_CLOSURE with upvalue descriptors
|
||||
self.assertIn(51, bc)
|
||||
# Find closure index and check upvalue-count in constants
|
||||
consts = list(result['constants'])
|
||||
code_objs = [c for c in consts if isinstance(c, dict) and 'bytecode' in c]
|
||||
self.assertTrue(len(code_objs) > 0)
|
||||
code = code_objs[0]
|
||||
self.assertEqual(code.get('upvalue-count', 0), 1)
|
||||
# Inner bytecode should use OP_UPVALUE_GET (18)
|
||||
inner_bc = list(code['bytecode'])
|
||||
self.assertIn(18, inner_bc)
|
||||
|
||||
def test_cond_compiles(self):
|
||||
result = self._compile('(cond (= x 1) "a" :else "b")')
|
||||
self.assertTrue(len(list(result['bytecode'])) > 0)
|
||||
|
||||
def test_case_compiles(self):
|
||||
result = self._compile('(case x 1 "one" :else "other")')
|
||||
self.assertTrue(len(list(result['bytecode'])) > 0)
|
||||
|
||||
def test_thread_first_compiles(self):
|
||||
result = self._compile('(-> x (+ 1))')
|
||||
self.assertTrue(len(list(result['bytecode'])) > 0)
|
||||
|
||||
def test_begin_compiles(self):
|
||||
result = self._compile('(do (+ 1 2) (+ 3 4))')
|
||||
bc = list(result['bytecode'])
|
||||
# Should contain OP_POP (5) between expressions
|
||||
self.assertIn(5, bc)
|
||||
|
||||
def test_define_compiles(self):
|
||||
result = self._compile('(define x 42)')
|
||||
bc = list(result['bytecode'])
|
||||
# Should contain OP_DEFINE (128)
|
||||
self.assertIn(128, bc)
|
||||
|
||||
def test_nested_let_shares_frame(self):
|
||||
"""Nested lets should use incrementing slot numbers, not restart at 0."""
|
||||
result = self._compile('(let ((a 1)) (let ((b 2)) (+ a b)))')
|
||||
bc = list(result['bytecode'])
|
||||
# First LOC_SET should be slot 0, second should be slot 1
|
||||
set_indices = []
|
||||
for i, op in enumerate(bc):
|
||||
if op == 17 and i + 1 < len(bc): # OP_LOCAL_SET
|
||||
set_indices.append(bc[i + 1])
|
||||
self.assertEqual(set_indices, [0, 1])
|
||||
|
||||
def test_tail_call(self):
|
||||
"""Calls in tail position should use OP_TAIL_CALL."""
|
||||
result = self._compile('(fn (x) (if (> x 0) (foo (- x 1)) 0))')
|
||||
consts = list(result['constants'])
|
||||
code_objs = [c for c in consts if isinstance(c, dict) and 'bytecode' in c]
|
||||
inner_bc = list(code_objs[0]['bytecode'])
|
||||
# Should contain OP_TAIL_CALL (49) for the recursive call
|
||||
self.assertIn(49, inner_bc)
|
||||
|
||||
|
||||
class TestVMExecution(unittest.IsolatedAsyncioTestCase):
|
||||
"""Test that compiled bytecode executes correctly on the OCaml VM."""
|
||||
|
||||
@classmethod
|
||||
def setUpClass(cls):
|
||||
_skip_if_no_binary()
|
||||
|
||||
async def asyncSetUp(self):
|
||||
self.bridge = OcamlBridge()
|
||||
await self.bridge.start()
|
||||
|
||||
async def asyncTearDown(self):
|
||||
await self.bridge.stop()
|
||||
|
||||
async def _vm_eval(self, src):
|
||||
"""Compile SX source and execute on VM, return result."""
|
||||
compiled = _compile(_compiler_env, src)
|
||||
code_sx = serialize(compiled)
|
||||
async with self.bridge._lock:
|
||||
await self.bridge._send(f'(vm-exec {code_sx})')
|
||||
return await self.bridge._read_until_ok(ctx=None)
|
||||
|
||||
async def _cek_eval(self, src):
|
||||
"""Evaluate SX source on CEK machine, return result."""
|
||||
async with self.bridge._lock:
|
||||
await self.bridge._send(f'(eval "{_escape_for_ocaml(src)}")')
|
||||
return await self.bridge._read_until_ok(ctx=None)
|
||||
|
||||
async def test_arithmetic(self):
|
||||
result = await self._vm_eval('(+ 1 2)')
|
||||
self.assertEqual(result.strip(), '3')
|
||||
|
||||
async def test_nested_arithmetic(self):
|
||||
result = await self._vm_eval('(+ (* 3 4) (- 10 5))')
|
||||
self.assertEqual(result.strip(), '17')
|
||||
|
||||
async def test_if_true(self):
|
||||
result = await self._vm_eval('(if true "yes" "no")')
|
||||
self.assertIn('yes', result)
|
||||
|
||||
async def test_if_false(self):
|
||||
result = await self._vm_eval('(if false "yes" "no")')
|
||||
self.assertIn('no', result)
|
||||
|
||||
async def test_let_binding(self):
|
||||
result = await self._vm_eval('(let ((x 10) (y 20)) (+ x y))')
|
||||
self.assertEqual(result.strip(), '30')
|
||||
|
||||
async def test_nested_let(self):
|
||||
result = await self._vm_eval('(let ((a 1)) (let ((b 2)) (+ a b)))')
|
||||
self.assertEqual(result.strip(), '3')
|
||||
|
||||
async def test_closure_captures_variable(self):
|
||||
result = await self._vm_eval(
|
||||
'(let ((x 10)) (let ((f (fn (y) (+ x y)))) (f 5)))')
|
||||
self.assertEqual(result.strip(), '15')
|
||||
|
||||
async def test_closure_nested_capture(self):
|
||||
result = await self._vm_eval(
|
||||
'(let ((a 1) (b 2)) (let ((f (fn (c) (+ a (+ b c))))) (f 3)))')
|
||||
self.assertEqual(result.strip(), '6')
|
||||
|
||||
async def test_and_short_circuit(self):
|
||||
result = await self._vm_eval('(and false (error "should not reach"))')
|
||||
self.assertEqual(result.strip(), 'false')
|
||||
|
||||
async def test_or_short_circuit(self):
|
||||
result = await self._vm_eval('(or 42 (error "should not reach"))')
|
||||
self.assertEqual(result.strip(), '42')
|
||||
|
||||
async def test_when_true(self):
|
||||
result = await self._vm_eval('(when true "yes")')
|
||||
self.assertIn('yes', result)
|
||||
|
||||
async def test_when_false(self):
|
||||
result = await self._vm_eval('(when false "yes")')
|
||||
self.assertIn('nil', result.lower())
|
||||
|
||||
async def test_cond(self):
|
||||
result = await self._vm_eval(
|
||||
'(let ((x 2)) (cond (= x 1) "one" (= x 2) "two" :else "other"))')
|
||||
self.assertIn('two', result)
|
||||
|
||||
async def test_string_primitives(self):
|
||||
result = await self._vm_eval('(str "hello" " " "world")')
|
||||
self.assertIn('hello world', result)
|
||||
|
||||
async def test_list_construction(self):
|
||||
result = await self._vm_eval('(list 1 2 3)')
|
||||
self.assertIn('1', result)
|
||||
self.assertIn('2', result)
|
||||
self.assertIn('3', result)
|
||||
|
||||
async def test_define_and_call(self):
|
||||
result = await self._vm_eval(
|
||||
'(do (define double (fn (x) (* x 2))) (double 21))')
|
||||
self.assertEqual(result.strip(), '42')
|
||||
|
||||
async def test_higher_order_call(self):
|
||||
"""A function that takes another function as argument."""
|
||||
result = await self._vm_eval(
|
||||
'(let ((apply-fn (fn (f x) (f x)))) (apply-fn (fn (n) (* n 3)) 7))')
|
||||
self.assertEqual(result.strip(), '21')
|
||||
|
||||
async def test_vm_matches_cek(self):
|
||||
"""VM result must match CEK result for numeric expressions."""
|
||||
test_exprs = [
|
||||
('(+ 1 2)', '3'),
|
||||
('(* 3 (+ 4 5))', '27'),
|
||||
('(let ((x 10)) (+ x 1))', '11'),
|
||||
('(- 100 42)', '58'),
|
||||
]
|
||||
for src, expected in test_exprs:
|
||||
vm_result = await self._vm_eval(src)
|
||||
self.assertEqual(vm_result.strip(), expected,
|
||||
f"VM wrong for {src}: got {vm_result}, expected {expected}")
|
||||
|
||||
|
||||
class TestVMAutoCompile(unittest.IsolatedAsyncioTestCase):
|
||||
"""Test patterns that auto-compile needs to handle.
|
||||
These represent the 111 functions that currently fail."""
|
||||
|
||||
@classmethod
|
||||
def setUpClass(cls):
|
||||
_skip_if_no_binary()
|
||||
|
||||
async def asyncSetUp(self):
|
||||
self.bridge = OcamlBridge()
|
||||
await self.bridge.start()
|
||||
|
||||
async def asyncTearDown(self):
|
||||
await self.bridge.stop()
|
||||
|
||||
async def _vm_eval(self, src):
|
||||
compiled = _compile(_compiler_env, src)
|
||||
code_sx = serialize(compiled)
|
||||
async with self.bridge._lock:
|
||||
await self.bridge._send(f'(vm-exec {code_sx})')
|
||||
return await self.bridge._read_until_ok(ctx=None)
|
||||
|
||||
async def test_for_each_via_primitive(self):
|
||||
"""for-each should work as a primitive call."""
|
||||
result = await self._vm_eval(
|
||||
'(let ((sum 0)) (for-each (fn (x) (set! sum (+ sum x))) (list 1 2 3)) sum)')
|
||||
self.assertEqual(result.strip(), '6')
|
||||
|
||||
async def test_map_via_primitive(self):
|
||||
"""map should work as a primitive call."""
|
||||
result = await self._vm_eval(
|
||||
'(map (fn (x) (* x 2)) (list 1 2 3))')
|
||||
self.assertIn('2', result)
|
||||
self.assertIn('4', result)
|
||||
self.assertIn('6', result)
|
||||
|
||||
async def test_filter_via_primitive(self):
|
||||
"""filter should work as a primitive call."""
|
||||
result = await self._vm_eval(
|
||||
'(filter (fn (x) (> x 2)) (list 1 2 3 4 5))')
|
||||
self.assertIn('3', result)
|
||||
self.assertIn('4', result)
|
||||
self.assertIn('5', result)
|
||||
|
||||
async def test_closure_over_mutable(self):
|
||||
"""Closure capturing a set! target must share the mutation."""
|
||||
result = await self._vm_eval(
|
||||
'(let ((count 0)) (let ((inc (fn () (set! count (+ count 1))))) (inc) (inc) (inc) count))')
|
||||
self.assertEqual(result.strip(), '3')
|
||||
|
||||
async def test_recursive_function(self):
|
||||
"""Recursive function via define."""
|
||||
result = await self._vm_eval(
|
||||
'(do (define fact (fn (n) (if (<= n 1) 1 (* n (fact (- n 1)))))) (fact 5))')
|
||||
self.assertEqual(result.strip(), '120')
|
||||
|
||||
async def test_string_building(self):
|
||||
"""String concatenation — hot path for aser."""
|
||||
result = await self._vm_eval(
|
||||
'(str "(" "div" " " ":class" ")")')
|
||||
self.assertIn('div', result)
|
||||
self.assertIn(':class', result)
|
||||
|
||||
async def test_type_dispatch(self):
|
||||
"""type-of dispatch — used heavily by aser."""
|
||||
result = await self._vm_eval(
|
||||
'(cond (= (type-of 42) "number") "num" (= (type-of "x") "string") "str" :else "other")')
|
||||
self.assertIn('num', result)
|
||||
|
||||
async def test_type_of_number(self):
|
||||
"""type-of dispatch — foundation for aser."""
|
||||
result = await self._vm_eval('(type-of 42)')
|
||||
self.assertIn('number', result)
|
||||
|
||||
async def test_empty_list_check(self):
|
||||
result = await self._vm_eval('(empty? (list))')
|
||||
self.assertEqual(result.strip(), 'true')
|
||||
|
||||
async def test_multiple_closures_same_scope(self):
|
||||
"""Multiple closures capturing from the same let."""
|
||||
result = await self._vm_eval('''
|
||||
(let ((base 100))
|
||||
(let ((add (fn (x) (+ base x)))
|
||||
(sub (fn (x) (- base x))))
|
||||
(+ (add 10) (sub 10))))''')
|
||||
self.assertEqual(result.strip(), '200')
|
||||
|
||||
|
||||
def _escape_for_ocaml(s):
|
||||
"""Escape a string for embedding in an OCaml SX command."""
|
||||
return s.replace('\\', '\\\\').replace('"', '\\"').replace('\n', '\\n')
|
||||
|
||||
|
||||
if __name__ == "__main__":
|
||||
unittest.main()
|
||||
@@ -306,6 +306,26 @@
|
||||
(scan kont (list))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Extension points — custom special forms and render dispatch
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Extensions (web forms, type system, etc.) register handlers here.
|
||||
;; The evaluator calls these from step-eval-list after core forms.
|
||||
|
||||
(define *custom-special-forms* (dict))
|
||||
|
||||
(define register-special-form!
|
||||
(fn ((name :as string) handler)
|
||||
(dict-set! *custom-special-forms* name handler)))
|
||||
|
||||
;; Render dispatch — installed by web adapters, nil when no renderer active.
|
||||
;; *render-check*: (expr env) → boolean — should this expression be rendered?
|
||||
;; *render-fn*: (expr env) → value — render and return result
|
||||
(define *render-check* nil)
|
||||
(define *render-fn* nil)
|
||||
|
||||
|
||||
;; **************************************************************************
|
||||
;; Part 2: Evaluation Utilities
|
||||
;; **************************************************************************
|
||||
@@ -545,6 +565,14 @@
|
||||
(every? (fn (c) (and (= (type-of c) "list") (= (len c) 2)))
|
||||
clauses)))
|
||||
|
||||
;; is-else-clause? — check if a cond/case test is an else marker
|
||||
(define is-else-clause?
|
||||
(fn (test)
|
||||
(or (and (= (type-of test) "keyword") (= (keyword-name test) "else"))
|
||||
(and (= (type-of test) "symbol")
|
||||
(or (= (symbol-name test) "else")
|
||||
(= (symbol-name test) ":else"))))))
|
||||
|
||||
|
||||
;; Named let: (let name ((x 0) (y 1)) body...)
|
||||
;; Desugars to a self-recursive lambda called with initial values.
|
||||
@@ -755,91 +783,6 @@
|
||||
(list params rest-param))))
|
||||
|
||||
|
||||
(define sf-defstyle
|
||||
(fn ((args :as list) (env :as dict))
|
||||
;; (defstyle name expr) — bind name to evaluated expr (string, function, etc.)
|
||||
(let ((name-sym (first args))
|
||||
(value (trampoline (eval-expr (nth args 1) env))))
|
||||
(env-bind! env (symbol-name name-sym) value)
|
||||
value)))
|
||||
|
||||
|
||||
;; -- deftype helpers (must be in eval.sx, not types.sx, because
|
||||
;; sf-deftype is always compiled but types.sx is a spec module) --
|
||||
|
||||
(define make-type-def
|
||||
(fn ((name :as string) (params :as list) body)
|
||||
{:name name :params params :body body}))
|
||||
|
||||
(define normalize-type-body
|
||||
(fn (body)
|
||||
;; Convert AST type expressions to type representation.
|
||||
;; Symbols → strings, (union ...) → (or ...), dict keys → strings.
|
||||
(cond
|
||||
(nil? body) "nil"
|
||||
(= (type-of body) "symbol")
|
||||
(symbol-name body)
|
||||
(= (type-of body) "string")
|
||||
body
|
||||
(= (type-of body) "keyword")
|
||||
(keyword-name body)
|
||||
(= (type-of body) "dict")
|
||||
;; Record type — normalize values
|
||||
(map-dict (fn (k v) (normalize-type-body v)) body)
|
||||
(= (type-of body) "list")
|
||||
(if (empty? body) "any"
|
||||
(let ((head (first body)))
|
||||
(let ((head-name (if (= (type-of head) "symbol")
|
||||
(symbol-name head) (str head))))
|
||||
;; (union a b) → (or a b)
|
||||
(if (= head-name "union")
|
||||
(cons "or" (map normalize-type-body (rest body)))
|
||||
;; (or a b), (list-of t), (-> ...) etc.
|
||||
(cons head-name (map normalize-type-body (rest body)))))))
|
||||
:else (str body))))
|
||||
|
||||
(define sf-deftype
|
||||
(fn ((args :as list) (env :as dict))
|
||||
;; (deftype name body) or (deftype (name a b ...) body)
|
||||
(let ((name-or-form (first args))
|
||||
(body-expr (nth args 1))
|
||||
(type-name nil)
|
||||
(type-params (list)))
|
||||
;; Parse name — symbol or (symbol params...)
|
||||
(if (= (type-of name-or-form) "symbol")
|
||||
(set! type-name (symbol-name name-or-form))
|
||||
(when (= (type-of name-or-form) "list")
|
||||
(set! type-name (symbol-name (first name-or-form)))
|
||||
(set! type-params
|
||||
(map (fn (p) (if (= (type-of p) "symbol")
|
||||
(symbol-name p) (str p)))
|
||||
(rest name-or-form)))))
|
||||
;; Normalize and store in *type-registry*
|
||||
(let ((body (normalize-type-body body-expr))
|
||||
(registry (if (env-has? env "*type-registry*")
|
||||
(env-get env "*type-registry*")
|
||||
(dict))))
|
||||
(dict-set! registry type-name
|
||||
(make-type-def type-name type-params body))
|
||||
(env-bind! env "*type-registry*" registry)
|
||||
nil))))
|
||||
|
||||
|
||||
(define sf-defeffect
|
||||
(fn ((args :as list) (env :as dict))
|
||||
;; (defeffect name) — register an effect name
|
||||
(let ((effect-name (if (= (type-of (first args)) "symbol")
|
||||
(symbol-name (first args))
|
||||
(str (first args))))
|
||||
(registry (if (env-has? env "*effect-registry*")
|
||||
(env-get env "*effect-registry*")
|
||||
(list))))
|
||||
(when (not (contains? registry effect-name))
|
||||
(append! registry effect-name))
|
||||
(env-bind! env "*effect-registry*" registry)
|
||||
nil)))
|
||||
|
||||
|
||||
(define qq-expand
|
||||
(fn (template (env :as dict))
|
||||
(if (not (= (type-of template) "list"))
|
||||
@@ -953,6 +896,14 @@
|
||||
;; (call-thunk f env) — call a zero-arg function
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; step-sf-letrec: sf-letrec evaluates bindings + intermediate body,
|
||||
;; returns a thunk for the last body expression. Unwrap into CEK state
|
||||
;; so the last expression is properly evaluated by the CEK machine.
|
||||
(define step-sf-letrec
|
||||
(fn (args env kont)
|
||||
(let ((thk (sf-letrec args env)))
|
||||
(make-cek-state (thunk-expr thk) (thunk-env thk) kont))))
|
||||
|
||||
(define sf-dynamic-wind
|
||||
(fn ((args :as list) (env :as dict))
|
||||
(let ((before (trampoline (eval-expr (first args) env)))
|
||||
@@ -1126,10 +1077,11 @@
|
||||
;; (pop-wind!) → void (pop wind record from stack)
|
||||
;; (call-thunk f env) → value (call a zero-arg function)
|
||||
;;
|
||||
;; Render-time accumulators:
|
||||
;; (collect! bucket value) → void (add to named bucket, deduplicated)
|
||||
;; (collected bucket) → list (all values in bucket)
|
||||
;; (clear-collected! bucket) → void (empty the bucket)
|
||||
;; Extension hooks (set by web adapters, type system, etc.):
|
||||
;; *custom-special-forms* — dict of name → handler fn
|
||||
;; register-special-form! — (name handler) → registers custom form
|
||||
;; *render-check* — nil or (expr env) → boolean
|
||||
;; *render-fn* — nil or (expr env) → value
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
|
||||
@@ -1188,6 +1140,9 @@
|
||||
(= name "false") false
|
||||
(= name "nil") nil
|
||||
:else (error (str "Undefined symbol: " name)))))
|
||||
;; Warn when a ~component symbol resolves to nil (likely missing)
|
||||
(when (and (nil? val) (starts-with? name "~"))
|
||||
(debug-log "Component not found:" name))
|
||||
(make-cek-value val env kont)))
|
||||
|
||||
;; --- Keyword → string ---
|
||||
@@ -1262,20 +1217,13 @@
|
||||
(= name "defcomp") (make-cek-value (sf-defcomp args env) env kont)
|
||||
(= name "defisland") (make-cek-value (sf-defisland args env) env kont)
|
||||
(= name "defmacro") (make-cek-value (sf-defmacro args env) env kont)
|
||||
(= name "defstyle") (make-cek-value (sf-defstyle args env) env kont)
|
||||
(= name "defhandler") (make-cek-value (sf-defhandler args env) env kont)
|
||||
(= name "defpage") (make-cek-value (sf-defpage args env) env kont)
|
||||
(= name "defquery") (make-cek-value (sf-defquery args env) env kont)
|
||||
(= name "defaction") (make-cek-value (sf-defaction args env) env kont)
|
||||
(= name "deftype") (make-cek-value (sf-deftype args env) env kont)
|
||||
(= name "defeffect") (make-cek-value (sf-defeffect args env) env kont)
|
||||
(= name "begin") (step-sf-begin args env kont)
|
||||
(= name "do") (step-sf-begin args env kont)
|
||||
(= name "quote") (make-cek-value (if (empty? args) nil (first args)) env kont)
|
||||
(= name "quasiquote") (make-cek-value (qq-expand (first args) env) env kont)
|
||||
(= name "->") (step-sf-thread-first args env kont)
|
||||
(= name "set!") (step-sf-set! args env kont)
|
||||
(= name "letrec") (make-cek-value (sf-letrec args env) env kont)
|
||||
(= name "letrec") (step-sf-letrec args env kont)
|
||||
|
||||
;; Continuations — native in CEK
|
||||
(= name "reset") (step-sf-reset args env kont)
|
||||
@@ -1303,14 +1251,20 @@
|
||||
(= name "every?") (step-ho-every args env kont)
|
||||
(= name "for-each") (step-ho-for-each args env kont)
|
||||
|
||||
;; Custom special forms (registered by extensions)
|
||||
(has-key? *custom-special-forms* name)
|
||||
(make-cek-value
|
||||
((get *custom-special-forms* name) args env)
|
||||
env kont)
|
||||
|
||||
;; Macro expansion
|
||||
(and (env-has? env name) (macro? (env-get env name)))
|
||||
(let ((mac (env-get env name)))
|
||||
(make-cek-state (expand-macro mac args env) env kont))
|
||||
|
||||
;; Render expression
|
||||
(and (render-active?) (is-render-expr? expr))
|
||||
(make-cek-value (render-expr expr env) env kont)
|
||||
;; Render dispatch (installed by web adapters)
|
||||
(and *render-check* (*render-check* expr env))
|
||||
(make-cek-value (*render-fn* expr env) env kont)
|
||||
|
||||
;; Fall through to function call
|
||||
:else (step-eval-call head args env kont)))
|
||||
@@ -1451,11 +1405,7 @@
|
||||
(let ((clause (first args))
|
||||
(test (first clause)))
|
||||
;; Check for :else / else
|
||||
(if (or (and (= (type-of test) "symbol")
|
||||
(or (= (symbol-name test) "else")
|
||||
(= (symbol-name test) ":else")))
|
||||
(and (= (type-of test) "keyword")
|
||||
(= (keyword-name test) "else")))
|
||||
(if (is-else-clause? test)
|
||||
(make-cek-state (nth clause 1) env kont)
|
||||
(make-cek-state
|
||||
test env
|
||||
@@ -1464,10 +1414,7 @@
|
||||
(if (< (len args) 2)
|
||||
(make-cek-value nil env kont)
|
||||
(let ((test (first args)))
|
||||
(if (or (and (= (type-of test) "keyword") (= (keyword-name test) "else"))
|
||||
(and (= (type-of test) "symbol")
|
||||
(or (= (symbol-name test) "else")
|
||||
(= (symbol-name test) ":else"))))
|
||||
(if (is-else-clause? test)
|
||||
(make-cek-state (nth args 1) env kont)
|
||||
(make-cek-state
|
||||
test env
|
||||
@@ -1493,7 +1440,12 @@
|
||||
(make-cek-value (sf-lambda args env) env kont)))
|
||||
|
||||
;; scope: evaluate name, then push ScopeFrame
|
||||
;; scope: push ScopeAccFrame, evaluate body. emit!/emitted walk kont.
|
||||
;; scope/provide/context/emit!/emitted — CEK frame-based.
|
||||
;; provide/scope push proper CEK frames onto the continuation so that
|
||||
;; shift/reset can capture and restore them correctly.
|
||||
;; context/emit!/emitted walk the kont to find the relevant frame.
|
||||
|
||||
;; scope: push ScopeAccFrame, evaluate body expressions via continuation.
|
||||
;; (scope name body...) or (scope name :value v body...)
|
||||
(define step-sf-scope
|
||||
(fn (args env kont)
|
||||
@@ -1501,43 +1453,31 @@
|
||||
(rest-args (slice args 1))
|
||||
(val nil)
|
||||
(body nil))
|
||||
;; Check for :value keyword
|
||||
(if (and (>= (len rest-args) 2)
|
||||
(= (type-of (first rest-args)) "keyword")
|
||||
(= (keyword-name (first rest-args)) "value"))
|
||||
(do (set! val (trampoline (eval-expr (nth rest-args 1) env)))
|
||||
(set! body (slice rest-args 2)))
|
||||
(set! body rest-args))
|
||||
;; Push ScopeAccFrame and start evaluating body
|
||||
(if (empty? body)
|
||||
(make-cek-value nil env kont)
|
||||
(if (= (len body) 1)
|
||||
(make-cek-state (first body) env
|
||||
(kont-push (make-scope-acc-frame name val (list) env) kont))
|
||||
(make-cek-state (first body) env
|
||||
(kont-push
|
||||
(make-scope-acc-frame name val (rest body) env)
|
||||
kont)))))))
|
||||
(make-cek-state
|
||||
(first body) env
|
||||
(kont-push (make-scope-acc-frame name val (rest body) env) kont))))))
|
||||
|
||||
;; provide: push ProvideFrame, evaluate body. context walks kont to read.
|
||||
;; (provide name value body...)
|
||||
;; provide: push ProvideFrame, evaluate body expressions via continuation.
|
||||
(define step-sf-provide
|
||||
(fn (args env kont)
|
||||
(let ((name (trampoline (eval-expr (first args) env)))
|
||||
(val (trampoline (eval-expr (nth args 1) env)))
|
||||
(body (slice args 2)))
|
||||
;; Push ProvideFrame and start evaluating body
|
||||
(if (empty? body)
|
||||
(make-cek-value nil env kont)
|
||||
(if (= (len body) 1)
|
||||
(make-cek-state (first body) env
|
||||
(kont-push (make-provide-frame name val (list) env) kont))
|
||||
(make-cek-state (first body) env
|
||||
(kont-push
|
||||
(make-provide-frame name val (rest body) env)
|
||||
kont)))))))
|
||||
(make-cek-state
|
||||
(first body) env
|
||||
(kont-push (make-provide-frame name val (rest body) env) kont))))))
|
||||
|
||||
;; context: walk kont for nearest ProvideFrame with matching name
|
||||
;; context: walk kont for nearest ProvideFrame with matching name.
|
||||
(define step-sf-context
|
||||
(fn (args env kont)
|
||||
(let ((name (trampoline (eval-expr (first args) env)))
|
||||
@@ -1545,31 +1485,24 @@
|
||||
(trampoline (eval-expr (nth args 1) env))
|
||||
nil))
|
||||
(frame (kont-find-provide kont name)))
|
||||
(if frame
|
||||
(make-cek-value (get frame "value") env kont)
|
||||
(if (>= (len args) 2)
|
||||
(make-cek-value default-val env kont)
|
||||
(error (str "No provider for: " name)))))))
|
||||
(make-cek-value (if (nil? frame) default-val (get frame "value")) env kont))))
|
||||
|
||||
;; emit!: walk kont for nearest ScopeAccFrame, append value
|
||||
;; emit!: walk kont for nearest ScopeAccFrame, append to its emitted list.
|
||||
(define step-sf-emit
|
||||
(fn (args env kont)
|
||||
(let ((name (trampoline (eval-expr (first args) env)))
|
||||
(val (trampoline (eval-expr (nth args 1) env)))
|
||||
(frame (kont-find-scope-acc kont name)))
|
||||
(if frame
|
||||
(do (append! (get frame "emitted") val)
|
||||
(make-cek-value nil env kont))
|
||||
(error (str "No scope for emit!: " name))))))
|
||||
(when frame
|
||||
(dict-set! frame "emitted" (append (get frame "emitted") (list val))))
|
||||
(make-cek-value nil env kont))))
|
||||
|
||||
;; emitted: walk kont for nearest ScopeAccFrame, return accumulated list
|
||||
;; emitted: walk kont for nearest ScopeAccFrame, return its emitted list.
|
||||
(define step-sf-emitted
|
||||
(fn (args env kont)
|
||||
(let ((name (trampoline (eval-expr (first args) env)))
|
||||
(frame (kont-find-scope-acc kont name)))
|
||||
(if frame
|
||||
(make-cek-value (get frame "emitted") env kont)
|
||||
(error (str "No scope for emitted: " name))))))
|
||||
(make-cek-value (if (nil? frame) (list) (get frame "emitted")) env kont))))
|
||||
|
||||
;; reset: push ResetFrame, evaluate body
|
||||
(define step-sf-reset
|
||||
@@ -1604,13 +1537,18 @@
|
||||
(kont-push (make-deref-frame env) kont))))
|
||||
|
||||
;; cek-call — call a function via CEK (replaces invoke)
|
||||
;; cek-call — unified function dispatch
|
||||
;; Both lambdas and native callables go through continue-with-call
|
||||
;; so they interact identically with the continuation stack.
|
||||
;; This is critical: replacing a native callable with an SX lambda
|
||||
;; (e.g. stdlib.sx) must not change shift/reset behavior.
|
||||
(define cek-call
|
||||
(fn (f args)
|
||||
(let ((a (if (nil? args) (list) args)))
|
||||
(cond
|
||||
(nil? f) nil
|
||||
(lambda? f) (cek-run (continue-with-call f a (dict) a (list)))
|
||||
(callable? f) (apply f a)
|
||||
(or (lambda? f) (callable? f))
|
||||
(cek-run (continue-with-call f a (make-env) a (list)))
|
||||
:else nil))))
|
||||
|
||||
;; reactive-shift-deref: the heart of deref-as-shift
|
||||
@@ -1950,11 +1888,7 @@
|
||||
(make-cek-value nil fenv rest-k)
|
||||
(let ((next-clause (first next-clauses))
|
||||
(next-test (first next-clause)))
|
||||
(if (or (and (= (type-of next-test) "symbol")
|
||||
(or (= (symbol-name next-test) "else")
|
||||
(= (symbol-name next-test) ":else")))
|
||||
(and (= (type-of next-test) "keyword")
|
||||
(= (keyword-name next-test) "else")))
|
||||
(if (is-else-clause? next-test)
|
||||
(make-cek-state (nth next-clause 1) fenv rest-k)
|
||||
(make-cek-state
|
||||
next-test fenv
|
||||
@@ -1966,10 +1900,7 @@
|
||||
(if (< (len next) 2)
|
||||
(make-cek-value nil fenv rest-k)
|
||||
(let ((next-test (first next)))
|
||||
(if (or (and (= (type-of next-test) "keyword") (= (keyword-name next-test) "else"))
|
||||
(and (= (type-of next-test) "symbol")
|
||||
(or (= (symbol-name next-test) "else")
|
||||
(= (symbol-name next-test) ":else"))))
|
||||
(if (is-else-clause? next-test)
|
||||
(make-cek-state (nth next 1) fenv rest-k)
|
||||
(make-cek-state
|
||||
next-test fenv
|
||||
@@ -2326,6 +2257,7 @@
|
||||
:else (error (str "Not callable: " (inspect f))))))
|
||||
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 10. Case step loop helper
|
||||
;; --------------------------------------------------------------------------
|
||||
@@ -2336,10 +2268,7 @@
|
||||
(make-cek-value nil env kont)
|
||||
(let ((test (first clauses))
|
||||
(body (nth clauses 1)))
|
||||
(if (or (and (= (type-of test) "keyword") (= (keyword-name test) "else"))
|
||||
(and (= (type-of test) "symbol")
|
||||
(or (= (symbol-name test) "else")
|
||||
(= (symbol-name test) ":else"))))
|
||||
(if (is-else-clause? test)
|
||||
(make-cek-state body env kont)
|
||||
;; Evaluate test expression
|
||||
(let ((test-val (trampoline (eval-expr test env))))
|
||||
@@ -2368,150 +2297,6 @@
|
||||
val)))
|
||||
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 13. Freeze scopes — named serializable state boundaries
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; A freeze scope collects signals registered within it. On freeze,
|
||||
;; their current values are serialized to SX. On thaw, values are
|
||||
;; restored. Multiple named scopes can coexist independently.
|
||||
;;
|
||||
;; Uses the scoped effects system: scope-push!/scope-pop!/context.
|
||||
;;
|
||||
;; Usage:
|
||||
;; (freeze-scope "editor"
|
||||
;; (let ((doc (signal "hello")))
|
||||
;; (freeze-signal "doc" doc)
|
||||
;; ...))
|
||||
;;
|
||||
;; (cek-freeze-scope "editor") → {:name "editor" :signals {:doc "hello"}}
|
||||
;; (cek-thaw-scope "editor" frozen-data) → restores signal values
|
||||
|
||||
;; Registry of freeze scopes: name → list of {name signal} entries
|
||||
(define freeze-registry (dict))
|
||||
|
||||
;; Register a signal in the current freeze scope
|
||||
(define freeze-signal :effects [mutation]
|
||||
(fn (name sig)
|
||||
(let ((scope-name (context "sx-freeze-scope" nil)))
|
||||
(when scope-name
|
||||
(let ((entries (or (get freeze-registry scope-name) (list))))
|
||||
(append! entries (dict "name" name "signal" sig))
|
||||
(dict-set! freeze-registry scope-name entries))))))
|
||||
|
||||
;; Freeze scope delimiter — collects signals registered within body
|
||||
(define freeze-scope :effects [mutation]
|
||||
(fn (name body-fn)
|
||||
(scope-push! "sx-freeze-scope" name)
|
||||
;; Initialize empty entry list for this scope
|
||||
(dict-set! freeze-registry name (list))
|
||||
(cek-call body-fn nil)
|
||||
(scope-pop! "sx-freeze-scope")
|
||||
nil))
|
||||
|
||||
;; Freeze a named scope → SX dict of signal values
|
||||
(define cek-freeze-scope :effects []
|
||||
(fn (name)
|
||||
(let ((entries (or (get freeze-registry name) (list)))
|
||||
(signals-dict (dict)))
|
||||
(for-each (fn (entry)
|
||||
(dict-set! signals-dict
|
||||
(get entry "name")
|
||||
(signal-value (get entry "signal"))))
|
||||
entries)
|
||||
(dict "name" name "signals" signals-dict))))
|
||||
|
||||
;; Freeze all scopes
|
||||
(define cek-freeze-all :effects []
|
||||
(fn ()
|
||||
(map (fn (name) (cek-freeze-scope name))
|
||||
(keys freeze-registry))))
|
||||
|
||||
;; Thaw a named scope — restore signal values from frozen data
|
||||
(define cek-thaw-scope :effects [mutation]
|
||||
(fn (name frozen)
|
||||
(let ((entries (or (get freeze-registry name) (list)))
|
||||
(values (get frozen "signals")))
|
||||
(when values
|
||||
(for-each (fn (entry)
|
||||
(let ((sig-name (get entry "name"))
|
||||
(sig (get entry "signal"))
|
||||
(val (get values sig-name)))
|
||||
(when (not (nil? val))
|
||||
(reset! sig val))))
|
||||
entries)))))
|
||||
|
||||
;; Thaw all scopes from a list of frozen scope dicts
|
||||
(define cek-thaw-all :effects [mutation]
|
||||
(fn (frozen-list)
|
||||
(for-each (fn (frozen)
|
||||
(cek-thaw-scope (get frozen "name") frozen))
|
||||
frozen-list)))
|
||||
|
||||
;; Serialize a frozen scope to SX text
|
||||
(define freeze-to-sx :effects []
|
||||
(fn (name)
|
||||
(sx-serialize (cek-freeze-scope name))))
|
||||
|
||||
;; Restore from SX text
|
||||
(define thaw-from-sx :effects [mutation]
|
||||
(fn (sx-text)
|
||||
(let ((parsed (sx-parse sx-text)))
|
||||
(when (not (empty? parsed))
|
||||
(let ((frozen (first parsed)))
|
||||
(cek-thaw-scope (get frozen "name") frozen))))))
|
||||
|
||||
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 14. Content-addressed computation
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Hash frozen SX to a content identifier. Store and retrieve by CID.
|
||||
;; The content IS the address — same SX always produces the same CID.
|
||||
;;
|
||||
;; Uses an in-memory content store. Applications can persist to
|
||||
;; localStorage or IPFS by providing their own store backend.
|
||||
|
||||
(define content-store (dict))
|
||||
|
||||
(define content-hash :effects []
|
||||
(fn (sx-text)
|
||||
;; djb2 hash → hex string. Simple, deterministic, fast.
|
||||
;; Real deployment would use SHA-256 / multihash.
|
||||
(let ((hash 5381))
|
||||
(for-each (fn (i)
|
||||
(set! hash (mod (+ (* hash 33) (char-code-at sx-text i)) 4294967296)))
|
||||
(range 0 (len sx-text)))
|
||||
(to-hex hash))))
|
||||
|
||||
(define content-put :effects [mutation]
|
||||
(fn (sx-text)
|
||||
(let ((cid (content-hash sx-text)))
|
||||
(dict-set! content-store cid sx-text)
|
||||
cid)))
|
||||
|
||||
(define content-get :effects []
|
||||
(fn (cid)
|
||||
(get content-store cid)))
|
||||
|
||||
;; Freeze a scope → store → return CID
|
||||
(define freeze-to-cid :effects [mutation]
|
||||
(fn (scope-name)
|
||||
(let ((sx-text (freeze-to-sx scope-name)))
|
||||
(content-put sx-text))))
|
||||
|
||||
;; Thaw from CID → look up → restore
|
||||
(define thaw-from-cid :effects [mutation]
|
||||
(fn (cid)
|
||||
(let ((sx-text (content-get cid)))
|
||||
(when sx-text
|
||||
(thaw-from-sx sx-text)
|
||||
true))))
|
||||
|
||||
|
||||
;; **************************************************************************
|
||||
;; eval-expr / trampoline — canonical definitions (after cek-run is defined)
|
||||
;; **************************************************************************
|
||||
|
||||
@@ -1,36 +1,38 @@
|
||||
;; ==========================================================================
|
||||
;; primitives.sx — Specification of all SX built-in pure functions
|
||||
;; primitives.sx — Irreducible primitive set
|
||||
;;
|
||||
;; Each entry declares: name, parameter signature, and semantics.
|
||||
;; Bootstrap compilers implement these natively per target.
|
||||
;; These are the functions that CANNOT be written in SX because they
|
||||
;; require host-native capabilities: native arithmetic, type inspection,
|
||||
;; host string library, host math, host I/O, host data structures.
|
||||
;;
|
||||
;; This file is a SPECIFICATION, not executable code. The define-primitive
|
||||
;; form is a declarative macro that bootstrap compilers consume to generate
|
||||
;; native primitive registrations.
|
||||
;; Everything else lives in spec/stdlib.sx as library functions.
|
||||
;;
|
||||
;; The primitive set is the out-of-band floor. The fewer primitives,
|
||||
;; the tighter the strange loop and the more of the system is auditable,
|
||||
;; verifiable, portable SX.
|
||||
;;
|
||||
;; Format:
|
||||
;; (define-primitive "name"
|
||||
;; :params (param1 param2 &rest rest)
|
||||
;; :returns "type"
|
||||
;; :doc "description"
|
||||
;; :body (reference-implementation ...))
|
||||
;; :doc "description")
|
||||
;;
|
||||
;; Typed params use (name :as type) syntax:
|
||||
;; (define-primitive "+"
|
||||
;; :params (&rest (args :as number))
|
||||
;; :returns "number"
|
||||
;; :doc "Sum all arguments.")
|
||||
;; Typed params use (name :as type) syntax.
|
||||
;; Modules: (define-module :name) scopes subsequent entries.
|
||||
;;
|
||||
;; Untyped params default to `any`. Typed params enable the gradual
|
||||
;; type checker (types.sx) to catch mistyped primitive calls.
|
||||
;;
|
||||
;; The :body is optional — when provided, it gives a reference
|
||||
;; implementation in SX that bootstrap compilers MAY use for testing
|
||||
;; or as a fallback. Most targets will implement natively for performance.
|
||||
;;
|
||||
;; Modules: (define-module :name) scopes subsequent define-primitive
|
||||
;; entries until the next define-module. Bootstrappers use this to
|
||||
;; selectively include primitive groups.
|
||||
;; Functions moved to stdlib.sx (no longer primitives):
|
||||
;; Comparison: != <= >= eq? eqv? equal?
|
||||
;; Predicates: nil? boolean? number? string? list? dict?
|
||||
;; continuation? empty? odd? even? zero? contains?
|
||||
;; Arithmetic: inc dec abs ceil round min max clamp
|
||||
;; Collections: first last rest nth cons append reverse flatten
|
||||
;; range chunk-every zip-pairs vals has-key? merge
|
||||
;; assoc dissoc into
|
||||
;; Strings: upcase downcase string-length substring
|
||||
;; string-contains? starts-with? ends-with?
|
||||
;; split join replace
|
||||
;; Logic: not
|
||||
;; Text: pluralize escape assert parse-datetime
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
|
||||
@@ -32,7 +32,7 @@
|
||||
"div" "p" "blockquote" "pre" "figure" "figcaption" "address" "details" "summary"
|
||||
;; Inline
|
||||
"a" "span" "em" "strong" "small" "b" "i" "u" "s" "mark" "sub" "sup"
|
||||
"abbr" "cite" "code" "time" "br" "wbr" "hr"
|
||||
"abbr" "cite" "code" "kbd" "samp" "var" "time" "br" "wbr" "hr"
|
||||
;; Lists
|
||||
"ul" "ol" "li" "dl" "dt" "dd"
|
||||
;; Tables
|
||||
@@ -71,11 +71,16 @@
|
||||
;; Shared utilities
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Extension point for definition forms — modules append names here.
|
||||
;; Survives spec reloads (no function wrapping needed).
|
||||
(define *definition-form-extensions* (list))
|
||||
|
||||
(define definition-form? :effects []
|
||||
(fn ((name :as string))
|
||||
(or (= name "define") (= name "defcomp") (= name "defisland")
|
||||
(= name "defmacro") (= name "defstyle") (= name "defhandler")
|
||||
(= name "deftype") (= name "defeffect"))))
|
||||
(= name "defmacro") (= name "defstyle")
|
||||
(= name "deftype") (= name "defeffect")
|
||||
(contains? *definition-form-extensions* name))))
|
||||
|
||||
|
||||
(define parse-element-args :effects [render]
|
||||
@@ -146,11 +151,7 @@
|
||||
(let ((clause (first clauses))
|
||||
(test (first clause))
|
||||
(body (nth clause 1)))
|
||||
(if (or (and (= (type-of test) "symbol")
|
||||
(or (= (symbol-name test) "else")
|
||||
(= (symbol-name test) ":else")))
|
||||
(and (= (type-of test) "keyword")
|
||||
(= (keyword-name test) "else")))
|
||||
(if (is-else-clause? test)
|
||||
body
|
||||
(if (trampoline (eval-expr test env))
|
||||
body
|
||||
@@ -162,10 +163,7 @@
|
||||
nil
|
||||
(let ((test (first clauses))
|
||||
(body (nth clauses 1)))
|
||||
(if (or (and (= (type-of test) "keyword") (= (keyword-name test) "else"))
|
||||
(and (= (type-of test) "symbol")
|
||||
(or (= (symbol-name test) "else")
|
||||
(= (symbol-name test) ":else"))))
|
||||
(if (is-else-clause? test)
|
||||
body
|
||||
(if (trampoline (eval-expr test env))
|
||||
body
|
||||
@@ -250,13 +248,29 @@
|
||||
(keys spread-dict))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; HTML escaping — library functions (pure text processing)
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define escape-html
|
||||
(fn (s)
|
||||
(let ((r (str s)))
|
||||
(set! r (replace r "&" "&"))
|
||||
(set! r (replace r "<" "<"))
|
||||
(set! r (replace r ">" ">"))
|
||||
(set! r (replace r "\"" """))
|
||||
r)))
|
||||
|
||||
(define escape-attr
|
||||
(fn (s)
|
||||
(escape-html s)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Platform interface (shared across adapters)
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; HTML/attribute escaping (used by HTML and SX wire adapters):
|
||||
;; (escape-html s) → HTML-escaped string
|
||||
;; (escape-attr s) → attribute-value-escaped string
|
||||
;; Raw HTML (marker type for unescaped content):
|
||||
;; (raw-html-content r) → unwrap RawHTML marker to string
|
||||
;;
|
||||
;; Spread (render-time attribute injection):
|
||||
|
||||
@@ -566,181 +566,3 @@
|
||||
(assert-equal 0 (len (list)))
|
||||
(assert-equal "" (str))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Server-only tests — skip in browser (defpage, streaming functions)
|
||||
;; These require forms.sx which is only loaded server-side.
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(when (get (try-call (fn () stream-chunk-id)) "ok")
|
||||
|
||||
(defsuite "defpage"
|
||||
(deftest "basic defpage returns page-def"
|
||||
(let ((p (defpage test-basic :path "/test" :auth :public :content (div "hello"))))
|
||||
(assert-true (not (nil? p)))
|
||||
(assert-equal "test-basic" (get p "name"))
|
||||
(assert-equal "/test" (get p "path"))
|
||||
(assert-equal "public" (get p "auth"))))
|
||||
|
||||
(deftest "defpage content expr is unevaluated AST"
|
||||
(let ((p (defpage test-content :path "/c" :auth :public :content (~my-comp :title "hi"))))
|
||||
(assert-true (not (nil? (get p "content"))))))
|
||||
|
||||
(deftest "defpage with :stream"
|
||||
(let ((p (defpage test-stream :path "/s" :auth :public :stream true :content (div "x"))))
|
||||
(assert-equal true (get p "stream"))))
|
||||
|
||||
(deftest "defpage with :shell"
|
||||
(let ((p (defpage test-shell :path "/sh" :auth :public :stream true
|
||||
:shell (~my-layout (~suspense :id "data" :fallback (div "loading...")))
|
||||
:content (~my-streamed :data data-val))))
|
||||
(assert-true (not (nil? (get p "shell"))))
|
||||
(assert-true (not (nil? (get p "content"))))))
|
||||
|
||||
(deftest "defpage with :fallback"
|
||||
(let ((p (defpage test-fallback :path "/f" :auth :public :stream true
|
||||
:fallback (div :class "skeleton" "loading")
|
||||
:content (div "done"))))
|
||||
(assert-true (not (nil? (get p "fallback"))))))
|
||||
|
||||
(deftest "defpage with :data"
|
||||
(let ((p (defpage test-data :path "/d" :auth :public
|
||||
:data (fetch-items)
|
||||
:content (~items-list :items items))))
|
||||
(assert-true (not (nil? (get p "data"))))))
|
||||
|
||||
(deftest "defpage missing fields are nil"
|
||||
(let ((p (defpage test-minimal :path "/m" :auth :public :content (div "x"))))
|
||||
(assert-nil (get p "data"))
|
||||
(assert-nil (get p "filter"))
|
||||
(assert-nil (get p "aside"))
|
||||
(assert-nil (get p "menu"))
|
||||
(assert-nil (get p "shell"))
|
||||
(assert-nil (get p "fallback"))
|
||||
(assert-equal false (get p "stream")))))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Multi-stream data protocol (from forms.sx)
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "stream-chunk-id"
|
||||
(deftest "extracts stream-id from chunk"
|
||||
(assert-equal "my-slot" (stream-chunk-id {"stream-id" "my-slot" "x" 1})))
|
||||
|
||||
(deftest "defaults to stream-content when missing"
|
||||
(assert-equal "stream-content" (stream-chunk-id {"x" 1 "y" 2}))))
|
||||
|
||||
(defsuite "stream-chunk-bindings"
|
||||
(deftest "removes stream-id from chunk"
|
||||
(let ((bindings (stream-chunk-bindings {"stream-id" "slot" "name" "alice" "age" 30})))
|
||||
(assert-equal "alice" (get bindings "name"))
|
||||
(assert-equal 30 (get bindings "age"))
|
||||
(assert-nil (get bindings "stream-id"))))
|
||||
|
||||
(deftest "returns all keys when no stream-id"
|
||||
(let ((bindings (stream-chunk-bindings {"a" 1 "b" 2})))
|
||||
(assert-equal 1 (get bindings "a"))
|
||||
(assert-equal 2 (get bindings "b")))))
|
||||
|
||||
(defsuite "normalize-binding-key"
|
||||
(deftest "converts underscores to hyphens"
|
||||
(assert-equal "my-key" (normalize-binding-key "my_key")))
|
||||
|
||||
(deftest "leaves hyphens unchanged"
|
||||
(assert-equal "my-key" (normalize-binding-key "my-key")))
|
||||
|
||||
(deftest "handles multiple underscores"
|
||||
(assert-equal "a-b-c" (normalize-binding-key "a_b_c"))))
|
||||
|
||||
(defsuite "bind-stream-chunk"
|
||||
(deftest "creates fresh env with bindings"
|
||||
(let ((base {"existing" 42})
|
||||
(chunk {"stream-id" "slot" "user-name" "bob" "count" 5})
|
||||
(env (bind-stream-chunk chunk base)))
|
||||
;; Base env bindings are preserved
|
||||
(assert-equal 42 (get env "existing"))
|
||||
;; Chunk bindings are added (stream-id removed)
|
||||
(assert-equal "bob" (get env "user-name"))
|
||||
(assert-equal 5 (get env "count"))
|
||||
;; stream-id is not in env
|
||||
(assert-nil (get env "stream-id"))))
|
||||
|
||||
(deftest "isolates env from base — bindings don't leak to base"
|
||||
(let ((base {"x" 1})
|
||||
(chunk {"stream-id" "s" "y" 2})
|
||||
(env (bind-stream-chunk chunk base)))
|
||||
;; Chunk bindings should not appear in base
|
||||
(assert-nil (get base "y"))
|
||||
;; Base bindings should be in derived env
|
||||
(assert-equal 1 (get env "x")))))
|
||||
|
||||
(defsuite "validate-stream-data"
|
||||
(deftest "valid: list of dicts"
|
||||
(assert-true (validate-stream-data
|
||||
(list {"stream-id" "a" "x" 1}
|
||||
{"stream-id" "b" "y" 2}))))
|
||||
|
||||
(deftest "valid: empty list"
|
||||
(assert-true (validate-stream-data (list))))
|
||||
|
||||
(deftest "invalid: single dict (not a list)"
|
||||
(assert-equal false (validate-stream-data {"x" 1})))
|
||||
|
||||
(deftest "invalid: list containing non-dict"
|
||||
(assert-equal false (validate-stream-data (list {"x" 1} "oops" {"y" 2})))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Multi-stream end-to-end scenarios
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "multi-stream routing"
|
||||
(deftest "stream-chunk-id routes different chunks to different slots"
|
||||
(let ((chunks (list
|
||||
{"stream-id" "stream-fast" "msg" "quick"}
|
||||
{"stream-id" "stream-medium" "msg" "steady"}
|
||||
{"stream-id" "stream-slow" "msg" "slow"}))
|
||||
(ids (map stream-chunk-id chunks)))
|
||||
(assert-equal "stream-fast" (nth ids 0))
|
||||
(assert-equal "stream-medium" (nth ids 1))
|
||||
(assert-equal "stream-slow" (nth ids 2))))
|
||||
|
||||
(deftest "bind-stream-chunk creates isolated envs per chunk"
|
||||
(let ((base {"layout" "main"})
|
||||
(chunk-a {"stream-id" "a" "title" "First" "count" 1})
|
||||
(chunk-b {"stream-id" "b" "title" "Second" "count" 2})
|
||||
(env-a (bind-stream-chunk chunk-a base))
|
||||
(env-b (bind-stream-chunk chunk-b base)))
|
||||
;; Each env has its own bindings
|
||||
(assert-equal "First" (get env-a "title"))
|
||||
(assert-equal "Second" (get env-b "title"))
|
||||
(assert-equal 1 (get env-a "count"))
|
||||
(assert-equal 2 (get env-b "count"))
|
||||
;; Both share base
|
||||
(assert-equal "main" (get env-a "layout"))
|
||||
(assert-equal "main" (get env-b "layout"))
|
||||
;; Neither leaks into base
|
||||
(assert-nil (get base "title"))))
|
||||
|
||||
(deftest "normalize-binding-key applied to chunk keys"
|
||||
(let ((chunk {"stream-id" "s" "user_name" "alice" "item_count" 3})
|
||||
(bindings (stream-chunk-bindings chunk)))
|
||||
;; Keys with underscores need normalizing for SX env
|
||||
(assert-equal "alice" (get bindings "user_name"))
|
||||
;; normalize-binding-key converts them
|
||||
(assert-equal "user-name" (normalize-binding-key "user_name"))
|
||||
(assert-equal "item-count" (normalize-binding-key "item_count"))))
|
||||
|
||||
(deftest "defpage stream flag defaults to false"
|
||||
(let ((p (defpage test-no-stream :path "/ns" :auth :public :content (div "x"))))
|
||||
(assert-equal false (get p "stream"))))
|
||||
|
||||
(deftest "defpage stream true recorded in page-def"
|
||||
(let ((p (defpage test-with-stream :path "/ws" :auth :public
|
||||
:stream true
|
||||
:shell (~layout (~suspense :id "data"))
|
||||
:content (~chunk :val val))))
|
||||
(assert-equal true (get p "stream"))
|
||||
(assert-true (not (nil? (get p "shell")))))))
|
||||
|
||||
) ;; end (when has-server-forms?)
|
||||
|
||||
@@ -79,6 +79,19 @@
|
||||
(assert-length 1 result)
|
||||
(assert-equal (list 1 (list 2 3) 4) (first result))))
|
||||
|
||||
(deftest "parse sibling sublists"
|
||||
;; Regression: closing paren of (b) must not swallow (c) as a child
|
||||
(let ((result (sx-parse "(a (b) (c))")))
|
||||
(assert-length 1 result)
|
||||
(assert-length 3 (first result))
|
||||
(assert-equal (list (make-symbol "a") (list (make-symbol "b")) (list (make-symbol "c")))
|
||||
(first result))))
|
||||
|
||||
(deftest "parse multiple sibling sublists with content"
|
||||
(let ((result (sx-parse "(div (span 1) (span 2) (span 3))")))
|
||||
(assert-length 1 result)
|
||||
(assert-length 4 (first result))))
|
||||
|
||||
(deftest "parse square brackets as list"
|
||||
(let ((result (sx-parse "[1 2 3]")))
|
||||
(assert-length 1 result)
|
||||
@@ -522,3 +535,76 @@
|
||||
(deftest "parse nil is not a symbol"
|
||||
(let ((result (first (sx-parse "nil"))))
|
||||
(assert-nil result))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; JIT regression: mutable pos shared via upvalues across recursive calls
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "parser-jit-regression"
|
||||
(deftest "letrec parser with mutable pos — recursive sublists"
|
||||
;; Minimal reproducer for the sx-parse JIT bug.
|
||||
;; Uses define inside fn (like sx-parse's read-list-loop pattern).
|
||||
(let ((parse-fn (fn (src)
|
||||
(let ((pos 0))
|
||||
(letrec
|
||||
((read-list (fn ()
|
||||
(let ((result (list))
|
||||
(done false))
|
||||
(define go (fn ()
|
||||
(when (and (not done) (< pos (len src)))
|
||||
(let ((ch (nth src pos)))
|
||||
(set! pos (inc pos))
|
||||
(cond
|
||||
(= ch ")") (set! done true)
|
||||
(= ch "(") (do (append! result (read-list)) (go))
|
||||
:else (do (append! result ch) (go)))))))
|
||||
(go)
|
||||
result))))
|
||||
(set! pos 1)
|
||||
(read-list))))))
|
||||
(let ((r (parse-fn "(a(b)(c))")))
|
||||
(assert (list? r) (str "result should be list, got type=" (type-of r)))
|
||||
(assert-equal 3 (len r))
|
||||
(assert-equal (list "a" (list "b") (list "c")) r))))
|
||||
)
|
||||
|
||||
(defsuite "define-as-local"
|
||||
(deftest "define inside fn creates local, not global"
|
||||
;; When define is inside a fn body, recursive calls must each
|
||||
;; get their own copy. If define writes to global, recursive
|
||||
;; calls overwrite each other.
|
||||
(let ((result
|
||||
(let ((counter 0))
|
||||
(letrec
|
||||
((make-counter (fn ()
|
||||
(define my-val counter)
|
||||
(set! counter (inc counter))
|
||||
my-val)))
|
||||
(list (make-counter) (make-counter) (make-counter))))))
|
||||
(assert-equal (list 0 1 2) result)))
|
||||
|
||||
(deftest "define inside fn with self-recursion via define"
|
||||
;; read-list-loop pattern: define a function that calls itself
|
||||
(let ((result
|
||||
(let ((items (list)))
|
||||
(define go (fn (n)
|
||||
(when (< n 3)
|
||||
(append! items n)
|
||||
(go (inc n)))))
|
||||
(go 0)
|
||||
items)))
|
||||
(assert-equal (list 0 1 2) result)))
|
||||
|
||||
(deftest "recursive define inside letrec fn doesn't overwrite"
|
||||
;; Each call to make-list creates its own 'loop' local
|
||||
(let ((make-list (fn (items)
|
||||
(let ((result (list)))
|
||||
(define loop (fn (i)
|
||||
(when (< i (len items))
|
||||
(append! result (nth items i))
|
||||
(loop (inc i)))))
|
||||
(loop 0)
|
||||
result))))
|
||||
(assert-equal (list "a" "b") (make-list (list "a" "b")))
|
||||
(assert-equal (list 1 2 3) (make-list (list 1 2 3))))))
|
||||
|
||||
763
spec/tests/test-render-html.sx
Normal file
763
spec/tests/test-render-html.sx
Normal file
@@ -0,0 +1,763 @@
|
||||
;; ==========================================================================
|
||||
;; test-render-html.sx — Exhaustive tests for HTML rendering
|
||||
;;
|
||||
;; Tests render-to-html against the HTML serialization specification.
|
||||
;; Every test verifies the SX renderer produces correct HTML strings.
|
||||
;;
|
||||
;; Requires: test-framework.sx, adapter-html.sx loaded.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; Helper: render a QUOTED SX expression to HTML string.
|
||||
;; The expression is first evaluated in the env (to resolve symbols),
|
||||
;; then the result is passed to render-to-html.
|
||||
;; For simple values (strings, numbers), use rh-val instead.
|
||||
(define rh
|
||||
(fn (expr)
|
||||
(let ((env (env-extend (test-env))))
|
||||
(render-to-html expr env))))
|
||||
|
||||
;; Helper: render a literal value (no evaluation needed).
|
||||
;; Uses render-value-to-html which skips the eval-expr dispatch.
|
||||
(define rh-val
|
||||
(fn (val)
|
||||
(render-value-to-html val (env-extend (test-env)))))
|
||||
|
||||
;; Helper: render with a pre-built env
|
||||
(define rh-env
|
||||
(fn (expr env)
|
||||
(render-to-html expr env)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 1. Text content and literals
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "html-text"
|
||||
(deftest "string renders as escaped text"
|
||||
(assert-equal "hello" (rh-val "hello")))
|
||||
|
||||
(deftest "number renders as string"
|
||||
(assert-equal "42" (rh-val 42)))
|
||||
|
||||
(deftest "float renders as string"
|
||||
(assert-equal "3.14" (rh-val 3.14)))
|
||||
|
||||
(deftest "boolean true renders as text"
|
||||
(assert-equal "true" (rh-val true)))
|
||||
|
||||
(deftest "boolean false renders as text"
|
||||
(assert-equal "false" (rh-val false)))
|
||||
|
||||
(deftest "nil renders as empty string"
|
||||
(assert-equal "" (rh-val nil)))
|
||||
|
||||
(deftest "keyword renders as text"
|
||||
(assert-equal "hello" (rh-val :hello))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 2. HTML escaping — content
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "html-escaping-content"
|
||||
(deftest "ampersand escaped in text"
|
||||
(assert-equal "a & b" (rh-val "a & b")))
|
||||
|
||||
(deftest "less-than escaped in text"
|
||||
(assert-equal "a < b" (rh-val "a < b")))
|
||||
|
||||
(deftest "greater-than escaped in text"
|
||||
(assert-equal "a > b" (rh-val "a > b")))
|
||||
|
||||
(deftest "multiple special chars escaped"
|
||||
(assert-equal "<b>tag</b>"
|
||||
(rh-val "<b>tag</b>")))
|
||||
|
||||
(deftest "text inside element is escaped"
|
||||
(assert-equal "<p>a & b</p>"
|
||||
(rh '(p "a & b")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 3. HTML escaping — attributes
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "html-escaping-attrs"
|
||||
(deftest "ampersand escaped in attribute value"
|
||||
(assert-equal "<div title=\"a & b\"></div>"
|
||||
(rh '(div :title "a & b"))))
|
||||
|
||||
(deftest "angle brackets escaped in attribute value"
|
||||
(assert-equal "<div title=\"<b>\"></div>"
|
||||
(rh '(div :title "<b>")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 4. Normal elements — open tag, children, close tag
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "html-normal-elements"
|
||||
(deftest "div with text"
|
||||
(assert-equal "<div>hello</div>" (rh '(div "hello"))))
|
||||
|
||||
(deftest "p with text"
|
||||
(assert-equal "<p>paragraph</p>" (rh '(p "paragraph"))))
|
||||
|
||||
(deftest "span with text"
|
||||
(assert-equal "<span>inline</span>" (rh '(span "inline"))))
|
||||
|
||||
(deftest "empty div"
|
||||
(assert-equal "<div></div>" (rh '(div))))
|
||||
|
||||
(deftest "nested elements"
|
||||
(assert-equal "<div><p>inner</p></div>"
|
||||
(rh '(div (p "inner")))))
|
||||
|
||||
(deftest "multiple children"
|
||||
(assert-equal "<div><p>a</p><p>b</p></div>"
|
||||
(rh '(div (p "a") (p "b")))))
|
||||
|
||||
(deftest "deep nesting"
|
||||
(assert-equal "<div><section><article><p>deep</p></article></section></div>"
|
||||
(rh '(div (section (article (p "deep")))))))
|
||||
|
||||
(deftest "mixed text and element children"
|
||||
(assert-equal "<p>hello <strong>world</strong></p>"
|
||||
(rh '(p "hello " (strong "world"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 5. Void elements — self-closing, no children
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "html-void-elements"
|
||||
(deftest "br"
|
||||
(assert-equal "<br />" (rh '(br))))
|
||||
|
||||
(deftest "hr"
|
||||
(assert-equal "<hr />" (rh '(hr))))
|
||||
|
||||
(deftest "img with src"
|
||||
(assert-equal "<img src=\"photo.jpg\" />"
|
||||
(rh '(img :src "photo.jpg"))))
|
||||
|
||||
(deftest "input with type"
|
||||
(assert-equal "<input type=\"text\" />"
|
||||
(rh '(input :type "text"))))
|
||||
|
||||
(deftest "meta with charset"
|
||||
(assert-equal "<meta charset=\"utf-8\" />"
|
||||
(rh '(meta :charset "utf-8"))))
|
||||
|
||||
(deftest "link with rel and href"
|
||||
(assert-equal "<link rel=\"stylesheet\" href=\"style.css\" />"
|
||||
(rh '(link :rel "stylesheet" :href "style.css"))))
|
||||
|
||||
(deftest "source with src"
|
||||
(assert-equal "<source src=\"video.mp4\" />"
|
||||
(rh '(source :src "video.mp4"))))
|
||||
|
||||
(deftest "col"
|
||||
(assert-equal "<col />" (rh '(col))))
|
||||
|
||||
(deftest "wbr"
|
||||
(assert-equal "<wbr />" (rh '(wbr)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 6. Boolean attributes — name only when truthy
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "html-boolean-attrs"
|
||||
(deftest "checked true"
|
||||
(assert-equal "<input checked />"
|
||||
(rh '(input :checked true))))
|
||||
|
||||
(deftest "checked false omitted"
|
||||
(assert-equal "<input />"
|
||||
(rh '(input :checked false))))
|
||||
|
||||
(deftest "disabled true"
|
||||
(assert-equal "<button disabled>click</button>"
|
||||
(rh '(button :disabled true "click"))))
|
||||
|
||||
(deftest "disabled false omitted"
|
||||
(assert-equal "<button>click</button>"
|
||||
(rh '(button :disabled false "click"))))
|
||||
|
||||
(deftest "readonly"
|
||||
(assert-equal "<input readonly />"
|
||||
(rh '(input :readonly true))))
|
||||
|
||||
(deftest "required"
|
||||
(assert-equal "<input required />"
|
||||
(rh '(input :required true))))
|
||||
|
||||
(deftest "multiple"
|
||||
(assert-equal "<select multiple></select>"
|
||||
(rh '(select :multiple true))))
|
||||
|
||||
(deftest "hidden"
|
||||
(assert-equal "<div hidden></div>"
|
||||
(rh '(div :hidden true))))
|
||||
|
||||
(deftest "autofocus"
|
||||
(assert-equal "<input autofocus />"
|
||||
(rh '(input :autofocus true))))
|
||||
|
||||
(deftest "autoplay"
|
||||
(assert-equal "<video autoplay></video>"
|
||||
(rh '(video :autoplay true))))
|
||||
|
||||
(deftest "loop"
|
||||
(assert-equal "<video loop></video>"
|
||||
(rh '(video :loop true))))
|
||||
|
||||
(deftest "muted"
|
||||
(assert-equal "<video muted></video>"
|
||||
(rh '(video :muted true))))
|
||||
|
||||
(deftest "controls"
|
||||
(assert-equal "<audio controls></audio>"
|
||||
(rh '(audio :controls true))))
|
||||
|
||||
(deftest "selected"
|
||||
(assert-equal "<option selected>yes</option>"
|
||||
(rh '(option :selected true "yes"))))
|
||||
|
||||
(deftest "open (details)"
|
||||
(assert-equal "<details open></details>"
|
||||
(rh '(details :open true))))
|
||||
|
||||
(deftest "defer"
|
||||
(assert-equal "<script defer></script>"
|
||||
(rh '(script :defer true))))
|
||||
|
||||
(deftest "async"
|
||||
(assert-equal "<script async></script>"
|
||||
(rh '(script :async true))))
|
||||
|
||||
(deftest "novalidate"
|
||||
(assert-equal "<form novalidate></form>"
|
||||
(rh '(form :novalidate true)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 7. Regular attributes
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "html-regular-attrs"
|
||||
(deftest "class attribute"
|
||||
(assert-equal "<div class=\"container\"></div>"
|
||||
(rh '(div :class "container"))))
|
||||
|
||||
(deftest "id attribute"
|
||||
(assert-equal "<div id=\"main\"></div>"
|
||||
(rh '(div :id "main"))))
|
||||
|
||||
(deftest "style attribute"
|
||||
(assert-equal "<div style=\"color: red\"></div>"
|
||||
(rh '(div :style "color: red"))))
|
||||
|
||||
(deftest "data-* attribute"
|
||||
(assert-equal "<div data-value=\"42\"></div>"
|
||||
(rh '(div :data-value "42"))))
|
||||
|
||||
(deftest "aria-* attribute"
|
||||
(assert-equal "<div aria-label=\"close\"></div>"
|
||||
(rh '(div :aria-label "close"))))
|
||||
|
||||
(deftest "multiple attributes"
|
||||
(assert-equal "<a href=\"/\" class=\"link\">home</a>"
|
||||
(rh '(a :href "/" :class "link" "home"))))
|
||||
|
||||
(deftest "nil attribute omitted"
|
||||
(assert-equal "<div></div>"
|
||||
(rh '(div :class nil))))
|
||||
|
||||
(deftest "numeric attribute value"
|
||||
(assert-equal "<input maxlength=\"10\" />"
|
||||
(rh '(input :maxlength 10)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 8. Fragments — children without wrapper
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "html-fragments"
|
||||
(deftest "fragment renders children without wrapper"
|
||||
(assert-equal "<p>a</p><p>b</p>"
|
||||
(rh '(<> (p "a") (p "b")))))
|
||||
|
||||
(deftest "empty fragment"
|
||||
(assert-equal "" (rh '(<>))))
|
||||
|
||||
(deftest "fragment with text"
|
||||
(assert-equal "hello world"
|
||||
(rh '(<> "hello " "world"))))
|
||||
|
||||
(deftest "nested fragment"
|
||||
(assert-equal "<p>a</p><p>b</p>"
|
||||
(rh '(<> (<> (p "a")) (p "b"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 9. Raw HTML — unescaped passthrough
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "html-raw"
|
||||
(deftest "raw! passes through unescaped"
|
||||
(assert-equal "<b>bold</b>"
|
||||
(rh '(raw! "<b>bold</b>"))))
|
||||
|
||||
(deftest "raw! with multiple args"
|
||||
(assert-equal "<em>a</em><em>b</em>"
|
||||
(rh '(raw! "<em>a</em>" "<em>b</em>")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 10. Heading levels
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "html-headings"
|
||||
(deftest "h1" (assert-equal "<h1>title</h1>" (rh '(h1 "title"))))
|
||||
(deftest "h2" (assert-equal "<h2>sub</h2>" (rh '(h2 "sub"))))
|
||||
(deftest "h3" (assert-equal "<h3>sec</h3>" (rh '(h3 "sec"))))
|
||||
(deftest "h4" (assert-equal "<h4>sub</h4>" (rh '(h4 "sub"))))
|
||||
(deftest "h5" (assert-equal "<h5>sub</h5>" (rh '(h5 "sub"))))
|
||||
(deftest "h6" (assert-equal "<h6>sub</h6>" (rh '(h6 "sub")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 11. Lists (HTML)
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "html-lists"
|
||||
(deftest "unordered list"
|
||||
(assert-equal "<ul><li>a</li><li>b</li></ul>"
|
||||
(rh '(ul (li "a") (li "b")))))
|
||||
|
||||
(deftest "ordered list"
|
||||
(assert-equal "<ol><li>1</li><li>2</li></ol>"
|
||||
(rh '(ol (li "1") (li "2")))))
|
||||
|
||||
(deftest "definition list"
|
||||
(assert-equal "<dl><dt>term</dt><dd>def</dd></dl>"
|
||||
(rh '(dl (dt "term") (dd "def"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 12. Tables
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "html-tables"
|
||||
(deftest "basic table"
|
||||
(assert-equal "<table><tr><td>cell</td></tr></table>"
|
||||
(rh '(table (tr (td "cell"))))))
|
||||
|
||||
(deftest "table with header"
|
||||
(assert-equal "<table><thead><tr><th>col</th></tr></thead><tbody><tr><td>val</td></tr></tbody></table>"
|
||||
(rh '(table (thead (tr (th "col"))) (tbody (tr (td "val"))))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 13. Forms
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "html-forms"
|
||||
(deftest "form with action"
|
||||
(assert-equal "<form action=\"/submit\"></form>"
|
||||
(rh '(form :action "/submit"))))
|
||||
|
||||
(deftest "input types"
|
||||
(assert-equal "<input type=\"email\" />"
|
||||
(rh '(input :type "email"))))
|
||||
|
||||
(deftest "textarea"
|
||||
(assert-equal "<textarea>content</textarea>"
|
||||
(rh '(textarea "content"))))
|
||||
|
||||
(deftest "select with options"
|
||||
(assert-equal "<select><option>a</option><option>b</option></select>"
|
||||
(rh '(select (option "a") (option "b")))))
|
||||
|
||||
(deftest "button"
|
||||
(assert-equal "<button type=\"submit\">go</button>"
|
||||
(rh '(button :type "submit" "go"))))
|
||||
|
||||
(deftest "label with for"
|
||||
(assert-equal "<label for=\"name\">Name</label>"
|
||||
(rh '(label :for "name" "Name"))))
|
||||
|
||||
(deftest "fieldset and legend"
|
||||
(assert-equal "<fieldset><legend>group</legend></fieldset>"
|
||||
(rh '(fieldset (legend "group"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 14. Media elements
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "html-media"
|
||||
(deftest "video with src"
|
||||
(assert-equal "<video src=\"v.mp4\"></video>"
|
||||
(rh '(video :src "v.mp4"))))
|
||||
|
||||
(deftest "audio with controls"
|
||||
(assert-equal "<audio controls></audio>"
|
||||
(rh '(audio :controls true))))
|
||||
|
||||
(deftest "iframe"
|
||||
(assert-equal "<iframe src=\"page.html\"></iframe>"
|
||||
(rh '(iframe :src "page.html"))))
|
||||
|
||||
(deftest "canvas"
|
||||
(assert-equal "<canvas width=\"100\" height=\"100\"></canvas>"
|
||||
(rh '(canvas :width 100 :height 100))))
|
||||
|
||||
(deftest "picture with source and img"
|
||||
(assert-equal "<picture><source srcset=\"photo.webp\" /><img src=\"photo.jpg\" /></picture>"
|
||||
(rh '(picture (source :srcset "photo.webp") (img :src "photo.jpg"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 15. Semantic elements
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "html-semantic"
|
||||
(deftest "header" (assert-equal "<header>h</header>" (rh '(header "h"))))
|
||||
(deftest "nav" (assert-equal "<nav>n</nav>" (rh '(nav "n"))))
|
||||
(deftest "main" (assert-equal "<main>m</main>" (rh '(main "m"))))
|
||||
(deftest "section" (assert-equal "<section>s</section>" (rh '(section "s"))))
|
||||
(deftest "article" (assert-equal "<article>a</article>" (rh '(article "a"))))
|
||||
(deftest "aside" (assert-equal "<aside>a</aside>" (rh '(aside "a"))))
|
||||
(deftest "footer" (assert-equal "<footer>f</footer>" (rh '(footer "f"))))
|
||||
(deftest "details and summary"
|
||||
(assert-equal "<details><summary>more</summary><p>info</p></details>"
|
||||
(rh '(details (summary "more") (p "info")))))
|
||||
(deftest "figure and figcaption"
|
||||
(assert-equal "<figure><img src=\"x.jpg\" /><figcaption>cap</figcaption></figure>"
|
||||
(rh '(figure (img :src "x.jpg") (figcaption "cap"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 16. SVG elements
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "html-svg"
|
||||
(deftest "svg container"
|
||||
(assert-equal "<svg viewBox=\"0 0 100 100\"></svg>"
|
||||
(rh '(svg :viewBox "0 0 100 100"))))
|
||||
|
||||
(deftest "circle"
|
||||
(let ((html (rh '(circle :cx 50 :cy 50 :r 40))))
|
||||
(assert-true (string-contains? html "cx=\"50\""))
|
||||
(assert-true (string-contains? html "cy=\"50\""))
|
||||
(assert-true (string-contains? html "r=\"40\""))))
|
||||
|
||||
(deftest "rect"
|
||||
(assert-equal "<rect width=\"100\" height=\"50\"></rect>"
|
||||
(rh '(rect :width 100 :height 50))))
|
||||
|
||||
(deftest "path"
|
||||
(assert-equal "<path d=\"M0 0 L100 100\"></path>"
|
||||
(rh '(path :d "M0 0 L100 100"))))
|
||||
|
||||
(deftest "g with transform"
|
||||
(assert-equal "<g transform=\"translate(10,20)\"></g>"
|
||||
(rh '(g :transform "translate(10,20)"))))
|
||||
|
||||
(deftest "text element"
|
||||
(assert-equal "<text x=\"10\" y=\"20\">label</text>"
|
||||
(rh '(text :x 10 :y 20 "label")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 17. Control flow in templates
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "html-control-flow"
|
||||
(deftest "if true renders then-branch"
|
||||
(assert-equal "<p>yes</p>"
|
||||
(rh '(if true (p "yes") (p "no")))))
|
||||
|
||||
(deftest "if false renders else-branch"
|
||||
(assert-equal "<p>no</p>"
|
||||
(rh '(if false (p "yes") (p "no")))))
|
||||
|
||||
(deftest "if false without else renders empty"
|
||||
(assert-equal "" (rh '(if false (p "x")))))
|
||||
|
||||
(deftest "when true renders body"
|
||||
(assert-equal "<p>ok</p>"
|
||||
(rh '(when true (p "ok")))))
|
||||
|
||||
(deftest "when false renders empty"
|
||||
(assert-equal "" (rh '(when false (p "x")))))
|
||||
|
||||
(deftest "cond renders matching branch"
|
||||
(assert-equal "<p>b</p>"
|
||||
(rh '(cond false (p "a") true (p "b")))))
|
||||
|
||||
(deftest "cond else branch"
|
||||
(assert-equal "<p>c</p>"
|
||||
(rh '(cond false (p "a") :else (p "c"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 18. Let bindings in templates
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "html-let"
|
||||
(deftest "let binding used in template"
|
||||
(assert-equal "<p>hello</p>"
|
||||
(rh '(let ((x "hello")) (p x)))))
|
||||
|
||||
(deftest "let with multiple bindings"
|
||||
(assert-equal "<p>helloworld</p>"
|
||||
(rh '(let ((a "hello") (b "world")) (p a b)))))
|
||||
|
||||
(deftest "nested let"
|
||||
(assert-equal "<div><p>inner</p></div>"
|
||||
(rh '(let ((x "inner")) (div (let ((y x)) (p y))))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 19. Map / for-each in templates
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "html-iteration"
|
||||
(deftest "map over items"
|
||||
(assert-equal "<li>a</li><li>b</li><li>c</li>"
|
||||
(rh '(map (fn (x) (li x)) (list "a" "b" "c")))))
|
||||
|
||||
(deftest "for-each renders items"
|
||||
(assert-equal "<p>1</p><p>2</p>"
|
||||
(rh '(for-each (fn (x) (p (str x))) (list 1 2)))))
|
||||
|
||||
(deftest "map-indexed"
|
||||
(assert-equal "<li>0: a</li><li>1: b</li>"
|
||||
(rh '(map-indexed (fn (i x) (li (str i ": " x))) (list "a" "b"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 20. Components
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "html-components"
|
||||
(deftest "simple component"
|
||||
(let ((env (env-extend (test-env))))
|
||||
(eval-expr '(defcomp ~card (&key title) (div :class "card" (h2 title))) env)
|
||||
(assert-equal "<div class=\"card\"><h2>hello</h2></div>"
|
||||
(rh-env '(~card :title "hello") env))))
|
||||
|
||||
(deftest "component with children"
|
||||
(let ((env (env-extend (test-env))))
|
||||
(eval-expr '(defcomp ~box (&rest children) (div :class "box" children)) env)
|
||||
(assert-equal "<div class=\"box\"><p>inner</p></div>"
|
||||
(rh-env '(~box (p "inner")) env))))
|
||||
|
||||
(deftest "component with keyword and children"
|
||||
(let ((env (env-extend (test-env))))
|
||||
(eval-expr '(defcomp ~panel (&key title &rest children)
|
||||
(section (h2 title) children)) env)
|
||||
(assert-equal "<section><h2>Title</h2><p>body</p></section>"
|
||||
(rh-env '(~panel :title "Title" (p "body")) env))))
|
||||
|
||||
(deftest "nested components"
|
||||
(let ((env (env-extend (test-env))))
|
||||
(eval-expr '(defcomp ~inner (&key text) (em text)) env)
|
||||
(eval-expr '(defcomp ~outer (&key text) (div (~inner :text text))) env)
|
||||
(assert-equal "<div><em>hi</em></div>"
|
||||
(rh-env '(~outer :text "hi") env)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 21. Macros
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "html-macros"
|
||||
(deftest "macro expands and renders"
|
||||
(let ((env (env-extend (test-env))))
|
||||
(eval-expr '(defmacro ~wrap (body)
|
||||
`(div :class "wrapped" ,body)) env)
|
||||
(assert-equal "<div class=\"wrapped\"><p>hello</p></div>"
|
||||
(rh-env '(~wrap (p "hello")) env)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 22. Begin/do — multi-expression body
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "html-begin"
|
||||
(deftest "do renders all expressions"
|
||||
(assert-equal "<p>a</p><p>b</p>"
|
||||
(rh '(do (p "a") (p "b")))))
|
||||
|
||||
(deftest "begin renders all expressions"
|
||||
(assert-equal "<h1>title</h1><p>body</p>"
|
||||
(rh '(begin (h1 "title") (p "body"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 23. Letrec in templates
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "html-letrec"
|
||||
(deftest "letrec with side-effect rendering"
|
||||
(assert-equal "<li>a</li><li>b</li>"
|
||||
(rh '(letrec ((items (list "a" "b")))
|
||||
(do (map (fn (x) (li x)) items)))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 24. Scope/provide in templates
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "html-scope"
|
||||
(deftest "scope renders body"
|
||||
(assert-equal "<ul><li>inside</li></ul>"
|
||||
(rh '(scope "items"
|
||||
(ul (li "inside"))))))
|
||||
|
||||
(deftest "provide renders body"
|
||||
(assert-equal "<div>content</div>"
|
||||
(rh '(provide "theme" "dark"
|
||||
(div "content"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 25. Other elements
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "html-other-elements"
|
||||
(deftest "pre preserves structure"
|
||||
(assert-equal "<pre>code here</pre>"
|
||||
(rh '(pre "code here"))))
|
||||
|
||||
(deftest "code element"
|
||||
(assert-equal "<code>x = 1</code>"
|
||||
(rh '(code "x = 1"))))
|
||||
|
||||
(deftest "blockquote"
|
||||
(assert-equal "<blockquote>quote</blockquote>"
|
||||
(rh '(blockquote "quote"))))
|
||||
|
||||
(deftest "abbr with title"
|
||||
(assert-equal "<abbr title=\"HyperText Markup Language\">HTML</abbr>"
|
||||
(rh '(abbr :title "HyperText Markup Language" "HTML"))))
|
||||
|
||||
(deftest "time with datetime"
|
||||
(assert-equal "<time datetime=\"2026-01-01\">New Year</time>"
|
||||
(rh '(time :datetime "2026-01-01" "New Year"))))
|
||||
|
||||
(deftest "dialog"
|
||||
(assert-equal "<dialog open>content</dialog>"
|
||||
(rh '(dialog :open true "content"))))
|
||||
|
||||
(deftest "template"
|
||||
(assert-equal "<template>inner</template>"
|
||||
(rh '(template "inner"))))
|
||||
|
||||
(deftest "slot with name"
|
||||
(assert-equal "<slot name=\"header\"></slot>"
|
||||
(rh '(slot :name "header"))))
|
||||
|
||||
(deftest "noscript"
|
||||
(assert-equal "<noscript>fallback</noscript>"
|
||||
(rh '(noscript "fallback")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 26. Islands — defisland with hydration markers
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "html-islands"
|
||||
(deftest "island renders with data-sx-island attribute"
|
||||
(let ((env (env-extend (test-env))))
|
||||
(eval-expr '(defisland ~counter (&key start)
|
||||
(span (str "count: " start))) env)
|
||||
(let ((html (rh-env '(~counter :start 0) env)))
|
||||
(assert-true (string-contains? html "data-sx-island"))
|
||||
(assert-true (string-contains? html "count: 0")))))
|
||||
|
||||
(deftest "island name appears in marker"
|
||||
(let ((env (env-extend (test-env))))
|
||||
(eval-expr '(defisland ~toggle (&key label)
|
||||
(button label)) env)
|
||||
(let ((html (rh-env '(~toggle :label "click") env)))
|
||||
(assert-true (string-contains? html "toggle"))
|
||||
(assert-true (string-contains? html "click")))))
|
||||
|
||||
(deftest "island with children"
|
||||
(let ((env (env-extend (test-env))))
|
||||
(eval-expr '(defisland ~wrapper (&rest children)
|
||||
(div :class "island" children)) env)
|
||||
(let ((html (rh-env '(~wrapper (p "inside")) env)))
|
||||
(assert-true (string-contains? html "data-sx-island"))
|
||||
(assert-true (string-contains? html "<p>inside</p>"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 27. Lakes — server-morphable slots within islands
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "html-lakes"
|
||||
(deftest "lake renders with data-sx-lake attribute"
|
||||
(let ((env (env-extend (test-env))))
|
||||
(let ((html (rh-env '(lake :id "content" (p "hello")) env)))
|
||||
(assert-true (string-contains? html "data-sx-lake"))
|
||||
(assert-true (string-contains? html "content"))
|
||||
(assert-true (string-contains? html "<p>hello</p>")))))
|
||||
|
||||
(deftest "lake with custom tag"
|
||||
(let ((env (env-extend (test-env))))
|
||||
(let ((html (rh-env '(lake :id "nav" :tag "nav" (a "link")) env)))
|
||||
(assert-true (starts-with? html "<nav"))
|
||||
(assert-true (string-contains? html "<a>link</a>"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 28. Marshes — reactive server-morphable slots
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "html-marshes"
|
||||
(deftest "marsh renders with data-sx-marsh attribute"
|
||||
(let ((env (env-extend (test-env))))
|
||||
(let ((html (rh-env '(marsh :id "feed" (li "item")) env)))
|
||||
(assert-true (string-contains? html "data-sx-marsh"))
|
||||
(assert-true (string-contains? html "feed"))
|
||||
(assert-true (string-contains? html "<li>item</li>")))))
|
||||
|
||||
(deftest "marsh with custom tag"
|
||||
(let ((env (env-extend (test-env))))
|
||||
(let ((html (rh-env '(marsh :id "list" :tag "ul" (li "a") (li "b")) env)))
|
||||
(assert-true (starts-with? html "<ul"))
|
||||
(assert-true (string-contains? html "<li>a</li>"))
|
||||
(assert-true (string-contains? html "<li>b</li>"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 29. Thread macro in templates
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "html-threading"
|
||||
(deftest "thread-first in template context"
|
||||
(assert-equal "<p>HELLO</p>"
|
||||
(rh '(p (-> "hello" upper))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 30. Define in templates
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "html-define-in-template"
|
||||
(deftest "define then use in same template"
|
||||
(assert-equal "<p>42</p>"
|
||||
(rh '(do (define x 42) (p (str x))))))
|
||||
|
||||
(deftest "defcomp then use"
|
||||
(assert-equal "<em>hi</em>"
|
||||
(rh '(do (defcomp ~tag (&key text) (em text))
|
||||
(~tag :text "hi"))))))
|
||||
19
sx/app.py
19
sx/app.py
@@ -49,6 +49,11 @@ async def sx_standalone_context() -> dict:
|
||||
ctx["cart_mini"] = ""
|
||||
ctx["auth_menu"] = ""
|
||||
ctx["nav_tree"] = ""
|
||||
# Generate CSRF token — standalone has no account service but still
|
||||
# needs CSRF for mutation handlers (DELETE etc.)
|
||||
from shared.browser.app.csrf import generate_csrf_token
|
||||
from quart import g
|
||||
g.csrf_token = generate_csrf_token()
|
||||
return ctx
|
||||
|
||||
|
||||
@@ -57,8 +62,8 @@ def create_app() -> "Quart":
|
||||
|
||||
extra_kw = {}
|
||||
if SX_STANDALONE:
|
||||
extra_kw["no_oauth"] = True
|
||||
extra_kw["no_db"] = True
|
||||
extra_kw["no_oauth"] = True
|
||||
|
||||
app = create_base_app(
|
||||
"sx",
|
||||
@@ -182,11 +187,11 @@ def create_app() -> "Quart":
|
||||
from quart import request, make_response
|
||||
from shared.browser.app.utils.htmx import is_htmx_request
|
||||
from shared.sx.jinja_bridge import get_component_env, _get_request_context
|
||||
from shared.sx.async_eval import async_eval_slot_to_sx
|
||||
from shared.sx.types import Symbol, Keyword
|
||||
from shared.sx.helpers import full_page_sx, oob_page_sx, sx_response
|
||||
from shared.sx.pages import get_page_helpers
|
||||
from shared.sx.page import get_template_context
|
||||
import os
|
||||
|
||||
path = request.path
|
||||
content_ast = [
|
||||
@@ -199,7 +204,15 @@ def create_app() -> "Quart":
|
||||
ctx = _get_request_context()
|
||||
|
||||
try:
|
||||
content_sx = await async_eval_slot_to_sx(content_ast, env, ctx)
|
||||
if os.environ.get("SX_USE_OCAML") == "1":
|
||||
from shared.sx.ocaml_bridge import get_bridge
|
||||
from shared.sx.parser import serialize
|
||||
bridge = await get_bridge()
|
||||
sx_text = serialize(content_ast)
|
||||
content_sx = await bridge.aser_slot(sx_text, ctx={"_helper_service": "sx"})
|
||||
else:
|
||||
from shared.sx.async_eval import async_eval_slot_to_sx
|
||||
content_sx = await async_eval_slot_to_sx(content_ast, env, ctx)
|
||||
except Exception:
|
||||
from shared.browser.app.errors import _sx_error_page
|
||||
html = _sx_error_page("404", "NOT FOUND",
|
||||
|
||||
@@ -1,26 +1,22 @@
|
||||
"""SX docs page routes.
|
||||
|
||||
Page GET routes are defined declaratively in sxc/pages/docs.sx via defpage.
|
||||
Example API endpoints are now defined in sx/handlers/examples.sx via defhandler.
|
||||
This file contains only SSE and marsh demo endpoints that need Python.
|
||||
API endpoints are defined in sx/handlers/*.sx via defhandler.
|
||||
This file contains only SSE endpoints that need Python (async generators).
|
||||
"""
|
||||
from __future__ import annotations
|
||||
|
||||
import asyncio
|
||||
import random
|
||||
from datetime import datetime
|
||||
|
||||
from quart import Blueprint, Response, request
|
||||
from quart import Blueprint, Response
|
||||
|
||||
|
||||
def register(url_prefix: str = "/") -> Blueprint:
|
||||
bp = Blueprint("pages", __name__, url_prefix=url_prefix)
|
||||
|
||||
# ------------------------------------------------------------------
|
||||
# Reference API endpoints — remaining Python-only
|
||||
#
|
||||
# Most reference endpoints migrated to sx/sx/handlers/ref-api.sx.
|
||||
# SSE stays in Python — fundamentally different paradigm (async generator).
|
||||
# SSE — async generator, fundamentally not expressible in SX
|
||||
# ------------------------------------------------------------------
|
||||
|
||||
@bp.get("/sx/(geography.(hypermedia.(reference.(api.sse-time))))")
|
||||
@@ -34,132 +30,4 @@ def register(url_prefix: str = "/") -> Blueprint:
|
||||
return Response(generate(), content_type="text/event-stream",
|
||||
headers={"Cache-Control": "no-cache", "X-Accel-Buffering": "no"})
|
||||
|
||||
# --- Marsh demos ---
|
||||
|
||||
_marsh_sale_idx = {"n": 0}
|
||||
|
||||
@bp.get("/sx/(geography.(reactive.(api.flash-sale)))")
|
||||
async def api_marsh_flash_sale():
|
||||
from shared.sx.helpers import sx_response
|
||||
prices = [14.99, 9.99, 24.99, 12.49, 7.99, 29.99, 4.99, 16.50]
|
||||
_marsh_sale_idx["n"] = (_marsh_sale_idx["n"] + 1) % len(prices)
|
||||
new_price = prices[_marsh_sale_idx["n"]]
|
||||
now = datetime.now().strftime("%H:%M:%S")
|
||||
sx_src = (
|
||||
f'(<>'
|
||||
f' (div :class "space-y-2"'
|
||||
f' (p :class "text-sm text-emerald-600 font-medium"'
|
||||
f' "\u26A1 Flash sale! Price: ${new_price:.2f}")'
|
||||
f' (p :class "text-xs text-stone-400" "at {now}"))'
|
||||
f' (script :type "text/sx" :data-init ""'
|
||||
f' "(reset! (use-store \\"demo-price\\") {new_price})"))'
|
||||
)
|
||||
return sx_response(sx_src)
|
||||
|
||||
# --- Demo 3: sx-on-settle endpoint ---
|
||||
|
||||
_settle_counter = {"n": 0}
|
||||
|
||||
@bp.get("/sx/(geography.(reactive.(api.settle-data)))")
|
||||
async def api_settle_data():
|
||||
from shared.sx.helpers import sx_response
|
||||
_settle_counter["n"] += 1
|
||||
items = ["Widget", "Gadget", "Sprocket", "Gizmo", "Doohickey"]
|
||||
item = items[_settle_counter["n"] % len(items)]
|
||||
now = datetime.now().strftime("%H:%M:%S")
|
||||
sx_src = (
|
||||
f'(div :class "space-y-1"'
|
||||
f' (p :class "text-sm font-medium text-stone-700" "Fetched: {item}")'
|
||||
f' (p :class "text-xs text-stone-400" "at {now}"))'
|
||||
)
|
||||
return sx_response(sx_src)
|
||||
|
||||
# --- Demo 4: signal-bound URL endpoints ---
|
||||
|
||||
@bp.get("/sx/(geography.(reactive.(api.search-products)))")
|
||||
async def api_search_products():
|
||||
from shared.sx.helpers import sx_response
|
||||
q = request.args.get("q", "")
|
||||
items = ["Artisan Widget", "Premium Gadget", "Handcrafted Sprocket",
|
||||
"Bespoke Gizmo", "Organic Doohickey"]
|
||||
matches = [i for i in items if q.lower() in i.lower()] if q else items
|
||||
rows = " ".join(
|
||||
f'(li :class "text-sm text-stone-600" "{m}")'
|
||||
for m in matches[:3]
|
||||
)
|
||||
sx_src = (
|
||||
f'(div :class "space-y-1"'
|
||||
f' (p :class "text-xs font-semibold text-violet-600 uppercase" "Products")'
|
||||
f' (ul :class "list-disc pl-4" {rows})'
|
||||
f' (p :class "text-xs text-stone-400" "{len(matches)} result(s)"))'
|
||||
)
|
||||
return sx_response(sx_src)
|
||||
|
||||
@bp.get("/sx/(geography.(reactive.(api.search-events)))")
|
||||
async def api_search_events():
|
||||
from shared.sx.helpers import sx_response
|
||||
q = request.args.get("q", "")
|
||||
items = ["Summer Workshop", "Craft Fair", "Open Studio",
|
||||
"Artist Talk", "Gallery Opening"]
|
||||
matches = [i for i in items if q.lower() in i.lower()] if q else items
|
||||
rows = " ".join(
|
||||
f'(li :class "text-sm text-stone-600" "{m}")'
|
||||
for m in matches[:3]
|
||||
)
|
||||
sx_src = (
|
||||
f'(div :class "space-y-1"'
|
||||
f' (p :class "text-xs font-semibold text-emerald-600 uppercase" "Events")'
|
||||
f' (ul :class "list-disc pl-4" {rows})'
|
||||
f' (p :class "text-xs text-stone-400" "{len(matches)} result(s)"))'
|
||||
)
|
||||
return sx_response(sx_src)
|
||||
|
||||
@bp.get("/sx/(geography.(reactive.(api.search-posts)))")
|
||||
async def api_search_posts():
|
||||
from shared.sx.helpers import sx_response
|
||||
q = request.args.get("q", "")
|
||||
items = ["On Craft and Code", "The SX Manifesto", "Islands and Lakes",
|
||||
"Reactive Marshes", "Self-Hosting Spec"]
|
||||
matches = [i for i in items if q.lower() in i.lower()] if q else items
|
||||
rows = " ".join(
|
||||
f'(li :class "text-sm text-stone-600" "{m}")'
|
||||
for m in matches[:3]
|
||||
)
|
||||
sx_src = (
|
||||
f'(div :class "space-y-1"'
|
||||
f' (p :class "text-xs font-semibold text-amber-600 uppercase" "Posts")'
|
||||
f' (ul :class "list-disc pl-4" {rows})'
|
||||
f' (p :class "text-xs text-stone-400" "{len(matches)} result(s)"))'
|
||||
)
|
||||
return sx_response(sx_src)
|
||||
|
||||
# --- Demo 5: marsh transform endpoint ---
|
||||
|
||||
@bp.get("/sx/(geography.(reactive.(api.catalog)))")
|
||||
async def api_catalog():
|
||||
from shared.sx.helpers import sx_response
|
||||
items = [
|
||||
("Artisan Widget", "19.99", "Hand-crafted with care"),
|
||||
("Premium Gadget", "34.50", "Top-of-the-line quality"),
|
||||
("Vintage Sprocket", "12.99", "Classic design"),
|
||||
("Custom Gizmo", "27.00", "Made to order"),
|
||||
]
|
||||
random.shuffle(items)
|
||||
now = datetime.now().strftime("%H:%M:%S")
|
||||
# Build an SX list literal for the data-init script.
|
||||
# Inner quotes must be escaped since the whole expression lives
|
||||
# inside an SX string literal (the script tag's text content).
|
||||
items_sx = "(list " + " ".join(
|
||||
f'(dict \\"name\\" \\"{n}\\" \\"price\\" \\"{p}\\" \\"desc\\" \\"{d}\\")'
|
||||
for n, p, d in items
|
||||
) + ")"
|
||||
sx_src = (
|
||||
f'(<>'
|
||||
f' (p :class "text-sm text-emerald-600 font-medium"'
|
||||
f' "Catalog loaded: {len(items)} items (shuffled at {now})")'
|
||||
f' (script :type "text/sx" :data-init ""'
|
||||
f' "(reset! (use-store \\"catalog-items\\") {items_sx})"))'
|
||||
)
|
||||
return sx_response(sx_src)
|
||||
|
||||
return bp
|
||||
|
||||
@@ -1,90 +1,10 @@
|
||||
"""Documentation content for the sx docs site.
|
||||
|
||||
All page content as Python data structures, consumed by sx_components.py
|
||||
to build s-expression page trees.
|
||||
Data structures consumed by helpers.py for pages that need server-side data.
|
||||
Navigation is defined in nav-data.sx (the single source of truth).
|
||||
"""
|
||||
from __future__ import annotations
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Navigation
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
DOCS_NAV = [
|
||||
("Introduction", "/(language.(doc.introduction))"),
|
||||
("Getting Started", "/(language.(doc.getting-started))"),
|
||||
("Components", "/(language.(doc.components))"),
|
||||
("Evaluator", "/(language.(doc.evaluator))"),
|
||||
("Primitives", "/(language.(doc.primitives))"),
|
||||
("CSS", "/(language.(doc.css))"),
|
||||
("Server Rendering", "/(language.(doc.server-rendering))"),
|
||||
]
|
||||
|
||||
REFERENCE_NAV = [
|
||||
("Attributes", "/(geography.(hypermedia.(reference.attributes)))"),
|
||||
("Headers", "/(geography.(hypermedia.(reference.headers)))"),
|
||||
("Events", "/(geography.(hypermedia.(reference.events)))"),
|
||||
("JS API", "/(geography.(hypermedia.(reference.js-api)))"),
|
||||
]
|
||||
|
||||
PROTOCOLS_NAV = [
|
||||
("Wire Format", "/(applications.(protocol.wire-format))"),
|
||||
("Fragments", "/(applications.(protocol.fragments))"),
|
||||
("Resolver I/O", "/(applications.(protocol.resolver-io))"),
|
||||
("Internal Services", "/(applications.(protocol.internal-services))"),
|
||||
("ActivityPub", "/(applications.(protocol.activitypub))"),
|
||||
("Future", "/(applications.(protocol.future))"),
|
||||
]
|
||||
|
||||
EXAMPLES_NAV = [
|
||||
("Click to Load", "/(geography.(hypermedia.(example.click-to-load)))"),
|
||||
("Form Submission", "/(geography.(hypermedia.(example.form-submission)))"),
|
||||
("Polling", "/(geography.(hypermedia.(example.polling)))"),
|
||||
("Delete Row", "/(geography.(hypermedia.(example.delete-row)))"),
|
||||
("Inline Edit", "/(geography.(hypermedia.(example.inline-edit)))"),
|
||||
("OOB Swaps", "/(geography.(hypermedia.(example.oob-swaps)))"),
|
||||
("Lazy Loading", "/(geography.(hypermedia.(example.lazy-loading)))"),
|
||||
("Infinite Scroll", "/(geography.(hypermedia.(example.infinite-scroll)))"),
|
||||
("Progress Bar", "/(geography.(hypermedia.(example.progress-bar)))"),
|
||||
("Active Search", "/(geography.(hypermedia.(example.active-search)))"),
|
||||
("Inline Validation", "/(geography.(hypermedia.(example.inline-validation)))"),
|
||||
("Value Select", "/(geography.(hypermedia.(example.value-select)))"),
|
||||
("Reset on Submit", "/(geography.(hypermedia.(example.reset-on-submit)))"),
|
||||
("Edit Row", "/(geography.(hypermedia.(example.edit-row)))"),
|
||||
("Bulk Update", "/(geography.(hypermedia.(example.bulk-update)))"),
|
||||
("Swap Positions", "/(geography.(hypermedia.(example.swap-positions)))"),
|
||||
("Select Filter", "/(geography.(hypermedia.(example.select-filter)))"),
|
||||
("Tabs", "/(geography.(hypermedia.(example.tabs)))"),
|
||||
("Animations", "/(geography.(hypermedia.(example.animations)))"),
|
||||
("Dialogs", "/(geography.(hypermedia.(example.dialogs)))"),
|
||||
("Keyboard Shortcuts", "/(geography.(hypermedia.(example.keyboard-shortcuts)))"),
|
||||
("PUT / PATCH", "/(geography.(hypermedia.(example.put-patch)))"),
|
||||
("JSON Encoding", "/(geography.(hypermedia.(example.json-encoding)))"),
|
||||
("Vals & Headers", "/(geography.(hypermedia.(example.vals-and-headers)))"),
|
||||
("Loading States", "/(geography.(hypermedia.(example.loading-states)))"),
|
||||
("Request Abort", "/(geography.(hypermedia.(example.sync-replace)))"),
|
||||
("Retry", "/(geography.(hypermedia.(example.retry)))"),
|
||||
]
|
||||
|
||||
ESSAYS_NAV = [
|
||||
("sx sucks", "/(etc.(essay.sx-sucks))"),
|
||||
("Why S-Expressions", "/(etc.(essay.why-sexps))"),
|
||||
("The htmx/React Hybrid", "/(etc.(essay.htmx-react-hybrid))"),
|
||||
("On-Demand CSS", "/(etc.(essay.on-demand-css))"),
|
||||
("Client Reactivity", "/(etc.(essay.client-reactivity))"),
|
||||
("SX Native", "/(etc.(essay.sx-native))"),
|
||||
("The SX Manifesto", "/(etc.(philosophy.sx-manifesto))"),
|
||||
("Tail-Call Optimization", "/(etc.(essay.tail-call-optimization))"),
|
||||
("Continuations", "/(etc.(essay.continuations))"),
|
||||
]
|
||||
|
||||
MAIN_NAV = [
|
||||
("Docs", "/(language.(doc.introduction))"),
|
||||
("Reference", "/(geography.(hypermedia.(reference)))"),
|
||||
("Protocols", "/(applications.(protocol.wire-format))"),
|
||||
("Examples", "/(geography.(hypermedia.(example.click-to-load)))"),
|
||||
("Essays", "/(etc.(essay.sx-sucks))"),
|
||||
]
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Reference: Attributes
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
@@ -58,18 +58,18 @@
|
||||
(let ((running (signal false))
|
||||
(elapsed (signal 0))
|
||||
(time-text (create-text-node "0.0s"))
|
||||
(btn-text (create-text-node "Start")))
|
||||
(effect (fn ()
|
||||
(when (deref running)
|
||||
(let ((id (set-interval (fn () (swap! elapsed inc)) 100)))
|
||||
(fn () (clear-interval id))))))
|
||||
(effect (fn ()
|
||||
(let ((e (deref elapsed)))
|
||||
(dom-set-text-content time-text
|
||||
(str (floor (/ e 10)) "." (mod e 10) "s")))))
|
||||
(effect (fn ()
|
||||
(dom-set-text-content btn-text
|
||||
(if (deref running) "Stop" "Start"))))
|
||||
(btn-text (create-text-node "Start"))
|
||||
(_e1 (effect (fn ()
|
||||
(when (deref running)
|
||||
(let ((id (set-interval (fn () (swap! elapsed inc)) 100)))
|
||||
(fn () (clear-interval id)))))))
|
||||
(_e2 (effect (fn ()
|
||||
(let ((e (deref elapsed)))
|
||||
(dom-set-text-content time-text
|
||||
(str (floor (/ e 10)) "." (mod e 10) "s"))))))
|
||||
(_e3 (effect (fn ()
|
||||
(dom-set-text-content btn-text
|
||||
(if (deref running) "Stop" "Start"))))))
|
||||
(div :class "rounded-lg border border-stone-200 p-4"
|
||||
(div :class "flex items-center gap-3"
|
||||
(span :class "text-2xl font-bold text-violet-700 font-mono min-w-[5ch]" time-text)
|
||||
@@ -82,10 +82,10 @@
|
||||
(defisland ~geography/cek/demo-batch ()
|
||||
(let ((first-sig (signal 0))
|
||||
(second-sig (signal 0))
|
||||
(renders (signal 0)))
|
||||
(effect (fn ()
|
||||
(deref first-sig) (deref second-sig)
|
||||
(swap! renders inc)))
|
||||
(renders (signal 0))
|
||||
(_eff (effect (fn ()
|
||||
(deref first-sig) (deref second-sig)
|
||||
(swap! renders inc)))))
|
||||
(div :class "rounded-lg border border-stone-200 p-4 space-y-2"
|
||||
(div :class "flex items-center gap-4 text-sm"
|
||||
(span (str "first: " (deref first-sig)))
|
||||
|
||||
148
sx/sx/geography/index.sx
Normal file
148
sx/sx/geography/index.sx
Normal file
@@ -0,0 +1,148 @@
|
||||
;; Geography index — architecture overview
|
||||
;; Describes the rendering pipeline: OCaml evaluator → wire formats → client
|
||||
|
||||
(defcomp ~geography/index-content () :affinity :server
|
||||
(div :class "max-w-4xl mx-auto px-6 pb-8 pt-4"
|
||||
(h2 :class "text-3xl font-bold text-stone-800 mb-4" "Geography")
|
||||
(p :class "text-lg text-stone-600 mb-8"
|
||||
"Where code runs and how it gets there. Geography maps the rendering pipeline from server-side evaluation through wire formats to client-side hydration.")
|
||||
|
||||
;; Architecture diagram
|
||||
(div :class "bg-stone-50 border border-stone-200 rounded-lg p-6 mb-8"
|
||||
(h3 :class "text-xl font-semibold text-stone-700 mb-4" "Rendering Pipeline")
|
||||
(div :class "space-y-4"
|
||||
;; Server
|
||||
(div :class "flex items-start gap-4"
|
||||
(div :class "w-28 shrink-0 font-mono text-sm font-semibold text-sky-700 bg-sky-50 rounded px-2 py-1 text-center" "OCaml kernel")
|
||||
(div
|
||||
(p :class "text-stone-700"
|
||||
"The evaluator is a CEK machine written in SX and bootstrapped to OCaml. It evaluates page definitions, expands components, resolves IO (helpers, queries), and serializes the result as SX wire format.")
|
||||
(p :class "text-sm text-stone-500 mt-1"
|
||||
"spec/evaluator.sx → hosts/ocaml/ → aser-slot with batch IO")))
|
||||
|
||||
;; Wire format
|
||||
(div :class "flex items-start gap-4"
|
||||
(div :class "w-28 shrink-0 font-mono text-sm font-semibold text-amber-700 bg-amber-50 rounded px-2 py-1 text-center" "Wire format")
|
||||
(div
|
||||
(p :class "text-stone-700"
|
||||
"The aser (async-serialize) mode produces SX text — HTML tags and component calls serialized as s-expressions. Components with server affinity are expanded; client components stay as calls. The wire format is placed in a "
|
||||
(code :class "text-sm" "<script type=\"text/sx\">")
|
||||
" tag inside the HTML shell.")
|
||||
(p :class "text-sm text-stone-500 mt-1"
|
||||
"web/adapter-sx.sx → SxExpr values pass through serialize unquoted")))
|
||||
|
||||
;; Client
|
||||
(div :class "flex items-start gap-4"
|
||||
(div :class "w-28 shrink-0 font-mono text-sm font-semibold text-emerald-700 bg-emerald-50 rounded px-2 py-1 text-center" "sx-browser.js")
|
||||
(div
|
||||
(p :class "text-stone-700"
|
||||
"The client engine parses the SX wire format, evaluates component definitions, renders the DOM, and hydrates reactive islands. It includes the same CEK evaluator (transpiled from the spec), the parser, all web adapters, and the orchestration layer for fetch/swap/polling.")
|
||||
(p :class "text-sm text-stone-500 mt-1"
|
||||
"spec/ + web/ → hosts/javascript/cli.py → sx-browser.js (~400KB)")))))
|
||||
|
||||
;; What lives where
|
||||
(h3 :class "text-xl font-semibold text-stone-700 mb-4 mt-8" "What lives where")
|
||||
|
||||
(div :class "grid md:grid-cols-2 gap-4 mb-8"
|
||||
;; Spec
|
||||
(div :class "border border-stone-200 rounded-lg p-4"
|
||||
(h4 :class "font-semibold text-stone-700 mb-2" "Spec (shared)")
|
||||
(p :class "text-sm text-stone-600 mb-2" "The canonical SX language, bootstrapped identically to OCaml, JavaScript, and Python:")
|
||||
(ul :class "text-sm text-stone-600 space-y-1 list-disc ml-4"
|
||||
(li "CEK evaluator — frames, step function, call dispatch")
|
||||
(li "Parser — tokenizer, s-expression reader, serializer")
|
||||
(li "Primitives — ~80 built-in pure functions")
|
||||
(li "Render modes — HTML, SX wire, DOM")))
|
||||
|
||||
;; Web adapters
|
||||
(div :class "border border-stone-200 rounded-lg p-4"
|
||||
(h4 :class "font-semibold text-stone-700 mb-2" "Web Adapters")
|
||||
(p :class "text-sm text-stone-600 mb-2" "SX-defined modules that run on both server and client:")
|
||||
(ul :class "text-sm text-stone-600 space-y-1 list-disc ml-4"
|
||||
(li "adapter-sx.sx — aser wire format (server component expansion)")
|
||||
(li "adapter-html.sx — server HTML rendering")
|
||||
(li "adapter-dom.sx — client DOM rendering")
|
||||
(li "orchestration.sx — fetch, swap, polling, navigation")
|
||||
(li "engine.sx — trigger parsing, request building")))
|
||||
|
||||
;; OCaml kernel
|
||||
(div :class "border border-stone-200 rounded-lg p-4"
|
||||
(h4 :class "font-semibold text-stone-700 mb-2" "OCaml Kernel (server)")
|
||||
(p :class "text-sm text-stone-600 mb-2" "Persistent process connected via a binary pipe protocol:")
|
||||
(ul :class "text-sm text-stone-600 space-y-1 list-disc ml-4"
|
||||
(li "CEK evaluator + VM bytecode compiler")
|
||||
(li "Batch IO bridge — defers helper/query calls to Python")
|
||||
(li "Length-prefixed blob protocol — no string escaping")
|
||||
(li "Component hot-reload on .sx file changes")))
|
||||
|
||||
;; sx-browser.js
|
||||
(div :class "border border-stone-200 rounded-lg p-4"
|
||||
(h4 :class "font-semibold text-stone-700 mb-2" "sx-browser.js (client)")
|
||||
(p :class "text-sm text-stone-600 mb-2" "Single JS bundle transpiled from spec + web adapters:")
|
||||
(ul :class "text-sm text-stone-600 space-y-1 list-disc ml-4"
|
||||
(li "Parses SX wire format from script tags")
|
||||
(li "Renders component trees to DOM")
|
||||
(li "Hydrates reactive islands (signals, effects)")
|
||||
(li "Client-side routing with defpage")
|
||||
(li "HTMX-like fetch/swap orchestration"))))
|
||||
|
||||
;; Rendering modes
|
||||
(h3 :class "text-xl font-semibold text-stone-700 mb-4 mt-8" "Rendering Modes")
|
||||
|
||||
(div :class "overflow-x-auto mb-8"
|
||||
(table :class "w-full text-sm"
|
||||
(thead
|
||||
(tr :class "border-b border-stone-200"
|
||||
(th :class "px-3 py-2 text-left font-medium text-stone-600" "Mode")
|
||||
(th :class "px-3 py-2 text-left font-medium text-stone-600" "Runs on")
|
||||
(th :class "px-3 py-2 text-left font-medium text-stone-600" "Components")
|
||||
(th :class "px-3 py-2 text-left font-medium text-stone-600" "Output")))
|
||||
(tbody
|
||||
(tr :class "border-b border-stone-100"
|
||||
(td :class "px-3 py-2 font-mono" "render-to-html")
|
||||
(td :class "px-3 py-2" "Server (OCaml)")
|
||||
(td :class "px-3 py-2" "Expanded recursively")
|
||||
(td :class "px-3 py-2" "HTML string"))
|
||||
(tr :class "border-b border-stone-100"
|
||||
(td :class "px-3 py-2 font-mono" "aser / aser-slot")
|
||||
(td :class "px-3 py-2" "Server (OCaml)")
|
||||
(td :class "px-3 py-2" "Server-affinity expanded; client preserved")
|
||||
(td :class "px-3 py-2" "SX wire format"))
|
||||
(tr :class "border-b border-stone-100"
|
||||
(td :class "px-3 py-2 font-mono" "render-to-dom")
|
||||
(td :class "px-3 py-2" "Client (sx-browser.js)")
|
||||
(td :class "px-3 py-2" "Expanded recursively")
|
||||
(td :class "px-3 py-2" "DOM nodes"))
|
||||
(tr :class "border-b border-stone-100"
|
||||
(td :class "px-3 py-2 font-mono" "client routing")
|
||||
(td :class "px-3 py-2" "Client (sx-browser.js)")
|
||||
(td :class "px-3 py-2" "defpage content evaluated locally")
|
||||
(td :class "px-3 py-2" "DOM swap")))))
|
||||
|
||||
;; Topics
|
||||
(h3 :class "text-xl font-semibold text-stone-700 mb-4 mt-8" "Topics")
|
||||
|
||||
(div :class "grid md:grid-cols-2 gap-4"
|
||||
(a :href "/sx/(geography.(hypermedia))" :class "block border border-stone-200 rounded-lg p-4 hover:border-sky-300 hover:bg-sky-50 transition-colors"
|
||||
(h4 :class "font-semibold text-stone-700" "Hypermedia Lakes")
|
||||
(p :class "text-sm text-stone-500" "Server-driven UI with sx-get/post/put/delete — fetch, swap, and the request lifecycle."))
|
||||
|
||||
(a :href "/sx/(geography.(reactive))" :class "block border border-stone-200 rounded-lg p-4 hover:border-sky-300 hover:bg-sky-50 transition-colors"
|
||||
(h4 :class "font-semibold text-stone-700" "Reactive Islands")
|
||||
(p :class "text-sm text-stone-500" "Client-side signals and effects hydrated from server-rendered HTML. defisland, deref, lakes."))
|
||||
|
||||
(a :href "/sx/(geography.(marshes))" :class "block border border-stone-200 rounded-lg p-4 hover:border-sky-300 hover:bg-sky-50 transition-colors"
|
||||
(h4 :class "font-semibold text-stone-700" "Marshes")
|
||||
(p :class "text-sm text-stone-500" "Where reactivity and hypermedia interpenetrate — server writes to signals, reactive views reshape server content."))
|
||||
|
||||
(a :href "/sx/(geography.(scopes))" :class "block border border-stone-200 rounded-lg p-4 hover:border-sky-300 hover:bg-sky-50 transition-colors"
|
||||
(h4 :class "font-semibold text-stone-700" "Scopes")
|
||||
(p :class "text-sm text-stone-500" "Render-time dynamic scope — the primitive beneath provide, collect!, spreads, and islands."))
|
||||
|
||||
(a :href "/sx/(geography.(cek))" :class "block border border-stone-200 rounded-lg p-4 hover:border-sky-300 hover:bg-sky-50 transition-colors"
|
||||
(h4 :class "font-semibold text-stone-700" "CEK Machine")
|
||||
(p :class "text-sm text-stone-500" "The evaluator internals — frames, continuations, tail-call optimization, and the VM bytecode compiler."))
|
||||
|
||||
(a :href "/sx/(geography.(isomorphism))" :class "block border border-stone-200 rounded-lg p-4 hover:border-sky-300 hover:bg-sky-50 transition-colors"
|
||||
(h4 :class "font-semibold text-stone-700" "Isomorphism")
|
||||
(p :class "text-sm text-stone-500" "One spec, multiple hosts — how the same SX code runs on OCaml, JavaScript, and Python.")))))
|
||||
@@ -59,11 +59,11 @@
|
||||
:method :get
|
||||
:returns "element"
|
||||
(&key)
|
||||
(let ((now (now "%Y-%m-%d %H:%M:%S")))
|
||||
(let ((now (helper "now" "%Y-%m-%d %H:%M:%S")))
|
||||
(<>
|
||||
(~examples/click-result :time now)
|
||||
(~docs/oob-code :target-id "click-comp"
|
||||
:text (component-source "~examples/click-result"))
|
||||
:text (helper "component-source" "~examples/click-result"))
|
||||
(~docs/oob-code :target-id "click-wire"
|
||||
:text (str "(~examples/click-result :time \"" now "\")")))))
|
||||
|
||||
@@ -78,11 +78,11 @@
|
||||
:csrf false
|
||||
:returns "element"
|
||||
(&key)
|
||||
(let ((name (request-form "name" "")))
|
||||
(let ((name (helper "request-form" "name" "")))
|
||||
(<>
|
||||
(~examples/form-result :name name)
|
||||
(~docs/oob-code :target-id "form-comp"
|
||||
:text (component-source "~examples/form-result"))
|
||||
:text (helper "component-source" "~examples/form-result"))
|
||||
(~docs/oob-code :target-id "form-wire"
|
||||
:text (str "(~examples/form-result :name \"" name "\")")))))
|
||||
|
||||
@@ -96,16 +96,17 @@
|
||||
:method :get
|
||||
:returns "element"
|
||||
(&key)
|
||||
(let ((n (+ (state-get "ex-poll-n" 0) 1)))
|
||||
(state-set! "ex-poll-n" n)
|
||||
(let ((now (now "%H:%M:%S"))
|
||||
(let ((prev (helper "state-get" "ex-poll-n" 0)))
|
||||
(let ((n (+ prev 1)))
|
||||
(helper "state-set!" "ex-poll-n" n)
|
||||
(let ((now (helper "now" "%H:%M:%S"))
|
||||
(count (if (< n 10) n 10)))
|
||||
(<>
|
||||
(~examples/poll-result :time now :count count)
|
||||
(~docs/oob-code :target-id "poll-comp"
|
||||
:text (component-source "~examples/poll-result"))
|
||||
:text (helper "component-source" "~examples/poll-result"))
|
||||
(~docs/oob-code :target-id "poll-wire"
|
||||
:text (str "(~examples/poll-result :time \"" now "\" :count " count ")"))))))
|
||||
:text (str "(~examples/poll-result :time \"" now "\" :count " count ")")))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
@@ -120,7 +121,7 @@
|
||||
(&key item-id)
|
||||
(<>
|
||||
(~docs/oob-code :target-id "delete-comp"
|
||||
:text (component-source "~examples/delete-row"))
|
||||
:text (helper "component-source" "~examples/delete-row"))
|
||||
(~docs/oob-code :target-id "delete-wire"
|
||||
:text "(empty — row removed by outerHTML swap)")))
|
||||
|
||||
@@ -134,11 +135,11 @@
|
||||
:method :get
|
||||
:returns "element"
|
||||
(&key)
|
||||
(let ((value (request-arg "value" "")))
|
||||
(let ((value (helper "request-arg" "value" "")))
|
||||
(<>
|
||||
(~examples/inline-edit-form :value value)
|
||||
(~docs/oob-code :target-id "edit-comp"
|
||||
:text (component-source "~examples/inline-edit-form"))
|
||||
:text (helper "component-source" "~examples/inline-edit-form"))
|
||||
(~docs/oob-code :target-id "edit-wire"
|
||||
:text (str "(~examples/inline-edit-form :value \"" value "\")")))))
|
||||
|
||||
@@ -148,11 +149,11 @@
|
||||
:csrf false
|
||||
:returns "element"
|
||||
(&key)
|
||||
(let ((value (request-form "value" "")))
|
||||
(let ((value (helper "request-form" "value" "")))
|
||||
(<>
|
||||
(~examples/inline-view :value value)
|
||||
(~docs/oob-code :target-id "edit-comp"
|
||||
:text (component-source "~examples/inline-view"))
|
||||
:text (helper "component-source" "~examples/inline-view"))
|
||||
(~docs/oob-code :target-id "edit-wire"
|
||||
:text (str "(~examples/inline-view :value \"" value "\")")))))
|
||||
|
||||
@@ -161,11 +162,11 @@
|
||||
:method :get
|
||||
:returns "element"
|
||||
(&key)
|
||||
(let ((value (request-arg "value" "")))
|
||||
(let ((value (helper "request-arg" "value" "")))
|
||||
(<>
|
||||
(~examples/inline-view :value value)
|
||||
(~docs/oob-code :target-id "edit-comp"
|
||||
:text (component-source "~examples/inline-view"))
|
||||
:text (helper "component-source" "~examples/inline-view"))
|
||||
(~docs/oob-code :target-id "edit-wire"
|
||||
:text (str "(~examples/inline-view :value \"" value "\")")))))
|
||||
|
||||
@@ -179,7 +180,7 @@
|
||||
:method :get
|
||||
:returns "element"
|
||||
(&key)
|
||||
(let ((now (now "%H:%M:%S")))
|
||||
(let ((now (helper "now" "%H:%M:%S")))
|
||||
(<>
|
||||
(p :class "text-emerald-600 font-medium" "Box A updated!")
|
||||
(p :class "text-sm text-stone-500" (str "at " now))
|
||||
@@ -199,11 +200,11 @@
|
||||
:method :get
|
||||
:returns "element"
|
||||
(&key)
|
||||
(let ((now (now "%H:%M:%S")))
|
||||
(let ((now (helper "now" "%H:%M:%S")))
|
||||
(<>
|
||||
(~examples/lazy-result :time now)
|
||||
(~docs/oob-code :target-id "lazy-comp"
|
||||
:text (component-source "~examples/lazy-result"))
|
||||
:text (helper "component-source" "~examples/lazy-result"))
|
||||
(~docs/oob-code :target-id "lazy-wire"
|
||||
:text (str "(~examples/lazy-result :time \"" now "\")")))))
|
||||
|
||||
@@ -217,7 +218,7 @@
|
||||
:method :get
|
||||
:returns "element"
|
||||
(&key)
|
||||
(let ((page (request-arg "page" "2")))
|
||||
(let ((page (helper "request-arg" "page" "2")))
|
||||
(let ((pg (parse-int page))
|
||||
(start (+ (* (- (parse-int page) 1) 5) 1)))
|
||||
(<>
|
||||
@@ -249,30 +250,31 @@
|
||||
:csrf false
|
||||
:returns "element"
|
||||
(&key)
|
||||
(let ((n (+ (state-get "ex-job-counter" 0) 1)))
|
||||
(state-set! "ex-job-counter" n)
|
||||
(let ((prev-job (helper "state-get" "ex-job-counter" 0)))
|
||||
(let ((n (+ prev-job 1)))
|
||||
(helper "state-set!" "ex-job-counter" n)
|
||||
(let ((job-id (str "job-" n)))
|
||||
(state-set! (str "ex-job-" job-id) 0)
|
||||
(helper "state-set!" (str "ex-job-" job-id) 0)
|
||||
(<>
|
||||
(~examples/progress-status :percent 0 :job-id job-id)
|
||||
(~docs/oob-code :target-id "progress-comp"
|
||||
:text (component-source "~examples/progress-status"))
|
||||
:text (helper "component-source" "~examples/progress-status"))
|
||||
(~docs/oob-code :target-id "progress-wire"
|
||||
:text (str "(~examples/progress-status :percent 0 :job-id \"" job-id "\")"))))))
|
||||
:text (str "(~examples/progress-status :percent 0 :job-id \"" job-id "\")")))))))
|
||||
|
||||
(defhandler ex-progress-status
|
||||
:path "/sx/(geography.(hypermedia.(example.(api.progress-status))))"
|
||||
:method :get
|
||||
:returns "element"
|
||||
(&key)
|
||||
(let ((job-id (request-arg "job" "")))
|
||||
(let ((current (state-get (str "ex-job-" job-id) 0)))
|
||||
(let ((job-id (helper "request-arg" "job" "")))
|
||||
(let ((current (helper "state-get" (str "ex-job-" job-id) 0)))
|
||||
(let ((next (if (>= (+ current (random-int 15 30)) 100) 100 (+ current (random-int 15 30)))))
|
||||
(state-set! (str "ex-job-" job-id) next)
|
||||
(helper "state-set!" (str "ex-job-" job-id) next)
|
||||
(<>
|
||||
(~examples/progress-status :percent next :job-id job-id)
|
||||
(~docs/oob-code :target-id "progress-comp"
|
||||
:text (component-source "~examples/progress-status"))
|
||||
:text (helper "component-source" "~examples/progress-status"))
|
||||
(~docs/oob-code :target-id "progress-wire"
|
||||
:text (str "(~examples/progress-status :percent " next " :job-id \"" job-id "\")")))))))
|
||||
|
||||
@@ -286,17 +288,17 @@
|
||||
:method :get
|
||||
:returns "element"
|
||||
(&key)
|
||||
(let ((q (request-arg "q" "")))
|
||||
(let ((q (helper "request-arg" "q" "")))
|
||||
(let ((results (if (= q "")
|
||||
search-languages
|
||||
(filter (fn (lang) (contains? (lower-case lang) (lower-case q)))
|
||||
(filter (fn (lang) (contains? (lower lang) (lower q)))
|
||||
search-languages))))
|
||||
(<>
|
||||
(~search-results :items results :query q)
|
||||
(~examples/search-results :items results :query q)
|
||||
(~docs/oob-code :target-id "search-comp"
|
||||
:text (component-source "~search-results"))
|
||||
:text (helper "component-source" "~examples/search-results"))
|
||||
(~docs/oob-code :target-id "search-wire"
|
||||
:text (str "(~search-results :items (list ...) :query \"" q "\")"))))))
|
||||
:text (str "(~examples/search-results :items (list ...) :query \"" q "\")"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
@@ -308,27 +310,37 @@
|
||||
:method :get
|
||||
:returns "element"
|
||||
(&key)
|
||||
(let ((email (request-arg "email" "")))
|
||||
(let ((result
|
||||
(cond
|
||||
(= email "")
|
||||
(list "validation-error" "(~examples/validation-error :message \"Email is required\")"
|
||||
(~examples/validation-error :message "Email is required"))
|
||||
(not (contains? email "@"))
|
||||
(list "validation-error" "(~examples/validation-error :message \"Invalid email format\")"
|
||||
(~examples/validation-error :message "Invalid email format"))
|
||||
(some (fn (e) (= (lower-case e) (lower-case email))) taken-emails)
|
||||
(list "validation-error" (str "(~examples/validation-error :message \"" email " is already taken\")")
|
||||
(~examples/validation-error :message (str email " is already taken")))
|
||||
:else
|
||||
(list "validation-ok" (str "(~examples/validation-ok :email \"" email "\")")
|
||||
(~examples/validation-ok :email email)))))
|
||||
(<>
|
||||
(nth result 2)
|
||||
(~docs/oob-code :target-id "validate-comp"
|
||||
:text (component-source (first result)))
|
||||
(~docs/oob-code :target-id "validate-wire"
|
||||
:text (nth result 1))))))
|
||||
(let ((email (helper "request-arg" "email" "")))
|
||||
(cond
|
||||
(= email "")
|
||||
(<>
|
||||
(~examples/validation-error :message "Email is required")
|
||||
(~docs/oob-code :target-id "validate-comp"
|
||||
:text (helper "component-source" "~examples/validation-error"))
|
||||
(~docs/oob-code :target-id "validate-wire"
|
||||
:text "(~examples/validation-error :message \"Email is required\")"))
|
||||
(not (contains? email "@"))
|
||||
(<>
|
||||
(~examples/validation-error :message "Invalid email format")
|
||||
(~docs/oob-code :target-id "validate-comp"
|
||||
:text (helper "component-source" "~examples/validation-error"))
|
||||
(~docs/oob-code :target-id "validate-wire"
|
||||
:text "(~examples/validation-error :message \"Invalid email format\")"))
|
||||
(some (fn (e) (= (lower e) (lower email))) taken-emails)
|
||||
(<>
|
||||
(~examples/validation-error :message (str email " is already taken"))
|
||||
(~docs/oob-code :target-id "validate-comp"
|
||||
:text (helper "component-source" "~examples/validation-error"))
|
||||
(~docs/oob-code :target-id "validate-wire"
|
||||
:text (str "(~examples/validation-error :message \"" email " is already taken\")")))
|
||||
:else
|
||||
(<>
|
||||
(~examples/validation-ok :email email)
|
||||
(~docs/oob-code :target-id "validate-comp"
|
||||
:text (helper "component-source" "~examples/validation-ok"))
|
||||
(~docs/oob-code :target-id "validate-wire"
|
||||
:text (str "(~examples/validation-ok :email \"" email "\")"))))))
|
||||
|
||||
|
||||
(defhandler ex-validate-submit
|
||||
:path "/sx/(geography.(hypermedia.(example.(api.validate-submit))))"
|
||||
@@ -336,7 +348,7 @@
|
||||
:csrf false
|
||||
:returns "element"
|
||||
(&key)
|
||||
(let ((email (request-form "email" "")))
|
||||
(let ((email (helper "request-form" "email" "")))
|
||||
(if (or (= email "") (not (contains? email "@")))
|
||||
(p :class "text-sm text-rose-600 mt-2" "Please enter a valid email.")
|
||||
(p :class "text-sm text-emerald-600 mt-2" (str "Form submitted with: " email)))))
|
||||
@@ -351,15 +363,14 @@
|
||||
:method :get
|
||||
:returns "element"
|
||||
(&key)
|
||||
(let ((cat (request-arg "category" "")))
|
||||
(let ((cat (helper "request-arg" "category" "")))
|
||||
(let ((items (get value-select-data cat (list))))
|
||||
(let ((options (if (empty? items)
|
||||
(list (option :value "" "No items"))
|
||||
(map (fn (i) (option :value i i)) items))))
|
||||
(<>
|
||||
options
|
||||
(~docs/oob-code :target-id "values-wire"
|
||||
:text (str "(options for \"" cat "\")")))))))
|
||||
(<>
|
||||
(if (empty? items)
|
||||
(option :value "" "No items")
|
||||
(map (fn (i) (option :value i i)) items))
|
||||
(~docs/oob-code :target-id "values-wire"
|
||||
:text (str "(options for \"" cat "\")"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
@@ -372,12 +383,12 @@
|
||||
:csrf false
|
||||
:returns "element"
|
||||
(&key)
|
||||
(let ((msg (request-form "message" "(empty)"))
|
||||
(now (now "%H:%M:%S")))
|
||||
(let ((msg (helper "request-form" "message" "(empty)"))
|
||||
(now (helper "now" "%H:%M:%S")))
|
||||
(<>
|
||||
(~examples/reset-message :message msg :time now)
|
||||
(~docs/oob-code :target-id "reset-comp"
|
||||
:text (component-source "~examples/reset-message"))
|
||||
:text (helper "component-source" "~examples/reset-message"))
|
||||
(~docs/oob-code :target-id "reset-wire"
|
||||
:text (str "(~examples/reset-message :message \"" msg "\" :time \"" now "\")")))))
|
||||
|
||||
@@ -392,12 +403,12 @@
|
||||
:returns "element"
|
||||
(&key row-id)
|
||||
(let ((default (get edit-row-defaults row-id {"id" row-id "name" "" "price" "0" "stock" "0"})))
|
||||
(let ((row (state-get (str "ex-row-" row-id) default)))
|
||||
(let ((row (helper "state-get" (str "ex-row-" row-id) default)))
|
||||
(<>
|
||||
(~examples/edit-row-form :id (get row "id") :name (get row "name")
|
||||
:price (get row "price") :stock (get row "stock"))
|
||||
(~docs/oob-code :target-id "editrow-comp"
|
||||
:text (component-source "~examples/edit-row-form"))
|
||||
:text (helper "component-source" "~examples/edit-row-form"))
|
||||
(~docs/oob-code :target-id "editrow-wire"
|
||||
:text (str "(~examples/edit-row-form :id \"" (get row "id") "\" ...)"))))))
|
||||
|
||||
@@ -407,15 +418,15 @@
|
||||
:csrf false
|
||||
:returns "element"
|
||||
(&key row-id)
|
||||
(let ((name (request-form "name" ""))
|
||||
(price (request-form "price" "0"))
|
||||
(stock (request-form "stock" "0")))
|
||||
(state-set! (str "ex-row-" row-id)
|
||||
(let ((name (helper "request-form" "name" ""))
|
||||
(price (helper "request-form" "price" "0"))
|
||||
(stock (helper "request-form" "stock" "0")))
|
||||
(helper "state-set!" (str "ex-row-" row-id)
|
||||
{"id" row-id "name" name "price" price "stock" stock})
|
||||
(<>
|
||||
(~examples/edit-row-view :id row-id :name name :price price :stock stock)
|
||||
(~docs/oob-code :target-id "editrow-comp"
|
||||
:text (component-source "~examples/edit-row-view"))
|
||||
:text (helper "component-source" "~examples/edit-row-view"))
|
||||
(~docs/oob-code :target-id "editrow-wire"
|
||||
:text (str "(~examples/edit-row-view :id \"" row-id "\" ...)")))))
|
||||
|
||||
@@ -425,12 +436,12 @@
|
||||
:returns "element"
|
||||
(&key row-id)
|
||||
(let ((default (get edit-row-defaults row-id {"id" row-id "name" "" "price" "0" "stock" "0"})))
|
||||
(let ((row (state-get (str "ex-row-" row-id) default)))
|
||||
(let ((row (helper "state-get" (str "ex-row-" row-id) default)))
|
||||
(<>
|
||||
(~examples/edit-row-view :id (get row "id") :name (get row "name")
|
||||
:price (get row "price") :stock (get row "stock"))
|
||||
(~docs/oob-code :target-id "editrow-comp"
|
||||
:text (component-source "~examples/edit-row-view"))
|
||||
:text (helper "component-source" "~examples/edit-row-view"))
|
||||
(~docs/oob-code :target-id "editrow-wire"
|
||||
:text (str "(~examples/edit-row-view :id \"" (get row "id") "\" ...)"))))))
|
||||
|
||||
@@ -444,29 +455,29 @@
|
||||
:csrf false
|
||||
:returns "element"
|
||||
(&key)
|
||||
(let ((action (request-arg "action" "activate"))
|
||||
(ids (request-form-list "ids")))
|
||||
(let ((action (helper "request-arg" "action" "activate"))
|
||||
(ids (helper "request-form-list" "ids")))
|
||||
(let ((new-status (if (= action "activate") "active" "inactive")))
|
||||
;; Update matching users in state
|
||||
(for-each (fn (uid)
|
||||
(let ((default (get bulk-user-defaults uid nil)))
|
||||
(let ((user (state-get (str "ex-bulk-" uid) default)))
|
||||
(let ((user (helper "state-get" (str "ex-bulk-" uid) default)))
|
||||
(when user
|
||||
(state-set! (str "ex-bulk-" uid)
|
||||
(helper "state-set!" (str "ex-bulk-" uid)
|
||||
(assoc user "status" new-status))))))
|
||||
ids)
|
||||
;; Return all rows
|
||||
(let ((rows (map (fn (uid)
|
||||
(let ((default (get bulk-user-defaults uid
|
||||
{"id" uid "name" "" "email" "" "status" "active"})))
|
||||
(let ((u (state-get (str "ex-bulk-" uid) default)))
|
||||
(let ((u (helper "state-get" (str "ex-bulk-" uid) default)))
|
||||
(~examples/bulk-row :id (get u "id") :name (get u "name")
|
||||
:email (get u "email") :status (get u "status")))))
|
||||
(list "1" "2" "3" "4" "5"))))
|
||||
(<>
|
||||
rows
|
||||
(~docs/oob-code :target-id "bulk-comp"
|
||||
:text (component-source "~examples/bulk-row"))
|
||||
:text (helper "component-source" "~examples/bulk-row"))
|
||||
(~docs/oob-code :target-id "bulk-wire"
|
||||
:text (str "(updated " (len ids) " users to " new-status ")")))))))
|
||||
|
||||
@@ -481,10 +492,11 @@
|
||||
:csrf false
|
||||
:returns "element"
|
||||
(&key)
|
||||
(let ((mode (request-arg "mode" "beforeend"))
|
||||
(n (+ (state-get "ex-swap-n" 0) 1))
|
||||
(now (now "%H:%M:%S")))
|
||||
(state-set! "ex-swap-n" n)
|
||||
(let ((mode (helper "request-arg" "mode" "beforeend"))
|
||||
(prev-swap (helper "state-get" "ex-swap-n" 0))
|
||||
(now (helper "now" "%H:%M:%S")))
|
||||
(let ((n (+ prev-swap 1)))
|
||||
(helper "state-set!" "ex-swap-n" n)
|
||||
(<>
|
||||
(div :class "px-3 py-2 text-sm text-stone-700"
|
||||
(str "[" now "] " mode " (#" n ")"))
|
||||
@@ -492,7 +504,7 @@
|
||||
:class "self-center text-sm text-stone-500"
|
||||
(str "Count: " n))
|
||||
(~docs/oob-code :target-id "swap-wire"
|
||||
:text (str "(entry + oob counter: " n ")")))))
|
||||
:text (str "(entry + oob counter: " n ")"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
@@ -504,7 +516,7 @@
|
||||
:method :get
|
||||
:returns "element"
|
||||
(&key)
|
||||
(let ((now (now "%H:%M:%S")))
|
||||
(let ((now (helper "now" "%H:%M:%S")))
|
||||
(<>
|
||||
(div :id "dash-header" :class "p-3 bg-violet-50 rounded mb-3"
|
||||
(h4 :class "font-semibold text-violet-800" "Dashboard Header")
|
||||
@@ -556,12 +568,12 @@
|
||||
:returns "element"
|
||||
(&key)
|
||||
(let ((idx (random-int 0 4))
|
||||
(now (now "%H:%M:%S")))
|
||||
(now (helper "now" "%H:%M:%S")))
|
||||
(let ((color (nth anim-colors idx)))
|
||||
(<>
|
||||
(~anim-result :color color :time now)
|
||||
(~docs/oob-code :target-id "anim-comp"
|
||||
:text (component-source "~anim-result"))
|
||||
:text (helper "component-source" "~anim-result"))
|
||||
(~docs/oob-code :target-id "anim-wire"
|
||||
:text (str "(~anim-result :color \"" color "\" :time \"" now "\")"))))))
|
||||
|
||||
@@ -579,7 +591,7 @@
|
||||
(~examples/dialog-modal :title "Confirm Action"
|
||||
:message "Are you sure you want to proceed? This is a demo dialog rendered entirely with sx components.")
|
||||
(~docs/oob-code :target-id "dialog-comp"
|
||||
:text (component-source "~examples/dialog-modal"))
|
||||
:text (helper "component-source" "~examples/dialog-modal"))
|
||||
(~docs/oob-code :target-id "dialog-wire"
|
||||
:text "(~examples/dialog-modal :title \"Confirm Action\" :message \"...\")")))
|
||||
|
||||
@@ -602,12 +614,12 @@
|
||||
:method :get
|
||||
:returns "element"
|
||||
(&key)
|
||||
(let ((key (request-arg "key" "")))
|
||||
(let ((key (helper "request-arg" "key" "")))
|
||||
(let ((action (get kbd-actions key (str "Unknown key: " key))))
|
||||
(<>
|
||||
(~examples/kbd-result :key key :action action)
|
||||
(~docs/oob-code :target-id "kbd-comp"
|
||||
:text (component-source "~examples/kbd-result"))
|
||||
:text (helper "component-source" "~examples/kbd-result"))
|
||||
(~docs/oob-code :target-id "kbd-wire"
|
||||
:text (str "(~examples/kbd-result :key \"" key "\" :action \"" action "\")"))))))
|
||||
|
||||
@@ -621,12 +633,12 @@
|
||||
:method :get
|
||||
:returns "element"
|
||||
(&key)
|
||||
(let ((p (state-get "ex-profile"
|
||||
(let ((p (helper "state-get" "ex-profile"
|
||||
{"name" "Ada Lovelace" "email" "ada@example.com" "role" "Engineer"})))
|
||||
(<>
|
||||
(~examples/pp-form-full :name (get p "name") :email (get p "email") :role (get p "role"))
|
||||
(~docs/oob-code :target-id "pp-comp"
|
||||
:text (component-source "~examples/pp-form-full"))
|
||||
:text (helper "component-source" "~examples/pp-form-full"))
|
||||
(~docs/oob-code :target-id "pp-wire"
|
||||
:text (str "(~examples/pp-form-full :name \"" (get p "name") "\" ...)")))))
|
||||
|
||||
@@ -636,14 +648,14 @@
|
||||
:csrf false
|
||||
:returns "element"
|
||||
(&key)
|
||||
(let ((name (request-form "name" ""))
|
||||
(email (request-form "email" ""))
|
||||
(role (request-form "role" "")))
|
||||
(state-set! "ex-profile" {"name" name "email" email "role" role})
|
||||
(let ((name (helper "request-form" "name" ""))
|
||||
(email (helper "request-form" "email" ""))
|
||||
(role (helper "request-form" "role" "")))
|
||||
(helper "state-set!" "ex-profile" {"name" name "email" email "role" role})
|
||||
(<>
|
||||
(~examples/pp-view :name name :email email :role role)
|
||||
(~docs/oob-code :target-id "pp-comp"
|
||||
:text (component-source "~examples/pp-view"))
|
||||
:text (helper "component-source" "~examples/pp-view"))
|
||||
(~docs/oob-code :target-id "pp-wire"
|
||||
:text (str "(~examples/pp-view :name \"" name "\" ...)")))))
|
||||
|
||||
@@ -652,12 +664,12 @@
|
||||
:method :get
|
||||
:returns "element"
|
||||
(&key)
|
||||
(let ((p (state-get "ex-profile"
|
||||
(let ((p (helper "state-get" "ex-profile"
|
||||
{"name" "Ada Lovelace" "email" "ada@example.com" "role" "Engineer"})))
|
||||
(<>
|
||||
(~examples/pp-view :name (get p "name") :email (get p "email") :role (get p "role"))
|
||||
(~docs/oob-code :target-id "pp-comp"
|
||||
:text (component-source "~examples/pp-view"))
|
||||
:text (helper "component-source" "~examples/pp-view"))
|
||||
(~docs/oob-code :target-id "pp-wire"
|
||||
:text (str "(~examples/pp-view :name \"" (get p "name") "\" ...)")))))
|
||||
|
||||
@@ -672,13 +684,13 @@
|
||||
:csrf false
|
||||
:returns "element"
|
||||
(&key)
|
||||
(let ((data (request-json))
|
||||
(ct (request-content-type)))
|
||||
(let ((data (helper "request-json"))
|
||||
(ct (helper "request-content-type")))
|
||||
(let ((body (json-encode data)))
|
||||
(<>
|
||||
(~examples/json-result :body body :content-type ct)
|
||||
(~docs/oob-code :target-id "json-comp"
|
||||
:text (component-source "~examples/json-result"))
|
||||
:text (helper "component-source" "~examples/json-result"))
|
||||
(~docs/oob-code :target-id "json-wire"
|
||||
:text (str "(~examples/json-result :body \"" body "\" :content-type \"" ct "\")"))))))
|
||||
|
||||
@@ -692,7 +704,7 @@
|
||||
:method :get
|
||||
:returns "element"
|
||||
(&key)
|
||||
(let ((vals (into (list) (request-args-all))))
|
||||
(let ((vals (helper "into" (list) (helper "request-args-all"))))
|
||||
(let ((filtered (filter (fn (pair) (and (not (= (first pair) "_"))
|
||||
(not (= (first pair) "sx-request"))))
|
||||
vals)))
|
||||
@@ -700,7 +712,7 @@
|
||||
(<>
|
||||
(~examples/echo-result :label "values" :items items)
|
||||
(~docs/oob-code :target-id "vals-comp"
|
||||
:text (component-source "~examples/echo-result"))
|
||||
:text (helper "component-source" "~examples/echo-result"))
|
||||
(~docs/oob-code :target-id "vals-wire"
|
||||
:text (str "(~examples/echo-result :label \"values\" :items (list ...))")))))))
|
||||
|
||||
@@ -709,13 +721,13 @@
|
||||
:method :get
|
||||
:returns "element"
|
||||
(&key)
|
||||
(let ((all-headers (into (list) (request-headers-all))))
|
||||
(let ((all-headers (helper "into" (list) (helper "request-headers-all"))))
|
||||
(let ((custom (filter (fn (pair) (starts-with? (first pair) "x-")) all-headers)))
|
||||
(let ((items (map (fn (pair) (str (first pair) ": " (nth pair 1))) custom)))
|
||||
(<>
|
||||
(~examples/echo-result :label "headers" :items items)
|
||||
(~docs/oob-code :target-id "vals-comp"
|
||||
:text (component-source "~examples/echo-result"))
|
||||
:text (helper "component-source" "~examples/echo-result"))
|
||||
(~docs/oob-code :target-id "vals-wire"
|
||||
:text (str "(~examples/echo-result :label \"headers\" :items (list ...))")))))))
|
||||
|
||||
@@ -730,11 +742,11 @@
|
||||
:returns "element"
|
||||
(&key)
|
||||
(sleep 2000)
|
||||
(let ((now (now "%H:%M:%S")))
|
||||
(let ((now (helper "now" "%H:%M:%S")))
|
||||
(<>
|
||||
(~examples/loading-result :time now)
|
||||
(~docs/oob-code :target-id "loading-comp"
|
||||
:text (component-source "~examples/loading-result"))
|
||||
:text (helper "component-source" "~examples/loading-result"))
|
||||
(~docs/oob-code :target-id "loading-wire"
|
||||
:text (str "(~examples/loading-result :time \"" now "\")")))))
|
||||
|
||||
@@ -750,11 +762,11 @@
|
||||
(&key)
|
||||
(let ((delay-ms (random-int 500 2000)))
|
||||
(sleep delay-ms)
|
||||
(let ((q (request-arg "q" "")))
|
||||
(let ((q (helper "request-arg" "q" "")))
|
||||
(<>
|
||||
(~examples/sync-result :query q :delay (str delay-ms))
|
||||
(~docs/oob-code :target-id "sync-comp"
|
||||
:text (component-source "~examples/sync-result"))
|
||||
:text (helper "component-source" "~examples/sync-result"))
|
||||
(~docs/oob-code :target-id "sync-wire"
|
||||
:text (str "(~examples/sync-result :query \"" q "\" :delay \"" delay-ms "\")"))))))
|
||||
|
||||
@@ -768,8 +780,9 @@
|
||||
:method :get
|
||||
:returns "element"
|
||||
(&key)
|
||||
(let ((n (+ (state-get "ex-flaky-n" 0) 1)))
|
||||
(state-set! "ex-flaky-n" n)
|
||||
(let ((prev-flaky (helper "state-get" "ex-flaky-n" 0)))
|
||||
(let ((n (+ prev-flaky 1)))
|
||||
(helper "state-set!" "ex-flaky-n" n)
|
||||
(if (not (= (mod n 3) 0))
|
||||
(do
|
||||
(set-response-status 503)
|
||||
@@ -777,6 +790,6 @@
|
||||
(<>
|
||||
(~examples/retry-result :attempt (str n) :message "Success! The endpoint finally responded.")
|
||||
(~docs/oob-code :target-id "retry-comp"
|
||||
:text (component-source "~examples/retry-result"))
|
||||
:text (helper "component-source" "~examples/retry-result"))
|
||||
(~docs/oob-code :target-id "retry-wire"
|
||||
:text (str "(~examples/retry-result :attempt \"" n "\" ...)"))))))
|
||||
:text (str "(~examples/retry-result :attempt \"" n "\" ...)")))))))
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user