Compare commits
34 Commits
1a3d7b3d77
...
wasm
| Author | SHA1 | Date | |
|---|---|---|---|
| 0caa965de0 | |||
| 5ab3ecb7e0 | |||
| 313f7d6be1 | |||
| 16fa813d6d | |||
| 818e5d53f0 | |||
| 3a268e7277 | |||
| bdbf594bc8 | |||
| a1fa1edf8a | |||
| 2ef3f03db3 | |||
| 9f32c8cf0d | |||
| 719da7914e | |||
| c6a662c980 | |||
| e475222099 | |||
| b4df216fae | |||
| 9b4f735a0e | |||
| 293af75821 | |||
| ebb3445667 | |||
| 8f146cc810 | |||
| c67adaceaf | |||
| a2ab12a1d5 | |||
| 5a03943b39 | |||
| c20369b766 | |||
| 237ac234df | |||
| 4b21efc43c | |||
| 1ea80a2b71 | |||
| c3aee94c8f | |||
| 1800b80316 | |||
| 1a5dbc2800 | |||
| 7cde140c7e | |||
| 72eaefac13 | |||
| 7036621be8 | |||
| 05f7b10864 | |||
| 8ed8134d66 | |||
| f8a8e1eeb0 |
4
.gitignore
vendored
4
.gitignore
vendored
@@ -11,3 +11,7 @@ build/
|
||||
venv/
|
||||
_snapshot/
|
||||
_debug/
|
||||
sx-haskell/
|
||||
sx-rust/
|
||||
shared/static/scripts/sx-full-test.js
|
||||
hosts/ocaml/_build/
|
||||
|
||||
91
RESTRUCTURE_PLAN.md
Normal file
91
RESTRUCTURE_PLAN.md
Normal file
@@ -0,0 +1,91 @@
|
||||
# Restructure Plan
|
||||
|
||||
Reorganise from flat `shared/sx/ref/` to layered `spec/` + `hosts/` + `web/` + `sx/`.
|
||||
|
||||
Recovery point: commit `1a3d7b3` on branch `macros`.
|
||||
|
||||
## Phase 1: Directory structure
|
||||
Create all directories. No file moves.
|
||||
```
|
||||
spec/tests/
|
||||
hosts/python/
|
||||
hosts/javascript/
|
||||
web/adapters/
|
||||
web/tests/
|
||||
web/platforms/python/
|
||||
web/platforms/javascript/
|
||||
sx/platforms/python/
|
||||
sx/platforms/javascript/
|
||||
```
|
||||
|
||||
## Phase 2: Spec files (git mv)
|
||||
Move from `shared/sx/ref/` to `spec/`:
|
||||
- eval.sx, parser.sx, primitives.sx, render.sx
|
||||
- cek.sx, frames.sx, special-forms.sx
|
||||
- continuations.sx, callcc.sx, types.sx
|
||||
Move tests to `spec/tests/`:
|
||||
- test-framework.sx, test.sx, test-eval.sx, test-parser.sx
|
||||
- test-render.sx, test-cek.sx, test-continuations.sx, test-types.sx
|
||||
Remove boundary-core.sx from spec/ (it's a contract doc, not spec)
|
||||
|
||||
## Phase 3: Host files (git mv)
|
||||
Python host - move from `shared/sx/ref/` to `hosts/python/`:
|
||||
- bootstrap_py.py → hosts/python/bootstrap.py
|
||||
- platform_py.py → hosts/python/platform.py
|
||||
- py.sx → hosts/python/transpiler.sx
|
||||
- boundary_parser.py → hosts/python/boundary_parser.py
|
||||
- run_signal_tests.py, run_cek_tests.py, run_cek_reactive_tests.py,
|
||||
run_continuation_tests.py, run_type_tests.py → hosts/python/tests/
|
||||
|
||||
JS host - move from `shared/sx/ref/` to `hosts/javascript/`:
|
||||
- run_js_sx.py → hosts/javascript/bootstrap.py
|
||||
- bootstrap_js.py → hosts/javascript/cli.py
|
||||
- platform_js.py → hosts/javascript/platform.py
|
||||
- js.sx → hosts/javascript/transpiler.sx
|
||||
|
||||
Generated output stays in place:
|
||||
- shared/sx/ref/sx_ref.py (Python runtime)
|
||||
- shared/static/scripts/sx-browser.js (JS runtime)
|
||||
|
||||
## Phase 4: Web framework files (git mv)
|
||||
Move from `shared/sx/ref/` to `web/`:
|
||||
- signals.sx → web/signals.sx
|
||||
- engine.sx, orchestration.sx, boot.sx → web/
|
||||
- router.sx, deps.sx, forms.sx, page-helpers.sx → web/
|
||||
Move adapters to `web/adapters/`:
|
||||
- adapter-dom.sx → web/adapters/dom.sx
|
||||
- adapter-html.sx → web/adapters/html.sx
|
||||
- adapter-sx.sx → web/adapters/sx.sx
|
||||
- adapter-async.sx → web/adapters/async.sx
|
||||
Move web tests to `web/tests/`:
|
||||
- test-signals.sx, test-aser.sx, test-engine.sx, etc.
|
||||
Move boundary-web.sx to `web/boundary.sx`
|
||||
Move boundary-app.sx to `web/boundary-app.sx`
|
||||
|
||||
## Phase 5: Platform bindings
|
||||
Web platforms:
|
||||
- Extract DOM/browser primitives from platform_js.py → web/platforms/javascript/
|
||||
- Extract IO/server primitives from platform_py.py → web/platforms/python/
|
||||
App platforms:
|
||||
- sx/sxc/pages/helpers.py → sx/platforms/python/helpers.py
|
||||
- sx/sxc/init-client.sx.txt → sx/platforms/javascript/init.sx
|
||||
|
||||
## Phase 6: Update imports
|
||||
- All Python imports referencing shared.sx.ref.*
|
||||
- Bootstrapper paths (ref_dir, _source_dirs, _find_sx)
|
||||
- Docker volume mounts in docker-compose*.yml
|
||||
- Test runner paths
|
||||
- CLAUDE.md paths
|
||||
|
||||
## Phase 7: Verify
|
||||
- Both bootstrappers build
|
||||
- All tests pass
|
||||
- Dev container starts
|
||||
- Website works
|
||||
- Remove duplicate files from shared/sx/ref/
|
||||
|
||||
## Notes
|
||||
- Generated files (sx_ref.py, sx-browser.js) stay where they are
|
||||
- The runtime imports from shared.sx.ref.sx_ref — that doesn't change
|
||||
- Only the SOURCE .sx files and bootstrapper tools move
|
||||
- Each phase is a separate commit for safe rollback
|
||||
86
_config/dev-sh-config.yaml
Normal file
86
_config/dev-sh-config.yaml
Normal file
@@ -0,0 +1,86 @@
|
||||
root: "/rose-ash-wholefood-coop" # no trailing slash needed (we normalize it)
|
||||
host: "https://rose-ash.com"
|
||||
base_host: "wholesale.suma.coop"
|
||||
base_login: https://wholesale.suma.coop/customer/account/login/
|
||||
base_url: https://wholesale.suma.coop/
|
||||
title: sx-web
|
||||
market_root: /market
|
||||
market_title: Market
|
||||
blog_root: /
|
||||
blog_title: all the news
|
||||
cart_root: /cart
|
||||
app_urls:
|
||||
blog: "https://blog.rose-ash.com"
|
||||
market: "https://market.rose-ash.com"
|
||||
cart: "https://cart.rose-ash.com"
|
||||
events: "https://events.rose-ash.com"
|
||||
federation: "https://federation.rose-ash.com"
|
||||
account: "https://account.rose-ash.com"
|
||||
sx: "https://sx.rose-ash.com"
|
||||
test: "https://test.rose-ash.com"
|
||||
orders: "https://orders.rose-ash.com"
|
||||
cache:
|
||||
fs_root: /app/_snapshot # <- absolute path to your snapshot dir
|
||||
categories:
|
||||
allow:
|
||||
Basics: basics
|
||||
Branded Goods: branded-goods
|
||||
Chilled: chilled
|
||||
Frozen: frozen
|
||||
Non-foods: non-foods
|
||||
Supplements: supplements
|
||||
Christmas: christmas
|
||||
slugs:
|
||||
skip:
|
||||
- ""
|
||||
- customer
|
||||
- account
|
||||
- checkout
|
||||
- wishlist
|
||||
- sales
|
||||
- contact
|
||||
- privacy-policy
|
||||
- terms-and-conditions
|
||||
- delivery
|
||||
- catalogsearch
|
||||
- quickorder
|
||||
- apply
|
||||
- search
|
||||
- static
|
||||
- media
|
||||
section-titles:
|
||||
- ingredients
|
||||
- allergy information
|
||||
- allergens
|
||||
- nutritional information
|
||||
- nutrition
|
||||
- storage
|
||||
- directions
|
||||
- preparation
|
||||
- serving suggestions
|
||||
- origin
|
||||
- country of origin
|
||||
- recycling
|
||||
- general information
|
||||
- additional information
|
||||
- a note about prices
|
||||
|
||||
blacklist:
|
||||
category:
|
||||
- branded-goods/alcoholic-drinks
|
||||
- branded-goods/beers
|
||||
- branded-goods/ciders
|
||||
- branded-goods/wines
|
||||
product:
|
||||
- list-price-suma-current-suma-price-list-each-bk012-2-html
|
||||
product-details:
|
||||
- General Information
|
||||
- A Note About Prices
|
||||
sumup:
|
||||
merchant_code: "ME4J6100"
|
||||
currency: "GBP"
|
||||
# Name of the environment variable that holds your SumUp API key
|
||||
api_key_env: "SUMUP_API_KEY"
|
||||
webhook_secret: "jfwlekjfwef798ewf769ew8f679ew8f7weflwef"
|
||||
|
||||
|
||||
30
dev-sx.sh
Executable file
30
dev-sx.sh
Executable file
@@ -0,0 +1,30 @@
|
||||
#!/usr/bin/env bash
|
||||
set -euo pipefail
|
||||
|
||||
# Dev mode for sx_docs only (standalone, no DB)
|
||||
# Bind-mounted source + auto-reload on externalnet
|
||||
# Browse to sx.rose-ash.com
|
||||
#
|
||||
# Usage:
|
||||
# ./dev-sx.sh # Start sx_docs dev
|
||||
# ./dev-sx.sh down # Stop
|
||||
# ./dev-sx.sh logs # Tail logs
|
||||
# ./dev-sx.sh --build # Rebuild image then start
|
||||
|
||||
COMPOSE="docker compose -p sx-dev -f docker-compose.dev-sx.yml"
|
||||
|
||||
case "${1:-up}" in
|
||||
down)
|
||||
$COMPOSE down
|
||||
;;
|
||||
logs)
|
||||
$COMPOSE logs -f sx_docs
|
||||
;;
|
||||
*)
|
||||
BUILD_FLAG=""
|
||||
if [[ "${1:-}" == "--build" ]]; then
|
||||
BUILD_FLAG="--build"
|
||||
fi
|
||||
$COMPOSE up $BUILD_FLAG
|
||||
;;
|
||||
esac
|
||||
65
docker-compose.dev-sx.yml
Normal file
65
docker-compose.dev-sx.yml
Normal file
@@ -0,0 +1,65 @@
|
||||
# Standalone dev mode for sx_docs only
|
||||
# Replaces ~/sx-web production stack with bind-mounted source + auto-reload
|
||||
# Accessible at sx.rose-ash.com via Caddy on externalnet
|
||||
|
||||
services:
|
||||
sx_docs:
|
||||
image: registry.rose-ash.com:5000/sx_docs:latest
|
||||
environment:
|
||||
SX_STANDALONE: "true"
|
||||
SECRET_KEY: "${SECRET_KEY:-sx-dev-secret}"
|
||||
REDIS_URL: redis://redis:6379/0
|
||||
WORKERS: "1"
|
||||
ENVIRONMENT: development
|
||||
RELOAD: "true"
|
||||
SX_USE_REF: "1"
|
||||
SX_USE_OCAML: "1"
|
||||
SX_OCAML_BIN: "/app/bin/sx_server"
|
||||
SX_BOUNDARY_STRICT: "1"
|
||||
SX_USE_WASM: "1"
|
||||
SX_DEV: "1"
|
||||
volumes:
|
||||
- /root/rose-ash/_config/dev-sh-config.yaml:/app/config/app-config.yaml:ro
|
||||
- ./shared:/app/shared
|
||||
- ./sx/app.py:/app/app.py
|
||||
- ./sx/sxc:/app/sxc
|
||||
- ./sx/bp:/app/bp
|
||||
- ./sx/services:/app/services
|
||||
- ./sx/content:/app/content
|
||||
- ./sx/sx:/app/sx
|
||||
- ./sx/path_setup.py:/app/path_setup.py
|
||||
- ./sx/entrypoint.sh:/usr/local/bin/entrypoint.sh
|
||||
# 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
|
||||
# sibling models for cross-domain SQLAlchemy imports
|
||||
- ./blog/__init__.py:/app/blog/__init__.py:ro
|
||||
- ./blog/models:/app/blog/models:ro
|
||||
- ./market/__init__.py:/app/market/__init__.py:ro
|
||||
- ./market/models:/app/market/models:ro
|
||||
- ./cart/__init__.py:/app/cart/__init__.py:ro
|
||||
- ./cart/models:/app/cart/models:ro
|
||||
- ./events/__init__.py:/app/events/__init__.py:ro
|
||||
- ./events/models:/app/events/models:ro
|
||||
- ./federation/__init__.py:/app/federation/__init__.py:ro
|
||||
- ./federation/models:/app/federation/models:ro
|
||||
- ./account/__init__.py:/app/account/__init__.py:ro
|
||||
- ./account/models:/app/account/models:ro
|
||||
- ./relations/__init__.py:/app/relations/__init__.py:ro
|
||||
- ./relations/models:/app/relations/models:ro
|
||||
- ./likes/__init__.py:/app/likes/__init__.py:ro
|
||||
- ./likes/models:/app/likes/models:ro
|
||||
- ./orders/__init__.py:/app/orders/__init__.py:ro
|
||||
- ./orders/models:/app/orders/models:ro
|
||||
networks:
|
||||
- externalnet
|
||||
- default
|
||||
restart: unless-stopped
|
||||
|
||||
redis:
|
||||
image: redis:7-alpine
|
||||
restart: unless-stopped
|
||||
|
||||
networks:
|
||||
externalnet:
|
||||
external: true
|
||||
@@ -228,6 +228,8 @@ 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
|
||||
|
||||
@@ -16,13 +16,13 @@ import os
|
||||
import sys
|
||||
|
||||
_HERE = os.path.dirname(os.path.abspath(__file__))
|
||||
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", "..", ".."))
|
||||
_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
|
||||
from shared.sx.ref.platform_js import (
|
||||
from hosts.javascript.platform import (
|
||||
extract_defines,
|
||||
ADAPTER_FILES, ADAPTER_DEPS, SPEC_MODULES, SPEC_MODULE_ORDER, EXTENSION_NAMES,
|
||||
PREAMBLE, PLATFORM_JS_PRE, PLATFORM_JS_POST,
|
||||
@@ -44,7 +44,7 @@ def load_js_sx() -> dict:
|
||||
if _js_sx_env is not None:
|
||||
return _js_sx_env
|
||||
|
||||
js_sx_path = os.path.join(_HERE, "js.sx")
|
||||
js_sx_path = os.path.join(_HERE, "transpiler.sx")
|
||||
with open(js_sx_path) as f:
|
||||
source = f.read()
|
||||
|
||||
@@ -77,8 +77,7 @@ def compile_ref_to_js(
|
||||
from datetime import datetime, timezone
|
||||
from shared.sx.ref.sx_ref import evaluate
|
||||
|
||||
ref_dir = _HERE
|
||||
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", "..", ".."))
|
||||
ref_dir = os.path.join(_PROJECT, "shared", "sx", "ref")
|
||||
# Source directories: core spec, web framework, and legacy ref (for bootstrapper tools)
|
||||
_source_dirs = [
|
||||
os.path.join(_PROJECT, "spec"), # Core spec
|
||||
@@ -113,17 +112,11 @@ def compile_ref_to_js(
|
||||
spec_mod_set.add("deps")
|
||||
if "page-helpers" in SPEC_MODULES:
|
||||
spec_mod_set.add("page-helpers")
|
||||
# CEK needed for reactive rendering (deref-as-shift)
|
||||
if "dom" in adapter_set:
|
||||
spec_mod_set.add("cek")
|
||||
spec_mod_set.add("frames")
|
||||
# cek module requires frames
|
||||
if "cek" in spec_mod_set:
|
||||
spec_mod_set.add("frames")
|
||||
# CEK is always included (part of evaluator.sx core file)
|
||||
has_cek = True
|
||||
has_deps = "deps" in spec_mod_set
|
||||
has_router = "router" in spec_mod_set
|
||||
has_page_helpers = "page-helpers" in spec_mod_set
|
||||
has_cek = "cek" in spec_mod_set
|
||||
|
||||
# Resolve extensions
|
||||
ext_set = set()
|
||||
@@ -134,9 +127,10 @@ def compile_ref_to_js(
|
||||
ext_set.add(e)
|
||||
has_continuations = "continuations" in ext_set
|
||||
|
||||
# Build file list: core + adapters + spec modules
|
||||
# Build file list: core evaluator + adapters + spec modules
|
||||
# evaluator.sx = merged frames + eval utilities + CEK machine
|
||||
sx_files = [
|
||||
("eval.sx", "eval"),
|
||||
("evaluator.sx", "evaluator (frames + eval + CEK)"),
|
||||
("render.sx", "render (core)"),
|
||||
]
|
||||
for name in ("parser", "html", "sx", "dom", "engine", "orchestration", "boot"):
|
||||
@@ -239,8 +233,11 @@ def compile_ref_to_js(
|
||||
for name in ("dom", "engine", "orchestration", "boot"):
|
||||
if name in adapter_set and name in adapter_platform:
|
||||
parts.append(adapter_platform[name])
|
||||
if has_continuations:
|
||||
parts.append(CONTINUATIONS_JS)
|
||||
# CONTINUATIONS_JS is the tree-walk shift/reset extension.
|
||||
# With CEK as sole evaluator, continuations are handled natively by
|
||||
# cek.sx (step-sf-reset, step-sf-shift). Skip the tree-walk extension.
|
||||
# if has_continuations:
|
||||
# parts.append(CONTINUATIONS_JS)
|
||||
if has_dom:
|
||||
parts.append(ASYNC_IO_JS)
|
||||
parts.append(public_api_js(has_html, has_sx, has_dom, has_engine, has_orch, has_boot, has_parser, adapter_label, has_deps, has_router, has_signals, has_page_helpers, has_cek))
|
||||
@@ -20,8 +20,10 @@ if _PROJECT not in sys.path:
|
||||
|
||||
# Re-export everything that consumers import from this module.
|
||||
# Canonical source is now run_js_sx.py (self-hosting via js.sx) and platform_js.py.
|
||||
from shared.sx.ref.run_js_sx import compile_ref_to_js, load_js_sx # noqa: F401
|
||||
from shared.sx.ref.platform_js import ( # noqa: F401
|
||||
import sys, os
|
||||
sys.path.insert(0, os.path.abspath(os.path.join(os.path.dirname(__file__), "..", "..")))
|
||||
from hosts.javascript.bootstrap import compile_ref_to_js, load_js_sx # noqa: F401
|
||||
from hosts.javascript.platform import ( # noqa: F401
|
||||
extract_defines,
|
||||
ADAPTER_FILES, ADAPTER_DEPS, SPEC_MODULES, EXTENSION_NAMES,
|
||||
PREAMBLE, PLATFORM_JS_PRE, PLATFORM_JS_POST,
|
||||
@@ -44,7 +46,7 @@ if __name__ == "__main__":
|
||||
help="Comma-separated extensions (continuations). Default: none.")
|
||||
p.add_argument("--spec-modules",
|
||||
help="Comma-separated spec modules (deps). Default: none.")
|
||||
default_output = os.path.join(_HERE, "..", "..", "static", "scripts", "sx-browser.js")
|
||||
default_output = os.path.join(_HERE, "..", "..", "shared", "static", "scripts", "sx-browser.js")
|
||||
p.add_argument("--output", "-o", default=default_output,
|
||||
help="Output file (default: shared/static/scripts/sx-browser.js)")
|
||||
args = p.parse_args()
|
||||
@@ -46,13 +46,12 @@ SPEC_MODULES = {
|
||||
"router": ("router.sx", "router (client-side route matching)"),
|
||||
"signals": ("signals.sx", "signals (reactive signal runtime)"),
|
||||
"page-helpers": ("page-helpers.sx", "page-helpers (pure data transformation helpers)"),
|
||||
"frames": ("frames.sx", "frames (CEK continuation frames)"),
|
||||
"cek": ("cek.sx", "cek (explicit CEK machine evaluator)"),
|
||||
"types": ("types.sx", "types (gradual type system)"),
|
||||
}
|
||||
# Note: frames and cek are now part of evaluator.sx (always loaded as core)
|
||||
|
||||
# Explicit ordering for spec modules with dependencies.
|
||||
# Modules listed here are emitted in this order; any not listed use alphabetical.
|
||||
SPEC_MODULE_ORDER = ["deps", "frames", "page-helpers", "router", "cek", "signals"]
|
||||
SPEC_MODULE_ORDER = ["deps", "page-helpers", "router", "signals", "types"]
|
||||
|
||||
|
||||
EXTENSION_NAMES = {"continuations"}
|
||||
@@ -61,9 +60,13 @@ CONTINUATIONS_JS = '''
|
||||
// Extension: Delimited continuations (shift/reset)
|
||||
// =========================================================================
|
||||
|
||||
function Continuation(fn) { this.fn = fn; }
|
||||
Continuation.prototype._continuation = true;
|
||||
Continuation.prototype.call = function(value) { return this.fn(value !== undefined ? value : NIL); };
|
||||
function Continuation(fn) {
|
||||
var c = function(value) { return fn(value !== undefined ? value : NIL); };
|
||||
c.fn = fn;
|
||||
c._continuation = true;
|
||||
c.call = function(value) { return fn(value !== undefined ? value : NIL); };
|
||||
return c;
|
||||
}
|
||||
|
||||
function ShiftSignal(kName, body, env) {
|
||||
this.kName = kName;
|
||||
@@ -978,6 +981,7 @@ PRIMITIVES_JS_MODULES: dict[str, str] = {
|
||||
PRIMITIVES["substring"] = function(s, a, b) { return String(s).substring(a, b); };
|
||||
PRIMITIVES["char-from-code"] = function(n) { return String.fromCharCode(n); };
|
||||
PRIMITIVES["string-length"] = function(s) { return String(s).length; };
|
||||
var stringLength = PRIMITIVES["string-length"];
|
||||
PRIMITIVES["string-contains?"] = function(s, sub) { return String(s).indexOf(String(sub)) !== -1; };
|
||||
PRIMITIVES["concat"] = function() {
|
||||
var out = [];
|
||||
@@ -1156,12 +1160,12 @@ PLATFORM_JS_PRE = '''
|
||||
function makeSymbol(n) { return new Symbol(n); }
|
||||
function makeKeyword(n) { return new Keyword(n); }
|
||||
|
||||
function makeLambda(params, body, env) { return new Lambda(params, body, merge(env)); }
|
||||
function makeLambda(params, body, env) { return new Lambda(params, body, env); }
|
||||
function makeComponent(name, params, hasChildren, body, env, affinity) {
|
||||
return new Component(name, params, hasChildren, body, merge(env), affinity);
|
||||
return new Component(name, params, hasChildren, body, env, affinity);
|
||||
}
|
||||
function makeMacro(params, restParam, body, env, name) {
|
||||
return new Macro(params, restParam, body, merge(env), name);
|
||||
return new Macro(params, restParam, body, env, name);
|
||||
}
|
||||
function makeThunk(expr, env) { return new Thunk(expr, env); }
|
||||
|
||||
@@ -1230,6 +1234,8 @@ PLATFORM_JS_PRE = '''
|
||||
function componentHasChildren(c) { return c.hasChildren; }
|
||||
function componentName(c) { return c.name; }
|
||||
function componentAffinity(c) { return c.affinity || "auto"; }
|
||||
function componentParamTypes(c) { return (c && c._paramTypes) ? c._paramTypes : NIL; }
|
||||
function componentSetParamTypes_b(c, t) { if (c) c._paramTypes = t; return NIL; }
|
||||
|
||||
function macroParams(m) { return m.params; }
|
||||
function macroRestParam(m) { return m.restParam; }
|
||||
@@ -1249,7 +1255,7 @@ PLATFORM_JS_PRE = '''
|
||||
|
||||
// Island platform
|
||||
function makeIsland(name, params, hasChildren, body, env) {
|
||||
return new Island(name, params, hasChildren, body, merge(env));
|
||||
return new Island(name, params, hasChildren, body, env);
|
||||
}
|
||||
|
||||
// JSON / dict helpers for island state serialization
|
||||
@@ -1264,6 +1270,11 @@ PLATFORM_JS_PRE = '''
|
||||
|
||||
function envHas(env, name) { return name in env; }
|
||||
function envGet(env, name) { return env[name]; }
|
||||
function envBind(env, name, val) {
|
||||
// Direct property set — creates or overwrites on THIS env only.
|
||||
// Used by let, define, defcomp, lambda param binding.
|
||||
env[name] = val;
|
||||
}
|
||||
function envSet(env, name, val) {
|
||||
// Walk prototype chain to find where the variable is defined (for set!)
|
||||
var obj = env;
|
||||
@@ -1491,13 +1502,16 @@ PLATFORM_CEK_JS = '''
|
||||
// Platform: CEK module — explicit CEK machine
|
||||
// =========================================================================
|
||||
|
||||
// Continuation type (needed by CEK even without the tree-walk shift/reset extension)
|
||||
if (typeof Continuation === "undefined") {
|
||||
function Continuation(fn) { this.fn = fn; }
|
||||
Continuation.prototype._continuation = true;
|
||||
Continuation.prototype.call = function(value) { return this.fn(value !== undefined ? value : NIL); };
|
||||
PRIMITIVES["continuation?"] = function(x) { return x != null && x._continuation === true; };
|
||||
// Continuation type — callable as JS function so isCallable/apply work.
|
||||
// CEK is the canonical evaluator; continuations are always available.
|
||||
function Continuation(fn) {
|
||||
var c = function(value) { return fn(value !== undefined ? value : NIL); };
|
||||
c.fn = fn;
|
||||
c._continuation = true;
|
||||
c.call = function(value) { return fn(value !== undefined ? value : NIL); };
|
||||
return c;
|
||||
}
|
||||
PRIMITIVES["continuation?"] = function(x) { return x != null && x._continuation === true; };
|
||||
|
||||
// Standalone aliases for primitives used by cek.sx / frames.sx
|
||||
var inc = PRIMITIVES["inc"];
|
||||
@@ -1524,6 +1538,20 @@ CEK_FIXUPS_JS = '''
|
||||
return cekValue(state);
|
||||
};
|
||||
|
||||
// CEK is the canonical evaluator — override evalExpr to use it.
|
||||
// The tree-walk evaluator (evalExpr from eval.sx) is superseded.
|
||||
var _treeWalkEvalExpr = evalExpr;
|
||||
evalExpr = function(expr, env) {
|
||||
return cekRun(makeCekState(expr, env, []));
|
||||
};
|
||||
|
||||
// CEK never produces thunks — trampoline resolves any legacy thunks
|
||||
var _treeWalkTrampoline = trampoline;
|
||||
trampoline = function(val) {
|
||||
if (isThunk(val)) return evalExpr(thunkExpr(val), thunkEnv(val));
|
||||
return val;
|
||||
};
|
||||
|
||||
// Platform functions — defined in platform_js.py, not in .sx spec files.
|
||||
// Spec defines self-register via js-emit-define; these are the platform interface.
|
||||
PRIMITIVES["type-of"] = typeOf;
|
||||
@@ -3228,6 +3256,7 @@ def public_api_js(has_html, has_sx, has_dom, has_engine, has_orch, has_boot, has
|
||||
isNil: isNil,
|
||||
componentEnv: componentEnv,''')
|
||||
|
||||
api_lines.append(' setRenderActive: function(val) { setRenderActiveB(val); },')
|
||||
if has_html:
|
||||
api_lines.append(' renderToHtml: function(expr, env) { return renderToHtml(expr, env || merge(componentEnv)); },')
|
||||
if has_sx:
|
||||
320
hosts/javascript/run_tests.js
Normal file
320
hosts/javascript/run_tests.js
Normal file
@@ -0,0 +1,320 @@
|
||||
#!/usr/bin/env node
|
||||
/**
|
||||
* Run SX spec tests in Node.js using the bootstrapped evaluator.
|
||||
*
|
||||
* Usage:
|
||||
* node hosts/javascript/run_tests.js # all spec tests
|
||||
* node hosts/javascript/run_tests.js test-primitives # specific test
|
||||
*/
|
||||
const fs = require("fs");
|
||||
const path = require("path");
|
||||
|
||||
// Provide globals that sx-browser.js expects
|
||||
global.window = global;
|
||||
global.addEventListener = () => {};
|
||||
global.self = global;
|
||||
global.document = {
|
||||
createElement: () => ({ style: {}, setAttribute: () => {}, appendChild: () => {}, children: [] }),
|
||||
createDocumentFragment: () => ({ appendChild: () => {}, children: [], childNodes: [] }),
|
||||
head: { appendChild: () => {} },
|
||||
body: { appendChild: () => {} },
|
||||
querySelector: () => null,
|
||||
querySelectorAll: () => [],
|
||||
createTextNode: (s) => ({ textContent: s }),
|
||||
addEventListener: () => {},
|
||||
};
|
||||
global.localStorage = { getItem: () => null, setItem: () => {}, removeItem: () => {} };
|
||||
global.CustomEvent = class CustomEvent { constructor(n, o) { this.type = n; this.detail = (o||{}).detail||{}; } };
|
||||
global.MutationObserver = class { observe() {} disconnect() {} };
|
||||
global.requestIdleCallback = (fn) => setTimeout(fn, 0);
|
||||
global.matchMedia = () => ({ matches: false });
|
||||
global.navigator = { serviceWorker: { register: () => Promise.resolve() } };
|
||||
global.location = { href: "", pathname: "/", hostname: "localhost" };
|
||||
global.history = { pushState: () => {}, replaceState: () => {} };
|
||||
global.fetch = () => Promise.resolve({ ok: true, text: () => Promise.resolve("") });
|
||||
global.setTimeout = setTimeout;
|
||||
global.clearTimeout = clearTimeout;
|
||||
global.console = console;
|
||||
|
||||
// Load the bootstrapped evaluator
|
||||
// Use --full flag to load a full-spec build (if available)
|
||||
const fullBuild = process.argv.includes("--full");
|
||||
const jsPath = fullBuild
|
||||
? path.join(__dirname, "..", "..", "shared", "static", "scripts", "sx-full-test.js")
|
||||
: path.join(__dirname, "..", "..", "shared", "static", "scripts", "sx-browser.js");
|
||||
if (fullBuild && !fs.existsSync(jsPath)) {
|
||||
console.error("Full test build not found. Run: python3 hosts/javascript/cli.py --extensions continuations --spec-modules types --output shared/static/scripts/sx-full-test.js");
|
||||
process.exit(1);
|
||||
}
|
||||
const Sx = require(jsPath);
|
||||
if (!Sx || !Sx.parse) {
|
||||
console.error("Failed to load Sx evaluator");
|
||||
process.exit(1);
|
||||
}
|
||||
|
||||
// Reset render mode — boot process may have set it to true
|
||||
if (Sx.setRenderActive) Sx.setRenderActive(false);
|
||||
|
||||
// Test infrastructure
|
||||
let passCount = 0;
|
||||
let failCount = 0;
|
||||
const suiteStack = [];
|
||||
|
||||
// Build env with all primitives + spec functions
|
||||
const env = Sx.getEnv ? Object.assign({}, Sx.getEnv()) : {};
|
||||
|
||||
// Additional test helpers needed by spec tests
|
||||
env["sx-parse"] = function(s) { return Sx.parse(s); };
|
||||
env["sx-parse-one"] = function(s) { const r = Sx.parse(s); return r && r.length > 0 ? r[0] : null; };
|
||||
env["test-env"] = function() { return Sx.getEnv ? Object.assign({}, Sx.getEnv()) : {}; };
|
||||
env["cek-eval"] = function(s) {
|
||||
const parsed = Sx.parse(s);
|
||||
if (!parsed || parsed.length === 0) return null;
|
||||
return Sx.eval(parsed[0], Sx.getEnv ? Object.assign({}, Sx.getEnv()) : {});
|
||||
};
|
||||
env["eval-expr-cek"] = function(expr, e) { return Sx.eval(expr, e || env); };
|
||||
env["env-get"] = function(e, k) { return e && e[k] !== undefined ? e[k] : null; };
|
||||
env["env-has?"] = function(e, k) { return e && k in e; };
|
||||
env["env-bind!"] = function(e, k, v) { if (e) e[k] = v; return v; };
|
||||
env["env-set!"] = function(e, k, v) { if (e) e[k] = v; return v; };
|
||||
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
|
||||
env["upcase"] = function(s) { return s.toUpperCase(); };
|
||||
env["downcase"] = function(s) { return s.toLowerCase(); };
|
||||
env["make-keyword"] = function(name) { return new Sx.Keyword(name); };
|
||||
env["string-length"] = function(s) { return s.length; };
|
||||
env["dict-get"] = function(d, k) { return d && d[k] !== undefined ? d[k] : null; };
|
||||
env["apply"] = function(f) {
|
||||
var args = Array.prototype.slice.call(arguments, 1);
|
||||
var lastArg = args.pop();
|
||||
if (Array.isArray(lastArg)) args = args.concat(lastArg);
|
||||
return f.apply(null, args);
|
||||
};
|
||||
|
||||
// Deep equality
|
||||
function deepEqual(a, b) {
|
||||
if (a === b) return true;
|
||||
if (a == null || b == null) return a == b;
|
||||
if (typeof a !== typeof b) return false;
|
||||
if (Array.isArray(a) && Array.isArray(b)) {
|
||||
if (a.length !== b.length) return false;
|
||||
return a.every((v, i) => deepEqual(v, b[i]));
|
||||
}
|
||||
if (typeof a === "object") {
|
||||
const ka = Object.keys(a).filter(k => k !== "_nil");
|
||||
const kb = Object.keys(b).filter(k => k !== "_nil");
|
||||
if (ka.length !== kb.length) return false;
|
||||
return ka.every(k => deepEqual(a[k], b[k]));
|
||||
}
|
||||
return false;
|
||||
}
|
||||
env["equal?"] = deepEqual;
|
||||
env["identical?"] = function(a, b) { return a === b; };
|
||||
|
||||
// Continuation support
|
||||
env["make-continuation"] = function(fn) {
|
||||
// Continuation must be callable as a function AND have _continuation flag
|
||||
var c = function(v) { return fn(v !== undefined ? v : null); };
|
||||
c._continuation = true;
|
||||
c.fn = fn;
|
||||
c.call = function(v) { return fn(v !== undefined ? v : null); };
|
||||
return c;
|
||||
};
|
||||
env["continuation?"] = function(x) { return x != null && x._continuation === true; };
|
||||
env["continuation-fn"] = function(c) { return c.fn; };
|
||||
|
||||
// Render helpers
|
||||
// render-html: the tests call this with an SX source string, parse it, and render to HTML
|
||||
// IMPORTANT: renderToHtml sets a global _renderMode flag but never resets it.
|
||||
// We must reset it after each call so subsequent eval calls don't go through the render path.
|
||||
env["render-html"] = function(src, e) {
|
||||
var result;
|
||||
if (typeof src === "string") {
|
||||
var parsed = Sx.parse(src);
|
||||
if (!parsed || parsed.length === 0) return "";
|
||||
var expr = parsed.length === 1 ? parsed[0] : [{ name: "do" }].concat(parsed);
|
||||
if (Sx.renderToHtml) {
|
||||
result = Sx.renderToHtml(expr, e || (Sx.getEnv ? Object.assign({}, Sx.getEnv()) : {}));
|
||||
} else {
|
||||
result = Sx.serialize(expr);
|
||||
}
|
||||
} else {
|
||||
if (Sx.renderToHtml) {
|
||||
result = Sx.renderToHtml(src, e || env);
|
||||
} else {
|
||||
result = Sx.serialize(src);
|
||||
}
|
||||
}
|
||||
// Reset render mode so subsequent eval calls don't go through DOM/HTML render path
|
||||
if (Sx.setRenderActive) Sx.setRenderActive(false);
|
||||
return result;
|
||||
};
|
||||
// Also register render-to-html directly
|
||||
env["render-to-html"] = env["render-html"];
|
||||
|
||||
// Type system helpers — available when types module is included
|
||||
|
||||
// test-prim-types: dict of primitive return types for type inference
|
||||
env["test-prim-types"] = function() {
|
||||
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
|
||||
env["test-prim-param-types"] = function() {
|
||||
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": null},
|
||||
"dec": {"positional": [["n", "number"]], "rest-type": null},
|
||||
"upper": {"positional": [["s", "string"]], "rest-type": null},
|
||||
"lower": {"positional": [["s", "string"]], "rest-type": null},
|
||||
"keys": {"positional": [["d", "dict"]], "rest-type": null},
|
||||
"vals": {"positional": [["d", "dict"]], "rest-type": null},
|
||||
};
|
||||
};
|
||||
|
||||
// Component type accessors
|
||||
env["component-param-types"] = function(c) {
|
||||
return c && c._paramTypes ? c._paramTypes : null;
|
||||
};
|
||||
env["component-set-param-types!"] = function(c, t) {
|
||||
if (c) c._paramTypes = t;
|
||||
return null;
|
||||
};
|
||||
env["component-params"] = function(c) {
|
||||
return c && c.params ? c.params : null;
|
||||
};
|
||||
env["component-body"] = function(c) {
|
||||
return c && c.body ? c.body : null;
|
||||
};
|
||||
env["component-has-children"] = function(c) {
|
||||
return c && c.has_children ? c.has_children : false;
|
||||
};
|
||||
|
||||
// Platform test functions
|
||||
env["try-call"] = function(thunk) {
|
||||
try {
|
||||
Sx.eval([thunk], env);
|
||||
return { ok: true };
|
||||
} catch (e) {
|
||||
return { ok: false, error: e.message || String(e) };
|
||||
}
|
||||
};
|
||||
|
||||
env["report-pass"] = function(name) {
|
||||
passCount++;
|
||||
const ctx = suiteStack.join(" > ");
|
||||
console.log(` PASS: ${ctx} > ${name}`);
|
||||
return null;
|
||||
};
|
||||
|
||||
env["report-fail"] = function(name, error) {
|
||||
failCount++;
|
||||
const ctx = suiteStack.join(" > ");
|
||||
console.log(` FAIL: ${ctx} > ${name}: ${error}`);
|
||||
return null;
|
||||
};
|
||||
|
||||
env["push-suite"] = function(name) {
|
||||
suiteStack.push(name);
|
||||
console.log(`${" ".repeat(suiteStack.length - 1)}Suite: ${name}`);
|
||||
return null;
|
||||
};
|
||||
|
||||
env["pop-suite"] = function() {
|
||||
suiteStack.pop();
|
||||
return null;
|
||||
};
|
||||
|
||||
// Load test framework
|
||||
const projectDir = path.join(__dirname, "..", "..");
|
||||
const specTests = path.join(projectDir, "spec", "tests");
|
||||
const webTests = path.join(projectDir, "web", "tests");
|
||||
|
||||
const frameworkSrc = fs.readFileSync(path.join(specTests, "test-framework.sx"), "utf8");
|
||||
const frameworkExprs = Sx.parse(frameworkSrc);
|
||||
for (const expr of frameworkExprs) {
|
||||
Sx.eval(expr, env);
|
||||
}
|
||||
|
||||
// Determine which tests to run
|
||||
const args = process.argv.slice(2).filter(a => !a.startsWith("--"));
|
||||
let testFiles = [];
|
||||
|
||||
if (args.length > 0) {
|
||||
// Specific test files
|
||||
for (const arg of args) {
|
||||
const name = arg.endsWith(".sx") ? arg : `${arg}.sx`;
|
||||
const specPath = path.join(specTests, name);
|
||||
const webPath = path.join(webTests, name);
|
||||
if (fs.existsSync(specPath)) testFiles.push(specPath);
|
||||
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
|
||||
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));
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
// Run tests
|
||||
for (const testFile of testFiles) {
|
||||
const name = path.basename(testFile);
|
||||
console.log("=" .repeat(60));
|
||||
console.log(`Running ${name}`);
|
||||
console.log("=" .repeat(60));
|
||||
|
||||
try {
|
||||
const src = fs.readFileSync(testFile, "utf8");
|
||||
const exprs = Sx.parse(src);
|
||||
for (const expr of exprs) {
|
||||
Sx.eval(expr, env);
|
||||
}
|
||||
} catch (e) {
|
||||
console.error(`ERROR in ${name}: ${e.message}`);
|
||||
failCount++;
|
||||
}
|
||||
}
|
||||
|
||||
// Summary
|
||||
console.log("=" .repeat(60));
|
||||
console.log(`Results: ${passCount} passed, ${failCount} failed`);
|
||||
console.log("=" .repeat(60));
|
||||
|
||||
process.exit(failCount > 0 ? 1 : 0);
|
||||
@@ -107,6 +107,7 @@
|
||||
"get-primitive" "getPrimitive"
|
||||
"env-has?" "envHas"
|
||||
"env-get" "envGet"
|
||||
"env-bind!" "envBind"
|
||||
"env-set!" "envSet"
|
||||
"env-extend" "envExtend"
|
||||
"env-merge" "envMerge"
|
||||
@@ -989,6 +990,11 @@
|
||||
", " (js-expr (nth args 1))
|
||||
", " (js-expr (nth args 2)) ")")
|
||||
|
||||
(= op "env-bind!")
|
||||
(str "envBind(" (js-expr (nth args 0))
|
||||
", " (js-expr (nth args 1))
|
||||
", " (js-expr (nth args 2)) ")")
|
||||
|
||||
(= op "env-set!")
|
||||
(str "envSet(" (js-expr (nth args 0))
|
||||
", " (js-expr (nth args 1))
|
||||
@@ -1396,6 +1402,10 @@
|
||||
"] = " (js-expr (nth expr 3)) ";")
|
||||
(= name "append!")
|
||||
(str (js-expr (nth expr 1)) ".push(" (js-expr (nth expr 2)) ");")
|
||||
(= name "env-bind!")
|
||||
(str "envBind(" (js-expr (nth expr 1))
|
||||
", " (js-expr (nth expr 2))
|
||||
", " (js-expr (nth expr 3)) ");")
|
||||
(= name "env-set!")
|
||||
(str "envSet(" (js-expr (nth expr 1))
|
||||
", " (js-expr (nth expr 2))
|
||||
36
hosts/ocaml/bin/debug_set.ml
Normal file
36
hosts/ocaml/bin/debug_set.ml
Normal file
@@ -0,0 +1,36 @@
|
||||
module T = Sx_types
|
||||
module P = Sx_parser
|
||||
module R = Sx_ref
|
||||
open T
|
||||
|
||||
let () =
|
||||
let env = T.make_env () in
|
||||
let eval src =
|
||||
let exprs = P.parse_all src in
|
||||
let result = ref Nil in
|
||||
List.iter (fun e -> result := R.eval_expr e (Env env)) exprs;
|
||||
!result
|
||||
in
|
||||
(* Test 1: basic set! in closure *)
|
||||
let r = eval "(let ((x 0)) (set! x 42) x)" in
|
||||
Printf.printf "basic set!: %s (expect 42)\n%!" (T.inspect r);
|
||||
|
||||
(* Test 2: set! through lambda call *)
|
||||
let r = eval "(let ((x 0)) (let ((f (fn () (set! x 99)))) (f) x))" in
|
||||
Printf.printf "set! via lambda: %s (expect 99)\n%!" (T.inspect r);
|
||||
|
||||
(* Test 3: counter pattern *)
|
||||
let r = eval "(do (define make-counter (fn () (let ((c 0)) (fn () (set! c (+ c 1)) c)))) (let ((counter (make-counter))) (counter) (counter) (counter)))" in
|
||||
Printf.printf "counter: %s (expect 3)\n%!" (T.inspect r);
|
||||
|
||||
(* Test 4: set! in for-each *)
|
||||
let r = eval "(let ((total 0)) (for-each (fn (n) (set! total (+ total n))) (list 1 2 3 4 5)) total)" in
|
||||
Printf.printf "set! in for-each: %s (expect 15)\n%!" (T.inspect r);
|
||||
|
||||
(* Test 5: append! in for-each *)
|
||||
ignore (T.env_bind env "append!" (NativeFn ("append!", fun args ->
|
||||
match args with
|
||||
| [List items; v] -> List (items @ [v])
|
||||
| _ -> raise (Eval_error "append!: expected list and value"))));
|
||||
let r = eval "(let ((log (list))) (for-each (fn (x) (append! log x)) (list 1 2 3)) log)" in
|
||||
Printf.printf "append! in for-each: %s (expect (1 2 3))\n%!" (T.inspect r)
|
||||
3
hosts/ocaml/bin/dune
Normal file
3
hosts/ocaml/bin/dune
Normal file
@@ -0,0 +1,3 @@
|
||||
(executables
|
||||
(names run_tests debug_set sx_server)
|
||||
(libraries sx))
|
||||
1
hosts/ocaml/bin/dune_debug
Normal file
1
hosts/ocaml/bin/dune_debug
Normal file
@@ -0,0 +1 @@
|
||||
(executable (name debug_macro) (libraries sx))
|
||||
694
hosts/ocaml/bin/run_tests.ml
Normal file
694
hosts/ocaml/bin/run_tests.ml
Normal file
@@ -0,0 +1,694 @@
|
||||
(** Test runner — runs the SX spec test suite against the transpiled CEK evaluator.
|
||||
|
||||
Provides the 5 platform functions required by test-framework.sx:
|
||||
try-call, report-pass, report-fail, push-suite, pop-suite
|
||||
|
||||
Plus test helpers: sx-parse, cek-eval, env-*, equal?, etc.
|
||||
|
||||
Usage:
|
||||
dune exec bin/run_tests.exe # foundation + spec tests
|
||||
dune exec bin/run_tests.exe -- test-primitives # specific test
|
||||
dune exec bin/run_tests.exe -- --foundation # foundation only *)
|
||||
|
||||
open Sx_types
|
||||
open Sx_parser
|
||||
open Sx_primitives
|
||||
open Sx_runtime
|
||||
open Sx_ref
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Test state *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let pass_count = ref 0
|
||||
let fail_count = ref 0
|
||||
let suite_stack : string list ref = ref []
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Deep equality — SX structural comparison *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let rec deep_equal a b =
|
||||
match a, b with
|
||||
| Nil, Nil -> true
|
||||
| Bool a, Bool b -> a = b
|
||||
| Number a, Number b -> a = b
|
||||
| String a, String b -> a = b
|
||||
| Symbol a, Symbol b -> a = b
|
||||
| Keyword a, Keyword b -> a = b
|
||||
| (List a | ListRef { contents = a }), (List b | ListRef { contents = b }) ->
|
||||
List.length a = List.length b &&
|
||||
List.for_all2 deep_equal a b
|
||||
| Dict a, Dict b ->
|
||||
let ka = Hashtbl.fold (fun k _ acc -> k :: acc) a [] in
|
||||
let kb = Hashtbl.fold (fun k _ acc -> k :: acc) b [] in
|
||||
List.length ka = List.length kb &&
|
||||
List.for_all (fun k ->
|
||||
Hashtbl.mem b k &&
|
||||
deep_equal
|
||||
(match Hashtbl.find_opt a k with Some v -> v | None -> Nil)
|
||||
(match Hashtbl.find_opt b k with Some v -> v | None -> Nil)) ka
|
||||
| Lambda _, Lambda _ -> a == b (* identity *)
|
||||
| NativeFn _, NativeFn _ -> a == b
|
||||
| _ -> false
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Build evaluator environment with test platform functions *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let make_test_env () =
|
||||
let env = Sx_types.make_env () in
|
||||
|
||||
let bind name fn =
|
||||
ignore (Sx_types.env_bind env name (NativeFn (name, fn)))
|
||||
in
|
||||
|
||||
(* --- 5 platform functions required by test-framework.sx --- *)
|
||||
|
||||
bind "try-call" (fun args ->
|
||||
match args with
|
||||
| [thunk] ->
|
||||
(try
|
||||
(* Call the thunk: it's a lambda with no params *)
|
||||
let result = eval_expr (List [thunk]) (Env env) in
|
||||
ignore result;
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "ok" (Bool true);
|
||||
Dict d
|
||||
with
|
||||
| Eval_error msg ->
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "ok" (Bool false);
|
||||
Hashtbl.replace d "error" (String msg);
|
||||
Dict d
|
||||
| exn ->
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "ok" (Bool false);
|
||||
Hashtbl.replace d "error" (String (Printexc.to_string exn));
|
||||
Dict d)
|
||||
| _ -> raise (Eval_error "try-call: expected 1 arg"));
|
||||
|
||||
bind "report-pass" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
incr pass_count;
|
||||
let ctx = String.concat " > " (List.rev !suite_stack) in
|
||||
Printf.printf " PASS: %s > %s\n%!" ctx name;
|
||||
Nil
|
||||
| [v] ->
|
||||
incr pass_count;
|
||||
let ctx = String.concat " > " (List.rev !suite_stack) in
|
||||
Printf.printf " PASS: %s > %s\n%!" ctx (Sx_types.inspect v);
|
||||
Nil
|
||||
| _ -> raise (Eval_error "report-pass: expected 1 arg"));
|
||||
|
||||
bind "report-fail" (fun args ->
|
||||
match args with
|
||||
| [String name; String error] ->
|
||||
incr fail_count;
|
||||
let ctx = String.concat " > " (List.rev !suite_stack) in
|
||||
Printf.printf " FAIL: %s > %s: %s\n%!" ctx name error;
|
||||
Nil
|
||||
| [name_v; error_v] ->
|
||||
incr fail_count;
|
||||
let ctx = String.concat " > " (List.rev !suite_stack) in
|
||||
Printf.printf " FAIL: %s > %s: %s\n%!" ctx
|
||||
(Sx_types.value_to_string name_v)
|
||||
(Sx_types.value_to_string error_v);
|
||||
Nil
|
||||
| _ -> raise (Eval_error "report-fail: expected 2 args"));
|
||||
|
||||
bind "push-suite" (fun args ->
|
||||
match args with
|
||||
| [String name] ->
|
||||
suite_stack := name :: !suite_stack;
|
||||
let indent = String.make ((List.length !suite_stack - 1) * 2) ' ' in
|
||||
Printf.printf "%sSuite: %s\n%!" indent name;
|
||||
Nil
|
||||
| [v] ->
|
||||
let name = Sx_types.value_to_string v in
|
||||
suite_stack := name :: !suite_stack;
|
||||
let indent = String.make ((List.length !suite_stack - 1) * 2) ' ' in
|
||||
Printf.printf "%sSuite: %s\n%!" indent name;
|
||||
Nil
|
||||
| _ -> raise (Eval_error "push-suite: expected 1 arg"));
|
||||
|
||||
bind "pop-suite" (fun _args ->
|
||||
suite_stack := (match !suite_stack with _ :: t -> t | [] -> []);
|
||||
Nil);
|
||||
|
||||
(* --- Test helpers --- *)
|
||||
|
||||
bind "sx-parse" (fun args ->
|
||||
match args with
|
||||
| [String s] -> List (parse_all s)
|
||||
| _ -> raise (Eval_error "sx-parse: expected string"));
|
||||
|
||||
bind "sx-parse-one" (fun args ->
|
||||
match args with
|
||||
| [String s] ->
|
||||
let exprs = parse_all s in
|
||||
(match exprs with e :: _ -> e | [] -> Nil)
|
||||
| _ -> raise (Eval_error "sx-parse-one: expected string"));
|
||||
|
||||
bind "cek-eval" (fun args ->
|
||||
match args with
|
||||
| [String s] ->
|
||||
let exprs = parse_all s in
|
||||
(match exprs with
|
||||
| e :: _ -> eval_expr e (Env env)
|
||||
| [] -> Nil)
|
||||
| _ -> raise (Eval_error "cek-eval: expected string"));
|
||||
|
||||
bind "eval-expr-cek" (fun args ->
|
||||
match args with
|
||||
| [expr; e] -> eval_expr expr e
|
||||
| [expr] -> eval_expr expr (Env env)
|
||||
| _ -> raise (Eval_error "eval-expr-cek: expected 1-2 args"));
|
||||
|
||||
bind "test-env" (fun _args -> Env (Sx_types.env_extend env));
|
||||
|
||||
(* --- Environment operations --- *)
|
||||
|
||||
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
|
||||
| _ -> 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)
|
||||
| _ -> 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
|
||||
| _ -> 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
|
||||
| _ -> 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)
|
||||
| _ -> 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)
|
||||
| _ -> raise (Eval_error "env-merge: expected 2 envs"));
|
||||
|
||||
(* --- Equality --- *)
|
||||
|
||||
bind "equal?" (fun args ->
|
||||
match args with
|
||||
| [a; b] -> Bool (deep_equal a b)
|
||||
| _ -> raise (Eval_error "equal?: expected 2 args"));
|
||||
|
||||
bind "identical?" (fun args ->
|
||||
match args with
|
||||
| [a; b] -> Bool (a == b)
|
||||
| _ -> raise (Eval_error "identical?: expected 2 args"));
|
||||
|
||||
(* --- Continuation support --- *)
|
||||
|
||||
bind "make-continuation" (fun args ->
|
||||
match args with
|
||||
| [f] ->
|
||||
let k v = sx_call f [v] in
|
||||
Continuation (k, None)
|
||||
| _ -> raise (Eval_error "make-continuation: expected 1 arg"));
|
||||
|
||||
bind "continuation?" (fun args ->
|
||||
match args with
|
||||
| [Continuation _] -> Bool true
|
||||
| [_] -> Bool false
|
||||
| _ -> raise (Eval_error "continuation?: expected 1 arg"));
|
||||
|
||||
bind "continuation-fn" (fun args ->
|
||||
match args with
|
||||
| [Continuation (f, _)] -> NativeFn ("continuation-fn-result", fun args ->
|
||||
match args with [v] -> f v | _ -> f Nil)
|
||||
| _ -> raise (Eval_error "continuation-fn: expected continuation"));
|
||||
|
||||
(* --- Core builtins used by test framework / test code --- *)
|
||||
|
||||
bind "assert" (fun args ->
|
||||
match args with
|
||||
| [cond] ->
|
||||
if not (sx_truthy cond) then raise (Eval_error "Assertion failed");
|
||||
Bool true
|
||||
| [cond; String msg] ->
|
||||
if not (sx_truthy cond) then raise (Eval_error ("Assertion error: " ^ msg));
|
||||
Bool true
|
||||
| [cond; msg] ->
|
||||
if not (sx_truthy cond) then
|
||||
raise (Eval_error ("Assertion error: " ^ Sx_types.value_to_string msg));
|
||||
Bool true
|
||||
| _ -> raise (Eval_error "assert: expected 1-2 args"));
|
||||
|
||||
bind "append!" (fun args ->
|
||||
match args with
|
||||
| [ListRef r; v] -> r := !r @ [v]; ListRef r (* mutate in place *)
|
||||
| [List items; v] -> List (items @ [v]) (* immutable fallback *)
|
||||
| _ -> raise (Eval_error "append!: expected list and value"));
|
||||
|
||||
(* --- HTML Renderer (from sx_render.ml library module) --- *)
|
||||
Sx_render.setup_render_env env;
|
||||
|
||||
(* --- Missing primitives referenced by tests --- *)
|
||||
|
||||
bind "upcase" (fun args ->
|
||||
match args with
|
||||
| [String s] -> String (String.uppercase_ascii s)
|
||||
| _ -> raise (Eval_error "upcase: expected string"));
|
||||
|
||||
bind "downcase" (fun args ->
|
||||
match args with
|
||||
| [String s] -> String (String.lowercase_ascii s)
|
||||
| _ -> raise (Eval_error "downcase: expected string"));
|
||||
|
||||
bind "make-keyword" (fun args ->
|
||||
match args with
|
||||
| [String s] -> Keyword s
|
||||
| _ -> raise (Eval_error "make-keyword: expected string"));
|
||||
|
||||
bind "string-length" (fun args ->
|
||||
match args with
|
||||
| [String s] -> Number (float_of_int (String.length s))
|
||||
| _ -> raise (Eval_error "string-length: expected string"));
|
||||
|
||||
bind "dict-get" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k] -> Sx_types.dict_get d k
|
||||
| [Dict d; Keyword k] -> Sx_types.dict_get d k
|
||||
| _ -> raise (Eval_error "dict-get: expected dict and key"));
|
||||
|
||||
bind "apply" (fun args ->
|
||||
match args with
|
||||
| f :: rest ->
|
||||
let all_args = match List.rev rest with
|
||||
| List last :: prefix -> List.rev prefix @ last
|
||||
| _ -> rest
|
||||
in
|
||||
sx_call f all_args
|
||||
| _ -> raise (Eval_error "apply: expected function and args"));
|
||||
|
||||
(* --- Type system helpers (for --full tests) --- *)
|
||||
|
||||
bind "test-prim-types" (fun _args ->
|
||||
let d = Hashtbl.create 40 in
|
||||
List.iter (fun (k, v) -> Hashtbl.replace d k (String v)) [
|
||||
"+", "number"; "-", "number"; "*", "number"; "/", "number";
|
||||
"mod", "number"; "inc", "number"; "dec", "number";
|
||||
"abs", "number"; "min", "number"; "max", "number";
|
||||
"floor", "number"; "ceil", "number"; "round", "number";
|
||||
"str", "string"; "upper", "string"; "lower", "string";
|
||||
"trim", "string"; "join", "string"; "replace", "string";
|
||||
"format", "string"; "substr", "string";
|
||||
"=", "boolean"; "<", "boolean"; ">", "boolean";
|
||||
"<=", "boolean"; ">=", "boolean"; "!=", "boolean";
|
||||
"not", "boolean"; "nil?", "boolean"; "empty?", "boolean";
|
||||
"number?", "boolean"; "string?", "boolean"; "boolean?", "boolean";
|
||||
"list?", "boolean"; "dict?", "boolean"; "symbol?", "boolean";
|
||||
"keyword?", "boolean"; "contains?", "boolean"; "has-key?", "boolean";
|
||||
"starts-with?", "boolean"; "ends-with?", "boolean";
|
||||
"len", "number"; "first", "any"; "rest", "list";
|
||||
"last", "any"; "nth", "any"; "cons", "list";
|
||||
"append", "list"; "concat", "list"; "reverse", "list";
|
||||
"sort", "list"; "slice", "list"; "range", "list";
|
||||
"flatten", "list"; "keys", "list"; "vals", "list";
|
||||
"map-dict", "dict"; "assoc", "dict"; "dissoc", "dict";
|
||||
"merge", "dict"; "dict", "dict";
|
||||
"get", "any"; "type-of", "string";
|
||||
];
|
||||
Dict d);
|
||||
|
||||
bind "test-prim-param-types" (fun _args ->
|
||||
let d = Hashtbl.create 10 in
|
||||
let pos name typ =
|
||||
let d2 = Hashtbl.create 2 in
|
||||
Hashtbl.replace d2 "positional" (List [List [String name; String typ]]);
|
||||
Hashtbl.replace d2 "rest-type" Nil;
|
||||
Dict d2
|
||||
in
|
||||
let pos_rest name typ rt =
|
||||
let d2 = Hashtbl.create 2 in
|
||||
Hashtbl.replace d2 "positional" (List [List [String name; String typ]]);
|
||||
Hashtbl.replace d2 "rest-type" (String rt);
|
||||
Dict d2
|
||||
in
|
||||
Hashtbl.replace d "+" (pos_rest "a" "number" "number");
|
||||
Hashtbl.replace d "-" (pos_rest "a" "number" "number");
|
||||
Hashtbl.replace d "*" (pos_rest "a" "number" "number");
|
||||
Hashtbl.replace d "/" (pos_rest "a" "number" "number");
|
||||
Hashtbl.replace d "inc" (pos "n" "number");
|
||||
Hashtbl.replace d "dec" (pos "n" "number");
|
||||
Hashtbl.replace d "upper" (pos "s" "string");
|
||||
Hashtbl.replace d "lower" (pos "s" "string");
|
||||
Hashtbl.replace d "keys" (pos "d" "dict");
|
||||
Hashtbl.replace d "vals" (pos "d" "dict");
|
||||
Dict d);
|
||||
|
||||
(* --- Component accessors --- *)
|
||||
|
||||
bind "component-param-types" (fun _args -> Nil);
|
||||
|
||||
bind "component-set-param-types!" (fun _args -> Nil);
|
||||
|
||||
bind "component-params" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> List (List.map (fun s -> String s) c.c_params)
|
||||
| _ -> Nil);
|
||||
|
||||
bind "component-body" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> c.c_body
|
||||
| _ -> Nil);
|
||||
|
||||
bind "component-has-children" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> Bool c.c_has_children
|
||||
| _ -> Bool false);
|
||||
|
||||
bind "component-affinity" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> String c.c_affinity
|
||||
| _ -> String "auto");
|
||||
|
||||
(* --- Parser test helpers --- *)
|
||||
|
||||
bind "keyword-name" (fun args ->
|
||||
match args with
|
||||
| [Keyword k] -> String k
|
||||
| _ -> raise (Eval_error "keyword-name: expected keyword"));
|
||||
|
||||
bind "symbol-name" (fun args ->
|
||||
match args with
|
||||
| [Symbol s] -> String s
|
||||
| _ -> raise (Eval_error "symbol-name: expected symbol"));
|
||||
|
||||
bind "sx-serialize" (fun args ->
|
||||
match args with
|
||||
| [v] -> String (Sx_types.inspect v)
|
||||
| _ -> raise (Eval_error "sx-serialize: expected 1 arg"));
|
||||
|
||||
(* --- make-symbol --- *)
|
||||
|
||||
bind "make-symbol" (fun args ->
|
||||
match args with
|
||||
| [String s] -> Symbol s
|
||||
| [v] -> Symbol (Sx_types.value_to_string v)
|
||||
| _ -> raise (Eval_error "make-symbol: expected 1 arg"));
|
||||
|
||||
(* --- CEK stepping / introspection --- *)
|
||||
|
||||
bind "make-cek-state" (fun args ->
|
||||
match args with
|
||||
| [ctrl; env'; kont] -> Sx_ref.make_cek_state ctrl env' kont
|
||||
| _ -> raise (Eval_error "make-cek-state: expected 3 args"));
|
||||
|
||||
bind "cek-step" (fun args ->
|
||||
match args with
|
||||
| [state] -> Sx_ref.cek_step state
|
||||
| _ -> raise (Eval_error "cek-step: expected 1 arg"));
|
||||
|
||||
bind "cek-phase" (fun args ->
|
||||
match args with
|
||||
| [state] -> Sx_ref.cek_phase state
|
||||
| _ -> raise (Eval_error "cek-phase: expected 1 arg"));
|
||||
|
||||
bind "cek-value" (fun args ->
|
||||
match args with
|
||||
| [state] -> Sx_ref.cek_value state
|
||||
| _ -> raise (Eval_error "cek-value: expected 1 arg"));
|
||||
|
||||
bind "cek-terminal?" (fun args ->
|
||||
match args with
|
||||
| [state] -> Sx_ref.cek_terminal_p state
|
||||
| _ -> raise (Eval_error "cek-terminal?: expected 1 arg"));
|
||||
|
||||
bind "cek-kont" (fun args ->
|
||||
match args with
|
||||
| [state] -> Sx_ref.cek_kont state
|
||||
| _ -> raise (Eval_error "cek-kont: expected 1 arg"));
|
||||
|
||||
bind "frame-type" (fun args ->
|
||||
match args with
|
||||
| [frame] -> Sx_ref.frame_type frame
|
||||
| _ -> raise (Eval_error "frame-type: expected 1 arg"));
|
||||
|
||||
(* --- Strict mode --- *)
|
||||
(* *strict* is a plain value in the env, mutated via env_set by set-strict! *)
|
||||
ignore (Sx_types.env_bind env "*strict*" (Bool false));
|
||||
ignore (Sx_types.env_bind env "*prim-param-types*" Nil);
|
||||
|
||||
bind "set-strict!" (fun args ->
|
||||
match args with
|
||||
| [v] ->
|
||||
Sx_ref._strict_ref := v;
|
||||
ignore (Sx_types.env_set env "*strict*" v); Nil
|
||||
| _ -> raise (Eval_error "set-strict!: expected 1 arg"));
|
||||
|
||||
bind "set-prim-param-types!" (fun args ->
|
||||
match args with
|
||||
| [v] ->
|
||||
Sx_ref._prim_param_types_ref := v;
|
||||
ignore (Sx_types.env_set env "*prim-param-types*" v); Nil
|
||||
| _ -> raise (Eval_error "set-prim-param-types!: expected 1 arg"));
|
||||
|
||||
bind "value-matches-type?" (fun args ->
|
||||
match args with
|
||||
| [v; String expected] -> Sx_ref.value_matches_type_p v (String expected)
|
||||
| _ -> raise (Eval_error "value-matches-type?: expected value and type string"));
|
||||
|
||||
env
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Foundation tests (direct, no evaluator) *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let run_foundation_tests () =
|
||||
Printf.printf "=== SX OCaml Foundation Tests ===\n\n";
|
||||
|
||||
let assert_eq name expected actual =
|
||||
if deep_equal expected actual then begin
|
||||
incr pass_count;
|
||||
Printf.printf " PASS: %s\n" name
|
||||
end else begin
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: %s — expected %s, got %s\n" name
|
||||
(Sx_types.inspect expected) (Sx_types.inspect actual)
|
||||
end
|
||||
in
|
||||
let assert_true name v =
|
||||
if sx_truthy v then begin
|
||||
incr pass_count;
|
||||
Printf.printf " PASS: %s\n" name
|
||||
end else begin
|
||||
incr fail_count;
|
||||
Printf.printf " FAIL: %s — expected truthy, got %s\n" name (Sx_types.inspect v)
|
||||
end
|
||||
in
|
||||
let call name args =
|
||||
match Hashtbl.find_opt primitives name with
|
||||
| Some f -> f args
|
||||
| None -> failwith ("Unknown primitive: " ^ name)
|
||||
in
|
||||
|
||||
Printf.printf "Suite: parser\n";
|
||||
assert_eq "number" (Number 42.0) (List.hd (parse_all "42"));
|
||||
assert_eq "string" (String "hello") (List.hd (parse_all "\"hello\""));
|
||||
assert_eq "bool true" (Bool true) (List.hd (parse_all "true"));
|
||||
assert_eq "nil" Nil (List.hd (parse_all "nil"));
|
||||
assert_eq "keyword" (Keyword "class") (List.hd (parse_all ":class"));
|
||||
assert_eq "symbol" (Symbol "foo") (List.hd (parse_all "foo"));
|
||||
assert_eq "list" (List [Symbol "+"; Number 1.0; Number 2.0]) (List.hd (parse_all "(+ 1 2)"));
|
||||
(match List.hd (parse_all "(div :class \"card\" (p \"hi\"))") with
|
||||
| List [Symbol "div"; Keyword "class"; String "card"; List [Symbol "p"; String "hi"]] ->
|
||||
incr pass_count; Printf.printf " PASS: nested list\n"
|
||||
| v -> incr fail_count; Printf.printf " FAIL: nested list — got %s\n" (Sx_types.inspect v));
|
||||
(match List.hd (parse_all "'(1 2 3)") with
|
||||
| List [Symbol "quote"; List [Number 1.0; Number 2.0; Number 3.0]] ->
|
||||
incr pass_count; Printf.printf " PASS: quote sugar\n"
|
||||
| v -> incr fail_count; Printf.printf " FAIL: quote sugar — got %s\n" (Sx_types.inspect v));
|
||||
(match List.hd (parse_all "{:a 1 :b 2}") with
|
||||
| Dict d when dict_has d "a" && dict_has d "b" ->
|
||||
incr pass_count; Printf.printf " PASS: dict literal\n"
|
||||
| v -> incr fail_count; Printf.printf " FAIL: dict literal — got %s\n" (Sx_types.inspect v));
|
||||
assert_eq "comment" (Number 42.0) (List.hd (parse_all ";; comment\n42"));
|
||||
assert_eq "string escape" (String "hello\nworld") (List.hd (parse_all "\"hello\\nworld\""));
|
||||
assert_eq "multiple exprs" (Number 2.0) (Number (float_of_int (List.length (parse_all "(1 2 3) (4 5)"))));
|
||||
|
||||
Printf.printf "\nSuite: primitives\n";
|
||||
assert_eq "+" (Number 6.0) (call "+" [Number 1.0; Number 2.0; Number 3.0]);
|
||||
assert_eq "-" (Number 3.0) (call "-" [Number 5.0; Number 2.0]);
|
||||
assert_eq "*" (Number 12.0) (call "*" [Number 3.0; Number 4.0]);
|
||||
assert_eq "/" (Number 2.5) (call "/" [Number 5.0; Number 2.0]);
|
||||
assert_eq "mod" (Number 1.0) (call "mod" [Number 5.0; Number 2.0]);
|
||||
assert_eq "inc" (Number 6.0) (call "inc" [Number 5.0]);
|
||||
assert_eq "abs" (Number 5.0) (call "abs" [Number (-5.0)]);
|
||||
assert_true "=" (call "=" [Number 1.0; Number 1.0]);
|
||||
assert_true "!=" (call "!=" [Number 1.0; Number 2.0]);
|
||||
assert_true "<" (call "<" [Number 1.0; Number 2.0]);
|
||||
assert_true ">" (call ">" [Number 2.0; Number 1.0]);
|
||||
assert_true "nil?" (call "nil?" [Nil]);
|
||||
assert_true "number?" (call "number?" [Number 1.0]);
|
||||
assert_true "string?" (call "string?" [String "hi"]);
|
||||
assert_true "list?" (call "list?" [List [Number 1.0]]);
|
||||
assert_true "empty? list" (call "empty?" [List []]);
|
||||
assert_true "empty? string" (call "empty?" [String ""]);
|
||||
assert_eq "str" (String "hello42") (call "str" [String "hello"; Number 42.0]);
|
||||
assert_eq "upper" (String "HI") (call "upper" [String "hi"]);
|
||||
assert_eq "trim" (String "hi") (call "trim" [String " hi "]);
|
||||
assert_eq "join" (String "a,b,c") (call "join" [String ","; List [String "a"; String "b"; String "c"]]);
|
||||
assert_true "starts-with?" (call "starts-with?" [String "hello"; String "hel"]);
|
||||
assert_true "contains?" (call "contains?" [List [Number 1.0; Number 2.0; Number 3.0]; Number 2.0]);
|
||||
assert_eq "list" (List [Number 1.0; Number 2.0]) (call "list" [Number 1.0; Number 2.0]);
|
||||
assert_eq "len" (Number 3.0) (call "len" [List [Number 1.0; Number 2.0; Number 3.0]]);
|
||||
assert_eq "first" (Number 1.0) (call "first" [List [Number 1.0; Number 2.0]]);
|
||||
assert_eq "rest" (List [Number 2.0; Number 3.0]) (call "rest" [List [Number 1.0; Number 2.0; Number 3.0]]);
|
||||
assert_eq "nth" (Number 2.0) (call "nth" [List [Number 1.0; Number 2.0]; Number 1.0]);
|
||||
assert_eq "cons" (List [Number 0.0; Number 1.0]) (call "cons" [Number 0.0; List [Number 1.0]]);
|
||||
assert_eq "append" (List [Number 1.0; Number 2.0; Number 3.0])
|
||||
(call "append" [List [Number 1.0]; List [Number 2.0; Number 3.0]]);
|
||||
assert_eq "reverse" (List [Number 3.0; Number 2.0; Number 1.0])
|
||||
(call "reverse" [List [Number 1.0; Number 2.0; Number 3.0]]);
|
||||
assert_eq "range" (List [Number 0.0; Number 1.0; Number 2.0]) (call "range" [Number 3.0]);
|
||||
assert_eq "slice" (List [Number 2.0; Number 3.0])
|
||||
(call "slice" [List [Number 1.0; Number 2.0; Number 3.0]; Number 1.0]);
|
||||
assert_eq "type-of" (String "number") (call "type-of" [Number 1.0]);
|
||||
assert_eq "type-of nil" (String "nil") (call "type-of" [Nil]);
|
||||
|
||||
Printf.printf "\nSuite: env\n";
|
||||
let e = Sx_types.make_env () in
|
||||
ignore (Sx_types.env_bind e "x" (Number 42.0));
|
||||
assert_eq "env-bind + get" (Number 42.0) (Sx_types.env_get e "x");
|
||||
assert_true "env-has" (Bool (Sx_types.env_has e "x"));
|
||||
let child = Sx_types.env_extend e in
|
||||
ignore (Sx_types.env_bind child "y" (Number 10.0));
|
||||
assert_eq "child sees parent" (Number 42.0) (Sx_types.env_get child "x");
|
||||
assert_eq "child own binding" (Number 10.0) (Sx_types.env_get child "y");
|
||||
ignore (Sx_types.env_set child "x" (Number 99.0));
|
||||
assert_eq "set! walks chain" (Number 99.0) (Sx_types.env_get e "x");
|
||||
|
||||
Printf.printf "\nSuite: types\n";
|
||||
assert_true "sx_truthy true" (Bool (sx_truthy (Bool true)));
|
||||
assert_true "sx_truthy 0" (Bool (sx_truthy (Number 0.0)));
|
||||
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
|
||||
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))
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Spec test runner *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let run_spec_tests env test_files =
|
||||
(* Find project root: walk up from cwd until we find spec/tests *)
|
||||
let rec find_root dir =
|
||||
let candidate = Filename.concat dir "spec/tests" in
|
||||
if Sys.file_exists candidate then dir
|
||||
else
|
||||
let parent = Filename.dirname dir in
|
||||
if parent = dir then Sys.getcwd () (* reached filesystem root *)
|
||||
else find_root parent
|
||||
in
|
||||
let project_dir = find_root (Sys.getcwd ()) in
|
||||
let spec_tests_dir = Filename.concat project_dir "spec/tests" in
|
||||
let framework_path = Filename.concat spec_tests_dir "test-framework.sx" in
|
||||
|
||||
if not (Sys.file_exists framework_path) then begin
|
||||
Printf.eprintf "test-framework.sx not found at %s\n" framework_path;
|
||||
Printf.eprintf "Run from the project root directory.\n";
|
||||
exit 1
|
||||
end;
|
||||
|
||||
let load_and_eval path =
|
||||
let ic = open_in path in
|
||||
let n = in_channel_length ic in
|
||||
let s = Bytes.create n in
|
||||
really_input ic s 0 n;
|
||||
close_in ic;
|
||||
let src = Bytes.to_string s in
|
||||
let exprs = parse_all src in
|
||||
List.iter (fun expr ->
|
||||
ignore (eval_expr expr (Env env))
|
||||
) exprs
|
||||
in
|
||||
|
||||
Printf.printf "\nLoading test framework...\n%!";
|
||||
load_and_eval framework_path;
|
||||
|
||||
(* Determine test files *)
|
||||
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))
|
||||
end else
|
||||
List.map (fun name ->
|
||||
if Filename.check_suffix name ".sx" then name
|
||||
else name ^ ".sx") test_files
|
||||
in
|
||||
|
||||
List.iter (fun name ->
|
||||
let path = Filename.concat spec_tests_dir name in
|
||||
if Sys.file_exists path then begin
|
||||
Printf.printf "\n%s\n" (String.make 60 '=');
|
||||
Printf.printf "Running %s\n" name;
|
||||
Printf.printf "%s\n%!" (String.make 60 '=');
|
||||
(try
|
||||
load_and_eval path
|
||||
with
|
||||
| Eval_error msg ->
|
||||
incr fail_count;
|
||||
Printf.printf " ERROR in %s: %s\n%!" name msg
|
||||
| exn ->
|
||||
incr fail_count;
|
||||
Printf.printf " ERROR in %s: %s\n%!" name (Printexc.to_string exn))
|
||||
end else
|
||||
Printf.eprintf "Test file not found: %s\n" path
|
||||
) files
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Main *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let () =
|
||||
let args = Array.to_list Sys.argv |> List.tl in
|
||||
let foundation_only = List.mem "--foundation" args in
|
||||
let test_files = List.filter (fun a -> not (String.length a > 0 && a.[0] = '-')) args in
|
||||
|
||||
(* Always run foundation tests *)
|
||||
run_foundation_tests ();
|
||||
|
||||
if not foundation_only then begin
|
||||
Printf.printf "\n=== SX Spec Tests (CEK Evaluator) ===\n%!";
|
||||
let env = make_test_env () in
|
||||
run_spec_tests env test_files
|
||||
end;
|
||||
|
||||
(* Summary *)
|
||||
Printf.printf "\n%s\n" (String.make 60 '=');
|
||||
Printf.printf "Results: %d passed, %d failed\n" !pass_count !fail_count;
|
||||
Printf.printf "%s\n" (String.make 60 '=');
|
||||
if !fail_count > 0 then exit 1
|
||||
420
hosts/ocaml/bin/sx_server.ml
Normal file
420
hosts/ocaml/bin/sx_server.ml
Normal file
@@ -0,0 +1,420 @@
|
||||
(** SX coroutine subprocess server.
|
||||
|
||||
Persistent process that accepts commands on stdin and writes
|
||||
responses on stdout. All messages are single-line SX expressions,
|
||||
newline-delimited.
|
||||
|
||||
Protocol:
|
||||
Python → OCaml: (ping), (load path), (load-source src),
|
||||
(eval src), (render src), (reset),
|
||||
(io-response value)
|
||||
OCaml → Python: (ready), (ok), (ok value), (error msg),
|
||||
(io-request name args...)
|
||||
|
||||
IO primitives (query, action, request-arg, request-method, ctx)
|
||||
yield (io-request ...) and block on stdin for (io-response ...). *)
|
||||
|
||||
open Sx_types
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Output helpers *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
(** Escape a string for embedding in an SX string literal. *)
|
||||
let escape_sx_string s =
|
||||
let buf = Buffer.create (String.length s + 16) in
|
||||
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.contents buf
|
||||
|
||||
(** Serialize a value to SX text (for io-request args). *)
|
||||
let rec serialize_value = function
|
||||
| Nil -> "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
|
||||
| String s -> "\"" ^ escape_sx_string s ^ "\""
|
||||
| Symbol s -> s
|
||||
| Keyword k -> ":" ^ k
|
||||
| List items | ListRef { contents = items } ->
|
||||
"(list " ^ String.concat " " (List.map serialize_value items) ^ ")"
|
||||
| Dict d ->
|
||||
let pairs = Hashtbl.fold (fun k v acc ->
|
||||
(Printf.sprintf ":%s %s" k (serialize_value v)) :: acc) d [] in
|
||||
"{" ^ String.concat " " pairs ^ "}"
|
||||
| RawHTML s -> "\"" ^ escape_sx_string s ^ "\""
|
||||
| _ -> "nil"
|
||||
|
||||
let send line =
|
||||
print_string line;
|
||||
print_char '\n';
|
||||
flush stdout
|
||||
|
||||
let send_ok () = send "(ok)"
|
||||
let send_ok_value v = send (Printf.sprintf "(ok %s)" (serialize_value v))
|
||||
let send_ok_string s = send (Printf.sprintf "(ok \"%s\")" (escape_sx_string s))
|
||||
let send_error msg = send (Printf.sprintf "(error \"%s\")" (escape_sx_string msg))
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* IO bridge — primitives that yield to Python *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
(** Read a line from stdin (blocking). *)
|
||||
let read_line_blocking () =
|
||||
try Some (input_line stdin)
|
||||
with End_of_file -> None
|
||||
|
||||
(** Send an io-request and block until io-response arrives. *)
|
||||
let io_request name args =
|
||||
let args_str = String.concat " " (List.map serialize_value args) in
|
||||
send (Printf.sprintf "(io-request \"%s\" %s)" name args_str);
|
||||
(* Block on stdin for io-response *)
|
||||
match read_line_blocking () with
|
||||
| None -> raise (Eval_error "IO bridge: stdin closed while waiting for io-response")
|
||||
| Some line ->
|
||||
let exprs = Sx_parser.parse_all line in
|
||||
match exprs with
|
||||
| [List [Symbol "io-response"; value]] -> value
|
||||
| [List (Symbol "io-response" :: values)] ->
|
||||
(match values with
|
||||
| [v] -> v
|
||||
| _ -> List values)
|
||||
| _ -> raise (Eval_error ("IO bridge: unexpected response: " ^ line))
|
||||
|
||||
(** Bind IO primitives into the environment. *)
|
||||
let setup_io_env env =
|
||||
let bind name fn =
|
||||
ignore (env_bind env name (NativeFn (name, fn)))
|
||||
in
|
||||
|
||||
bind "query" (fun args ->
|
||||
match args with
|
||||
| service :: query_name :: rest ->
|
||||
io_request "query" (service :: query_name :: rest)
|
||||
| _ -> raise (Eval_error "query: expected (query service name ...)"));
|
||||
|
||||
bind "action" (fun args ->
|
||||
match args with
|
||||
| service :: action_name :: rest ->
|
||||
io_request "action" (service :: action_name :: rest)
|
||||
| _ -> raise (Eval_error "action: expected (action service name ...)"));
|
||||
|
||||
bind "request-arg" (fun args ->
|
||||
match args with
|
||||
| [name] -> io_request "request-arg" [name]
|
||||
| _ -> raise (Eval_error "request-arg: expected 1 arg"));
|
||||
|
||||
bind "request-method" (fun _args ->
|
||||
io_request "request-method" []);
|
||||
|
||||
bind "ctx" (fun args ->
|
||||
match args with
|
||||
| [key] -> io_request "ctx" [key]
|
||||
| _ -> raise (Eval_error "ctx: expected 1 arg"))
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Environment setup *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let make_server_env () =
|
||||
let env = make_env () in
|
||||
|
||||
(* Evaluator bindings — same as run_tests.ml's make_test_env,
|
||||
but only the ones needed for rendering (not test helpers). *)
|
||||
let bind name fn =
|
||||
ignore (env_bind env name (NativeFn (name, fn)))
|
||||
in
|
||||
|
||||
bind "assert" (fun args ->
|
||||
match args with
|
||||
| [cond] ->
|
||||
if not (sx_truthy cond) then raise (Eval_error "Assertion failed");
|
||||
Bool true
|
||||
| [cond; String msg] ->
|
||||
if not (sx_truthy cond) then raise (Eval_error ("Assertion error: " ^ msg));
|
||||
Bool true
|
||||
| [cond; msg] ->
|
||||
if not (sx_truthy cond) then
|
||||
raise (Eval_error ("Assertion error: " ^ value_to_string msg));
|
||||
Bool true
|
||||
| _ -> raise (Eval_error "assert: expected 1-2 args"));
|
||||
|
||||
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"));
|
||||
|
||||
(* HTML renderer *)
|
||||
Sx_render.setup_render_env env;
|
||||
|
||||
(* Missing primitives that may be referenced *)
|
||||
bind "upcase" (fun args ->
|
||||
match args with
|
||||
| [String s] -> String (String.uppercase_ascii s)
|
||||
| _ -> raise (Eval_error "upcase: expected string"));
|
||||
|
||||
bind "downcase" (fun args ->
|
||||
match args with
|
||||
| [String s] -> String (String.lowercase_ascii s)
|
||||
| _ -> raise (Eval_error "downcase: expected string"));
|
||||
|
||||
bind "make-keyword" (fun args ->
|
||||
match args with
|
||||
| [String s] -> Keyword s
|
||||
| _ -> raise (Eval_error "make-keyword: expected string"));
|
||||
|
||||
bind "string-length" (fun args ->
|
||||
match args with
|
||||
| [String s] -> Number (float_of_int (String.length s))
|
||||
| _ -> raise (Eval_error "string-length: expected string"));
|
||||
|
||||
bind "dict-get" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k] -> dict_get d k
|
||||
| [Dict d; Keyword k] -> dict_get d k
|
||||
| _ -> raise (Eval_error "dict-get: expected dict and key"));
|
||||
|
||||
bind "apply" (fun args ->
|
||||
match args with
|
||||
| f :: rest ->
|
||||
let all_args = match List.rev rest with
|
||||
| List last :: prefix -> List.rev prefix @ last
|
||||
| _ -> rest
|
||||
in
|
||||
Sx_runtime.sx_call f all_args
|
||||
| _ -> raise (Eval_error "apply: expected function and args"));
|
||||
|
||||
bind "equal?" (fun args ->
|
||||
match args with
|
||||
| [a; b] -> Bool (a = b)
|
||||
| _ -> raise (Eval_error "equal?: expected 2 args"));
|
||||
|
||||
bind "identical?" (fun args ->
|
||||
match args with
|
||||
| [a; b] -> Bool (a == b)
|
||||
| _ -> raise (Eval_error "identical?: expected 2 args"));
|
||||
|
||||
bind "make-continuation" (fun args ->
|
||||
match args with
|
||||
| [f] ->
|
||||
let k v = Sx_runtime.sx_call f [v] in
|
||||
Continuation (k, None)
|
||||
| _ -> raise (Eval_error "make-continuation: expected 1 arg"));
|
||||
|
||||
bind "continuation?" (fun args ->
|
||||
match args with
|
||||
| [Continuation _] -> Bool true
|
||||
| [_] -> Bool false
|
||||
| _ -> raise (Eval_error "continuation?: expected 1 arg"));
|
||||
|
||||
bind "make-symbol" (fun args ->
|
||||
match args with
|
||||
| [String s] -> Symbol s
|
||||
| [v] -> Symbol (value_to_string v)
|
||||
| _ -> raise (Eval_error "make-symbol: expected 1 arg"));
|
||||
|
||||
bind "sx-serialize" (fun args ->
|
||||
match args with
|
||||
| [v] -> String (inspect v)
|
||||
| _ -> raise (Eval_error "sx-serialize: expected 1 arg"));
|
||||
|
||||
(* Env operations *)
|
||||
bind "env-get" (fun args ->
|
||||
match args with
|
||||
| [Env e; String k] -> env_get e k
|
||||
| [Env e; Keyword k] -> env_get e k
|
||||
| _ -> raise (Eval_error "env-get: expected env and string"));
|
||||
|
||||
bind "env-has?" (fun args ->
|
||||
match args with
|
||||
| [Env e; String k] -> Bool (env_has e k)
|
||||
| [Env e; Keyword k] -> Bool (env_has e k)
|
||||
| _ -> raise (Eval_error "env-has?: expected env and string"));
|
||||
|
||||
bind "env-bind!" (fun args ->
|
||||
match args with
|
||||
| [Env e; String k; v] -> env_bind e k v
|
||||
| [Env e; Keyword k; v] -> env_bind e k v
|
||||
| _ -> raise (Eval_error "env-bind!: expected env, key, value"));
|
||||
|
||||
bind "env-set!" (fun args ->
|
||||
match args with
|
||||
| [Env e; String k; v] -> env_set e k v
|
||||
| [Env e; Keyword k; v] -> env_set e k v
|
||||
| _ -> raise (Eval_error "env-set!: expected env, key, value"));
|
||||
|
||||
bind "env-extend" (fun args ->
|
||||
match args with
|
||||
| [Env e] -> Env (env_extend e)
|
||||
| _ -> raise (Eval_error "env-extend: expected env"));
|
||||
|
||||
bind "env-merge" (fun args ->
|
||||
match args with
|
||||
| [Env a; Env b] -> Env (env_merge a b)
|
||||
| _ -> raise (Eval_error "env-merge: expected 2 envs"));
|
||||
|
||||
(* Strict mode state *)
|
||||
ignore (env_bind env "*strict*" (Bool false));
|
||||
ignore (env_bind env "*prim-param-types*" Nil);
|
||||
|
||||
bind "set-strict!" (fun args ->
|
||||
match args with
|
||||
| [v] ->
|
||||
Sx_ref._strict_ref := v;
|
||||
ignore (env_set env "*strict*" v); Nil
|
||||
| _ -> raise (Eval_error "set-strict!: expected 1 arg"));
|
||||
|
||||
bind "set-prim-param-types!" (fun args ->
|
||||
match args with
|
||||
| [v] ->
|
||||
Sx_ref._prim_param_types_ref := v;
|
||||
ignore (env_set env "*prim-param-types*" v); Nil
|
||||
| _ -> raise (Eval_error "set-prim-param-types!: expected 1 arg"));
|
||||
|
||||
bind "component-param-types" (fun _args -> Nil);
|
||||
bind "component-set-param-types!" (fun _args -> Nil);
|
||||
|
||||
bind "component-params" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> List (List.map (fun s -> String s) c.c_params)
|
||||
| _ -> Nil);
|
||||
|
||||
bind "component-body" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> c.c_body
|
||||
| _ -> Nil);
|
||||
|
||||
bind "component-has-children" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> Bool c.c_has_children
|
||||
| _ -> Bool false);
|
||||
|
||||
bind "component-affinity" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> String c.c_affinity
|
||||
| _ -> String "auto");
|
||||
|
||||
bind "keyword-name" (fun args ->
|
||||
match args with
|
||||
| [Keyword k] -> String k
|
||||
| _ -> raise (Eval_error "keyword-name: expected keyword"));
|
||||
|
||||
bind "symbol-name" (fun args ->
|
||||
match args with
|
||||
| [Symbol s] -> String s
|
||||
| _ -> raise (Eval_error "symbol-name: expected symbol"));
|
||||
|
||||
(* IO primitives *)
|
||||
setup_io_env env;
|
||||
|
||||
env
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Command dispatch *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let dispatch env cmd =
|
||||
match cmd with
|
||||
| List [Symbol "ping"] ->
|
||||
send_ok_string "ocaml-cek"
|
||||
|
||||
| List [Symbol "load"; String path] ->
|
||||
(try
|
||||
let exprs = Sx_parser.parse_file path in
|
||||
let count = ref 0 in
|
||||
List.iter (fun expr ->
|
||||
ignore (Sx_ref.eval_expr expr (Env env));
|
||||
incr count
|
||||
) exprs;
|
||||
send_ok_value (Number (float_of_int !count))
|
||||
with
|
||||
| Eval_error msg -> send_error msg
|
||||
| Sys_error msg -> send_error ("File error: " ^ msg)
|
||||
| exn -> send_error (Printexc.to_string exn))
|
||||
|
||||
| List [Symbol "load-source"; String src] ->
|
||||
(try
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let count = ref 0 in
|
||||
List.iter (fun expr ->
|
||||
ignore (Sx_ref.eval_expr expr (Env env));
|
||||
incr count
|
||||
) exprs;
|
||||
send_ok_value (Number (float_of_int !count))
|
||||
with
|
||||
| Eval_error msg -> send_error msg
|
||||
| exn -> send_error (Printexc.to_string exn))
|
||||
|
||||
| List [Symbol "eval"; String src] ->
|
||||
(try
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let result = List.fold_left (fun _acc expr ->
|
||||
Sx_ref.eval_expr expr (Env env)
|
||||
) Nil exprs in
|
||||
send_ok_value result
|
||||
with
|
||||
| Eval_error msg -> send_error msg
|
||||
| exn -> send_error (Printexc.to_string exn))
|
||||
|
||||
| List [Symbol "render"; String src] ->
|
||||
(try
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let expr = match exprs with
|
||||
| [e] -> e
|
||||
| [] -> Nil
|
||||
| _ -> List (Symbol "do" :: exprs)
|
||||
in
|
||||
let html = Sx_render.render_to_html expr env in
|
||||
send_ok_string html
|
||||
with
|
||||
| Eval_error msg -> send_error msg
|
||||
| exn -> send_error (Printexc.to_string exn))
|
||||
|
||||
| List [Symbol "reset"] ->
|
||||
(* Clear all bindings and rebuild env.
|
||||
We can't reassign env, so clear and re-populate. *)
|
||||
Hashtbl.clear env.bindings;
|
||||
let fresh = make_server_env () in
|
||||
Hashtbl.iter (fun k v -> Hashtbl.replace env.bindings k v) fresh.bindings;
|
||||
send_ok ()
|
||||
|
||||
| _ ->
|
||||
send_error ("Unknown command: " ^ inspect cmd)
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Main loop *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let () =
|
||||
let env = make_server_env () in
|
||||
send "(ready)";
|
||||
(* Main command loop *)
|
||||
try
|
||||
while true do
|
||||
match read_line_blocking () with
|
||||
| None -> exit 0 (* stdin closed *)
|
||||
| Some line ->
|
||||
let line = String.trim line in
|
||||
if line = "" then () (* skip blank lines *)
|
||||
else begin
|
||||
let exprs = Sx_parser.parse_all line in
|
||||
match exprs with
|
||||
| [cmd] -> dispatch env cmd
|
||||
| _ -> send_error ("Expected single command, got " ^ string_of_int (List.length exprs))
|
||||
end
|
||||
done
|
||||
with
|
||||
| End_of_file -> ()
|
||||
373
hosts/ocaml/bootstrap.py
Normal file
373
hosts/ocaml/bootstrap.py
Normal file
@@ -0,0 +1,373 @@
|
||||
#!/usr/bin/env python3
|
||||
"""
|
||||
Bootstrap compiler: SX spec -> OCaml.
|
||||
|
||||
Loads the SX-to-OCaml transpiler (transpiler.sx), feeds it the spec files,
|
||||
and produces sx_ref.ml — the transpiled evaluator as native OCaml.
|
||||
|
||||
Usage:
|
||||
python3 hosts/ocaml/bootstrap.py --output hosts/ocaml/lib/sx_ref.ml
|
||||
"""
|
||||
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
|
||||
|
||||
|
||||
def extract_defines(source: str) -> list[tuple[str, list]]:
|
||||
"""Parse .sx source, return list of (name, define-expr) for top-level defines.
|
||||
Strips :effects [...] annotations from defines."""
|
||||
from shared.sx.types import Keyword
|
||||
exprs = parse_all(source)
|
||||
defines = []
|
||||
for expr in exprs:
|
||||
if isinstance(expr, list) and expr and isinstance(expr[0], Symbol):
|
||||
if expr[0].name == "define":
|
||||
name = expr[1].name if isinstance(expr[1], Symbol) else str(expr[1])
|
||||
# Strip :effects [...] annotation if present
|
||||
# (define name :effects [...] body) → (define name body)
|
||||
cleaned = list(expr)
|
||||
if (len(cleaned) >= 4 and isinstance(cleaned[2], Keyword)
|
||||
and cleaned[2].name == "effects"):
|
||||
cleaned = [cleaned[0], cleaned[1]] + cleaned[4:]
|
||||
defines.append((name, cleaned))
|
||||
return defines
|
||||
|
||||
|
||||
# OCaml preamble — opens and runtime helpers
|
||||
PREAMBLE = """\
|
||||
(* sx_ref.ml — Auto-generated from SX spec by hosts/ocaml/bootstrap.py *)
|
||||
(* Do not edit — regenerate with: python3 hosts/ocaml/bootstrap.py *)
|
||||
|
||||
[@@@warning "-26-27"]
|
||||
|
||||
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 *)
|
||||
|
||||
"""
|
||||
|
||||
|
||||
# OCaml fixups — override iterative CEK run + reactive subscriber fix
|
||||
FIXUPS = """\
|
||||
|
||||
(* Override recursive cek_run with iterative loop *)
|
||||
let cek_run_iterative state =
|
||||
let s = ref state in
|
||||
while not (match cek_terminal_p !s with Bool true -> true | _ -> false) do
|
||||
s := cek_step !s
|
||||
done;
|
||||
cek_value !s
|
||||
|
||||
(* Strict mode refs — used by test runner, stubbed here *)
|
||||
let _strict_ref = ref Nil
|
||||
let _prim_param_types_ref = ref Nil
|
||||
let value_matches_type_p _v _t = Bool true
|
||||
|
||||
(* Override reactive_shift_deref to wrap subscriber as NativeFn.
|
||||
The transpiler emits bare OCaml closures for (fn () ...) but
|
||||
signal_add_sub_b expects SX values. *)
|
||||
let reactive_shift_deref sig' env kont =
|
||||
let scan_result = kont_capture_to_reactive_reset kont in
|
||||
let captured_frames = first scan_result in
|
||||
let reset_frame = nth scan_result (Number 1.0) in
|
||||
let remaining_kont = nth scan_result (Number 2.0) in
|
||||
let update_fn = get reset_frame (String "update-fn") in
|
||||
let sub_disposers = ref (List []) in
|
||||
let subscriber_fn () =
|
||||
List.iter (fun d -> ignore (cek_call d Nil)) (sx_to_list !sub_disposers);
|
||||
sub_disposers := List [];
|
||||
let new_reset = make_reactive_reset_frame env update_fn (Bool false) in
|
||||
let new_kont = prim_call "concat" [captured_frames; List [new_reset]; remaining_kont] in
|
||||
ignore (with_island_scope
|
||||
(fun d -> sub_disposers := sx_append_b !sub_disposers d; Nil)
|
||||
(fun () -> cek_run (make_cek_value (signal_value sig') env new_kont)));
|
||||
Nil
|
||||
in
|
||||
let subscriber = NativeFn ("reactive-subscriber", fun _args -> subscriber_fn ()) in
|
||||
ignore (signal_add_sub_b sig' subscriber);
|
||||
ignore (register_in_scope (fun () ->
|
||||
ignore (signal_remove_sub_b sig' subscriber);
|
||||
List.iter (fun d -> ignore (cek_call d Nil)) (sx_to_list !sub_disposers);
|
||||
Nil));
|
||||
let initial_kont = prim_call "concat" [captured_frames; List [reset_frame]; remaining_kont] in
|
||||
make_cek_value (signal_value sig') env initial_kont
|
||||
|
||||
"""
|
||||
|
||||
|
||||
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
|
||||
|
||||
if spec_dir is None:
|
||||
spec_dir = os.path.join(_PROJECT, "spec")
|
||||
|
||||
# Load the transpiler
|
||||
env = make_env()
|
||||
transpiler_path = os.path.join(_HERE, "transpiler.sx")
|
||||
with open(transpiler_path) as f:
|
||||
transpiler_src = f.read()
|
||||
for expr in sx_parse(transpiler_src):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Spec files to transpile (in dependency order)
|
||||
sx_files = [
|
||||
("evaluator.sx", "evaluator (frames + eval + CEK)"),
|
||||
]
|
||||
|
||||
parts = [PREAMBLE]
|
||||
|
||||
for filename, label in sx_files:
|
||||
filepath = os.path.join(spec_dir, filename)
|
||||
if not os.path.exists(filepath):
|
||||
print(f"Warning: {filepath} not found, skipping", file=sys.stderr)
|
||||
continue
|
||||
|
||||
with open(filepath) as f:
|
||||
src = f.read()
|
||||
defines = extract_defines(src)
|
||||
|
||||
# Skip defines provided by preamble/fixups or that belong in web module
|
||||
skip = {"trampoline",
|
||||
# Freeze functions depend on signals.sx (web spec)
|
||||
"freeze-registry", "freeze-signal", "freeze-scope",
|
||||
"cek-freeze-scope", "cek-freeze-all",
|
||||
"cek-thaw-scope", "cek-thaw-all",
|
||||
"freeze-to-sx", "thaw-from-sx",
|
||||
"freeze-to-cid", "thaw-from-cid",
|
||||
"content-hash", "content-put", "content-get", "content-store"}
|
||||
defines = [(n, e) for n, e in defines if n not in skip]
|
||||
|
||||
# Deduplicate — keep last definition for each name (CEK overrides tree-walk)
|
||||
seen = {}
|
||||
for i, (n, e) in enumerate(defines):
|
||||
seen[n] = i
|
||||
defines = [(n, e) for i, (n, e) in enumerate(defines) if seen[n] == i]
|
||||
|
||||
# Build the defines list for the transpiler
|
||||
defines_list = [[name, expr] for name, expr in defines]
|
||||
env["_defines"] = defines_list
|
||||
|
||||
# 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]
|
||||
|
||||
# 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))
|
||||
|
||||
parts.append(f"\n(* === Transpiled from {label} === *)\n")
|
||||
parts.append(result)
|
||||
|
||||
parts.append(FIXUPS)
|
||||
return "\n".join(parts)
|
||||
|
||||
|
||||
WEB_PREAMBLE = """\
|
||||
(* sx_web.ml — Auto-generated from web adapters by hosts/ocaml/bootstrap.py *)
|
||||
(* Do not edit — regenerate with: python3 hosts/ocaml/bootstrap.py --web *)
|
||||
|
||||
[@@@warning "-26-27"]
|
||||
|
||||
open Sx_types
|
||||
open Sx_runtime
|
||||
|
||||
"""
|
||||
|
||||
# Web adapter files to transpile (dependency order)
|
||||
WEB_ADAPTER_FILES = [
|
||||
("signals.sx", "signals (reactive signal runtime)"),
|
||||
("deps.sx", "deps (component dependency analysis)"),
|
||||
("page-helpers.sx", "page-helpers (pure data transformation helpers)"),
|
||||
("router.sx", "router (client-side route matching)"),
|
||||
("adapter-html.sx", "adapter-html (HTML rendering adapter)"),
|
||||
]
|
||||
|
||||
|
||||
def compile_web_to_ml(web_dir: str | None = None) -> str:
|
||||
"""Compile web adapter SX files to OCaml source."""
|
||||
from shared.sx.ref.sx_ref import eval_expr, trampoline, make_env, sx_parse
|
||||
|
||||
if web_dir is None:
|
||||
web_dir = os.path.join(_PROJECT, "web")
|
||||
|
||||
# Load the transpiler
|
||||
env = make_env()
|
||||
transpiler_path = os.path.join(_HERE, "transpiler.sx")
|
||||
with open(transpiler_path) as f:
|
||||
transpiler_src = f.read()
|
||||
for expr in sx_parse(transpiler_src):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
# Also load the evaluator defines so the transpiler knows about them
|
||||
spec_dir = os.path.join(_PROJECT, "spec")
|
||||
eval_path = os.path.join(spec_dir, "evaluator.sx")
|
||||
if os.path.exists(eval_path):
|
||||
with open(eval_path) as f:
|
||||
eval_defines = extract_defines(f.read())
|
||||
eval_names = [n for n, _ in eval_defines]
|
||||
else:
|
||||
eval_names = []
|
||||
|
||||
parts = [WEB_PREAMBLE]
|
||||
|
||||
# Collect all web adapter defines
|
||||
all_defines = []
|
||||
for filename, label in WEB_ADAPTER_FILES:
|
||||
filepath = os.path.join(web_dir, filename)
|
||||
if not os.path.exists(filepath):
|
||||
print(f"Warning: {filepath} not found, skipping", file=sys.stderr)
|
||||
continue
|
||||
|
||||
with open(filepath) as f:
|
||||
src = f.read()
|
||||
defines = extract_defines(src)
|
||||
|
||||
# Deduplicate within file
|
||||
seen = {}
|
||||
for i, (n, e) in enumerate(defines):
|
||||
seen[n] = i
|
||||
defines = [(n, e) for i, (n, e) in enumerate(defines) if seen[n] == i]
|
||||
|
||||
all_defines.extend(defines)
|
||||
print(f" {filename}: {len(defines)} defines", file=sys.stderr)
|
||||
|
||||
# Deduplicate across files (last wins)
|
||||
seen = {}
|
||||
for i, (n, e) in enumerate(all_defines):
|
||||
seen[n] = i
|
||||
all_defines = [(n, e) for i, (n, e) in enumerate(all_defines) if seen[n] == i]
|
||||
|
||||
print(f" Total: {len(all_defines)} unique defines", file=sys.stderr)
|
||||
|
||||
# Build the defines list for the transpiler
|
||||
defines_list = [[name, expr] for name, expr in all_defines]
|
||||
env["_defines"] = defines_list
|
||||
|
||||
# Known defines = evaluator names + web adapter names
|
||||
env["_known_defines"] = eval_names + [name for name, _ in all_defines]
|
||||
|
||||
# Translate
|
||||
translate_expr = sx_parse("(ml-translate-file _defines)")[0]
|
||||
result = trampoline(eval_expr(translate_expr, env))
|
||||
|
||||
parts.append("\n(* === Transpiled from web adapters === *)\n")
|
||||
parts.append(result)
|
||||
|
||||
# Registration function — extract actual OCaml names from transpiled output
|
||||
# by using the same transpiler mangling.
|
||||
# Ask the transpiler for the mangled name of each define.
|
||||
name_map = {}
|
||||
for name, _ in all_defines:
|
||||
mangle_expr = sx_parse(f'(ml-mangle "{name}")')[0]
|
||||
mangled = trampoline(eval_expr(mangle_expr, env))
|
||||
name_map[name] = mangled
|
||||
|
||||
def count_params(expr):
|
||||
"""Count actual params from a (define name [annotations] (fn (params...) body)) form."""
|
||||
# Find the (fn ...) form — it might be at index 2, 3, or 4 depending on annotations
|
||||
fn_expr = None
|
||||
for i in range(2, min(len(expr), 6)):
|
||||
if (isinstance(expr[i], list) and expr[i] and
|
||||
isinstance(expr[i][0], Symbol) and expr[i][0].name in ("fn", "lambda")):
|
||||
fn_expr = expr[i]
|
||||
break
|
||||
if fn_expr is None:
|
||||
return -1 # not a function
|
||||
params = fn_expr[1] if isinstance(fn_expr[1], list) else []
|
||||
n = 0
|
||||
skip = False
|
||||
for p in params:
|
||||
if skip:
|
||||
skip = False
|
||||
continue
|
||||
if isinstance(p, Symbol) and p.name in ("&key", "&rest"):
|
||||
skip = True
|
||||
continue
|
||||
if isinstance(p, list) and len(p) >= 3: # (name :as type)
|
||||
n += 1
|
||||
elif isinstance(p, Symbol):
|
||||
n += 1
|
||||
return n
|
||||
|
||||
parts.append("\n\n(* Register all web adapter functions into an environment *)\n")
|
||||
parts.append("let register_web_adapters env =\n")
|
||||
for name, expr in all_defines:
|
||||
mangled = name_map[name]
|
||||
n = count_params(expr)
|
||||
if n < 0:
|
||||
# Non-function define (constant)
|
||||
parts.append(f' ignore (Sx_types.env_bind env "{name}" {mangled});\n')
|
||||
elif n == 0:
|
||||
parts.append(f' ignore (Sx_types.env_bind env "{name}" '
|
||||
f'(NativeFn ("{name}", fun _args -> {mangled} Nil)));\n')
|
||||
else:
|
||||
# Generate match with correct arity
|
||||
arg_names = [chr(97 + i) for i in range(n)] # a, b, c, ...
|
||||
pat = "; ".join(arg_names)
|
||||
call = " ".join(arg_names)
|
||||
# Pad with Nil for partial application
|
||||
pad_call = " ".join(arg_names[:1] + ["Nil"] * (n - 1)) if n > 1 else arg_names[0]
|
||||
parts.append(f' ignore (Sx_types.env_bind env "{name}" '
|
||||
f'(NativeFn ("{name}", fun args -> match args with '
|
||||
f'| [{pat}] -> {mangled} {call} '
|
||||
f'| _ -> raise (Eval_error "{name}: expected {n} args"))));\n')
|
||||
parts.append(" ()\n")
|
||||
|
||||
return "\n".join(parts)
|
||||
|
||||
|
||||
def main():
|
||||
import argparse
|
||||
parser = argparse.ArgumentParser(description="Bootstrap SX spec -> OCaml")
|
||||
parser.add_argument(
|
||||
"--output", "-o",
|
||||
default=None,
|
||||
help="Output file (default: stdout)",
|
||||
)
|
||||
parser.add_argument(
|
||||
"--web",
|
||||
action="store_true",
|
||||
help="Compile web adapters instead of evaluator spec",
|
||||
)
|
||||
parser.add_argument(
|
||||
"--web-output",
|
||||
default=None,
|
||||
help="Output file for web adapters (default: stdout)",
|
||||
)
|
||||
args = parser.parse_args()
|
||||
|
||||
if args.web or args.web_output:
|
||||
result = compile_web_to_ml()
|
||||
out = args.web_output or args.output
|
||||
if out:
|
||||
with open(out, "w") as f:
|
||||
f.write(result)
|
||||
size = os.path.getsize(out)
|
||||
print(f"Wrote {out} ({size} bytes)", file=sys.stderr)
|
||||
else:
|
||||
print(result)
|
||||
else:
|
||||
result = compile_spec_to_ml()
|
||||
if args.output:
|
||||
with open(args.output, "w") as f:
|
||||
f.write(result)
|
||||
size = os.path.getsize(args.output)
|
||||
print(f"Wrote {args.output} ({size} bytes)", file=sys.stderr)
|
||||
else:
|
||||
print(result)
|
||||
|
||||
|
||||
if __name__ == "__main__":
|
||||
main()
|
||||
37
hosts/ocaml/browser/build.sh
Executable file
37
hosts/ocaml/browser/build.sh
Executable file
@@ -0,0 +1,37 @@
|
||||
#!/usr/bin/env bash
|
||||
# Build the OCaml SX engine for browser use (WASM + JS fallback).
|
||||
#
|
||||
# Outputs:
|
||||
# _build/default/browser/sx_browser.bc.wasm.js WASM loader
|
||||
# _build/default/browser/sx_browser.bc.wasm.assets/ WASM modules
|
||||
# _build/default/browser/sx_browser.bc.js JS fallback
|
||||
#
|
||||
# Usage:
|
||||
# cd hosts/ocaml && ./browser/build.sh
|
||||
|
||||
set -euo pipefail
|
||||
cd "$(dirname "$0")/.."
|
||||
|
||||
eval $(opam env 2>/dev/null || true)
|
||||
|
||||
echo "=== Building OCaml SX browser engine ==="
|
||||
|
||||
# Build all targets: bytecode, JS, WASM
|
||||
dune build browser/sx_browser.bc.js browser/sx_browser.bc.wasm.js
|
||||
|
||||
echo ""
|
||||
echo "--- Output sizes ---"
|
||||
echo -n "JS (unoptimized): "; ls -lh _build/default/browser/sx_browser.bc.js | awk '{print $5}'
|
||||
echo -n "WASM loader: "; ls -lh _build/default/browser/sx_browser.bc.wasm.js | awk '{print $5}'
|
||||
echo -n "WASM modules: "; du -sh _build/default/browser/sx_browser.bc.wasm.assets/*.wasm | awk '{s+=$1}END{print s"K"}'
|
||||
|
||||
# Optimized JS build
|
||||
js_of_ocaml --opt=3 -o _build/default/browser/sx_browser.opt.js _build/default/browser/sx_browser.bc
|
||||
echo -n "JS (optimized): "; ls -lh _build/default/browser/sx_browser.opt.js | awk '{print $5}'
|
||||
|
||||
echo ""
|
||||
echo "=== Build complete ==="
|
||||
echo ""
|
||||
echo "Test with:"
|
||||
echo " node hosts/ocaml/browser/run_tests_js.js # JS"
|
||||
echo " node --experimental-wasm-imported-strings hosts/ocaml/browser/run_tests_wasm.js # WASM"
|
||||
139
hosts/ocaml/browser/bundle.sh
Executable file
139
hosts/ocaml/browser/bundle.sh
Executable file
@@ -0,0 +1,139 @@
|
||||
#!/usr/bin/env bash
|
||||
# Bundle the WASM engine + platform + web adapters into shared/static/scripts/
|
||||
#
|
||||
# Usage: hosts/ocaml/browser/bundle.sh
|
||||
|
||||
set -euo pipefail
|
||||
cd "$(dirname "$0")/../../.."
|
||||
|
||||
WASM_LOADER="hosts/ocaml/_build/default/browser/sx_browser.bc.wasm.js"
|
||||
WASM_ASSETS="hosts/ocaml/_build/default/browser/sx_browser.bc.wasm.assets"
|
||||
PLATFORM="hosts/ocaml/browser/sx-platform.js"
|
||||
OUT="shared/static/scripts/sx-wasm.js"
|
||||
ASSET_DIR="shared/static/scripts/sx-wasm-assets"
|
||||
|
||||
if [ ! -f "$WASM_LOADER" ]; then
|
||||
echo "Build first: cd hosts/ocaml && eval \$(opam env) && dune build browser/sx_browser.bc.wasm.js"
|
||||
exit 1
|
||||
fi
|
||||
|
||||
# 1. WASM loader (patched asset path)
|
||||
sed 's|"src":"sx_browser.bc.wasm.assets"|"src":"sx-wasm-assets"|' \
|
||||
"$WASM_LOADER" > "$OUT"
|
||||
|
||||
# 2. Platform layer
|
||||
echo "" >> "$OUT"
|
||||
cat "$PLATFORM" >> "$OUT"
|
||||
|
||||
# 3. Embedded web adapters — SX source as JS string constants
|
||||
echo "" >> "$OUT"
|
||||
echo "// =========================================================================" >> "$OUT"
|
||||
echo "// Embedded web adapters (loaded into WASM engine at boot)" >> "$OUT"
|
||||
echo "// =========================================================================" >> "$OUT"
|
||||
echo "globalThis.__sxAdapters = {};" >> "$OUT"
|
||||
|
||||
# Adapters to embed (order matters for dependencies)
|
||||
ADAPTERS="signals deps page-helpers router adapter-html"
|
||||
|
||||
for name in $ADAPTERS; do
|
||||
file="web/${name}.sx"
|
||||
if [ -f "$file" ]; then
|
||||
echo -n "globalThis.__sxAdapters[\"${name}\"] = " >> "$OUT"
|
||||
# Escape the SX source for embedding in a JS string
|
||||
python3 -c "
|
||||
import json, sys
|
||||
with open('$file') as f:
|
||||
print(json.dumps(f.read()) + ';')
|
||||
" >> "$OUT"
|
||||
fi
|
||||
done
|
||||
|
||||
# 4. Boot shim
|
||||
cat >> "$OUT" << 'BOOT'
|
||||
|
||||
// =========================================================================
|
||||
// WASM Boot: load adapters, then process inline <script type="text/sx">
|
||||
// =========================================================================
|
||||
(function() {
|
||||
"use strict";
|
||||
if (typeof document === "undefined") return;
|
||||
|
||||
function sxWasmBoot() {
|
||||
var K = globalThis.SxKernel;
|
||||
if (!K || !globalThis.Sx) { setTimeout(sxWasmBoot, 50); return; }
|
||||
|
||||
console.log("[sx-wasm] booting, engine:", K.engine());
|
||||
|
||||
// Load embedded web adapters
|
||||
var adapters = globalThis.__sxAdapters || {};
|
||||
var adapterOrder = ["signals", "deps", "page-helpers", "router", "adapter-html"];
|
||||
for (var j = 0; j < adapterOrder.length; j++) {
|
||||
var name = adapterOrder[j];
|
||||
if (adapters[name]) {
|
||||
var r = K.loadSource(adapters[name]);
|
||||
if (typeof r === "string" && r.startsWith("Error:")) {
|
||||
console.error("[sx-wasm] adapter " + name + " error:", r);
|
||||
} else {
|
||||
console.log("[sx-wasm] loaded " + name + " (" + r + " defs)");
|
||||
}
|
||||
}
|
||||
}
|
||||
delete globalThis.__sxAdapters; // Free memory
|
||||
|
||||
// Process <script type="text/sx" data-components>
|
||||
var scripts = document.querySelectorAll('script[type="text/sx"]');
|
||||
for (var i = 0; i < scripts.length; i++) {
|
||||
var s = scripts[i], src = s.textContent.trim();
|
||||
if (!src) continue;
|
||||
if (s.hasAttribute("data-components")) {
|
||||
var result = K.loadSource(src);
|
||||
if (typeof result === "string" && result.startsWith("Error:"))
|
||||
console.error("[sx-wasm] component load error:", result);
|
||||
}
|
||||
}
|
||||
|
||||
// Process <script type="text/sx" data-init>
|
||||
for (var i = 0; i < scripts.length; i++) {
|
||||
var s = scripts[i];
|
||||
if (s.hasAttribute("data-init")) {
|
||||
var src = s.textContent.trim();
|
||||
if (src) K.loadSource(src);
|
||||
}
|
||||
}
|
||||
|
||||
// Process <script type="text/sx" data-mount="...">
|
||||
for (var i = 0; i < scripts.length; i++) {
|
||||
var s = scripts[i];
|
||||
if (s.hasAttribute("data-mount")) {
|
||||
var mount = s.getAttribute("data-mount"), src = s.textContent.trim();
|
||||
if (!src) continue;
|
||||
var target = mount === "body" ? document.body : document.querySelector(mount);
|
||||
if (!target) continue;
|
||||
try {
|
||||
var parsed = K.parse(src);
|
||||
if (parsed && parsed.length > 0) {
|
||||
var html = K.renderToHtml(parsed[0]);
|
||||
if (html && typeof html === "string") {
|
||||
target.innerHTML = html;
|
||||
console.log("[sx-wasm] mounted to", mount);
|
||||
}
|
||||
}
|
||||
} catch(e) { console.error("[sx-wasm] mount error:", e); }
|
||||
}
|
||||
}
|
||||
|
||||
console.log("[sx-wasm] boot complete");
|
||||
}
|
||||
|
||||
if (document.readyState === "loading") document.addEventListener("DOMContentLoaded", sxWasmBoot);
|
||||
else sxWasmBoot();
|
||||
})();
|
||||
BOOT
|
||||
|
||||
# 5. Copy WASM assets
|
||||
mkdir -p "$ASSET_DIR"
|
||||
cp "$WASM_ASSETS"/*.wasm "$ASSET_DIR/"
|
||||
|
||||
echo "=== Bundle complete ==="
|
||||
ls -lh "$OUT"
|
||||
echo -n "WASM assets: "; du -sh "$ASSET_DIR" | awk '{print $1}'
|
||||
5
hosts/ocaml/browser/dune
Normal file
5
hosts/ocaml/browser/dune
Normal file
@@ -0,0 +1,5 @@
|
||||
(executable
|
||||
(name sx_browser)
|
||||
(libraries sx js_of_ocaml)
|
||||
(modes byte js wasm)
|
||||
(preprocess (pps js_of_ocaml-ppx)))
|
||||
149
hosts/ocaml/browser/run_tests_js.js
Normal file
149
hosts/ocaml/browser/run_tests_js.js
Normal file
@@ -0,0 +1,149 @@
|
||||
#!/usr/bin/env node
|
||||
/**
|
||||
* Test runner for the js_of_ocaml-compiled SX engine.
|
||||
*
|
||||
* Loads the OCaml CEK machine (compiled to JS) and runs the spec test suite.
|
||||
*
|
||||
* Usage:
|
||||
* node hosts/ocaml/browser/run_tests_js.js # standard tests
|
||||
* node hosts/ocaml/browser/run_tests_js.js --full # full suite
|
||||
*/
|
||||
|
||||
const fs = require("fs");
|
||||
const path = require("path");
|
||||
|
||||
// Load the compiled OCaml engine
|
||||
const enginePath = path.join(__dirname, "../_build/default/browser/sx_browser.bc.js");
|
||||
if (!fs.existsSync(enginePath)) {
|
||||
console.error("Build first: cd hosts/ocaml && eval $(opam env) && dune build browser/sx_browser.bc.js");
|
||||
process.exit(1);
|
||||
}
|
||||
require(enginePath);
|
||||
|
||||
const K = globalThis.SxKernel;
|
||||
const full = process.argv.includes("--full");
|
||||
|
||||
// Test state
|
||||
let passed = 0;
|
||||
let failed = 0;
|
||||
let errors = [];
|
||||
let suiteStack = [];
|
||||
|
||||
function currentSuite() {
|
||||
return suiteStack.length > 0 ? suiteStack.join(" > ") : "";
|
||||
}
|
||||
|
||||
// Register platform test functions
|
||||
K.registerNative("report-pass", (args) => {
|
||||
const name = typeof args[0] === "string" ? args[0] : JSON.stringify(args[0]);
|
||||
passed++;
|
||||
if (process.env.VERBOSE) {
|
||||
console.log(` PASS: ${currentSuite()} > ${name}`);
|
||||
} else {
|
||||
process.stdout.write(".");
|
||||
if (passed % 80 === 0) process.stdout.write("\n");
|
||||
}
|
||||
return null;
|
||||
});
|
||||
|
||||
K.registerNative("report-fail", (args) => {
|
||||
const name = typeof args[0] === "string" ? args[0] : JSON.stringify(args[0]);
|
||||
const error = args.length > 1 && args[1] != null
|
||||
? (typeof args[1] === "string" ? args[1] : JSON.stringify(args[1]))
|
||||
: "unknown";
|
||||
failed++;
|
||||
const fullName = currentSuite() ? `${currentSuite()} > ${name}` : name;
|
||||
errors.push(`FAIL: ${fullName}\n ${error}`);
|
||||
process.stdout.write("F");
|
||||
});
|
||||
|
||||
K.registerNative("push-suite", (args) => {
|
||||
const name = typeof args[0] === "string" ? args[0] : String(args[0]);
|
||||
suiteStack.push(name);
|
||||
return null;
|
||||
});
|
||||
|
||||
K.registerNative("pop-suite", (_args) => {
|
||||
suiteStack.pop();
|
||||
return null;
|
||||
});
|
||||
|
||||
console.log(`=== SX OCaml→JS Engine Test Runner ===`);
|
||||
console.log(`Engine: ${K.engine()}`);
|
||||
console.log(`Mode: ${full ? "full" : "standard"}`);
|
||||
console.log("");
|
||||
|
||||
// Load a .sx file by reading it from disk and evaluating via loadSource
|
||||
function loadFile(filePath) {
|
||||
const src = fs.readFileSync(filePath, "utf8");
|
||||
return K.loadSource(src);
|
||||
}
|
||||
|
||||
// Test files
|
||||
const specDir = path.join(__dirname, "../../../spec");
|
||||
const testDir = path.join(specDir, "tests");
|
||||
|
||||
const standardTests = [
|
||||
"test-framework.sx",
|
||||
"test-eval.sx",
|
||||
"test-parser.sx",
|
||||
"test-primitives.sx",
|
||||
"test-collections.sx",
|
||||
"test-closures.sx",
|
||||
"test-defcomp.sx",
|
||||
"test-macros.sx",
|
||||
"test-errors.sx",
|
||||
"test-render.sx",
|
||||
"test-tco.sx",
|
||||
"test-scope.sx",
|
||||
"test-cek.sx",
|
||||
"test-advanced.sx",
|
||||
];
|
||||
|
||||
const fullOnlyTests = [
|
||||
"test-freeze.sx",
|
||||
"test-continuations.sx",
|
||||
"test-continuations-advanced.sx",
|
||||
"test-cek-advanced.sx",
|
||||
"test-signals-advanced.sx",
|
||||
"test-render-advanced.sx",
|
||||
"test-integration.sx",
|
||||
"test-strict.sx",
|
||||
"test-types.sx",
|
||||
];
|
||||
|
||||
const testFiles = full ? [...standardTests, ...fullOnlyTests] : standardTests;
|
||||
|
||||
for (const file of testFiles) {
|
||||
const filePath = path.join(testDir, file);
|
||||
if (!fs.existsSync(filePath)) {
|
||||
console.log(`\nSkipping ${file} (not found)`);
|
||||
continue;
|
||||
}
|
||||
|
||||
const label = file.replace(".sx", "").replace("test-", "");
|
||||
process.stdout.write(`\n[${label}] `);
|
||||
|
||||
const result = loadFile(filePath);
|
||||
if (typeof result === "string" && result.startsWith("Error:")) {
|
||||
console.log(`\n LOAD ERROR: ${result}`);
|
||||
failed++;
|
||||
errors.push(`LOAD ERROR: ${file}\n ${result}`);
|
||||
}
|
||||
}
|
||||
|
||||
console.log("\n");
|
||||
|
||||
if (errors.length > 0) {
|
||||
console.log(`--- Failures (${errors.length}) ---`);
|
||||
for (const e of errors.slice(0, 20)) {
|
||||
console.log(e);
|
||||
}
|
||||
if (errors.length > 20) {
|
||||
console.log(`... and ${errors.length - 20} more`);
|
||||
}
|
||||
console.log("");
|
||||
}
|
||||
|
||||
console.log(`Results: ${passed} passed, ${failed} failed, ${passed + failed} total`);
|
||||
process.exit(failed > 0 ? 1 : 0);
|
||||
146
hosts/ocaml/browser/run_tests_wasm.js
Normal file
146
hosts/ocaml/browser/run_tests_wasm.js
Normal file
@@ -0,0 +1,146 @@
|
||||
#!/usr/bin/env node
|
||||
/**
|
||||
* Test runner for the wasm_of_ocaml-compiled SX engine.
|
||||
*
|
||||
* Loads the OCaml CEK machine (compiled to WASM) and runs the spec test suite.
|
||||
* Requires Node.js 22+ with --experimental-wasm-imported-strings flag.
|
||||
*
|
||||
* Usage:
|
||||
* node --experimental-wasm-imported-strings hosts/ocaml/browser/run_tests_wasm.js
|
||||
* node --experimental-wasm-imported-strings hosts/ocaml/browser/run_tests_wasm.js --full
|
||||
*/
|
||||
|
||||
const fs = require("fs");
|
||||
const path = require("path");
|
||||
|
||||
const wasmDir = path.join(__dirname, "../_build/default/browser");
|
||||
const loaderPath = path.join(wasmDir, "sx_browser.bc.wasm.js");
|
||||
|
||||
if (!fs.existsSync(loaderPath)) {
|
||||
console.error("Build first: cd hosts/ocaml && eval $(opam env) && dune build browser/sx_browser.bc.wasm.js");
|
||||
process.exit(1);
|
||||
}
|
||||
|
||||
// Set require.main.filename so the WASM loader can find .wasm assets
|
||||
if (!require.main) {
|
||||
require.main = { filename: path.join(wasmDir, "test.js") };
|
||||
} else {
|
||||
require.main.filename = path.join(wasmDir, "test.js");
|
||||
}
|
||||
|
||||
require(loaderPath);
|
||||
|
||||
const full = process.argv.includes("--full");
|
||||
|
||||
// WASM loader is async — wait for SxKernel to be available
|
||||
setTimeout(() => {
|
||||
const K = globalThis.SxKernel;
|
||||
if (!K) {
|
||||
console.error("SxKernel not available — WASM initialization failed");
|
||||
process.exit(1);
|
||||
}
|
||||
|
||||
let passed = 0;
|
||||
let failed = 0;
|
||||
let errors = [];
|
||||
let suiteStack = [];
|
||||
|
||||
function currentSuite() {
|
||||
return suiteStack.length > 0 ? suiteStack.join(" > ") : "";
|
||||
}
|
||||
|
||||
// Register platform test functions
|
||||
K.registerNative("report-pass", (args) => {
|
||||
const name = typeof args[0] === "string" ? args[0] : JSON.stringify(args[0]);
|
||||
passed++;
|
||||
if (process.env.VERBOSE) {
|
||||
console.log(` PASS: ${currentSuite()} > ${name}`);
|
||||
} else {
|
||||
process.stdout.write(".");
|
||||
if (passed % 80 === 0) process.stdout.write("\n");
|
||||
}
|
||||
return null;
|
||||
});
|
||||
|
||||
K.registerNative("report-fail", (args) => {
|
||||
const name = typeof args[0] === "string" ? args[0] : JSON.stringify(args[0]);
|
||||
const error = args.length > 1 && args[1] != null
|
||||
? (typeof args[1] === "string" ? args[1] : JSON.stringify(args[1]))
|
||||
: "unknown";
|
||||
failed++;
|
||||
const fullName = currentSuite() ? `${currentSuite()} > ${name}` : name;
|
||||
errors.push(`FAIL: ${fullName}\n ${error}`);
|
||||
process.stdout.write("F");
|
||||
});
|
||||
|
||||
K.registerNative("push-suite", (args) => {
|
||||
const name = typeof args[0] === "string" ? args[0] : String(args[0]);
|
||||
suiteStack.push(name);
|
||||
return null;
|
||||
});
|
||||
|
||||
K.registerNative("pop-suite", (_args) => {
|
||||
suiteStack.pop();
|
||||
return null;
|
||||
});
|
||||
|
||||
console.log(`=== SX OCaml→WASM Engine Test Runner ===`);
|
||||
console.log(`Engine: ${K.engine()}`);
|
||||
console.log(`Mode: ${full ? "full" : "standard"}`);
|
||||
console.log("");
|
||||
|
||||
const specDir = path.join(__dirname, "../../../spec");
|
||||
const testDir = path.join(specDir, "tests");
|
||||
|
||||
const standardTests = [
|
||||
"test-framework.sx", "test-eval.sx", "test-parser.sx",
|
||||
"test-primitives.sx", "test-collections.sx", "test-closures.sx",
|
||||
"test-defcomp.sx", "test-macros.sx", "test-errors.sx",
|
||||
"test-render.sx", "test-tco.sx", "test-scope.sx",
|
||||
"test-cek.sx", "test-advanced.sx",
|
||||
];
|
||||
|
||||
const fullOnlyTests = [
|
||||
"test-freeze.sx", "test-continuations.sx",
|
||||
"test-continuations-advanced.sx", "test-cek-advanced.sx",
|
||||
"test-signals-advanced.sx", "test-render-advanced.sx",
|
||||
"test-integration.sx", "test-strict.sx", "test-types.sx",
|
||||
];
|
||||
|
||||
const testFiles = full ? [...standardTests, ...fullOnlyTests] : standardTests;
|
||||
|
||||
for (const file of testFiles) {
|
||||
const filePath = path.join(testDir, file);
|
||||
if (!fs.existsSync(filePath)) {
|
||||
console.log(`\nSkipping ${file} (not found)`);
|
||||
continue;
|
||||
}
|
||||
|
||||
const label = file.replace(".sx", "").replace("test-", "");
|
||||
process.stdout.write(`\n[${label}] `);
|
||||
|
||||
const src = fs.readFileSync(filePath, "utf8");
|
||||
const result = K.loadSource(src);
|
||||
if (typeof result === "string" && result.startsWith("Error:")) {
|
||||
console.log(`\n LOAD ERROR: ${result}`);
|
||||
failed++;
|
||||
errors.push(`LOAD ERROR: ${file}\n ${result}`);
|
||||
}
|
||||
}
|
||||
|
||||
console.log("\n");
|
||||
|
||||
if (errors.length > 0) {
|
||||
console.log(`--- Failures (${errors.length}) ---`);
|
||||
for (const e of errors.slice(0, 20)) {
|
||||
console.log(e);
|
||||
}
|
||||
if (errors.length > 20) {
|
||||
console.log(`... and ${errors.length - 20} more`);
|
||||
}
|
||||
console.log("");
|
||||
}
|
||||
|
||||
console.log(`Results: ${passed} passed, ${failed} failed, ${passed + failed} total`);
|
||||
process.exit(failed > 0 ? 1 : 0);
|
||||
}, 1000);
|
||||
676
hosts/ocaml/browser/sx-platform.js
Normal file
676
hosts/ocaml/browser/sx-platform.js
Normal file
@@ -0,0 +1,676 @@
|
||||
/**
|
||||
* sx-platform.js — Thin JS platform layer for the OCaml SX WASM engine.
|
||||
*
|
||||
* This file provides browser-native primitives (DOM, fetch, timers, etc.)
|
||||
* to the WASM-compiled OCaml CEK machine. It:
|
||||
* 1. Loads the WASM module (SxKernel)
|
||||
* 2. Registers ~80 native browser functions via registerNative
|
||||
* 3. Loads web adapters (.sx files) into the engine
|
||||
* 4. Exports the public Sx API
|
||||
*
|
||||
* Both wasm_of_ocaml and js_of_ocaml targets bind to this same layer.
|
||||
*/
|
||||
|
||||
(function(global) {
|
||||
"use strict";
|
||||
|
||||
function initPlatform() {
|
||||
var K = global.SxKernel;
|
||||
if (!K) {
|
||||
// WASM loader is async — wait and retry
|
||||
setTimeout(initPlatform, 20);
|
||||
return;
|
||||
}
|
||||
|
||||
var _hasDom = typeof document !== "undefined";
|
||||
var NIL = null;
|
||||
var SVG_NS = "http://www.w3.org/2000/svg";
|
||||
|
||||
// =========================================================================
|
||||
// Helper: wrap SX lambda for use as JS callback
|
||||
// =========================================================================
|
||||
|
||||
function wrapLambda(fn) {
|
||||
// For now, SX lambdas from registerNative are opaque — we can't call them
|
||||
// directly from JS. They need to go through the engine.
|
||||
// TODO: add callLambda API to SxKernel
|
||||
return fn;
|
||||
}
|
||||
|
||||
// =========================================================================
|
||||
// 1. DOM Creation & Manipulation
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-create-element", function(args) {
|
||||
if (!_hasDom) return NIL;
|
||||
var tag = args[0], ns = args[1];
|
||||
if (ns && ns !== NIL) return document.createElementNS(ns, tag);
|
||||
return document.createElement(tag);
|
||||
});
|
||||
|
||||
K.registerNative("create-text-node", function(args) {
|
||||
return _hasDom ? document.createTextNode(args[0] || "") : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("create-comment", function(args) {
|
||||
return _hasDom ? document.createComment(args[0] || "") : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("create-fragment", function(_args) {
|
||||
return _hasDom ? document.createDocumentFragment() : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-clone", function(args) {
|
||||
var node = args[0];
|
||||
return node && node.cloneNode ? node.cloneNode(true) : node;
|
||||
});
|
||||
|
||||
K.registerNative("dom-parse-html", function(args) {
|
||||
if (!_hasDom) return NIL;
|
||||
var tpl = document.createElement("template");
|
||||
tpl.innerHTML = args[0] || "";
|
||||
return tpl.content;
|
||||
});
|
||||
|
||||
K.registerNative("dom-parse-html-document", function(args) {
|
||||
if (!_hasDom) return NIL;
|
||||
var parser = new DOMParser();
|
||||
return parser.parseFromString(args[0] || "", "text/html");
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 2. DOM Queries
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-query", function(args) {
|
||||
return _hasDom ? document.querySelector(args[0]) || NIL : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-query-all", function(args) {
|
||||
var root = args[0] || (_hasDom ? document : null);
|
||||
if (!root || !root.querySelectorAll) return [];
|
||||
return Array.prototype.slice.call(root.querySelectorAll(args[1] || args[0]));
|
||||
});
|
||||
|
||||
K.registerNative("dom-query-by-id", function(args) {
|
||||
return _hasDom ? document.getElementById(args[0]) || NIL : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-body", function(_args) {
|
||||
return _hasDom ? document.body : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-ensure-element", function(args) {
|
||||
if (!_hasDom) return NIL;
|
||||
var sel = args[0];
|
||||
var el = document.querySelector(sel);
|
||||
if (el) return el;
|
||||
if (sel.charAt(0) === "#") {
|
||||
el = document.createElement("div");
|
||||
el.id = sel.slice(1);
|
||||
document.body.appendChild(el);
|
||||
return el;
|
||||
}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 3. DOM Attributes
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-get-attr", function(args) {
|
||||
var el = args[0], name = args[1];
|
||||
if (!el || !el.getAttribute) return NIL;
|
||||
var v = el.getAttribute(name);
|
||||
return v === null ? NIL : v;
|
||||
});
|
||||
|
||||
K.registerNative("dom-set-attr", function(args) {
|
||||
var el = args[0], name = args[1], val = args[2];
|
||||
if (el && el.setAttribute) el.setAttribute(name, val);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-remove-attr", function(args) {
|
||||
if (args[0] && args[0].removeAttribute) args[0].removeAttribute(args[1]);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-has-attr?", function(args) {
|
||||
return !!(args[0] && args[0].hasAttribute && args[0].hasAttribute(args[1]));
|
||||
});
|
||||
|
||||
K.registerNative("dom-attr-list", function(args) {
|
||||
var el = args[0];
|
||||
if (!el || !el.attributes) return [];
|
||||
var r = [];
|
||||
for (var i = 0; i < el.attributes.length; i++) {
|
||||
r.push([el.attributes[i].name, el.attributes[i].value]);
|
||||
}
|
||||
return r;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 4. DOM Content
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-text-content", function(args) {
|
||||
var el = args[0];
|
||||
return el ? el.textContent || el.nodeValue || "" : "";
|
||||
});
|
||||
|
||||
K.registerNative("dom-set-text-content", function(args) {
|
||||
var el = args[0], s = args[1];
|
||||
if (el) {
|
||||
if (el.nodeType === 3 || el.nodeType === 8) el.nodeValue = s;
|
||||
else el.textContent = s;
|
||||
}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-inner-html", function(args) {
|
||||
return args[0] && args[0].innerHTML != null ? args[0].innerHTML : "";
|
||||
});
|
||||
|
||||
K.registerNative("dom-set-inner-html", function(args) {
|
||||
if (args[0]) args[0].innerHTML = args[1] || "";
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-insert-adjacent-html", function(args) {
|
||||
var el = args[0], pos = args[1], html = args[2];
|
||||
if (el && el.insertAdjacentHTML) el.insertAdjacentHTML(pos, html);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-body-inner-html", function(args) {
|
||||
var doc = args[0];
|
||||
return doc && doc.body ? doc.body.innerHTML : "";
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 5. DOM Structure & Navigation
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-parent", function(args) { return args[0] ? args[0].parentNode || NIL : NIL; });
|
||||
K.registerNative("dom-first-child", function(args) { return args[0] ? args[0].firstChild || NIL : NIL; });
|
||||
K.registerNative("dom-next-sibling", function(args) { return args[0] ? args[0].nextSibling || NIL : NIL; });
|
||||
K.registerNative("dom-id", function(args) { return args[0] && args[0].id ? args[0].id : NIL; });
|
||||
K.registerNative("dom-node-type", function(args) { return args[0] ? args[0].nodeType : 0; });
|
||||
K.registerNative("dom-node-name", function(args) { return args[0] ? args[0].nodeName : ""; });
|
||||
K.registerNative("dom-tag-name", function(args) { return args[0] && args[0].tagName ? args[0].tagName : ""; });
|
||||
|
||||
K.registerNative("dom-child-list", function(args) {
|
||||
var el = args[0];
|
||||
if (!el || !el.childNodes) return [];
|
||||
return Array.prototype.slice.call(el.childNodes);
|
||||
});
|
||||
|
||||
K.registerNative("dom-child-nodes", function(args) {
|
||||
var el = args[0];
|
||||
if (!el || !el.childNodes) return [];
|
||||
return Array.prototype.slice.call(el.childNodes);
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 6. DOM Insertion & Removal
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-append", function(args) {
|
||||
var parent = args[0], child = args[1];
|
||||
if (parent && child) parent.appendChild(child);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-prepend", function(args) {
|
||||
var parent = args[0], child = args[1];
|
||||
if (parent && child) parent.insertBefore(child, parent.firstChild);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-insert-before", function(args) {
|
||||
var parent = args[0], node = args[1], ref = args[2];
|
||||
if (parent && node) parent.insertBefore(node, ref || null);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-insert-after", function(args) {
|
||||
var ref = args[0], node = args[1];
|
||||
if (ref && ref.parentNode && node) {
|
||||
ref.parentNode.insertBefore(node, ref.nextSibling);
|
||||
}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-remove", function(args) {
|
||||
var node = args[0];
|
||||
if (node && node.parentNode) node.parentNode.removeChild(node);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-remove-child", function(args) {
|
||||
var parent = args[0], child = args[1];
|
||||
if (parent && child && child.parentNode === parent) parent.removeChild(child);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-replace-child", function(args) {
|
||||
var parent = args[0], newC = args[1], oldC = args[2];
|
||||
if (parent && newC && oldC) parent.replaceChild(newC, oldC);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-remove-children-after", function(args) {
|
||||
var marker = args[0];
|
||||
if (!marker || !marker.parentNode) return NIL;
|
||||
var parent = marker.parentNode;
|
||||
while (marker.nextSibling) parent.removeChild(marker.nextSibling);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-append-to-head", function(args) {
|
||||
if (_hasDom && args[0]) document.head.appendChild(args[0]);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 7. DOM Type Checks
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-is-fragment?", function(args) { return args[0] ? args[0].nodeType === 11 : false; });
|
||||
K.registerNative("dom-is-child-of?", function(args) { return !!(args[1] && args[0] && args[0].parentNode === args[1]); });
|
||||
K.registerNative("dom-is-active-element?", function(args) { return _hasDom && args[0] === document.activeElement; });
|
||||
K.registerNative("dom-is-input-element?", function(args) {
|
||||
if (!args[0] || !args[0].tagName) return false;
|
||||
var t = args[0].tagName;
|
||||
return t === "INPUT" || t === "TEXTAREA" || t === "SELECT";
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 8. DOM Styles & Classes
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-get-style", function(args) {
|
||||
return args[0] && args[0].style ? args[0].style[args[1]] || "" : "";
|
||||
});
|
||||
|
||||
K.registerNative("dom-set-style", function(args) {
|
||||
if (args[0] && args[0].style) args[0].style[args[1]] = args[2];
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-add-class", function(args) {
|
||||
if (args[0] && args[0].classList) args[0].classList.add(args[1]);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-remove-class", function(args) {
|
||||
if (args[0] && args[0].classList) args[0].classList.remove(args[1]);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-has-class?", function(args) {
|
||||
return !!(args[0] && args[0].classList && args[0].classList.contains(args[1]));
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 9. DOM Properties & Data
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-get-prop", function(args) { return args[0] ? args[0][args[1]] : NIL; });
|
||||
K.registerNative("dom-set-prop", function(args) { if (args[0]) args[0][args[1]] = args[2]; return NIL; });
|
||||
|
||||
K.registerNative("dom-set-data", function(args) {
|
||||
var el = args[0], key = args[1], val = args[2];
|
||||
if (el) { if (!el._sxData) el._sxData = {}; el._sxData[key] = val; }
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-get-data", function(args) {
|
||||
var el = args[0], key = args[1];
|
||||
return (el && el._sxData) ? (el._sxData[key] != null ? el._sxData[key] : NIL) : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("dom-call-method", function(args) {
|
||||
var obj = args[0], method = args[1];
|
||||
var callArgs = args.slice(2);
|
||||
if (obj && typeof obj[method] === "function") {
|
||||
try { return obj[method].apply(obj, callArgs); }
|
||||
catch(e) { return NIL; }
|
||||
}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 10. DOM Events
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("dom-listen", function(args) {
|
||||
var el = args[0], name = args[1], handler = args[2];
|
||||
if (!_hasDom || !el) return function() {};
|
||||
|
||||
// handler is a wrapped SX lambda (JS function with __sx_handle).
|
||||
// Wrap it to:
|
||||
// - Pass the event object as arg (or no args for 0-arity handlers)
|
||||
// - Catch errors from the CEK machine
|
||||
var arity = K.fnArity(handler);
|
||||
var wrapped;
|
||||
if (arity === 0) {
|
||||
wrapped = function(_e) {
|
||||
try { K.callFn(handler, []); }
|
||||
catch(err) { console.error("[sx] event handler error:", name, err); }
|
||||
};
|
||||
} else {
|
||||
wrapped = function(e) {
|
||||
try { K.callFn(handler, [e]); }
|
||||
catch(err) { console.error("[sx] event handler error:", name, err); }
|
||||
};
|
||||
}
|
||||
el.addEventListener(name, wrapped);
|
||||
return function() { el.removeEventListener(name, wrapped); };
|
||||
});
|
||||
|
||||
K.registerNative("dom-dispatch", function(args) {
|
||||
if (!_hasDom || !args[0]) return false;
|
||||
var evt = new CustomEvent(args[1], { bubbles: true, cancelable: true, detail: args[2] || {} });
|
||||
return args[0].dispatchEvent(evt);
|
||||
});
|
||||
|
||||
K.registerNative("event-detail", function(args) {
|
||||
return (args[0] && args[0].detail != null) ? args[0].detail : NIL;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 11. Browser Navigation & History
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("browser-location-href", function(_args) {
|
||||
return typeof location !== "undefined" ? location.href : "";
|
||||
});
|
||||
|
||||
K.registerNative("browser-same-origin?", function(args) {
|
||||
try { return new URL(args[0], location.href).origin === location.origin; }
|
||||
catch (e) { return true; }
|
||||
});
|
||||
|
||||
K.registerNative("browser-push-state", function(args) {
|
||||
if (typeof history !== "undefined") {
|
||||
try { history.pushState({ sxUrl: args[0], scrollY: typeof window !== "undefined" ? window.scrollY : 0 }, "", args[0]); }
|
||||
catch (e) {}
|
||||
}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("browser-replace-state", function(args) {
|
||||
if (typeof history !== "undefined") {
|
||||
try { history.replaceState({ sxUrl: args[0], scrollY: typeof window !== "undefined" ? window.scrollY : 0 }, "", args[0]); }
|
||||
catch (e) {}
|
||||
}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("browser-navigate", function(args) {
|
||||
if (typeof location !== "undefined") location.assign(args[0]);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("browser-reload", function(_args) {
|
||||
if (typeof location !== "undefined") location.reload();
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("browser-scroll-to", function(args) {
|
||||
if (typeof window !== "undefined") window.scrollTo(args[0] || 0, args[1] || 0);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("browser-media-matches?", function(args) {
|
||||
if (typeof window === "undefined") return false;
|
||||
return window.matchMedia(args[0]).matches;
|
||||
});
|
||||
|
||||
K.registerNative("browser-confirm", function(args) {
|
||||
if (typeof window === "undefined") return false;
|
||||
return window.confirm(args[0]);
|
||||
});
|
||||
|
||||
K.registerNative("browser-prompt", function(args) {
|
||||
if (typeof window === "undefined") return NIL;
|
||||
var r = window.prompt(args[0]);
|
||||
return r === null ? NIL : r;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 12. Timers
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("set-timeout", function(args) {
|
||||
var fn = args[0], ms = args[1] || 0;
|
||||
var cb = (typeof fn === "function" && fn.__sx_handle != null)
|
||||
? function() { try { K.callFn(fn, []); } catch(e) { console.error("[sx] timeout error:", e); } }
|
||||
: fn;
|
||||
return setTimeout(cb, ms);
|
||||
});
|
||||
|
||||
K.registerNative("set-interval", function(args) {
|
||||
var fn = args[0], ms = args[1] || 1000;
|
||||
var cb = (typeof fn === "function" && fn.__sx_handle != null)
|
||||
? function() { try { K.callFn(fn, []); } catch(e) { console.error("[sx] interval error:", e); } }
|
||||
: fn;
|
||||
return setInterval(cb, ms);
|
||||
});
|
||||
|
||||
K.registerNative("clear-timeout", function(args) { clearTimeout(args[0]); return NIL; });
|
||||
K.registerNative("clear-interval", function(args) { clearInterval(args[0]); return NIL; });
|
||||
K.registerNative("now-ms", function(_args) {
|
||||
return (typeof performance !== "undefined") ? performance.now() : Date.now();
|
||||
});
|
||||
|
||||
K.registerNative("request-animation-frame", function(args) {
|
||||
var fn = args[0];
|
||||
var cb = (typeof fn === "function" && fn.__sx_handle != null)
|
||||
? function() { try { K.callFn(fn, []); } catch(e) { console.error("[sx] raf error:", e); } }
|
||||
: fn;
|
||||
if (typeof requestAnimationFrame !== "undefined") requestAnimationFrame(cb);
|
||||
else setTimeout(cb, 16);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 13. Promises
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("promise-resolve", function(args) { return Promise.resolve(args[0]); });
|
||||
|
||||
K.registerNative("promise-then", function(args) {
|
||||
var p = args[0];
|
||||
if (!p || !p.then) return p;
|
||||
var onResolve = function(v) { return K.callFn(args[1], [v]); };
|
||||
var onReject = args[2] ? function(e) { return K.callFn(args[2], [e]); } : undefined;
|
||||
return onReject ? p.then(onResolve, onReject) : p.then(onResolve);
|
||||
});
|
||||
|
||||
K.registerNative("promise-catch", function(args) {
|
||||
if (!args[0] || !args[0].catch) return args[0];
|
||||
return args[0].catch(function(e) { return K.callFn(args[1], [e]); });
|
||||
});
|
||||
|
||||
K.registerNative("promise-delayed", function(args) {
|
||||
return new Promise(function(resolve) {
|
||||
setTimeout(function() { resolve(args[1]); }, args[0]);
|
||||
});
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 14. Abort Controllers
|
||||
// =========================================================================
|
||||
|
||||
var _controllers = typeof WeakMap !== "undefined" ? new WeakMap() : null;
|
||||
var _targetControllers = typeof WeakMap !== "undefined" ? new WeakMap() : null;
|
||||
|
||||
K.registerNative("new-abort-controller", function(_args) {
|
||||
return typeof AbortController !== "undefined" ? new AbortController() : { signal: null, abort: function() {} };
|
||||
});
|
||||
|
||||
K.registerNative("abort-previous", function(args) {
|
||||
if (_controllers) { var prev = _controllers.get(args[0]); if (prev) prev.abort(); }
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("track-controller", function(args) {
|
||||
if (_controllers) _controllers.set(args[0], args[1]);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("abort-previous-target", function(args) {
|
||||
if (_targetControllers) { var prev = _targetControllers.get(args[0]); if (prev) prev.abort(); }
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("track-controller-target", function(args) {
|
||||
if (_targetControllers) _targetControllers.set(args[0], args[1]);
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("controller-signal", function(args) { return args[0] ? args[0].signal : NIL; });
|
||||
K.registerNative("is-abort-error", function(args) { return args[0] && args[0].name === "AbortError"; });
|
||||
|
||||
// =========================================================================
|
||||
// 15. Fetch
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("fetch-request", function(args) {
|
||||
var config = args[0], successFn = args[1], errorFn = args[2];
|
||||
var opts = { method: config.method, headers: config.headers };
|
||||
if (config.signal) opts.signal = config.signal;
|
||||
if (config.body && config.method !== "GET") opts.body = config.body;
|
||||
if (config["cross-origin"]) opts.credentials = "include";
|
||||
|
||||
return fetch(config.url, opts).then(function(resp) {
|
||||
return resp.text().then(function(text) {
|
||||
var getHeader = function(name) {
|
||||
var v = resp.headers.get(name);
|
||||
return v === null ? NIL : v;
|
||||
};
|
||||
return K.callFn(successFn, [resp.ok, resp.status, getHeader, text]);
|
||||
});
|
||||
}).catch(function(err) {
|
||||
return K.callFn(errorFn, [err]);
|
||||
});
|
||||
});
|
||||
|
||||
K.registerNative("csrf-token", function(_args) {
|
||||
if (!_hasDom) return NIL;
|
||||
var m = document.querySelector('meta[name="csrf-token"]');
|
||||
return m ? m.getAttribute("content") : NIL;
|
||||
});
|
||||
|
||||
K.registerNative("is-cross-origin", function(args) {
|
||||
try {
|
||||
var h = new URL(args[0], location.href).hostname;
|
||||
return h !== location.hostname &&
|
||||
(h.indexOf(".rose-ash.com") >= 0 || h.indexOf(".localhost") >= 0);
|
||||
} catch (e) { return false; }
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 16. localStorage
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("local-storage-get", function(args) {
|
||||
try { var v = localStorage.getItem(args[0]); return v === null ? NIL : v; }
|
||||
catch(e) { return NIL; }
|
||||
});
|
||||
|
||||
K.registerNative("local-storage-set", function(args) {
|
||||
try { localStorage.setItem(args[0], args[1]); } catch(e) {}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("local-storage-remove", function(args) {
|
||||
try { localStorage.removeItem(args[0]); } catch(e) {}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 17. Document Head & Title
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("set-document-title", function(args) {
|
||||
if (_hasDom) document.title = args[0] || "";
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("remove-head-element", function(args) {
|
||||
if (_hasDom) {
|
||||
var el = document.head.querySelector(args[0]);
|
||||
if (el) el.remove();
|
||||
}
|
||||
return NIL;
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 18. Logging
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("log-info", function(args) { console.log("[sx]", args[0]); return NIL; });
|
||||
K.registerNative("log-warn", function(args) { console.warn("[sx]", args[0]); return NIL; });
|
||||
K.registerNative("log-error", function(args) { console.error("[sx]", args[0]); return NIL; });
|
||||
|
||||
// =========================================================================
|
||||
// 19. JSON
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("json-parse", function(args) {
|
||||
try { return JSON.parse(args[0]); } catch(e) { return {}; }
|
||||
});
|
||||
|
||||
K.registerNative("try-parse-json", function(args) {
|
||||
try { return JSON.parse(args[0]); } catch(e) { return NIL; }
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// 20. Processing markers
|
||||
// =========================================================================
|
||||
|
||||
K.registerNative("mark-processed!", function(args) {
|
||||
var el = args[0], key = args[1] || "sx";
|
||||
if (el) { if (!el._sxProcessed) el._sxProcessed = {}; el._sxProcessed[key] = true; }
|
||||
return NIL;
|
||||
});
|
||||
|
||||
K.registerNative("is-processed?", function(args) {
|
||||
var el = args[0], key = args[1] || "sx";
|
||||
return !!(el && el._sxProcessed && el._sxProcessed[key]);
|
||||
});
|
||||
|
||||
// =========================================================================
|
||||
// Public Sx API (wraps SxKernel for compatibility with existing code)
|
||||
// =========================================================================
|
||||
|
||||
var Sx = {
|
||||
// Core (delegated to WASM engine)
|
||||
parse: K.parse,
|
||||
eval: K.eval,
|
||||
evalExpr: K.evalExpr,
|
||||
load: K.load,
|
||||
loadSource: K.loadSource,
|
||||
renderToHtml: K.renderToHtml,
|
||||
typeOf: K.typeOf,
|
||||
inspect: K.inspect,
|
||||
engine: K.engine,
|
||||
|
||||
// Will be populated after web adapters load:
|
||||
// mount, hydrate, processElements, etc.
|
||||
};
|
||||
|
||||
global.Sx = Sx;
|
||||
global.SxKernel = K; // Keep kernel available for direct access
|
||||
|
||||
console.log("[sx-platform] registered, engine:", K.engine());
|
||||
|
||||
} // end initPlatform
|
||||
|
||||
initPlatform();
|
||||
|
||||
})(typeof globalThis !== "undefined" ? globalThis : this);
|
||||
946
hosts/ocaml/browser/sx_browser.ml
Normal file
946
hosts/ocaml/browser/sx_browser.ml
Normal file
@@ -0,0 +1,946 @@
|
||||
(** sx_browser.ml — OCaml SX engine compiled to WASM/JS for browser use.
|
||||
|
||||
Exposes the CEK machine, parser, and primitives as a global [Sx] object
|
||||
that the thin JS platform layer binds to. *)
|
||||
|
||||
open Js_of_ocaml
|
||||
open Sx_types
|
||||
|
||||
(* ================================================================== *)
|
||||
(* Value conversion: OCaml <-> JS *)
|
||||
(* ================================================================== *)
|
||||
|
||||
(* ------------------------------------------------------------------ *)
|
||||
(* Opaque value handle table *)
|
||||
(* *)
|
||||
(* Non-primitive SX values (lambdas, components, signals, etc.) are *)
|
||||
(* stored in a handle table and represented on the JS side as objects *)
|
||||
(* with an __sx_handle integer key. This preserves identity across *)
|
||||
(* the JS↔OCaml boundary — the same handle always resolves to the *)
|
||||
(* same OCaml value. *)
|
||||
(* *)
|
||||
(* Callable values (Lambda, NativeFn, Continuation) are additionally *)
|
||||
(* wrapped as JS functions so they can be used directly as event *)
|
||||
(* listeners, setTimeout callbacks, etc. *)
|
||||
(* ------------------------------------------------------------------ *)
|
||||
|
||||
let _next_handle = ref 0
|
||||
let _handle_table : (int, value) Hashtbl.t = Hashtbl.create 256
|
||||
|
||||
(** Store a value in the handle table, return its handle id. *)
|
||||
let alloc_handle (v : value) : int =
|
||||
let id = !_next_handle in
|
||||
incr _next_handle;
|
||||
Hashtbl.replace _handle_table id v;
|
||||
id
|
||||
|
||||
(** Look up a value by handle. *)
|
||||
let get_handle (id : int) : value =
|
||||
match Hashtbl.find_opt _handle_table id with
|
||||
| Some v -> v
|
||||
| None -> raise (Eval_error (Printf.sprintf "Invalid SX handle: %d" id))
|
||||
|
||||
(** Late-bound reference to global env (set after global_env is created). *)
|
||||
let _global_env_ref : env option ref = ref None
|
||||
let get_global_env () = match !_global_env_ref with
|
||||
| Some e -> e | None -> raise (Eval_error "Global env not initialized")
|
||||
|
||||
(** Call an SX callable through the CEK machine.
|
||||
Constructs (fn arg1 arg2 ...) and evaluates it. *)
|
||||
let call_sx_fn (fn : value) (args : value list) : value =
|
||||
Sx_ref.eval_expr (List (fn :: args)) (Env (get_global_env ()))
|
||||
|
||||
(** Convert an OCaml SX value to a JS representation.
|
||||
Primitive types map directly.
|
||||
Callable values become JS functions (with __sx_handle).
|
||||
Other compound types become tagged objects (with __sx_handle). *)
|
||||
let rec value_to_js (v : value) : Js.Unsafe.any =
|
||||
match v with
|
||||
| Nil -> Js.Unsafe.inject Js.null
|
||||
| Bool b -> Js.Unsafe.inject (Js.bool b)
|
||||
| Number n -> Js.Unsafe.inject (Js.number_of_float n)
|
||||
| String s -> Js.Unsafe.inject (Js.string s)
|
||||
| Symbol s ->
|
||||
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string "symbol"));
|
||||
("name", Js.Unsafe.inject (Js.string s)) |] in
|
||||
Js.Unsafe.inject obj
|
||||
| Keyword k ->
|
||||
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string "keyword"));
|
||||
("name", Js.Unsafe.inject (Js.string k)) |] in
|
||||
Js.Unsafe.inject obj
|
||||
| List items ->
|
||||
let arr = items |> List.map value_to_js |> Array.of_list in
|
||||
let js_arr = Js.array arr in
|
||||
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string "list"));
|
||||
("items", Js.Unsafe.inject js_arr) |] in
|
||||
Js.Unsafe.inject obj
|
||||
| ListRef r ->
|
||||
let arr = !r |> List.map value_to_js |> Array.of_list in
|
||||
let js_arr = Js.array arr in
|
||||
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string "list"));
|
||||
("items", Js.Unsafe.inject js_arr) |] in
|
||||
Js.Unsafe.inject obj
|
||||
| Dict d ->
|
||||
let obj = Js.Unsafe.obj [||] in
|
||||
Js.Unsafe.set obj (Js.string "_type") (Js.string "dict");
|
||||
Hashtbl.iter (fun k v ->
|
||||
Js.Unsafe.set obj (Js.string k) (value_to_js v)
|
||||
) d;
|
||||
Js.Unsafe.inject obj
|
||||
| RawHTML s -> Js.Unsafe.inject (Js.string s)
|
||||
(* Callable values: wrap as JS functions *)
|
||||
| Lambda _ | NativeFn _ | Continuation _ ->
|
||||
let handle = alloc_handle v in
|
||||
(* Create a JS function that calls back into the CEK machine.
|
||||
Use _tagFn helper (registered on globalThis) to create a function
|
||||
with __sx_handle and _type properties that survive js_of_ocaml
|
||||
return-value wrapping. *)
|
||||
let inner = Js.wrap_callback (fun args_js ->
|
||||
try
|
||||
let arg = js_to_value args_js in
|
||||
let args = match arg with Nil -> [] | _ -> [arg] in
|
||||
let result = call_sx_fn v args in
|
||||
value_to_js result
|
||||
with Eval_error msg ->
|
||||
ignore (Js.Unsafe.meth_call (Js.Unsafe.get Js.Unsafe.global (Js.string "console"))
|
||||
"error" [| Js.Unsafe.inject (Js.string (Printf.sprintf "[sx] callback error: %s" msg)) |]);
|
||||
Js.Unsafe.inject Js.null
|
||||
) in
|
||||
let tag_fn = Js.Unsafe.get Js.Unsafe.global (Js.string "__sxTagFn") in
|
||||
Js.Unsafe.fun_call tag_fn [|
|
||||
Js.Unsafe.inject inner;
|
||||
Js.Unsafe.inject handle;
|
||||
Js.Unsafe.inject (Js.string (type_of v))
|
||||
|]
|
||||
(* Non-callable compound values: tagged objects with handle *)
|
||||
| Component c ->
|
||||
let handle = alloc_handle v in
|
||||
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string "component"));
|
||||
("name", Js.Unsafe.inject (Js.string c.c_name));
|
||||
("__sx_handle", Js.Unsafe.inject handle) |] in
|
||||
Js.Unsafe.inject obj
|
||||
| Island i ->
|
||||
let handle = alloc_handle v in
|
||||
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string "island"));
|
||||
("name", Js.Unsafe.inject (Js.string i.i_name));
|
||||
("__sx_handle", Js.Unsafe.inject handle) |] in
|
||||
Js.Unsafe.inject obj
|
||||
| Signal _ ->
|
||||
let handle = alloc_handle v in
|
||||
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string "signal"));
|
||||
("__sx_handle", Js.Unsafe.inject handle) |] in
|
||||
Js.Unsafe.inject obj
|
||||
| _ ->
|
||||
let handle = alloc_handle v in
|
||||
let obj = Js.Unsafe.obj [| ("_type", Js.Unsafe.inject (Js.string (type_of v)));
|
||||
("__sx_handle", Js.Unsafe.inject handle) |] in
|
||||
Js.Unsafe.inject obj
|
||||
|
||||
(** Convert a JS value back to an OCaml SX value. *)
|
||||
and js_to_value (js : Js.Unsafe.any) : value =
|
||||
(* Check null/undefined *)
|
||||
if Js.Unsafe.equals js Js.null || Js.Unsafe.equals js Js.undefined then
|
||||
Nil
|
||||
else
|
||||
let ty = Js.to_string (Js.typeof js) in
|
||||
match ty with
|
||||
| "number" ->
|
||||
Number (Js.float_of_number (Js.Unsafe.coerce js))
|
||||
| "boolean" ->
|
||||
Bool (Js.to_bool (Js.Unsafe.coerce js))
|
||||
| "string" ->
|
||||
String (Js.to_string (Js.Unsafe.coerce js))
|
||||
| "function" ->
|
||||
(* Check for __sx_handle — this is a wrapped SX callable *)
|
||||
let handle_field = Js.Unsafe.get js (Js.string "__sx_handle") in
|
||||
if not (Js.Unsafe.equals handle_field Js.undefined) then
|
||||
let id = Js.float_of_number (Js.Unsafe.coerce handle_field) |> int_of_float in
|
||||
get_handle id
|
||||
else
|
||||
(* Plain JS function — wrap as NativeFn *)
|
||||
NativeFn ("js-callback", fun args ->
|
||||
let js_args = args |> List.map value_to_js |> Array.of_list in
|
||||
let result = Js.Unsafe.fun_call js
|
||||
(Array.map (fun a -> a) js_args) in
|
||||
js_to_value result)
|
||||
| "object" ->
|
||||
(* Check for __sx_handle — this is a wrapped SX value *)
|
||||
let handle_field = Js.Unsafe.get js (Js.string "__sx_handle") in
|
||||
if not (Js.Unsafe.equals handle_field Js.undefined) then begin
|
||||
let id = Js.float_of_number (Js.Unsafe.coerce handle_field) |> int_of_float in
|
||||
get_handle id
|
||||
end else begin
|
||||
(* Check for _type tag *)
|
||||
let type_field = Js.Unsafe.get js (Js.string "_type") in
|
||||
if Js.Unsafe.equals type_field Js.undefined then begin
|
||||
(* Check if it's an array *)
|
||||
let is_arr = Js.to_bool (Js.Unsafe.global##._Array##isArray js) in
|
||||
if is_arr then begin
|
||||
let len_js = Js.Unsafe.get js (Js.string "length") in
|
||||
let n = Js.float_of_number (Js.Unsafe.coerce len_js) |> int_of_float in
|
||||
let items = List.init n (fun i ->
|
||||
js_to_value (Js.array_get (Js.Unsafe.coerce js) i
|
||||
|> Js.Optdef.to_option |> Option.get)
|
||||
) in
|
||||
List items
|
||||
end else begin
|
||||
(* Plain JS object — convert to dict *)
|
||||
let d = Hashtbl.create 8 in
|
||||
let keys = Js.Unsafe.global##._Object##keys js in
|
||||
let len = keys##.length in
|
||||
for i = 0 to len - 1 do
|
||||
let k = Js.to_string (Js.array_get keys i |> Js.Optdef.to_option |> Option.get) in
|
||||
let v = Js.Unsafe.get js (Js.string k) in
|
||||
Hashtbl.replace d k (js_to_value v)
|
||||
done;
|
||||
Dict d
|
||||
end
|
||||
end else begin
|
||||
let tag = Js.to_string (Js.Unsafe.coerce type_field) in
|
||||
match tag with
|
||||
| "symbol" ->
|
||||
Symbol (Js.to_string (Js.Unsafe.get js (Js.string "name")))
|
||||
| "keyword" ->
|
||||
Keyword (Js.to_string (Js.Unsafe.get js (Js.string "name")))
|
||||
| "list" ->
|
||||
let items_js = Js.Unsafe.get js (Js.string "items") in
|
||||
let len = Js.Unsafe.get items_js (Js.string "length") in
|
||||
let n = Js.float_of_number (Js.Unsafe.coerce len) |> int_of_float in
|
||||
let items = List.init n (fun i ->
|
||||
js_to_value (Js.array_get (Js.Unsafe.coerce items_js) i
|
||||
|> Js.Optdef.to_option |> Option.get)
|
||||
) in
|
||||
List items
|
||||
| "dict" ->
|
||||
let d = Hashtbl.create 8 in
|
||||
let keys = Js.Unsafe.global##._Object##keys js in
|
||||
let len = keys##.length in
|
||||
for i = 0 to len - 1 do
|
||||
let k = Js.to_string (Js.array_get keys i |> Js.Optdef.to_option |> Option.get) in
|
||||
if k <> "_type" then begin
|
||||
let v = Js.Unsafe.get js (Js.string k) in
|
||||
Hashtbl.replace d k (js_to_value v)
|
||||
end
|
||||
done;
|
||||
Dict d
|
||||
| _ -> Nil
|
||||
end
|
||||
end
|
||||
| _ -> Nil
|
||||
|
||||
(* ================================================================== *)
|
||||
(* Global environment *)
|
||||
(* ================================================================== *)
|
||||
|
||||
let global_env = make_env ()
|
||||
let () = _global_env_ref := Some global_env
|
||||
|
||||
(* Render mode flag — set true during renderToHtml/loadSource calls
|
||||
that should dispatch HTML tags to the renderer. *)
|
||||
let _sx_render_mode = ref false
|
||||
|
||||
(* Register JS helpers.
|
||||
__sxTagFn: tag a function with __sx_handle and _type properties.
|
||||
__sxR: side-channel for return values (bypasses Js.wrap_callback
|
||||
which strips custom properties from function objects). *)
|
||||
let () =
|
||||
let tag_fn = Js.Unsafe.pure_js_expr
|
||||
"(function(fn, handle, type) { fn.__sx_handle = handle; fn._type = type; return fn; })" in
|
||||
Js.Unsafe.set Js.Unsafe.global (Js.string "__sxTagFn") tag_fn
|
||||
|
||||
(** Store a value in the side-channel and return a sentinel.
|
||||
The JS wrapper picks up __sxR instead of the return value. *)
|
||||
let return_via_side_channel (v : Js.Unsafe.any) : Js.Unsafe.any =
|
||||
Js.Unsafe.set Js.Unsafe.global (Js.string "__sxR") v;
|
||||
v
|
||||
|
||||
(* ================================================================== *)
|
||||
(* Core API functions *)
|
||||
(* ================================================================== *)
|
||||
|
||||
(** Parse SX source string into a list of values. *)
|
||||
let api_parse src_js =
|
||||
let src = Js.to_string src_js in
|
||||
try
|
||||
let values = Sx_parser.parse_all src in
|
||||
let arr = values |> List.map value_to_js |> Array.of_list in
|
||||
Js.Unsafe.inject (Js.array arr)
|
||||
with Parse_error msg ->
|
||||
Js.Unsafe.inject (Js.string ("Parse error: " ^ msg))
|
||||
|
||||
(** Serialize an SX value to source text. *)
|
||||
let api_stringify v_js =
|
||||
let v = js_to_value v_js in
|
||||
Js.Unsafe.inject (Js.string (inspect v))
|
||||
|
||||
(** Evaluate a single SX expression in the global environment. *)
|
||||
let api_eval_expr expr_js env_js =
|
||||
let expr = js_to_value expr_js in
|
||||
let _env = if Js.Unsafe.equals env_js Js.undefined then global_env
|
||||
else global_env in
|
||||
try
|
||||
let result = Sx_ref.eval_expr expr (Env _env) in
|
||||
return_via_side_channel (value_to_js result)
|
||||
with Eval_error msg ->
|
||||
Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
||||
|
||||
(** Evaluate SX source string and return the last result. *)
|
||||
let api_eval src_js =
|
||||
let src = Js.to_string src_js in
|
||||
try
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let env = Env global_env in
|
||||
let result = List.fold_left (fun _acc expr ->
|
||||
Sx_ref.eval_expr expr env
|
||||
) Nil exprs in
|
||||
return_via_side_channel (value_to_js result)
|
||||
with
|
||||
| Eval_error msg -> Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
||||
| Parse_error msg -> Js.Unsafe.inject (Js.string ("Parse error: " ^ msg))
|
||||
|
||||
(** Run the CEK machine on an expression, return result. *)
|
||||
let api_cek_run expr_js =
|
||||
let expr = js_to_value expr_js in
|
||||
try
|
||||
let state = Sx_ref.make_cek_state expr (Env global_env) Nil in
|
||||
let result = Sx_ref.cek_run_iterative state in
|
||||
return_via_side_channel (value_to_js result)
|
||||
with Eval_error msg ->
|
||||
Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
||||
|
||||
(** Render SX expression to HTML string. *)
|
||||
let api_render_to_html expr_js =
|
||||
let expr = js_to_value expr_js in
|
||||
let prev = !_sx_render_mode in
|
||||
_sx_render_mode := true;
|
||||
try
|
||||
let html = Sx_render.render_to_html expr global_env in
|
||||
_sx_render_mode := prev;
|
||||
Js.Unsafe.inject (Js.string html)
|
||||
with Eval_error msg ->
|
||||
_sx_render_mode := prev;
|
||||
Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
||||
|
||||
(** Load SX source for side effects (define, defcomp, defmacro). *)
|
||||
let api_load src_js =
|
||||
let src = Js.to_string src_js in
|
||||
try
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let env = Env global_env in
|
||||
let count = ref 0 in
|
||||
List.iter (fun expr ->
|
||||
ignore (Sx_ref.eval_expr expr env);
|
||||
incr count
|
||||
) exprs;
|
||||
Js.Unsafe.inject !count
|
||||
with
|
||||
| Eval_error msg -> Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
||||
| Parse_error msg -> Js.Unsafe.inject (Js.string ("Parse error: " ^ msg))
|
||||
|
||||
(** Get the type of an SX value. *)
|
||||
let api_type_of v_js =
|
||||
let v = js_to_value v_js in
|
||||
Js.Unsafe.inject (Js.string (type_of v))
|
||||
|
||||
(** Inspect an SX value (debug string). *)
|
||||
let api_inspect v_js =
|
||||
let v = js_to_value v_js in
|
||||
Js.Unsafe.inject (Js.string (inspect v))
|
||||
|
||||
(** Get engine identity. *)
|
||||
let api_engine () =
|
||||
Js.Unsafe.inject (Js.string "ocaml-cek-wasm")
|
||||
|
||||
(** Register a JS callback as a named native function in the global env.
|
||||
JS callback receives JS-converted args and should return a JS value. *)
|
||||
let api_register_native name_js callback_js =
|
||||
let name = Js.to_string name_js in
|
||||
let native_fn args =
|
||||
let js_args = args |> List.map value_to_js |> Array.of_list in
|
||||
let result = Js.Unsafe.fun_call callback_js
|
||||
[| Js.Unsafe.inject (Js.array js_args) |] in
|
||||
js_to_value result
|
||||
in
|
||||
ignore (env_bind global_env name (NativeFn (name, native_fn)));
|
||||
Js.Unsafe.inject Js.null
|
||||
|
||||
(** Call an SX callable (lambda, native fn) with JS args.
|
||||
fn_js can be a wrapped SX callable (with __sx_handle) or a JS value.
|
||||
args_js is a JS array of arguments. *)
|
||||
let api_call_fn fn_js args_js =
|
||||
try
|
||||
let fn = js_to_value fn_js in
|
||||
let args_arr = Js.to_array (Js.Unsafe.coerce args_js) in
|
||||
let args = Array.to_list (Array.map js_to_value args_arr) in
|
||||
let result = call_sx_fn fn args in
|
||||
return_via_side_channel (value_to_js result)
|
||||
with
|
||||
| Eval_error msg ->
|
||||
ignore (Js.Unsafe.meth_call (Js.Unsafe.get Js.Unsafe.global (Js.string "console"))
|
||||
"error" [| Js.Unsafe.inject (Js.string (Printf.sprintf "[sx] callFn error: %s" msg)) |]);
|
||||
Js.Unsafe.inject Js.null
|
||||
| exn ->
|
||||
ignore (Js.Unsafe.meth_call (Js.Unsafe.get Js.Unsafe.global (Js.string "console"))
|
||||
"error" [| Js.Unsafe.inject (Js.string (Printf.sprintf "[sx] callFn error: %s" (Printexc.to_string exn))) |]);
|
||||
Js.Unsafe.inject Js.null
|
||||
|
||||
(** Check if a JS value is a wrapped SX callable. *)
|
||||
let api_is_callable fn_js =
|
||||
if Js.Unsafe.equals fn_js Js.null || Js.Unsafe.equals fn_js Js.undefined then
|
||||
Js.Unsafe.inject (Js.bool false)
|
||||
else
|
||||
let handle_field = Js.Unsafe.get fn_js (Js.string "__sx_handle") in
|
||||
if not (Js.Unsafe.equals handle_field Js.undefined) then begin
|
||||
let id = Js.float_of_number (Js.Unsafe.coerce handle_field) |> int_of_float in
|
||||
let v = get_handle id in
|
||||
Js.Unsafe.inject (Js.bool (is_callable v))
|
||||
end else
|
||||
Js.Unsafe.inject (Js.bool false)
|
||||
|
||||
(** Get the parameter count of an SX callable (for zero-arg optimization). *)
|
||||
let api_fn_arity fn_js =
|
||||
let handle_field = Js.Unsafe.get fn_js (Js.string "__sx_handle") in
|
||||
if Js.Unsafe.equals handle_field Js.undefined then
|
||||
Js.Unsafe.inject (Js.number_of_float (-1.0))
|
||||
else
|
||||
let id = Js.float_of_number (Js.Unsafe.coerce handle_field) |> int_of_float in
|
||||
let v = get_handle id in
|
||||
match v with
|
||||
| Lambda l -> Js.Unsafe.inject (Js.number_of_float (float_of_int (List.length l.l_params)))
|
||||
| _ -> Js.Unsafe.inject (Js.number_of_float (-1.0))
|
||||
|
||||
(** Load and evaluate SX source string with error wrapping (for test runner). *)
|
||||
let api_load_source src_js =
|
||||
let src = Js.to_string src_js in
|
||||
try
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let env = Env global_env in
|
||||
let count = ref 0 in
|
||||
List.iter (fun expr ->
|
||||
ignore (Sx_ref.eval_expr expr env);
|
||||
incr count
|
||||
) exprs;
|
||||
Js.Unsafe.inject !count
|
||||
with
|
||||
| Eval_error msg -> Js.Unsafe.inject (Js.string ("Error: " ^ msg))
|
||||
| Parse_error msg -> Js.Unsafe.inject (Js.string ("Parse error: " ^ msg))
|
||||
| exn -> Js.Unsafe.inject (Js.string ("Error: " ^ Printexc.to_string exn))
|
||||
|
||||
(* ================================================================== *)
|
||||
(* Register global Sx object *)
|
||||
(* ================================================================== *)
|
||||
|
||||
(* ================================================================== *)
|
||||
(* Platform test functions (registered in global env) *)
|
||||
(* ================================================================== *)
|
||||
|
||||
let () =
|
||||
let bind name fn =
|
||||
ignore (env_bind global_env name (NativeFn (name, fn)))
|
||||
in
|
||||
|
||||
(* --- Deep equality --- *)
|
||||
let rec deep_equal a b =
|
||||
match a, b with
|
||||
| Nil, Nil -> true
|
||||
| Bool a, Bool b -> a = b
|
||||
| Number a, Number b -> a = b
|
||||
| String a, String b -> a = b
|
||||
| Symbol a, Symbol b -> a = b
|
||||
| Keyword a, Keyword b -> a = b
|
||||
| (List a | ListRef { contents = a }), (List b | ListRef { contents = b }) ->
|
||||
List.length a = List.length b && List.for_all2 deep_equal a b
|
||||
| Dict a, Dict b ->
|
||||
let ka = Hashtbl.fold (fun k _ acc -> k :: acc) a [] in
|
||||
let kb = Hashtbl.fold (fun k _ acc -> k :: acc) b [] in
|
||||
List.length ka = List.length kb &&
|
||||
List.for_all (fun k ->
|
||||
Hashtbl.mem b k &&
|
||||
deep_equal
|
||||
(match Hashtbl.find_opt a k with Some v -> v | None -> Nil)
|
||||
(match Hashtbl.find_opt b k with Some v -> v | None -> Nil)) ka
|
||||
| Lambda _, Lambda _ -> a == b
|
||||
| NativeFn _, NativeFn _ -> a == b
|
||||
| _ -> false
|
||||
in
|
||||
|
||||
(* --- try-call --- *)
|
||||
bind "try-call" (fun args ->
|
||||
match args with
|
||||
| [thunk] ->
|
||||
(try
|
||||
ignore (Sx_ref.eval_expr (List [thunk]) (Env global_env));
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "ok" (Bool true); Dict d
|
||||
with
|
||||
| Eval_error msg ->
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "ok" (Bool false);
|
||||
Hashtbl.replace d "error" (String msg); Dict d
|
||||
| exn ->
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "ok" (Bool false);
|
||||
Hashtbl.replace d "error" (String (Printexc.to_string exn)); Dict d)
|
||||
| _ -> raise (Eval_error "try-call: expected 1 arg"));
|
||||
|
||||
(* --- Evaluation --- *)
|
||||
bind "cek-eval" (fun args ->
|
||||
match args with
|
||||
| [expr] -> Sx_ref.eval_expr expr (Env global_env)
|
||||
| [expr; env_val] -> Sx_ref.eval_expr expr env_val
|
||||
| _ -> raise (Eval_error "cek-eval: expected 1-2 args"));
|
||||
|
||||
bind "eval-expr-cek" (fun args ->
|
||||
match args with
|
||||
| [expr] -> Sx_ref.eval_expr expr (Env global_env)
|
||||
| [expr; env_val] -> Sx_ref.eval_expr expr env_val
|
||||
| _ -> raise (Eval_error "eval-expr-cek: expected 1-2 args"));
|
||||
|
||||
bind "sx-parse" (fun args ->
|
||||
match args with
|
||||
| [String src] -> List (Sx_parser.parse_all src)
|
||||
| _ -> raise (Eval_error "sx-parse: expected string"));
|
||||
|
||||
(* --- Equality and assertions --- *)
|
||||
bind "equal?" (fun args ->
|
||||
match args with
|
||||
| [a; b] -> Bool (deep_equal a b)
|
||||
| _ -> raise (Eval_error "equal?: expected 2 args"));
|
||||
|
||||
bind "identical?" (fun args ->
|
||||
match args with
|
||||
| [a; b] -> Bool (a == b)
|
||||
| _ -> raise (Eval_error "identical?: expected 2 args"));
|
||||
|
||||
bind "assert" (fun args ->
|
||||
match args with
|
||||
| [cond] ->
|
||||
if not (sx_truthy cond) then raise (Eval_error "Assertion failed");
|
||||
Bool true
|
||||
| [cond; String msg] ->
|
||||
if not (sx_truthy cond) then raise (Eval_error ("Assertion error: " ^ msg));
|
||||
Bool true
|
||||
| [cond; msg] ->
|
||||
if not (sx_truthy cond) then
|
||||
raise (Eval_error ("Assertion error: " ^ value_to_string msg));
|
||||
Bool true
|
||||
| _ -> raise (Eval_error "assert: expected 1-2 args"));
|
||||
|
||||
(* --- List mutation --- *)
|
||||
bind "append!" (fun args ->
|
||||
match args with
|
||||
| [ListRef r; v] -> r := !r @ [v]; ListRef r
|
||||
| [List items; v] -> List (items @ [v])
|
||||
| _ -> raise (Eval_error "append!: expected list and value"));
|
||||
|
||||
(* --- Environment ops --- *)
|
||||
bind "make-env" (fun _args -> Env (make_env ()));
|
||||
|
||||
bind "env-has?" (fun args ->
|
||||
match args with
|
||||
| [Env e; String k] -> Bool (env_has e k)
|
||||
| [Env e; Keyword k] -> Bool (env_has e k)
|
||||
| _ -> raise (Eval_error "env-has?: expected env and key"));
|
||||
|
||||
bind "env-get" (fun args ->
|
||||
match args with
|
||||
| [Env e; String k] -> env_get e k
|
||||
| [Env e; Keyword k] -> env_get e k
|
||||
| _ -> raise (Eval_error "env-get: expected env and key"));
|
||||
|
||||
bind "env-bind!" (fun args ->
|
||||
match args with
|
||||
| [Env e; String k; v] -> env_bind e k v
|
||||
| [Env e; Keyword k; v] -> env_bind e k v
|
||||
| _ -> raise (Eval_error "env-bind!: expected env, key, value"));
|
||||
|
||||
bind "env-set!" (fun args ->
|
||||
match args with
|
||||
| [Env e; String k; v] -> env_set e k v
|
||||
| [Env e; Keyword k; v] -> env_set e k v
|
||||
| _ -> raise (Eval_error "env-set!: expected env, key, value"));
|
||||
|
||||
bind "env-extend" (fun args ->
|
||||
match args with
|
||||
| [Env e] -> Env (env_extend e)
|
||||
| _ -> raise (Eval_error "env-extend: expected env"));
|
||||
|
||||
bind "env-merge" (fun args ->
|
||||
match args with
|
||||
| [Env a; Env b] -> Env (env_merge a b)
|
||||
| _ -> raise (Eval_error "env-merge: expected 2 envs"));
|
||||
|
||||
(* --- Continuation support --- *)
|
||||
bind "make-continuation" (fun args ->
|
||||
match args with
|
||||
| [f] ->
|
||||
let k v = Sx_runtime.sx_call f [v] in
|
||||
Continuation (k, None)
|
||||
| _ -> raise (Eval_error "make-continuation: expected 1 arg"));
|
||||
|
||||
bind "continuation?" (fun args ->
|
||||
match args with
|
||||
| [Continuation _] -> Bool true
|
||||
| [_] -> Bool false
|
||||
| _ -> raise (Eval_error "continuation?: expected 1 arg"));
|
||||
|
||||
bind "continuation-fn" (fun args ->
|
||||
match args with
|
||||
| [Continuation (f, _)] -> NativeFn ("continuation-fn-result", fun args ->
|
||||
(match args with [v] -> f v | _ -> f Nil))
|
||||
| _ -> raise (Eval_error "continuation-fn: expected continuation"));
|
||||
|
||||
(* --- Missing primitives --- *)
|
||||
bind "make-keyword" (fun args ->
|
||||
match args with
|
||||
| [String s] -> Keyword s
|
||||
| _ -> raise (Eval_error "make-keyword: expected string"));
|
||||
|
||||
(* --- Test helpers --- *)
|
||||
bind "sx-parse-one" (fun args ->
|
||||
match args with
|
||||
| [String src] ->
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
(match exprs with e :: _ -> e | [] -> Nil)
|
||||
| _ -> raise (Eval_error "sx-parse-one: expected string"));
|
||||
|
||||
bind "test-env" (fun _args -> Env (env_extend global_env));
|
||||
|
||||
(* cek-eval takes a string in the native runner *)
|
||||
bind "cek-eval" (fun args ->
|
||||
match args with
|
||||
| [String s] ->
|
||||
let exprs = Sx_parser.parse_all s in
|
||||
(match exprs with
|
||||
| e :: _ -> Sx_ref.eval_expr e (Env global_env)
|
||||
| [] -> Nil)
|
||||
| [expr] -> Sx_ref.eval_expr expr (Env global_env)
|
||||
| [expr; env_val] -> Sx_ref.eval_expr expr env_val
|
||||
| _ -> raise (Eval_error "cek-eval: expected 1-2 args"));
|
||||
|
||||
bind "eval-expr-cek" (fun args ->
|
||||
match args with
|
||||
| [expr; e] -> Sx_ref.eval_expr expr e
|
||||
| [expr] -> Sx_ref.eval_expr expr (Env global_env)
|
||||
| _ -> raise (Eval_error "eval-expr-cek: expected 1-2 args"));
|
||||
|
||||
(* --- Component accessors --- *)
|
||||
bind "component-params" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> List (List.map (fun s -> String s) c.c_params)
|
||||
| _ -> Nil);
|
||||
|
||||
bind "component-body" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> c.c_body
|
||||
| _ -> Nil);
|
||||
|
||||
bind "component-has-children" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> Bool c.c_has_children
|
||||
| _ -> Bool false);
|
||||
|
||||
bind "component-affinity" (fun args ->
|
||||
match args with
|
||||
| [Component c] -> String c.c_affinity
|
||||
| _ -> String "auto");
|
||||
|
||||
bind "component-param-types" (fun _args -> Nil);
|
||||
bind "component-set-param-types!" (fun _args -> Nil);
|
||||
|
||||
(* --- Parser/symbol helpers --- *)
|
||||
bind "keyword-name" (fun args ->
|
||||
match args with
|
||||
| [Keyword k] -> String k
|
||||
| _ -> raise (Eval_error "keyword-name: expected keyword"));
|
||||
|
||||
bind "symbol-name" (fun args ->
|
||||
match args with
|
||||
| [Symbol s] -> String s
|
||||
| _ -> raise (Eval_error "symbol-name: expected symbol"));
|
||||
|
||||
bind "sx-serialize" (fun args ->
|
||||
match args with
|
||||
| [v] -> String (inspect v)
|
||||
| _ -> raise (Eval_error "sx-serialize: expected 1 arg"));
|
||||
|
||||
bind "make-symbol" (fun args ->
|
||||
match args with
|
||||
| [String s] -> Symbol s
|
||||
| [v] -> Symbol (value_to_string v)
|
||||
| _ -> raise (Eval_error "make-symbol: expected 1 arg"));
|
||||
|
||||
(* --- CEK stepping / introspection --- *)
|
||||
bind "make-cek-state" (fun args ->
|
||||
match args with
|
||||
| [ctrl; env'; kont] -> Sx_ref.make_cek_state ctrl env' kont
|
||||
| _ -> raise (Eval_error "make-cek-state: expected 3 args"));
|
||||
|
||||
bind "cek-step" (fun args ->
|
||||
match args with
|
||||
| [state] -> Sx_ref.cek_step state
|
||||
| _ -> raise (Eval_error "cek-step: expected 1 arg"));
|
||||
|
||||
bind "cek-phase" (fun args ->
|
||||
match args with
|
||||
| [state] -> Sx_ref.cek_phase state
|
||||
| _ -> raise (Eval_error "cek-phase: expected 1 arg"));
|
||||
|
||||
bind "cek-value" (fun args ->
|
||||
match args with
|
||||
| [state] -> Sx_ref.cek_value state
|
||||
| _ -> raise (Eval_error "cek-value: expected 1 arg"));
|
||||
|
||||
bind "cek-terminal?" (fun args ->
|
||||
match args with
|
||||
| [state] -> Sx_ref.cek_terminal_p state
|
||||
| _ -> raise (Eval_error "cek-terminal?: expected 1 arg"));
|
||||
|
||||
bind "cek-kont" (fun args ->
|
||||
match args with
|
||||
| [state] -> Sx_ref.cek_kont state
|
||||
| _ -> raise (Eval_error "cek-kont: expected 1 arg"));
|
||||
|
||||
bind "frame-type" (fun args ->
|
||||
match args with
|
||||
| [frame] -> Sx_ref.frame_type frame
|
||||
| _ -> raise (Eval_error "frame-type: expected 1 arg"));
|
||||
|
||||
(* --- Strict mode --- *)
|
||||
ignore (env_bind global_env "*strict*" (Bool false));
|
||||
ignore (env_bind global_env "*prim-param-types*" Nil);
|
||||
|
||||
bind "set-strict!" (fun args ->
|
||||
match args with
|
||||
| [v] ->
|
||||
Sx_ref._strict_ref := v;
|
||||
ignore (env_set global_env "*strict*" v); Nil
|
||||
| _ -> raise (Eval_error "set-strict!: expected 1 arg"));
|
||||
|
||||
bind "set-prim-param-types!" (fun args ->
|
||||
match args with
|
||||
| [v] ->
|
||||
Sx_ref._prim_param_types_ref := v;
|
||||
ignore (env_set global_env "*prim-param-types*" v); Nil
|
||||
| _ -> raise (Eval_error "set-prim-param-types!: expected 1 arg"));
|
||||
|
||||
bind "value-matches-type?" (fun args ->
|
||||
match args with
|
||||
| [v; String expected] -> Sx_ref.value_matches_type_p v (String expected)
|
||||
| _ -> raise (Eval_error "value-matches-type?: expected value and type string"));
|
||||
|
||||
(* --- Apply --- *)
|
||||
bind "apply" (fun args ->
|
||||
match args with
|
||||
| f :: rest ->
|
||||
let all_args = match List.rev rest with
|
||||
| List last :: prefix -> List.rev prefix @ last
|
||||
| _ -> rest
|
||||
in
|
||||
Sx_runtime.sx_call f all_args
|
||||
| _ -> raise (Eval_error "apply: expected function and args"));
|
||||
|
||||
(* --- Type system test helpers (for --full tests) --- *)
|
||||
bind "test-prim-types" (fun _args ->
|
||||
let d = Hashtbl.create 40 in
|
||||
List.iter (fun (k, v) -> Hashtbl.replace d k (String v)) [
|
||||
"+", "number"; "-", "number"; "*", "number"; "/", "number";
|
||||
"mod", "number"; "inc", "number"; "dec", "number";
|
||||
"abs", "number"; "min", "number"; "max", "number";
|
||||
"floor", "number"; "ceil", "number"; "round", "number";
|
||||
"str", "string"; "upper", "string"; "lower", "string";
|
||||
"trim", "string"; "join", "string"; "replace", "string";
|
||||
"format", "string"; "substr", "string";
|
||||
"=", "boolean"; "<", "boolean"; ">", "boolean";
|
||||
"<=", "boolean"; ">=", "boolean"; "!=", "boolean";
|
||||
"not", "boolean"; "nil?", "boolean"; "empty?", "boolean";
|
||||
"number?", "boolean"; "string?", "boolean"; "boolean?", "boolean";
|
||||
"list?", "boolean"; "dict?", "boolean"; "symbol?", "boolean";
|
||||
"keyword?", "boolean"; "contains?", "boolean"; "has-key?", "boolean";
|
||||
"starts-with?", "boolean"; "ends-with?", "boolean";
|
||||
"len", "number"; "first", "any"; "rest", "list";
|
||||
"last", "any"; "nth", "any"; "cons", "list";
|
||||
"append", "list"; "concat", "list"; "reverse", "list";
|
||||
"sort", "list"; "slice", "list"; "range", "list";
|
||||
"flatten", "list"; "keys", "list"; "vals", "list";
|
||||
"map-dict", "dict"; "assoc", "dict"; "dissoc", "dict";
|
||||
"merge", "dict"; "dict", "dict";
|
||||
"get", "any"; "type-of", "string";
|
||||
];
|
||||
Dict d);
|
||||
|
||||
bind "test-prim-param-types" (fun _args ->
|
||||
let d = Hashtbl.create 10 in
|
||||
let pos name typ =
|
||||
let d2 = Hashtbl.create 2 in
|
||||
Hashtbl.replace d2 "positional" (List [List [String name; String typ]]);
|
||||
Hashtbl.replace d2 "rest-type" Nil; Dict d2
|
||||
in
|
||||
let pos_rest name typ rt =
|
||||
let d2 = Hashtbl.create 2 in
|
||||
Hashtbl.replace d2 "positional" (List [List [String name; String typ]]);
|
||||
Hashtbl.replace d2 "rest-type" (String rt); Dict d2
|
||||
in
|
||||
Hashtbl.replace d "+" (pos_rest "a" "number" "number");
|
||||
Hashtbl.replace d "-" (pos_rest "a" "number" "number");
|
||||
Hashtbl.replace d "*" (pos_rest "a" "number" "number");
|
||||
Hashtbl.replace d "/" (pos_rest "a" "number" "number");
|
||||
Hashtbl.replace d "inc" (pos "n" "number");
|
||||
Hashtbl.replace d "dec" (pos "n" "number");
|
||||
Hashtbl.replace d "upper" (pos "s" "string");
|
||||
Hashtbl.replace d "lower" (pos "s" "string");
|
||||
Hashtbl.replace d "keys" (pos "d" "dict");
|
||||
Hashtbl.replace d "vals" (pos "d" "dict");
|
||||
Dict d);
|
||||
|
||||
(* --- HTML renderer --- *)
|
||||
Sx_render.setup_render_env global_env;
|
||||
|
||||
(* Web adapters loaded as SX source at boot time via bundle.sh *)
|
||||
|
||||
(* Wire up render mode — the CEK machine checks these to dispatch
|
||||
HTML tags and components to the renderer instead of eval. *)
|
||||
Sx_runtime._render_active_p_fn :=
|
||||
(fun () -> Bool !_sx_render_mode);
|
||||
Sx_runtime._is_render_expr_fn :=
|
||||
(fun expr -> match expr with
|
||||
| List (Symbol tag :: _) ->
|
||||
Bool (Sx_render.is_html_tag tag || tag = "<>" || tag = "raw!")
|
||||
| _ -> Bool false);
|
||||
Sx_runtime._render_expr_fn :=
|
||||
(fun expr env -> match env with
|
||||
| Env e -> RawHTML (Sx_render.render_to_html expr e)
|
||||
| _ -> RawHTML (Sx_render.render_to_html expr global_env));
|
||||
|
||||
(* --- Scope stack primitives (called by transpiled evaluator via prim_call) --- *)
|
||||
Sx_primitives.register "collect!" (fun args ->
|
||||
match args with [a; b] -> Sx_runtime.sx_collect a b | _ -> Nil);
|
||||
Sx_primitives.register "collected" (fun args ->
|
||||
match args with [a] -> Sx_runtime.sx_collected a | _ -> List []);
|
||||
Sx_primitives.register "clear-collected!" (fun args ->
|
||||
match args with [a] -> Sx_runtime.sx_clear_collected a | _ -> Nil);
|
||||
Sx_primitives.register "emit!" (fun args ->
|
||||
match args with [a; b] -> Sx_runtime.sx_emit a b | _ -> Nil);
|
||||
Sx_primitives.register "emitted" (fun args ->
|
||||
match args with [a] -> Sx_runtime.sx_emitted a | _ -> List []);
|
||||
Sx_primitives.register "context" (fun args ->
|
||||
match args with [a; b] -> Sx_runtime.sx_context a b | [a] -> Sx_runtime.sx_context a Nil | _ -> Nil);
|
||||
|
||||
(* --- Fragment and raw HTML (always available, not just in render mode) --- *)
|
||||
bind "<>" (fun args ->
|
||||
let parts = List.map (fun a ->
|
||||
match a with
|
||||
| String s -> s
|
||||
| RawHTML s -> s
|
||||
| Nil -> ""
|
||||
| List _ -> Sx_render.render_to_html a global_env
|
||||
| _ -> value_to_string a
|
||||
) args in
|
||||
RawHTML (String.concat "" parts));
|
||||
|
||||
bind "raw!" (fun args ->
|
||||
match args with
|
||||
| [String s] -> RawHTML s
|
||||
| [RawHTML s] -> RawHTML s
|
||||
| [Nil] -> RawHTML ""
|
||||
| _ -> RawHTML (String.concat "" (List.map (fun a ->
|
||||
match a with String s | RawHTML s -> s | _ -> value_to_string a
|
||||
) args)));
|
||||
|
||||
(* --- Scope stack functions (used by signals.sx, evaluator scope forms) --- *)
|
||||
bind "scope-push!" (fun args ->
|
||||
match args with
|
||||
| [name; value] -> Sx_runtime.scope_push name value
|
||||
| _ -> raise (Eval_error "scope-push!: expected 2 args"));
|
||||
|
||||
bind "scope-pop!" (fun args ->
|
||||
match args with
|
||||
| [_name] -> Sx_runtime.scope_pop _name
|
||||
| _ -> raise (Eval_error "scope-pop!: expected 1 arg"));
|
||||
|
||||
bind "provide-push!" (fun args ->
|
||||
match args with
|
||||
| [name; value] -> Sx_runtime.provide_push name value
|
||||
| _ -> raise (Eval_error "provide-push!: expected 2 args"));
|
||||
|
||||
bind "provide-pop!" (fun args ->
|
||||
match args with
|
||||
| [_name] -> Sx_runtime.provide_pop _name
|
||||
| _ -> raise (Eval_error "provide-pop!: expected 1 arg"));
|
||||
|
||||
(* define-page-helper: registers a named page helper — stub for browser *)
|
||||
bind "define-page-helper" (fun args ->
|
||||
match args with
|
||||
| [String _name; _body] -> Nil (* Page helpers are server-side; noop in browser *)
|
||||
| _ -> Nil);
|
||||
|
||||
(* cek-call: call a function via the CEK machine (used by signals, orchestration)
|
||||
(cek-call fn nil) → call with no args
|
||||
(cek-call fn (list a)) → call with args list
|
||||
(cek-call fn a) → call with single arg *)
|
||||
bind "cek-call" (fun args ->
|
||||
match args with
|
||||
| [f; Nil] -> Sx_ref.eval_expr (List [f]) (Env global_env)
|
||||
| [f; List arg_list] -> Sx_ref.eval_expr (List (f :: arg_list)) (Env global_env)
|
||||
| [f; a] -> Sx_ref.eval_expr (List [f; a]) (Env global_env)
|
||||
| [f] -> Sx_ref.eval_expr (List [f]) (Env global_env)
|
||||
| f :: rest -> Sx_ref.eval_expr (List (f :: rest)) (Env global_env)
|
||||
| _ -> raise (Eval_error "cek-call: expected function and args"));
|
||||
|
||||
(* not : logical negation (sometimes missing from evaluator prims) *)
|
||||
(if not (Sx_primitives.is_primitive "not") then
|
||||
bind "not" (fun args ->
|
||||
match args with
|
||||
| [v] -> Bool (not (sx_truthy v))
|
||||
| _ -> raise (Eval_error "not: expected 1 arg")))
|
||||
|
||||
let () =
|
||||
let sx = Js.Unsafe.obj [||] in
|
||||
|
||||
(* __sxWrap: wraps an OCaml API function so that after calling it,
|
||||
the JS side picks up the result from globalThis.__sxR if set.
|
||||
This bypasses js_of_ocaml stripping properties from function return values. *)
|
||||
let wrap = Js.Unsafe.pure_js_expr
|
||||
{|(function(fn) {
|
||||
return function() {
|
||||
globalThis.__sxR = undefined;
|
||||
var r = fn.apply(null, arguments);
|
||||
return globalThis.__sxR !== undefined ? globalThis.__sxR : r;
|
||||
};
|
||||
})|} in
|
||||
let w fn = Js.Unsafe.fun_call wrap [| Js.Unsafe.inject (Js.wrap_callback fn) |] in
|
||||
|
||||
(* Core evaluation *)
|
||||
Js.Unsafe.set sx (Js.string "parse")
|
||||
(Js.wrap_callback api_parse);
|
||||
Js.Unsafe.set sx (Js.string "stringify")
|
||||
(Js.wrap_callback api_stringify);
|
||||
Js.Unsafe.set sx (Js.string "eval")
|
||||
(w api_eval);
|
||||
Js.Unsafe.set sx (Js.string "evalExpr")
|
||||
(w api_eval_expr);
|
||||
Js.Unsafe.set sx (Js.string "cekRun")
|
||||
(w api_cek_run);
|
||||
Js.Unsafe.set sx (Js.string "renderToHtml")
|
||||
(Js.wrap_callback api_render_to_html);
|
||||
Js.Unsafe.set sx (Js.string "load")
|
||||
(Js.wrap_callback api_load);
|
||||
Js.Unsafe.set sx (Js.string "typeOf")
|
||||
(Js.wrap_callback api_type_of);
|
||||
Js.Unsafe.set sx (Js.string "inspect")
|
||||
(Js.wrap_callback api_inspect);
|
||||
Js.Unsafe.set sx (Js.string "engine")
|
||||
(Js.wrap_callback api_engine);
|
||||
Js.Unsafe.set sx (Js.string "registerNative")
|
||||
(Js.wrap_callback api_register_native);
|
||||
Js.Unsafe.set sx (Js.string "loadSource")
|
||||
(Js.wrap_callback api_load_source);
|
||||
Js.Unsafe.set sx (Js.string "callFn")
|
||||
(w api_call_fn);
|
||||
Js.Unsafe.set sx (Js.string "isCallable")
|
||||
(Js.wrap_callback api_is_callable);
|
||||
Js.Unsafe.set sx (Js.string "fnArity")
|
||||
(Js.wrap_callback api_fn_arity);
|
||||
|
||||
(* Expose globally *)
|
||||
Js.Unsafe.set Js.Unsafe.global (Js.string "SxKernel") sx
|
||||
2
hosts/ocaml/dune-project
Normal file
2
hosts/ocaml/dune-project
Normal file
@@ -0,0 +1,2 @@
|
||||
(lang dune 3.19)
|
||||
(name sx)
|
||||
3
hosts/ocaml/lib/dune
Normal file
3
hosts/ocaml/lib/dune
Normal file
@@ -0,0 +1,3 @@
|
||||
(library
|
||||
(name sx)
|
||||
(wrapped false))
|
||||
206
hosts/ocaml/lib/sx_parser.ml
Normal file
206
hosts/ocaml/lib/sx_parser.ml
Normal file
@@ -0,0 +1,206 @@
|
||||
(** S-expression parser.
|
||||
|
||||
Recursive descent over a string, producing [Sx_types.value list].
|
||||
Supports: lists, dicts, symbols, keywords, strings (with escapes),
|
||||
numbers, booleans, nil, comments, quote/quasiquote/unquote sugar. *)
|
||||
|
||||
open Sx_types
|
||||
|
||||
type state = {
|
||||
src : string;
|
||||
len : int;
|
||||
mutable pos : int;
|
||||
}
|
||||
|
||||
let make_state src = { src; len = String.length src; pos = 0 }
|
||||
|
||||
let peek s = if s.pos < s.len then Some s.src.[s.pos] else None
|
||||
let advance s = s.pos <- s.pos + 1
|
||||
let at_end s = s.pos >= s.len
|
||||
|
||||
let skip_whitespace_and_comments s =
|
||||
let rec go () =
|
||||
if at_end s then ()
|
||||
else match s.src.[s.pos] with
|
||||
| ' ' | '\t' | '\n' | '\r' -> advance s; go ()
|
||||
| ';' ->
|
||||
while s.pos < s.len && s.src.[s.pos] <> '\n' do advance s done;
|
||||
if s.pos < s.len then advance s;
|
||||
go ()
|
||||
| _ -> ()
|
||||
in go ()
|
||||
|
||||
let is_symbol_char = function
|
||||
| '(' | ')' | '[' | ']' | '{' | '}' | '"' | '\'' | '`'
|
||||
| ' ' | '\t' | '\n' | '\r' | ',' | ';' -> false
|
||||
| _ -> true
|
||||
|
||||
let read_string s =
|
||||
(* s.pos is on the opening quote *)
|
||||
advance s;
|
||||
let buf = Buffer.create 64 in
|
||||
let rec go () =
|
||||
if at_end s then raise (Parse_error "Unterminated string");
|
||||
let c = s.src.[s.pos] in
|
||||
advance s;
|
||||
if c = '"' then Buffer.contents buf
|
||||
else if c = '\\' then begin
|
||||
if at_end s then raise (Parse_error "Unterminated string escape");
|
||||
let esc = s.src.[s.pos] in
|
||||
advance s;
|
||||
(match esc with
|
||||
| 'n' -> Buffer.add_char buf '\n'
|
||||
| 't' -> Buffer.add_char buf '\t'
|
||||
| 'r' -> Buffer.add_char buf '\r'
|
||||
| '"' -> Buffer.add_char buf '"'
|
||||
| '\\' -> Buffer.add_char buf '\\'
|
||||
| 'u' ->
|
||||
(* \uXXXX — read 4 hex digits, encode as UTF-8 *)
|
||||
if s.pos + 4 > s.len then raise (Parse_error "Incomplete \\u escape");
|
||||
let hex = String.sub s.src s.pos 4 in
|
||||
s.pos <- s.pos + 4;
|
||||
let code = int_of_string ("0x" ^ hex) in
|
||||
let ubuf = Buffer.create 4 in
|
||||
Buffer.add_utf_8_uchar ubuf (Uchar.of_int code);
|
||||
Buffer.add_string buf (Buffer.contents ubuf)
|
||||
| '`' -> Buffer.add_char buf '`'
|
||||
| _ -> Buffer.add_char buf '\\'; Buffer.add_char buf esc);
|
||||
go ()
|
||||
end else begin
|
||||
Buffer.add_char buf c;
|
||||
go ()
|
||||
end
|
||||
in go ()
|
||||
|
||||
let read_symbol s =
|
||||
let start = s.pos in
|
||||
while s.pos < s.len && is_symbol_char s.src.[s.pos] do advance s done;
|
||||
String.sub s.src start (s.pos - start)
|
||||
|
||||
let try_number str =
|
||||
match float_of_string_opt str with
|
||||
| Some n -> Some (Number n)
|
||||
| None -> None
|
||||
|
||||
let rec read_value s : value =
|
||||
skip_whitespace_and_comments s;
|
||||
if at_end s then raise (Parse_error "Unexpected end of input");
|
||||
match s.src.[s.pos] with
|
||||
| '(' -> read_list s ')'
|
||||
| '[' -> read_list s ']'
|
||||
| '{' -> read_dict s
|
||||
| '"' -> String (read_string s)
|
||||
| '\'' -> advance s; List [Symbol "quote"; read_value s]
|
||||
| '`' -> advance s; List [Symbol "quasiquote"; read_value s]
|
||||
| '#' when s.pos + 1 < s.len && s.src.[s.pos + 1] = ';' ->
|
||||
(* Datum comment: #; discards next expression *)
|
||||
advance s; advance s;
|
||||
ignore (read_value s);
|
||||
read_value s
|
||||
| '#' when s.pos + 1 < s.len && s.src.[s.pos + 1] = '\'' ->
|
||||
(* Quote shorthand: #'expr -> (quote expr) *)
|
||||
advance s; advance s;
|
||||
List [Symbol "quote"; read_value s]
|
||||
| '#' when s.pos + 1 < s.len && s.src.[s.pos + 1] = '|' ->
|
||||
(* Raw string: #|...| — ends at next | *)
|
||||
advance s; advance s;
|
||||
let buf = Buffer.create 64 in
|
||||
let rec go () =
|
||||
if at_end s then raise (Parse_error "Unterminated raw string");
|
||||
let c = s.src.[s.pos] in
|
||||
advance s;
|
||||
if c = '|' then
|
||||
String (Buffer.contents buf)
|
||||
else begin
|
||||
Buffer.add_char buf c;
|
||||
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
|
||||
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
|
||||
(* 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]));
|
||||
match token with
|
||||
| "true" -> Bool true
|
||||
| "false" -> Bool false
|
||||
| "nil" -> Nil
|
||||
| _ when token.[0] = ':' ->
|
||||
Keyword (String.sub token 1 (String.length token - 1))
|
||||
| _ ->
|
||||
match try_number token with
|
||||
| Some n -> n
|
||||
| None -> Symbol token
|
||||
end
|
||||
|
||||
and read_list s close_char =
|
||||
advance s; (* skip opening paren/bracket *)
|
||||
let items = ref [] in
|
||||
let rec go () =
|
||||
skip_whitespace_and_comments s;
|
||||
if at_end s then raise (Parse_error "Unterminated list");
|
||||
if s.src.[s.pos] = close_char then begin
|
||||
advance s;
|
||||
List (List.rev !items)
|
||||
end else begin
|
||||
items := read_value s :: !items;
|
||||
go ()
|
||||
end
|
||||
in go ()
|
||||
|
||||
and read_dict s =
|
||||
advance s; (* skip { *)
|
||||
let d = make_dict () in
|
||||
let rec go () =
|
||||
skip_whitespace_and_comments s;
|
||||
if at_end s then raise (Parse_error "Unterminated dict");
|
||||
if s.src.[s.pos] = '}' then begin
|
||||
advance s;
|
||||
Dict d
|
||||
end else begin
|
||||
let key = read_value s in
|
||||
let key_str = match key with
|
||||
| Keyword k -> k
|
||||
| String k -> k
|
||||
| Symbol k -> k
|
||||
| _ -> raise (Parse_error "Dict key must be keyword, string, or symbol")
|
||||
in
|
||||
let v = read_value s in
|
||||
dict_set d key_str v;
|
||||
go ()
|
||||
end
|
||||
in go ()
|
||||
|
||||
|
||||
(** Parse a string into a list of SX values. *)
|
||||
let parse_all src =
|
||||
let s = make_state src in
|
||||
let results = ref [] in
|
||||
let rec go () =
|
||||
skip_whitespace_and_comments s;
|
||||
if at_end s then List.rev !results
|
||||
else begin
|
||||
results := read_value s :: !results;
|
||||
go ()
|
||||
end
|
||||
in go ()
|
||||
|
||||
(** Parse a file into a list of SX values. *)
|
||||
let parse_file path =
|
||||
let ic = open_in path in
|
||||
let n = in_channel_length ic in
|
||||
let src = really_input_string ic n in
|
||||
close_in ic;
|
||||
parse_all src
|
||||
578
hosts/ocaml/lib/sx_primitives.ml
Normal file
578
hosts/ocaml/lib/sx_primitives.ml
Normal file
@@ -0,0 +1,578 @@
|
||||
(** Built-in primitive functions (~80 pure functions).
|
||||
|
||||
Registered in a global table; the evaluator checks this table
|
||||
when a symbol isn't found in the lexical environment. *)
|
||||
|
||||
open Sx_types
|
||||
|
||||
let primitives : (string, value list -> value) Hashtbl.t = Hashtbl.create 128
|
||||
|
||||
let register name fn = Hashtbl.replace primitives name fn
|
||||
|
||||
let is_primitive name = Hashtbl.mem primitives name
|
||||
|
||||
let get_primitive name =
|
||||
match Hashtbl.find_opt primitives name with
|
||||
| Some fn -> NativeFn (name, fn)
|
||||
| None -> raise (Eval_error ("Unknown primitive: " ^ name))
|
||||
|
||||
(* --- Helpers --- *)
|
||||
|
||||
let as_number = function
|
||||
| Number n -> n
|
||||
| Bool true -> 1.0
|
||||
| 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))
|
||||
|
||||
let as_string = function
|
||||
| String s -> s
|
||||
| v -> raise (Eval_error ("Expected string, got " ^ type_of v))
|
||||
|
||||
let as_list = function
|
||||
| List l -> l
|
||||
| ListRef r -> !r
|
||||
| Nil -> []
|
||||
| v -> raise (Eval_error ("Expected list, got " ^ type_of v))
|
||||
|
||||
let as_bool = function
|
||||
| Bool b -> b
|
||||
| v -> sx_truthy v
|
||||
|
||||
let to_string = function
|
||||
| String s -> s
|
||||
| Number n ->
|
||||
if Float.is_integer n then string_of_int (int_of_float n)
|
||||
else Printf.sprintf "%g" n
|
||||
| Bool true -> "true"
|
||||
| Bool false -> "false"
|
||||
| Nil -> ""
|
||||
| Symbol s -> s
|
||||
| Keyword k -> k
|
||||
| v -> inspect v
|
||||
|
||||
let () =
|
||||
(* === Arithmetic === *)
|
||||
register "+" (fun args ->
|
||||
Number (List.fold_left (fun acc a -> acc +. as_number a) 0.0 args));
|
||||
register "-" (fun args ->
|
||||
match args with
|
||||
| [] -> Number 0.0
|
||||
| [a] -> Number (-. (as_number a))
|
||||
| a :: rest -> Number (List.fold_left (fun acc x -> acc -. as_number x) (as_number a) rest));
|
||||
register "*" (fun args ->
|
||||
Number (List.fold_left (fun acc a -> acc *. as_number a) 1.0 args));
|
||||
register "/" (fun args ->
|
||||
match args with
|
||||
| [a; b] -> Number (as_number a /. as_number b)
|
||||
| _ -> raise (Eval_error "/: expected 2 args"));
|
||||
register "mod" (fun args ->
|
||||
match args with
|
||||
| [a; b] -> Number (Float.rem (as_number a) (as_number b))
|
||||
| _ -> raise (Eval_error "mod: expected 2 args"));
|
||||
register "inc" (fun args ->
|
||||
match args with [a] -> Number (as_number a +. 1.0) | _ -> raise (Eval_error "inc: 1 arg"));
|
||||
register "dec" (fun args ->
|
||||
match args with [a] -> Number (as_number a -. 1.0) | _ -> raise (Eval_error "dec: 1 arg"));
|
||||
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))))
|
||||
| _ -> 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))))
|
||||
| _ -> raise (Eval_error "ceil: 1 arg"));
|
||||
register "round" (fun args ->
|
||||
match args with
|
||||
| [a] -> Number (Float.round (as_number a))
|
||||
| [a; b] ->
|
||||
let n = as_number a and places = int_of_float (as_number b) in
|
||||
let factor = 10.0 ** float_of_int places in
|
||||
Number (Float.round (n *. factor) /. factor)
|
||||
| _ -> raise (Eval_error "round: 1-2 args"));
|
||||
register "min" (fun args ->
|
||||
match args with
|
||||
| [] -> raise (Eval_error "min: at least 1 arg")
|
||||
| _ -> Number (List.fold_left (fun acc a -> Float.min acc (as_number a)) Float.infinity args));
|
||||
register "max" (fun args ->
|
||||
match args with
|
||||
| [] -> raise (Eval_error "max: at least 1 arg")
|
||||
| _ -> Number (List.fold_left (fun acc a -> Float.max acc (as_number a)) Float.neg_infinity args));
|
||||
register "sqrt" (fun args ->
|
||||
match args with [a] -> Number (Float.sqrt (as_number a)) | _ -> raise (Eval_error "sqrt: 1 arg"));
|
||||
register "pow" (fun args ->
|
||||
match args with [a; b] -> Number (as_number a ** as_number b)
|
||||
| _ -> raise (Eval_error "pow: 2 args"));
|
||||
register "clamp" (fun args ->
|
||||
match args with
|
||||
| [x; lo; hi] ->
|
||||
let x = as_number x and lo = as_number lo and hi = as_number hi in
|
||||
Number (Float.max lo (Float.min hi x))
|
||||
| _ -> raise (Eval_error "clamp: 3 args"));
|
||||
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))
|
||||
| _ -> Nil);
|
||||
register "parse-float" (fun args ->
|
||||
match args with
|
||||
| [String s] -> (match float_of_string_opt s with Some n -> Number n | None -> Nil)
|
||||
| [Number n] -> Number n
|
||||
| _ -> Nil);
|
||||
|
||||
(* === Comparison === *)
|
||||
(* Normalize ListRef to List for structural equality *)
|
||||
let rec normalize_for_eq = function
|
||||
| ListRef { contents = items } -> List (List.map normalize_for_eq items)
|
||||
| List items -> List (List.map normalize_for_eq items)
|
||||
| v -> v
|
||||
in
|
||||
register "=" (fun args ->
|
||||
match args with
|
||||
| [a; b] -> Bool (normalize_for_eq a = normalize_for_eq b)
|
||||
| _ -> raise (Eval_error "=: 2 args"));
|
||||
register "!=" (fun args ->
|
||||
match args with
|
||||
| [a; b] -> Bool (normalize_for_eq a <> normalize_for_eq b)
|
||||
| _ -> raise (Eval_error "!=: 2 args"));
|
||||
register "<" (fun args ->
|
||||
match args with
|
||||
| [String a; String b] -> Bool (a < b)
|
||||
| [a; b] -> Bool (as_number a < as_number b)
|
||||
| _ -> raise (Eval_error "<: 2 args"));
|
||||
register ">" (fun args ->
|
||||
match args with
|
||||
| [String a; String b] -> Bool (a > b)
|
||||
| [a; b] -> Bool (as_number a > as_number b)
|
||||
| _ -> raise (Eval_error ">: 2 args"));
|
||||
register "<=" (fun args ->
|
||||
match args with
|
||||
| [String a; String b] -> Bool (a <= b)
|
||||
| [a; b] -> Bool (as_number a <= as_number b)
|
||||
| _ -> raise (Eval_error "<=: 2 args"));
|
||||
register ">=" (fun args ->
|
||||
match args with
|
||||
| [String a; String b] -> Bool (a >= b)
|
||||
| [a; b] -> Bool (as_number a >= as_number b)
|
||||
| _ -> raise (Eval_error ">=: 2 args"));
|
||||
|
||||
(* === Logic === *)
|
||||
register "not" (fun args ->
|
||||
match args with [a] -> Bool (not (sx_truthy a)) | _ -> raise (Eval_error "not: 1 arg"));
|
||||
|
||||
(* === Predicates === *)
|
||||
register "nil?" (fun args ->
|
||||
match args with [a] -> Bool (is_nil a) | _ -> raise (Eval_error "nil?: 1 arg"));
|
||||
register "number?" (fun args ->
|
||||
match args with [Number _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "number?: 1 arg"));
|
||||
register "string?" (fun args ->
|
||||
match args with [String _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "string?: 1 arg"));
|
||||
register "boolean?" (fun args ->
|
||||
match args with [Bool _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "boolean?: 1 arg"));
|
||||
register "list?" (fun args ->
|
||||
match args with [List _] | [ListRef _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "list?: 1 arg"));
|
||||
register "dict?" (fun args ->
|
||||
match args with [Dict _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "dict?: 1 arg"));
|
||||
register "symbol?" (fun args ->
|
||||
match args with [Symbol _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "symbol?: 1 arg"));
|
||||
register "keyword?" (fun args ->
|
||||
match args with [Keyword _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "keyword?: 1 arg"));
|
||||
register "empty?" (fun args ->
|
||||
match args with
|
||||
| [List []] | [ListRef { contents = [] }] -> Bool true
|
||||
| [List _] | [ListRef _] -> Bool false
|
||||
| [String ""] -> Bool true | [String _] -> Bool false
|
||||
| [Dict d] -> Bool (Hashtbl.length d = 0)
|
||||
| [Nil] -> Bool true
|
||||
| [_] -> Bool false
|
||||
| _ -> raise (Eval_error "empty?: 1 arg"));
|
||||
register "odd?" (fun args ->
|
||||
match args with [a] -> Bool (int_of_float (as_number a) mod 2 <> 0) | _ -> raise (Eval_error "odd?: 1 arg"));
|
||||
register "even?" (fun args ->
|
||||
match args with [a] -> Bool (int_of_float (as_number a) mod 2 = 0) | _ -> raise (Eval_error "even?: 1 arg"));
|
||||
register "zero?" (fun args ->
|
||||
match args with [a] -> Bool (as_number a = 0.0) | _ -> raise (Eval_error "zero?: 1 arg"));
|
||||
|
||||
(* === Strings === *)
|
||||
register "str" (fun args -> String (String.concat "" (List.map to_string args)));
|
||||
register "upper" (fun args ->
|
||||
match args with [a] -> String (String.uppercase_ascii (as_string a)) | _ -> raise (Eval_error "upper: 1 arg"));
|
||||
register "upcase" (fun args ->
|
||||
match args with [a] -> String (String.uppercase_ascii (as_string a)) | _ -> raise (Eval_error "upcase: 1 arg"));
|
||||
register "lower" (fun args ->
|
||||
match args with [a] -> String (String.lowercase_ascii (as_string a)) | _ -> raise (Eval_error "lower: 1 arg"));
|
||||
register "downcase" (fun args ->
|
||||
match args with [a] -> String (String.lowercase_ascii (as_string a)) | _ -> raise (Eval_error "downcase: 1 arg"));
|
||||
register "trim" (fun args ->
|
||||
match args with [a] -> String (String.trim (as_string a)) | _ -> raise (Eval_error "trim: 1 arg"));
|
||||
register "string-length" (fun args ->
|
||||
match args with [a] -> Number (float_of_int (String.length (as_string a)))
|
||||
| _ -> raise (Eval_error "string-length: 1 arg"));
|
||||
register "string-contains?" (fun args ->
|
||||
match args with
|
||||
| [String haystack; String needle] ->
|
||||
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 Bool (find 0)
|
||||
| _ -> raise (Eval_error "string-contains?: 2 string args"));
|
||||
register "starts-with?" (fun args ->
|
||||
match args with
|
||||
| [String s; String prefix] ->
|
||||
Bool (String.length s >= String.length prefix &&
|
||||
String.sub s 0 (String.length prefix) = prefix)
|
||||
| _ -> raise (Eval_error "starts-with?: 2 string args"));
|
||||
register "ends-with?" (fun args ->
|
||||
match args with
|
||||
| [String s; String suffix] ->
|
||||
let sl = String.length s and xl = String.length suffix in
|
||||
Bool (sl >= xl && String.sub s (sl - xl) xl = suffix)
|
||||
| _ -> raise (Eval_error "ends-with?: 2 string args"));
|
||||
register "index-of" (fun args ->
|
||||
match args with
|
||||
| [String haystack; String needle] ->
|
||||
let nl = String.length needle and hl = String.length haystack in
|
||||
let rec find i =
|
||||
if i + nl > hl then Number (-1.0)
|
||||
else if String.sub haystack i nl = needle then Number (float_of_int i)
|
||||
else find (i + 1)
|
||||
in find 0
|
||||
| _ -> raise (Eval_error "index-of: 2 string args"));
|
||||
register "substring" (fun args ->
|
||||
match args with
|
||||
| [String s; Number start; Number end_] ->
|
||||
let i = int_of_float start and j = int_of_float end_ in
|
||||
let len = String.length s in
|
||||
let i = max 0 (min i len) and j = max 0 (min j len) in
|
||||
String (String.sub s i (max 0 (j - i)))
|
||||
| _ -> raise (Eval_error "substring: 3 args"));
|
||||
register "substr" (fun args ->
|
||||
match args with
|
||||
| [String s; Number start; Number len] ->
|
||||
let i = int_of_float start and n = int_of_float len in
|
||||
let sl = String.length s in
|
||||
let i = max 0 (min i sl) in
|
||||
let n = max 0 (min n (sl - i)) in
|
||||
String (String.sub s i n)
|
||||
| [String s; Number start] ->
|
||||
let i = int_of_float start in
|
||||
let sl = String.length s in
|
||||
let i = max 0 (min i sl) in
|
||||
String (String.sub s i (sl - i))
|
||||
| _ -> raise (Eval_error "substr: 2-3 args"));
|
||||
register "split" (fun args ->
|
||||
match args with
|
||||
| [String s; String sep] ->
|
||||
List (List.map (fun p -> String p) (String.split_on_char sep.[0] s))
|
||||
| _ -> raise (Eval_error "split: 2 args"));
|
||||
register "join" (fun args ->
|
||||
match args with
|
||||
| [String sep; (List items | ListRef { contents = items })] ->
|
||||
String (String.concat sep (List.map to_string items))
|
||||
| _ -> raise (Eval_error "join: 2 args"));
|
||||
register "replace" (fun args ->
|
||||
match args with
|
||||
| [String s; String old_s; String new_s] ->
|
||||
let ol = String.length old_s in
|
||||
if ol = 0 then String s
|
||||
else begin
|
||||
let buf = Buffer.create (String.length s) in
|
||||
let rec go i =
|
||||
if i >= String.length s then ()
|
||||
else if i + ol <= String.length s && String.sub s i ol = old_s then begin
|
||||
Buffer.add_string buf new_s;
|
||||
go (i + ol)
|
||||
end else begin
|
||||
Buffer.add_char buf s.[i];
|
||||
go (i + 1)
|
||||
end
|
||||
in go 0;
|
||||
String (Buffer.contents buf)
|
||||
end
|
||||
| _ -> raise (Eval_error "replace: 3 string args"));
|
||||
register "char-from-code" (fun args ->
|
||||
match args with
|
||||
| [Number n] ->
|
||||
let buf = Buffer.create 4 in
|
||||
Buffer.add_utf_8_uchar buf (Uchar.of_int (int_of_float n));
|
||||
String (Buffer.contents buf)
|
||||
| _ -> raise (Eval_error "char-from-code: 1 arg"));
|
||||
|
||||
(* === Collections === *)
|
||||
register "list" (fun args -> ListRef (ref args));
|
||||
register "len" (fun args ->
|
||||
match args 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
|
||||
| _ -> raise (Eval_error "len: 1 arg"));
|
||||
register "first" (fun args ->
|
||||
match args with
|
||||
| [List (x :: _)] | [ListRef { contents = x :: _ }] -> x
|
||||
| [List []] | [ListRef { contents = [] }] -> Nil | [Nil] -> Nil
|
||||
| _ -> raise (Eval_error "first: 1 list arg"));
|
||||
register "rest" (fun args ->
|
||||
match args with
|
||||
| [List (_ :: xs)] | [ListRef { contents = _ :: xs }] -> List xs
|
||||
| [List []] | [ListRef { contents = [] }] -> List [] | [Nil] -> List []
|
||||
| _ -> raise (Eval_error "rest: 1 list arg"));
|
||||
register "last" (fun args ->
|
||||
match args with
|
||||
| [List l] | [ListRef { contents = l }] ->
|
||||
(match List.rev l with x :: _ -> x | [] -> Nil)
|
||||
| _ -> raise (Eval_error "last: 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"));
|
||||
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);
|
||||
register "reverse" (fun args ->
|
||||
match args with
|
||||
| [List l] | [ListRef { contents = l }] -> List (List.rev l)
|
||||
| _ -> raise (Eval_error "reverse: 1 list"));
|
||||
register "flatten" (fun args ->
|
||||
let rec flat = function
|
||||
| List items | ListRef { contents = items } -> List.concat_map flat items
|
||||
| x -> [x]
|
||||
in
|
||||
match args with
|
||||
| [List l] | [ListRef { contents = l }] -> List (List.concat_map flat l)
|
||||
| _ -> raise (Eval_error "flatten: 1 list"));
|
||||
register "concat" (fun args -> List (List.concat_map as_list args));
|
||||
register "contains?" (fun args ->
|
||||
match args with
|
||||
| [List l; item] | [ListRef { contents = l }; item] -> Bool (List.mem item l)
|
||||
| [String s; String sub] ->
|
||||
let rec find i =
|
||||
if i + String.length sub > String.length s then false
|
||||
else if String.sub s i (String.length sub) = sub then true
|
||||
else find (i + 1)
|
||||
in Bool (find 0)
|
||||
| _ -> raise (Eval_error "contains?: 2 args"));
|
||||
register "range" (fun args ->
|
||||
match args with
|
||||
| [Number stop] ->
|
||||
let n = int_of_float stop in
|
||||
List (List.init (max 0 n) (fun i -> Number (float_of_int i)))
|
||||
| [Number start; Number stop] ->
|
||||
let s = int_of_float start and e = int_of_float stop in
|
||||
let len = max 0 (e - s) in
|
||||
List (List.init len (fun i -> Number (float_of_int (s + i))))
|
||||
| [Number start; Number stop; Number step] ->
|
||||
let s = start and e = stop and st = step in
|
||||
if st = 0.0 then List []
|
||||
else
|
||||
let items = ref [] in
|
||||
let i = ref s in
|
||||
if st > 0.0 then
|
||||
(while !i < e do items := Number !i :: !items; i := !i +. st done)
|
||||
else
|
||||
(while !i > e do items := Number !i :: !items; i := !i +. st done);
|
||||
List (List.rev !items)
|
||||
| _ -> raise (Eval_error "range: 1-3 args"));
|
||||
register "slice" (fun args ->
|
||||
match args with
|
||||
| [(List l | ListRef { contents = l }); Number start] ->
|
||||
let i = max 0 (int_of_float start) in
|
||||
let rec drop n = function _ :: xs when n > 0 -> drop (n-1) xs | l -> l in
|
||||
List (drop i l)
|
||||
| [(List l | ListRef { contents = l }); Number start; Number end_] ->
|
||||
let i = max 0 (int_of_float start) and j = int_of_float end_ in
|
||||
let len = List.length l in
|
||||
let j = min j len in
|
||||
let rec take_range idx = function
|
||||
| [] -> []
|
||||
| x :: xs ->
|
||||
if idx >= j then []
|
||||
else if idx >= i then x :: take_range (idx+1) xs
|
||||
else take_range (idx+1) xs
|
||||
in List (take_range 0 l)
|
||||
| [String s; Number start] ->
|
||||
let i = max 0 (int_of_float start) in
|
||||
String (String.sub s i (max 0 (String.length s - i)))
|
||||
| [String s; Number start; Number end_] ->
|
||||
let i = max 0 (int_of_float start) and j = int_of_float end_ in
|
||||
let sl = String.length s in
|
||||
let j = min j sl in
|
||||
String (String.sub s i (max 0 (j - i)))
|
||||
| _ -> raise (Eval_error "slice: 2-3 args"));
|
||||
register "sort" (fun args ->
|
||||
match args with
|
||||
| [List l] | [ListRef { contents = l }] -> List (List.sort compare l)
|
||||
| _ -> raise (Eval_error "sort: 1 list"));
|
||||
register "zip" (fun args ->
|
||||
match args with
|
||||
| [a; b] ->
|
||||
let la = as_list a and lb = as_list b in
|
||||
let rec go l1 l2 acc = match l1, l2 with
|
||||
| x :: xs, y :: ys -> go xs ys (List [x; y] :: acc)
|
||||
| _ -> List.rev acc
|
||||
in List (go la lb [])
|
||||
| _ -> raise (Eval_error "zip: 2 lists"));
|
||||
register "zip-pairs" (fun args ->
|
||||
match args with
|
||||
| [v] ->
|
||||
let l = as_list v in
|
||||
let rec go = function
|
||||
| a :: b :: rest -> List [a; b] :: go rest
|
||||
| _ -> []
|
||||
in List (go l)
|
||||
| _ -> raise (Eval_error "zip-pairs: 1 list"));
|
||||
register "take" (fun args ->
|
||||
match args with
|
||||
| [(List l | ListRef { contents = l }); Number n] ->
|
||||
let rec take_n i = function
|
||||
| x :: xs when i > 0 -> x :: take_n (i-1) xs
|
||||
| _ -> []
|
||||
in List (take_n (int_of_float n) l)
|
||||
| _ -> raise (Eval_error "take: list and number"));
|
||||
register "drop" (fun args ->
|
||||
match args with
|
||||
| [(List l | ListRef { contents = l }); Number n] ->
|
||||
let rec drop_n i = function
|
||||
| _ :: xs when i > 0 -> drop_n (i-1) xs
|
||||
| l -> l
|
||||
in List (drop_n (int_of_float n) l)
|
||||
| _ -> raise (Eval_error "drop: list and number"));
|
||||
register "chunk-every" (fun args ->
|
||||
match args with
|
||||
| [(List l | ListRef { contents = l }); Number n] ->
|
||||
let size = int_of_float n in
|
||||
let rec go = function
|
||||
| [] -> []
|
||||
| l ->
|
||||
let rec take_n i = function
|
||||
| x :: xs when i > 0 -> x :: take_n (i-1) xs
|
||||
| _ -> []
|
||||
in
|
||||
let rec drop_n i = function
|
||||
| _ :: xs when i > 0 -> drop_n (i-1) xs
|
||||
| l -> l
|
||||
in
|
||||
List (take_n size l) :: go (drop_n size l)
|
||||
in List (go l)
|
||||
| _ -> raise (Eval_error "chunk-every: list and number"));
|
||||
register "unique" (fun args ->
|
||||
match args with
|
||||
| [(List l | ListRef { contents = l })] ->
|
||||
let seen = Hashtbl.create 16 in
|
||||
let result = List.filter (fun x ->
|
||||
let key = inspect x in
|
||||
if Hashtbl.mem seen key then false
|
||||
else (Hashtbl.replace seen key true; true)
|
||||
) l in
|
||||
List result
|
||||
| _ -> raise (Eval_error "unique: 1 list"));
|
||||
|
||||
(* === Dict === *)
|
||||
register "dict" (fun args ->
|
||||
let d = make_dict () in
|
||||
let rec go = function
|
||||
| [] -> Dict d
|
||||
| Keyword k :: v :: rest -> dict_set d k v; go rest
|
||||
| String k :: v :: rest -> dict_set d k v; go rest
|
||||
| _ -> raise (Eval_error "dict: pairs of key value")
|
||||
in go args);
|
||||
register "get" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k] -> dict_get d k
|
||||
| [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"));
|
||||
register "has-key?" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k] -> Bool (dict_has d k)
|
||||
| [Dict d; Keyword k] -> Bool (dict_has d k)
|
||||
| _ -> raise (Eval_error "has-key?: dict and key"));
|
||||
register "assoc" (fun args ->
|
||||
match args with
|
||||
| Dict d :: rest ->
|
||||
let d2 = Hashtbl.copy d in
|
||||
let rec go = function
|
||||
| [] -> Dict d2
|
||||
| String k :: v :: rest -> Hashtbl.replace d2 k v; go rest
|
||||
| Keyword k :: v :: rest -> Hashtbl.replace d2 k v; go rest
|
||||
| _ -> raise (Eval_error "assoc: pairs")
|
||||
in go rest
|
||||
| _ -> raise (Eval_error "assoc: dict + pairs"));
|
||||
register "dissoc" (fun args ->
|
||||
match args with
|
||||
| Dict d :: keys ->
|
||||
let d2 = Hashtbl.copy d in
|
||||
List.iter (fun k -> Hashtbl.remove d2 (to_string k)) keys;
|
||||
Dict d2
|
||||
| _ -> raise (Eval_error "dissoc: dict + keys"));
|
||||
register "merge" (fun args ->
|
||||
let d = make_dict () in
|
||||
List.iter (function
|
||||
| Dict src -> Hashtbl.iter (fun k v -> Hashtbl.replace d k v) src
|
||||
| _ -> raise (Eval_error "merge: all args must be dicts")
|
||||
) args;
|
||||
Dict d);
|
||||
register "keys" (fun args ->
|
||||
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 "dict-set!" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k; v] -> dict_set d k v; v
|
||||
| [Dict d; Keyword k; v] -> dict_set d k v; v
|
||||
| _ -> raise (Eval_error "dict-set!: dict key val"));
|
||||
register "dict-get" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k] -> dict_get d k
|
||||
| [Dict d; Keyword k] -> dict_get d k
|
||||
| _ -> raise (Eval_error "dict-get: dict and key"));
|
||||
register "dict-has?" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k] -> Bool (dict_has d k)
|
||||
| _ -> raise (Eval_error "dict-has?: dict and key"));
|
||||
register "dict-delete!" (fun args ->
|
||||
match args with
|
||||
| [Dict d; String k] -> dict_delete d k; Nil
|
||||
| _ -> raise (Eval_error "dict-delete!: dict and key"));
|
||||
|
||||
(* === Misc === *)
|
||||
register "type-of" (fun args ->
|
||||
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 "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
|
||||
| _ -> 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"));
|
||||
register "make-spread" (fun args ->
|
||||
match args with
|
||||
| [Dict d] ->
|
||||
let pairs = Hashtbl.fold (fun k v acc -> (k, v) :: acc) d [] in
|
||||
Spread pairs
|
||||
| _ -> raise (Eval_error "make-spread: 1 dict"));
|
||||
register "spread?" (fun args ->
|
||||
match args with [Spread _] -> Bool true | [_] -> Bool false
|
||||
| _ -> raise (Eval_error "spread?: 1 arg"));
|
||||
register "spread-attrs" (fun args ->
|
||||
match args with
|
||||
| [Spread pairs] ->
|
||||
let d = make_dict () in
|
||||
List.iter (fun (k, v) -> dict_set d k v) pairs;
|
||||
Dict d
|
||||
| _ -> raise (Eval_error "spread-attrs: 1 spread"));
|
||||
()
|
||||
539
hosts/ocaml/lib/sx_ref.ml
Normal file
539
hosts/ocaml/lib/sx_ref.ml
Normal file
File diff suppressed because one or more lines are too long
444
hosts/ocaml/lib/sx_render.ml
Normal file
444
hosts/ocaml/lib/sx_render.ml
Normal file
@@ -0,0 +1,444 @@
|
||||
(** HTML renderer for SX values.
|
||||
|
||||
Extracted from run_tests.ml — renders an SX expression tree to an
|
||||
HTML string, expanding components and macros along the way.
|
||||
|
||||
Depends on [Sx_ref.eval_expr] for evaluating sub-expressions
|
||||
during rendering (keyword arg values, conditionals, etc.). *)
|
||||
|
||||
open Sx_types
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Tag / attribute registries *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let html_tags = [
|
||||
"html"; "head"; "body"; "title"; "meta"; "link"; "script"; "style"; "noscript";
|
||||
"header"; "nav"; "main"; "section"; "article"; "aside"; "footer";
|
||||
"h1"; "h2"; "h3"; "h4"; "h5"; "h6"; "hgroup";
|
||||
"div"; "p"; "blockquote"; "pre"; "figure"; "figcaption"; "address"; "hr";
|
||||
"ul"; "ol"; "li"; "dl"; "dt"; "dd"; "menu";
|
||||
"a"; "span"; "em"; "strong"; "small"; "b"; "i"; "u"; "s"; "sub"; "sup";
|
||||
"mark"; "del"; "ins"; "q"; "cite"; "dfn"; "abbr"; "code"; "var"; "samp";
|
||||
"kbd"; "data"; "time"; "ruby"; "rt"; "rp"; "bdi"; "bdo"; "wbr"; "br";
|
||||
"table"; "thead"; "tbody"; "tfoot"; "tr"; "th"; "td"; "caption"; "colgroup"; "col";
|
||||
"form"; "input"; "textarea"; "select"; "option"; "optgroup"; "button"; "label";
|
||||
"fieldset"; "legend"; "datalist"; "output"; "progress"; "meter";
|
||||
"details"; "summary"; "dialog";
|
||||
"img"; "video"; "audio"; "source"; "picture"; "canvas"; "iframe"; "embed"; "object"; "param";
|
||||
"svg"; "path"; "circle"; "rect"; "line"; "polyline"; "polygon"; "ellipse";
|
||||
"g"; "defs"; "use"; "text"; "tspan"; "clipPath"; "mask"; "pattern";
|
||||
"linearGradient"; "radialGradient"; "stop"; "filter"; "feBlend"; "feFlood";
|
||||
"feGaussianBlur"; "feOffset"; "feMerge"; "feMergeNode"; "feComposite";
|
||||
"template"; "slot";
|
||||
]
|
||||
|
||||
let void_elements = [
|
||||
"area"; "base"; "br"; "col"; "embed"; "hr"; "img"; "input";
|
||||
"link"; "meta"; "param"; "source"; "track"; "wbr"
|
||||
]
|
||||
|
||||
let boolean_attrs = [
|
||||
"async"; "autofocus"; "autoplay"; "checked"; "controls"; "default";
|
||||
"defer"; "disabled"; "formnovalidate"; "hidden"; "inert"; "ismap";
|
||||
"loop"; "multiple"; "muted"; "nomodule"; "novalidate"; "open";
|
||||
"playsinline"; "readonly"; "required"; "reversed"; "selected"
|
||||
]
|
||||
|
||||
let is_html_tag name = List.mem name html_tags
|
||||
let is_void name = List.mem name void_elements
|
||||
let is_boolean_attr name = List.mem name boolean_attrs
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* HTML escaping *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let escape_html s =
|
||||
let buf = Buffer.create (String.length s) in
|
||||
String.iter (function
|
||||
| '&' -> Buffer.add_string buf "&"
|
||||
| '<' -> Buffer.add_string buf "<"
|
||||
| '>' -> Buffer.add_string buf ">"
|
||||
| '"' -> Buffer.add_string buf """
|
||||
| c -> Buffer.add_char buf c) s;
|
||||
Buffer.contents buf
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Attribute rendering *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let render_attrs attrs =
|
||||
let buf = Buffer.create 64 in
|
||||
Hashtbl.iter (fun k v ->
|
||||
if is_boolean_attr k then begin
|
||||
if sx_truthy v then begin
|
||||
Buffer.add_char buf ' ';
|
||||
Buffer.add_string buf k
|
||||
end
|
||||
end else if not (is_nil v) then begin
|
||||
Buffer.add_char buf ' ';
|
||||
Buffer.add_string buf k;
|
||||
Buffer.add_string buf "=\"";
|
||||
Buffer.add_string buf (escape_html (value_to_string v));
|
||||
Buffer.add_char buf '"'
|
||||
end) attrs;
|
||||
Buffer.contents buf
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* HTML renderer *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
(* Forward ref — resolved at setup time *)
|
||||
let render_to_html_ref : (value -> env -> string) ref =
|
||||
ref (fun _expr _env -> "")
|
||||
|
||||
let render_to_html expr env = !render_to_html_ref expr env
|
||||
|
||||
let render_children children env =
|
||||
String.concat "" (List.map (fun c -> render_to_html c env) children)
|
||||
|
||||
(** Parse keyword attrs and positional children from an element call's args.
|
||||
Attrs are evaluated; children are returned UNEVALUATED for render dispatch. *)
|
||||
let parse_element_args args env =
|
||||
let attrs = Hashtbl.create 8 in
|
||||
let children = ref [] in
|
||||
let skip = ref false in
|
||||
let len = List.length args in
|
||||
List.iteri (fun idx arg ->
|
||||
if !skip then skip := false
|
||||
else match arg with
|
||||
| Keyword k when idx + 1 < len ->
|
||||
let v = Sx_ref.eval_expr (List.nth args (idx + 1)) (Env env) in
|
||||
Hashtbl.replace attrs k v;
|
||||
skip := true
|
||||
| Spread pairs ->
|
||||
List.iter (fun (k, v) -> Hashtbl.replace attrs k v) pairs
|
||||
| _ ->
|
||||
children := arg :: !children
|
||||
) args;
|
||||
(attrs, List.rev !children)
|
||||
|
||||
let render_html_element tag args env =
|
||||
let (attrs, children) = parse_element_args args env in
|
||||
let attr_str = render_attrs attrs in
|
||||
if is_void tag then
|
||||
"<" ^ tag ^ attr_str ^ " />"
|
||||
else
|
||||
let content = String.concat ""
|
||||
(List.map (fun c -> render_to_html c env) children) in
|
||||
"<" ^ tag ^ attr_str ^ ">" ^ content ^ "</" ^ tag ^ ">"
|
||||
|
||||
let render_component_generic ~params ~has_children ~body ~closure args env =
|
||||
let kwargs = Hashtbl.create 8 in
|
||||
let children_exprs = ref [] in
|
||||
let skip = ref false in
|
||||
let len = List.length args in
|
||||
List.iteri (fun idx arg ->
|
||||
if !skip then skip := false
|
||||
else match arg with
|
||||
| Keyword k when idx + 1 < len ->
|
||||
let v = Sx_ref.eval_expr (List.nth args (idx + 1)) (Env env) in
|
||||
Hashtbl.replace kwargs k v;
|
||||
skip := true
|
||||
| _ ->
|
||||
children_exprs := arg :: !children_exprs
|
||||
) args;
|
||||
let children = List.rev !children_exprs in
|
||||
let local = env_merge closure env in
|
||||
List.iter (fun p ->
|
||||
let v = match Hashtbl.find_opt kwargs p with Some v -> v | None -> Nil in
|
||||
ignore (env_bind local p v)
|
||||
) params;
|
||||
if has_children then begin
|
||||
let rendered_children = String.concat ""
|
||||
(List.map (fun c -> render_to_html c env) children) in
|
||||
ignore (env_bind local "children" (RawHTML rendered_children))
|
||||
end;
|
||||
render_to_html body local
|
||||
|
||||
let render_component comp args env =
|
||||
match comp with
|
||||
| Component c ->
|
||||
render_component_generic
|
||||
~params:c.c_params ~has_children:c.c_has_children
|
||||
~body:c.c_body ~closure:c.c_closure args env
|
||||
| Island i ->
|
||||
render_component_generic
|
||||
~params:i.i_params ~has_children:i.i_has_children
|
||||
~body:i.i_body ~closure:i.i_closure args env
|
||||
| _ -> ""
|
||||
|
||||
let expand_macro (m : macro) args _env =
|
||||
let local = env_extend m.m_closure in
|
||||
let params = m.m_params 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
|
||||
| _ :: _, [] ->
|
||||
List.iter (fun p -> ignore (env_bind local p Nil)) (List.rev ps)
|
||||
in
|
||||
bind_params params args;
|
||||
Sx_ref.eval_expr m.m_body (Env local)
|
||||
|
||||
let rec do_render_to_html (expr : value) (env : env) : string =
|
||||
match expr with
|
||||
| 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
|
||||
| String s -> escape_html s
|
||||
| Keyword k -> escape_html k
|
||||
| RawHTML s -> s
|
||||
| Symbol s ->
|
||||
let v = Sx_ref.eval_expr (Symbol s) (Env env) in
|
||||
do_render_to_html v env
|
||||
| List [] | ListRef { contents = [] } -> ""
|
||||
| List (head :: args) | ListRef { contents = head :: args } ->
|
||||
render_list_to_html head args env
|
||||
| _ ->
|
||||
let v = Sx_ref.eval_expr expr (Env env) in
|
||||
do_render_to_html v env
|
||||
|
||||
and render_list_to_html head args env =
|
||||
match head with
|
||||
| Symbol "<>" ->
|
||||
render_children args env
|
||||
| Symbol tag when is_html_tag tag ->
|
||||
render_html_element tag args env
|
||||
| Symbol "if" ->
|
||||
let cond_val = Sx_ref.eval_expr (List.hd args) (Env env) in
|
||||
if sx_truthy cond_val then
|
||||
(if List.length args > 1 then do_render_to_html (List.nth args 1) env else "")
|
||||
else
|
||||
(if List.length args > 2 then do_render_to_html (List.nth args 2) env else "")
|
||||
| Symbol "when" ->
|
||||
let cond_val = Sx_ref.eval_expr (List.hd args) (Env env) in
|
||||
if sx_truthy cond_val then
|
||||
String.concat "" (List.map (fun e -> do_render_to_html e env) (List.tl args))
|
||||
else ""
|
||||
| Symbol "cond" ->
|
||||
render_cond args env
|
||||
| Symbol "case" ->
|
||||
let v = Sx_ref.eval_expr (List (head :: args)) (Env env) in
|
||||
do_render_to_html v env
|
||||
| Symbol ("let" | "let*") ->
|
||||
render_let args env
|
||||
| Symbol ("begin" | "do") ->
|
||||
let rec go = function
|
||||
| [] -> ""
|
||||
| [last] -> do_render_to_html last env
|
||||
| e :: rest ->
|
||||
ignore (Sx_ref.eval_expr e (Env env));
|
||||
go rest
|
||||
in go args
|
||||
| Symbol ("define" | "defcomp" | "defmacro" | "defisland") ->
|
||||
ignore (Sx_ref.eval_expr (List (head :: args)) (Env env));
|
||||
""
|
||||
| Symbol "map" ->
|
||||
render_map args env false
|
||||
| Symbol "map-indexed" ->
|
||||
render_map args env true
|
||||
| Symbol "filter" ->
|
||||
let v = Sx_ref.eval_expr (List (head :: args)) (Env env) in
|
||||
do_render_to_html v env
|
||||
| Symbol "for-each" ->
|
||||
render_for_each args env
|
||||
| Symbol name ->
|
||||
(try
|
||||
let v = env_get env name in
|
||||
(match v with
|
||||
| Component _ | Island _ -> render_component v args env
|
||||
| Macro m ->
|
||||
let expanded = expand_macro m args env in
|
||||
do_render_to_html expanded env
|
||||
| _ ->
|
||||
let result = Sx_ref.eval_expr (List (head :: args)) (Env env) in
|
||||
do_render_to_html result env)
|
||||
with Eval_error _ ->
|
||||
let result = Sx_ref.eval_expr (List (head :: args)) (Env env) in
|
||||
do_render_to_html result env)
|
||||
| _ ->
|
||||
let result = Sx_ref.eval_expr (List (head :: args)) (Env env) in
|
||||
do_render_to_html result env
|
||||
|
||||
and render_cond args env =
|
||||
let as_list = function List l | ListRef { contents = l } -> Some l | _ -> None in
|
||||
let is_scheme = List.for_all (fun a -> match as_list a with
|
||||
| Some items when List.length items = 2 -> true
|
||||
| _ -> false) args
|
||||
in
|
||||
if is_scheme then begin
|
||||
let rec go = function
|
||||
| [] -> ""
|
||||
| clause :: rest ->
|
||||
(match as_list clause with
|
||||
| Some [test; body] ->
|
||||
let is_else = match test with
|
||||
| Keyword "else" -> true
|
||||
| Symbol "else" | Symbol ":else" -> true
|
||||
| _ -> false
|
||||
in
|
||||
if is_else then do_render_to_html body env
|
||||
else
|
||||
let v = Sx_ref.eval_expr test (Env env) in
|
||||
if sx_truthy v then do_render_to_html body env
|
||||
else go rest
|
||||
| _ -> "")
|
||||
in go args
|
||||
end else begin
|
||||
let rec go = function
|
||||
| [] -> ""
|
||||
| [_] -> ""
|
||||
| test :: body :: rest ->
|
||||
let is_else = match test with
|
||||
| Keyword "else" -> true
|
||||
| Symbol "else" | Symbol ":else" -> true
|
||||
| _ -> false
|
||||
in
|
||||
if is_else then do_render_to_html body env
|
||||
else
|
||||
let v = Sx_ref.eval_expr test (Env env) in
|
||||
if sx_truthy v then do_render_to_html body env
|
||||
else go rest
|
||||
in go args
|
||||
end
|
||||
|
||||
and render_let args env =
|
||||
let as_list = function List l | ListRef { contents = l } -> Some l | _ -> None in
|
||||
let bindings_expr = List.hd args in
|
||||
let body = List.tl args in
|
||||
let local = env_extend env in
|
||||
let bindings = match as_list bindings_expr with Some l -> l | None -> [] in
|
||||
let is_scheme = match bindings with
|
||||
| (List _ :: _) | (ListRef _ :: _) -> true
|
||||
| _ -> false
|
||||
in
|
||||
if is_scheme then
|
||||
List.iter (fun b ->
|
||||
match as_list b with
|
||||
| Some [Symbol name; expr] | Some [String name; expr] ->
|
||||
let v = Sx_ref.eval_expr expr (Env local) in
|
||||
ignore (env_bind local name v)
|
||||
| _ -> ()
|
||||
) bindings
|
||||
else begin
|
||||
let rec go = function
|
||||
| [] -> ()
|
||||
| (Symbol name) :: expr :: rest | (String name) :: expr :: rest ->
|
||||
let v = Sx_ref.eval_expr expr (Env local) in
|
||||
ignore (env_bind local name v);
|
||||
go rest
|
||||
| _ -> ()
|
||||
in go bindings
|
||||
end;
|
||||
let rec render_body = function
|
||||
| [] -> ""
|
||||
| [last] -> do_render_to_html last local
|
||||
| e :: rest ->
|
||||
ignore (Sx_ref.eval_expr e (Env local));
|
||||
render_body rest
|
||||
in render_body body
|
||||
|
||||
and render_map args env indexed =
|
||||
let (fn_val, coll_val) = match args with
|
||||
| [a; b] ->
|
||||
let va = Sx_ref.eval_expr a (Env env) in
|
||||
let vb = Sx_ref.eval_expr b (Env env) in
|
||||
(match va, vb with
|
||||
| (Lambda _ | NativeFn _), _ -> (va, vb)
|
||||
| _, (Lambda _ | NativeFn _) -> (vb, va)
|
||||
| _ -> (va, vb))
|
||||
| _ -> (Nil, Nil)
|
||||
in
|
||||
let items = match coll_val with List l | ListRef { contents = l } -> l | _ -> [] in
|
||||
String.concat "" (List.mapi (fun i item ->
|
||||
let call_args = if indexed then [Number (float_of_int i); item] else [item] in
|
||||
match fn_val with
|
||||
| Lambda l ->
|
||||
let local = env_extend l.l_closure in
|
||||
List.iter2 (fun p a -> ignore (env_bind local p a))
|
||||
l.l_params call_args;
|
||||
do_render_to_html l.l_body local
|
||||
| _ ->
|
||||
let result = Sx_runtime.sx_call fn_val call_args in
|
||||
do_render_to_html result env
|
||||
) items)
|
||||
|
||||
and render_for_each args env =
|
||||
let (fn_val, coll_val) = match args with
|
||||
| [a; b] ->
|
||||
let va = Sx_ref.eval_expr a (Env env) in
|
||||
let vb = Sx_ref.eval_expr b (Env env) in
|
||||
(match va, vb with
|
||||
| (Lambda _ | NativeFn _), _ -> (va, vb)
|
||||
| _, (Lambda _ | NativeFn _) -> (vb, va)
|
||||
| _ -> (va, vb))
|
||||
| _ -> (Nil, Nil)
|
||||
in
|
||||
let items = match coll_val with List l | ListRef { contents = l } -> l | _ -> [] in
|
||||
String.concat "" (List.map (fun item ->
|
||||
match fn_val with
|
||||
| Lambda l ->
|
||||
let local = env_extend l.l_closure in
|
||||
List.iter2 (fun p a -> ignore (env_bind local p a))
|
||||
l.l_params [item];
|
||||
do_render_to_html l.l_body local
|
||||
| _ ->
|
||||
let result = Sx_runtime.sx_call fn_val [item] in
|
||||
do_render_to_html result env
|
||||
) items)
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Setup — bind render primitives in an env and wire up the ref *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
let setup_render_env env =
|
||||
render_to_html_ref := do_render_to_html;
|
||||
|
||||
let bind name fn =
|
||||
ignore (env_bind env name (NativeFn (name, fn)))
|
||||
in
|
||||
|
||||
bind "render-html" (fun args ->
|
||||
match args with
|
||||
| [String src] ->
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let expr = match exprs with
|
||||
| [e] -> e
|
||||
| [] -> Nil
|
||||
| _ -> List (Symbol "do" :: exprs)
|
||||
in
|
||||
String (render_to_html expr env)
|
||||
| [expr] ->
|
||||
String (render_to_html expr env)
|
||||
| [expr; Env e] ->
|
||||
String (render_to_html expr e)
|
||||
| _ -> String "");
|
||||
|
||||
bind "render-to-html" (fun args ->
|
||||
match args with
|
||||
| [String src] ->
|
||||
let exprs = Sx_parser.parse_all src in
|
||||
let expr = match exprs with
|
||||
| [e] -> e
|
||||
| [] -> Nil
|
||||
| _ -> List (Symbol "do" :: exprs)
|
||||
in
|
||||
String (render_to_html expr env)
|
||||
| [expr] ->
|
||||
String (render_to_html expr env)
|
||||
| [expr; Env e] ->
|
||||
String (render_to_html expr e)
|
||||
| _ -> String "")
|
||||
470
hosts/ocaml/lib/sx_runtime.ml
Normal file
470
hosts/ocaml/lib/sx_runtime.ml
Normal file
@@ -0,0 +1,470 @@
|
||||
(** Runtime helpers for transpiled code.
|
||||
|
||||
These bridge the gap between the transpiler's output and the
|
||||
foundation types/primitives. The transpiled evaluator calls these
|
||||
functions directly. *)
|
||||
|
||||
open Sx_types
|
||||
|
||||
(** Call a registered primitive by name. *)
|
||||
let prim_call name args =
|
||||
match Hashtbl.find_opt Sx_primitives.primitives name with
|
||||
| Some f -> f args
|
||||
| None -> raise (Eval_error ("Unknown primitive: " ^ name))
|
||||
|
||||
(** Convert any SX value to an OCaml string (internal). *)
|
||||
let value_to_str = function
|
||||
| String s -> s
|
||||
| Number n ->
|
||||
if Float.is_integer n then string_of_int (int_of_float n)
|
||||
else Printf.sprintf "%g" n
|
||||
| Bool true -> "true"
|
||||
| Bool false -> "false"
|
||||
| Nil -> ""
|
||||
| Symbol s -> s
|
||||
| Keyword k -> k
|
||||
| v -> inspect v
|
||||
|
||||
(** sx_to_string returns a value (String) for transpiled code. *)
|
||||
let sx_to_string v = String (value_to_str v)
|
||||
|
||||
(** String concatenation helper — [sx_str] takes a list of values. *)
|
||||
let sx_str args =
|
||||
String.concat "" (List.map value_to_str args)
|
||||
|
||||
(** Convert a value to a list. *)
|
||||
let sx_to_list = function
|
||||
| List l -> l
|
||||
| ListRef r -> !r
|
||||
| Nil -> []
|
||||
| v -> raise (Eval_error ("Expected list, got " ^ type_of v))
|
||||
|
||||
(** Call an SX callable (lambda, native fn, continuation). *)
|
||||
let sx_call f args =
|
||||
match f with
|
||||
| NativeFn (_, fn) -> fn args
|
||||
| Lambda l ->
|
||||
let local = Sx_types.env_extend l.l_closure in
|
||||
List.iter2 (fun p a -> ignore (Sx_types.env_bind local p a)) l.l_params args;
|
||||
(* 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))
|
||||
|
||||
(** Apply a function to a list of args. *)
|
||||
let sx_apply f args_list =
|
||||
sx_call f (sx_to_list args_list)
|
||||
|
||||
(** Mutable append — add item to a list ref or accumulator.
|
||||
In transpiled code, lists that get appended to are mutable refs. *)
|
||||
let sx_append_b lst item =
|
||||
match lst with
|
||||
| List items -> List (items @ [item])
|
||||
| ListRef r -> r := !r @ [item]; lst (* mutate in place, return same ref *)
|
||||
| _ -> raise (Eval_error ("append!: expected list, got " ^ type_of lst))
|
||||
|
||||
(** Mutable dict-set — set key in dict, return value. *)
|
||||
let sx_dict_set_b d k v =
|
||||
match d, k with
|
||||
| Dict tbl, String key -> Hashtbl.replace tbl key v; v
|
||||
| Dict tbl, Keyword key -> Hashtbl.replace tbl key v; v
|
||||
| _ -> raise (Eval_error "dict-set!: expected dict and string key")
|
||||
|
||||
(** Get from dict or list. *)
|
||||
let get_val container key =
|
||||
match container, key with
|
||||
| Dict d, String k -> dict_get d k
|
||||
| Dict d, Keyword k -> dict_get d k
|
||||
| (List l | ListRef { contents = l }), Number n ->
|
||||
(try List.nth l (int_of_float n) with _ -> Nil)
|
||||
| _ -> raise (Eval_error ("get: unsupported " ^ type_of container ^ " / " ^ type_of key))
|
||||
|
||||
(** Register get as a primitive override — transpiled code calls (get d k). *)
|
||||
let () =
|
||||
Sx_primitives.register "get" (fun args ->
|
||||
match args with
|
||||
| [c; k] -> get_val c k
|
||||
| [c; k; default] ->
|
||||
(try
|
||||
let v = get_val c k in
|
||||
if v = Nil then default else v
|
||||
with _ -> default)
|
||||
| _ -> raise (Eval_error "get: 2-3 args"))
|
||||
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Primitive aliases — top-level functions called by transpiled code *)
|
||||
(* ====================================================================== *)
|
||||
|
||||
(** The transpiled evaluator calls primitives directly by their mangled
|
||||
OCaml name. These aliases delegate to the primitives table so the
|
||||
transpiled code compiles without needing [prim_call] everywhere. *)
|
||||
|
||||
let _prim name = match Hashtbl.find_opt Sx_primitives.primitives name with
|
||||
| Some f -> f | None -> (fun _ -> raise (Eval_error ("Missing prim: " ^ name)))
|
||||
|
||||
(* Collection ops *)
|
||||
let first args = _prim "first" [args]
|
||||
let rest args = _prim "rest" [args]
|
||||
let last args = _prim "last" [args]
|
||||
let nth coll i = _prim "nth" [coll; i]
|
||||
let cons x l = _prim "cons" [x; l]
|
||||
let append a b = _prim "append" [a; b]
|
||||
let reverse l = _prim "reverse" [l]
|
||||
let flatten l = _prim "flatten" [l]
|
||||
let concat a b = _prim "concat" [a; b]
|
||||
let slice a b = _prim "slice" [a; b]
|
||||
let len a = _prim "len" [a]
|
||||
let get a b = get_val a b
|
||||
let sort' a = _prim "sort" [a]
|
||||
let range' a = _prim "range" [a]
|
||||
let unique a = _prim "unique" [a]
|
||||
let zip a b = _prim "zip" [a; b]
|
||||
let zip_pairs a = _prim "zip-pairs" [a]
|
||||
let take a b = _prim "take" [a; b]
|
||||
let drop a b = _prim "drop" [a; b]
|
||||
let chunk_every a b = _prim "chunk-every" [a; b]
|
||||
|
||||
(* Predicates *)
|
||||
let empty_p a = _prim "empty?" [a]
|
||||
let nil_p a = _prim "nil?" [a]
|
||||
let number_p a = _prim "number?" [a]
|
||||
let string_p a = _prim "string?" [a]
|
||||
let boolean_p a = _prim "boolean?" [a]
|
||||
let list_p a = _prim "list?" [a]
|
||||
let dict_p a = _prim "dict?" [a]
|
||||
let symbol_p a = _prim "symbol?" [a]
|
||||
let keyword_p a = _prim "keyword?" [a]
|
||||
let contains_p a b = _prim "contains?" [a; b]
|
||||
let has_key_p a b = _prim "has-key?" [a; b]
|
||||
let starts_with_p a b = _prim "starts-with?" [a; b]
|
||||
let ends_with_p a b = _prim "ends-with?" [a; b]
|
||||
let string_contains_p a b = _prim "string-contains?" [a; b]
|
||||
let odd_p a = _prim "odd?" [a]
|
||||
let even_p a = _prim "even?" [a]
|
||||
let zero_p a = _prim "zero?" [a]
|
||||
|
||||
(* String ops *)
|
||||
let str' args = String (sx_str args)
|
||||
let upper a = _prim "upper" [a]
|
||||
let upcase a = _prim "upcase" [a]
|
||||
let lower a = _prim "lower" [a]
|
||||
let downcase a = _prim "downcase" [a]
|
||||
let trim a = _prim "trim" [a]
|
||||
let split a b = _prim "split" [a; b]
|
||||
let join a b = _prim "join" [a; b]
|
||||
let replace a b c = _prim "replace" [a; b; c]
|
||||
let index_of a b = _prim "index-of" [a; b]
|
||||
let substring a b c = _prim "substring" [a; b; c]
|
||||
let string_length a = _prim "string-length" [a]
|
||||
let char_from_code a = _prim "char-from-code" [a]
|
||||
|
||||
(* Dict ops *)
|
||||
let assoc d k v = _prim "assoc" [d; k; v]
|
||||
let dissoc d k = _prim "dissoc" [d; k]
|
||||
let merge' a b = _prim "merge" [a; b]
|
||||
let keys a = _prim "keys" [a]
|
||||
let vals a = _prim "vals" [a]
|
||||
let dict_set a b c = _prim "dict-set!" [a; b; c]
|
||||
let dict_get a b = _prim "dict-get" [a; b]
|
||||
let dict_has_p a b = _prim "dict-has?" [a; b]
|
||||
let dict_delete a b = _prim "dict-delete!" [a; b]
|
||||
|
||||
(* Math *)
|
||||
let abs' a = _prim "abs" [a]
|
||||
let sqrt' a = _prim "sqrt" [a]
|
||||
let pow' a b = _prim "pow" [a; b]
|
||||
let floor' a = _prim "floor" [a]
|
||||
let ceil' a = _prim "ceil" [a]
|
||||
let round' a = _prim "round" [a]
|
||||
let min' a b = _prim "min" [a; b]
|
||||
let max' a b = _prim "max" [a; b]
|
||||
let clamp a b c = _prim "clamp" [a; b; c]
|
||||
let parse_int a = _prim "parse-int" [a]
|
||||
let parse_float a = _prim "parse-float" [a]
|
||||
|
||||
(* Misc *)
|
||||
let error msg = raise (Eval_error (value_to_str msg))
|
||||
|
||||
(* inspect wrapper — returns String value instead of OCaml string *)
|
||||
let inspect v = String (Sx_types.inspect v)
|
||||
let apply' f args = sx_apply f args
|
||||
let identical_p a b = _prim "identical?" [a; b]
|
||||
let _is_spread_prim a = _prim "spread?" [a]
|
||||
let spread_attrs a = _prim "spread-attrs" [a]
|
||||
let make_spread a = _prim "make-spread" [a]
|
||||
|
||||
(* Scope stacks — thread-local stacks keyed by name string.
|
||||
collect!/collected implement accumulator scopes.
|
||||
emit!/emitted implement event emission scopes.
|
||||
context reads the top of a named scope stack. *)
|
||||
let _scope_stacks : (string, value list) Hashtbl.t = Hashtbl.create 8
|
||||
|
||||
let sx_collect name value =
|
||||
let key = value_to_str name in
|
||||
let stack = match Hashtbl.find_opt _scope_stacks key with
|
||||
| Some s -> s | None -> [] in
|
||||
(* Push value onto the top list of the stack *)
|
||||
(match stack with
|
||||
| List items :: rest ->
|
||||
Hashtbl.replace _scope_stacks key (List (items @ [value]) :: rest)
|
||||
| _ ->
|
||||
Hashtbl.replace _scope_stacks key (List [value] :: stack));
|
||||
Nil
|
||||
|
||||
let sx_collected name =
|
||||
let key = value_to_str name in
|
||||
match Hashtbl.find_opt _scope_stacks key with
|
||||
| Some (List items :: _) -> List items
|
||||
| _ -> List []
|
||||
|
||||
let sx_clear_collected name =
|
||||
let key = value_to_str name in
|
||||
(match Hashtbl.find_opt _scope_stacks key with
|
||||
| Some (_ :: rest) -> Hashtbl.replace _scope_stacks key (List [] :: rest)
|
||||
| _ -> ());
|
||||
Nil
|
||||
|
||||
let sx_emit name value =
|
||||
let key = value_to_str name in
|
||||
let stack = match Hashtbl.find_opt _scope_stacks key with
|
||||
| Some s -> s | None -> [] in
|
||||
(match stack with
|
||||
| List items :: rest ->
|
||||
Hashtbl.replace _scope_stacks key (List (items @ [value]) :: rest)
|
||||
| _ ->
|
||||
Hashtbl.replace _scope_stacks key (List [value] :: stack));
|
||||
Nil
|
||||
|
||||
let sx_emitted name =
|
||||
let key = value_to_str name in
|
||||
match Hashtbl.find_opt _scope_stacks key with
|
||||
| Some (List items :: _) -> List items
|
||||
| _ -> List []
|
||||
|
||||
let sx_context name default =
|
||||
let key = value_to_str name in
|
||||
match Hashtbl.find_opt _scope_stacks key with
|
||||
| Some (v :: _) -> v
|
||||
| _ -> default
|
||||
|
||||
(* Trampoline — forward-declared in sx_ref.ml, delegates to CEK eval_expr *)
|
||||
(* This is a stub; the real trampoline is wired up in sx_ref.ml after eval_expr is defined *)
|
||||
let trampoline v = v
|
||||
|
||||
(* Value-returning type predicates — the transpiled code passes these through
|
||||
sx_truthy, so they need to return Bool, not OCaml bool. *)
|
||||
(* type_of returns value, not string *)
|
||||
let type_of v = String (Sx_types.type_of v)
|
||||
|
||||
(* Env operations — accept Env-wrapped values and value keys.
|
||||
The transpiled CEK machine stores envs in dicts as Env values. *)
|
||||
let unwrap_env = function
|
||||
| Env e -> e
|
||||
| _ -> raise (Eval_error "Expected env")
|
||||
|
||||
let env_has e name = Bool (Sx_types.env_has (unwrap_env e) (value_to_str name))
|
||||
let env_get e name = Sx_types.env_get (unwrap_env e) (value_to_str name)
|
||||
let env_bind e name v = Sx_types.env_bind (unwrap_env e) (value_to_str name) v
|
||||
let env_set e name v = Sx_types.env_set (unwrap_env e) (value_to_str name) v
|
||||
|
||||
let make_env () = Env (Sx_types.make_env ())
|
||||
let env_extend e = Env (Sx_types.env_extend (unwrap_env e))
|
||||
let env_merge a b = Env (Sx_types.env_merge (unwrap_env a) (unwrap_env b))
|
||||
|
||||
(* set_lambda_name wrapper — accepts value, extracts string *)
|
||||
let set_lambda_name l n = Sx_types.set_lambda_name l (value_to_str n)
|
||||
|
||||
let is_nil v = Bool (Sx_types.is_nil v)
|
||||
let is_thunk v = Bool (Sx_types.is_thunk v)
|
||||
let is_lambda v = Bool (Sx_types.is_lambda v)
|
||||
let is_component v = Bool (Sx_types.is_component v)
|
||||
let is_island v = Bool (Sx_types.is_island v)
|
||||
let is_macro v = Bool (Sx_types.is_macro v)
|
||||
let is_signal v = Bool (Sx_types.is_signal v)
|
||||
let is_callable v = Bool (Sx_types.is_callable v)
|
||||
let is_identical a b = Bool (a == b)
|
||||
let is_primitive name = Bool (Sx_primitives.is_primitive (value_to_str name))
|
||||
let get_primitive name = Sx_primitives.get_primitive (value_to_str name)
|
||||
let is_spread v = match v with Spread _ -> Bool true | _ -> Bool false
|
||||
|
||||
(* Stubs for functions defined in sx_ref.ml — resolved at link time *)
|
||||
(* These are forward-declared here; sx_ref.ml defines the actual implementations *)
|
||||
|
||||
(* strip-prefix *)
|
||||
(* Stubs for evaluator functions — defined in sx_ref.ml but
|
||||
sometimes referenced before their definition via forward calls.
|
||||
These get overridden by the actual transpiled definitions. *)
|
||||
|
||||
let map_indexed fn coll =
|
||||
List (List.mapi (fun i x -> sx_call fn [Number (float_of_int i); x]) (sx_to_list coll))
|
||||
|
||||
let map_dict fn d =
|
||||
match d with
|
||||
| Dict tbl ->
|
||||
let result = Hashtbl.create (Hashtbl.length tbl) in
|
||||
Hashtbl.iter (fun k v -> Hashtbl.replace result k (sx_call fn [String k; v])) tbl;
|
||||
Dict result
|
||||
| _ -> raise (Eval_error "map-dict: expected dict")
|
||||
|
||||
let for_each fn coll =
|
||||
List.iter (fun x -> ignore (sx_call fn [x])) (sx_to_list coll);
|
||||
Nil
|
||||
|
||||
let for_each_indexed fn coll =
|
||||
List.iteri (fun i x -> ignore (sx_call fn [Number (float_of_int i); x])) (sx_to_list coll);
|
||||
Nil
|
||||
|
||||
(* Continuation support *)
|
||||
let continuation_p v = match v with Continuation (_, _) -> Bool true | _ -> Bool false
|
||||
|
||||
let make_cek_continuation captured rest_kont =
|
||||
let data = Hashtbl.create 2 in
|
||||
Hashtbl.replace data "captured" captured;
|
||||
Hashtbl.replace data "rest-kont" rest_kont;
|
||||
Continuation ((fun v -> v), Some data)
|
||||
|
||||
let continuation_data v = match v with
|
||||
| Continuation (_, Some d) -> Dict d
|
||||
| Continuation (_, None) -> Dict (Hashtbl.create 0)
|
||||
| _ -> raise (Eval_error "not a continuation")
|
||||
|
||||
(* Dynamic wind — simplified for OCaml (no async) *)
|
||||
let dynamic_wind_call before body after _env =
|
||||
ignore (sx_call before []);
|
||||
let result = sx_call body [] in
|
||||
ignore (sx_call after []);
|
||||
result
|
||||
|
||||
(* Scope stack stubs — delegated to primitives when available *)
|
||||
let scope_push name value =
|
||||
let key = value_to_str name in
|
||||
let stack = match Hashtbl.find_opt _scope_stacks key with
|
||||
| Some s -> s | None -> [] in
|
||||
Hashtbl.replace _scope_stacks key (value :: stack);
|
||||
Nil
|
||||
|
||||
let scope_pop name =
|
||||
let key = value_to_str name in
|
||||
(match Hashtbl.find_opt _scope_stacks key with
|
||||
| Some (_ :: rest) -> Hashtbl.replace _scope_stacks key rest
|
||||
| _ -> ());
|
||||
Nil
|
||||
|
||||
let provide_push name value = scope_push name value
|
||||
let provide_pop name = scope_pop name
|
||||
|
||||
(* Render mode — mutable refs so browser entry point can wire up the renderer *)
|
||||
let _render_active_p_fn : (unit -> value) ref = ref (fun () -> Bool false)
|
||||
let _render_expr_fn : (value -> value -> value) ref = ref (fun _expr _env -> Nil)
|
||||
let _is_render_expr_fn : (value -> value) ref = ref (fun _expr -> Bool false)
|
||||
|
||||
let render_active_p () = !_render_active_p_fn ()
|
||||
let render_expr expr env = !_render_expr_fn expr env
|
||||
let is_render_expr expr = !_is_render_expr_fn expr
|
||||
|
||||
(* Signal accessors — handle both native Signal type and dict-based signals
|
||||
from web/signals.sx which use {__signal: true, value: ..., subscribers: ..., deps: ...} *)
|
||||
let is_dict_signal d = Hashtbl.mem d "__signal"
|
||||
|
||||
let signal_value s = match s with
|
||||
| Signal sig' -> sig'.s_value
|
||||
| Dict d when is_dict_signal d -> Sx_types.dict_get d "value"
|
||||
| _ -> raise (Eval_error ("not a signal: " ^ Sx_types.type_of s))
|
||||
|
||||
let signal_set_value s v = match s with
|
||||
| Signal sig' -> sig'.s_value <- v; v
|
||||
| Dict d when is_dict_signal d -> Hashtbl.replace d "value" v; v
|
||||
| _ -> raise (Eval_error "not a signal")
|
||||
|
||||
let signal_subscribers s = match s with
|
||||
| Signal sig' -> List (List.map (fun _ -> Nil) sig'.s_subscribers)
|
||||
| Dict d when is_dict_signal d -> Sx_types.dict_get d "subscribers"
|
||||
| _ -> List []
|
||||
|
||||
(* These use Obj.magic to accept both SX values and OCaml closures.
|
||||
The transpiler generates bare (fun () -> ...) for reactive subscribers
|
||||
but signal_add_sub_b expects value. This is a known transpiler limitation. *)
|
||||
let signal_add_sub_b s (f : _ ) = match s with
|
||||
| Dict d when is_dict_signal d ->
|
||||
let f_val : value = Obj.magic f in
|
||||
let subs = match Sx_types.dict_get d "subscribers" with
|
||||
| List l -> l | ListRef r -> !r | _ -> [] in
|
||||
Hashtbl.replace d "subscribers" (List (subs @ [f_val])); Nil
|
||||
| _ -> Nil
|
||||
|
||||
let signal_remove_sub_b s (f : _) = match s with
|
||||
| Dict d when is_dict_signal d ->
|
||||
let f_val : value = Obj.magic f in
|
||||
let subs = match Sx_types.dict_get d "subscribers" with
|
||||
| List l -> l | ListRef r -> !r | _ -> [] in
|
||||
Hashtbl.replace d "subscribers" (List (List.filter (fun x -> x != f_val) subs)); Nil
|
||||
| _ -> Nil
|
||||
|
||||
let signal_deps s = match s with
|
||||
| Dict d when is_dict_signal d -> Sx_types.dict_get d "deps"
|
||||
| _ -> List []
|
||||
|
||||
let signal_set_deps s deps = match s with
|
||||
| Dict d when is_dict_signal d -> Hashtbl.replace d "deps" deps; Nil
|
||||
| _ -> Nil
|
||||
|
||||
let notify_subscribers s = match s with
|
||||
| Dict d when is_dict_signal d ->
|
||||
let subs = match Sx_types.dict_get d "subscribers" with
|
||||
| List l -> l | ListRef r -> !r | _ -> [] in
|
||||
List.iter (fun sub ->
|
||||
match sub with
|
||||
| NativeFn (_, f) -> ignore (f [])
|
||||
| Lambda _ -> ignore (Sx_types.env_bind (Sx_types.make_env ()) "_" Nil) (* TODO: call through CEK *)
|
||||
| _ -> ()
|
||||
) subs; Nil
|
||||
| _ -> Nil
|
||||
|
||||
let flush_subscribers _s = Nil
|
||||
let dispose_computed _s = Nil
|
||||
|
||||
(* Island scope stubs — accept OCaml functions from transpiled code.
|
||||
Use Obj.magic for the same reason as signal_add_sub_b. *)
|
||||
let with_island_scope (_register_fn : _) (body_fn : _) =
|
||||
let body : unit -> value = Obj.magic body_fn in
|
||||
body ()
|
||||
let register_in_scope (_dispose_fn : _) = Nil
|
||||
|
||||
(* Component type annotation stub *)
|
||||
let component_set_param_types_b _comp _types = Nil
|
||||
|
||||
(* Parse keyword args from a call — this is defined in evaluator.sx,
|
||||
the transpiled version will override this stub. *)
|
||||
(* Forward-reference stubs for evaluator functions used before definition *)
|
||||
let parse_comp_params _params = List [List []; Nil; Bool false]
|
||||
let parse_macro_params _params = List [List []; Nil]
|
||||
|
||||
let parse_keyword_args _raw_args _env =
|
||||
(* Stub — the real implementation is transpiled from evaluator.sx *)
|
||||
List [Dict (Hashtbl.create 0); List []]
|
||||
|
||||
(* Make handler/query/action/page def stubs *)
|
||||
let make_handler_def name params body _env = Dict (let d = Hashtbl.create 4 in Hashtbl.replace d "type" (String "handler"); Hashtbl.replace d "name" name; Hashtbl.replace d "params" params; Hashtbl.replace d "body" body; d)
|
||||
let make_query_def name params body _env = make_handler_def name params body _env
|
||||
let make_action_def name params body _env = make_handler_def name params body _env
|
||||
let make_page_def name _opts = Dict (let d = Hashtbl.create 4 in Hashtbl.replace d "type" (String "page"); Hashtbl.replace d "name" name; d)
|
||||
|
||||
(* sf-def* stubs — platform-specific def-forms, not in the SX spec *)
|
||||
let sf_defhandler args env =
|
||||
let name = first args in let rest_args = rest args in
|
||||
make_handler_def name (first rest_args) (nth rest_args (Number 1.0)) env
|
||||
let sf_defquery args env = sf_defhandler args env
|
||||
let sf_defaction args env = sf_defhandler args env
|
||||
let sf_defpage args _env =
|
||||
let name = first args in make_page_def name (rest args)
|
||||
|
||||
let strip_prefix s prefix =
|
||||
match s, prefix with
|
||||
| String s, String p ->
|
||||
let pl = String.length p in
|
||||
if String.length s >= pl && String.sub s 0 pl = p
|
||||
then String (String.sub s pl (String.length s - pl))
|
||||
else String s
|
||||
| _ -> s
|
||||
401
hosts/ocaml/lib/sx_types.ml
Normal file
401
hosts/ocaml/lib/sx_types.ml
Normal file
@@ -0,0 +1,401 @@
|
||||
(** Core types for the SX language.
|
||||
|
||||
The [value] sum type represents every possible SX runtime value.
|
||||
OCaml's algebraic types make the CEK machine's frame dispatch a
|
||||
pattern match — exactly what the spec describes. *)
|
||||
|
||||
(** {1 Environment} *)
|
||||
|
||||
(** Lexical scope chain. Each frame holds a mutable binding table and
|
||||
an optional parent link for scope-chain lookup. *)
|
||||
type env = {
|
||||
bindings : (string, value) Hashtbl.t;
|
||||
parent : env option;
|
||||
}
|
||||
|
||||
(** {1 Values} *)
|
||||
|
||||
and value =
|
||||
| Nil
|
||||
| Bool of bool
|
||||
| Number of float
|
||||
| String of string
|
||||
| Symbol of string
|
||||
| Keyword of string
|
||||
| List of value list
|
||||
| Dict of dict
|
||||
| Lambda of lambda
|
||||
| Component of component
|
||||
| Island of island
|
||||
| Macro of macro
|
||||
| Thunk of value * env
|
||||
| Continuation of (value -> value) * dict option
|
||||
| NativeFn of string * (value list -> value)
|
||||
| Signal of signal
|
||||
| RawHTML of string
|
||||
| Spread of (string * value) list
|
||||
| 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! *)
|
||||
|
||||
(** Mutable string-keyed table (SX dicts support [dict-set!]). *)
|
||||
and dict = (string, value) Hashtbl.t
|
||||
|
||||
and lambda = {
|
||||
l_params : string list;
|
||||
l_body : value;
|
||||
l_closure : env;
|
||||
mutable l_name : string option;
|
||||
}
|
||||
|
||||
and component = {
|
||||
c_name : string;
|
||||
c_params : string list;
|
||||
c_has_children : bool;
|
||||
c_body : value;
|
||||
c_closure : env;
|
||||
c_affinity : string; (** "auto" | "client" | "server" *)
|
||||
}
|
||||
|
||||
and island = {
|
||||
i_name : string;
|
||||
i_params : string list;
|
||||
i_has_children : bool;
|
||||
i_body : value;
|
||||
i_closure : env;
|
||||
}
|
||||
|
||||
and macro = {
|
||||
m_params : string list;
|
||||
m_rest_param : string option;
|
||||
m_body : value;
|
||||
m_closure : env;
|
||||
m_name : string option;
|
||||
}
|
||||
|
||||
and signal = {
|
||||
mutable s_value : value;
|
||||
mutable s_subscribers : (unit -> unit) list;
|
||||
mutable s_deps : signal list;
|
||||
}
|
||||
|
||||
|
||||
(** {1 Errors} *)
|
||||
|
||||
exception Eval_error of string
|
||||
exception Parse_error of string
|
||||
|
||||
|
||||
(** {1 Environment operations} *)
|
||||
|
||||
let make_env () =
|
||||
{ bindings = Hashtbl.create 16; parent = None }
|
||||
|
||||
let env_extend parent =
|
||||
{ bindings = Hashtbl.create 16; parent = Some parent }
|
||||
|
||||
let env_bind env name v =
|
||||
Hashtbl.replace env.bindings name v; Nil
|
||||
|
||||
let rec env_has env name =
|
||||
Hashtbl.mem env.bindings name ||
|
||||
match env.parent with Some p -> env_has p name | None -> false
|
||||
|
||||
let rec env_get env name =
|
||||
match Hashtbl.find_opt env.bindings name with
|
||||
| Some v -> v
|
||||
| None ->
|
||||
match env.parent with
|
||||
| Some p -> env_get p name
|
||||
| None -> raise (Eval_error ("Undefined symbol: " ^ name))
|
||||
|
||||
let rec env_set env name v =
|
||||
if Hashtbl.mem env.bindings name then
|
||||
(Hashtbl.replace env.bindings name v; Nil)
|
||||
else
|
||||
match env.parent with
|
||||
| Some p -> env_set p name v
|
||||
| None -> Hashtbl.replace env.bindings name v; Nil
|
||||
|
||||
let env_merge base overlay =
|
||||
(* If base and overlay are the same env (physical equality) or overlay
|
||||
is a descendant of base, just extend base — no copying needed.
|
||||
This prevents set! inside lambdas from modifying shadow copies. *)
|
||||
if base == overlay then
|
||||
{ bindings = Hashtbl.create 16; parent = Some base }
|
||||
else begin
|
||||
(* Check if overlay is a descendant of base *)
|
||||
let rec is_descendant e depth =
|
||||
if depth > 100 then false
|
||||
else if e == base then true
|
||||
else match e.parent with Some p -> is_descendant p (depth + 1) | None -> false
|
||||
in
|
||||
if is_descendant overlay 0 then
|
||||
{ bindings = Hashtbl.create 16; parent = Some base }
|
||||
else begin
|
||||
(* General case: extend base, copy ONLY overlay bindings that don't
|
||||
exist anywhere in the base chain (avoids shadowing closure bindings). *)
|
||||
let e = { bindings = Hashtbl.create 16; parent = Some base } in
|
||||
Hashtbl.iter (fun k v ->
|
||||
if not (env_has base k) then Hashtbl.replace e.bindings k v
|
||||
) overlay.bindings;
|
||||
e
|
||||
end
|
||||
end
|
||||
|
||||
|
||||
(** {1 Value extraction helpers} *)
|
||||
|
||||
let value_to_string = function
|
||||
| String s -> s | Symbol s -> s | Keyword k -> k
|
||||
| Number n -> if Float.is_integer n then string_of_int (int_of_float n) else Printf.sprintf "%g" n
|
||||
| Bool true -> "true" | Bool false -> "false"
|
||||
| Nil -> "" | _ -> "<value>"
|
||||
|
||||
let value_to_string_list = function
|
||||
| List items | ListRef { contents = items } -> List.map value_to_string items
|
||||
| _ -> []
|
||||
|
||||
let value_to_bool = function
|
||||
| Bool b -> b | Nil -> false | _ -> true
|
||||
|
||||
let value_to_string_opt = function
|
||||
| String s -> Some s | Symbol s -> Some s | Nil -> None | _ -> None
|
||||
|
||||
|
||||
(** {1 Constructors — accept [value] args from transpiled code} *)
|
||||
|
||||
let unwrap_env_val = function
|
||||
| Env e -> e
|
||||
| _ -> raise (Eval_error "make_lambda: expected env for closure")
|
||||
|
||||
let make_lambda params body closure =
|
||||
let ps = match params with
|
||||
| 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 }
|
||||
|
||||
let make_component name params has_children body closure affinity =
|
||||
let n = value_to_string name in
|
||||
let ps = value_to_string_list params in
|
||||
let hc = value_to_bool has_children in
|
||||
let aff = match affinity with String s -> s | _ -> "auto" in
|
||||
Component {
|
||||
c_name = n; c_params = ps; c_has_children = hc;
|
||||
c_body = body; c_closure = unwrap_env_val closure; c_affinity = aff;
|
||||
}
|
||||
|
||||
let make_island name params has_children body closure =
|
||||
let n = value_to_string name in
|
||||
let ps = value_to_string_list params in
|
||||
let hc = value_to_bool has_children in
|
||||
Island {
|
||||
i_name = n; i_params = ps; i_has_children = hc;
|
||||
i_body = body; i_closure = unwrap_env_val closure;
|
||||
}
|
||||
|
||||
let make_macro params rest_param body closure name =
|
||||
let ps = value_to_string_list params in
|
||||
let rp = value_to_string_opt rest_param in
|
||||
let n = value_to_string_opt name in
|
||||
Macro {
|
||||
m_params = ps; m_rest_param = rp;
|
||||
m_body = body; m_closure = unwrap_env_val closure; m_name = n;
|
||||
}
|
||||
|
||||
let make_thunk expr env = Thunk (expr, unwrap_env_val env)
|
||||
|
||||
let make_symbol name = Symbol (value_to_string name)
|
||||
let make_keyword name = Keyword (value_to_string name)
|
||||
|
||||
|
||||
(** {1 Type inspection} *)
|
||||
|
||||
let type_of = function
|
||||
| Nil -> "nil"
|
||||
| Bool _ -> "boolean"
|
||||
| Number _ -> "number"
|
||||
| String _ -> "string"
|
||||
| Symbol _ -> "symbol"
|
||||
| Keyword _ -> "keyword"
|
||||
| List _ | ListRef _ -> "list"
|
||||
| Dict _ -> "dict"
|
||||
| Lambda _ -> "lambda"
|
||||
| Component _ -> "component"
|
||||
| Island _ -> "island"
|
||||
| Macro _ -> "macro"
|
||||
| Thunk _ -> "thunk"
|
||||
| Continuation (_, _) -> "continuation"
|
||||
| NativeFn _ -> "function"
|
||||
| Signal _ -> "signal"
|
||||
| RawHTML _ -> "raw-html"
|
||||
| Spread _ -> "spread"
|
||||
| SxExpr _ -> "sx-expr"
|
||||
| Env _ -> "env"
|
||||
|
||||
let is_nil = function Nil -> true | _ -> false
|
||||
let is_lambda = function Lambda _ -> true | _ -> false
|
||||
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
|
||||
| Dict d -> Hashtbl.mem d "__signal"
|
||||
| _ -> false
|
||||
|
||||
let is_callable = function
|
||||
| Lambda _ | NativeFn _ | Continuation (_, _) -> true
|
||||
| _ -> false
|
||||
|
||||
|
||||
(** {1 Truthiness} *)
|
||||
|
||||
(** SX truthiness: everything is truthy except [Nil] and [Bool false]. *)
|
||||
let sx_truthy = function
|
||||
| Nil | Bool false -> false
|
||||
| _ -> true
|
||||
|
||||
|
||||
(** {1 Accessors} *)
|
||||
|
||||
let symbol_name = function
|
||||
| Symbol s -> String s
|
||||
| v -> raise (Eval_error ("Expected symbol, got " ^ type_of v))
|
||||
|
||||
let keyword_name = function
|
||||
| Keyword k -> String k
|
||||
| v -> raise (Eval_error ("Expected keyword, got " ^ type_of v))
|
||||
|
||||
let lambda_params = function
|
||||
| Lambda l -> List (List.map (fun s -> String s) l.l_params)
|
||||
| v -> raise (Eval_error ("Expected lambda, got " ^ type_of v))
|
||||
|
||||
let lambda_body = function
|
||||
| Lambda l -> l.l_body
|
||||
| v -> raise (Eval_error ("Expected lambda, got " ^ type_of v))
|
||||
|
||||
let lambda_closure = function
|
||||
| Lambda l -> Env l.l_closure
|
||||
| v -> raise (Eval_error ("Expected lambda, got " ^ type_of v))
|
||||
|
||||
let lambda_name = function
|
||||
| Lambda l -> (match l.l_name with Some n -> String n | None -> Nil)
|
||||
| v -> raise (Eval_error ("Expected lambda, got " ^ type_of v))
|
||||
|
||||
let set_lambda_name l n = match l with
|
||||
| Lambda l -> l.l_name <- Some n; Nil
|
||||
| _ -> raise (Eval_error "set-lambda-name!: not a lambda")
|
||||
|
||||
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
|
||||
| Macro m -> List (List.map (fun s -> String s) m.m_params)
|
||||
| v -> raise (Eval_error ("Expected macro, got " ^ type_of v))
|
||||
|
||||
let macro_rest_param = function
|
||||
| Macro m -> (match m.m_rest_param with Some s -> String s | None -> Nil)
|
||||
| v -> raise (Eval_error ("Expected macro, got " ^ type_of v))
|
||||
|
||||
let macro_body = function
|
||||
| Macro m -> m.m_body
|
||||
| v -> raise (Eval_error ("Expected macro, got " ^ type_of v))
|
||||
|
||||
let macro_closure = function
|
||||
| Macro m -> Env m.m_closure
|
||||
| v -> raise (Eval_error ("Expected macro, got " ^ type_of v))
|
||||
|
||||
let thunk_expr = function
|
||||
| Thunk (e, _) -> e
|
||||
| v -> raise (Eval_error ("Expected thunk, got " ^ type_of v))
|
||||
|
||||
let thunk_env = function
|
||||
| Thunk (_, e) -> Env e
|
||||
| v -> raise (Eval_error ("Expected thunk, got " ^ type_of v))
|
||||
|
||||
|
||||
(** {1 Dict operations} *)
|
||||
|
||||
let make_dict () : dict = Hashtbl.create 8
|
||||
|
||||
let dict_get (d : dict) key =
|
||||
match Hashtbl.find_opt d key with Some v -> v | None -> Nil
|
||||
|
||||
let dict_has (d : dict) key = Hashtbl.mem d key
|
||||
|
||||
let dict_set (d : dict) key v = Hashtbl.replace d key v
|
||||
|
||||
let dict_delete (d : dict) key = Hashtbl.remove d key
|
||||
|
||||
let dict_keys (d : dict) =
|
||||
Hashtbl.fold (fun k _ acc -> String k :: acc) d []
|
||||
|
||||
let dict_vals (d : dict) =
|
||||
Hashtbl.fold (fun _ v acc -> v :: acc) d []
|
||||
|
||||
|
||||
(** {1 Value display} *)
|
||||
|
||||
let rec inspect = function
|
||||
| Nil -> "nil"
|
||||
| Bool true -> "true"
|
||||
| Bool false -> "false"
|
||||
| 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
|
||||
| Symbol s -> s
|
||||
| Keyword k -> ":" ^ k
|
||||
| List items | ListRef { contents = items } ->
|
||||
"(" ^ String.concat " " (List.map inspect items) ^ ")"
|
||||
| Dict d ->
|
||||
let pairs = Hashtbl.fold (fun k v acc ->
|
||||
(Printf.sprintf ":%s %s" k (inspect v)) :: acc) d [] in
|
||||
"{" ^ String.concat " " pairs ^ "}"
|
||||
| Lambda l ->
|
||||
let tag = match l.l_name with Some n -> n | None -> "lambda" in
|
||||
Printf.sprintf "<%s(%s)>" tag (String.concat ", " l.l_params)
|
||||
| Component c ->
|
||||
Printf.sprintf "<Component ~%s(%s)>" c.c_name (String.concat ", " c.c_params)
|
||||
| Island i ->
|
||||
Printf.sprintf "<Island ~%s(%s)>" i.i_name (String.concat ", " i.i_params)
|
||||
| Macro m ->
|
||||
let tag = match m.m_name with Some n -> n | None -> "macro" in
|
||||
Printf.sprintf "<%s(%s)>" tag (String.concat ", " m.m_params)
|
||||
| Thunk _ -> "<thunk>"
|
||||
| Continuation (_, _) -> "<continuation>"
|
||||
| NativeFn (name, _) -> Printf.sprintf "<native:%s>" name
|
||||
| Signal _ -> "<signal>"
|
||||
| RawHTML s -> Printf.sprintf "<raw-html:%d chars>" (String.length s)
|
||||
| Spread _ -> "<spread>"
|
||||
| SxExpr s -> Printf.sprintf "<sx-expr:%d chars>" (String.length s)
|
||||
| Env _ -> "<env>"
|
||||
1230
hosts/ocaml/transpiler.sx
Normal file
1230
hosts/ocaml/transpiler.sx
Normal file
File diff suppressed because it is too large
Load Diff
@@ -20,7 +20,7 @@ import sys
|
||||
|
||||
# Add project root to path for imports
|
||||
_HERE = os.path.dirname(os.path.abspath(__file__))
|
||||
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", "..", ".."))
|
||||
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", ".."))
|
||||
sys.path.insert(0, _PROJECT)
|
||||
|
||||
from shared.sx.parser import parse_all
|
||||
@@ -1313,7 +1313,7 @@ try:
|
||||
EXTENSION_NAMES, EXTENSION_FORMS,
|
||||
)
|
||||
except ImportError:
|
||||
from shared.sx.ref.platform_py import (
|
||||
from hosts.python.platform import (
|
||||
PREAMBLE, PLATFORM_PY, PRIMITIVES_PY_PRE, PRIMITIVES_PY_POST,
|
||||
PRIMITIVES_PY_MODULES, _ALL_PY_MODULES,
|
||||
PLATFORM_PARSER_PY,
|
||||
@@ -1439,7 +1439,7 @@ def compile_ref_to_py(
|
||||
raise ValueError(f"Unknown module: {m!r}. Valid: {', '.join(PRIMITIVES_PY_MODULES)}")
|
||||
prim_modules.append(m)
|
||||
|
||||
ref_dir = os.path.dirname(os.path.abspath(__file__))
|
||||
ref_dir = os.path.join(os.path.abspath(os.path.join(os.path.dirname(os.path.abspath(__file__)), "..", "..")), "shared", "sx", "ref")
|
||||
_project = os.path.abspath(os.path.join(ref_dir, "..", "..", ".."))
|
||||
_source_dirs = [
|
||||
os.path.join(_project, "spec"),
|
||||
@@ -1484,15 +1484,14 @@ def compile_ref_to_py(
|
||||
spec_mod_set.add("page-helpers")
|
||||
if "router" in SPEC_MODULES:
|
||||
spec_mod_set.add("router")
|
||||
# CEK is the canonical evaluator — always include
|
||||
spec_mod_set.add("cek")
|
||||
spec_mod_set.add("frames")
|
||||
# CEK is always included (part of evaluator.sx core file)
|
||||
has_cek = True
|
||||
has_deps = "deps" in spec_mod_set
|
||||
has_cek = "cek" in spec_mod_set
|
||||
|
||||
# Core files always included, then selected adapters, then spec modules
|
||||
# evaluator.sx = merged frames + eval utilities + CEK machine
|
||||
sx_files = [
|
||||
("eval.sx", "eval"),
|
||||
("evaluator.sx", "evaluator (frames + eval + CEK)"),
|
||||
("forms.sx", "forms (server definition forms)"),
|
||||
("render.sx", "render (core)"),
|
||||
]
|
||||
@@ -498,10 +498,23 @@ def env_get(env, name):
|
||||
return env.get(name, NIL)
|
||||
|
||||
|
||||
def env_set(env, name, val):
|
||||
def env_bind(env, name, val):
|
||||
"""Create/overwrite binding on THIS env only (let, define, param binding)."""
|
||||
env[name] = val
|
||||
|
||||
|
||||
def env_set(env, name, val):
|
||||
"""Mutate existing binding, walking scope chain (set!)."""
|
||||
if hasattr(env, 'set'):
|
||||
try:
|
||||
env.set(name, val)
|
||||
except KeyError:
|
||||
# Not found anywhere — bind on immediate env
|
||||
env[name] = val
|
||||
else:
|
||||
env[name] = val
|
||||
|
||||
|
||||
def env_extend(env):
|
||||
return _ensure_env(env).extend()
|
||||
|
||||
@@ -512,13 +525,24 @@ def env_merge(base, overlay):
|
||||
if base is overlay:
|
||||
# Same env — just extend with empty local scope for params
|
||||
return base.extend()
|
||||
# Check if base is an ancestor of overlay — if so, no need to merge
|
||||
# (common for self-recursive calls where closure == caller's ancestor)
|
||||
# Check if base is an ancestor of overlay — if so, overlay contains
|
||||
# everything in base. But overlay scopes between overlay and base may
|
||||
# have extra local bindings (e.g. page helpers injected at request time).
|
||||
# Only take the shortcut if no intermediate scope has local bindings.
|
||||
p = overlay
|
||||
depth = 0
|
||||
while p is not None and depth < 100:
|
||||
if p is base:
|
||||
return base.extend()
|
||||
q = overlay
|
||||
has_extra = False
|
||||
while q is not base:
|
||||
if hasattr(q, '_bindings') and q._bindings:
|
||||
has_extra = True
|
||||
break
|
||||
q = getattr(q, '_parent', None)
|
||||
if not has_extra:
|
||||
return base.extend()
|
||||
break
|
||||
p = getattr(p, '_parent', None)
|
||||
depth += 1
|
||||
# MergedEnv: reads walk base then overlay; set! walks base only
|
||||
@@ -1623,14 +1647,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)"),
|
||||
"frames": ("frames.sx", "frames (CEK continuation frames)"),
|
||||
"cek": ("cek.sx", "cek (explicit CEK machine evaluator)"),
|
||||
}
|
||||
# Note: frames and cek are now part of evaluator.sx (always loaded as core)
|
||||
|
||||
# Explicit ordering for spec modules with dependencies.
|
||||
# Modules listed here are emitted in this order; any not listed use alphabetical.
|
||||
SPEC_MODULE_ORDER = [
|
||||
"deps", "engine", "frames", "page-helpers", "router", "cek", "signals", "types",
|
||||
"deps", "engine", "page-helpers", "router", "signals", "types",
|
||||
]
|
||||
|
||||
EXTENSION_NAMES = {"continuations"}
|
||||
@@ -5,6 +5,8 @@ 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)
|
||||
|
||||
@@ -212,25 +214,25 @@ for name in ["sf-defhandler", "sf-defpage", "sf-defquery", "sf-defaction"]:
|
||||
env[name] = lambda args, e, _n=name: NIL
|
||||
|
||||
# Load test framework
|
||||
with open(os.path.join(_HERE, "test-framework.sx")) as f:
|
||||
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(_HERE, "signals.sx")) as f:
|
||||
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(_HERE, "frames.sx")) as f:
|
||||
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(_HERE, "cek.sx")) as f:
|
||||
with open(os.path.join(_PROJECT, "spec", "cek.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
@@ -239,7 +241,7 @@ print("=" * 60)
|
||||
print("Running test-cek-reactive.sx")
|
||||
print("=" * 60)
|
||||
|
||||
with open(os.path.join(_HERE, "test-cek-reactive.sx")) as f:
|
||||
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))
|
||||
|
||||
@@ -5,6 +5,8 @@ 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
|
||||
@@ -223,19 +225,19 @@ for name in ["sf-defhandler", "sf-defpage", "sf-defquery", "sf-defaction"]:
|
||||
env[name] = lambda args, e, _n=name: NIL
|
||||
|
||||
# Load test framework
|
||||
with open(os.path.join(_HERE, "test-framework.sx")) as f:
|
||||
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(_HERE, "frames.sx")) as f:
|
||||
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(_HERE, "cek.sx")) as f:
|
||||
with open(os.path.join(_PROJECT, "spec", "cek.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
@@ -255,7 +257,7 @@ print("=" * 60)
|
||||
print("Running test-cek.sx")
|
||||
print("=" * 60)
|
||||
|
||||
with open(os.path.join(_HERE, "test-cek.sx")) as f:
|
||||
with open(os.path.join(_SPEC_TESTS, "test-cek.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
@@ -5,12 +5,14 @@ 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.py"),
|
||||
[sys.executable, os.path.join(_HERE, "..", "bootstrap.py"),
|
||||
"--extensions", "continuations"],
|
||||
capture_output=True, text=True, cwd=_PROJECT,
|
||||
)
|
||||
@@ -87,7 +89,7 @@ env["push-suite"] = _push_suite
|
||||
env["pop-suite"] = _pop_suite
|
||||
|
||||
# Load test framework
|
||||
with open(os.path.join(_HERE, "test-framework.sx")) as f:
|
||||
with open(os.path.join(_SPEC_TESTS, "test-framework.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
@@ -96,7 +98,7 @@ print("=" * 60)
|
||||
print("Running test-continuations.sx")
|
||||
print("=" * 60)
|
||||
|
||||
with open(os.path.join(_HERE, "test-continuations.sx")) as f:
|
||||
with open(os.path.join(_SPEC_TESTS, "test-continuations.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
@@ -10,6 +10,8 @@ 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
|
||||
@@ -143,7 +145,7 @@ env["register-in-scope"] = sx_ref.register_in_scope
|
||||
env["callable?"] = sx_ref.is_callable
|
||||
|
||||
# Load test framework
|
||||
with open(os.path.join(_HERE, "test-framework.sx")) as f:
|
||||
with open(os.path.join(_SPEC_TESTS, "test-framework.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
@@ -152,7 +154,7 @@ print("=" * 60)
|
||||
print("Running test-signals.sx")
|
||||
print("=" * 60)
|
||||
|
||||
with open(os.path.join(_HERE, "test-signals.sx")) as f:
|
||||
with open(os.path.join(_WEB_TESTS, "test-signals.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
316
hosts/python/tests/run_tests.py
Normal file
316
hosts/python/tests/run_tests.py
Normal file
@@ -0,0 +1,316 @@
|
||||
#!/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)
|
||||
@@ -5,6 +5,9 @@ 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
|
||||
@@ -167,12 +170,12 @@ env["env-has?"] = env_has
|
||||
env["env-set!"] = env_set
|
||||
|
||||
# Load test framework (macros + assertion helpers)
|
||||
with open(os.path.join(_HERE, "test-framework.sx")) as f:
|
||||
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(_HERE, "types.sx")) as f:
|
||||
with open(os.path.join(_SPEC_DIR, "types.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
@@ -181,7 +184,7 @@ print("=" * 60)
|
||||
print("Running test-types.sx")
|
||||
print("=" * 60)
|
||||
|
||||
with open(os.path.join(_HERE, "test-types.sx")) as f:
|
||||
with open(os.path.join(_SPEC_TESTS, "test-types.sx")) as f:
|
||||
for expr in parse_all(f.read()):
|
||||
trampoline(eval_expr(expr, env))
|
||||
|
||||
@@ -107,6 +107,7 @@
|
||||
"get-primitive" "get_primitive"
|
||||
"env-has?" "env_has"
|
||||
"env-get" "env_get"
|
||||
"env-bind!" "env_bind"
|
||||
"env-set!" "env_set"
|
||||
"env-extend" "env_extend"
|
||||
"env-merge" "env_merge"
|
||||
@@ -524,11 +525,16 @@
|
||||
", " (py-expr-with-cells (nth args 1) cell-vars)
|
||||
", " (py-expr-with-cells (nth args 2) cell-vars) ")")
|
||||
|
||||
(= op "env-set!")
|
||||
(= op "env-bind!")
|
||||
(str "_sx_dict_set(" (py-expr-with-cells (nth args 0) cell-vars)
|
||||
", " (py-expr-with-cells (nth args 1) cell-vars)
|
||||
", " (py-expr-with-cells (nth args 2) cell-vars) ")")
|
||||
|
||||
(= op "env-set!")
|
||||
(str "env_set(" (py-expr-with-cells (nth args 0) cell-vars)
|
||||
", " (py-expr-with-cells (nth args 1) cell-vars)
|
||||
", " (py-expr-with-cells (nth args 2) cell-vars) ")")
|
||||
|
||||
(= op "set-lambda-name!")
|
||||
(str "_sx_set_attr(" (py-expr-with-cells (nth args 0) cell-vars)
|
||||
", 'name', " (py-expr-with-cells (nth args 1) cell-vars) ")")
|
||||
@@ -901,10 +907,14 @@
|
||||
(= name "append!")
|
||||
(str pad (py-expr-with-cells (nth expr 1) cell-vars)
|
||||
".append(" (py-expr-with-cells (nth expr 2) cell-vars) ")")
|
||||
(= name "env-set!")
|
||||
(= name "env-bind!")
|
||||
(str pad (py-expr-with-cells (nth expr 1) cell-vars)
|
||||
"[" (py-expr-with-cells (nth expr 2) cell-vars)
|
||||
"] = " (py-expr-with-cells (nth expr 3) cell-vars))
|
||||
(= name "env-set!")
|
||||
(str pad "env_set(" (py-expr-with-cells (nth expr 1) cell-vars)
|
||||
", " (py-expr-with-cells (nth expr 2) cell-vars)
|
||||
", " (py-expr-with-cells (nth expr 3) cell-vars) ")")
|
||||
(= name "set-lambda-name!")
|
||||
(str pad (py-expr-with-cells (nth expr 1) cell-vars)
|
||||
".name = " (py-expr-with-cells (nth expr 2) cell-vars))
|
||||
@@ -1098,10 +1108,14 @@
|
||||
(append! lines (str pad (py-expr-with-cells (nth expr 1) cell-vars)
|
||||
"[" (py-expr-with-cells (nth expr 2) cell-vars)
|
||||
"] = " (py-expr-with-cells (nth expr 3) cell-vars)))
|
||||
(= name "env-set!")
|
||||
(= name "env-bind!")
|
||||
(append! lines (str pad (py-expr-with-cells (nth expr 1) cell-vars)
|
||||
"[" (py-expr-with-cells (nth expr 2) cell-vars)
|
||||
"] = " (py-expr-with-cells (nth expr 3) cell-vars)))
|
||||
(= name "env-set!")
|
||||
(append! lines (str pad "env_set(" (py-expr-with-cells (nth expr 1) cell-vars)
|
||||
", " (py-expr-with-cells (nth expr 2) cell-vars)
|
||||
", " (py-expr-with-cells (nth expr 3) cell-vars) ")"))
|
||||
:else
|
||||
(append! lines (py-statement-with-cells expr indent cell-vars)))))))))
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/js_of_ocaml-651f6707.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/js_of_ocaml-651f6707.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/jsoo_runtime-f96b44a8.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/jsoo_runtime-f96b44a8.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/prelude-d7e4b000.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/prelude-d7e4b000.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/runtime-0db9b496.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/runtime-0db9b496.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/start-9afa06f6.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/start-9afa06f6.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/std_exit-10fb8830.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/std_exit-10fb8830.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/stdlib-23ce0836.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/stdlib-23ce0836.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/sx-2f171299.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/sx-2f171299.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/sx-340f03ca.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/sx-340f03ca.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/sx-4d3c7bfa.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/sx-4d3c7bfa.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/sx-a462ed04.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/sx-a462ed04.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/sx-ca2dce12.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/sx-ca2dce12.wasm
Normal file
Binary file not shown.
BIN
shared/static/scripts/sx-wasm-assets/sx-fc47a7a0.wasm
Normal file
BIN
shared/static/scripts/sx-wasm-assets/sx-fc47a7a0.wasm
Normal file
Binary file not shown.
2584
shared/static/scripts/sx-wasm.js
Normal file
2584
shared/static/scripts/sx-wasm.js
Normal file
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
@@ -852,6 +852,9 @@ async def sx_page(ctx: dict, page_sx: str, *,
|
||||
if body_scripts is None:
|
||||
body_scripts = _shell_cfg.get("body_scripts")
|
||||
|
||||
import os as _os
|
||||
_sx_js_file = "sx-wasm.js" if _os.environ.get("SX_USE_WASM") == "1" else "sx-browser.js"
|
||||
|
||||
shell_kwargs: dict[str, Any] = dict(
|
||||
title=_html_escape(title),
|
||||
asset_url=asset_url,
|
||||
@@ -863,7 +866,8 @@ async def sx_page(ctx: dict, page_sx: str, *,
|
||||
page_sx=page_sx,
|
||||
sx_css=sx_css,
|
||||
sx_css_classes=sx_css_classes,
|
||||
sx_js_hash=_script_hash("sx-browser.js"),
|
||||
sx_js_file=_sx_js_file,
|
||||
sx_js_hash=_script_hash(_sx_js_file),
|
||||
body_js_hash=_script_hash("body.js"),
|
||||
)
|
||||
if head_scripts is not None:
|
||||
|
||||
@@ -31,7 +31,13 @@ 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_REF") == "1":
|
||||
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
|
||||
@@ -348,6 +354,12 @@ def reload_if_changed() -> None:
|
||||
reload_logger.info("Reloaded %d file(s), components in %.1fms",
|
||||
len(changed_files), (t1 - t0) * 1000)
|
||||
|
||||
# Invalidate OCaml bridge component cache so next render reloads
|
||||
if _os.environ.get("SX_USE_OCAML") == "1":
|
||||
from .ocaml_bridge import _bridge
|
||||
if _bridge is not None:
|
||||
_bridge._components_loaded = False
|
||||
|
||||
# Recompute render plans for all services that have pages
|
||||
from .pages import _PAGE_REGISTRY, compute_page_render_plans
|
||||
for svc in _PAGE_REGISTRY:
|
||||
@@ -430,6 +442,9 @@ def finalize_components() -> None:
|
||||
compute_all_io_refs(_COMPONENT_ENV, get_all_io_names())
|
||||
_compute_component_hash()
|
||||
|
||||
# OCaml bridge loads components lazily on first render via
|
||||
# OcamlBridge._ensure_components() — no sync needed here.
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# sx() — render s-expression from Jinja template
|
||||
@@ -482,7 +497,16 @@ async def sx_async(source: str, **kwargs: Any) -> str:
|
||||
Use when the s-expression contains I/O nodes::
|
||||
|
||||
{{ sx_async('(frag "blog" "card" :slug "apple")') | safe }}
|
||||
|
||||
When SX_USE_OCAML=1, renders via the OCaml kernel subprocess which
|
||||
yields io-requests back to Python for async fulfillment.
|
||||
"""
|
||||
if _os.environ.get("SX_USE_OCAML") == "1":
|
||||
from .ocaml_bridge import get_bridge
|
||||
bridge = await get_bridge()
|
||||
ctx = dict(kwargs)
|
||||
return await bridge.render(source, ctx=ctx)
|
||||
|
||||
from .resolver import resolve, RequestContext
|
||||
|
||||
env = dict(_COMPONENT_ENV)
|
||||
|
||||
408
shared/sx/ocaml_bridge.py
Normal file
408
shared/sx/ocaml_bridge.py
Normal file
@@ -0,0 +1,408 @@
|
||||
"""
|
||||
OCaml SX kernel ↔ Python coroutine bridge.
|
||||
|
||||
Manages a persistent OCaml subprocess (sx_server) that evaluates SX
|
||||
expressions. When the OCaml kernel needs IO (database queries, service
|
||||
calls), it yields an ``(io-request ...)`` back to Python, which fulfills
|
||||
it asynchronously and sends an ``(io-response ...)`` back.
|
||||
|
||||
Usage::
|
||||
|
||||
bridge = OcamlBridge()
|
||||
await bridge.start()
|
||||
html = await bridge.render('(div (p "hello"))')
|
||||
await bridge.stop()
|
||||
"""
|
||||
|
||||
from __future__ import annotations
|
||||
|
||||
import asyncio
|
||||
import logging
|
||||
import os
|
||||
from typing import Any
|
||||
|
||||
_logger = logging.getLogger("sx.ocaml")
|
||||
|
||||
# Default binary path — can be overridden via SX_OCAML_BIN env var
|
||||
_DEFAULT_BIN = os.path.join(
|
||||
os.path.dirname(__file__),
|
||||
"../../hosts/ocaml/_build/default/bin/sx_server.exe",
|
||||
)
|
||||
|
||||
|
||||
class OcamlBridgeError(Exception):
|
||||
"""Error from the OCaml SX kernel."""
|
||||
|
||||
|
||||
class OcamlBridge:
|
||||
"""Async bridge to a persistent OCaml SX subprocess."""
|
||||
|
||||
def __init__(self, binary: str | None = None):
|
||||
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._started = False
|
||||
self._components_loaded = False
|
||||
|
||||
async def start(self) -> None:
|
||||
"""Launch the OCaml subprocess and wait for (ready)."""
|
||||
if self._started:
|
||||
return
|
||||
|
||||
bin_path = os.path.abspath(self._binary)
|
||||
if not os.path.isfile(bin_path):
|
||||
raise FileNotFoundError(
|
||||
f"OCaml SX server binary not found: {bin_path}\n"
|
||||
f"Build with: cd hosts/ocaml && eval $(opam env) && dune build"
|
||||
)
|
||||
|
||||
_logger.info("Starting OCaml SX kernel: %s", bin_path)
|
||||
self._proc = await asyncio.create_subprocess_exec(
|
||||
bin_path,
|
||||
stdin=asyncio.subprocess.PIPE,
|
||||
stdout=asyncio.subprocess.PIPE,
|
||||
stderr=asyncio.subprocess.PIPE,
|
||||
)
|
||||
|
||||
# Wait for (ready)
|
||||
line = await self._readline()
|
||||
if line != "(ready)":
|
||||
raise OcamlBridgeError(f"Expected (ready), got: {line!r}")
|
||||
|
||||
self._started = True
|
||||
|
||||
# Verify engine identity
|
||||
self._send("(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)
|
||||
|
||||
async def stop(self) -> None:
|
||||
"""Terminate the subprocess."""
|
||||
if self._proc and self._proc.returncode is None:
|
||||
self._proc.stdin.close()
|
||||
try:
|
||||
await asyncio.wait_for(self._proc.wait(), timeout=5.0)
|
||||
except asyncio.TimeoutError:
|
||||
self._proc.kill()
|
||||
await self._proc.wait()
|
||||
_logger.info("OCaml SX kernel stopped")
|
||||
self._proc = None
|
||||
self._started = False
|
||||
|
||||
async def ping(self) -> str:
|
||||
"""Health check — returns engine name (e.g. 'ocaml-cek')."""
|
||||
async with self._lock:
|
||||
self._send("(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}")
|
||||
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}")
|
||||
return int(float(value)) if value else 0
|
||||
|
||||
async def eval(self, source: str) -> str:
|
||||
"""Evaluate SX expression, return serialized result."""
|
||||
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 ""
|
||||
|
||||
async def render(
|
||||
self,
|
||||
source: str,
|
||||
ctx: dict[str, Any] | None = None,
|
||||
) -> str:
|
||||
"""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)}")')
|
||||
return await self._read_until_ok(ctx)
|
||||
|
||||
async def _ensure_components(self) -> None:
|
||||
"""Load component definitions into the kernel on first use."""
|
||||
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
|
||||
|
||||
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))
|
||||
except Exception as e:
|
||||
_logger.error("Failed to load components into OCaml kernel: %s", e)
|
||||
self._components_loaded = False # retry next time
|
||||
|
||||
async def reset(self) -> None:
|
||||
"""Reset the kernel environment to pristine state."""
|
||||
async with self._lock:
|
||||
self._send("(reset)")
|
||||
kind, value = await self._read_response()
|
||||
if kind == "error":
|
||||
raise OcamlBridgeError(f"reset: {value}")
|
||||
|
||||
# ------------------------------------------------------------------
|
||||
# Internal protocol handling
|
||||
# ------------------------------------------------------------------
|
||||
|
||||
def _send(self, line: str) -> None:
|
||||
"""Write a line to the subprocess stdin."""
|
||||
assert self._proc and self._proc.stdin
|
||||
self._proc.stdin.write((line + "\n").encode())
|
||||
|
||||
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()
|
||||
raise OcamlBridgeError(
|
||||
f"OCaml subprocess died unexpectedly. stderr: {stderr.decode(errors='replace')}"
|
||||
)
|
||||
return data.decode().rstrip("\n")
|
||||
|
||||
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".
|
||||
"""
|
||||
line = await self._readline()
|
||||
return _parse_response(line)
|
||||
|
||||
async def _read_until_ok(
|
||||
self,
|
||||
ctx: dict[str, Any] | None = None,
|
||||
) -> str:
|
||||
"""Read lines until (ok ...) or (error ...).
|
||||
|
||||
Handles (io-request ...) by fulfilling IO and sending (io-response ...).
|
||||
"""
|
||||
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)})")
|
||||
continue
|
||||
|
||||
kind, value = _parse_response(line)
|
||||
if kind == "error":
|
||||
raise OcamlBridgeError(value or "Unknown error")
|
||||
# kind == "ok"
|
||||
return value or ""
|
||||
|
||||
async def _handle_io_request(
|
||||
self,
|
||||
line: str,
|
||||
ctx: dict[str, Any] | None,
|
||||
) -> Any:
|
||||
"""Dispatch an io-request to the appropriate Python handler."""
|
||||
from .parser import parse_all
|
||||
|
||||
# Parse the io-request
|
||||
parsed = parse_all(line)
|
||||
if not parsed or not isinstance(parsed[0], list):
|
||||
raise OcamlBridgeError(f"Malformed io-request: {line}")
|
||||
|
||||
parts = parsed[0]
|
||||
# parts = [Symbol("io-request"), name_str, ...args]
|
||||
if len(parts) < 2:
|
||||
raise OcamlBridgeError(f"Malformed io-request: {line}")
|
||||
|
||||
req_name = _to_str(parts[1])
|
||||
args = parts[2:]
|
||||
|
||||
if req_name == "query":
|
||||
return await self._io_query(args)
|
||||
elif req_name == "action":
|
||||
return await self._io_action(args)
|
||||
elif req_name == "request-arg":
|
||||
return self._io_request_arg(args)
|
||||
elif req_name == "request-method":
|
||||
return self._io_request_method()
|
||||
elif req_name == "ctx":
|
||||
return self._io_ctx(args, ctx)
|
||||
else:
|
||||
raise OcamlBridgeError(f"Unknown io-request type: {req_name}")
|
||||
|
||||
async def _io_query(self, args: list) -> Any:
|
||||
"""Handle (io-request "query" service name params...)."""
|
||||
from shared.infrastructure.internal import fetch_data
|
||||
|
||||
service = _to_str(args[0]) if len(args) > 0 else ""
|
||||
query = _to_str(args[1]) if len(args) > 1 else ""
|
||||
params = _to_dict(args[2]) if len(args) > 2 else {}
|
||||
return await fetch_data(service, query, params)
|
||||
|
||||
async def _io_action(self, args: list) -> Any:
|
||||
"""Handle (io-request "action" service name payload...)."""
|
||||
from shared.infrastructure.internal import call_action
|
||||
|
||||
service = _to_str(args[0]) if len(args) > 0 else ""
|
||||
action = _to_str(args[1]) if len(args) > 1 else ""
|
||||
payload = _to_dict(args[2]) if len(args) > 2 else {}
|
||||
return await call_action(service, action, payload)
|
||||
|
||||
def _io_request_arg(self, args: list) -> Any:
|
||||
"""Handle (io-request "request-arg" name)."""
|
||||
try:
|
||||
from quart import request
|
||||
name = _to_str(args[0]) if args else ""
|
||||
return request.args.get(name)
|
||||
except RuntimeError:
|
||||
return None
|
||||
|
||||
def _io_request_method(self) -> str:
|
||||
"""Handle (io-request "request-method")."""
|
||||
try:
|
||||
from quart import request
|
||||
return request.method
|
||||
except RuntimeError:
|
||||
return "GET"
|
||||
|
||||
def _io_ctx(self, args: list, ctx: dict[str, Any] | None) -> Any:
|
||||
"""Handle (io-request "ctx" key)."""
|
||||
if ctx is None:
|
||||
return None
|
||||
key = _to_str(args[0]) if args else ""
|
||||
return ctx.get(key)
|
||||
|
||||
|
||||
# ------------------------------------------------------------------
|
||||
# Module-level singleton
|
||||
# ------------------------------------------------------------------
|
||||
|
||||
_bridge: OcamlBridge | None = None
|
||||
|
||||
|
||||
async def get_bridge() -> OcamlBridge:
|
||||
"""Get or create the singleton bridge instance."""
|
||||
global _bridge
|
||||
if _bridge is None:
|
||||
_bridge = OcamlBridge()
|
||||
if not _bridge._started:
|
||||
await _bridge.start()
|
||||
return _bridge
|
||||
|
||||
|
||||
# ------------------------------------------------------------------
|
||||
# Helpers
|
||||
# ------------------------------------------------------------------
|
||||
|
||||
def _escape(s: str) -> str:
|
||||
"""Escape a string for embedding in an SX string literal."""
|
||||
return s.replace("\\", "\\\\").replace('"', '\\"').replace("\n", "\\n").replace("\r", "\\r").replace("\t", "\\t")
|
||||
|
||||
|
||||
def _parse_response(line: str) -> tuple[str, str | None]:
|
||||
"""Parse an (ok ...) or (error ...) response line.
|
||||
|
||||
Returns (kind, value) tuple.
|
||||
"""
|
||||
line = line.strip()
|
||||
if line == "(ok)":
|
||||
return ("ok", None)
|
||||
if line.startswith("(ok "):
|
||||
value = line[4:-1] # strip (ok and )
|
||||
# If the value is a quoted string, unquote it
|
||||
if value.startswith('"') and value.endswith('"'):
|
||||
value = _unescape(value[1:-1])
|
||||
return ("ok", value)
|
||||
if line.startswith("(error "):
|
||||
msg = line[7:-1]
|
||||
if msg.startswith('"') and msg.endswith('"'):
|
||||
msg = _unescape(msg[1:-1])
|
||||
return ("error", msg)
|
||||
return ("error", f"Unexpected response: {line}")
|
||||
|
||||
|
||||
def _unescape(s: str) -> str:
|
||||
"""Unescape an SX string literal."""
|
||||
return (
|
||||
s.replace("\\n", "\n")
|
||||
.replace("\\r", "\r")
|
||||
.replace("\\t", "\t")
|
||||
.replace('\\"', '"')
|
||||
.replace("\\\\", "\\")
|
||||
)
|
||||
|
||||
|
||||
def _to_str(val: Any) -> str:
|
||||
"""Convert an SX parsed value to a Python string."""
|
||||
if isinstance(val, str):
|
||||
return val
|
||||
if hasattr(val, "name"):
|
||||
return val.name
|
||||
return str(val)
|
||||
|
||||
|
||||
def _to_dict(val: Any) -> dict:
|
||||
"""Convert an SX parsed value to a Python dict."""
|
||||
if isinstance(val, dict):
|
||||
return val
|
||||
return {}
|
||||
|
||||
|
||||
def _serialize_for_ocaml(val: Any) -> str:
|
||||
"""Serialize a Python value to SX text for sending to OCaml."""
|
||||
if val is None:
|
||||
return "nil"
|
||||
if isinstance(val, bool):
|
||||
return "true" if val else "false"
|
||||
if isinstance(val, (int, float)):
|
||||
if isinstance(val, float) and val == int(val):
|
||||
return str(int(val))
|
||||
return str(val)
|
||||
if isinstance(val, str):
|
||||
return f'"{_escape(val)}"'
|
||||
if isinstance(val, (list, tuple)):
|
||||
items = " ".join(_serialize_for_ocaml(v) for v in val)
|
||||
return f"(list {items})"
|
||||
if isinstance(val, dict):
|
||||
pairs = " ".join(
|
||||
f":{k} {_serialize_for_ocaml(v)}" for k, v in val.items()
|
||||
)
|
||||
return "{" + pairs + "}"
|
||||
return f'"{_escape(str(val))}"'
|
||||
@@ -23,11 +23,28 @@ import logging
|
||||
import os
|
||||
from typing import Any
|
||||
|
||||
from .types import PageDef
|
||||
import traceback
|
||||
|
||||
from .types import EvalError, PageDef
|
||||
|
||||
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
|
||||
msg = _esc(str(e))
|
||||
ctx = _esc(context)
|
||||
return (
|
||||
f'(div :class "sx-eval-error" :style '
|
||||
f'"background:#fef2f2;border:1px solid #fca5a5;'
|
||||
f'color:#991b1b;padding:1rem;margin:1rem 0;'
|
||||
f'border-radius:0.5rem;font-family:monospace;white-space:pre-wrap"'
|
||||
f' (p :style "font-weight:700;margin:0 0 0.5rem" "SX EvalError in {ctx}")'
|
||||
f' (p :style "margin:0" "{msg}"))'
|
||||
)
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Registry — service → page-name → PageDef
|
||||
# ---------------------------------------------------------------------------
|
||||
@@ -511,8 +528,12 @@ async def execute_page_streaming(
|
||||
aside_sx = await _eval_slot(page_def.aside_expr, data_env, ctx) if page_def.aside_expr else ""
|
||||
menu_sx = await _eval_slot(page_def.menu_expr, data_env, ctx) if page_def.menu_expr else ""
|
||||
await _stream_queue.put(("data-single", content_sx, filter_sx, aside_sx, menu_sx))
|
||||
except EvalError as e:
|
||||
logger.error("Streaming data task failed (EvalError): %s\n%s", e, traceback.format_exc())
|
||||
error_sx = _eval_error_sx(e, "page content")
|
||||
await _stream_queue.put(("data-single", error_sx, "", "", ""))
|
||||
except Exception as e:
|
||||
logger.error("Streaming data task failed: %s", e)
|
||||
logger.error("Streaming data task failed: %s\n%s", e, traceback.format_exc())
|
||||
await _stream_queue.put(("data-done",))
|
||||
|
||||
async def _eval_headers():
|
||||
@@ -524,7 +545,7 @@ async def execute_page_streaming(
|
||||
menu = await layout.mobile_menu(tctx, **layout_kwargs)
|
||||
await _stream_queue.put(("headers", rows, menu))
|
||||
except Exception as e:
|
||||
logger.error("Streaming headers task failed: %s", e)
|
||||
logger.error("Streaming headers task failed: %s\n%s", e, traceback.format_exc())
|
||||
await _stream_queue.put(("headers", "", ""))
|
||||
|
||||
data_task = asyncio.create_task(_eval_data_and_content())
|
||||
@@ -629,7 +650,7 @@ async def execute_page_streaming(
|
||||
elif kind == "data-done":
|
||||
remaining -= 1
|
||||
except Exception as e:
|
||||
logger.error("Streaming resolve failed for %s: %s", kind, e)
|
||||
logger.error("Streaming resolve failed for %s: %s\n%s", kind, e, traceback.format_exc())
|
||||
|
||||
yield "\n</body>\n</html>"
|
||||
|
||||
@@ -733,8 +754,13 @@ async def execute_page_streaming_oob(
|
||||
await _stream_queue.put(("data-done",))
|
||||
return
|
||||
await _stream_queue.put(("data-done",))
|
||||
except EvalError as e:
|
||||
logger.error("Streaming OOB data task failed (EvalError): %s\n%s", e, traceback.format_exc())
|
||||
error_sx = _eval_error_sx(e, "page content")
|
||||
await _stream_queue.put(("data", "stream-content", error_sx))
|
||||
await _stream_queue.put(("data-done",))
|
||||
except Exception as e:
|
||||
logger.error("Streaming OOB data task failed: %s", e)
|
||||
logger.error("Streaming OOB data task failed: %s\n%s", e, traceback.format_exc())
|
||||
await _stream_queue.put(("data-done",))
|
||||
|
||||
async def _eval_oob_headers():
|
||||
@@ -745,7 +771,7 @@ async def execute_page_streaming_oob(
|
||||
else:
|
||||
await _stream_queue.put(("headers", ""))
|
||||
except Exception as e:
|
||||
logger.error("Streaming OOB headers task failed: %s", e)
|
||||
logger.error("Streaming OOB headers task failed: %s\n%s", e, traceback.format_exc())
|
||||
await _stream_queue.put(("headers", ""))
|
||||
|
||||
data_task = asyncio.create_task(_eval_data())
|
||||
@@ -836,7 +862,7 @@ async def execute_page_streaming_oob(
|
||||
elif kind == "data-done":
|
||||
remaining -= 1
|
||||
except Exception as e:
|
||||
logger.error("Streaming OOB resolve failed for %s: %s", kind, e)
|
||||
logger.error("Streaming OOB resolve failed for %s: %s\n%s", kind, e, traceback.format_exc())
|
||||
|
||||
return _stream_oob_chunks()
|
||||
|
||||
|
||||
@@ -573,3 +573,32 @@ def prim_json_encode(value) -> str:
|
||||
import json
|
||||
return json.dumps(value, indent=2)
|
||||
|
||||
|
||||
# ---------------------------------------------------------------------------
|
||||
# Scope primitives — delegate to sx_ref.py's scope stack implementation
|
||||
# (shared global state between transpiled and hand-written evaluators)
|
||||
# ---------------------------------------------------------------------------
|
||||
|
||||
def _lazy_scope_primitives():
|
||||
"""Register scope/provide/collect primitives from sx_ref.py.
|
||||
|
||||
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).
|
||||
"""
|
||||
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
|
||||
|
||||
_lazy_scope_primitives()
|
||||
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@@ -1,545 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; adapter-html.sx — HTML string rendering adapter
|
||||
;;
|
||||
;; Renders evaluated SX expressions to HTML strings. Used server-side.
|
||||
;;
|
||||
;; Depends on:
|
||||
;; render.sx — HTML_TAGS, VOID_ELEMENTS, BOOLEAN_ATTRS,
|
||||
;; parse-element-args, render-attrs, definition-form?
|
||||
;; eval.sx — eval-expr, trampoline, expand-macro, process-bindings,
|
||||
;; eval-cond, env-has?, env-get, env-set!, env-merge,
|
||||
;; lambda?, component?, island?, macro?,
|
||||
;; lambda-closure, lambda-params, lambda-body
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
(define render-to-html :effects [render]
|
||||
(fn (expr (env :as dict))
|
||||
(set-render-active! true)
|
||||
(case (type-of expr)
|
||||
;; Literals — render directly
|
||||
"nil" ""
|
||||
"string" (escape-html expr)
|
||||
"number" (str expr)
|
||||
"boolean" (if expr "true" "false")
|
||||
;; List — dispatch to render-list which handles HTML tags, special forms, etc.
|
||||
"list" (if (empty? expr) "" (render-list-to-html expr env))
|
||||
;; Symbol — evaluate then render
|
||||
"symbol" (render-value-to-html (trampoline (eval-expr expr env)) env)
|
||||
;; Keyword — render as text
|
||||
"keyword" (escape-html (keyword-name expr))
|
||||
;; Raw HTML passthrough
|
||||
"raw-html" (raw-html-content expr)
|
||||
;; Spread — emit attrs to nearest element provider
|
||||
"spread" (do (emit! "element-attrs" (spread-attrs expr)) "")
|
||||
;; Everything else — evaluate first
|
||||
:else (render-value-to-html (trampoline (eval-expr expr env)) env))))
|
||||
|
||||
(define render-value-to-html :effects [render]
|
||||
(fn (val (env :as dict))
|
||||
(case (type-of val)
|
||||
"nil" ""
|
||||
"string" (escape-html val)
|
||||
"number" (str val)
|
||||
"boolean" (if val "true" "false")
|
||||
"list" (render-list-to-html val env)
|
||||
"raw-html" (raw-html-content val)
|
||||
"spread" (do (emit! "element-attrs" (spread-attrs val)) "")
|
||||
:else (escape-html (str val)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Render-aware form classification
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define RENDER_HTML_FORMS
|
||||
(list "if" "when" "cond" "case" "let" "let*" "begin" "do"
|
||||
"define" "defcomp" "defisland" "defmacro" "defstyle" "defhandler"
|
||||
"deftype" "defeffect"
|
||||
"map" "map-indexed" "filter" "for-each" "scope" "provide"))
|
||||
|
||||
(define render-html-form? :effects []
|
||||
(fn ((name :as string))
|
||||
(contains? RENDER_HTML_FORMS name)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; render-list-to-html — dispatch on list head
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define render-list-to-html :effects [render]
|
||||
(fn ((expr :as list) (env :as dict))
|
||||
(if (empty? expr)
|
||||
""
|
||||
(let ((head (first expr)))
|
||||
(if (not (= (type-of head) "symbol"))
|
||||
;; Data list — render each item
|
||||
(join "" (map (fn (x) (render-value-to-html x env)) expr))
|
||||
(let ((name (symbol-name head))
|
||||
(args (rest expr)))
|
||||
(cond
|
||||
;; Fragment
|
||||
(= name "<>")
|
||||
(join "" (map (fn (x) (render-to-html x env)) args))
|
||||
|
||||
;; Raw HTML passthrough
|
||||
(= name "raw!")
|
||||
(join "" (map (fn (x) (str (trampoline (eval-expr x env)))) args))
|
||||
|
||||
;; Lake — server-morphable slot within an island
|
||||
(= name "lake")
|
||||
(render-html-lake args env)
|
||||
|
||||
;; Marsh — reactive server-morphable slot within an island
|
||||
(= name "marsh")
|
||||
(render-html-marsh args env)
|
||||
|
||||
;; HTML tag
|
||||
(contains? HTML_TAGS name)
|
||||
(render-html-element name args env)
|
||||
|
||||
;; Island (~name) — reactive component, SSR with hydration markers
|
||||
(and (starts-with? name "~")
|
||||
(env-has? env name)
|
||||
(island? (env-get env name)))
|
||||
(render-html-island (env-get env name) args env)
|
||||
|
||||
;; Component or macro call (~name)
|
||||
(starts-with? name "~")
|
||||
(let ((val (env-get env name)))
|
||||
(cond
|
||||
(component? val)
|
||||
(render-html-component val args env)
|
||||
(macro? val)
|
||||
(render-to-html
|
||||
(expand-macro val args env)
|
||||
env)
|
||||
:else
|
||||
(error (str "Unknown component: " name))))
|
||||
|
||||
;; Render-aware special forms
|
||||
(render-html-form? name)
|
||||
(dispatch-html-form name expr env)
|
||||
|
||||
;; Macro expansion
|
||||
(and (env-has? env name) (macro? (env-get env name)))
|
||||
(render-to-html
|
||||
(expand-macro (env-get env name) args env)
|
||||
env)
|
||||
|
||||
;; Fallback — evaluate then render result
|
||||
:else
|
||||
(render-value-to-html
|
||||
(trampoline (eval-expr expr env))
|
||||
env))))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; dispatch-html-form — render-aware special form handling for HTML output
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define dispatch-html-form :effects [render]
|
||||
(fn ((name :as string) (expr :as list) (env :as dict))
|
||||
(cond
|
||||
;; if
|
||||
(= name "if")
|
||||
(let ((cond-val (trampoline (eval-expr (nth expr 1) env))))
|
||||
(if cond-val
|
||||
(render-to-html (nth expr 2) env)
|
||||
(if (> (len expr) 3)
|
||||
(render-to-html (nth expr 3) env)
|
||||
"")))
|
||||
|
||||
;; when — single body: pass through. Multi: join strings.
|
||||
(= name "when")
|
||||
(if (not (trampoline (eval-expr (nth expr 1) env)))
|
||||
""
|
||||
(if (= (len expr) 3)
|
||||
(render-to-html (nth expr 2) env)
|
||||
(join "" (map (fn (i) (render-to-html (nth expr i) env))
|
||||
(range 2 (len expr))))))
|
||||
|
||||
;; cond
|
||||
(= name "cond")
|
||||
(let ((branch (eval-cond (rest expr) env)))
|
||||
(if branch
|
||||
(render-to-html branch env)
|
||||
""))
|
||||
|
||||
;; case
|
||||
(= name "case")
|
||||
(render-to-html (trampoline (eval-expr expr env)) env)
|
||||
|
||||
;; let / let* — single body: pass through. Multi: join strings.
|
||||
(or (= name "let") (= name "let*"))
|
||||
(let ((local (process-bindings (nth expr 1) env)))
|
||||
(if (= (len expr) 3)
|
||||
(render-to-html (nth expr 2) local)
|
||||
(join "" (map (fn (i) (render-to-html (nth expr i) local))
|
||||
(range 2 (len expr))))))
|
||||
|
||||
;; begin / do — single body: pass through. Multi: join strings.
|
||||
(or (= name "begin") (= name "do"))
|
||||
(if (= (len expr) 2)
|
||||
(render-to-html (nth expr 1) env)
|
||||
(join "" (map (fn (i) (render-to-html (nth expr i) env))
|
||||
(range 1 (len expr)))))
|
||||
|
||||
;; Definition forms — eval for side effects
|
||||
(definition-form? name)
|
||||
(do (trampoline (eval-expr expr env)) "")
|
||||
|
||||
;; map
|
||||
(= name "map")
|
||||
(let ((f (trampoline (eval-expr (nth expr 1) env)))
|
||||
(coll (trampoline (eval-expr (nth expr 2) env))))
|
||||
(join ""
|
||||
(map
|
||||
(fn (item)
|
||||
(if (lambda? f)
|
||||
(render-lambda-html f (list item) env)
|
||||
(render-to-html (apply f (list item)) env)))
|
||||
coll)))
|
||||
|
||||
;; map-indexed
|
||||
(= name "map-indexed")
|
||||
(let ((f (trampoline (eval-expr (nth expr 1) env)))
|
||||
(coll (trampoline (eval-expr (nth expr 2) env))))
|
||||
(join ""
|
||||
(map-indexed
|
||||
(fn (i item)
|
||||
(if (lambda? f)
|
||||
(render-lambda-html f (list i item) env)
|
||||
(render-to-html (apply f (list i item)) env)))
|
||||
coll)))
|
||||
|
||||
;; filter — evaluate fully then render
|
||||
(= name "filter")
|
||||
(render-to-html (trampoline (eval-expr expr env)) env)
|
||||
|
||||
;; for-each (render variant)
|
||||
(= name "for-each")
|
||||
(let ((f (trampoline (eval-expr (nth expr 1) env)))
|
||||
(coll (trampoline (eval-expr (nth expr 2) env))))
|
||||
(join ""
|
||||
(map
|
||||
(fn (item)
|
||||
(if (lambda? f)
|
||||
(render-lambda-html f (list item) env)
|
||||
(render-to-html (apply f (list item)) env)))
|
||||
coll)))
|
||||
|
||||
;; scope — unified render-time dynamic scope
|
||||
(= name "scope")
|
||||
(let ((scope-name (trampoline (eval-expr (nth expr 1) env)))
|
||||
(rest-args (slice expr 2))
|
||||
(scope-val nil)
|
||||
(body-exprs 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! scope-val (trampoline (eval-expr (nth rest-args 1) env)))
|
||||
(set! body-exprs (slice rest-args 2)))
|
||||
(set! body-exprs rest-args))
|
||||
(scope-push! scope-name scope-val)
|
||||
(let ((result (if (= (len body-exprs) 1)
|
||||
(render-to-html (first body-exprs) env)
|
||||
(join "" (map (fn (e) (render-to-html e env)) body-exprs)))))
|
||||
(scope-pop! scope-name)
|
||||
result))
|
||||
|
||||
;; provide — sugar for scope with value
|
||||
(= name "provide")
|
||||
(let ((prov-name (trampoline (eval-expr (nth expr 1) env)))
|
||||
(prov-val (trampoline (eval-expr (nth expr 2) env)))
|
||||
(body-start 3)
|
||||
(body-count (- (len expr) 3)))
|
||||
(scope-push! prov-name prov-val)
|
||||
(let ((result (if (= body-count 1)
|
||||
(render-to-html (nth expr body-start) env)
|
||||
(join "" (map (fn (i) (render-to-html (nth expr i) env))
|
||||
(range body-start (+ body-start body-count)))))))
|
||||
(scope-pop! prov-name)
|
||||
result))
|
||||
|
||||
;; Fallback
|
||||
:else
|
||||
(render-value-to-html (trampoline (eval-expr expr env)) env))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; render-lambda-html — render a lambda body in HTML context
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define render-lambda-html :effects [render]
|
||||
(fn ((f :as lambda) (args :as list) (env :as dict))
|
||||
(let ((local (env-merge (lambda-closure f) env)))
|
||||
(for-each-indexed
|
||||
(fn (i p)
|
||||
(env-set! local p (nth args i)))
|
||||
(lambda-params f))
|
||||
(render-to-html (lambda-body f) local))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; render-html-component — expand and render a component
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define render-html-component :effects [render]
|
||||
(fn ((comp :as component) (args :as list) (env :as dict))
|
||||
;; Expand component and render body through HTML adapter.
|
||||
;; Component body contains rendering forms (HTML tags) that only the
|
||||
;; adapter understands, so expansion must happen here, not in eval-expr.
|
||||
(let ((kwargs (dict))
|
||||
(children (list)))
|
||||
;; Separate keyword args from positional children
|
||||
(reduce
|
||||
(fn (state arg)
|
||||
(let ((skip (get state "skip")))
|
||||
(if skip
|
||||
(assoc state "skip" false "i" (inc (get state "i")))
|
||||
(if (and (= (type-of arg) "keyword")
|
||||
(< (inc (get state "i")) (len args)))
|
||||
(let ((val (trampoline
|
||||
(eval-expr (nth args (inc (get state "i"))) env))))
|
||||
(dict-set! kwargs (keyword-name arg) val)
|
||||
(assoc state "skip" true "i" (inc (get state "i"))))
|
||||
(do
|
||||
(append! children arg)
|
||||
(assoc state "i" (inc (get state "i"))))))))
|
||||
(dict "i" 0 "skip" false)
|
||||
args)
|
||||
;; Build component env: closure + caller env + params
|
||||
(let ((local (env-merge (component-closure comp) env)))
|
||||
;; Bind params from kwargs
|
||||
(for-each
|
||||
(fn (p)
|
||||
(env-set! local p (if (dict-has? kwargs p) (dict-get kwargs p) nil)))
|
||||
(component-params comp))
|
||||
;; If component accepts children, pre-render them to raw HTML
|
||||
(when (component-has-children? comp)
|
||||
(env-set! local "children"
|
||||
(make-raw-html (join "" (map (fn (c) (render-to-html c env)) children)))))
|
||||
(render-to-html (component-body comp) local)))))
|
||||
|
||||
|
||||
(define render-html-element :effects [render]
|
||||
(fn ((tag :as string) (args :as list) (env :as dict))
|
||||
(let ((parsed (parse-element-args args env))
|
||||
(attrs (first parsed))
|
||||
(children (nth parsed 1))
|
||||
(is-void (contains? VOID_ELEMENTS tag)))
|
||||
(if is-void
|
||||
(str "<" tag (render-attrs attrs) " />")
|
||||
;; Provide scope for spread emit!
|
||||
(do
|
||||
(scope-push! "element-attrs" nil)
|
||||
(let ((content (join "" (map (fn (c) (render-to-html c env)) children))))
|
||||
(for-each
|
||||
(fn (spread-dict) (merge-spread-attrs attrs spread-dict))
|
||||
(emitted "element-attrs"))
|
||||
(scope-pop! "element-attrs")
|
||||
(str "<" tag (render-attrs attrs) ">"
|
||||
content
|
||||
"</" tag ">")))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; render-html-lake — SSR rendering of a server-morphable slot
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; (lake :id "name" children...) → <div data-sx-lake="name">children</div>
|
||||
;;
|
||||
;; Lakes are server territory inside islands. The morph can update lake
|
||||
;; content while preserving surrounding reactive DOM.
|
||||
|
||||
(define render-html-lake :effects [render]
|
||||
(fn ((args :as list) (env :as dict))
|
||||
(let ((lake-id nil)
|
||||
(lake-tag "div")
|
||||
(children (list)))
|
||||
(reduce
|
||||
(fn (state arg)
|
||||
(let ((skip (get state "skip")))
|
||||
(if skip
|
||||
(assoc state "skip" false "i" (inc (get state "i")))
|
||||
(if (and (= (type-of arg) "keyword")
|
||||
(< (inc (get state "i")) (len args)))
|
||||
(let ((kname (keyword-name arg))
|
||||
(kval (trampoline (eval-expr (nth args (inc (get state "i"))) env))))
|
||||
(cond
|
||||
(= kname "id") (set! lake-id kval)
|
||||
(= kname "tag") (set! lake-tag kval))
|
||||
(assoc state "skip" true "i" (inc (get state "i"))))
|
||||
(do
|
||||
(append! children arg)
|
||||
(assoc state "i" (inc (get state "i"))))))))
|
||||
(dict "i" 0 "skip" false)
|
||||
args)
|
||||
;; Provide scope for spread emit!
|
||||
(let ((lake-attrs (dict "data-sx-lake" (or lake-id ""))))
|
||||
(scope-push! "element-attrs" nil)
|
||||
(let ((content (join "" (map (fn (c) (render-to-html c env)) children))))
|
||||
(for-each
|
||||
(fn (spread-dict) (merge-spread-attrs lake-attrs spread-dict))
|
||||
(emitted "element-attrs"))
|
||||
(scope-pop! "element-attrs")
|
||||
(str "<" lake-tag (render-attrs lake-attrs) ">"
|
||||
content
|
||||
"</" lake-tag ">"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; render-html-marsh — SSR rendering of a reactive server-morphable slot
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; (marsh :id "name" :tag "div" :transform fn children...)
|
||||
;; → <div data-sx-marsh="name">children</div>
|
||||
;;
|
||||
;; Like a lake but reactive: during morph, new content is parsed as SX and
|
||||
;; re-evaluated in the island's signal scope. Server renders children normally;
|
||||
;; the :transform is a client-only concern.
|
||||
|
||||
(define render-html-marsh :effects [render]
|
||||
(fn ((args :as list) (env :as dict))
|
||||
(let ((marsh-id nil)
|
||||
(marsh-tag "div")
|
||||
(children (list)))
|
||||
(reduce
|
||||
(fn (state arg)
|
||||
(let ((skip (get state "skip")))
|
||||
(if skip
|
||||
(assoc state "skip" false "i" (inc (get state "i")))
|
||||
(if (and (= (type-of arg) "keyword")
|
||||
(< (inc (get state "i")) (len args)))
|
||||
(let ((kname (keyword-name arg))
|
||||
(kval (trampoline (eval-expr (nth args (inc (get state "i"))) env))))
|
||||
(cond
|
||||
(= kname "id") (set! marsh-id kval)
|
||||
(= kname "tag") (set! marsh-tag kval)
|
||||
(= kname "transform") nil)
|
||||
(assoc state "skip" true "i" (inc (get state "i"))))
|
||||
(do
|
||||
(append! children arg)
|
||||
(assoc state "i" (inc (get state "i"))))))))
|
||||
(dict "i" 0 "skip" false)
|
||||
args)
|
||||
;; Provide scope for spread emit!
|
||||
(let ((marsh-attrs (dict "data-sx-marsh" (or marsh-id ""))))
|
||||
(scope-push! "element-attrs" nil)
|
||||
(let ((content (join "" (map (fn (c) (render-to-html c env)) children))))
|
||||
(for-each
|
||||
(fn (spread-dict) (merge-spread-attrs marsh-attrs spread-dict))
|
||||
(emitted "element-attrs"))
|
||||
(scope-pop! "element-attrs")
|
||||
(str "<" marsh-tag (render-attrs marsh-attrs) ">"
|
||||
content
|
||||
"</" marsh-tag ">"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; render-html-island — SSR rendering of a reactive island
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Renders the island body as static HTML wrapped in a container element
|
||||
;; with data-sx-island and data-sx-state attributes. The client hydrates
|
||||
;; this by finding these elements and re-rendering with reactive context.
|
||||
;;
|
||||
;; On the server, signal/deref/reset!/swap! are simple passthrough:
|
||||
;; (signal val) → returns val (no container needed server-side)
|
||||
;; (deref s) → returns s (signal values are plain values server-side)
|
||||
;; (reset! s v) → no-op
|
||||
;; (swap! s f) → no-op
|
||||
|
||||
(define render-html-island :effects [render]
|
||||
(fn ((island :as island) (args :as list) (env :as dict))
|
||||
;; Parse kwargs and children (same pattern as render-html-component)
|
||||
(let ((kwargs (dict))
|
||||
(children (list)))
|
||||
(reduce
|
||||
(fn (state arg)
|
||||
(let ((skip (get state "skip")))
|
||||
(if skip
|
||||
(assoc state "skip" false "i" (inc (get state "i")))
|
||||
(if (and (= (type-of arg) "keyword")
|
||||
(< (inc (get state "i")) (len args)))
|
||||
(let ((val (trampoline
|
||||
(eval-expr (nth args (inc (get state "i"))) env))))
|
||||
(dict-set! kwargs (keyword-name arg) val)
|
||||
(assoc state "skip" true "i" (inc (get state "i"))))
|
||||
(do
|
||||
(append! children arg)
|
||||
(assoc state "i" (inc (get state "i"))))))))
|
||||
(dict "i" 0 "skip" false)
|
||||
args)
|
||||
|
||||
;; Build island env: closure + caller env + params
|
||||
(let ((local (env-merge (component-closure island) env))
|
||||
(island-name (component-name island)))
|
||||
|
||||
;; Bind params from kwargs
|
||||
(for-each
|
||||
(fn (p)
|
||||
(env-set! local p (if (dict-has? kwargs p) (dict-get kwargs p) nil)))
|
||||
(component-params island))
|
||||
|
||||
;; If island accepts children, pre-render them to raw HTML
|
||||
(when (component-has-children? island)
|
||||
(env-set! local "children"
|
||||
(make-raw-html (join "" (map (fn (c) (render-to-html c env)) children)))))
|
||||
|
||||
;; Render the island body as HTML
|
||||
(let ((body-html (render-to-html (component-body island) local))
|
||||
(state-sx (serialize-island-state kwargs)))
|
||||
;; Wrap in container with hydration attributes
|
||||
(str "<span data-sx-island=\"" (escape-attr island-name) "\""
|
||||
(if state-sx
|
||||
(str " data-sx-state=\"" (escape-attr state-sx) "\"")
|
||||
"")
|
||||
">"
|
||||
body-html
|
||||
"</span>"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; serialize-island-state — serialize kwargs to SX for hydration
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Uses the SX serializer (not JSON) so the client can parse with sx-parse.
|
||||
;; Handles all SX types natively: numbers, strings, booleans, nil, lists, dicts.
|
||||
|
||||
(define serialize-island-state :effects []
|
||||
(fn ((kwargs :as dict))
|
||||
(if (empty-dict? kwargs)
|
||||
nil
|
||||
(sx-serialize kwargs))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Platform interface — HTML adapter
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Inherited from render.sx:
|
||||
;; escape-html, escape-attr, raw-html-content
|
||||
;;
|
||||
;; From eval.sx:
|
||||
;; eval-expr, trampoline, expand-macro, process-bindings, eval-cond
|
||||
;; env-has?, env-get, env-set!, env-merge
|
||||
;; lambda?, component?, island?, macro?
|
||||
;; lambda-closure, lambda-params, lambda-body
|
||||
;; component-params, component-body, component-closure,
|
||||
;; component-has-children?, component-name
|
||||
;;
|
||||
;; Raw HTML construction:
|
||||
;; (make-raw-html s) → wrap string as raw HTML (not double-escaped)
|
||||
;;
|
||||
;; Island state serialization:
|
||||
;; (sx-serialize val) → SX source string (from parser.sx)
|
||||
;; (empty-dict? d) → boolean
|
||||
;; (escape-attr s) → HTML attribute escape
|
||||
;;
|
||||
;; Iteration:
|
||||
;; (for-each-indexed fn coll) → call fn(index, item) for each element
|
||||
;; (map-indexed fn coll) → map fn(index, item) over each element
|
||||
;; --------------------------------------------------------------------------
|
||||
@@ -1,407 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; adapter-sx.sx — SX wire format rendering adapter
|
||||
;;
|
||||
;; Serializes SX expressions for client-side rendering.
|
||||
;; Component calls are NOT expanded — they're sent to the client as-is.
|
||||
;; HTML tags are serialized as SX source text. Special forms are evaluated.
|
||||
;;
|
||||
;; Depends on:
|
||||
;; render.sx — HTML_TAGS
|
||||
;; eval.sx — eval-expr, trampoline, call-lambda, expand-macro
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
(define render-to-sx :effects [render]
|
||||
(fn (expr (env :as dict))
|
||||
(let ((result (aser expr env)))
|
||||
;; aser-call already returns serialized SX strings;
|
||||
;; only serialize non-string values
|
||||
(if (= (type-of result) "string")
|
||||
result
|
||||
(serialize result)))))
|
||||
|
||||
(define aser :effects [render]
|
||||
(fn ((expr :as any) (env :as dict))
|
||||
;; Evaluate for SX wire format — serialize rendering forms,
|
||||
;; evaluate control flow and function calls.
|
||||
(set-render-active! true)
|
||||
(let ((result
|
||||
(case (type-of expr)
|
||||
"number" expr
|
||||
"string" expr
|
||||
"boolean" expr
|
||||
"nil" nil
|
||||
|
||||
"symbol"
|
||||
(let ((name (symbol-name expr)))
|
||||
(cond
|
||||
(env-has? env name) (env-get env name)
|
||||
(primitive? name) (get-primitive name)
|
||||
(= name "true") true
|
||||
(= name "false") false
|
||||
(= name "nil") nil
|
||||
:else (error (str "Undefined symbol: " name))))
|
||||
|
||||
"keyword" (keyword-name expr)
|
||||
|
||||
"list"
|
||||
(if (empty? expr)
|
||||
(list)
|
||||
(aser-list expr env))
|
||||
|
||||
;; Spread — emit attrs to nearest element provider
|
||||
"spread" (do (emit! "element-attrs" (spread-attrs expr)) nil)
|
||||
|
||||
:else expr)))
|
||||
;; Catch spread values from function calls and symbol lookups
|
||||
(if (spread? result)
|
||||
(do (emit! "element-attrs" (spread-attrs result)) nil)
|
||||
result))))
|
||||
|
||||
|
||||
(define aser-list :effects [render]
|
||||
(fn ((expr :as list) (env :as dict))
|
||||
(let ((head (first expr))
|
||||
(args (rest expr)))
|
||||
(if (not (= (type-of head) "symbol"))
|
||||
(map (fn (x) (aser x env)) expr)
|
||||
(let ((name (symbol-name head)))
|
||||
(cond
|
||||
;; Fragment — serialize children
|
||||
(= name "<>")
|
||||
(aser-fragment args env)
|
||||
|
||||
;; Component call — serialize WITHOUT expanding
|
||||
(starts-with? name "~")
|
||||
(aser-call name args env)
|
||||
|
||||
;; Lake — serialize (server-morphable slot)
|
||||
(= name "lake")
|
||||
(aser-call name args env)
|
||||
|
||||
;; Marsh — serialize (reactive server-morphable slot)
|
||||
(= name "marsh")
|
||||
(aser-call name args env)
|
||||
|
||||
;; HTML tag — serialize
|
||||
(contains? HTML_TAGS name)
|
||||
(aser-call name args env)
|
||||
|
||||
;; Special/HO forms — evaluate (produces data)
|
||||
(or (special-form? name) (ho-form? name))
|
||||
(aser-special name expr env)
|
||||
|
||||
;; Macro — expand then aser
|
||||
(and (env-has? env name) (macro? (env-get env name)))
|
||||
(aser (expand-macro (env-get env name) args env) env)
|
||||
|
||||
;; Function call — evaluate fully
|
||||
:else
|
||||
(let ((f (trampoline (eval-expr head env)))
|
||||
(evaled-args (map (fn (a) (trampoline (eval-expr a env))) args)))
|
||||
(cond
|
||||
(and (callable? f) (not (lambda? f)) (not (component? f)) (not (island? f)))
|
||||
(apply f evaled-args)
|
||||
(lambda? f)
|
||||
(trampoline (call-lambda f evaled-args env))
|
||||
(component? f)
|
||||
(aser-call (str "~" (component-name f)) args env)
|
||||
(island? f)
|
||||
(aser-call (str "~" (component-name f)) args env)
|
||||
:else (error (str "Not callable: " (inspect f)))))))))))
|
||||
|
||||
|
||||
(define aser-fragment :effects [render]
|
||||
(fn ((children :as list) (env :as dict))
|
||||
;; Serialize (<> child1 child2 ...) to sx source string
|
||||
;; Must flatten list results (e.g. from map/filter) to avoid nested parens
|
||||
(let ((parts (list)))
|
||||
(for-each
|
||||
(fn (c)
|
||||
(let ((result (aser c env)))
|
||||
(if (= (type-of result) "list")
|
||||
(for-each
|
||||
(fn (item)
|
||||
(when (not (nil? item))
|
||||
(append! parts (serialize item))))
|
||||
result)
|
||||
(when (not (nil? result))
|
||||
(append! parts (serialize result))))))
|
||||
children)
|
||||
(if (empty? parts)
|
||||
""
|
||||
(str "(<> " (join " " parts) ")")))))
|
||||
|
||||
|
||||
(define aser-call :effects [render]
|
||||
(fn ((name :as string) (args :as list) (env :as dict))
|
||||
;; Serialize (name :key val child ...) — evaluate args but keep as sx
|
||||
;; Uses for-each + mutable state (not reduce) so bootstrapper emits for-loops
|
||||
;; that can contain nested for-each for list flattening.
|
||||
;; Separate attrs and children so emitted spread attrs go before children.
|
||||
(let ((attr-parts (list))
|
||||
(child-parts (list))
|
||||
(skip false)
|
||||
(i 0))
|
||||
;; Provide scope for spread emit!
|
||||
(scope-push! "element-attrs" nil)
|
||||
(for-each
|
||||
(fn (arg)
|
||||
(if skip
|
||||
(do (set! skip false)
|
||||
(set! i (inc i)))
|
||||
(if (and (= (type-of arg) "keyword")
|
||||
(< (inc i) (len args)))
|
||||
(let ((val (aser (nth args (inc i)) env)))
|
||||
(when (not (nil? val))
|
||||
(append! attr-parts (str ":" (keyword-name arg)))
|
||||
(append! attr-parts (serialize val)))
|
||||
(set! skip true)
|
||||
(set! i (inc i)))
|
||||
(let ((val (aser arg env)))
|
||||
(when (not (nil? val))
|
||||
(if (= (type-of val) "list")
|
||||
(for-each
|
||||
(fn (item)
|
||||
(when (not (nil? item))
|
||||
(append! child-parts (serialize item))))
|
||||
val)
|
||||
(append! child-parts (serialize val))))
|
||||
(set! i (inc i))))))
|
||||
args)
|
||||
;; Collect emitted spread attrs — goes after explicit attrs, before children
|
||||
(for-each
|
||||
(fn (spread-dict)
|
||||
(for-each
|
||||
(fn (k)
|
||||
(let ((v (dict-get spread-dict k)))
|
||||
(append! attr-parts (str ":" k))
|
||||
(append! attr-parts (serialize v))))
|
||||
(keys spread-dict)))
|
||||
(emitted "element-attrs"))
|
||||
(scope-pop! "element-attrs")
|
||||
(let ((parts (concat (list name) attr-parts child-parts)))
|
||||
(str "(" (join " " parts) ")")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Form classification
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define SPECIAL_FORM_NAMES
|
||||
(list "if" "when" "cond" "case" "and" "or"
|
||||
"let" "let*" "lambda" "fn"
|
||||
"define" "defcomp" "defmacro" "defstyle"
|
||||
"defhandler" "defpage" "defquery" "defaction" "defrelation"
|
||||
"begin" "do" "quote" "quasiquote"
|
||||
"->" "set!" "letrec" "dynamic-wind" "defisland"
|
||||
"deftype" "defeffect" "scope" "provide"))
|
||||
|
||||
(define HO_FORM_NAMES
|
||||
(list "map" "map-indexed" "filter" "reduce"
|
||||
"some" "every?" "for-each"))
|
||||
|
||||
(define special-form? :effects []
|
||||
(fn ((name :as string))
|
||||
(contains? SPECIAL_FORM_NAMES name)))
|
||||
|
||||
(define ho-form? :effects []
|
||||
(fn ((name :as string))
|
||||
(contains? HO_FORM_NAMES name)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; aser-special — evaluate special/HO forms in aser mode
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Control flow forms evaluate conditions normally but render branches
|
||||
;; through aser (serializing tags/components instead of rendering HTML).
|
||||
;; Definition forms evaluate for side effects and return nil.
|
||||
|
||||
(define aser-special :effects [render]
|
||||
(fn ((name :as string) (expr :as list) (env :as dict))
|
||||
(let ((args (rest expr)))
|
||||
(cond
|
||||
;; if — evaluate condition, aser chosen branch
|
||||
(= name "if")
|
||||
(if (trampoline (eval-expr (first args) env))
|
||||
(aser (nth args 1) env)
|
||||
(if (> (len args) 2)
|
||||
(aser (nth args 2) env)
|
||||
nil))
|
||||
|
||||
;; when — evaluate condition, aser body if true
|
||||
(= name "when")
|
||||
(if (not (trampoline (eval-expr (first args) env)))
|
||||
nil
|
||||
(let ((result nil))
|
||||
(for-each (fn (body) (set! result (aser body env)))
|
||||
(rest args))
|
||||
result))
|
||||
|
||||
;; cond — evaluate conditions, aser matching branch
|
||||
(= name "cond")
|
||||
(let ((branch (eval-cond args env)))
|
||||
(if branch (aser branch env) nil))
|
||||
|
||||
;; case — evaluate match value, check each pair
|
||||
(= name "case")
|
||||
(let ((match-val (trampoline (eval-expr (first args) env)))
|
||||
(clauses (rest args)))
|
||||
(eval-case-aser match-val clauses env))
|
||||
|
||||
;; let / let*
|
||||
(or (= name "let") (= name "let*"))
|
||||
(let ((local (process-bindings (first args) env))
|
||||
(result nil))
|
||||
(for-each (fn (body) (set! result (aser body local)))
|
||||
(rest args))
|
||||
result)
|
||||
|
||||
;; begin / do
|
||||
(or (= name "begin") (= name "do"))
|
||||
(let ((result nil))
|
||||
(for-each (fn (body) (set! result (aser body env))) args)
|
||||
result)
|
||||
|
||||
;; and — short-circuit
|
||||
(= name "and")
|
||||
(let ((result true))
|
||||
(some (fn (arg)
|
||||
(set! result (trampoline (eval-expr arg env)))
|
||||
(not result))
|
||||
args)
|
||||
result)
|
||||
|
||||
;; or — short-circuit
|
||||
(= name "or")
|
||||
(let ((result false))
|
||||
(some (fn (arg)
|
||||
(set! result (trampoline (eval-expr arg env)))
|
||||
result)
|
||||
args)
|
||||
result)
|
||||
|
||||
;; map — evaluate function and collection, map through aser
|
||||
(= name "map")
|
||||
(let ((f (trampoline (eval-expr (first args) env)))
|
||||
(coll (trampoline (eval-expr (nth args 1) env))))
|
||||
(map (fn (item)
|
||||
(if (lambda? f)
|
||||
(let ((local (env-merge (lambda-closure f) env)))
|
||||
(env-set! local (first (lambda-params f)) item)
|
||||
(aser (lambda-body f) local))
|
||||
(cek-call f (list item))))
|
||||
coll))
|
||||
|
||||
;; map-indexed
|
||||
(= name "map-indexed")
|
||||
(let ((f (trampoline (eval-expr (first args) env)))
|
||||
(coll (trampoline (eval-expr (nth args 1) env))))
|
||||
(map-indexed (fn (i item)
|
||||
(if (lambda? f)
|
||||
(let ((local (env-merge (lambda-closure f) env)))
|
||||
(env-set! local (first (lambda-params f)) i)
|
||||
(env-set! local (nth (lambda-params f) 1) item)
|
||||
(aser (lambda-body f) local))
|
||||
(cek-call f (list i item))))
|
||||
coll))
|
||||
|
||||
;; for-each — evaluate for side effects, aser each body
|
||||
(= name "for-each")
|
||||
(let ((f (trampoline (eval-expr (first args) env)))
|
||||
(coll (trampoline (eval-expr (nth args 1) env)))
|
||||
(results (list)))
|
||||
(for-each (fn (item)
|
||||
(if (lambda? f)
|
||||
(let ((local (env-merge (lambda-closure f) env)))
|
||||
(env-set! local (first (lambda-params f)) item)
|
||||
(append! results (aser (lambda-body f) local)))
|
||||
(cek-call f (list item))))
|
||||
coll)
|
||||
(if (empty? results) nil results))
|
||||
|
||||
;; defisland — evaluate AND serialize (client needs the definition)
|
||||
(= name "defisland")
|
||||
(do (trampoline (eval-expr expr env))
|
||||
(serialize expr))
|
||||
|
||||
;; Definition forms — evaluate for side effects
|
||||
(or (= name "define") (= name "defcomp") (= name "defmacro")
|
||||
(= name "defstyle") (= name "defhandler") (= name "defpage")
|
||||
(= name "defquery") (= name "defaction") (= name "defrelation")
|
||||
(= name "deftype") (= name "defeffect"))
|
||||
(do (trampoline (eval-expr expr env)) nil)
|
||||
|
||||
;; scope — unified render-time dynamic scope
|
||||
(= name "scope")
|
||||
(let ((scope-name (trampoline (eval-expr (first args) env)))
|
||||
(rest-args (rest args))
|
||||
(scope-val nil)
|
||||
(body-args 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! scope-val (trampoline (eval-expr (nth rest-args 1) env)))
|
||||
(set! body-args (slice rest-args 2)))
|
||||
(set! body-args rest-args))
|
||||
(scope-push! scope-name scope-val)
|
||||
(let ((result nil))
|
||||
(for-each (fn (body) (set! result (aser body env)))
|
||||
body-args)
|
||||
(scope-pop! scope-name)
|
||||
result))
|
||||
|
||||
;; provide — sugar for scope with value
|
||||
(= name "provide")
|
||||
(let ((prov-name (trampoline (eval-expr (first args) env)))
|
||||
(prov-val (trampoline (eval-expr (nth args 1) env)))
|
||||
(result nil))
|
||||
(scope-push! prov-name prov-val)
|
||||
(for-each (fn (body) (set! result (aser body env)))
|
||||
(slice args 2))
|
||||
(scope-pop! prov-name)
|
||||
result)
|
||||
|
||||
;; Everything else — evaluate normally
|
||||
:else
|
||||
(trampoline (eval-expr expr env))))))
|
||||
|
||||
|
||||
;; Helper: case dispatch for aser mode
|
||||
(define eval-case-aser :effects [render]
|
||||
(fn (match-val (clauses :as list) (env :as dict))
|
||||
(if (< (len clauses) 2)
|
||||
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"))))
|
||||
(aser body env)
|
||||
(if (= match-val (trampoline (eval-expr test env)))
|
||||
(aser body env)
|
||||
(eval-case-aser match-val (slice clauses 2) env)))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Platform interface — SX wire adapter
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; From eval.sx:
|
||||
;; eval-expr, trampoline, call-lambda, expand-macro
|
||||
;; env-has?, env-get, env-set!, env-merge, callable?, lambda?, component?,
|
||||
;; macro?, island?, primitive?, get-primitive, component-name
|
||||
;; lambda-closure, lambda-params, lambda-body
|
||||
;;
|
||||
;; From render.sx:
|
||||
;; HTML_TAGS, eval-cond, process-bindings
|
||||
;;
|
||||
;; From parser.sx:
|
||||
;; serialize (= sx-serialize)
|
||||
;;
|
||||
;; From signals.sx (optional):
|
||||
;; invoke
|
||||
;; --------------------------------------------------------------------------
|
||||
@@ -1,552 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; boot.sx — Browser boot, mount, hydrate, script processing
|
||||
;;
|
||||
;; Handles the browser startup lifecycle:
|
||||
;; 1. CSS tracking init
|
||||
;; 2. Component script processing (from <script type="text/sx">)
|
||||
;; 3. Hydration of [data-sx] elements
|
||||
;; 4. Engine element processing
|
||||
;;
|
||||
;; Also provides the public mounting/hydration API:
|
||||
;; mount, hydrate, update, render-component
|
||||
;;
|
||||
;; Depends on:
|
||||
;; orchestration.sx — process-elements, engine-init
|
||||
;; adapter-dom.sx — render-to-dom
|
||||
;; render.sx — shared registries
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Head element hoisting (full version)
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Moves <meta>, <title>, <link rel=canonical>, <script type=application/ld+json>
|
||||
;; from rendered content to <head>, deduplicating as needed.
|
||||
|
||||
(define HEAD_HOIST_SELECTOR
|
||||
"meta, title, link[rel='canonical'], script[type='application/ld+json']")
|
||||
|
||||
(define hoist-head-elements-full :effects [mutation io]
|
||||
(fn (root)
|
||||
(let ((els (dom-query-all root HEAD_HOIST_SELECTOR)))
|
||||
(for-each
|
||||
(fn (el)
|
||||
(let ((tag (lower (dom-tag-name el))))
|
||||
(cond
|
||||
;; <title> — replace document title
|
||||
(= tag "title")
|
||||
(do
|
||||
(set-document-title (dom-text-content el))
|
||||
(dom-remove-child (dom-parent el) el))
|
||||
|
||||
;; <meta> — deduplicate by name or property
|
||||
(= tag "meta")
|
||||
(do
|
||||
(let ((name (dom-get-attr el "name"))
|
||||
(prop (dom-get-attr el "property")))
|
||||
(when name
|
||||
(remove-head-element (str "meta[name=\"" name "\"]")))
|
||||
(when prop
|
||||
(remove-head-element (str "meta[property=\"" prop "\"]"))))
|
||||
(dom-remove-child (dom-parent el) el)
|
||||
(dom-append-to-head el))
|
||||
|
||||
;; <link rel=canonical> — deduplicate
|
||||
(and (= tag "link")
|
||||
(= (dom-get-attr el "rel") "canonical"))
|
||||
(do
|
||||
(remove-head-element "link[rel=\"canonical\"]")
|
||||
(dom-remove-child (dom-parent el) el)
|
||||
(dom-append-to-head el))
|
||||
|
||||
;; Everything else (ld+json, etc.) — just move
|
||||
:else
|
||||
(do
|
||||
(dom-remove-child (dom-parent el) el)
|
||||
(dom-append-to-head el)))))
|
||||
els))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Mount — render SX source into a DOM element
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define sx-mount :effects [mutation io]
|
||||
(fn (target (source :as string) (extra-env :as dict))
|
||||
;; Render SX source string into target element.
|
||||
;; target: Element or CSS selector string
|
||||
;; source: SX source string
|
||||
;; extra-env: optional extra bindings dict
|
||||
(let ((el (resolve-mount-target target)))
|
||||
(when el
|
||||
(let ((node (sx-render-with-env source extra-env)))
|
||||
(dom-set-text-content el "")
|
||||
(dom-append el node)
|
||||
;; Hoist head elements from rendered content
|
||||
(hoist-head-elements-full el)
|
||||
;; Process sx- attributes, hydrate data-sx and islands
|
||||
(process-elements el)
|
||||
(sx-hydrate-elements el)
|
||||
(sx-hydrate-islands el)
|
||||
(run-post-render-hooks))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Resolve Suspense — replace streaming placeholder with resolved content
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Called by inline <script> tags that arrive during chunked transfer:
|
||||
;; __sxResolve("content", "(~article :title \"Hello\")")
|
||||
;;
|
||||
;; Finds the suspense wrapper by data-suspense attribute, renders the
|
||||
;; new SX content, and replaces the wrapper's children.
|
||||
|
||||
(define resolve-suspense :effects [mutation io]
|
||||
(fn ((id :as string) (sx :as string))
|
||||
;; Process any new <script type="text/sx"> tags that arrived via
|
||||
;; streaming (e.g. extra component defs) before resolving.
|
||||
(process-sx-scripts nil)
|
||||
(let ((el (dom-query (str "[data-suspense=\"" id "\"]"))))
|
||||
(if el
|
||||
(do
|
||||
;; parse returns a list of expressions — render each individually
|
||||
;; (mirroring the public render() API).
|
||||
(let ((exprs (parse sx))
|
||||
(env (get-render-env nil)))
|
||||
(dom-set-text-content el "")
|
||||
(for-each (fn (expr)
|
||||
(dom-append el (render-to-dom expr env nil)))
|
||||
exprs)
|
||||
(process-elements el)
|
||||
(sx-hydrate-elements el)
|
||||
(sx-hydrate-islands el)
|
||||
(run-post-render-hooks)
|
||||
(dom-dispatch el "sx:resolved" {:id id})))
|
||||
(log-warn (str "resolveSuspense: no element for id=" id))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Hydrate — render all [data-sx] elements
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define sx-hydrate-elements :effects [mutation io]
|
||||
(fn (root)
|
||||
;; Find all [data-sx] elements within root and render them.
|
||||
(let ((els (dom-query-all (or root (dom-body)) "[data-sx]")))
|
||||
(for-each
|
||||
(fn (el)
|
||||
(when (not (is-processed? el "hydrated"))
|
||||
(mark-processed! el "hydrated")
|
||||
(sx-update-element el nil)))
|
||||
els))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Update — re-render a [data-sx] element with new env data
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define sx-update-element :effects [mutation io]
|
||||
(fn (el new-env)
|
||||
;; Re-render a [data-sx] element.
|
||||
;; Reads source from data-sx attr, base env from data-sx-env attr.
|
||||
(let ((target (resolve-mount-target el)))
|
||||
(when target
|
||||
(let ((source (dom-get-attr target "data-sx")))
|
||||
(when source
|
||||
(let ((base-env (parse-env-attr target))
|
||||
(env (merge-envs base-env new-env)))
|
||||
(let ((node (sx-render-with-env source env)))
|
||||
(dom-set-text-content target "")
|
||||
(dom-append target node)
|
||||
;; Update stored env if new-env provided
|
||||
(when new-env
|
||||
(store-env-attr target base-env new-env))))))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Render component — build synthetic call from kwargs dict
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define sx-render-component :effects [mutation io]
|
||||
(fn ((name :as string) (kwargs :as dict) (extra-env :as dict))
|
||||
;; Render a named component with keyword args.
|
||||
;; name: component name (with or without ~ prefix)
|
||||
;; kwargs: dict of param-name → value
|
||||
;; extra-env: optional extra env bindings
|
||||
(let ((full-name (if (starts-with? name "~") name (str "~" name))))
|
||||
(let ((env (get-render-env extra-env))
|
||||
(comp (env-get env full-name)))
|
||||
(if (not (component? comp))
|
||||
(error (str "Unknown component: " full-name))
|
||||
;; Build synthetic call expression
|
||||
(let ((call-expr (list (make-symbol full-name))))
|
||||
(for-each
|
||||
(fn ((k :as string))
|
||||
(append! call-expr (make-keyword (to-kebab k)))
|
||||
(append! call-expr (dict-get kwargs k)))
|
||||
(keys kwargs))
|
||||
(render-to-dom call-expr env nil)))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Script processing — <script type="text/sx">
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define process-sx-scripts :effects [mutation io]
|
||||
(fn (root)
|
||||
;; Process all <script type="text/sx"> tags.
|
||||
;; - data-components + data-hash → localStorage cache
|
||||
;; - data-mount="<selector>" → render into target
|
||||
;; - Default: load as components
|
||||
(let ((scripts (query-sx-scripts root)))
|
||||
(for-each
|
||||
(fn (s)
|
||||
(when (not (is-processed? s "script"))
|
||||
(mark-processed! s "script")
|
||||
(let ((text (dom-text-content s)))
|
||||
(cond
|
||||
;; Component definitions
|
||||
(dom-has-attr? s "data-components")
|
||||
(process-component-script s text)
|
||||
|
||||
;; Empty script — skip
|
||||
(or (nil? text) (empty? (trim text)))
|
||||
nil
|
||||
|
||||
;; Init scripts — evaluate SX for side effects (event listeners etc.)
|
||||
(dom-has-attr? s "data-init")
|
||||
(let ((exprs (sx-parse text)))
|
||||
(for-each
|
||||
(fn (expr) (eval-expr expr (env-extend (dict))))
|
||||
exprs))
|
||||
|
||||
;; Mount directive
|
||||
(dom-has-attr? s "data-mount")
|
||||
(let ((mount-sel (dom-get-attr s "data-mount"))
|
||||
(target (dom-query mount-sel)))
|
||||
(when target
|
||||
(sx-mount target text nil)))
|
||||
|
||||
;; Default: load as components
|
||||
:else
|
||||
(sx-load-components text)))))
|
||||
scripts))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Component script with caching
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define process-component-script :effects [mutation io]
|
||||
(fn (script (text :as string))
|
||||
;; Handle <script type="text/sx" data-components data-hash="...">
|
||||
(let ((hash (dom-get-attr script "data-hash")))
|
||||
(if (nil? hash)
|
||||
;; Legacy: no hash — just load inline
|
||||
(when (and text (not (empty? (trim text))))
|
||||
(sx-load-components text))
|
||||
;; Hash-based caching
|
||||
(let ((has-inline (and text (not (empty? (trim text))))))
|
||||
(let ((cached-hash (local-storage-get "sx-components-hash")))
|
||||
(if (= cached-hash hash)
|
||||
;; Cache hit
|
||||
(if has-inline
|
||||
;; Server sent full source (cookie stale) — update cache
|
||||
(do
|
||||
(local-storage-set "sx-components-hash" hash)
|
||||
(local-storage-set "sx-components-src" text)
|
||||
(sx-load-components text)
|
||||
(log-info "components: downloaded (cookie stale)"))
|
||||
;; Server omitted source — load from cache
|
||||
(let ((cached (local-storage-get "sx-components-src")))
|
||||
(if cached
|
||||
(do
|
||||
(sx-load-components cached)
|
||||
(log-info (str "components: cached (" hash ")")))
|
||||
;; Cache entry missing — clear cookie and reload
|
||||
(do
|
||||
(clear-sx-comp-cookie)
|
||||
(browser-reload)))))
|
||||
;; Cache miss — hash mismatch
|
||||
(if has-inline
|
||||
;; Server sent full source — cache it
|
||||
(do
|
||||
(local-storage-set "sx-components-hash" hash)
|
||||
(local-storage-set "sx-components-src" text)
|
||||
(sx-load-components text)
|
||||
(log-info (str "components: downloaded (" hash ")")))
|
||||
;; Server omitted but cache stale — clear and reload
|
||||
(do
|
||||
(local-storage-remove "sx-components-hash")
|
||||
(local-storage-remove "sx-components-src")
|
||||
(clear-sx-comp-cookie)
|
||||
(browser-reload)))))
|
||||
(set-sx-comp-cookie hash))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Page registry for client-side routing
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define _page-routes (list))
|
||||
|
||||
(define process-page-scripts :effects [mutation io]
|
||||
(fn ()
|
||||
;; Process <script type="text/sx-pages"> tags.
|
||||
;; Parses SX page registry and builds route entries with parsed patterns.
|
||||
(let ((scripts (query-page-scripts)))
|
||||
(log-info (str "pages: found " (len scripts) " script tags"))
|
||||
(for-each
|
||||
(fn (s)
|
||||
(when (not (is-processed? s "pages"))
|
||||
(mark-processed! s "pages")
|
||||
(let ((text (dom-text-content s)))
|
||||
(log-info (str "pages: script text length=" (if text (len text) 0)))
|
||||
(if (and text (not (empty? (trim text))))
|
||||
(let ((pages (parse text)))
|
||||
(log-info (str "pages: parsed " (len pages) " entries"))
|
||||
(for-each
|
||||
(fn ((page :as dict))
|
||||
(append! _page-routes
|
||||
(merge page
|
||||
{"parsed" (parse-route-pattern (get page "path"))})))
|
||||
pages))
|
||||
(log-warn "pages: script tag is empty")))))
|
||||
scripts)
|
||||
(log-info (str "pages: " (len _page-routes) " routes loaded")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Island hydration — activate reactive islands from SSR output
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; The server renders islands as:
|
||||
;; <div data-sx-island="counter" data-sx-state='{"initial": 0}'>
|
||||
;; ...static HTML...
|
||||
;; </div>
|
||||
;;
|
||||
;; Hydration:
|
||||
;; 1. Find all [data-sx-island] elements
|
||||
;; 2. Look up the island component by name
|
||||
;; 3. Parse data-sx-state into kwargs
|
||||
;; 4. Re-render the island body in a reactive context
|
||||
;; 5. Morph existing DOM to preserve structure, focus, scroll
|
||||
;; 6. Store disposers on the element for cleanup
|
||||
|
||||
(define sx-hydrate-islands :effects [mutation io]
|
||||
(fn (root)
|
||||
(let ((els (dom-query-all (or root (dom-body)) "[data-sx-island]")))
|
||||
(for-each
|
||||
(fn (el)
|
||||
(when (not (is-processed? el "island-hydrated"))
|
||||
(mark-processed! el "island-hydrated")
|
||||
(hydrate-island el)))
|
||||
els))))
|
||||
|
||||
(define hydrate-island :effects [mutation io]
|
||||
(fn (el)
|
||||
(let ((name (dom-get-attr el "data-sx-island"))
|
||||
(state-sx (or (dom-get-attr el "data-sx-state") "{}")))
|
||||
(let ((comp-name (str "~" name))
|
||||
(env (get-render-env nil)))
|
||||
(let ((comp (env-get env comp-name)))
|
||||
(if (not (or (component? comp) (island? comp)))
|
||||
(log-warn (str "hydrate-island: unknown island " comp-name))
|
||||
|
||||
;; Parse state and build keyword args — SX format, not JSON
|
||||
(let ((kwargs (or (first (sx-parse state-sx)) {}))
|
||||
(disposers (list))
|
||||
(local (env-merge (component-closure comp) env)))
|
||||
|
||||
;; Bind params from kwargs
|
||||
(for-each
|
||||
(fn ((p :as string))
|
||||
(env-set! local p (if (dict-has? kwargs p) (dict-get kwargs p) nil)))
|
||||
(component-params comp))
|
||||
|
||||
;; Render the island body in a reactive scope
|
||||
(let ((body-dom
|
||||
(with-island-scope
|
||||
(fn (disposable) (append! disposers disposable))
|
||||
(fn () (render-to-dom (component-body comp) local nil)))))
|
||||
|
||||
;; Clear existing content and append reactive DOM directly.
|
||||
;; Unlike morph-children, this preserves addEventListener-based
|
||||
;; event handlers on the freshly rendered nodes.
|
||||
(dom-set-text-content el "")
|
||||
(dom-append el body-dom)
|
||||
|
||||
;; Store disposers for cleanup
|
||||
(dom-set-data el "sx-disposers" disposers)
|
||||
|
||||
;; Process any sx- attributes on new content
|
||||
(process-elements el)
|
||||
|
||||
(log-info (str "hydrated island: " comp-name
|
||||
" (" (len disposers) " disposers)"))))))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Island disposal — clean up when island removed from DOM
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define dispose-island :effects [mutation io]
|
||||
(fn (el)
|
||||
(let ((disposers (dom-get-data el "sx-disposers")))
|
||||
(when disposers
|
||||
(for-each
|
||||
(fn ((d :as lambda))
|
||||
(when (callable? d) (d)))
|
||||
disposers)
|
||||
(dom-set-data el "sx-disposers" nil)))))
|
||||
|
||||
(define dispose-islands-in :effects [mutation io]
|
||||
(fn (root)
|
||||
;; Dispose islands within root, but SKIP hydrated islands —
|
||||
;; they may be preserved across morphs. Only dispose islands
|
||||
;; that are not currently hydrated (e.g. freshly parsed content
|
||||
;; being discarded) or that have been explicitly detached.
|
||||
(when root
|
||||
(let ((islands (dom-query-all root "[data-sx-island]")))
|
||||
(when (and islands (not (empty? islands)))
|
||||
(let ((to-dispose (filter
|
||||
(fn (el) (not (is-processed? el "island-hydrated")))
|
||||
islands)))
|
||||
(when (not (empty? to-dispose))
|
||||
(log-info (str "disposing " (len to-dispose) " island(s)"))
|
||||
(for-each dispose-island to-dispose))))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Render hooks — generic pre/post callbacks for hydration, swap, mount.
|
||||
;; The spec calls these at render boundaries; the app decides what to do.
|
||||
;; Pre-render: setup before DOM changes (e.g. prepare state).
|
||||
;; Post-render: cleanup after DOM changes (e.g. flush collected CSS).
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define *pre-render-hooks* (list))
|
||||
(define *post-render-hooks* (list))
|
||||
|
||||
(define register-pre-render-hook :effects [mutation]
|
||||
(fn ((hook-fn :as lambda))
|
||||
(append! *pre-render-hooks* hook-fn)))
|
||||
|
||||
(define register-post-render-hook :effects [mutation]
|
||||
(fn ((hook-fn :as lambda))
|
||||
(append! *post-render-hooks* hook-fn)))
|
||||
|
||||
(define run-pre-render-hooks :effects [mutation io]
|
||||
(fn ()
|
||||
(for-each (fn (hook) (cek-call hook nil)) *pre-render-hooks*)))
|
||||
|
||||
(define run-post-render-hooks :effects [mutation io]
|
||||
(fn ()
|
||||
(log-info "run-post-render-hooks:" (len *post-render-hooks*) "hooks")
|
||||
(for-each (fn (hook)
|
||||
(log-info " hook type:" (type-of hook) "callable:" (callable? hook) "lambda:" (lambda? hook))
|
||||
(cek-call hook nil))
|
||||
*post-render-hooks*)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Full boot sequence
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define boot-init :effects [mutation io]
|
||||
(fn ()
|
||||
;; Full browser initialization:
|
||||
;; 1. CSS tracking
|
||||
;; 2. Style dictionary
|
||||
;; 3. Process scripts (components + mounts)
|
||||
;; 4. Process page registry (client-side routing)
|
||||
;; 5. Hydrate [data-sx] elements
|
||||
;; 6. Hydrate [data-sx-island] elements (reactive islands)
|
||||
;; 7. Process engine elements
|
||||
(do
|
||||
(log-info (str "sx-browser " SX_VERSION))
|
||||
(init-css-tracking)
|
||||
(process-page-scripts)
|
||||
(process-sx-scripts nil)
|
||||
(sx-hydrate-elements nil)
|
||||
(sx-hydrate-islands nil)
|
||||
(run-post-render-hooks)
|
||||
(process-elements nil))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Platform interface — Boot
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; From orchestration.sx:
|
||||
;; process-elements, init-css-tracking
|
||||
;;
|
||||
;; === DOM / Render ===
|
||||
;; (resolve-mount-target target) → Element (string → querySelector, else identity)
|
||||
;; (sx-render-with-env source extra-env) → DOM node (parse + render with componentEnv + extra)
|
||||
;; (get-render-env extra-env) → merged component env + extra
|
||||
;; (merge-envs base new) → merged env dict
|
||||
;; (render-to-dom expr env ns) → DOM node
|
||||
;; (sx-load-components text) → void (parse + eval into componentEnv)
|
||||
;;
|
||||
;; === DOM queries ===
|
||||
;; (dom-query sel) → Element or nil
|
||||
;; (dom-query-all root sel) → list of Elements
|
||||
;; (dom-body) → document.body
|
||||
;; (dom-get-attr el name) → string or nil
|
||||
;; (dom-has-attr? el name) → boolean
|
||||
;; (dom-text-content el) → string
|
||||
;; (dom-set-text-content el s) → void
|
||||
;; (dom-append el child) → void
|
||||
;; (dom-remove-child parent el) → void
|
||||
;; (dom-parent el) → Element
|
||||
;; (dom-append-to-head el) → void
|
||||
;; (dom-tag-name el) → string
|
||||
;;
|
||||
;; === Head hoisting ===
|
||||
;; (set-document-title s) → void (document.title = s)
|
||||
;; (remove-head-element sel) → void (remove matching element from <head>)
|
||||
;;
|
||||
;; === Script queries ===
|
||||
;; (query-sx-scripts root) → list of <script type="text/sx"> elements
|
||||
;; (query-page-scripts) → list of <script type="text/sx-pages"> elements
|
||||
;;
|
||||
;; === localStorage ===
|
||||
;; (local-storage-get key) → string or nil
|
||||
;; (local-storage-set key val) → void
|
||||
;; (local-storage-remove key) → void
|
||||
;;
|
||||
;; === Cookies ===
|
||||
;; (set-sx-comp-cookie hash) → void
|
||||
;; (clear-sx-comp-cookie) → void
|
||||
;;
|
||||
;; === Env ===
|
||||
;; (parse-env-attr el) → dict (parse data-sx-env JSON attr)
|
||||
;; (store-env-attr el base new) → void (merge and store back as JSON)
|
||||
;; (to-kebab s) → string (underscore → kebab-case)
|
||||
;;
|
||||
;; === Logging ===
|
||||
;; (log-info msg) → void (console.log with prefix)
|
||||
;; (log-parse-error label text err) → void (diagnostic parse error)
|
||||
;;
|
||||
;; === Parsing (island state) ===
|
||||
;; (sx-parse str) → list of AST expressions (from parser.sx)
|
||||
;;
|
||||
;; === Processing markers ===
|
||||
;; (mark-processed! el key) → void
|
||||
;; (is-processed? el key) → boolean
|
||||
;;
|
||||
;; === Morph ===
|
||||
;; (morph-children target source) → void (morph target's children to match source)
|
||||
;;
|
||||
;; === Island support (from adapter-dom.sx / signals.sx) ===
|
||||
;; (island? x) → boolean
|
||||
;; (component-closure comp) → env
|
||||
;; (component-params comp) → list of param names
|
||||
;; (component-body comp) → AST
|
||||
;; (component-name comp) → string
|
||||
;; (component-has-children? comp) → boolean
|
||||
;; (with-island-scope scope-fn body-fn) → result (track disposables)
|
||||
;; (render-to-dom expr env ns) → DOM node
|
||||
;; (dom-get-data el key) → any (from el._sxData)
|
||||
;; (dom-set-data el key val) → void
|
||||
;; --------------------------------------------------------------------------
|
||||
@@ -1,206 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; boundary-app.sx — Deployment-specific boundary declarations
|
||||
;;
|
||||
;; I/O primitives specific to THIS deployment's architecture:
|
||||
;; inter-service communication, framework bindings, domain concepts,
|
||||
;; and layout context providers.
|
||||
;;
|
||||
;; These are NOT part of the SX language contract — a different deployment
|
||||
;; would declare different primitives here.
|
||||
;;
|
||||
;; The core SX I/O contract lives in boundary.sx.
|
||||
;; Per-service page helpers live in {service}/sx/boundary.sx.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Inter-service communication — microservice architecture
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define-io-primitive "frag"
|
||||
:params (service frag-type &key)
|
||||
:returns "string"
|
||||
:async true
|
||||
:doc "Fetch cross-service HTML fragment."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "query"
|
||||
:params (service query-name &key)
|
||||
:returns "any"
|
||||
:async true
|
||||
:doc "Fetch data from another service via internal HTTP."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "action"
|
||||
:params (service action-name &key)
|
||||
:returns "any"
|
||||
:async true
|
||||
:doc "Call an action on another service via internal HTTP."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "service"
|
||||
:params (service-or-method &rest args &key)
|
||||
:returns "any"
|
||||
:async true
|
||||
:doc "Call a domain service method. Two-arg: (service svc method). One-arg: (service method) uses bound handler service."
|
||||
:context :request)
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Framework bindings — Quart/Jinja2/HTMX specifics
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define-io-primitive "htmx-request?"
|
||||
:params ()
|
||||
:returns "boolean"
|
||||
:async true
|
||||
:doc "True if current request has HX-Request header."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "g"
|
||||
:params (key)
|
||||
:returns "any"
|
||||
:async true
|
||||
:doc "Read a value from the Quart request-local g object."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "jinja-global"
|
||||
:params (key &rest default)
|
||||
:returns "any"
|
||||
:async false
|
||||
:doc "Read a Jinja environment global."
|
||||
:context :request)
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Domain concepts — navigation, relations
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define-io-primitive "nav-tree"
|
||||
:params ()
|
||||
:returns "list"
|
||||
:async true
|
||||
:doc "Navigation tree as list of node dicts."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "get-children"
|
||||
:params (&key parent-type parent-id)
|
||||
:returns "list"
|
||||
:async true
|
||||
:doc "Fetch child entities for a parent."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "relations-from"
|
||||
:params (entity-type)
|
||||
:returns "list"
|
||||
:async false
|
||||
:doc "List of RelationDef dicts for an entity type."
|
||||
:context :config)
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Layout context providers — per-service header/page context
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Shared across all services (root layout)
|
||||
|
||||
(define-io-primitive "root-header-ctx"
|
||||
:params ()
|
||||
:returns "dict"
|
||||
:async true
|
||||
:doc "Dict with root header values (cart-mini, auth-menu, nav-tree, etc.)."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "select-colours"
|
||||
:params ()
|
||||
:returns "string"
|
||||
:async true
|
||||
:doc "Shared select/hover CSS class string."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "account-nav-ctx"
|
||||
:params ()
|
||||
:returns "any"
|
||||
:async true
|
||||
:doc "Account nav fragments, or nil."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "app-rights"
|
||||
:params ()
|
||||
:returns "dict"
|
||||
:async true
|
||||
:doc "User rights dict from g.rights."
|
||||
:context :request)
|
||||
|
||||
;; Blog service layout
|
||||
|
||||
(define-io-primitive "post-header-ctx"
|
||||
:params ()
|
||||
:returns "dict"
|
||||
:async true
|
||||
:doc "Dict with post-level header values."
|
||||
:context :request)
|
||||
|
||||
;; Cart service layout
|
||||
|
||||
(define-io-primitive "cart-page-ctx"
|
||||
:params ()
|
||||
:returns "dict"
|
||||
:async true
|
||||
:doc "Dict with cart page header values."
|
||||
:context :request)
|
||||
|
||||
;; Events service layouts
|
||||
|
||||
(define-io-primitive "events-calendar-ctx"
|
||||
:params ()
|
||||
:returns "dict"
|
||||
:async true
|
||||
:doc "Dict with events calendar header values."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "events-day-ctx"
|
||||
:params ()
|
||||
:returns "dict"
|
||||
:async true
|
||||
:doc "Dict with events day header values."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "events-entry-ctx"
|
||||
:params ()
|
||||
:returns "dict"
|
||||
:async true
|
||||
:doc "Dict with events entry header values."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "events-slot-ctx"
|
||||
:params ()
|
||||
:returns "dict"
|
||||
:async true
|
||||
:doc "Dict with events slot header values."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "events-ticket-type-ctx"
|
||||
:params ()
|
||||
:returns "dict"
|
||||
:async true
|
||||
:doc "Dict with ticket type header values."
|
||||
:context :request)
|
||||
|
||||
;; Market service layout
|
||||
|
||||
(define-io-primitive "market-header-ctx"
|
||||
:params ()
|
||||
:returns "dict"
|
||||
:async true
|
||||
:doc "Dict with market header data."
|
||||
:context :request)
|
||||
|
||||
;; Federation service layout
|
||||
|
||||
(define-io-primitive "federation-actor-ctx"
|
||||
:params ()
|
||||
:returns "dict?"
|
||||
:async true
|
||||
:doc "Serialized ActivityPub actor dict or nil."
|
||||
:context :request)
|
||||
@@ -1,435 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; boundary.sx — SX language boundary contract
|
||||
;;
|
||||
;; Declares the core I/O primitives that any SX host must provide.
|
||||
;; This is the LANGUAGE contract — not deployment-specific.
|
||||
;;
|
||||
;; Pure primitives (Tier 1) are declared in primitives.sx.
|
||||
;; Deployment-specific I/O lives in boundary-app.sx.
|
||||
;; Per-service page helpers live in {service}/sx/boundary.sx.
|
||||
;;
|
||||
;; Format:
|
||||
;; (define-io-primitive "name"
|
||||
;; :params (param1 param2 &key ...)
|
||||
;; :returns "type"
|
||||
;; :effects [io]
|
||||
;; :async true
|
||||
;; :doc "description"
|
||||
;; :context :request)
|
||||
;;
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Tier 1: Pure primitives — declared in primitives.sx
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(declare-tier :pure :source "primitives.sx")
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Tier 2: Core I/O primitives — async, side-effectful, need host context
|
||||
;;
|
||||
;; These are generic web-platform I/O that any SX web host would provide,
|
||||
;; regardless of deployment architecture.
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Request context
|
||||
|
||||
(define-io-primitive "current-user"
|
||||
:params ()
|
||||
:returns "dict?"
|
||||
:effects [io]
|
||||
:async true
|
||||
:doc "Current authenticated user dict, or nil."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "request-arg"
|
||||
:params (name &rest default)
|
||||
:returns "any"
|
||||
:effects [io]
|
||||
:async true
|
||||
:doc "Read a query string argument from the current request."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "request-path"
|
||||
:params ()
|
||||
:returns "string"
|
||||
:effects [io]
|
||||
:async true
|
||||
:doc "Current request path."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "request-view-args"
|
||||
:params (key)
|
||||
:returns "any"
|
||||
:effects [io]
|
||||
:async true
|
||||
:doc "Read a URL view argument from the current request."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "csrf-token"
|
||||
:params ()
|
||||
:returns "string"
|
||||
:effects [io]
|
||||
:async true
|
||||
:doc "Current CSRF token string."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "abort"
|
||||
:params (status &rest message)
|
||||
:returns "nil"
|
||||
:effects [io]
|
||||
:async true
|
||||
:doc "Raise HTTP error from SX."
|
||||
:context :request)
|
||||
|
||||
;; Routing
|
||||
|
||||
(define-io-primitive "url-for"
|
||||
:params (endpoint &key)
|
||||
:returns "string"
|
||||
:effects [io]
|
||||
:async true
|
||||
:doc "Generate URL for a named endpoint."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "route-prefix"
|
||||
:params ()
|
||||
:returns "string"
|
||||
:effects [io]
|
||||
:async true
|
||||
:doc "Service URL prefix for dev/prod routing."
|
||||
:context :request)
|
||||
|
||||
;; Config and host context (sync — no await needed)
|
||||
|
||||
(define-io-primitive "app-url"
|
||||
:params (service &rest path)
|
||||
:returns "string"
|
||||
:effects [io]
|
||||
:async false
|
||||
:doc "Full URL for a service: (app-url \"blog\" \"/my-post/\")."
|
||||
:context :config)
|
||||
|
||||
(define-io-primitive "asset-url"
|
||||
:params (&rest path)
|
||||
:returns "string"
|
||||
:effects [io]
|
||||
:async false
|
||||
:doc "Versioned static asset URL."
|
||||
:context :config)
|
||||
|
||||
(define-io-primitive "config"
|
||||
:params (key)
|
||||
:returns "any"
|
||||
:effects [io]
|
||||
:async false
|
||||
:doc "Read a value from host configuration."
|
||||
:context :config)
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Boundary types — what's allowed to cross the host-SX boundary
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define-boundary-types
|
||||
(list "number" "string" "boolean" "nil" "keyword"
|
||||
"list" "dict" "sx-source"))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Web interop — reading non-SX request formats
|
||||
;;
|
||||
;; SX's native wire format is SX (text/sx). These primitives bridge to
|
||||
;; legacy web formats: HTML form encoding, JSON bodies, HTTP headers.
|
||||
;; They're useful for interop but not fundamental to SX-to-SX communication.
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define-io-primitive "now"
|
||||
:params (&rest format)
|
||||
:returns "string"
|
||||
:async true
|
||||
:doc "Current timestamp. Optional format string (strftime). Default ISO 8601."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "sleep"
|
||||
:params (ms)
|
||||
:returns "nil"
|
||||
:async true
|
||||
:doc "Pause execution for ms milliseconds. For demos and testing."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "request-form"
|
||||
:params (name &rest default)
|
||||
:returns "any"
|
||||
:async true
|
||||
:doc "Read a form field from a POST/PUT/PATCH request body."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "request-json"
|
||||
:params ()
|
||||
:returns "dict?"
|
||||
:async true
|
||||
:doc "Read JSON body from the current request, or nil if not JSON."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "request-header"
|
||||
:params (name &rest default)
|
||||
:returns "string?"
|
||||
:async true
|
||||
:doc "Read a request header value by name."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "request-content-type"
|
||||
:params ()
|
||||
:returns "string?"
|
||||
:async true
|
||||
:doc "Content-Type of the current request."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "request-args-all"
|
||||
:params ()
|
||||
:returns "dict"
|
||||
:async true
|
||||
:doc "All query string parameters as a dict."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "request-form-all"
|
||||
:params ()
|
||||
:returns "dict"
|
||||
:async true
|
||||
:doc "All form fields as a dict."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "request-form-list"
|
||||
:params (field-name)
|
||||
:returns "list"
|
||||
:async true
|
||||
:doc "All values for a multi-value form field as a list."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "request-headers-all"
|
||||
:params ()
|
||||
:returns "dict"
|
||||
:async true
|
||||
:doc "All request headers as a dict (lowercase keys)."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "request-file-name"
|
||||
:params (field-name)
|
||||
:returns "string?"
|
||||
:async true
|
||||
:doc "Filename of an uploaded file by field name, or nil."
|
||||
:context :request)
|
||||
|
||||
;; Response manipulation
|
||||
|
||||
(define-io-primitive "set-response-header"
|
||||
:params (name value)
|
||||
:returns "nil"
|
||||
:async true
|
||||
:doc "Set a response header. Applied after handler returns."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "set-response-status"
|
||||
:params (status)
|
||||
:returns "nil"
|
||||
:async true
|
||||
:doc "Set the HTTP response status code. Applied after handler returns."
|
||||
:context :request)
|
||||
|
||||
;; Ephemeral state — per-process, resets on restart
|
||||
|
||||
(define-io-primitive "state-get"
|
||||
:params (key &rest default)
|
||||
:returns "any"
|
||||
:async true
|
||||
:doc "Read from ephemeral per-process state dict."
|
||||
:context :request)
|
||||
|
||||
(define-io-primitive "state-set!"
|
||||
:params (key value)
|
||||
:returns "nil"
|
||||
:async true
|
||||
:doc "Write to ephemeral per-process state dict."
|
||||
:context :request)
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Tier 3: Signal primitives — reactive state for islands
|
||||
;;
|
||||
;; These are pure primitives (no IO) but are separated from primitives.sx
|
||||
;; because they introduce a new type (signal) and depend on signals.sx.
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(declare-tier :signals :source "signals.sx")
|
||||
|
||||
(declare-signal-primitive "signal"
|
||||
:params (initial-value)
|
||||
:returns "signal"
|
||||
:effects []
|
||||
:doc "Create a reactive signal container with an initial value.")
|
||||
|
||||
(declare-signal-primitive "deref"
|
||||
:params (signal)
|
||||
:returns "any"
|
||||
:effects []
|
||||
:doc "Read a signal's current value. In a reactive context (inside an island),
|
||||
subscribes the current DOM binding to the signal. Outside reactive
|
||||
context, just returns the value.")
|
||||
|
||||
(declare-signal-primitive "reset!"
|
||||
:params (signal value)
|
||||
:returns "nil"
|
||||
:effects [mutation]
|
||||
:doc "Set a signal to a new value. Notifies all subscribers.")
|
||||
|
||||
(declare-signal-primitive "swap!"
|
||||
:params (signal f &rest args)
|
||||
:returns "nil"
|
||||
:effects [mutation]
|
||||
:doc "Update a signal by applying f to its current value. (swap! s inc)
|
||||
is equivalent to (reset! s (inc (deref s))) but atomic.")
|
||||
|
||||
(declare-signal-primitive "computed"
|
||||
:params (compute-fn)
|
||||
:returns "signal"
|
||||
:effects []
|
||||
:doc "Create a derived signal that recomputes when its dependencies change.
|
||||
Dependencies are discovered automatically by tracking deref calls.")
|
||||
|
||||
(declare-signal-primitive "effect"
|
||||
:params (effect-fn)
|
||||
:returns "lambda"
|
||||
:effects [mutation]
|
||||
:doc "Run a side effect that re-runs when its signal dependencies change.
|
||||
Returns a dispose function. If the effect function returns a function,
|
||||
it is called as cleanup before the next run.")
|
||||
|
||||
(declare-signal-primitive "batch"
|
||||
:params (thunk)
|
||||
:returns "any"
|
||||
:effects [mutation]
|
||||
:doc "Group multiple signal writes. Subscribers are notified once at the end,
|
||||
after all values have been updated.")
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Tier 4: Spread + Collect — render-time attribute injection and accumulation
|
||||
;;
|
||||
;; `spread` is a new type: a dict of attributes that, when returned as a child
|
||||
;; of an HTML element, merges its attrs onto the parent element rather than
|
||||
;; rendering as content. This enables components like `~cssx/tw` to inject
|
||||
;; classes and styles onto their parent from inside the child list.
|
||||
;;
|
||||
;; `collect!` / `collected` are render-time accumulators. Values are collected
|
||||
;; into named buckets (with deduplication) during rendering and retrieved at
|
||||
;; flush points (e.g. a single <style> tag for all collected CSS rules).
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(declare-tier :spread :source "render.sx")
|
||||
|
||||
(declare-spread-primitive "make-spread"
|
||||
:params (attrs)
|
||||
:returns "spread"
|
||||
:effects []
|
||||
:doc "Create a spread value from an attrs dict. When this value appears as
|
||||
a child of an HTML element, its attrs are merged onto the parent
|
||||
element (class values joined, others overwritten).")
|
||||
|
||||
(declare-spread-primitive "spread?"
|
||||
:params (x)
|
||||
:returns "boolean"
|
||||
:effects []
|
||||
:doc "Test whether a value is a spread.")
|
||||
|
||||
(declare-spread-primitive "spread-attrs"
|
||||
:params (s)
|
||||
:returns "dict"
|
||||
:effects []
|
||||
:doc "Extract the attrs dict from a spread value.")
|
||||
|
||||
(declare-spread-primitive "collect!"
|
||||
:params (bucket value)
|
||||
:returns "nil"
|
||||
:effects [mutation]
|
||||
:doc "Add value to a named render-time accumulator bucket. Values are
|
||||
deduplicated (no duplicates added). Buckets persist for the duration
|
||||
of the current render pass.")
|
||||
|
||||
(declare-spread-primitive "collected"
|
||||
:params (bucket)
|
||||
:returns "list"
|
||||
:effects []
|
||||
:doc "Return all values collected in the named bucket during the current
|
||||
render pass. Returns an empty list if the bucket doesn't exist.")
|
||||
|
||||
(declare-spread-primitive "clear-collected!"
|
||||
:params (bucket)
|
||||
:returns "nil"
|
||||
:effects [mutation]
|
||||
:doc "Clear a named render-time accumulator bucket. Used at flush points
|
||||
after emitting collected values (e.g. after writing a <style> tag).")
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Tier 5: Scoped effects — unified render-time dynamic scope
|
||||
;;
|
||||
;; `scope` is the general primitive. `provide` is sugar for scope-with-value.
|
||||
;; Both `provide` and `scope` are special forms in the evaluator.
|
||||
;;
|
||||
;; The platform must implement per-name stacks. Each entry has a value,
|
||||
;; an emitted list, and a dedup flag. `scope-push!`/`scope-pop!` manage
|
||||
;; the stack. `provide-push!`/`provide-pop!` are aliases.
|
||||
;;
|
||||
;; `collect!`/`collected`/`clear-collected!` (Tier 4) are backed by scopes:
|
||||
;; collect! lazily creates a root scope with dedup=true, then emits into it.
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(declare-tier :scoped-effects :source "eval.sx")
|
||||
|
||||
(declare-spread-primitive "scope-push!"
|
||||
:params (name value)
|
||||
:returns "nil"
|
||||
:effects [mutation]
|
||||
:doc "Push a scope with name and value. General form — provide-push! is an alias.")
|
||||
|
||||
(declare-spread-primitive "scope-pop!"
|
||||
:params (name)
|
||||
:returns "nil"
|
||||
:effects [mutation]
|
||||
:doc "Pop the most recent scope for name. General form — provide-pop! is an alias.")
|
||||
|
||||
(declare-spread-primitive "provide-push!"
|
||||
:params (name value)
|
||||
:returns "nil"
|
||||
:effects [mutation]
|
||||
:doc "Alias for scope-push!. Push a scope with name and value.")
|
||||
|
||||
(declare-spread-primitive "provide-pop!"
|
||||
:params (name)
|
||||
:returns "nil"
|
||||
:effects [mutation]
|
||||
:doc "Alias for scope-pop!. Pop the most recent scope for name.")
|
||||
|
||||
(declare-spread-primitive "context"
|
||||
:params (name &rest default)
|
||||
:returns "any"
|
||||
:effects []
|
||||
:doc "Read value from nearest enclosing provide with matching name.
|
||||
Errors if no provider and no default given.")
|
||||
|
||||
(declare-spread-primitive "emit!"
|
||||
:params (name value)
|
||||
:returns "nil"
|
||||
:effects [mutation]
|
||||
:doc "Append value to nearest enclosing provide's accumulator.
|
||||
Errors if no matching provider. No deduplication.")
|
||||
|
||||
(declare-spread-primitive "emitted"
|
||||
:params (name)
|
||||
:returns "list"
|
||||
:effects []
|
||||
:doc "Return list of values emitted into nearest matching provider.
|
||||
Empty list if no provider.")
|
||||
@@ -1,245 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; callcc.sx — Full first-class continuations (call/cc)
|
||||
;;
|
||||
;; OPTIONAL EXTENSION — not required by the core evaluator.
|
||||
;; Bootstrappers include this only when the target supports it naturally.
|
||||
;;
|
||||
;; Full call/cc (call-with-current-continuation) captures the ENTIRE
|
||||
;; remaining computation as a first-class function — not just up to a
|
||||
;; delimiter, but all the way to the top level. Invoking a continuation
|
||||
;; captured by call/cc abandons the current computation entirely and
|
||||
;; resumes from where the continuation was captured.
|
||||
;;
|
||||
;; This is strictly more powerful than delimited continuations (shift/reset)
|
||||
;; but harder to implement in targets that don't support it natively.
|
||||
;; Recommended only for targets where it's natural:
|
||||
;; - Scheme/Racket (native call/cc)
|
||||
;; - Haskell (ContT monad transformer)
|
||||
;;
|
||||
;; For targets like Python, JavaScript, and Rust, delimited continuations
|
||||
;; (continuations.sx) are more practical and cover the same use cases
|
||||
;; without requiring a global CPS transform.
|
||||
;;
|
||||
;; One new special form:
|
||||
;; (call/cc f) — call f with the current continuation
|
||||
;;
|
||||
;; One new type:
|
||||
;; continuation — same type as in continuations.sx
|
||||
;;
|
||||
;; If both extensions are loaded, the continuation type is shared.
|
||||
;; Delimited and undelimited continuations are the same type —
|
||||
;; the difference is in how they are captured, not what they are.
|
||||
;;
|
||||
;; Platform requirements:
|
||||
;; (make-continuation fn) — wrap a function as a continuation value
|
||||
;; (continuation? x) — type predicate
|
||||
;; (type-of continuation) → "continuation"
|
||||
;; (call-with-cc f env) — target-specific call/cc implementation
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 1. Semantics
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; (call/cc f)
|
||||
;;
|
||||
;; Evaluates f (which must be a function of one argument), passing it the
|
||||
;; current continuation as a continuation value. f can:
|
||||
;;
|
||||
;; a) Return normally — call/cc returns whatever f returns
|
||||
;; b) Invoke the continuation — abandons f's computation, call/cc
|
||||
;; "returns" the value passed to the continuation
|
||||
;; c) Store the continuation — invoke it later, possibly multiple times
|
||||
;;
|
||||
;; Key difference from shift/reset: invoking an undelimited continuation
|
||||
;; NEVER RETURNS to the caller. It abandons the current computation and
|
||||
;; jumps back to where call/cc was originally called.
|
||||
;;
|
||||
;; ;; Delimited (shift/reset) — k returns a value:
|
||||
;; (reset (+ 1 (shift k (+ (k 10) (k 20)))))
|
||||
;; ;; (k 10) → 11, returns to the (+ ... (k 20)) expression
|
||||
;; ;; (k 20) → 21, returns to the (+ 11 ...) expression
|
||||
;; ;; result: 32
|
||||
;;
|
||||
;; ;; Undelimited (call/cc) — k does NOT return:
|
||||
;; (+ 1 (call/cc (fn (k)
|
||||
;; (+ (k 10) (k 20)))))
|
||||
;; ;; (k 10) abandons (+ (k 10) (k 20)) entirely
|
||||
;; ;; jumps back to (+ 1 _) with 10
|
||||
;; ;; result: 11
|
||||
;; ;; (k 20) is never reached
|
||||
;;
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 2. call/cc — call with current continuation
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define sf-callcc
|
||||
(fn (args env)
|
||||
;; Single argument: a function to call with the current continuation.
|
||||
(let ((f-expr (first args))
|
||||
(f (trampoline (eval-expr f-expr env))))
|
||||
(call-with-cc f env))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 3. Derived forms
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; With call/cc available, several patterns become expressible:
|
||||
;;
|
||||
;; --- Early return ---
|
||||
;;
|
||||
;; (define find-first
|
||||
;; (fn (pred items)
|
||||
;; (call/cc (fn (return)
|
||||
;; (for-each (fn (item)
|
||||
;; (when (pred item)
|
||||
;; (return item)))
|
||||
;; items)
|
||||
;; nil))))
|
||||
;;
|
||||
;; --- Exception-like flow ---
|
||||
;;
|
||||
;; (define try-catch
|
||||
;; (fn (body handler)
|
||||
;; (call/cc (fn (throw)
|
||||
;; (body throw)))))
|
||||
;;
|
||||
;; (try-catch
|
||||
;; (fn (throw)
|
||||
;; (let ((result (dangerous-operation)))
|
||||
;; (when (not result) (throw "failed"))
|
||||
;; result))
|
||||
;; (fn (error) (str "Caught: " error)))
|
||||
;;
|
||||
;; --- Coroutines ---
|
||||
;;
|
||||
;; Two call/cc captures that alternate control between two
|
||||
;; computations. Each captures its own continuation, then invokes
|
||||
;; the other's. This gives cooperative multitasking without threads.
|
||||
;;
|
||||
;; --- Undo ---
|
||||
;;
|
||||
;; (define with-undo
|
||||
;; (fn (action)
|
||||
;; (call/cc (fn (restore)
|
||||
;; (action)
|
||||
;; restore))))
|
||||
;;
|
||||
;; ;; (let ((undo (with-undo (fn () (delete-item 42)))))
|
||||
;; ;; (undo "anything")) → item 42 is back
|
||||
;;
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 4. Interaction with delimited continuations
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; If both callcc.sx and continuations.sx are loaded:
|
||||
;;
|
||||
;; - The continuation type is shared. (continuation? k) returns true
|
||||
;; for both delimited and undelimited continuations.
|
||||
;;
|
||||
;; - shift inside a call/cc body captures up to the nearest reset,
|
||||
;; not up to the call/cc. The two mechanisms compose.
|
||||
;;
|
||||
;; - call/cc inside a reset body captures the entire continuation
|
||||
;; (past the reset). This is the expected behavior — call/cc is
|
||||
;; undelimited by definition.
|
||||
;;
|
||||
;; - A delimited continuation (from shift) returns a value when invoked.
|
||||
;; An undelimited continuation (from call/cc) does not return.
|
||||
;; Both are callable with the same syntax: (k value).
|
||||
;; The caller cannot distinguish them by type — only by behavior.
|
||||
;;
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 5. Interaction with I/O and state
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Full call/cc has well-known interactions with side effects:
|
||||
;;
|
||||
;; Re-entry:
|
||||
;; Invoking a saved continuation re-enters a completed computation.
|
||||
;; If that computation mutated state (set!, I/O writes), the mutations
|
||||
;; are NOT undone. The continuation resumes in the current state,
|
||||
;; not the state at the time of capture.
|
||||
;;
|
||||
;; I/O:
|
||||
;; Same as delimited continuations — I/O executes at invocation time.
|
||||
;; A continuation containing (current-user) will call current-user
|
||||
;; when invoked, in whatever request context exists then.
|
||||
;;
|
||||
;; Dynamic extent:
|
||||
;; call/cc captures the continuation, not the dynamic environment.
|
||||
;; Host-language context (Python's Quart request context, JavaScript's
|
||||
;; async context) may not be valid when a saved continuation is invoked
|
||||
;; later. Typed targets can enforce this; dynamic targets fail at runtime.
|
||||
;;
|
||||
;; Recommendation:
|
||||
;; Use call/cc for pure control flow (early return, coroutines,
|
||||
;; backtracking). Use delimited continuations for effectful patterns
|
||||
;; (suspense, cooperative scheduling) where the delimiter provides
|
||||
;; a natural boundary.
|
||||
;;
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 6. Implementation notes per target
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Scheme / Racket:
|
||||
;; Native call/cc. Zero implementation effort.
|
||||
;;
|
||||
;; Haskell:
|
||||
;; ContT monad transformer. The evaluator runs in ContT, and call/cc
|
||||
;; is callCC from Control.Monad.Cont. Natural and type-safe.
|
||||
;;
|
||||
;; Python:
|
||||
;; Requires full CPS transform of the evaluator, or greenlet-based
|
||||
;; stack capture. Significantly more invasive than delimited
|
||||
;; continuations. NOT RECOMMENDED — use continuations.sx instead.
|
||||
;;
|
||||
;; JavaScript:
|
||||
;; Requires full CPS transform. Cannot be implemented with generators
|
||||
;; alone (generators only support delimited yield, not full escape).
|
||||
;; NOT RECOMMENDED — use continuations.sx instead.
|
||||
;;
|
||||
;; Rust:
|
||||
;; Full CPS transform at compile time. Possible but adds significant
|
||||
;; complexity. Delimited continuations are more natural (enum-based).
|
||||
;; Consider only if the target genuinely needs undelimited escape.
|
||||
;;
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 7. Platform interface — what each target must provide
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; (call-with-cc f env)
|
||||
;; Call f with the current continuation. f is a function of one
|
||||
;; argument (the continuation). If f returns normally, call-with-cc
|
||||
;; returns f's result. If f invokes the continuation, the computation
|
||||
;; jumps to the call-with-cc call site with the provided value.
|
||||
;;
|
||||
;; (make-continuation fn)
|
||||
;; Wrap a native function as a continuation value.
|
||||
;; (Shared with continuations.sx if both are loaded.)
|
||||
;;
|
||||
;; (continuation? x)
|
||||
;; Type predicate.
|
||||
;; (Shared with continuations.sx if both are loaded.)
|
||||
;;
|
||||
;; Continuations must be callable via the standard function-call
|
||||
;; dispatch in eval-list (same path as lambda calls).
|
||||
;;
|
||||
;; --------------------------------------------------------------------------
|
||||
1178
shared/sx/ref/cek.sx
1178
shared/sx/ref/cek.sx
File diff suppressed because it is too large
Load Diff
@@ -1,248 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; continuations.sx — Delimited continuations (shift/reset)
|
||||
;;
|
||||
;; OPTIONAL EXTENSION — not required by the core evaluator.
|
||||
;; Bootstrappers include this only when the target requests it.
|
||||
;;
|
||||
;; Delimited continuations capture "the rest of the computation up to
|
||||
;; a delimiter." They are strictly less powerful than full call/cc but
|
||||
;; cover the practical use cases: suspendable rendering, cooperative
|
||||
;; scheduling, linear async flows, wizard forms, and undo.
|
||||
;;
|
||||
;; Two new special forms:
|
||||
;; (reset body) — establish a delimiter
|
||||
;; (shift k body) — capture the continuation to the nearest reset
|
||||
;;
|
||||
;; One new type:
|
||||
;; continuation — a captured delimited continuation, callable
|
||||
;;
|
||||
;; The captured continuation is a function of one argument. Invoking it
|
||||
;; provides the value that the shift expression "returns" within the
|
||||
;; delimited context, then completes the rest of the reset body.
|
||||
;;
|
||||
;; Continuations are composable — invoking a continuation returns a
|
||||
;; value (the result of the reset body), which can be used normally.
|
||||
;; This is the key difference from undelimited call/cc, where invoking
|
||||
;; a continuation never returns.
|
||||
;;
|
||||
;; Platform requirements:
|
||||
;; (make-continuation fn) — wrap a function as a continuation value
|
||||
;; (continuation? x) — type predicate
|
||||
;; (type-of continuation) → "continuation"
|
||||
;; Continuations are callable (same dispatch as lambda).
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 1. Type
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; A continuation is a callable value of one argument.
|
||||
;;
|
||||
;; (continuation? k) → true if k is a captured continuation
|
||||
;; (type-of k) → "continuation"
|
||||
;; (k value) → invoke: resume the captured computation with value
|
||||
;;
|
||||
;; Continuations are first-class: they can be stored in variables, passed
|
||||
;; as arguments, returned from functions, and put in data structures.
|
||||
;;
|
||||
;; Invoking a delimited continuation RETURNS a value — the result of the
|
||||
;; reset body. This makes them composable:
|
||||
;;
|
||||
;; (+ 1 (reset (+ 10 (shift k (k 5)))))
|
||||
;; ;; k is "add 10 to _ and return from reset"
|
||||
;; ;; (k 5) → 15, which is returned from reset
|
||||
;; ;; (+ 1 15) → 16
|
||||
;;
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 2. reset — establish a continuation delimiter
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; (reset body)
|
||||
;;
|
||||
;; Evaluates body in the current environment. If no shift occurs during
|
||||
;; evaluation of body, reset simply returns the value of body.
|
||||
;;
|
||||
;; If shift occurs, reset is the boundary — the continuation captured by
|
||||
;; shift extends from the shift point back to (and including) this reset.
|
||||
;;
|
||||
;; reset is the "prompt" — it marks where the continuation stops.
|
||||
;;
|
||||
;; Semantics:
|
||||
;; (reset expr) where expr contains no shift
|
||||
;; → (eval expr env) ;; just evaluates normally
|
||||
;;
|
||||
;; (reset ... (shift k body) ...)
|
||||
;; → captures continuation, evaluates shift's body
|
||||
;; → the result of the shift body is the result of the reset
|
||||
;;
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define sf-reset
|
||||
(fn ((args :as list) (env :as dict))
|
||||
;; Single argument: the body expression.
|
||||
;; Install a continuation delimiter, then evaluate body.
|
||||
;; The implementation is target-specific:
|
||||
;; - In Scheme: native reset/shift
|
||||
;; - In Haskell: Control.Monad.CC or delimited continuations library
|
||||
;; - In Python: coroutine/generator-based (see implementation notes)
|
||||
;; - In JavaScript: generator-based or CPS transform
|
||||
;; - In Rust: CPS transform at compile time
|
||||
(let ((body (first args)))
|
||||
(eval-with-delimiter body env))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 3. shift — capture the continuation to the nearest reset
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; (shift k body)
|
||||
;;
|
||||
;; Captures the continuation from this point back to the nearest enclosing
|
||||
;; reset and binds it to k. Then evaluates body in the current environment
|
||||
;; extended with k. The result of body becomes the result of the enclosing
|
||||
;; reset.
|
||||
;;
|
||||
;; k is a function of one argument. Calling (k value) resumes the captured
|
||||
;; computation with value standing in for the shift expression.
|
||||
;;
|
||||
;; The continuation k is composable: (k value) returns a value (the result
|
||||
;; of the reset body when resumed with value). This means k can be called
|
||||
;; multiple times, and its result can be used in further computation.
|
||||
;;
|
||||
;; Examples:
|
||||
;;
|
||||
;; ;; Basic: shift provides a value to the surrounding computation
|
||||
;; (reset (+ 1 (shift k (k 41))))
|
||||
;; ;; k = "add 1 to _", (k 41) → 42, reset returns 42
|
||||
;;
|
||||
;; ;; Abort: shift can discard the continuation entirely
|
||||
;; (reset (+ 1 (shift k "aborted")))
|
||||
;; ;; k is never called, reset returns "aborted"
|
||||
;;
|
||||
;; ;; Multiple invocations: k can be called more than once
|
||||
;; (reset (+ 1 (shift k (list (k 10) (k 20)))))
|
||||
;; ;; (k 10) → 11, (k 20) → 21, reset returns (11 21)
|
||||
;;
|
||||
;; ;; Stored for later: k can be saved and invoked outside reset
|
||||
;; (define saved nil)
|
||||
;; (reset (+ 1 (shift k (set! saved k) 0)))
|
||||
;; ;; reset returns 0, saved holds the continuation
|
||||
;; (saved 99) ;; → 100
|
||||
;;
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define sf-shift
|
||||
(fn ((args :as list) (env :as dict))
|
||||
;; Two arguments: the continuation variable name, and the body.
|
||||
(let ((k-name (symbol-name (first args)))
|
||||
(body (second args)))
|
||||
;; Capture the current continuation up to the nearest reset.
|
||||
;; Bind it to k-name in the environment, then evaluate body.
|
||||
;; The result of body is returned to the reset.
|
||||
(capture-continuation k-name body env))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 4. Interaction with other features
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; TCO (trampoline):
|
||||
;; Continuations interact naturally with the trampoline. A shift inside
|
||||
;; a tail-call position captures the continuation including the pending
|
||||
;; return. The trampoline resolves thunks before the continuation is
|
||||
;; delimited.
|
||||
;;
|
||||
;; Macros:
|
||||
;; shift/reset are special forms, not macros. Macros expand before
|
||||
;; evaluation, so shift inside a macro-expanded form works correctly —
|
||||
;; it captures the continuation of the expanded code.
|
||||
;;
|
||||
;; Components:
|
||||
;; shift inside a component body captures the continuation of that
|
||||
;; component's render. The enclosing reset determines the delimiter.
|
||||
;; This is the foundation for suspendable rendering — a component can
|
||||
;; shift to suspend, and the server resumes it when data arrives.
|
||||
;;
|
||||
;; I/O primitives:
|
||||
;; I/O primitives execute at invocation time, in whatever context
|
||||
;; exists then. A continuation that captures a computation containing
|
||||
;; I/O will re-execute that I/O when invoked. If the I/O requires
|
||||
;; request context (e.g. current-user), invoking the continuation
|
||||
;; outside a request will fail — same as calling the I/O directly.
|
||||
;; This is consistent, not a restriction.
|
||||
;;
|
||||
;; In typed targets (Haskell, Rust), the type system can enforce that
|
||||
;; continuations containing I/O are only invoked in appropriate contexts.
|
||||
;; In dynamic targets (Python, JS), it fails at runtime.
|
||||
;;
|
||||
;; Lexical scope:
|
||||
;; Continuations capture the dynamic extent (what happens next) but
|
||||
;; close over the lexical environment at the point of capture. Variable
|
||||
;; bindings in the continuation refer to the same environment — mutations
|
||||
;; via set! are visible.
|
||||
;;
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 5. Implementation notes per target
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; The bootstrapper emits target-specific continuation machinery.
|
||||
;; The spec defines semantics; each target chooses representation.
|
||||
;;
|
||||
;; Scheme / Racket:
|
||||
;; Native shift/reset. No transformation needed. The bootstrapper
|
||||
;; emits (require racket/control) or equivalent.
|
||||
;;
|
||||
;; Haskell:
|
||||
;; Control.Monad.CC provides delimited continuations in the CC monad.
|
||||
;; Alternatively, the evaluator can be CPS-transformed at compile time.
|
||||
;; Continuations become first-class functions naturally.
|
||||
;;
|
||||
;; Python:
|
||||
;; Generator-based: reset creates a generator, shift yields from it.
|
||||
;; The trampoline loop drives the generator. Each yield is a shift
|
||||
;; point, and send() provides the resume value.
|
||||
;; Alternative: greenlet-based (stackful coroutines).
|
||||
;;
|
||||
;; JavaScript:
|
||||
;; Generator-based (function* / yield). Similar to Python.
|
||||
;; Alternative: CPS transform at bootstrap time — the bootstrapper
|
||||
;; rewrites the evaluator into continuation-passing style, making
|
||||
;; shift/reset explicit function arguments.
|
||||
;;
|
||||
;; Rust:
|
||||
;; CPS transform at compile time. Continuations become enum variants
|
||||
;; or boxed closures. The type system ensures continuations are used
|
||||
;; linearly if desired (affine types via ownership).
|
||||
;;
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 6. Platform interface — what each target must provide
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; (eval-with-delimiter expr env)
|
||||
;; Install a reset delimiter, evaluate expr, return result.
|
||||
;; If expr calls shift, the continuation is captured up to here.
|
||||
;;
|
||||
;; (capture-continuation k-name body env)
|
||||
;; Capture the current continuation up to the nearest delimiter.
|
||||
;; Bind it to k-name in env, evaluate body, return result to delimiter.
|
||||
;;
|
||||
;; (make-continuation fn)
|
||||
;; Wrap a native function as a continuation value.
|
||||
;;
|
||||
;; (continuation? x)
|
||||
;; Type predicate.
|
||||
;;
|
||||
;; Continuations must be callable via the standard function-call
|
||||
;; dispatch in eval-list (same path as lambda calls).
|
||||
;;
|
||||
;; --------------------------------------------------------------------------
|
||||
@@ -1,459 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; deps.sx — Component dependency analysis specification
|
||||
;;
|
||||
;; Pure functions for analyzing component dependency graphs.
|
||||
;; Used by the bundling system to compute per-page component bundles
|
||||
;; instead of sending every definition to every page.
|
||||
;;
|
||||
;; All functions are pure — no IO, no platform-specific operations.
|
||||
;; Each host bootstraps this to native code alongside eval.sx/render.sx.
|
||||
;;
|
||||
;; From eval.sx platform (already provided by every host):
|
||||
;; (type-of x) → type string
|
||||
;; (symbol-name s) → string name of symbol
|
||||
;; (component-body c) → unevaluated AST of component body
|
||||
;; (component-name c) → string name (without ~)
|
||||
;; (macro-body m) → macro body AST
|
||||
;; (env-get env k) → value or nil
|
||||
;;
|
||||
;; New platform functions for deps (each host implements):
|
||||
;; (component-deps c) → cached deps list (may be empty)
|
||||
;; (component-set-deps! c d)→ cache deps on component
|
||||
;; (component-css-classes c)→ pre-scanned CSS class list
|
||||
;; (regex-find-all pat src) → list of capture group 1 matches
|
||||
;; (scan-css-classes src) → list of CSS class strings from source
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 1. AST scanning — collect ~component references from an AST node
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Walks all branches of control flow (if/when/cond/case) to find
|
||||
;; every component that *could* be rendered.
|
||||
|
||||
(define scan-refs :effects []
|
||||
(fn (node)
|
||||
(let ((refs (list)))
|
||||
(scan-refs-walk node refs)
|
||||
refs)))
|
||||
|
||||
|
||||
(define scan-refs-walk :effects []
|
||||
(fn (node (refs :as list))
|
||||
(cond
|
||||
;; Symbol starting with ~ → component reference
|
||||
(= (type-of node) "symbol")
|
||||
(let ((name (symbol-name node)))
|
||||
(when (starts-with? name "~")
|
||||
(when (not (contains? refs name))
|
||||
(append! refs name))))
|
||||
|
||||
;; List → recurse into all elements (covers all control flow branches)
|
||||
(= (type-of node) "list")
|
||||
(for-each (fn (item) (scan-refs-walk item refs)) node)
|
||||
|
||||
;; Dict → recurse into values
|
||||
(= (type-of node) "dict")
|
||||
(for-each (fn (key) (scan-refs-walk (dict-get node key) refs))
|
||||
(keys node))
|
||||
|
||||
;; Literals (number, string, boolean, nil, keyword) → no refs
|
||||
:else nil)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 2. Transitive dependency closure
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Given a component name and an environment, compute all components
|
||||
;; that it can transitively render. Handles cycles via seen-set.
|
||||
|
||||
(define transitive-deps-walk :effects []
|
||||
(fn ((n :as string) (seen :as list) (env :as dict))
|
||||
(when (not (contains? seen n))
|
||||
(append! seen n)
|
||||
(let ((val (env-get env n)))
|
||||
(cond
|
||||
(or (= (type-of val) "component") (= (type-of val) "island"))
|
||||
(for-each (fn ((ref :as string)) (transitive-deps-walk ref seen env))
|
||||
(scan-refs (component-body val)))
|
||||
(= (type-of val) "macro")
|
||||
(for-each (fn ((ref :as string)) (transitive-deps-walk ref seen env))
|
||||
(scan-refs (macro-body val)))
|
||||
:else nil)))))
|
||||
|
||||
|
||||
(define transitive-deps :effects []
|
||||
(fn ((name :as string) (env :as dict))
|
||||
(let ((seen (list))
|
||||
(key (if (starts-with? name "~") name (str "~" name))))
|
||||
(transitive-deps-walk key seen env)
|
||||
(filter (fn ((x :as string)) (not (= x key))) seen))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 3. Compute deps for all components in an environment
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Iterates env, calls transitive-deps for each component, and
|
||||
;; stores the result via the platform's component-set-deps! function.
|
||||
;;
|
||||
;; Platform interface:
|
||||
;; (env-components env) → list of component names in env
|
||||
;; (component-set-deps! comp deps) → store deps on component
|
||||
|
||||
(define compute-all-deps :effects [mutation]
|
||||
(fn ((env :as dict))
|
||||
(for-each
|
||||
(fn ((name :as string))
|
||||
(let ((val (env-get env name)))
|
||||
(when (or (= (type-of val) "component") (= (type-of val) "island"))
|
||||
(component-set-deps! val (transitive-deps name env)))))
|
||||
(env-components env))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 4. Scan serialized SX source for component references
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Regex-based extraction of (~name patterns from SX wire format.
|
||||
;; Returns list of names WITH ~ prefix.
|
||||
;;
|
||||
;; Platform interface:
|
||||
;; (regex-find-all pattern source) → list of matched group strings
|
||||
|
||||
(define scan-components-from-source :effects []
|
||||
(fn ((source :as string))
|
||||
(let ((matches (regex-find-all "\\(~([a-zA-Z_][a-zA-Z0-9_\\-:/]*)" source)))
|
||||
(map (fn ((m :as string)) (str "~" m)) matches))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 5. Components needed for a page
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Scans page source for direct component references, then computes
|
||||
;; the transitive closure. Returns list of ~names.
|
||||
|
||||
(define components-needed :effects []
|
||||
(fn ((page-source :as string) (env :as dict))
|
||||
(let ((direct (scan-components-from-source page-source))
|
||||
(all-needed (list)))
|
||||
|
||||
;; Add each direct ref + its transitive deps
|
||||
(for-each
|
||||
(fn ((name :as string))
|
||||
(when (not (contains? all-needed name))
|
||||
(append! all-needed name))
|
||||
(let ((val (env-get env name)))
|
||||
(let ((deps (if (and (= (type-of val) "component")
|
||||
(not (empty? (component-deps val))))
|
||||
(component-deps val)
|
||||
(transitive-deps name env))))
|
||||
(for-each
|
||||
(fn ((dep :as string))
|
||||
(when (not (contains? all-needed dep))
|
||||
(append! all-needed dep)))
|
||||
deps))))
|
||||
direct)
|
||||
|
||||
all-needed)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 6. Build per-page component bundle
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Given page source and env, returns list of component names needed.
|
||||
;; The host uses this list to serialize only the needed definitions
|
||||
;; and compute a page-specific hash.
|
||||
;;
|
||||
;; This replaces the "send everything" approach with per-page bundles.
|
||||
|
||||
(define page-component-bundle :effects []
|
||||
(fn ((page-source :as string) (env :as dict))
|
||||
(components-needed page-source env)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 7. CSS classes for a page
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Returns the union of CSS classes from components this page uses,
|
||||
;; plus classes from the page source itself.
|
||||
;;
|
||||
;; Platform interface:
|
||||
;; (component-css-classes c) → set/list of class strings
|
||||
;; (scan-css-classes source) → set/list of class strings from source
|
||||
|
||||
(define page-css-classes :effects []
|
||||
(fn ((page-source :as string) (env :as dict))
|
||||
(let ((needed (components-needed page-source env))
|
||||
(classes (list)))
|
||||
|
||||
;; Collect classes from needed components
|
||||
(for-each
|
||||
(fn ((name :as string))
|
||||
(let ((val (env-get env name)))
|
||||
(when (= (type-of val) "component")
|
||||
(for-each
|
||||
(fn ((cls :as string))
|
||||
(when (not (contains? classes cls))
|
||||
(append! classes cls)))
|
||||
(component-css-classes val)))))
|
||||
needed)
|
||||
|
||||
;; Add classes from page source
|
||||
(for-each
|
||||
(fn ((cls :as string))
|
||||
(when (not (contains? classes cls))
|
||||
(append! classes cls)))
|
||||
(scan-css-classes page-source))
|
||||
|
||||
classes)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 8. IO detection — scan component ASTs for IO primitive references
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Extends the dependency walker to detect references to IO primitives.
|
||||
;; IO names are provided by the host (from boundary.sx declarations).
|
||||
;; A component is "pure" if it (transitively) references no IO primitives.
|
||||
;;
|
||||
;; Platform interface additions:
|
||||
;; (component-io-refs c) → cached IO ref list (may be empty)
|
||||
;; (component-set-io-refs! c r) → cache IO refs on component
|
||||
|
||||
(define scan-io-refs-walk :effects []
|
||||
(fn (node (io-names :as list) (refs :as list))
|
||||
(cond
|
||||
;; Symbol → check if name is in the IO set
|
||||
(= (type-of node) "symbol")
|
||||
(let ((name (symbol-name node)))
|
||||
(when (contains? io-names name)
|
||||
(when (not (contains? refs name))
|
||||
(append! refs name))))
|
||||
|
||||
;; List → recurse into all elements
|
||||
(= (type-of node) "list")
|
||||
(for-each (fn (item) (scan-io-refs-walk item io-names refs)) node)
|
||||
|
||||
;; Dict → recurse into values
|
||||
(= (type-of node) "dict")
|
||||
(for-each (fn (key) (scan-io-refs-walk (dict-get node key) io-names refs))
|
||||
(keys node))
|
||||
|
||||
;; Literals → no IO refs
|
||||
:else nil)))
|
||||
|
||||
|
||||
(define scan-io-refs :effects []
|
||||
(fn (node (io-names :as list))
|
||||
(let ((refs (list)))
|
||||
(scan-io-refs-walk node io-names refs)
|
||||
refs)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 9. Transitive IO refs — follow component deps and union IO refs
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define transitive-io-refs-walk :effects []
|
||||
(fn ((n :as string) (seen :as list) (all-refs :as list) (env :as dict) (io-names :as list))
|
||||
(when (not (contains? seen n))
|
||||
(append! seen n)
|
||||
(let ((val (env-get env n)))
|
||||
(cond
|
||||
(= (type-of val) "component")
|
||||
(do
|
||||
;; Scan this component's body for IO refs
|
||||
(for-each
|
||||
(fn ((ref :as string))
|
||||
(when (not (contains? all-refs ref))
|
||||
(append! all-refs ref)))
|
||||
(scan-io-refs (component-body val) io-names))
|
||||
;; Recurse into component deps
|
||||
(for-each
|
||||
(fn ((dep :as string)) (transitive-io-refs-walk dep seen all-refs env io-names))
|
||||
(scan-refs (component-body val))))
|
||||
|
||||
(= (type-of val) "macro")
|
||||
(do
|
||||
(for-each
|
||||
(fn ((ref :as string))
|
||||
(when (not (contains? all-refs ref))
|
||||
(append! all-refs ref)))
|
||||
(scan-io-refs (macro-body val) io-names))
|
||||
(for-each
|
||||
(fn ((dep :as string)) (transitive-io-refs-walk dep seen all-refs env io-names))
|
||||
(scan-refs (macro-body val))))
|
||||
|
||||
:else nil)))))
|
||||
|
||||
|
||||
(define transitive-io-refs :effects []
|
||||
(fn ((name :as string) (env :as dict) (io-names :as list))
|
||||
(let ((all-refs (list))
|
||||
(seen (list))
|
||||
(key (if (starts-with? name "~") name (str "~" name))))
|
||||
(transitive-io-refs-walk key seen all-refs env io-names)
|
||||
all-refs)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 10. Compute IO refs for all components in an environment
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define compute-all-io-refs :effects [mutation]
|
||||
(fn ((env :as dict) (io-names :as list))
|
||||
(for-each
|
||||
(fn ((name :as string))
|
||||
(let ((val (env-get env name)))
|
||||
(when (= (type-of val) "component")
|
||||
(component-set-io-refs! val (transitive-io-refs name env io-names)))))
|
||||
(env-components env))))
|
||||
|
||||
|
||||
(define component-io-refs-cached :effects []
|
||||
(fn ((name :as string) (env :as dict) (io-names :as list))
|
||||
(let ((key (if (starts-with? name "~") name (str "~" name))))
|
||||
(let ((val (env-get env key)))
|
||||
(if (and (= (type-of val) "component")
|
||||
(not (nil? (component-io-refs val)))
|
||||
(not (empty? (component-io-refs val))))
|
||||
(component-io-refs val)
|
||||
;; Fallback: not yet cached (shouldn't happen after compute-all-io-refs)
|
||||
(transitive-io-refs name env io-names))))))
|
||||
|
||||
(define component-pure? :effects []
|
||||
(fn ((name :as string) (env :as dict) (io-names :as list))
|
||||
(let ((key (if (starts-with? name "~") name (str "~" name))))
|
||||
(let ((val (env-get env key)))
|
||||
(if (and (= (type-of val) "component")
|
||||
(not (nil? (component-io-refs val))))
|
||||
;; Use cached io-refs (empty list = pure)
|
||||
(empty? (component-io-refs val))
|
||||
;; Fallback
|
||||
(empty? (transitive-io-refs name env io-names)))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 5. Render target — boundary decision per component
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Combines IO analysis with affinity annotations to decide where a
|
||||
;; component should render:
|
||||
;;
|
||||
;; :affinity :server → always "server" (auth-sensitive, secrets)
|
||||
;; :affinity :client → "client" even if IO-dependent (IO proxy)
|
||||
;; :affinity :auto → "server" if IO-dependent, "client" if pure
|
||||
;;
|
||||
;; Returns: "server" | "client"
|
||||
|
||||
(define render-target :effects []
|
||||
(fn ((name :as string) (env :as dict) (io-names :as list))
|
||||
(let ((key (if (starts-with? name "~") name (str "~" name))))
|
||||
(let ((val (env-get env key)))
|
||||
(if (not (= (type-of val) "component"))
|
||||
"server"
|
||||
(let ((affinity (component-affinity val)))
|
||||
(cond
|
||||
(= affinity "server") "server"
|
||||
(= affinity "client") "client"
|
||||
;; auto: decide from IO analysis
|
||||
(not (component-pure? name env io-names)) "server"
|
||||
:else "client")))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 6. Page render plan — pre-computed boundary decisions for a page
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Given page source + env + IO names, returns a render plan dict:
|
||||
;;
|
||||
;; {:components {~name "server"|"client" ...}
|
||||
;; :server (list of ~names that render server-side)
|
||||
;; :client (list of ~names that render client-side)
|
||||
;; :io-deps (list of IO primitives needed by server components)}
|
||||
;;
|
||||
;; This is computed once at page registration and cached on the page def.
|
||||
;; The async evaluator and client router both use it to make decisions
|
||||
;; without recomputing at every request.
|
||||
|
||||
(define page-render-plan :effects []
|
||||
(fn ((page-source :as string) (env :as dict) (io-names :as list))
|
||||
(let ((needed (components-needed page-source env))
|
||||
(comp-targets (dict))
|
||||
(server-list (list))
|
||||
(client-list (list))
|
||||
(io-deps (list)))
|
||||
|
||||
(for-each
|
||||
(fn ((name :as string))
|
||||
(let ((target (render-target name env io-names)))
|
||||
(dict-set! comp-targets name target)
|
||||
(if (= target "server")
|
||||
(do
|
||||
(append! server-list name)
|
||||
;; Collect IO deps from server components (use cache)
|
||||
(for-each
|
||||
(fn ((io-ref :as string))
|
||||
(when (not (contains? io-deps io-ref))
|
||||
(append! io-deps io-ref)))
|
||||
(component-io-refs-cached name env io-names)))
|
||||
(append! client-list name))))
|
||||
needed)
|
||||
|
||||
{:components comp-targets
|
||||
:server server-list
|
||||
:client client-list
|
||||
:io-deps io-deps})))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Host obligation: selective expansion in async partial evaluation
|
||||
;; --------------------------------------------------------------------------
|
||||
;; The spec classifies components as pure or IO-dependent and provides
|
||||
;; per-component render-target decisions. Each host's async partial
|
||||
;; evaluator (the server-side rendering path that bridges sync evaluation
|
||||
;; with async IO) must use this classification:
|
||||
;;
|
||||
;; render-target "server" → expand server-side (IO must resolve)
|
||||
;; render-target "client" → serialize for client (can render anywhere)
|
||||
;; Layout slot context → expand all (server needs full HTML)
|
||||
;;
|
||||
;; The spec provides: component-io-refs, component-pure?, render-target,
|
||||
;; component-affinity. The host provides the async runtime that acts on it.
|
||||
;; This is not SX semantics — it is host infrastructure. Every host
|
||||
;; with a server-side async evaluator implements the same rule.
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Platform interface summary
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; From eval.sx (already provided):
|
||||
;; (type-of x) → type string
|
||||
;; (symbol-name s) → string name of symbol
|
||||
;; (env-get env k) → value or nil
|
||||
;;
|
||||
;; New for deps.sx (each host implements):
|
||||
;; (component-body c) → AST body of component
|
||||
;; (component-name c) → name string
|
||||
;; (component-deps c) → cached deps list (may be empty)
|
||||
;; (component-set-deps! c d)→ cache deps on component
|
||||
;; (component-css-classes c)→ pre-scanned CSS class list
|
||||
;; (component-io-refs c) → cached IO ref list (may be empty)
|
||||
;; (component-set-io-refs! c r)→ cache IO refs on component
|
||||
;; (component-affinity c) → "auto" | "client" | "server"
|
||||
;; (macro-body m) → AST body of macro
|
||||
;; (regex-find-all pat src) → list of capture group matches
|
||||
;; (scan-css-classes src) → list of CSS class strings from source
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; env-components — list component/macro names in an environment
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Moved from platform to spec: pure logic using type predicates.
|
||||
|
||||
(define env-components :effects []
|
||||
(fn ((env :as dict))
|
||||
(filter
|
||||
(fn ((k :as string))
|
||||
(let ((v (env-get env k)))
|
||||
(or (component? v) (macro? v))))
|
||||
(keys env))))
|
||||
@@ -1,803 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; engine.sx — SxEngine pure logic
|
||||
;;
|
||||
;; Fetch/swap/history engine for browser-side SX. Like HTMX but native
|
||||
;; to the SX rendering pipeline.
|
||||
;;
|
||||
;; This file specifies the pure LOGIC of the engine in s-expressions:
|
||||
;; parsing trigger specs, morph algorithm, swap dispatch, header building,
|
||||
;; retry logic, target resolution, etc.
|
||||
;;
|
||||
;; Orchestration (binding events, executing requests, processing elements)
|
||||
;; lives in orchestration.sx, which depends on this file.
|
||||
;;
|
||||
;; Depends on:
|
||||
;; adapter-dom.sx — render-to-dom (for SX response rendering)
|
||||
;; render.sx — shared registries
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Constants
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define ENGINE_VERBS (list "get" "post" "put" "delete" "patch"))
|
||||
(define DEFAULT_SWAP "outerHTML")
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Trigger parsing
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Parses the sx-trigger attribute value into a list of trigger descriptors.
|
||||
;; Each descriptor is a dict with "event" and "modifiers" keys.
|
||||
|
||||
(define parse-time :effects []
|
||||
(fn ((s :as string))
|
||||
;; Parse time string: "2s" → 2000, "500ms" → 500
|
||||
;; Uses nested if (not cond) because cond misclassifies 2-element
|
||||
;; function calls like (nil? s) as scheme-style ((test body)) clauses.
|
||||
(if (nil? s) 0
|
||||
(if (ends-with? s "ms") (parse-int s 0)
|
||||
(if (ends-with? s "s") (* (parse-int (replace s "s" "") 0) 1000)
|
||||
(parse-int s 0))))))
|
||||
|
||||
|
||||
(define parse-trigger-spec :effects []
|
||||
(fn ((spec :as string))
|
||||
;; Parse "click delay:500ms once,change" → list of trigger descriptors
|
||||
(if (nil? spec)
|
||||
nil
|
||||
(let ((raw-parts (split spec ",")))
|
||||
(filter
|
||||
(fn (x) (not (nil? x)))
|
||||
(map
|
||||
(fn ((part :as string))
|
||||
(let ((tokens (split (trim part) " ")))
|
||||
(if (empty? tokens)
|
||||
nil
|
||||
(if (and (= (first tokens) "every") (>= (len tokens) 2))
|
||||
;; Polling trigger
|
||||
(dict
|
||||
"event" "every"
|
||||
"modifiers" (dict "interval" (parse-time (nth tokens 1))))
|
||||
;; Normal trigger with optional modifiers
|
||||
(let ((mods (dict)))
|
||||
(for-each
|
||||
(fn ((tok :as string))
|
||||
(cond
|
||||
(= tok "once")
|
||||
(dict-set! mods "once" true)
|
||||
(= tok "changed")
|
||||
(dict-set! mods "changed" true)
|
||||
(starts-with? tok "delay:")
|
||||
(dict-set! mods "delay"
|
||||
(parse-time (slice tok 6)))
|
||||
(starts-with? tok "from:")
|
||||
(dict-set! mods "from"
|
||||
(slice tok 5))))
|
||||
(rest tokens))
|
||||
(dict "event" (first tokens) "modifiers" mods))))))
|
||||
raw-parts))))))
|
||||
|
||||
|
||||
(define default-trigger :effects []
|
||||
(fn ((tag-name :as string))
|
||||
;; Default trigger for element type
|
||||
(cond
|
||||
(= tag-name "FORM")
|
||||
(list (dict "event" "submit" "modifiers" (dict)))
|
||||
(or (= tag-name "INPUT")
|
||||
(= tag-name "SELECT")
|
||||
(= tag-name "TEXTAREA"))
|
||||
(list (dict "event" "change" "modifiers" (dict)))
|
||||
:else
|
||||
(list (dict "event" "click" "modifiers" (dict))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Verb extraction
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define get-verb-info :effects [io]
|
||||
(fn (el)
|
||||
;; Check element for sx-get, sx-post, etc. Returns (dict "method" "url") or nil.
|
||||
(some
|
||||
(fn ((verb :as string))
|
||||
(let ((url (dom-get-attr el (str "sx-" verb))))
|
||||
(if url
|
||||
(dict "method" (upper verb) "url" url)
|
||||
nil)))
|
||||
ENGINE_VERBS)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Request header building
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define build-request-headers :effects [io]
|
||||
(fn (el (loaded-components :as list) (css-hash :as string))
|
||||
;; Build the SX request headers dict
|
||||
(let ((headers (dict
|
||||
"SX-Request" "true"
|
||||
"SX-Current-URL" (browser-location-href))))
|
||||
;; Target selector
|
||||
(let ((target-sel (dom-get-attr el "sx-target")))
|
||||
(when target-sel
|
||||
(dict-set! headers "SX-Target" target-sel)))
|
||||
|
||||
;; Loaded component names
|
||||
(when (not (empty? loaded-components))
|
||||
(dict-set! headers "SX-Components"
|
||||
(join "," loaded-components)))
|
||||
|
||||
;; CSS class hash
|
||||
(when css-hash
|
||||
(dict-set! headers "SX-Css" css-hash))
|
||||
|
||||
;; Extra headers from sx-headers attribute
|
||||
(let ((extra-h (dom-get-attr el "sx-headers")))
|
||||
(when extra-h
|
||||
(let ((parsed (parse-header-value extra-h)))
|
||||
(when parsed
|
||||
(for-each
|
||||
(fn ((key :as string)) (dict-set! headers key (str (get parsed key))))
|
||||
(keys parsed))))))
|
||||
|
||||
headers)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Response header processing
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define process-response-headers :effects []
|
||||
(fn ((get-header :as lambda))
|
||||
;; Extract all SX response header directives into a dict.
|
||||
;; get-header is (fn (name) → string or nil).
|
||||
(dict
|
||||
"redirect" (get-header "SX-Redirect")
|
||||
"refresh" (get-header "SX-Refresh")
|
||||
"trigger" (get-header "SX-Trigger")
|
||||
"retarget" (get-header "SX-Retarget")
|
||||
"reswap" (get-header "SX-Reswap")
|
||||
"location" (get-header "SX-Location")
|
||||
"replace-url" (get-header "SX-Replace-Url")
|
||||
"css-hash" (get-header "SX-Css-Hash")
|
||||
"trigger-swap" (get-header "SX-Trigger-After-Swap")
|
||||
"trigger-settle" (get-header "SX-Trigger-After-Settle")
|
||||
"content-type" (get-header "Content-Type")
|
||||
"cache-invalidate" (get-header "SX-Cache-Invalidate")
|
||||
"cache-update" (get-header "SX-Cache-Update"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Swap specification parsing
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define parse-swap-spec :effects []
|
||||
(fn ((raw-swap :as string) (global-transitions? :as boolean))
|
||||
;; Parse "innerHTML transition:true" → dict with style + transition flag
|
||||
(let ((parts (split (or raw-swap DEFAULT_SWAP) " "))
|
||||
(style (first parts))
|
||||
(use-transition global-transitions?))
|
||||
(for-each
|
||||
(fn ((p :as string))
|
||||
(cond
|
||||
(= p "transition:true") (set! use-transition true)
|
||||
(= p "transition:false") (set! use-transition false)))
|
||||
(rest parts))
|
||||
(dict "style" style "transition" use-transition))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Retry logic
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define parse-retry-spec :effects []
|
||||
(fn ((retry-attr :as string))
|
||||
;; Parse "exponential:1000:30000" → spec dict or nil
|
||||
(if (nil? retry-attr)
|
||||
nil
|
||||
(let ((parts (split retry-attr ":")))
|
||||
(dict
|
||||
"strategy" (first parts)
|
||||
"start-ms" (parse-int (nth parts 1) 1000)
|
||||
"cap-ms" (parse-int (nth parts 2) 30000))))))
|
||||
|
||||
|
||||
(define next-retry-ms :effects []
|
||||
(fn ((current-ms :as number) (cap-ms :as number))
|
||||
;; Exponential backoff: double current, cap at max
|
||||
(min (* current-ms 2) cap-ms)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Form parameter filtering
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define filter-params :effects []
|
||||
(fn ((params-spec :as string) (all-params :as list))
|
||||
;; Filter form parameters by sx-params spec.
|
||||
;; all-params is a list of (key value) pairs.
|
||||
;; Returns filtered list of (key value) pairs.
|
||||
;; Uses nested if (not cond) — see parse-time comment.
|
||||
(if (nil? params-spec) all-params
|
||||
(if (= params-spec "none") (list)
|
||||
(if (= params-spec "*") all-params
|
||||
(if (starts-with? params-spec "not ")
|
||||
(let ((excluded (map trim (split (slice params-spec 4) ","))))
|
||||
(filter
|
||||
(fn ((p :as list)) (not (contains? excluded (first p))))
|
||||
all-params))
|
||||
(let ((allowed (map trim (split params-spec ","))))
|
||||
(filter
|
||||
(fn ((p :as list)) (contains? allowed (first p)))
|
||||
all-params))))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Target resolution
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define resolve-target :effects [io]
|
||||
(fn (el)
|
||||
;; Resolve the swap target for an element
|
||||
(let ((sel (dom-get-attr el "sx-target")))
|
||||
(cond
|
||||
(or (nil? sel) (= sel "this")) el
|
||||
(= sel "closest") (dom-parent el)
|
||||
:else (dom-query sel)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Optimistic updates
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define apply-optimistic :effects [mutation io]
|
||||
(fn (el)
|
||||
;; Apply optimistic update preview. Returns state for reverting, or nil.
|
||||
(let ((directive (dom-get-attr el "sx-optimistic")))
|
||||
(if (nil? directive)
|
||||
nil
|
||||
(let ((target (or (resolve-target el) el))
|
||||
(state (dict "target" target "directive" directive)))
|
||||
(cond
|
||||
(= directive "remove")
|
||||
(do
|
||||
(dict-set! state "opacity" (dom-get-style target "opacity"))
|
||||
(dom-set-style target "opacity" "0")
|
||||
(dom-set-style target "pointer-events" "none"))
|
||||
(= directive "disable")
|
||||
(do
|
||||
(dict-set! state "disabled" (dom-get-prop target "disabled"))
|
||||
(dom-set-prop target "disabled" true))
|
||||
(starts-with? directive "add-class:")
|
||||
(let ((cls (slice directive 10)))
|
||||
(dict-set! state "add-class" cls)
|
||||
(dom-add-class target cls)))
|
||||
state)))))
|
||||
|
||||
|
||||
(define revert-optimistic :effects [mutation io]
|
||||
(fn ((state :as dict))
|
||||
;; Revert an optimistic update
|
||||
(when state
|
||||
(let ((target (get state "target"))
|
||||
(directive (get state "directive")))
|
||||
(cond
|
||||
(= directive "remove")
|
||||
(do
|
||||
(dom-set-style target "opacity" (or (get state "opacity") ""))
|
||||
(dom-set-style target "pointer-events" ""))
|
||||
(= directive "disable")
|
||||
(dom-set-prop target "disabled" (or (get state "disabled") false))
|
||||
(get state "add-class")
|
||||
(dom-remove-class target (get state "add-class")))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Out-of-band swap identification
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define find-oob-swaps :effects [mutation io]
|
||||
(fn (container)
|
||||
;; Find elements marked for out-of-band swapping.
|
||||
;; Returns list of (dict "element" el "swap-type" type "target-id" id).
|
||||
(let ((results (list)))
|
||||
(for-each
|
||||
(fn ((attr :as string))
|
||||
(let ((oob-els (dom-query-all container (str "[" attr "]"))))
|
||||
(for-each
|
||||
(fn (oob)
|
||||
(let ((swap-type (or (dom-get-attr oob attr) "outerHTML"))
|
||||
(target-id (dom-id oob)))
|
||||
(dom-remove-attr oob attr)
|
||||
(when target-id
|
||||
(append! results
|
||||
(dict "element" oob
|
||||
"swap-type" swap-type
|
||||
"target-id" target-id)))))
|
||||
oob-els)))
|
||||
(list "sx-swap-oob" "hx-swap-oob"))
|
||||
results)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; DOM morph algorithm
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Lightweight reconciler: patches oldNode to match newNode in-place,
|
||||
;; preserving event listeners, focus, scroll position, and form state
|
||||
;; on keyed (id) elements.
|
||||
|
||||
(define morph-node :effects [mutation io]
|
||||
(fn (old-node new-node)
|
||||
;; Morph old-node to match new-node, preserving listeners/state.
|
||||
(cond
|
||||
;; sx-preserve / sx-ignore → skip
|
||||
(or (dom-has-attr? old-node "sx-preserve")
|
||||
(dom-has-attr? old-node "sx-ignore"))
|
||||
nil
|
||||
|
||||
;; Hydrated island → preserve reactive state, morph lakes.
|
||||
;; If old and new are the same island (by name), keep the old DOM
|
||||
;; with its live signals, effects, and event listeners intact.
|
||||
;; But recurse into data-sx-lake slots so the server can update
|
||||
;; non-reactive content within the island.
|
||||
(and (dom-has-attr? old-node "data-sx-island")
|
||||
(is-processed? old-node "island-hydrated")
|
||||
(dom-has-attr? new-node "data-sx-island")
|
||||
(= (dom-get-attr old-node "data-sx-island")
|
||||
(dom-get-attr new-node "data-sx-island")))
|
||||
(morph-island-children old-node new-node)
|
||||
|
||||
;; Different node type or tag → replace wholesale
|
||||
(or (not (= (dom-node-type old-node) (dom-node-type new-node)))
|
||||
(not (= (dom-node-name old-node) (dom-node-name new-node))))
|
||||
(dom-replace-child (dom-parent old-node)
|
||||
(dom-clone new-node) old-node)
|
||||
|
||||
;; Text/comment nodes → update content
|
||||
(or (= (dom-node-type old-node) 3) (= (dom-node-type old-node) 8))
|
||||
(when (not (= (dom-text-content old-node) (dom-text-content new-node)))
|
||||
(dom-set-text-content old-node (dom-text-content new-node)))
|
||||
|
||||
;; Element nodes → sync attributes, then recurse children
|
||||
(= (dom-node-type old-node) 1)
|
||||
(do
|
||||
(sync-attrs old-node new-node)
|
||||
;; Skip morphing focused input to preserve user's in-progress edits
|
||||
(when (not (and (dom-is-active-element? old-node)
|
||||
(dom-is-input-element? old-node)))
|
||||
(morph-children old-node new-node))))))
|
||||
|
||||
|
||||
(define sync-attrs :effects [mutation io]
|
||||
(fn (old-el new-el)
|
||||
;; Sync attributes from new to old, but skip reactively managed attrs.
|
||||
;; data-sx-reactive-attrs="style,class" means those attrs are owned by
|
||||
;; signal effects and must not be overwritten by the morph.
|
||||
(let ((ra-str (or (dom-get-attr old-el "data-sx-reactive-attrs") ""))
|
||||
(reactive-attrs (if (empty? ra-str) (list) (split ra-str ","))))
|
||||
;; Add/update attributes from new, skip reactive ones
|
||||
(for-each
|
||||
(fn ((attr :as list))
|
||||
(let ((name (first attr))
|
||||
(val (nth attr 1)))
|
||||
(when (and (not (= (dom-get-attr old-el name) val))
|
||||
(not (contains? reactive-attrs name)))
|
||||
(dom-set-attr old-el name val))))
|
||||
(dom-attr-list new-el))
|
||||
;; Remove attributes not in new, skip reactive + marker attrs
|
||||
(for-each
|
||||
(fn ((attr :as list))
|
||||
(let ((aname (first attr)))
|
||||
(when (and (not (dom-has-attr? new-el aname))
|
||||
(not (contains? reactive-attrs aname))
|
||||
(not (= aname "data-sx-reactive-attrs")))
|
||||
(dom-remove-attr old-el aname))))
|
||||
(dom-attr-list old-el)))))
|
||||
|
||||
|
||||
(define morph-children :effects [mutation io]
|
||||
(fn (old-parent new-parent)
|
||||
;; Reconcile children of old-parent to match new-parent.
|
||||
;; Keyed elements (with id) are matched and moved in-place.
|
||||
(let ((old-kids (dom-child-list old-parent))
|
||||
(new-kids (dom-child-list new-parent))
|
||||
;; Build ID map of old children for keyed matching
|
||||
(old-by-id (reduce
|
||||
(fn ((acc :as dict) kid)
|
||||
(let ((id (dom-id kid)))
|
||||
(if id (do (dict-set! acc id kid) acc) acc)))
|
||||
(dict) old-kids))
|
||||
(oi 0))
|
||||
|
||||
;; Walk new children, morph/insert/append
|
||||
(for-each
|
||||
(fn (new-child)
|
||||
(let ((match-id (dom-id new-child))
|
||||
(match-by-id (if match-id (dict-get old-by-id match-id) nil)))
|
||||
(cond
|
||||
;; Keyed match — move into position if needed, then morph
|
||||
(and match-by-id (not (nil? match-by-id)))
|
||||
(do
|
||||
(when (and (< oi (len old-kids))
|
||||
(not (= match-by-id (nth old-kids oi))))
|
||||
(dom-insert-before old-parent match-by-id
|
||||
(if (< oi (len old-kids)) (nth old-kids oi) nil)))
|
||||
(morph-node match-by-id new-child)
|
||||
(set! oi (inc oi)))
|
||||
|
||||
;; Positional match
|
||||
(< oi (len old-kids))
|
||||
(let ((old-child (nth old-kids oi)))
|
||||
(if (and (dom-id old-child) (not match-id))
|
||||
;; Old has ID, new doesn't — insert new before old
|
||||
(dom-insert-before old-parent
|
||||
(dom-clone new-child) old-child)
|
||||
;; Normal positional morph
|
||||
(do
|
||||
(morph-node old-child new-child)
|
||||
(set! oi (inc oi)))))
|
||||
|
||||
;; Extra new children — append
|
||||
:else
|
||||
(dom-append old-parent (dom-clone new-child)))))
|
||||
new-kids)
|
||||
|
||||
;; Remove leftover old children
|
||||
(for-each
|
||||
(fn ((i :as number))
|
||||
(when (>= i oi)
|
||||
(let ((leftover (nth old-kids i)))
|
||||
(when (and (dom-is-child-of? leftover old-parent)
|
||||
(not (dom-has-attr? leftover "sx-preserve"))
|
||||
(not (dom-has-attr? leftover "sx-ignore")))
|
||||
(dom-remove-child old-parent leftover)))))
|
||||
(range oi (len old-kids))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; morph-island-children — deep morph into hydrated islands via lakes
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Level 2-3 island morphing: the server can update non-reactive content
|
||||
;; within hydrated islands by morphing data-sx-lake slots.
|
||||
;;
|
||||
;; The island's reactive DOM (signals, effects, event listeners) is preserved.
|
||||
;; Only lake slots — explicitly marked server territory — receive new content.
|
||||
;;
|
||||
;; This is the Hegelian synthesis made concrete:
|
||||
;; - Islands = client subjectivity (reactive state, preserved)
|
||||
;; - Lakes = server substance (content, morphed)
|
||||
;; - The morph = Aufhebung (cancellation/preservation/elevation of both)
|
||||
|
||||
(define morph-island-children :effects [mutation io]
|
||||
(fn (old-island new-island)
|
||||
;; Find all lake and marsh slots in both old and new islands
|
||||
(let ((old-lakes (dom-query-all old-island "[data-sx-lake]"))
|
||||
(new-lakes (dom-query-all new-island "[data-sx-lake]"))
|
||||
(old-marshes (dom-query-all old-island "[data-sx-marsh]"))
|
||||
(new-marshes (dom-query-all new-island "[data-sx-marsh]")))
|
||||
;; Build ID→element maps for new lakes and marshes
|
||||
(let ((new-lake-map (dict))
|
||||
(new-marsh-map (dict)))
|
||||
(for-each
|
||||
(fn (lake)
|
||||
(let ((id (dom-get-attr lake "data-sx-lake")))
|
||||
(when id (dict-set! new-lake-map id lake))))
|
||||
new-lakes)
|
||||
(for-each
|
||||
(fn (marsh)
|
||||
(let ((id (dom-get-attr marsh "data-sx-marsh")))
|
||||
(when id (dict-set! new-marsh-map id marsh))))
|
||||
new-marshes)
|
||||
;; Morph each old lake from its new counterpart
|
||||
(for-each
|
||||
(fn (old-lake)
|
||||
(let ((id (dom-get-attr old-lake "data-sx-lake")))
|
||||
(let ((new-lake (dict-get new-lake-map id)))
|
||||
(when new-lake
|
||||
(sync-attrs old-lake new-lake)
|
||||
(morph-children old-lake new-lake)))))
|
||||
old-lakes)
|
||||
;; Morph each old marsh from its new counterpart
|
||||
(for-each
|
||||
(fn (old-marsh)
|
||||
(let ((id (dom-get-attr old-marsh "data-sx-marsh")))
|
||||
(let ((new-marsh (dict-get new-marsh-map id)))
|
||||
(when new-marsh
|
||||
(morph-marsh old-marsh new-marsh old-island)))))
|
||||
old-marshes)
|
||||
;; Process data-sx-signal attributes — server writes to named stores
|
||||
(process-signal-updates new-island)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; morph-marsh — re-evaluate server content in island's reactive scope
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Marshes are zones inside islands where server content is re-evaluated by
|
||||
;; the island's reactive evaluator. During morph, the new content is parsed
|
||||
;; as SX and rendered in the island's signal context. If the marsh has a
|
||||
;; :transform function, it reshapes the content before evaluation.
|
||||
|
||||
(define morph-marsh :effects [mutation io]
|
||||
(fn (old-marsh new-marsh island-el)
|
||||
(let ((transform (dom-get-data old-marsh "sx-marsh-transform"))
|
||||
(env (dom-get-data old-marsh "sx-marsh-env"))
|
||||
(new-html (dom-inner-html new-marsh)))
|
||||
(if (and env new-html (not (empty? new-html)))
|
||||
;; Parse new content as SX and re-evaluate in island scope
|
||||
(let ((parsed (parse new-html)))
|
||||
(let ((sx-content (if transform (cek-call transform (list parsed)) parsed)))
|
||||
;; Dispose old reactive bindings in this marsh
|
||||
(dispose-marsh-scope old-marsh)
|
||||
;; Evaluate the SX in a new marsh scope — creates new reactive bindings
|
||||
(with-marsh-scope old-marsh
|
||||
(fn ()
|
||||
(let ((new-dom (render-to-dom sx-content env nil)))
|
||||
;; Replace marsh children
|
||||
(dom-remove-children-after old-marsh nil)
|
||||
(dom-append old-marsh new-dom))))))
|
||||
;; Fallback: morph like a lake
|
||||
(do
|
||||
(sync-attrs old-marsh new-marsh)
|
||||
(morph-children old-marsh new-marsh))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; process-signal-updates — server responses write to named store signals
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Elements with data-sx-signal="name:value" trigger signal writes.
|
||||
;; After processing, the attribute is removed (consumed).
|
||||
;;
|
||||
;; Values are JSON-parsed: "7" → 7, "\"hello\"" → "hello", "true" → true.
|
||||
|
||||
(define process-signal-updates :effects [mutation io]
|
||||
(fn (root)
|
||||
(let ((signal-els (dom-query-all root "[data-sx-signal]")))
|
||||
(for-each
|
||||
(fn (el)
|
||||
(let ((spec (dom-get-attr el "data-sx-signal")))
|
||||
(when spec
|
||||
(let ((colon-idx (index-of spec ":")))
|
||||
(when (> colon-idx 0)
|
||||
(let ((store-name (slice spec 0 colon-idx))
|
||||
(raw-value (slice spec (+ colon-idx 1))))
|
||||
(let ((parsed (json-parse raw-value)))
|
||||
(reset! (use-store store-name) parsed))
|
||||
(dom-remove-attr el "data-sx-signal")))))))
|
||||
signal-els))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Swap dispatch
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define swap-dom-nodes :effects [mutation io]
|
||||
(fn (target new-nodes (strategy :as string))
|
||||
;; Execute a swap strategy on live DOM nodes.
|
||||
;; new-nodes is typically a DocumentFragment or Element.
|
||||
(case strategy
|
||||
"innerHTML"
|
||||
(if (dom-is-fragment? new-nodes)
|
||||
(morph-children target new-nodes)
|
||||
(let ((wrapper (dom-create-element "div" nil)))
|
||||
(dom-append wrapper new-nodes)
|
||||
(morph-children target wrapper)))
|
||||
|
||||
"outerHTML"
|
||||
(let ((parent (dom-parent target)))
|
||||
(if (dom-is-fragment? new-nodes)
|
||||
;; Fragment — morph first child, insert rest
|
||||
(let ((fc (dom-first-child new-nodes)))
|
||||
(if fc
|
||||
(do
|
||||
(morph-node target fc)
|
||||
;; Insert remaining siblings after morphed element
|
||||
(let ((sib (dom-next-sibling fc)))
|
||||
(insert-remaining-siblings parent target sib)))
|
||||
(dom-remove-child parent target)))
|
||||
(morph-node target new-nodes))
|
||||
parent)
|
||||
|
||||
"afterend"
|
||||
(dom-insert-after target new-nodes)
|
||||
|
||||
"beforeend"
|
||||
(dom-append target new-nodes)
|
||||
|
||||
"afterbegin"
|
||||
(dom-prepend target new-nodes)
|
||||
|
||||
"beforebegin"
|
||||
(dom-insert-before (dom-parent target) new-nodes target)
|
||||
|
||||
"delete"
|
||||
(dom-remove-child (dom-parent target) target)
|
||||
|
||||
"none"
|
||||
nil
|
||||
|
||||
;; Default = innerHTML
|
||||
:else
|
||||
(if (dom-is-fragment? new-nodes)
|
||||
(morph-children target new-nodes)
|
||||
(let ((wrapper (dom-create-element "div" nil)))
|
||||
(dom-append wrapper new-nodes)
|
||||
(morph-children target wrapper))))))
|
||||
|
||||
|
||||
(define insert-remaining-siblings :effects [mutation io]
|
||||
(fn (parent ref-node sib)
|
||||
;; Insert sibling chain after ref-node
|
||||
(when sib
|
||||
(let ((next (dom-next-sibling sib)))
|
||||
(dom-insert-after ref-node sib)
|
||||
(insert-remaining-siblings parent sib next)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; String-based swap (fallback for HTML responses)
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define swap-html-string :effects [mutation io]
|
||||
(fn (target (html :as string) (strategy :as string))
|
||||
;; Execute a swap strategy using an HTML string (DOMParser pipeline).
|
||||
(case strategy
|
||||
"innerHTML"
|
||||
(dom-set-inner-html target html)
|
||||
"outerHTML"
|
||||
(let ((parent (dom-parent target)))
|
||||
(dom-insert-adjacent-html target "afterend" html)
|
||||
(dom-remove-child parent target)
|
||||
parent)
|
||||
"afterend"
|
||||
(dom-insert-adjacent-html target "afterend" html)
|
||||
"beforeend"
|
||||
(dom-insert-adjacent-html target "beforeend" html)
|
||||
"afterbegin"
|
||||
(dom-insert-adjacent-html target "afterbegin" html)
|
||||
"beforebegin"
|
||||
(dom-insert-adjacent-html target "beforebegin" html)
|
||||
"delete"
|
||||
(dom-remove-child (dom-parent target) target)
|
||||
"none"
|
||||
nil
|
||||
:else
|
||||
(dom-set-inner-html target html))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; History management
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define handle-history :effects [io]
|
||||
(fn (el (url :as string) (resp-headers :as dict))
|
||||
;; Process history push/replace based on element attrs and response headers
|
||||
(let ((push-url (dom-get-attr el "sx-push-url"))
|
||||
(replace-url (dom-get-attr el "sx-replace-url"))
|
||||
(hdr-replace (get resp-headers "replace-url")))
|
||||
(cond
|
||||
;; Server override
|
||||
hdr-replace
|
||||
(browser-replace-state hdr-replace)
|
||||
;; Client push
|
||||
(and push-url (not (= push-url "false")))
|
||||
(browser-push-state
|
||||
(if (= push-url "true") url push-url))
|
||||
;; Client replace
|
||||
(and replace-url (not (= replace-url "false")))
|
||||
(browser-replace-state
|
||||
(if (= replace-url "true") url replace-url))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Preload cache
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define PRELOAD_TTL 30000) ;; 30 seconds
|
||||
|
||||
(define preload-cache-get :effects [mutation]
|
||||
(fn ((cache :as dict) (url :as string))
|
||||
;; Get and consume a cached preload response.
|
||||
;; Returns (dict "text" ... "content-type" ...) or nil.
|
||||
(let ((entry (dict-get cache url)))
|
||||
(if (nil? entry)
|
||||
nil
|
||||
(if (> (- (now-ms) (get entry "timestamp")) PRELOAD_TTL)
|
||||
(do (dict-delete! cache url) nil)
|
||||
(do (dict-delete! cache url) entry))))))
|
||||
|
||||
|
||||
(define preload-cache-set :effects [mutation]
|
||||
(fn ((cache :as dict) (url :as string) (text :as string) (content-type :as string))
|
||||
;; Store a preloaded response
|
||||
(dict-set! cache url
|
||||
(dict "text" text "content-type" content-type "timestamp" (now-ms)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Trigger dispatch table
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Maps trigger event names to binding strategies.
|
||||
;; This is the logic; actual browser event binding is platform interface.
|
||||
|
||||
(define classify-trigger :effects []
|
||||
(fn ((trigger :as dict))
|
||||
;; Classify a parsed trigger descriptor for binding.
|
||||
;; Returns one of: "poll", "intersect", "load", "revealed", "event"
|
||||
(let ((event (get trigger "event")))
|
||||
(cond
|
||||
(= event "every") "poll"
|
||||
(= event "intersect") "intersect"
|
||||
(= event "load") "load"
|
||||
(= event "revealed") "revealed"
|
||||
:else "event"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Boost logic
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define should-boost-link? :effects [io]
|
||||
(fn (link)
|
||||
;; Whether a link inside an sx-boost container should be boosted
|
||||
(let ((href (dom-get-attr link "href")))
|
||||
(and href
|
||||
(not (starts-with? href "#"))
|
||||
(not (starts-with? href "javascript:"))
|
||||
(not (starts-with? href "mailto:"))
|
||||
(browser-same-origin? href)
|
||||
(not (dom-has-attr? link "sx-get"))
|
||||
(not (dom-has-attr? link "sx-post"))
|
||||
(not (dom-has-attr? link "sx-disable"))))))
|
||||
|
||||
|
||||
(define should-boost-form? :effects [io]
|
||||
(fn (form)
|
||||
;; Whether a form inside an sx-boost container should be boosted
|
||||
(and (not (dom-has-attr? form "sx-get"))
|
||||
(not (dom-has-attr? form "sx-post"))
|
||||
(not (dom-has-attr? form "sx-disable")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; SSE event classification
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define parse-sse-swap :effects [io]
|
||||
(fn (el)
|
||||
;; Parse sx-sse-swap attribute
|
||||
;; Returns event name to listen for (default "message")
|
||||
(or (dom-get-attr el "sx-sse-swap") "message")))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Platform interface — Engine (pure logic)
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; From adapter-dom.sx:
|
||||
;; dom-get-attr, dom-set-attr, dom-remove-attr, dom-has-attr?, dom-attr-list
|
||||
;; dom-query, dom-query-all, dom-id, dom-parent, dom-first-child,
|
||||
;; dom-next-sibling, dom-child-list, dom-node-type, dom-node-name,
|
||||
;; dom-text-content, dom-set-text-content, dom-is-fragment?,
|
||||
;; dom-is-child-of?, dom-is-active-element?, dom-is-input-element?,
|
||||
;; dom-create-element, dom-append, dom-prepend, dom-insert-before,
|
||||
;; dom-insert-after, dom-remove-child, dom-replace-child, dom-clone,
|
||||
;; dom-get-style, dom-set-style, dom-get-prop, dom-set-prop,
|
||||
;; dom-add-class, dom-remove-class, dom-set-inner-html,
|
||||
;; dom-insert-adjacent-html
|
||||
;;
|
||||
;; Browser/Network:
|
||||
;; (browser-location-href) → current URL string
|
||||
;; (browser-same-origin? url) → boolean
|
||||
;; (browser-push-state url) → void (history.pushState)
|
||||
;; (browser-replace-state url) → void (history.replaceState)
|
||||
;;
|
||||
;; Parsing:
|
||||
;; (parse-header-value s) → parsed dict from header string
|
||||
;; (now-ms) → current timestamp in milliseconds
|
||||
;; --------------------------------------------------------------------------
|
||||
File diff suppressed because it is too large
Load Diff
@@ -1,278 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; forms.sx — Server-side definition forms
|
||||
;;
|
||||
;; Platform-specific special forms for declaring handlers, pages, queries,
|
||||
;; and actions. These parse &key parameter lists and create typed definition
|
||||
;; objects that the server runtime uses for routing and execution.
|
||||
;;
|
||||
;; When SX moves to isomorphic execution, these forms will have different
|
||||
;; platform bindings on client vs server. The spec stays the same — only
|
||||
;; the constructors (make-handler-def, make-query-def, etc.) change.
|
||||
;;
|
||||
;; Platform functions required:
|
||||
;; make-handler-def(name, params, body, env) → HandlerDef
|
||||
;; make-query-def(name, params, doc, body, env) → QueryDef
|
||||
;; make-action-def(name, params, doc, body, env) → ActionDef
|
||||
;; make-page-def(name, slots, env) → PageDef
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Shared: parse (&key param1 param2 ...) → list of param name strings
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define parse-key-params
|
||||
(fn ((params-expr :as list))
|
||||
(let ((params (list))
|
||||
(in-key false))
|
||||
(for-each
|
||||
(fn (p)
|
||||
(when (= (type-of p) "symbol")
|
||||
(let ((name (symbol-name p)))
|
||||
(cond
|
||||
(= name "&key") (set! in-key true)
|
||||
in-key (append! params name)
|
||||
:else (append! params name)))))
|
||||
params-expr)
|
||||
params)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; defhandler — (defhandler name [:path "..." :method :get :csrf false :returns "element"] (&key param...) body)
|
||||
;;
|
||||
;; Keyword options between name and params list:
|
||||
;; :path — public route path (string). Without :path, handler is internal-only.
|
||||
;; :method — HTTP method (keyword: :get :post :put :patch :delete). Default :get.
|
||||
;; :csrf — CSRF protection (boolean). Default true; set false for POST/PUT etc.
|
||||
;; :returns — return type annotation (types.sx vocabulary). Default "element".
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define parse-handler-args
|
||||
(fn ((args :as list))
|
||||
"Parse defhandler args after the name symbol.
|
||||
Scans for :keyword value option pairs, then a list (params), then body.
|
||||
Returns dict with keys: opts, params, body."
|
||||
(let ((opts {})
|
||||
(params (list))
|
||||
(body nil)
|
||||
(i 0)
|
||||
(n (len args))
|
||||
(done false))
|
||||
(for-each
|
||||
(fn (idx)
|
||||
(when (and (not done) (= idx i))
|
||||
(let ((arg (nth args idx)))
|
||||
(cond
|
||||
;; keyword-value pair → consume two items
|
||||
(= (type-of arg) "keyword")
|
||||
(do
|
||||
(when (< (+ idx 1) n)
|
||||
(let ((val (nth args (+ idx 1))))
|
||||
;; For :method, extract keyword name; for :csrf, keep as-is
|
||||
(dict-set! opts (keyword-name arg)
|
||||
(if (= (type-of val) "keyword")
|
||||
(keyword-name val)
|
||||
val))))
|
||||
(set! i (+ idx 2)))
|
||||
;; list → params, next element is body
|
||||
(= (type-of arg) "list")
|
||||
(do
|
||||
(set! params (parse-key-params arg))
|
||||
(when (< (+ idx 1) n)
|
||||
(set! body (nth args (+ idx 1))))
|
||||
(set! done true))
|
||||
;; anything else → no explicit params, this is body
|
||||
:else
|
||||
(do
|
||||
(set! body arg)
|
||||
(set! done true))))))
|
||||
(range 0 n))
|
||||
(dict :opts opts :params params :body body))))
|
||||
|
||||
(define sf-defhandler
|
||||
(fn ((args :as list) (env :as dict))
|
||||
(let ((name-sym (first args))
|
||||
(name (symbol-name name-sym))
|
||||
(parsed (parse-handler-args (rest args)))
|
||||
(opts (get parsed "opts"))
|
||||
(params (get parsed "params"))
|
||||
(body (get parsed "body")))
|
||||
(let ((hdef (make-handler-def name params body env opts)))
|
||||
(env-set! env (str "handler:" name) hdef)
|
||||
hdef))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; defquery — (defquery name (&key param...) "docstring" body)
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define sf-defquery
|
||||
(fn ((args :as list) (env :as dict))
|
||||
(let ((name-sym (first args))
|
||||
(params-raw (nth args 1))
|
||||
(name (symbol-name name-sym))
|
||||
(params (parse-key-params params-raw))
|
||||
;; Optional docstring before body
|
||||
(has-doc (and (>= (len args) 4) (= (type-of (nth args 2)) "string")))
|
||||
(doc (if has-doc (nth args 2) ""))
|
||||
(body (if has-doc (nth args 3) (nth args 2))))
|
||||
(let ((qdef (make-query-def name params doc body env)))
|
||||
(env-set! env (str "query:" name) qdef)
|
||||
qdef))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; defaction — (defaction name (&key param...) "docstring" body)
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define sf-defaction
|
||||
(fn ((args :as list) (env :as dict))
|
||||
(let ((name-sym (first args))
|
||||
(params-raw (nth args 1))
|
||||
(name (symbol-name name-sym))
|
||||
(params (parse-key-params params-raw))
|
||||
(has-doc (and (>= (len args) 4) (= (type-of (nth args 2)) "string")))
|
||||
(doc (if has-doc (nth args 2) ""))
|
||||
(body (if has-doc (nth args 3) (nth args 2))))
|
||||
(let ((adef (make-action-def name params doc body env)))
|
||||
(env-set! env (str "action:" name) adef)
|
||||
adef))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; defpage — (defpage name :path "/..." :auth :public :content expr ...)
|
||||
;;
|
||||
;; Keyword-slot form: all values after the name are :key value pairs.
|
||||
;; Values are stored as unevaluated AST — resolved at request time.
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define sf-defpage
|
||||
(fn ((args :as list) (env :as dict))
|
||||
(let ((name-sym (first args))
|
||||
(name (symbol-name name-sym))
|
||||
(slots {}))
|
||||
;; Parse keyword slots from remaining args
|
||||
(let ((i 1)
|
||||
(max-i (len args)))
|
||||
(for-each
|
||||
(fn ((idx :as number))
|
||||
(when (and (< idx max-i)
|
||||
(= (type-of (nth args idx)) "keyword"))
|
||||
(when (< (+ idx 1) max-i)
|
||||
(dict-set! slots (keyword-name (nth args idx))
|
||||
(nth args (+ idx 1))))))
|
||||
(range 1 max-i 2)))
|
||||
(let ((pdef (make-page-def name slots env)))
|
||||
(env-set! env (str "page:" name) pdef)
|
||||
pdef))))
|
||||
|
||||
|
||||
;; ==========================================================================
|
||||
;; Page Execution Semantics
|
||||
;; ==========================================================================
|
||||
;;
|
||||
;; A PageDef describes what to render for a route. The host evaluates slots
|
||||
;; at request time. This section specifies the data → content protocol that
|
||||
;; every host must implement identically.
|
||||
;;
|
||||
;; Slots (all unevaluated AST):
|
||||
;; :path — route pattern (string)
|
||||
;; :auth — "public" | "login" | "admin"
|
||||
;; :layout — layout reference + kwargs
|
||||
;; :stream — boolean, opt into chunked transfer
|
||||
;; :shell — immediate content (contains ~suspense placeholders)
|
||||
;; :fallback — loading skeleton for single-stream mode
|
||||
;; :data — IO expression producing bindings
|
||||
;; :content — template expression evaluated with data bindings
|
||||
;; :filter, :aside, :menu — additional content slots
|
||||
;;
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Data Protocol
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; The :data expression is evaluated at request time. It returns one of:
|
||||
;;
|
||||
;; 1. A dict — single-stream mode (default).
|
||||
;; Each key becomes an env binding (underscores → hyphens).
|
||||
;; Then :content is evaluated once with those bindings.
|
||||
;; Result resolves the "stream-content" suspense slot.
|
||||
;;
|
||||
;; 2. A sequence of dicts — multi-stream mode.
|
||||
;; The host delivers items over time (async generator, channel, etc.).
|
||||
;; Each dict:
|
||||
;; - MUST contain "stream-id" → string matching a ~suspense :id
|
||||
;; - Remaining keys become env bindings (underscores → hyphens)
|
||||
;; - :content is re-evaluated with those bindings
|
||||
;; - Result resolves the ~suspense slot matching "stream-id"
|
||||
;; If "stream-id" is absent, defaults to "stream-content".
|
||||
;;
|
||||
;; The host is free to choose the timing mechanism:
|
||||
;; Python — async generator (yield dicts at intervals)
|
||||
;; Go — channel of dicts
|
||||
;; Haskell — conduit / streaming
|
||||
;; JS — async iterator
|
||||
;;
|
||||
;; The spec requires:
|
||||
;; (a) Each item's bindings are isolated (fresh env per item)
|
||||
;; (b) :content is evaluated independently for each item
|
||||
;; (c) Resolution is incremental — each item resolves as it arrives
|
||||
;; (d) "stream-id" routes to the correct ~suspense slot
|
||||
;;
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Streaming Execution Order
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; When :stream is true:
|
||||
;;
|
||||
;; 1. Evaluate :shell (if present) → HTML for immediate content slot
|
||||
;; :shell typically contains ~suspense placeholders with :fallback
|
||||
;; 2. Render HTML shell with suspense placeholders → send to client
|
||||
;; 3. Start :data evaluation concurrently with header resolution
|
||||
;; 4. As each data item arrives:
|
||||
;; a. Bind item keys into fresh env
|
||||
;; b. Evaluate :content with those bindings → SX wire format
|
||||
;; c. Send resolve script: __sxResolve(stream-id, sx)
|
||||
;; 5. Close response when all items + headers have resolved
|
||||
;;
|
||||
;; Non-streaming pages evaluate :data then :content sequentially and
|
||||
;; return the complete page in a single response.
|
||||
;;
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Spec helpers for multi-stream data protocol
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Extract stream-id from a data chunk dict, defaulting to "stream-content"
|
||||
(define stream-chunk-id
|
||||
(fn ((chunk :as dict))
|
||||
(if (has-key? chunk "stream-id")
|
||||
(get chunk "stream-id")
|
||||
"stream-content")))
|
||||
|
||||
;; Remove stream-id from chunk, returning only the bindings
|
||||
(define stream-chunk-bindings
|
||||
(fn ((chunk :as dict))
|
||||
(dissoc chunk "stream-id")))
|
||||
|
||||
;; Normalize binding keys: underscore → hyphen
|
||||
(define normalize-binding-key
|
||||
(fn ((key :as string))
|
||||
(replace key "_" "-")))
|
||||
|
||||
;; Bind a data chunk's keys into a fresh env (isolated per chunk)
|
||||
(define bind-stream-chunk
|
||||
(fn ((chunk :as dict) (base-env :as dict))
|
||||
(let ((env (merge {} base-env))
|
||||
(bindings (stream-chunk-bindings chunk)))
|
||||
(for-each
|
||||
(fn ((key :as string))
|
||||
(env-set! env (normalize-binding-key key)
|
||||
(get bindings key)))
|
||||
(keys bindings))
|
||||
env)))
|
||||
|
||||
;; Validate a multi-stream data result: must be a list of dicts
|
||||
(define validate-stream-data
|
||||
(fn (data)
|
||||
(and (= (type-of data) "list")
|
||||
(every? (fn (item) (= (type-of item) "dict")) data))))
|
||||
@@ -1,262 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; frames.sx — CEK machine frame types
|
||||
;;
|
||||
;; Defines the continuation frame types used by the explicit CEK evaluator.
|
||||
;; Each frame represents a "what to do next" when a sub-evaluation completes.
|
||||
;;
|
||||
;; A CEK state is a dict:
|
||||
;; {:control expr — expression being evaluated (or nil in continue phase)
|
||||
;; :env env — current environment
|
||||
;; :kont list — continuation: list of frames (stack, head = top)
|
||||
;; :phase "eval"|"continue"
|
||||
;; :value any} — value produced (only in continue phase)
|
||||
;;
|
||||
;; Two-phase step function:
|
||||
;; step-eval: control is expression → dispatch → push frame + new control
|
||||
;; step-continue: value produced → pop frame → dispatch → new state
|
||||
;;
|
||||
;; Terminal state: phase = "continue" and kont is empty → value is final result.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 1. CEK State constructors
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define make-cek-state
|
||||
(fn (control env kont)
|
||||
{:control control :env env :kont kont :phase "eval" :value nil}))
|
||||
|
||||
(define make-cek-value
|
||||
(fn (value env kont)
|
||||
{:control nil :env env :kont kont :phase "continue" :value value}))
|
||||
|
||||
(define cek-terminal?
|
||||
(fn (state)
|
||||
(and (= (get state "phase") "continue")
|
||||
(empty? (get state "kont")))))
|
||||
|
||||
(define cek-control (fn (s) (get s "control")))
|
||||
(define cek-env (fn (s) (get s "env")))
|
||||
(define cek-kont (fn (s) (get s "kont")))
|
||||
(define cek-phase (fn (s) (get s "phase")))
|
||||
(define cek-value (fn (s) (get s "value")))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 2. Frame constructors
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Each frame type is a dict with a "type" key and frame-specific data.
|
||||
|
||||
;; IfFrame: waiting for condition value
|
||||
;; After condition evaluates, choose then or else branch
|
||||
(define make-if-frame
|
||||
(fn (then-expr else-expr env)
|
||||
{:type "if" :then then-expr :else else-expr :env env}))
|
||||
|
||||
;; WhenFrame: waiting for condition value
|
||||
;; If truthy, evaluate body exprs sequentially
|
||||
(define make-when-frame
|
||||
(fn (body-exprs env)
|
||||
{:type "when" :body body-exprs :env env}))
|
||||
|
||||
;; BeginFrame: sequential evaluation
|
||||
;; Remaining expressions to evaluate after current one
|
||||
(define make-begin-frame
|
||||
(fn (remaining env)
|
||||
{:type "begin" :remaining remaining :env env}))
|
||||
|
||||
;; LetFrame: binding evaluation in progress
|
||||
;; name = current binding name, remaining = remaining (name val) pairs
|
||||
;; body = body expressions to evaluate after all bindings
|
||||
(define make-let-frame
|
||||
(fn (name remaining body local)
|
||||
{:type "let" :name name :remaining remaining :body body :env local}))
|
||||
|
||||
;; DefineFrame: waiting for value to bind
|
||||
(define make-define-frame
|
||||
(fn (name env has-effects effect-list)
|
||||
{:type "define" :name name :env env
|
||||
:has-effects has-effects :effect-list effect-list}))
|
||||
|
||||
;; SetFrame: waiting for value to assign
|
||||
(define make-set-frame
|
||||
(fn (name env)
|
||||
{:type "set" :name name :env env}))
|
||||
|
||||
;; ArgFrame: evaluating function arguments
|
||||
;; f = function value (already evaluated), evaled = already evaluated args
|
||||
;; remaining = remaining arg expressions
|
||||
(define make-arg-frame
|
||||
(fn (f evaled remaining env raw-args)
|
||||
{:type "arg" :f f :evaled evaled :remaining remaining :env env
|
||||
:raw-args raw-args}))
|
||||
|
||||
;; CallFrame: about to call with fully evaluated args
|
||||
(define make-call-frame
|
||||
(fn (f args env)
|
||||
{:type "call" :f f :args args :env env}))
|
||||
|
||||
;; CondFrame: evaluating cond clauses
|
||||
(define make-cond-frame
|
||||
(fn (remaining env scheme?)
|
||||
{:type "cond" :remaining remaining :env env :scheme scheme?}))
|
||||
|
||||
;; CaseFrame: evaluating case clauses
|
||||
(define make-case-frame
|
||||
(fn (match-val remaining env)
|
||||
{:type "case" :match-val match-val :remaining remaining :env env}))
|
||||
|
||||
;; ThreadFirstFrame: pipe threading
|
||||
(define make-thread-frame
|
||||
(fn (remaining env)
|
||||
{:type "thread" :remaining remaining :env env}))
|
||||
|
||||
;; MapFrame: higher-order map/map-indexed in progress
|
||||
(define make-map-frame
|
||||
(fn (f remaining results env)
|
||||
{:type "map" :f f :remaining remaining :results results :env env :indexed false}))
|
||||
|
||||
(define make-map-indexed-frame
|
||||
(fn (f remaining results env)
|
||||
{:type "map" :f f :remaining remaining :results results :env env :indexed true}))
|
||||
|
||||
;; FilterFrame: higher-order filter in progress
|
||||
(define make-filter-frame
|
||||
(fn (f remaining results current-item env)
|
||||
{:type "filter" :f f :remaining remaining :results results
|
||||
:current-item current-item :env env}))
|
||||
|
||||
;; ReduceFrame: higher-order reduce in progress
|
||||
(define make-reduce-frame
|
||||
(fn (f remaining env)
|
||||
{:type "reduce" :f f :remaining remaining :env env}))
|
||||
|
||||
;; ForEachFrame: higher-order for-each in progress
|
||||
(define make-for-each-frame
|
||||
(fn (f remaining env)
|
||||
{:type "for-each" :f f :remaining remaining :env env}))
|
||||
|
||||
;; SomeFrame: higher-order some (short-circuit on first truthy)
|
||||
(define make-some-frame
|
||||
(fn (f remaining env)
|
||||
{:type "some" :f f :remaining remaining :env env}))
|
||||
|
||||
;; EveryFrame: higher-order every? (short-circuit on first falsy)
|
||||
(define make-every-frame
|
||||
(fn (f remaining env)
|
||||
{:type "every" :f f :remaining remaining :env env}))
|
||||
|
||||
;; ScopeFrame: scope-pop! when frame pops
|
||||
(define make-scope-frame
|
||||
(fn (name remaining env)
|
||||
{:type "scope" :name name :remaining remaining :env env}))
|
||||
|
||||
;; ResetFrame: delimiter for shift/reset continuations
|
||||
(define make-reset-frame
|
||||
(fn (env)
|
||||
{:type "reset" :env env}))
|
||||
|
||||
;; DictFrame: evaluating dict values
|
||||
(define make-dict-frame
|
||||
(fn (remaining results env)
|
||||
{:type "dict" :remaining remaining :results results :env env}))
|
||||
|
||||
;; AndFrame: short-circuit and
|
||||
(define make-and-frame
|
||||
(fn (remaining env)
|
||||
{:type "and" :remaining remaining :env env}))
|
||||
|
||||
;; OrFrame: short-circuit or
|
||||
(define make-or-frame
|
||||
(fn (remaining env)
|
||||
{:type "or" :remaining remaining :env env}))
|
||||
|
||||
;; QuasiquoteFrame (not a real frame — QQ is handled specially)
|
||||
|
||||
;; DynamicWindFrame: phases of dynamic-wind
|
||||
(define make-dynamic-wind-frame
|
||||
(fn (phase body-thunk after-thunk env)
|
||||
{:type "dynamic-wind" :phase phase
|
||||
:body-thunk body-thunk :after-thunk after-thunk :env env}))
|
||||
|
||||
;; ReactiveResetFrame: delimiter for reactive deref-as-shift
|
||||
;; Carries an update-fn that gets called with new values on re-render.
|
||||
(define make-reactive-reset-frame
|
||||
(fn (env update-fn first-render?)
|
||||
{:type "reactive-reset" :env env :update-fn update-fn
|
||||
:first-render first-render?}))
|
||||
|
||||
;; DerefFrame: awaiting evaluation of deref's argument
|
||||
(define make-deref-frame
|
||||
(fn (env)
|
||||
{:type "deref" :env env}))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 3. Frame accessors
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define frame-type (fn (f) (get f "type")))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 4. Continuation operations
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define kont-push
|
||||
(fn (frame kont) (cons frame kont)))
|
||||
|
||||
(define kont-top
|
||||
(fn (kont) (first kont)))
|
||||
|
||||
(define kont-pop
|
||||
(fn (kont) (rest kont)))
|
||||
|
||||
(define kont-empty?
|
||||
(fn (kont) (empty? kont)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 5. CEK shift/reset support
|
||||
;; --------------------------------------------------------------------------
|
||||
;; shift captures all frames up to the nearest ResetFrame.
|
||||
;; reset pushes a ResetFrame.
|
||||
|
||||
(define kont-capture-to-reset
|
||||
(fn (kont)
|
||||
;; Returns (captured-frames remaining-kont).
|
||||
;; captured-frames: frames from top up to (not including) ResetFrame.
|
||||
;; remaining-kont: frames after ResetFrame.
|
||||
;; Stops at either "reset" or "reactive-reset" frames.
|
||||
(define scan
|
||||
(fn (k captured)
|
||||
(if (empty? k)
|
||||
(error "shift without enclosing reset")
|
||||
(let ((frame (first k)))
|
||||
(if (or (= (frame-type frame) "reset")
|
||||
(= (frame-type frame) "reactive-reset"))
|
||||
(list captured (rest k))
|
||||
(scan (rest k) (append captured (list frame))))))))
|
||||
(scan kont (list))))
|
||||
|
||||
;; Check if a ReactiveResetFrame exists anywhere in the continuation
|
||||
(define has-reactive-reset-frame?
|
||||
(fn (kont)
|
||||
(if (empty? kont) false
|
||||
(if (= (frame-type (first kont)) "reactive-reset") true
|
||||
(has-reactive-reset-frame? (rest kont))))))
|
||||
|
||||
;; Capture frames up to nearest ReactiveResetFrame.
|
||||
;; Returns (captured-frames, reset-frame, remaining-kont).
|
||||
(define kont-capture-to-reactive-reset
|
||||
(fn (kont)
|
||||
(define scan
|
||||
(fn (k captured)
|
||||
(if (empty? k)
|
||||
(error "reactive deref without enclosing reactive-reset")
|
||||
(let ((frame (first k)))
|
||||
(if (= (frame-type frame) "reactive-reset")
|
||||
(list captured frame (rest k))
|
||||
(scan (rest k) (append captured (list frame))))))))
|
||||
(scan kont (list))))
|
||||
File diff suppressed because it is too large
Load Diff
@@ -1,368 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; page-helpers.sx — Pure data-transformation page helpers
|
||||
;;
|
||||
;; These functions take raw data (from Python I/O edge) and return
|
||||
;; structured dicts for page rendering. No I/O — pure transformations
|
||||
;; only. Bootstrapped to every host.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; categorize-special-forms
|
||||
;;
|
||||
;; Parses define-special-form declarations from special-forms.sx AST,
|
||||
;; categorizes each form by name lookup, returns dict of category → forms.
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define special-form-category-map
|
||||
{"if" "Control Flow" "when" "Control Flow" "cond" "Control Flow"
|
||||
"case" "Control Flow" "and" "Control Flow" "or" "Control Flow"
|
||||
"let" "Binding" "let*" "Binding" "letrec" "Binding"
|
||||
"define" "Binding" "set!" "Binding"
|
||||
"lambda" "Functions & Components" "fn" "Functions & Components"
|
||||
"defcomp" "Functions & Components" "defmacro" "Functions & Components"
|
||||
"begin" "Sequencing & Threading" "do" "Sequencing & Threading"
|
||||
"->" "Sequencing & Threading"
|
||||
"quote" "Quoting" "quasiquote" "Quoting"
|
||||
"reset" "Continuations" "shift" "Continuations"
|
||||
"dynamic-wind" "Guards"
|
||||
"map" "Higher-Order Forms" "map-indexed" "Higher-Order Forms"
|
||||
"filter" "Higher-Order Forms" "reduce" "Higher-Order Forms"
|
||||
"some" "Higher-Order Forms" "every?" "Higher-Order Forms"
|
||||
"for-each" "Higher-Order Forms"
|
||||
"defstyle" "Domain Definitions"
|
||||
"defhandler" "Domain Definitions" "defpage" "Domain Definitions"
|
||||
"defquery" "Domain Definitions" "defaction" "Domain Definitions"})
|
||||
|
||||
|
||||
(define extract-define-kwargs
|
||||
(fn ((expr :as list))
|
||||
;; Extract keyword args from a define-special-form expression.
|
||||
;; Returns dict of keyword-name → string value.
|
||||
;; Walks items pairwise: when item[i] is a keyword, item[i+1] is its value.
|
||||
(let ((result {})
|
||||
(items (slice expr 2))
|
||||
(n (len items)))
|
||||
(for-each
|
||||
(fn ((idx :as number))
|
||||
(when (and (< (+ idx 1) n)
|
||||
(= (type-of (nth items idx)) "keyword"))
|
||||
(let ((key (keyword-name (nth items idx)))
|
||||
(val (nth items (+ idx 1))))
|
||||
(dict-set! result key
|
||||
(if (= (type-of val) "list")
|
||||
(str "(" (join " " (map serialize val)) ")")
|
||||
(str val))))))
|
||||
(range 0 n))
|
||||
result)))
|
||||
|
||||
|
||||
(define categorize-special-forms
|
||||
(fn ((parsed-exprs :as list))
|
||||
;; parsed-exprs: result of parse-all on special-forms.sx
|
||||
;; Returns dict of category-name → list of form dicts.
|
||||
(let ((categories {}))
|
||||
(for-each
|
||||
(fn (expr)
|
||||
(when (and (= (type-of expr) "list")
|
||||
(>= (len expr) 2)
|
||||
(= (type-of (first expr)) "symbol")
|
||||
(= (symbol-name (first expr)) "define-special-form"))
|
||||
(let ((name (nth expr 1))
|
||||
(kwargs (extract-define-kwargs expr))
|
||||
(category (or (get special-form-category-map name) "Other")))
|
||||
(when (not (has-key? categories category))
|
||||
(dict-set! categories category (list)))
|
||||
(append! (get categories category)
|
||||
{"name" name
|
||||
"syntax" (or (get kwargs "syntax") "")
|
||||
"doc" (or (get kwargs "doc") "")
|
||||
"tail-position" (or (get kwargs "tail-position") "")
|
||||
"example" (or (get kwargs "example") "")}))))
|
||||
parsed-exprs)
|
||||
categories)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; build-reference-data
|
||||
;;
|
||||
;; Takes a slug and raw reference data, returns structured dict for rendering.
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define build-ref-items-with-href
|
||||
(fn ((items :as list) (base-path :as string) (detail-keys :as list) (n-fields :as number))
|
||||
;; items: list of lists (tuples), each with n-fields elements
|
||||
;; base-path: e.g. "/geography/hypermedia/reference/attributes/"
|
||||
;; detail-keys: list of strings (keys that have detail pages)
|
||||
;; n-fields: 2 or 3 (number of fields per tuple)
|
||||
(map
|
||||
(fn ((item :as list))
|
||||
(if (= n-fields 3)
|
||||
;; [name, desc/value, exists/desc]
|
||||
(let ((name (nth item 0))
|
||||
(field2 (nth item 1))
|
||||
(field3 (nth item 2)))
|
||||
{"name" name
|
||||
"desc" field2
|
||||
"exists" field3
|
||||
"href" (if (and field3 (some (fn ((k :as string)) (= k name)) detail-keys))
|
||||
(str base-path name)
|
||||
nil)})
|
||||
;; [name, desc]
|
||||
(let ((name (nth item 0))
|
||||
(desc (nth item 1)))
|
||||
{"name" name
|
||||
"desc" desc
|
||||
"href" (if (some (fn ((k :as string)) (= k name)) detail-keys)
|
||||
(str base-path name)
|
||||
nil)})))
|
||||
items)))
|
||||
|
||||
|
||||
(define build-reference-data
|
||||
(fn ((slug :as string) (raw-data :as dict) (detail-keys :as list))
|
||||
;; slug: "attributes", "headers", "events", "js-api"
|
||||
;; raw-data: dict with the raw data lists for this slug
|
||||
;; detail-keys: list of names that have detail pages
|
||||
(case slug
|
||||
"attributes"
|
||||
{"req-attrs" (build-ref-items-with-href
|
||||
(get raw-data "req-attrs")
|
||||
"/geography/hypermedia/reference/attributes/" detail-keys 3)
|
||||
"beh-attrs" (build-ref-items-with-href
|
||||
(get raw-data "beh-attrs")
|
||||
"/geography/hypermedia/reference/attributes/" detail-keys 3)
|
||||
"uniq-attrs" (build-ref-items-with-href
|
||||
(get raw-data "uniq-attrs")
|
||||
"/geography/hypermedia/reference/attributes/" detail-keys 3)}
|
||||
|
||||
"headers"
|
||||
{"req-headers" (build-ref-items-with-href
|
||||
(get raw-data "req-headers")
|
||||
"/geography/hypermedia/reference/headers/" detail-keys 3)
|
||||
"resp-headers" (build-ref-items-with-href
|
||||
(get raw-data "resp-headers")
|
||||
"/geography/hypermedia/reference/headers/" detail-keys 3)}
|
||||
|
||||
"events"
|
||||
{"events-list" (build-ref-items-with-href
|
||||
(get raw-data "events-list")
|
||||
"/geography/hypermedia/reference/events/" detail-keys 2)}
|
||||
|
||||
"js-api"
|
||||
{"js-api-list" (map (fn ((item :as list)) {"name" (nth item 0) "desc" (nth item 1)})
|
||||
(get raw-data "js-api-list"))}
|
||||
|
||||
;; default: attributes
|
||||
:else
|
||||
{"req-attrs" (build-ref-items-with-href
|
||||
(get raw-data "req-attrs")
|
||||
"/geography/hypermedia/reference/attributes/" detail-keys 3)
|
||||
"beh-attrs" (build-ref-items-with-href
|
||||
(get raw-data "beh-attrs")
|
||||
"/geography/hypermedia/reference/attributes/" detail-keys 3)
|
||||
"uniq-attrs" (build-ref-items-with-href
|
||||
(get raw-data "uniq-attrs")
|
||||
"/geography/hypermedia/reference/attributes/" detail-keys 3)})))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; build-attr-detail / build-header-detail / build-event-detail
|
||||
;;
|
||||
;; Lookup a slug in a detail dict, reshape for page rendering.
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define build-attr-detail
|
||||
(fn ((slug :as string) detail)
|
||||
;; detail: dict with "description", "example", "handler", "demo" keys or nil
|
||||
(if (nil? detail)
|
||||
{"attr-not-found" true}
|
||||
{"attr-not-found" nil
|
||||
"attr-title" slug
|
||||
"attr-description" (get detail "description")
|
||||
"attr-example" (get detail "example")
|
||||
"attr-handler" (get detail "handler")
|
||||
"attr-demo" (get detail "demo")
|
||||
"attr-wire-id" (if (has-key? detail "handler")
|
||||
(str "ref-wire-"
|
||||
(replace (replace slug ":" "-") "*" "star"))
|
||||
nil)})))
|
||||
|
||||
|
||||
(define build-header-detail
|
||||
(fn ((slug :as string) detail)
|
||||
(if (nil? detail)
|
||||
{"header-not-found" true}
|
||||
{"header-not-found" nil
|
||||
"header-title" slug
|
||||
"header-direction" (get detail "direction")
|
||||
"header-description" (get detail "description")
|
||||
"header-example" (get detail "example")
|
||||
"header-demo" (get detail "demo")})))
|
||||
|
||||
|
||||
(define build-event-detail
|
||||
(fn ((slug :as string) detail)
|
||||
(if (nil? detail)
|
||||
{"event-not-found" true}
|
||||
{"event-not-found" nil
|
||||
"event-title" slug
|
||||
"event-description" (get detail "description")
|
||||
"event-example" (get detail "example")
|
||||
"event-demo" (get detail "demo")})))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; build-component-source
|
||||
;;
|
||||
;; Reconstruct defcomp/defisland source from component metadata.
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define build-component-source
|
||||
(fn ((comp-data :as dict))
|
||||
;; comp-data: dict with "type", "name", "params", "has-children", "body-sx", "affinity"
|
||||
(let ((comp-type (get comp-data "type"))
|
||||
(name (get comp-data "name"))
|
||||
(params (get comp-data "params"))
|
||||
(has-children (get comp-data "has-children"))
|
||||
(body-sx (get comp-data "body-sx"))
|
||||
(affinity (get comp-data "affinity")))
|
||||
(if (= comp-type "not-found")
|
||||
(str ";; component " name " not found")
|
||||
(let ((param-strs (if (empty? params)
|
||||
(if has-children
|
||||
(list "&rest" "children")
|
||||
(list))
|
||||
(if has-children
|
||||
(append (cons "&key" params) (list "&rest" "children"))
|
||||
(cons "&key" params))))
|
||||
(params-sx (str "(" (join " " param-strs) ")"))
|
||||
(form-name (if (= comp-type "island") "defisland" "defcomp"))
|
||||
(affinity-str (if (and (= comp-type "component")
|
||||
(not (nil? affinity))
|
||||
(not (= affinity "auto")))
|
||||
(str " :affinity " affinity)
|
||||
"")))
|
||||
(str "(" form-name " " name " " params-sx affinity-str "\n " body-sx ")"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; build-bundle-analysis
|
||||
;;
|
||||
;; Compute per-page bundle stats from pre-extracted component data.
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define build-bundle-analysis
|
||||
(fn ((pages-raw :as list) (components-raw :as dict) (total-components :as number) (total-macros :as number) (pure-count :as number) (io-count :as number))
|
||||
;; pages-raw: list of {:name :path :direct :needed-names}
|
||||
;; components-raw: dict of name → {:is-pure :affinity :render-target :io-refs :deps :source}
|
||||
(let ((pages-data (list)))
|
||||
(for-each
|
||||
(fn ((page :as dict))
|
||||
(let ((needed-names (get page "needed-names"))
|
||||
(n (len needed-names))
|
||||
(pct (if (> total-components 0)
|
||||
(round (* (/ n total-components) 100))
|
||||
0))
|
||||
(savings (- 100 pct))
|
||||
(pure-in-page 0)
|
||||
(io-in-page 0)
|
||||
(page-io-refs (list))
|
||||
(comp-details (list)))
|
||||
;; Walk needed components
|
||||
(for-each
|
||||
(fn ((comp-name :as string))
|
||||
(let ((info (get components-raw comp-name)))
|
||||
(when (not (nil? info))
|
||||
(if (get info "is-pure")
|
||||
(set! pure-in-page (+ pure-in-page 1))
|
||||
(do
|
||||
(set! io-in-page (+ io-in-page 1))
|
||||
(for-each
|
||||
(fn ((ref :as string)) (when (not (some (fn ((r :as string)) (= r ref)) page-io-refs))
|
||||
(append! page-io-refs ref)))
|
||||
(or (get info "io-refs") (list)))))
|
||||
(append! comp-details
|
||||
{"name" comp-name
|
||||
"is-pure" (get info "is-pure")
|
||||
"affinity" (get info "affinity")
|
||||
"render-target" (get info "render-target")
|
||||
"io-refs" (or (get info "io-refs") (list))
|
||||
"deps" (or (get info "deps") (list))
|
||||
"source" (get info "source")}))))
|
||||
needed-names)
|
||||
(append! pages-data
|
||||
{"name" (get page "name")
|
||||
"path" (get page "path")
|
||||
"direct" (get page "direct")
|
||||
"needed" n
|
||||
"pct" pct
|
||||
"savings" savings
|
||||
"io-refs" (len page-io-refs)
|
||||
"pure-in-page" pure-in-page
|
||||
"io-in-page" io-in-page
|
||||
"components" comp-details})))
|
||||
pages-raw)
|
||||
{"pages" pages-data
|
||||
"total-components" total-components
|
||||
"total-macros" total-macros
|
||||
"pure-count" pure-count
|
||||
"io-count" io-count})))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; build-routing-analysis
|
||||
;;
|
||||
;; Classify pages by routing mode (client vs server).
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define build-routing-analysis
|
||||
(fn ((pages-raw :as list))
|
||||
;; pages-raw: list of {:name :path :has-data :content-src}
|
||||
(let ((pages-data (list))
|
||||
(client-count 0)
|
||||
(server-count 0))
|
||||
(for-each
|
||||
(fn ((page :as dict))
|
||||
(let ((has-data (get page "has-data"))
|
||||
(content-src (or (get page "content-src") ""))
|
||||
(mode nil)
|
||||
(reason ""))
|
||||
(cond
|
||||
has-data
|
||||
(do (set! mode "server")
|
||||
(set! reason "Has :data expression — needs server IO")
|
||||
(set! server-count (+ server-count 1)))
|
||||
(empty? content-src)
|
||||
(do (set! mode "server")
|
||||
(set! reason "No content expression")
|
||||
(set! server-count (+ server-count 1)))
|
||||
:else
|
||||
(do (set! mode "client")
|
||||
(set! client-count (+ client-count 1))))
|
||||
(append! pages-data
|
||||
{"name" (get page "name")
|
||||
"path" (get page "path")
|
||||
"mode" mode
|
||||
"has-data" has-data
|
||||
"content-expr" (if (> (len content-src) 80)
|
||||
(str (slice content-src 0 80) "...")
|
||||
content-src)
|
||||
"reason" reason})))
|
||||
pages-raw)
|
||||
{"pages" pages-data
|
||||
"total-pages" (+ client-count server-count)
|
||||
"client-count" client-count
|
||||
"server-count" server-count})))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; build-affinity-analysis
|
||||
;;
|
||||
;; Package component affinity info + page render plans for display.
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define build-affinity-analysis
|
||||
(fn ((demo-components :as list) (page-plans :as list))
|
||||
{"components" demo-components
|
||||
"page-plans" page-plans}))
|
||||
@@ -1,418 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; parser.sx — Reference SX parser specification
|
||||
;;
|
||||
;; Defines how SX source text is tokenized and parsed into AST.
|
||||
;; The parser is intentionally simple — s-expressions need minimal parsing.
|
||||
;;
|
||||
;; Single-pass recursive descent: reads source text directly into AST,
|
||||
;; no separate tokenization phase. All mutable cursor state lives inside
|
||||
;; the parse closure.
|
||||
;;
|
||||
;; Grammar:
|
||||
;; program → expr*
|
||||
;; expr → atom | list | vector | map | quote-sugar
|
||||
;; list → '(' expr* ')'
|
||||
;; vector → '[' expr* ']' (sugar for list)
|
||||
;; map → '{' (key expr)* '}'
|
||||
;; atom → string | number | keyword | symbol | boolean | nil
|
||||
;; string → '"' (char | escape)* '"'
|
||||
;; number → '-'? digit+ ('.' digit+)? ([eE] [+-]? digit+)?
|
||||
;; keyword → ':' ident
|
||||
;; symbol → ident
|
||||
;; boolean → 'true' | 'false'
|
||||
;; nil → 'nil'
|
||||
;; ident → ident-start ident-char*
|
||||
;; comment → ';' to end of line (discarded)
|
||||
;;
|
||||
;; Quote sugar:
|
||||
;; 'expr → (quote expr)
|
||||
;; `expr → (quasiquote expr)
|
||||
;; ,expr → (unquote expr)
|
||||
;; ,@expr → (splice-unquote expr)
|
||||
;;
|
||||
;; Reader macros:
|
||||
;; #;expr → datum comment (read and discard expr)
|
||||
;; #|raw chars| → raw string literal (no escape processing)
|
||||
;; #'expr → (quote expr)
|
||||
;; #name expr → extensible dispatch (calls registered handler)
|
||||
;;
|
||||
;; Platform interface (each target implements natively):
|
||||
;; (ident-start? ch) → boolean
|
||||
;; (ident-char? ch) → boolean
|
||||
;; (make-symbol name) → Symbol value
|
||||
;; (make-keyword name) → Keyword value
|
||||
;; (escape-string s) → string with " and \ escaped for serialization
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Parser — single-pass recursive descent
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Returns a list of top-level AST expressions.
|
||||
|
||||
(define sx-parse :effects []
|
||||
(fn ((source :as string))
|
||||
(let ((pos 0)
|
||||
(len-src (len source)))
|
||||
|
||||
;; -- Cursor helpers (closure over pos, source, len-src) --
|
||||
|
||||
(define skip-comment :effects []
|
||||
(fn ()
|
||||
(when (and (< pos len-src) (not (= (nth source pos) "\n")))
|
||||
(set! pos (inc pos))
|
||||
(skip-comment))))
|
||||
|
||||
(define skip-ws :effects []
|
||||
(fn ()
|
||||
(when (< pos len-src)
|
||||
(let ((ch (nth source pos)))
|
||||
(cond
|
||||
;; Whitespace
|
||||
(or (= ch " ") (= ch "\t") (= ch "\n") (= ch "\r"))
|
||||
(do (set! pos (inc pos)) (skip-ws))
|
||||
;; Comment — skip to end of line
|
||||
(= ch ";")
|
||||
(do (set! pos (inc pos))
|
||||
(skip-comment)
|
||||
(skip-ws))
|
||||
;; Not whitespace or comment — stop
|
||||
:else nil)))))
|
||||
|
||||
;; -- Atom readers --
|
||||
|
||||
(define hex-digit-value :effects []
|
||||
(fn (ch) (index-of "0123456789abcdef" (lower ch))))
|
||||
|
||||
(define read-string :effects []
|
||||
(fn ()
|
||||
(set! pos (inc pos)) ;; skip opening "
|
||||
(let ((buf ""))
|
||||
(define read-str-loop :effects []
|
||||
(fn ()
|
||||
(if (>= pos len-src)
|
||||
(error "Unterminated string")
|
||||
(let ((ch (nth source pos)))
|
||||
(cond
|
||||
(= ch "\"")
|
||||
(do (set! pos (inc pos)) nil) ;; done
|
||||
(= ch "\\")
|
||||
(do (set! pos (inc pos))
|
||||
(let ((esc (nth source pos)))
|
||||
(if (= esc "u")
|
||||
;; Unicode escape: \uXXXX → char
|
||||
(do (set! pos (inc pos))
|
||||
(let ((d0 (hex-digit-value (nth source pos)))
|
||||
(_ (set! pos (inc pos)))
|
||||
(d1 (hex-digit-value (nth source pos)))
|
||||
(_ (set! pos (inc pos)))
|
||||
(d2 (hex-digit-value (nth source pos)))
|
||||
(_ (set! pos (inc pos)))
|
||||
(d3 (hex-digit-value (nth source pos)))
|
||||
(_ (set! pos (inc pos))))
|
||||
(set! buf (str buf (char-from-code
|
||||
(+ (* d0 4096) (* d1 256) (* d2 16) d3))))
|
||||
(read-str-loop)))
|
||||
;; Standard escapes: \n \t \r or literal
|
||||
(do (set! buf (str buf
|
||||
(cond
|
||||
(= esc "n") "\n"
|
||||
(= esc "t") "\t"
|
||||
(= esc "r") "\r"
|
||||
:else esc)))
|
||||
(set! pos (inc pos))
|
||||
(read-str-loop)))))
|
||||
:else
|
||||
(do (set! buf (str buf ch))
|
||||
(set! pos (inc pos))
|
||||
(read-str-loop)))))))
|
||||
(read-str-loop)
|
||||
buf)))
|
||||
|
||||
(define read-ident :effects []
|
||||
(fn ()
|
||||
(let ((start pos))
|
||||
(define read-ident-loop :effects []
|
||||
(fn ()
|
||||
(when (and (< pos len-src)
|
||||
(ident-char? (nth source pos)))
|
||||
(set! pos (inc pos))
|
||||
(read-ident-loop))))
|
||||
(read-ident-loop)
|
||||
(slice source start pos))))
|
||||
|
||||
(define read-keyword :effects []
|
||||
(fn ()
|
||||
(set! pos (inc pos)) ;; skip :
|
||||
(make-keyword (read-ident))))
|
||||
|
||||
(define read-number :effects []
|
||||
(fn ()
|
||||
(let ((start pos))
|
||||
;; Optional leading minus
|
||||
(when (and (< pos len-src) (= (nth source pos) "-"))
|
||||
(set! pos (inc pos)))
|
||||
;; Integer digits
|
||||
(define read-digits :effects []
|
||||
(fn ()
|
||||
(when (and (< pos len-src)
|
||||
(let ((c (nth source pos)))
|
||||
(and (>= c "0") (<= c "9"))))
|
||||
(set! pos (inc pos))
|
||||
(read-digits))))
|
||||
(read-digits)
|
||||
;; Decimal part
|
||||
(when (and (< pos len-src) (= (nth source pos) "."))
|
||||
(set! pos (inc pos))
|
||||
(read-digits))
|
||||
;; Exponent
|
||||
(when (and (< pos len-src)
|
||||
(or (= (nth source pos) "e")
|
||||
(= (nth source pos) "E")))
|
||||
(set! pos (inc pos))
|
||||
(when (and (< pos len-src)
|
||||
(or (= (nth source pos) "+")
|
||||
(= (nth source pos) "-")))
|
||||
(set! pos (inc pos)))
|
||||
(read-digits))
|
||||
(parse-number (slice source start pos)))))
|
||||
|
||||
(define read-symbol :effects []
|
||||
(fn ()
|
||||
(let ((name (read-ident)))
|
||||
(cond
|
||||
(= name "true") true
|
||||
(= name "false") false
|
||||
(= name "nil") nil
|
||||
:else (make-symbol name)))))
|
||||
|
||||
;; -- Composite readers --
|
||||
|
||||
(define read-list :effects []
|
||||
(fn ((close-ch :as string))
|
||||
(let ((items (list)))
|
||||
(define read-list-loop :effects []
|
||||
(fn ()
|
||||
(skip-ws)
|
||||
(if (>= pos len-src)
|
||||
(error "Unterminated list")
|
||||
(if (= (nth source pos) close-ch)
|
||||
(do (set! pos (inc pos)) nil) ;; done
|
||||
(do (append! items (read-expr))
|
||||
(read-list-loop))))))
|
||||
(read-list-loop)
|
||||
items)))
|
||||
|
||||
(define read-map :effects []
|
||||
(fn ()
|
||||
(let ((result (dict)))
|
||||
(define read-map-loop :effects []
|
||||
(fn ()
|
||||
(skip-ws)
|
||||
(if (>= pos len-src)
|
||||
(error "Unterminated map")
|
||||
(if (= (nth source pos) "}")
|
||||
(do (set! pos (inc pos)) nil) ;; done
|
||||
(let ((key-expr (read-expr))
|
||||
(key-str (if (= (type-of key-expr) "keyword")
|
||||
(keyword-name key-expr)
|
||||
(str key-expr)))
|
||||
(val-expr (read-expr)))
|
||||
(dict-set! result key-str val-expr)
|
||||
(read-map-loop))))))
|
||||
(read-map-loop)
|
||||
result)))
|
||||
|
||||
;; -- Raw string reader (for #|...|) --
|
||||
|
||||
(define read-raw-string :effects []
|
||||
(fn ()
|
||||
(let ((buf ""))
|
||||
(define raw-loop :effects []
|
||||
(fn ()
|
||||
(if (>= pos len-src)
|
||||
(error "Unterminated raw string")
|
||||
(let ((ch (nth source pos)))
|
||||
(if (= ch "|")
|
||||
(do (set! pos (inc pos)) nil) ;; done
|
||||
(do (set! buf (str buf ch))
|
||||
(set! pos (inc pos))
|
||||
(raw-loop)))))))
|
||||
(raw-loop)
|
||||
buf)))
|
||||
|
||||
;; -- Main expression reader --
|
||||
|
||||
(define read-expr :effects []
|
||||
(fn ()
|
||||
(skip-ws)
|
||||
(if (>= pos len-src)
|
||||
(error "Unexpected end of input")
|
||||
(let ((ch (nth source pos)))
|
||||
(cond
|
||||
;; Lists
|
||||
(= ch "(")
|
||||
(do (set! pos (inc pos)) (read-list ")"))
|
||||
(= ch "[")
|
||||
(do (set! pos (inc pos)) (read-list "]"))
|
||||
|
||||
;; Map
|
||||
(= ch "{")
|
||||
(do (set! pos (inc pos)) (read-map))
|
||||
|
||||
;; String
|
||||
(= ch "\"")
|
||||
(read-string)
|
||||
|
||||
;; Keyword
|
||||
(= ch ":")
|
||||
(read-keyword)
|
||||
|
||||
;; Quote sugar
|
||||
(= ch "'")
|
||||
(do (set! pos (inc pos))
|
||||
(list (make-symbol "quote") (read-expr)))
|
||||
|
||||
;; Quasiquote sugar
|
||||
(= ch "`")
|
||||
(do (set! pos (inc pos))
|
||||
(list (make-symbol "quasiquote") (read-expr)))
|
||||
|
||||
;; Unquote / splice-unquote
|
||||
(= ch ",")
|
||||
(do (set! pos (inc pos))
|
||||
(if (and (< pos len-src) (= (nth source pos) "@"))
|
||||
(do (set! pos (inc pos))
|
||||
(list (make-symbol "splice-unquote") (read-expr)))
|
||||
(list (make-symbol "unquote") (read-expr))))
|
||||
|
||||
;; Reader macros: #
|
||||
(= ch "#")
|
||||
(do (set! pos (inc pos))
|
||||
(if (>= pos len-src)
|
||||
(error "Unexpected end of input after #")
|
||||
(let ((dispatch-ch (nth source pos)))
|
||||
(cond
|
||||
;; #; — datum comment: read and discard next expr
|
||||
(= dispatch-ch ";")
|
||||
(do (set! pos (inc pos))
|
||||
(read-expr) ;; read and discard
|
||||
(read-expr)) ;; return the NEXT expr
|
||||
|
||||
;; #| — raw string
|
||||
(= dispatch-ch "|")
|
||||
(do (set! pos (inc pos))
|
||||
(read-raw-string))
|
||||
|
||||
;; #' — quote shorthand
|
||||
(= dispatch-ch "'")
|
||||
(do (set! pos (inc pos))
|
||||
(list (make-symbol "quote") (read-expr)))
|
||||
|
||||
;; #name — extensible dispatch
|
||||
(ident-start? dispatch-ch)
|
||||
(let ((macro-name (read-ident)))
|
||||
(let ((handler (reader-macro-get macro-name)))
|
||||
(if handler
|
||||
(handler (read-expr))
|
||||
(error (str "Unknown reader macro: #" macro-name)))))
|
||||
|
||||
:else
|
||||
(error (str "Unknown reader macro: #" dispatch-ch))))))
|
||||
|
||||
;; Number (or negative number)
|
||||
(or (and (>= ch "0") (<= ch "9"))
|
||||
(and (= ch "-")
|
||||
(< (inc pos) len-src)
|
||||
(let ((next-ch (nth source (inc pos))))
|
||||
(and (>= next-ch "0") (<= next-ch "9")))))
|
||||
(read-number)
|
||||
|
||||
;; Ellipsis (... as a symbol)
|
||||
(and (= ch ".")
|
||||
(< (+ pos 2) len-src)
|
||||
(= (nth source (+ pos 1)) ".")
|
||||
(= (nth source (+ pos 2)) "."))
|
||||
(do (set! pos (+ pos 3))
|
||||
(make-symbol "..."))
|
||||
|
||||
;; Symbol (must be ident-start char)
|
||||
(ident-start? ch)
|
||||
(read-symbol)
|
||||
|
||||
;; Unexpected
|
||||
:else
|
||||
(error (str "Unexpected character: " ch)))))))
|
||||
|
||||
;; -- Entry point: parse all top-level expressions --
|
||||
(let ((exprs (list)))
|
||||
(define parse-loop :effects []
|
||||
(fn ()
|
||||
(skip-ws)
|
||||
(when (< pos len-src)
|
||||
(append! exprs (read-expr))
|
||||
(parse-loop))))
|
||||
(parse-loop)
|
||||
exprs))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Serializer — AST → SX source text
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define sx-serialize :effects []
|
||||
(fn (val)
|
||||
(case (type-of val)
|
||||
"nil" "nil"
|
||||
"boolean" (if val "true" "false")
|
||||
"number" (str val)
|
||||
"string" (str "\"" (escape-string val) "\"")
|
||||
"symbol" (symbol-name val)
|
||||
"keyword" (str ":" (keyword-name val))
|
||||
"list" (str "(" (join " " (map sx-serialize val)) ")")
|
||||
"dict" (sx-serialize-dict val)
|
||||
"sx-expr" (sx-expr-source val)
|
||||
"spread" (str "(make-spread " (sx-serialize-dict (spread-attrs val)) ")")
|
||||
:else (str val))))
|
||||
|
||||
|
||||
(define sx-serialize-dict :effects []
|
||||
(fn ((d :as dict))
|
||||
(str "{"
|
||||
(join " "
|
||||
(reduce
|
||||
(fn ((acc :as list) (key :as string))
|
||||
(concat acc (list (str ":" key) (sx-serialize (dict-get d key)))))
|
||||
(list)
|
||||
(keys d)))
|
||||
"}")))
|
||||
|
||||
|
||||
;; Alias: adapters use (serialize val) — canonicalize to sx-serialize
|
||||
(define serialize sx-serialize)
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Platform parser interface
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Character classification (implemented natively per target):
|
||||
;; (ident-start? ch) → boolean
|
||||
;; True for: a-z A-Z _ ~ * + - > < = / ! ? &
|
||||
;;
|
||||
;; (ident-char? ch) → boolean
|
||||
;; True for: ident-start chars plus: 0-9 . : / # ,
|
||||
;;
|
||||
;; Constructors (provided by the SX runtime):
|
||||
;; (make-symbol name) → Symbol value
|
||||
;; (make-keyword name) → Keyword value
|
||||
;; (parse-number s) → number (int or float from string)
|
||||
;;
|
||||
;; String utilities:
|
||||
;; (escape-string s) → string with " and \ escaped
|
||||
;; (sx-expr-source e) → unwrap SxExpr to its source string
|
||||
;;
|
||||
;; Reader macro registry:
|
||||
;; (reader-macro-get name) → handler fn or nil
|
||||
;; (reader-macro-set! name handler) → register a reader macro
|
||||
;; --------------------------------------------------------------------------
|
||||
@@ -1,607 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; primitives.sx — Specification of all SX built-in pure functions
|
||||
;;
|
||||
;; Each entry declares: name, parameter signature, and semantics.
|
||||
;; Bootstrap compilers implement these natively per target.
|
||||
;;
|
||||
;; 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.
|
||||
;;
|
||||
;; Format:
|
||||
;; (define-primitive "name"
|
||||
;; :params (param1 param2 &rest rest)
|
||||
;; :returns "type"
|
||||
;; :doc "description"
|
||||
;; :body (reference-implementation ...))
|
||||
;;
|
||||
;; Typed params use (name :as type) syntax:
|
||||
;; (define-primitive "+"
|
||||
;; :params (&rest (args :as number))
|
||||
;; :returns "number"
|
||||
;; :doc "Sum all arguments.")
|
||||
;;
|
||||
;; 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.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Core — Arithmetic
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define-module :core.arithmetic)
|
||||
|
||||
(define-primitive "+"
|
||||
:params (&rest (args :as number))
|
||||
:returns "number"
|
||||
:doc "Sum all arguments."
|
||||
:body (reduce (fn (a b) (native-add a b)) 0 args))
|
||||
|
||||
(define-primitive "-"
|
||||
:params ((a :as number) &rest (b :as number))
|
||||
:returns "number"
|
||||
:doc "Subtract. Unary: negate. Binary: a - b."
|
||||
:body (if (empty? b) (native-neg a) (native-sub a (first b))))
|
||||
|
||||
(define-primitive "*"
|
||||
:params (&rest (args :as number))
|
||||
:returns "number"
|
||||
:doc "Multiply all arguments."
|
||||
:body (reduce (fn (a b) (native-mul a b)) 1 args))
|
||||
|
||||
(define-primitive "/"
|
||||
:params ((a :as number) (b :as number))
|
||||
:returns "number"
|
||||
:doc "Divide a by b."
|
||||
:body (native-div a b))
|
||||
|
||||
(define-primitive "mod"
|
||||
:params ((a :as number) (b :as number))
|
||||
:returns "number"
|
||||
:doc "Modulo a % b."
|
||||
:body (native-mod a b))
|
||||
|
||||
(define-primitive "random-int"
|
||||
:params ((low :as number) (high :as number))
|
||||
:returns "number"
|
||||
:doc "Random integer in [low, high] inclusive."
|
||||
:body (native-random-int low high))
|
||||
|
||||
(define-primitive "json-encode"
|
||||
:params (value)
|
||||
:returns "string"
|
||||
:doc "Encode value as JSON string with indentation.")
|
||||
|
||||
(define-primitive "sqrt"
|
||||
:params ((x :as number))
|
||||
:returns "number"
|
||||
:doc "Square root.")
|
||||
|
||||
(define-primitive "pow"
|
||||
:params ((x :as number) (n :as number))
|
||||
:returns "number"
|
||||
:doc "x raised to power n.")
|
||||
|
||||
(define-primitive "abs"
|
||||
:params ((x :as number))
|
||||
:returns "number"
|
||||
:doc "Absolute value.")
|
||||
|
||||
(define-primitive "floor"
|
||||
:params ((x :as number))
|
||||
:returns "number"
|
||||
:doc "Floor to integer.")
|
||||
|
||||
(define-primitive "ceil"
|
||||
:params ((x :as number))
|
||||
:returns "number"
|
||||
:doc "Ceiling to integer.")
|
||||
|
||||
(define-primitive "round"
|
||||
:params ((x :as number) &rest (ndigits :as number))
|
||||
:returns "number"
|
||||
:doc "Round to ndigits decimal places (default 0).")
|
||||
|
||||
(define-primitive "min"
|
||||
:params (&rest (args :as number))
|
||||
:returns "number"
|
||||
:doc "Minimum. Single list arg or variadic.")
|
||||
|
||||
(define-primitive "max"
|
||||
:params (&rest (args :as number))
|
||||
:returns "number"
|
||||
:doc "Maximum. Single list arg or variadic.")
|
||||
|
||||
(define-primitive "clamp"
|
||||
:params ((x :as number) (lo :as number) (hi :as number))
|
||||
:returns "number"
|
||||
:doc "Clamp x to range [lo, hi]."
|
||||
:body (max lo (min hi x)))
|
||||
|
||||
(define-primitive "inc"
|
||||
:params ((n :as number))
|
||||
:returns "number"
|
||||
:doc "Increment by 1."
|
||||
:body (+ n 1))
|
||||
|
||||
(define-primitive "dec"
|
||||
:params ((n :as number))
|
||||
:returns "number"
|
||||
:doc "Decrement by 1."
|
||||
:body (- n 1))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Core — Comparison
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define-module :core.comparison)
|
||||
|
||||
(define-primitive "="
|
||||
:params (a b)
|
||||
:returns "boolean"
|
||||
:doc "Deep structural equality. Alias for equal?.")
|
||||
|
||||
(define-primitive "!="
|
||||
:params (a b)
|
||||
:returns "boolean"
|
||||
:doc "Inequality."
|
||||
:body (not (= a b)))
|
||||
|
||||
(define-primitive "eq?"
|
||||
:params (a b)
|
||||
:returns "boolean"
|
||||
:doc "Identity equality. True only if a and b are the exact same object.
|
||||
For immutable atoms (numbers, strings, booleans, nil) this may or
|
||||
may not match — use eqv? for reliable atom comparison.")
|
||||
|
||||
(define-primitive "eqv?"
|
||||
:params (a b)
|
||||
:returns "boolean"
|
||||
:doc "Equivalent value for atoms, identity for compound objects.
|
||||
Returns true for identical objects (eq?), and also for numbers,
|
||||
strings, booleans, and nil with the same value. For lists, dicts,
|
||||
lambdas, and components, only true if same identity.")
|
||||
|
||||
(define-primitive "equal?"
|
||||
:params (a b)
|
||||
:returns "boolean"
|
||||
:doc "Deep structural equality. Recursively compares lists and dicts.
|
||||
Same semantics as = but explicit Scheme name.")
|
||||
|
||||
(define-primitive "<"
|
||||
:params ((a :as number) (b :as number))
|
||||
:returns "boolean"
|
||||
:doc "Less than.")
|
||||
|
||||
(define-primitive ">"
|
||||
:params ((a :as number) (b :as number))
|
||||
:returns "boolean"
|
||||
:doc "Greater than.")
|
||||
|
||||
(define-primitive "<="
|
||||
:params ((a :as number) (b :as number))
|
||||
:returns "boolean"
|
||||
:doc "Less than or equal.")
|
||||
|
||||
(define-primitive ">="
|
||||
:params ((a :as number) (b :as number))
|
||||
:returns "boolean"
|
||||
:doc "Greater than or equal.")
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Core — Predicates
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define-module :core.predicates)
|
||||
|
||||
(define-primitive "odd?"
|
||||
:params ((n :as number))
|
||||
:returns "boolean"
|
||||
:doc "True if n is odd."
|
||||
:body (= (mod n 2) 1))
|
||||
|
||||
(define-primitive "even?"
|
||||
:params ((n :as number))
|
||||
:returns "boolean"
|
||||
:doc "True if n is even."
|
||||
:body (= (mod n 2) 0))
|
||||
|
||||
(define-primitive "zero?"
|
||||
:params ((n :as number))
|
||||
:returns "boolean"
|
||||
:doc "True if n is zero."
|
||||
:body (= n 0))
|
||||
|
||||
(define-primitive "nil?"
|
||||
:params (x)
|
||||
:returns "boolean"
|
||||
:doc "True if x is nil/null/None.")
|
||||
|
||||
(define-primitive "boolean?"
|
||||
:params (x)
|
||||
:returns "boolean"
|
||||
:doc "True if x is a boolean (true or false). Must be checked before
|
||||
number? on platforms where booleans are numeric subtypes.")
|
||||
|
||||
(define-primitive "number?"
|
||||
:params (x)
|
||||
:returns "boolean"
|
||||
:doc "True if x is a number (int or float). Excludes booleans.")
|
||||
|
||||
(define-primitive "string?"
|
||||
:params (x)
|
||||
:returns "boolean"
|
||||
:doc "True if x is a string.")
|
||||
|
||||
(define-primitive "list?"
|
||||
:params (x)
|
||||
:returns "boolean"
|
||||
:doc "True if x is a list/array.")
|
||||
|
||||
(define-primitive "dict?"
|
||||
:params (x)
|
||||
:returns "boolean"
|
||||
:doc "True if x is a dict/map.")
|
||||
|
||||
(define-primitive "continuation?"
|
||||
:params (x)
|
||||
:returns "boolean"
|
||||
:doc "True if x is a captured continuation.")
|
||||
|
||||
(define-primitive "empty?"
|
||||
:params (coll)
|
||||
:returns "boolean"
|
||||
:doc "True if coll is nil or has length 0.")
|
||||
|
||||
(define-primitive "contains?"
|
||||
:params (coll key)
|
||||
:returns "boolean"
|
||||
:doc "True if coll contains key. Strings: substring check. Dicts: key check. Lists: membership.")
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Core — Logic
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define-module :core.logic)
|
||||
|
||||
(define-primitive "not"
|
||||
:params (x)
|
||||
:returns "boolean"
|
||||
:doc "Logical negation. Note: and/or are special forms (short-circuit).")
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Core — Strings
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define-module :core.strings)
|
||||
|
||||
(define-primitive "str"
|
||||
:params (&rest args)
|
||||
:returns "string"
|
||||
:doc "Concatenate all args as strings. nil → empty string, bool → true/false.")
|
||||
|
||||
(define-primitive "concat"
|
||||
:params (&rest (colls :as list))
|
||||
:returns "list"
|
||||
:doc "Concatenate multiple lists into one. Skips nil values.")
|
||||
|
||||
(define-primitive "upper"
|
||||
:params ((s :as string))
|
||||
:returns "string"
|
||||
:doc "Uppercase string.")
|
||||
|
||||
(define-primitive "upcase"
|
||||
:params ((s :as string))
|
||||
:returns "string"
|
||||
:doc "Alias for upper. Uppercase string.")
|
||||
|
||||
(define-primitive "lower"
|
||||
:params ((s :as string))
|
||||
:returns "string"
|
||||
:doc "Lowercase string.")
|
||||
|
||||
(define-primitive "downcase"
|
||||
:params ((s :as string))
|
||||
:returns "string"
|
||||
:doc "Alias for lower. Lowercase string.")
|
||||
|
||||
(define-primitive "string-length"
|
||||
:params ((s :as string))
|
||||
:returns "number"
|
||||
:doc "Length of string in characters.")
|
||||
|
||||
(define-primitive "char-from-code"
|
||||
:params ((n :as number))
|
||||
:returns "string"
|
||||
:doc "Convert Unicode code point to single-character string.")
|
||||
|
||||
(define-primitive "substring"
|
||||
:params ((s :as string) (start :as number) (end :as number))
|
||||
:returns "string"
|
||||
:doc "Extract substring from start (inclusive) to end (exclusive).")
|
||||
|
||||
(define-primitive "string-contains?"
|
||||
:params ((s :as string) (needle :as string))
|
||||
:returns "boolean"
|
||||
:doc "True if string s contains substring needle.")
|
||||
|
||||
(define-primitive "trim"
|
||||
:params ((s :as string))
|
||||
:returns "string"
|
||||
:doc "Strip leading/trailing whitespace.")
|
||||
|
||||
(define-primitive "split"
|
||||
:params ((s :as string) &rest (sep :as string))
|
||||
:returns "list"
|
||||
:doc "Split string by separator (default space).")
|
||||
|
||||
(define-primitive "join"
|
||||
:params ((sep :as string) (coll :as list))
|
||||
:returns "string"
|
||||
:doc "Join collection items with separator string.")
|
||||
|
||||
(define-primitive "replace"
|
||||
:params ((s :as string) (old :as string) (new :as string))
|
||||
:returns "string"
|
||||
:doc "Replace all occurrences of old with new in s.")
|
||||
|
||||
(define-primitive "slice"
|
||||
:params (coll (start :as number) &rest (end :as number))
|
||||
:returns "any"
|
||||
:doc "Slice a string or list from start to end (exclusive). End is optional.")
|
||||
|
||||
(define-primitive "index-of"
|
||||
:params ((s :as string) (needle :as string) &rest (from :as number))
|
||||
:returns "number"
|
||||
:doc "Index of first occurrence of needle in s, or -1 if not found. Optional start index.")
|
||||
|
||||
(define-primitive "starts-with?"
|
||||
:params ((s :as string) (prefix :as string))
|
||||
:returns "boolean"
|
||||
:doc "True if string s starts with prefix.")
|
||||
|
||||
(define-primitive "ends-with?"
|
||||
:params ((s :as string) (suffix :as string))
|
||||
:returns "boolean"
|
||||
:doc "True if string s ends with suffix.")
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Core — Collections
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define-module :core.collections)
|
||||
|
||||
(define-primitive "list"
|
||||
:params (&rest args)
|
||||
:returns "list"
|
||||
:doc "Create a list from arguments.")
|
||||
|
||||
(define-primitive "dict"
|
||||
:params (&rest pairs)
|
||||
:returns "dict"
|
||||
:doc "Create a dict from key/value pairs: (dict :a 1 :b 2).")
|
||||
|
||||
(define-primitive "range"
|
||||
:params ((start :as number) (end :as number) &rest (step :as number))
|
||||
:returns "list"
|
||||
:doc "Integer range [start, end) with optional step.")
|
||||
|
||||
(define-primitive "get"
|
||||
:params (coll key &rest default)
|
||||
:returns "any"
|
||||
:doc "Get value from dict by key, or list by index. Optional default.")
|
||||
|
||||
(define-primitive "len"
|
||||
:params (coll)
|
||||
:returns "number"
|
||||
:doc "Length of string, list, or dict.")
|
||||
|
||||
(define-primitive "first"
|
||||
:params ((coll :as list))
|
||||
:returns "any"
|
||||
:doc "First element, or nil if empty.")
|
||||
|
||||
(define-primitive "last"
|
||||
:params ((coll :as list))
|
||||
:returns "any"
|
||||
:doc "Last element, or nil if empty.")
|
||||
|
||||
(define-primitive "rest"
|
||||
:params ((coll :as list))
|
||||
:returns "list"
|
||||
:doc "All elements except the first.")
|
||||
|
||||
(define-primitive "nth"
|
||||
:params ((coll :as list) (n :as number))
|
||||
:returns "any"
|
||||
:doc "Element at index n, or nil if out of bounds.")
|
||||
|
||||
(define-primitive "cons"
|
||||
:params (x (coll :as list))
|
||||
:returns "list"
|
||||
:doc "Prepend x to coll.")
|
||||
|
||||
(define-primitive "append"
|
||||
:params ((coll :as list) x)
|
||||
:returns "list"
|
||||
:doc "If x is a list, concatenate. Otherwise append x as single element.")
|
||||
|
||||
(define-primitive "append!"
|
||||
:params ((coll :as list) x)
|
||||
:returns "list"
|
||||
:doc "Mutate coll by appending x in-place. Returns coll.")
|
||||
|
||||
(define-primitive "reverse"
|
||||
:params ((coll :as list))
|
||||
:returns "list"
|
||||
:doc "Return coll in reverse order.")
|
||||
|
||||
(define-primitive "flatten"
|
||||
:params ((coll :as list))
|
||||
:returns "list"
|
||||
:doc "Flatten one level of nesting. Nested lists become top-level elements.")
|
||||
|
||||
(define-primitive "chunk-every"
|
||||
:params ((coll :as list) (n :as number))
|
||||
:returns "list"
|
||||
:doc "Split coll into sub-lists of size n.")
|
||||
|
||||
(define-primitive "zip-pairs"
|
||||
:params ((coll :as list))
|
||||
:returns "list"
|
||||
:doc "Consecutive pairs: (1 2 3 4) → ((1 2) (2 3) (3 4)).")
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Core — Dict operations
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define-module :core.dict)
|
||||
|
||||
(define-primitive "keys"
|
||||
:params ((d :as dict))
|
||||
:returns "list"
|
||||
:doc "List of dict keys.")
|
||||
|
||||
(define-primitive "vals"
|
||||
:params ((d :as dict))
|
||||
:returns "list"
|
||||
:doc "List of dict values.")
|
||||
|
||||
(define-primitive "merge"
|
||||
:params (&rest (dicts :as dict))
|
||||
:returns "dict"
|
||||
:doc "Merge dicts left to right. Later keys win. Skips nil.")
|
||||
|
||||
(define-primitive "has-key?"
|
||||
:params ((d :as dict) key)
|
||||
:returns "boolean"
|
||||
:doc "True if dict d contains key.")
|
||||
|
||||
(define-primitive "assoc"
|
||||
:params ((d :as dict) &rest pairs)
|
||||
:returns "dict"
|
||||
:doc "Return new dict with key/value pairs added/overwritten.")
|
||||
|
||||
(define-primitive "dissoc"
|
||||
:params ((d :as dict) &rest keys)
|
||||
:returns "dict"
|
||||
:doc "Return new dict with keys removed.")
|
||||
|
||||
(define-primitive "dict-set!"
|
||||
:params ((d :as dict) key val)
|
||||
:returns "any"
|
||||
:doc "Mutate dict d by setting key to val in-place. Returns val.")
|
||||
|
||||
(define-primitive "into"
|
||||
:params (target coll)
|
||||
:returns "any"
|
||||
:doc "Pour coll into target. List target: convert to list. Dict target: convert pairs to dict.")
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Stdlib — Format
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define-module :stdlib.format)
|
||||
|
||||
(define-primitive "format-date"
|
||||
:params ((date-str :as string) (fmt :as string))
|
||||
:returns "string"
|
||||
:doc "Parse ISO date string and format with strftime-style format.")
|
||||
|
||||
(define-primitive "format-decimal"
|
||||
:params ((val :as number) &rest (places :as number))
|
||||
:returns "string"
|
||||
:doc "Format number with fixed decimal places (default 2).")
|
||||
|
||||
(define-primitive "parse-int"
|
||||
:params (val &rest default)
|
||||
:returns "number"
|
||||
:doc "Parse string to integer with optional default on failure.")
|
||||
|
||||
(define-primitive "parse-datetime"
|
||||
:params ((s :as string))
|
||||
:returns "string"
|
||||
:doc "Parse datetime string — identity passthrough (returns string or nil).")
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Stdlib — Text
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define-module :stdlib.text)
|
||||
|
||||
(define-primitive "pluralize"
|
||||
:params ((count :as number) &rest (forms :as string))
|
||||
:returns "string"
|
||||
:doc "Pluralize: (pluralize 1) → \"\", (pluralize 2) → \"s\". Or (pluralize n \"item\" \"items\").")
|
||||
|
||||
(define-primitive "escape"
|
||||
:params ((s :as string))
|
||||
:returns "string"
|
||||
:doc "HTML-escape a string (&, <, >, \", ').")
|
||||
|
||||
(define-primitive "strip-tags"
|
||||
:params ((s :as string))
|
||||
:returns "string"
|
||||
:doc "Remove HTML tags from string.")
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Stdlib — Style
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Stdlib — Debug
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define-module :stdlib.debug)
|
||||
|
||||
(define-primitive "assert"
|
||||
:params (condition &rest message)
|
||||
:returns "boolean"
|
||||
:doc "Assert condition is truthy; raise error with message if not.")
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Type introspection — platform primitives
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define-module :stdlib.types)
|
||||
|
||||
(define-primitive "type-of"
|
||||
:params (x)
|
||||
:returns "string"
|
||||
:doc "Return type name: number, string, boolean, nil, symbol, keyword, list, dict, lambda, component, island, macro.")
|
||||
|
||||
(define-primitive "symbol-name"
|
||||
:params ((sym :as symbol))
|
||||
:returns "string"
|
||||
:doc "Return the name string of a symbol.")
|
||||
|
||||
(define-primitive "keyword-name"
|
||||
:params ((kw :as keyword))
|
||||
:returns "string"
|
||||
:doc "Return the name string of a keyword.")
|
||||
|
||||
(define-primitive "sx-parse"
|
||||
:params ((source :as string))
|
||||
:returns "list"
|
||||
:doc "Parse SX source string into a list of AST expressions.")
|
||||
@@ -1,283 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; render.sx — Core rendering specification
|
||||
;;
|
||||
;; Shared registries and utilities used by all rendering adapters.
|
||||
;; This file defines WHAT is renderable (tag registries, attribute rules)
|
||||
;; and HOW arguments are parsed — but not the output format.
|
||||
;;
|
||||
;; Adapters:
|
||||
;; adapter-html.sx — HTML string output (server)
|
||||
;; adapter-sx.sx — SX wire format output (server → client)
|
||||
;; adapter-dom.sx — Live DOM node output (browser)
|
||||
;;
|
||||
;; Each adapter imports these shared definitions and provides its own
|
||||
;; render entry point (render-to-html, render-to-sx, render-to-dom).
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; HTML tag registry
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Tags known to the renderer. Unknown names are treated as function calls.
|
||||
;; Void elements self-close (no children). Boolean attrs emit name only.
|
||||
|
||||
(define HTML_TAGS
|
||||
(list
|
||||
;; Document
|
||||
"html" "head" "body" "title" "meta" "link" "script" "style" "noscript"
|
||||
;; Sections
|
||||
"header" "nav" "main" "section" "article" "aside" "footer"
|
||||
"h1" "h2" "h3" "h4" "h5" "h6" "hgroup"
|
||||
;; Block
|
||||
"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"
|
||||
;; Lists
|
||||
"ul" "ol" "li" "dl" "dt" "dd"
|
||||
;; Tables
|
||||
"table" "thead" "tbody" "tfoot" "tr" "th" "td" "caption" "colgroup" "col"
|
||||
;; Forms
|
||||
"form" "input" "textarea" "select" "option" "optgroup" "button" "label"
|
||||
"fieldset" "legend" "output" "datalist"
|
||||
;; Media
|
||||
"img" "video" "audio" "source" "picture" "canvas" "iframe"
|
||||
;; SVG
|
||||
"svg" "math" "path" "circle" "ellipse" "rect" "line" "polyline" "polygon"
|
||||
"text" "tspan" "g" "defs" "use" "clipPath" "mask" "pattern"
|
||||
"linearGradient" "radialGradient" "stop" "filter"
|
||||
"feGaussianBlur" "feOffset" "feBlend" "feColorMatrix" "feComposite"
|
||||
"feMerge" "feMergeNode" "feTurbulence"
|
||||
"feComponentTransfer" "feFuncR" "feFuncG" "feFuncB" "feFuncA"
|
||||
"feDisplacementMap" "feFlood" "feImage" "feMorphology"
|
||||
"feSpecularLighting" "feDiffuseLighting"
|
||||
"fePointLight" "feSpotLight" "feDistantLight"
|
||||
"animate" "animateTransform" "foreignObject"
|
||||
;; Other
|
||||
"template" "slot" "dialog" "menu"))
|
||||
|
||||
(define VOID_ELEMENTS
|
||||
(list "area" "base" "br" "col" "embed" "hr" "img" "input"
|
||||
"link" "meta" "param" "source" "track" "wbr"))
|
||||
|
||||
(define BOOLEAN_ATTRS
|
||||
(list "async" "autofocus" "autoplay" "checked" "controls" "default"
|
||||
"defer" "disabled" "formnovalidate" "hidden" "inert" "ismap"
|
||||
"loop" "multiple" "muted" "nomodule" "novalidate" "open"
|
||||
"playsinline" "readonly" "required" "reversed" "selected"))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Shared utilities
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(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"))))
|
||||
|
||||
|
||||
(define parse-element-args :effects [render]
|
||||
(fn ((args :as list) (env :as dict))
|
||||
;; Parse (:key val :key2 val2 child1 child2) into (attrs-dict children-list)
|
||||
(let ((attrs (dict))
|
||||
(children (list)))
|
||||
(reduce
|
||||
(fn ((state :as dict) arg)
|
||||
(let ((skip (get state "skip")))
|
||||
(if skip
|
||||
(assoc state "skip" false "i" (inc (get state "i")))
|
||||
(if (and (= (type-of arg) "keyword")
|
||||
(< (inc (get state "i")) (len args)))
|
||||
(let ((val (trampoline (eval-expr (nth args (inc (get state "i"))) env))))
|
||||
(dict-set! attrs (keyword-name arg) val)
|
||||
(assoc state "skip" true "i" (inc (get state "i"))))
|
||||
(do
|
||||
(append! children arg)
|
||||
(assoc state "i" (inc (get state "i"))))))))
|
||||
(dict "i" 0 "skip" false)
|
||||
args)
|
||||
(list attrs children))))
|
||||
|
||||
|
||||
(define render-attrs :effects []
|
||||
(fn ((attrs :as dict))
|
||||
;; Render an attrs dict to an HTML attribute string.
|
||||
;; Used by adapter-html.sx and adapter-sx.sx.
|
||||
(join ""
|
||||
(map
|
||||
(fn ((key :as string))
|
||||
(let ((val (dict-get attrs key)))
|
||||
(cond
|
||||
;; Boolean attrs
|
||||
(and (contains? BOOLEAN_ATTRS key) val)
|
||||
(str " " key)
|
||||
(and (contains? BOOLEAN_ATTRS key) (not val))
|
||||
""
|
||||
;; Nil values — skip
|
||||
(nil? val) ""
|
||||
;; Normal attr
|
||||
:else (str " " key "=\"" (escape-attr (str val)) "\""))))
|
||||
(keys attrs)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Render adapter helpers
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Shared by HTML and DOM adapters for evaluating control forms during
|
||||
;; rendering. Unlike sf-cond (eval.sx) which returns a thunk for TCO,
|
||||
;; eval-cond returns the unevaluated body expression so the adapter
|
||||
;; can render it in its own mode (HTML string vs DOM nodes).
|
||||
|
||||
;; eval-cond: find matching cond branch, return unevaluated body expr.
|
||||
;; Handles both scheme-style ((test body) ...) and clojure-style
|
||||
;; (test body test body ...).
|
||||
(define eval-cond :effects []
|
||||
(fn ((clauses :as list) (env :as dict))
|
||||
(if (cond-scheme? clauses)
|
||||
(eval-cond-scheme clauses env)
|
||||
(eval-cond-clojure clauses env))))
|
||||
|
||||
(define eval-cond-scheme :effects []
|
||||
(fn ((clauses :as list) (env :as dict))
|
||||
(if (empty? clauses)
|
||||
nil
|
||||
(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")))
|
||||
body
|
||||
(if (trampoline (eval-expr test env))
|
||||
body
|
||||
(eval-cond-scheme (rest clauses) env)))))))
|
||||
|
||||
(define eval-cond-clojure :effects []
|
||||
(fn ((clauses :as list) (env :as dict))
|
||||
(if (< (len clauses) 2)
|
||||
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"))))
|
||||
body
|
||||
(if (trampoline (eval-expr test env))
|
||||
body
|
||||
(eval-cond-clojure (slice clauses 2) env)))))))
|
||||
|
||||
;; process-bindings: evaluate let-binding pairs, return extended env.
|
||||
;; bindings = ((name1 expr1) (name2 expr2) ...)
|
||||
(define process-bindings :effects [mutation]
|
||||
(fn ((bindings :as list) (env :as dict))
|
||||
;; env-extend (not merge) — Env is not a dict subclass, so merge()
|
||||
;; returns an empty dict, losing all parent scope bindings.
|
||||
(let ((local (env-extend env)))
|
||||
(for-each
|
||||
(fn ((pair :as list))
|
||||
(when (and (= (type-of pair) "list") (>= (len pair) 2))
|
||||
(let ((name (if (= (type-of (first pair)) "symbol")
|
||||
(symbol-name (first pair))
|
||||
(str (first pair)))))
|
||||
(env-set! local name (trampoline (eval-expr (nth pair 1) local))))))
|
||||
bindings)
|
||||
local)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; is-render-expr? — check if expression is a rendering form
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Used by eval-list to dispatch rendering forms to the active adapter
|
||||
;; (HTML, SX wire, or DOM) rather than evaluating them as function calls.
|
||||
|
||||
(define is-render-expr? :effects []
|
||||
(fn (expr)
|
||||
(if (or (not (= (type-of expr) "list")) (empty? expr))
|
||||
false
|
||||
(let ((h (first expr)))
|
||||
(if (not (= (type-of h) "symbol"))
|
||||
false
|
||||
(let ((n (symbol-name h)))
|
||||
(or (= n "<>")
|
||||
(= n "raw!")
|
||||
(starts-with? n "~")
|
||||
(starts-with? n "html:")
|
||||
(contains? HTML_TAGS n)
|
||||
(and (> (index-of n "-") 0)
|
||||
(> (len expr) 1)
|
||||
(= (type-of (nth expr 1)) "keyword")))))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Spread — attribute injection from children into parent elements
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; A spread value is a dict of attributes that, when returned as a child
|
||||
;; of an HTML element, merges its attrs onto the parent element.
|
||||
;; This enables components to inject classes/styles/data-attrs onto their
|
||||
;; parent without the parent knowing about the specific attrs.
|
||||
;;
|
||||
;; merge-spread-attrs: merge a spread's attrs into an element's attrs dict.
|
||||
;; Class values are joined (space-separated); others overwrite.
|
||||
;; Mutates the target attrs dict in place.
|
||||
|
||||
(define merge-spread-attrs :effects [mutation]
|
||||
(fn ((target :as dict) (spread-dict :as dict))
|
||||
(for-each
|
||||
(fn ((key :as string))
|
||||
(let ((val (dict-get spread-dict key)))
|
||||
(if (= key "class")
|
||||
;; Class: join existing + new with space
|
||||
(let ((existing (dict-get target "class")))
|
||||
(dict-set! target "class"
|
||||
(if (and existing (not (= existing "")))
|
||||
(str existing " " val)
|
||||
val)))
|
||||
;; Style: join with semicolons
|
||||
(if (= key "style")
|
||||
(let ((existing (dict-get target "style")))
|
||||
(dict-set! target "style"
|
||||
(if (and existing (not (= existing "")))
|
||||
(str existing ";" val)
|
||||
val)))
|
||||
;; Everything else: overwrite
|
||||
(dict-set! target key val)))))
|
||||
(keys spread-dict))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 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-content r) → unwrap RawHTML marker to string
|
||||
;;
|
||||
;; Spread (render-time attribute injection):
|
||||
;; (make-spread attrs) → Spread value
|
||||
;; (spread? x) → boolean
|
||||
;; (spread-attrs s) → dict
|
||||
;;
|
||||
;; Render-time accumulators:
|
||||
;; (collect! bucket value) → void
|
||||
;; (collected bucket) → list
|
||||
;; (clear-collected! bucket) → void
|
||||
;;
|
||||
;; Scoped effects (scope/provide/context/emit!):
|
||||
;; (scope-push! name val) → void (general form)
|
||||
;; (scope-pop! name) → void (general form)
|
||||
;; (provide-push! name val) → alias for scope-push!
|
||||
;; (provide-pop! name) → alias for scope-pop!
|
||||
;; (context name &rest def) → value from nearest scope
|
||||
;; (emit! name value) → void (append to scope accumulator)
|
||||
;; (emitted name) → list of emitted values
|
||||
;;
|
||||
;; From parser.sx:
|
||||
;; (sx-serialize val) → SX source string (aliased as serialize above)
|
||||
;; --------------------------------------------------------------------------
|
||||
@@ -1,680 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; router.sx — Client-side route matching specification
|
||||
;;
|
||||
;; Pure functions for matching URL paths against Flask-style route patterns.
|
||||
;; Used by client-side routing to determine if a page can be rendered
|
||||
;; locally without a server roundtrip.
|
||||
;;
|
||||
;; All functions are pure — no IO, no platform-specific operations.
|
||||
;; Uses only primitives from primitives.sx (string ops, list ops).
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 1. Split path into segments
|
||||
;; --------------------------------------------------------------------------
|
||||
;; "/docs/hello" → ("docs" "hello")
|
||||
;; "/" → ()
|
||||
;; "/docs/" → ("docs")
|
||||
|
||||
(define split-path-segments :effects []
|
||||
(fn ((path :as string))
|
||||
(let ((trimmed (if (starts-with? path "/") (slice path 1) path)))
|
||||
(let ((trimmed2 (if (and (not (empty? trimmed))
|
||||
(ends-with? trimmed "/"))
|
||||
(slice trimmed 0 (- (len trimmed) 1))
|
||||
trimmed)))
|
||||
(if (empty? trimmed2)
|
||||
(list)
|
||||
(split trimmed2 "/"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 2. Parse Flask-style route pattern into segment descriptors
|
||||
;; --------------------------------------------------------------------------
|
||||
;; "/docs/<slug>" → ({"type" "literal" "value" "docs"}
|
||||
;; {"type" "param" "value" "slug"})
|
||||
|
||||
(define make-route-segment :effects []
|
||||
(fn ((seg :as string))
|
||||
(if (and (starts-with? seg "<") (ends-with? seg ">"))
|
||||
(let ((param-name (slice seg 1 (- (len seg) 1))))
|
||||
(let ((d {}))
|
||||
(dict-set! d "type" "param")
|
||||
(dict-set! d "value" param-name)
|
||||
d))
|
||||
(let ((d {}))
|
||||
(dict-set! d "type" "literal")
|
||||
(dict-set! d "value" seg)
|
||||
d))))
|
||||
|
||||
(define parse-route-pattern :effects []
|
||||
(fn ((pattern :as string))
|
||||
(let ((segments (split-path-segments pattern)))
|
||||
(map make-route-segment segments))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 3. Match path segments against parsed pattern
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Returns params dict if match, nil if no match.
|
||||
|
||||
(define match-route-segments :effects []
|
||||
(fn ((path-segs :as list) (parsed-segs :as list))
|
||||
(if (not (= (len path-segs) (len parsed-segs)))
|
||||
nil
|
||||
(let ((params {})
|
||||
(matched true))
|
||||
(for-each-indexed
|
||||
(fn ((i :as number) (parsed-seg :as dict))
|
||||
(when matched
|
||||
(let ((path-seg (nth path-segs i))
|
||||
(seg-type (get parsed-seg "type")))
|
||||
(cond
|
||||
(= seg-type "literal")
|
||||
(when (not (= path-seg (get parsed-seg "value")))
|
||||
(set! matched false))
|
||||
(= seg-type "param")
|
||||
(dict-set! params (get parsed-seg "value") path-seg)
|
||||
:else
|
||||
(set! matched false)))))
|
||||
parsed-segs)
|
||||
(if matched params nil)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 4. Public API: match a URL path against a pattern string
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Returns params dict (may be empty for exact matches) or nil.
|
||||
|
||||
(define match-route :effects []
|
||||
(fn ((path :as string) (pattern :as string))
|
||||
(let ((path-segs (split-path-segments path))
|
||||
(parsed-segs (parse-route-pattern pattern)))
|
||||
(match-route-segments path-segs parsed-segs))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 5. Search a list of route entries for first match
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Each entry: {"pattern" "/docs/<slug>" "parsed" [...] "name" "docs-page" ...}
|
||||
;; Returns matching entry with "params" added, or nil.
|
||||
|
||||
(define find-matching-route :effects []
|
||||
(fn ((path :as string) (routes :as list))
|
||||
;; If path is an SX expression URL, convert to old-style for matching.
|
||||
(let ((match-path (if (starts-with? path "/(")
|
||||
(or (sx-url-to-path path) path)
|
||||
path)))
|
||||
(let ((path-segs (split-path-segments match-path))
|
||||
(result nil))
|
||||
(for-each
|
||||
(fn ((route :as dict))
|
||||
(when (nil? result)
|
||||
(let ((params (match-route-segments path-segs (get route "parsed"))))
|
||||
(when (not (nil? params))
|
||||
(let ((matched (merge route {})))
|
||||
(dict-set! matched "params" params)
|
||||
(set! result matched))))))
|
||||
routes)
|
||||
result))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 6. SX expression URL → old-style path conversion
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Converts /(language.(doc.introduction)) → /language/docs/introduction
|
||||
;; so client-side routing can match SX URLs against Flask-style patterns.
|
||||
|
||||
(define _fn-to-segment :effects []
|
||||
(fn ((name :as string))
|
||||
(case name
|
||||
"doc" "docs"
|
||||
"spec" "specs"
|
||||
"bootstrapper" "bootstrappers"
|
||||
"test" "testing"
|
||||
"example" "examples"
|
||||
"protocol" "protocols"
|
||||
"essay" "essays"
|
||||
"plan" "plans"
|
||||
"reference-detail" "reference"
|
||||
:else name)))
|
||||
|
||||
(define sx-url-to-path :effects []
|
||||
(fn ((url :as string))
|
||||
;; Convert an SX expression URL to an old-style slash path.
|
||||
;; "/(language.(doc.introduction))" → "/language/docs/introduction"
|
||||
;; Returns nil for non-SX URLs (those not starting with "/(" ).
|
||||
(if (not (and (starts-with? url "/(") (ends-with? url ")")))
|
||||
nil
|
||||
(let ((inner (slice url 2 (- (len url) 1))))
|
||||
;; "language.(doc.introduction)" → dots to slashes, strip parens
|
||||
(let ((s (replace (replace (replace inner "." "/") "(" "") ")" "")))
|
||||
;; "language/doc/introduction" → split, map names, rejoin
|
||||
(let ((segs (filter (fn (s) (not (empty? s))) (split s "/"))))
|
||||
(str "/" (join "/" (map _fn-to-segment segs)))))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 7. Relative SX URL resolution
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Resolves relative SX URLs against the current absolute URL.
|
||||
;; This is a macro in the deepest sense: SX transforming SX into SX.
|
||||
;; The URL is code. Relative resolution is code transformation.
|
||||
;;
|
||||
;; Relative URLs start with ( or . :
|
||||
;; (.slug) → append slug as argument to innermost call
|
||||
;; (..section) → up 1: replace innermost with new nested call
|
||||
;; (...section) → up 2: replace 2 innermost levels
|
||||
;;
|
||||
;; Bare-dot shorthand (parens optional):
|
||||
;; .slug → same as (.slug)
|
||||
;; .. → same as (..) — go up one level
|
||||
;; ... → same as (...) — go up two levels
|
||||
;; .:page.4 → same as (.:page.4) — set keyword
|
||||
;;
|
||||
;; Dot count semantics (parallels filesystem . and ..):
|
||||
;; 1 dot = current level (append argument / modify keyword)
|
||||
;; 2 dots = up 1 level (sibling call)
|
||||
;; 3 dots = up 2 levels
|
||||
;; N dots = up N-1 levels
|
||||
;;
|
||||
;; Keyword operations (set, delta):
|
||||
;; (.:page.4) → set :page to 4 at current level
|
||||
;; (.:page.+1) → increment :page by 1 (delta)
|
||||
;; (.:page.-1) → decrement :page by 1 (delta)
|
||||
;; (.slug.:page.1) → append slug AND set :page=1
|
||||
;;
|
||||
;; Examples (current = "/(geography.(hypermedia.(example)))"):
|
||||
;; (.progress-bar) → /(geography.(hypermedia.(example.progress-bar)))
|
||||
;; (..reactive.demo) → /(geography.(hypermedia.(reactive.demo)))
|
||||
;; (...marshes) → /(geography.(marshes))
|
||||
;; (..) → /(geography.(hypermedia))
|
||||
;; (...) → /(geography)
|
||||
;;
|
||||
;; Keyword examples (current = "/(language.(spec.(explore.signals.:page.3)))"):
|
||||
;; (.:page.4) → /(language.(spec.(explore.signals.:page.4)))
|
||||
;; (.:page.+1) → /(language.(spec.(explore.signals.:page.4)))
|
||||
;; (.:page.-1) → /(language.(spec.(explore.signals.:page.2)))
|
||||
;; (..eval) → /(language.(spec.(eval)))
|
||||
;; (..eval.:page.1) → /(language.(spec.(eval.:page.1)))
|
||||
|
||||
(define _count-leading-dots :effects []
|
||||
(fn ((s :as string))
|
||||
(if (empty? s)
|
||||
0
|
||||
(if (starts-with? s ".")
|
||||
(+ 1 (_count-leading-dots (slice s 1)))
|
||||
0))))
|
||||
|
||||
(define _strip-trailing-close :effects []
|
||||
(fn ((s :as string))
|
||||
;; Strip trailing ) characters: "/(a.(b.(c" from "/(a.(b.(c)))"
|
||||
(if (ends-with? s ")")
|
||||
(_strip-trailing-close (slice s 0 (- (len s) 1)))
|
||||
s)))
|
||||
|
||||
(define _index-of-safe :effects []
|
||||
(fn ((s :as string) (needle :as string))
|
||||
;; Wrapper around index-of that normalizes -1 to nil.
|
||||
;; (index-of returns -1 on some platforms, nil on others.)
|
||||
(let ((idx (index-of s needle)))
|
||||
(if (or (nil? idx) (< idx 0)) nil idx))))
|
||||
|
||||
(define _last-index-of :effects []
|
||||
(fn ((s :as string) (needle :as string))
|
||||
;; Find the last occurrence of needle in s. Returns nil if not found.
|
||||
(let ((idx (_index-of-safe s needle)))
|
||||
(if (nil? idx)
|
||||
nil
|
||||
(let ((rest-idx (_last-index-of (slice s (+ idx 1)) needle)))
|
||||
(if (nil? rest-idx)
|
||||
idx
|
||||
(+ (+ idx 1) rest-idx)))))))
|
||||
|
||||
(define _pop-sx-url-level :effects []
|
||||
(fn ((url :as string))
|
||||
;; Remove the innermost nesting level from an absolute SX URL.
|
||||
;; "/(a.(b.(c)))" → "/(a.(b))"
|
||||
;; "/(a.(b))" → "/(a)"
|
||||
;; "/(a)" → "/"
|
||||
(let ((stripped (_strip-trailing-close url))
|
||||
(close-count (- (len url) (len (_strip-trailing-close url)))))
|
||||
(if (<= close-count 1)
|
||||
"/" ;; at root, popping goes to bare root
|
||||
(let ((last-dp (_last-index-of stripped ".(")))
|
||||
(if (nil? last-dp)
|
||||
"/" ;; single-level URL, pop to root
|
||||
;; Remove from .( to end of stripped, drop one closing paren
|
||||
(str (slice stripped 0 last-dp)
|
||||
(slice url (- (len url) (- close-count 1))))))))))
|
||||
|
||||
(define _pop-sx-url-levels :effects []
|
||||
(fn ((url :as string) (n :as number))
|
||||
(if (<= n 0)
|
||||
url
|
||||
(_pop-sx-url-levels (_pop-sx-url-level url) (- n 1)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 8. Relative URL body parsing — positional vs keyword tokens
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Body "slug.:page.4" → positional "slug", keywords ((:page 4))
|
||||
;; Body ":page.+1" → positional "", keywords ((:page +1))
|
||||
|
||||
(define _split-pos-kw :effects []
|
||||
(fn ((tokens :as list) (i :as number) (pos :as list) (kw :as list))
|
||||
;; Walk tokens: non-: tokens are positional, : tokens consume next as value
|
||||
(if (>= i (len tokens))
|
||||
{"positional" (join "." pos) "keywords" kw}
|
||||
(let ((tok (nth tokens i)))
|
||||
(if (starts-with? tok ":")
|
||||
;; Keyword: take this + next token as a pair
|
||||
(let ((val (if (< (+ i 1) (len tokens))
|
||||
(nth tokens (+ i 1))
|
||||
"")))
|
||||
(_split-pos-kw tokens (+ i 2) pos
|
||||
(append kw (list (list tok val)))))
|
||||
;; Positional token
|
||||
(_split-pos-kw tokens (+ i 1)
|
||||
(append pos (list tok))
|
||||
kw))))))
|
||||
|
||||
(define _parse-relative-body :effects []
|
||||
(fn ((body :as string))
|
||||
;; Returns {"positional" <string> "keywords" <list of (kw val) pairs>}
|
||||
(if (empty? body)
|
||||
{"positional" "" "keywords" (list)}
|
||||
(_split-pos-kw (split body ".") 0 (list) (list)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 9. Keyword operations on URL expressions
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Extract, find, and modify keyword arguments in the innermost expression.
|
||||
|
||||
(define _extract-innermost :effects []
|
||||
(fn ((url :as string))
|
||||
;; Returns {"before" ... "content" ... "suffix" ...}
|
||||
;; where before + content + suffix = url
|
||||
;; content = the innermost expression's dot-separated tokens
|
||||
(let ((stripped (_strip-trailing-close url))
|
||||
(suffix (slice url (len (_strip-trailing-close url)))))
|
||||
(let ((last-dp (_last-index-of stripped ".(")))
|
||||
(if (nil? last-dp)
|
||||
;; Single-level: /(content)
|
||||
{"before" "/("
|
||||
"content" (slice stripped 2)
|
||||
"suffix" suffix}
|
||||
;; Multi-level: .../.(content)...)
|
||||
{"before" (slice stripped 0 (+ last-dp 2))
|
||||
"content" (slice stripped (+ last-dp 2))
|
||||
"suffix" suffix})))))
|
||||
|
||||
(define _find-kw-in-tokens :effects []
|
||||
(fn ((tokens :as list) (i :as number) (kw :as string))
|
||||
;; Find value of keyword kw in token list. Returns nil if not found.
|
||||
(if (>= i (len tokens))
|
||||
nil
|
||||
(if (and (= (nth tokens i) kw)
|
||||
(< (+ i 1) (len tokens)))
|
||||
(nth tokens (+ i 1))
|
||||
(_find-kw-in-tokens tokens (+ i 1) kw)))))
|
||||
|
||||
(define _find-keyword-value :effects []
|
||||
(fn ((content :as string) (kw :as string))
|
||||
;; Find keyword's value in dot-separated content string.
|
||||
;; "explore.signals.:page.3" ":page" → "3"
|
||||
(_find-kw-in-tokens (split content ".") 0 kw)))
|
||||
|
||||
(define _replace-kw-in-tokens :effects []
|
||||
(fn ((tokens :as list) (i :as number) (kw :as string) (value :as string))
|
||||
;; Replace keyword's value in token list. Returns new token list.
|
||||
(if (>= i (len tokens))
|
||||
(list)
|
||||
(if (and (= (nth tokens i) kw)
|
||||
(< (+ i 1) (len tokens)))
|
||||
;; Found — keep keyword, replace value, concat rest
|
||||
(append (list kw value)
|
||||
(_replace-kw-in-tokens tokens (+ i 2) kw value))
|
||||
;; Not this keyword — keep token, continue
|
||||
(cons (nth tokens i)
|
||||
(_replace-kw-in-tokens tokens (+ i 1) kw value))))))
|
||||
|
||||
(define _set-keyword-in-content :effects []
|
||||
(fn ((content :as string) (kw :as string) (value :as string))
|
||||
;; Set or replace keyword value in dot-separated content.
|
||||
;; "a.b.:page.3" ":page" "4" → "a.b.:page.4"
|
||||
;; "a.b" ":page" "1" → "a.b.:page.1"
|
||||
(let ((current (_find-keyword-value content kw)))
|
||||
(if (nil? current)
|
||||
;; Not found — append
|
||||
(str content "." kw "." value)
|
||||
;; Found — replace
|
||||
(join "." (_replace-kw-in-tokens (split content ".") 0 kw value))))))
|
||||
|
||||
(define _is-delta-value? :effects []
|
||||
(fn ((s :as string))
|
||||
;; "+1", "-2", "+10" are deltas. "-" alone is not.
|
||||
(and (not (empty? s))
|
||||
(> (len s) 1)
|
||||
(or (starts-with? s "+") (starts-with? s "-")))))
|
||||
|
||||
(define _apply-delta :effects []
|
||||
(fn ((current-str :as string) (delta-str :as string))
|
||||
;; Apply numeric delta to current value string.
|
||||
;; "3" "+1" → "4", "3" "-1" → "2"
|
||||
(let ((cur (parse-int current-str nil))
|
||||
(delta (parse-int delta-str nil)))
|
||||
(if (or (nil? cur) (nil? delta))
|
||||
delta-str ;; fallback: use delta as literal value
|
||||
(str (+ cur delta))))))
|
||||
|
||||
(define _apply-kw-pairs :effects []
|
||||
(fn ((content :as string) (kw-pairs :as list))
|
||||
;; Apply keyword modifications to content, one at a time.
|
||||
(if (empty? kw-pairs)
|
||||
content
|
||||
(let ((pair (first kw-pairs))
|
||||
(kw (first pair))
|
||||
(raw-val (nth pair 1)))
|
||||
(let ((actual-val
|
||||
(if (_is-delta-value? raw-val)
|
||||
(let ((current (_find-keyword-value content kw)))
|
||||
(if (nil? current)
|
||||
raw-val ;; no current value, treat delta as literal
|
||||
(_apply-delta current raw-val)))
|
||||
raw-val)))
|
||||
(_apply-kw-pairs
|
||||
(_set-keyword-in-content content kw actual-val)
|
||||
(rest kw-pairs)))))))
|
||||
|
||||
(define _apply-keywords-to-url :effects []
|
||||
(fn ((url :as string) (kw-pairs :as list))
|
||||
;; Apply keyword modifications to the innermost expression of a URL.
|
||||
(if (empty? kw-pairs)
|
||||
url
|
||||
(let ((parts (_extract-innermost url)))
|
||||
(let ((new-content (_apply-kw-pairs (get parts "content") kw-pairs)))
|
||||
(str (get parts "before") new-content (get parts "suffix")))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 10. Public API: resolve-relative-url (structural + keywords)
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define _normalize-relative :effects []
|
||||
(fn ((url :as string))
|
||||
;; Normalize bare-dot shorthand to paren form.
|
||||
;; ".." → "(..)"
|
||||
;; ".slug" → "(.slug)"
|
||||
;; ".:page.4" → "(.:page.4)"
|
||||
;; "(.slug)" → "(.slug)" (already canonical)
|
||||
(if (starts-with? url "(")
|
||||
url
|
||||
(str "(" url ")"))))
|
||||
|
||||
(define resolve-relative-url :effects []
|
||||
(fn ((current :as string) (relative :as string))
|
||||
;; current: absolute SX URL "/(geography.(hypermedia.(example)))"
|
||||
;; relative: relative SX URL "(.progress-bar)" or ".." or ".:page.+1"
|
||||
;; Returns: absolute SX URL
|
||||
(let ((canonical (_normalize-relative relative)))
|
||||
(let ((rel-inner (slice canonical 1 (- (len canonical) 1))))
|
||||
(let ((dots (_count-leading-dots rel-inner))
|
||||
(body (slice rel-inner (_count-leading-dots rel-inner))))
|
||||
(if (= dots 0)
|
||||
current ;; no dots — not a relative URL
|
||||
;; Parse body into positional part + keyword pairs
|
||||
(let ((parsed (_parse-relative-body body))
|
||||
(pos-body (get parsed "positional"))
|
||||
(kw-pairs (get parsed "keywords")))
|
||||
;; Step 1: structural navigation
|
||||
(let ((after-nav
|
||||
(if (= dots 1)
|
||||
;; One dot = current level
|
||||
(if (empty? pos-body)
|
||||
current ;; no positional → stay here (keyword-only)
|
||||
;; Append positional part at current level
|
||||
(let ((stripped (_strip-trailing-close current))
|
||||
(suffix (slice current (len (_strip-trailing-close current)))))
|
||||
(str stripped "." pos-body suffix)))
|
||||
;; Two+ dots = pop (dots-1) levels
|
||||
(let ((base (_pop-sx-url-levels current (- dots 1))))
|
||||
(if (empty? pos-body)
|
||||
base ;; no positional → just pop (cd ..)
|
||||
(if (= base "/")
|
||||
(str "/(" pos-body ")")
|
||||
(let ((stripped (_strip-trailing-close base))
|
||||
(suffix (slice base (len (_strip-trailing-close base)))))
|
||||
(str stripped ".(" pos-body ")" suffix))))))))
|
||||
;; Step 2: apply keyword modifications
|
||||
(_apply-keywords-to-url after-nav kw-pairs)))))))))
|
||||
|
||||
;; Check if a URL is relative (starts with ( but not /( , or starts with .)
|
||||
(define relative-sx-url? :effects []
|
||||
(fn ((url :as string))
|
||||
(or (and (starts-with? url "(")
|
||||
(not (starts-with? url "/(")))
|
||||
(starts-with? url "."))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 11. URL special forms (! prefix)
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Special forms are meta-operations on URL expressions.
|
||||
;; Distinguished by `!` prefix to avoid name collisions with sections/pages.
|
||||
;;
|
||||
;; Known forms:
|
||||
;; !source — show defcomp source code
|
||||
;; !inspect — deps, CSS footprint, render plan, IO
|
||||
;; !diff — side-by-side comparison of two expressions
|
||||
;; !search — grep within a page/spec
|
||||
;; !raw — skip ~sx-doc wrapping, return raw content
|
||||
;; !json — return content as JSON data
|
||||
;;
|
||||
;; URL examples:
|
||||
;; /(!source.(~essay-sx-sucks))
|
||||
;; /(!inspect.(language.(doc.primitives)))
|
||||
;; /(!diff.(language.(spec.signals)).(language.(spec.eval)))
|
||||
;; /(!search."define".:in.(language.(spec.signals)))
|
||||
;; /(!raw.(~some-component))
|
||||
;; /(!json.(language.(doc.primitives)))
|
||||
|
||||
(define _url-special-forms :effects []
|
||||
(fn ()
|
||||
;; Returns the set of known URL special form names.
|
||||
(list "!source" "!inspect" "!diff" "!search" "!raw" "!json")))
|
||||
|
||||
(define url-special-form? :effects []
|
||||
(fn ((name :as string))
|
||||
;; Check if a name is a URL special form (starts with ! and is known).
|
||||
(and (starts-with? name "!")
|
||||
(contains? (_url-special-forms) name))))
|
||||
|
||||
(define parse-sx-url :effects []
|
||||
(fn ((url :as string))
|
||||
;; Parse an SX URL into a structured descriptor.
|
||||
;; Returns a dict with:
|
||||
;; "type" — "home" | "absolute" | "relative" | "special-form" | "direct-component"
|
||||
;; "form" — special form name (for special-form type), e.g. "!source"
|
||||
;; "inner" — inner URL expression string (without the special form wrapper)
|
||||
;; "raw" — original URL string
|
||||
;;
|
||||
;; Examples:
|
||||
;; "/" → {"type" "home" "raw" "/"}
|
||||
;; "/(language.(doc.intro))" → {"type" "absolute" "raw" ...}
|
||||
;; "(.slug)" → {"type" "relative" "raw" ...}
|
||||
;; "..slug" → {"type" "relative" "raw" ...}
|
||||
;; "/(!source.(~essay))" → {"type" "special-form" "form" "!source" "inner" "(~essay)" "raw" ...}
|
||||
;; "/(~essay-sx-sucks)" → {"type" "direct-component" "name" "~essay-sx-sucks" "raw" ...}
|
||||
(cond
|
||||
(= url "/")
|
||||
{"type" "home" "raw" url}
|
||||
(relative-sx-url? url)
|
||||
{"type" "relative" "raw" url}
|
||||
(and (starts-with? url "/(!")
|
||||
(ends-with? url ")"))
|
||||
;; Special form: /(!source.(~essay)) or /(!diff.a.b)
|
||||
;; Extract the form name (first dot-separated token after /()
|
||||
(let ((inner (slice url 2 (- (len url) 1))))
|
||||
;; inner = "!source.(~essay)" or "!diff.(a).(b)"
|
||||
(let ((dot-pos (_index-of-safe inner "."))
|
||||
(paren-pos (_index-of-safe inner "(")))
|
||||
;; Form name ends at first . or ( (whichever comes first)
|
||||
(let ((end-pos (cond
|
||||
(and (nil? dot-pos) (nil? paren-pos)) (len inner)
|
||||
(nil? dot-pos) paren-pos
|
||||
(nil? paren-pos) dot-pos
|
||||
:else (min dot-pos paren-pos))))
|
||||
(let ((form-name (slice inner 0 end-pos))
|
||||
(rest-part (slice inner end-pos)))
|
||||
;; rest-part starts with "." → strip leading dot
|
||||
(let ((inner-expr (if (starts-with? rest-part ".")
|
||||
(slice rest-part 1)
|
||||
rest-part)))
|
||||
{"type" "special-form"
|
||||
"form" form-name
|
||||
"inner" inner-expr
|
||||
"raw" url})))))
|
||||
(and (starts-with? url "/(~")
|
||||
(ends-with? url ")"))
|
||||
;; Direct component: /(~essay-sx-sucks)
|
||||
(let ((name (slice url 2 (- (len url) 1))))
|
||||
{"type" "direct-component" "name" name "raw" url})
|
||||
(and (starts-with? url "/(")
|
||||
(ends-with? url ")"))
|
||||
{"type" "absolute" "raw" url}
|
||||
:else
|
||||
{"type" "path" "raw" url})))
|
||||
|
||||
(define url-special-form-name :effects []
|
||||
(fn ((url :as string))
|
||||
;; Extract the special form name from a URL, or nil if not a special form.
|
||||
;; "/(!source.(~essay))" → "!source"
|
||||
;; "/(language.(doc))" → nil
|
||||
(let ((parsed (parse-sx-url url)))
|
||||
(if (= (get parsed "type") "special-form")
|
||||
(get parsed "form")
|
||||
nil))))
|
||||
|
||||
(define url-special-form-inner :effects []
|
||||
(fn ((url :as string))
|
||||
;; Extract the inner expression from a special form URL, or nil.
|
||||
;; "/(!source.(~essay))" → "(~essay)"
|
||||
;; "/(!diff.(a).(b))" → "(a).(b)"
|
||||
(let ((parsed (parse-sx-url url)))
|
||||
(if (= (get parsed "type") "special-form")
|
||||
(get parsed "inner")
|
||||
nil))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 12. URL expression evaluation
|
||||
;; --------------------------------------------------------------------------
|
||||
;; A URL is an expression. The system is the environment.
|
||||
;; eval(url, env) — that's it.
|
||||
;;
|
||||
;; The only URL-specific pre-processing:
|
||||
;; 1. Surface syntax → AST (dots to spaces, parse as SX)
|
||||
;; 2. Auto-quote unknowns (symbols not in env become strings)
|
||||
;;
|
||||
;; After that, it's standard eval. The host wires these into its route
|
||||
;; handlers (Python catch-all, JS client-side navigation). The same
|
||||
;; functions serve both.
|
||||
|
||||
(define url-to-expr :effects []
|
||||
(fn ((url-path :as string))
|
||||
;; Convert a URL path to an SX expression (AST).
|
||||
;;
|
||||
;; "/sx/(language.(doc.introduction))" → (language (doc introduction))
|
||||
;; "/(language.(doc.introduction))" → (language (doc introduction))
|
||||
;; "/" → (list) ; empty — home
|
||||
;;
|
||||
;; Steps:
|
||||
;; 1. Strip URL prefix ("/sx/" or "/") — host passes the path after prefix
|
||||
;; 2. Dots → spaces (URL-safe whitespace encoding)
|
||||
;; 3. Parse as SX expression
|
||||
;;
|
||||
;; The caller is responsible for stripping any app-level prefix.
|
||||
;; This function receives the raw expression portion: "(language.(doc.intro))"
|
||||
;; or "/" for home.
|
||||
(if (or (= url-path "/") (empty? url-path))
|
||||
(list)
|
||||
(let ((trimmed (if (starts-with? url-path "/")
|
||||
(slice url-path 1)
|
||||
url-path)))
|
||||
;; Dots → spaces
|
||||
(let ((sx-source (replace trimmed "." " ")))
|
||||
;; Parse — returns list of expressions, take the first
|
||||
(let ((exprs (sx-parse sx-source)))
|
||||
(if (empty? exprs)
|
||||
(list)
|
||||
(first exprs))))))))
|
||||
|
||||
|
||||
(define auto-quote-unknowns :effects []
|
||||
(fn ((expr :as list) (env :as dict))
|
||||
;; Walk an AST and replace symbols not in env with their name as a string.
|
||||
;; This makes URL slugs work without quoting:
|
||||
;; (language (doc introduction)) ; introduction is not a function
|
||||
;; → (language (doc "introduction"))
|
||||
;;
|
||||
;; Rules:
|
||||
;; - List head (call position) stays as-is — it's a function name
|
||||
;; - Tail symbols: if in env, keep as symbol; otherwise, string
|
||||
;; - Keywords, strings, numbers, nested lists: pass through
|
||||
;; - Non-list expressions: pass through unchanged
|
||||
(if (not (list? expr))
|
||||
expr
|
||||
(if (empty? expr)
|
||||
expr
|
||||
;; Head stays as symbol (function position), quote the rest
|
||||
(cons (first expr)
|
||||
(map (fn (child)
|
||||
(cond
|
||||
;; Nested list — recurse
|
||||
(list? child)
|
||||
(auto-quote-unknowns child env)
|
||||
;; Symbol — check env
|
||||
(= (type-of child) "symbol")
|
||||
(let ((name (symbol-name child)))
|
||||
(if (or (env-has? env name)
|
||||
;; Keep keywords, component refs, special forms
|
||||
(starts-with? name ":")
|
||||
(starts-with? name "~")
|
||||
(starts-with? name "!"))
|
||||
child
|
||||
name)) ;; unknown → string
|
||||
;; Everything else passes through
|
||||
:else child))
|
||||
(rest expr)))))))
|
||||
|
||||
|
||||
(define prepare-url-expr :effects []
|
||||
(fn ((url-path :as string) (env :as dict))
|
||||
;; Full pipeline: URL path → ready-to-eval AST.
|
||||
;;
|
||||
;; "(language.(doc.introduction))" + env
|
||||
;; → (language (doc "introduction"))
|
||||
;;
|
||||
;; The result can be fed directly to eval:
|
||||
;; (eval (prepare-url-expr path env) env)
|
||||
(let ((expr (url-to-expr url-path)))
|
||||
(if (empty? expr)
|
||||
expr
|
||||
(auto-quote-unknowns expr env)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Platform interface
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Pure primitives used:
|
||||
;; split, slice, starts-with?, ends-with?, len, empty?, replace,
|
||||
;; map, filter, for-each, for-each-indexed, nth, get, dict-set!, merge,
|
||||
;; list, nil?, not, =, case, join, str, index-of, and, or, cons,
|
||||
;; first, rest, append, parse-int, contains?, min, cond,
|
||||
;; symbol?, symbol-name, list?, env-has?, type-of
|
||||
;;
|
||||
;; From parser.sx: sx-parse, sx-serialize
|
||||
;; --------------------------------------------------------------------------
|
||||
@@ -1,479 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; signals.sx — Reactive signal runtime specification
|
||||
;;
|
||||
;; Defines the signal primitive: a container for a value that notifies
|
||||
;; subscribers when it changes. Signals are the reactive state primitive
|
||||
;; for SX islands.
|
||||
;;
|
||||
;; Signals are pure computation — no DOM, no IO. The reactive rendering
|
||||
;; layer (adapter-dom.sx) subscribes DOM nodes to signals. The server
|
||||
;; adapter (adapter-html.sx) reads signal values without subscribing.
|
||||
;;
|
||||
;; Signals are plain dicts with a "__signal" marker key. No platform
|
||||
;; primitives needed — all signal operations are pure SX.
|
||||
;;
|
||||
;; Reactive tracking and island lifecycle use the general scoped effects
|
||||
;; system (scope-push!/scope-pop!/context) instead of separate globals.
|
||||
;; Two scope names:
|
||||
;; "sx-reactive" — tracking context for computed/effect dep discovery
|
||||
;; "sx-island-scope" — island disposable collector
|
||||
;;
|
||||
;; Scope-based tracking:
|
||||
;; (scope-push! "sx-reactive" {:deps (list) :notify fn}) → void
|
||||
;; (scope-pop! "sx-reactive") → void
|
||||
;; (context "sx-reactive" nil) → dict or nil
|
||||
;;
|
||||
;; CEK callable dispatch:
|
||||
;; (cek-call f args) → any — call f with args list via CEK.
|
||||
;; Dispatches through cek-run for SX
|
||||
;; lambdas, apply for native callables.
|
||||
;; Defined in cek.sx.
|
||||
;;
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Signal container — plain dict with marker key
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; A signal is a dict: {"__signal" true, "value" v, "subscribers" [], "deps" []}
|
||||
;; type-of returns "dict". Use signal? to distinguish from regular dicts.
|
||||
|
||||
(define make-signal (fn (value)
|
||||
(dict "__signal" true "value" value "subscribers" (list) "deps" (list))))
|
||||
|
||||
(define signal? (fn (x)
|
||||
(and (dict? x) (has-key? x "__signal"))))
|
||||
|
||||
(define signal-value (fn (s) (get s "value")))
|
||||
(define signal-set-value! (fn (s v) (dict-set! s "value" v)))
|
||||
(define signal-subscribers (fn (s) (get s "subscribers")))
|
||||
|
||||
(define signal-add-sub! (fn (s f)
|
||||
(when (not (contains? (get s "subscribers") f))
|
||||
(append! (get s "subscribers") f))))
|
||||
|
||||
(define signal-remove-sub! (fn (s f)
|
||||
(dict-set! s "subscribers"
|
||||
(filter (fn (sub) (not (identical? sub f)))
|
||||
(get s "subscribers")))))
|
||||
|
||||
(define signal-deps (fn (s) (get s "deps")))
|
||||
(define signal-set-deps! (fn (s deps) (dict-set! s "deps" deps)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 1. signal — create a reactive container
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define signal :effects []
|
||||
(fn ((initial-value :as any))
|
||||
(make-signal initial-value)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 2. deref — read signal value, subscribe current reactive context
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; In a reactive context (inside effect or computed), deref registers the
|
||||
;; signal as a dependency. Outside reactive context, deref just returns
|
||||
;; the current value — no subscription, no overhead.
|
||||
|
||||
(define deref :effects []
|
||||
(fn ((s :as any))
|
||||
(if (not (signal? s))
|
||||
s ;; non-signal values pass through
|
||||
(let ((ctx (context "sx-reactive" nil)))
|
||||
(when ctx
|
||||
;; Register this signal as a dependency of the current context
|
||||
(let ((dep-list (get ctx "deps"))
|
||||
(notify-fn (get ctx "notify")))
|
||||
(when (not (contains? dep-list s))
|
||||
(append! dep-list s)
|
||||
(signal-add-sub! s notify-fn))))
|
||||
(signal-value s)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 3. reset! — write a new value, notify subscribers
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define reset! :effects [mutation]
|
||||
(fn ((s :as signal) value)
|
||||
(when (signal? s)
|
||||
(let ((old (signal-value s)))
|
||||
(when (not (identical? old value))
|
||||
(signal-set-value! s value)
|
||||
(notify-subscribers s))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 4. swap! — update signal via function
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define swap! :effects [mutation]
|
||||
(fn ((s :as signal) (f :as lambda) &rest args)
|
||||
(when (signal? s)
|
||||
(let ((old (signal-value s))
|
||||
(new-val (apply f (cons old args))))
|
||||
(when (not (identical? old new-val))
|
||||
(signal-set-value! s new-val)
|
||||
(notify-subscribers s))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 5. computed — derived signal with automatic dependency tracking
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; A computed signal wraps a zero-arg function. It re-evaluates when any
|
||||
;; of its dependencies change. The dependency set is discovered automatically
|
||||
;; by tracking deref calls during evaluation.
|
||||
|
||||
(define computed :effects [mutation]
|
||||
(fn ((compute-fn :as lambda))
|
||||
(let ((s (make-signal nil))
|
||||
(deps (list))
|
||||
(compute-ctx nil))
|
||||
|
||||
;; The notify function — called when a dependency changes
|
||||
(let ((recompute
|
||||
(fn ()
|
||||
;; Unsubscribe from old deps
|
||||
(for-each
|
||||
(fn ((dep :as signal)) (signal-remove-sub! dep recompute))
|
||||
(signal-deps s))
|
||||
(signal-set-deps! s (list))
|
||||
|
||||
;; Push scope-based tracking context for this computed
|
||||
(let ((ctx (dict "deps" (list) "notify" recompute)))
|
||||
(scope-push! "sx-reactive" ctx)
|
||||
(let ((new-val (cek-call compute-fn nil)))
|
||||
(scope-pop! "sx-reactive")
|
||||
;; Save discovered deps
|
||||
(signal-set-deps! s (get ctx "deps"))
|
||||
;; Update value + notify downstream
|
||||
(let ((old (signal-value s)))
|
||||
(signal-set-value! s new-val)
|
||||
(when (not (identical? old new-val))
|
||||
(notify-subscribers s))))))))
|
||||
|
||||
;; Initial computation
|
||||
(recompute)
|
||||
;; Auto-register disposal with island scope
|
||||
(register-in-scope (fn () (dispose-computed s)))
|
||||
s))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 6. effect — side effect that runs when dependencies change
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Like computed, but doesn't produce a signal value. Returns a dispose
|
||||
;; function that tears down the effect.
|
||||
|
||||
(define effect :effects [mutation]
|
||||
(fn ((effect-fn :as lambda))
|
||||
(let ((deps (list))
|
||||
(disposed false)
|
||||
(cleanup-fn nil))
|
||||
|
||||
(let ((run-effect
|
||||
(fn ()
|
||||
(when (not disposed)
|
||||
;; Run previous cleanup if any
|
||||
(when cleanup-fn (cek-call cleanup-fn nil))
|
||||
|
||||
;; Unsubscribe from old deps
|
||||
(for-each
|
||||
(fn ((dep :as signal)) (signal-remove-sub! dep run-effect))
|
||||
deps)
|
||||
(set! deps (list))
|
||||
|
||||
;; Push scope-based tracking context
|
||||
(let ((ctx (dict "deps" (list) "notify" run-effect)))
|
||||
(scope-push! "sx-reactive" ctx)
|
||||
(let ((result (cek-call effect-fn nil)))
|
||||
(scope-pop! "sx-reactive")
|
||||
(set! deps (get ctx "deps"))
|
||||
;; If effect returns a function, it's the cleanup
|
||||
(when (callable? result)
|
||||
(set! cleanup-fn result))))))))
|
||||
|
||||
;; Initial run
|
||||
(run-effect)
|
||||
|
||||
;; Return dispose function
|
||||
(let ((dispose-fn
|
||||
(fn ()
|
||||
(set! disposed true)
|
||||
(when cleanup-fn (cek-call cleanup-fn nil))
|
||||
(for-each
|
||||
(fn ((dep :as signal)) (signal-remove-sub! dep run-effect))
|
||||
deps)
|
||||
(set! deps (list)))))
|
||||
;; Auto-register with island scope so disposal happens on swap
|
||||
(register-in-scope dispose-fn)
|
||||
dispose-fn)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 7. batch — group multiple signal writes into one notification pass
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; During a batch, signal writes are deferred. Subscribers are notified
|
||||
;; once at the end, after all values have been updated.
|
||||
|
||||
(define *batch-depth* 0)
|
||||
(define *batch-queue* (list))
|
||||
|
||||
(define batch :effects [mutation]
|
||||
(fn ((thunk :as lambda))
|
||||
(set! *batch-depth* (+ *batch-depth* 1))
|
||||
(cek-call thunk nil)
|
||||
(set! *batch-depth* (- *batch-depth* 1))
|
||||
(when (= *batch-depth* 0)
|
||||
(let ((queue *batch-queue*))
|
||||
(set! *batch-queue* (list))
|
||||
;; Collect unique subscribers across all queued signals,
|
||||
;; then notify each exactly once.
|
||||
(let ((seen (list))
|
||||
(pending (list)))
|
||||
(for-each
|
||||
(fn ((s :as signal))
|
||||
(for-each
|
||||
(fn ((sub :as lambda))
|
||||
(when (not (contains? seen sub))
|
||||
(append! seen sub)
|
||||
(append! pending sub)))
|
||||
(signal-subscribers s)))
|
||||
queue)
|
||||
(for-each (fn ((sub :as lambda)) (sub)) pending))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 8. notify-subscribers — internal notification dispatch
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; If inside a batch, queues the signal. Otherwise, notifies immediately.
|
||||
|
||||
(define notify-subscribers :effects [mutation]
|
||||
(fn ((s :as signal))
|
||||
(if (> *batch-depth* 0)
|
||||
(when (not (contains? *batch-queue* s))
|
||||
(append! *batch-queue* s))
|
||||
(flush-subscribers s))))
|
||||
|
||||
(define flush-subscribers :effects [mutation]
|
||||
(fn ((s :as signal))
|
||||
(for-each
|
||||
(fn ((sub :as lambda)) (sub))
|
||||
(signal-subscribers s))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 9. Reactive tracking context
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Tracking is now scope-based. computed/effect push a dict
|
||||
;; {:deps (list) :notify fn} onto the "sx-reactive" scope stack via
|
||||
;; scope-push!/scope-pop!. deref reads it via (context "sx-reactive" nil).
|
||||
;; No platform primitives needed — uses the existing scope infrastructure.
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 10. dispose — tear down a computed signal
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; For computed signals, unsubscribe from all dependencies.
|
||||
;; For effects, the dispose function is returned by effect itself.
|
||||
|
||||
(define dispose-computed :effects [mutation]
|
||||
(fn ((s :as signal))
|
||||
(when (signal? s)
|
||||
(for-each
|
||||
(fn ((dep :as signal)) (signal-remove-sub! dep nil))
|
||||
(signal-deps s))
|
||||
(signal-set-deps! s (list)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 11. Island scope — automatic cleanup of signals within an island
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; When an island is created, all signals, effects, and computeds created
|
||||
;; within it are tracked. When the island is removed from the DOM, they
|
||||
;; are all disposed.
|
||||
;;
|
||||
;; Uses "sx-island-scope" scope name. The scope value is a collector
|
||||
;; function (fn (disposable) ...) that appends to the island's disposer list.
|
||||
|
||||
(define with-island-scope :effects [mutation]
|
||||
(fn ((scope-fn :as lambda) (body-fn :as lambda))
|
||||
(scope-push! "sx-island-scope" scope-fn)
|
||||
(let ((result (body-fn)))
|
||||
(scope-pop! "sx-island-scope")
|
||||
result)))
|
||||
|
||||
;; Hook into signal/effect/computed creation for scope tracking.
|
||||
|
||||
(define register-in-scope :effects [mutation]
|
||||
(fn ((disposable :as lambda))
|
||||
(let ((collector (context "sx-island-scope" nil)))
|
||||
(when collector
|
||||
(cek-call collector (list disposable))))))
|
||||
|
||||
|
||||
;; ==========================================================================
|
||||
;; 12. Marsh scopes — child scopes within islands
|
||||
;; ==========================================================================
|
||||
;;
|
||||
;; Marshes are zones inside islands where server content is re-evaluated
|
||||
;; in the island's reactive context. When a marsh is re-morphed with new
|
||||
;; content, its old effects and computeds must be disposed WITHOUT disturbing
|
||||
;; the island's own reactive graph.
|
||||
;;
|
||||
;; Scope hierarchy: island → marsh → effects/computeds
|
||||
;; Disposing a marsh disposes its subscope. Disposing an island disposes
|
||||
;; all its marshes. The signal graph is a tree, not a flat list.
|
||||
;;
|
||||
;; Platform interface required:
|
||||
;; (dom-set-data el key val) → void — store JS value on element
|
||||
;; (dom-get-data el key) → any — retrieve stored value
|
||||
|
||||
(define with-marsh-scope :effects [mutation io]
|
||||
(fn (marsh-el (body-fn :as lambda))
|
||||
;; Execute body-fn collecting all disposables into a marsh-local list.
|
||||
;; Nested under the current island scope — if the island is disposed,
|
||||
;; the marsh is disposed too (because island scope collected the marsh's
|
||||
;; own dispose function).
|
||||
(let ((disposers (list)))
|
||||
(with-island-scope
|
||||
(fn (d) (append! disposers d))
|
||||
body-fn)
|
||||
;; Store disposers on the marsh element for later cleanup
|
||||
(dom-set-data marsh-el "sx-marsh-disposers" disposers))))
|
||||
|
||||
(define dispose-marsh-scope :effects [mutation io]
|
||||
(fn (marsh-el)
|
||||
;; Dispose all effects/computeds registered in this marsh's scope.
|
||||
;; Parent island scope and sibling marshes are unaffected.
|
||||
(let ((disposers (dom-get-data marsh-el "sx-marsh-disposers")))
|
||||
(when disposers
|
||||
(for-each (fn ((d :as lambda)) (cek-call d nil)) disposers)
|
||||
(dom-set-data marsh-el "sx-marsh-disposers" nil)))))
|
||||
|
||||
|
||||
;; ==========================================================================
|
||||
;; 13. Named stores — page-level signal containers (L3)
|
||||
;; ==========================================================================
|
||||
;;
|
||||
;; Stores persist across island creation/destruction. They live at page
|
||||
;; scope, not island scope. When an island is swapped out and re-created,
|
||||
;; it reconnects to the same store instance.
|
||||
;;
|
||||
;; The store registry is global page-level state. It survives island
|
||||
;; disposal but is cleared on full page navigation.
|
||||
|
||||
(define *store-registry* (dict))
|
||||
|
||||
(define def-store :effects [mutation]
|
||||
(fn ((name :as string) (init-fn :as lambda))
|
||||
(let ((registry *store-registry*))
|
||||
;; Only create the store once — subsequent calls return existing
|
||||
(when (not (has-key? registry name))
|
||||
(set! *store-registry* (assoc registry name (cek-call init-fn nil))))
|
||||
(get *store-registry* name))))
|
||||
|
||||
(define use-store :effects []
|
||||
(fn ((name :as string))
|
||||
(if (has-key? *store-registry* name)
|
||||
(get *store-registry* name)
|
||||
(error (str "Store not found: " name
|
||||
". Call (def-store ...) before (use-store ...).")))))
|
||||
|
||||
(define clear-stores :effects [mutation]
|
||||
(fn ()
|
||||
(set! *store-registry* (dict))))
|
||||
|
||||
|
||||
;; ==========================================================================
|
||||
;; 13. Event bridge — DOM event communication for lake→island
|
||||
;; ==========================================================================
|
||||
;;
|
||||
;; Server-rendered content ("htmx lakes") inside reactive islands can
|
||||
;; communicate with island signals via DOM custom events. The bridge
|
||||
;; pattern:
|
||||
;;
|
||||
;; 1. Server renders a button/link with data-sx-emit="event-name"
|
||||
;; 2. When clicked, the client dispatches a CustomEvent on the element
|
||||
;; 3. The event bubbles up to the island container
|
||||
;; 4. An island effect listens for the event and updates signals
|
||||
;;
|
||||
;; This keeps server content pure HTML — no signal references needed.
|
||||
;; The island effect is the only reactive code.
|
||||
;;
|
||||
;; Platform interface required:
|
||||
;; (dom-listen el event-name handler) → remove-fn
|
||||
;; (dom-dispatch el event-name detail) → void
|
||||
;; (event-detail e) → any
|
||||
;;
|
||||
;; These are platform primitives because they require browser DOM APIs.
|
||||
|
||||
(define emit-event :effects [io]
|
||||
(fn (el (event-name :as string) detail)
|
||||
(dom-dispatch el event-name detail)))
|
||||
|
||||
(define on-event :effects [io]
|
||||
(fn (el (event-name :as string) (handler :as lambda))
|
||||
(dom-listen el event-name handler)))
|
||||
|
||||
;; Convenience: create an effect that listens for a DOM event on an
|
||||
;; element and writes the event detail (or a transformed value) into
|
||||
;; a target signal. Returns the effect's dispose function.
|
||||
;; When the effect is disposed (island teardown), the listener is
|
||||
;; removed automatically via the cleanup return.
|
||||
|
||||
(define bridge-event :effects [mutation io]
|
||||
(fn (el (event-name :as string) (target-signal :as signal) transform-fn)
|
||||
(effect (fn ()
|
||||
(let ((remove (dom-listen el event-name
|
||||
(fn (e)
|
||||
(let ((detail (event-detail e))
|
||||
(new-val (if transform-fn
|
||||
(cek-call transform-fn (list detail))
|
||||
detail)))
|
||||
(reset! target-signal new-val))))))
|
||||
;; Return cleanup — removes listener on dispose/re-run
|
||||
remove)))))
|
||||
|
||||
|
||||
;; ==========================================================================
|
||||
;; 14. Resource — async signal with loading/resolved/error states
|
||||
;; ==========================================================================
|
||||
;;
|
||||
;; A resource wraps an async operation (fetch, computation) and exposes
|
||||
;; its state as a signal. The signal transitions through:
|
||||
;; {:loading true :data nil :error nil} — initial/loading
|
||||
;; {:loading false :data result :error nil} — success
|
||||
;; {:loading false :data nil :error err} — failure
|
||||
;;
|
||||
;; Usage:
|
||||
;; (let ((user (resource (fn () (fetch-json "/api/user")))))
|
||||
;; (cond
|
||||
;; (get (deref user) "loading") (div "Loading...")
|
||||
;; (get (deref user) "error") (div "Error: " (get (deref user) "error"))
|
||||
;; :else (div (get (deref user) "data"))))
|
||||
;;
|
||||
;; Platform interface required:
|
||||
;; (promise-then promise on-resolve on-reject) → void
|
||||
|
||||
(define resource :effects [mutation io]
|
||||
(fn ((fetch-fn :as lambda))
|
||||
(let ((state (signal (dict "loading" true "data" nil "error" nil))))
|
||||
;; Kick off the async operation
|
||||
(promise-then (cek-call fetch-fn nil)
|
||||
(fn (data) (reset! state (dict "loading" false "data" data "error" nil)))
|
||||
(fn (err) (reset! state (dict "loading" false "data" nil "error" err))))
|
||||
state)))
|
||||
|
||||
|
||||
@@ -1,444 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; special-forms.sx — Specification of all SX special forms
|
||||
;;
|
||||
;; Special forms are syntactic constructs whose arguments are NOT evaluated
|
||||
;; before dispatch. Each form has its own evaluation rules — unlike primitives,
|
||||
;; which receive pre-evaluated values.
|
||||
;;
|
||||
;; This file is a SPECIFICATION, not executable code. Bootstrap compilers
|
||||
;; consume these declarations but implement special forms natively.
|
||||
;;
|
||||
;; Format:
|
||||
;; (define-special-form "name"
|
||||
;; :syntax (name arg1 arg2 ...)
|
||||
;; :doc "description"
|
||||
;; :tail-position "which subexpressions are in tail position"
|
||||
;; :example "(name ...)")
|
||||
;;
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Control flow
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define-special-form "if"
|
||||
:syntax (if condition then-expr else-expr)
|
||||
:doc "If condition is truthy, evaluate then-expr; otherwise evaluate else-expr.
|
||||
Both branches are in tail position. The else branch is optional and
|
||||
defaults to nil."
|
||||
:tail-position "then-expr, else-expr"
|
||||
:example "(if (> x 10) \"big\" \"small\")")
|
||||
|
||||
(define-special-form "when"
|
||||
:syntax (when condition body ...)
|
||||
:doc "If condition is truthy, evaluate all body expressions sequentially.
|
||||
Returns the value of the last body expression, or nil if condition
|
||||
is falsy. Only the last body expression is in tail position."
|
||||
:tail-position "last body expression"
|
||||
:example "(when (logged-in? user)
|
||||
(render-dashboard user))")
|
||||
|
||||
(define-special-form "cond"
|
||||
:syntax (cond test1 result1 test2 result2 ... :else default)
|
||||
:doc "Multi-way conditional. Tests are evaluated in order; the result
|
||||
paired with the first truthy test is returned. The :else keyword
|
||||
(or the symbol else) matches unconditionally. Supports both
|
||||
Clojure-style flat pairs and Scheme-style nested pairs:
|
||||
Clojure: (cond test1 result1 test2 result2 :else default)
|
||||
Scheme: (cond (test1 result1) (test2 result2) (else default))"
|
||||
:tail-position "all result expressions"
|
||||
:example "(cond
|
||||
(= status \"active\") (render-active item)
|
||||
(= status \"draft\") (render-draft item)
|
||||
:else (render-unknown item))")
|
||||
|
||||
(define-special-form "case"
|
||||
:syntax (case expr val1 result1 val2 result2 ... :else default)
|
||||
:doc "Match expr against values using equality. Like cond but tests
|
||||
a single expression against multiple values. The :else keyword
|
||||
matches if no values match."
|
||||
:tail-position "all result expressions"
|
||||
:example "(case (get request \"method\")
|
||||
\"GET\" (handle-get request)
|
||||
\"POST\" (handle-post request)
|
||||
:else (method-not-allowed))")
|
||||
|
||||
(define-special-form "and"
|
||||
:syntax (and expr ...)
|
||||
:doc "Short-circuit logical AND. Evaluates expressions left to right.
|
||||
Returns the first falsy value, or the last value if all are truthy.
|
||||
Returns true if given no arguments."
|
||||
:tail-position "last expression"
|
||||
:example "(and (valid? input) (authorized? user) (process input))")
|
||||
|
||||
(define-special-form "or"
|
||||
:syntax (or expr ...)
|
||||
:doc "Short-circuit logical OR. Evaluates expressions left to right.
|
||||
Returns the first truthy value, or the last value if all are falsy.
|
||||
Returns false if given no arguments."
|
||||
:tail-position "last expression"
|
||||
:example "(or (get cache key) (fetch-from-db key) \"default\")")
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Binding
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define-special-form "let"
|
||||
:syntax (let bindings body ...)
|
||||
:doc "Create local bindings and evaluate body in the extended environment.
|
||||
Bindings can be Scheme-style ((name val) ...) or Clojure-style
|
||||
(name val name val ...). Each binding can see previous bindings.
|
||||
Only the last body expression is in tail position.
|
||||
|
||||
Named let: (let name ((x init) ...) body) creates a loop. The name
|
||||
is bound to a function that takes the same params and recurses with
|
||||
tail-call optimization."
|
||||
:tail-position "last body expression; recursive call in named let"
|
||||
:example ";; Basic let
|
||||
(let ((x 10) (y 20))
|
||||
(+ x y))
|
||||
|
||||
;; Clojure-style
|
||||
(let (x 10 y 20)
|
||||
(+ x y))
|
||||
|
||||
;; Named let (loop)
|
||||
(let loop ((i 0) (acc 0))
|
||||
(if (= i 100)
|
||||
acc
|
||||
(loop (+ i 1) (+ acc i))))")
|
||||
|
||||
(define-special-form "let*"
|
||||
:syntax (let* bindings body ...)
|
||||
:doc "Alias for let. In SX, let is already sequential (each binding
|
||||
sees previous ones), so let* is identical to let."
|
||||
:tail-position "last body expression"
|
||||
:example "(let* ((x 10) (y (* x 2)))
|
||||
(+ x y)) ;; → 30")
|
||||
|
||||
(define-special-form "letrec"
|
||||
:syntax (letrec bindings body ...)
|
||||
:doc "Mutually recursive local bindings. All names are bound to nil first,
|
||||
then all values are evaluated (so they can reference each other),
|
||||
then lambda closures are patched to include the final bindings.
|
||||
Used for defining mutually recursive local functions."
|
||||
:tail-position "last body expression"
|
||||
:example "(letrec ((even? (fn (n) (if (= n 0) true (odd? (- n 1)))))
|
||||
(odd? (fn (n) (if (= n 0) false (even? (- n 1))))))
|
||||
(even? 10)) ;; → true")
|
||||
|
||||
(define-special-form "define"
|
||||
:syntax (define name value)
|
||||
:doc "Bind name to value in the current environment. If value is a lambda
|
||||
and has no name, the lambda's name is set to the symbol name.
|
||||
Returns the value."
|
||||
:tail-position "none (value is eagerly evaluated)"
|
||||
:example "(define greeting \"hello\")
|
||||
(define double (fn (x) (* x 2)))")
|
||||
|
||||
(define-special-form "set!"
|
||||
:syntax (set! name value)
|
||||
:doc "Mutate an existing binding. The name must already be bound in the
|
||||
current environment. Returns the new value."
|
||||
:tail-position "none (value is eagerly evaluated)"
|
||||
:example "(let (count 0)
|
||||
(set! count (+ count 1)))")
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Functions and components
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define-special-form "lambda"
|
||||
:syntax (lambda params body)
|
||||
:doc "Create a function. Params is a list of parameter names. Body is
|
||||
a single expression (the return value). The lambda captures the
|
||||
current environment as its closure."
|
||||
:tail-position "body"
|
||||
:example "(lambda (x y) (+ x y))")
|
||||
|
||||
(define-special-form "fn"
|
||||
:syntax (fn params body)
|
||||
:doc "Alias for lambda."
|
||||
:tail-position "body"
|
||||
:example "(fn (x) (* x x))")
|
||||
|
||||
(define-special-form "defcomp"
|
||||
:syntax (defcomp ~name (&key param1 param2 &rest children) body)
|
||||
:doc "Define a component. Components are called with keyword arguments
|
||||
and optional positional children. The &key marker introduces
|
||||
keyword parameters. The &rest (or &children) marker captures
|
||||
remaining positional arguments as a list.
|
||||
|
||||
Component names conventionally start with ~ to distinguish them
|
||||
from HTML elements. Components are evaluated with a merged
|
||||
environment: closure + caller-env + bound-params."
|
||||
:tail-position "body"
|
||||
:example "(defcomp ~card (&key title subtitle &rest children)
|
||||
(div :class \"card\"
|
||||
(h2 title)
|
||||
(when subtitle (p subtitle))
|
||||
children))")
|
||||
|
||||
(define-special-form "defisland"
|
||||
:syntax (defisland ~name (&key param1 param2 &rest children) body)
|
||||
:doc "Define a reactive island. Islands have the same calling convention
|
||||
as components (defcomp) but create a reactive boundary. Inside an
|
||||
island, signals are tracked — deref subscribes DOM nodes to signals,
|
||||
and signal changes update only the affected nodes.
|
||||
|
||||
On the server, islands render as static HTML wrapped in a
|
||||
data-sx-island container with serialized initial state. On the
|
||||
client, islands hydrate into reactive contexts."
|
||||
:tail-position "body"
|
||||
:example "(defisland ~counter (&key initial)
|
||||
(let ((count (signal (or initial 0))))
|
||||
(div :class \"counter\"
|
||||
(span (deref count))
|
||||
(button :on-click (fn (e) (swap! count inc)) \"+\"))))")
|
||||
|
||||
(define-special-form "defmacro"
|
||||
:syntax (defmacro name (params ...) body)
|
||||
:doc "Define a macro. Macros receive their arguments unevaluated (as raw
|
||||
AST) and return a new expression that is then evaluated. The
|
||||
returned expression replaces the macro call. Use quasiquote for
|
||||
template construction."
|
||||
:tail-position "none (expansion is evaluated separately)"
|
||||
:example "(defmacro unless (condition &rest body)
|
||||
`(when (not ~condition) ~@body))")
|
||||
|
||||
(define-special-form "deftype"
|
||||
:syntax (deftype name body)
|
||||
:doc "Define a named type. The name can be a simple symbol for type aliases
|
||||
and records, or a list (name param ...) for parameterized types.
|
||||
Body is a type expression: a symbol (alias), (union t1 t2 ...) for
|
||||
union types, or {:field1 type1 :field2 type2} for record types.
|
||||
Type definitions are metadata for the type checker with no runtime cost."
|
||||
:tail-position "none"
|
||||
:example "(deftype price number)
|
||||
(deftype card-props {:title string :price number})
|
||||
(deftype (maybe a) (union a nil))")
|
||||
|
||||
(define-special-form "defeffect"
|
||||
:syntax (defeffect name)
|
||||
:doc "Declare a named effect. Effects annotate functions and components
|
||||
to track side effects. A pure function (:effects [pure]) cannot
|
||||
call IO functions. Unannotated functions are assumed to have all
|
||||
effects. Effect checking is gradual — annotations opt in."
|
||||
:tail-position "none"
|
||||
:example "(defeffect io)
|
||||
(defeffect async)
|
||||
(define add :effects [pure] (fn (a b) (+ a b)))")
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Sequencing and threading
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define-special-form "begin"
|
||||
:syntax (begin expr ...)
|
||||
:doc "Evaluate expressions sequentially. Returns the value of the last
|
||||
expression. Used when multiple side-effecting expressions need
|
||||
to be grouped."
|
||||
:tail-position "last expression"
|
||||
:example "(begin
|
||||
(log \"starting\")
|
||||
(process data)
|
||||
(log \"done\"))")
|
||||
|
||||
(define-special-form "do"
|
||||
:syntax (do expr ...)
|
||||
:doc "Alias for begin."
|
||||
:tail-position "last expression"
|
||||
:example "(do (set! x 1) (set! y 2) (+ x y))")
|
||||
|
||||
(define-special-form "->"
|
||||
:syntax (-> value form1 form2 ...)
|
||||
:doc "Thread-first macro. Threads value through a series of function calls,
|
||||
inserting it as the first argument of each form. Nested lists are
|
||||
treated as function calls; bare symbols become unary calls."
|
||||
:tail-position "last form"
|
||||
:example "(-> user
|
||||
(get \"name\")
|
||||
upper
|
||||
(str \" says hello\"))
|
||||
;; Expands to: (str (upper (get user \"name\")) \" says hello\")")
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Quoting
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define-special-form "quote"
|
||||
:syntax (quote expr)
|
||||
:doc "Return expr as data, without evaluating it. Symbols remain symbols,
|
||||
lists remain lists. The reader shorthand is the ' prefix."
|
||||
:tail-position "none (not evaluated)"
|
||||
:example "'(+ 1 2) ;; → the list (+ 1 2), not the number 3")
|
||||
|
||||
(define-special-form "quasiquote"
|
||||
:syntax (quasiquote expr)
|
||||
:doc "Template construction. Like quote, but allows unquoting with ~ and
|
||||
splicing with ~@. The reader shorthand is the ` prefix.
|
||||
`(a ~b ~@c)
|
||||
Quotes everything except: ~expr evaluates expr and inserts the
|
||||
result; ~@expr evaluates to a list and splices its elements."
|
||||
:tail-position "none (template is constructed, not evaluated)"
|
||||
:example "`(div :class \"card\" ~title ~@children)")
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Continuations
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define-special-form "reset"
|
||||
:syntax (reset body)
|
||||
:doc "Establish a continuation delimiter. Evaluates body normally unless
|
||||
a shift is encountered, in which case the continuation (the rest
|
||||
of the computation up to this reset) is captured and passed to
|
||||
the shift's body. Without shift, reset is a no-op wrapper."
|
||||
:tail-position "body"
|
||||
:example "(reset (+ 1 (shift k (k 10)))) ;; → 11")
|
||||
|
||||
(define-special-form "shift"
|
||||
:syntax (shift k body)
|
||||
:doc "Capture the continuation to the nearest reset as k, then evaluate
|
||||
body with k bound. If k is never called, the value of body is
|
||||
returned from the reset (abort). If k is called with a value,
|
||||
the reset body is re-evaluated with shift returning that value.
|
||||
k can be called multiple times."
|
||||
:tail-position "body"
|
||||
:example ";; Abort: shift body becomes the reset result
|
||||
(reset (+ 1 (shift k 42))) ;; → 42
|
||||
|
||||
;; Resume: k re-enters the computation
|
||||
(reset (+ 1 (shift k (k 10)))) ;; → 11
|
||||
|
||||
;; Multiple invocations
|
||||
(reset (* 2 (shift k (+ (k 1) (k 10))))) ;; → 24")
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Guards
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define-special-form "dynamic-wind"
|
||||
:syntax (dynamic-wind before-thunk body-thunk after-thunk)
|
||||
:doc "Entry/exit guards. All three arguments are zero-argument functions
|
||||
(thunks). before-thunk is called on entry, body-thunk is called
|
||||
for the result, and after-thunk is always called on exit (even on
|
||||
error). The wind stack is maintained so that when continuations
|
||||
jump across dynamic-wind boundaries, the correct before/after
|
||||
thunks fire."
|
||||
:tail-position "none (all thunks are eagerly called)"
|
||||
:example "(dynamic-wind
|
||||
(fn () (log \"entering\"))
|
||||
(fn () (do-work))
|
||||
(fn () (log \"exiting\")))")
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Higher-order forms
|
||||
;;
|
||||
;; These are syntactic forms (not primitives) because the evaluator
|
||||
;; handles them directly for performance — avoiding the overhead of
|
||||
;; constructing argument lists and doing generic dispatch. They could
|
||||
;; be implemented as primitives but are special-cased in eval-list.
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define-special-form "map"
|
||||
:syntax (map fn coll)
|
||||
:doc "Apply fn to each element of coll, returning a list of results."
|
||||
:tail-position "none"
|
||||
:example "(map (fn (x) (* x x)) (list 1 2 3 4)) ;; → (1 4 9 16)")
|
||||
|
||||
(define-special-form "map-indexed"
|
||||
:syntax (map-indexed fn coll)
|
||||
:doc "Like map, but fn receives two arguments: (index element)."
|
||||
:tail-position "none"
|
||||
:example "(map-indexed (fn (i x) (str i \": \" x)) (list \"a\" \"b\" \"c\"))")
|
||||
|
||||
(define-special-form "filter"
|
||||
:syntax (filter fn coll)
|
||||
:doc "Return elements of coll for which fn returns truthy."
|
||||
:tail-position "none"
|
||||
:example "(filter (fn (x) (> x 3)) (list 1 5 2 8 3)) ;; → (5 8)")
|
||||
|
||||
(define-special-form "reduce"
|
||||
:syntax (reduce fn init coll)
|
||||
:doc "Reduce coll to a single value. fn receives (accumulator element)
|
||||
and returns the new accumulator. init is the initial value."
|
||||
:tail-position "none"
|
||||
:example "(reduce (fn (acc x) (+ acc x)) 0 (list 1 2 3 4)) ;; → 10")
|
||||
|
||||
(define-special-form "some"
|
||||
:syntax (some fn coll)
|
||||
:doc "Return the first truthy result of applying fn to elements of coll,
|
||||
or nil if none match. Short-circuits on first truthy result."
|
||||
:tail-position "none"
|
||||
:example "(some (fn (x) (> x 3)) (list 1 2 5 3)) ;; → true")
|
||||
|
||||
(define-special-form "every?"
|
||||
:syntax (every? fn coll)
|
||||
:doc "Return true if fn returns truthy for every element of coll.
|
||||
Short-circuits on first falsy result."
|
||||
:tail-position "none"
|
||||
:example "(every? (fn (x) (> x 0)) (list 1 2 3)) ;; → true")
|
||||
|
||||
(define-special-form "for-each"
|
||||
:syntax (for-each fn coll)
|
||||
:doc "Apply fn to each element of coll for side effects. Returns nil."
|
||||
:tail-position "none"
|
||||
:example "(for-each (fn (x) (log x)) (list 1 2 3))")
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Definition forms (domain-specific)
|
||||
;;
|
||||
;; These define named entities in the environment. They are special forms
|
||||
;; because their arguments have domain-specific structure that the
|
||||
;; evaluator parses directly.
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define-special-form "defstyle"
|
||||
:syntax (defstyle name expr)
|
||||
:doc "Define a named style value. Evaluates expr and binds the result
|
||||
to name in the environment. The value is typically a class string
|
||||
or a function that returns class strings."
|
||||
:tail-position "none"
|
||||
:example "(defstyle card-style \"rounded-lg shadow-md p-4 bg-white\")")
|
||||
|
||||
(define-special-form "defhandler"
|
||||
:syntax (defhandler name (&key params ...) body)
|
||||
:doc "Define an event handler function. Used by the SxEngine for
|
||||
client-side event handling."
|
||||
:tail-position "body"
|
||||
:example "(defhandler toggle-menu (&key target)
|
||||
(toggle-class target \"hidden\"))")
|
||||
|
||||
(define-special-form "defpage"
|
||||
:syntax (defpage name &key route method content ...)
|
||||
:doc "Define a page route. Declares the URL pattern, HTTP method, and
|
||||
content component for server-side page routing."
|
||||
:tail-position "none"
|
||||
:example "(defpage dashboard-page
|
||||
:route \"/dashboard\"
|
||||
:content (~dashboard-content))")
|
||||
|
||||
(define-special-form "defquery"
|
||||
:syntax (defquery name (&key params ...) body)
|
||||
:doc "Define a named query for data fetching. Used by the resolver
|
||||
system to declare data dependencies."
|
||||
:tail-position "body"
|
||||
:example "(defquery user-profile (&key user-id)
|
||||
(fetch-user user-id))")
|
||||
|
||||
(define-special-form "defaction"
|
||||
:syntax (defaction name (&key params ...) body)
|
||||
:doc "Define a named action for mutations. Like defquery but for
|
||||
write operations."
|
||||
:tail-position "body"
|
||||
:example "(defaction update-profile (&key user-id name email)
|
||||
(save-user user-id name email))")
|
||||
@@ -1,346 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; test-aser.sx — Tests for the SX wire format (aser) adapter
|
||||
;;
|
||||
;; Requires: test-framework.sx loaded first.
|
||||
;; Modules tested: adapter-sx.sx (aser, aser-call, aser-fragment, aser-special)
|
||||
;;
|
||||
;; Platform functions required (beyond test framework):
|
||||
;; render-sx (sx-source) -> SX wire format string
|
||||
;; Parses the sx-source string, evaluates via aser in a
|
||||
;; fresh env, and returns the resulting SX wire format string.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Basic serialization
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "aser-basics"
|
||||
(deftest "number literal passes through"
|
||||
(assert-equal "42"
|
||||
(render-sx "42")))
|
||||
|
||||
(deftest "string literal passes through"
|
||||
;; aser returns the raw string value; render-sx concatenates it directly
|
||||
(assert-equal "hello"
|
||||
(render-sx "\"hello\"")))
|
||||
|
||||
(deftest "boolean true passes through"
|
||||
(assert-equal "true"
|
||||
(render-sx "true")))
|
||||
|
||||
(deftest "boolean false passes through"
|
||||
(assert-equal "false"
|
||||
(render-sx "false")))
|
||||
|
||||
(deftest "nil produces empty"
|
||||
(assert-equal ""
|
||||
(render-sx "nil"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; HTML tag serialization
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "aser-tags"
|
||||
(deftest "simple div"
|
||||
(assert-equal "(div \"hello\")"
|
||||
(render-sx "(div \"hello\")")))
|
||||
|
||||
(deftest "nested tags"
|
||||
(assert-equal "(div (span \"hi\"))"
|
||||
(render-sx "(div (span \"hi\"))")))
|
||||
|
||||
(deftest "multiple children"
|
||||
(assert-equal "(div (p \"a\") (p \"b\"))"
|
||||
(render-sx "(div (p \"a\") (p \"b\"))")))
|
||||
|
||||
(deftest "attributes serialize"
|
||||
(assert-equal "(div :class \"foo\" \"bar\")"
|
||||
(render-sx "(div :class \"foo\" \"bar\")")))
|
||||
|
||||
(deftest "multiple attributes"
|
||||
(assert-equal "(a :href \"/home\" :class \"link\" \"Home\")"
|
||||
(render-sx "(a :href \"/home\" :class \"link\" \"Home\")")))
|
||||
|
||||
(deftest "void elements"
|
||||
(assert-equal "(br)"
|
||||
(render-sx "(br)")))
|
||||
|
||||
(deftest "void element with attrs"
|
||||
(assert-equal "(img :src \"pic.jpg\")"
|
||||
(render-sx "(img :src \"pic.jpg\")"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Fragment serialization
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "aser-fragments"
|
||||
(deftest "simple fragment"
|
||||
(assert-equal "(<> (p \"a\") (p \"b\"))"
|
||||
(render-sx "(<> (p \"a\") (p \"b\"))")))
|
||||
|
||||
(deftest "empty fragment"
|
||||
(assert-equal ""
|
||||
(render-sx "(<>)")))
|
||||
|
||||
(deftest "single-child fragment"
|
||||
(assert-equal "(<> (div \"x\"))"
|
||||
(render-sx "(<> (div \"x\"))"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Control flow in aser mode
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "aser-control-flow"
|
||||
(deftest "if true branch"
|
||||
(assert-equal "(p \"yes\")"
|
||||
(render-sx "(if true (p \"yes\") (p \"no\"))")))
|
||||
|
||||
(deftest "if false branch"
|
||||
(assert-equal "(p \"no\")"
|
||||
(render-sx "(if false (p \"yes\") (p \"no\"))")))
|
||||
|
||||
(deftest "when true"
|
||||
(assert-equal "(p \"ok\")"
|
||||
(render-sx "(when true (p \"ok\"))")))
|
||||
|
||||
(deftest "when false"
|
||||
(assert-equal ""
|
||||
(render-sx "(when false (p \"ok\"))")))
|
||||
|
||||
(deftest "cond serializes matching branch"
|
||||
(assert-equal "(p \"two\")"
|
||||
(render-sx "(cond false (p \"one\") true (p \"two\") :else (p \"three\"))")))
|
||||
|
||||
(deftest "cond with 2-element predicate test"
|
||||
;; Regression: cond misclassifies (nil? x) as scheme-style clause.
|
||||
(assert-equal "(p \"yes\")"
|
||||
(render-sx "(cond (nil? nil) (p \"yes\") :else (p \"no\"))"))
|
||||
(assert-equal "(p \"no\")"
|
||||
(render-sx "(cond (nil? \"x\") (p \"yes\") :else (p \"no\"))")))
|
||||
|
||||
(deftest "let binds then serializes"
|
||||
(assert-equal "(p \"hello\")"
|
||||
(render-sx "(let ((x \"hello\")) (p x))")))
|
||||
|
||||
(deftest "let preserves outer scope bindings"
|
||||
;; Regression: process-bindings must preserve parent env scope chain.
|
||||
;; Using merge() instead of env-extend loses parent scope items.
|
||||
(assert-equal "(p \"outer\")"
|
||||
(render-sx "(do (define theme \"outer\") (let ((x 1)) (p theme)))")))
|
||||
|
||||
(deftest "nested let preserves outer scope"
|
||||
(assert-equal "(div (span \"hello\") (span \"world\"))"
|
||||
(render-sx "(do (define a \"hello\")
|
||||
(define b \"world\")
|
||||
(div (let ((x 1)) (span a))
|
||||
(let ((y 2)) (span b))))")))
|
||||
|
||||
(deftest "begin serializes last"
|
||||
(assert-equal "(p \"last\")"
|
||||
(render-sx "(begin (p \"first\") (p \"last\"))"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; THE BUG — map/filter list flattening in children (critical regression)
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "aser-list-flattening"
|
||||
(deftest "map inside tag flattens children"
|
||||
(assert-equal "(div (span \"a\") (span \"b\") (span \"c\"))"
|
||||
(render-sx "(do (define items (list \"a\" \"b\" \"c\"))
|
||||
(div (map (fn (x) (span x)) items)))")))
|
||||
|
||||
(deftest "map inside tag with other children"
|
||||
(assert-equal "(ul (li \"first\") (li \"a\") (li \"b\"))"
|
||||
(render-sx "(do (define items (list \"a\" \"b\"))
|
||||
(ul (li \"first\") (map (fn (x) (li x)) items)))")))
|
||||
|
||||
(deftest "filter result via let binding as children"
|
||||
;; Note: (filter ...) is treated as an SVG tag in aser dispatch (SVG has <filter>),
|
||||
;; so we evaluate filter via let binding + map to serialize children
|
||||
(assert-equal "(ul (li \"a\") (li \"b\"))"
|
||||
(render-sx "(do (define items (list \"a\" nil \"b\"))
|
||||
(define kept (filter (fn (x) (not (nil? x))) items))
|
||||
(ul (map (fn (x) (li x)) kept)))")))
|
||||
|
||||
(deftest "map inside fragment flattens"
|
||||
(assert-equal "(<> (p \"a\") (p \"b\"))"
|
||||
(render-sx "(do (define items (list \"a\" \"b\"))
|
||||
(<> (map (fn (x) (p x)) items)))")))
|
||||
|
||||
(deftest "nested map does not double-wrap"
|
||||
(assert-equal "(div (span \"1\") (span \"2\"))"
|
||||
(render-sx "(do (define nums (list 1 2))
|
||||
(div (map (fn (n) (span (str n))) nums)))")))
|
||||
|
||||
(deftest "map with component-like output flattens"
|
||||
(assert-equal "(div (li \"x\") (li \"y\"))"
|
||||
(render-sx "(do (define items (list \"x\" \"y\"))
|
||||
(div (map (fn (x) (li x)) items)))"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Component serialization (NOT expanded in basic aser mode)
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "aser-components"
|
||||
(deftest "unknown component serializes as-is"
|
||||
(assert-equal "(~foo :title \"bar\")"
|
||||
(render-sx "(~foo :title \"bar\")")))
|
||||
|
||||
(deftest "defcomp then unexpanded component call"
|
||||
(assert-equal "(~card :title \"Hi\")"
|
||||
(render-sx "(do (defcomp ~card (&key title) (h1 title)) (~card :title \"Hi\"))")))
|
||||
|
||||
(deftest "component with children serializes unexpanded"
|
||||
(assert-equal "(~box (p \"inside\"))"
|
||||
(render-sx "(do (defcomp ~box (&key &rest children) (div children))
|
||||
(~box (p \"inside\")))"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Definition forms in aser mode
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "aser-definitions"
|
||||
(deftest "define evaluates for side effects, returns nil"
|
||||
(assert-equal "(p 42)"
|
||||
(render-sx "(do (define x 42) (p x))")))
|
||||
|
||||
(deftest "defcomp evaluates and returns nil"
|
||||
(assert-equal "(~tag :x 1)"
|
||||
(render-sx "(do (defcomp ~tag (&key x) (span x)) (~tag :x 1))")))
|
||||
|
||||
(deftest "defisland evaluates AND serializes"
|
||||
(let ((result (render-sx "(defisland ~counter (&key count) (span count))")))
|
||||
(assert-true (string-contains? result "defisland")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Function calls in aser mode
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "aser-function-calls"
|
||||
(deftest "named function call evaluates fully"
|
||||
(assert-equal "3"
|
||||
(render-sx "(do (define inc1 (fn (x) (+ x 1))) (inc1 2))")))
|
||||
|
||||
(deftest "define + call"
|
||||
(assert-equal "10"
|
||||
(render-sx "(do (define double (fn (x) (* x 2))) (double 5))")))
|
||||
|
||||
(deftest "native callable with multiple args"
|
||||
;; Regression: async-aser-eval-call passed evaled-args list to
|
||||
;; async-invoke (&rest), wrapping it in another list. apply(f, [list])
|
||||
;; calls f(list) instead of f(*list).
|
||||
(assert-equal "3"
|
||||
(render-sx "(do (define my-add +) (my-add 1 2))")))
|
||||
|
||||
(deftest "native callable with two args via alias"
|
||||
(assert-equal "hello world"
|
||||
(render-sx "(do (define my-join str) (my-join \"hello\" \" world\"))")))
|
||||
|
||||
(deftest "higher-order: map returns list"
|
||||
(let ((result (render-sx "(map (fn (x) (+ x 1)) (list 1 2 3))")))
|
||||
;; map at top level returns a list, not serialized tags
|
||||
(assert-true (not (nil? result))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; and/or short-circuit in aser mode
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "aser-logic"
|
||||
(deftest "and short-circuits on false"
|
||||
(assert-equal "false"
|
||||
(render-sx "(and true false true)")))
|
||||
|
||||
(deftest "and returns last truthy"
|
||||
(assert-equal "3"
|
||||
(render-sx "(and 1 2 3)")))
|
||||
|
||||
(deftest "or short-circuits on true"
|
||||
(assert-equal "1"
|
||||
(render-sx "(or 1 2 3)")))
|
||||
|
||||
(deftest "or returns last falsy"
|
||||
(assert-equal "false"
|
||||
(render-sx "(or false false)"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Spread serialization
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "aser-spreads"
|
||||
(deftest "spread in element merges attrs"
|
||||
(assert-equal "(div :class \"card\" \"hello\")"
|
||||
(render-sx "(div (make-spread {:class \"card\"}) \"hello\")")))
|
||||
|
||||
(deftest "multiple spreads merge into element"
|
||||
(assert-equal "(div :class \"card\" :style \"color:red\" \"hello\")"
|
||||
(render-sx "(div (make-spread {:class \"card\"}) (make-spread {:style \"color:red\"}) \"hello\")")))
|
||||
|
||||
(deftest "spread in fragment is silently dropped"
|
||||
(assert-equal "(<> \"hello\")"
|
||||
(render-sx "(<> (make-spread {:class \"card\"}) \"hello\")")))
|
||||
|
||||
(deftest "stored spread in let binding"
|
||||
(assert-equal "(div :class \"card\" \"hello\")"
|
||||
(render-sx "(let ((card (make-spread {:class \"card\"})))
|
||||
(div card \"hello\"))")))
|
||||
|
||||
(deftest "spread in nested element"
|
||||
(assert-equal "(div (span :class \"inner\" \"hi\"))"
|
||||
(render-sx "(div (span (make-spread {:class \"inner\"}) \"hi\"))")))
|
||||
|
||||
(deftest "spread in non-element context silently drops"
|
||||
(assert-equal "hello"
|
||||
(render-sx "(do (make-spread {:class \"card\"}) \"hello\")"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Scope tests — unified scope primitive
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "scope"
|
||||
|
||||
(deftest "scope with value and context"
|
||||
(assert-equal "dark"
|
||||
(render-sx "(scope \"sc-theme\" :value \"dark\" (context \"sc-theme\"))")))
|
||||
|
||||
(deftest "scope without value defaults to nil"
|
||||
(assert-equal ""
|
||||
(render-sx "(scope \"sc-nil\" (str (context \"sc-nil\")))")))
|
||||
|
||||
(deftest "scope with emit!/emitted"
|
||||
(assert-equal "a,b"
|
||||
(render-sx "(scope \"sc-emit\" (emit! \"sc-emit\" \"a\") (emit! \"sc-emit\" \"b\") (join \",\" (emitted \"sc-emit\")))")))
|
||||
|
||||
(deftest "provide is equivalent to scope with value"
|
||||
(assert-equal "42"
|
||||
(render-sx "(provide \"sc-prov\" 42 (str (context \"sc-prov\")))")))
|
||||
|
||||
(deftest "collect! works via scope (lazy root scope)"
|
||||
(assert-equal "x,y"
|
||||
(render-sx "(do (collect! \"sc-coll\" \"x\") (collect! \"sc-coll\" \"y\") (join \",\" (collected \"sc-coll\")))")))
|
||||
|
||||
(deftest "collect! deduplicates"
|
||||
(assert-equal "a"
|
||||
(render-sx "(do (collect! \"sc-dedup\" \"a\") (collect! \"sc-dedup\" \"a\") (join \",\" (collected \"sc-dedup\")))")))
|
||||
|
||||
(deftest "clear-collected! clears scope accumulator"
|
||||
(assert-equal ""
|
||||
(render-sx "(do (collect! \"sc-clear\" \"x\") (clear-collected! \"sc-clear\") (join \",\" (collected \"sc-clear\")))")))
|
||||
|
||||
(deftest "nested scope shadows outer"
|
||||
(assert-equal "inner"
|
||||
(render-sx "(scope \"sc-nest\" :value \"outer\" (scope \"sc-nest\" :value \"inner\" (context \"sc-nest\")))")))
|
||||
|
||||
(deftest "scope pops correctly after body"
|
||||
(assert-equal "outer"
|
||||
(render-sx "(scope \"sc-pop\" :value \"outer\" (scope \"sc-pop\" :value \"inner\" \"ignore\") (context \"sc-pop\"))"))))
|
||||
@@ -1,279 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; test-cek-reactive.sx — Tests for deref-as-shift reactive rendering
|
||||
;;
|
||||
;; Tests that (deref signal) inside a reactive-reset boundary performs
|
||||
;; continuation capture: the rest of the expression becomes the subscriber.
|
||||
;;
|
||||
;; Requires: test-framework.sx, frames.sx, cek.sx, signals.sx loaded first.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Basic deref behavior through CEK
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "deref pass-through"
|
||||
(deftest "deref non-signal passes through"
|
||||
(let ((result (eval-expr-cek
|
||||
(sx-parse-one "(deref 42)")
|
||||
(test-env))))
|
||||
(assert-equal 42 result)))
|
||||
|
||||
(deftest "deref nil passes through"
|
||||
(let ((result (eval-expr-cek
|
||||
(sx-parse-one "(deref nil)")
|
||||
(test-env))))
|
||||
(assert-nil result)))
|
||||
|
||||
(deftest "deref string passes through"
|
||||
(let ((result (eval-expr-cek
|
||||
(sx-parse-one "(deref \"hello\")")
|
||||
(test-env))))
|
||||
(assert-equal "hello" result))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Deref signal without reactive-reset (no shift)
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "deref signal without reactive-reset"
|
||||
(deftest "deref signal returns current value"
|
||||
(let ((s (signal 99)))
|
||||
(env-set! (test-env) "test-sig" s)
|
||||
(let ((result (eval-expr-cek
|
||||
(sx-parse-one "(deref test-sig)")
|
||||
(test-env))))
|
||||
(assert-equal 99 result))))
|
||||
|
||||
(deftest "deref signal in expression returns computed value"
|
||||
(let ((s (signal 10)))
|
||||
(env-set! (test-env) "test-sig" s)
|
||||
(let ((result (eval-expr-cek
|
||||
(sx-parse-one "(+ 5 (deref test-sig))")
|
||||
(test-env))))
|
||||
(assert-equal 15 result)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Reactive reset + deref: continuation capture
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "reactive-reset shift"
|
||||
(deftest "deref signal with reactive-reset captures continuation"
|
||||
(let ((s (signal 42))
|
||||
(captured-val nil))
|
||||
;; Run CEK with a ReactiveResetFrame
|
||||
(let ((result (cek-run
|
||||
(make-cek-state
|
||||
(sx-parse-one "(deref test-sig)")
|
||||
(let ((e (env-extend (test-env))))
|
||||
(env-set! e "test-sig" s)
|
||||
e)
|
||||
(list (make-reactive-reset-frame
|
||||
(test-env)
|
||||
(fn (v) (set! captured-val v))
|
||||
true))))))
|
||||
;; Initial render: returns current value, update-fn NOT called (first-render)
|
||||
(assert-equal 42 result)
|
||||
(assert-nil captured-val))))
|
||||
|
||||
(deftest "signal change invokes subscriber with update-fn"
|
||||
(let ((s (signal 10))
|
||||
(update-calls (list)))
|
||||
;; Set up reactive-reset with tracking update-fn
|
||||
(scope-push! "sx-island-scope" nil)
|
||||
(let ((e (env-extend (test-env))))
|
||||
(env-set! e "test-sig" s)
|
||||
(cek-run
|
||||
(make-cek-state
|
||||
(sx-parse-one "(deref test-sig)")
|
||||
e
|
||||
(list (make-reactive-reset-frame
|
||||
e
|
||||
(fn (v) (append! update-calls v))
|
||||
true)))))
|
||||
;; Change signal — subscriber should fire
|
||||
(reset! s 20)
|
||||
(assert-equal 1 (len update-calls))
|
||||
(assert-equal 20 (first update-calls))
|
||||
;; Change again
|
||||
(reset! s 30)
|
||||
(assert-equal 2 (len update-calls))
|
||||
(assert-equal 30 (nth update-calls 1))
|
||||
(scope-pop! "sx-island-scope")))
|
||||
|
||||
(deftest "expression with deref captures rest as continuation"
|
||||
(let ((s (signal 5))
|
||||
(update-calls (list)))
|
||||
(scope-push! "sx-island-scope" nil)
|
||||
(let ((e (env-extend (test-env))))
|
||||
(env-set! e "test-sig" s)
|
||||
;; (str "val=" (deref test-sig)) — continuation captures (str "val=" [HOLE])
|
||||
(let ((result (cek-run
|
||||
(make-cek-state
|
||||
(sx-parse-one "(str \"val=\" (deref test-sig))")
|
||||
e
|
||||
(list (make-reactive-reset-frame
|
||||
e
|
||||
(fn (v) (append! update-calls v))
|
||||
true))))))
|
||||
(assert-equal "val=5" result)))
|
||||
;; Change signal — should get updated string
|
||||
(reset! s 42)
|
||||
(assert-equal 1 (len update-calls))
|
||||
(assert-equal "val=42" (first update-calls))
|
||||
(scope-pop! "sx-island-scope"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Disposal and cleanup
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "disposal"
|
||||
(deftest "scope cleanup unsubscribes continuation"
|
||||
(let ((s (signal 1))
|
||||
(update-calls (list))
|
||||
(disposers (list)))
|
||||
;; Create island scope with collector that accumulates disposers
|
||||
(scope-push! "sx-island-scope" (fn (d) (append! disposers d)))
|
||||
(let ((e (env-extend (test-env))))
|
||||
(env-set! e "test-sig" s)
|
||||
(cek-run
|
||||
(make-cek-state
|
||||
(sx-parse-one "(deref test-sig)")
|
||||
e
|
||||
(list (make-reactive-reset-frame
|
||||
e
|
||||
(fn (v) (append! update-calls v))
|
||||
true)))))
|
||||
;; Pop scope — call all disposers
|
||||
(scope-pop! "sx-island-scope")
|
||||
(for-each (fn (d) (cek-call d nil)) disposers)
|
||||
;; Change signal — no update should fire
|
||||
(reset! s 999)
|
||||
(assert-equal 0 (len update-calls)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; cek-call integration — computed/effect use cek-call dispatch
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "cek-call dispatch"
|
||||
(deftest "cek-call invokes native function"
|
||||
(let ((log (list)))
|
||||
(cek-call (fn (x) (append! log x)) (list 42))
|
||||
(assert-equal (list 42) log)))
|
||||
|
||||
(deftest "cek-call invokes zero-arg lambda"
|
||||
(let ((result (cek-call (fn () (+ 1 2)) nil)))
|
||||
(assert-equal 3 result)))
|
||||
|
||||
(deftest "cek-call with nil function returns nil"
|
||||
(assert-nil (cek-call nil nil)))
|
||||
|
||||
(deftest "computed tracks deps via cek-call"
|
||||
(let ((s (signal 10)))
|
||||
(let ((c (computed (fn () (* 2 (deref s))))))
|
||||
(assert-equal 20 (deref c))
|
||||
(reset! s 5)
|
||||
(assert-equal 10 (deref c)))))
|
||||
|
||||
(deftest "effect runs and re-runs via cek-call"
|
||||
(let ((s (signal "a"))
|
||||
(log (list)))
|
||||
(effect (fn () (append! log (deref s))))
|
||||
(assert-equal (list "a") log)
|
||||
(reset! s "b")
|
||||
(assert-equal (list "a" "b") log)))
|
||||
|
||||
(deftest "effect cleanup runs on re-trigger"
|
||||
(let ((s (signal 0))
|
||||
(log (list)))
|
||||
(effect (fn ()
|
||||
(let ((val (deref s)))
|
||||
(append! log (str "run:" val))
|
||||
;; Return cleanup function
|
||||
(fn () (append! log (str "clean:" val))))))
|
||||
(assert-equal (list "run:0") log)
|
||||
(reset! s 1)
|
||||
(assert-equal (list "run:0" "clean:0" "run:1") log)))
|
||||
|
||||
(deftest "batch coalesces via cek-call"
|
||||
(let ((s (signal 0))
|
||||
(count (signal 0)))
|
||||
(effect (fn () (do (deref s) (swap! count inc))))
|
||||
(assert-equal 1 (deref count))
|
||||
(batch (fn ()
|
||||
(reset! s 1)
|
||||
(reset! s 2)
|
||||
(reset! s 3)))
|
||||
;; batch should coalesce — effect runs once, not three times
|
||||
(assert-equal 2 (deref count)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; CEK-native higher-order forms
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "CEK higher-order forms"
|
||||
(deftest "map through CEK"
|
||||
(let ((result (eval-expr-cek
|
||||
(sx-parse-one "(map (fn (x) (* x 2)) (list 1 2 3))")
|
||||
(test-env))))
|
||||
(assert-equal (list 2 4 6) result)))
|
||||
|
||||
(deftest "map-indexed through CEK"
|
||||
(let ((result (eval-expr-cek
|
||||
(sx-parse-one "(map-indexed (fn (i x) (+ i x)) (list 10 20 30))")
|
||||
(test-env))))
|
||||
(assert-equal (list 10 21 32) result)))
|
||||
|
||||
(deftest "filter through CEK"
|
||||
(let ((result (eval-expr-cek
|
||||
(sx-parse-one "(filter (fn (x) (> x 2)) (list 1 2 3 4 5))")
|
||||
(test-env))))
|
||||
(assert-equal (list 3 4 5) result)))
|
||||
|
||||
(deftest "reduce through CEK"
|
||||
(let ((result (eval-expr-cek
|
||||
(sx-parse-one "(reduce (fn (acc x) (+ acc x)) 0 (list 1 2 3))")
|
||||
(test-env))))
|
||||
(assert-equal 6 result)))
|
||||
|
||||
(deftest "some through CEK"
|
||||
(let ((result (eval-expr-cek
|
||||
(sx-parse-one "(some (fn (x) (> x 3)) (list 1 2 3 4 5))")
|
||||
(test-env))))
|
||||
(assert-true result)))
|
||||
|
||||
(deftest "some returns false when none match"
|
||||
(let ((result (eval-expr-cek
|
||||
(sx-parse-one "(some (fn (x) (> x 10)) (list 1 2 3))")
|
||||
(test-env))))
|
||||
(assert-false result)))
|
||||
|
||||
(deftest "every? through CEK"
|
||||
(let ((result (eval-expr-cek
|
||||
(sx-parse-one "(every? (fn (x) (> x 0)) (list 1 2 3))")
|
||||
(test-env))))
|
||||
(assert-true result)))
|
||||
|
||||
(deftest "every? returns false on first falsy"
|
||||
(let ((result (eval-expr-cek
|
||||
(sx-parse-one "(every? (fn (x) (> x 2)) (list 1 2 3))")
|
||||
(test-env))))
|
||||
(assert-false result)))
|
||||
|
||||
(deftest "for-each through CEK"
|
||||
(let ((log (list)))
|
||||
(env-set! (test-env) "test-log" log)
|
||||
(eval-expr-cek
|
||||
(sx-parse-one "(for-each (fn (x) (append! test-log x)) (list 1 2 3))")
|
||||
(test-env))
|
||||
(assert-equal (list 1 2 3) log)))
|
||||
|
||||
(deftest "map on empty list"
|
||||
(let ((result (eval-expr-cek
|
||||
(sx-parse-one "(map (fn (x) x) (list))")
|
||||
(test-env))))
|
||||
(assert-equal (list) result))))
|
||||
@@ -1,259 +0,0 @@
|
||||
;; ==========================================================================
|
||||
;; test-parser.sx — Tests for the SX parser and serializer
|
||||
;;
|
||||
;; Requires: test-framework.sx loaded first.
|
||||
;; Modules tested: parser.sx
|
||||
;;
|
||||
;; Platform functions required (beyond test framework):
|
||||
;; sx-parse (source) -> list of AST expressions
|
||||
;; sx-serialize (expr) -> SX source string
|
||||
;; make-symbol (name) -> Symbol value
|
||||
;; make-keyword (name) -> Keyword value
|
||||
;; symbol-name (sym) -> string
|
||||
;; keyword-name (kw) -> string
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Literal parsing
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "parser-literals"
|
||||
(deftest "parse integers"
|
||||
(assert-equal (list 42) (sx-parse "42"))
|
||||
(assert-equal (list 0) (sx-parse "0"))
|
||||
(assert-equal (list -7) (sx-parse "-7")))
|
||||
|
||||
(deftest "parse floats"
|
||||
(assert-equal (list 3.14) (sx-parse "3.14"))
|
||||
(assert-equal (list -0.5) (sx-parse "-0.5")))
|
||||
|
||||
(deftest "parse strings"
|
||||
(assert-equal (list "hello") (sx-parse "\"hello\""))
|
||||
(assert-equal (list "") (sx-parse "\"\"")))
|
||||
|
||||
(deftest "parse escape: newline"
|
||||
(assert-equal (list "a\nb") (sx-parse "\"a\\nb\"")))
|
||||
|
||||
(deftest "parse escape: tab"
|
||||
(assert-equal (list "a\tb") (sx-parse "\"a\\tb\"")))
|
||||
|
||||
(deftest "parse escape: quote"
|
||||
(assert-equal (list "a\"b") (sx-parse "\"a\\\"b\"")))
|
||||
|
||||
(deftest "parse booleans"
|
||||
(assert-equal (list true) (sx-parse "true"))
|
||||
(assert-equal (list false) (sx-parse "false")))
|
||||
|
||||
(deftest "parse nil"
|
||||
(assert-equal (list nil) (sx-parse "nil")))
|
||||
|
||||
(deftest "parse keywords"
|
||||
(let ((result (sx-parse ":hello")))
|
||||
(assert-length 1 result)
|
||||
(assert-equal "hello" (keyword-name (first result)))))
|
||||
|
||||
(deftest "parse symbols"
|
||||
(let ((result (sx-parse "foo")))
|
||||
(assert-length 1 result)
|
||||
(assert-equal "foo" (symbol-name (first result))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Composite parsing
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "parser-lists"
|
||||
(deftest "parse empty list"
|
||||
(let ((result (sx-parse "()")))
|
||||
(assert-length 1 result)
|
||||
(assert-equal (list) (first result))))
|
||||
|
||||
(deftest "parse list of numbers"
|
||||
(let ((result (sx-parse "(1 2 3)")))
|
||||
(assert-length 1 result)
|
||||
(assert-equal (list 1 2 3) (first result))))
|
||||
|
||||
(deftest "parse nested lists"
|
||||
(let ((result (sx-parse "(1 (2 3) 4)")))
|
||||
(assert-length 1 result)
|
||||
(assert-equal (list 1 (list 2 3) 4) (first result))))
|
||||
|
||||
(deftest "parse square brackets as list"
|
||||
(let ((result (sx-parse "[1 2 3]")))
|
||||
(assert-length 1 result)
|
||||
(assert-equal (list 1 2 3) (first result))))
|
||||
|
||||
(deftest "parse mixed types"
|
||||
(let ((result (sx-parse "(42 \"hello\" true nil)")))
|
||||
(assert-length 1 result)
|
||||
(let ((lst (first result)))
|
||||
(assert-equal 42 (nth lst 0))
|
||||
(assert-equal "hello" (nth lst 1))
|
||||
(assert-equal true (nth lst 2))
|
||||
(assert-nil (nth lst 3))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Dict parsing
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "parser-dicts"
|
||||
(deftest "parse empty dict"
|
||||
(let ((result (sx-parse "{}")))
|
||||
(assert-length 1 result)
|
||||
(assert-type "dict" (first result))))
|
||||
|
||||
(deftest "parse dict with keyword keys"
|
||||
(let ((result (sx-parse "{:a 1 :b 2}")))
|
||||
(assert-length 1 result)
|
||||
(let ((d (first result)))
|
||||
(assert-type "dict" d)
|
||||
(assert-equal 1 (get d "a"))
|
||||
(assert-equal 2 (get d "b")))))
|
||||
|
||||
(deftest "parse dict with string values"
|
||||
(let ((result (sx-parse "{:name \"alice\"}")))
|
||||
(assert-length 1 result)
|
||||
(assert-equal "alice" (get (first result) "name")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Comments and whitespace
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "parser-whitespace"
|
||||
(deftest "skip line comments"
|
||||
(assert-equal (list 42) (sx-parse ";; comment\n42"))
|
||||
(assert-equal (list 1 2) (sx-parse "1 ;; middle\n2")))
|
||||
|
||||
(deftest "skip whitespace"
|
||||
(assert-equal (list 42) (sx-parse " 42 "))
|
||||
(assert-equal (list 1 2) (sx-parse " 1 \n\t 2 ")))
|
||||
|
||||
(deftest "parse multiple top-level expressions"
|
||||
(assert-length 3 (sx-parse "1 2 3"))
|
||||
(assert-equal (list 1 2 3) (sx-parse "1 2 3")))
|
||||
|
||||
(deftest "empty input"
|
||||
(assert-equal (list) (sx-parse "")))
|
||||
|
||||
(deftest "only comments"
|
||||
(assert-equal (list) (sx-parse ";; just a comment\n;; another"))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Quote sugar
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "parser-quote-sugar"
|
||||
(deftest "quasiquote"
|
||||
(let ((result (sx-parse "`foo")))
|
||||
(assert-length 1 result)
|
||||
(let ((expr (first result)))
|
||||
(assert-type "list" expr)
|
||||
(assert-equal "quasiquote" (symbol-name (first expr))))))
|
||||
|
||||
(deftest "unquote"
|
||||
(let ((result (sx-parse ",foo")))
|
||||
(assert-length 1 result)
|
||||
(let ((expr (first result)))
|
||||
(assert-type "list" expr)
|
||||
(assert-equal "unquote" (symbol-name (first expr))))))
|
||||
|
||||
(deftest "splice-unquote"
|
||||
(let ((result (sx-parse ",@foo")))
|
||||
(assert-length 1 result)
|
||||
(let ((expr (first result)))
|
||||
(assert-type "list" expr)
|
||||
(assert-equal "splice-unquote" (symbol-name (first expr)))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Serializer
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "serializer"
|
||||
(deftest "serialize number"
|
||||
(assert-equal "42" (sx-serialize 42)))
|
||||
|
||||
(deftest "serialize string"
|
||||
(assert-equal "\"hello\"" (sx-serialize "hello")))
|
||||
|
||||
(deftest "serialize boolean"
|
||||
(assert-equal "true" (sx-serialize true))
|
||||
(assert-equal "false" (sx-serialize false)))
|
||||
|
||||
(deftest "serialize nil"
|
||||
(assert-equal "nil" (sx-serialize nil)))
|
||||
|
||||
(deftest "serialize keyword"
|
||||
(assert-equal ":foo" (sx-serialize (make-keyword "foo"))))
|
||||
|
||||
(deftest "serialize symbol"
|
||||
(assert-equal "bar" (sx-serialize (make-symbol "bar"))))
|
||||
|
||||
(deftest "serialize list"
|
||||
(assert-equal "(1 2 3)" (sx-serialize (list 1 2 3))))
|
||||
|
||||
(deftest "serialize empty list"
|
||||
(assert-equal "()" (sx-serialize (list))))
|
||||
|
||||
(deftest "serialize nested"
|
||||
(assert-equal "(1 (2 3) 4)" (sx-serialize (list 1 (list 2 3) 4)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Round-trip: parse then serialize
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "parser-roundtrip"
|
||||
(deftest "roundtrip number"
|
||||
(assert-equal "42" (sx-serialize (first (sx-parse "42")))))
|
||||
|
||||
(deftest "roundtrip string"
|
||||
(assert-equal "\"hello\"" (sx-serialize (first (sx-parse "\"hello\"")))))
|
||||
|
||||
(deftest "roundtrip list"
|
||||
(assert-equal "(1 2 3)" (sx-serialize (first (sx-parse "(1 2 3)")))))
|
||||
|
||||
(deftest "roundtrip nested"
|
||||
(assert-equal "(a (b c))"
|
||||
(sx-serialize (first (sx-parse "(a (b c))"))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Reader macros
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(defsuite "reader-macros"
|
||||
(deftest "datum comment discards expr"
|
||||
(assert-equal (list 42) (sx-parse "#;(ignored) 42")))
|
||||
|
||||
(deftest "datum comment in list"
|
||||
(assert-equal (list (list 1 3)) (sx-parse "(1 #;2 3)")))
|
||||
|
||||
(deftest "datum comment discards nested"
|
||||
(assert-equal (list 99) (sx-parse "#;(a (b c) d) 99")))
|
||||
|
||||
(deftest "raw string basic"
|
||||
(assert-equal (list "hello") (sx-parse "#|hello|")))
|
||||
|
||||
(deftest "raw string with quotes"
|
||||
(assert-equal (list "say \"hi\"") (sx-parse "#|say \"hi\"|")))
|
||||
|
||||
(deftest "raw string with backslashes"
|
||||
(assert-equal (list "a\\nb") (sx-parse "#|a\\nb|")))
|
||||
|
||||
(deftest "raw string empty"
|
||||
(assert-equal (list "") (sx-parse "#||")))
|
||||
|
||||
(deftest "quote shorthand symbol"
|
||||
(let ((result (first (sx-parse "#'foo"))))
|
||||
(assert-equal "quote" (symbol-name (first result)))
|
||||
(assert-equal "foo" (symbol-name (nth result 1)))))
|
||||
|
||||
(deftest "quote shorthand list"
|
||||
(let ((result (first (sx-parse "#'(1 2 3)"))))
|
||||
(assert-equal "quote" (symbol-name (first result)))
|
||||
(assert-equal (list 1 2 3) (nth result 1)))))
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user