coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Compare commits

base: coop:architecture
Branches Tags
coop:main coop:architecture coop:wasm coop:macros coop:sx coop:exorcism coop:cssx coop:decoupling coop:sexpression coop:relations
..
compare: coop:6417d15e6049301ea73cf5f970bc89127f5fe7d4
Branches Tags
coop:architecture coop:main coop:wasm coop:macros coop:sx coop:exorcism coop:cssx coop:decoupling coop:sexpression coop:relations

5 Commits
architectu ... 6417d15e60

Author SHA1 Message Date
giles
6417d15e60 Merge branch 'ocaml-vm'
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
Details
2026-03-25 01:21:00 +00:00
giles
73810d249d Merge branch 'ocaml-vm'
All checks were successful
Test, Build, and Deploy / test-build-deploy (push) Successful in 5m58s
Details
2026-03-25 00:59:50 +00:00
giles
2bc1aee888 Merge branch 'ocaml-vm'
All checks were successful
Test, Build, and Deploy / test-build-deploy (push) Successful in 2m25s
Details
2026-03-25 00:36:57 +00:00
giles
7ac026eccb Merge branch 'ocaml-vm'
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 14s
Details
2026-03-25 00:35:06 +00:00
giles
1b5d3e8eb1 Add spec/, lib/, web/ to sx_docs Docker image
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 16s
Details 
The Dockerfile was missing COPY lines for the SX source files loaded
by the OCaml kernel at runtime (parser, render, compiler, adapters,
signals, freeze). This caused CI test failures and production deploy
to run without the spec/lib split or web adapters.

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
 2026-03-25 00:31:56 +00:00
477 changed files with 34661 additions and 168365 deletions
Expand all files Collapse all files

27
.claude/agents/explore.md
View File

@@ -1,27 +0,0 @@
---
name: explore
description: Explore codebase using sx-tree MCP tools for .sx files
tools: Read, Grep, Glob, Bash, mcp__sx-tree__sx_summarise, mcp__sx-tree__sx_read_tree, mcp__sx-tree__sx_read_subtree, mcp__sx-tree__sx_find_all, mcp__sx-tree__sx_get_context, mcp__sx-tree__sx_get_siblings, mcp__sx-tree__sx_validate
hooks:
PreToolUse:
- matcher: "Read"
hooks:
- type: command
command: "bash .claude/hooks/block-sx-edit.sh"
---
Fast codebase exploration agent. Use for finding files, searching code, and answering questions about the codebase.
## Critical rule for .sx and .sxc files
NEVER use Read on .sx or .sxc files. The hook will block it. Instead use the sx-tree MCP tools:
- `mcp__sx-tree__sx_summarise` — structural overview at configurable depth
- `mcp__sx-tree__sx_read_tree` — full annotated tree with path labels
- `mcp__sx-tree__sx_read_subtree` — expand a specific subtree by path
- `mcp__sx-tree__sx_find_all` — search for nodes matching a pattern
- `mcp__sx-tree__sx_get_context` — enclosing chain from root to target
- `mcp__sx-tree__sx_get_siblings` — siblings of a node with target marked
- `mcp__sx-tree__sx_validate` — structural integrity checks
For all other file types, use Read, Grep, Glob, and Bash as normal.

7
.claude/hooks/block-sx-edit.sh
View File

@@ -1,7 +0,0 @@
#!/bin/bash
# Block Edit/Read/Write on .sx/.sxc files — force use of sx-tree MCP tools
FILE=$(jq -r '.tool_input.file_path // .tool_input.file // empty' 2>/dev/null)
if [ -n "$FILE" ] && echo "$FILE" | grep -qE '\.(sx|sxc)$'; then
printf '{"decision":"block","reason":"Use sx-tree MCP tools instead of Edit/Read/Write on .sx/.sxc files. For new files use sx_write_file, for reading use sx_read_tree/sx_summarise, for editing use sx_replace_node/sx_rename_symbol/etc. See CLAUDE.md for the protocol."}'
exit 2
fi

13
.gitignore vendored
View File

@@ -15,16 +15,3 @@ sx-haskell/
sx-rust/
shared/static/scripts/sx-full-test.js
hosts/ocaml/_build/
hosts/ocaml/browser/sx_browser.bc.wasm.assets/
hosts/ocaml/browser/sx_browser.bc.wasm.assets.bak/
hosts/ocaml/bin/mcp_tree_built.exe
hosts/ocaml/hosts/
hosts/ocaml/test-results/
shared/static/wasm/sx_browser.bc.wasm.assets/
.claude/worktrees/
tests/playwright/test-results/
test-case-define.sx
test-case-define.txt
test_all.js
test_final.js
test_interactive.js

13
.mcp.json
View File

@@ -1,13 +0,0 @@
{
"mcpServers": {
"sx-tree": {
"type": "stdio",
"command": "./hosts/ocaml/_build/default/bin/mcp_tree.exe"
},
"rose-ash-services": {
"type": "stdio",
"command": "python3",
"args": ["tools/mcp_services.py"]
}
}
}

228
CLAUDE.md
View File

@@ -2,124 +2,6 @@
Cooperative web platform: federated content, commerce, events, and media processing. Each domain runs as an independent Quart microservice with its own database, communicating via HMAC-signed internal HTTP and ActivityPub events.
## S-expression files — reading and editing protocol
**Never use `Edit`, `Read`, or `Write` on `.sx` or `.sxc` files.** A hook blocks these tools on `.sx`/`.sxc` files. Use the `sx-tree` MCP server tools instead — they operate on the parsed tree, not raw text. Bracket errors are impossible by construction.
### Before doing anything in an `.sx` file
1. Call `sx_summarise` to get a structural overview of the whole file
2. Call `sx_read_subtree` on the region you intend to work in
3. Call `sx_get_context` on specific nodes to understand their position
4. Call `sx_find_all` to locate definitions or patterns by name
5. For project-wide searches, use `sx_find_across`, `sx_comp_list`, or `sx_comp_usage`
**Never proceed to an edit without first establishing where you are in the tree using the comprehension tools.**
### For every s-expression edit
**Path-based** (when you know the exact path):
1. Call `sx_read_subtree` on the target region to confirm the correct path
2. Call `sx_replace_node` / `sx_insert_child` / `sx_delete_node` / `sx_wrap_node`
3. Call `sx_validate` to confirm structural integrity
4. Call `sx_read_subtree` again on the edited region to verify the result
**Pattern-based** (when you can describe what to find):
- `sx_rename_symbol` — rename all occurrences of a symbol in a file
- `sx_replace_by_pattern` — find + replace first/all nodes matching a pattern
- `sx_insert_near` — insert before/after a pattern match (top-level)
- `sx_rename_across` — rename a symbol across all `.sx` files (use `dry_run=true` first)
### Creating new `.sx` files
Use `sx_write_file` — it validates the source by parsing before writing. Malformed SX is rejected.
### On failure
Read the error carefully. Fragment errors give the parse failure in the new source. Path errors tell you which segment was not found. Fix the specific problem and retry the tree edit. **Never fall back to raw file writes.**
### Available MCP tools (sx-tree server)
**Comprehension:**
| Tool | Purpose |
|------|---------|
| `sx_read_tree` | Annotated tree — auto-summarises large files. Params: `focus` (expand matching subtrees), `max_depth`, `max_lines`/`offset` |
| `sx_summarise` | Folded overview at configurable depth |
| `sx_read_subtree` | Expand a specific subtree by path |
| `sx_get_context` | Enclosing chain from root to target |
| `sx_find_all` | Search by pattern in one file, returns paths |
| `sx_get_siblings` | Siblings of a node with target marked |
| `sx_validate` | Structural integrity checks |
**Path-based editing:**
| Tool | Purpose |
|------|---------|
| `sx_replace_node` | Replace node at path with new source |
| `sx_insert_child` | Insert child at index in a list |
| `sx_delete_node` | Remove node, siblings shift |
| `sx_wrap_node` | Wrap in template with `_` placeholder |
**Smart editing (pattern-based):**
| Tool | Purpose |
|------|---------|
| `sx_rename_symbol` | Rename all occurrences of a symbol in a file |
| `sx_replace_by_pattern` | Find + replace first/all nodes matching a pattern. `all=true` for all matches |
| `sx_insert_near` | Insert before/after a pattern match (top-level). `position="before"` or `"after"` |
| `sx_rename_across` | Rename symbol across all `.sx` files in a directory. `dry_run=true` to preview |
**Project-wide:**
| Tool | Purpose |
|------|---------|
| `sx_find_across` | Search pattern across all `.sx` files in a directory |
| `sx_comp_list` | List all definitions (defcomp/defisland/defmacro/defpage/define) across files |
| `sx_comp_usage` | Find all uses of a component/symbol across files |
**Development:**
| Tool | Purpose |
|------|---------|
| `sx_pretty_print` | Reformat an `.sx` file with indentation. Also used automatically by all edit tools |
| `sx_write_file` | Create/overwrite `.sx` file with parse validation |
| `sx_build` | Build JS bundle (`target="js"`) or OCaml binary (`target="ocaml"`) |
| `sx_test` | Run test suite (`host="js"` or `"ocaml"`, `full=true` for extensions) |
| `sx_format_check` | Lint: empty bindings, missing bodies, duplicate params |
| `sx_macroexpand` | Evaluate expression with a file's macro definitions loaded |
| `sx_eval` | REPL — evaluate SX expressions in the MCP server env |
**Git integration:**
| Tool | Purpose |
|------|---------|
| `sx_changed` | List `.sx` files changed since a ref with structural summaries |
| `sx_diff_branch` | Structural diff of all `.sx` changes on branch vs base ref |
| `sx_blame` | Git blame for `.sx` file, optionally focused on a tree path |
**Test harness:**
| Tool | Purpose |
|------|---------|
| `sx_harness_eval` | Evaluate SX in a sandboxed harness with mock IO. Returns result + IO trace. Params: `expr`, optional `mock`, `file`, `files` (array), `setup` (SX expr run before eval) |
**Analysis:**
| Tool | Purpose |
|------|---------|
| `sx_diff` | Structural diff between two `.sx` files (ADDED/REMOVED/CHANGED) |
| `sx_doc_gen` | Generate component docs from signatures across a directory |
| `sx_playwright` | Run Playwright browser tests for the SX docs site |
**Debugging & analysis:**
| Tool | Purpose |
|------|---------|
| `sx_trace` | Step-through CEK evaluation showing symbol lookups, function calls, returns. Params: `expr`, optional `file`, `max_steps` |
| `sx_deps` | Dependency analysis — shows all free symbols in a component and where they're defined. Params: `file`, optional `name`, `dir` |
| `sx_build_manifest` | Show build contents: adapters, spec modules, primitives. Params: optional `target` ("js" or "ocaml") |
## Deployment
- **Do NOT push** until explicitly told to. Pushes reload code to dev automatically.
@@ -182,8 +64,6 @@ The SX language is defined by a self-hosting specification in `shared/sx/ref/`.
- **`shared/sx/ref/primitives.sx`** — All ~80 built-in pure functions: arithmetic, comparison, predicates, string ops, collection ops, dict ops, format helpers, CSSX style primitives.
- **`shared/sx/ref/render.sx`** — Three rendering modes: `render-to-html` (server HTML), `render-to-sx`/`aser` (SX wire format for client), `render-to-dom` (browser). HTML tag registry, void elements, boolean attrs.
- **`shared/sx/ref/bootstrap_js.py`** — Transpiler: reads the `.sx` spec files and emits `sx-ref.js`.
- **`spec/harness.sx`** — Test harness: mock IO platform for testing components. Sessions, IO interception, log queries, assertions (`assert-io-called`, `assert-io-count`, `assert-io-args`, `assert-no-io`, `assert-state`). Extensible — new platforms add entries to the platform dict. Loaded automatically by test runners.
- **`spec/tests/test-harness.sx`** — Tests for the harness itself (15 tests).
### Type system
@@ -228,26 +108,6 @@ lambda, component, macro, thunk (TCO deferred eval)
The `aser` (async-serialize) mode evaluates control flow and function calls but serializes HTML tags and component calls as SX source — the client renders them. This is the wire format for HTMX-like responses.
### Test harness (from harness.sx)
The harness provides sandboxed testing of IO behavior. It's a spec-level facility — works on every host.
**Core concepts:**
- **Session** — `(make-harness &key platform)` creates a session with mock IO operations
- **Interceptor** — `(make-interceptor session op-name mock-fn)` wraps a mock to record calls
- **IO log** — append-only trace of every IO call. Query with `io-calls`, `io-call-count`, `io-call-args`
- **Assertions** — `assert-io-called`, `assert-no-io`, `assert-io-count`, `assert-io-args`, `assert-state`
**Default platform** provides 30+ mock IO operations (fetch, query, action, cookies, DOM, storage, etc.) that return sensible empty values. Override per-test with `:platform` on `make-harness`.
**Extensibility:** New platforms add entries to the platform dict. The harness intercepts any registered operation — no harness code changes needed for new IO types.
**Platform-specific test extensions** live in the platform spec, not the core harness:
- `web/harness-web.sx` — DOM assertions, `simulate-click`, CSS class checks
- `web/harness-reactive.sx` — signal assertions: `assert-signal-value`, `assert-signal-subscribers`
**Components ship with tests** via `deftest` forms. Tests reference components by name or CID (`:for` param). Tests are independent content-addressed objects — anyone can publish tests for any component.
### Platform interface
Each target (JS, Python) must provide: type inspection (`type-of`), constructors (`make-lambda`, `make-component`, `make-macro`, `make-thunk`), accessors, environment operations (`env-has?`, `env-get`, `env-set!`, `env-extend`, `env-merge`), and DOM/HTML rendering primitives.
@@ -349,9 +209,6 @@ Shared components live in `shared/sx/templates/` and are loaded by `load_shared_
| relations | (internal only) | 8008 |
| likes | (internal only) | 8009 |
| orders | orders.rose-ash.com | 8010 |
| sx_docs | sx.rose-ash.com | 8013 |
**Dev serves live domains.** Docker dev containers bind-mount host files and Caddy routes public domains (e.g. `sx.rose-ash.com`) to the dev container ports (e.g. `localhost:8013`). There is no separate "local" vs "production" — editing files on the host and restarting the container updates the live site immediately. Playwright tests at `localhost:8013` test the same server visitors see at `sx.rose-ash.com`.
## Dev Container Mounts
@@ -369,88 +226,3 @@ Dev bind mounts in `docker-compose.dev.yml` must mirror the Docker image's COPY
- Use Context7 MCP for up-to-date library documentation
- Playwright MCP is available for browser automation/testing
### Service introspection MCP (rose-ash-services)
Python-based MCP server for understanding the microservice topology. Static analysis — works without running services.
| Tool | Purpose |
|------|---------|
| `svc_status` | Docker container status for all rose-ash services |
| `svc_routes` | List all HTTP routes for a service by scanning blueprints |
| `svc_calls` | Map inter-service calls (fetch_data/call_action/send_internal_activity/fetch_fragment) |
| `svc_config` | Environment variables and config for a service |
| `svc_models` | SQLAlchemy models, columns, relationships for a service |
| `svc_schema` | Live defquery/defaction manifest from a running service |
| `alembic_status` | Migration count and latest migration per service |
| `svc_logs` | Recent Docker logs for a service |
| `svc_start` | Start services via dev.sh |
| `svc_stop` | Stop all services |
| `svc_queries` | List all defquery definitions from queries.sx files |
| `svc_actions` | List all defaction definitions from actions.sx files |
### VM / Bytecode Debugging Tools
These are OCaml server commands sent via the epoch protocol (`printf '(epoch N)\n(command args)\n' | sx_server.exe`). They're available in any context where the OCaml kernel is running (dev server, CLI, tests).
```bash
# Full build pipeline — OCaml + JS browser + JS test + run tests
./scripts/sx-build-all.sh
# WASM boot test — verify sx_browser.bc.js loads in Node.js without a browser
bash hosts/ocaml/browser/test_boot.sh
```
#### `(vm-trace "<sx-source>")`
Step through bytecode execution. Returns a list of trace entries, each with:
- `:opcode` — instruction name (CONST, CALL, JUMP_IF_FALSE, etc.)
- `:stack` — top 5 values on the stack at that point
- `:depth` — frame nesting depth
Requires the compiler to be loaded (`lib/compiler.sx`). Use this to debug unexpected VM behavior — it shows exactly what the bytecode does step by step.
```bash
printf '(epoch 1)\n(load "lib/compiler.sx")\n(epoch 2)\n(vm-trace "(+ 1 2)")\n' | sx_server.exe
```
#### `(bytecode-inspect "<function-name>")`
Disassemble a compiled function's bytecode. Returns a dict with:
- `:arity` — number of parameters
- `:num_locals` — stack frame size
- `:constants` — constant pool (strings, numbers, symbols)
- `:bytecode` — list of instructions, each with `:offset`, `:opcode`, `:operands`
Only works on functions that have been JIT-compiled (have a `vm_closure`). Use this to verify the compiler emits correct bytecode.
```bash
printf '(epoch 1)\n(bytecode-inspect "my-function")\n' | sx_server.exe
```
#### `(deps-check "<sx-source>")`
Strict symbol resolution checker. Parses the source, walks the AST, and checks every symbol reference against:
- Environment bindings (defines, let bindings)
- Primitive functions table
- Special form names (if, when, cond, let, define, etc.)
Returns `{:resolved (...) :unresolved (...)}`. Run this on `.sx` files before compilation to catch typos and missing imports (e.g., `extract-verb-info` vs `get-verb-info`).
```bash
printf '(epoch 1)\n(deps-check "(defcomp ~my-comp () (div (frobnicate x)))")\n' | sx_server.exe
# => {:resolved ("defcomp" "div") :unresolved ("frobnicate" "x")}
```
#### `(prim-check "<function-name>")`
Scan compiled bytecode for `CALL_PRIM` instructions and verify each primitive name exists in the runtime. Returns `{:valid (...) :invalid (...)}`. Catches mismatches like `length` vs `len` that would crash at runtime.
```bash
printf '(epoch 1)\n(prim-check "my-compiled-fn")\n' | sx_server.exe
# => {:valid ("+" "len" "first") :invalid ("length")}
```
### SX Island Authoring Rules
Key patterns discovered from the reactive runtime demos (see `sx/sx/reactive-runtime.sx`):
1. **Multi-expression bodies need `(do ...)`** — `fn`, `let`, and `when` bodies evaluate only the last expression. Wrap multiples in `(do expr1 expr2 expr3)`.
2. **`let` is parallel, not sequential** — bindings in the same `let` can't reference each other. Use nested `let` blocks when functions need to reference signals defined earlier.
3. **Reactive text needs `(deref (computed ...))`** — bare `(len (deref items))` is NOT reactive. Wrap in `(deref (computed (fn () (len (deref items)))))`.
4. **Effects go in inner `let`** — signals in outer `let`, functions and effects in inner `let`. The OCaml SSR evaluator can't resolve outer `let` bindings from same-`let` lambdas.

1
_config/app-config.sx
View File

@@ -1 +0,0 @@
(defconfig app {:market-root "/market" :host "https://rose-ash.com" :base-url "https://wholesale.suma.coop/" :base-login "https://wholesale.suma.coop/customer/account/login/" :slugs {:skip ("" "customer" "account" "checkout" "wishlist" "sales" "contact" "privacy-policy" "terms-and-conditions" "delivery" "catalogsearch" "quickorder" "apply" "search" "static" "media")} :categories {:allow {:Chilled "chilled" :Non-foods "non-foods" :Branded-Goods "branded-goods" :Frozen "frozen" :Basics "basics" :Supplements "supplements" :Christmas "christmas"}} :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")} :cart-root "/cart" :cache {:fs-root "/app/_snapshot"} :market-title "Market" :app-urls {:sx "https://sx.rose-ash.com" :account "https://account.rose-ash.com" :events "https://events.rose-ash.com" :federation "https://federation.rose-ash.com" :cart "https://cart.rose-ash.com" :orders "https://orders.rose-ash.com" :test "https://test.rose-ash.com" :blog "https://blog.rose-ash.com" :market "https://market.rose-ash.com"} :title "ROSE-ASH 2.0" :blog-root "/" :sumup {:merchant-code "ME4J6100" :currency "GBP" :webhook-secret (env-get "SUMUP_WEBHOOK_SECRET") :api-key (env-get "SUMUP_API_KEY")} :root "/rose-ash-wholefood-coop" :base-host "wholesale.suma.coop" :blog-title "all the news"})

155
applications/sxtp/spec.sx
View File

@@ -1,155 +0,0 @@
(define
request-fields
(quote
((:verb "Symbol — the action to perform (required)")
(:path "String — resource path (required)")
(:headers "Dict — structured request metadata (optional)")
(:cookies "Dict — client state, values can be any SX type (optional)")
(:params "Dict — query parameters as typed values (optional)")
(:capabilities "List — capabilities this request requires (optional)")
(:body "Any SX value — request payload (optional)"))))
(define
response-fields
(quote
((:status "Symbol or condition — result status (required)")
(:headers "Dict — structured response metadata (optional)")
(:set-cookie
"Dict — cookies to set, values are dicts with :value :max-age :path (optional)")
(:body "Any SX value — response payload (optional)")
(:stream "Boolean — if true, body is a sequence of chunks (optional)"))))
(define
core-verbs
(quote
((navigate "Retrieve a page for display — analogous to GET for documents")
(fetch "Retrieve data — analogous to GET for APIs")
(query "Structured query — body contains a query expression")
(mutate "Change state — analogous to POST/PUT/PATCH")
(create "Create a new resource — analogous to POST")
(delete "Remove a resource — analogous to DELETE")
(subscribe "Open a streaming channel for real-time updates")
(inspect "Retrieve metadata about a resource (capabilities, schema)")
(ping "Liveness check — server responds with (response :status ok)"))))
(define
standard-headers
(quote
((:accept "List of acceptable response types")
(:language "String or list — preferred languages")
(:if-match "String — content hash for conditional requests")
(:capabilities "List — capabilities the client holds")
(:origin "String — requesting origin for CORS-like checks")
(:content-type "String — always text/sx in pure SXTP")
(:content-hash "String — SHA3-256 of the body expression")
(:cache "Symbol — :immutable, :revalidate, :none")
(:vary "List of header keys that affect caching")
(:link "Dict — related resources"))))
(define
cookie-options
(quote
((:value "Any SX value — the cookie payload (required)")
(:max-age "Number — seconds until expiry (optional)")
(:path "String — path scope (optional, default /)")
(:domain "String — domain scope (optional)")
(:secure "Boolean — require secure transport (optional)")
(:same-site "Symbol — :strict, :lax, or :none (optional)")
(:delete "Boolean — if true, remove this cookie (optional)"))))
(define
status-symbols
(quote
((ok "Success — body contains the result")
(created "Resource created — body contains the new resource")
(accepted "Request accepted for async processing")
(no-content "Success with no body")
(redirect "See :headers :location for target")
(not-modified "Cached version is current based on :if-match")
(error "General error — see :body for condition")
(not-found "Resource does not exist")
(forbidden "Insufficient capabilities")
(invalid "Malformed request or invalid params")
(conflict "State conflict — concurrent edit")
(unavailable "Service temporarily unavailable"))))
(define
condition-fields
(quote
((:type "Symbol — condition type (required)")
(:message "String — human-readable description (optional)")
(:path "String — resource that caused the error (optional)")
(:retry "Boolean — whether retrying may succeed (optional)")
(:detail "Any SX value — domain-specific detail (optional)"))))
(define
chunk-fields
(quote
((:seq "Number — sequence index for ordered chunks")
(:body "Any SX value — the chunk content")
(:done "Boolean — signals end of stream"))))
(define
event-fields
(quote
((:type "Symbol — event type (required)")
(:id "String — event or resource identifier (optional)")
(:body "Any SX value — event payload (optional)")
(:time "Number — unix timestamp (optional)"))))
(define
example-navigate
(quote
((request :verb navigate :path "/geography/capabilities" :headers {:host "sx.rose-ash.com" :accept "text/sx"})
(response
:status ok
:headers {:content-type "text/sx" :content-hash "sha3-9f2a"}
:body (page
:title "Capabilities"
(h1 "Geography Capabilities")
(~capability-list :domain "geography"))))))
(define
example-query
(quote
((request :verb query :path "/events" :capabilities (fetch db:read) :params {:after "2026-03-01" :limit 10} :body (filter (events) (fn (e) (> (:attendees e) 50))))
(response
:status ok
:headers {:cache :revalidate}
:body ((event :id "evt-42" :title "Jazz Night" :attendees 87)
(event :id "evt-55" :title "Art Walk" :attendees 120))))))
(define
example-mutate
(quote
((request :verb create :path "/blog/posts" :capabilities (mutate blog:publish) :cookies {:session "tok_abc123"} :body {:tags ("protocol" "sx" "web") :body (article (h1 "SXTP") (p "Everything is SX.")) :title "SXTP Protocol"})
(response :status created :headers {:location "/blog/posts/sxtp-protocol" :content-hash "sha3-ff01"} :body {:created-at 1711612800 :id "post-789" :path "/blog/posts/sxtp-protocol"}))))
(define
example-subscribe
(quote
((request :verb subscribe :path "/events/live" :capabilities (fetch) :headers {:host "events.rose-ash.com"})
(response :status ok :stream true)
(event
:type new-event
:id "evt-99"
:body (div :class "event-card" (h3 "Poetry Slam")))
(event :type heartbeat :time 1711612860))))
(define
example-error
(quote
((request :verb fetch :path "/blog/nonexistent")
(response
:status not-found
:body (condition
:type resource-not-found
:path "/blog/nonexistent"
:message "No such post"
:retry false)))))
(define
example-inspect
(quote
((request :verb inspect :path "/cart/checkout")
(response :status ok :body {:available-verbs (inspect mutate) :params-schema {:payment-method "symbol" :shipping-address "dict"} :required-capabilities (mutate cart:checkout)}))))

1
blog/config/app-config.sx
View File

@@ -1 +0,0 @@
(defconfig app {:market-root "/market" :host "https://rose-ash.com" :base-url "https://wholesale.suma.coop/" :base-login "https://wholesale.suma.coop/customer/account/login/" :slugs {:skip ("" "customer" "account" "checkout" "wishlist" "sales" "contact" "privacy-policy" "terms-and-conditions" "delivery" "catalogsearch" "quickorder" "apply" "search" "static" "media")} :categories {:allow {:Chilled "chilled" :Non-foods "non-foods" :Branded-Goods "branded-goods" :Frozen "frozen" :Basics "basics" :Supplements "supplements" :Christmas "christmas"}} :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")} :cart-root "/cart" :cache {:fs-root "/app/_snapshot"} :market-title "Market" :app-urls {:sx "https://sx.rose-ash.com" :account "https://account.rose-ash.com" :events "https://events.rose-ash.com" :federation "https://federation.rose-ash.com" :cart "https://cart.rose-ash.com" :orders "https://orders.rose-ash.com" :test "https://test.rose-ash.com" :blog "https://blog.rose-ash.com" :market "https://market.rose-ash.com"} :title "ROSE-ASH 2.0" :blog-root "/" :sumup {:merchant-code "ME4J6100" :currency "GBP" :webhook-secret (env-get "SUMUP_WEBHOOK_SECRET") :api-key (env-get "SUMUP_API_KEY")} :root "/rose-ash-wholefood-coop" :base-host "wholesale.suma.coop" :blog-title "all the news"})

703
blog/sx/admin.sx
View File

@@ -144,140 +144,78 @@
edit-form delete-form))
;; Data-driven snippets list (replaces Python _snippets_sx loop)
(defcomp
~admin/snippets-from-data
(&key snippets user-id is-admin csrf badge-colours)
(defcomp ~admin/snippets-from-data (&key snippets user-id is-admin csrf badge-colours)
(~admin/snippets-list
:rows (<>
(map
(lambda
(s)
(let-match
{:visibility s-vis :delete_url delete-url :patch_url patch-url :id s-id :user_id s-uid :name s-name}
s
(let*
((owner (if (= s-uid user-id) "You" (str "User #" s-uid)))
(badge-cls
(or (get badge-colours s-vis) "bg-stone-200 text-stone-700"))
(extra
(<>
(when
is-admin
(~admin/snippet-visibility-select
:patch-url patch-url
:hx-headers (str "{\"X-CSRFToken\": \"" csrf "\"}")
:options (<>
(~admin/snippet-option
:value "private"
:selected (= s-vis "private")
:label "private")
(~admin/snippet-option
:value "shared"
:selected (= s-vis "shared")
:label "shared")
(~admin/snippet-option
:value "admin"
:selected (= s-vis "admin")
:label "admin"))
:cls "text-sm border border-stone-300 rounded px-2 py-0.5"))
(when
(or (= s-uid user-id) is-admin)
(~shared:misc/delete-btn
:url delete-url
:trigger-target "#snippets-list"
:title "Delete snippet?"
:text (str "Delete \"" s-name "\"?")
:sx-headers (str "{\"X-CSRFToken\": \"" csrf "\"}")
:cls "px-3 py-1 text-sm bg-red-200 hover:bg-red-300 text-red-800 rounded-full")))))
(~admin/snippet-row
:name s-name
:owner owner
:badge-cls badge-cls
:visibility s-vis
:extra extra))))
(or snippets (list))))))
:rows (<> (map (lambda (s)
(let* ((s-id (get s "id"))
(s-name (get s "name"))
(s-uid (get s "user_id"))
(s-vis (get s "visibility"))
(owner (if (= s-uid user-id) "You" (str "User #" s-uid)))
(badge-cls (or (get badge-colours s-vis) "bg-stone-200 text-stone-700"))
(extra (<>
(when is-admin
(~admin/snippet-visibility-select
:patch-url (get s "patch_url")
:hx-headers (str "{\"X-CSRFToken\": \"" csrf "\"}")
:options (<>
(~admin/snippet-option :value "private" :selected (= s-vis "private") :label "private")
(~admin/snippet-option :value "shared" :selected (= s-vis "shared") :label "shared")
(~admin/snippet-option :value "admin" :selected (= s-vis "admin") :label "admin"))
:cls "text-sm border border-stone-300 rounded px-2 py-1"))
(when (or (= s-uid user-id) is-admin)
(~shared:misc/delete-btn :url (get s "delete_url") :trigger-target "#snippets-list"
:title "Delete snippet?"
:text (str "Delete \u201c" s-name "\u201d?")
:sx-headers (str "{\"X-CSRFToken\": \"" csrf "\"}")
:cls "px-3 py-1 text-sm bg-red-200 hover:bg-red-300 rounded text-red-800 flex-shrink-0")))))
(~admin/snippet-row :name s-name :owner owner :badge-cls badge-cls
:visibility s-vis :extra extra)))
(or snippets (list))))))
;; Data-driven menu items list (replaces Python _menu_items_list_sx loop)
(defcomp
~admin/menu-items-from-data
(&key items csrf)
(defcomp ~admin/menu-items-from-data (&key items csrf)
(~admin/menu-items-list
:rows (<>
(map
(lambda
(item)
(let-match
{:delete_url delete-url :sort_order sort-order :edit_url edit-url :feature_image feature-image :label label :slug slug}
item
(let
((img (~shared:misc/img-or-placeholder :src feature-image :alt label :size-cls "w-12 h-12 rounded-full object-cover flex-shrink-0")))
(~admin/menu-item-row
:img img
:label label
:slug slug
:sort-order sort-order
:edit-url edit-url
:delete-url delete-url
:confirm-text (str "Remove " label " from the menu?")
:hx-headers (str "{\"X-CSRFToken\": \"" csrf "\"}")))))
(or items (list))))))
:rows (<> (map (lambda (item)
(let* ((img (~shared:misc/img-or-placeholder :src (get item "feature_image") :alt (get item "label")
:size-cls "w-12 h-12 rounded-full object-cover flex-shrink-0")))
(~admin/menu-item-row
:img img :label (get item "label") :slug (get item "slug")
:sort-order (get item "sort_order") :edit-url (get item "edit_url")
:delete-url (get item "delete_url")
:confirm-text (str "Remove " (get item "label") " from the menu?")
:hx-headers (str "{\"X-CSRFToken\": \"" csrf "\"}"))))
(or items (list))))))
;; Data-driven tag groups main (replaces Python _tag_groups_main_panel_sx loops)
(defcomp
~admin/tag-groups-from-data
(&key groups unassigned-tags csrf create-url)
(defcomp ~admin/tag-groups-from-data (&key groups unassigned-tags csrf create-url)
(~admin/tag-groups-main
:form (~admin/tag-groups-create-form :create-url create-url :csrf csrf)
:groups (if
(empty? (or groups (list)))
(~shared:misc/empty-state
:message "No tag groups yet."
:cls "text-stone-500 text-sm")
:groups (if (empty? (or groups (list)))
(~shared:misc/empty-state :message "No tag groups yet." :cls "text-stone-500 text-sm")
(~admin/tag-groups-list
:items (<>
(map
(lambda
(g)
(let-match
{:sort_order sort-order :feature_image feature-image :slug slug :edit_href edit-href :initial initial :name name :style style}
g
(let
((icon (if feature-image (~admin/tag-group-icon-image :src feature-image :name name) (~admin/tag-group-icon-color :style style :initial initial))))
(~admin/tag-group-li
:icon icon
:edit-href edit-href
:name name
:slug slug
:sort-order sort-order))))
groups))))
:unassigned (when
(not (empty? (or unassigned-tags (list))))
:items (<> (map (lambda (g)
(let* ((icon (if (get g "feature_image")
(~admin/tag-group-icon-image :src (get g "feature_image") :name (get g "name"))
(~admin/tag-group-icon-color :style (get g "style") :initial (get g "initial")))))
(~admin/tag-group-li :icon icon :edit-href (get g "edit_href")
:name (get g "name") :slug (get g "slug") :sort-order (get g "sort_order"))))
groups))))
:unassigned (when (not (empty? (or unassigned-tags (list))))
(~admin/unassigned-tags
:heading (str "Unassigned Tags (" (len unassigned-tags) ")")
:spans (<>
(map
(lambda (t) (~admin/unassigned-tag :name (get t "name")))
unassigned-tags))))))
:spans (<> (map (lambda (t)
(~admin/unassigned-tag :name (get t "name")))
unassigned-tags))))))
;; Data-driven tag group edit (replaces Python _tag_groups_edit_main_panel_sx loop)
(defcomp
~admin/tag-checkboxes-from-data
(&key tags)
(<>
(map
(lambda
(t)
(let-match
{:tag_id tag-id :checked checked :feature_image feature-image :name name}
t
(~admin/tag-checkbox
:tag-id tag-id
:checked checked
:img (when
feature-image
(~admin/tag-checkbox-image :src feature-image))
:name name)))
(or tags (list)))))
(defcomp ~admin/tag-checkboxes-from-data (&key tags)
(<> (map (lambda (t)
(~admin/tag-checkbox
:tag-id (get t "tag_id") :checked (get t "checked")
:img (when (get t "feature_image") (~admin/tag-checkbox-image :src (get t "feature_image")))
:name (get t "name")))
(or tags (list)))))
;; Preview panel components
@@ -320,175 +258,113 @@
;; ---------------------------------------------------------------------------
;; Snippets — receives serialized snippet dicts from service
(defcomp
~admin/snippets-content
(&key snippets is-admin csrf)
(defcomp ~admin/snippets-content (&key snippets is-admin csrf)
(~admin/snippets-panel
:list (if
(empty? (or snippets (list)))
(~shared:misc/empty-state
:icon "fa fa-puzzle-piece"
:list (if (empty? (or snippets (list)))
(~shared:misc/empty-state :icon "fa fa-puzzle-piece"
:message "No snippets yet. Create one from the blog editor.")
(~admin/snippets-list
:rows (map
(lambda
(s)
(let-match
{:visibility vis* :delete_url delete-url :owner owner :can_delete can-delete :patch_url patch-url :name name}
s
(let*
((vis (or vis* "private"))
(badge-colours
(dict
"private"
"bg-stone-200 text-stone-700"
"shared"
"bg-blue-100 text-blue-700"
"admin"
"bg-amber-100 text-amber-700"))
(badge-cls
(or (get badge-colours vis) "bg-stone-200 text-stone-700")))
(~admin/snippet-row
:name name
:owner owner
:badge-cls badge-cls
:visibility vis
:extra (<>
(when
is-admin
(~admin/snippet-visibility-select
:patch-url patch-url
:hx-headers (str "{\"X-CSRFToken\": \"" csrf "\"}")
:options (<>
(~admin/snippet-option
:value "private"
:selected (= vis "private")
:label "private")
(~admin/snippet-option
:value "shared"
:selected (= vis "shared")
:label "shared")
(~admin/snippet-option
:value "admin"
:selected (= vis "admin")
:label "admin"))))
(when
can-delete
(~shared:misc/delete-btn
:url delete-url
:trigger-target "#snippets-list"
:title "Delete snippet?"
:text (str "Delete \"" name "\"?")
:sx-headers (str "{\"X-CSRFToken\": \"" csrf "\"}")
:cls "px-3 py-1 text-sm bg-red-200 hover:bg-red-300 text-red-800 rounded-full")))))))
:rows (map (lambda (s)
(let* ((badge-colours (dict
"private" "bg-stone-200 text-stone-700"
"shared" "bg-blue-100 text-blue-700"
"admin" "bg-amber-100 text-amber-700"))
(vis (or (get s "visibility") "private"))
(badge-cls (or (get badge-colours vis) "bg-stone-200 text-stone-700"))
(name (get s "name"))
(owner (get s "owner"))
(can-delete (get s "can_delete")))
(~admin/snippet-row
:name name :owner owner :badge-cls badge-cls :visibility vis
:extra (<>
(when is-admin
(~admin/snippet-visibility-select
:patch-url (get s "patch_url")
:hx-headers {:X-CSRFToken csrf}
:options (<>
(~admin/snippet-option :value "private" :selected (= vis "private") :label "private")
(~admin/snippet-option :value "shared" :selected (= vis "shared") :label "shared")
(~admin/snippet-option :value "admin" :selected (= vis "admin") :label "admin"))))
(when can-delete
(~shared:misc/delete-btn
:url (get s "delete_url")
:trigger-target "#snippets-list"
:title "Delete snippet?"
:text (str "Delete \u201c" name "\u201d?")
:sx-headers {:X-CSRFToken csrf}
:cls "px-3 py-1 text-sm bg-red-200 hover:bg-red-300 rounded text-red-800 flex-shrink-0"))))))
(or snippets (list)))))))
;; Menu Items — receives serialized menu item dicts from service
(defcomp
~admin/menu-items-content
(&key menu-items new-url csrf)
(defcomp ~admin/menu-items-content (&key menu-items new-url csrf)
(~admin/menu-items-panel
:new-url new-url
:list (if
(empty? (or menu-items (list)))
(~shared:misc/empty-state
:icon "fa fa-inbox"
:list (if (empty? (or menu-items (list)))
(~shared:misc/empty-state :icon "fa fa-inbox"
:message "No menu items yet. Add one to get started!")
(~admin/menu-items-list
:rows (map
(lambda
(mi)
(let-match
{:delete_url delete-url :url url :sort_order sort-order :edit_url edit-url :feature_image feature-image :label label}
mi
(~admin/menu-item-row
:img (~shared:misc/img-or-placeholder
:src feature-image
:alt label
:size-cls "w-12 h-12 rounded-full object-cover flex-shrink-0")
:label label
:slug url
:sort-order (str (or sort-order 0))
:edit-url edit-url
:delete-url delete-url
:confirm-text (str "Remove " label " from the menu?")
:hx-headers (str "{\"X-CSRFToken\": \"" csrf "\"}"))))
:rows (map (lambda (mi)
(~admin/menu-item-row
:img (~shared:misc/img-or-placeholder
:src (get mi "feature_image") :alt (get mi "label")
:size-cls "w-12 h-12 rounded-full object-cover flex-shrink-0")
:label (get mi "label")
:slug (get mi "url")
:sort-order (str (or (get mi "sort_order") 0))
:edit-url (get mi "edit_url")
:delete-url (get mi "delete_url")
:confirm-text (str "Remove " (get mi "label") " from the menu?")
:hx-headers {:X-CSRFToken csrf}))
(or menu-items (list)))))))
;; Tag Groups — receives serialized tag group data from service
(defcomp
~admin/tag-groups-content
(&key groups unassigned-tags create-url csrf)
(defcomp ~admin/tag-groups-content (&key groups unassigned-tags create-url csrf)
(~admin/tag-groups-main
:form (~admin/tag-groups-create-form :create-url create-url :csrf csrf)
:groups (if
(empty? (or groups (list)))
(~shared:misc/empty-state
:icon "fa fa-tags"
:message "No tag groups yet.")
:groups (if (empty? (or groups (list)))
(~shared:misc/empty-state :icon "fa fa-tags" :message "No tag groups yet.")
(~admin/tag-groups-list
:items (map
(lambda
(g)
(let-match
{:colour colour :sort_order sort-order* :feature_image fi :edit_href edit-href :slug slug* :name name}
g
(let*
((initial (slice (or name "?") 0 1))
(icon
(if
fi
(~admin/tag-group-icon-image :src fi :name name)
(~admin/tag-group-icon-color
:style (if
colour
(str "background:" colour)
"background:#e7e5e4")
:initial initial))))
(~admin/tag-group-li
:icon icon
:edit-href edit-href
:name name
:slug (or slug* "")
:sort-order (or sort-order* 0)))))
:items (map (lambda (g)
(let* ((fi (get g "feature_image"))
(colour (get g "colour"))
(name (get g "name"))
(initial (slice (or name "?") 0 1))
(icon (if fi
(~admin/tag-group-icon-image :src fi :name name)
(~admin/tag-group-icon-color
:style (if colour (str "background:" colour) "background:#e7e5e4")
:initial initial))))
(~admin/tag-group-li
:icon icon
:edit-href (get g "edit_href")
:name name
:slug (or (get g "slug") "")
:sort-order (or (get g "sort_order") 0))))
(or groups (list)))))
:unassigned (when
(not (empty? (or unassigned-tags (list))))
:unassigned (when (not (empty? (or unassigned-tags (list))))
(~admin/unassigned-tags
:heading (str (len (or unassigned-tags (list))) " Unassigned Tags")
:spans (map
(lambda (t) (~admin/unassigned-tag :name (get t "name")))
:spans (map (lambda (t)
(~admin/unassigned-tag :name (get t "name")))
(or unassigned-tags (list)))))))
;; Tag Group Edit — receives serialized tag group + tags from service
(defcomp
~admin/tag-group-edit-content
(&key group all-tags save-url delete-url csrf)
(defcomp ~admin/tag-group-edit-content (&key group all-tags save-url delete-url csrf)
(~admin/tag-group-edit-main
:edit-form (let-match
{:colour colour :sort_order sort-order :feature_image feature-image :name name}
group
(~admin/tag-group-edit-form
:save-url save-url
:csrf csrf
:name name
:colour colour
:sort-order sort-order
:feature-image feature-image
:tags (map
(lambda
(t)
(let-match
{:checked checked :feature_image t-feature-image :id tag-id :name t-name}
t
(~admin/tag-checkbox
:tag-id tag-id
:checked checked
:img (when
t-feature-image
(~admin/tag-checkbox-image :src t-feature-image))
:name t-name)))
(or all-tags (list)))))
:edit-form (~admin/tag-group-edit-form
:save-url save-url :csrf csrf
:name (get group "name")
:colour (get group "colour")
:sort-order (get group "sort_order")
:feature-image (get group "feature_image")
:tags (map (lambda (t)
(~admin/tag-checkbox
:tag-id (get t "id")
:checked (get t "checked")
:img (when (get t "feature_image")
(~admin/tag-checkbox-image :src (get t "feature_image")))
:name (get t "name")))
(or all-tags (list))))
:delete-form (~admin/tag-group-delete-form :delete-url delete-url :csrf csrf)))
;; ---------------------------------------------------------------------------
@@ -524,54 +400,31 @@
(code value)
value))))
(defcomp
~admin/data-scalar-table
(&key columns)
(div
:class "w-full overflow-x-auto sm:overflow-visible"
(table
:class "w-full table-fixed text-sm border border-neutral-200 rounded-xl overflow-hidden"
(thead
:class "bg-neutral-50/70"
(tr
(th :class "px-3 py-2 text-left font-medium w-40 sm:w-56" "Field")
(th :class "px-3 py-2 text-left font-medium" "Value")))
(defcomp ~admin/data-scalar-table (&key columns)
(div :class "w-full overflow-x-auto sm:overflow-visible"
(table :class "w-full table-fixed text-sm border border-neutral-200 rounded-xl overflow-hidden"
(thead :class "bg-neutral-50/70"
(tr (th :class "px-3 py-2 text-left font-medium w-40 sm:w-56" "Field")
(th :class "px-3 py-2 text-left font-medium" "Value")))
(tbody
(map
(lambda
(col)
(let-match
{:value value :key key :type type}
col
(tr
:class "border-t border-neutral-200 align-top"
(td :class "px-3 py-2 whitespace-nowrap text-neutral-600" key)
(td
:class "px-3 py-2 align-top"
(~admin/data-value-cell :value value :value-type type)))))
(map (lambda (col)
(tr :class "border-t border-neutral-200 align-top"
(td :class "px-3 py-2 whitespace-nowrap text-neutral-600 align-top" (get col "key"))
(td :class "px-3 py-2 align-top"
(~admin/data-value-cell :value (get col "value") :value-type (get col "type")))))
(or columns (list)))))))
(defcomp
~admin/data-relationship-item
(&key index summary children)
(tr
:class "border-t border-neutral-200 align-top"
(defcomp ~admin/data-relationship-item (&key index summary children)
(tr :class "border-t border-neutral-200 align-top"
(td :class "px-2 py-1 whitespace-nowrap align-top" (str index))
(td
:class "px-2 py-1 align-top"
(pre
:class "whitespace-pre-wrap break-words break-all text-xs"
(td :class "px-2 py-1 align-top"
(pre :class "whitespace-pre-wrap break-words break-all text-xs"
(code summary))
(when
children
(div
:class "mt-2 pl-3 border-l border-neutral-200"
(let-match
{:relationships relationships :columns columns}
children
(~admin/data-model-content
:columns columns
:relationships relationships)))))))
(when children
(div :class "mt-2 pl-3 border-l border-neutral-200"
(~admin/data-model-content
:columns (get children "columns")
:relationships (get children "relationships")))))))
(defcomp ~admin/data-relationship (&key name cardinality class-name loaded value)
(div :class "rounded-xl border border-neutral-200"
@@ -610,50 +463,29 @@
:columns (get (get value "children") "columns")
:relationships (get (get value "children") "relationships"))))))))))
(defcomp
~admin/data-model-content
(&key columns relationships)
(div
:class "space-y-4"
(defcomp ~admin/data-model-content (&key columns relationships)
(div :class "space-y-4"
(~admin/data-scalar-table :columns columns)
(when
(not (empty? (or relationships (list))))
(div
:class "space-y-3"
(map
(lambda
(rel)
(let-match
{:cardinality cardinality :class_name class-name :loaded loaded :value value :name name}
rel
(~admin/data-relationship
:name name
:cardinality cardinality
:class-name class-name
:loaded loaded
:value value)))
(when (not (empty? (or relationships (list))))
(div :class "space-y-3"
(map (lambda (rel)
(~admin/data-relationship
:name (get rel "name")
:cardinality (get rel "cardinality")
:class-name (get rel "class_name")
:loaded (get rel "loaded")
:value (get rel "value")))
relationships)))))
(defcomp
~admin/data-table-content
(&key tablename model-data)
(if
(not model-data)
(defcomp ~admin/data-table-content (&key tablename model-data)
(if (not model-data)
(div :class "px-4 py-8 text-stone-400" "No post data available.")
(div
:class "px-4 py-8"
(div
:class "mb-6 text-sm text-neutral-500"
"Model: "
(code "Post")
" • Table: "
(code tablename))
(let-match
{:relationships relationships :columns columns}
model-data
(~admin/data-model-content
:columns columns
:relationships relationships)))))
(div :class "px-4 py-8"
(div :class "mb-6 text-sm text-neutral-500"
"Model: " (code "Post") " \u2022 Table: " (code tablename))
(~admin/data-model-content
:columns (get model-data "columns")
:relationships (get model-data "relationships")))))
;; ---------------------------------------------------------------------------
;; Calendar month view for browsing/toggling entries (B1)
@@ -686,117 +518,59 @@
:sx-on:afterSwap "document.body.dispatchEvent(new CustomEvent('entryToggled'))"
(span :class "truncate block" name)))
(defcomp
~admin/calendar-view
(&key
cal-id
year
month-name
current-url
prev-month-url
prev-year-url
next-month-url
next-year-url
weekday-names
days
csrf)
(let*
((target (str "#calendar-view-" cal-id)))
(div
:id (str "calendar-view-" cal-id)
:sx-get current-url
:sx-trigger "entryToggled from:body"
:sx-swap "outerHTML"
(header
:class "flex items-center justify-center mb-4"
(nav
:class "flex items-center gap-2 text-xl"
(a
:class "px-2 py-1 hover:bg-stone-100 rounded"
:sx-get prev-year-url
:sx-target target
:sx-swap "outerHTML"
(defcomp ~admin/calendar-view (&key cal-id year month-name
current-url prev-month-url prev-year-url
next-month-url next-year-url
weekday-names days csrf)
(let* ((target (str "#calendar-view-" cal-id)))
(div :id (str "calendar-view-" cal-id)
:sx-get current-url :sx-trigger "entryToggled from:body" :sx-swap "outerHTML"
(header :class "flex items-center justify-center mb-4"
(nav :class "flex items-center gap-2 text-xl"
(a :class "px-2 py-1 hover:bg-stone-100 rounded"
:sx-get prev-year-url :sx-target target :sx-swap "outerHTML"
(raw! "&laquo;"))
(a
:class "px-2 py-1 hover:bg-stone-100 rounded"
:sx-get prev-month-url
:sx-target target
:sx-swap "outerHTML"
(a :class "px-2 py-1 hover:bg-stone-100 rounded"
:sx-get prev-month-url :sx-target target :sx-swap "outerHTML"
(raw! "&lsaquo;"))
(div :class "px-3 font-medium" (str month-name " " year))
(a
:class "px-2 py-1 hover:bg-stone-100 rounded"
:sx-get next-month-url
:sx-target target
:sx-swap "outerHTML"
(a :class "px-2 py-1 hover:bg-stone-100 rounded"
:sx-get next-month-url :sx-target target :sx-swap "outerHTML"
(raw! "&rsaquo;"))
(a
:class "px-2 py-1 hover:bg-stone-100 rounded"
:sx-get next-year-url
:sx-target target
:sx-swap "outerHTML"
(a :class "px-2 py-1 hover:bg-stone-100 rounded"
:sx-get next-year-url :sx-target target :sx-swap "outerHTML"
(raw! "&raquo;"))))
(div
:class "rounded border bg-white"
(div
:class "hidden sm:grid grid-cols-7 text-center text-xs font-semibold text-stone-700 bg-stone-50 border-b"
(map
(lambda (wd) (div :class "py-2" wd))
(or weekday-names (list))))
(div
:class "grid grid-cols-1 sm:grid-cols-7 gap-px bg-stone-200"
(map
(lambda
(day)
(let-match
{:entries entries* :in_month in-month :day day-num}
day
(let*
((extra-cls (if in-month "" " bg-stone-50 text-stone-400"))
(entries (or entries* (list))))
(div
:class (str "min-h-20 bg-white px-2 py-2 text-xs" extra-cls)
(div :class "font-medium mb-1" (str day-num))
(when
(not (empty? entries))
(div
:class "space-y-0.5"
(map
(lambda
(e)
(let-match
{:is_associated is-associated :toggle_url toggle-url :name name}
e
(if
is-associated
(~admin/cal-entry-associated
:name name
:toggle-url toggle-url
:csrf csrf)
(~admin/cal-entry-unassociated
:name name
:toggle-url toggle-url
:csrf csrf))))
entries)))))))
(div :class "rounded border bg-white"
(div :class "hidden sm:grid grid-cols-7 text-center text-xs font-semibold text-stone-700 bg-stone-50 border-b"
(map (lambda (wd) (div :class "py-2" wd)) (or weekday-names (list))))
(div :class "grid grid-cols-1 sm:grid-cols-7 gap-px bg-stone-200"
(map (lambda (day)
(let* ((extra-cls (if (get day "in_month") "" " bg-stone-50 text-stone-400"))
(entries (or (get day "entries") (list))))
(div :class (str "min-h-20 bg-white px-2 py-2 text-xs" extra-cls)
(div :class "font-medium mb-1" (str (get day "day")))
(when (not (empty? entries))
(div :class "space-y-0.5"
(map (lambda (e)
(if (get e "is_associated")
(~admin/cal-entry-associated
:name (get e "name") :toggle-url (get e "toggle_url") :csrf csrf)
(~admin/cal-entry-unassociated
:name (get e "name") :toggle-url (get e "toggle_url") :csrf csrf)))
entries))))))
(or days (list))))))))
;; ---------------------------------------------------------------------------
;; Nav entries OOB — renders associated entry/calendar items in scroll wrapper (B2)
;; ---------------------------------------------------------------------------
(defcomp
~admin/nav-entries-oob
(&key entries calendars)
(let*
((entry-list (or entries (list)))
(cal-list (or calendars (list)))
(has-items (or (not (empty? entry-list)) (not (empty? cal-list))))
(nav-cls
"justify-center cursor-pointer flex flex-row items-center gap-2 rounded bg-stone-200 text-black [.hover-capable_&]:hover:bg-yellow-300 aria-selected:bg-stone-500 aria-selected:text-white [.hover-capable_&[aria-selected=true]:hover]:bg-orange-500 p-2")
(scroll-hs
"on load or scroll if window.innerWidth >= 640 and my.scrollWidth > my.clientWidth remove .hidden from .entries-nav-arrow add .flex to .entries-nav-arrow else add .hidden to .entries-nav-arrow remove .flex from .entries-nav-arrow end"))
(if
(not has-items)
(defcomp ~admin/nav-entries-oob (&key entries calendars)
(let* ((entry-list (or entries (list)))
(cal-list (or calendars (list)))
(has-items (or (not (empty? entry-list)) (not (empty? cal-list))))
(nav-cls "justify-center cursor-pointer flex flex-row items-center gap-2 rounded bg-stone-200 text-black [.hover-capable_&]:hover:bg-yellow-300 aria-selected:bg-stone-500 aria-selected:text-white [.hover-capable_&[aria-selected=true]:hover]:bg-orange-500 p-2")
(scroll-hs "on load or scroll if window.innerWidth >= 640 and my.scrollWidth > my.clientWidth remove .hidden from .entries-nav-arrow add .flex to .entries-nav-arrow else add .hidden to .entries-nav-arrow remove .flex from .entries-nav-arrow end"))
(if (not has-items)
(~shared:nav/blog-nav-entries-empty)
(~shared:misc/scroll-nav-wrapper
:wrapper-id "entries-calendars-nav-wrapper"
@@ -806,27 +580,14 @@
:scroll-hs scroll-hs
:right-hs "on click set #associated-items-container.scrollLeft to #associated-items-container.scrollLeft + 200"
:items (<>
(map
(lambda
(e)
(let-match
{:href href :date_str date-str :name name}
e
(~shared:navigation/calendar-entry-nav
:href href
:nav-class nav-cls
:name name
:date-str date-str)))
(map (lambda (e)
(~shared:navigation/calendar-entry-nav
:href (get e "href") :nav-class nav-cls
:name (get e "name") :date-str (get e "date_str")))
entry-list)
(map
(lambda
(c)
(let-match
{:href href :name name}
c
(~shared:nav/blog-nav-calendar-item
:href href
:nav-cls nav-cls
:name name)))
(map (lambda (c)
(~shared:nav/blog-nav-calendar-item
:href (get c "href") :nav-cls nav-cls
:name (get c "name")))
cal-list))
:oob true))))

1
cart/config/app-config.sx
View File

@@ -1 +0,0 @@
(defconfig app {:market-root "/market" :host "https://rose-ash.com" :base-url "https://wholesale.suma.coop/" :base-login "https://wholesale.suma.coop/customer/account/login/" :slugs {:skip ("" "customer" "account" "checkout" "wishlist" "sales" "contact" "privacy-policy" "terms-and-conditions" "delivery" "catalogsearch" "quickorder" "apply" "search" "static" "media")} :categories {:allow {:Chilled "chilled" :Non-foods "non-foods" :Branded-Goods "branded-goods" :Frozen "frozen" :Basics "basics" :Supplements "supplements" :Christmas "christmas"}} :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")} :cart-root "/cart" :cache {:fs-root "/app/_snapshot"} :market-title "Market" :app-urls {:sx "https://sx.rose-ash.com" :account "https://account.rose-ash.com" :events "https://events.rose-ash.com" :federation "https://federation.rose-ash.com" :cart "https://cart.rose-ash.com" :orders "https://orders.rose-ash.com" :test "https://test.rose-ash.com" :blog "https://blog.rose-ash.com" :market "https://market.rose-ash.com"} :title "ROSE-ASH 2.0" :blog-root "/" :sumup {:merchant-code "ME4J6100" :currency "GBP" :webhook-secret (env-get "SUMUP_WEBHOOK_SECRET") :api-key (env-get "SUMUP_API_KEY")} :root "/rose-ash-wholefood-coop" :base-host "wholesale.suma.coop" :blog-title "all the news"})

8
deploy.sh
View File

@@ -63,12 +63,8 @@ for app in "${BUILD[@]}"; do
echo "=== $app ==="
docker build -f "$dir/Dockerfile" -t "$REGISTRY/$app:latest" .
docker push "$REGISTRY/$app:latest"
case "$app" in
sx_docs) svc="sx-web_sx_docs" ;;
*) svc="coop_$app" ;;
esac
docker service update --force "$svc" 2>/dev/null \
|| echo " (service $svc not running — will start on next stack deploy)"
docker service update --force "coop_$app" 2>/dev/null \
|| echo " (service coop_$app not running — will start on next stack deploy)"
echo ""
done

30
dev-pub.sh
View File

@@ -1,30 +0,0 @@
#!/usr/bin/env bash
set -euo pipefail
# Dev mode for sx-pub (SX-based ActivityPub)
# Bind-mounted source + auto-reload on externalnet
# Browse to pub.sx-web.org
#
# Usage:
# ./dev-pub.sh # Start sx-pub dev
# ./dev-pub.sh down # Stop
# ./dev-pub.sh logs # Tail logs
# ./dev-pub.sh --build # Rebuild image then start
COMPOSE="docker compose -p sx-pub -f docker-compose.dev-pub.yml"
case "${1:-up}" in
down)
$COMPOSE down
;;
logs)
$COMPOSE logs -f sx_pub
;;
*)
BUILD_FLAG=""
if [[ "${1:-}" == "--build" ]]; then
BUILD_FLAG="--build"
fi
$COMPOSE up $BUILD_FLAG
;;
esac

37
dev-sx-native.sh
View File

@@ -1,37 +0,0 @@
#!/usr/bin/env bash
set -euo pipefail
# Dev mode for sx_docs using the native OCaml HTTP server.
# No Docker, no Python, no Quart — just the OCaml binary.
# Caddy still handles TLS and static files on externalnet.
#
# Usage:
# ./dev-sx-native.sh # Start on port 8013
# ./dev-sx-native.sh 8014 # Start on custom port
# ./dev-sx-native.sh --build # Rebuild OCaml binary first
PORT="${1:-8013}"
BUILD=false
if [[ "${1:-}" == "--build" ]]; then
BUILD=true
PORT="${2:-8013}"
fi
# Build if requested or binary doesn't exist
BIN="hosts/ocaml/_build/default/bin/sx_server.exe"
if [[ "$BUILD" == true ]] || [[ ! -f "$BIN" ]]; then
echo "[dev-sx-native] Building OCaml binary..."
cd hosts/ocaml && eval "$(opam env)" && dune build bin/sx_server.exe && cd ../..
echo "[dev-sx-native] Build complete"
fi
# Set project dir so the server finds spec/, lib/, web/, sx/sx/
export SX_PROJECT_DIR="$(pwd)"
echo "[dev-sx-native] Starting OCaml HTTP server on port $PORT"
echo "[dev-sx-native] project=$SX_PROJECT_DIR"
echo "[dev-sx-native] binary=$BIN"
echo ""
exec "$BIN" --http "$PORT"

114
docker-compose.dev-pub.yml
View File

@@ -1,114 +0,0 @@
# Dev mode for sx-pub (SX-based ActivityPub)
# Starts as sx_docs clone — AP protocol built in SX from scratch
# Accessible at pub.sx-web.org via Caddy on externalnet
# Own DB + pgbouncer + IPFS node
services:
sx_pub:
image: registry.rose-ash.com:5000/sx_docs:latest
environment:
SX_STANDALONE: "true"
SECRET_KEY: "${SECRET_KEY:-pub-dev-secret}"
REDIS_URL: redis://redis:6379/0
DATABASE_URL: postgresql+asyncpg://postgres:change-me@pgbouncer:5432/sx_pub
ALEMBIC_DATABASE_URL: postgresql+psycopg://postgres:change-me@db:5432/sx_pub
SX_PUB_DOMAIN: pub.sx-web.org
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_DEV: "1"
OCAMLRUNPARAM: "b"
IPFS_API: http://ipfs:5001
ports:
- "8014:8000"
volumes:
- /root/sx-pub/_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
- ./sx/__init__.py:/app/__init__.py:ro
# Spec + web SX files
- ./spec:/app/spec:ro
- ./web:/app/web:ro
# OCaml SX kernel binary
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server: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
depends_on:
- pgbouncer
- redis
- ipfs
networks:
- externalnet
- default
restart: unless-stopped
db:
image: postgres:16
environment:
POSTGRES_USER: postgres
POSTGRES_PASSWORD: change-me
POSTGRES_DB: sx_pub
volumes:
- db_data:/var/lib/postgresql/data
restart: unless-stopped
pgbouncer:
image: edoburu/pgbouncer:latest
environment:
DB_HOST: db
DB_PORT: "5432"
DB_USER: postgres
DB_PASSWORD: change-me
POOL_MODE: transaction
DEFAULT_POOL_SIZE: "10"
MAX_CLIENT_CONN: "100"
AUTH_TYPE: plain
depends_on:
- db
restart: unless-stopped
ipfs:
image: ipfs/kubo:latest
volumes:
- ipfs_data:/data/ipfs
restart: unless-stopped
redis:
image: redis:7-alpine
restart: unless-stopped
volumes:
db_data:
ipfs_data:
networks:
externalnet:
external: true

17
docker-compose.dev-sx-native.yml
View File

@@ -1,17 +0,0 @@
# Native OCaml HTTP server for sx_docs — no Python, no Quart
# Overrides dev-sx.yml entrypoint to use sx_server --http
#
# Usage:
# docker compose -p sx-dev -f docker-compose.dev-sx.yml -f docker-compose.dev-sx-native.yml up
services:
sx_docs:
entrypoint: ["/app/bin/sx_server", "--http", "8000"]
environment:
SX_PROJECT_DIR: /app
SX_SPEC_DIR: /app/spec
SX_LIB_DIR: /app/lib
SX_WEB_DIR: /app/web
volumes:
# Static files (CSS, JS, WASM) — served by Caddy on externalnet
- ./shared/static:/app/static:ro

58
docker-compose.dev-sx.yml
View File

@@ -1,31 +1,71 @@
# Native OCaml SX server — no Python, no Quart
# 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
entrypoint: ["/app/bin/sx_server", "--http", "8000"]
working_dir: /app
environment:
SX_PROJECT_DIR: /app
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_DEV: "1"
OCAMLRUNPARAM: "b"
ports:
- "8013:8000"
volumes:
# SX source files (hot-reload on restart)
- /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
# Spec + lib + web SX files (loaded by OCaml kernel)
- ./spec:/app/spec:ro
- ./lib:/app/lib:ro
- ./web:/app/web:ro
- ./sx/sx:/app/sx:ro
- ./sx/sxc:/app/sxc:ro
- ./shared:/app/shared:ro
# OCaml binary (rebuild with: cd hosts/ocaml && eval $(opam env) && dune build)
# 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

1
events/config/app-config.sx
View File

@@ -1 +0,0 @@
(defconfig app {:market-root "/market" :host "https://rose-ash.com" :base-url "https://wholesale.suma.coop/" :base-login "https://wholesale.suma.coop/customer/account/login/" :slugs {:skip ("" "customer" "account" "checkout" "wishlist" "sales" "contact" "privacy-policy" "terms-and-conditions" "delivery" "catalogsearch" "quickorder" "apply" "search" "static" "media")} :categories {:allow {:Chilled "chilled" :Non-foods "non-foods" :Branded-Goods "branded-goods" :Frozen "frozen" :Basics "basics" :Supplements "supplements" :Christmas "christmas"}} :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")} :cart-root "/cart" :cache {:fs-root "/app/_snapshot"} :market-title "Market" :app-urls {:sx "https://sx.rose-ash.com" :account "https://account.rose-ash.com" :events "https://events.rose-ash.com" :federation "https://federation.rose-ash.com" :cart "https://cart.rose-ash.com" :orders "https://orders.rose-ash.com" :test "https://test.rose-ash.com" :blog "https://blog.rose-ash.com" :market "https://market.rose-ash.com"} :title "ROSE-ASH 2.0" :blog-root "/" :sumup {:merchant-code "ME4J6100" :currency "GBP" :webhook-secret (env-get "SUMUP_WEBHOOK_SECRET") :api-key (env-get "SUMUP_API_KEY")} :root "/rose-ash-wholefood-coop" :base-host "wholesale.suma.coop" :blog-title "all the news"})

184
events/sx/entries.sx
View File

@@ -159,147 +159,91 @@
:btn (~page/tw-plus))))))
;; Entry card (list view) from data
(defcomp
~entries/entry-card-from-data
(&key
entry-href
name
day-href
page-badge-href
page-badge-title
cal-name
date-str
start-time
end-time
is-page-scoped
cost
has-ticket
ticket-data)
(defcomp ~entries/entry-card-from-data (&key entry-href name day-href
page-badge-href page-badge-title cal-name
date-str start-time end-time is-page-scoped
cost has-ticket ticket-data)
(~entries/entry-card
:title (if
entry-href
:title (if entry-href
(~entries/entry-title-linked :href entry-href :name name)
(~entries/entry-title-plain :name name))
:badges (<>
(when
page-badge-title
(~entries/entry-page-badge
:href page-badge-href
:title page-badge-title))
(when cal-name (~entries/entry-cal-badge :name cal-name)))
(when page-badge-title
(~entries/entry-page-badge :href page-badge-href :title page-badge-title))
(when cal-name
(~entries/entry-cal-badge :name cal-name)))
:time-parts (<>
(when
(and day-href (not is-page-scoped))
(when (and day-href (not is-page-scoped))
(~entries/entry-time-linked :href day-href :date-str date-str))
(when
(and (not day-href) (not is-page-scoped) date-str)
(when (and (not day-href) (not is-page-scoped) date-str)
(~entries/entry-time-plain :date-str date-str))
start-time
(when end-time (str " – " end-time)))
(when end-time (str " \u2013 " end-time)))
:cost (when cost (~entries/entry-cost :cost cost))
:widget (when
has-ticket
(let-match
{:csrf csrf :entry-id entry-id :qty qty :price price :ticket-url ticket-url}
ticket-data
(~entries/entry-widget-wrapper
:widget (~entries/tw-widget-from-data
:entry-id entry-id
:price price
:qty qty
:ticket-url ticket-url
:csrf csrf))))))
:widget (when has-ticket
(~entries/entry-widget-wrapper
:widget (~entries/tw-widget-from-data
:entry-id (get ticket-data "entry-id")
:price (get ticket-data "price")
:qty (get ticket-data "qty")
:ticket-url (get ticket-data "ticket-url")
:csrf (get ticket-data "csrf"))))))
;; Entry card (tile view) from data
(defcomp
~entries/entry-card-tile-from-data
(&key
entry-href
name
day-href
page-badge-href
page-badge-title
cal-name
date-str
time-str
cost
has-ticket
ticket-data)
(defcomp ~entries/entry-card-tile-from-data (&key entry-href name day-href
page-badge-href page-badge-title cal-name
date-str time-str
cost has-ticket ticket-data)
(~entries/entry-card-tile
:title (if
entry-href
:title (if entry-href
(~entries/entry-title-tile-linked :href entry-href :name name)
(~entries/entry-title-tile-plain :name name))
:badges (<>
(when
page-badge-title
(~entries/entry-page-badge
:href page-badge-href
:title page-badge-title))
(when cal-name (~entries/entry-cal-badge :name cal-name)))
(when page-badge-title
(~entries/entry-page-badge :href page-badge-href :title page-badge-title))
(when cal-name
(~entries/entry-cal-badge :name cal-name)))
:time time-str
:cost (when cost (~entries/entry-cost :cost cost))
:widget (when
has-ticket
(let-match
{:csrf csrf :entry-id entry-id :qty qty :price price :ticket-url ticket-url}
ticket-data
(~entries/entry-tile-widget-wrapper
:widget (~entries/tw-widget-from-data
:entry-id entry-id
:price price
:qty qty
:ticket-url ticket-url
:csrf csrf))))))
:widget (when has-ticket
(~entries/entry-tile-widget-wrapper
:widget (~entries/tw-widget-from-data
:entry-id (get ticket-data "entry-id")
:price (get ticket-data "price")
:qty (get ticket-data "qty")
:ticket-url (get ticket-data "ticket-url")
:csrf (get ticket-data "csrf"))))))
;; Entry cards list (with date separators + sentinel) from data
(defcomp
~entries/entry-cards-from-data
(&key items view page has-more next-url)
(defcomp ~entries/entry-cards-from-data (&key items view page has-more next-url)
(<>
(map
(lambda
(item)
(let-match
{:date-str date-str :time-str time-str :has-ticket has-ticket :is-separator is-separator :ticket-data ticket-data :day-href day-href :page-badge-title page-badge-title :entry-href entry-href :start-time start-time :end-time end-time :is-page-scoped is-page-scoped :page-badge-href page-badge-href :cal-name cal-name :cost cost :name name}
item
(if
is-separator
(~entries/date-separator :date-str date-str)
(if
(= view "tile")
(~entries/entry-card-tile-from-data
:entry-href entry-href
:name name
:day-href day-href
:page-badge-href page-badge-href
:page-badge-title page-badge-title
:cal-name cal-name
:date-str date-str
:time-str time-str
:cost cost
:has-ticket has-ticket
:ticket-data ticket-data)
(~entries/entry-card-from-data
:entry-href entry-href
:name name
:day-href day-href
:page-badge-href page-badge-href
:page-badge-title page-badge-title
:cal-name cal-name
:date-str date-str
:start-time start-time
:end-time end-time
:is-page-scoped is-page-scoped
:cost cost
:has-ticket has-ticket
:ticket-data ticket-data)))))
(map (lambda (item)
(if (get item "is-separator")
(~entries/date-separator :date-str (get item "date-str"))
(if (= view "tile")
(~entries/entry-card-tile-from-data
:entry-href (get item "entry-href") :name (get item "name")
:day-href (get item "day-href")
:page-badge-href (get item "page-badge-href")
:page-badge-title (get item "page-badge-title")
:cal-name (get item "cal-name")
:date-str (get item "date-str") :time-str (get item "time-str")
:cost (get item "cost") :has-ticket (get item "has-ticket")
:ticket-data (get item "ticket-data"))
(~entries/entry-card-from-data
:entry-href (get item "entry-href") :name (get item "name")
:day-href (get item "day-href")
:page-badge-href (get item "page-badge-href")
:page-badge-title (get item "page-badge-title")
:cal-name (get item "cal-name")
:date-str (get item "date-str")
:start-time (get item "start-time") :end-time (get item "end-time")
:is-page-scoped (get item "is-page-scoped")
:cost (get item "cost") :has-ticket (get item "has-ticket")
:ticket-data (get item "ticket-data")))))
(or items (list)))
(when
has-more
(~shared:misc/sentinel-simple
:id (str "sentinel-" page)
:next-url next-url))))
(when has-more
(~shared:misc/sentinel-simple :id (str "sentinel-" page) :next-url next-url))))
;; Events main panel (toggle + cards grid) from data
(defcomp ~entries/main-panel-from-data (&key toggle items view page has-more next-url)

49
events/sx/forms.sx
View File

@@ -323,43 +323,28 @@
;; ---------------------------------------------------------------------------
;; Day checkboxes from data — replaces Python loop
(defcomp
~forms/day-checkboxes-from-data
(&key days-data all-checked)
(defcomp ~forms/day-checkboxes-from-data (&key days-data all-checked)
(<>
(~forms/day-all-checkbox :checked (when all-checked "checked"))
(map
(lambda
(d)
(let-match
{:checked checked :label label :name name}
d
(~forms/day-checkbox
:name name
:label label
:checked (when checked "checked"))))
(map (lambda (d)
(~forms/day-checkbox
:name (get d "name")
:label (get d "label")
:checked (when (get d "checked") "checked")))
(or days-data (list)))))
;; Slot options from data — replaces _slot_options_html Python loop
(defcomp
~forms/slot-options-from-data
(&key slots)
(<>
(map
(lambda
(s)
(let-match
{:data-end data-end :data-flexible data-flexible :selected selected :value value :data-cost data-cost :label label :data-start data-start}
s
(~forms/slot-option
:value value
:data-start data-start
:data-end data-end
:data-flexible data-flexible
:data-cost data-cost
:selected selected
:label label)))
(or slots (list)))))
(defcomp ~forms/slot-options-from-data (&key slots)
(<> (map (lambda (s)
(~forms/slot-option
:value (get s "value")
:data-start (get s "data-start")
:data-end (get s "data-end")
:data-flexible (get s "data-flexible")
:data-cost (get s "data-cost")
:selected (get s "selected")
:label (get s "label")))
(or slots (list)))))
;; Slot picker from data — wraps picker + options
(defcomp ~forms/slot-picker-from-data (&key id slots)

338
events/sx/layouts.sx
View File

@@ -5,247 +5,155 @@
;; Auto-fetching header macros — calendar, day, entry, slot, tickets
;; ---------------------------------------------------------------------------
(defmacro
~events-calendar-header-auto
(oob)
(defmacro ~events-calendar-header-auto (oob)
"Calendar header row using (events-calendar-ctx)."
(quasiquote
(let
((__cal (events-calendar-ctx)) (__sc (select-colours)))
(let-match
{:description description :slug slug :name name}
__cal
(when
slug
(~shared:layout/menu-row-sx
:id "calendar-row"
:level 3
:link-href (url-for "calendar.get" :calendar-slug slug)
:link-label-content (~header/calendar-label :name name :description description)
:nav (<>
(~shared:layout/nav-link
:href (url-for "defpage_slots_listing" :calendar-slug slug)
:icon "fa fa-clock"
:label "Slots"
:select-colours __sc)
(let
((__rights (app-rights)))
(when
(get __rights "admin")
(~shared:layout/nav-link
:href (url-for "defpage_calendar_admin" :calendar-slug slug)
:icon "fa fa-cog"
:select-colours __sc))))
:child-id "calendar-header-child"
:oob (unquote oob)))))))
(let ((__cal (events-calendar-ctx))
(__sc (select-colours)))
(when (get __cal "slug")
(~shared:layout/menu-row-sx :id "calendar-row" :level 3
:link-href (url-for "calendar.get"
:calendar-slug (get __cal "slug"))
:link-label-content (~header/calendar-label
:name (get __cal "name")
:description (get __cal "description"))
:nav (<>
(~shared:layout/nav-link :href (url-for "defpage_slots_listing"
:calendar-slug (get __cal "slug"))
:icon "fa fa-clock" :label "Slots"
:select-colours __sc)
(let ((__rights (app-rights)))
(when (get __rights "admin")
(~shared:layout/nav-link :href (url-for "defpage_calendar_admin"
:calendar-slug (get __cal "slug"))
:icon "fa fa-cog"
:select-colours __sc))))
:child-id "calendar-header-child"
:oob (unquote oob))))))
(defmacro
~events-calendar-admin-header-auto
(oob)
(defmacro ~events-calendar-admin-header-auto (oob)
"Calendar admin header row."
(quasiquote
(let
((__cal (events-calendar-ctx)) (__sc (select-colours)))
(let-match
{:slug slug}
__cal
(when
slug
(~shared:layout/menu-row-sx
:id "calendar-admin-row"
:level 4
:link-label "admin"
:icon "fa fa-cog"
:nav (<>
(~shared:layout/nav-link
:href (url-for "defpage_slots_listing" :calendar-slug slug)
:label "slots"
:select-colours __sc)
(~shared:layout/nav-link
:href (url-for
"calendar.admin.calendar_description_edit"
:calendar-slug slug)
:label "description"
:select-colours __sc))
:child-id "calendar-admin-header-child"
:oob (unquote oob)))))))
(let ((__cal (events-calendar-ctx))
(__sc (select-colours)))
(when (get __cal "slug")
(~shared:layout/menu-row-sx :id "calendar-admin-row" :level 4
:link-label "admin" :icon "fa fa-cog"
:nav (<>
(~shared:layout/nav-link :href (url-for "defpage_slots_listing"
:calendar-slug (get __cal "slug"))
:label "slots" :select-colours __sc)
(~shared:layout/nav-link :href (url-for "calendar.admin.calendar_description_edit"
:calendar-slug (get __cal "slug"))
:label "description" :select-colours __sc))
:child-id "calendar-admin-header-child"
:oob (unquote oob))))))
(defmacro
~events-day-header-auto
(oob)
(defmacro ~events-day-header-auto (oob)
"Day header row using (events-day-ctx)."
(quasiquote
(let
((__day (events-day-ctx)) (__cal (events-calendar-ctx)))
(let-match
{:date-str date-str :nav nav :year year :day day :month month}
__day
(when
date-str
(let-match
{:slug cal-slug}
__cal
(~shared:layout/menu-row-sx
:id "day-row"
:level 4
:link-href (url-for
"calendar.day.show_day"
:calendar-slug cal-slug
:year year
:month month
:day day)
:link-label-content (~header/day-label :date-str date-str)
:nav nav
:child-id "day-header-child"
:oob (unquote oob))))))))
(let ((__day (events-day-ctx))
(__cal (events-calendar-ctx)))
(when (get __day "date-str")
(~shared:layout/menu-row-sx :id "day-row" :level 4
:link-href (url-for "calendar.day.show_day"
:calendar-slug (get __cal "slug")
:year (get __day "year")
:month (get __day "month")
:day (get __day "day"))
:link-label-content (~header/day-label
:date-str (get __day "date-str"))
:nav (get __day "nav")
:child-id "day-header-child"
:oob (unquote oob))))))
(defmacro
~events-day-admin-header-auto
(oob)
(defmacro ~events-day-admin-header-auto (oob)
"Day admin header row."
(quasiquote
(let
((__day (events-day-ctx)) (__cal (events-calendar-ctx)))
(let-match
{:date-str date-str :year year :day day :month month}
__day
(when
date-str
(let-match
{:slug cal-slug}
__cal
(~shared:layout/menu-row-sx
:id "day-admin-row"
:level 5
:link-href (url-for
"defpage_day_admin"
:calendar-slug cal-slug
:year year
:month month
:day day)
:link-label "admin"
:icon "fa fa-cog"
:child-id "day-admin-header-child"
:oob (unquote oob))))))))
(let ((__day (events-day-ctx))
(__cal (events-calendar-ctx)))
(when (get __day "date-str")
(~shared:layout/menu-row-sx :id "day-admin-row" :level 5
:link-href (url-for "defpage_day_admin"
:calendar-slug (get __cal "slug")
:year (get __day "year")
:month (get __day "month")
:day (get __day "day"))
:link-label "admin" :icon "fa fa-cog"
:child-id "day-admin-header-child"
:oob (unquote oob))))))
(defmacro
~events-entry-header-auto
(oob)
(defmacro ~events-entry-header-auto (oob)
"Entry header row using (events-entry-ctx)."
(quasiquote
(let
((__ectx (events-entry-ctx)))
(let-match
{:time-str time-str :nav nav :link-href link-href :id id :name name}
__ectx
(when
id
(~shared:layout/menu-row-sx
:id "entry-row"
:level 5
:link-href link-href
:link-label-content (~header/entry-label
:entry-id id
:title (~admin/entry-title :name name)
:times (~admin/entry-times :time-str time-str))
:nav nav
:child-id "entry-header-child"
:oob (unquote oob)))))))
(let ((__ectx (events-entry-ctx)))
(when (get __ectx "id")
(~shared:layout/menu-row-sx :id "entry-row" :level 5
:link-href (get __ectx "link-href")
:link-label-content (~header/entry-label
:entry-id (get __ectx "id")
:title (~admin/entry-title :name (get __ectx "name"))
:times (~admin/entry-times :time-str (get __ectx "time-str")))
:nav (get __ectx "nav")
:child-id "entry-header-child"
:oob (unquote oob))))))
(defmacro
~events-entry-admin-header-auto
(oob)
(defmacro ~events-entry-admin-header-auto (oob)
"Entry admin header row."
(quasiquote
(let
((__ectx (events-entry-ctx)))
(let-match
{:admin-href admin-href :is-admin is-admin :ticket-types-href ticket-types-href :select-colours select-colours :id id}
__ectx
(when
id
(~shared:layout/menu-row-sx
:id "entry-admin-row"
:level 6
:link-href admin-href
:link-label "admin"
:icon "fa fa-cog"
:nav (when
is-admin
(~shared:layout/nav-link
:href ticket-types-href
:label "ticket_types"
:select-colours select-colours))
:child-id "entry-admin-header-child"
:oob (unquote oob)))))))
(let ((__ectx (events-entry-ctx)))
(when (get __ectx "id")
(~shared:layout/menu-row-sx :id "entry-admin-row" :level 6
:link-href (get __ectx "admin-href")
:link-label "admin" :icon "fa fa-cog"
:nav (when (get __ectx "is-admin")
(~shared:layout/nav-link :href (get __ectx "ticket-types-href")
:label "ticket_types"
:select-colours (get __ectx "select-colours")))
:child-id "entry-admin-header-child"
:oob (unquote oob))))))
(defmacro
~events-slot-header-auto
(oob)
(defmacro ~events-slot-header-auto (oob)
"Slot detail header row using (events-slot-ctx)."
(quasiquote
(let
((__slot (events-slot-ctx)))
(let-match
{:description description :name name}
__slot
(when
name
(~shared:layout/menu-row-sx
:id "slot-row"
:level 5
:link-label-content (~header/slot-label :name name :description description)
:child-id "slot-header-child"
:oob (unquote oob)))))))
(let ((__slot (events-slot-ctx)))
(when (get __slot "name")
(~shared:layout/menu-row-sx :id "slot-row" :level 5
:link-label-content (~header/slot-label
:name (get __slot "name")
:description (get __slot "description"))
:child-id "slot-header-child"
:oob (unquote oob))))))
(defmacro
~events-ticket-types-header-auto
(oob)
(defmacro ~events-ticket-types-header-auto (oob)
"Ticket types header row."
(quasiquote
(let
((__ectx (events-entry-ctx)) (__cal (events-calendar-ctx)))
(let-match
{:ticket-types-href ticket-types-href :id id}
__ectx
(when
id
(~shared:layout/menu-row-sx
:id "ticket_types-row"
:level 7
:link-href ticket-types-href
:link-label-content (<>
(i :class "fa fa-ticket")
(div :class "shrink-0" "ticket types"))
:nav (~forms/admin-placeholder-nav)
:child-id "ticket_type-header-child"
:oob (unquote oob)))))))
(let ((__ectx (events-entry-ctx))
(__cal (events-calendar-ctx)))
(when (get __ectx "id")
(~shared:layout/menu-row-sx :id "ticket_types-row" :level 7
:link-href (get __ectx "ticket-types-href")
:link-label-content (<>
(i :class "fa fa-ticket")
(div :class "shrink-0" "ticket types"))
:nav (~forms/admin-placeholder-nav)
:child-id "ticket_type-header-child"
:oob (unquote oob))))))
(defmacro
~events-ticket-type-header-auto
(oob)
(defmacro ~events-ticket-type-header-auto (oob)
"Single ticket type header row using (events-ticket-type-ctx)."
(quasiquote
(let
((__tt (events-ticket-type-ctx)))
(let-match
{:link-href link-href :id id :name name}
__tt
(when
id
(~shared:layout/menu-row-sx
:id "ticket_type-row"
:level 8
:link-href link-href
:link-label-content (div
:class "flex flex-col md:flex-row md:gap-2 items-baseline"
(div
:class "flex flex-row items-center gap-2"
(i :class "fa fa-ticket")
(div :class "shrink-0" name)))
:nav (~forms/admin-placeholder-nav)
:child-id "ticket_type-header-child-inner"
:oob (unquote oob)))))))
(let ((__tt (events-ticket-type-ctx)))
(when (get __tt "id")
(~shared:layout/menu-row-sx :id "ticket_type-row" :level 8
:link-href (get __tt "link-href")
:link-label-content (div :class "flex flex-col md:flex-row md:gap-2 items-center"
(div :class "flex flex-row items-center gap-2"
(i :class "fa fa-ticket")
(div :class "shrink-0" (get __tt "name"))))
:nav (~forms/admin-placeholder-nav)
:child-id "ticket_type-header-child-inner"
:oob (unquote oob))))))
(defmacro ~events-markets-header-auto (oob)
"Markets section header row."

334
events/sx/page.sx
View File

@@ -98,47 +98,24 @@
(~page/slot-description-oob :description (or description "")))))
;; Slots table from data
(defcomp
~page/slots-table-from-data
(&key
list-container
slots
pre-action
add-url
tr-cls
pill-cls
action-btn
hx-select
csrf-hdr)
(defcomp ~page/slots-table-from-data (&key list-container slots pre-action add-url
tr-cls pill-cls action-btn hx-select csrf-hdr)
(~page/slots-table
:list-container list-container
:rows (if
(empty? (or slots (list)))
:rows (if (empty? (or slots (list)))
(~page/slots-empty-row)
(<>
(map
(lambda
(s)
(let-match
{:slot-name slot-name :time-str time-str :flexible flexible :description description :days days :cost-str cost-str :del-url del-url :slot-href slot-href}
s
(~page/slots-row
:tr-cls tr-cls
:slot-href slot-href
:pill-cls pill-cls
:hx-select hx-select
:slot-name slot-name
:description description
:flexible flexible
:days (~page/days-pills-from-data :days days)
:time-str time-str
:cost-str cost-str
:action-btn action-btn
:del-url del-url
:csrf-hdr csrf-hdr)))
(or slots (list)))))
:pre-action pre-action
:add-url add-url))
(<> (map (lambda (s)
(~page/slots-row
:tr-cls tr-cls :slot-href (get s "slot-href")
:pill-cls pill-cls :hx-select hx-select
:slot-name (get s "slot-name") :description (get s "description")
:flexible (get s "flexible")
:days (~page/days-pills-from-data :days (get s "days"))
:time-str (get s "time-str")
:cost-str (get s "cost-str") :action-btn action-btn
:del-url (get s "del-url") :csrf-hdr csrf-hdr))
(or slots (list)))))
:pre-action pre-action :add-url add-url))
(defcomp ~page/ticket-type-col (&key label value)
(div :class "flex flex-col"
@@ -226,87 +203,47 @@
:onclick hide-js "Cancel"))))
;; Data-driven buy form — Python passes pre-resolved data, .sx does layout + iteration
(defcomp
~page/buy-form
(&key
entry-id
info-sold
info-remaining
info-basket
ticket-types
user-ticket-counts-by-type
user-ticket-count
price-str
adjust-url
csrf
state
my-tickets-href)
(if
(!= state "confirmed")
(defcomp ~page/buy-form (&key entry-id info-sold info-remaining info-basket
ticket-types user-ticket-counts-by-type
user-ticket-count price-str adjust-url csrf state
my-tickets-href)
(if (!= state "confirmed")
(~page/buy-not-confirmed :entry-id (str entry-id))
(let
((eid-s (str entry-id)) (target (str "#ticket-buy-" entry-id)))
(div
:id (str "ticket-buy-" entry-id)
:class "rounded-xl border border-stone-200 bg-white p-4"
(h3
:class "text-sm font-semibold text-stone-700 mb-3"
(i :class "fa fa-ticket mr-1" :aria-hidden "true")
"Tickets")
(when
(or info-sold info-remaining info-basket)
(div
:class "flex items-center gap-3 mb-3 text-xs text-stone-500"
(let ((eid-s (str entry-id))
(target (str "#ticket-buy-" entry-id)))
(div :id (str "ticket-buy-" entry-id) :class "rounded-xl border border-stone-200 bg-white p-4"
(h3 :class "text-sm font-semibold text-stone-700 mb-3"
(i :class "fa fa-ticket mr-1" :aria-hidden "true") "Tickets")
;; Info bar
(when (or info-sold info-remaining info-basket)
(div :class "flex items-center gap-3 mb-3 text-xs text-stone-500"
(when info-sold (span (str info-sold " sold")))
(when info-remaining (span (str info-remaining " remaining")))
(when
info-basket
(span
:class "text-emerald-600 font-medium"
(i
:class "fa fa-shopping-cart text-[0.6rem]"
:aria-hidden "true")
(when info-basket
(span :class "text-emerald-600 font-medium"
(i :class "fa fa-shopping-cart text-[0.6rem]" :aria-hidden "true")
(str " " info-basket " in basket")))))
(if
(and ticket-types (not (empty? ticket-types)))
(div
:class "space-y-2"
(map
(fn
(tt)
(let-match
{:cost_str cost-str :id tt-id :name tt-name}
tt
(let
((tt-count (if user-ticket-counts-by-type (get user-ticket-counts-by-type (str tt-id) 0) 0)))
(div
:class "flex items-center justify-between p-3 rounded-lg bg-stone-50 border border-stone-100"
(div
(div :class "font-medium text-sm" tt-name)
(div :class "text-xs text-stone-500" cost-str))
(~page/adjust-inline
:csrf csrf
:adjust-url adjust-url
:target target
:entry-id eid-s
:count tt-count
:ticket-type-id tt-id
:my-tickets-href my-tickets-href)))))
;; Body — multi-type or default
(if (and ticket-types (not (empty? ticket-types)))
(div :class "space-y-2"
(map (fn (tt)
(let ((tt-count (if user-ticket-counts-by-type
(get user-ticket-counts-by-type (str (get tt "id")) 0)
0))
(tt-id (get tt "id")))
(div :class "flex items-center justify-between p-3 rounded-lg bg-stone-50 border border-stone-100"
(div (div :class "font-medium text-sm" (get tt "name"))
(div :class "text-xs text-stone-500" (get tt "cost_str")))
(~page/adjust-inline :csrf csrf :adjust-url adjust-url :target target
:entry-id eid-s :count tt-count :ticket-type-id tt-id
:my-tickets-href my-tickets-href))))
ticket-types))
(<>
(div
:class "flex items-center justify-between mb-4"
(div
(span :class "font-medium text-green-600" price-str)
(span :class "text-sm text-stone-500 ml-2" "per ticket")))
(~page/adjust-inline
:csrf csrf
:adjust-url adjust-url
:target target
:entry-id eid-s
:count (if user-ticket-count user-ticket-count 0)
:ticket-type-id nil
:my-tickets-href my-tickets-href)))))))
(<> (div :class "flex items-center justify-between mb-4"
(div (span :class "font-medium text-green-600" price-str)
(span :class "text-sm text-stone-500 ml-2" "per ticket")))
(~page/adjust-inline :csrf csrf :adjust-url adjust-url :target target
:entry-id eid-s :count (if user-ticket-count user-ticket-count 0)
:ticket-type-id nil :my-tickets-href my-tickets-href)))))))
;; Inline +/- controls (used by both default and per-type)
(defcomp ~page/adjust-inline (&key csrf adjust-url target entry-id count ticket-type-id my-tickets-href)
@@ -348,53 +285,26 @@
"Tickets available once this event is confirmed."))
(defcomp
~page/buy-result
(&key entry-id tickets remaining my-tickets-href)
(let
((count (len tickets)) (suffix (if (= count 1) "" "s")))
(div
:id (str "ticket-buy-" entry-id)
:class "rounded-xl border border-emerald-200 bg-emerald-50 p-4"
(div
:class "flex items-center gap-2 mb-3"
(defcomp ~page/buy-result (&key entry-id tickets remaining my-tickets-href)
(let ((count (len tickets))
(suffix (if (= count 1) "" "s")))
(div :id (str "ticket-buy-" entry-id) :class "rounded-xl border border-emerald-200 bg-emerald-50 p-4"
(div :class "flex items-center gap-2 mb-3"
(i :class "fa fa-check-circle text-emerald-600" :aria-hidden "true")
(span
:class "font-semibold text-emerald-800"
(str count " ticket" suffix " reserved")))
(div
:class "space-y-2 mb-4"
(map
(fn
(t)
(let-match
{:href href :code_short code-short}
t
(a
:href href
:class "flex items-center justify-between p-2 rounded-lg bg-white border border-emerald-100 hover:border-emerald-300 transition text-sm"
(div
:class "flex items-center gap-2"
(i
:class "fa fa-ticket text-emerald-500"
:aria-hidden "true")
(span :class "font-mono text-xs text-stone-500" code-short))
(span
:class "text-xs text-emerald-600 font-medium"
"View ticket"))))
(span :class "font-semibold text-emerald-800" (str count " ticket" suffix " reserved")))
(div :class "space-y-2 mb-4"
(map (fn (t)
(a :href (get t "href") :class "flex items-center justify-between p-2 rounded-lg bg-white border border-emerald-100 hover:border-emerald-300 transition text-sm"
(div :class "flex items-center gap-2"
(i :class "fa fa-ticket text-emerald-500" :aria-hidden "true")
(span :class "font-mono text-xs text-stone-500" (get t "code_short")))
(span :class "text-xs text-emerald-600 font-medium" "View ticket")))
tickets))
(when
(not (nil? remaining))
(let
((r-suffix (if (= remaining 1) "" "s")))
(p
:class "text-xs text-stone-500"
(str remaining " ticket" r-suffix " remaining"))))
(div
:class "mt-3 flex gap-2"
(a
:href my-tickets-href
:class "text-sm text-emerald-700 hover:text-emerald-900 underline"
(when (not (nil? remaining))
(let ((r-suffix (if (= remaining 1) "" "s")))
(p :class "text-xs text-stone-500" (str remaining " ticket" r-suffix " remaining"))))
(div :class "mt-3 flex gap-2"
(a :href my-tickets-href :class "text-sm text-emerald-700 hover:text-emerald-900 underline"
"View all my tickets")))))
;; Single response wrappers for POST routes (include OOB cart icon)
@@ -567,46 +477,27 @@
(~page/post-img-placeholder)))
;; Entry posts nav OOB from data
(defcomp
~page/entry-posts-nav-oob-from-data
(&key nav-btn posts)
(if
(empty? (or posts (list)))
(defcomp ~page/entry-posts-nav-oob-from-data (&key nav-btn posts)
(if (empty? (or posts (list)))
(~page/entry-posts-nav-oob-empty)
(~page/entry-posts-nav-oob
:items (<>
(map
(lambda
(p)
(let-match
{:href href :title title :img img}
p
(~page/entry-nav-post
:href href
:nav-btn nav-btn
:img (~page/post-img-from-data :src img :alt title)
:title title)))
posts)))))
:items (<> (map (lambda (p)
(~page/entry-nav-post
:href (get p "href") :nav-btn nav-btn
:img (~page/post-img-from-data :src (get p "img") :alt (get p "title"))
:title (get p "title")))
posts)))))
;; Entry posts nav (non-OOB) from data — for desktop nav embedding
(defcomp
~page/entry-posts-nav-inner-from-data
(&key posts)
(when
(not (empty? (or posts (list))))
(defcomp ~page/entry-posts-nav-inner-from-data (&key posts)
(when (not (empty? (or posts (list))))
(~page/entry-posts-nav-oob
:items (<>
(map
(lambda
(p)
(let-match
{:href href :title title :img img}
p
(~page/entry-nav-post-link
:href href
:img (~page/post-img-from-data :src img :alt title)
:title title)))
posts)))))
:items (<> (map (lambda (p)
(~page/entry-nav-post-link
:href (get p "href")
:img (~page/post-img-from-data :src (get p "img") :alt (get p "title"))
:title (get p "title")))
posts)))))
;; Post nav entries+calendars OOB from data
(defcomp ~page/post-nav-wrapper-from-data (&key nav-btn entries calendars hyperscript)
@@ -711,23 +602,14 @@
(~shared:layout/nav-link :href admin-href :icon "fa fa-cog"))))
;; Post search results from data
(defcomp
~page/post-search-results-from-data
(&key items page next-url has-more)
(defcomp ~page/post-search-results-from-data (&key items page next-url has-more)
(<>
(map
(lambda
(item)
(let-match
{:csrf csrf :entry-id entry-id :post-url post-url :title title :img img :post-id post-id}
item
(~forms/post-search-item
:post-url post-url
:entry-id entry-id
:csrf csrf
:post-id post-id
:img (~page/post-img-from-data :src img :alt title)
:title title)))
(map (lambda (item)
(~forms/post-search-item
:post-url (get item "post-url") :entry-id (get item "entry-id")
:csrf (get item "csrf") :post-id (get item "post-id")
:img (~page/post-img-from-data :src (get item "img") :alt (get item "title"))
:title (get item "title")))
(or items (list)))
(cond
(has-more (~forms/post-search-sentinel :page page :next-url next-url))
@@ -735,26 +617,16 @@
(true ""))))
;; Entry options from data — state-driven button composition
(defcomp
~page/entry-options-from-data
(&key entry-id state buttons)
(defcomp ~page/entry-options-from-data (&key entry-id state buttons)
(~admin/entry-options
:entry-id entry-id
:buttons (<>
(map
(lambda
(b)
(let-match
{:csrf csrf :confirm-title confirm-title :url url :btn-type btn-type :action-btn action-btn :confirm-text confirm-text :label label :is-btn is-btn}
b
(~admin/entry-option-button
:url url
:target (str "#calendar_entry_options_" entry-id)
:csrf csrf
:btn-type btn-type
:action-btn action-btn
:confirm-title confirm-title
:confirm-text confirm-text
:label label
:is-btn is-btn)))
(or buttons (list))))))
:buttons (<> (map (lambda (b)
(~admin/entry-option-button
:url (get b "url") :target (str "#calendar_entry_options_" entry-id)
:csrf (get b "csrf") :btn-type (get b "btn-type")
:action-btn (get b "action-btn")
:confirm-title (get b "confirm-title")
:confirm-text (get b "confirm-text")
:label (get b "label")
:is-btn (get b "is-btn")))
(or buttons (list))))))

202
events/sx/tickets.sx
View File

@@ -211,28 +211,18 @@
;; ---------------------------------------------------------------------------
;; My tickets panel from data
(defcomp
~tickets/panel-from-data
(&key (list-container :as string) (tickets :as list?))
(defcomp ~tickets/panel-from-data (&key (list-container :as string) (tickets :as list?))
(~tickets/panel
:list-container list-container
:has-tickets (not (empty? (or tickets (list))))
:cards (<>
(map
(lambda
(t)
(let-match
{:time-str time-str :href href :type-name type-name :code-prefix code-prefix :entry-name entry-name :cal-name cal-name :state state}
t
(~tickets/card
:href href
:entry-name entry-name
:type-name type-name
:time-str time-str
:cal-name cal-name
:badge (~entries/ticket-state-badge :state state)
:code-prefix code-prefix)))
(or tickets (list))))))
:cards (<> (map (lambda (t)
(~tickets/card
:href (get t "href") :entry-name (get t "entry-name")
:type-name (get t "type-name") :time-str (get t "time-str")
:cal-name (get t "cal-name")
:badge (~entries/ticket-state-badge :state (get t "state"))
:code-prefix (get t "code-prefix")))
(or tickets (list))))))
;; Ticket detail from data — uses lg badge variant
(defcomp ~tickets/detail-from-data (&key (list-container :as string) (back-href :as string) (header-bg :as string) (entry-name :as string)
@@ -266,106 +256,54 @@
(true nil))))
;; Ticket admin panel from data
(defcomp
~tickets/admin-panel-from-data
(&key
(list-container :as string)
(lookup-url :as string)
(tickets :as list?)
(total :as number?)
(confirmed :as number?)
(checked-in :as number?)
(reserved :as number?))
(defcomp ~tickets/admin-panel-from-data (&key (list-container :as string) (lookup-url :as string) (tickets :as list?)
(total :as number?) (confirmed :as number?) (checked-in :as number?) (reserved :as number?))
(~tickets/admin-panel
:list-container list-container
:stats (<>
(~tickets/admin-stat
:border "border-stone-200"
:bg ""
:text-cls "text-stone-900"
:label-cls "text-stone-500"
:value (str (or total 0))
:label "Total")
(~tickets/admin-stat
:border "border-emerald-200"
:bg "bg-emerald-50"
:text-cls "text-emerald-700"
:label-cls "text-emerald-600"
:value (str (or confirmed 0))
:label "Confirmed")
(~tickets/admin-stat
:border "border-blue-200"
:bg "bg-blue-50"
:text-cls "text-blue-700"
:label-cls "text-blue-600"
:value (str (or checked-in 0))
:label "Checked In")
(~tickets/admin-stat
:border "border-amber-200"
:bg "bg-amber-50"
:text-cls "text-amber-700"
:label-cls "text-amber-600"
:value (str (or reserved 0))
:label "Reserved"))
(~tickets/admin-stat :border "border-stone-200" :bg ""
:text-cls "text-stone-900" :label-cls "text-stone-500"
:value (str (or total 0)) :label "Total")
(~tickets/admin-stat :border "border-emerald-200" :bg "bg-emerald-50"
:text-cls "text-emerald-700" :label-cls "text-emerald-600"
:value (str (or confirmed 0)) :label "Confirmed")
(~tickets/admin-stat :border "border-blue-200" :bg "bg-blue-50"
:text-cls "text-blue-700" :label-cls "text-blue-600"
:value (str (or checked-in 0)) :label "Checked In")
(~tickets/admin-stat :border "border-amber-200" :bg "bg-amber-50"
:text-cls "text-amber-700" :label-cls "text-amber-600"
:value (str (or reserved 0)) :label "Reserved"))
:lookup-url lookup-url
:has-tickets (not (empty? (or tickets (list))))
:rows (<>
(map
(lambda
(t)
(let-match
{:date-str date-str :csrf csrf :type-name type-name :code-short code-short :entry-name entry-name :code code :checkin-url checkin-url :checked-in-time checked-in-time :state state}
t
(~tickets/admin-row-from-data
:code code
:code-short code-short
:entry-name entry-name
:date-str date-str
:type-name type-name
:state state
:checkin-url checkin-url
:csrf csrf
:checked-in-time checked-in-time)))
(or tickets (list))))))
:rows (<> (map (lambda (t)
(~tickets/admin-row-from-data
:code (get t "code") :code-short (get t "code-short")
:entry-name (get t "entry-name") :date-str (get t "date-str")
:type-name (get t "type-name") :state (get t "state")
:checkin-url (get t "checkin-url") :csrf (get t "csrf")
:checked-in-time (get t "checked-in-time")))
(or tickets (list))))))
;; Entry tickets admin from data
(defcomp
~tickets/entry-tickets-admin-from-data
(&key
(entry-name :as string)
(count-label :as string)
(tickets :as list?)
(csrf :as string))
(defcomp ~tickets/entry-tickets-admin-from-data (&key (entry-name :as string) (count-label :as string) (tickets :as list?) (csrf :as string))
(~tickets/entry-tickets-admin-panel
:entry-name entry-name
:count-label count-label
:body (if
(empty? (or tickets (list)))
:entry-name entry-name :count-label count-label
:body (if (empty? (or tickets (list)))
(~tickets/entry-tickets-admin-empty)
(~tickets/entry-tickets-admin-table
:rows (<>
(map
(lambda
(t)
(let-match
{:type-name type-name :code-short code-short :code code :checkin-url checkin-url :checked-in-time checked-in-time :state state}
t
(~tickets/entry-tickets-admin-row
:code code
:code-short code-short
:type-name type-name
:badge (~entries/ticket-state-badge :state state)
:action (cond
((or (= state "confirmed") (= state "paid"))
(~tickets/entry-tickets-admin-checkin
:checkin-url checkin-url
:code code
:csrf csrf))
((= state "checked-in")
(~tickets/admin-checked-in
:time-str (or checked-in-time "")))
(true nil)))))
(or tickets (list))))))))
:rows (<> (map (lambda (t)
(~tickets/entry-tickets-admin-row
:code (get t "code") :code-short (get t "code-short")
:type-name (get t "type-name")
:badge (~entries/ticket-state-badge :state (get t "state"))
:action (cond
((or (= (get t "state") "confirmed") (= (get t "state") "reserved"))
(~tickets/entry-tickets-admin-checkin
:checkin-url (get t "checkin-url") :code (get t "code") :csrf csrf))
((= (get t "state") "checked_in")
(~tickets/admin-checked-in :time-str (or (get t "checked-in-time") "")))
(true nil))))
(or tickets (list))))))))
;; Checkin success row from data
(defcomp ~tickets/checkin-success-row-from-data (&key (code :as string) (code-short :as string) (entry-name :as string) (date-str :as string?) (type-name :as string) (time-str :as string))
@@ -378,43 +316,21 @@
:time-str time-str))
;; Ticket types table from data
(defcomp
~tickets/types-table-from-data
(&key
(list-container :as string)
(ticket-types :as list?)
(action-btn :as string)
(add-url :as string)
(tr-cls :as string)
(pill-cls :as string)
(hx-select :as string)
(csrf-hdr :as string))
(defcomp ~tickets/types-table-from-data (&key (list-container :as string) (ticket-types :as list?) (action-btn :as string) (add-url :as string)
(tr-cls :as string) (pill-cls :as string) (hx-select :as string) (csrf-hdr :as string))
(~page/ticket-types-table
:list-container list-container
:rows (if
(empty? (or ticket-types (list)))
:rows (if (empty? (or ticket-types (list)))
(~page/ticket-types-empty-row)
(<>
(map
(lambda
(tt)
(let-match
{:tt-href tt-href :count count :cost-str cost-str :tt-name tt-name :del-url del-url}
tt
(~page/ticket-types-row
:tr-cls tr-cls
:tt-href tt-href
:pill-cls pill-cls
:hx-select hx-select
:tt-name tt-name
:cost-str cost-str
:count count
:action-btn action-btn
:del-url del-url
:csrf-hdr csrf-hdr)))
(or ticket-types (list)))))
:action-btn action-btn
:add-url add-url))
(<> (map (lambda (tt)
(~page/ticket-types-row
:tr-cls tr-cls :tt-href (get tt "tt-href")
:pill-cls pill-cls :hx-select hx-select
:tt-name (get tt "tt-name") :cost-str (get tt "cost-str")
:count (get tt "count") :action-btn action-btn
:del-url (get tt "del-url") :csrf-hdr csrf-hdr))
(or ticket-types (list)))))
:action-btn action-btn :add-url add-url))
;; Lookup result from data
(defcomp ~tickets/lookup-result-from-data (&key (entry-name :as string) (type-name :as string?) (date-str :as string?) (cal-name :as string?)

1
federation/config/app-config.sx
View File

@@ -1 +0,0 @@
(defconfig app {:market-root "/market" :host "https://rose-ash.com" :base-url "https://wholesale.suma.coop/" :base-login "https://wholesale.suma.coop/customer/account/login/" :slugs {:skip ("" "customer" "account" "checkout" "wishlist" "sales" "contact" "privacy-policy" "terms-and-conditions" "delivery" "catalogsearch" "quickorder" "apply" "search" "static" "media")} :categories {:allow {:Chilled "chilled" :Non-foods "non-foods" :Branded-Goods "branded-goods" :Frozen "frozen" :Basics "basics" :Supplements "supplements" :Christmas "christmas"}} :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")} :cart-root "/cart" :cache {:fs-root "/app/_snapshot"} :market-title "Market" :app-urls {:sx "https://sx.rose-ash.com" :account "https://account.rose-ash.com" :events "https://events.rose-ash.com" :federation "https://federation.rose-ash.com" :cart "https://cart.rose-ash.com" :orders "https://orders.rose-ash.com" :test "https://test.rose-ash.com" :blog "https://blog.rose-ash.com" :market "https://market.rose-ash.com"} :title "ROSE-ASH 2.0" :blog-root "/" :sumup {:merchant-code "ME4J6100" :currency "GBP" :webhook-secret (env-get "SUMUP_WEBHOOK_SECRET") :api-key (env-get "SUMUP_API_KEY")} :root "/rose-ash-wholefood-coop" :base-host "wholesale.suma.coop" :blog-title "all the news"})

197
federation/sx/social.sx
View File

@@ -92,95 +92,52 @@
;; --- Data-driven post card (replaces Python _post_card_sx loop) ---
(defcomp
~social/post-card-from-data
(&key
(d :as dict)
(has-actor :as boolean)
(csrf :as string)
(like-url :as string)
(unlike-url :as string)
(boost-url :as string)
(unboost-url :as string))
(let-match
{:actor_name actor-name :liked_by_me liked :boosted_by_me boosted-me :time time :actor_username actor-username :domain domain :content content :object_id oid :boosted_by boosted-by :summary summary :original_url original-url :safe_id safe-id :author_inbox ainbox :reply_url reply-url :like_count like-count :boost_count boost-count :actor_icon actor-icon :initial initial*}
d
(let*
((initial (or initial* "?"))
(avatar
(~shared:misc/avatar
:src actor-icon
:cls (if
actor-icon
"w-10 h-10 rounded-full"
"w-10 h-10 rounded-full bg-stone-300 flex items-center justify-center text-stone-600 font-bold text-sm")
:initial (when (not actor-icon) initial)))
(boost (when boosted-by (~social/boost-label :name boosted-by)))
(content-sx
(if
summary
(~social/content :content content :summary summary)
(~social/content :content content)))
(original
(when original-url (~social/original-link :url original-url)))
(interactions
(when
has-actor
(let*
((target (str "#interactions-" safe-id))
(l-action (if liked unlike-url like-url))
(l-cls
(str
"flex items-center gap-1 "
(if
liked
"text-red-500 hover:text-red-600"
"hover:text-red-500")))
(l-icon (if liked "♥" "♡"))
(b-action (if boosted-me unboost-url boost-url))
(b-cls
(str
"flex items-center gap-1 "
(if
boosted-me
"text-green-600 hover:text-green-700"
"hover:text-green-600")))
(reply (when reply-url (~social/reply-link :url reply-url)))
(like-form
(~social/like-form
:action l-action
:target target
:oid oid
:ainbox ainbox
:csrf csrf
:cls l-cls
:icon l-icon
:count like-count))
(boost-form
(~social/boost-form
:action b-action
:target target
:oid oid
:ainbox ainbox
:csrf csrf
:cls b-cls
:count boost-count)))
(div
:id (str "interactions-" safe-id)
(~social/interaction-buttons
:like like-form
:boost boost-form
:reply reply))))))
(~social/post-card
:boost boost
:avatar avatar
:actor-name actor-name
:actor-username actor-username
:domain domain
:time time
:content content-sx
:original original
:interactions interactions))))
(defcomp ~social/post-card-from-data (&key (d :as dict) (has-actor :as boolean) (csrf :as string)
(like-url :as string) (unlike-url :as string)
(boost-url :as string) (unboost-url :as string))
(let* ((boosted-by (get d "boosted_by"))
(actor-icon (get d "actor_icon"))
(actor-name (get d "actor_name"))
(initial (or (get d "initial") "?"))
(avatar (~shared:misc/avatar
:src actor-icon
:cls (if actor-icon "w-10 h-10 rounded-full"
"w-10 h-10 rounded-full bg-stone-300 flex items-center justify-center text-stone-600 font-bold text-sm")
:initial (when (not actor-icon) initial)))
(boost (when boosted-by (~social/boost-label :name boosted-by)))
(content-sx (if (get d "summary")
(~social/content :content (get d "content") :summary (get d "summary"))
(~social/content :content (get d "content"))))
(original (when (get d "original_url")
(~social/original-link :url (get d "original_url"))))
(safe-id (get d "safe_id"))
(interactions (when has-actor
(let* ((oid (get d "object_id"))
(ainbox (get d "author_inbox"))
(target (str "#interactions-" safe-id))
(liked (get d "liked_by_me"))
(boosted-me (get d "boosted_by_me"))
(l-action (if liked unlike-url like-url))
(l-cls (str "flex items-center gap-1 " (if liked "text-red-500 hover:text-red-600" "hover:text-red-500")))
(l-icon (if liked "\u2665" "\u2661"))
(b-action (if boosted-me unboost-url boost-url))
(b-cls (str "flex items-center gap-1 " (if boosted-me "text-green-600 hover:text-green-700" "hover:text-green-600")))
(reply-url (get d "reply_url"))
(reply (when reply-url (~social/reply-link :url reply-url)))
(like-form (~social/like-form
:action l-action :target target :oid oid :ainbox ainbox
:csrf csrf :cls l-cls :icon l-icon :count (get d "like_count")))
(boost-form (~social/boost-form
:action b-action :target target :oid oid :ainbox ainbox
:csrf csrf :cls b-cls :count (get d "boost_count"))))
(div :id (str "interactions-" safe-id)
(~social/interaction-buttons :like like-form :boost boost-form :reply reply))))))
(~social/post-card
:boost boost :avatar avatar
:actor-name actor-name :actor-username (get d "actor_username")
:domain (get d "domain") :time (get d "time")
:content content-sx :original original
:interactions interactions)))
;; Data-driven timeline items (replaces Python _timeline_items_sx loop)
(defcomp ~social/timeline-items-from-data (&key (items :as list) (next-url :as string?) (has-actor :as boolean) (csrf :as string)
@@ -217,53 +174,35 @@
;; Assembled social nav — replaces Python _social_nav_sx
;; ---------------------------------------------------------------------------
(defcomp
~social/nav
(&key actor)
(if
(not actor)
(~social/nav-choose-username
:url (url-for "identity.choose_username_form"))
(let*
((rp (request-path))
(links
(list
(dict :endpoint "social.defpage_home_timeline" :label "Timeline")
(dict :endpoint "social.defpage_public_timeline" :label "Public")
(dict :endpoint "social.defpage_compose_form" :label "Compose")
(dict :endpoint "social.defpage_following_list" :label "Following")
(dict :endpoint "social.defpage_followers_list" :label "Followers")
(dict :endpoint "social.defpage_search" :label "Search"))))
(defcomp ~social/nav (&key actor)
(if (not actor)
(~social/nav-choose-username :url (url-for "identity.choose_username_form"))
(let* ((rp (request-path))
(links (list
(dict :endpoint "social.defpage_home_timeline" :label "Timeline")
(dict :endpoint "social.defpage_public_timeline" :label "Public")
(dict :endpoint "social.defpage_compose_form" :label "Compose")
(dict :endpoint "social.defpage_following_list" :label "Following")
(dict :endpoint "social.defpage_followers_list" :label "Followers")
(dict :endpoint "social.defpage_search" :label "Search"))))
(~social/nav-bar
:items (<>
(map
(lambda
(lnk)
(let-match
{:label label :endpoint endpoint}
lnk
(let*
((href (url-for endpoint))
(bold (if (= rp href) " font-bold" "")))
(a
:href href
:class (str "px-2 py-1 rounded hover:bg-stone-200" bold)
label))))
(map (lambda (lnk)
(let* ((href (url-for (get lnk "endpoint")))
(bold (if (= rp href) " font-bold" "")))
(a :href href
:class (str "px-2 py-1 rounded hover:bg-stone-200" bold)
(get lnk "label"))))
links)
(let*
((notif-url (url-for "social.defpage_notifications"))
(notif-bold (if (= rp notif-url) " font-bold" "")))
(let* ((notif-url (url-for "social.defpage_notifications"))
(notif-bold (if (= rp notif-url) " font-bold" "")))
(~social/nav-notification-link
:href notif-url
:cls (str "px-2 py-1 rounded hover:bg-stone-200 relative" notif-bold)
:count-url (url-for "social.notification_count")))
(let-match
{:preferred_username username}
actor
(a
:href (url-for "activitypub.actor_profile" :username username)
:class "px-2 py-1 rounded hover:bg-stone-200"
(str "@" username))))))))
(a :href (url-for "activitypub.actor_profile" :username (get actor "preferred_username"))
:class "px-2 py-1 rounded hover:bg-stone-200"
(str "@" (get actor "preferred_username"))))))))
;; ---------------------------------------------------------------------------
;; Assembled post card — replaces Python _post_card_sx

4
hosts/javascript/bootstrap.py
View File

@@ -99,8 +99,6 @@ def compile_ref_to_js(
spec_mod_set.add(sm)
if "dom" in adapter_set and "signals" in SPEC_MODULES:
spec_mod_set.add("signals")
if "signals-web" in SPEC_MODULES:
spec_mod_set.add("signals-web")
if "boot" in adapter_set:
spec_mod_set.add("router")
spec_mod_set.add("deps")
@@ -132,7 +130,7 @@ def compile_ref_to_js(
("render.sx", "render (core)"),
("web-forms.sx", "web-forms (defstyle, deftype, defeffect, defrelation)"),
]
for name in ("parser", "html", "sx", "dom-lib", "browser-lib", "dom", "engine", "orchestration", "boot"):
for name in ("parser", "html", "sx", "dom", "engine", "orchestration", "boot"):
if name in adapter_set:
sx_files.append(ADAPTER_FILES[name])
# Use explicit ordering for spec modules (respects dependencies)

95
hosts/javascript/manifest.py
View File

@@ -1,95 +0,0 @@
#!/usr/bin/env python3
"""Output JS build manifest as structured text for the MCP server."""
from __future__ import annotations
import json
import os
import re
import sys
_HERE = os.path.dirname(os.path.abspath(__file__))
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", ".."))
if _PROJECT not in sys.path:
sys.path.insert(0, _PROJECT)
from hosts.javascript.platform import (
ADAPTER_FILES, ADAPTER_DEPS, SPEC_MODULES, SPEC_MODULE_ORDER,
PRIMITIVES_JS_MODULES, _ALL_JS_MODULES, EXTENSION_NAMES,
)
def extract_primitives(js_code: str) -> list[str]:
"""Extract PRIMITIVES["name"] registrations from JS code."""
return sorted(set(re.findall(r'PRIMITIVES\["([^"]+)"\]', js_code)))
def main():
# Core spec files (always included)
core_files = [
"evaluator.sx (frames + eval + CEK)",
"freeze.sx (serializable state)",
"content.sx (content-addressed computation)",
"render.sx (core renderer)",
"web-forms.sx (defstyle, deftype, defeffect)",
]
# Adapters
adapter_lines = []
for name, (filename, label) in sorted(ADAPTER_FILES.items()):
deps = ADAPTER_DEPS.get(name, [])
dep_str = f" (deps: {', '.join(deps)})" if deps else ""
adapter_lines.append(f" {name:18s} {filename:22s} {label}{dep_str}")
# Spec modules
module_lines = []
for name in SPEC_MODULE_ORDER:
if name in SPEC_MODULES:
filename, label = SPEC_MODULES[name]
module_lines.append(f" {name:18s} {filename:22s} {label}")
# Extensions
ext_lines = [f" {name}" for name in sorted(EXTENSION_NAMES)]
# Primitive modules
prim_lines = []
for mod_name in sorted(_ALL_JS_MODULES):
if mod_name in PRIMITIVES_JS_MODULES:
prims = extract_primitives(PRIMITIVES_JS_MODULES[mod_name])
prim_lines.append(f" {mod_name} ({len(prims)}): {', '.join(prims)}")
# Current build file
build_path = os.path.join(_PROJECT, "shared", "static", "scripts", "sx-browser.js")
build_info = ""
if os.path.exists(build_path):
size = os.path.getsize(build_path)
mtime = os.path.getmtime(build_path)
from datetime import datetime
ts = datetime.fromtimestamp(mtime).strftime("%Y-%m-%d %H:%M:%S")
# Count PRIMITIVES in actual build
with open(build_path) as f:
content = f.read()
actual_prims = extract_primitives(content)
build_info = f"\nCurrent build: {size:,} bytes, {ts}, {len(actual_prims)} primitives registered"
print(f"""JS Build Manifest
=================
{build_info}
Core files (always included):
{chr(10).join(' ' + f for f in core_files)}
Adapters ({len(ADAPTER_FILES)}):
{chr(10).join(adapter_lines)}
Spec modules ({len(SPEC_MODULES)}, order: {' → '.join(SPEC_MODULE_ORDER)}):
{chr(10).join(module_lines)}
Extensions ({len(EXTENSION_NAMES)}):
{chr(10).join(ext_lines)}
Primitive modules ({len(_ALL_JS_MODULES)}):
{chr(10).join(prim_lines)}""")
if __name__ == "__main__":
main()

75
hosts/javascript/platform.py
View File

@@ -61,7 +61,6 @@ SPEC_MODULES = {
"deps": ("deps.sx", "deps (component dependency analysis)"),
"router": ("router.sx", "router (client-side route matching)"),
"signals": ("signals.sx", "signals (reactive signal runtime)"),
"signals-web": ("web-signals.sx", "signals-web (stores, events, resources)"),
"page-helpers": ("page-helpers.sx", "page-helpers (pure data transformation helpers)"),
"types": ("types.sx", "types (gradual type system)"),
"vm": ("vm.sx", "vm (bytecode virtual machine)"),
@@ -69,7 +68,7 @@ SPEC_MODULES = {
# Note: frames and cek are now part of evaluator.sx (always loaded as core)
# Explicit ordering for spec modules with dependencies.
SPEC_MODULE_ORDER = ["deps", "page-helpers", "router", "signals", "signals-web", "types", "vm"]
SPEC_MODULE_ORDER = ["deps", "page-helpers", "router", "signals", "types", "vm"]
EXTENSION_NAMES = {"continuations"}
@@ -835,16 +834,6 @@ PREAMBLE = '''\
;(function(global) {
"use strict";
// =========================================================================
// Equality — used by transpiled code (= a b) → sxEq(a, b)
// =========================================================================
function sxEq(a, b) {
if (a === b) return true;
if (a && b && a._sym && b._sym) return a.name === b.name;
if (a && b && a._kw && b._kw) return a.name === b.name;
return false;
}
// =========================================================================
// Types
// =========================================================================
@@ -954,8 +943,8 @@ PRIMITIVES_JS_MODULES: dict[str, str] = {
"core.comparison": '''
// core.comparison
PRIMITIVES["="] = sxEq;
PRIMITIVES["!="] = function(a, b) { return !sxEq(a, b); };
PRIMITIVES["="] = function(a, b) { return a === b; };
PRIMITIVES["!="] = function(a, b) { return a !== b; };
PRIMITIVES["<"] = function(a, b) { return a < b; };
PRIMITIVES[">"] = function(a, b) { return a > b; };
PRIMITIVES["<="] = function(a, b) { return a <= b; };
@@ -1037,7 +1026,7 @@ PRIMITIVES_JS_MODULES: dict[str, str] = {
PRIMITIVES["len"] = function(c) { return Array.isArray(c) ? c.length : typeof c === "string" ? c.length : Object.keys(c).length; };
PRIMITIVES["first"] = function(c) { return c && c.length > 0 ? c[0] : NIL; };
PRIMITIVES["last"] = function(c) { return c && c.length > 0 ? c[c.length - 1] : NIL; };
PRIMITIVES["rest"] = function(c) { if (!c || c._nil) return []; if (typeof c.slice !== "function") return []; return c.slice(1); };
PRIMITIVES["rest"] = function(c) { if (c && typeof c.slice !== "function") { console.error("[sx-debug] rest called on non-sliceable:", typeof c, c, new Error().stack); return []; } return c ? c.slice(1) : []; };
PRIMITIVES["nth"] = function(c, n) { return c && n >= 0 && n < c.length ? c[n] : NIL; };
PRIMITIVES["cons"] = function(x, c) { return [x].concat(c || []); };
PRIMITIVES["append"] = function(c, x) { return (c || []).concat(Array.isArray(x) ? x : [x]); };
@@ -1078,8 +1067,6 @@ PRIMITIVES_JS_MODULES: dict[str, str] = {
PRIMITIVES["dict-set!"] = function(d, k, v) { d[k] = v; return v; };
PRIMITIVES["has-key?"] = function(d, k) { return d !== null && d !== undefined && k in d; };
PRIMITIVES["into"] = function(target, coll) {
if (target === "list") return Array.isArray(coll) ? coll.slice() : Object.entries(coll).map(function(e) { return [e[0], e[1]]; });
if (target === "dict") { var r = {}; for (var i = 0; i < coll.length; i++) { var p = coll[i]; if (Array.isArray(p) && p.length >= 2) r[p[0]] = p[1]; } return r; }
if (Array.isArray(target)) return Array.isArray(coll) ? coll.slice() : Object.entries(coll);
var r = {}; for (var i = 0; i < coll.length; i++) { var p = coll[i]; if (Array.isArray(p) && p.length >= 2) r[p[0]] = p[1]; }
return r;
@@ -1318,7 +1305,6 @@ PLATFORM_JS_PRE = '''
function componentClosure(c) { return c.closure; }
function componentHasChildren(c) { return c.hasChildren; }
function componentName(c) { return c.name; }
function componentFile(c) { return (c && c.file) ? c.file : NIL; }
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; }
@@ -1714,8 +1700,7 @@ PLATFORM_CEK_JS = '''
CEK_FIXUPS_JS = '''
// Override recursive cekRun with iterative loop (avoids stack overflow)
cekRun = function(state) {
while (!cekTerminal_p(state) && !cekSuspended_p(state)) { state = cekStep(state); }
if (cekSuspended_p(state)) { throw new Error("IO suspension in non-IO context"); }
while (!cekTerminal_p(state)) { state = cekStep(state); }
return cekValue(state);
};
@@ -2680,17 +2665,6 @@ PLATFORM_ORCHESTRATION_JS = """
: catchFn;
try { return t(); } catch (e) { return c(e); }
}
function cekTry(thunkFn, handlerFn) {
try {
var result = _wrapSxFn(thunkFn)();
if (!handlerFn || handlerFn === NIL) return [makeSymbol("ok"), result];
return result;
} catch (e) {
var msg = (e && e.message) ? e.message : String(e);
if (handlerFn && handlerFn !== NIL) return _wrapSxFn(handlerFn)(msg);
return [makeSymbol("error"), msg];
}
}
function errorMessage(e) {
return e && e.message ? e.message : String(e);
}
@@ -3103,7 +3077,7 @@ PLATFORM_BOOT_JS = """
}
function getRenderEnv(extraEnv) {
return extraEnv ? merge(componentEnv, PRIMITIVES, extraEnv) : merge(componentEnv, PRIMITIVES);
return extraEnv ? merge(componentEnv, extraEnv) : componentEnv;
}
function mergeEnvs(base, newEnv) {
@@ -3237,15 +3211,7 @@ def fixups_js(has_html, has_sx, has_dom, has_signals=False, has_deps=False, has_
// Core primitives that require native JS (cannot be expressed via FFI)
// -----------------------------------------------------------------------
PRIMITIVES["error"] = function(msg) { throw new Error(msg); };
PRIMITIVES["sort"] = function(lst) {
if (!Array.isArray(lst)) return lst;
return lst.slice().sort(function(a, b) {
if (a < b) return -1; if (a > b) return 1; return 0;
});
};
// Aliases for VM bytecode compatibility
PRIMITIVES["length"] = PRIMITIVES["len"];
// FFI library functions — defined in dom.sx/browser.sx but not transpiled.
// Registered here so runtime-evaluated SX code (data-init, islands) can use them.
PRIMITIVES["prevent-default"] = preventDefault_;
@@ -3321,34 +3287,7 @@ def fixups_js(has_html, has_sx, has_dom, has_signals=False, has_deps=False, has_
try { localStorage.removeItem(key); } catch (e) {}
return NIL;
};
if (typeof sxParse === "function") PRIMITIVES["sx-parse"] = sxParse;
PRIMITIVES["cek-try"] = function(thunkFn, handlerFn) {
try {
var result = _wrapSxFn(thunkFn)();
if (!handlerFn || handlerFn === NIL) return [makeSymbol("ok"), result];
return result;
} catch (e) {
var msg = (e && e.message) ? e.message : String(e);
if (handlerFn && handlerFn !== NIL) return _wrapSxFn(handlerFn)(msg);
return [makeSymbol("error"), msg];
}
};
// Named stores — global mutable registry (mirrors OCaml sx_primitives.ml)
var _storeRegistry = {};
function defStore(name, initFn) {
if (!_storeRegistry.hasOwnProperty(name)) {
_storeRegistry[name] = _wrapSxFn(initFn)();
}
return _storeRegistry[name];
}
function useStore(name) {
if (!_storeRegistry.hasOwnProperty(name)) throw new Error("Store not found: " + name);
return _storeRegistry[name];
}
function clearStores() { _storeRegistry = {}; return NIL; }
PRIMITIVES["def-store"] = defStore;
PRIMITIVES["use-store"] = useStore;
PRIMITIVES["clear-stores"] = clearStores;''']
if (typeof sxParse === "function") PRIMITIVES["sx-parse"] = sxParse;''']
if has_deps:
lines.append('''
// Platform deps functions (native JS, not transpiled — need explicit registration)

104
hosts/javascript/run_tests.js
View File

@@ -82,18 +82,6 @@ env["env-merge"] = function(a, b) { return Object.assign({}, a, b); };
// Missing primitives referenced by tests
// primitive? is now in platform.py PRIMITIVES
env["contains-char?"] = function(s, c) { return typeof s === "string" && typeof c === "string" && s.indexOf(c) >= 0; };
env["escape-string"] = function(s) { return s.replace(/\\/g, "\\\\").replace(/"/g, '\\"').replace(/\n/g, "\\n").replace(/\t/g, "\\t"); };
env["trim-right"] = function(s) { return typeof s === "string" ? s.trimEnd() : s; };
env["sha3-256"] = function(s) {
// Simple hash stub for testing — not real SHA3
var h = 0;
for (var i = 0; i < s.length; i++) { h = ((h << 5) - h + s.charCodeAt(i)) | 0; }
h = Math.abs(h);
var hex = h.toString(16);
while (hex.length < 64) hex = "0" + hex;
return hex;
};
env["upcase"] = function(s) { return s.toUpperCase(); };
env["downcase"] = function(s) { return s.toLowerCase(); };
env["make-keyword"] = function(name) { return new Sx.Keyword(name); };
@@ -244,20 +232,6 @@ env["render-sx"] = function(source) {
return parts.join("");
};
// Mock request/state primitives for test-handlers.sx
const _mockState = {};
env["now"] = function(fmt) { return new Date().toISOString(); };
env["state-get"] = function(key, dflt) { return key in _mockState ? _mockState[key] : (dflt !== undefined ? dflt : null); };
env["state-set!"] = function(key, val) { _mockState[key] = val; return val; };
env["state-clear!"] = function(key) { delete _mockState[key]; return null; };
env["request-method"] = function() { return "GET"; };
env["request-arg"] = function(name, dflt) { return dflt !== undefined ? dflt : null; };
env["request-form"] = function(name, dflt) { return dflt !== undefined ? dflt : ""; };
env["request-headers-all"] = function() { return {}; };
env["request-form-all"] = function() { return {}; };
env["request-args-all"] = function() { return {}; };
env["request-content-type"] = function() { return "text/html"; };
// Platform test functions
env["try-call"] = function(thunk) {
try {
@@ -305,61 +279,10 @@ for (const expr of frameworkExprs) {
Sx.eval(expr, env);
}
// Load test harness (mock IO platform)
const harnessPath = path.join(projectDir, "spec", "harness.sx");
if (fs.existsSync(harnessPath)) {
const harnessSrc = fs.readFileSync(harnessPath, "utf8");
const harnessExprs = Sx.parse(harnessSrc);
for (const expr of harnessExprs) {
try { Sx.eval(expr, env); } catch (e) {
console.error(`Error loading harness.sx: ${e.message}`);
}
}
}
// Load canonical.sx (content-addressing, serialization)
const canonicalPath = path.join(projectDir, "spec", "canonical.sx");
if (fs.existsSync(canonicalPath)) {
const canonicalSrc = fs.readFileSync(canonicalPath, "utf8");
const canonicalExprs = Sx.parse(canonicalSrc);
for (const expr of canonicalExprs) {
try { Sx.eval(expr, env); } catch (e) {
console.error(`Error loading canonical.sx: ${e.message}`);
}
}
}
// Load sx-swap.sx (needed by spec/tests/test-sx-swap.sx)
const swapPath = path.join(projectDir, "lib", "sx-swap.sx");
if (fs.existsSync(swapPath)) {
const swapSrc = fs.readFileSync(swapPath, "utf8");
const swapExprs = Sx.parse(swapSrc);
for (const expr of swapExprs) {
try { Sx.eval(expr, env); } catch (e) {
console.error(`Error loading sx-swap.sx: ${e.message}`);
}
}
}
// Load tw system (needed by spec/tests/test-tw.sx)
const twDir = path.join(projectDir, "shared", "sx", "templates");
for (const twFile of ["tw-type.sx", "tw-layout.sx", "tw.sx"]) {
const twPath = path.join(twDir, twFile);
if (fs.existsSync(twPath)) {
const twSrc = fs.readFileSync(twPath, "utf8");
const twExprs = Sx.parse(twSrc);
for (const expr of twExprs) {
try { Sx.eval(expr, env); } catch (e) {
console.error(`Error loading ${twFile}: ${e.message}`);
}
}
}
}
// Load compiler + VM from lib/ when running full tests
if (fullBuild) {
const libDir = path.join(projectDir, "lib");
for (const libFile of ["bytecode.sx", "compiler.sx", "vm.sx", "tree-tools.sx"]) {
for (const libFile of ["bytecode.sx", "compiler.sx", "vm.sx"]) {
const libPath = path.join(libDir, libFile);
if (fs.existsSync(libPath)) {
const src = fs.readFileSync(libPath, "utf8");
@@ -371,31 +294,6 @@ if (fullBuild) {
}
}
}
// Load web harnesses (DOM mocking, signals, rendering awareness)
const webDir = path.join(projectDir, "web");
for (const webFile of ["harness-web.sx", "harness-reactive.sx"]) {
const wp = path.join(webDir, webFile);
if (fs.existsSync(wp)) {
const src = fs.readFileSync(wp, "utf8");
const exprs = Sx.parse(src);
for (const expr of exprs) {
try { Sx.eval(expr, env); } catch (e) {
console.error(`Error loading ${webFile}: ${e.message}`);
}
}
}
}
// Load stepper-lib (shared stepper functions used by lib/tests/test-stepper.sx)
const stepperLibPath = path.join(projectDir, "sx", "sx", "stepper-lib.sx");
if (fs.existsSync(stepperLibPath)) {
const src = fs.readFileSync(stepperLibPath, "utf8");
const exprs = Sx.parse(src);
for (const expr of exprs) {
try { Sx.eval(expr, env); } catch (e) {
console.error(`Error loading stepper-lib.sx: ${e.message}`);
}
}
}
}
// Determine which tests to run

2521
hosts/javascript/transpiler.sx
View File

File diff suppressed because one or more lines are too long

3
hosts/native/bin/dune
View File

@@ -1,3 +0,0 @@
(executable
(name sx_native_app)
(libraries sx sx_native cairo2 tsdl unix))

276
hosts/native/bin/sx_native_app.ml
View File

@@ -1,276 +0,0 @@
(** SX Native Browser -- renders s-expressions directly to pixels.
A proof-of-concept desktop browser that parses .sx files and
renders them using SDL2 + Cairo, with no HTML/CSS/JS engine. *)
open Tsdl
open Sx_native
open Sx_native_types
(* -- Helpers for SDL result handling -- *)
let sdl_ok = function
| Ok v -> v
| Error (`Msg e) -> failwith ("SDL error: " ^ e)
(* -- State -- *)
type app_state = {
mutable current_url : string;
mutable root : node;
mutable needs_repaint : bool;
mutable win_w : int;
mutable win_h : int;
mutable scroll_y : float;
}
(* -- Parse and build render tree -- *)
let load_content (state : app_state) (source : string) (cr : Cairo.context) =
let values = Sx_parser.parse_all source in
let navigate href =
(* Simple navigation: if href starts with / or is a relative path, reload *)
Printf.printf "[navigate] %s\n%!" href;
state.current_url <- href;
(* In a full implementation, this would trigger a re-fetch and re-render *)
in
let root = Sx_native_render.render_page ~navigate values in
Sx_native_layout.measure cr root;
let w = float_of_int state.win_w in
let h = float_of_int state.win_h -. 36. in (* subtract URL bar *)
Sx_native_layout.layout root 0. 0. w h;
state.root <- root;
state.needs_repaint <- true
(* -- Hit testing -- *)
let rec hit_test (node : node) (x : float) (y : float) : node option =
let b = node.box in
if x >= b.x && x <= b.x +. b.w && y >= b.y && y <= b.y +. b.h then begin
(* Check children in reverse order (topmost first) *)
let child_hit = List.fold_left (fun acc child ->
match acc with
| Some _ -> acc
| None -> hit_test child x y
) None (List.rev node.children) in
match child_hit with
| Some _ -> child_hit
| None -> Some node
end
else None
let handle_click (state : app_state) (root : node) (x : float) (y : float) =
(* Offset y by URL bar height for hit testing *)
let adjusted_y = y -. 36. -. state.scroll_y in
match hit_test root x adjusted_y with
| Some node ->
(match node.on_click with
| Some f -> f ()
| None ->
match node.href with
| Some href ->
Printf.printf "[click] link: %s\n%!" href;
state.current_url <- href
| None ->
Printf.printf "[click] %s at (%.0f, %.0f)\n%!" node.tag x y)
| None ->
Printf.printf "[click] miss at (%.0f, %.0f)\n%!" x y
(* -- Default demo content -- *)
let demo_sx = {|
(div :class "flex flex-col items-center gap-6 p-8 bg-stone-50"
(h1 :class "text-3xl font-bold text-stone-800" "SX Native Browser")
(p :class "text-stone-500" "Rendering s-expressions directly to pixels")
(div :class "flex gap-4 items-center"
(div :class "p-4 rounded-lg bg-white border border-stone-200 shadow"
(h3 :class "font-bold text-stone-700" "No HTML")
(p :class "text-sm text-stone-500" "This is not a web page"))
(div :class "p-4 rounded-lg bg-white border border-stone-200 shadow"
(h3 :class "font-bold text-stone-700" "No CSS")
(p :class "text-sm text-stone-500" "Tailwind classes parsed to native styles"))
(div :class "p-4 rounded-lg bg-white border border-stone-200 shadow"
(h3 :class "font-bold text-stone-700" "No JavaScript")
(p :class "text-sm text-stone-500" "The SX evaluator does everything")))
(div :class "p-6 rounded-lg bg-violet-600"
(p :class "text-white text-lg font-bold" "5,000 lines of OCaml instead of 35 million lines of browser engine")))
|}
(* -- Main -- *)
let () =
(* Parse command line *)
let source = ref "" in
let url = ref "sx://demo" in
let args = Array.to_list Sys.argv in
(match args with
| _ :: file :: _ when Sys.file_exists file ->
source := Sx_native_fetch.read_file file;
url := "file://" ^ file
| _ :: path :: _ when String.length path > 0 ->
(try
source := Sx_native_fetch.fetch_page path;
url := path
with _ ->
Printf.eprintf "Failed to fetch %s, using demo content\n%!" path;
source := demo_sx;
url := "sx://demo")
| _ ->
source := demo_sx);
(* Initialize SDL2 *)
sdl_ok (Sdl.init Sdl.Init.(video + events));
at_exit Sdl.quit;
let initial_w = 1024 in
let initial_h = 768 in
let window = sdl_ok (Sdl.create_window "SX Browser"
~x:Sdl.Window.pos_centered ~y:Sdl.Window.pos_centered
~w:initial_w ~h:initial_h
Sdl.Window.(shown + resizable + allow_highdpi)) in
let renderer = sdl_ok (Sdl.create_renderer window
~flags:Sdl.Renderer.(accelerated + presentvsync)) in
(* Create SDL texture for Cairo to draw into *)
let create_texture w h =
sdl_ok (Sdl.create_texture renderer Sdl.Pixel.format_argb8888
Sdl.Texture.access_streaming ~w ~h)
in
let texture = ref (create_texture initial_w initial_h) in
(* Create Cairo surface *)
let create_cairo_surface w h =
Cairo.Image.create Cairo.Image.ARGB32 ~w ~h
in
let surface = ref (create_cairo_surface initial_w initial_h) in
let cr = ref (Cairo.create !surface) in
(* App state *)
let state = {
current_url = !url;
root = { tag = "root"; style = default_style; children = [];
text = None; box = make_box (); href = None; on_click = None };
needs_repaint = true;
win_w = initial_w;
win_h = initial_h;
scroll_y = 0.;
} in
(* Initial load *)
load_content state !source !cr;
(* Main event loop *)
let event = Sdl.Event.create () in
let running = ref true in
while !running do
(* Process all pending events *)
while Sdl.poll_event (Some event) do
let typ = Sdl.Event.get event Sdl.Event.typ in
if typ = Sdl.Event.quit then
running := false
else if typ = Sdl.Event.key_down then begin
let scancode = Sdl.Event.get event Sdl.Event.keyboard_scancode in
if scancode = Sdl.Scancode.escape then
running := false
else if scancode = Sdl.Scancode.up then begin
state.scroll_y <- Float.min 0. (state.scroll_y +. 40.);
state.needs_repaint <- true
end
else if scancode = Sdl.Scancode.down then begin
state.scroll_y <- state.scroll_y -. 40.;
state.needs_repaint <- true
end
else if scancode = Sdl.Scancode.home then begin
state.scroll_y <- 0.;
state.needs_repaint <- true
end
end
else if typ = Sdl.Event.mouse_button_down then begin
let mx = Float.of_int (Sdl.Event.get event Sdl.Event.mouse_button_x) in
let my = Float.of_int (Sdl.Event.get event Sdl.Event.mouse_button_y) in
handle_click state state.root mx my
end
else if typ = Sdl.Event.mouse_wheel then begin
let wy = Sdl.Event.get event Sdl.Event.mouse_wheel_y in
state.scroll_y <- state.scroll_y +. (float_of_int wy *. 40.);
if state.scroll_y > 0. then state.scroll_y <- 0.;
state.needs_repaint <- true
end
else if typ = Sdl.Event.window_event then begin
let wev = Sdl.Event.get event Sdl.Event.window_event_id in
if wev = Sdl.Event.window_event_resized
|| wev = Sdl.Event.window_event_size_changed
|| wev = Sdl.Event.window_event_exposed then begin
let (new_w, new_h) = Sdl.get_window_size window in
if new_w <> state.win_w || new_h <> state.win_h then begin
state.win_w <- new_w;
state.win_h <- new_h;
(* Recreate texture and surface at new size *)
Sdl.destroy_texture !texture;
texture := create_texture new_w new_h;
Cairo.Surface.finish !surface;
surface := create_cairo_surface new_w new_h;
cr := Cairo.create !surface;
(* Re-layout *)
Sx_native_layout.measure !cr state.root;
let w = float_of_int new_w in
let h = float_of_int new_h -. 36. in
Sx_native_layout.layout state.root 0. 0. w h
end;
state.needs_repaint <- true
end
end
done;
(* Paint if needed *)
if state.needs_repaint then begin
state.needs_repaint <- false;
let w = float_of_int state.win_w in
let h = float_of_int state.win_h in
(* Apply scroll offset to root *)
state.root.box.y <- state.scroll_y;
Sx_native_paint.paint_scene !cr state.root state.current_url w h;
Cairo.Surface.flush !surface;
(* Restore root position *)
state.root.box.y <- 0.;
(* Copy Cairo surface data to SDL texture *)
let data = Cairo.Image.get_data8 !surface in
let stride = Bigarray.Array1.dim data / state.win_h in
(* Lock texture, copy data, unlock *)
(match Sdl.lock_texture !texture None Bigarray.int8_unsigned with
| Ok (pixels, _pitch) ->
let src_len = Bigarray.Array1.dim data in
let dst_len = Bigarray.Array1.dim pixels in
let copy_len = min src_len dst_len in
for i = 0 to copy_len - 1 do
Bigarray.Array1.set pixels i (Bigarray.Array1.get data i)
done;
ignore stride;
Sdl.unlock_texture !texture
| Error (`Msg e) ->
Printf.eprintf "lock_texture error: %s\n%!" e);
(* Present *)
ignore (Sdl.render_clear renderer);
ignore (Sdl.render_copy renderer !texture);
Sdl.render_present renderer
end;
Sdl.delay 16l (* ~60 fps cap *)
done;
(* Cleanup *)
Sdl.destroy_texture !texture;
Sdl.destroy_renderer renderer;
Sdl.destroy_window window

25
hosts/native/demo/counter.sx
View File

@@ -1,25 +0,0 @@
(div
:class "flex flex-col items-center gap-6 p-8 bg-stone-50"
(h1 :class "text-3xl font-bold text-stone-800" "SX Native Browser")
(p :class "text-stone-500" "Rendering s-expressions directly to pixels")
(div
:class "flex gap-4 items-center"
(div
:class "p-4 rounded-lg bg-white border border-stone-200 shadow"
(h3 :class "font-bold text-stone-700" "No HTML")
(p :class "text-sm text-stone-500" "This is not a web page"))
(div
:class "p-4 rounded-lg bg-white border border-stone-200 shadow"
(h3 :class "font-bold text-stone-700" "No CSS")
(p
:class "text-sm text-stone-500"
"Tailwind classes parsed to native styles"))
(div
:class "p-4 rounded-lg bg-white border border-stone-200 shadow"
(h3 :class "font-bold text-stone-700" "No JavaScript")
(p :class "text-sm text-stone-500" "The SX evaluator does everything")))
(div
:class "p-6 rounded-lg bg-violet-600"
(p
:class "text-white text-lg font-bold"
"5,000 lines of OCaml instead of 35 million lines of browser engine")))

2
hosts/native/dune-project
View File

@@ -1,2 +0,0 @@
(lang dune 3.19)
(name sx_native)

2
hosts/native/dune-workspace
View File

@@ -1,2 +0,0 @@
(lang dune 3.19)
(context default)

3
hosts/native/lib/dune
View File

@@ -1,3 +0,0 @@
(library
(name sx_native)
(libraries sx cairo2 unix))

37
hosts/native/lib/sx_native_fetch.ml
View File

@@ -1,37 +0,0 @@
(** HTTP fetcher for SX pages.
Uses curl via Unix.open_process_in for simplicity.
Fetches pages from sx.rose-ash.com with SX-Request headers. *)
let base_url = "https://sx.rose-ash.com"
(** Fetch a URL and return the response body as a string. *)
let fetch_url (url : string) : string =
let cmd = Printf.sprintf
"curl -s -L -H 'Accept: text/sx' -H 'SX-Request: true' '%s'" url in
let ic = Unix.open_process_in cmd in
let buf = Buffer.create 8192 in
(try while true do Buffer.add_char buf (input_char ic) done
with End_of_file -> ());
ignore (Unix.close_process_in ic);
Buffer.contents buf
(** Fetch an SX page by path (e.g. "/sx/" or "/sx/language"). *)
let fetch_page (path : string) : string =
let url = if String.length path > 0 && path.[0] = '/' then
base_url ^ path
else if String.length path > 4 && String.sub path 0 4 = "http" then
path
else
base_url ^ "/" ^ path
in
fetch_url url
(** Read a local .sx file. *)
let read_file (path : string) : string =
let ic = open_in path in
let n = in_channel_length ic in
let buf = Bytes.create n in
really_input ic buf 0 n;
close_in ic;
Bytes.to_string buf

232
hosts/native/lib/sx_native_layout.ml
View File

@@ -1,232 +0,0 @@
(** Pure flexbox layout engine.
Two-pass algorithm:
1. Measure (bottom-up): compute intrinsic sizes from text extents
and children accumulation.
2. Layout (top-down): allocate space starting from window bounds,
distributing via flex-grow and handling alignment/gap. *)
open Sx_native_types
(* -- Text measurement -- *)
let measure_text (cr : Cairo.context) (family : [`Sans | `Mono]) (weight : [`Normal | `Bold])
(slant : [`Normal | `Italic]) (size : float) (text : string) : float * float =
let font_name = match family with `Sans -> "sans-serif" | `Mono -> "monospace" in
let cairo_weight = match weight with `Normal -> Cairo.Normal | `Bold -> Cairo.Bold in
let cairo_slant = match slant with `Normal -> Cairo.Upright | `Italic -> Cairo.Italic in
Cairo.select_font_face cr ~slant:cairo_slant ~weight:cairo_weight font_name;
Cairo.set_font_size cr size;
let fe = Cairo.font_extents cr in
if String.length text = 0 then (0., fe.ascent +. fe.descent)
else begin
(* Word wrap not needed for POC -- measure as single line *)
let te = Cairo.text_extents cr text in
(te.Cairo.width +. te.Cairo.x_bearing, fe.ascent +. fe.descent)
end
(* -- Measure pass (bottom-up) -- *)
(** Set intrinsic [box.w] and [box.h] on each node based on text extents
and children accumulation. Does NOT set x/y. *)
let rec measure (cr : Cairo.context) (node : node) : unit =
(* Measure children first *)
List.iter (measure cr) node.children;
let pad = node.style.padding in
let pad_h = pad.left +. pad.right in
let pad_v = pad.top +. pad.bottom in
match node.text with
| Some txt ->
(* Leaf text node: measure the text *)
let (tw, th) = measure_text cr node.style.font_family node.style.font_weight
node.style.font_style node.style.font_size txt in
node.box.w <- tw +. pad_h;
node.box.h <- th +. pad_v
| None ->
if node.style.display = `None then begin
node.box.w <- 0.;
node.box.h <- 0.
end else begin
let visible_children = List.filter (fun c -> c.style.display <> `None) node.children in
let n_children = List.length visible_children in
let total_gap = if n_children > 1 then node.style.gap *. float_of_int (n_children - 1) else 0. in
match node.style.flex_direction with
| `Column ->
(* Stack vertically: width = max child width, height = sum of child heights + gaps *)
let max_w = List.fold_left (fun acc c ->
let cm = c.style.margin in
Float.max acc (c.box.w +. cm.left +. cm.right)
) 0. visible_children in
let sum_h = List.fold_left (fun acc c ->
let cm = c.style.margin in
acc +. c.box.h +. cm.top +. cm.bottom
) 0. visible_children in
node.box.w <- max_w +. pad_h;
node.box.h <- sum_h +. total_gap +. pad_v
| `Row ->
(* Stack horizontally: height = max child height, width = sum of child widths + gaps *)
let sum_w = List.fold_left (fun acc c ->
let cm = c.style.margin in
acc +. c.box.w +. cm.left +. cm.right
) 0. visible_children in
let max_h = List.fold_left (fun acc c ->
let cm = c.style.margin in
Float.max acc (c.box.h +. cm.top +. cm.bottom)
) 0. visible_children in
node.box.w <- sum_w +. total_gap +. pad_h;
node.box.h <- max_h +. pad_v
end;
(* Apply explicit width/height constraints *)
(match node.style.width with
| `Px w -> node.box.w <- w
| `Full | `Auto -> ());
(match node.style.height with
| `Px h -> node.box.h <- h
| `Full | `Auto -> ())
(* -- Layout pass (top-down) -- *)
(** Position all nodes within the given bounds [x, y, w, h].
Distributes space according to flex-grow and handles alignment. *)
let rec layout (node : node) (x : float) (y : float) (avail_w : float) (avail_h : float) : unit =
let margin = node.style.margin in
let x = x +. margin.left in
let y = y +. margin.top in
let avail_w = avail_w -. margin.left -. margin.right in
let avail_h = avail_h -. margin.top -. margin.bottom in
node.box.x <- x;
node.box.y <- y;
(* Determine actual width/height.
Container nodes with Auto width stretch to fill available space
(like CSS block-level elements), while text nodes keep intrinsic width. *)
let is_text_node = node.text <> None in
let w = match node.style.width with
| `Full -> avail_w
| `Px pw -> Float.min pw avail_w
| `Auto ->
if is_text_node then Float.min node.box.w avail_w
else avail_w (* containers expand to fill *)
in
let h = match node.style.height with
| `Full -> avail_h
| `Px ph -> Float.min ph avail_h
| `Auto -> node.box.h (* Use intrinsic height *)
in
node.box.w <- w;
node.box.h <- h;
if node.style.display = `None then ()
else begin
let pad = node.style.padding in
let inner_x = x +. pad.left in
let inner_y = y +. pad.top in
let inner_w = w -. pad.left -. pad.right in
let inner_h = h -. pad.top -. pad.bottom in
let visible_children = List.filter (fun c -> c.style.display <> `None) node.children in
match visible_children with
| [] -> () (* Leaf or empty container *)
| children ->
let n_children = List.length children in
let total_gap = if n_children > 1 then node.style.gap *. float_of_int (n_children - 1) else 0. in
match node.style.flex_direction with
| `Column ->
(* Calculate total intrinsic height and flex-grow sum *)
let total_intrinsic = List.fold_left (fun acc c ->
let cm = c.style.margin in
acc +. c.box.h +. cm.top +. cm.bottom
) 0. children in
let total_grow = List.fold_left (fun acc c -> acc +. c.style.flex_grow) 0. children in
let remaining = Float.max 0. (inner_h -. total_intrinsic -. total_gap) in
(* justify-content: space-between *)
let (start_offset, between_extra) = match node.style.justify_content with
| `Between when n_children > 1 ->
(0., remaining /. float_of_int (n_children - 1))
| `Center -> (remaining /. 2., 0.)
| `End -> (remaining, 0.)
| _ -> (0., 0.)
in
let cur_y = ref (inner_y +. start_offset) in
List.iter (fun child ->
let cm = child.style.margin in
let child_w = match child.style.width with
| `Full -> inner_w -. cm.left -. cm.right
| _ -> Float.min child.box.w (inner_w -. cm.left -. cm.right)
in
let extra_h = if total_grow > 0. then remaining *. child.style.flex_grow /. total_grow else 0. in
let child_h = child.box.h +. extra_h in
(* align-items: cross-axis alignment *)
let child_x = match node.style.align_items with
| `Center -> inner_x +. (inner_w -. child_w -. cm.left -. cm.right) /. 2.
| `End -> inner_x +. inner_w -. child_w -. cm.right
| `Stretch ->
(* Stretch: child takes full width *)
layout child (inner_x) !cur_y (inner_w) child_h;
cur_y := !cur_y +. child.box.h +. cm.top +. cm.bottom +. node.style.gap +. between_extra;
(* skip the normal layout below *)
inner_x (* dummy, won't be used *)
| _ -> inner_x
in
if node.style.align_items <> `Stretch then begin
layout child child_x !cur_y child_w child_h;
cur_y := !cur_y +. child.box.h +. cm.top +. cm.bottom +. node.style.gap +. between_extra
end
) children
| `Row ->
(* Calculate total intrinsic width and flex-grow sum *)
let total_intrinsic = List.fold_left (fun acc c ->
let cm = c.style.margin in
acc +. c.box.w +. cm.left +. cm.right
) 0. children in
let total_grow = List.fold_left (fun acc c -> acc +. c.style.flex_grow) 0. children in
let remaining = Float.max 0. (inner_w -. total_intrinsic -. total_gap) in
let (start_offset, between_extra) = match node.style.justify_content with
| `Between when n_children > 1 ->
(0., remaining /. float_of_int (n_children - 1))
| `Center -> (remaining /. 2., 0.)
| `End -> (remaining, 0.)
| _ -> (0., 0.)
in
let cur_x = ref (inner_x +. start_offset) in
List.iter (fun child ->
let cm = child.style.margin in
let extra_w = if total_grow > 0. then remaining *. child.style.flex_grow /. total_grow else 0. in
let child_w = child.box.w +. extra_w in
let child_h = match child.style.height with
| `Full -> inner_h -. cm.top -. cm.bottom
| _ -> Float.min child.box.h (inner_h -. cm.top -. cm.bottom)
in
(* align-items: cross-axis alignment *)
let child_y = match node.style.align_items with
| `Center -> inner_y +. (inner_h -. child_h -. cm.top -. cm.bottom) /. 2.
| `End -> inner_y +. inner_h -. child_h -. cm.bottom
| `Stretch ->
layout child !cur_x inner_y child_w inner_h;
cur_x := !cur_x +. child.box.w +. cm.left +. cm.right +. node.style.gap +. between_extra;
inner_y (* dummy *)
| _ -> inner_y
in
if node.style.align_items <> `Stretch then begin
layout child !cur_x child_y child_w child_h;
cur_x := !cur_x +. child.box.w +. cm.left +. cm.right +. node.style.gap +. between_extra
end
) children
end

156
hosts/native/lib/sx_native_paint.ml
View File

@@ -1,156 +0,0 @@
(** Walk a positioned node tree and issue Cairo draw commands.
Handles backgrounds with rounded corners, borders, shadows,
and text rendering with proper font face/size/weight. *)
open Sx_native_types
open Sx_native_style
(* -- Rounded rectangle path -- *)
let rounded_rect (cr : Cairo.context) (x : float) (y : float) (w : float) (h : float) (r : float) =
let r = Float.min r (Float.min (w /. 2.) (h /. 2.)) in
if r <= 0. then
Cairo.rectangle cr x y ~w ~h
else begin
let pi = Float.pi in
Cairo.Path.sub cr;
Cairo.arc cr (x +. w -. r) (y +. r) ~r ~a1:(-.pi /. 2.) ~a2:0.;
Cairo.arc cr (x +. w -. r) (y +. h -. r) ~r ~a1:0. ~a2:(pi /. 2.);
Cairo.arc cr (x +. r) (y +. h -. r) ~r ~a1:(pi /. 2.) ~a2:pi;
Cairo.arc cr (x +. r) (y +. r) ~r ~a1:pi ~a2:(-.pi /. 2.);
Cairo.Path.close cr
end
(* -- Shadow painting -- *)
let paint_shadow (cr : Cairo.context) (b : box) (radius : float) (level : [`Sm | `Md]) =
let (offset, blur_passes, alpha) = match level with
| `Sm -> (1., 2, 0.04)
| `Md -> (2., 3, 0.05)
in
for i = 1 to blur_passes do
let spread = float_of_int i *. 2. in
Cairo.save cr;
Cairo.set_source_rgba cr 0. 0. 0. (alpha /. float_of_int i);
rounded_rect cr
(b.x -. spread)
(b.y +. offset -. spread +. float_of_int i)
(b.w +. spread *. 2.)
(b.h +. spread *. 2.)
(radius +. spread);
Cairo.fill cr;
Cairo.restore cr
done
(* -- Main paint function -- *)
(** Paint a positioned node tree to a Cairo context. *)
let rec paint (cr : Cairo.context) (node : node) : unit =
let s = node.style in
let b = node.box in
if s.display = `None then ()
else begin
(* Save state for potential clip *)
Cairo.save cr;
(* Shadow *)
(match s.shadow with
| `None -> ()
| `Sm -> paint_shadow cr b s.border_radius `Sm
| `Md -> paint_shadow cr b s.border_radius `Md);
(* Background *)
(match s.bg_color with
| Some c ->
Cairo.set_source_rgba cr c.r c.g c.b c.a;
rounded_rect cr b.x b.y b.w b.h s.border_radius;
Cairo.fill cr
| None -> ());
(* Border *)
if s.border_width > 0. then begin
let bc = match s.border_color with Some c -> c | None -> stone_800 in
Cairo.set_source_rgba cr bc.r bc.g bc.b bc.a;
Cairo.set_line_width cr s.border_width;
rounded_rect cr
(b.x +. s.border_width /. 2.)
(b.y +. s.border_width /. 2.)
(b.w -. s.border_width)
(b.h -. s.border_width)
(Float.max 0. (s.border_radius -. s.border_width /. 2.));
Cairo.stroke cr
end;
(* Clip for overflow *)
if s.overflow_hidden then begin
rounded_rect cr b.x b.y b.w b.h s.border_radius;
Cairo.clip cr
end;
(* Text *)
(match node.text with
| Some txt when String.length txt > 0 ->
let font_name = match s.font_family with `Sans -> "sans-serif" | `Mono -> "monospace" in
let weight = match s.font_weight with `Normal -> Cairo.Normal | `Bold -> Cairo.Bold in
let slant = match s.font_style with `Normal -> Cairo.Upright | `Italic -> Cairo.Italic in
Cairo.select_font_face cr ~slant ~weight font_name;
Cairo.set_font_size cr s.font_size;
let fe = Cairo.font_extents cr in
Cairo.set_source_rgba cr s.text_color.r s.text_color.g s.text_color.b s.text_color.a;
Cairo.move_to cr (b.x +. s.padding.left) (b.y +. s.padding.top +. fe.ascent);
Cairo.show_text cr txt
| _ -> ());
(* Children *)
List.iter (paint cr) node.children;
Cairo.restore cr
end
(** Paint a horizontal URL bar at the top of the window. *)
let paint_url_bar (cr : Cairo.context) (url : string) (width : float) : float =
let bar_height = 36. in
(* Bar background *)
Cairo.set_source_rgba cr stone_100.r stone_100.g stone_100.b 1.0;
Cairo.rectangle cr 0. 0. ~w:width ~h:bar_height;
Cairo.fill cr;
(* Bottom border *)
Cairo.set_source_rgba cr stone_200.r stone_200.g stone_200.b 1.0;
Cairo.set_line_width cr 1.;
Cairo.move_to cr 0. bar_height;
Cairo.line_to cr width bar_height;
Cairo.stroke cr;
(* URL text *)
Cairo.select_font_face cr ~slant:Cairo.Upright ~weight:Cairo.Normal "monospace";
Cairo.set_font_size cr 13.;
Cairo.set_source_rgba cr stone_600.r stone_600.g stone_600.b 1.0;
Cairo.move_to cr 12. 23.;
Cairo.show_text cr url;
bar_height
(** Paint the entire scene: clear, URL bar, then content. *)
let paint_scene (cr : Cairo.context) (root : node) (url : string) (width : float) (height : float) : unit =
(* Clear to white *)
Cairo.set_source_rgba cr 1. 1. 1. 1.;
Cairo.rectangle cr 0. 0. ~w:width ~h:height;
Cairo.fill cr;
(* URL bar *)
let bar_h = paint_url_bar cr url width in
(* Content area *)
Cairo.save cr;
Cairo.rectangle cr 0. bar_h ~w:width ~h:(height -. bar_h);
Cairo.clip cr;
(* Offset layout by bar height *)
root.box.y <- root.box.y +. bar_h;
paint cr root;
root.box.y <- root.box.y -. bar_h; (* restore for hit testing *)
Cairo.restore cr

221
hosts/native/lib/sx_native_render.ml
View File

@@ -1,221 +0,0 @@
(** Convert an [Sx_types.value] tree into a native [node] render tree.
Walks the parsed SX AST and produces nodes for HTML-like tags
(div, p, h1-h6, span, etc.), extracting :class attributes for
styling and string content for text nodes. Unknown forms are
rendered as gray placeholders. *)
open Sx_native_types
open Sx_native_style
(* -- Tag default styles -- *)
let tag_base_style (tag : string) : style =
match tag with
| "h1" -> { default_style with font_size = 36.; font_weight = `Bold }
| "h2" -> { default_style with font_size = 30.; font_weight = `Bold }
| "h3" -> { default_style with font_size = 24.; font_weight = `Bold }
| "h4" -> { default_style with font_size = 20.; font_weight = `Bold }
| "h5" -> { default_style with font_size = 18.; font_weight = `Bold }
| "h6" -> { default_style with font_size = 16.; font_weight = `Bold }
| "p" -> { default_style with flex_direction = `Row }
| "span" -> { default_style with flex_direction = `Row }
| "div" -> default_style
| "section" -> default_style
| "article" -> default_style
| "main" -> default_style
| "header" -> default_style
| "footer" -> default_style
| "nav" -> { default_style with flex_direction = `Row }
| "button" ->
{ default_style with
flex_direction = `Row;
padding = { top = 8.; right = 16.; bottom = 8.; left = 16. };
bg_color = Some violet_600;
text_color = white;
border_radius = 6.;
align_items = `Center;
justify_content = `Center }
| "a" -> { default_style with flex_direction = `Row; text_color = violet_600 }
| "code" ->
{ default_style with
font_family = `Mono;
font_size = 14.;
bg_color = Some stone_100;
padding = { top = 2.; right = 4.; bottom = 2.; left = 4. };
border_radius = 4. }
| "pre" ->
{ default_style with
font_family = `Mono;
font_size = 14.;
bg_color = Some stone_100;
padding = { top = 12.; right = 16.; bottom = 12.; left = 16. };
border_radius = 8. }
| "strong" | "b" -> { default_style with font_weight = `Bold; flex_direction = `Row }
| "em" | "i" -> { default_style with font_style = `Italic; flex_direction = `Row }
| "ul" -> { default_style with padding = { zero_edges with left = 16. } }
| "ol" -> { default_style with padding = { zero_edges with left = 16. } }
| "li" -> { default_style with flex_direction = `Row; gap = 4. }
| "table" -> default_style
| "thead" | "tbody" -> default_style
| "tr" -> { default_style with flex_direction = `Row; gap = 0. }
| "th" -> { default_style with font_weight = `Bold; padding = { top = 4.; right = 8.; bottom = 4.; left = 8. } }
| "td" -> { default_style with padding = { top = 4.; right = 8.; bottom = 4.; left = 8. } }
| "hr" ->
{ default_style with
height = `Px 1.;
bg_color = Some stone_200;
width = `Full }
| "br" -> { default_style with height = `Px 16. }
| "img" ->
{ default_style with
width = `Px 200.;
height = `Px 150.;
bg_color = Some stone_200;
border_radius = 4. }
| _ -> default_style
(* -- Known HTML tags -- *)
let is_html_tag = function
| "div" | "span" | "p" | "section" | "article" | "main" | "header"
| "footer" | "nav" | "aside"
| "h1" | "h2" | "h3" | "h4" | "h5" | "h6"
| "button" | "a" | "input" | "form" | "label" | "select" | "textarea"
| "ul" | "ol" | "li"
| "table" | "thead" | "tbody" | "tr" | "th" | "td"
| "strong" | "b" | "em" | "i" | "u" | "s"
| "code" | "pre" | "blockquote"
| "img" | "video" | "audio" | "source"
| "hr" | "br"
| "head" | "body" | "html" | "title" | "meta" | "link" | "script" | "style"
| "small" | "mark" | "sup" | "sub" | "abbr" | "time"
| "figure" | "figcaption" | "details" | "summary"
| "dl" | "dt" | "dd" -> true
| _ -> false
(* Void/skip tags -- don't render these *)
let is_skip_tag = function
| "head" | "meta" | "link" | "script" | "style" | "title"
| "source" | "input" -> true
| _ -> false
(* -- Extract keyword args from SX list -- *)
(** Extract keyword arguments and children from an SX element's argument list.
Returns [(attrs, children)] where attrs is a (key, value) list. *)
let extract_attrs (items : Sx_types.value list) : (string * Sx_types.value) list * Sx_types.value list =
let rec go attrs children = function
| [] -> (List.rev attrs, List.rev children)
| Sx_types.Keyword k :: v :: rest ->
go ((k, v) :: attrs) children rest
| other :: rest ->
go attrs (other :: children) rest
in
go [] [] items
(** Get a string attribute from keyword args. *)
let get_string_attr (attrs : (string * Sx_types.value) list) (key : string) : string option =
match List.assoc_opt key attrs with
| Some (Sx_types.String s) -> Some s
| _ -> None
(* -- Render SX values to native nodes -- *)
(** Make a text leaf node with inherited style. *)
let make_text_node (style : style) (text : string) : node =
{ tag = "#text"; style; children = []; text = Some text;
box = make_box (); href = None; on_click = None }
(** Render an SX value tree to a native node tree.
[~navigate] callback is invoked when a link is clicked. *)
let rec render ?(navigate : (string -> unit) option) (value : Sx_types.value) : node option =
match value with
| Sx_types.String s ->
Some (make_text_node default_style s)
| Sx_types.Number n ->
let s = if Float.is_integer n then string_of_int (int_of_float n)
else Printf.sprintf "%g" n in
Some (make_text_node default_style s)
| Sx_types.Bool true -> Some (make_text_node default_style "true")
| Sx_types.Bool false -> Some (make_text_node default_style "false")
| Sx_types.Nil -> None
| Sx_types.Keyword _ -> None (* bare keywords are attr markers *)
| Sx_types.Symbol _ -> None (* bare symbols are not renderable *)
| Sx_types.List (Sx_types.Symbol tag :: rest) when is_html_tag tag ->
if is_skip_tag tag then None
else begin
let (attrs, children_sx) = extract_attrs rest in
let class_str = get_string_attr attrs "class" in
let href = get_string_attr attrs "href" in
(* Build style: tag defaults + class overrides *)
let base = tag_base_style tag in
let style = match class_str with
| Some cls -> parse_classes ~base cls
| None -> base
in
(* Special: li gets a bullet prefix *)
let extra_children = if tag = "li" then
[make_text_node { style with flex_direction = `Row } "\xe2\x80\xa2 "]
else [] in
(* Render children *)
let children = extra_children @ List.filter_map (render ?navigate) children_sx in
(* For link nodes, set up navigation *)
let on_click = match href, navigate with
| Some h, Some nav -> Some (fun () -> nav h)
| _ -> None
in
Some { tag; style; children; text = None;
box = make_box (); href; on_click }
end
(* Component calls (~name ...) -- render as placeholder *)
| Sx_types.List (Sx_types.Symbol name :: rest) when String.length name > 0 && name.[0] = '~' ->
let (attrs, children_sx) = extract_attrs rest in
let class_str = get_string_attr attrs "class" in
let base = { default_style with
border_width = 1.;
border_color = Some violet_200;
border_radius = 4.;
padding = { top = 8.; right = 8.; bottom = 8.; left = 8. } } in
let style = match class_str with
| Some cls -> parse_classes ~base cls
| None -> base
in
let label = make_text_node
{ default_style with font_size = 12.; text_color = violet_500; font_family = `Mono }
name in
let children = label :: List.filter_map (render ?navigate) children_sx in
Some { tag = "component"; style; children; text = None;
box = make_box (); href = None; on_click = None }
(* Unknown list forms -- try to render children *)
| Sx_types.List items ->
let children = List.filter_map (render ?navigate) items in
if children = [] then None
else if List.length children = 1 then Some (List.hd children)
else
Some { tag = "group"; style = default_style; children; text = None;
box = make_box (); href = None; on_click = None }
| _ -> None (* Lambda, Dict, etc. -- skip *)
(** Render a list of top-level SX values into a single root node. *)
let render_page ?(navigate : (string -> unit) option) (values : Sx_types.value list) : node =
let children = List.filter_map (render ?navigate) values in
(* Wrap everything in a root container *)
{ tag = "root";
style = { default_style with
width = `Full;
padding = { top = 0.; right = 0.; bottom = 0.; left = 0. } };
children;
text = None;
box = make_box ();
href = None;
on_click = None }

277
hosts/native/lib/sx_native_style.ml
View File

@@ -1,277 +0,0 @@
(** Parse Tailwind CSS class strings into native style records.
Supports ~50 common utility classes covering layout, spacing,
sizing, typography, colors, borders, and effects. *)
open Sx_native_types
(* -- Color palette (Tailwind stone + violet) -- *)
let white = { r = 1.0; g = 1.0; b = 1.0; a = 1.0 }
let black = { r = 0.0; g = 0.0; b = 0.0; a = 1.0 }
let stone_50 = { r = 0.980; g = 0.976; b = 0.973; a = 1.0 }
let stone_100 = { r = 0.961; g = 0.953; b = 0.945; a = 1.0 }
let stone_200 = { r = 0.906; g = 0.890; b = 0.875; a = 1.0 }
let stone_300 = { r = 0.839; g = 0.812; b = 0.788; a = 1.0 }
let stone_400 = { r = 0.659; g = 0.616; b = 0.576; a = 1.0 }
let stone_500 = { r = 0.471; g = 0.431; b = 0.396; a = 1.0 }
let stone_600 = { r = 0.341; g = 0.306; b = 0.275; a = 1.0 }
let stone_700 = { r = 0.267; g = 0.231; b = 0.208; a = 1.0 }
(* stone_800 is already in sx_native_types *)
let stone_900 = { r = 0.106; g = 0.098; b = 0.090; a = 1.0 }
let violet_50 = { r = 0.961; g = 0.953; b = 1.0; a = 1.0 }
let violet_100 = { r = 0.929; g = 0.906; b = 0.996; a = 1.0 }
let violet_200 = { r = 0.867; g = 0.820; b = 0.992; a = 1.0 }
let violet_300 = { r = 0.769; g = 0.686; b = 0.984; a = 1.0 }
let violet_400 = { r = 0.655; g = 0.525; b = 0.969; a = 1.0 }
let violet_500 = { r = 0.545; g = 0.361; b = 0.945; a = 1.0 }
let violet_600 = { r = 0.486; g = 0.227; b = 0.929; a = 1.0 }
let violet_700 = { r = 0.427; g = 0.176; b = 0.831; a = 1.0 }
let violet_800 = { r = 0.357; g = 0.153; b = 0.694; a = 1.0 }
let violet_900 = { r = 0.298; g = 0.133; b = 0.576; a = 1.0 }
let red_500 = { r = 0.937; g = 0.267; b = 0.267; a = 1.0 }
let red_600 = { r = 0.863; g = 0.145; b = 0.145; a = 1.0 }
let blue_500 = { r = 0.231; g = 0.510; b = 0.965; a = 1.0 }
let blue_600 = { r = 0.145; g = 0.388; b = 0.922; a = 1.0 }
let green_500 = { r = 0.133; g = 0.773; b = 0.369; a = 1.0 }
let green_600 = { r = 0.086; g = 0.635; b = 0.290; a = 1.0 }
let amber_500 = { r = 0.961; g = 0.718; b = 0.078; a = 1.0 }
(* -- Spacing scale (Tailwind: 1 unit = 4px) -- *)
let spacing n = float_of_int n *. 4.0
(* -- Font sizes (Tailwind) -- *)
let font_size_of = function
| "text-xs" -> 12.
| "text-sm" -> 14.
| "text-base" -> 16.
| "text-lg" -> 18.
| "text-xl" -> 20.
| "text-2xl" -> 24.
| "text-3xl" -> 30.
| "text-4xl" -> 36.
| "text-5xl" -> 48.
| _ -> 16.
(* -- Parse a single Tailwind class, mutating a style -- *)
let parse_spacing_value s =
(* Extract numeric value from strings like "p-4", "gap-2" *)
match int_of_string_opt s with
| Some n -> spacing n
| None -> 0.
let bg_color_of cls =
match cls with
| "bg-white" -> Some white
| "bg-black" -> Some black
| "bg-stone-50" -> Some stone_50
| "bg-stone-100" -> Some stone_100
| "bg-stone-200" -> Some stone_200
| "bg-stone-300" -> Some stone_300
| "bg-stone-400" -> Some stone_400
| "bg-stone-500" -> Some stone_500
| "bg-stone-600" -> Some stone_600
| "bg-stone-700" -> Some stone_700
| "bg-stone-800" -> Some stone_800
| "bg-stone-900" -> Some stone_900
| "bg-violet-50" -> Some violet_50
| "bg-violet-100" -> Some violet_100
| "bg-violet-200" -> Some violet_200
| "bg-violet-300" -> Some violet_300
| "bg-violet-400" -> Some violet_400
| "bg-violet-500" -> Some violet_500
| "bg-violet-600" -> Some violet_600
| "bg-violet-700" -> Some violet_700
| "bg-violet-800" -> Some violet_800
| "bg-violet-900" -> Some violet_900
| "bg-red-500" -> Some red_500
| "bg-red-600" -> Some red_600
| "bg-blue-500" -> Some blue_500
| "bg-blue-600" -> Some blue_600
| "bg-green-500" -> Some green_500
| "bg-green-600" -> Some green_600
| "bg-amber-500" -> Some amber_500
| _ -> None
let text_color_of cls =
match cls with
| "text-white" -> Some white
| "text-black" -> Some black
| "text-stone-50" -> Some stone_50
| "text-stone-100" -> Some stone_100
| "text-stone-200" -> Some stone_200
| "text-stone-300" -> Some stone_300
| "text-stone-400" -> Some stone_400
| "text-stone-500" -> Some stone_500
| "text-stone-600" -> Some stone_600
| "text-stone-700" -> Some stone_700
| "text-stone-800" -> Some stone_800
| "text-stone-900" -> Some stone_900
| "text-violet-50" -> Some violet_50
| "text-violet-100" -> Some violet_100
| "text-violet-200" -> Some violet_200
| "text-violet-300" -> Some violet_300
| "text-violet-400" -> Some violet_400
| "text-violet-500" -> Some violet_500
| "text-violet-600" -> Some violet_600
| "text-violet-700" -> Some violet_700
| "text-violet-800" -> Some violet_800
| "text-violet-900" -> Some violet_900
| "text-red-500" -> Some red_500
| "text-red-600" -> Some red_600
| "text-blue-500" -> Some blue_500
| "text-blue-600" -> Some blue_600
| "text-green-500" -> Some green_500
| "text-green-600" -> Some green_600
| "text-amber-500" -> Some amber_500
| _ -> None
let border_color_of cls =
match cls with
| "border-stone-100" -> Some stone_100
| "border-stone-200" -> Some stone_200
| "border-stone-300" -> Some stone_300
| "border-violet-200" -> Some violet_200
| "border-violet-300" -> Some violet_300
| "border-white" -> Some white
| _ -> None
(** Apply a single Tailwind class to a style, returning the updated style. *)
let apply_class (s : style) (cls : string) : style =
(* Layout *)
if cls = "flex" then { s with display = `Flex; flex_direction = `Row }
else if cls = "flex-col" then { s with display = `Flex; flex_direction = `Column }
else if cls = "flex-row" then { s with display = `Flex; flex_direction = `Row }
else if cls = "block" then { s with display = `Block }
else if cls = "hidden" then { s with display = `None }
else if cls = "items-center" then { s with align_items = `Center }
else if cls = "items-start" then { s with align_items = `Start }
else if cls = "items-end" then { s with align_items = `End }
else if cls = "items-stretch" then { s with align_items = `Stretch }
else if cls = "justify-center" then { s with justify_content = `Center }
else if cls = "justify-between" then { s with justify_content = `Between }
else if cls = "justify-start" then { s with justify_content = `Start }
else if cls = "justify-end" then { s with justify_content = `End }
else if cls = "flex-grow" || cls = "grow" then { s with flex_grow = 1. }
(* Gap *)
else if String.length cls > 4 && String.sub cls 0 4 = "gap-" then
let n = String.sub cls 4 (String.length cls - 4) in
{ s with gap = parse_spacing_value n }
(* Padding *)
else if String.length cls > 2 && String.sub cls 0 2 = "p-" && cls.[2] <> 'x' && cls.[2] <> 'y' && cls.[2] <> 'l' && cls.[2] <> 'r' && cls.[2] <> 't' && cls.[2] <> 'b' then
let n = String.sub cls 2 (String.length cls - 2) in
let v = parse_spacing_value n in
{ s with padding = { top = v; right = v; bottom = v; left = v } }
else if String.length cls > 3 && String.sub cls 0 3 = "px-" then
let n = String.sub cls 3 (String.length cls - 3) in
let v = parse_spacing_value n in
{ s with padding = { s.padding with left = v; right = v } }
else if String.length cls > 3 && String.sub cls 0 3 = "py-" then
let n = String.sub cls 3 (String.length cls - 3) in
let v = parse_spacing_value n in
{ s with padding = { s.padding with top = v; bottom = v } }
else if String.length cls > 3 && String.sub cls 0 3 = "pt-" then
let n = String.sub cls 3 (String.length cls - 3) in
{ s with padding = { s.padding with top = parse_spacing_value n } }
else if String.length cls > 3 && String.sub cls 0 3 = "pb-" then
let n = String.sub cls 3 (String.length cls - 3) in
{ s with padding = { s.padding with bottom = parse_spacing_value n } }
else if String.length cls > 3 && String.sub cls 0 3 = "pl-" then
let n = String.sub cls 3 (String.length cls - 3) in
{ s with padding = { s.padding with left = parse_spacing_value n } }
else if String.length cls > 3 && String.sub cls 0 3 = "pr-" then
let n = String.sub cls 3 (String.length cls - 3) in
{ s with padding = { s.padding with right = parse_spacing_value n } }
(* Margin *)
else if String.length cls > 2 && String.sub cls 0 2 = "m-" && cls.[2] <> 'x' && cls.[2] <> 'y' && cls.[2] <> 'l' && cls.[2] <> 'r' && cls.[2] <> 't' && cls.[2] <> 'b' then
let n = String.sub cls 2 (String.length cls - 2) in
let v = parse_spacing_value n in
{ s with margin = { top = v; right = v; bottom = v; left = v } }
else if String.length cls > 3 && String.sub cls 0 3 = "mx-" then
let n = String.sub cls 3 (String.length cls - 3) in
let v = parse_spacing_value n in
{ s with margin = { s.margin with left = v; right = v } }
else if String.length cls > 3 && String.sub cls 0 3 = "my-" then
let n = String.sub cls 3 (String.length cls - 3) in
let v = parse_spacing_value n in
{ s with margin = { s.margin with top = v; bottom = v } }
else if String.length cls > 3 && String.sub cls 0 3 = "mt-" then
let n = String.sub cls 3 (String.length cls - 3) in
{ s with margin = { s.margin with top = parse_spacing_value n } }
else if String.length cls > 3 && String.sub cls 0 3 = "mb-" then
let n = String.sub cls 3 (String.length cls - 3) in
{ s with margin = { s.margin with bottom = parse_spacing_value n } }
(* Sizing *)
else if cls = "w-full" then { s with width = `Full }
else if cls = "h-full" then { s with height = `Full }
else if String.length cls > 2 && String.sub cls 0 2 = "w-" then
let n = String.sub cls 2 (String.length cls - 2) in
(match int_of_string_opt n with
| Some v -> { s with width = `Px (float_of_int v *. 4.) }
| None -> s)
else if String.length cls > 2 && String.sub cls 0 2 = "h-" then
let n = String.sub cls 2 (String.length cls - 2) in
(match int_of_string_opt n with
| Some v -> { s with height = `Px (float_of_int v *. 4.) }
| None -> s)
(* Typography *)
else if cls = "font-bold" then { s with font_weight = `Bold }
else if cls = "font-semibold" then { s with font_weight = `Bold }
else if cls = "font-normal" then { s with font_weight = `Normal }
else if cls = "italic" then { s with font_style = `Italic }
else if cls = "font-mono" then { s with font_family = `Mono }
else if String.length cls >= 5 && String.sub cls 0 5 = "text-" then
(* Could be text color or text size *)
let rest = String.sub cls 5 (String.length cls - 5) in
if rest = "xs" || rest = "sm" || rest = "base" || rest = "lg"
|| rest = "xl" || rest = "2xl" || rest = "3xl" || rest = "4xl"
|| rest = "5xl" then
{ s with font_size = font_size_of cls }
else
(match text_color_of cls with
| Some c -> { s with text_color = c }
| None -> s)
(* Background *)
else if String.length cls >= 3 && String.sub cls 0 3 = "bg-" then
(match bg_color_of cls with
| Some c -> { s with bg_color = Some c }
| None -> s)
(* Borders *)
else if cls = "rounded" then { s with border_radius = 4. }
else if cls = "rounded-md" then { s with border_radius = 6. }
else if cls = "rounded-lg" then { s with border_radius = 8. }
else if cls = "rounded-xl" then { s with border_radius = 12. }
else if cls = "rounded-2xl" then { s with border_radius = 16. }
else if cls = "rounded-full" then { s with border_radius = 9999. }
else if cls = "border" then
{ s with border_width = 1.;
border_color = (if s.border_color = None then Some stone_200 else s.border_color) }
else if cls = "border-2" then
{ s with border_width = 2.;
border_color = (if s.border_color = None then Some stone_200 else s.border_color) }
else if String.length cls >= 7 && String.sub cls 0 7 = "border-" then
(match border_color_of cls with
| Some c -> { s with border_color = Some c;
border_width = (if s.border_width = 0. then 1. else s.border_width) }
| None -> s)
(* Shadow *)
else if cls = "shadow" then { s with shadow = `Sm }
else if cls = "shadow-md" then { s with shadow = `Md }
else if cls = "shadow-lg" then { s with shadow = `Md }
(* Overflow *)
else if cls = "overflow-hidden" then { s with overflow_hidden = true }
else s (* unknown class: ignore *)
(** Parse a space-separated Tailwind class string into a [style]. *)
let parse_classes ?(base = default_style) (classes : string) : style =
let parts = String.split_on_char ' ' classes in
List.fold_left (fun s cls ->
let cls = String.trim cls in
if cls = "" then s else apply_class s cls
) base parts

79
hosts/native/lib/sx_native_types.ml
View File

@@ -1,79 +0,0 @@
(** Types for the SX native render tree.
Every SX element is converted to a [node] with a [style] record
that the layout engine positions and the painter draws. *)
type color = { r: float; g: float; b: float; a: float }
type edges = { top: float; right: float; bottom: float; left: float }
type style = {
display: [`Flex | `Block | `None];
flex_direction: [`Row | `Column];
gap: float;
padding: edges;
margin: edges;
align_items: [`Start | `Center | `End | `Stretch];
justify_content: [`Start | `Center | `End | `Between];
flex_grow: float;
bg_color: color option;
text_color: color;
font_size: float;
font_weight: [`Normal | `Bold];
font_style: [`Normal | `Italic];
font_family: [`Sans | `Mono];
border_radius: float;
border_width: float;
border_color: color option;
width: [`Auto | `Px of float | `Full];
height: [`Auto | `Px of float | `Full];
shadow: [`None | `Sm | `Md];
overflow_hidden: bool;
}
type box = {
mutable x: float;
mutable y: float;
mutable w: float;
mutable h: float;
}
type node = {
tag: string;
style: style;
children: node list;
text: string option;
box: box;
href: string option;
on_click: (unit -> unit) option;
}
let zero_edges = { top = 0.; right = 0.; bottom = 0.; left = 0. }
let stone_800 = { r = 0.114; g = 0.094; b = 0.082; a = 1.0 }
let default_style = {
display = `Flex;
flex_direction = `Column;
gap = 0.;
padding = zero_edges;
margin = zero_edges;
align_items = `Stretch;
justify_content = `Start;
flex_grow = 0.;
bg_color = None;
text_color = stone_800;
font_size = 16.;
font_weight = `Normal;
font_style = `Normal;
font_family = `Sans;
border_radius = 0.;
border_width = 0.;
border_color = None;
width = `Auto;
height = `Auto;
shadow = `None;
overflow_hidden = false;
}
let make_box () = { x = 0.; y = 0.; w = 0.; h = 0. }

1
hosts/native/lib_sx
View File

@@ -1 +0,0 @@
../../hosts/ocaml/lib

3
hosts/native/test/dune
View File

@@ -1,3 +0,0 @@
(executable
(name test_render)
(libraries sx sx_native cairo2 unix))

75
hosts/native/test/test_render.ml
View File

@@ -1,75 +0,0 @@
(** Smoke test: parse SX, render to node tree, measure, layout, paint to PNG. *)
open Sx_native.Sx_native_types
let demo_sx = {|
(div :class "flex flex-col items-center gap-6 p-8 bg-stone-50"
(h1 :class "text-3xl font-bold text-stone-800" "SX Native Browser")
(p :class "text-stone-500" "Rendering s-expressions directly to pixels")
(div :class "flex gap-4 items-center"
(div :class "p-4 rounded-lg bg-white border border-stone-200 shadow"
(h3 :class "font-bold text-stone-700" "No HTML")
(p :class "text-sm text-stone-500" "This is not a web page"))
(div :class "p-4 rounded-lg bg-white border border-stone-200 shadow"
(h3 :class "font-bold text-stone-700" "No CSS")
(p :class "text-sm text-stone-500" "Tailwind classes parsed to native styles"))
(div :class "p-4 rounded-lg bg-white border border-stone-200 shadow"
(h3 :class "font-bold text-stone-700" "No JavaScript")
(p :class "text-sm text-stone-500" "The SX evaluator does everything")))
(div :class "p-6 rounded-lg bg-violet-600"
(p :class "text-white text-lg font-bold" "5000 lines of OCaml instead of 35 million lines of browser engine")))
|}
let rec count_nodes (node : node) : int =
1 + List.fold_left (fun acc c -> acc + count_nodes c) 0 node.children
let rec print_tree indent (node : node) =
let prefix = String.make (indent * 2) ' ' in
let text_info = match node.text with
| Some t -> Printf.sprintf " \"%s\"" (if String.length t > 30 then String.sub t 0 30 ^ "..." else t)
| None -> ""
in
let size_info = Printf.sprintf " [%.0fx%.0f @ (%.0f,%.0f)]" node.box.w node.box.h node.box.x node.box.y in
Printf.printf "%s<%s>%s%s\n" prefix node.tag text_info size_info;
List.iter (print_tree (indent + 1)) node.children
let () =
Printf.printf "=== SX Native Browser Smoke Test ===\n\n";
(* 1. Parse *)
let values = Sx_parser.parse_all demo_sx in
Printf.printf "1. Parsed %d top-level form(s)\n" (List.length values);
(* 2. Render to node tree *)
let root = Sx_native.Sx_native_render.render_page values in
let n = count_nodes root in
Printf.printf "2. Render tree: %d nodes, root tag=%s\n" n root.tag;
(* 3. Create Cairo surface for measurement *)
let surface = Cairo.Image.create Cairo.Image.ARGB32 ~w:1024 ~h:768 in
let cr = Cairo.create surface in
(* 4. Measure *)
Sx_native.Sx_native_layout.measure cr root;
Printf.printf "3. Measured intrinsic size: %.0f x %.0f\n" root.box.w root.box.h;
(* 5. Layout *)
Sx_native.Sx_native_layout.layout root 0. 0. 1024. 732.;
Printf.printf "4. Layout complete, root positioned at (%.0f, %.0f) size %.0f x %.0f\n"
root.box.x root.box.y root.box.w root.box.h;
(* 6. Paint *)
Sx_native.Sx_native_paint.paint_scene cr root "sx://demo" 1024. 768.;
Cairo.Surface.flush surface;
(* 7. Write PNG *)
let png_path = "/tmp/sx_browser_test.png" in
Cairo.PNG.write surface png_path;
Printf.printf "5. Rendered to %s\n\n" png_path;
(* Print tree *)
Printf.printf "=== Render Tree ===\n";
print_tree 0 root;
Cairo.Surface.finish surface;
Printf.printf "\n=== All OK! ===\n"

6
hosts/ocaml/bin/debug_set.ml
View File

@@ -1,6 +1,6 @@
module T = Sx_types
module P = Sx_parser
module R = Sx_ref
module T = Sx.Sx_types
module P = Sx.Sx_parser
module R = Sx.Sx_ref
open T
let () =

8
hosts/ocaml/bin/dune
View File

@@ -1,11 +1,3 @@
(executables
(names run_tests debug_set sx_server integration_tests)
(libraries sx unix))
(executable
(name mcp_tree)
(libraries sx unix yojson str))
(executable
(name test_cst)
(libraries sx))

146
hosts/ocaml/bin/integration_tests.ml
View File

@@ -7,7 +7,12 @@
Usage:
dune exec bin/integration_tests.exe *)
(* Modules accessed directly — library is unwrapped *)
module Sx_types = Sx.Sx_types
module Sx_parser = Sx.Sx_parser
module Sx_primitives = Sx.Sx_primitives
module Sx_runtime = Sx.Sx_runtime
module Sx_ref = Sx.Sx_ref
module Sx_render = Sx.Sx_render
open Sx_types
@@ -315,7 +320,7 @@ let make_integration_env () =
let body_env = { bindings = Hashtbl.create 16; parent = Some e } in
List.iteri (fun i p ->
let v = if i < List.length macro_args then List.nth macro_args i else Nil in
Hashtbl.replace body_env.bindings (Sx_types.intern p) v
Hashtbl.replace body_env.bindings p v
) m.m_params;
Sx_ref.eval_expr m.m_body (Env body_env)
| _ -> raise (Eval_error "expand-macro: expected (macro args env)"));
@@ -407,7 +412,7 @@ let () =
let render_html src =
let exprs = Sx_parser.parse_all src in
let expr = match exprs with [e] -> e | _ -> Nil in
Sx_render.sx_render_to_html env expr env
Sx_render.render_to_html expr env
in
(* Helper: call SX render-to-html via the adapter *)
@@ -508,141 +513,6 @@ let () =
(reset! s (list 1 2 3))
(len (deref s)))");
(* ================================================================== *)
Printf.printf "\nSuite: JIT closure scoping\n%!";
(* The JIT bug: when a lambda captures closure vars (e.g. from let/letrec),
the VM must use the closure's vm_env_ref (which has the merged bindings),
not the caller's globals (which lacks them). This test reproduces the
exact pattern that broke the home stepper: a component with a letrec
binding referenced inside a map callback. *)
(* 1. Define a component whose body uses letrec + map with closure var *)
assert_no_error "defcomp with letrec+map closure var" (fun () ->
ignore (Sx_ref.eval_expr
(List.hd (Sx_parser.parse_all
"(defcomp ~jit-test (&key)
(let ((items (list \"a\" \"b\" \"c\")))
(letrec ((fmt (fn (x) (str \"[\" x \"]\"))))
(div (map (fn (item) (span (fmt item))) items)))))"))
(Env env)));
(* 2. Render it — this triggers JIT compilation of the map callback *)
assert_contains "jit closure: first render"
"[a]" (sx_render_html "(~jit-test)");
(* 3. Render something ELSE — tests that the JIT-compiled closure
still works when called in a different context *)
assert_contains "jit closure: unrelated render between"
"<p>" (sx_render_html "(p \"hello\")");
(* 4. Render the component AGAIN — the JIT-compiled map callback
must still find 'fmt' via its closure env, not the caller's globals *)
assert_contains "jit closure: second render still works"
"[b]" (sx_render_html "(~jit-test)");
(* 5. Test with signal (the actual stepper pattern) *)
assert_no_error "defcomp with signal+map closure" (fun () ->
ignore (Sx_ref.eval_expr
(List.hd (Sx_parser.parse_all
"(defcomp ~jit-signal-test (&key)
(let ((data (signal (list 1 2 3))))
(letrec ((double (fn (x) (* x 2))))
(div (map (fn (item) (span (str (double item)))) (deref data))))))"))
(Env env)));
assert_contains "jit signal closure: renders" "4" (sx_render_html "(~jit-signal-test)");
assert_contains "jit signal closure: after other render"
"4" (let _ = sx_render_html "(div \"break\")" in sx_render_html "(~jit-signal-test)");
(* 6. Nested closures — lambda inside lambda, both with closure vars *)
assert_no_error "defcomp with nested closures" (fun () ->
ignore (Sx_ref.eval_expr
(List.hd (Sx_parser.parse_all
"(defcomp ~jit-nested (&key)
(let ((prefix \">\"))
(letrec ((wrap (fn (x)
(let ((suffix \"<\"))
(str prefix x suffix)))))
(div (map (fn (item) (span (wrap item)))
(list \"a\" \"b\"))))))"))
(Env env)));
assert_contains "nested closure: inner sees outer var"
"&gt;a&lt;" (sx_render_html "(~jit-nested)");
assert_contains "nested closure: second item"
"&gt;b&lt;" (sx_render_html "(~jit-nested)");
(* After unrelated render, nested closures still work *)
assert_contains "nested closure: survives context switch"
"&gt;a&lt;" (let _ = sx_render_html "(p \"x\")" in sx_render_html "(~jit-nested)");
(* 7. Mutual recursion in letrec *)
assert_no_error "defcomp with mutual recursion" (fun () ->
ignore (Sx_ref.eval_expr
(List.hd (Sx_parser.parse_all
"(defcomp ~jit-mutual (&key)
(letrec ((is-even (fn (n)
(if (= n 0) true (is-odd (- n 1)))))
(is-odd (fn (n)
(if (= n 0) false (is-even (- n 1))))))
(div
(span (str (is-even 4)))
(span (str (is-odd 3))))))"))
(Env env)));
assert_contains "mutual recursion: is-even 4" "true" (sx_render_html "(~jit-mutual)");
assert_contains "mutual recursion: is-odd 3" "true" (sx_render_html "(~jit-mutual)");
assert_contains "mutual recursion: survives context switch"
"true" (let _ = sx_render_html "(div \"y\")" in sx_render_html "(~jit-mutual)");
(* 8. set! modifying closure var after JIT compilation *)
assert_no_error "defcomp with set! mutation" (fun () ->
ignore (Sx_ref.eval_expr
(List.hd (Sx_parser.parse_all
"(defcomp ~jit-setbang (&key)
(let ((counter 0))
(letrec ((bump (fn () (set! counter (+ counter 1)) counter))
(get-count (fn () counter)))
(div (span (str (bump)))
(span (str (bump)))
(span (str (get-count)))))))"))
(Env env)));
(* Each render should restart counter at 0 since it's a fresh let *)
assert_contains "set! mutation: first bump" "1" (sx_render_html "(~jit-setbang)");
assert_contains "set! mutation: second bump" "2" (sx_render_html "(~jit-setbang)");
(* 9. Island with signal + effect + letrec — the stepper pattern *)
assert_no_error "defisland with signal+letrec+map" (fun () ->
ignore (Sx_ref.eval_expr
(List.hd (Sx_parser.parse_all
"(defisland ~jit-island-test ()
(let ((items (signal (list \"x\" \"y\" \"z\")))
(label (signal \"test\")))
(letrec ((format-item (fn (item)
(str (deref label) \":\" item))))
(div (map (fn (i) (span (format-item i)))
(deref items))))))"))
(Env env)));
assert_contains "island signal+letrec: renders"
"test:x" (sx_render_html "(~jit-island-test)");
assert_contains "island signal+letrec: after other render"
"test:y" (let _ = sx_render_html "(p \"z\")" in sx_render_html "(~jit-island-test)");
(* 10. Deep nesting — for-each inside map inside letrec inside let *)
assert_no_error "defcomp with deep nesting" (fun () ->
ignore (Sx_ref.eval_expr
(List.hd (Sx_parser.parse_all
"(defcomp ~jit-deep (&key)
(let ((rows (list (list 1 2) (list 3 4))))
(letrec ((sum-row (fn (row)
(reduce + 0 row))))
(div (map (fn (row)
(span (str (sum-row row))))
rows)))))"))
(Env env)));
assert_contains "deep nesting: first row sum" "3" (sx_render_html "(~jit-deep)");
assert_contains "deep nesting: second row sum" "7" (sx_render_html "(~jit-deep)");
assert_contains "deep nesting: survives context switch"
"3" (let _ = sx_render_html "(div \"w\")" in sx_render_html "(~jit-deep)");
(* ================================================================== *)
Printf.printf "\n";
Printf.printf "============================================================\n";

2562
hosts/ocaml/bin/mcp_tree.ml
View File

File diff suppressed because it is too large Load Diff

754
hosts/ocaml/bin/run_tests.ml
View File

@@ -10,7 +10,12 @@
dune exec bin/run_tests.exe -- test-primitives # specific test
dune exec bin/run_tests.exe -- --foundation # foundation only *)
(* Modules accessed directly — library is unwrapped *)
module Sx_types = Sx.Sx_types
module Sx_parser = Sx.Sx_parser
module Sx_primitives = Sx.Sx_primitives
module Sx_runtime = Sx.Sx_runtime
module Sx_ref = Sx.Sx_ref
module Sx_render = Sx.Sx_render
open Sx_types
open Sx_parser
@@ -50,13 +55,6 @@ let rec deep_equal a b =
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
| Record a, Record b ->
a.r_type.rt_uid = b.r_type.rt_uid &&
Array.length a.r_fields = Array.length b.r_fields &&
(let eq = ref true in
for i = 0 to Array.length a.r_fields - 1 do
if not (deep_equal a.r_fields.(i) b.r_fields.(i)) then eq := false
done; !eq)
| Lambda _, Lambda _ -> a == b (* identity *)
| NativeFn _, NativeFn _ -> a == b
| _ -> false
@@ -72,18 +70,7 @@ let make_test_env () =
ignore (Sx_types.env_bind env name (NativeFn (name, fn)))
in
(* --- platform functions required by test-framework.sx --- *)
bind "cek-try" (fun args ->
match args with
| [thunk; handler] ->
(try Sx_ref.cek_call thunk Nil
with Eval_error msg -> Sx_ref.cek_call handler (List [String msg]))
| [thunk] ->
(try let r = Sx_ref.cek_call thunk Nil in
List [Symbol "ok"; r]
with Eval_error msg -> List [Symbol "error"; String msg])
| _ -> Nil);
(* --- 5 platform functions required by test-framework.sx --- *)
bind "try-call" (fun args ->
match args with
@@ -206,9 +193,11 @@ let make_test_env () =
bind "env-bind!" (fun args ->
match args with
| [Dict d; String k; v] -> Hashtbl.replace d k v; v
| [Dict d; Keyword k; v] -> Hashtbl.replace d k v; v
| [e; String k; v] -> Sx_types.env_bind (uw e) k v
| [e; String k; v] ->
let ue = uw e in
if k = "x" || k = "children" || k = "i" then
Printf.eprintf "[env-bind!] '%s' env-id=%d bindings-before=%d\n%!" k (Obj.obj (Obj.repr ue) : int) (Hashtbl.length ue.Sx_types.bindings);
Sx_types.env_bind ue k v
| [e; Keyword k; v] -> Sx_types.env_bind (uw e) k v
| _ -> raise (Eval_error "env-bind!: expected env, key, value"));
@@ -218,8 +207,6 @@ let make_test_env () =
| [e; Keyword k; v] -> Sx_types.env_set (uw e) k v
| _ -> raise (Eval_error "env-set!: expected env, key, value"));
bind "make-env" (fun _args -> Env (Sx_types.make_env ()));
bind "env-extend" (fun args ->
match args with
| [e] -> Env (Sx_types.env_extend (uw e))
@@ -239,12 +226,7 @@ let make_test_env () =
bind "identical?" (fun args ->
match args with
| [a; b] -> Bool (match a, b with
| Number x, Number y -> x = y
| String x, String y -> x = y
| Bool x, Bool y -> x = y
| Nil, Nil -> true
| _ -> a == b)
| [a; b] -> Bool (a == b)
| _ -> raise (Eval_error "identical?: expected 2 args"));
(* --- Continuation support --- *)
@@ -291,14 +273,7 @@ let make_test_env () =
| _ -> raise (Eval_error "append!: expected list and value"));
(* --- HTML Renderer (from sx_render.ml library module) --- *)
Sx_render.setup_render_env env;
(* HTML tag functions — bind all tags as native fns returning (tag ...args) *)
List.iter (fun tag ->
ignore (Sx_types.env_bind env tag
(NativeFn ("html:" ^ tag, fun args -> List (Symbol tag :: args))))
) Sx_render.html_tags;
bind "is-html-tag?" (fun args -> match args with [String s] -> Bool (Sx_render.is_html_tag s) | _ -> Bool false);
Sx.Sx_render.setup_render_env env;
(* Stubs needed by adapter-html.sx when loaded at test time *)
bind "set-render-active!" (fun _args -> Nil);
@@ -311,31 +286,13 @@ let make_test_env () =
bind "eval-expr" (fun args ->
match args with
| [expr; e] ->
(match e with
| Dict _ -> Printf.eprintf "[EVAL-EXPR] env is Dict! expr=%s\n%!" (Sx_runtime.value_to_str expr)
| Nil -> Printf.eprintf "[EVAL-EXPR] env is Nil! expr=%s\n%!" (Sx_runtime.value_to_str expr)
| _ -> ());
let ue = Sx_runtime.unwrap_env e in
eval_expr expr (Env ue)
| [expr] -> eval_expr expr (Env env)
| _ -> raise (Eval_error "eval-expr: expected (expr env)"));
bind "set-render-active!" (fun _args -> Nil);
(* render-to-sx wrapper: if called with a string, parse and aser it *)
bind "render-to-sx" (fun args ->
match args with
| [String src] ->
let exprs = Sx_parser.parse_all src in
let expr = match exprs with [e] -> e | es -> List (Symbol "do" :: es) in
let result = eval_expr (List [Symbol "aser"; expr; Env env]) (Env env) in
(match result with SxExpr s -> String s | String s -> String s | _ -> String (Sx_runtime.value_to_str result))
| [expr; Env e] ->
let result = eval_expr (List [Symbol "aser"; expr; Env e]) (Env e) in
(match result with SxExpr s -> String s | String s -> String s | _ -> String (Sx_runtime.value_to_str result))
| _ -> String "");
(* Scope primitives — share the same scope stacks as sx_primitives.ml
so that CEK evaluator's scope_push/scope_peek and SX-level scope-push!/scope-peek
operate on the same table. *)
let _scope_stacks = Sx_primitives._scope_stacks in
(* Scope primitives — use a local scope stacks table.
Must match the same pattern as sx_server.ml's _scope_stacks. *)
let _scope_stacks : (string, Sx_types.value list) Hashtbl.t = Hashtbl.create 8 in
bind "scope-push!" (fun args ->
match args with
| [String name; value] ->
@@ -351,20 +308,6 @@ let make_test_env () =
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with _ :: rest -> Hashtbl.replace _scope_stacks name rest | [] -> ()); Nil
| _ -> Nil);
bind "scope-peek" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with v :: _ -> v | [] -> Nil)
| _ -> Nil);
let context_fn = (fun args ->
match args with
| String name :: rest ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with v :: _ -> v | [] -> (match rest with d :: _ -> d | [] -> Nil))
| _ -> Nil) in
bind "context" context_fn;
Sx_primitives.register "context" context_fn;
bind "scope-emit!" (fun args ->
match args with
| [String name; value] ->
@@ -405,229 +348,20 @@ let make_test_env () =
bind "cond-scheme?" (fun args ->
match args with
| [(List clauses | ListRef { contents = clauses })] ->
Bool (List.for_all (fun c ->
match c with
| List l | ListRef { contents = l } -> List.length l = 2
| _ -> false
) clauses)
(match clauses with
| (List _ | ListRef _) :: _ -> Bool true
| _ -> Bool false)
| _ -> Bool false);
bind "expand-macro" (fun args ->
match args with
| [Macro m; (List a | ListRef { contents = a }); _] ->
let local = Sx_types.env_extend m.m_closure in
let rec bind_params ps as' =
match ps, as' with
| [], rest ->
(match m.m_rest_param with
| Some rp -> ignore (Sx_types.env_bind local rp (List rest))
| None -> ())
| p :: ps_rest, a :: as_rest ->
ignore (Sx_types.env_bind local p a);
bind_params ps_rest as_rest
| remaining, [] ->
List.iter (fun p -> ignore (Sx_types.env_bind local p Nil)) remaining
in
bind_params m.m_params a;
List.iteri (fun i p ->
ignore (Sx_types.env_bind local p (if i < List.length a then List.nth a i else Nil))
) m.m_params;
eval_expr m.m_body (Env local)
| _ -> raise (Eval_error "expand-macro: expected (macro args env)"));
bind "cek-call" (fun args ->
match args with
| [fn_val; List call_args] -> Sx_ref.cek_call fn_val (List call_args)
| [fn_val; ListRef { contents = call_args }] -> Sx_ref.cek_call fn_val (List call_args)
| [fn_val; Nil] -> Sx_ref.cek_call fn_val (List [])
| [fn_val] -> Sx_ref.cek_call fn_val (List [])
| _ -> Nil);
bind "cek-run" (fun args ->
match args with
| [state] -> Sx_ref.cek_run state
| _ -> Nil);
bind "batch-begin!" (fun _args -> Sx_ref.batch_begin_b ());
bind "batch-end!" (fun _args -> Sx_ref.batch_end_b ());
bind "now-ms" (fun _args -> Number 1000.0);
bind "random-int" (fun args -> match args with [Number lo; _] -> Number lo | _ -> Number 0.0);
bind "try-rerender-page" (fun _args -> Nil);
bind "collect!" (fun args ->
match args with
| [String name; value] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with
| List items :: rest ->
if List.mem value items then Nil
else (Hashtbl.replace _scope_stacks name (List (items @ [value]) :: rest); Nil)
| _ ->
Hashtbl.replace _scope_stacks name (List [value] :: stack); Nil)
| _ -> Nil);
bind "collected" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with List items :: _ -> List items | _ -> List [])
| _ -> List []);
bind "clear-collected!" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with _ :: rest -> Hashtbl.replace _scope_stacks name (List [] :: rest) | [] -> ()); Nil
| _ -> Nil);
(* regex-find-all now provided by sx_primitives.ml *)
bind "callable?" (fun args ->
match args with
| [NativeFn _] | [Lambda _] | [Component _] | [Island _] -> Bool true
| _ -> Bool false);
bind "make-sx-expr" (fun args -> match args with [String s] -> SxExpr s | _ -> raise (Eval_error "make-sx-expr: expected string"));
bind "sx-expr-source" (fun args -> match args with [SxExpr s] -> String s | [String s] -> String s | _ -> raise (Eval_error "sx-expr-source: expected sx-expr or string"));
bind "sx-expr?" (fun args -> match args with [SxExpr _] -> Bool true | _ -> Bool false);
bind "spread?" (fun args -> match args with [Spread _] -> Bool true | _ -> Bool false);
bind "call-lambda" (fun args ->
match args with
| [Lambda _ as f; (List a | ListRef { contents = a })] ->
let l = match f with Lambda l -> l | _ -> assert false in
let local = Sx_types.env_extend l.l_closure in
let rec bind_ps ps as' = match ps, as' with
| [], _ -> () | p :: pr, a :: ar -> ignore (Sx_types.env_bind local p a); bind_ps pr ar
| p :: pr, [] -> ignore (Sx_types.env_bind local p Nil); bind_ps pr [] in
bind_ps l.l_params a;
eval_expr l.l_body (Env local)
| [Lambda _ as f; (List a | ListRef { contents = a }); Env e] ->
let l = match f with Lambda l -> l | _ -> assert false in
let local = Sx_types.env_merge l.l_closure e in
let rec bind_ps ps as' = match ps, as' with
| [], _ -> () | p :: pr, a :: ar -> ignore (Sx_types.env_bind local p a); bind_ps pr ar
| p :: pr, [] -> ignore (Sx_types.env_bind local p Nil); bind_ps pr [] in
bind_ps l.l_params a;
eval_expr l.l_body (Env local)
| _ -> raise (Eval_error "call-lambda: expected (fn args env?)"));
(* Declarative type/effect forms — no-ops at runtime *)
bind "deftype" (fun _args -> Nil);
bind "defeffect" (fun _args -> Nil);
bind "register-special-form!" (fun args ->
match args with
| [String name; fn_val] ->
(* Don't let SX modules override OCaml-registered defhandler/defisland *)
if name = "defhandler" || name = "defisland" then Nil
else (ignore (Sx_ref.register_special_form (String name) fn_val); Nil)
| _ -> Nil);
(* defhandler — register handler as handler:name in eval env.
Mirrors sx_server.ml's defhandler special form. *)
ignore (Sx_ref.register_special_form (String "defhandler") (NativeFn ("defhandler", fun sf_args ->
let raw_args, eval_env = match sf_args with
| [List a; Env e] | [ListRef { contents = a }; Env e] -> (a, e)
| _ -> ([], env) in
match raw_args with
| name_sym :: rest ->
let name = match name_sym with Symbol s -> s | String s -> s | _ -> Sx_types.inspect name_sym in
let rec parse_opts acc = function
| Keyword k :: v :: rest -> Hashtbl.replace acc k v; parse_opts acc rest
| rest -> (acc, rest) in
let opts = Hashtbl.create 4 in
let (_, remaining) = parse_opts opts rest in
let params, body_forms = match remaining with
| List p :: rest -> (p, rest) | _ -> ([], []) in
(* Wrap multiple body forms in (do ...) *)
let body = match body_forms with
| [] -> Nil | [b] -> b
| forms -> List (Symbol "do" :: forms) in
(* Extract &key param names for binding *)
let key_params =
let rec collect acc in_key = function
| [] -> List.rev acc
| Symbol "&key" :: rest -> collect acc true rest
| Symbol "&rest" :: _ :: rest -> collect acc false rest
| Symbol s :: rest when in_key -> collect (s :: acc) true rest
| _ :: rest -> collect acc in_key rest
in collect [] false params in
let hdef = Hashtbl.create 8 in
Hashtbl.replace hdef "__type" (String "handler");
Hashtbl.replace hdef "name" (String name);
Hashtbl.replace hdef "body" body;
Hashtbl.replace hdef "params" (List (List.map (fun s -> String s) key_params));
Hashtbl.replace hdef "closure" (Env eval_env);
Hashtbl.replace hdef "method" (match Hashtbl.find_opt opts "method" with
| Some (Keyword m) -> String m | Some v -> v | None -> String "get");
ignore (Sx_types.env_bind eval_env ("handler:" ^ name) (Dict hdef));
Dict hdef
| _ -> Nil)));
(* defisland — register island component. Stub: creates a component record. *)
ignore (Sx_ref.register_special_form (String "defisland") (NativeFn ("defisland", fun sf_args ->
let raw_args, eval_env = match sf_args with
| [List a; Env e] | [ListRef { contents = a }; Env e] -> (a, e)
| _ -> ([], env) in
match raw_args with
| name_sym :: rest ->
let name = match name_sym with Symbol s -> s | String s -> s | _ -> Sx_types.inspect name_sym in
let short_name = if String.length name > 1 && name.[0] = '~' then String.sub name 1 (String.length name - 1) else name in
let params, body = match rest with
| List p :: b :: _ -> (p, b) | List p :: [] -> (p, Nil) | _ -> ([], Nil) in
let param_names = List.filter_map (fun p ->
match p with Symbol s -> Some s | _ -> None) params in
let has_children = List.exists (fun p ->
match p with Symbol "&rest" -> true | _ -> false) params in
let island = Island {
i_name = short_name; i_params = param_names;
i_has_children = has_children;
i_body = body; i_closure = eval_env; i_file = None; i_compiled = None;
} in
ignore (Sx_types.env_bind eval_env name island);
island
| _ -> Nil)));
(* IO registry — spec-level defio populates *io-registry* in evaluator.
Bind accessor functions + __io-registry alias for backward compat. *)
ignore (Sx_types.env_bind env "__io-registry" Sx_ref._io_registry_);
bind "io-registered?" (fun args -> match args with [String n] -> Sx_ref.io_registered_p (String n) | _ -> Bool false);
bind "io-lookup" (fun args -> match args with [String n] -> Sx_ref.io_lookup (String n) | _ -> Nil);
bind "io-names" (fun _args -> Sx_ref.io_names ());
bind "io-register!" (fun args -> match args with [String n; spec] -> Sx_ref.io_register_b (String n) spec | _ -> Nil);
(* Foreign registry — spec-level define-foreign populates *foreign-registry*.
Bind accessor functions so test-foreign.sx can inspect the registry. *)
ignore (Sx_types.env_bind env "*foreign-registry*" Sx_ref._foreign_registry_);
bind "foreign-registered?" (fun args -> match args with [String n] -> Sx_ref.foreign_registered_p (String n) | _ -> Bool false);
bind "foreign-lookup" (fun args -> match args with [String n] -> Sx_ref.foreign_lookup (String n) | _ -> Nil);
bind "foreign-names" (fun _args -> Sx_ref.foreign_names ());
bind "foreign-register!" (fun args -> match args with [String n; spec] -> Sx_ref.foreign_register_b (String n) spec | _ -> Nil);
bind "foreign-resolve-binding" (fun args -> match args with [String s] -> Sx_ref.foreign_resolve_binding (String s) | _ -> Nil);
bind "foreign-check-args" (fun args ->
let to_list = function List l -> List l | ListRef r -> List !r | v -> v in
match args with
| [String n; (List _ | ListRef _ as p); (List _ | ListRef _ as a)] ->
Sx_ref.foreign_check_args (String n) (to_list p) (to_list a)
| _ -> Nil);
bind "foreign-build-lambda" (fun args -> match args with [spec] -> Sx_ref.foreign_build_lambda spec | _ -> Nil);
(* Initialize CEK call forward ref — needed by with-capabilities and foreign-dispatch *)
Sx_types._cek_call_ref := Sx_ref.cek_call;
(* --- Primitives for canonical.sx / content tests --- *)
bind "contains-char?" (fun args ->
match args with
| [String s; String c] when String.length c = 1 ->
Bool (String.contains s c.[0])
| _ -> Bool false);
bind "escape-string" (fun args ->
match args with
| [String s] ->
let buf = Buffer.create (String.length s + 4) in
String.iter (fun c -> match c with
| '"' -> Buffer.add_string buf "\\\""
| '\\' -> Buffer.add_string buf "\\\\"
| '\n' -> Buffer.add_string buf "\\n"
| '\t' -> Buffer.add_string buf "\\t"
| c -> Buffer.add_char buf c) s;
String (Buffer.contents buf)
| _ -> raise (Eval_error "escape-string: expected string"));
bind "sha3-256" (fun args ->
match args with
| [String s] ->
(* Stub: use a simple hash for testing — not real SHA3 *)
let h = Hashtbl.hash s in
String (Printf.sprintf "%064x" (abs h))
| _ -> raise (Eval_error "sha3-256: expected string"));
(* --- Missing primitives referenced by tests --- *)
bind "upcase" (fun args ->
@@ -727,8 +461,6 @@ let make_test_env () =
bind "component-param-types" (fun _args -> Nil);
bind "component-set-param-types!" (fun _args -> Nil);
bind "component-file" (fun args -> match args with [v] -> component_file v | _ -> Nil);
bind "component-set-file!" (fun args -> match args with [v; f] -> component_set_file v f | _ -> Nil);
bind "component-params" (fun args ->
match args with
@@ -816,60 +548,6 @@ let make_test_env () =
| [frame] -> Sx_ref.frame_type frame
| _ -> raise (Eval_error "frame-type: expected 1 arg"));
(* IO suspension primitives — inline until retranspile *)
let is_suspended state =
match get_val state (String "phase") with String "io-suspended" -> true | _ -> false in
let step_loop state =
let s = ref state in
while not (match Sx_ref.cek_terminal_p !s with Bool true -> true | _ -> false)
&& not (is_suspended !s) do
s := Sx_ref.cek_step !s
done;
!s in
bind "cek-step-loop" (fun args ->
match args with
| [state] -> step_loop state
| _ -> raise (Eval_error "cek-step-loop: expected 1 arg"));
bind "cek-resume" (fun args ->
match args with
| [state; result] ->
step_loop (Sx_ref.make_cek_value result (get_val state (String "env")) (get_val state (String "kont")))
| _ -> raise (Eval_error "cek-resume: expected 2 args"));
bind "cek-suspended?" (fun args ->
match args with
| [state] -> Bool (is_suspended state)
| _ -> raise (Eval_error "cek-suspended?: expected 1 arg"));
bind "cek-io-request" (fun args ->
match args with
| [state] -> get_val state (String "request")
| _ -> raise (Eval_error "cek-io-request: expected 1 arg"));
bind "make-cek-suspended" (fun args ->
match args with
| [req; env'; kont] ->
let d = Hashtbl.create 4 in
Hashtbl.replace d "phase" (String "io-suspended");
Hashtbl.replace d "request" req;
Hashtbl.replace d "env" env';
Hashtbl.replace d "kont" kont;
Dict d
| _ -> raise (Eval_error "make-cek-suspended: expected 3 args"));
(* --- Library registry --- *)
let lib_registry = Hashtbl.create 16 in
ignore (Sx_types.env_bind env "*library-registry*" (Dict lib_registry));
bind "library-loaded?" (fun args ->
match args with
| [spec] -> Sx_ref.library_loaded_p spec
| _ -> raise (Eval_error "library-loaded?: expected 1 arg"));
bind "library-exports" (fun args ->
match args with
| [spec] -> Sx_ref.library_exports spec
| _ -> raise (Eval_error "library-exports: expected 1 arg"));
bind "register-library" (fun args ->
match args with
| [spec; exports] -> Sx_ref.register_library spec exports
| _ -> raise (Eval_error "register-library: expected 2 args"));
(* --- 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));
@@ -894,118 +572,6 @@ let make_test_env () =
| [v; String expected] -> Sx_ref.value_matches_type_p v (String expected)
| _ -> raise (Eval_error "value-matches-type?: expected value and type string"));
(* Request primitives — stubs for test environment *)
let _test_state : (string, value) Hashtbl.t = Hashtbl.create 16 in
bind "now" (fun args ->
let fmt = match args with String f :: _ -> f | _ -> "%Y-%m-%d %H:%M:%S" in
let open Unix in let tm = localtime (gettimeofday ()) in
let r = if fmt = "%H:%M:%S" then Printf.sprintf "%02d:%02d:%02d" tm.tm_hour tm.tm_min tm.tm_sec
else Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d" (tm.tm_year+1900) (tm.tm_mon+1) tm.tm_mday tm.tm_hour tm.tm_min tm.tm_sec in
String r);
bind "state-get" (fun args -> match args with
| String key :: rest -> let default = match rest with v :: _ -> v | [] -> Nil in
(match Hashtbl.find_opt _test_state key with Some v -> v | None -> default)
| _ -> Nil);
bind "state-set!" (fun args -> match args with
| String key :: value :: _ -> Hashtbl.replace _test_state key value; Nil | _ -> Nil);
bind "state-clear!" (fun args -> match args with
| [String key] -> Hashtbl.remove _test_state key; Nil | _ -> Nil);
bind "request-method" (fun _args -> String "GET");
bind "request-body" (fun _args -> String "");
bind "request-form" (fun args -> match args with
| String _ :: rest -> (match rest with v :: _ -> v | [] -> String "") | _ -> String "");
bind "request-arg" (fun args -> match args with
| String _ :: rest -> (match rest with v :: _ -> v | [] -> Nil) | _ -> Nil);
bind "request-form-all" (fun _args -> Dict (Hashtbl.create 0));
bind "request-args-all" (fun _args -> Dict (Hashtbl.create 0));
bind "request-form-list" (fun _args -> List []);
bind "request-json" (fun _args -> String "");
bind "request-header" (fun args -> match args with
| String _ :: rest -> (match rest with v :: _ -> v | [] -> String "") | _ -> String "");
bind "request-headers-all" (fun _args -> Dict (Hashtbl.create 0));
bind "request-content-type" (fun _args -> String "");
bind "request-file-name" (fun _args -> String "");
bind "into" (fun args -> match args with
| [String "list"; Dict d] ->
List (Hashtbl.fold (fun k v acc -> List [String k; v] :: acc) d [])
| [String "dict"; List pairs] | [String "dict"; ListRef { contents = pairs }] ->
let d = Hashtbl.create 8 in
List.iter (fun pair -> match pair with
| List [String k; v] | ListRef { contents = [String k; v] } -> Hashtbl.replace d k v
| _ -> ()) pairs;
Dict d
| _ -> Nil);
(* --- Stubs for offline/IO tests --- *)
bind "log-info" (fun _args -> Nil);
bind "log-warn" (fun _args -> Nil);
bind "log-error" (fun _args -> Nil);
bind "execute-action" (fun _args -> Nil);
(* --- make-page-def for defpage tests --- *)
bind "make-page-def" (fun args ->
let convert_val = function Keyword k -> String k | v -> v in
let make_pdef name slots =
let d = Hashtbl.create 8 in
Hashtbl.replace d "__type" (String "page");
Hashtbl.replace d "name" (String name);
(* Defaults for missing fields *)
Hashtbl.replace d "stream" (Bool false);
Hashtbl.replace d "shell" Nil;
Hashtbl.replace d "fallback" Nil;
Hashtbl.replace d "data" Nil;
(* Override with actual slot values *)
Hashtbl.iter (fun k v -> Hashtbl.replace d k (convert_val v)) slots;
Dict d
in
match args with
| [String name; Dict slots; _env] -> make_pdef name slots
| [String name; Dict slots] -> make_pdef name slots
| _ -> Nil);
(* --- component-io-refs for deps.sx tests --- *)
bind "component-io-refs" (fun args ->
match args with
| [Component c] ->
(* Scan body for IO calls — look for known IO functions *)
let rec scan = function
| List (Symbol s :: _) when
s = "fetch" || s = "fetch-data" || s = "query" || s = "action" ||
s = "state-get" || s = "state-set!" ||
s = "request-arg" || s = "request-form" || s = "request-method" || s = "now" ||
s = "request-header" || s = "request-json" || s = "request-content-type" ||
s = "execute-action" || s = "submit-mutation" -> [s]
| List items | ListRef { contents = items } -> List.concat_map scan items
| _ -> []
in
let refs = scan c.c_body in
let unique = List.sort_uniq String.compare refs in
List (List.map (fun s -> String s) unique)
| _ -> List []);
bind "component-set-io-refs!" (fun _args -> Nil);
(* --- Fragment binding for aser tests --- *)
bind "<>" (fun args -> List args);
(* --- component-deps / component-set-deps! for deps.sx --- *)
let _comp_deps : (string, value) Hashtbl.t = Hashtbl.create 16 in
bind "component-deps" (fun args ->
match args with
| [Component c] -> (match Hashtbl.find_opt _comp_deps c.c_name with Some v -> v | None -> Nil)
| [Island i] -> (match Hashtbl.find_opt _comp_deps i.i_name with Some v -> v | None -> Nil)
| _ -> Nil);
bind "component-set-deps!" (fun args ->
match args with
| [Component c; v] -> Hashtbl.replace _comp_deps c.c_name v; Nil
| [Island i; v] -> Hashtbl.replace _comp_deps i.i_name v; Nil
| _ -> Nil);
(* --- submit-mutation stub for offline tests --- *)
bind "submit-mutation" (fun args ->
match args with
| _ :: _ -> String "confirmed"
| _ -> Nil);
env
(* ====================================================================== *)
@@ -1152,101 +718,6 @@ let run_spec_tests env test_files =
exit 1
end;
(* IO-aware evaluation: resolve library paths and handle import suspension *)
let lib_base = Filename.concat project_dir "lib" in
let spec_base = Filename.concat project_dir "spec" in
let web_base = Filename.concat project_dir "web" in
let resolve_library_path lib_spec =
let parts = match lib_spec with List l | ListRef { contents = l } -> l | _ -> [] in
match List.map (fun v -> match v with Symbol s -> s | String s -> s | _ -> "") parts with
| ["sx"; name] ->
let spec_path = Filename.concat spec_base (name ^ ".sx") in
let lib_path = Filename.concat lib_base (name ^ ".sx") in
let web_lib_path = Filename.concat (Filename.concat web_base "lib") (name ^ ".sx") in
if Sys.file_exists spec_path then Some spec_path
else if Sys.file_exists lib_path then Some lib_path
else if Sys.file_exists web_lib_path then Some web_lib_path
else None
| ["web"; name] ->
let path = Filename.concat web_base (name ^ ".sx") in
let lib_path = Filename.concat (Filename.concat web_base "lib") (name ^ ".sx") in
if Sys.file_exists path then Some path
else if Sys.file_exists lib_path then Some lib_path
else None
| [prefix; name] ->
let path = Filename.concat (Filename.concat project_dir prefix) (name ^ ".sx") in
if Sys.file_exists path then Some path else None
| _ -> None
in
(* Run CEK step loop, handling IO suspension for imports *)
let rec eval_with_io expr env_val =
let state = Sx_ref.make_cek_state expr env_val (List []) in
run_with_io state
and load_library_file path =
let exprs = Sx_parser.parse_file path in
List.iter (fun expr -> ignore (eval_with_io expr (Env env))) exprs
and run_with_io state =
let s = ref state in
let is_terminal st = match Sx_ref.cek_terminal_p st with Bool true -> true | _ -> false in
let is_suspended st = match Sx_runtime.get_val st (String "phase") with String "io-suspended" -> true | _ -> false in
(* Check if kont has any handler frames — pure structural scan *)
let kont_has_handler kont =
let k = ref kont in
let found = ref false in
while (match !k with List (_::_) -> true | _ -> false) && not !found do
(match !k with
| List (frame :: rest) ->
(match frame with
| CekFrame f when f.cf_type = "handler" -> found := true
| _ -> ());
k := List rest
| _ -> k := List [])
done;
!found in
let rec loop () =
while not (is_terminal !s) && not (is_suspended !s) do
(try s := Sx_ref.cek_step !s
with Eval_error msg ->
let kont = Sx_ref.cek_kont !s in
if kont_has_handler kont then
(* Convert to CEK-level raise so guard/handler-bind can catch it *)
let env = Sx_ref.cek_env !s in
s := Sx_ref.make_cek_value (String msg) env
(Sx_ref.kont_push (Sx_ref.make_raise_eval_frame env (Bool false)) kont)
else
raise (Eval_error msg))
done;
if is_suspended !s then begin
let request = Sx_runtime.get_val !s (String "request") in
let op = match Sx_runtime.get_val request (String "op") with String s -> s | _ -> "" in
let response = match op with
| "import" ->
let lib_spec = Sx_runtime.get_val request (String "library") in
let key = Sx_ref.library_name_key lib_spec in
if Sx_types.sx_truthy (Sx_ref.library_loaded_p key) then
Nil
else begin
(match resolve_library_path lib_spec with
| Some path ->
(try load_library_file path
with Sx_types.Eval_error msg ->
Printf.eprintf "[import] Warning loading %s: %s\n%!"
(Sx_runtime.value_to_str lib_spec) msg)
| None -> ()); (* silently skip unresolvable libraries *)
Nil
end
| _ -> Nil (* Other IO ops return nil in test context *)
in
s := Sx_ref.cek_resume !s response;
loop ()
end else
Sx_ref.cek_value !s
in
loop ()
in
let load_and_eval path =
let ic = open_in path in
let n = in_channel_length ic in
@@ -1256,22 +727,13 @@ let run_spec_tests env test_files =
let src = Bytes.to_string s in
let exprs = parse_all src in
List.iter (fun expr ->
try ignore (eval_with_io expr (Env env))
with Sx_types.Eval_error _ -> () (* skip expressions that fail during load *)
ignore (eval_expr expr (Env env))
) exprs
in
Printf.printf "\nLoading test framework...\n%!";
load_and_eval framework_path;
(* Load test harness (mock IO platform) *)
let harness_path = Filename.concat (Filename.concat project_dir "spec") "harness.sx" in
if Sys.file_exists harness_path then begin
Printf.printf "Loading test harness...\n%!";
(try load_and_eval harness_path
with e -> Printf.eprintf "Warning: harness.sx: %s\n%!" (Printexc.to_string e))
end;
(* Load modules needed by tests *)
let spec_dir = Filename.concat project_dir "spec" in
let lib_dir = Filename.concat project_dir "lib" in
@@ -1284,110 +746,20 @@ let run_spec_tests env test_files =
with e -> Printf.eprintf "Warning: %s: %s\n%!" name (Printexc.to_string e))
end
in
(* R7RS compatibility library — minimal test version *)
load_module "r7rs.sx" lib_dir;
(* Render adapter for test-render-html.sx *)
load_module "render.sx" spec_dir;
load_module "canonical.sx" spec_dir;
load_module "adapter-html.sx" web_dir;
load_module "adapter-sx.sx" web_dir;
(* Web modules for web/tests/ *)
load_module "forms.sx" web_dir;
load_module "engine.sx" web_dir;
load_module "page-helpers.sx" web_dir;
load_module "request-handler.sx" web_dir;
load_module "router.sx" web_dir;
load_module "deps.sx" web_dir;
load_module "orchestration.sx" web_dir;
(* Library modules for lib/tests/ *)
load_module "bytecode.sx" lib_dir;
load_module "compiler.sx" lib_dir;
load_module "vm.sx" lib_dir;
load_module "signals.sx" spec_dir; (* core reactive primitives *)
load_module "signals.sx" web_dir; (* web extensions *)
load_module "signals.sx" web_dir;
load_module "freeze.sx" lib_dir;
load_module "content.sx" lib_dir;
load_module "parser-combinators.sx" lib_dir;
let hs_dir = Filename.concat lib_dir "hyperscript" in
load_module "tokenizer.sx" hs_dir;
load_module "parser.sx" hs_dir;
load_module "compiler.sx" hs_dir;
load_module "runtime.sx" hs_dir;
load_module "integration.sx" hs_dir;
load_module "types.sx" lib_dir;
load_module "sx-swap.sx" lib_dir;
(* Shared templates: TW styling engine *)
let templates_dir = Filename.concat project_dir "shared/sx/templates" in
load_module "tw.sx" templates_dir;
load_module "tw-layout.sx" templates_dir;
load_module "tw-type.sx" templates_dir;
(* SX docs site: components, handlers, demos *)
let sx_comp_dir = Filename.concat project_dir "sx/sxc" in
let sx_sx_dir = Filename.concat project_dir "sx/sx" in
let sx_handlers_dir = Filename.concat project_dir "sx/sx/handlers" in
let sx_islands_dir = Filename.concat project_dir "sx/sx/reactive-islands" in
let sx_geo_dir = Filename.concat project_dir "sx/sx/geography" in
(* Components + handlers *)
load_module "examples.sx" sx_comp_dir;
load_module "docs.sx" sx_sx_dir;
load_module "examples.sx" sx_handlers_dir;
load_module "ref-api.sx" sx_handlers_dir;
load_module "reactive-api.sx" sx_handlers_dir;
(* Server-rendered demos *)
load_module "scopes.sx" sx_sx_dir;
load_module "provide.sx" sx_sx_dir;
load_module "spreads.sx" sx_sx_dir;
(* Island definitions *)
load_module "index.sx" sx_islands_dir;
load_module "demo.sx" sx_islands_dir;
load_module "marshes.sx" sx_islands_dir;
load_module "cek.sx" sx_geo_dir;
load_module "reactive-runtime.sx" sx_sx_dir;
(* Create short-name aliases for reactive-islands tests *)
let alias short full =
try let v = Sx_types.env_get env full in
ignore (Sx_types.env_bind env short v)
with _ -> () in
alias "~reactive-islands/counter" "~reactive-islands/index/demo-counter";
alias "~reactive-islands/temperature" "~reactive-islands/index/demo-temperature";
alias "~reactive-islands/stopwatch" "~reactive-islands/index/demo-stopwatch";
alias "~reactive-islands/reactive-list" "~reactive-islands/index/demo-reactive-list";
alias "~reactive-islands/input-binding" "~reactive-islands/index/demo-input-binding";
alias "~reactive-islands/error-boundary" "~reactive-islands/index/demo-error-boundary";
alias "~reactive-islands/dynamic-class" "~reactive-islands/index/demo-dynamic-class";
alias "~reactive-islands/store-writer" "~reactive-islands/index/demo-store-writer";
alias "~reactive-islands/store-reader" "~reactive-islands/index/demo-store-reader";
alias "~marshes/demo-marsh-product" "~reactive-islands/marshes/demo-marsh-product";
alias "~marshes/demo-marsh-settle" "~reactive-islands/marshes/demo-marsh-settle";
(* Determine test files — scan spec/tests/, lib/tests/, web/tests/ *)
(* Determine test files — scan spec/tests/ and lib/tests/ *)
let lib_tests_dir = Filename.concat project_dir "lib/tests" in
let web_tests_dir = Filename.concat project_dir "web/tests" in
(* Pre-load test-handlers.sx so its mock definitions (reset-mocks!, helper, etc.)
are available to test-examples.sx which loads before it alphabetically *)
load_module "test-handlers.sx" web_tests_dir;
(* Re-bind render-to-sx AFTER adapter-sx.sx has loaded, wrapping the SX version.
The SX render-to-sx handles AST inputs; we add string→parse→aser support. *)
let sx_render_to_sx = try Some (Sx_types.env_get env "render-to-sx") with _ -> None in
ignore (Sx_types.env_bind env "render-to-sx" (NativeFn ("render-to-sx", fun args ->
match args with
| [String src] ->
(* String input: parse then evaluate via aser (quote the parsed AST so aser sees raw structure) *)
let exprs = Sx_parser.parse_all src in
let expr = match exprs with [e] -> e | es -> List (Symbol "do" :: es) in
let result = eval_expr (List [Symbol "aser"; List [Symbol "quote"; expr]; Env env]) (Env env) in
(match result with SxExpr s -> String s | String s -> String s | _ -> String (Sx_runtime.value_to_str result))
| _ ->
(* AST input: delegate to the SX render-to-sx *)
match sx_render_to_sx with
| Some (NativeFn (_, f)) -> f args
| Some (Lambda _ as fn) -> Sx_ref.cek_call fn (List args)
| _ -> String "")));
let files = if test_files = [] then begin
(* Spec tests (core language — always run) *)
let spec_entries = Sys.readdir spec_tests_dir in
@@ -1400,34 +772,15 @@ let run_spec_tests env test_files =
f <> "test-framework.sx")
|> List.map (fun f -> Filename.concat spec_tests_dir f)
in
(* Web tests (orchestration, handlers) *)
let web_files = if Sys.file_exists web_tests_dir then begin
let entries = Sys.readdir web_tests_dir in
Array.sort String.compare entries;
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-handlers.sx" && (* pre-loaded above *)
f <> "test-wasm-browser.sx" && (* browser-only, needs DOM primitives *)
f <> "test-adapter-dom.sx" && (* browser-only, needs DOM renderer *)
f <> "test-boot-helpers.sx" && (* browser-only, needs boot module *)
f <> "test-layout.sx" && (* needs render-to-html begin+defcomp support *)
f <> "test-cek-reactive.sx") (* needs test-env/make-reactive-reset-frame infra *)
|> List.map (fun f -> Filename.concat web_tests_dir f)
end else [] in
spec_files @ web_files
spec_files
end else
(* Specific test files — search all test dirs *)
List.map (fun name ->
let name = if Filename.check_suffix name ".sx" then name else name ^ ".sx" in
let spec_path = Filename.concat spec_tests_dir name in
let lib_path = Filename.concat lib_tests_dir name in
let web_path = Filename.concat web_tests_dir name in
if Sys.file_exists spec_path then spec_path
else if Sys.file_exists lib_path then lib_path
else if Sys.file_exists web_path then web_path
else Filename.concat spec_tests_dir name (* will fail with "not found" *)
) test_files
in
@@ -1459,68 +812,17 @@ let run_spec_tests env test_files =
let () =
let args = Array.to_list Sys.argv |> List.tl in
let foundation_only = List.mem "--foundation" args in
let jit_enabled = List.mem "--jit" 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 + JIT) ===\n%!";
Printf.printf "\n=== SX Spec Tests (CEK Evaluator) ===\n%!";
let env = make_test_env () in
(* Load compiler and enable JIT (opt-in via --jit flag) *)
if jit_enabled then begin
let globals = Hashtbl.create 512 in
let rec env_to_globals e =
Hashtbl.iter (fun id v ->
let name = Sx_types.unintern id in
if not (Hashtbl.mem globals name) then
Hashtbl.replace globals name v) e.Sx_types.bindings;
match e.Sx_types.parent with Some p -> env_to_globals p | None -> ()
in
env_to_globals env;
(try
let compiler_path = if Sys.file_exists "lib/compiler.sx" then "lib/compiler.sx"
else "../../lib/compiler.sx" in
let ic = open_in compiler_path in
let src = really_input_string ic (in_channel_length ic) in
close_in ic; let _ = src in
let exprs = Sx_parser.parse_all src in
List.iter (fun e -> ignore (Sx_ref.eval_expr e (Env env))) exprs;
env_to_globals env;
Sx_runtime._jit_try_call_fn := Some (fun f args ->
match f with
| Lambda l ->
(match l.l_compiled with
| Some cl when not (Sx_vm.is_jit_failed cl) ->
(try Some (Sx_vm.call_closure cl args cl.vm_env_ref)
with _ -> None)
| Some _ -> None
| None ->
if l.l_name = None then None
else begin
l.l_compiled <- Some Sx_vm.jit_failed_sentinel;
match Sx_vm.jit_compile_lambda l globals with
| Some cl -> l.l_compiled <- Some cl;
(try Some (Sx_vm.call_closure cl args cl.vm_env_ref) with _ -> None)
| None -> None
end)
| _ -> None);
Printf.printf "[jit] Compiler loaded, JIT enabled\n%!"
with e ->
Printf.printf "[jit] Compiler not loaded: %s\n%!" (Printexc.to_string e));
end;
Sx_runtime.jit_reset_counters ();
run_spec_tests env test_files
end;
(* JIT statistics *)
let jh = !(Sx_runtime._jit_hit) and jm = !(Sx_runtime._jit_miss) and js = !(Sx_runtime._jit_skip) in
let total = jh + jm + js in
if total > 0 then
Printf.printf "\n[jit] calls=%d hit=%d (%.1f%%) miss=%d skip=%d\n"
total jh (100.0 *. float_of_int jh /. float_of_int (max 1 total)) jm js;
(* Summary *)
Printf.printf "\n%s\n" (String.make 60 '=');
Printf.printf "Results: %d passed, %d failed\n" !pass_count !fail_count;

2053
hosts/ocaml/bin/sx_server.ml
View File

File diff suppressed because it is too large Load Diff

91
hosts/ocaml/bin/test_cst.ml
View File

@@ -1,91 +0,0 @@
let () =
let test_sources = [
"(define foo 42)";
";; comment\n(define bar 1)\n\n;; another\n(define baz 2)\n";
"(define my-fn\n (fn (x)\n ;; check nil\n (if (nil? x) 0 x)))";
"(list 1 2 3)";
"{:key \"value\" :num 42}";
"'(a b c)";
"`(a ,b ,@c)";
"(define x \"hello\\nworld\")";
";; top\n;; multi-line\n(define a 1)\n";
"";
" \n ";
"(a)\n(b)\n(c)";
"(a ;; inline\n b)";
] in
let pass = ref 0 in
let fail = ref 0 in
List.iter (fun src ->
let cst = Sx_parser.parse_all_cst src in
let roundtrip = Sx_cst.cst_file_to_source cst.nodes cst.trailing_trivia in
if roundtrip = src then begin
incr pass;
Printf.printf "PASS: %S\n" (if String.length src > 40 then String.sub src 0 40 ^ "..." else src)
end else begin
incr fail;
Printf.printf "FAIL: %S\n expected: %S\n got: %S\n"
(if String.length src > 40 then String.sub src 0 40 ^ "..." else src)
src roundtrip
end
) test_sources;
(* Also test CST→AST matches AST parser *)
let ast_tests = [
"(define foo 42)";
"(list 1 2 3)";
"{:key \"value\"}";
";; comment\n(define bar 1)";
] in
Printf.printf "\nCST→AST equivalence:\n";
List.iter (fun src ->
let ast_direct = Sx_parser.parse_all src in
let cst = Sx_parser.parse_all_cst src in
let ast_via_cst = List.map Sx_cst.cst_to_ast cst.nodes in
let s1 = String.concat " " (List.map Sx_types.inspect ast_direct) in
let s2 = String.concat " " (List.map Sx_types.inspect ast_via_cst) in
if s1 = s2 then begin
incr pass;
Printf.printf "PASS: %S\n" src
end else begin
incr fail;
Printf.printf "FAIL: %S\n AST: %s\n CST→AST: %s\n" src s1 s2
end
) ast_tests;
(* Test real .sx files from the codebase *)
Printf.printf "\nReal file round-trips:\n";
let test_file path =
try
let src = In_channel.with_open_text path In_channel.input_all in
let cst = Sx_parser.parse_all_cst src in
let roundtrip = Sx_cst.cst_file_to_source cst.nodes cst.trailing_trivia in
if roundtrip = src then begin
incr pass;
Printf.printf "PASS: %s (%d bytes)\n" path (String.length src)
end else begin
incr fail;
(* Find first difference *)
let len = min (String.length src) (String.length roundtrip) in
let diff_pos = ref len in
for i = 0 to len - 1 do
if src.[i] <> roundtrip.[i] && !diff_pos = len then diff_pos := i
done;
Printf.printf "FAIL: %s (diff at byte %d, src=%d rt=%d)\n" path !diff_pos (String.length src) (String.length roundtrip)
end
with e ->
incr fail;
Printf.printf "ERROR: %s — %s\n" path (Printexc.to_string e)
in
let spec_dir = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found -> "." in
List.iter test_file [
spec_dir ^ "/evaluator.sx";
spec_dir ^ "/parser.sx";
spec_dir ^ "/primitives.sx";
spec_dir ^ "/render.sx";
project_dir ^ "/lib/tree-tools.sx";
project_dir ^ "/web/engine.sx";
project_dir ^ "/web/io.sx";
];
Printf.printf "\n%d/%d passed\n" !pass (!pass + !fail);
if !fail > 0 then exit 1

155
hosts/ocaml/bootstrap.py
View File

@@ -49,11 +49,16 @@ let trampoline v = !trampoline_fn v
(* === Mutable globals — backing refs for transpiler's !_ref / _ref := === *)
(* === Mutable state for strict mode === *)
(* These are defined as top-level refs because the transpiler cannot handle
global set! mutation (it creates local refs that shadow the global). *)
let _strict_ref = ref (Bool false)
let _prim_param_types_ref = ref Nil
let _last_error_kont_ref = ref Nil
let _protocol_registry_ = Dict (Hashtbl.create 0)
(* JIT call hook — cek_call checks this before CEK dispatch for named
lambdas. Registered by sx_server.ml after compiler loads. Tests
run with hook = None (pure CEK, no compilation dependency). *)
let jit_call_hook : (value -> value list -> value option) option ref = ref None
"""
@@ -70,61 +75,13 @@ let () = trampoline_fn := (fun v ->
(* Wire up the primitives trampoline so call_any in HO forms resolves Thunks *)
let () = Sx_primitives._sx_trampoline_fn := !trampoline_fn
(* Override recursive cek_run with iterative loop.
On error, capture the kont from the last state for comp-trace. *)
(* Override recursive cek_run with iterative loop *)
let cek_run_iterative state =
let s = ref state in
(try
while not (match cek_terminal_p !s with Bool true -> true | _ -> false)
&& not (match cek_suspended_p !s with Bool true -> true | _ -> false) do
s := cek_step !s
done;
(match cek_suspended_p !s with
| Bool true -> raise (Eval_error "IO suspension in non-IO context")
| _ -> cek_value !s)
with Eval_error msg ->
_last_error_kont_ref := cek_kont !s;
raise (Eval_error msg))
(* Collect component trace from a kont value *)
let collect_comp_trace kont =
let trace = ref [] in
let k = ref kont in
while (match !k with List (_::_) -> true | _ -> false) do
(match !k with
| List (frame :: rest) ->
(match frame with
| CekFrame f when f.cf_type = "comp-trace" ->
let name = match f.cf_name with String s -> s | _ -> "?" in
let file = match f.cf_env with String s -> s | Nil -> "" | _ -> "" in
trace := (name, file) :: !trace
| Dict d when (match Hashtbl.find_opt d "type" with Some (String "comp-trace") -> true | _ -> false) ->
let name = match Hashtbl.find_opt d "name" with Some (String s) -> s | _ -> "?" in
let file = match Hashtbl.find_opt d "file" with Some (String s) -> s | _ -> "" in
trace := (name, file) :: !trace
| _ -> ());
k := List rest
| _ -> k := List [])
while not (match cek_terminal_p !s with Bool true -> true | _ -> false) do
s := cek_step !s
done;
List.rev !trace
(* Format a comp-trace into a human-readable string *)
let format_comp_trace trace =
match trace with
| [] -> ""
| entries ->
let lines = List.mapi (fun i (name, file) ->
let prefix = if i = 0 then " in " else " called from " in
if file = "" then prefix ^ "~" ^ name
else prefix ^ "~" ^ name ^ " (" ^ file ^ ")"
) entries in
"\n" ^ String.concat "\n" lines
(* Enhance an error message with component trace *)
let enhance_error_with_trace msg =
let trace = collect_comp_trace !_last_error_kont_ref in
_last_error_kont_ref := Nil;
msg ^ (format_comp_trace trace)
cek_value !s
@@ -206,18 +163,90 @@ def compile_spec_to_ml(spec_dir: str | None = None) -> str:
parts.append(FIXUPS)
output = "\n".join(parts)
# Mutable globals (*strict*, *prim-param-types*) are now handled by
# the transpiler directly — it emits !_ref for reads, _ref := for writes.
# Post-process: fix mutable globals that the transpiler can't handle.
# The transpiler emits local refs for set! targets within functions,
# but top-level globals (*strict*, *prim-param-types*) need to use
# the pre-declared refs from the preamble.
import re
# Remove `and _protocol_registry_ = (Dict ...)` from the let rec block —
# it's defined in the preamble as a top-level let, and Hashtbl.create
# is not allowed as a let rec right-hand side.
# Fix *strict*: use _strict_ref instead of immutable let rec binding
output = re.sub(
r'\n\(\* \*protocol-registry\*.*?\nand _protocol_registry_ =\n \(Dict \(Hashtbl\.create 0\)\)\n',
'\n',
output
r'and _strict_ =\n \(Bool false\)',
'and _strict_ = !_strict_ref',
output,
)
# Fix set-strict!: use _strict_ref instead of local ref
output = re.sub(
r'and set_strict_b val\' =\n let _strict_ = ref Nil in \(_strict_ := val\'; Nil\)',
"and set_strict_b val' =\n _strict_ref := val'; Nil",
output,
)
# Fix *prim-param-types*: use _prim_param_types_ref
output = re.sub(
r'and _prim_param_types_ =\n Nil',
'and _prim_param_types_ = !_prim_param_types_ref',
output,
)
# Fix set-prim-param-types!: use _prim_param_types_ref
output = re.sub(
r'and set_prim_param_types_b types =\n let _prim_param_types_ = ref Nil in \(_prim_param_types_ := types; Nil\)',
"and set_prim_param_types_b types =\n _prim_param_types_ref := types; Nil",
output,
)
# Fix all runtime reads of _strict_ and _prim_param_types_ to deref
# the mutable refs instead of using the stale let-rec bindings.
# This is needed because let-rec value bindings capture initial values.
# Use regex with word boundary to avoid replacing _strict_ref with
# !_strict_refref.
def fix_mutable_reads(text):
lines = text.split('\n')
fixed = []
for line in lines:
# Skip the definition lines
stripped = line.strip()
if stripped.startswith('and _strict_ =') or stripped.startswith('and _prim_param_types_ ='):
fixed.append(line)
continue
# Replace _strict_ as a standalone identifier only (not inside
# other names like set_strict_b). Match when preceded by space,
# paren, or start-of-line, and followed by space, paren, or ;.
line = re.sub(r'(?<=[ (])_strict_(?=[ );])', '!_strict_ref', line)
line = re.sub(r'(?<=[ (])_prim_param_types_(?=[ );])', '!_prim_param_types_ref', line)
fixed.append(line)
return '\n'.join(fixed)
output = fix_mutable_reads(output)
# Fix cek_call: the spec passes (make-env) as the env arg to
# continue_with_call, but the transpiler evaluates make-env at
# transpile time (it's a primitive), producing Dict instead of Env.
output = output.replace(
"((Dict (Hashtbl.create 0))) (a) ((List []))",
"(Env (Sx_types.make_env ())) (a) ((List []))",
)
# Inject JIT dispatch into continue_with_call's lambda branch.
# After params are bound, check jit_call_hook before creating CEK state.
lambda_body_pattern = (
'(prim_call "slice" [params; (len (args))])); Nil)) in '
'(make_cek_state ((lambda_body (f))) (local) (kont))'
)
lambda_body_jit = (
'(prim_call "slice" [params; (len (args))])); Nil)) in '
'(match !jit_call_hook, f with '
'| Some hook, Lambda l when l.l_name <> None -> '
'let args_list = match args with '
'List a | ListRef { contents = a } -> a | _ -> [] in '
'(match hook f args_list with '
'Some result -> make_cek_value result local kont '
'| None -> make_cek_state (lambda_body f) local kont) '
'| _ -> make_cek_state ((lambda_body (f))) (local) (kont))'
)
if lambda_body_pattern in output:
output = output.replace(lambda_body_pattern, lambda_body_jit, 1)
else:
import sys
print("WARNING: Could not find lambda body pattern for JIT injection", file=sys.stderr)
return output

153
hosts/ocaml/bootstrap_compiler.py
View File

@@ -1,153 +0,0 @@
#!/usr/bin/env python3
"""
Bootstrap the SX bytecode compiler to native OCaml.
Loads the SX-to-OCaml transpiler (transpiler.sx), feeds it compiler.sx,
and produces sx_compiler.ml — the bytecode compiler as native OCaml.
Usage:
python3 hosts/ocaml/bootstrap_compiler.py
"""
from __future__ import annotations
import os
import sys
_HERE = os.path.dirname(os.path.abspath(__file__))
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", ".."))
sys.path.insert(0, _PROJECT)
from shared.sx.parser import parse_all
from shared.sx.types import Symbol
def extract_defines(source: str) -> list[tuple[str, list]]:
"""Parse .sx source, return list of (name, define-expr) for top-level defines."""
exprs = parse_all(source)
defines = []
for expr in exprs:
if isinstance(expr, list) and expr and isinstance(expr[0], Symbol):
if expr[0].name == "define":
name = expr[1].name if isinstance(expr[1], Symbol) else str(expr[1])
defines.append((name, expr))
return defines
PREAMBLE = """\
(* sx_compiler.ml — Auto-generated from lib/compiler.sx *)
(* Do not edit — regenerate with: python3 hosts/ocaml/bootstrap_compiler.py *)
[@@@warning "-26-27"]
open Sx_types
open Sx_runtime
(* The compiler uses cek_call from the evaluator for runtime dispatch *)
let cek_call = Sx_ref.cek_call
let eval_expr = Sx_ref.eval_expr
let trampoline v = match v with
| Thunk (expr, env) -> Sx_ref.eval_expr expr (Env env)
| other -> other
(* Bindings for external functions the compiler calls.
Some shadow OCaml stdlib names — the SX versions operate on values. *)
let serialize v = String (Sx_types.inspect v)
let sx_parse v = match v with
| String s -> (match Sx_parser.parse_all s with [e] -> e | es -> List es)
| v -> v
let floor v = prim_call "floor" [v]
let abs v = prim_call "abs" [v]
let min a b = prim_call "min" [a; b]
let max a b = prim_call "max" [a; b]
let set_nth_b lst idx v = prim_call "set-nth!" [lst; idx; v]
let init lst = prim_call "init" [lst]
(* skip_annotations: strips :keyword value pairs from a list (type annotations) *)
let rec skip_annotations items =
match items with
| List [] | Nil -> Nil
| List (Keyword _ :: _ :: rest) -> skip_annotations (List rest)
| ListRef { contents = [] } -> Nil
| ListRef { contents = Keyword _ :: _ :: rest } -> skip_annotations (List rest)
| List (first :: _) -> first
| ListRef { contents = first :: _ } -> first
| _ -> Nil
(* compile_match: uses local recursion (letrec) that the transpiler can't handle.
Falls back to CEK evaluation at runtime. *)
let compile_match em args scope tail_p =
let fn = Sx_ref.eval_expr (Symbol "compile-match") (Env (Sx_types.make_env ())) in
ignore (Sx_ref.cek_call fn (List [em; args; scope; tail_p]));
Nil
"""
def main():
import tempfile
from shared.sx.ocaml_sync import OcamlSync
from shared.sx.parser import serialize
# Load the transpiler into OCaml kernel
bridge = OcamlSync()
transpiler_path = os.path.join(_HERE, "transpiler.sx")
bridge.load(transpiler_path)
# Read compiler.sx
compiler_path = os.path.join(_PROJECT, "lib", "compiler.sx")
with open(compiler_path) as f:
src = f.read()
defines = extract_defines(src)
# Skip functions that use letrec/named-let (transpiler can't handle)
skip = {"compile-match"}
defines = [(n, e) for n, e in defines if n not in skip]
# Deduplicate (keep last definition)
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]
print(f"Transpiling {len(defines)} defines from compiler.sx...", file=sys.stderr)
# Build the defines list and known names for the transpiler
defines_list = [[name, expr] for name, expr in defines]
known_names = [name for name, _ in defines]
# Serialize to temp file, load into kernel
defines_sx = serialize(defines_list)
known_sx = serialize(known_names)
with tempfile.NamedTemporaryFile(mode="w", suffix=".sx", delete=False) as tmp:
tmp.write(f"(define _defines '{defines_sx})\n")
tmp.write(f"(define _known_defines '{known_sx})\n")
tmp_path = tmp.name
try:
bridge.load(tmp_path)
finally:
os.unlink(tmp_path)
# Call ml-translate-file — emits as single let rec block
result = bridge.eval("(ml-translate-file _defines)")
bridge.stop()
output = PREAMBLE + "\n(* === Transpiled from bytecode compiler === *)\n" + result + "\n"
# Post-process: fix skip_annotations local NativeFn → use top-level
old = 'then (let skip_annotations = (NativeFn ('
if old in output:
idx = output.index(old)
end_marker = 'in (skip_annotations (rest_args)))'
end_idx = output.index(end_marker, idx)
output = output[:idx] + 'then (skip_annotations (rest_args))' + output[end_idx + len(end_marker):]
# Write output
out_path = os.path.join(_HERE, "lib", "sx_compiler.ml")
with open(out_path, "w") as f:
f.write(output)
print(f"Wrote {len(output)} bytes to {out_path}", file=sys.stderr)
print(f" {len(defines)} functions transpiled", file=sys.stderr)
if __name__ == "__main__":
main()

480
hosts/ocaml/bootstrap_render.py
View File

@@ -1,480 +0,0 @@
#!/usr/bin/env python3
"""
Bootstrap the SX HTML renderer to native OCaml.
Reads spec/render.sx (helpers) and web/adapter-html.sx (dispatch),
combines them, and transpiles to sx_render.ml.
Performance-critical functions (escape_html, render_attrs) are provided
as native OCaml in the PREAMBLE. Web-specific renderers (lake, marsh,
island) are appended in FIXUPS.
Usage:
python3 hosts/ocaml/bootstrap_render.py
"""
from __future__ import annotations
import os
import sys
_HERE = os.path.dirname(os.path.abspath(__file__))
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", ".."))
sys.path.insert(0, _PROJECT)
from shared.sx.parser import parse_all, serialize
from shared.sx.types import Symbol, Keyword
def extract_defines(source: str) -> list[tuple[str, list]]:
"""Parse .sx source, return list of (name, define-expr) for top-level defines."""
exprs = parse_all(source)
defines = []
for expr in exprs:
if isinstance(expr, list) and expr and isinstance(expr[0], Symbol):
if expr[0].name == "define":
name = expr[1].name if isinstance(expr[1], Symbol) else str(expr[1])
defines.append((name, expr))
return defines
def strip_type_annotations(expr):
"""Recursively strip :as type annotations from param lists.
Transforms (name :as type) → name in function parameter positions."""
if isinstance(expr, list):
# Check if this is a typed param: (name :as type)
if (len(expr) == 3 and isinstance(expr[0], Symbol)
and isinstance(expr[1], Keyword) and expr[1].name == "as"):
return expr[0] # just the name
# Check for param list patterns — list where first element is a symbol
# and contains :as keywords
new = []
for item in expr:
new.append(strip_type_annotations(item))
return new
return expr
PREAMBLE = """\
(* sx_render.ml — Auto-generated from spec/render.sx + web/adapter-html.sx *)
(* Do not edit — regenerate with: python3 hosts/ocaml/bootstrap_render.py *)
[@@@warning "-26-27"]
open Sx_types
open Sx_runtime
(* ====================================================================== *)
(* Platform bindings — native OCaml for performance and type access *)
(* ====================================================================== *)
let eval_expr expr env = Sx_ref.eval_expr expr env
let cond_scheme_p = Sx_ref.cond_scheme_p
(* Primitive wrappers needed as direct OCaml functions *)
let raw_html_content v = match v with RawHTML s -> String s | _ -> String ""
let make_raw_html v = match v with String s -> RawHTML s | _ -> Nil
let scope_emit v1 v2 = prim_call "scope-emit!" [v1; v2]
let init v = prim_call "init" [v]
let dict_has a b = prim_call "dict-has?" [a; b]
let dict_get a b = prim_call "dict-get" [a; b]
let is_component v = prim_call "component?" [v]
let is_island v = prim_call "island?" [v]
let is_macro v = prim_call "macro?" [v]
let is_lambda v = prim_call "lambda?" [v]
let is_nil v = prim_call "nil?" [v]
(* Forward refs for web-specific renderers — set in FIXUPS or by caller *)
let render_html_lake_ref : (value -> value -> value) ref = ref (fun _ _ -> String "")
let render_html_marsh_ref : (value -> value -> value) ref = ref (fun _ _ -> String "")
let render_html_island_ref : (value -> value -> value -> value) ref = ref (fun _ _ _ -> String "")
let render_html_lake args env = !render_html_lake_ref args env
let render_html_marsh args env = !render_html_marsh_ref args env
let render_html_island comp args env = !render_html_island_ref comp args env
let cek_call = Sx_ref.cek_call
let trampoline v = match v with
| Thunk (expr, env) -> Sx_ref.eval_expr expr (Env env)
| other -> other
let expand_macro m args_val _env = match m with
| Macro mac ->
let args = match args_val with List l | ListRef { contents = l } -> l | _ -> [] in
let local = env_extend (Env mac.m_closure) in
let rec bind_params ps as' = match ps, as' with
| [], rest ->
(match mac.m_rest_param with
| Some rp -> ignore (env_bind local (String 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 (List.map (fun p -> String p) mac.m_params) args;
Sx_ref.eval_expr mac.m_body local
| _ -> Nil
(** try-catch: wraps a try body fn and catch handler fn.
Maps to OCaml exception handling. *)
let try_catch try_fn catch_fn =
try sx_call try_fn []
with
| Eval_error msg -> sx_call catch_fn [String msg]
| e -> sx_call catch_fn [String (Printexc.to_string e)]
(** set-render-active! — no-op on OCaml (always active). *)
let set_render_active_b _v = Nil
(* ====================================================================== *)
(* Performance-critical: native Buffer-based HTML escaping *)
(* ====================================================================== *)
(* ====================================================================== *)
(* Tag registries — native string lists for callers, value Lists for SX *)
(* ====================================================================== *)
let boolean_attrs_set = [
"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_boolean_attr name = List.mem name boolean_attrs_set
let html_tags_list = [
"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"; "details"; "summary"; "dialog";
"a"; "span"; "em"; "strong"; "small"; "b"; "i"; "u"; "s"; "sub"; "sup";
"mark"; "abbr"; "cite"; "code"; "kbd"; "samp"; "var"; "time"; "br"; "wbr";
"table"; "thead"; "tbody"; "tfoot"; "tr"; "th"; "td"; "caption"; "colgroup"; "col";
"form"; "input"; "textarea"; "select"; "option"; "optgroup"; "button"; "label";
"fieldset"; "legend"; "datalist"; "output";
"img"; "video"; "audio"; "source"; "picture"; "canvas"; "iframe";
"svg"; "path"; "circle"; "rect"; "line"; "polyline"; "polygon"; "ellipse";
"g"; "defs"; "use"; "text"; "tspan"; "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"; "template"; "slot"
]
let html_tags = html_tags_list (* callers expect string list *)
let html_tags_val = List (List.map (fun s -> String s) html_tags_list)
let void_elements_list = [
"area"; "base"; "br"; "col"; "embed"; "hr"; "img"; "input";
"link"; "meta"; "param"; "source"; "track"; "wbr"
]
let void_elements = void_elements_list (* callers expect string list *)
let void_elements_val = List (List.map (fun s -> String s) void_elements_list)
let boolean_attrs = boolean_attrs_set (* callers expect string list *)
let boolean_attrs_val = List (List.map (fun s -> String s) boolean_attrs_set)
(* Native escape for internal use — returns raw OCaml string *)
let escape_html_raw s =
let buf = Buffer.create (String.length s) in
String.iter (function
| '&' -> Buffer.add_string buf "&amp;"
| '<' -> Buffer.add_string buf "&lt;"
| '>' -> Buffer.add_string buf "&gt;"
| '"' -> Buffer.add_string buf "&quot;"
| c -> Buffer.add_char buf c) s;
Buffer.contents buf
(* escape_html: native string -> string for callers *)
let escape_html = escape_html_raw
(* escape_html_val / escape_attr_val — take a value, return String value (for transpiled code) *)
let escape_html_val v =
let s = match v with String s -> s | v -> value_to_string v in
String (escape_html_raw s)
let escape_attr_val v = escape_html_val v
(* ====================================================================== *)
(* Performance-critical: native attribute rendering *)
(* ====================================================================== *)
let render_attrs attrs = match attrs with
| Dict d ->
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 v <> Nil then begin
Buffer.add_char buf ' ';
Buffer.add_string buf k;
Buffer.add_string buf "=\\"";
Buffer.add_string buf (escape_html_raw (value_to_string v));
Buffer.add_char buf '"'
end) d;
String (Buffer.contents buf)
| _ -> String ""
(* ====================================================================== *)
(* Forward ref — used by setup_render_env and buffer renderer *)
(* ====================================================================== *)
let render_to_html_ref : (value -> value -> value) ref =
ref (fun _expr _env -> String "")
(* scope-emitted is a prim alias *)
let scope_emitted name = prim_call "scope-emitted" [name]
(* RENDER_HTML_FORMS — list of special form names handled by dispatch-html-form *)
let render_html_forms = List [
String "if"; String "when"; String "cond"; String "case";
String "let"; String "let*"; String "letrec";
String "begin"; String "do";
String "define"; String "defcomp"; String "defmacro"; String "defisland";
String "defpage"; String "defhandler"; String "defquery"; String "defaction";
String "defrelation"; String "deftype"; String "defeffect"; String "defstyle";
String "map"; String "map-indexed"; String "filter"; String "for-each";
String "scope"; String "provide"
]
"""
FIXUPS = """
(* ====================================================================== *)
(* Wire up forward ref *)
(* ====================================================================== *)
let () = render_to_html_ref := render_to_html
(* ====================================================================== *)
(* Buffer-based streaming renderer — zero intermediate string allocation *)
(* ====================================================================== *)
(** Escape HTML directly into a buffer. *)
let escape_html_buf buf s =
for i = 0 to String.length s - 1 do
match String.unsafe_get s i with
| '&' -> Buffer.add_string buf "&amp;"
| '<' -> Buffer.add_string buf "&lt;"
| '>' -> Buffer.add_string buf "&gt;"
| '"' -> Buffer.add_string buf "&quot;"
| c -> Buffer.add_char buf c
done
let render_attrs_buf buf attrs =
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 v <> Nil then begin
Buffer.add_char buf ' ';
Buffer.add_string buf k;
Buffer.add_string buf "=\\"";
escape_html_buf buf (value_to_string v);
Buffer.add_char buf '"'
end) attrs
(** Render to pre-allocated buffer — delegates to transpiled render_to_html
and extracts the string result. *)
let render_to_buf buf expr (env : env) =
match !render_to_html_ref expr (Env env) with
| String s -> Buffer.add_string buf s
| RawHTML s -> Buffer.add_string buf s
| v -> Buffer.add_string buf (value_to_str v)
(** Public API: render to a pre-allocated buffer. *)
let render_to_buffer buf expr env = render_to_buf buf expr env
(** Convenience: render to string. *)
let render_to_html_streaming expr (env : env) =
match !render_to_html_ref expr (Env env) with
| String s -> s
| RawHTML s -> s
| v -> value_to_str v
(** The native OCaml renderer — used by sx_server when SX adapter isn't loaded. *)
let do_render_to_html expr (env_val : value) =
match !render_to_html_ref expr env_val with
| String s -> s
| RawHTML s -> s
| v -> value_to_str v
(** Render via the SX adapter (render-to-html from adapter-html.sx).
Falls back to the native ref if the SX adapter isn't loaded. *)
let sx_render_to_html (render_env : env) expr (eval_env : env) =
if Sx_types.env_has render_env "render-to-html" then
let fn = Sx_types.env_get render_env "render-to-html" in
let result = Sx_ref.cek_call fn (List [expr; Env eval_env]) in
match result with String s -> s | RawHTML s -> s | _ -> value_to_str result
else
do_render_to_html expr (Env eval_env)
(* ====================================================================== *)
(* Setup — bind render primitives in an env and wire up the ref *)
(* ====================================================================== *)
let is_html_tag name = List.mem name html_tags_list
let is_void name = List.mem name void_elements_list
(* escape_html_str: takes raw OCaml string, returns raw string — for callers *)
let escape_html_str = escape_html_raw
let setup_render_env (raw_env : env) =
let env = Env raw_env in
let bind name fn =
ignore (Sx_types.env_bind raw_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
!render_to_html_ref expr env
| [expr] ->
!render_to_html_ref expr env
| [expr; Env e] ->
!render_to_html_ref expr (Env 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
!render_to_html_ref expr env
| [expr] ->
!render_to_html_ref expr env
| [expr; Env e] ->
!render_to_html_ref expr (Env e)
| _ -> String "")
"""
def main():
import tempfile
from shared.sx.ocaml_sync import OcamlSync
# Load the transpiler into OCaml kernel
bridge = OcamlSync()
transpiler_path = os.path.join(_HERE, "transpiler.sx")
bridge.load(transpiler_path)
# Read source files
spec_path = os.path.join(_PROJECT, "spec", "render.sx")
adapter_path = os.path.join(_PROJECT, "web", "adapter-html.sx")
with open(spec_path) as f:
spec_src = f.read()
with open(adapter_path) as f:
adapter_src = f.read()
spec_defines = extract_defines(spec_src)
adapter_defines = extract_defines(adapter_src)
# Skip: performance-critical (native in PREAMBLE) and web-specific (in FIXUPS)
skip = {
# Native in PREAMBLE for performance
"escape-html", "escape-attr", "render-attrs",
# OCaml can't have uppercase let bindings; registries need dual types
"RENDER_HTML_FORMS",
"HTML_TAGS", "VOID_ELEMENTS", "BOOLEAN_ATTRS",
# Web-specific — provided as stubs or in FIXUPS
"render-html-lake", "render-html-marsh",
"render-html-island", "serialize-island-state",
}
# Combine: spec helpers first (dependency order), then adapter dispatch
all_defines = []
for name, expr in spec_defines:
if name not in skip:
all_defines.append((name, expr))
for name, expr in adapter_defines:
if name not in skip:
all_defines.append((name, expr))
# Deduplicate — keep last definition for each name
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]
# Strip type annotations from params: (name :as type) → name
all_defines = [(name, strip_type_annotations(expr)) for name, expr in all_defines]
print(f"Transpiling {len(all_defines)} defines from render spec + adapter...",
file=sys.stderr)
# Build the defines list and known names for the transpiler
defines_list = [[name, expr] for name, expr in all_defines]
known_names = [name for name, _ in all_defines]
# Add PREAMBLE-provided names so transpiler emits them as direct calls
known_names.extend([
"escape-html", "escape-attr", "render-attrs",
"eval-expr", "trampoline", "expand-macro",
"try-catch", "set-render-active!",
"render-html-lake", "render-html-marsh",
"render-html-island", "serialize-island-state",
"scope-emitted",
"RENDER_HTML_FORMS",
"cond-scheme?",
])
# Serialize to temp file, load into kernel
defines_sx = serialize(defines_list)
known_sx = serialize(known_names)
with tempfile.NamedTemporaryFile(mode="w", suffix=".sx", delete=False) as tmp:
tmp.write(f"(define _defines '{defines_sx})\n")
tmp.write(f"(define _known_defines '{known_sx})\n")
tmp_path = tmp.name
try:
bridge.load(tmp_path)
finally:
os.unlink(tmp_path)
# Add renames for uppercase constants and dual-form registries
bridge.eval('(dict-set! ml-renames "RENDER_HTML_FORMS" "render_html_forms")')
bridge.eval('(dict-set! ml-renames "HTML_TAGS" "html_tags_val")')
bridge.eval('(dict-set! ml-renames "VOID_ELEMENTS" "void_elements_val")')
bridge.eval('(dict-set! ml-renames "BOOLEAN_ATTRS" "boolean_attrs_val")')
bridge.eval('(dict-set! ml-renames "escape-html" "escape_html_val")')
bridge.eval('(dict-set! ml-renames "escape-attr" "escape_attr_val")')
# Call ml-translate-file — emits as single let rec block
result = bridge.eval("(ml-translate-file _defines)")
bridge.stop()
output = PREAMBLE + "\n(* === Transpiled from render spec + adapter === *)\n" + result + "\n" + FIXUPS
# Write output
output_path = os.path.join(_HERE, "lib", "sx_render.ml")
with open(output_path, "w") as f:
f.write(output)
print(f"Wrote {len(output)} bytes to {output_path}", file=sys.stderr)
print(f" {len(all_defines)} functions transpiled", file=sys.stderr)
if __name__ == "__main__":
main()

648
hosts/ocaml/bootstrap_vm.py
View File

@@ -1,648 +0,0 @@
#!/usr/bin/env python3
"""
Bootstrap the SX bytecode VM to native OCaml.
Loads the SX-to-OCaml transpiler (transpiler.sx), feeds it the logic
functions from lib/vm.sx, and produces sx_vm_ref.ml.
Type construction and performance-critical functions stay as native OCaml
in the preamble. Logic (opcode dispatch, call routing, execution loop)
is transpiled from SX.
Usage:
python3 hosts/ocaml/bootstrap_vm.py
"""
from __future__ import annotations
import os
import sys
import tempfile
_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, serialize
from shared.sx.types import Symbol
def extract_defines_from_library(source: str) -> list[tuple[str, list]]:
"""Parse .sx source with define-library wrapper, extract defines from begin body."""
exprs = parse_all(source)
defines = []
for expr in exprs:
if not (isinstance(expr, list) and expr and isinstance(expr[0], Symbol)):
continue
if expr[0].name == "define":
name = expr[1].name if isinstance(expr[1], Symbol) else str(expr[1])
defines.append((name, expr))
elif expr[0].name == "define-library":
# Extract defines from (begin ...) declarations
for decl in expr[2:]:
if isinstance(decl, list) and decl and isinstance(decl[0], Symbol) and decl[0].name == "begin":
for form in decl[1:]:
if isinstance(form, list) and form and isinstance(form[0], Symbol) and form[0].name == "define":
name = form[1].name if isinstance(form[1], Symbol) else str(form[1])
defines.append((name, form))
return defines
# Functions provided by the native OCaml preamble — skip from transpilation.
# These handle type construction and performance-critical ops.
SKIP = {
# Type construction
"make-upvalue-cell", "uv-get", "uv-set!",
"make-vm-code", "make-vm-closure", "make-vm-frame", "make-vm",
# Stack ops
"vm-push", "vm-pop", "vm-peek",
# Frame ops
"frame-read-u8", "frame-read-u16", "frame-read-i16",
"frame-local-get", "frame-local-set",
"frame-upvalue-get", "frame-upvalue-set",
# Accessors (native OCaml field access)
"frame-ip", "frame-set-ip!", "frame-base", "frame-closure",
"closure-code", "closure-upvalues", "closure-env",
"code-bytecode", "code-constants", "code-locals",
"vm-sp", "vm-set-sp!", "vm-stack", "vm-set-stack!",
"vm-frames", "vm-set-frames!", "vm-globals-ref",
# Global ops
"vm-global-get", "vm-global-set",
# Complex native ops
"vm-push-frame", "code-from-value", "vm-closure?",
"vm-create-closure",
# Lambda accessors (native type)
"lambda?", "lambda-compiled", "lambda-set-compiled!", "lambda-name",
# JIT dispatch + active VM (platform-specific)
"*active-vm*", "*jit-compile-fn*",
"try-jit-call", "vm-call-closure",
# Module execution (thin wrappers over native execute_module)
"vm-execute-module", "vm-resume-module",
# Env access (used by env-walk)
"env-walk", "env-walk-set!",
# CEK interop
"cek-call-or-suspend",
# Collection helpers (use mutable state + recursion)
"collect-n-from-stack", "collect-n-pairs", "pad-n-nils",
}
PREAMBLE = """\
(* sx_vm_ref.ml — Auto-generated from lib/vm.sx *)
(* Do not edit — regenerate with: python3 hosts/ocaml/bootstrap_vm.py *)
[@@@warning "-26-27-39"]
open Sx_types
open Sx_runtime
(* ================================================================
Forward references for CEK interop
================================================================ *)
let cek_call = Sx_ref.cek_call
let eval_expr = Sx_ref.eval_expr
let trampoline v = match v with
| Thunk (expr, env) -> Sx_ref.eval_expr expr (Env env)
| other -> other
(* SX List → OCaml list *)
let to_ocaml_list v = match v with List l -> l | Nil -> [] | _ -> [v]
(* str as NativeFn value — transpiled code passes it to sx_apply *)
let str = NativeFn ("str", fun args -> String (sx_str args))
(* Primitive call dispatch — transpiled code uses this for CALL_PRIM *)
let call_primitive name args =
let n = value_to_string name in
prim_call n (to_ocaml_list args)
(* ================================================================
Preamble: 48 native OCaml functions for VM type access.
These are SKIPPED from transpilation — the transpiled logic
functions call them for all type construction and field access.
================================================================ *)
(* --- Unwrap helpers --- *)
let unwrap_vm v = match v with VmMachine m -> m | _ -> raise (Eval_error "not a vm")
let unwrap_frame v = match v with VmFrame f -> f | _ -> raise (Eval_error "not a frame")
let unwrap_closure v = match v with VmClosure c -> c | _ -> raise (Eval_error "not a closure")
(* --- Upvalue cells (internal to preamble — never SX values) --- *)
let _make_uv_cell v : vm_upvalue_cell = { uv_value = v }
let _uv_get (c : vm_upvalue_cell) = c.uv_value
let _uv_set (c : vm_upvalue_cell) v = c.uv_value <- v
(* SX-facing stubs (in skip set, never called from transpiled code) *)
let make_upvalue_cell v = Nil
let uv_get _ = Nil
let uv_set_b _ _ = Nil
(* --- VM code construction --- *)
let code_from_value v = Sx_vm.code_from_value v
let make_vm_code arity locals bytecode constants =
(* Build a Dict that code_from_value can parse *)
let d = Hashtbl.create 4 in
Hashtbl.replace d "arity" arity;
Hashtbl.replace d "bytecode" bytecode;
Hashtbl.replace d "constants" constants;
Dict d
(* --- VM closure --- *)
let make_vm_closure code upvalues name globals closure_env =
let uv = match upvalues with
| List l -> Array.of_list (List.map (fun v -> { uv_value = v }) l)
| _ -> [||] in
VmClosure { vm_code = code_from_value code;
vm_upvalues = uv;
vm_name = (match name with String s -> Some s | Nil -> None | _ -> None);
vm_env_ref = (match globals with Dict d -> d | _ -> Hashtbl.create 0);
vm_closure_env = (match closure_env with Env e -> Some e | _ -> None) }
(* --- VM frame --- *)
let make_vm_frame closure base =
let cl = unwrap_closure closure in
VmFrame { vf_closure = cl; vf_ip = 0;
vf_base = val_to_int base;
vf_local_cells = Hashtbl.create 4 }
(* --- VM machine --- *)
let make_vm globals =
let g = match globals with Dict d -> d | _ -> Hashtbl.create 0 in
VmMachine { vm_stack = Array.make 4096 Nil; vm_sp = 0;
vm_frames = []; vm_globals = g; vm_pending_cek = None }
(* --- Stack ops --- *)
let vm_push vm_val v =
let m = unwrap_vm vm_val in
if m.vm_sp >= Array.length m.vm_stack then begin
let ns = Array.make (m.vm_sp * 2) Nil in
Array.blit m.vm_stack 0 ns 0 m.vm_sp;
m.vm_stack <- ns
end;
m.vm_stack.(m.vm_sp) <- v;
m.vm_sp <- m.vm_sp + 1;
Nil
let vm_pop vm_val =
let m = unwrap_vm vm_val in
m.vm_sp <- m.vm_sp - 1;
m.vm_stack.(m.vm_sp)
let vm_peek vm_val =
let m = unwrap_vm vm_val in
m.vm_stack.(m.vm_sp - 1)
(* --- Frame operand reading --- *)
let frame_read_u8 frame_val =
let f = unwrap_frame frame_val in
let v = f.vf_closure.vm_code.vc_bytecode.(f.vf_ip) in
f.vf_ip <- f.vf_ip + 1;
Number (float_of_int v)
let frame_read_u16 frame_val =
let f = unwrap_frame frame_val in
let lo = f.vf_closure.vm_code.vc_bytecode.(f.vf_ip) in
let hi = f.vf_closure.vm_code.vc_bytecode.(f.vf_ip + 1) in
f.vf_ip <- f.vf_ip + 2;
Number (float_of_int (lo lor (hi lsl 8)))
let frame_read_i16 frame_val =
let f = unwrap_frame frame_val in
let lo = f.vf_closure.vm_code.vc_bytecode.(f.vf_ip) in
let hi = f.vf_closure.vm_code.vc_bytecode.(f.vf_ip + 1) in
f.vf_ip <- f.vf_ip + 2;
let v = lo lor (hi lsl 8) in
Number (float_of_int (if v >= 32768 then v - 65536 else v))
(* --- Local variable access --- *)
let frame_local_get vm_val frame_val slot =
let m = unwrap_vm vm_val in
let f = unwrap_frame frame_val in
let idx = f.vf_base + val_to_int slot in
(* Check for shared upvalue cell *)
match Hashtbl.find_opt f.vf_local_cells (val_to_int slot) with
| Some cell -> cell.uv_value
| None -> m.vm_stack.(idx)
let frame_local_set vm_val frame_val slot v =
let m = unwrap_vm vm_val in
let f = unwrap_frame frame_val in
let s = val_to_int slot in
(* If slot has a shared cell, write through cell *)
(match Hashtbl.find_opt f.vf_local_cells s with
| Some cell -> cell.uv_value <- v
| None -> m.vm_stack.(f.vf_base + s) <- v);
Nil
(* --- Upvalue access --- *)
let frame_upvalue_get frame_val idx =
let f = unwrap_frame frame_val in
f.vf_closure.vm_upvalues.(val_to_int idx).uv_value
let frame_upvalue_set frame_val idx v =
let f = unwrap_frame frame_val in
f.vf_closure.vm_upvalues.(val_to_int idx).uv_value <- v;
Nil
(* --- Field accessors --- *)
let frame_ip f = let fr = unwrap_frame f in Number (float_of_int fr.vf_ip)
let frame_set_ip_b f v = let fr = unwrap_frame f in fr.vf_ip <- val_to_int v; Nil
let frame_base f = let fr = unwrap_frame f in Number (float_of_int fr.vf_base)
let frame_closure f = let fr = unwrap_frame f in VmClosure fr.vf_closure
let closure_code cl = let c = unwrap_closure cl in
(* Return as Dict for code_bytecode/code_constants/code_locals *)
let d = Hashtbl.create 4 in
Hashtbl.replace d "vc-bytecode" (List (Array.to_list (Array.map (fun i -> Number (float_of_int i)) c.vm_code.vc_bytecode)));
Hashtbl.replace d "vc-constants" (List (Array.to_list c.vm_code.vc_constants));
Hashtbl.replace d "vc-arity" (Number (float_of_int c.vm_code.vc_arity));
Hashtbl.replace d "vc-locals" (Number (float_of_int c.vm_code.vc_locals));
Dict d
let closure_upvalues cl = let c = unwrap_closure cl in
List (Array.to_list (Array.map (fun cell -> cell.uv_value) c.vm_upvalues))
let closure_env cl = match cl with
| VmClosure c -> (match c.vm_closure_env with Some e -> Env e | None -> Nil)
| _ -> Nil
let code_bytecode code = get_val code (String "vc-bytecode")
let code_constants code = get_val code (String "vc-constants")
let code_locals code = get_val code (String "vc-locals")
let vm_sp v = let m = unwrap_vm v in Number (float_of_int m.vm_sp)
let vm_set_sp_b v s = let m = unwrap_vm v in m.vm_sp <- val_to_int s; Nil
let vm_stack v = let _m = unwrap_vm v in Nil (* opaque — use vm_push/pop *)
let vm_set_stack_b v _s = Nil
let vm_frames v = let m = unwrap_vm v in List (List.map (fun f -> VmFrame f) m.vm_frames)
let vm_set_frames_b v fs = let m = unwrap_vm v in
m.vm_frames <- (match fs with
| List l -> List.map unwrap_frame l
| _ -> []);
Nil
let vm_globals_ref v = let m = unwrap_vm v in Dict m.vm_globals
(* --- Global variable access --- *)
let vm_global_get vm_val frame_val name =
let m = unwrap_vm vm_val in
let n = value_to_string name in
(* Try globals table first *)
match Hashtbl.find_opt m.vm_globals n with
| Some v -> v
| None ->
(* Walk closure env chain *)
let f = unwrap_frame frame_val in
(match f.vf_closure.vm_closure_env with
| Some env ->
let id = intern n in
let rec find_env e =
match Hashtbl.find_opt e.bindings id with
| Some v -> v
| None -> (match e.parent with Some p -> find_env p | None ->
(* Try evaluator's primitive table as last resort *)
(try prim_call n [] with _ ->
raise (Eval_error ("VM undefined: " ^ n))))
in find_env env
| None ->
(try prim_call n [] with _ ->
raise (Eval_error ("VM undefined: " ^ n))))
let vm_global_set vm_val frame_val name v =
let m = unwrap_vm vm_val in
let n = value_to_string name in
let f = unwrap_frame frame_val in
(* Write to closure env if name exists there *)
let written = match f.vf_closure.vm_closure_env with
| Some env ->
let id = intern n in
let rec find_env e =
if Hashtbl.mem e.bindings id then
(Hashtbl.replace e.bindings id v; true)
else match e.parent with Some p -> find_env p | None -> false
in find_env env
| None -> false
in
if not written then begin
Hashtbl.replace m.vm_globals n v;
(match !_vm_global_set_hook with Some f -> f n v | None -> ())
end;
Nil
(* --- Frame push --- *)
let vm_push_frame vm_val closure_val args =
let m = unwrap_vm vm_val in
let cl = unwrap_closure closure_val in
let f = { vf_closure = cl; vf_ip = 0; vf_base = m.vm_sp; vf_local_cells = Hashtbl.create 4 } in
let arg_list = to_ocaml_list args in
List.iter (fun a ->
m.vm_stack.(m.vm_sp) <- a; m.vm_sp <- m.vm_sp + 1
) arg_list;
(* Pad remaining locals *)
for _ = List.length arg_list to cl.vm_code.vc_locals - 1 do
m.vm_stack.(m.vm_sp) <- Nil; m.vm_sp <- m.vm_sp + 1
done;
m.vm_frames <- f :: m.vm_frames;
Nil
(* --- Closure type check --- *)
let vm_closure_p v = match v with VmClosure _ -> Bool true | _ -> Bool false
(* --- Closure creation (upvalue capture) --- *)
let vm_create_closure vm_val frame_val code_val =
let m = unwrap_vm vm_val in
let f = unwrap_frame frame_val in
let uv_count = match code_val with
| Dict d -> (match Hashtbl.find_opt d "upvalue-count" with
| Some (Number n) -> int_of_float n | _ -> 0)
| _ -> 0
in
let upvalues = Array.init uv_count (fun _ ->
let is_local = let v = f.vf_closure.vm_code.vc_bytecode.(f.vf_ip) in f.vf_ip <- f.vf_ip + 1; v in
let index = let v = f.vf_closure.vm_code.vc_bytecode.(f.vf_ip) in f.vf_ip <- f.vf_ip + 1; v in
if is_local = 1 then begin
match Hashtbl.find_opt f.vf_local_cells index with
| Some existing -> existing
| None ->
let c = { uv_value = m.vm_stack.(f.vf_base + index) } in
Hashtbl.replace f.vf_local_cells index c;
c
end else
f.vf_closure.vm_upvalues.(index)
) in
let code = code_from_value code_val in
VmClosure { vm_code = code; vm_upvalues = upvalues; vm_name = None;
vm_env_ref = m.vm_globals; vm_closure_env = f.vf_closure.vm_closure_env }
(* --- JIT sentinel --- *)
let _jit_failed_sentinel = {
vm_code = { vc_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||];
vc_bytecode_list = None; vc_constants_list = None };
vm_upvalues = [||]; vm_name = Some "__jit_failed__"; vm_env_ref = Hashtbl.create 0; vm_closure_env = None
}
let _is_jit_failed cl = cl.vm_code.vc_arity = -1
(* --- Lambda accessors --- *)
let is_lambda v = match v with Lambda _ -> Bool true | _ -> Bool false
let lambda_compiled v = match v with
| Lambda l -> (match l.l_compiled with Some c -> VmClosure c | None -> Nil)
| _ -> Nil
let lambda_set_compiled_b v c = match v with
| Lambda l -> (match c with
| VmClosure cl -> l.l_compiled <- Some cl; Nil
| String "jit-failed" -> l.l_compiled <- Some _jit_failed_sentinel; Nil
| _ -> l.l_compiled <- None; Nil)
| _ -> Nil
let lambda_name v = match v with
| Lambda l -> (match l.l_name with Some n -> String n | None -> Nil)
| _ -> Nil
(* --- CEK call with suspension awareness --- *)
let cek_call_or_suspend vm_val f args =
let a = to_ocaml_list args in
let state = Sx_ref.continue_with_call f (List a) (Env (Sx_types.make_env ())) (List a) (List []) in
let final = Sx_ref.cek_step_loop state in
match get_val final (String "phase") with
| String "io-suspended" ->
let m = unwrap_vm vm_val in
m.vm_pending_cek <- Some final;
raise (Sx_vm.VmSuspended (get_val final (String "request"), Sx_vm.create m.vm_globals))
| _ -> Sx_ref.cek_value final
(* --- Env walking (for global variable resolution) --- *)
let rec env_walk env name =
match env with
| Env e ->
let id = intern (value_to_string name) in
let rec find e =
match Hashtbl.find_opt e.bindings id with
| Some v -> v
| None -> (match e.parent with Some p -> find p | None -> Nil)
in find e
| Nil -> Nil
| _ -> Nil
let env_walk_set_b env name value =
match env with
| Env e ->
let id = intern (value_to_string name) in
let rec find e =
if Hashtbl.mem e.bindings id then
(Hashtbl.replace e.bindings id value; true)
else match e.parent with Some p -> find p | None -> false
in
if find e then Nil else Nil
| _ -> Nil
(* --- Active VM tracking (module-level mutable state) --- *)
let _active_vm : vm_machine option ref = ref None
(* Forward ref — resolved after transpiled let rec block *)
let _vm_run_fn : (value -> value) ref = ref (fun _ -> Nil)
let _vm_call_fn : (value -> value -> value -> value) ref = ref (fun _ _ _ -> Nil)
(* vm-call-closure: creates fresh VM, runs closure, returns result *)
let vm_call_closure closure_val args globals =
let cl = unwrap_closure closure_val in
let prev_vm = !_active_vm in
let g = match globals with Dict d -> d | _ -> Hashtbl.create 0 in
let m = { vm_stack = Array.make 4096 Nil; vm_sp = 0;
vm_frames = []; vm_globals = g; vm_pending_cek = None } in
let vm_val = VmMachine m in
_active_vm := Some m;
ignore (vm_push_frame vm_val closure_val args);
(try ignore (!_vm_run_fn vm_val) with e -> _active_vm := prev_vm; raise e);
_active_vm := prev_vm;
vm_pop vm_val
(* --- JIT dispatch (platform-specific) --- *)
let try_jit_call vm_val f args =
let m = unwrap_vm vm_val in
match f with
| Lambda l ->
(match l.l_compiled with
| Some cl when not (_is_jit_failed cl) ->
(try vm_push vm_val (vm_call_closure (VmClosure cl) args (Dict cl.vm_env_ref))
with _ -> vm_push vm_val (cek_call_or_suspend vm_val f args))
| Some _ ->
vm_push vm_val (cek_call_or_suspend vm_val f args)
| None ->
if l.l_name <> None then begin
l.l_compiled <- Some _jit_failed_sentinel;
match !Sx_vm.jit_compile_ref l m.vm_globals with
| Some cl ->
l.l_compiled <- Some cl;
(try vm_push vm_val (vm_call_closure (VmClosure cl) args (Dict cl.vm_env_ref))
with _ -> vm_push vm_val (cek_call_or_suspend vm_val f args))
| None ->
vm_push vm_val (cek_call_or_suspend vm_val f args)
end else
vm_push vm_val (cek_call_or_suspend vm_val f args))
| _ -> vm_push vm_val (cek_call_or_suspend vm_val f args)
(* --- Collection helpers --- *)
let collect_n_from_stack vm_val n =
let m = unwrap_vm vm_val in
let count = val_to_int n in
let result = ref [] in
for _ = 1 to count do
m.vm_sp <- m.vm_sp - 1;
result := m.vm_stack.(m.vm_sp) :: !result
done;
List !result
let collect_n_pairs vm_val n =
let m = unwrap_vm vm_val in
let count = val_to_int n in
let d = Hashtbl.create count in
for _ = 1 to count do
m.vm_sp <- m.vm_sp - 1;
let v = m.vm_stack.(m.vm_sp) in
m.vm_sp <- m.vm_sp - 1;
let k = value_to_string m.vm_stack.(m.vm_sp) in
Hashtbl.replace d k v
done;
Dict d
let pad_n_nils vm_val n =
let m = unwrap_vm vm_val in
let count = val_to_int n in
for _ = 1 to count do
m.vm_stack.(m.vm_sp) <- Nil;
m.vm_sp <- m.vm_sp + 1
done;
Nil
"""
def main():
from shared.sx.ocaml_sync import OcamlSync
# Load the transpiler into OCaml kernel
bridge = OcamlSync()
transpiler_path = os.path.join(_HERE, "transpiler.sx")
bridge.load(transpiler_path)
# Read vm.sx
vm_path = os.path.join(_PROJECT, "lib", "vm.sx")
with open(vm_path) as f:
src = f.read()
defines = extract_defines_from_library(src)
# Filter out preamble functions
defines = [(n, e) for n, e in defines if n not in SKIP]
# Deduplicate (keep last definition)
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]
print(f"Transpiling {len(defines)} defines from vm.sx...", file=sys.stderr)
print(f" Skipped {len(SKIP)} preamble functions", file=sys.stderr)
for name, _ in defines:
print(f" -> {name}", file=sys.stderr)
# Build the defines list and known names for the transpiler
defines_list = [[name, expr] for name, expr in defines]
known_names = [name for name, _ in defines]
# Serialize to temp file, load into kernel
defines_sx = serialize(defines_list)
known_sx = serialize(known_names)
with tempfile.NamedTemporaryFile(mode="w", suffix=".sx", delete=False) as tmp:
tmp.write(f"(define _defines '{defines_sx})\n")
tmp.write(f"(define _known_defines '{known_sx})\n")
tmp_path = tmp.name
try:
bridge.load(tmp_path)
finally:
os.unlink(tmp_path)
# Call ml-translate-file — emits as single let rec block
result = bridge.eval("(ml-translate-file _defines)")
bridge.stop()
fixups = """
(* Wire forward references to transpiled functions *)
let () = _vm_run_fn := vm_run
let () = _vm_call_fn := vm_call
(* ================================================================
Public API — matches Sx_vm interface for drop-in replacement
================================================================ *)
(** Build a suspension dict from __io_request in globals. *)
let check_io_suspension globals vm_val =
match Hashtbl.find_opt globals "__io_request" with
| Some req when sx_truthy req ->
let d = Hashtbl.create 4 in
Hashtbl.replace d "suspended" (Bool true);
Hashtbl.replace d "op" (String "import");
Hashtbl.replace d "request" req;
Hashtbl.replace d "vm" vm_val;
Some (Dict d)
| _ -> None
(** Execute a compiled module — entry point for load-sxbc, compile-blob.
Returns the result value, or a suspension dict if OP_PERFORM fired. *)
let execute_module (code : vm_code) (globals : (string, value) Hashtbl.t) =
let cl = { vm_code = code; vm_upvalues = [||]; vm_name = Some "module";
vm_env_ref = globals; vm_closure_env = None } in
let m = { vm_stack = Array.make 4096 Nil; vm_sp = 0;
vm_frames = []; vm_globals = globals; vm_pending_cek = None } in
let vm_val = VmMachine m in
let frame = { vf_closure = cl; vf_ip = 0; vf_base = 0; vf_local_cells = Hashtbl.create 4 } in
for _ = 0 to code.vc_locals - 1 do
m.vm_stack.(m.vm_sp) <- Nil; m.vm_sp <- m.vm_sp + 1
done;
m.vm_frames <- [frame];
ignore (vm_run vm_val);
match check_io_suspension globals vm_val with
| Some suspension -> suspension
| None -> vm_pop vm_val
(** Resume a suspended module. Clears __io_request, pushes nil, re-runs. *)
let resume_module (suspended : value) =
match suspended with
| Dict d ->
let vm_val = Hashtbl.find d "vm" in
let globals = match vm_val with
| VmMachine m -> m.vm_globals
| _ -> raise (Eval_error "resume_module: expected VmMachine") in
Hashtbl.replace globals "__io_request" Nil;
ignore (vm_push vm_val Nil);
ignore (vm_run vm_val);
(match check_io_suspension globals vm_val with
| Some suspension -> suspension
| None -> vm_pop vm_val)
| _ -> raise (Eval_error "resume_module: expected suspension dict")
(** Execute a closure with args — entry point for JIT Lambda calls. *)
let call_closure (cl : vm_closure) (args : value list) (globals : (string, value) Hashtbl.t) =
vm_call_closure (VmClosure cl) (List args) (Dict globals)
(** Reexport code_from_value for callers *)
let code_from_value = code_from_value
(** Reexport jit refs *)
let jit_compile_ref = Sx_vm.jit_compile_ref
let jit_failed_sentinel = _jit_failed_sentinel
let is_jit_failed = _is_jit_failed
"""
output = PREAMBLE + "\n(* === Transpiled from lib/vm.sx === *)\n" + result + "\n" + fixups
# Write output
out_path = os.path.join(_HERE, "sx_vm_ref.ml")
with open(out_path, "w") as f:
f.write(output)
print(f"Wrote {len(output)} bytes to {out_path}", file=sys.stderr)
print(f" {len(defines)} functions transpiled", file=sys.stderr)
if __name__ == "__main__":
main()

105
hosts/ocaml/browser/bisect_sxbc.sh
View File

@@ -1,105 +0,0 @@
#!/bin/bash
# bisect_sxbc.sh — Binary search for which .sxbc file breaks reactive rendering.
# Runs test_wasm.sh with SX_TEST_BYTECODE=1, toggling individual files between
# bytecode and source to find the culprit.
set -euo pipefail
cd "$(dirname "$0")/../../.."
SXBC_DIR="shared/static/wasm/sx"
BACKUP_DIR="/tmp/sxbc-bisect-backup"
# All .sxbc files in load order
FILES=(
render core-signals signals deps router page-helpers freeze
bytecode compiler vm dom browser
adapter-html adapter-sx adapter-dom
boot-helpers hypersx
harness harness-reactive harness-web
engine orchestration boot
)
# Backup all sxbc files
mkdir -p "$BACKUP_DIR"
for f in "${FILES[@]}"; do
cp "$SXBC_DIR/$f.sxbc" "$BACKUP_DIR/$f.sxbc" 2>/dev/null || true
done
# Test function: returns 0 if the reactive scoped test passes
test_passes() {
local result
result=$(SX_TEST_BYTECODE=1 bash hosts/ocaml/browser/test_wasm.sh 2>&1) || true
if echo "$result" | grep -q "scoped static class"; then
# Test mentioned = it failed
return 1
else
return 0
fi
}
# Restore all bytecodes
restore_all() {
for f in "${FILES[@]}"; do
cp "$BACKUP_DIR/$f.sxbc" "$SXBC_DIR/$f.sxbc" 2>/dev/null || true
done
}
# Remove specific bytecodes (force source loading for those)
remove_sxbc() {
for f in "$@"; do
rm -f "$SXBC_DIR/$f.sxbc"
done
}
echo "=== Bytecode bisect: finding which .sxbc breaks reactive rendering ==="
echo " ${#FILES[@]} files to search"
echo ""
# First: verify all-bytecode fails
restore_all
echo "--- All bytecode (should fail) ---"
if test_passes; then
echo "UNEXPECTED: all-bytecode passes! Nothing to bisect."
exit 0
fi
echo " Confirmed: fails with all bytecode"
# Second: verify all-source passes
for f in "${FILES[@]}"; do rm -f "$SXBC_DIR/$f.sxbc"; done
echo "--- All source (should pass) ---"
if ! test_passes; then
echo "UNEXPECTED: all-source also fails! Bug is not bytecode-specific."
restore_all
exit 1
fi
echo " Confirmed: passes with all source"
# Binary search: find minimal set of bytecode files that causes failure
# Strategy: start with all source, add bytecode files one at a time
echo ""
echo "=== Individual file test ==="
culprits=()
for f in "${FILES[@]}"; do
# Start from all-source, add just this one file as bytecode
for g in "${FILES[@]}"; do rm -f "$SXBC_DIR/$g.sxbc"; done
cp "$BACKUP_DIR/$f.sxbc" "$SXBC_DIR/$f.sxbc"
if test_passes; then
printf " %-20s bytecode OK\n" "$f"
else
printf " %-20s *** BREAKS ***\n" "$f"
culprits+=("$f")
fi
done
# Restore
restore_all
echo ""
if [ ${#culprits[@]} -eq 0 ]; then
echo "No single file causes the failure — it's a combination."
echo "Run with groups to narrow down."
else
echo "=== CULPRIT FILE(S): ${culprits[*]} ==="
echo "These .sxbc files individually cause the reactive rendering to break."
fi

38
hosts/ocaml/browser/build-all.sh
View File

@@ -1,38 +0,0 @@
#!/bin/bash
# Full build: OCaml WASM kernel + bundle + bytecode compile + deploy to shared/static/wasm/
#
# Usage: bash hosts/ocaml/browser/build-all.sh
# Or via MCP: sx_build target="wasm"
set -e
cd "$(dirname "$0")"
echo "=== 1. Build WASM kernel ==="
# Remove assets dir that conflicts with dune's output target
rm -rf sx_browser.bc.wasm.assets
eval $(opam env 2>/dev/null)
cd ..
dune build browser/sx_browser.bc.wasm.js browser/sx_browser.bc.js bin/sx_server.exe 2>&1
cd browser
echo "=== 2. Bundle ==="
bash bundle.sh
echo "=== 3. Compile .sxbc bytecode ==="
node compile-modules.js dist
echo "=== 4. Deploy to shared/static/wasm/ ==="
DEST=../../../shared/static/wasm
cp dist/sx_browser.bc.wasm.js "$DEST/"
cp dist/sx_browser.bc.js "$DEST/"
rm -rf "$DEST/sx_browser.bc.wasm.assets"
cp -r dist/sx_browser.bc.wasm.assets "$DEST/"
cp dist/sx-platform.js "$DEST/sx-platform.js"
cp dist/sx/*.sx "$DEST/sx/"
cp dist/sx/*.sxbc "$DEST/sx/" 2>/dev/null || true
# Keep assets dir for Node.js WASM tests
cp -r dist/sx_browser.bc.wasm.assets ./ 2>/dev/null || true
echo "=== 5. Run WASM tests ==="
node test_wasm_native.js
echo "=== Done ==="

87
hosts/ocaml/browser/bundle.sh
View File

@@ -1,87 +0,0 @@
#!/bin/bash
# Bundle the WASM SX kernel + platform + .sx files for serving.
#
# Output goes to hosts/ocaml/browser/dist/
# Serve dist/ at /wasm/ or similar path.
set -e
cd "$(dirname "$0")"
BUILD=../_build/default/browser
DIST=dist
ROOT=../../..
echo "=== Bundling SX WASM browser engine ==="
rm -rf "$DIST"
mkdir -p "$DIST/sx"
# 1. WASM kernel
cp "$BUILD/sx_browser.bc.wasm.js" "$DIST/"
cp -r "$BUILD/sx_browser.bc.wasm.assets" "$DIST/"
# Also copy js_of_ocaml version as fallback
cp "$BUILD/sx_browser.bc.js" "$DIST/"
# 2. Platform JS
cp sx-platform.js "$DIST/"
# 3. Spec modules
cp "$ROOT/spec/signals.sx" "$DIST/sx/core-signals.sx"
cp "$ROOT/spec/render.sx" "$DIST/sx/"
cp "$ROOT/web/web-signals.sx" "$DIST/sx/signals.sx"
cp "$ROOT/web/deps.sx" "$DIST/sx/"
cp "$ROOT/web/router.sx" "$DIST/sx/"
cp "$ROOT/web/page-helpers.sx" "$DIST/sx/"
# 3b. Freeze scope (signal persistence) + highlight (syntax coloring)
cp "$ROOT/lib/freeze.sx" "$DIST/sx/"
cp "$ROOT/lib/highlight.sx" "$DIST/sx/"
# 4. Bytecode compiler + VM
cp "$ROOT/lib/bytecode.sx" "$DIST/sx/"
cp "$ROOT/lib/compiler.sx" "$DIST/sx/"
cp "$ROOT/lib/vm.sx" "$DIST/sx/"
# 5. Web libraries (8 FFI primitives)
cp "$ROOT/web/lib/dom.sx" "$DIST/sx/"
cp "$ROOT/web/lib/browser.sx" "$DIST/sx/"
# 6. Web adapters
cp "$ROOT/web/adapter-html.sx" "$DIST/sx/"
cp "$ROOT/web/adapter-sx.sx" "$DIST/sx/"
cp "$ROOT/web/adapter-dom.sx" "$DIST/sx/"
# 7. Boot helpers (platform functions in pure SX)
cp "$ROOT/web/lib/boot-helpers.sx" "$DIST/sx/"
cp "$ROOT/web/lib/hypersx.sx" "$DIST/sx/"
# 7b. Test harness (for inline test runners)
cp "$ROOT/spec/harness.sx" "$DIST/sx/"
cp "$ROOT/web/harness-reactive.sx" "$DIST/sx/"
cp "$ROOT/web/harness-web.sx" "$DIST/sx/"
# 8. Web framework
cp "$ROOT/web/engine.sx" "$DIST/sx/"
cp "$ROOT/web/orchestration.sx" "$DIST/sx/"
cp "$ROOT/web/boot.sx" "$DIST/sx/"
# 9. Styling (tw token engine)
cp "$ROOT/shared/sx/templates/tw-layout.sx" "$DIST/sx/"
cp "$ROOT/shared/sx/templates/tw-type.sx" "$DIST/sx/"
cp "$ROOT/shared/sx/templates/tw.sx" "$DIST/sx/"
# Summary
WASM_SIZE=$(du -sh "$DIST/sx_browser.bc.wasm.assets" | cut -f1)
JS_SIZE=$(du -sh "$DIST/sx_browser.bc.js" | cut -f1)
SX_SIZE=$(du -sh "$DIST/sx" | cut -f1)
echo " WASM kernel: $WASM_SIZE (assets)"
echo " JS fallback: $JS_SIZE"
echo " SX sources: $SX_SIZE ($(ls "$DIST/sx/" | wc -l) files)"
echo " Platform JS: $(du -sh "$DIST/sx-platform.js" | cut -f1)"
echo ""
echo " dist/ ready to serve"
echo ""
echo " HTML usage:"
echo ' <script src="/wasm/sx_browser.bc.wasm.js"></script>'
echo ' <script src="/wasm/sx-platform.js"></script>'

396
hosts/ocaml/browser/compile-modules.js
View File

@@ -1,396 +0,0 @@
#!/usr/bin/env node
/**
* compile-modules.js — Pre-compile .sx files to bytecode s-expressions.
*
* Uses the native OCaml sx_server binary for compilation (~5x faster than
* the js_of_ocaml kernel). Sends source via the blob protocol, receives
* compiled bytecode as SX text.
*
* Usage: node compile-modules.js [dist-dir]
*/
const fs = require('fs');
const path = require('path');
const crypto = require('crypto');
const { execSync, spawnSync } = require('child_process');
const distDir = process.argv[2] || path.join(__dirname, 'dist');
const sxDir = path.join(distDir, 'sx');
const projectRoot = path.resolve(__dirname, '..', '..', '..');
if (!fs.existsSync(sxDir)) {
console.error('sx dir not found:', sxDir);
process.exit(1);
}
// Sync source .sx files to dist/sx/ before compiling.
// Source locations: spec/ for core, lib/ for compiler/vm, web/ and web/lib/ for web stack.
const SOURCE_MAP = {
// spec/
'render.sx': 'spec/render.sx',
'core-signals.sx': 'spec/signals.sx',
// lib/
'bytecode.sx': 'lib/bytecode.sx', 'compiler.sx': 'lib/compiler.sx',
'vm.sx': 'lib/vm.sx', 'freeze.sx': 'lib/freeze.sx',
'highlight.sx': 'lib/highlight.sx',
// web/lib/
'dom.sx': 'web/lib/dom.sx', 'browser.sx': 'web/lib/browser.sx',
// web/
'signals.sx': 'web/signals.sx', 'deps.sx': 'web/deps.sx',
'router.sx': 'web/router.sx', 'page-helpers.sx': 'web/page-helpers.sx',
'adapter-html.sx': 'web/adapter-html.sx', 'adapter-sx.sx': 'web/adapter-sx.sx',
'adapter-dom.sx': 'web/adapter-dom.sx',
'boot-helpers.sx': 'web/lib/boot-helpers.sx',
'hypersx.sx': 'web/hypersx.sx',
'harness.sx': 'spec/harness.sx', 'harness-reactive.sx': 'web/harness-reactive.sx',
'harness-web.sx': 'web/harness-web.sx',
'engine.sx': 'web/engine.sx', 'orchestration.sx': 'web/orchestration.sx',
'boot.sx': 'web/boot.sx',
'tw-layout.sx': 'web/tw-layout.sx', 'tw-type.sx': 'web/tw-type.sx', 'tw.sx': 'web/tw.sx',
};
let synced = 0;
for (const [dist, src] of Object.entries(SOURCE_MAP)) {
const srcPath = path.join(projectRoot, src);
const dstPath = path.join(sxDir, dist);
if (fs.existsSync(srcPath)) {
const srcContent = fs.readFileSync(srcPath);
const dstExists = fs.existsSync(dstPath);
if (!dstExists || !fs.readFileSync(dstPath).equals(srcContent)) {
fs.writeFileSync(dstPath, srcContent);
synced++;
}
}
}
if (synced > 0) console.log('Synced ' + synced + ' source files to dist/sx/');
// Find the native OCaml binary
const binPaths = [
path.join(__dirname, '..', '_build', 'default', 'bin', 'sx_server.exe'),
'/app/bin/sx_server',
];
const binPath = binPaths.find(p => fs.existsSync(p));
if (!binPath) {
console.error('sx_server binary not found at:', binPaths.join(', '));
process.exit(1);
}
const FILES = [
'render.sx', 'core-signals.sx', 'signals.sx', 'deps.sx', 'router.sx',
'page-helpers.sx', 'freeze.sx', 'bytecode.sx', 'compiler.sx', 'vm.sx',
'dom.sx', 'browser.sx', 'adapter-html.sx', 'adapter-sx.sx', 'adapter-dom.sx',
'tw-layout.sx', 'tw-type.sx', 'tw.sx',
'boot-helpers.sx', 'hypersx.sx', 'harness.sx', 'harness-reactive.sx',
'harness-web.sx', 'engine.sx', 'orchestration.sx', 'boot.sx',
];
// ---------------------------------------------------------------------------
// Build the full input script — all commands in one batch
// ---------------------------------------------------------------------------
const t0 = Date.now();
console.log('Building compilation script...');
let epoch = 1;
let script = '';
// Load compiler
script += `(epoch ${epoch++})\n(load "lib/compiler.sx")\n`;
// JIT pre-compile the compiler (skipped: vm-compile-adapter hangs with
// define-library wrappers in some lambda JIT paths. Compilation still
// works via CEK — just ~2x slower per file.)
// script += `(epoch ${epoch++})\n(vm-compile-adapter)\n`;
// Load all modules into env
for (const file of FILES) {
const src = fs.readFileSync(path.join(sxDir, file), 'utf8');
const buf = Buffer.from(src, 'utf8');
script += `(epoch ${epoch++})\n(eval-blob)\n(blob ${buf.length})\n`;
script += src + '\n';
}
// ---------------------------------------------------------------------------
// Strip define-library wrapper for bytecode compilation.
//
// Keeps (import ...) forms — the compiler emits OP_PERFORM for these, enabling
// lazy loading: when the VM hits an import for an unloaded library, it suspends
// to the JS platform which fetches the library on demand.
//
// Strips define-library header (name, export) and (begin ...) wrapper, leaving
// the body defines + import instructions as top-level forms.
// ---------------------------------------------------------------------------
function stripLibraryWrapper(source) {
// Line-based stripping: unwrap (define-library ... (begin BODY)), keep (import ...).
const lines = source.split('\n');
const result = [];
let skip = false; // inside header region (define-library, export)
for (let i = 0; i < lines.length; i++) {
const line = lines[i];
const trimmed = line.trim();
// Skip (define-library ...) header lines until (begin
if (trimmed.startsWith('(define-library ')) { skip = true; continue; }
if (skip && trimmed.startsWith('(export')) { continue; }
if (skip && trimmed.match(/^\(begin/)) { skip = false; continue; }
if (skip) continue;
// Skip closing )) of define-library — line is just ) or )) optionally with comments
if (trimmed.match(/^\)+(\s*;.*)?$/)) {
// Check if this is the end-of-define-library closer (only `)` chars + optional comment)
// vs a regular body closer like ` )` inside a nested form
// Only skip if at column 0 (not indented = top-level closer)
if (line.match(/^\)/)) continue;
}
// Skip standalone comments that are just structural markers
if (trimmed.match(/^;;\s*(end define-library|Re-export)/)) continue;
result.push(line);
}
return result.join('\n');
}
// Compile each module (stripped of define-library/import wrappers)
const compileEpochs = {};
for (const file of FILES) {
const rawSrc = fs.readFileSync(path.join(sxDir, file), 'utf8');
const src = stripLibraryWrapper(rawSrc);
const buf = Buffer.from(src, 'utf8');
const ep = epoch++;
compileEpochs[ep] = file;
script += `(epoch ${ep})\n(compile-blob)\n(blob ${buf.length})\n`;
script += src + '\n';
}
// Write script to temp file and pipe to server
const tmpFile = '/tmp/sx-compile-script.txt';
fs.writeFileSync(tmpFile, script);
console.log('Running native OCaml compiler (' + FILES.length + ' files)...');
const t1 = Date.now();
const result = spawnSync(binPath, [], {
input: fs.readFileSync(tmpFile),
maxBuffer: 100 * 1024 * 1024, // 100MB
timeout: 600000, // 10 min
stdio: ['pipe', 'pipe', 'pipe'],
});
if (result.error) {
console.error('Server error:', result.error);
process.exit(1);
}
const stderr = result.stderr.toString();
process.stderr.write(stderr);
// Use latin1 to preserve byte positions (UTF-8 multi-byte chars stay as-is in length)
const stdoutBuf = result.stdout;
const stdout = stdoutBuf.toString('latin1');
const dt = Date.now() - t1;
console.log('Server finished in ' + Math.round(dt / 1000) + 's');
// ---------------------------------------------------------------------------
// Parse responses — extract compiled bytecode for each file
// ---------------------------------------------------------------------------
// Parse responses — stdout is latin1 so byte positions match string positions
let compiled = 0, skipped = 0;
let pos = 0;
function nextLine() {
const nl = stdout.indexOf('\n', pos);
if (nl === -1) return null;
const line = stdout.slice(pos, nl);
pos = nl + 1;
return line;
}
while (pos < stdout.length) {
const line = nextLine();
if (line === null) break;
const trimmed = line.trim();
// ok-len EPOCH LEN — read LEN bytes as value
const lenMatch = trimmed.match(/^\(ok-len (\d+) (\d+)\)$/);
if (lenMatch) {
const ep = parseInt(lenMatch[1]);
const len = parseInt(lenMatch[2]);
// Read exactly len bytes — latin1 encoding preserves byte positions
const rawValue = stdout.slice(pos, pos + len);
// Re-encode to proper UTF-8
const value = Buffer.from(rawValue, 'latin1').toString('utf8');
pos += len;
// skip trailing newline
if (pos < stdout.length && stdout.charCodeAt(pos) === 10) pos++;
const file = compileEpochs[ep];
if (file) {
if (value === 'nil' || value.startsWith('(error')) {
console.error(' SKIP', file, '—', value.slice(0, 60));
skipped++;
} else {
const hash = crypto.createHash('sha256')
.update(fs.readFileSync(path.join(sxDir, file), 'utf8'))
.digest('hex').slice(0, 16);
const sxbc = '(sxbc 1 "' + hash + '"\n (code\n ' +
value.replace(/^\{/, '').replace(/\}$/, '').trim() + '))\n';
const outPath = path.join(sxDir, file.replace(/\.sx$/, '.sxbc'));
fs.writeFileSync(outPath, sxbc);
const size = fs.statSync(outPath).size;
console.log(' ok', file, '→', Math.round(size / 1024) + 'K');
compiled++;
}
}
continue;
}
// Simple ok or error — skip
if (trimmed.match(/^\(ok \d+/) || trimmed.match(/^\(error \d+/)) {
if (trimmed.match(/^\(error/)) {
const epMatch = trimmed.match(/^\(error (\d+)/);
if (epMatch) {
const ep = parseInt(epMatch[1]);
const file = compileEpochs[ep];
if (file) {
console.error(' SKIP', file, '—', trimmed.slice(0, 80));
skipped++;
}
}
}
continue;
}
}
// Copy compiled files to shared/static/wasm/sx/ for web serving
const staticSxDir = path.resolve(__dirname, '..', '..', '..', 'shared', 'static', 'wasm', 'sx');
if (fs.existsSync(staticSxDir)) {
let copied = 0;
for (const file of FILES) {
// Copy bytecode
for (const ext of ['.sxbc', '.sxbc.json']) {
const src = path.join(sxDir, file.replace(/\.sx$/, ext));
const dst = path.join(staticSxDir, file.replace(/\.sx$/, ext));
if (fs.existsSync(src)) {
fs.copyFileSync(src, dst);
copied++;
}
}
// Also sync .sx source files (fallback when .sxbc missing)
const sxSrc = path.join(sxDir, file);
const sxDst = path.join(staticSxDir, file);
if (fs.existsSync(sxSrc) && !fs.lstatSync(sxSrc).isSymbolicLink()) {
fs.copyFileSync(sxSrc, sxDst);
copied++;
}
}
console.log('Copied', copied, 'files to', staticSxDir);
}
// ---------------------------------------------------------------------------
// Generate module-manifest.json — dependency graph for lazy loading
// ---------------------------------------------------------------------------
console.log('Generating module manifest...');
// Extract library name from (define-library (namespace name) ...) in source
function extractLibraryName(source) {
const m = source.match(/\(define-library\s+(\([^)]+\))/);
return m ? m[1] : null;
}
// Extract top-level (import (namespace name)) deps from source
// Only matches imports BEFORE define-library (dependency declarations)
function extractImportDeps(source) {
const deps = [];
const lines = source.split('\n');
for (const line of lines) {
// Stop at define-library — imports after that are self-imports
if (line.startsWith('(define-library')) break;
const m = line.match(/^\(import\s+(\([^)]+\))\)/);
if (m) deps.push(m[1]);
}
return deps;
}
// Extract exported symbol names from (export name1 name2 ...) clause
function extractExports(source) {
const exports = [];
const m = source.match(/\(export\s+([\s\S]*?)\)\s*\(/);
if (!m) return exports;
// Parse symbol names from the export list (skip keywords, nested forms)
const tokens = m[1].split(/\s+/).filter(t => t && !t.startsWith(':') && !t.startsWith('(') && !t.startsWith(')'));
for (const t of tokens) {
const clean = t.replace(/[()]/g, '');
if (clean && !clean.startsWith(':')) exports.push(clean);
}
return exports;
}
// Flatten library spec: "(sx dom)" → "sx dom"
function libKey(spec) {
return spec.replace(/^\(/, '').replace(/\)$/, '');
}
const manifest = {};
let entryFile = null;
for (const file of FILES) {
const srcPath = path.join(sxDir, file);
if (!fs.existsSync(srcPath)) continue;
const src = fs.readFileSync(srcPath, 'utf8');
const libName = extractLibraryName(src);
const deps = extractImportDeps(src);
const sxbcFile = file.replace(/\.sx$/, '.sxbc');
if (libName) {
const exports = extractExports(src);
manifest[libKey(libName)] = {
file: sxbcFile,
deps: deps.map(libKey),
exports: exports,
};
} else if (deps.length > 0) {
// Entry point (no define-library, has imports)
entryFile = { file: sxbcFile, deps: deps.map(libKey) };
}
}
if (entryFile) {
// Partition entry deps into eager (needed at boot) and lazy (loaded on demand).
// Lazy deps are fetched by the suspension handler when the kernel requests them.
const LAZY_ENTRY_DEPS = new Set([
'sx bytecode', // JIT-only — enable-jit! runs after boot
]);
const eagerDeps = entryFile.deps.filter(d => !LAZY_ENTRY_DEPS.has(d));
const lazyDeps = entryFile.deps.filter(d => LAZY_ENTRY_DEPS.has(d));
manifest['_entry'] = {
file: entryFile.file,
deps: eagerDeps,
};
if (lazyDeps.length > 0) {
manifest['_entry'].lazy_deps = lazyDeps;
}
}
const manifestPath = path.join(sxDir, 'module-manifest.json');
fs.writeFileSync(manifestPath, JSON.stringify(manifest, null, 2) + '\n');
console.log(' Wrote', manifestPath, '(' + Object.keys(manifest).length + ' modules)');
// Copy manifest to static dir
if (fs.existsSync(staticSxDir)) {
fs.copyFileSync(manifestPath, path.join(staticSxDir, 'module-manifest.json'));
console.log(' Copied manifest to', staticSxDir);
}
const total = Date.now() - t0;
console.log('Done:', compiled, 'compiled,', skipped, 'skipped in', Math.round(total / 1000) + 's');
fs.unlinkSync(tmpFile);

5
hosts/ocaml/browser/dune
View File

@@ -1,5 +0,0 @@
(executable
(name sx_browser)
(libraries sx js_of_ocaml)
(modes byte js wasm)
(preprocess (pps js_of_ocaml-ppx)))

697
hosts/ocaml/browser/sx-platform.js
View File

@@ -1,697 +0,0 @@
/**
* sx-platform.js — Browser platform layer for the SX WASM kernel.
*
* Registers the 8 FFI host primitives and loads web adapter .sx files.
* This is the only JS needed beyond the WASM kernel itself.
*
* Usage:
* <script src="sx_browser.bc.wasm.js"></script>
* <script src="sx-platform.js"></script>
*
* Or for js_of_ocaml mode:
* <script src="sx_browser.bc.js"></script>
* <script src="sx-platform.js"></script>
*/
(function() {
"use strict";
function boot(K) {
// ================================================================
// FFI Host Primitives
// ================================================================
// Lazy module loading — islands/components call this to declare dependencies
K.registerNative("load-library!", function(args) {
var name = args[0];
if (!name) return false;
return __sxLoadLibrary(name) || false;
});
K.registerNative("host-global", function(args) {
var name = args[0];
if (typeof globalThis !== "undefined" && name in globalThis) return globalThis[name];
if (typeof window !== "undefined" && name in window) return window[name];
return null;
});
K.registerNative("host-get", function(args) {
var obj = args[0], prop = args[1];
if (obj == null) return null;
var v = obj[prop];
return v === undefined ? null : v;
});
K.registerNative("host-set!", function(args) {
var obj = args[0], prop = args[1], val = args[2];
if (obj != null) obj[prop] = val;
});
K.registerNative("host-call", function(args) {
var obj = args[0], method = args[1];
var callArgs = [];
for (var i = 2; i < args.length; i++) callArgs.push(args[i]);
if (obj == null) {
// Global function call
var fn = typeof globalThis !== "undefined" ? globalThis[method] : window[method];
if (typeof fn === "function") return fn.apply(null, callArgs);
return null;
}
if (typeof obj[method] === "function") {
try { return obj[method].apply(obj, callArgs); }
catch(e) { console.error("[sx] host-call error:", e); return null; }
}
return null;
});
K.registerNative("host-new", function(args) {
var name = args[0];
var cArgs = args.slice(1);
var Ctor = typeof globalThis !== "undefined" ? globalThis[name] : window[name];
if (typeof Ctor !== "function") return null;
switch (cArgs.length) {
case 0: return new Ctor();
case 1: return new Ctor(cArgs[0]);
case 2: return new Ctor(cArgs[0], cArgs[1]);
case 3: return new Ctor(cArgs[0], cArgs[1], cArgs[2]);
default: return new Ctor(cArgs[0], cArgs[1], cArgs[2], cArgs[3]);
}
});
K.registerNative("host-callback", function(args) {
var fn = args[0];
// Native JS function — pass through
if (typeof fn === "function") return fn;
// SX callable (has __sx_handle) — wrap as JS function
if (fn && fn.__sx_handle !== undefined) {
return function() {
var a = Array.prototype.slice.call(arguments);
return K.callFn(fn, a);
};
}
return function() {};
});
K.registerNative("host-typeof", function(args) {
var obj = args[0];
if (obj == null) return "nil";
if (obj instanceof Element) return "element";
if (obj instanceof Text) return "text";
if (obj instanceof DocumentFragment) return "fragment";
if (obj instanceof Document) return "document";
if (obj instanceof Event) return "event";
if (obj instanceof Promise) return "promise";
if (obj instanceof AbortController) return "abort-controller";
return typeof obj;
});
K.registerNative("host-await", function(args) {
var promise = args[0], callback = args[1];
if (promise && typeof promise.then === "function") {
var cb;
if (typeof callback === "function") cb = callback;
else if (callback && callback.__sx_handle !== undefined)
cb = function(v) { return K.callFn(callback, [v]); };
else cb = function() {};
promise.then(cb);
}
});
// ================================================================
// Constants expected by .sx files
// ================================================================
K.eval('(define SX_VERSION "wasm-1.0")');
K.eval('(define SX_ENGINE "ocaml-vm-wasm")');
K.eval('(define parse sx-parse)');
K.eval('(define serialize sx-serialize)');
// ================================================================
// DOM query helpers used by boot.sx / orchestration.sx
// (These are JS-native in the transpiled bundle; here via FFI.)
// ================================================================
K.registerNative("query-sx-scripts", function(args) {
var root = (args[0] && args[0] !== null) ? args[0] : document;
if (typeof root.querySelectorAll !== "function") root = document;
return Array.prototype.slice.call(root.querySelectorAll('script[type="text/sx"]'));
});
K.registerNative("query-page-scripts", function(args) {
return Array.prototype.slice.call(document.querySelectorAll('script[type="text/sx-pages"]'));
});
K.registerNative("query-component-scripts", function(args) {
var root = (args[0] && args[0] !== null) ? args[0] : document;
if (typeof root.querySelectorAll !== "function") root = document;
return Array.prototype.slice.call(root.querySelectorAll('script[type="text/sx"][data-components]'));
});
// localStorage
K.registerNative("local-storage-get", function(args) {
try { var v = localStorage.getItem(args[0]); return v === null ? null : v; }
catch(e) { return null; }
});
K.registerNative("local-storage-set", function(args) {
try { localStorage.setItem(args[0], args[1]); } catch(e) {}
});
K.registerNative("local-storage-remove", function(args) {
try { localStorage.removeItem(args[0]); } catch(e) {}
});
// log-info/log-warn defined in browser.sx; log-error as native fallback
K.registerNative("log-error", function(args) { console.error.apply(console, ["[sx]"].concat(args)); });
// Cookie access (browser-side)
K.registerNative("get-cookie", function(args) {
var name = args[0];
var match = document.cookie.match(new RegExp('(?:^|; )' + name.replace(/[.*+?^${}()|[\]\\]/g, '\\$&') + '=([^;]*)'));
return match ? decodeURIComponent(match[1]) : null;
});
K.registerNative("set-cookie", function(args) {
document.cookie = args[0] + "=" + encodeURIComponent(args[1] || "") + ";path=/;max-age=31536000;SameSite=Lax";
});
// IntersectionObserver — native JS to avoid bytecode callback issues
K.registerNative("observe-intersection", function(args) {
var el = args[0], callback = args[1], once = args[2], delay = args[3];
var obs = new IntersectionObserver(function(entries) {
for (var i = 0; i < entries.length; i++) {
if (entries[i].isIntersecting) {
var d = (delay && delay !== null) ? delay : 0;
setTimeout(function() { K.callFn(callback, []); }, d);
if (once) obs.unobserve(el);
}
}
});
obs.observe(el);
return obs;
});
// ================================================================
// Load SX web libraries and adapters
// ================================================================
// Load order follows dependency graph:
// 1. Core spec files (parser, render, primitives already compiled into WASM kernel)
// 2. Spec modules: signals, deps, router, page-helpers
// 3. Bytecode compiler + VM (for JIT in browser)
// 4. Web libraries: dom.sx, browser.sx (built on 8 FFI primitives)
// 5. Web adapters: adapter-html, adapter-sx, adapter-dom
// 6. Web framework: engine, orchestration, boot
var _baseUrl = "";
// Detect base URL and cache-bust params from current script tag.
// _cacheBust comes from the script's own ?v= query string (used for .sx source fallback).
// _sxbcCacheBust comes from data-sxbc-hash attribute — a separate content hash
// covering all .sxbc files so each file gets its own correct cache buster.
var _cacheBust = "";
var _sxbcCacheBust = "";
(function() {
if (typeof document !== "undefined") {
var scripts = document.getElementsByTagName("script");
for (var i = scripts.length - 1; i >= 0; i--) {
var src = scripts[i].src || "";
if (src.indexOf("sx-platform") !== -1) {
_baseUrl = src.substring(0, src.lastIndexOf("/") + 1);
var qi = src.indexOf("?");
if (qi !== -1) _cacheBust = src.substring(qi);
var sxbcHash = scripts[i].getAttribute("data-sxbc-hash");
if (sxbcHash) _sxbcCacheBust = "?v=" + sxbcHash;
break;
}
}
}
})();
/**
* Deserialize type-tagged JSON constant back to JS value for loadModule.
*/
function deserializeConstant(c) {
if (!c || !c.t) return null;
switch (c.t) {
case 's': return c.v;
case 'n': return c.v;
case 'b': return c.v;
case 'nil': return null;
case 'sym': return { _type: 'symbol', name: c.v };
case 'kw': return { _type: 'keyword', name: c.v };
case 'list': return { _type: 'list', items: (c.v || []).map(deserializeConstant) };
case 'code': return {
_type: 'dict',
bytecode: { _type: 'list', items: c.v.bytecode },
constants: { _type: 'list', items: (c.v.constants || []).map(deserializeConstant) },
arity: c.v.arity || 0,
'upvalue-count': c.v['upvalue-count'] || 0,
locals: c.v.locals || 0,
};
case 'dict': {
var d = { _type: 'dict' };
for (var k in c.v) d[k] = deserializeConstant(c.v[k]);
return d;
}
default: return null;
}
}
/**
* Convert a parsed SX code form ({_type:"list", items:[symbol"code", ...]})
* into the dict format that K.loadModule / js_to_value expects.
* Mirrors the OCaml convert_code/convert_const in sx_browser.ml.
*/
function convertCodeForm(form) {
if (!form || form._type !== "list" || !form.items || !form.items.length) return null;
var items = form.items;
if (!items[0] || items[0]._type !== "symbol" || items[0].name !== "code") return null;
var d = { _type: "dict", arity: 0, "upvalue-count": 0 };
for (var i = 1; i < items.length; i++) {
var item = items[i];
if (item && item._type === "keyword" && i + 1 < items.length) {
var val = items[i + 1];
if (item.name === "arity" || item.name === "upvalue-count") {
d[item.name] = (typeof val === "number") ? val : 0;
} else if (item.name === "bytecode" && val && val._type === "list") {
d.bytecode = val; // {_type:"list", items:[numbers...]}
} else if (item.name === "constants" && val && val._type === "list") {
d.constants = { _type: "list", items: (val.items || []).map(convertConst) };
}
i++; // skip value
}
}
return d;
}
function convertConst(c) {
if (!c || typeof c !== "object") return c; // number, string, boolean, null pass through
if (c._type === "list" && c.items && c.items.length > 0) {
var head = c.items[0];
if (head && head._type === "symbol" && head.name === "code") {
return convertCodeForm(c);
}
if (head && head._type === "symbol" && head.name === "list") {
return { _type: "list", items: c.items.slice(1).map(convertConst) };
}
}
return c; // symbols, keywords, etc. pass through
}
/**
* Try loading a pre-compiled .sxbc bytecode module (SX text format).
* Uses K.loadModule which handles VM suspension (import requests).
* Returns true on success, null on failure (caller falls back to .sx source).
*/
function loadBytecodeFile(path) {
var sxbcPath = path.replace(/\.sx$/, '.sxbc');
var url = _baseUrl + sxbcPath + _sxbcCacheBust;
try {
var xhr = new XMLHttpRequest();
xhr.open("GET", url, false);
xhr.send();
if (xhr.status !== 200) return null;
// Parse the sxbc text to get the SX tree
var parsed = K.parse(xhr.responseText);
if (!parsed || !parsed.length) return null;
var sxbc = parsed[0]; // (sxbc version hash (code ...))
if (!sxbc || sxbc._type !== "list" || !sxbc.items) return null;
// Extract the code form — 3rd or 4th item (after sxbc, version, optional hash)
var codeForm = null;
for (var i = 1; i < sxbc.items.length; i++) {
var item = sxbc.items[i];
if (item && item._type === "list" && item.items && item.items.length > 0 &&
item.items[0] && item.items[0]._type === "symbol" && item.items[0].name === "code") {
codeForm = item;
break;
}
}
if (!codeForm) return null;
// Convert the SX code form to a dict for loadModule
var moduleDict = convertCodeForm(codeForm);
if (!moduleDict) return null;
// Load via K.loadModule which handles VmSuspended
var result = K.loadModule(moduleDict);
// Handle import suspensions — fetch missing libraries on demand
while (result && result.suspended && result.op === "import") {
var req = result.request;
var libName = req && req.library;
if (libName) {
// Try to find and load the library from the manifest
var loaded = handleImportSuspension(libName);
if (!loaded) {
console.warn("[sx-platform] lazy import: library not found:", libName);
}
}
// Resume the suspended module (null = library is now in env)
result = result.resume(null);
}
if (typeof result === 'string' && result.indexOf('Error') === 0) {
console.warn("[sx-platform] bytecode FAIL " + path + ":", result);
return null;
}
return true;
} catch(e) {
console.warn("[sx-platform] bytecode FAIL " + path + ":", e.message || e);
return null;
}
}
/**
* Handle an import suspension by finding and loading the library.
* The library name may be an SX value (list/string) — normalize to manifest key.
*/
function handleImportSuspension(libSpec) {
// libSpec from the kernel is the library name spec, e.g. {_type:"list", items:[{name:"sx"},{name:"dom"}]}
// or a string like "sx dom"
var key;
if (typeof libSpec === "string") {
key = libSpec;
} else if (libSpec && libSpec._type === "list" && libSpec.items) {
key = libSpec.items.map(function(item) {
return (item && item.name) ? item.name : String(item);
}).join(" ");
} else if (libSpec && libSpec._type === "dict") {
// Dict with key/name fields
key = libSpec.key || libSpec.name || "";
} else {
key = String(libSpec);
}
if (_loadedLibs[key]) return true; // already loaded
if (!_manifest) loadManifest();
if (!_manifest || !_manifest[key]) {
console.warn("[sx-platform] lazy import: unknown library key '" + key + "'");
return false;
}
// Load the library (and its deps) on demand
return loadLibrary(key, {});
}
/**
* Load an .sx file synchronously via XHR (boot-time only).
* Returns the number of expressions loaded, or an error string.
*/
function loadSxFile(path) {
var url = _baseUrl + path + _cacheBust;
try {
var xhr = new XMLHttpRequest();
xhr.open("GET", url, false); // synchronous
xhr.send();
if (xhr.status === 200) {
var result = K.load(xhr.responseText);
if (typeof result === "string" && result.indexOf("Error") === 0) {
console.error("[sx-platform] FAIL " + path + ":", result);
return 0;
}
console.log("[sx-platform] ok " + path + " (" + result + " exprs)");
return result;
} else {
console.error("[sx] Failed to fetch " + path + ": HTTP " + xhr.status);
return null;
}
} catch(e) {
console.error("[sx] Failed to load " + path + ":", e);
return null;
}
}
// ================================================================
// Manifest-driven module loader — only loads what's needed
// ================================================================
var _manifest = null;
var _loadedLibs = {};
/**
* Fetch and parse the module manifest (library deps + file paths).
*/
function loadManifest() {
if (_manifest) return _manifest;
try {
var xhr = new XMLHttpRequest();
xhr.open("GET", _baseUrl + "sx/module-manifest.json" + _cacheBust, false);
xhr.send();
if (xhr.status === 200) {
_manifest = JSON.parse(xhr.responseText);
return _manifest;
}
} catch(e) {}
console.warn("[sx-platform] No manifest found, falling back to full load");
return null;
}
/**
* Load a single library and all its dependencies (recursive).
* Cycle-safe: tracks in-progress loads to break circular deps.
* Functions in cyclic modules resolve symbols at call time via global env.
*/
function loadLibrary(name, loading) {
if (_loadedLibs[name]) return true;
if (loading[name]) return true; // cycle — skip
loading[name] = true;
var info = _manifest[name];
if (!info) {
console.warn("[sx-platform] Unknown library: " + name);
return false;
}
// Resolve deps first
for (var i = 0; i < info.deps.length; i++) {
loadLibrary(info.deps[i], loading);
}
// Mark as loaded BEFORE executing — self-imports (define-library re-exports)
// will see it as already loaded and skip rather than infinite-looping.
_loadedLibs[name] = true;
// Load this module
var ok = loadBytecodeFile("sx/" + info.file);
if (!ok) {
var sxFile = info.file.replace(/\.sxbc$/, '.sx');
ok = loadSxFile("sx/" + sxFile);
}
return !!ok;
}
/**
* Load web stack using the module manifest.
* Only downloads libraries that the entry point transitively depends on.
*/
function loadWebStack() {
var manifest = loadManifest();
if (!manifest) return loadWebStackFallback();
var entry = manifest["_entry"];
if (!entry) {
console.warn("[sx-platform] No _entry in manifest, falling back");
return loadWebStackFallback();
}
var loading = {};
var t0 = performance.now();
if (K.beginModuleLoad) K.beginModuleLoad();
// Load all entry point deps recursively
for (var i = 0; i < entry.deps.length; i++) {
loadLibrary(entry.deps[i], loading);
}
// Load entry point itself (boot.sx — not a library, just defines + init)
loadBytecodeFile("sx/" + entry.file) || loadSxFile("sx/" + entry.file.replace(/\.sxbc$/, '.sx'));
if (K.endModuleLoad) K.endModuleLoad();
var count = Object.keys(_loadedLibs).length + 1; // +1 for entry
var dt = Math.round(performance.now() - t0);
console.log("[sx-platform] Loaded " + count + " modules in " + dt + "ms (manifest-driven)");
}
/**
* Fallback: load all files in hardcoded order (pre-manifest compat).
*/
function loadWebStackFallback() {
var files = [
"sx/render.sx", "sx/core-signals.sx", "sx/signals.sx", "sx/deps.sx",
"sx/router.sx", "sx/page-helpers.sx", "sx/freeze.sx", "sx/highlight.sx",
"sx/bytecode.sx", "sx/compiler.sx", "sx/vm.sx", "sx/dom.sx", "sx/browser.sx",
"sx/adapter-html.sx", "sx/adapter-sx.sx", "sx/adapter-dom.sx",
"sx/boot-helpers.sx", "sx/hypersx.sx", "sx/harness.sx",
"sx/harness-reactive.sx", "sx/harness-web.sx",
"sx/engine.sx", "sx/orchestration.sx", "sx/boot.sx",
];
if (K.beginModuleLoad) K.beginModuleLoad();
for (var i = 0; i < files.length; i++) {
if (!loadBytecodeFile(files[i])) loadSxFile(files[i]);
}
if (K.endModuleLoad) K.endModuleLoad();
console.log("[sx-platform] Loaded " + files.length + " files (fallback)");
}
/**
* Load an optional library on demand (e.g., highlight, harness).
* Can be called after boot for pages that need extra modules.
*/
globalThis.__sxLoadLibrary = function(name) {
if (!_manifest) loadManifest();
if (!_manifest) return false;
if (_loadedLibs[name]) return true;
if (K.beginModuleLoad) K.beginModuleLoad();
var ok = loadLibrary(name, {});
if (K.endModuleLoad) K.endModuleLoad();
return ok;
};
// ================================================================
// Transparent lazy loading — symbol → library index
//
// When the VM hits an undefined symbol, the resolve hook checks this
// index, loads the library that exports it, and returns the value.
// The programmer just calls the function — loading is invisible.
// ================================================================
var _symbolIndex = null; // symbol name → library key
function buildSymbolIndex() {
if (_symbolIndex) return _symbolIndex;
if (!_manifest) loadManifest();
if (!_manifest) return null;
_symbolIndex = {};
for (var key in _manifest) {
if (key.startsWith('_')) continue;
var entry = _manifest[key];
if (entry.exports) {
for (var i = 0; i < entry.exports.length; i++) {
_symbolIndex[entry.exports[i]] = key;
}
}
}
return _symbolIndex;
}
// Register the resolve hook — called by the VM when GLOBAL_GET fails
K.registerNative("__resolve-symbol", function(args) {
var name = args[0];
if (!name) return null;
var idx = buildSymbolIndex();
if (!idx || !idx[name]) return null;
var lib = idx[name];
if (_loadedLibs[lib]) return null; // already loaded but symbol still missing — real error
// Load the library
__sxLoadLibrary(lib);
// Return null — the VM will re-lookup in globals after the hook loads the module
return null;
});
// ================================================================
// Compatibility shim — expose Sx global matching current JS API
// ================================================================
globalThis.Sx = {
VERSION: "wasm-1.0",
parse: function(src) { return K.parse(src); },
eval: function(src) { return K.eval(src); },
load: function(src) { return K.load(src); },
renderToHtml: function(expr) { return K.renderToHtml(expr); },
callFn: function(fn, args) { return K.callFn(fn, args); },
engine: function() { return K.engine(); },
// Boot entry point (called by auto-init or manually)
init: function() {
if (typeof K.eval === "function") {
// Check boot-init exists
// Step through boot manually
console.log("[sx] init-css-tracking...");
K.eval("(init-css-tracking)");
console.log("[sx] process-page-scripts...");
K.eval("(process-page-scripts)");
console.log("[sx] routes after pages:", K.eval("(len _page-routes)"));
console.log("[sx] process-sx-scripts...");
K.eval("(process-sx-scripts nil)");
console.log("[sx] sx-hydrate-elements...");
K.eval("(sx-hydrate-elements nil)");
console.log("[sx] sx-hydrate-islands...");
K.eval("(sx-hydrate-islands nil)");
console.log("[sx] process-elements...");
K.eval("(process-elements nil)");
// Debug islands
console.log("[sx] ~home/stepper defined?", K.eval("(type-of ~home/stepper)"));
console.log("[sx] ~layouts/header defined?", K.eval("(type-of ~layouts/header)"));
// Island count (JS-side, avoids VM overhead)
console.log("[sx] manual island query:", document.querySelectorAll("[data-sx-island]").length);
// Try hydrating again
console.log("[sx] retry hydrate-islands...");
K.eval("(sx-hydrate-islands nil)");
// Check if links are boosted
var links = document.querySelectorAll("a[href]");
var boosted = 0;
for (var i = 0; i < links.length; i++) {
if (links[i]._sxBoundboost) boosted++;
}
console.log("[sx] boosted links:", boosted, "/", links.length);
// Check island state
var islands = document.querySelectorAll("[data-sx-island]");
console.log("[sx] islands:", islands.length);
for (var j = 0; j < islands.length; j++) {
console.log("[sx] island:", islands[j].getAttribute("data-sx-island"),
"hydrated:", !!islands[j]._sxBoundislandhydrated || !!islands[j]["_sxBound" + "island-hydrated"],
"children:", islands[j].children.length);
}
// Register popstate handler for back/forward navigation
window.addEventListener("popstate", function(e) {
var state = e.state;
var scrollY = (state && state.scrollY) ? state.scrollY : 0;
K.eval("(handle-popstate " + scrollY + ")");
});
// Signal boot complete
document.documentElement.setAttribute("data-sx-ready", "true");
console.log("[sx] boot done");
}
}
};
// ================================================================
// Auto-init: load web stack and boot on DOMContentLoaded
// ================================================================
if (typeof document !== "undefined") {
var _doInit = function() {
loadWebStack();
Sx.init();
// Enable JIT after all boot code has run.
// Lazy-load the compiler first — JIT needs it to compile functions.
setTimeout(function() {
if (K.beginModuleLoad) K.beginModuleLoad();
loadLibrary("sx compiler", {});
if (K.endModuleLoad) K.endModuleLoad();
K.eval('(enable-jit!)');
}, 0);
};
if (document.readyState === "loading") {
document.addEventListener("DOMContentLoaded", _doInit);
} else {
_doInit();
}
}
} // end boot
// SxKernel is available synchronously (js_of_ocaml) or after async
// WASM init. Poll briefly to handle both cases.
var K = globalThis.SxKernel;
if (K) { boot(K); return; }
var tries = 0;
var poll = setInterval(function() {
K = globalThis.SxKernel;
if (K) { clearInterval(poll); boot(K); }
else if (++tries > 100) { clearInterval(poll); console.error("[sx-platform] SxKernel not found after 5s"); }
}, 50);
})();

995
hosts/ocaml/browser/sx_browser.ml
View File

@@ -1,995 +0,0 @@
(** sx_browser.ml — OCaml SX kernel compiled to WASM/JS for browser use.
Exposes the CEK machine, bytecode VM, parser, and primitives as a
global [SxKernel] object that the JS platform layer binds to.
Fresh implementation on the ocaml-vm branch — builds on the bytecode
VM + lazy JIT infrastructure. *)
open Js_of_ocaml
open Sx_types
(* ================================================================== *)
(* Opaque value handle table *)
(* *)
(* Non-primitive SX values (lambdas, components, signals, etc.) are *)
(* stored here and represented on the JS side as objects with an *)
(* __sx_handle integer key. Preserves identity across JS↔OCaml. *)
(* ================================================================== *)
let _next_handle = ref 0
let _handle_table : (int, value) Hashtbl.t = Hashtbl.create 256
let alloc_handle (v : value) : int =
let id = !_next_handle in
incr _next_handle;
Hashtbl.replace _handle_table id v;
id
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))
(* JS-side opaque host object table.
Host objects (DOM elements, console, etc.) are stored here to preserve
identity across the OCaml↔JS boundary. Represented as Dict with
__host_handle key on the OCaml side. *)
let _next_host_handle = ref 0
let _alloc_host_handle = Js.Unsafe.pure_js_expr
"(function() { var t = {}; var n = 0; return { put: function(obj) { var id = n++; t[id] = obj; return id; }, get: function(id) { return t[id]; } }; })()"
let host_put (obj : Js.Unsafe.any) : int =
let id = !_next_host_handle in
incr _next_host_handle;
ignore (Js.Unsafe.meth_call _alloc_host_handle "put" [| obj |]);
id
let host_get_js (id : int) : Js.Unsafe.any =
Js.Unsafe.meth_call _alloc_host_handle "get" [| Js.Unsafe.inject id |]
(* ================================================================== *)
(* Global environment *)
(* ================================================================== *)
(* Clear scope stacks at startup *)
let () = Sx_primitives.scope_clear_all ()
let global_env = make_env ()
let _sx_render_mode = ref false
let call_sx_fn (fn : value) (args : value list) : value =
let result = Sx_runtime.sx_call fn args in
!Sx_primitives._sx_trampoline_fn result
(* ================================================================== *)
(* Value conversion: OCaml <-> JS *)
(* ================================================================== *)
(** Tag a JS function with __sx_handle and _type properties. *)
let _tag_fn = Js.Unsafe.pure_js_expr
"(function(fn, handle, type) { fn.__sx_handle = handle; fn._type = type; return fn; })"
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)
| RawHTML s -> Js.Unsafe.inject (Js.string s)
| Symbol s ->
Js.Unsafe.inject (Js.Unsafe.obj [|
("_type", Js.Unsafe.inject (Js.string "symbol"));
("name", Js.Unsafe.inject (Js.string s)) |])
| Keyword k ->
Js.Unsafe.inject (Js.Unsafe.obj [|
("_type", Js.Unsafe.inject (Js.string "keyword"));
("name", Js.Unsafe.inject (Js.string k)) |])
| List items | ListRef { contents = items } ->
let arr = items |> List.map value_to_js |> Array.of_list in
Js.Unsafe.inject (Js.Unsafe.obj [|
("_type", Js.Unsafe.inject (Js.string "list"));
("items", Js.Unsafe.inject (Js.array arr)) |])
| Dict d ->
(* Check for __host_handle — return original JS object *)
(match Hashtbl.find_opt d "__host_handle" with
| Some (Number n) -> host_get_js (int_of_float n)
| _ ->
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)
(* Callable values: wrap as JS functions with __sx_handle *)
| Lambda _ | NativeFn _ | Continuation _ | CallccContinuation _ | VmClosure _ ->
let handle = alloc_handle v in
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 ->
let fn_info = Printf.sprintf " [callback %s handle=%d]" (type_of v) handle in
ignore (Js.Unsafe.meth_call
(Js.Unsafe.get Js.Unsafe.global (Js.string "console"))
"error" [| Js.Unsafe.inject (Js.string ("[sx] " ^ msg ^ fn_info)) |]);
Js.Unsafe.inject Js.null
| exn ->
let fn_info = Printf.sprintf " [callback %s handle=%d]" (type_of v) handle in
ignore (Js.Unsafe.meth_call
(Js.Unsafe.get Js.Unsafe.global (Js.string "console"))
"error" [| Js.Unsafe.inject (Js.string ("[sx] UNCAUGHT: " ^ Printexc.to_string exn ^ fn_info)) |]);
Js.Unsafe.inject Js.null) 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: tagged object with handle *)
| _ ->
let handle = alloc_handle v in
Js.Unsafe.inject (Js.Unsafe.obj [|
("_type", Js.Unsafe.inject (Js.string (type_of v)));
("__sx_handle", Js.Unsafe.inject handle) |])
and js_to_value (js : Js.Unsafe.any) : value =
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" ->
let h = Js.Unsafe.get js (Js.string "__sx_handle") in
if not (Js.Unsafe.equals h Js.undefined) then
get_handle (Js.float_of_number (Js.Unsafe.coerce h) |> int_of_float)
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
js_to_value (Js.Unsafe.fun_call js (Array.map Fun.id js_args)))
| "object" ->
let h = Js.Unsafe.get js (Js.string "__sx_handle") in
if not (Js.Unsafe.equals h Js.undefined) then
get_handle (Js.float_of_number (Js.Unsafe.coerce h) |> int_of_float)
else
let type_field = Js.Unsafe.get js (Js.string "_type") in
if Js.Unsafe.equals type_field Js.undefined then begin
if Js.to_bool (Js.Unsafe.global##._Array##isArray js) then begin
let n = Js.float_of_number (Js.Unsafe.coerce (Js.Unsafe.get js (Js.string "length"))) |> int_of_float in
List (List.init n (fun i ->
js_to_value (Js.array_get (Js.Unsafe.coerce js) i |> Js.Optdef.to_option |> Option.get)))
end else begin
(* Opaque host object — store in JS-side table, return Dict with __host_handle *)
let id = host_put js in
let d = Hashtbl.create 2 in
Hashtbl.replace d "__host_handle" (Number (float_of_int id));
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 n = Js.float_of_number (Js.Unsafe.coerce (Js.Unsafe.get items_js (Js.string "length"))) |> int_of_float in
List (List.init n (fun i ->
js_to_value (Js.array_get (Js.Unsafe.coerce items_js) i |> Js.Optdef.to_option |> Option.get)))
| "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
Hashtbl.replace d k (js_to_value (Js.Unsafe.get js (Js.string k)))
done;
Dict d
| _ -> Nil
end
| _ -> Nil
(* ================================================================== *)
(* Side-channel return (bypasses js_of_ocaml stripping properties) *)
(* ================================================================== *)
let return_via_side_channel (v : Js.Unsafe.any) : Js.Unsafe.any =
Js.Unsafe.set Js.Unsafe.global (Js.string "__sxR") v; v
(* ================================================================== *)
(* Persistent VM globals — synced with global_env *)
(* ================================================================== *)
(* String-keyed mirror of global_env.bindings for VmClosures.
VmClosures from bytecode modules hold vm_env_ref pointing here.
Must stay in sync so VmClosures see post-boot definitions. *)
let _vm_globals : (string, value) Hashtbl.t = Hashtbl.create 512
let _in_batch = ref false
(* Sync env→VM: copy all bindings from global_env.bindings to _vm_globals.
Called after CEK eval/load so VmClosures can see new definitions. *)
let sync_env_to_vm () =
Hashtbl.iter (fun id v ->
Hashtbl.replace _vm_globals (unintern id) v
) global_env.bindings
(* Hook: intercept env_bind on global_env to also update _vm_globals.
Only sync bindings on the global env — let bindings in child envs
must NOT leak into _vm_globals (they'd overwrite real definitions). *)
let () =
Sx_types._env_bind_hook := Some (fun env name v ->
if env == global_env then
Hashtbl.replace _vm_globals name v)
(* Reverse hook: sync VM GLOBAL_SET mutations back to global_env.
Without this, set! inside JIT-compiled functions writes to _vm_globals
but leaves global_env stale — CEK reads then see the old value. *)
let () =
Sx_types._vm_global_set_hook := Some (fun name v ->
Hashtbl.replace global_env.bindings (Sx_types.intern name) v)
(* Symbol resolve hook: transparent lazy module loading.
When GLOBAL_GET can't find a symbol, this calls the JS __resolve-symbol
native which checks the manifest's symbol→library index and loads the
library that exports it. After loading, the symbol is in _vm_globals. *)
let () =
Sx_types._symbol_resolve_hook := Some (fun name ->
match Hashtbl.find_opt Sx_primitives.primitives "__resolve-symbol" with
| None -> None
| Some resolve_fn ->
(try ignore (resolve_fn [String name]) with _ -> ());
(* Check if the symbol appeared in globals after the load *)
match Hashtbl.find_opt _vm_globals name with
| Some v -> Some v
| None -> None)
(* ================================================================== *)
(* Core API *)
(* ================================================================== *)
let api_parse src_js =
let src = Js.to_string src_js in
try
let values = Sx_parser.parse_all src in
Js.Unsafe.inject (Js.array (values |> List.map value_to_js |> Array.of_list))
with Parse_error msg ->
Js.Unsafe.inject (Js.string ("Parse error: " ^ msg))
(** Build a JS suspension marker for the platform to handle.
Returns {suspended: true, op: string, request: obj, resume: fn(result)} *)
let _make_js_suspension request resume_fn =
let obj = Js.Unsafe.obj [||] in
Js.Unsafe.set obj (Js.string "suspended") (Js.Unsafe.inject (Js.bool true));
let op = match request with
| Dict d -> (match Hashtbl.find_opt d "op" with Some (String s) -> s | _ -> "unknown")
| _ -> "unknown" in
Js.Unsafe.set obj (Js.string "op") (Js.Unsafe.inject (Js.string op));
Js.Unsafe.set obj (Js.string "request") (value_to_js request);
Js.Unsafe.set obj (Js.string "resume") (Js.wrap_callback (fun result_js ->
let result = js_to_value result_js in
resume_fn result));
obj
(** Handle an import suspension: load the library from the library registry
or return a suspension marker to JS for async loading. *)
let handle_import_suspension request =
let lib_spec = match request with
| Dict d -> (match Hashtbl.find_opt d "library" with Some v -> v | _ -> Nil)
| _ -> Nil in
let key = Sx_ref.library_name_key lib_spec in
if Sx_types.sx_truthy (Sx_ref.library_loaded_p key) then
Some Nil (* Already loaded — resume immediately *)
else
None (* Not loaded — JS platform must fetch it *)
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
sync_env_to_vm ();
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))
(** evalVM: compile SX source to bytecode and run through the VM.
Globals defined with `define` are visible to subsequent evalVM/eval calls.
This tests the exact same code path as island hydration and click handlers. *)
let api_eval_vm src_js =
let src = Js.to_string src_js in
try
let exprs = Sx_parser.parse_all src in
let compile_fn = match Hashtbl.find_opt _vm_globals "compile-module" with
| Some v -> v
| None -> env_get global_env "compile-module" in
let code_val = Sx_ref.trampoline (Sx_runtime.sx_call compile_fn [List exprs]) in
let code = Sx_vm.code_from_value code_val in
let result = Sx_vm_ref.execute_module code _vm_globals in
(* Sync VM globals → CEK env so subsequent eval() calls see defines *)
Hashtbl.iter (fun name v ->
let id = intern name in
if not (Hashtbl.mem global_env.bindings id) then
Hashtbl.replace global_env.bindings id v
else (match Hashtbl.find global_env.bindings id, v with
| VmClosure _, VmClosure _ | _, VmClosure _ -> Hashtbl.replace global_env.bindings id v
| _ -> ())
) _vm_globals;
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))
| Not_found -> Js.Unsafe.inject (Js.string "Error: compile-module not loaded")
let api_eval_expr expr_js _env_js =
let expr = js_to_value expr_js in
try
let result = Sx_ref.eval_expr expr (Env global_env) in
sync_env_to_vm ();
return_via_side_channel (value_to_js result)
with Eval_error msg ->
Js.Unsafe.inject (Js.string ("Error: " ^ msg))
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 ->
(* Use IO-aware eval for each expression to handle import suspensions *)
let state = Sx_ref.make_cek_state expr env (List []) in
let final = ref (Sx_ref.cek_step_loop state) in
while Sx_types.sx_truthy (Sx_ref.cek_suspended_p !final) do
let request = Sx_ref.cek_io_request !final in
let op = match request with
| Dict d -> (match Hashtbl.find_opt d "op" with Some (String s) -> s | _ -> "")
| _ -> "" in
let response = if op = "import" then begin
match handle_import_suspension request with
| Some v -> v
| None -> Nil (* Library not found — resume with nil, import will use what's in env *)
end else Nil in
final := Sx_ref.cek_resume !final response
done;
ignore (Sx_ref.cek_value !final);
incr count
) exprs;
sync_env_to_vm ();
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))
let api_begin_module_load () =
(* Snapshot current env into the persistent VM globals table *)
Hashtbl.clear _vm_globals;
Hashtbl.iter (fun id v -> Hashtbl.replace _vm_globals (unintern id) v) global_env.bindings;
_in_batch := true;
Js.Unsafe.inject true
let api_end_module_load () =
if !_in_batch then begin
(* Copy VM globals back to env (bytecode modules defined new symbols) *)
Hashtbl.iter (fun k v ->
Hashtbl.replace global_env.bindings (intern k) v
) _vm_globals;
_in_batch := false
end;
Js.Unsafe.inject true
let sync_vm_to_env () =
Hashtbl.iter (fun name v ->
let id = intern name in
if not (Hashtbl.mem global_env.bindings id) then
Hashtbl.replace global_env.bindings id v
else begin
(* Update existing binding if the VM has a newer value *)
let existing = Hashtbl.find global_env.bindings id in
match existing, v with
| VmClosure _, VmClosure _ -> Hashtbl.replace global_env.bindings id v
| _, VmClosure _ -> Hashtbl.replace global_env.bindings id v
| _ -> ()
end
) _vm_globals
(** Convert a VM suspension dict to a JS suspension object for the platform. *)
let rec make_js_import_suspension (d : (string, value) Hashtbl.t) =
let obj = Js.Unsafe.obj [||] in
Js.Unsafe.set obj (Js.string "suspended") (Js.Unsafe.inject Js._true);
Js.Unsafe.set obj (Js.string "op") (Js.Unsafe.inject (Js.string "import"));
let request = match Hashtbl.find_opt d "request" with Some v -> v | None -> Nil in
Js.Unsafe.set obj (Js.string "request") (value_to_js request);
(* resume callback: clears __io_request, pushes nil, re-runs VM *)
Js.Unsafe.set obj (Js.string "resume") (Js.wrap_callback (fun _result_js ->
let resumed = Sx_vm_ref.resume_module (Dict d) in
sync_vm_to_env ();
match resumed with
| Dict d2 when (match Hashtbl.find_opt d2 "suspended" with Some (Bool true) -> true | _ -> false) ->
Js.Unsafe.inject (make_js_import_suspension d2)
| result -> value_to_js result));
obj
let api_load_module module_js =
try
let code_val = js_to_value module_js in
let code = Sx_vm.code_from_value code_val in
let result = Sx_vm_ref.execute_module code _vm_globals in
match result with
| Dict d when (match Hashtbl.find_opt d "suspended" with Some (Bool true) -> true | _ -> false) ->
(* VM suspended on OP_PERFORM (import) — return JS suspension object *)
Js.Unsafe.inject (make_js_import_suspension d)
| _ ->
sync_vm_to_env ();
Js.Unsafe.inject (Hashtbl.length _vm_globals)
with
| Eval_error msg -> Js.Unsafe.inject (Js.string ("Error: " ^ msg))
| exn -> Js.Unsafe.inject (Js.string ("Error: " ^ Printexc.to_string exn))
let api_debug_env name_js =
let name = Js.to_string name_js in
let id = intern name in
let found_env = Hashtbl.find_opt global_env.bindings id in
let found_vm = Hashtbl.find_opt _vm_globals name in
let total_env = Hashtbl.length global_env.bindings in
let total_vm = Hashtbl.length _vm_globals in
let env_s = match found_env with Some v -> "env:" ^ type_of v | None -> "env:MISSING" in
let vm_s = match found_vm with Some v -> "vm:" ^ type_of v | None -> "vm:MISSING" in
Js.Unsafe.inject (Js.string (Printf.sprintf "%s %s (env=%d vm=%d)" env_s vm_s total_env total_vm))
let api_compile_module src_js =
let src = Js.to_string src_js in
try
let exprs = Sx_parser.parse_all src in
let compile_fn = env_get global_env "compile-module" in
let code = Sx_ref.eval_expr (List [compile_fn; List exprs]) (Env global_env) in
return_via_side_channel (value_to_js code)
with
| Eval_error msg -> Js.Unsafe.inject (Js.string ("Error: " ^ msg))
| Parse_error msg -> Js.Unsafe.inject (Js.string ("Parse error: " ^ msg))
| Not_found -> Js.Unsafe.inject (Js.string "Error: compile-module not loaded")
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.sx_render_to_html global_env 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)))
let api_stringify v_js =
Js.Unsafe.inject (Js.string (inspect (js_to_value v_js)))
let api_type_of v_js =
Js.Unsafe.inject (Js.string (type_of (js_to_value v_js)))
let api_inspect v_js =
Js.Unsafe.inject (Js.string (inspect (js_to_value v_js)))
let api_engine () =
Js.Unsafe.inject (Js.string "ocaml-vm-wasm")
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
js_to_value (Js.Unsafe.fun_call callback_js [| Js.Unsafe.inject (Js.array js_args) |])
in
let v = NativeFn (name, native_fn) in
Sx_primitives.register name native_fn;
ignore (env_bind global_env name v);
Hashtbl.replace _vm_globals name v;
Js.Unsafe.inject Js.null
let api_call_fn fn_js args_js =
try
let fn = js_to_value fn_js in
let args = Array.to_list (Array.map js_to_value (Js.to_array (Js.Unsafe.coerce args_js))) in
return_via_side_channel (value_to_js (call_sx_fn fn args))
with
| Eval_error msg ->
ignore (Js.Unsafe.meth_call
(Js.Unsafe.get Js.Unsafe.global (Js.string "console"))
"error" [| Js.Unsafe.inject (Js.string ("[sx] callFn: " ^ 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 ("[sx] callFn: " ^ Printexc.to_string exn)) |]);
Js.Unsafe.inject Js.null
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 h = Js.Unsafe.get fn_js (Js.string "__sx_handle") in
if Js.Unsafe.equals h Js.undefined then Js.Unsafe.inject (Js.bool false)
else Js.Unsafe.inject (Js.bool (is_callable (get_handle (Js.float_of_number (Js.Unsafe.coerce h) |> int_of_float))))
let api_fn_arity fn_js =
let h = Js.Unsafe.get fn_js (Js.string "__sx_handle") in
if Js.Unsafe.equals h Js.undefined then Js.Unsafe.inject (Js.number_of_float (-1.0))
else
let v = get_handle (Js.float_of_number (Js.Unsafe.coerce h) |> int_of_float) 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))
(* ================================================================== *)
(* Platform bindings (registered in global env) *)
(* ================================================================== *)
let () =
let bind name fn = ignore (env_bind global_env name (NativeFn (name, fn))) in
(* client? returns true in browser — set the ref so the primitive returns true *)
Sx_primitives._is_client := true;
(* --- Evaluation --- *)
bind "cek-eval" (fun args ->
match args with
| [String s] -> let e = Sx_parser.parse_all s in (match e with h :: _ -> Sx_ref.eval_expr h (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"));
bind "cek-call" (fun args ->
match args with
| [f; a] when is_callable f ->
let arg_list = match a with List l -> l | Nil -> [] | v -> [v] in
Sx_ref.trampoline (Sx_runtime.sx_call f arg_list)
| [f; _] -> raise (Eval_error ("cek-call: not callable: " ^ type_of f))
| _ -> raise (Eval_error "cek-call: expected (fn args)"));
bind "sx-parse" (fun args ->
match args with
| [String src] -> List (Sx_parser.parse_all src)
| _ -> raise (Eval_error "sx-parse: expected string"));
(* parse: same as server — unwraps single results, returns list for multiple.
Used by boot.sx (page scripts, suspense) and engine.sx (marsh update). *)
bind "parse" (fun args ->
match args with
| [String src] | [SxExpr src] ->
let exprs = Sx_parser.parse_all src in
(match exprs with [e] -> e | _ -> List exprs)
| [v] -> v
| _ -> raise (Eval_error "parse: expected string"));
bind "sx-serialize" (fun args ->
match args with
| [v] -> String (inspect v)
| _ -> raise (Eval_error "sx-serialize: expected 1 arg"));
(* --- Assertions & 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 (Hashtbl.find a k) (Hashtbl.find b k)) ka
| _ -> false
in
bind "equal?" (fun args -> match args with [a; b] -> Bool (deep_equal a b) | _ -> raise (Eval_error "equal?: 2 args"));
bind "assert" (fun args ->
match args with
| [cond] -> if not (sx_truthy cond) then raise (Eval_error "Assertion failed"); Bool true
| [cond; msg] -> if not (sx_truthy cond) then raise (Eval_error ("Assertion: " ^ value_to_string msg)); Bool true
| _ -> raise (Eval_error "assert: 1-2 args"));
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)
| _ -> raise (Eval_error "try-call: 1 arg"));
(* --- Bytecode loading from s-expression format ---
(sxbc version hash (code :arity N :upvalue-count N :bytecode (...) :constants (...)))
Recursively converts the SX tree into the dict format that loadModule expects. *)
bind "load-sxbc" (fun args ->
match args with
| [List (_ :: _ :: _ :: code_form :: _)] | [List (_ :: _ :: code_form :: _)] ->
let rec convert_code form =
match form with
| List (Symbol "code" :: rest) ->
let d = Hashtbl.create 8 in
let rec parse_kv = function
| Keyword "arity" :: Number n :: rest -> Hashtbl.replace d "arity" (Number n); parse_kv rest
| Keyword "upvalue-count" :: Number n :: rest -> Hashtbl.replace d "upvalue-count" (Number n); parse_kv rest
| Keyword "bytecode" :: List nums :: rest ->
Hashtbl.replace d "bytecode" (List nums); parse_kv rest
| Keyword "constants" :: List consts :: rest ->
Hashtbl.replace d "constants" (List (List.map convert_const consts)); parse_kv rest
| _ :: rest -> parse_kv rest (* skip unknown keywords *)
| [] -> ()
in
parse_kv rest;
Dict d
| _ -> raise (Eval_error ("load-sxbc: expected (code ...), got " ^ type_of form))
and convert_const = function
| List (Symbol "code" :: _) as form -> convert_code form
| List (Symbol "list" :: items) -> List (List.map convert_const items)
| v -> v (* strings, numbers, booleans, nil, symbols, keywords pass through *)
in
let module_val = convert_code code_form in
let code = Sx_vm.code_from_value module_val in
let _result = Sx_vm.execute_module code _vm_globals in
sync_vm_to_env ();
Number (float_of_int (Hashtbl.length _vm_globals))
| _ -> raise (Eval_error "load-sxbc: expected (sxbc version hash (code ...))"));
(* --- 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"));
(* remove! — mutate ListRef in-place, removing by identity (==) *)
bind "remove!" (fun args ->
match args with
| [ListRef r; target] ->
r := List.filter (fun x -> x != target) !r; ListRef r
| [List items; target] ->
List (List.filter (fun x -> x != target) items)
| _ -> raise (Eval_error "append!: list and value"));
(* --- Environment ops --- *)
(* Use unwrap_env for nil/dict tolerance, matching the server kernel *)
let uw = Sx_runtime.unwrap_env in
bind "make-env" (fun _ -> Env (make_env ()));
bind "global-env" (fun _ -> Env global_env);
bind "env-has?" (fun args -> match args with [e; String k] | [e; Keyword k] -> Bool (env_has (uw e) k) | _ -> raise (Eval_error "env-has?"));
bind "env-get" (fun args -> match args with [e; String k] | [e; Keyword k] -> env_get (uw e) k | _ -> raise (Eval_error "env-get"));
bind "env-bind!" (fun args -> match args with [e; String k; v] | [e; Keyword k; v] -> env_bind (uw e) k v | _ -> raise (Eval_error "env-bind!"));
bind "env-set!" (fun args -> match args with [e; String k; v] | [e; Keyword k; v] -> env_set (uw e) k v | _ -> raise (Eval_error "env-set!"));
bind "env-extend" (fun args -> match args with [e] -> Env (env_extend (uw e)) | _ -> raise (Eval_error "env-extend"));
bind "env-merge" (fun args -> match args with [a; b] -> Sx_runtime.env_merge a b | _ -> raise (Eval_error "env-merge"));
(* --- Type constructors --- *)
bind "make-symbol" (fun args -> match args with [String s] -> Symbol s | [v] -> Symbol (value_to_string v) | _ -> raise (Eval_error "make-symbol"));
bind "make-keyword" (fun args -> match args with [String s] -> Keyword s | _ -> raise (Eval_error "make-keyword"));
bind "keyword-name" (fun args -> match args with [Keyword k] -> String k | _ -> raise (Eval_error "keyword-name"));
bind "symbol-name" (fun args -> match args with [Symbol s] -> String s | _ -> raise (Eval_error "symbol-name"));
(* --- Component/Island accessors (must handle both types) --- *)
bind "component-name" (fun args ->
match args with [Component c] -> String c.c_name | [Island i] -> String i.i_name | _ -> String "");
bind "component-closure" (fun args ->
match args with [Component c] -> Env c.c_closure | [Island i] -> Env i.i_closure | _ -> Dict (Hashtbl.create 0));
bind "component-params" (fun args ->
match args with
| [Component c] -> List (List.map (fun s -> String s) c.c_params)
| [Island i] -> List (List.map (fun s -> String s) i.i_params)
| _ -> Nil);
bind "component-body" (fun args ->
match args with [Component c] -> c.c_body | [Island i] -> i.i_body | _ -> Nil);
let has_children_impl = NativeFn ("component-has-children?", fun args ->
match args with [Component c] -> Bool c.c_has_children | [Island i] -> Bool i.i_has_children | _ -> Bool false) in
ignore (env_bind global_env "component-has-children" has_children_impl);
ignore (env_bind global_env "component-has-children?" has_children_impl);
bind "component-affinity" (fun args ->
match args with [Component c] -> String c.c_affinity | [Island _] -> String "client" | _ -> String "auto");
bind "component-param-types" (fun _ -> Nil);
bind "component-set-param-types!" (fun _ -> Nil);
(* --- CEK stepping --- *)
bind "make-cek-state" (fun args -> match args with [c; e; k] -> Sx_ref.make_cek_state c e k | _ -> raise (Eval_error "make-cek-state"));
bind "cek-step" (fun args -> match args with [s] -> Sx_ref.cek_step s | _ -> raise (Eval_error "cek-step"));
bind "cek-phase" (fun args -> match args with [s] -> Sx_ref.cek_phase s | _ -> raise (Eval_error "cek-phase"));
bind "cek-value" (fun args -> match args with [s] -> Sx_ref.cek_value s | _ -> raise (Eval_error "cek-value"));
bind "cek-terminal?" (fun args -> match args with [s] -> Sx_ref.cek_terminal_p s | _ -> raise (Eval_error "cek-terminal?"));
bind "cek-kont" (fun args -> match args with [s] -> Sx_ref.cek_kont s | _ -> raise (Eval_error "cek-kont"));
bind "frame-type" (fun args -> match args with [f] -> Sx_ref.frame_type f | _ -> raise (Eval_error "frame-type"));
(* --- 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 | _ -> Nil);
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 | _ -> Nil);
bind "value-matches-type?" (fun args -> match args with [v; t] -> Sx_ref.value_matches_type_p v t | _ -> Nil);
(* --- 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"));
(* --- Scope stack --- *)
(* Scope primitives (scope-push!, scope-pop!, context, collect!, collected,
emit!, emitted, scope-emit!, scope-emitted, etc.) are registered by
Sx_primitives module initialization in the primitives table.
The CEK evaluator falls through to the primitives table when a symbol
isn't in the env, so these work automatically.
Only provide-push!/provide-pop! need explicit env bindings as aliases. *)
bind "provide-push!" (fun args -> match args with [n; v] -> Sx_runtime.provide_push n v | _ -> raise (Eval_error "provide-push!"));
bind "provide-pop!" (fun args -> match args with [n] -> Sx_runtime.provide_pop n | _ -> raise (Eval_error "provide-pop!"));
(* Runtime helpers for bytecoded defcomp/defisland/defmacro forms.
The compiler emits GLOBAL_GET "eval-defcomp" + CALL — these must
exist as callable values for bytecoded .sx files that contain
component definitions (e.g. cssx.sx). *)
bind "eval-defcomp" (fun args ->
match args with [List (_ :: rest)] -> Sx_ref.sf_defcomp (List rest) (Env global_env) | _ -> Nil);
bind "eval-defisland" (fun args ->
match args with [List (_ :: rest)] -> Sx_ref.sf_defisland (List rest) (Env global_env) | _ -> Nil);
bind "eval-defmacro" (fun args ->
match args with [List (_ :: rest)] -> Sx_ref.sf_defmacro (List rest) (Env global_env) | _ -> Nil);
(* --- Fragment / raw HTML --- *)
bind "<>" (fun args ->
RawHTML (String.concat "" (List.map (fun a ->
match a with String s | RawHTML s -> s | Nil -> ""
| List _ -> Sx_render.sx_render_to_html global_env a global_env
| _ -> value_to_string a) args)));
bind "raw!" (fun args ->
RawHTML (String.concat "" (List.map (fun a ->
match a with String s | RawHTML s -> s | _ -> value_to_string a) args)));
bind "define-page-helper" (fun _ -> Nil);
(* IO registry — spec-level defio populates *io-registry* in evaluator.
Alias as __io-registry for backward compat. *)
ignore (env_bind global_env "__io-registry" Sx_ref._io_registry_);
(* --- Render --- *)
Sx_render.setup_render_env global_env;
bind "set-render-active!" (fun _ -> Nil);
bind "render-active?" (fun _ -> Bool true);
bind "is-html-tag?" (fun args -> match args with [String s] -> Bool (Sx_render.is_html_tag s) | _ -> Bool false);
(* --- Render constants needed by web adapters --- *)
let html_tags = List (List.map (fun s -> String s) Sx_render.html_tags) in
let void_elements = List (List.map (fun s -> String s) Sx_render.void_elements) in
let boolean_attrs = List (List.map (fun s -> String s) Sx_render.boolean_attrs) in
ignore (env_bind global_env "HTML_TAGS" html_tags);
ignore (env_bind global_env "VOID_ELEMENTS" void_elements);
ignore (env_bind global_env "BOOLEAN_ATTRS" boolean_attrs);
(* --- HTML tag special forms (div, span, h1, ...) --- *)
(* Registered as custom special forms so keywords are preserved.
Handler receives (raw-args env), evaluates non-keyword args
while keeping keyword names intact. *)
let eval_tag_args raw_args env =
let args = Sx_runtime.sx_to_list raw_args in
let rec process = function
| [] -> []
| (Keyword _ as kw) :: value :: rest ->
(* keyword + its value: keep keyword, evaluate value *)
kw :: Sx_ref.eval_expr value env :: process rest
| (Keyword _ as kw) :: [] ->
(* trailing keyword with no value — boolean attr *)
[kw]
| expr :: rest ->
(* non-keyword: evaluate *)
Sx_ref.eval_expr expr env :: process rest
in
process args
in
List.iter (fun tag ->
ignore (Sx_ref.register_special_form (String tag)
(NativeFn ("sf:" ^ tag, fun handler_args ->
match handler_args with
| [raw_args; env] -> List (Symbol tag :: eval_tag_args raw_args env)
| _ -> Nil)))
) Sx_render.html_tags;
(* --- Error handling --- *)
bind "cek-try" (fun args ->
match args with
| [thunk; handler] ->
(try Sx_ref.cek_call thunk Nil
with Eval_error msg -> Sx_ref.cek_call handler (List [String msg]))
| [thunk] ->
(try let r = Sx_ref.cek_call thunk Nil in
List [Symbol "ok"; r]
with Eval_error msg -> List [Symbol "error"; String msg])
| _ -> Nil);
(* --- Evaluator bridge functions needed by spec .sx files --- *)
bind "eval-expr" (fun args ->
match args with [expr; e] -> Sx_ref.eval_expr expr e | [expr] -> Sx_ref.eval_expr expr (Env global_env) | _ -> Nil);
bind "trampoline" (fun args -> match args with [v] -> !Sx_primitives._sx_trampoline_fn v | _ -> Nil);
bind "expand-macro" (fun args ->
match args with [mac; raw; Env e] -> Sx_ref.expand_macro mac raw (Env e) | [mac; raw] -> Sx_ref.expand_macro mac raw (Env global_env) | _ -> Nil);
bind "call-lambda" (fun args ->
match args with
| [f; a; _] | [f; a] when is_callable f ->
(* Use cek_call instead of sx_call to avoid eval_expr copying
Dict values (signals). sx_call returns a Thunk resolved via
eval_expr which deep-copies dicts, breaking signal mutation. *)
Sx_ref.cek_call f a
| _ -> raise (Eval_error "call-lambda: expected (fn args env?)"));
bind "cek-call" (fun args ->
match args with
| [f; a] when is_callable f ->
let arg_list = match a with List l -> l | Nil -> [] | v -> [v] in
Sx_ref.trampoline (Sx_runtime.sx_call f arg_list)
| [f; _] -> raise (Eval_error ("cek-call: not callable: " ^ type_of f))
| _ -> raise (Eval_error "cek-call: expected (fn args)"));
bind "cek-eval" (fun args ->
match args with [expr] -> Sx_ref.eval_expr expr (Env global_env) | [expr; e] -> Sx_ref.eval_expr expr e | _ -> Nil);
bind "qq-expand-runtime" (fun args ->
match args with [template] -> Sx_ref.qq_expand template (Env global_env) | [template; Env e] -> Sx_ref.qq_expand template (Env e) | _ -> Nil);
(* --- Type predicates needed by adapters --- *)
bind "thunk?" (fun args -> match args with [Thunk _] -> Bool true | _ -> Bool false);
bind "thunk-expr" (fun args -> match args with [v] -> thunk_expr v | _ -> Nil);
bind "thunk-env" (fun args -> match args with [v] -> thunk_env v | _ -> Nil);
bind "lambda?" (fun args -> match args with [Lambda _] -> Bool true | _ -> Bool false);
bind "macro?" (fun args -> match args with [Macro _] -> Bool true | _ -> Bool false);
bind "island?" (fun args -> match args with [Island _] -> Bool true | _ -> Bool false);
bind "component?" (fun args -> match args with [Component _] | [Island _] -> Bool true | _ -> Bool false);
bind "callable?" (fun args -> match args with [NativeFn _] | [Lambda _] | [Component _] | [Island _] -> Bool true | _ -> Bool false);
bind "spread?" (fun args -> match args with [Spread _] -> Bool true | _ -> Bool false);
bind "continuation?" (fun args -> match args with [Continuation _] -> Bool true | _ -> Bool false);
bind "lambda-params" (fun args -> match args with [Lambda l] -> List (List.map (fun s -> String s) l.l_params) | _ -> List []);
bind "lambda-body" (fun args -> match args with [Lambda l] -> l.l_body | _ -> Nil);
bind "lambda-closure" (fun args -> match args with [Lambda l] -> Env l.l_closure | _ -> Dict (Hashtbl.create 0));
(* --- Core operations needed by adapters --- *)
bind "spread-attrs" (fun args ->
match args with [Spread pairs] -> let d = Hashtbl.create 4 in List.iter (fun (k, v) -> Hashtbl.replace d k v) pairs; Dict d | _ -> Dict (Hashtbl.create 0));
bind "make-spread" (fun args ->
match args with [Dict d] -> Spread (Hashtbl.fold (fun k v acc -> (k, v) :: acc) d []) | _ -> Nil);
bind "make-raw-html" (fun args -> match args with [String s] -> RawHTML s | [v] -> RawHTML (value_to_string v) | _ -> Nil);
bind "raw-html-content" (fun args -> match args with [RawHTML s] -> String s | [String s] -> String s | _ -> String "");
bind "empty-dict?" (fun args -> match args with [Dict d] -> Bool (Hashtbl.length d = 0) | _ -> Bool true);
bind "identical?" (fun args -> match args with [a; b] -> Bool (a == b) | _ -> raise (Eval_error "identical?"));
bind "for-each-indexed" (fun args ->
match args with
| [fn_val; List items] | [fn_val; ListRef { contents = items }] ->
List.iteri (fun i item ->
ignore (Sx_ref.eval_expr (List [fn_val; Number (float_of_int i); item]) (Env global_env))
) items; Nil
| _ -> Nil);
(* --- String/number helpers used by orchestration/browser --- *)
bind "make-sx-expr" (fun args -> match args with [String s] -> SxExpr s | _ -> raise (Eval_error "make-sx-expr"));
bind "sx-expr-source" (fun args -> match args with [SxExpr s] -> String s | [String s] -> String s | _ -> raise (Eval_error "sx-expr-source"));
bind "parse-int" (fun args ->
match args with
| [String s] -> (try Number (float_of_int (int_of_string s)) with _ -> Nil)
| [String s; default_val] -> (try Number (float_of_int (int_of_string s)) with _ -> default_val)
| [Number n] | [Number n; _] -> Number (Float.round n)
| [_; default_val] -> default_val | _ -> Nil);
bind "parse-number" (fun args -> match args with [String s] -> (try Number (float_of_string s) with _ -> Nil) | _ -> Nil);
(* --- Server-only stubs (no-ops in browser) --- *)
bind "query" (fun _ -> Nil);
bind "action" (fun _ -> Nil);
bind "request-arg" (fun args -> match args with [_; d] -> d | _ -> Nil);
bind "request-method" (fun _ -> String "GET");
bind "ctx" (fun _ -> Nil);
bind "helper" (fun _ -> Nil);
()
(* ================================================================== *)
(* JIT compilation hook *)
(* *)
(* On first call to a named lambda, try to compile it to bytecode via *)
(* compiler.sx (loaded as an .sx platform file). Compiled closures run *)
(* on the bytecode VM; failures fall back to the CEK interpreter. *)
(* ================================================================== *)
let _jit_compiling = ref false
let _jit_enabled = ref false
let () =
Sx_runtime._jit_try_call_fn := Some (fun f args ->
match f with
| Lambda l when !_jit_enabled ->
(match l.l_compiled with
| Some cl when not (Sx_vm.is_jit_failed cl) ->
(try Some (Sx_vm.call_closure cl args _vm_globals)
with Eval_error msg ->
let fn_name = match l.l_name with Some n -> n | None -> "?" in
Printf.eprintf "[jit] FAIL %s: %s (bc=%d consts=%d upv=%d)\n%!"
fn_name msg
(Array.length cl.vm_code.vc_bytecode)
(Array.length cl.vm_code.vc_constants)
(Array.length cl.vm_upvalues);
(* Mark as failed to stop retrying *)
l.l_compiled <- Some (Sx_vm.jit_failed_sentinel);
None)
| Some _ -> None
| None ->
if !_jit_compiling then None
else begin
_jit_compiling := true;
let compiled = Sx_vm.jit_compile_lambda l _vm_globals in
_jit_compiling := false;
(match compiled with
| Some cl ->
l.l_compiled <- Some cl;
(try Some (Sx_vm.call_closure cl args _vm_globals)
with Eval_error msg ->
let fn_name2 = match l.l_name with Some n -> n | None -> "?" in
Printf.eprintf "[jit] FAIL %s: %s (bc=%d consts=%d upv=%d)\n%!"
fn_name2 msg
(Array.length cl.vm_code.vc_bytecode)
(Array.length cl.vm_code.vc_constants)
(Array.length cl.vm_upvalues);
l.l_compiled <- Some (Sx_vm.jit_failed_sentinel);
None)
| None -> None)
end)
| _ -> None)
let () = ignore (env_bind global_env "enable-jit!" (NativeFn ("enable-jit!", fun _ -> _jit_enabled := true; Nil)))
(* Seed BOTH _vm_globals AND global_env with ALL primitives as NativeFn values.
Unconditional — native primitives are authoritative for CALL_PRIM dispatch.
Must be in both because sync_env_to_vm() copies global_env → _vm_globals. *)
let () =
Hashtbl.iter (fun name fn ->
let v = NativeFn (name, fn) in
Hashtbl.replace _vm_globals name v;
Hashtbl.replace global_env.bindings (intern name) v
) Sx_primitives.primitives
(* ================================================================== *)
(* Register global SxKernel object *)
(* ================================================================== *)
let () =
let sx = Js.Unsafe.obj [||] in
let wrap fn = Js.Unsafe.fun_call
(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; }; })")
[| Js.Unsafe.inject (Js.wrap_callback fn) |] in
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") (wrap api_eval);
Js.Unsafe.set sx (Js.string "evalVM") (wrap api_eval_vm);
Js.Unsafe.set sx (Js.string "evalExpr") (wrap api_eval_expr);
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 "loadModule") (Js.wrap_callback api_load_module);
Js.Unsafe.set sx (Js.string "beginModuleLoad") (Js.wrap_callback (fun () -> api_begin_module_load ()));
Js.Unsafe.set sx (Js.string "endModuleLoad") (Js.wrap_callback (fun () -> api_end_module_load ()));
Js.Unsafe.set sx (Js.string "compileModule") (wrap api_compile_module);
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);
Js.Unsafe.set sx (Js.string "callFn") (wrap 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);
Js.Unsafe.set sx (Js.string "debugEnv") (Js.wrap_callback api_debug_env);
(* Scope tracing API *)
Js.Unsafe.set sx (Js.string "scopeTraceOn") (Js.wrap_callback (fun () ->
Sx_primitives.scope_trace_enable (); Js.Unsafe.inject Js.null));
Js.Unsafe.set sx (Js.string "scopeTraceOff") (Js.wrap_callback (fun () ->
Sx_primitives.scope_trace_disable (); Js.Unsafe.inject Js.null));
Js.Unsafe.set sx (Js.string "scopeTraceDrain") (Js.wrap_callback (fun () ->
let log = Sx_primitives.scope_trace_drain () in
Js.Unsafe.inject (Js.array (Array.of_list (List.map (fun s -> Js.Unsafe.inject (Js.string s)) log)))));
Js.Unsafe.set Js.Unsafe.global (Js.string "SxKernel") sx

226
hosts/ocaml/browser/test-spa.js
View File

@@ -1,226 +0,0 @@
#!/usr/bin/env node
/**
* test-spa.js — Deep browser diagnostic for SPA navigation.
*
* Uses Chrome DevTools Protocol to inspect event listeners,
* trace click handling, and detect SPA vs full reload.
*
* Usage:
* node test-spa.js # bytecode mode
* node test-spa.js --source # source mode (nosxbc)
* node test-spa.js --headed # visible browser
*/
const { chromium } = require('playwright');
const args = process.argv.slice(2);
const sourceMode = args.includes('--source');
const headed = args.includes('--headed');
const baseUrl = 'http://localhost:8013/sx/';
const url = sourceMode ? baseUrl + '?nosxbc' : baseUrl;
const label = sourceMode ? 'SOURCE' : 'BYTECODE';
(async () => {
const browser = await chromium.launch({ headless: !headed });
const page = await browser.newPage();
// Capture console
page.on('console', msg => {
const t = msg.text();
if (t.startsWith('[spa-diag]') || t.includes('Not callable') || t.includes('Error:'))
console.log(` [browser] ${t}`);
});
console.log(`\n=== SPA Diagnostic: ${label} mode ===\n`);
await page.goto(url);
await page.waitForTimeout(5000);
// ----------------------------------------------------------------
// 1. Use CDP to get event listeners on a link
// ----------------------------------------------------------------
console.log('--- 1. Event listeners on Geography link ---');
const cdp = await page.context().newCDPSession(page);
const listeners = await page.evaluate(async () => {
const link = document.querySelector('a[href="/sx/(geography)"]');
if (!link) return { error: 'link not found' };
// We can't use getEventListeners from page context (it's a DevTools API)
// But we can check _sxBound* properties and enumerate own properties
const ownProps = {};
for (const k of Object.getOwnPropertyNames(link)) {
if (k.startsWith('_') || k.startsWith('on'))
ownProps[k] = typeof link[k];
}
// Check for jQuery-style event data
const jqData = link.__events || link._events || null;
return {
href: link.getAttribute('href'),
ownProps,
jqData: jqData ? 'present' : 'none',
onclick: link.onclick ? 'set' : 'null',
parentTag: link.parentElement?.tagName,
};
});
console.log(' Link props:', JSON.stringify(listeners, null, 2));
// Check should-boost-link? and why it returns false
const boostCheck = await page.evaluate(() => {
const K = window.SxKernel;
const link = document.querySelectorAll('a[href]')[1]; // geography link
if (!link) return 'no link';
try {
// Check the conditions should-boost-link? checks
const href = link.getAttribute('href');
const checks = {
href,
hasBoostAttr: link.closest('[data-sx-boost]') ? 'yes' : 'no',
hasNoBoost: link.hasAttribute('data-sx-no-boost') ? 'yes' : 'no',
isExternal: href.startsWith('http') ? 'yes' : 'no',
isHash: href.startsWith('#') ? 'yes' : 'no',
};
// Try calling should-boost-link?
try { checks.shouldBoost = K.eval('(should-boost-link? (nth (dom-query-all (dom-body) "a[href]") 1))'); }
catch(e) { checks.shouldBoost = 'err: ' + e.message.slice(0, 80); }
return checks;
} catch(e) { return 'err: ' + e.message; }
});
console.log(' Boost check:', JSON.stringify(boostCheck, null, 2));
// Use CDP to get actual event listeners
const linkNode = await page.$('a[href="/sx/(geography)"]');
if (linkNode) {
const { object } = await cdp.send('Runtime.evaluate', {
expression: 'document.querySelector(\'a[href="/sx/(geography)"]\')',
});
if (object?.objectId) {
const { listeners: cdpListeners } = await cdp.send('DOMDebugger.getEventListeners', {
objectId: object.objectId,
depth: 0,
});
console.log(' CDP event listeners on link:', cdpListeners.length);
for (const l of cdpListeners) {
console.log(` ${l.type}: ${l.handler?.description?.slice(0, 100) || 'native'} (useCapture=${l.useCapture})`);
}
}
// Also check document-level click listeners
const { object: docObj } = await cdp.send('Runtime.evaluate', {
expression: 'document',
});
if (docObj?.objectId) {
const { listeners: docListeners } = await cdp.send('DOMDebugger.getEventListeners', {
objectId: docObj.objectId,
depth: 0,
});
const clickListeners = docListeners.filter(l => l.type === 'click');
console.log(' CDP document click listeners:', clickListeners.length);
for (const l of clickListeners) {
console.log(` ${l.type}: ${l.handler?.description?.slice(0, 120) || 'native'} (capture=${l.useCapture})`);
}
}
// Check window-level listeners too
const { object: winObj } = await cdp.send('Runtime.evaluate', {
expression: 'window',
});
if (winObj?.objectId) {
const { listeners: winListeners } = await cdp.send('DOMDebugger.getEventListeners', {
objectId: winObj.objectId,
depth: 0,
});
const winClick = winListeners.filter(l => l.type === 'click');
const winPop = winListeners.filter(l => l.type === 'popstate');
console.log(' CDP window click listeners:', winClick.length);
console.log(' CDP window popstate listeners:', winPop.length);
for (const l of winPop) {
console.log(` popstate: ${l.handler?.description?.slice(0, 120) || 'native'}`);
}
}
}
// ----------------------------------------------------------------
// 2. Trace what happens when we click
// ----------------------------------------------------------------
console.log('\n--- 2. Click trace ---');
// Inject click tracing
await page.evaluate(() => {
// Trace click event propagation
const phases = ['NONE', 'CAPTURE', 'AT_TARGET', 'BUBBLE'];
document.addEventListener('click', function(e) {
console.log('[spa-diag] click CAPTURE on document: target=' + e.target.tagName +
' href=' + (e.target.getAttribute?.('href') || 'none') +
' defaultPrevented=' + e.defaultPrevented);
}, true);
document.addEventListener('click', function(e) {
console.log('[spa-diag] click BUBBLE on document: defaultPrevented=' + e.defaultPrevented +
' propagation=' + (e.cancelBubble ? 'stopped' : 'running'));
}, false);
// Monitor pushState
const origPush = history.pushState;
history.pushState = function() {
console.log('[spa-diag] pushState called: ' + JSON.stringify(arguments[2]));
return origPush.apply(this, arguments);
};
// Monitor replaceState
const origReplace = history.replaceState;
history.replaceState = function() {
console.log('[spa-diag] replaceState called: ' + JSON.stringify(arguments[2]));
return origReplace.apply(this, arguments);
};
});
// Detect full reload vs SPA by checking if a new page load happens
let fullReload = false;
let networkNav = false;
page.on('load', () => { fullReload = true; });
page.on('request', req => {
if (req.isNavigationRequest()) {
networkNav = true;
console.log(' [network] Navigation request:', req.url());
}
});
// Click the link
console.log(' Clicking /sx/(geography)...');
const urlBefore = page.url();
await page.click('a[href="/sx/(geography)"]');
await page.waitForTimeout(3000);
const urlAfter = page.url();
console.log(` URL: ${urlBefore.split('8013')[1]} → ${urlAfter.split('8013')[1]}`);
console.log(` Full reload: ${fullReload}`);
console.log(` Network navigation: ${networkNav}`);
// Check page content
const content = await page.evaluate(() => ({
title: document.title,
h1: document.querySelector('h1')?.textContent?.slice(0, 50) || 'none',
bodyLen: document.body.innerHTML.length,
}));
console.log(' Content:', JSON.stringify(content));
// ----------------------------------------------------------------
// 3. Check SX router state
// ----------------------------------------------------------------
console.log('\n--- 3. SX router state ---');
const routerState = await page.evaluate(() => {
const K = window.SxKernel;
if (!K) return { error: 'no kernel' };
const checks = {};
try { checks['_page-routes count'] = K.eval('(len _page-routes)'); } catch(e) { checks['_page-routes'] = e.message; }
try { checks['current-route'] = K.eval('(browser-location-pathname)'); } catch(e) { checks['current-route'] = e.message; }
return checks;
});
console.log(' Router:', JSON.stringify(routerState));
console.log('\n=== Done ===\n');
await browser.close();
})();

30
hosts/ocaml/browser/test_boot.sh
View File

@@ -1,30 +0,0 @@
#!/bin/bash
# Test WASM boot in Node.js — verifies the compiled sx_browser.bc.js loads
# without errors by providing minimal DOM/browser API stubs.
set -euo pipefail
cd "$(dirname "$0")/../../.."
node -e "
global.window = global;
global.document = { createElement: () => ({style:{},setAttribute:()=>{},appendChild:()=>{},children:[]}), createDocumentFragment: () => ({appendChild:()=>{},children:[],childNodes:[]}), head:{appendChild:()=>{}}, body:{appendChild:()=>{}}, querySelector:()=>null, querySelectorAll:()=>[], createTextNode:(s)=>({textContent:s}), addEventListener:()=>{}, createComment:(s)=>({textContent:s||''}) };
global.localStorage = {getItem:()=>null,setItem:()=>{},removeItem:()=>{}};
global.CustomEvent = class { 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;
try {
require('./shared/static/wasm/sx_browser.bc.js');
console.log('WASM boot: OK');
} catch(e) {
console.error('WASM boot: FAILED');
console.error(e.message);
process.exit(1);
}
"

62
hosts/ocaml/browser/test_js.js
View File

@@ -1,62 +0,0 @@
#!/usr/bin/env node
// Test js_of_ocaml build of SX kernel
const path = require('path');
require(path.join(__dirname, '../_build/default/browser/sx_browser.bc.js'));
const sx = globalThis.SxKernel;
console.log('Engine:', sx.engine());
const tests = [
['(+ 1 2)', 3],
['(- 10 3)', 7],
['(* 6 7)', 42],
['(/ 10 2)', 5],
['(= 5 5)', true],
['(< 3 5)', true],
['(> 5 3)', true],
['(not false)', true],
['(inc 5)', 6],
['(dec 5)', 4],
['(len (list 1 2 3))', 3],
['(len "hello")', 5],
['(first (list 10 20))', 10],
['(nth "hello" 0)', 'h'],
['(nth "hello" 4)', 'o'],
['(str "a" "b")', 'ab'],
['(join ", " (list "a" "b" "c"))', 'a, b, c'],
['(let ((x 10) (y 20)) (+ x y))', 30],
['(if true "yes" "no")', 'yes'],
['(cond (= 1 2) "one" :else "other")', 'other'],
['(case 2 1 "one" 2 "two" :else "other")', 'two'],
['(render-to-html (list (quote div) "hello"))', '<div>hello</div>'],
['(render-to-html (list (quote span) (list (quote b) "bold")))', '<span><b>bold</b></span>'],
// Lambda + closure
['(let ((add (fn (a b) (+ a b)))) (add 3 4))', 7],
['(let ((x 10)) (let ((f (fn () x))) (f)))', 10],
// Higher-order
['(len (filter (fn (x) (> x 2)) (list 1 2 3 4 5)))', 3],
// Recursion
['(let ((fact (fn (n) (if (<= n 1) 1 (* n (fact (- n 1))))))) (fact 5))', 120],
];
let passed = 0, failed = 0;
for (const [expr, expected] of tests) {
try {
const result = sx.eval(expr);
const ok = typeof expected === 'object'
? result && result._type === expected._type
: result === expected;
if (ok) {
passed++;
} else {
console.log(` FAIL: ${expr} = ${JSON.stringify(result)} (expected ${JSON.stringify(expected)})`);
failed++;
}
} catch (e) {
console.log(` ERROR: ${expr}: ${e.message || e}`);
failed++;
}
}
console.log(`${passed} passed, ${failed} failed`);
process.exit(failed > 0 ? 1 : 0);

244
hosts/ocaml/browser/test_kernel.js
View File

@@ -1,244 +0,0 @@
#!/usr/bin/env node
// WASM kernel integration tests: env sync, globals, pages parsing, preventDefault
const path = require('path');
const fs = require('fs');
require(path.join(__dirname, '../_build/default/browser/sx_browser.bc.js'));
const K = globalThis.SxKernel;
// Load compiler for evalVM support
const compilerFiles = ['lib/bytecode.sx', 'lib/compiler.sx', 'lib/vm.sx'];
for (const f of compilerFiles) {
K.load(fs.readFileSync(path.join(__dirname, '../../..', f), 'utf8'));
}
let passed = 0, failed = 0;
function test(name, fn) {
try {
const result = fn();
if (result === true) {
passed++;
} else {
console.log(` FAIL: ${name} — got ${JSON.stringify(result)}`);
failed++;
}
} catch (e) {
console.log(` FAIL: ${name} — ${e.message || e}`);
failed++;
}
}
// ================================================================
// 1. Env binding / globals sync
// ================================================================
test('define at top level visible to VM', () => {
K.eval('(define _test-toplevel-1 42)');
return K.evalVM('_test-toplevel-1') === 42;
});
test('define in begin visible to VM', () => {
K.eval('(begin (define _test-begin-1 99))');
return K.evalVM('_test-begin-1') === 99;
});
test('set! on global syncs to VM', () => {
K.eval('(define _test-set-g 1)');
K.eval('(set! _test-set-g 55)');
return K.evalVM('_test-set-g') === 55;
});
test('VM define syncs back to CEK', () => {
K.evalVM('(define _test-vm-def 777)');
return K.eval('_test-vm-def') === 777;
});
test('CEK and VM see same value after multiple updates', () => {
K.eval('(define _test-ping 0)');
K.eval('(set! _test-ping 1)');
K.evalVM('(set! _test-ping 2)');
const cek = K.eval('_test-ping');
const vm = K.evalVM('_test-ping');
return cek === 2 && vm === 2;
});
test('lambda defined at top level callable from VM', () => {
K.eval('(define _test-top-fn (fn (x) (* x 10)))');
return K.evalVM('(_test-top-fn 3)') === 30;
});
// ================================================================
// 2. Parse function (pages-sx format)
// ================================================================
test('parse single dict', () => {
const r = K.eval('(get (parse "{:name \\"home\\" :path \\"/\\"}") "name")');
return r === 'home';
});
test('parse multiple dicts returns list', () => {
const r = K.eval('(len (parse "{:a 1}\\n{:b 2}\\n{:c 3}"))');
return r === 3;
});
test('parse single expr unwraps', () => {
return K.eval('(type-of (parse "42"))') === 'number';
});
test('parse multiple exprs returns list', () => {
return K.eval('(type-of (parse "1 2 3"))') === 'list';
});
test('parse dict with content string', () => {
const r = K.eval('(get (parse "{:name \\"test\\" :content \\"(div \\\\\\\"hello\\\\\\\")\\" :has-data false}") "content")');
return typeof r === 'string' && r.includes('div');
});
test('parse dict with path param pattern', () => {
const r = K.eval('(get (parse "{:path \\"/docs/<slug>\\"}") "path")');
return r === '/docs/<slug>';
});
// ================================================================
// 3. Route pattern parsing (requires router.sx loaded)
// ================================================================
// Load router module
const routerSrc = fs.readFileSync(path.join(__dirname, '../../../web/router.sx'), 'utf8');
K.load(routerSrc);
test('parse-route-pattern splits static path', () => {
const r = K.eval('(len (parse-route-pattern "/docs/intro"))');
return r === 2;
});
test('parse-route-pattern detects param segments', () => {
const r = K.eval('(get (nth (parse-route-pattern "/docs/<slug>") 1) "type")');
return r === 'param';
});
test('parse-route-pattern detects literal segments', () => {
const r = K.eval('(get (first (parse-route-pattern "/docs/<slug>")) "type")');
return r === 'literal';
});
test('find-matching-route matches static path', () => {
K.eval('(define _test-routes (list (merge {:name "home" :path "/"} {:parsed (parse-route-pattern "/")})))');
const r = K.eval('(get (find-matching-route "/" _test-routes) "name")');
return r === 'home';
});
test('find-matching-route matches param path', () => {
K.eval('(define _test-routes2 (list (merge {:name "doc" :path "/docs/<slug>"} {:parsed (parse-route-pattern "/docs/<slug>")})))');
const r = K.eval('(get (find-matching-route "/docs/intro" _test-routes2) "name")');
return r === 'doc';
});
test('find-matching-route returns nil for no match', () => {
return K.eval('(nil? (find-matching-route "/unknown" _test-routes))') === true;
});
// ================================================================
// 4. Click handler preventDefault pattern
// ================================================================
// Register host FFI primitives (normally done by sx-platform.js)
K.registerNative("host-global", function(args) {
var name = args[0];
return (typeof name === 'string') ? globalThis[name] : undefined;
});
K.registerNative("host-get", function(args) {
var obj = args[0], key = args[1];
if (obj == null) return null;
var v = obj[key];
return v === undefined ? null : v;
});
K.registerNative("host-call", function(args) {
var obj = args[0], method = args[1];
var callArgs = args.slice(2);
if (obj == null || typeof obj[method] !== 'function') return null;
try { return obj[method].apply(obj, callArgs); } catch(e) { return null; }
});
K.registerNative("host-set!", function(args) {
var obj = args[0], key = args[1], val = args[2];
if (obj != null) obj[key] = val;
return null;
});
test('host-call preventDefault on mock event', () => {
let prevented = false;
globalThis._testMockEvent = {
preventDefault: () => { prevented = true; },
type: 'click',
target: { tagName: 'A', getAttribute: () => '/test' }
};
K.eval('(host-call (host-global "_testMockEvent") "preventDefault")');
delete globalThis._testMockEvent;
return prevented === true;
});
test('host-get reads property from JS object', () => {
globalThis._testObj = { foo: 42 };
const r = K.eval('(host-get (host-global "_testObj") "foo")');
delete globalThis._testObj;
return r === 42;
});
test('host-set! writes property on JS object', () => {
globalThis._testObj2 = { val: 0 };
K.eval('(host-set! (host-global "_testObj2") "val" 99)');
const r = globalThis._testObj2.val;
delete globalThis._testObj2;
return r === 99;
});
test('click handler pattern: check target, prevent, navigate', () => {
let prevented = false;
let navigated = null;
globalThis._testClickEvent = {
preventDefault: () => { prevented = true; },
type: 'click',
target: { tagName: 'A', href: '/about' }
};
globalThis._testNavigate = (url) => { navigated = url; };
K.eval(`
(let ((e (host-global "_testClickEvent")))
(let ((tag (host-get (host-get e "target") "tagName")))
(when (= tag "A")
(host-call e "preventDefault")
(host-call (host-global "_testNavigate") "call" nil
(host-get (host-get e "target") "href")))))
`);
delete globalThis._testClickEvent;
delete globalThis._testNavigate;
return prevented === true && navigated === '/about';
});
// ================================================================
// 5. Iterative cek_run — deep evaluation without stack overflow
// ================================================================
test('deep recursion via foldl (100 iterations)', () => {
const r = K.eval('(reduce + 0 (map (fn (x) x) (list ' +
Array.from({length: 100}, (_, i) => i + 1).join(' ') + ')))');
return r === 5050;
});
test('deeply nested let bindings', () => {
// Build (let ((x0 0)) (let ((x1 (+ x0 1))) ... (let ((xN (+ xN-1 1))) xN)))
let expr = 'x49';
for (let i = 49; i >= 0; i--) {
const prev = i === 0 ? '0' : `(+ x${i-1} 1)`;
expr = `(let ((x${i} ${prev})) ${expr})`;
}
return K.eval(expr) === 49;
});
// ================================================================
// Results
// ================================================================
console.log(`\n${passed} passed, ${failed} failed`);
process.exit(failed > 0 ? 1 : 0);

134
hosts/ocaml/browser/test_platform.js
View File

@@ -1,134 +0,0 @@
#!/usr/bin/env node
/**
* Test the full WASM + platform stack in Node.
* Loads the kernel, registers FFI stubs, loads .sx web files.
*/
const path = require('path');
const fs = require('fs');
// Load js_of_ocaml kernel (WASM needs browser; JS works in Node)
require(path.join(__dirname, '../_build/default/browser/sx_browser.bc.js'));
const K = globalThis.SxKernel;
console.log('Engine:', K.engine());
// Register FFI stubs (no real DOM in Node, but the primitives must exist)
K.registerNative("host-global", (args) => {
const name = args[0];
return globalThis[name] || null;
});
K.registerNative("host-get", (args) => {
const [obj, prop] = args;
if (obj == null) return null;
const v = obj[prop];
return v === undefined ? null : v;
});
K.registerNative("host-set!", (args) => {
const [obj, prop, val] = args;
if (obj != null) obj[prop] = val;
});
K.registerNative("host-call", (args) => {
const [obj, method, ...rest] = args;
if (obj == null) return null;
if (typeof obj[method] === 'function') {
try { return obj[method].apply(obj, rest); } catch(e) { return null; }
}
return null;
});
K.registerNative("host-new", (args) => null);
K.registerNative("host-callback", (args) => {
const fn = args[0];
if (typeof fn === 'function') return fn;
if (fn && fn.__sx_handle !== undefined)
return (...a) => K.callFn(fn, a);
return () => {};
});
K.registerNative("host-typeof", (args) => {
const obj = args[0];
if (obj == null) return "nil";
return typeof obj;
});
K.registerNative("host-await", (args) => {
const [promise, callback] = args;
if (promise && typeof promise.then === 'function') {
const cb = typeof callback === 'function' ? callback :
(callback && callback.__sx_handle !== undefined) ?
(v) => K.callFn(callback, [v]) : () => {};
promise.then(cb);
}
});
// Load .sx web files in order
const root = path.join(__dirname, '../../..');
const sxFiles = [
'spec/render.sx', // HTML_TAGS, VOID_ELEMENTS, BOOLEAN_ATTRS, parse-element-args
'web/signals.sx',
'web/deps.sx',
'web/router.sx',
'web/page-helpers.sx',
'lib/bytecode.sx',
'lib/compiler.sx',
'lib/vm.sx',
'web/lib/dom.sx',
'web/lib/browser.sx',
'web/adapter-html.sx',
'web/adapter-sx.sx',
// Skip adapter-dom.sx, engine.sx, orchestration.sx, boot.sx — need real DOM
];
let totalExprs = 0;
for (const f of sxFiles) {
const src = fs.readFileSync(path.join(root, f), 'utf8');
const result = K.load(src);
if (typeof result === 'string' && result.startsWith('Error')) {
console.error(` FAIL loading ${f}: ${result}`);
process.exit(1);
}
totalExprs += (typeof result === 'number' ? result : 0);
}
console.log(`Loaded ${totalExprs} expressions from ${sxFiles.length} .sx files`);
// Test the loaded stack
const tests = [
// Signals
['(let ((s (signal 0))) (reset! s 42) (deref s))', 42],
['(let ((s (signal 10))) (swap! s inc) (deref s))', 11],
// Computed
['(let ((a (signal 2)) (b (computed (fn () (* (deref a) 3))))) (deref b))', 6],
// Render (OCaml renderer uses XHTML-style void tags)
['(render-to-html (quote (div :class "foo" "bar")))', '<div class="foo">bar</div>'],
['(render-to-html (quote (br)))', '<br />'],
// Compiler + VM
['(let ((c (compile (quote (+ 1 2))))) (get c "bytecode"))', { check: v => v && v._type === 'list' }],
// dom.sx loaded (functions exist even without real DOM)
['(type-of dom-create-element)', 'lambda'],
['(type-of dom-listen)', 'lambda'],
// browser.sx loaded
['(type-of console-log)', 'lambda'],
];
let passed = 0, failed = 0;
for (const [expr, expected] of tests) {
try {
const result = K.eval(expr);
let ok;
if (expected && typeof expected === 'object' && expected.check) {
ok = expected.check(result);
} else {
ok = result === expected;
}
if (ok) {
passed++;
} else {
console.log(` FAIL: ${expr}`);
console.log(` got: ${JSON.stringify(result)}, expected: ${JSON.stringify(expected)}`);
failed++;
}
} catch(e) {
console.log(` ERROR: ${expr}: ${e.message || e}`);
failed++;
}
}
console.log(`\n${passed} passed, ${failed} failed`);
process.exit(failed > 0 ? 1 : 0);

73
hosts/ocaml/browser/test_wasm.js
View File

@@ -1,73 +0,0 @@
#!/usr/bin/env node
// Test WASM build of SX kernel
const path = require('path');
const build_dir = path.join(__dirname, '../_build/default/browser');
async function main() {
// Load WASM module — require.main.filename must point to build dir
// so the WASM loader finds .wasm assets via path.dirname(require.main.filename)
require.main.filename = path.join(build_dir, 'test_wasm.js');
require(path.join(build_dir, 'sx_browser.bc.wasm.js'));
// Wait for WASM init
await new Promise(r => setTimeout(r, 2000));
const sx = globalThis.SxKernel;
if (!sx) {
console.error('FAIL: SxKernel not available');
process.exit(1);
}
console.log('Engine:', sx.engine());
// Basic tests
const tests = [
['(+ 1 2)', 3],
['(- 10 3)', 7],
['(* 6 7)', 42],
['(/ 10 2)', 5],
['(= 5 5)', true],
['(< 3 5)', true],
['(> 5 3)', true],
['(not false)', true],
['(inc 5)', 6],
['(dec 5)', 4],
['(len (list 1 2 3))', 3],
['(len "hello")', 5],
['(first (list 10 20))', 10],
['(nth "hello" 0)', 'h'],
['(nth "hello" 4)', 'o'],
['(str "a" "b")', 'ab'],
['(join ", " (list "a" "b" "c"))', 'a, b, c'],
['(let ((x 10) (y 20)) (+ x y))', 30],
['(if true "yes" "no")', 'yes'],
['(cond (= 1 2) "one" :else "other")', 'other'],
['(case 2 1 "one" 2 "two" :else "other")', 'two'],
['(render-to-html (list (quote div) "hello"))', '<div>hello</div>'],
['(render-to-html (list (quote span) (list (quote b) "bold")))', '<span><b>bold</b></span>'],
['(let ((add (fn (a b) (+ a b)))) (add 3 4))', 7],
['(let ((x 10)) (let ((f (fn () x))) (f)))', 10],
['(len (filter (fn (x) (> x 2)) (list 1 2 3 4 5)))', 3],
['(let ((fact (fn (n) (if (<= n 1) 1 (* n (fact (- n 1))))))) (fact 5))', 120],
];
let passed = 0, failed = 0;
for (const [expr, expected] of tests) {
const result = sx.eval(expr);
const ok = typeof expected === 'object'
? result && result._type === expected._type
: result === expected;
if (ok) {
console.log(` PASS: ${expr} = ${JSON.stringify(result)}`);
passed++;
} else {
console.log(` FAIL: ${expr} = ${JSON.stringify(result)} (expected ${JSON.stringify(expected)})`);
failed++;
}
}
console.log(`\n${passed} passed, ${failed} failed`);
process.exit(failed > 0 ? 1 : 0);
}
main().catch(e => { console.error(e); process.exit(1); });

307
hosts/ocaml/browser/test_wasm.sh
View File

@@ -1,307 +0,0 @@
#!/bin/bash
# WASM kernel tests in Node.js — verifies the compiled sx_browser.bc.js
# handles HTML tags, rendering, signals, and components correctly.
# Does NOT require a running server or browser.
set -euo pipefail
cd "$(dirname "$0")/../../.."
node -e '
// --- DOM stubs that track state ---
function makeElement(tag) {
var el = {
tagName: tag,
_attrs: {},
_children: [],
style: {},
childNodes: [],
children: [],
textContent: "",
setAttribute: function(k, v) { el._attrs[k] = v; },
getAttribute: function(k) { return el._attrs[k] || null; },
removeAttribute: function(k) { delete el._attrs[k]; },
appendChild: function(c) { el._children.push(c); el.childNodes.push(c); el.children.push(c); return c; },
insertBefore: function(c, ref) { el._children.push(c); el.childNodes.push(c); el.children.push(c); return c; },
removeChild: function(c) { return c; },
replaceChild: function(n, o) { return n; },
cloneNode: function() { return makeElement(tag); },
addEventListener: function() {},
removeEventListener: function() {},
dispatchEvent: function() {},
get innerHTML() {
// Reconstruct from children for simple cases
return el._children.map(function(c) {
if (c._isText) return c.textContent || "";
if (c._isComment) return "<!--" + (c.textContent || "") + "-->";
return c.outerHTML || "";
}).join("");
},
set innerHTML(v) { el._children = []; el.childNodes = []; el.children = []; el.textContent = v; },
get outerHTML() {
var s = "<" + tag;
var keys = Object.keys(el._attrs).sort();
for (var i = 0; i < keys.length; i++) {
s += " " + keys[i] + "=\"" + el._attrs[keys[i]] + "\"";
}
s += ">";
var voids = ["br","hr","img","input","meta","link"];
if (voids.indexOf(tag) >= 0) return s;
s += el.innerHTML;
s += "</" + tag + ">";
return s;
},
dataset: new Proxy({}, {
get: function(t, k) { return el._attrs["data-" + k.replace(/[A-Z]/g, function(c) { return "-" + c.toLowerCase(); })]; },
set: function(t, k, v) { el._attrs["data-" + k.replace(/[A-Z]/g, function(c) { return "-" + c.toLowerCase(); })] = v; return true; }
}),
querySelectorAll: function() { return []; },
querySelector: function() { return null; },
};
return el;
}
global.window = global;
global.document = {
createElement: makeElement,
createDocumentFragment: function() {
var f = makeElement("fragment");
f.tagName = undefined;
return f;
},
head: makeElement("head"),
body: makeElement("body"),
querySelector: function() { return null; },
querySelectorAll: function() { return []; },
createTextNode: function(s) { return {_isText:true, textContent:String(s), nodeType:3}; },
addEventListener: function() {},
createComment: function(s) { return {_isComment:true, textContent:s||"", nodeType:8}; },
getElementsByTagName: function() { return []; },
};
global.localStorage = {getItem:function(){return null},setItem:function(){},removeItem:function(){}};
global.CustomEvent = class { constructor(n,o){this.type=n;this.detail=(o||{}).detail||{}} };
global.MutationObserver = class { observe(){} disconnect(){} };
global.requestIdleCallback = function(fn) { return setTimeout(fn,0); };
global.matchMedia = function() { return {matches:false}; };
global.navigator = {serviceWorker:{register:function(){return Promise.resolve()}}};
global.location = {href:"",pathname:"/",hostname:"localhost"};
global.history = {pushState:function(){},replaceState:function(){}};
global.fetch = function() { return Promise.resolve({ok:true,text:function(){return Promise.resolve("")}}); };
global.setTimeout = setTimeout;
global.clearTimeout = clearTimeout;
global.XMLHttpRequest = class { open(){} send(){} };
// --- Load kernel ---
require("./shared/static/wasm/sx_browser.bc.js");
var K = globalThis.SxKernel;
if (!K) { console.error("FAIL: SxKernel not found"); process.exit(1); }
// --- Register 8 FFI host primitives (normally done by sx-platform.js) ---
K.registerNative("host-global", function(args) {
var name = args[0];
if (typeof globalThis !== "undefined" && name in globalThis) return globalThis[name];
return null;
});
K.registerNative("host-get", function(args) {
var obj = args[0], prop = args[1];
if (obj == null) return null;
var v = obj[prop];
return v === undefined ? null : v;
});
K.registerNative("host-set!", function(args) {
var obj = args[0], prop = args[1], val = args[2];
if (obj != null) obj[prop] = val;
return val;
});
K.registerNative("host-call", function(args) {
var obj = args[0], method = args[1];
var callArgs = args.slice(2);
if (obj == null || typeof obj[method] !== "function") return null;
var r = obj[method].apply(obj, callArgs);
return r === undefined ? null : r;
});
K.registerNative("host-new", function(args) {
var ctor = args[0];
var ctorArgs = args.slice(1);
return new (Function.prototype.bind.apply(ctor, [null].concat(ctorArgs)));
});
K.registerNative("host-callback", function(args) {
var fn = args[0];
return function() { return K.callFn(fn, Array.from(arguments)); };
});
K.registerNative("host-typeof", function(args) {
return typeof args[0];
});
K.registerNative("host-await", function(args) { return args[0]; });
// Platform constants
K.eval("(define SX_VERSION \"test-1.0\")");
K.eval("(define SX_ENGINE \"ocaml-vm-test\")");
K.eval("(define parse sx-parse)");
K.eval("(define serialize sx-serialize)");
var pass = 0, fail = 0;
function assert(name, got, expected) {
if (got === expected) { pass++; }
else { fail++; console.error("FAIL: " + name + "\n got: " + JSON.stringify(got) + "\n expected: " + JSON.stringify(expected)); }
}
function assertIncludes(name, got, substr) {
if (typeof got === "string" && got.includes(substr)) { pass++; }
else { fail++; console.error("FAIL: " + name + "\n got: " + JSON.stringify(got) + "\n expected to include: " + JSON.stringify(substr)); }
}
function assertNotError(name, got) {
if (typeof got === "string" && got.startsWith("Error:")) { fail++; console.error("FAIL: " + name + ": " + got); }
else { pass++; }
}
// =====================================================================
// Section 1: HTML tags and rendering
// =====================================================================
assert("arithmetic", K.eval("(+ 1 2)"), 3);
assert("string", K.eval("(str \"hello\" \" world\")"), "hello world");
// Tags as special forms — keywords preserved
assert("div preserves keywords",
K.eval("(inspect (div :class \"test\" \"hello\"))"),
"(div :class \"test\" \"hello\")");
assert("span preserves keywords",
K.eval("(inspect (span :id \"x\" \"content\"))"),
"(span :id \"x\" \"content\")");
// render-to-html
assert("render div+class", K.eval("(render-to-html (div :class \"card\" \"content\"))"), "<div class=\"card\">content</div>");
assert("render h1+class", K.eval("(render-to-html (h1 :class \"title\" \"Hello\"))"), "<h1 class=\"title\">Hello</h1>");
assert("render a+href", K.eval("(render-to-html (a :href \"/about\" \"About\"))"), "<a href=\"/about\">About</a>");
assert("render nested", K.eval("(render-to-html (div :class \"outer\" (span :class \"inner\" \"text\")))"), "<div class=\"outer\"><span class=\"inner\">text</span></div>");
assertIncludes("void element br", K.eval("(render-to-html (br))"), "br");
// Component rendering
K.eval("(defcomp ~test-card (&key title) (div :class \"card\" (h2 title)))");
assert("component render", K.eval("(render-to-html (~test-card :title \"Hello\"))"), "<div class=\"card\"><h2>Hello</h2></div>");
K.eval("(defcomp ~test-wrap (&key label) (div :class \"wrap\" (span label)))");
assert("component nested", K.eval("(render-to-html (~test-wrap :label \"hi\"))"), "<div class=\"wrap\"><span>hi</span></div>");
// Core primitives
assert("list length", K.eval("(list 1 2 3)").items.length, 3);
assert("first", K.eval("(first (list 1 2 3))"), 1);
assert("len", K.eval("(len (list 1 2 3))"), 3);
assert("map", K.eval("(len (map (fn (x) (+ x 1)) (list 1 2 3)))"), 3);
// HTML tag registry
assertNotError("HTML_TAGS defined", K.eval("(type-of HTML_TAGS)"));
assert("is-html-tag? div", K.eval("(is-html-tag? \"div\")"), true);
assert("is-html-tag? fake", K.eval("(is-html-tag? \"fake\")"), false);
// =====================================================================
// Load web stack modules (same as sx-platform.js loadWebStack)
// =====================================================================
var fs = require("fs");
var webStackFiles = [
"shared/static/wasm/sx/render.sx",
"shared/static/wasm/sx/core-signals.sx",
"shared/static/wasm/sx/signals.sx",
"shared/static/wasm/sx/deps.sx",
"shared/static/wasm/sx/router.sx",
"shared/static/wasm/sx/page-helpers.sx",
"shared/static/wasm/sx/freeze.sx",
"shared/static/wasm/sx/dom.sx",
"shared/static/wasm/sx/browser.sx",
"shared/static/wasm/sx/adapter-html.sx",
"shared/static/wasm/sx/adapter-sx.sx",
"shared/static/wasm/sx/adapter-dom.sx",
"shared/static/wasm/sx/boot-helpers.sx",
"shared/static/wasm/sx/hypersx.sx",
"shared/static/wasm/sx/engine.sx",
"shared/static/wasm/sx/orchestration.sx",
"shared/static/wasm/sx/boot.sx",
];
var loadFails = [];
var useBytecode = process.env.SX_TEST_BYTECODE === "1";
if (K.beginModuleLoad) K.beginModuleLoad();
for (var i = 0; i < webStackFiles.length; i++) {
var loaded = false;
if (useBytecode) {
var bcPath = webStackFiles[i].replace(/\.sx$/, ".sxbc");
try {
var bcSrc = fs.readFileSync(bcPath, "utf8");
global.__sxbcText = bcSrc;
var bcResult = K.eval("(load-sxbc (first (parse (host-global \"__sxbcText\"))))");
delete global.__sxbcText;
if (typeof bcResult !== "string" || !bcResult.startsWith("Error")) {
loaded = true;
} else {
loadFails.push(bcPath + " (sxbc): " + bcResult);
}
} catch(e) { delete global.__sxbcText; }
}
if (!loaded) {
var src = fs.readFileSync(webStackFiles[i], "utf8");
var r = K.load(src);
if (typeof r === "string" && r.startsWith("Error")) {
loadFails.push(webStackFiles[i] + ": " + r);
}
}
}
if (K.endModuleLoad) K.endModuleLoad();
if (loadFails.length > 0) {
console.error("Module load failures:");
loadFails.forEach(function(f) { console.error(" " + f); });
}
// =====================================================================
// Section 2: render-to-dom (requires working DOM stubs)
// All DOM results are host objects — use host-get/dom-get-attr from SX
// =====================================================================
// Basic DOM rendering
assert("dom tagName",
K.eval("(host-get (render-to-dom (div :class \"test\" \"hello\") (global-env) nil) \"tagName\")"),
"div");
assert("dom class attr",
K.eval("(dom-get-attr (render-to-dom (div :class \"test\" \"hello\") (global-env) nil) \"class\")"),
"test");
assertIncludes("dom outerHTML",
K.eval("(host-get (render-to-dom (div :class \"test\" \"hello\") (global-env) nil) \"outerHTML\")"),
"hello");
// Nested DOM rendering
assertIncludes("nested dom outerHTML",
K.eval("(host-get (render-to-dom (div :class \"outer\" (span :id \"inner\" \"text\")) (global-env) nil) \"outerHTML\")"),
"class=\"outer\"");
// =====================================================================
// Section 3: Reactive rendering — with-island-scope + deref
// This is the critical test for the hydration bug.
// with-island-scope should NOT strip attributes.
// =====================================================================
// 3a. with-island-scope should preserve static attributes
assert("scoped static class",
K.eval("(dom-get-attr (let ((d (list))) (with-island-scope (fn (x) (append! d x)) (fn () (render-to-dom (div :class \"scoped\" \"text\") (global-env) nil)))) \"class\")"),
"scoped");
// 3b. Signal deref in text position should render initial value
assertIncludes("signal text initial value",
K.eval("(host-get (let ((s (signal 42)) (d (list))) (with-island-scope (fn (x) (append! d x)) (fn () (render-to-dom (div (deref s)) (global-env) nil)))) \"outerHTML\")"),
"42");
// 3c. Signal deref in attribute position should set initial value
assert("signal attr initial value",
K.eval("(dom-get-attr (let ((s (signal \"active\")) (d (list))) (with-island-scope (fn (x) (append! d x)) (fn () (render-to-dom (div :class (deref s) \"content\") (global-env) nil)))) \"class\")"),
"active");
// 3d. After signal update, reactive DOM should update
// render-to-dom needs unevaluated expr (as in real browser boot from parsed source)
K.eval("(define test-reactive-sig (signal \"before\"))");
assert("reactive attr update",
K.eval("(let ((d (list))) (let ((el (with-island-scope (fn (x) (append! d x)) (fn () (render-to-dom (quote (div :class (deref test-reactive-sig) \"content\")) (global-env) nil))))) (reset! test-reactive-sig \"after\") (dom-get-attr el \"class\")))"),
"after");
// =====================================================================
// Summary
// =====================================================================
console.log("WASM kernel tests: " + pass + " passed, " + fail + " failed");
if (fail > 0) process.exit(1);
'

187
hosts/ocaml/browser/test_wasm_native.js
View File

@@ -1,187 +0,0 @@
#!/usr/bin/env node
// test_wasm_native.js — Run WASM kernel tests in Node.js using the actual
// WASM binary (not js_of_ocaml JS fallback). Tests are SX deftest forms
// in web/tests/test-wasm-browser.sx.
//
// Usage: node hosts/ocaml/browser/test_wasm_native.js
// SX_TEST_BYTECODE=1 node hosts/ocaml/browser/test_wasm_native.js
const fs = require('fs');
const path = require('path');
const PROJECT_ROOT = path.resolve(__dirname, '../../..');
const WASM_DIR = path.join(PROJECT_ROOT, 'shared/static/wasm');
// --- DOM stubs ---
function makeElement(tag) {
const el = {
tagName: tag, _attrs: {}, _children: [], style: {},
childNodes: [], children: [], textContent: '',
nodeType: 1,
setAttribute(k, v) { el._attrs[k] = String(v); },
getAttribute(k) { return el._attrs[k] || null; },
removeAttribute(k) { delete el._attrs[k]; },
appendChild(c) { el._children.push(c); el.childNodes.push(c); el.children.push(c); return c; },
insertBefore(c) { el._children.push(c); el.childNodes.push(c); el.children.push(c); return c; },
removeChild(c) { return c; },
replaceChild(n) { return n; },
cloneNode() { return makeElement(tag); },
addEventListener() {}, removeEventListener() {}, dispatchEvent() {},
get innerHTML() {
return el._children.map(c => {
if (c._isText) return c.textContent || '';
if (c._isComment) return '<!--' + (c.textContent || '') + '-->';
return c.outerHTML || '';
}).join('');
},
set innerHTML(v) { el._children = []; el.childNodes = []; el.children = []; },
get outerHTML() {
let s = '<' + tag;
for (const k of Object.keys(el._attrs).sort()) s += ` ${k}="${el._attrs[k]}"`;
s += '>';
if (['br','hr','img','input','meta','link'].includes(tag)) return s;
return s + el.innerHTML + '</' + tag + '>';
},
dataset: new Proxy({}, {
get(_, k) { return el._attrs['data-' + k.replace(/[A-Z]/g, c => '-' + c.toLowerCase())]; },
set(_, k, v) { el._attrs['data-' + k.replace(/[A-Z]/g, c => '-' + c.toLowerCase())] = v; return true; }
}),
querySelectorAll() { return []; },
querySelector() { return null; },
};
return el;
}
global.window = global;
global.document = {
createElement: makeElement,
createDocumentFragment() { return makeElement('fragment'); },
head: makeElement('head'), body: makeElement('body'),
querySelector() { return null; }, querySelectorAll() { return []; },
createTextNode(s) { return { _isText: true, textContent: String(s), nodeType: 3 }; },
addEventListener() {},
createComment(s) { return { _isComment: true, textContent: s || '', nodeType: 8 }; },
getElementsByTagName() { return []; },
};
global.localStorage = { getItem() { return null; }, setItem() {}, removeItem() {} };
global.CustomEvent = class { 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() { return Promise.resolve(); } } };
global.location = { href: '', pathname: '/', hostname: 'localhost' };
global.history = { pushState() {}, replaceState() {} };
global.fetch = () => Promise.resolve({ ok: true, text() { return Promise.resolve(''); } });
global.XMLHttpRequest = class { open() {} send() {} };
// --- Load WASM kernel ---
async function main() {
// The WASM loader sets globalThis.SxKernel after async init
require(path.join(WASM_DIR, 'sx_browser.bc.wasm.js'));
// Poll for SxKernel (WASM init is async)
const K = await new Promise((resolve, reject) => {
let tries = 0;
const poll = setInterval(() => {
if (globalThis.SxKernel) { clearInterval(poll); resolve(globalThis.SxKernel); }
else if (++tries > 200) { clearInterval(poll); reject(new Error('SxKernel not found after 10s')); }
}, 50);
});
console.log('WASM kernel loaded (native WASM, not JS fallback)');
// --- Register 8 FFI host primitives ---
K.registerNative('host-global', args => {
const name = args[0];
return (name in globalThis) ? globalThis[name] : null;
});
K.registerNative('host-get', args => {
const [obj, prop] = args;
if (obj == null) return null;
const v = obj[prop];
return v === undefined ? null : v;
});
K.registerNative('host-set!', args => { if (args[0] != null) args[0][args[1]] = args[2]; return args[2]; });
K.registerNative('host-call', args => {
const [obj, method, ...rest] = args;
if (obj == null || typeof obj[method] !== 'function') return null;
const r = obj[method].apply(obj, rest);
return r === undefined ? null : r;
});
K.registerNative('host-new', args => new (Function.prototype.bind.apply(args[0], [null, ...args.slice(1)])));
K.registerNative('host-callback', args => function() { return K.callFn(args[0], Array.from(arguments)); });
K.registerNative('host-typeof', args => typeof args[0]);
K.registerNative('host-await', args => args[0]);
K.eval('(define SX_VERSION "test-wasm-1.0")');
K.eval('(define SX_ENGINE "ocaml-vm-wasm-test")');
K.eval('(define parse sx-parse)');
K.eval('(define serialize sx-serialize)');
// --- Load web stack modules ---
const useBytecode = process.env.SX_TEST_BYTECODE === '1';
const sxDir = path.join(WASM_DIR, 'sx');
const modules = [
'render', 'core-signals', 'signals', 'deps', 'router', 'page-helpers', 'freeze',
'bytecode', 'compiler', 'vm', 'dom', 'browser',
'adapter-html', 'adapter-sx', 'adapter-dom',
'boot-helpers', 'hypersx',
'harness', 'harness-reactive', 'harness-web',
'engine', 'orchestration', 'boot',
];
if (K.beginModuleLoad) K.beginModuleLoad();
for (const mod of modules) {
let loaded = false;
if (useBytecode) {
try {
const bcSrc = fs.readFileSync(path.join(sxDir, mod + '.sxbc'), 'utf8');
global.__sxbcText = bcSrc;
const r = K.eval('(load-sxbc (first (parse (host-global "__sxbcText"))))');
delete global.__sxbcText;
if (typeof r !== 'string' || !r.startsWith('Error')) { loaded = true; }
} catch (e) { delete global.__sxbcText; }
}
if (!loaded) {
const src = fs.readFileSync(path.join(sxDir, mod + '.sx'), 'utf8');
K.load(src);
}
}
if (K.endModuleLoad) K.endModuleLoad();
// --- Register test framework hooks ---
let pass = 0, fail = 0;
const suiteStack = [];
K.registerNative('report-pass', args => {
pass++;
return null;
});
K.registerNative('report-fail', args => {
fail++;
const suitePath = suiteStack.join(' > ');
console.error(`FAIL: ${suitePath ? suitePath + ' > ' : ''}${args[0]}\n ${args[1]}`);
return null;
});
K.registerNative('push-suite', args => {
suiteStack.push(args[0]);
return null;
});
K.registerNative('pop-suite', args => {
suiteStack.pop();
return null;
});
// try-call must return {"ok": bool, "error": string|nil} for the test framework
K.eval('(define try-call (fn (thunk) (let ((result (cek-try thunk (fn (err) err)))) (if (and (= (type-of result) "string") (starts-with? result "Error")) {"ok" false "error" result} {"ok" true "error" nil}))))');
// --- Load test framework + SX test file ---
K.load(fs.readFileSync(path.join(PROJECT_ROOT, 'spec/tests/test-framework.sx'), 'utf8'));
K.load(fs.readFileSync(path.join(PROJECT_ROOT, 'web/tests/test-wasm-browser.sx'), 'utf8'));
// --- Summary ---
console.log(`WASM native tests: ${pass} passed, ${fail} failed`);
process.exit(fail > 0 ? 1 : 0);
}
main().catch(e => { console.error('FATAL:', e.message); process.exit(1); });

200
hosts/ocaml/browser/wrap-modules.js
View File

@@ -1,200 +0,0 @@
#!/usr/bin/env node
/**
* wrap-modules.js — Add define-library wrappers and import declarations
* to browser .sx SOURCE files for lazy loading support.
*
* Targets the real source locations (spec/, web/, lib/), NOT dist/.
* Run bundle.sh after to copy to dist/, then compile-modules.js.
*
* - 8 unwrapped files get define-library + export + begin wrappers
* - 4 already-wrapped files get dependency import declarations
* - boot.sx gets imports (stays unwrapped — entry point)
*/
const fs = require('fs');
const path = require('path');
const ROOT = path.resolve(__dirname, '..', '..', '..');
// Source file → library name (null = entry point)
const MODULES = {
// Spec modules
'spec/render.sx': { lib: '(sx render)', deps: [] },
'spec/signals.sx': { lib: '(sx signals)', deps: [] },
'web/web-signals.sx': { lib: '(sx signals-web)', deps: ['(sx dom)', '(sx browser)'] },
'web/deps.sx': { lib: '(web deps)', deps: [] },
'web/router.sx': { lib: '(web router)', deps: [] },
'web/page-helpers.sx': { lib: '(web page-helpers)', deps: [] },
// Lib modules
'lib/freeze.sx': { lib: '(sx freeze)', deps: [] },
'lib/highlight.sx': { lib: '(sx highlight)', deps: [] },
'lib/bytecode.sx': { lib: '(sx bytecode)', deps: [] },
'lib/compiler.sx': { lib: '(sx compiler)', deps: [] },
'lib/vm.sx': { lib: '(sx vm)', deps: [] },
// Web FFI
'web/lib/dom.sx': { lib: '(sx dom)', deps: [] },
'web/lib/browser.sx': { lib: '(sx browser)', deps: [] },
// Web adapters
'web/adapter-html.sx': { lib: '(web adapter-html)', deps: ['(sx render)'] },
'web/adapter-sx.sx': { lib: '(web adapter-sx)', deps: ['(web boot-helpers)'] },
'web/adapter-dom.sx': { lib: '(web adapter-dom)', deps: ['(sx dom)', '(sx render)'] },
// Web framework
'web/lib/boot-helpers.sx': { lib: '(web boot-helpers)', deps: ['(sx dom)', '(sx browser)', '(web adapter-dom)'] },
'web/lib/hypersx.sx': { lib: '(sx hypersx)', deps: [] },
'web/engine.sx': { lib: '(web engine)', deps: ['(web boot-helpers)', '(sx dom)', '(sx browser)'] },
'web/orchestration.sx': { lib: '(web orchestration)', deps: ['(web boot-helpers)', '(sx dom)', '(sx browser)', '(web adapter-dom)', '(web engine)'] },
'web/boot.sx': { lib: null, deps: ['(sx dom)', '(sx browser)', '(web boot-helpers)', '(web adapter-dom)',
'(sx signals)', '(sx signals-web)', '(web router)', '(web page-helpers)',
'(web orchestration)', '(sx render)',
'(sx bytecode)', '(sx compiler)', '(sx vm)'] },
// Test harness
'spec/harness.sx': { lib: '(sx harness)', deps: [] },
'web/harness-reactive.sx': { lib: '(sx harness-reactive)', deps: [] },
'web/harness-web.sx': { lib: '(sx harness-web)', deps: [] },
};
// Extract top-level define names from source.
// Handles both `(define name ...)` and `(define\n name ...)` formats.
function extractDefineNames(source) {
const names = [];
const lines = source.split('\n');
let depth = 0;
let expectName = false;
for (const line of lines) {
if (depth === 0) {
const m = line.match(/^\(define\s+\(?(\S+)/);
if (m) {
names.push(m[1]);
expectName = false;
} else if (line.match(/^\(define\s*$/)) {
expectName = true;
}
} else if (depth === 1 && expectName) {
const m = line.match(/^\s+(\S+)/);
if (m) {
names.push(m[1]);
expectName = false;
}
}
for (const ch of line) {
if (ch === '(') depth++;
else if (ch === ')') depth--;
}
}
return names;
}
function processFile(relPath, info) {
const filePath = path.join(ROOT, relPath);
if (!fs.existsSync(filePath)) {
console.log(' SKIP', relPath, '(not found)');
return;
}
let source = fs.readFileSync(filePath, 'utf8');
const { lib, deps } = info;
const hasWrapper = source.includes('(define-library');
const hasDepImports = deps.length > 0 && source.match(/^\(import\s+\(/m) &&
!source.match(/^\(import\s+\(\w+ \w+\)\)\s*$/m); // more than just self-import
// Skip files with no deps and already wrapped (or no wrapper needed)
if (deps.length === 0 && (hasWrapper || !lib)) {
console.log(' ok', relPath, '(no changes needed)');
return;
}
// Build import lines for deps
const importLines = deps.map(d => `(import ${d})`).join('\n');
// CASE 1: Entry point (boot.sx) — just add imports at top
if (!lib) {
if (deps.length > 0 && !source.startsWith('(import')) {
source = importLines + '\n\n' + source;
fs.writeFileSync(filePath, source);
console.log(' +imports', relPath, `(${deps.length} deps, entry point)`);
} else {
console.log(' ok', relPath, '(entry point, already has imports)');
}
return;
}
// CASE 2: Already wrapped — add imports before define-library
if (hasWrapper) {
if (deps.length > 0) {
// Check if imports already present
const firstImportCheck = deps[0].replace(/[()]/g, '\\$&');
if (source.match(new RegExp('\\(import ' + firstImportCheck))) {
console.log(' ok', relPath, '(already has dep imports)');
return;
}
const dlIdx = source.indexOf('(define-library');
source = source.slice(0, dlIdx) + importLines + '\n\n' + source.slice(dlIdx);
fs.writeFileSync(filePath, source);
console.log(' +imports', relPath, `(${deps.length} deps)`);
}
return;
}
// CASE 3: Needs full wrapping
if (deps.length === 0 && !hasWrapper) {
// Wrap with no deps
const names = extractDefineNames(source);
if (names.length === 0) {
console.log(' WARN', relPath, '— no defines found, skipping');
return;
}
const wrapped = buildWrapped(lib, names, source, '');
fs.writeFileSync(filePath, wrapped);
console.log(' wrapped', relPath, `as ${lib} (${names.length} exports)`);
return;
}
// Wrap with deps
const names = extractDefineNames(source);
if (names.length === 0) {
console.log(' WARN', relPath, '— no defines found, skipping');
return;
}
const wrapped = buildWrapped(lib, names, source, importLines);
fs.writeFileSync(filePath, wrapped);
console.log(' wrapped', relPath, `as ${lib} (${names.length} exports, ${deps.length} deps)`);
}
function buildWrapped(libName, exportNames, bodySource, importSection) {
const parts = [];
// Dependency imports (top-level, before define-library)
if (importSection) {
parts.push(importSection);
parts.push('');
}
// define-library header
parts.push(`(define-library ${libName}`);
parts.push(` (export ${exportNames.join(' ')})`);
parts.push(' (begin');
parts.push('');
// Body (original source, indented)
parts.push(bodySource);
parts.push('');
// Close begin + define-library
parts.push('))');
parts.push('');
// Self-import for backward compat
parts.push(`;; Re-export to global env`);
parts.push(`(import ${libName})`);
parts.push('');
return parts.join('\n');
}
console.log('Processing source .sx files...\n');
for (const [relPath, info] of Object.entries(MODULES)) {
processFile(relPath, info);
}
console.log('\nDone! Now run:');
console.log(' bash hosts/ocaml/browser/bundle.sh');
console.log(' node hosts/ocaml/browser/compile-modules.js');

2
hosts/ocaml/dune-project
View File

@@ -1,2 +1,2 @@
(lang dune 3.19)
(lang dune 3.0)
(name sx)

4
hosts/ocaml/lib/dune
View File

@@ -1,4 +1,2 @@
(library
(name sx)
(wrapped false)
(libraries re re.pcre))
(name sx))

212
hosts/ocaml/lib/sx_compiler.ml
View File

@@ -1,212 +0,0 @@
(* sx_compiler.ml — Auto-generated from lib/compiler.sx *)
(* Do not edit — regenerate with: python3 hosts/ocaml/bootstrap_compiler.py *)
[@@@warning "-26-27"]
open Sx_types
open Sx_runtime
(* The compiler uses cek_call from the evaluator for runtime dispatch *)
let cek_call = Sx_ref.cek_call
let eval_expr = Sx_ref.eval_expr
let trampoline v = match v with
| Thunk (expr, env) -> Sx_ref.eval_expr expr (Env env)
| other -> other
(* Bindings for external functions the compiler calls.
Some shadow OCaml stdlib names — the SX versions operate on values. *)
let serialize v = String (Sx_types.inspect v)
let sx_parse v = match v with
| String s -> (match Sx_parser.parse_all s with [e] -> e | es -> List es)
| v -> v
let floor v = prim_call "floor" [v]
let abs v = prim_call "abs" [v]
let min a b = prim_call "min" [a; b]
let max a b = prim_call "max" [a; b]
let set_nth_b lst idx v = prim_call "set-nth!" [lst; idx; v]
let init lst = prim_call "init" [lst]
(* skip_annotations: strips :keyword value pairs from a list (type annotations) *)
let rec skip_annotations items =
match items with
| List [] | Nil -> Nil
| List (Keyword _ :: _ :: rest) -> skip_annotations (List rest)
| ListRef { contents = [] } -> Nil
| ListRef { contents = Keyword _ :: _ :: rest } -> skip_annotations (List rest)
| List (first :: _) -> first
| ListRef { contents = first :: _ } -> first
| _ -> Nil
(* compile_match: uses local recursion (letrec) that the transpiler can't handle.
Falls back to CEK evaluation at runtime. *)
let compile_match em args scope tail_p =
let fn = Sx_ref.eval_expr (Symbol "compile-match") (Env (Sx_types.make_env ())) in
ignore (Sx_ref.cek_call fn (List [em; args; scope; tail_p]));
Nil
(* === Transpiled from bytecode compiler === *)
(* make-pool *)
let rec make_pool () =
(let _d = Hashtbl.create 2 in Hashtbl.replace _d "entries" (if sx_truthy ((is_primitive ((String "mutable-list")))) then (mutable_list ()) else (List [])); Hashtbl.replace _d "index" (let _d = Hashtbl.create 1 in Hashtbl.replace _d "_count" (Number 0.0); Dict _d); Dict _d)
(* pool-add *)
and pool_add pool value =
(let () = ignore ((String "Add a value to the constant pool, return its index. Deduplicates.")) in (let key = (serialize (value)) in let idx_map = (get (pool) ((String "index"))) in (if sx_truthy ((prim_call "has-key?" [idx_map; key])) then (get (idx_map) (key)) else (let idx = (get (idx_map) ((String "_count"))) in (let () = ignore ((sx_dict_set_b idx_map key idx)) in (let () = ignore ((sx_dict_set_b idx_map (String "_count") (prim_call "+" [idx; (Number 1.0)]))) in (let () = ignore ((sx_append_b (get (pool) ((String "entries"))) value)) in idx)))))))
(* make-scope *)
and make_scope parent =
(let _d = Hashtbl.create 5 in Hashtbl.replace _d "next-slot" (Number 0.0); Hashtbl.replace _d "upvalues" (List []); Hashtbl.replace _d "locals" (List []); Hashtbl.replace _d "parent" parent; Hashtbl.replace _d "is-function" (Bool false); Dict _d)
(* scope-define-local *)
and scope_define_local scope name =
(let () = ignore ((String "Add a local variable, return its slot index.\n Idempotent: if name already has a slot, return it.")) in (let existing = (first ((List (List.filter (fun l -> sx_truthy ((prim_call "=" [(get (l) ((String "name"))); name]))) (sx_to_list (get (scope) ((String "locals")))))))) in (if sx_truthy (existing) then (get (existing) ((String "slot"))) else (let slot = (get (scope) ((String "next-slot"))) in (let () = ignore ((sx_append_b (get (scope) ((String "locals"))) (let _d = Hashtbl.create 3 in Hashtbl.replace _d "mutable" (Bool false); Hashtbl.replace _d "slot" slot; Hashtbl.replace _d "name" name; Dict _d))) in (let () = ignore ((sx_dict_set_b scope (String "next-slot") (prim_call "+" [slot; (Number 1.0)]))) in slot))))))
(* scope-resolve *)
and scope_resolve scope name =
(let () = ignore ((String "Resolve a variable name. Returns {:type \"local\"|\"upvalue\"|\"global\", :index N}.\n Upvalue captures only happen at function boundaries (is-function=true).\n Let scopes share the enclosing function's frame — their locals are\n accessed directly without upvalue indirection.")) in (if sx_truthy ((is_nil (scope))) then (CekFrame { cf_type = "global"; cf_env = Nil; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil }) else (let locals = (get (scope) ((String "locals"))) in let found = (Bool (List.exists (fun l -> sx_truthy ((prim_call "=" [(get (l) ((String "name"))); name]))) (sx_to_list locals))) in (if sx_truthy (found) then (let local = (first ((List (List.filter (fun l -> sx_truthy ((prim_call "=" [(get (l) ((String "name"))); name]))) (sx_to_list locals))))) in (CekFrame { cf_type = "local"; cf_env = Nil; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })) else (let upvals = (get (scope) ((String "upvalues"))) in let uv_found = (Bool (List.exists (fun u -> sx_truthy ((prim_call "=" [(get (u) ((String "name"))); name]))) (sx_to_list upvals))) in (if sx_truthy (uv_found) then (let uv = (first ((List (List.filter (fun u -> sx_truthy ((prim_call "=" [(get (u) ((String "name"))); name]))) (sx_to_list upvals))))) in (CekFrame { cf_type = "upvalue"; cf_env = Nil; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil })) else (let parent = (get (scope) ((String "parent"))) in (if sx_truthy ((is_nil (parent))) then (CekFrame { cf_type = "global"; cf_env = Nil; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil }) else (let parent_result = (scope_resolve (parent) (name)) in (if sx_truthy ((prim_call "=" [(get (parent_result) ((String "type"))); (String "global")])) then parent_result else (if sx_truthy ((get (scope) ((String "is-function")))) then (let uv_idx = (len ((get (scope) ((String "upvalues"))))) in (let () = ignore ((sx_append_b (get (scope) ((String "upvalues"))) (let _d = Hashtbl.create 4 in Hashtbl.replace _d "index" (get (parent_result) ((String "index"))); Hashtbl.replace _d "is-local" (prim_call "=" [(get (parent_result) ((String "type"))); (String "local")]); Hashtbl.replace _d "uv-index" uv_idx; Hashtbl.replace _d "name" name; Dict _d))) in (CekFrame { cf_type = "upvalue"; cf_env = Nil; cf_name = Nil; cf_body = Nil; cf_remaining = Nil; cf_f = Nil; cf_args = Nil; cf_results = Nil; cf_extra = Nil; cf_extra2 = Nil }))) else parent_result)))))))))))
(* make-emitter *)
and make_emitter () =
(let _d = Hashtbl.create 2 in Hashtbl.replace _d "pool" (make_pool ()); Hashtbl.replace _d "bytecode" (if sx_truthy ((is_primitive ((String "mutable-list")))) then (mutable_list ()) else (List [])); Dict _d)
(* emit-byte *)
and emit_byte em byte =
(sx_append_b (get (em) ((String "bytecode"))) byte)
(* emit-u16 *)
and emit_u16 em value =
(let () = ignore ((emit_byte (em) ((prim_call "mod" [value; (Number 256.0)])))) in (emit_byte (em) ((prim_call "mod" [(floor ((prim_call "/" [value; (Number 256.0)]))); (Number 256.0)]))))
(* emit-i16 *)
and emit_i16 em value =
(let v = (if sx_truthy ((prim_call "<" [value; (Number 0.0)])) then (prim_call "+" [value; (Number 65536.0)]) else value) in (emit_u16 (em) (v)))
(* emit-op *)
and emit_op em opcode =
(emit_byte (em) (opcode))
(* emit-const *)
and emit_const em value =
(let idx = (pool_add ((get (em) ((String "pool")))) (value)) in (let () = ignore ((emit_op (em) ((Number 1.0)))) in (emit_u16 (em) (idx))))
(* current-offset *)
and current_offset em =
(len ((get (em) ((String "bytecode")))))
(* patch-i16 *)
and patch_i16 em offset value =
(let () = ignore ((String "Patch a previously emitted i16 at the given bytecode offset.")) in (let v = (if sx_truthy ((prim_call "<" [value; (Number 0.0)])) then (prim_call "+" [value; (Number 65536.0)]) else value) in let bc = (get (em) ((String "bytecode"))) in (let () = ignore ((set_nth_b (bc) (offset) ((prim_call "mod" [v; (Number 256.0)])))) in (set_nth_b (bc) ((prim_call "+" [offset; (Number 1.0)])) ((prim_call "mod" [(floor ((prim_call "/" [v; (Number 256.0)]))); (Number 256.0)]))))))
(* compile-expr *)
and compile_expr em expr scope tail_p =
(let () = ignore ((String "Compile an expression. tail? indicates tail position for TCO.")) in (if sx_truthy ((is_nil (expr))) then (emit_op (em) ((Number 2.0))) else (if sx_truthy ((prim_call "=" [(type_of (expr)); (String "number")])) then (emit_const (em) (expr)) else (if sx_truthy ((prim_call "=" [(type_of (expr)); (String "string")])) then (emit_const (em) (expr)) else (if sx_truthy ((prim_call "=" [(type_of (expr)); (String "boolean")])) then (emit_op (em) ((if sx_truthy (expr) then (Number 3.0) else (Number 4.0)))) else (if sx_truthy ((prim_call "=" [(type_of (expr)); (String "keyword")])) then (emit_const (em) ((keyword_name (expr)))) else (if sx_truthy ((prim_call "=" [(type_of (expr)); (String "symbol")])) then (compile_symbol (em) ((symbol_name (expr))) (scope)) else (if sx_truthy ((prim_call "=" [(type_of (expr)); (String "list")])) then (if sx_truthy ((empty_p (expr))) then (let () = ignore ((emit_op (em) ((Number 64.0)))) in (emit_u16 (em) ((Number 0.0)))) else (compile_list (em) (expr) (scope) (tail_p))) else (if sx_truthy ((prim_call "=" [(type_of (expr)); (String "dict")])) then (compile_dict (em) (expr) (scope)) else (emit_const (em) (expr)))))))))))
(* compile-symbol *)
and compile_symbol em name scope =
(let resolved = (scope_resolve (scope) (name)) in (if sx_truthy ((prim_call "=" [(get (resolved) ((String "type"))); (String "local")])) then (let () = ignore ((emit_op (em) ((Number 16.0)))) in (emit_byte (em) ((get (resolved) ((String "index")))))) else (if sx_truthy ((prim_call "=" [(get (resolved) ((String "type"))); (String "upvalue")])) then (let () = ignore ((emit_op (em) ((Number 18.0)))) in (emit_byte (em) ((get (resolved) ((String "index")))))) else (let idx = (pool_add ((get (em) ((String "pool")))) (name)) in (let () = ignore ((emit_op (em) ((Number 20.0)))) in (emit_u16 (em) (idx)))))))
(* compile-dict *)
and compile_dict em expr scope =
(let ks = (prim_call "keys" [expr]) in let count = (len (ks)) in (let () = ignore ((List.iter (fun k -> ignore ((let () = ignore ((emit_const (em) (k))) in (compile_expr (em) ((get (expr) (k))) (scope) ((Bool false)))))) (sx_to_list ks); Nil)) in (let () = ignore ((emit_op (em) ((Number 65.0)))) in (emit_u16 (em) (count)))))
(* compile-list *)
and compile_list em expr scope tail_p =
(let head = (first (expr)) in let args = (rest (expr)) in (if sx_truthy ((Bool (not (sx_truthy ((prim_call "=" [(type_of (head)); (String "symbol")])))))) then (compile_call (em) (head) (args) (scope) (tail_p)) else (let name = (symbol_name (head)) in (if sx_truthy ((prim_call "=" [name; (String "if")])) then (compile_if (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "when")])) then (compile_when (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "and")])) then (compile_and (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "or")])) then (compile_or (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "let")])) then (compile_let (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "let*")])) then (compile_let (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "begin")])) then (compile_begin (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "do")])) then (compile_begin (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "lambda")])) then (compile_lambda (em) (args) (scope)) else (if sx_truthy ((prim_call "=" [name; (String "fn")])) then (compile_lambda (em) (args) (scope)) else (if sx_truthy ((prim_call "=" [name; (String "define")])) then (compile_define (em) (args) (scope)) else (if sx_truthy ((prim_call "=" [name; (String "set!")])) then (compile_set (em) (args) (scope)) else (if sx_truthy ((prim_call "=" [name; (String "quote")])) then (compile_quote (em) (args)) else (if sx_truthy ((prim_call "=" [name; (String "cond")])) then (compile_cond (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "case")])) then (compile_case (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "->")])) then (compile_thread (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "defcomp")])) then (compile_defcomp (em) (args) (scope)) else (if sx_truthy ((prim_call "=" [name; (String "defisland")])) then (compile_defcomp (em) (args) (scope)) else (if sx_truthy ((prim_call "=" [name; (String "defmacro")])) then (compile_defmacro (em) (args) (scope)) else (if sx_truthy ((prim_call "=" [name; (String "defstyle")])) then (let () = ignore ((emit_op (em) ((Number 2.0)))) in Nil) else (if sx_truthy ((prim_call "=" [name; (String "defhandler")])) then (let () = ignore ((emit_op (em) ((Number 2.0)))) in Nil) else (if sx_truthy ((prim_call "=" [name; (String "defpage")])) then (let () = ignore ((emit_op (em) ((Number 2.0)))) in Nil) else (if sx_truthy ((prim_call "=" [name; (String "defquery")])) then (let () = ignore ((emit_op (em) ((Number 2.0)))) in Nil) else (if sx_truthy ((prim_call "=" [name; (String "defaction")])) then (let () = ignore ((emit_op (em) ((Number 2.0)))) in Nil) else (if sx_truthy ((prim_call "=" [name; (String "defrelation")])) then (let () = ignore ((emit_op (em) ((Number 2.0)))) in Nil) else (if sx_truthy ((prim_call "=" [name; (String "deftype")])) then (let () = ignore ((emit_op (em) ((Number 2.0)))) in Nil) else (if sx_truthy ((prim_call "=" [name; (String "defeffect")])) then (let () = ignore ((emit_op (em) ((Number 2.0)))) in Nil) else (if sx_truthy ((prim_call "=" [name; (String "defisland")])) then (compile_defcomp (em) (args) (scope)) else (if sx_truthy ((prim_call "=" [name; (String "quasiquote")])) then (compile_quasiquote (em) ((first (args))) (scope)) else (if sx_truthy ((prim_call "=" [name; (String "letrec")])) then (compile_letrec (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "match")])) then (compile_match (em) (args) (scope) (tail_p)) else (if sx_truthy ((prim_call "=" [name; (String "perform")])) then ( (let () = ignore ((compile_expr (em) ((first (args))) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 112.0)))) in Nil))) else (compile_call (em) (head) (args) (scope) (tail_p)))))))))))))))))))))))))))))))))))))
(* compile-if *)
and compile_if em args scope tail_p =
(let test = (first (args)) in let then_expr = (nth (args) ((Number 1.0))) in let else_expr = (if sx_truthy ((prim_call ">" [(len (args)); (Number 2.0)])) then (nth (args) ((Number 2.0))) else Nil) in (let () = ignore ((compile_expr (em) (test) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 33.0)))) in (let else_jump = (current_offset (em)) in (let () = ignore ((emit_i16 (em) ((Number 0.0)))) in (let () = ignore ((compile_expr (em) (then_expr) (scope) (tail_p))) in (let () = ignore ((emit_op (em) ((Number 32.0)))) in (let end_jump = (current_offset (em)) in (let () = ignore ((emit_i16 (em) ((Number 0.0)))) in (let () = ignore ((patch_i16 (em) (else_jump) ((prim_call "-" [(current_offset (em)); (prim_call "+" [else_jump; (Number 2.0)])])))) in (let () = ignore ((if sx_truthy ((is_nil (else_expr))) then (emit_op (em) ((Number 2.0))) else (compile_expr (em) (else_expr) (scope) (tail_p)))) in (patch_i16 (em) (end_jump) ((prim_call "-" [(current_offset (em)); (prim_call "+" [end_jump; (Number 2.0)])]))))))))))))))
(* compile-when *)
and compile_when em args scope tail_p =
(let test = (first (args)) in let body = (rest (args)) in (let () = ignore ((compile_expr (em) (test) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 33.0)))) in (let skip_jump = (current_offset (em)) in (let () = ignore ((emit_i16 (em) ((Number 0.0)))) in (let () = ignore ((compile_begin (em) (body) (scope) (tail_p))) in (let () = ignore ((emit_op (em) ((Number 32.0)))) in (let end_jump = (current_offset (em)) in (let () = ignore ((emit_i16 (em) ((Number 0.0)))) in (let () = ignore ((patch_i16 (em) (skip_jump) ((prim_call "-" [(current_offset (em)); (prim_call "+" [skip_jump; (Number 2.0)])])))) in (let () = ignore ((emit_op (em) ((Number 2.0)))) in (patch_i16 (em) (end_jump) ((prim_call "-" [(current_offset (em)); (prim_call "+" [end_jump; (Number 2.0)])]))))))))))))))
(* compile-and *)
and compile_and em args scope tail_p =
(if sx_truthy ((empty_p (args))) then (emit_op (em) ((Number 3.0))) else (if sx_truthy ((prim_call "=" [(len (args)); (Number 1.0)])) then (compile_expr (em) ((first (args))) (scope) (tail_p)) else (let () = ignore ((compile_expr (em) ((first (args))) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 6.0)))) in (let () = ignore ((emit_op (em) ((Number 33.0)))) in (let skip = (current_offset (em)) in (let () = ignore ((emit_i16 (em) ((Number 0.0)))) in (let () = ignore ((emit_op (em) ((Number 5.0)))) in (let () = ignore ((compile_and (em) ((rest (args))) (scope) (tail_p))) in (patch_i16 (em) (skip) ((prim_call "-" [(current_offset (em)); (prim_call "+" [skip; (Number 2.0)])]))))))))))))
(* compile-or *)
and compile_or em args scope tail_p =
(if sx_truthy ((empty_p (args))) then (emit_op (em) ((Number 4.0))) else (if sx_truthy ((prim_call "=" [(len (args)); (Number 1.0)])) then (compile_expr (em) ((first (args))) (scope) (tail_p)) else (let () = ignore ((compile_expr (em) ((first (args))) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 6.0)))) in (let () = ignore ((emit_op (em) ((Number 34.0)))) in (let skip = (current_offset (em)) in (let () = ignore ((emit_i16 (em) ((Number 0.0)))) in (let () = ignore ((emit_op (em) ((Number 5.0)))) in (let () = ignore ((compile_or (em) ((rest (args))) (scope) (tail_p))) in (patch_i16 (em) (skip) ((prim_call "-" [(current_offset (em)); (prim_call "+" [skip; (Number 2.0)])]))))))))))))
(* compile-begin *)
and compile_begin em exprs scope tail_p =
(let () = ignore ((if sx_truthy ((let _and = (Bool (not (sx_truthy ((empty_p (exprs)))))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((is_nil ((get (scope) ((String "parent"))))))))))) then (List.iter (fun expr -> ignore ((if sx_truthy ((let _and = (prim_call "=" [(type_of (expr)); (String "list")]) in if not (sx_truthy _and) then _and else (let _and = (prim_call ">=" [(len (expr)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((first (expr)))); (String "symbol")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name ((first (expr)))); (String "define")]))))) then (let name_expr = (nth (expr) ((Number 1.0))) in let name = (if sx_truthy ((prim_call "=" [(type_of (name_expr)); (String "symbol")])) then (symbol_name (name_expr)) else name_expr) in (scope_define_local (scope) (name))) else Nil))) (sx_to_list exprs); Nil) else Nil)) in (if sx_truthy ((empty_p (exprs))) then (emit_op (em) ((Number 2.0))) else (if sx_truthy ((prim_call "=" [(len (exprs)); (Number 1.0)])) then (compile_expr (em) ((first (exprs))) (scope) (tail_p)) else (let () = ignore ((compile_expr (em) ((first (exprs))) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 5.0)))) in (compile_begin (em) ((rest (exprs))) (scope) (tail_p)))))))
(* compile-let *)
and compile_let em args scope tail_p =
(if sx_truthy ((prim_call "=" [(type_of ((first (args)))); (String "symbol")])) then (let loop_name = (symbol_name ((first (args)))) in let bindings = (nth (args) ((Number 1.0))) in let body = (prim_call "slice" [args; (Number 2.0)]) in let params = ref ((List [])) in let inits = ref ((List [])) in (let () = ignore ((List.iter (fun binding -> ignore ((let () = ignore ((params := sx_append_b !params (if sx_truthy ((prim_call "=" [(type_of ((first (binding)))); (String "symbol")])) then (first (binding)) else (make_symbol ((first (binding))))); Nil)) in (inits := sx_append_b !inits (nth (binding) ((Number 1.0))); Nil)))) (sx_to_list bindings); Nil)) in (let lambda_expr = (prim_call "concat" [(List [(make_symbol ((String "fn"))); !params]); body]) in let letrec_bindings = (List [(List [(make_symbol (loop_name)); lambda_expr])]) in let call_expr = (cons ((make_symbol (loop_name))) (!inits)) in (compile_letrec (em) ((List [letrec_bindings; call_expr])) (scope) (tail_p))))) else (let bindings = (first (args)) in let body = (rest (args)) in let let_scope = (make_scope (scope)) in (let () = ignore ((sx_dict_set_b let_scope (String "next-slot") (get (scope) ((String "next-slot"))))) in (let () = ignore ((List.iter (fun binding -> ignore ((let name = (if sx_truthy ((prim_call "=" [(type_of ((first (binding)))); (String "symbol")])) then (symbol_name ((first (binding)))) else (first (binding))) in let value = (nth (binding) ((Number 1.0))) in let slot = (scope_define_local (let_scope) (name)) in (let () = ignore ((compile_expr (em) (value) (let_scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 17.0)))) in (emit_byte (em) (slot))))))) (sx_to_list bindings); Nil)) in (compile_begin (em) (body) (let_scope) (tail_p))))))
(* compile-letrec *)
and compile_letrec em args scope tail_p =
(let () = ignore ((String "Compile letrec: all names visible during value compilation.\n 1. Define all local slots (initialized to nil).\n 2. Compile each value and assign — names are already in scope\n so mutually recursive functions can reference each other.")) in (let bindings = (first (args)) in let body = (rest (args)) in let let_scope = (make_scope (scope)) in (let () = ignore ((sx_dict_set_b let_scope (String "next-slot") (get (scope) ((String "next-slot"))))) in (let () = ignore ((let slots = (List (List.map (fun binding -> (let name = (if sx_truthy ((prim_call "=" [(type_of ((first (binding)))); (String "symbol")])) then (symbol_name ((first (binding)))) else (first (binding))) in (let slot = (scope_define_local (let_scope) (name)) in (let () = ignore ((emit_op (em) ((Number 2.0)))) in (let () = ignore ((emit_op (em) ((Number 17.0)))) in (let () = ignore ((emit_byte (em) (slot))) in slot)))))) (sx_to_list bindings))) in (List.iter (fun pair -> ignore ((let binding = (first (pair)) in let slot = (nth (pair) ((Number 1.0))) in (let () = ignore ((compile_expr (em) ((nth (binding) ((Number 1.0)))) (let_scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 17.0)))) in (emit_byte (em) (slot))))))) (sx_to_list (List (List.map (fun i -> (List [(nth (bindings) (i)); (nth (slots) (i))])) (sx_to_list (prim_call "range" [(Number 0.0); (len (bindings))]))))); Nil))) in (compile_begin (em) (body) (let_scope) (tail_p))))))
(* compile-lambda *)
and compile_lambda em args scope =
(let params = (first (args)) in let body = (rest (args)) in let fn_scope = (make_scope (scope)) in let fn_em = (make_emitter ()) in (let () = ignore ((sx_dict_set_b fn_scope (String "is-function") (Bool true))) in (let () = ignore ((List.iter (fun p -> ignore ((let name = (if sx_truthy ((prim_call "=" [(type_of (p)); (String "symbol")])) then (symbol_name (p)) else (if sx_truthy ((let _and = (list_p (p)) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((empty_p (p)))))) in if not (sx_truthy _and) then _and else (prim_call "=" [(type_of ((first (p)))); (String "symbol")])))) then (symbol_name ((first (p)))) else p)) in (if sx_truthy ((let _and = (Bool (not (sx_truthy ((prim_call "=" [name; (String "&key")]))))) in if not (sx_truthy _and) then _and else (Bool (not (sx_truthy ((prim_call "=" [name; (String "&rest")]))))))) then (scope_define_local (fn_scope) (name)) else Nil)))) (sx_to_list params); Nil)) in (let () = ignore ((compile_begin (fn_em) (body) (fn_scope) ((Bool true)))) in (let () = ignore ((emit_op (fn_em) ((Number 50.0)))) in (let upvals = (get (fn_scope) ((String "upvalues"))) in let code = (let _d = Hashtbl.create 4 in Hashtbl.replace _d "upvalue-count" (len (upvals)); Hashtbl.replace _d "arity" (len ((get (fn_scope) ((String "locals"))))); Hashtbl.replace _d "constants" (get ((get (fn_em) ((String "pool")))) ((String "entries"))); Hashtbl.replace _d "bytecode" (get (fn_em) ((String "bytecode"))); Dict _d) in let code_idx = (pool_add ((get (em) ((String "pool")))) (code)) in (let () = ignore ((emit_op (em) ((Number 51.0)))) in (let () = ignore ((emit_u16 (em) (code_idx))) in (List.iter (fun uv -> ignore ((let () = ignore ((emit_byte (em) ((if sx_truthy ((get (uv) ((String "is-local")))) then (Number 1.0) else (Number 0.0))))) in (emit_byte (em) ((get (uv) ((String "index")))))))) (sx_to_list upvals); Nil)))))))))
(* compile-define *)
and compile_define em args scope =
(let name_expr = (first (args)) in let name = (if sx_truthy ((prim_call "=" [(type_of (name_expr)); (String "symbol")])) then (symbol_name (name_expr)) else name_expr) in let value = (let rest_args = (rest (args)) in (if sx_truthy ((let _and = (Bool (not (sx_truthy ((empty_p (rest_args)))))) in if not (sx_truthy _and) then _and else (prim_call "=" [(type_of ((first (rest_args)))); (String "keyword")]))) then (skip_annotations (rest_args)) else (first (rest_args)))) in (if sx_truthy ((Bool (not (sx_truthy ((is_nil ((get (scope) ((String "parent")))))))))) then (let slot = (scope_define_local (scope) (name)) in (let () = ignore ((compile_expr (em) (value) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 17.0)))) in (emit_byte (em) (slot))))) else (let name_idx = (pool_add ((get (em) ((String "pool")))) (name)) in (let () = ignore ((compile_expr (em) (value) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 128.0)))) in (emit_u16 (em) (name_idx)))))))
(* compile-set *)
and compile_set em args scope =
(let name = (if sx_truthy ((prim_call "=" [(type_of ((first (args)))); (String "symbol")])) then (symbol_name ((first (args)))) else (first (args))) in let value = (nth (args) ((Number 1.0))) in let resolved = (scope_resolve (scope) (name)) in (let () = ignore ((compile_expr (em) (value) (scope) ((Bool false)))) in (if sx_truthy ((prim_call "=" [(get (resolved) ((String "type"))); (String "local")])) then (let () = ignore ((emit_op (em) ((Number 17.0)))) in (emit_byte (em) ((get (resolved) ((String "index")))))) else (if sx_truthy ((prim_call "=" [(get (resolved) ((String "type"))); (String "upvalue")])) then (let () = ignore ((emit_op (em) ((Number 19.0)))) in (emit_byte (em) ((get (resolved) ((String "index")))))) else (let idx = (pool_add ((get (em) ((String "pool")))) (name)) in (let () = ignore ((emit_op (em) ((Number 21.0)))) in (emit_u16 (em) (idx))))))))
(* compile-quote *)
and compile_quote em args =
(if sx_truthy ((empty_p (args))) then (emit_op (em) ((Number 2.0))) else (emit_const (em) ((first (args)))))
(* compile-cond *)
and compile_cond em args scope tail_p =
(let () = ignore ((String "Compile (cond test1 body1 test2 body2 ... :else fallback).")) in (if sx_truthy ((prim_call "<" [(len (args)); (Number 2.0)])) then (emit_op (em) ((Number 2.0))) else (let test = (first (args)) in let body = (nth (args) ((Number 1.0))) in let rest_clauses = (if sx_truthy ((prim_call ">" [(len (args)); (Number 2.0)])) then (prim_call "slice" [args; (Number 2.0)]) else (List [])) in (if sx_truthy ((let _or = (let _and = (prim_call "=" [(type_of (test)); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name (test)); (String "else")])) in if sx_truthy _or then _or else (prim_call "=" [test; (Bool true)]))) then (compile_expr (em) (body) (scope) (tail_p)) else (let () = ignore ((compile_expr (em) (test) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 33.0)))) in (let skip = (current_offset (em)) in (let () = ignore ((emit_i16 (em) ((Number 0.0)))) in (let () = ignore ((compile_expr (em) (body) (scope) (tail_p))) in (let () = ignore ((emit_op (em) ((Number 32.0)))) in (let end_jump = (current_offset (em)) in (let () = ignore ((emit_i16 (em) ((Number 0.0)))) in (let () = ignore ((patch_i16 (em) (skip) ((prim_call "-" [(current_offset (em)); (prim_call "+" [skip; (Number 2.0)])])))) in (let () = ignore ((compile_cond (em) (rest_clauses) (scope) (tail_p))) in (patch_i16 (em) (end_jump) ((prim_call "-" [(current_offset (em)); (prim_call "+" [end_jump; (Number 2.0)])])))))))))))))))))
(* compile-case *)
and compile_case em args scope tail_p =
(let () = ignore ((String "Compile (case expr val1 body1 val2 body2 ... :else fallback).")) in (let () = ignore ((compile_expr (em) ((first (args))) (scope) ((Bool false)))) in (let clauses = (rest (args)) in (compile_case_clauses (em) (clauses) (scope) (tail_p)))))
(* compile-case-clauses *)
and compile_case_clauses em clauses scope tail_p =
(if sx_truthy ((prim_call "<" [(len (clauses)); (Number 2.0)])) then (let () = ignore ((emit_op (em) ((Number 5.0)))) in (emit_op (em) ((Number 2.0)))) else (let test = (first (clauses)) in let body = (nth (clauses) ((Number 1.0))) in let rest_clauses = (if sx_truthy ((prim_call ">" [(len (clauses)); (Number 2.0)])) then (prim_call "slice" [clauses; (Number 2.0)]) else (List [])) in (if sx_truthy ((let _or = (let _and = (prim_call "=" [(type_of (test)); (String "keyword")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(keyword_name (test)); (String "else")])) in if sx_truthy _or then _or else (prim_call "=" [test; (Bool true)]))) then (let () = ignore ((emit_op (em) ((Number 5.0)))) in (compile_expr (em) (body) (scope) (tail_p))) else (let () = ignore ((emit_op (em) ((Number 6.0)))) in (let () = ignore ((compile_expr (em) (test) (scope) ((Bool false)))) in (let () = ignore ((let name_idx = (pool_add ((get (em) ((String "pool")))) ((String "="))) in (let () = ignore ((emit_op (em) ((Number 52.0)))) in (let () = ignore ((emit_u16 (em) (name_idx))) in (emit_byte (em) ((Number 2.0))))))) in (let () = ignore ((emit_op (em) ((Number 33.0)))) in (let skip = (current_offset (em)) in (let () = ignore ((emit_i16 (em) ((Number 0.0)))) in (let () = ignore ((emit_op (em) ((Number 5.0)))) in (let () = ignore ((compile_expr (em) (body) (scope) (tail_p))) in (let () = ignore ((emit_op (em) ((Number 32.0)))) in (let end_jump = (current_offset (em)) in (let () = ignore ((emit_i16 (em) ((Number 0.0)))) in (let () = ignore ((patch_i16 (em) (skip) ((prim_call "-" [(current_offset (em)); (prim_call "+" [skip; (Number 2.0)])])))) in (let () = ignore ((compile_case_clauses (em) (rest_clauses) (scope) (tail_p))) in (patch_i16 (em) (end_jump) ((prim_call "-" [(current_offset (em)); (prim_call "+" [end_jump; (Number 2.0)])])))))))))))))))))))
(* compile-thread *)
and compile_thread em args scope tail_p =
(let () = ignore ((String "Compile (-> val (f1 a) (f2 b)) by desugaring to nested calls.")) in (if sx_truthy ((empty_p (args))) then (emit_op (em) ((Number 2.0))) else (if sx_truthy ((prim_call "=" [(len (args)); (Number 1.0)])) then (compile_expr (em) ((first (args))) (scope) (tail_p)) else (let val_expr = (first (args)) in let forms = (rest (args)) in (compile_thread_step (em) (val_expr) (forms) (scope) (tail_p))))))
(* compile-thread-step *)
and compile_thread_step em val_expr forms scope tail_p =
(if sx_truthy ((empty_p (forms))) then (compile_expr (em) (val_expr) (scope) (tail_p)) else (let form = (first (forms)) in let rest_forms = (rest (forms)) in let is_tail = (let _and = tail_p in if not (sx_truthy _and) then _and else (empty_p (rest_forms))) in (let call_expr = (if sx_truthy ((list_p (form))) then (prim_call "concat" [(List [(first (form)); val_expr]); (rest (form))]) else (List [form; val_expr])) in (if sx_truthy ((empty_p (rest_forms))) then (compile_expr (em) (call_expr) (scope) (is_tail)) else (let () = ignore ((compile_expr (em) (call_expr) (scope) ((Bool false)))) in (compile_thread_step (em) (call_expr) (rest_forms) (scope) (tail_p)))))))
(* compile-defcomp *)
and compile_defcomp em args scope =
(let () = ignore ((String "Compile defcomp/defisland — delegates to runtime via GLOBAL_GET + CALL.")) in (let () = ignore ((let name_idx = (pool_add ((get (em) ((String "pool")))) ((String "eval-defcomp"))) in (let () = ignore ((emit_op (em) ((Number 20.0)))) in (emit_u16 (em) (name_idx))))) in (let () = ignore ((emit_const (em) ((prim_call "concat" [(List [(make_symbol ((String "defcomp")))]); args])))) in (let () = ignore ((emit_op (em) ((Number 48.0)))) in (emit_byte (em) ((Number 1.0)))))))
(* compile-defmacro *)
and compile_defmacro em args scope =
(let () = ignore ((String "Compile defmacro — delegates to runtime via GLOBAL_GET + CALL.")) in (let () = ignore ((let name_idx = (pool_add ((get (em) ((String "pool")))) ((String "eval-defmacro"))) in (let () = ignore ((emit_op (em) ((Number 20.0)))) in (emit_u16 (em) (name_idx))))) in (let () = ignore ((emit_const (em) ((prim_call "concat" [(List [(make_symbol ((String "defmacro")))]); args])))) in (let () = ignore ((emit_op (em) ((Number 48.0)))) in (emit_byte (em) ((Number 1.0)))))))
(* compile-quasiquote *)
and compile_quasiquote em expr scope =
(let () = ignore ((String "Compile quasiquote inline — walks the template at compile time,\n emitting code that builds the structure at runtime. Unquoted\n expressions are compiled normally (resolving locals/upvalues),\n avoiding the qq-expand-runtime env-lookup limitation.")) in (compile_qq_expr (em) (expr) (scope)))
(* compile-qq-expr *)
and compile_qq_expr em expr scope =
(let () = ignore ((String "Compile a quasiquote sub-expression.")) in (if sx_truthy ((Bool (not (sx_truthy ((prim_call "=" [(type_of (expr)); (String "list")])))))) then (emit_const (em) (expr)) else (if sx_truthy ((empty_p (expr))) then (let () = ignore ((emit_op (em) ((Number 64.0)))) in (emit_u16 (em) ((Number 0.0)))) else (let head = (first (expr)) in (if sx_truthy ((let _and = (prim_call "=" [(type_of (head)); (String "symbol")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name (head)); (String "unquote")]))) then (compile_expr (em) ((nth (expr) ((Number 1.0)))) (scope) ((Bool false))) else (compile_qq_list (em) (expr) (scope)))))))
(* compile-qq-list *)
and compile_qq_list em items scope =
(let () = ignore ((String "Compile a quasiquote list. Handles splice-unquote by building\n segments and concatenating them.")) in (let has_splice = (Bool (List.exists (fun item -> sx_truthy ((let _and = (prim_call "=" [(type_of (item)); (String "list")]) in if not (sx_truthy _and) then _and else (let _and = (prim_call ">=" [(len (item)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((first (item)))); (String "symbol")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name ((first (item)))); (String "splice-unquote")])))))) (sx_to_list items))) in (if sx_truthy ((Bool (not (sx_truthy (has_splice))))) then (let () = ignore ((List.iter (fun item -> ignore ((compile_qq_expr (em) (item) (scope)))) (sx_to_list items); Nil)) in (let () = ignore ((emit_op (em) ((Number 64.0)))) in (emit_u16 (em) ((len (items)))))) else (let segment_count = ref ((Number 0.0)) in let pending = ref ((Number 0.0)) in (let () = ignore ((List.iter (fun item -> ignore ((if sx_truthy ((let _and = (prim_call "=" [(type_of (item)); (String "list")]) in if not (sx_truthy _and) then _and else (let _and = (prim_call ">=" [(len (item)); (Number 2.0)]) in if not (sx_truthy _and) then _and else (let _and = (prim_call "=" [(type_of ((first (item)))); (String "symbol")]) in if not (sx_truthy _and) then _and else (prim_call "=" [(symbol_name ((first (item)))); (String "splice-unquote")]))))) then (let () = ignore ((if sx_truthy ((prim_call ">" [!pending; (Number 0.0)])) then (let () = ignore ((emit_op (em) ((Number 64.0)))) in (let () = ignore ((emit_u16 (em) (!pending))) in (let () = ignore ((segment_count := (prim_call "+" [!segment_count; (Number 1.0)]); Nil)) in (pending := (Number 0.0); Nil)))) else Nil)) in (let () = ignore ((compile_expr (em) ((nth (item) ((Number 1.0)))) (scope) ((Bool false)))) in (segment_count := (prim_call "+" [!segment_count; (Number 1.0)]); Nil))) else (let () = ignore ((compile_qq_expr (em) (item) (scope))) in (pending := (prim_call "+" [!pending; (Number 1.0)]); Nil))))) (sx_to_list items); Nil)) in (let () = ignore ((if sx_truthy ((prim_call ">" [!pending; (Number 0.0)])) then (let () = ignore ((emit_op (em) ((Number 64.0)))) in (let () = ignore ((emit_u16 (em) (!pending))) in (segment_count := (prim_call "+" [!segment_count; (Number 1.0)]); Nil))) else Nil)) in (if sx_truthy ((prim_call ">" [!segment_count; (Number 1.0)])) then (let concat_idx = (pool_add ((get (em) ((String "pool")))) ((String "concat"))) in (let () = ignore ((emit_op (em) ((Number 52.0)))) in (let () = ignore ((emit_u16 (em) (concat_idx))) in (emit_byte (em) (!segment_count))))) else Nil)))))))
(* compile-call *)
and compile_call em head args scope tail_p =
(let is_prim = (let _and = (prim_call "=" [(type_of (head)); (String "symbol")]) in if not (sx_truthy _and) then _and else (let name = (symbol_name (head)) in (let _and = (Bool (not (sx_truthy ((prim_call "=" [(get ((scope_resolve (scope) (name))) ((String "type"))); (String "local")]))))) in if not (sx_truthy _and) then _and else (let _and = (Bool (not (sx_truthy ((prim_call "=" [(get ((scope_resolve (scope) (name))) ((String "type"))); (String "upvalue")]))))) in if not (sx_truthy _and) then _and else (is_primitive (name)))))) in (if sx_truthy (is_prim) then (let name = (symbol_name (head)) in let argc = (len (args)) in let name_idx = (pool_add ((get (em) ((String "pool")))) (name)) in (let () = ignore ((List.iter (fun a -> ignore ((compile_expr (em) (a) (scope) ((Bool false))))) (sx_to_list args); Nil)) in (let () = ignore ((emit_op (em) ((Number 52.0)))) in (let () = ignore ((emit_u16 (em) (name_idx))) in (emit_byte (em) (argc)))))) else (let () = ignore ((compile_expr (em) (head) (scope) ((Bool false)))) in (let () = ignore ((List.iter (fun a -> ignore ((compile_expr (em) (a) (scope) ((Bool false))))) (sx_to_list args); Nil)) in (if sx_truthy (tail_p) then (let () = ignore ((emit_op (em) ((Number 49.0)))) in (emit_byte (em) ((len (args))))) else (let () = ignore ((emit_op (em) ((Number 48.0)))) in (emit_byte (em) ((len (args))))))))))
(* compile *)
and compile expr =
(let () = ignore ((String "Compile a single SX expression to a bytecode module.")) in (let em = (make_emitter ()) in let scope = (make_scope (Nil)) in (let () = ignore ((compile_expr (em) (expr) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 50.0)))) in (let _d = Hashtbl.create 2 in Hashtbl.replace _d "constants" (get ((get (em) ((String "pool")))) ((String "entries"))); Hashtbl.replace _d "bytecode" (get (em) ((String "bytecode"))); Dict _d)))))
(* compile-module *)
and compile_module exprs =
(let () = ignore ((String "Compile a list of top-level expressions to a bytecode module.")) in (let em = (make_emitter ()) in let scope = (make_scope (Nil)) in (let () = ignore ((List.iter (fun expr -> ignore ((let () = ignore ((compile_expr (em) (expr) (scope) ((Bool false)))) in (emit_op (em) ((Number 5.0)))))) (sx_to_list (init (exprs))); Nil)) in (let () = ignore ((compile_expr (em) ((last (exprs))) (scope) ((Bool false)))) in (let () = ignore ((emit_op (em) ((Number 50.0)))) in (let _d = Hashtbl.create 2 in Hashtbl.replace _d "constants" (get ((get (em) ((String "pool")))) ((String "entries"))); Hashtbl.replace _d "bytecode" (get (em) ((String "bytecode"))); Dict _d))))))

146
hosts/ocaml/lib/sx_cst.ml
View File

@@ -1,146 +0,0 @@
(** Concrete Syntax Tree for SX — lossless source representation.
Every piece of source text is preserved: whitespace, comments,
delimiters, raw token text. The CST supports two projections:
- [cst_to_source]: reconstruct the exact original source
- [cst_to_ast]: strip trivia, produce [Sx_types.value] for evaluation
Trivia attaches to nodes (leading on every node, trailing on
containers before the close delimiter). No separate comment map. *)
open Sx_types
(** {1 Types} *)
type trivia =
| Whitespace of string (** Runs of spaces, tabs, newlines *)
| LineComment of string (** ";;" through end of line, including the ";" chars *)
type span = {
start_offset : int;
end_offset : int;
}
type cst_node =
| CstAtom of {
leading_trivia : trivia list;
token : string; (** Raw source text of the token *)
value : value; (** Parsed semantic value *)
span : span;
}
| CstList of {
leading_trivia : trivia list;
open_delim : char; (** '(' or '[' *)
children : cst_node list;
close_delim : char; (** ')' or ']' *)
trailing_trivia : trivia list; (** Trivia between last child and close delim *)
span : span;
}
| CstDict of {
leading_trivia : trivia list;
children : cst_node list; (** Alternating key/value atoms *)
trailing_trivia : trivia list;
span : span;
}
(** {1 CST → Source (lossless reconstruction)} *)
let trivia_to_string ts =
let buf = Buffer.create 64 in
List.iter (function
| Whitespace s -> Buffer.add_string buf s
| LineComment s -> Buffer.add_string buf s
) ts;
Buffer.contents buf
let rec cst_to_source node =
match node with
| CstAtom { leading_trivia; token; _ } ->
trivia_to_string leading_trivia ^ token
| CstList { leading_trivia; open_delim; children; close_delim; trailing_trivia; _ } ->
let buf = Buffer.create 256 in
Buffer.add_string buf (trivia_to_string leading_trivia);
Buffer.add_char buf open_delim;
List.iter (fun c -> Buffer.add_string buf (cst_to_source c)) children;
Buffer.add_string buf (trivia_to_string trailing_trivia);
Buffer.add_char buf close_delim;
Buffer.contents buf
| CstDict { leading_trivia; children; trailing_trivia; _ } ->
let buf = Buffer.create 256 in
Buffer.add_string buf (trivia_to_string leading_trivia);
Buffer.add_char buf '{';
List.iter (fun c -> Buffer.add_string buf (cst_to_source c)) children;
Buffer.add_string buf (trivia_to_string trailing_trivia);
Buffer.add_char buf '}';
Buffer.contents buf
let cst_to_source_file nodes =
String.concat "" (List.map cst_to_source nodes)
(** Reconstruct source from a parsed file (nodes + trailing trivia). *)
let cst_file_to_source nodes trailing =
cst_to_source_file nodes ^ trivia_to_string trailing
(** {1 CST → AST (strip trivia for evaluation)} *)
let rec cst_to_ast = function
| CstAtom { value; _ } -> value
| CstList { children; _ } ->
List (List.map cst_to_ast children)
| CstDict { children; _ } ->
let d = make_dict () in
let rec pairs = function
| k :: v :: rest ->
let key_str = match cst_to_ast k with
| Keyword k -> k | String k -> k | Symbol k -> k | _ -> ""
in
dict_set d key_str (cst_to_ast v);
pairs rest
| _ -> ()
in
pairs children;
Dict d
(** {1 CST editing — apply AST-level edits back to the CST} *)
(** Replace the CST node at [path] with [new_source], preserving the
original node's leading trivia. [new_source] is parsed as CST so
any comments in it are preserved. *)
let apply_edit path new_cst_nodes original_cst_nodes =
let rec go nodes idx_path =
match idx_path with
| [] -> nodes (* shouldn't happen *)
| [target] ->
List.mapi (fun i node ->
if i = target then
match new_cst_nodes with
| [replacement] ->
(* Preserve original leading trivia *)
let orig_trivia = match node with
| CstAtom { leading_trivia; _ } -> leading_trivia
| CstList { leading_trivia; _ } -> leading_trivia
| CstDict { leading_trivia; _ } -> leading_trivia
in
(match replacement with
| CstAtom r -> CstAtom { r with leading_trivia = orig_trivia }
| CstList r -> CstList { r with leading_trivia = orig_trivia }
| CstDict r -> CstDict { r with leading_trivia = orig_trivia })
| _ -> node (* multi-node replacement: use as-is *)
else node
) nodes
| target :: rest ->
List.mapi (fun i node ->
if i = target then
match node with
| CstList r ->
CstList { r with children = go r.children rest }
| CstDict r ->
CstDict { r with children = go r.children rest }
| _ -> node
else node
) nodes
in
go original_cst_nodes path

248
hosts/ocaml/lib/sx_parser.ml
View File

@@ -95,11 +95,7 @@ let try_number str =
let rec read_value s : value =
skip_whitespace_and_comments s;
if at_end s then begin
let line = ref 1 in
String.iter (fun c -> if c = '\n' then incr line) s.src;
raise (Parse_error (Printf.sprintf "Unexpected end of input at line %d (pos %d)" !line s.pos))
end;
if at_end s then raise (Parse_error "Unexpected end of input");
match s.src.[s.pos] with
| '(' -> read_list s ')'
| '[' -> read_list s ']'
@@ -143,14 +139,7 @@ let rec read_value s : value =
begin
(* Symbol, keyword, number, or boolean *)
let token = read_symbol s in
if token = "" then begin
let line = ref 1 and col = ref 1 in
for i = 0 to s.pos - 1 do
if s.src.[i] = '\n' then (incr line; col := 1) else incr col
done;
raise (Parse_error (Printf.sprintf "Unexpected char: %c at line %d col %d (pos %d)"
s.src.[s.pos] !line !col s.pos))
end;
if token = "" then raise (Parse_error ("Unexpected char: " ^ String.make 1 s.src.[s.pos]));
match token with
| "true" -> Bool true
| "false" -> Bool false
@@ -202,7 +191,7 @@ and read_dict s =
in go ()
(** Parse a string into a list of SX values (AST — comments stripped). *)
(** Parse a string into a list of SX values. *)
let parse_all src =
let s = make_state src in
let results = ref [] in
@@ -215,239 +204,10 @@ let parse_all src =
end
in go ()
(** Parse a file into a list of SX values (AST — comments stripped). *)
(** 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
(* ================================================================== *)
(* CST parser — lossless concrete syntax tree *)
(* ================================================================== *)
open Sx_cst
(** Collect leading trivia (whitespace + comments) from current position. *)
let collect_trivia s =
let items = ref [] in
let rec go () =
if at_end s then ()
else match s.src.[s.pos] with
| ' ' | '\t' | '\n' | '\r' ->
let start = s.pos in
while s.pos < s.len && (let c = s.src.[s.pos] in c = ' ' || c = '\t' || c = '\n' || c = '\r') do
advance s
done;
items := Whitespace (String.sub s.src start (s.pos - start)) :: !items;
go ()
| ';' ->
let start = s.pos in
while s.pos < s.len && s.src.[s.pos] <> '\n' do advance s done;
let text = String.sub s.src start (s.pos - start) in
if s.pos < s.len then advance s;
(* Include the newline in the comment trivia *)
let text = if s.pos > 0 && s.pos <= s.len && s.src.[s.pos - 1] = '\n'
then text ^ "\n" else text in
items := LineComment text :: !items;
go ()
| _ -> ()
in
go ();
List.rev !items
(** Read a single CST value — dispatches on first non-trivia char. *)
let rec read_cst s : cst_node =
let trivia = collect_trivia s in
if at_end s then
raise (Parse_error "Unexpected end of input");
let start = s.pos in
match s.src.[s.pos] with
| '(' -> read_cst_list s trivia start '(' ')'
| '[' -> read_cst_list s trivia start '[' ']'
| '{' -> read_cst_dict s trivia start
| '\'' ->
(* Quote sugar: 'x → (quote x) — emit as raw token *)
advance s;
let inner = read_cst s in
let end_pos = s.pos in
let token = String.sub s.src start (end_pos - start) in
let value = List [Symbol "quote"; cst_to_ast inner] in
CstAtom { leading_trivia = trivia; token; value; span = { start_offset = start; end_offset = end_pos } }
| '`' ->
advance s;
let inner = read_cst s in
let end_pos = s.pos in
let token = String.sub s.src start (end_pos - start) in
let value = List [Symbol "quasiquote"; cst_to_ast inner] in
CstAtom { leading_trivia = trivia; token; value; span = { start_offset = start; end_offset = end_pos } }
| ',' ->
advance s;
let splice = s.pos < s.len && s.src.[s.pos] = '@' in
if splice then advance s;
let inner = read_cst s in
let end_pos = s.pos in
let token = String.sub s.src start (end_pos - start) in
let sym = if splice then "splice-unquote" else "unquote" in
let value = List [Symbol sym; cst_to_ast inner] in
CstAtom { leading_trivia = trivia; token; value; span = { start_offset = start; end_offset = end_pos } }
| '#' when s.pos + 1 < s.len && s.src.[s.pos + 1] = ';' ->
(* Datum comment: #; discards next expression *)
advance s; advance s;
let _discarded = read_cst s in
(* Read the real value after the datum comment — attach trivia from #; *)
let next = read_cst s in
let combined_trivia = trivia @ (match next with
| CstAtom r -> r.leading_trivia
| CstList r -> r.leading_trivia
| CstDict r -> r.leading_trivia) in
(match next with
| CstAtom r -> CstAtom { r with leading_trivia = combined_trivia }
| CstList r -> CstList { r with leading_trivia = combined_trivia }
| CstDict r -> CstDict { r with leading_trivia = combined_trivia })
| '#' when s.pos + 1 < s.len && s.src.[s.pos + 1] = '\'' ->
advance s; advance s;
let inner = read_cst s in
let end_pos = s.pos in
let token = String.sub s.src start (end_pos - start) in
let value = List [Symbol "quote"; cst_to_ast inner] in
CstAtom { leading_trivia = trivia; token; value; span = { start_offset = start; end_offset = end_pos } }
| '#' when s.pos + 1 < s.len && s.src.[s.pos + 1] = '|' ->
(* Raw string: #|...| *)
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 ()
else begin Buffer.add_char buf c; go () end
in
go ();
let end_pos = s.pos in
let token = String.sub s.src start (end_pos - start) in
CstAtom { leading_trivia = trivia; token; value = String (Buffer.contents buf);
span = { start_offset = start; end_offset = end_pos } }
| '"' ->
let value = String (read_string s) in
let end_pos = s.pos in
let token = String.sub s.src start (end_pos - start) in
CstAtom { leading_trivia = trivia; token; value;
span = { start_offset = start; end_offset = end_pos } }
| _ ->
let sym = read_symbol s in
if sym = "" then begin
let line = ref 1 and col = ref 1 in
for i = 0 to s.pos - 1 do
if s.src.[i] = '\n' then (incr line; col := 1) else incr col
done;
raise (Parse_error (Printf.sprintf "Unexpected char: %c at line %d col %d (pos %d)"
s.src.[s.pos] !line !col s.pos))
end;
let end_pos = s.pos in
let token = String.sub s.src start (end_pos - start) in
let value = match sym with
| "true" -> Bool true
| "false" -> Bool false
| "nil" -> Nil
| _ when sym.[0] = ':' -> Keyword (String.sub sym 1 (String.length sym - 1))
| _ -> match try_number sym with Some n -> n | None -> Symbol sym
in
CstAtom { leading_trivia = trivia; token; value;
span = { start_offset = start; end_offset = end_pos } }
and read_cst_list s trivia start open_c close_c =
advance s; (* skip open delim *)
let children = ref [] in
let rec go () =
let child_trivia = collect_trivia s in
if at_end s then raise (Parse_error "Unterminated list");
if s.src.[s.pos] = close_c then begin
advance s;
let end_pos = s.pos in
CstList { leading_trivia = trivia; open_delim = open_c;
children = List.rev !children; close_delim = close_c;
trailing_trivia = child_trivia;
span = { start_offset = start; end_offset = end_pos } }
end else begin
(* Push collected trivia onto the next child *)
let child_start = s.pos in
let child = read_cst_inner s in
let child_with_trivia = match child with
| CstAtom r -> CstAtom { r with leading_trivia = child_trivia @ r.leading_trivia }
| CstList r -> CstList { r with leading_trivia = child_trivia @ r.leading_trivia }
| CstDict r -> CstDict { r with leading_trivia = child_trivia @ r.leading_trivia }
in
ignore child_start;
children := child_with_trivia :: !children;
go ()
end
in
go ()
and read_cst_dict s trivia start =
advance s; (* skip { *)
let children = ref [] in
let rec go () =
let child_trivia = collect_trivia s in
if at_end s then raise (Parse_error "Unterminated dict");
if s.src.[s.pos] = '}' then begin
advance s;
let end_pos = s.pos in
CstDict { leading_trivia = trivia; children = List.rev !children;
trailing_trivia = child_trivia;
span = { start_offset = start; end_offset = end_pos } }
end else begin
let child = read_cst_inner s in
let child_with_trivia = match child with
| CstAtom r -> CstAtom { r with leading_trivia = child_trivia @ r.leading_trivia }
| CstList r -> CstList { r with leading_trivia = child_trivia @ r.leading_trivia }
| CstDict r -> CstDict { r with leading_trivia = child_trivia @ r.leading_trivia }
in
children := child_with_trivia :: !children;
go ()
end
in
go ()
(** Inner read — no trivia collection (caller handles it). *)
and read_cst_inner s : cst_node =
read_cst s
(** Parse result: list of CST nodes + any trailing trivia after the last node. *)
type cst_file = {
nodes : cst_node list;
trailing_trivia : trivia list;
}
(** Parse a string into a list of CST nodes. *)
let parse_all_cst src =
let s = make_state src in
let results = ref [] in
let rec go () =
let trivia = collect_trivia s in
if at_end s then
{ nodes = List.rev !results; trailing_trivia = trivia }
else begin
let node = read_cst_inner s in
(* Prepend collected trivia to this node *)
let node_with_trivia = match node with
| CstAtom r -> CstAtom { r with leading_trivia = trivia @ r.leading_trivia }
| CstList r -> CstList { r with leading_trivia = trivia @ r.leading_trivia }
| CstDict r -> CstDict { r with leading_trivia = trivia @ r.leading_trivia }
in
results := node_with_trivia :: !results;
go ()
end
in
go ()
(** Parse a file into a list of CST nodes. *)
let parse_file_cst 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_cst src

819
hosts/ocaml/lib/sx_primitives.ml
View File

@@ -12,30 +12,6 @@ let _sx_call_fn : (value -> value list -> value) ref =
ref (fun _ _ -> raise (Eval_error "sx_call not initialized"))
let _sx_trampoline_fn : (value -> value) ref =
ref (fun v -> v)
let _is_client : bool ref = ref false
(** Scope stacks — dynamic scope for render-time effects.
Each key maps to a stack of values. Used by aser for
spread/provide/emit patterns, CSSX collect/flush, etc.
Migrated from sx_scope.ml. *)
let _scope_stacks : (string, value list) Hashtbl.t = Hashtbl.create 8
(** Debug trace for scope operations *)
let _scope_trace = ref false
let _scope_log : string list ref = ref []
let scope_trace_enable () = _scope_trace := true; _scope_log := []
let scope_trace_disable () = _scope_trace := false
let scope_trace_drain () =
let log = List.rev !_scope_log in
_scope_log := [];
log
(** Request cookies — set by the Python bridge before each render.
get-cookie reads from here; set-cookie is a no-op on the server. *)
let _request_cookies : (string, string) Hashtbl.t = Hashtbl.create 8
(** Clear all scope stacks. Called between requests if needed. *)
let scope_clear_all () = Hashtbl.clear _scope_stacks
let register name fn = Hashtbl.replace primitives name fn
@@ -48,18 +24,12 @@ let get_primitive name =
(* --- Helpers --- *)
(* Trampoline hook — set by sx_ref after initialization to break circular dep *)
let trampoline_hook : (value -> value) ref = ref (fun v -> v)
let rec as_number = function
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)
| Thunk _ as t ->
(* Trampoline thunks — they shouldn't leak but sometimes do *)
as_number (!trampoline_hook t)
| v -> raise (Eval_error ("Expected number, got " ^ type_of v ^ ": " ^ (match v with Dict d -> (match Hashtbl.find_opt d "__signal" with Some _ -> "signal{value=" ^ (match Hashtbl.find_opt d "value" with Some v' -> value_to_string v' | None -> "?") ^ "}" | None -> "dict") | _ -> "")))
let as_string = function
@@ -77,7 +47,7 @@ let as_bool = function
| Bool b -> b
| v -> sx_truthy v
let rec to_string = function
let to_string = function
| String s -> s
| Number n ->
if Float.is_integer n then string_of_int (int_of_float n)
@@ -87,9 +57,6 @@ let rec to_string = function
| Nil -> ""
| Symbol s -> s
| Keyword k -> k
| Thunk _ as t -> to_string (!trampoline_hook t)
| SxExpr s -> s
| RawHTML s -> s
| v -> inspect v
let () =
@@ -150,53 +117,11 @@ let () =
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 "truncate" (fun args ->
match args with
| [a] -> let n = as_number a in Number (if n >= 0.0 then floor n else ceil n)
| _ -> raise (Eval_error "truncate: 1 arg"));
register "remainder" (fun args ->
match args with
| [a; b] -> Number (Float.rem (as_number a) (as_number b))
| _ -> raise (Eval_error "remainder: 2 args"));
register "modulo" (fun args ->
match args with
| [a; b] ->
let a = as_number a and b = as_number b in
let r = Float.rem a b in
Number (if r = 0.0 || (r > 0.0) = (b > 0.0) then r else r +. b)
| _ -> raise (Eval_error "modulo: 2 args"));
register "exact?" (fun args ->
match args with [Number f] -> Bool (Float.is_integer f) | [_] -> Bool false
| _ -> raise (Eval_error "exact?: 1 arg"));
register "inexact?" (fun args ->
match args with [Number f] -> Bool (not (Float.is_integer f)) | [_] -> Bool false
| _ -> raise (Eval_error "inexact?: 1 arg"));
register "exact->inexact" (fun args ->
match args with [Number n] -> Number n | [a] -> Number (as_number a)
| _ -> raise (Eval_error "exact->inexact: 1 arg"));
register "inexact->exact" (fun args ->
match args with
| [Number n] -> if Float.is_integer n then Number n else Number (Float.round n)
| [a] -> Number (Float.round (as_number a))
| _ -> raise (Eval_error "inexact->exact: 1 arg"));
register "parse-int" (fun args ->
let parse_leading_int s =
let len = String.length s in
let start = ref 0 in
let neg = len > 0 && s.[0] = '-' in
if neg then start := 1
else if len > 0 && s.[0] = '+' then start := 1;
let j = ref !start in
while !j < len && s.[!j] >= '0' && s.[!j] <= '9' do incr j done;
if !j > !start then
let n = int_of_string (String.sub s !start (!j - !start)) in
Some (if neg then -n else n)
else None
in
match args with
| [String s] -> (match parse_leading_int s with Some n -> Number (float_of_int n) | None -> Nil)
| [String s] -> (match int_of_string_opt s with Some n -> Number (float_of_int n) | None -> Nil)
| [String s; default_val] ->
(match parse_leading_int s with Some n -> Number (float_of_int n) | None -> default_val)
(match int_of_string_opt s with Some n -> Number (float_of_int n) | None -> default_val)
| [Number n] | [Number n; _] -> Number (float_of_int (int_of_float n))
| [_; default_val] -> default_val
| _ -> Nil);
@@ -207,55 +132,19 @@ let () =
| _ -> Nil);
(* === Comparison === *)
(* Safe equality: physical equality for potentially-circular types
(Dict, Lambda, Component, Island, Signal, NativeFn),
structural equality for acyclic types (Number, String, Bool, etc.).
Lists are compared element-wise recursively with the same safety. *)
let rec safe_eq a b =
if a == b then true (* physical equality fast path *)
else match a, b with
| Number x, Number y -> x = y
| String x, String y -> x = y
| Bool x, Bool y -> x = y
| Nil, Nil -> true
| Symbol x, Symbol y -> x = y
| Keyword x, Keyword y -> x = y
| (List la | ListRef { contents = la }),
(List lb | ListRef { contents = lb }) ->
List.length la = List.length lb &&
List.for_all2 safe_eq la lb
(* Dict: check __host_handle for DOM node identity *)
| Dict a, Dict b ->
(match Hashtbl.find_opt a "__host_handle", Hashtbl.find_opt b "__host_handle" with
| Some (Number ha), Some (Number hb) -> ha = hb
| _ -> false)
(* Records: same type + structurally equal fields *)
| Record a, Record b ->
a.r_type.rt_uid = b.r_type.rt_uid &&
Array.length a.r_fields = Array.length b.r_fields &&
(let eq = ref true in
for i = 0 to Array.length a.r_fields - 1 do
if not (safe_eq a.r_fields.(i) b.r_fields.(i)) then eq := false
done; !eq)
(* Parameters: same UID = same parameter *)
| Parameter a, Parameter b -> a.pm_uid = b.pm_uid
(* Vectors: same length + element-wise equal *)
| Vector a, Vector b ->
Array.length a = Array.length b &&
(let eq = ref true in
for i = 0 to Array.length a - 1 do
if not (safe_eq a.(i) b.(i)) then eq := false
done; !eq)
(* Lambda/Component/Island/Signal/NativeFn: physical only *)
| _ -> false
(* 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 (safe_eq a b)
| [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 (not (safe_eq a b))
| [a; b] -> Bool (normalize_for_eq a <> normalize_for_eq b)
| _ -> raise (Eval_error "!=: 2 args"));
register "<" (fun args ->
match args with
@@ -287,8 +176,6 @@ let () =
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 "integer?" (fun args ->
match args with [Number f] -> Bool (Float.is_integer f) | [_] -> Bool false | _ -> raise (Eval_error "integer?: 1 arg"));
register "string?" (fun args ->
match args with [String _] -> Bool true | [_] -> Bool false | _ -> raise (Eval_error "string?: 1 arg"));
register "boolean?" (fun args ->
@@ -362,17 +249,7 @@ let () =
else if String.sub haystack i nl = needle then Number (float_of_int i)
else find (i + 1)
in find 0
| [List items; target] | [ListRef { contents = items }; target] ->
let eq a b = match a, b with
| String x, String y -> x = y | Number x, Number y -> x = y
| Symbol x, Symbol y -> x = y | Keyword x, Keyword y -> x = y
| Bool x, Bool y -> x = y | Nil, Nil -> true | _ -> a == b in
let rec find i = function
| [] -> Nil
| h :: _ when eq h target -> Number (float_of_int i)
| _ :: tl -> find (i + 1) tl
in find 0 items
| _ -> raise (Eval_error "index-of: 2 string args or list+target"));
| _ -> raise (Eval_error "index-of: 2 string args"));
register "substring" (fun args ->
match args with
| [String s; Number start; Number end_] ->
@@ -398,12 +275,7 @@ let () =
register "split" (fun args ->
match args with
| [String s; String sep] ->
if String.length sep = 1 then
List (List.map (fun p -> String p) (String.split_on_char sep.[0] s))
else
(* Multi-char separator: use Re for literal split *)
let re = Re.compile (Re.str sep) in
List (List.map (fun p -> String p) (Re.split re s))
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
@@ -446,94 +318,6 @@ let () =
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"));
register "char-at" (fun args ->
match args with
| [String s; Number n] ->
let i = int_of_float n in
if i >= 0 && i < String.length s then
String (String.make 1 s.[i])
else Nil
| _ -> raise (Eval_error "char-at: string and index"));
register "char-code" (fun args ->
match args with
| [String s] when String.length s > 0 -> Number (float_of_int (Char.code s.[0]))
| _ -> raise (Eval_error "char-code: 1 non-empty string arg"));
register "parse-number" (fun args ->
match args with
| [String s] ->
(try Number (float_of_string s)
with Failure _ -> Nil)
| _ -> raise (Eval_error "parse-number: 1 string arg"));
(* === Regex (PCRE-compatible — same syntax as JS RegExp) === *)
register "regex-match" (fun args ->
match args with
| [String pattern; String input] ->
(try
let re = Re.Pcre.re pattern |> Re.compile in
match Re.exec_opt re input with
| Some group ->
let full = Re.Group.get group 0 in
let n = Re.Group.nb_groups group in
let groups = ref [String full] in
for i = 1 to n - 1 do
(try groups := !groups @ [String (Re.Group.get group i)]
with Not_found -> groups := !groups @ [Nil])
done;
List !groups
| None -> Nil
with _ -> Nil)
| _ -> raise (Eval_error "regex-match: pattern and input strings"));
register "regex-match?" (fun args ->
match args with
| [String pattern; String input] ->
(try Bool (Re.execp (Re.Pcre.re pattern |> Re.compile) input)
with _ -> Bool false)
| _ -> raise (Eval_error "regex-match?: pattern and input strings"));
register "regex-find-all" (fun args ->
match args with
| [String pattern; String input] ->
(try
let re = Re.Pcre.re pattern |> Re.compile in
let matches = Re.all re input in
let results = List.map (fun group ->
(* If there's a capture group, return group 1; else full match *)
try String (Re.Group.get group 1)
with Not_found -> String (Re.Group.get group 0)
) matches in
ListRef (ref results)
with _ -> ListRef (ref []))
| _ -> raise (Eval_error "regex-find-all: pattern and input strings"));
register "regex-replace" (fun args ->
match args with
| [String pattern; String replacement; String input] ->
(try
let re = Re.Pcre.re pattern |> Re.compile in
String (Re.replace_string re ~by:replacement input)
with _ -> String input)
| _ -> raise (Eval_error "regex-replace: pattern, replacement, input strings"));
register "regex-replace-first" (fun args ->
match args with
| [String pattern; String replacement; String input] ->
(try
let re = Re.Pcre.re pattern |> Re.compile in
(* Re doesn't have replace_first, so use all matches and replace only first *)
match Re.exec_opt re input with
| Some group ->
let start = Re.Group.start group 0 and stop = Re.Group.stop group 0 in
String (String.sub input 0 start ^ replacement ^
String.sub input stop (String.length input - stop))
| None -> String input
with _ -> String input)
| _ -> raise (Eval_error "regex-replace-first: pattern, replacement, input strings"));
register "regex-split" (fun args ->
match args with
| [String pattern; String input] ->
(try
let re = Re.Pcre.re pattern |> Re.compile in
ListRef (ref (List.map (fun s -> String s) (Re.split re input)))
with _ -> ListRef (ref [String input]))
| _ -> raise (Eval_error "regex-split: pattern and input strings"));
(* === Collections === *)
register "list" (fun args -> ListRef (ref args));
@@ -552,12 +336,10 @@ let () =
| [Macro _] | [Thunk _] | [Keyword _] | [Symbol _] -> Number 0.0
| _ -> raise (Eval_error (Printf.sprintf "len: %d args"
(List.length args))));
register "length" (Hashtbl.find primitives "len");
register "first" (fun args ->
match args with
| [List (x :: _)] | [ListRef { contents = x :: _ }] -> x
| [List []] | [ListRef { contents = [] }] -> Nil | [Nil] -> Nil
| [x] -> raise (Eval_error ("first: expected list, got " ^ inspect x))
| _ -> raise (Eval_error "first: 1 list arg"));
register "rest" (fun args ->
match args with
@@ -599,11 +381,6 @@ let () =
| _ ->
let all = List.concat_map as_list args in
List all);
register "append!" (fun args ->
match args with
| [ListRef r; item] -> r := !r @ [item]; ListRef r
| [List items; item] -> List (items @ [item])
| _ -> raise (Eval_error "append!: list and item"));
register "reverse" (fun args ->
match args with
| [List l] | [ListRef { contents = l }] -> List (List.rev l)
@@ -619,25 +396,7 @@ let () =
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] ->
(* Physical equality first (handles signals/dicts/closures safely),
structural fallback only for acyclic types (string/number/bool/nil/symbol/keyword) *)
let safe_eq a b =
a == b ||
(match a, b with
| Number x, Number y -> x = y
| String x, String y -> x = y
| Bool x, Bool y -> x = y
| Nil, Nil -> true
| Symbol x, Symbol y -> x = y
| Keyword x, Keyword y -> x = y
| Dict a, Dict b ->
(match Hashtbl.find_opt a "__host_handle", Hashtbl.find_opt b "__host_handle" with
| Some (Number ha), Some (Number hb) -> ha = hb
| _ -> false)
| _ -> false)
in
Bool (List.exists (fun x -> safe_eq x item) l)
| [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
@@ -849,24 +608,6 @@ let () =
match args with [a] -> String (inspect a) | _ -> raise (Eval_error "inspect: 1 arg"));
register "serialize" (fun args ->
match args with
| [SxExpr s] -> String s
| [RawHTML s] -> String s
| [Spread pairs] ->
(* Serialize spread values as (make-spread {:key "val" ...}) *)
let dict_parts = List.map (fun (k, v) ->
Printf.sprintf ":%s %s" k (inspect v)) pairs in
String (Printf.sprintf "(make-spread {%s})" (String.concat " " dict_parts))
| [Component c] ->
(* Serialize component values as their ~name reference *)
String (Printf.sprintf "~%s" c.c_name)
| [Island i] ->
String (Printf.sprintf "~%s" i.i_name)
| [Lambda _] -> String "<lambda>"
| [Record r] -> String (Printf.sprintf "#<%s>" r.r_type.rt_name)
| [Parameter p] -> String (Printf.sprintf "#<parameter %s>" p.pm_uid)
| [Vector arr] ->
let elts = Array.to_list (Array.map (fun v -> inspect v) arr) in
String (Printf.sprintf "#(%s)" (String.concat " " elts))
| [a] -> String (inspect a) (* used for dedup keys in compiler *)
| _ -> raise (Eval_error "serialize: 1 arg"));
register "make-symbol" (fun args ->
@@ -877,68 +618,10 @@ let () =
match args with [String msg] -> raise (Eval_error msg)
| [a] -> raise (Eval_error (to_string a))
| _ -> raise (Eval_error "error: 1 arg"));
register "host-error" (fun args ->
match args with [String msg] -> raise (Eval_error msg)
| [a] -> raise (Eval_error (to_string a))
| _ -> raise (Eval_error "host-error: 1 arg"));
register "try-catch" (fun args ->
match args with
| [try_fn; catch_fn] ->
(try !_sx_trampoline_fn (!_sx_call_fn try_fn [])
with Eval_error msg ->
!_sx_trampoline_fn (!_sx_call_fn catch_fn [String msg]))
| _ -> raise (Eval_error "try-catch: expected (try-fn catch-fn)"));
(* client? — false by default (server); sx_browser.ml sets _is_client := true *)
register "client?" (fun _args -> Bool !_is_client);
(* Named stores — global mutable registry, bypasses env scoping issues *)
let store_registry : (string, value) Hashtbl.t = Hashtbl.create 16 in
register "def-store" (fun args ->
match args with
| [String name; init_fn] ->
if not (Hashtbl.mem store_registry name) then begin
let store = !_sx_trampoline_fn (!_sx_call_fn init_fn []) in
Hashtbl.replace store_registry name store
end;
(match Hashtbl.find_opt store_registry name with Some v -> v | None -> Nil)
| _ -> raise (Eval_error "def-store: expected (name init-fn)"));
register "use-store" (fun args ->
match args with
| [String name] ->
(match Hashtbl.find_opt store_registry name with
| Some v -> v
| None -> raise (Eval_error ("Store not found: " ^ name)))
| _ -> raise (Eval_error "use-store: expected (name)"));
register "clear-stores" (fun _args -> Hashtbl.clear store_registry; Nil);
(* SSR stubs — resource returns loading state on server.
NOTE: effect and register-in-scope must NOT be registered as primitives
here — the bytecode compiler uses primitive? to decide CALL_PRIM vs
GLOBAL_GET+CALL. If effect is a primitive, bytecoded modules emit
CALL_PRIM which returns Nil instead of calling the real effect function
from core-signals.sx. The server overrides effect in sx_server.ml via
env_bind AFTER compilation. *)
(* register "effect" — REMOVED: see note above *)
(* register "register-in-scope" — REMOVED: see note above *)
(* resource — SSR stub: return signal with {loading: true}, client hydrates real fetch *)
register "resource" (fun _args ->
let state = Hashtbl.create 8 in
Hashtbl.replace state "loading" (Bool true);
Hashtbl.replace state "data" Nil;
Hashtbl.replace state "error" Nil;
let sig_d = Hashtbl.create 8 in
Hashtbl.replace sig_d "__signal" (Bool true);
Hashtbl.replace sig_d "value" (Dict state);
Hashtbl.replace sig_d "subscribers" (List []);
Hashtbl.replace sig_d "deps" (List []);
Dict sig_d);
register "apply" (fun args ->
let call f a =
match f with
| NativeFn (_, fn) -> fn a
| _ -> !_sx_trampoline_fn (!_sx_call_fn f a)
in
match args with
| [f; (List a | ListRef { contents = a })] -> call f a
| [f; Nil] -> call f []
| [NativeFn (_, f); (List a | ListRef { contents = a })] -> f a
| [NativeFn (_, f); Nil] -> f []
| _ -> raise (Eval_error "apply: function and list"));
register "identical?" (fun args ->
match args with [a; b] -> Bool (a == b) | _ -> raise (Eval_error "identical?: 2 args"));
@@ -1002,12 +685,8 @@ let () =
register "some" (fun args ->
match args with
| [f; (List items | ListRef { contents = items })] ->
let rec find = function
| [] -> Bool false
| x :: rest ->
let result = call_any f [x] in
if sx_truthy result then result else find rest
in find items
(try List.find (fun x -> sx_truthy (call_any f [x])) items
with Not_found -> Bool false)
| [_; Nil] -> Bool false
| _ -> raise (Eval_error "some: expected (fn list)"));
register "every?" (fun args ->
@@ -1056,167 +735,11 @@ let () =
match args with [Lambda _] -> Bool true | _ -> Bool false);
register "island?" (fun args ->
match args with [Island _] -> Bool true | _ -> Bool false);
(* R7RS records *)
register "record?" (fun args ->
match args with [v] -> record_p v | _ -> Bool false);
register "make-rtd" (fun args ->
match args with [name; fields; ctor_params] -> make_rtd name fields ctor_params
| _ -> raise (Eval_error "make-rtd: expected (name fields ctor-params)"));
register "make-record" (fun args ->
match args with [uid; arg_list] -> make_record uid arg_list
| _ -> raise (Eval_error "make-record: expected (uid args-list)"));
register "record-ref" (fun args ->
match args with [v; idx] -> record_ref v idx
| _ -> raise (Eval_error "record-ref: expected (record index)"));
register "record-set!" (fun args ->
match args with [v; idx; nv] -> record_set_b v idx nv
| _ -> raise (Eval_error "record-set!: expected (record index value)"));
register "record-type?" (fun args ->
match args with [v; uid] -> record_type_p v uid | _ -> Bool false);
register "make-record-constructor" (fun args ->
match args with [uid] -> make_record_constructor uid
| _ -> raise (Eval_error "make-record-constructor: expected (uid)"));
register "make-record-predicate" (fun args ->
match args with [uid] -> make_record_predicate uid
| _ -> raise (Eval_error "make-record-predicate: expected (uid)"));
register "make-record-accessor" (fun args ->
match args with [idx] -> make_record_accessor idx
| _ -> raise (Eval_error "make-record-accessor: expected (index)"));
register "make-record-mutator" (fun args ->
match args with [idx] -> make_record_mutator idx
| _ -> raise (Eval_error "make-record-mutator: expected (index)"));
(* R7RS parameters — converter stored, applied by parameterize frame *)
register "make-parameter" (fun args ->
match args with
| [init] ->
let uid = !param_counter in
incr param_counter;
Parameter { pm_uid = "__param_" ^ string_of_int uid;
pm_default = init; pm_converter = None }
| [init; converter] ->
let uid = !param_counter in
incr param_counter;
(* Apply converter to init for NativeFn, store raw for Lambda *)
let converted = match converter with
| NativeFn (_, f) -> f [init]
| _ -> init (* Lambda converters applied via CEK at parameterize time *)
in
Parameter { pm_uid = "__param_" ^ string_of_int uid;
pm_default = converted; pm_converter = Some converter }
| _ -> raise (Eval_error "make-parameter: expected 1-2 args"));
register "parameter?" (fun args ->
match args with [Parameter _] -> Bool true | [_] -> Bool false
| _ -> Bool false);
register "parameter-uid" (fun args ->
match args with [Parameter p] -> String p.pm_uid
| _ -> raise (Eval_error "parameter-uid: expected parameter"));
register "parameter-default" (fun args ->
match args with [Parameter p] -> p.pm_default
| _ -> raise (Eval_error "parameter-default: expected parameter"));
register "parameter-converter" (fun args ->
match args with
| [Parameter p] -> (match p.pm_converter with Some c -> c | None -> Nil)
| _ -> raise (Eval_error "parameter-converter: expected parameter"));
(* R7RS vectors — mutable fixed-size arrays *)
register "make-vector" (fun args ->
match args with
| [Number n] -> Vector (Array.make (int_of_float n) Nil)
| [Number n; fill] -> Vector (Array.make (int_of_float n) fill)
| _ -> raise (Eval_error "make-vector: expected (length) or (length fill)"));
register "vector" (fun args -> Vector (Array.of_list args));
register "vector?" (fun args ->
match args with [Vector _] -> Bool true | [_] -> Bool false
| _ -> raise (Eval_error "vector?: 1 arg"));
register "vector-length" (fun args ->
match args with [Vector arr] -> Number (float_of_int (Array.length arr))
| _ -> raise (Eval_error "vector-length: expected vector"));
register "vector-ref" (fun args ->
match args with
| [Vector arr; Number n] -> arr.(int_of_float n)
| _ -> raise (Eval_error "vector-ref: expected (vector index)"));
register "vector-set!" (fun args ->
match args with
| [Vector arr; Number n; v] -> arr.(int_of_float n) <- v; Nil
| _ -> raise (Eval_error "vector-set!: expected (vector index value)"));
register "vector->list" (fun args ->
match args with [Vector arr] -> List (Array.to_list arr)
| _ -> raise (Eval_error "vector->list: expected vector"));
register "list->vector" (fun args ->
match args with
| [List l] -> Vector (Array.of_list l)
| [ListRef { contents = l }] -> Vector (Array.of_list l)
| _ -> raise (Eval_error "list->vector: expected list"));
register "vector-fill!" (fun args ->
match args with
| [Vector arr; v] -> Array.fill arr 0 (Array.length arr) v; Nil
| _ -> raise (Eval_error "vector-fill!: expected (vector value)"));
register "vector-copy" (fun args ->
match args with [Vector arr] -> Vector (Array.copy arr)
| _ -> raise (Eval_error "vector-copy: expected vector"));
(* Capability-based sandboxing — gate IO operations *)
let cap_stack : string list ref = ref [] in
register "with-capabilities" (fun args ->
match args with
| [List caps; body] ->
let cap_set = List.filter_map (fun v -> match v with
| Symbol s | String s | Keyword s -> Some s | _ -> None) caps in
let prev = !cap_stack in
cap_stack := cap_set;
(match body with
| Lambda _ | NativeFn _ | VmClosure _ ->
let result = (try !Sx_types._cek_call_ref body Nil
with exn -> cap_stack := prev; raise exn) in
cap_stack := prev; result
| _ -> cap_stack := prev; body)
| [ListRef { contents = caps }; body] ->
(* Handle mutable lists too *)
let cap_set = List.filter_map (fun v -> match v with
| Symbol s | String s | Keyword s -> Some s | _ -> None) caps in
let prev = !cap_stack in
cap_stack := cap_set;
(match body with
| Lambda _ | NativeFn _ | VmClosure _ ->
let result = (try !Sx_types._cek_call_ref body Nil
with exn -> cap_stack := prev; raise exn) in
cap_stack := prev; result
| _ -> cap_stack := prev; body)
| _ -> raise (Eval_error "with-capabilities: expected (cap-list body-fn)"));
register "current-capabilities" (fun _args ->
if !cap_stack = [] then Nil
else List (List.map (fun s -> String s) !cap_stack));
register "has-capability?" (fun args ->
match args with
| [String cap] | [Keyword cap] | [Symbol cap] ->
if !cap_stack = [] then Bool true (* unrestricted *)
else Bool (List.mem cap !cap_stack)
| _ -> Bool true);
register "require-capability!" (fun args ->
match args with
| [String cap] | [Keyword cap] | [Symbol cap] ->
if !cap_stack = [] then Nil (* unrestricted *)
else if List.mem cap !cap_stack then Nil
else raise (Eval_error (Printf.sprintf
"Capability '%s' not available. Current capabilities: [%s]"
cap (String.concat ", " !cap_stack)))
| _ -> Nil);
register "capability-restricted?" (fun _args ->
Bool (!cap_stack <> []));
register "is-else-clause?" (fun args ->
match args with
| [Keyword "else"] -> Bool true
| [Bool true] -> Bool true
| _ -> Bool false);
register "cond-scheme?" (fun args ->
match args with
| [List clauses] ->
Bool (List.for_all (fun c ->
match c with
| List l -> List.length l = 2
| _ -> false) clauses)
| _ -> Bool false);
register "component?" (fun args ->
match args with [Component _] -> Bool true | [Island _] -> Bool true | _ -> Bool false);
register "lambda-closure" (fun args ->
@@ -1246,10 +769,6 @@ let () =
| [Component c] -> c.c_body
| [Island i] -> i.i_body
| _ -> Nil);
register "component-file" (fun args ->
match args with [v] -> component_file v | _ -> Nil);
register "component-set-file!" (fun args ->
match args with [v; f] -> component_set_file v f | _ -> Nil);
register "macro?" (fun args ->
match args with [Macro _] -> Bool true | _ -> Bool false);
register "for-each-indexed" (fun args ->
@@ -1291,304 +810,4 @@ let () =
| Some fn -> fn []
| None -> raise (Eval_error ("VM undefined: " ^ name)))
| _ -> raise (Eval_error "call-primitive: expected (name args-list)"));
();
(* ================================================================ *)
(* Scope stacks — dynamic scope for render-time effects. *)
(* Migrated from sx_scope.ml — Phase 1 of step 5.5 *)
(* ================================================================ *)
(* --- Cookies --- *)
register "get-cookie" (fun args ->
match args with
| [String name] ->
(match Hashtbl.find_opt _request_cookies name with
| Some v -> String v
| None -> Nil)
| _ -> Nil);
register "set-cookie" (fun _args -> Nil);
(* --- Core scope stack operations --- *)
register "scope-push!" (fun args ->
match args with
| [String name; value] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
if !_scope_trace then
_scope_log := Printf.sprintf "PUSH %s depth=%d->%d" name (List.length stack) (List.length stack + 1) :: !_scope_log;
Hashtbl.replace _scope_stacks name (value :: stack); Nil
| _ -> Nil);
register "scope-pop!" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
if !_scope_trace then
_scope_log := Printf.sprintf "POP %s depth=%d->%d" name (List.length stack) (max 0 (List.length stack - 1)) :: !_scope_log;
(match stack with _ :: rest -> Hashtbl.replace _scope_stacks name rest | [] -> ()); Nil
| _ -> Nil);
register "scope-peek" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
if !_scope_trace then
_scope_log := Printf.sprintf "PEEK %s depth=%d found=%b" name (List.length stack) (stack <> []) :: !_scope_log;
(match stack with v :: _ -> v | [] -> Nil)
| _ -> Nil);
(* --- Context (scope lookup with optional default) --- *)
register "context" (fun args ->
match args with
| (String name) :: rest ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
if !_scope_trace then
_scope_log := Printf.sprintf "CTX %s depth=%d found=%b" name (List.length stack) (stack <> []) :: !_scope_log;
(match stack with
| v :: _ -> v
| [] -> (match rest with default_val :: _ -> default_val | [] -> Nil))
| _ -> Nil);
register "context-debug" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
let all_keys = Hashtbl.fold (fun k _ acc -> k :: acc) _scope_stacks [] in
String (Printf.sprintf "name=%s stack_len=%d all_keys=[%s]"
name (List.length stack) (String.concat "," all_keys))
| _ -> String "bad args");
(* --- Collect / collected / clear-collected! --- *)
register "collect!" (fun args ->
match args with
| [String name; value] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with
| List items :: rest ->
if not (List.mem value items) then
Hashtbl.replace _scope_stacks name (List (items @ [value]) :: rest)
| [] ->
Hashtbl.replace _scope_stacks name [List [value]]
| _ :: _ -> ());
Nil
| _ -> Nil);
register "collected" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with List items :: _ -> List items | _ -> List [])
| _ -> List []);
register "clear-collected!" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with
| _ :: rest -> Hashtbl.replace _scope_stacks name (List [] :: rest)
| [] -> Hashtbl.replace _scope_stacks name [List []]);
Nil
| _ -> Nil);
(* --- Unified reactive model (Step 10c) ---
provide wraps value in a Signal (reactive cell).
context unwraps the signal + registers in tracking context.
peek unwraps without tracking.
provide! mutates the signal and notifies subscribers. *)
let _tracking_active : bool ref = ref false in
let _tracking_deps : value list ref = ref [] in
register "provide-reactive!" (fun args ->
match args with
| [String name; value] ->
let sig' = { s_value = value; s_subscribers = []; s_deps = [] } in
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
Hashtbl.replace _scope_stacks name (Signal sig' :: stack); Nil
| _ -> raise (Eval_error "provide-reactive!: expected (name value)"));
register "provide-pop-reactive!" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with _ :: rest -> Hashtbl.replace _scope_stacks name rest | [] -> ()); Nil
| _ -> Nil);
register "provide-set!" (fun args ->
match args with
| [String name; new_value] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with
| Signal sig' :: _ ->
sig'.s_value <- new_value;
List.iter (fun sub -> sub ()) sig'.s_subscribers;
Nil
| _ -> raise (Eval_error (Printf.sprintf
"provide-set!: '%s' is not a reactive provide" name)))
| _ -> raise (Eval_error "provide-set!: expected (name new-value)"));
register "peek" (fun args ->
match args with
| (String name) :: _ ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with
| Signal sig' :: _ -> sig'.s_value
| v :: _ -> v
| [] -> Nil)
| _ -> raise (Eval_error "peek: expected (name)"));
register "tracking-start!" (fun _args ->
_tracking_active := true; _tracking_deps := []; Nil);
register "tracking-stop!" (fun _args ->
_tracking_active := false;
let deps = !_tracking_deps in
_tracking_deps := [];
List deps);
register "tracking-active?" (fun _args ->
Bool !_tracking_active);
(* Override context to be tracking-aware *)
Hashtbl.remove primitives "context";
register "context" (fun args ->
match args with
| (String name) :: rest ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with
| Signal sig' :: _ ->
(* Register in tracking context if active *)
if !_tracking_active then begin
if not (List.memq (Signal sig') !_tracking_deps) then
_tracking_deps := Signal sig' :: !_tracking_deps
end;
sig'.s_value
| v :: _ -> v
| [] -> (match rest with default_val :: _ -> default_val | [] -> Nil))
| _ -> Nil);
(* tracking-register-scope! — explicitly register a reactive provide as a dep *)
register "tracking-register-scope!" (fun args ->
match args with
| [String name] ->
if !_tracking_active then begin
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
match stack with
| Signal sig' :: _ ->
if not (List.memq (Signal sig') !_tracking_deps) then
_tracking_deps := Signal sig' :: !_tracking_deps;
Nil
| _ -> Nil
end else Nil
| _ -> Nil);
(* deref — unwrap a signal value with reactive dependency tracking.
If value is a Signal, returns s_value and registers in tracking context.
Otherwise returns value as-is. *)
register "deref" (fun args ->
match args with
| [Signal sig'] ->
if !_tracking_active then begin
if not (List.memq (Signal sig') !_tracking_deps) then
_tracking_deps := Signal sig' :: !_tracking_deps
end;
sig'.s_value
| [v] -> v
| _ -> Nil);
(* bind — create a tracked computation. Takes a body-fn (lambda).
Starts tracking, evaluates body, collects deps, subscribes.
On dep change: unsubscribes, re-evaluates, re-subscribes.
Returns initial value. Optional update-fn called with new values. *)
register "bind" (fun args ->
match args with
| [body_fn] | [body_fn; _] ->
let update_fn = match args with [_; u] -> Some u | _ -> None in
let disposers : (unit -> unit) list ref = ref [] in
let rec run_tracked () =
(* Clean up previous subscriptions *)
List.iter (fun d -> d ()) !disposers;
disposers := [];
(* Start tracking *)
_tracking_active := true;
_tracking_deps := [];
(* Evaluate body *)
let result = !Sx_types._cek_call_ref body_fn Nil in
(* Collect deps *)
let deps = !_tracking_deps in
_tracking_active := false;
_tracking_deps := [];
(* Subscribe to each dep *)
List.iter (fun dep ->
match dep with
| Signal sig' ->
let subscriber = (fun () ->
let new_result = run_tracked () in
match update_fn with
| Some f -> ignore (!Sx_types._cek_call_ref f (List [new_result]))
| None -> ()
) in
sig'.s_subscribers <- subscriber :: sig'.s_subscribers;
disposers := (fun () ->
sig'.s_subscribers <- List.filter (fun s -> s != subscriber) sig'.s_subscribers
) :: !disposers
| _ -> ()
) deps;
result
in
run_tracked ()
| _ -> raise (Eval_error "bind: expected (body-fn) or (body-fn update-fn)"));
(* --- Emit / emitted --- *)
register "scope-emit!" (fun args ->
match args with
| [String name; value] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with
| List items :: rest ->
Hashtbl.replace _scope_stacks name (List (items @ [value]) :: rest)
| Nil :: rest ->
Hashtbl.replace _scope_stacks name (List [value] :: rest)
| [] ->
Hashtbl.replace _scope_stacks name [List [value]]
| _ :: _ -> ());
Nil
| _ -> Nil);
register "emit!" (fun args ->
match Hashtbl.find_opt primitives "scope-emit!" with
| Some fn -> fn args | None -> Nil);
register "emitted" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find _scope_stacks name with Not_found -> [] in
(match stack with List items :: _ -> List items | _ -> List [])
| _ -> List []);
register "scope-emitted" (fun args ->
match Hashtbl.find_opt primitives "emitted" with
| Some fn -> fn args | None -> List []);
register "scope-collected" (fun args ->
match Hashtbl.find_opt primitives "collected" with
| Some fn -> fn args | None -> List []);
register "scope-clear-collected!" (fun args ->
match Hashtbl.find_opt primitives "clear-collected!" with
| Some fn -> fn args | None -> Nil);
(* --- Provide aliases --- *)
register "provide-push!" (fun args ->
match Hashtbl.find_opt primitives "scope-push!" with
| Some fn -> fn args | None -> Nil);
register "provide-pop!" (fun args ->
match Hashtbl.find_opt primitives "scope-pop!" with
| Some fn -> fn args | None -> Nil)
()

534
hosts/ocaml/lib/sx_ref.ml
View File

File diff suppressed because one or more lines are too long

673
hosts/ocaml/lib/sx_render.ml
View File

File diff suppressed because one or more lines are too long

215
hosts/ocaml/lib/sx_runtime.ml
View File

@@ -50,14 +50,7 @@ let sx_call f args =
Thunk (l.l_body, local)
| Continuation (k, _) ->
k (match args with x :: _ -> x | [] -> Nil)
| CallccContinuation _ ->
raise (Eval_error "callcc continuations must be invoked through the CEK machine")
| _ ->
let nargs = List.length args in
let args_preview = if nargs = 0 then "" else
let s = String.concat ", " (List.map (fun a -> let s = inspect a in if String.length s > 40 then String.sub s 0 40 ^ ".." else s) args) in
" with args=[" ^ s ^ "]" in
raise (Eval_error ("Not callable: " ^ inspect f ^ args_preview))
| _ -> raise (Eval_error ("Not callable: " ^ inspect f))
(* Initialize forward ref so primitives can call SX functions *)
let () = Sx_primitives._sx_call_fn := sx_call
@@ -67,28 +60,6 @@ let () = Sx_primitives._sx_call_fn := sx_call
let sx_apply f args_list =
sx_call f (sx_to_list args_list)
(** CEK-safe apply — catches Eval_error from native fns and returns an error
marker dict instead of raising. The CEK evaluator checks for this and
converts to a raise-eval state so guard/handler-bind can intercept it.
Non-native calls (lambda, continuation) delegate to sx_apply unchanged. *)
let sx_apply_cek f args_list =
match f with
| NativeFn _ | VmClosure _ ->
(try sx_apply f args_list
with Eval_error msg ->
let d = Hashtbl.create 3 in
Hashtbl.replace d "__eval_error__" (Bool true);
Hashtbl.replace d "message" (String msg);
Dict d)
| _ -> sx_apply f args_list
(** Check if a value is an eval-error marker from sx_apply_cek. *)
let is_eval_error v =
match v with
| Dict d -> (match Hashtbl.find_opt d "__eval_error__" with
| Some (Bool true) -> true | _ -> false)
| _ -> false
(** 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 =
@@ -102,25 +73,6 @@ 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
| CekFrame f, String key ->
(match key with
| "value" | "extra" | "ho-type" | "scheme" | "indexed"
| "phase" | "has-effects" | "match-val" | "current-item"
| "update-fn" | "head-name" -> f.cf_extra <- v; v
| "remaining" -> f.cf_remaining <- v; v
| "subscribers" | "results" | "raw-args" -> f.cf_results <- v; v
| "emitted" | "effect-list" | "first-render" | "extra2" -> f.cf_extra2 <- v; v
| _ -> raise (Eval_error ("dict-set! cek-frame: unknown field " ^ key)))
| VmFrame f, String key ->
(match key with
| "ip" -> f.vf_ip <- val_to_int v; v
| _ -> raise (Eval_error ("dict-set! vm-frame: unknown field " ^ key)))
| VmMachine m, String key ->
(match key with
| "sp" -> m.vm_sp <- val_to_int v; v
| "frames" -> m.vm_frames <- (match v with List l -> List.map (fun x -> match x with VmFrame f -> f | _ -> raise (Eval_error "vm: frames must be vm-frame list")) l | _ -> []); v
| "stack" -> (match v with List _ -> v | _ -> raise (Eval_error "vm: stack must be array"))
| _ -> raise (Eval_error ("dict-set! vm-machine: unknown field " ^ key)))
| _ -> raise (Eval_error "dict-set!: expected dict and string key")
(** Get from dict or list. *)
@@ -145,56 +97,7 @@ let get_val container key =
| "match-val" -> f.cf_extra | "current-item" -> f.cf_extra
| "update-fn" -> f.cf_extra | "head-name" -> f.cf_extra
| "emitted" -> f.cf_extra2 | "effect-list" -> f.cf_extra2
| "first-render" -> f.cf_extra2 | "file" -> f.cf_env
| "extra" -> f.cf_extra | "extra2" -> f.cf_extra2
| "subscribers" -> f.cf_results
| "prev-tracking" -> f.cf_extra
| _ -> Nil)
| VmFrame f, String k ->
(match k with
| "ip" -> Number (float_of_int f.vf_ip)
| "closure" -> VmClosure f.vf_closure
| "base" -> Number (float_of_int f.vf_base)
| "local-cells" -> Nil (* opaque — accessed via frame-local-get/set *)
| _ -> Nil)
| VmMachine m, String k ->
(match k with
| "sp" -> Number (float_of_int m.vm_sp)
| "stack" -> Nil (* opaque — accessed via vm-push/pop *)
| "frames" -> List (List.map (fun f -> VmFrame f) m.vm_frames)
| "globals" -> Dict m.vm_globals
| _ -> Nil)
| VmClosure cl, String k ->
(match k with
| "vm-code" ->
(* Return vm_code fields as a Dict. The bytecode and constants arrays
are lazily converted to Lists and cached on the vm_code record so
the transpiled VM loop (which re-derives bc/consts each iteration)
doesn't allocate on every step. *)
let c = cl.vm_code in
let bc = match c.vc_bytecode_list with
| Some l -> l
| None ->
let l = Array.to_list (Array.map (fun i -> Number (float_of_int i)) c.vc_bytecode) in
c.vc_bytecode_list <- Some l; l in
let consts = match c.vc_constants_list with
| Some l -> l
| None ->
let l = Array.to_list c.vc_constants in
c.vc_constants_list <- Some l; l in
let d = Hashtbl.create 4 in
Hashtbl.replace d "vc-bytecode" (List bc);
Hashtbl.replace d "vc-constants" (List consts);
Hashtbl.replace d "vc-arity" (Number (float_of_int c.vc_arity));
Hashtbl.replace d "vc-locals" (Number (float_of_int c.vc_locals));
Dict d
| "vm-upvalues" ->
List (Array.to_list (Array.map (fun uv -> uv.uv_value) cl.vm_upvalues))
| "vm-name" ->
(match cl.vm_name with Some n -> String n | None -> Nil)
| "vm-globals" -> Dict cl.vm_env_ref
| "vm-closure-env" ->
(match cl.vm_closure_env with Some e -> Env e | None -> Nil)
| "first-render" -> f.cf_extra2
| _ -> Nil)
| Dict d, String k -> dict_get d k
| Dict d, Keyword k -> dict_get d k
@@ -244,18 +147,29 @@ 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 keyword_p a = _prim "keyword?" [a]
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)
@@ -267,7 +181,10 @@ 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]
@@ -277,6 +194,7 @@ 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 *)
@@ -289,6 +207,8 @@ 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))
@@ -296,8 +216,17 @@ let error msg = raise (Eval_error (value_to_str msg))
(* inspect wrapper — returns String value instead of OCaml string *)
let inspect v = String (Sx_types.inspect v)
let apply' f args = sx_apply f args
let identical_p a b = _prim "identical?" [a; b]
let _is_spread_prim a = _prim "spread?" [a]
let spread_attrs a = _prim "spread-attrs" [a]
let make_spread a = _prim "make-spread" [a]
(* Scope primitives — delegate to sx_ref.py's shared scope stacks *)
let sx_collect a b = prim_call "collect!" [a; b]
let sx_collected a = prim_call "collected" [a]
let sx_clear_collected a = prim_call "clear-collected!" [a]
let sx_emit a b = prim_call "emit!" [a; b]
let sx_emitted a = prim_call "emitted" [a]
let sx_context a b = prim_call "context" [a; b]
(* Trampoline — forward-declared in sx_ref.ml, delegates to CEK eval_expr *)
@@ -343,8 +272,10 @@ 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 *)
@@ -354,6 +285,21 @@ let get_primitive name = Sx_primitives.get_primitive (value_to_str name)
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
@@ -372,20 +318,7 @@ let continuation_data v = match v with
| Continuation (_, None) -> Dict (Hashtbl.create 0)
| _ -> raise (Eval_error "not a continuation")
(* Callcc (undelimited) continuation support *)
let callcc_continuation_p v = match v with CallccContinuation _ -> Bool true | _ -> Bool false
let make_callcc_continuation captured =
CallccContinuation (sx_to_list captured)
let callcc_continuation_data v = match v with
| CallccContinuation frames -> List frames
| _ -> raise (Eval_error "not a callcc continuation")
(* Dynamic wind — simplified for OCaml (no async) *)
let host_error msg =
raise (Eval_error (value_to_str msg))
let dynamic_wind_call before body after _env =
ignore (sx_call before []);
let result = sx_call body [] in
@@ -426,23 +359,15 @@ let signal_value s = match s with
| Signal sig' -> sig'.s_value
| Dict d -> (match Hashtbl.find_opt d "value" with Some v -> v | None -> Nil)
| _ -> raise (Eval_error "not a signal")
let signal_add_sub_b s f =
match s with
| Dict d ->
(match Hashtbl.find_opt d "subscribers" with
| Some (ListRef r) -> r := !r @ [f]; Nil
| Some (List items) -> Hashtbl.replace d "subscribers" (ListRef (ref (items @ [f]))); Nil
| _ -> Hashtbl.replace d "subscribers" (ListRef (ref [f])); Nil)
| _ -> Nil
let signal_remove_sub_b s f =
match s with
| Dict d ->
(match Hashtbl.find_opt d "subscribers" with
| Some (ListRef r) -> r := List.filter (fun x -> x != f) !r; Nil
| Some (List items) -> Hashtbl.replace d "subscribers" (List (List.filter (fun x -> x != f) items)); Nil
| _ -> Nil)
| _ -> Nil
let signal_set_value s v = match s with Signal sig' -> sig'.s_value <- v; v | _ -> raise (Eval_error "not a signal")
let signal_subscribers s = match s with Signal sig' -> List (List.map (fun _ -> Nil) sig'.s_subscribers) | _ -> List []
let signal_add_sub_b _s _f = Nil
let signal_remove_sub_b _s _f = Nil
let signal_deps _s = List []
let signal_set_deps _s _d = Nil
let notify_subscribers _s = Nil
let flush_subscribers _s = Nil
let dispose_computed _s = Nil
(* Island scope stubs — accept both bare OCaml fns and NativeFn values
from transpiled code (NativeFn wrapping for value-storable lambdas). *)
@@ -465,14 +390,20 @@ let parse_keyword_args _raw_args _env =
(* Stub — the real implementation is transpiled from evaluator.sx *)
List [Dict (Hashtbl.create 0); List []]
(* Make handler def — used by custom_special_forms *)
(* 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_defhandler — used by custom_special_forms *)
(* 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
@@ -486,23 +417,3 @@ let strip_prefix s prefix =
(* debug_log — no-op in production, used by CEK evaluator for component warnings *)
let debug_log _ _ = Nil
(* mutable_list — mutable list for bytecode compiler pool entries *)
let mutable_list () = ListRef (ref [])
(* JIT try-call — ref set by sx_server.ml after compiler loads.
Returns Nil (no JIT) or the result value. Spec calls this. *)
let _jit_try_call_fn : (value -> value list -> value option) option ref = ref None
let _jit_hit = ref 0
let _jit_miss = ref 0
let _jit_skip = ref 0
let jit_reset_counters () = _jit_hit := 0; _jit_miss := 0; _jit_skip := 0
let jit_try_call f args =
match !_jit_try_call_fn with
| None -> incr _jit_skip; Nil
| Some hook ->
match f with
| Lambda l when l.l_name <> None ->
let arg_list = match args with List a | ListRef { contents = a } -> a | _ -> [] in
(match hook f arg_list with Some result -> incr _jit_hit; result | None -> incr _jit_miss; Nil)
| _ -> incr _jit_skip; Nil

154
hosts/ocaml/lib/sx_scope.ml Normal file
View File

@@ -0,0 +1,154 @@
(** Scope stacks — dynamic scope for render-time effects.
Provides scope-push!/pop!/peek, collect!/collected/clear-collected!,
scope-emit!/emitted/scope-emitted, context, and cookie access.
All functions are registered as primitives so both the CEK evaluator
and the JIT VM can find them in the same place. *)
open Sx_types
(** The shared scope stacks hashtable. Each key maps to a stack of values.
Used by aser for spread/provide/emit patterns, CSSX collect/flush, etc. *)
let scope_stacks : (string, value list) Hashtbl.t = Hashtbl.create 8
(** Request cookies — set by the Python bridge before each render.
get-cookie reads from here; set-cookie is a no-op on the server. *)
let request_cookies : (string, string) Hashtbl.t = Hashtbl.create 8
(** Clear all scope stacks. Called between requests if needed. *)
let clear_all () = Hashtbl.clear scope_stacks
let () =
let register = Sx_primitives.register in
(* --- Cookies --- *)
register "get-cookie" (fun args ->
match args with
| [String name] ->
(match Hashtbl.find_opt request_cookies name with
| Some v -> String v
| None -> Nil)
| _ -> Nil);
register "set-cookie" (fun _args -> Nil);
(* --- Core scope stack operations --- *)
register "scope-push!" (fun args ->
match args with
| [String name; value] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
Hashtbl.replace scope_stacks name (value :: stack); Nil
| _ -> Nil);
register "scope-pop!" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
(match stack with _ :: rest -> Hashtbl.replace scope_stacks name rest | [] -> ()); Nil
| _ -> Nil);
register "scope-peek" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
(match stack with v :: _ -> v | [] -> Nil)
| _ -> Nil);
(* --- Context (scope lookup with optional default) --- *)
register "context" (fun args ->
match args with
| [String name] | [String name; _] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
(match stack, args with
| v :: _, _ -> v
| [], [_; default_val] -> default_val
| [], _ -> Nil)
| _ -> Nil);
(* --- Collect / collected / clear-collected! --- *)
register "collect!" (fun args ->
match args with
| [String name; value] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
(match stack with
| List items :: rest ->
if not (List.mem value items) then
Hashtbl.replace scope_stacks name (List (items @ [value]) :: rest)
| [] ->
Hashtbl.replace scope_stacks name [List [value]]
| _ :: _ -> ());
Nil
| _ -> Nil);
register "collected" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
(match stack with List items :: _ -> List items | _ -> List [])
| _ -> List []);
register "clear-collected!" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
(match stack with
| _ :: rest -> Hashtbl.replace scope_stacks name (List [] :: rest)
| [] -> Hashtbl.replace scope_stacks name [List []]);
Nil
| _ -> Nil);
(* --- Emit / emitted (for spread attrs in adapter-html.sx) --- *)
register "scope-emit!" (fun args ->
match args with
| [String name; value] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
(match stack with
| List items :: rest ->
Hashtbl.replace scope_stacks name (List (items @ [value]) :: rest)
| Nil :: rest ->
Hashtbl.replace scope_stacks name (List [value] :: rest)
| [] ->
Hashtbl.replace scope_stacks name [List [value]]
| _ :: _ -> ());
Nil
| _ -> Nil);
register "emit!" (fun args ->
(* Alias for scope-emit! *)
match Sx_primitives.get_primitive "scope-emit!" with
| NativeFn (_, fn) -> fn args | _ -> Nil);
register "emitted" (fun args ->
match args with
| [String name] ->
let stack = try Hashtbl.find scope_stacks name with Not_found -> [] in
(match stack with List items :: _ -> List items | _ -> List [])
| _ -> List []);
register "scope-emitted" (fun args ->
match Sx_primitives.get_primitive "emitted" with
| NativeFn (_, fn) -> fn args | _ -> List []);
register "scope-collected" (fun args ->
match Sx_primitives.get_primitive "collected" with
| NativeFn (_, fn) -> fn args | _ -> List []);
register "scope-clear-collected!" (fun args ->
match Sx_primitives.get_primitive "clear-collected!" with
| NativeFn (_, fn) -> fn args | _ -> Nil);
(* --- Provide aliases --- *)
register "provide-push!" (fun args ->
match Sx_primitives.get_primitive "scope-push!" with
| NativeFn (_, fn) -> fn args | _ -> Nil);
register "provide-pop!" (fun args ->
match Sx_primitives.get_primitive "scope-pop!" with
| NativeFn (_, fn) -> fn args | _ -> Nil)

366
hosts/ocaml/lib/sx_types.ml
View File

@@ -4,38 +4,12 @@
OCaml's algebraic types make the CEK machine's frame dispatch a
pattern match — exactly what the spec describes. *)
(** {1 Symbol interning} *)
(** Map symbol names to small integers for O(1) env lookups.
The intern table is populated once per unique symbol name;
all subsequent env operations use the integer key. *)
let sym_to_id : (string, int) Hashtbl.t = Hashtbl.create 512
let id_to_sym : (int, string) Hashtbl.t = Hashtbl.create 512
let sym_next = ref 0
let intern s =
match Hashtbl.find_opt sym_to_id s with
| Some id -> id
| None ->
let id = !sym_next in
incr sym_next;
Hashtbl.replace sym_to_id s id;
Hashtbl.replace id_to_sym id s;
id
let unintern id =
match Hashtbl.find_opt id_to_sym id with
| Some s -> s
| None -> "<sym:" ^ string_of_int id ^ ">"
(** {1 Environment} *)
(** Lexical scope chain. Each frame holds a mutable binding table
keyed by interned symbol IDs for fast lookup. *)
(** Lexical scope chain. Each frame holds a mutable binding table and
an optional parent link for scope-chain lookup. *)
type env = {
bindings : (int, value) Hashtbl.t;
bindings : (string, value) Hashtbl.t;
parent : env option;
}
@@ -56,7 +30,6 @@ and value =
| Macro of macro
| Thunk of value * env
| Continuation of (value -> value) * dict option
| CallccContinuation of value list (** Undelimited continuation — captured kont frames *)
| NativeFn of string * (value list -> value)
| Signal of signal
| RawHTML of string
@@ -67,11 +40,6 @@ and value =
| CekState of cek_state (** Optimized CEK machine state — avoids Dict allocation. *)
| CekFrame of cek_frame (** Optimized CEK continuation frame. *)
| VmClosure of vm_closure (** VM-compiled closure — callable within the VM without allocating a new VM. *)
| VmFrame of vm_frame (** VM call frame — one per function invocation. *)
| VmMachine of vm_machine (** VM state — stack, frames, globals. *)
| Record of record (** R7RS record — opaque, generative, field-indexed. *)
| Parameter of parameter (** R7RS parameter — dynamic binding via kont-stack provide frames. *)
| Vector of value array (** R7RS vector — mutable fixed-size array. *)
(** CEK machine state — record instead of Dict for performance.
5 fields × 55K steps/sec = 275K Hashtbl allocations/sec eliminated. *)
@@ -91,12 +59,12 @@ and cek_frame = {
cf_env : value; (* environment — every frame has this *)
cf_name : value; (* let/define/set/scope: binding name *)
cf_body : value; (* when/let: body expr *)
mutable cf_remaining : value; (* begin/cond/map/etc: remaining exprs *)
cf_remaining : value; (* begin/cond/map/etc: remaining exprs *)
cf_f : value; (* call/map/filter/etc: function *)
cf_args : value; (* call: raw args; arg: evaled args *)
mutable cf_results : value; (* map/filter/dict: accumulated results; provide: subscribers *)
mutable cf_extra : value; (* extra field: scheme, indexed, value, phase, etc. *)
mutable cf_extra2 : value; (* second extra: emitted, etc. *)
cf_results : value; (* map/filter/dict: accumulated results *)
cf_extra : value; (* extra field: scheme, indexed, value, phase, etc. *)
cf_extra2 : value; (* second extra: emitted, etc. *)
}
(** Mutable string-keyed table (SX dicts support [dict-set!]). *)
@@ -117,7 +85,6 @@ and component = {
c_body : value;
c_closure : env;
c_affinity : string; (** "auto" | "client" | "server" *)
mutable c_file : string option; (** Source file path *)
mutable c_compiled : vm_closure option; (** Lazy JIT cache *)
}
@@ -127,8 +94,6 @@ and island = {
i_has_children : bool;
i_body : value;
i_closure : env;
mutable i_file : string option; (** Source file path *)
mutable i_compiled : vm_closure option; (** Lazy JIT cache *)
}
and macro = {
@@ -145,30 +110,6 @@ and signal = {
mutable s_deps : signal list;
}
(** R7RS record type descriptor — one per [define-record-type] call.
Stored in [rtd_table]; closures capture only the integer uid. *)
and record_type = {
rt_name : string; (** e.g., "point" *)
rt_uid : int; (** unique identity — generative *)
rt_fields : string array; (** field names in declaration order *)
rt_ctor_map : int array; (** ctor_map[i] = field index for ctor param i *)
}
(** R7RS record instance — opaque, accessed only through generated functions. *)
and record = {
r_type : record_type;
r_fields : value array; (** mutable via Array.set for record-set! *)
}
(** R7RS parameter — dynamic binding via provide frames on the kont stack.
Calling [(param)] searches kont for the nearest provide frame keyed
by [pm_uid]; if not found returns [pm_default]. *)
and parameter = {
pm_uid : string; (** unique ID — used as provide frame key *)
pm_default : value; (** initial/default value *)
pm_converter : value option; (** optional converter function *)
}
(** {1 Bytecode VM types}
Defined here (not in sx_vm.ml) because [vm_code.constants] references
@@ -181,8 +122,6 @@ and vm_code = {
vc_locals : int;
vc_bytecode : int array;
vc_constants : value array;
mutable vc_bytecode_list : value list option; (** Lazy cache for transpiled VM *)
mutable vc_constants_list : value list option; (** Lazy cache for transpiled VM *)
}
(** Upvalue cell — shared mutable reference to a captured variable. *)
@@ -199,35 +138,12 @@ and vm_closure = {
vm_closure_env : env option; (** Original closure env for inner functions *)
}
(** VM call frame — one per function invocation.
Defined here (not in sx_vm.ml) so it can be a [value] variant. *)
and vm_frame = {
vf_closure : vm_closure;
mutable vf_ip : int;
vf_base : int;
vf_local_cells : (int, vm_upvalue_cell) Hashtbl.t;
}
(** VM state — stack machine with frame list.
Defined here for the same mutual-recursion reason. *)
and vm_machine = {
mutable vm_stack : value array;
mutable vm_sp : int;
mutable vm_frames : vm_frame list;
vm_globals : (string, value) Hashtbl.t;
mutable vm_pending_cek : value option;
}
(** {1 Forward ref for calling VM closures from outside the VM} *)
let _vm_call_closure_ref : (vm_closure -> value list -> value) ref =
ref (fun _ _ -> raise (Failure "VM call_closure not initialized"))
(** Forward ref for calling CEK evaluator from primitives (avoids dependency cycle). *)
let _cek_call_ref : (value -> value -> value) ref =
ref (fun _ _ -> raise (Failure "CEK call not initialized"))
(** {1 Errors} *)
@@ -235,16 +151,6 @@ exception Eval_error of string
exception Parse_error of string
(** {1 Record type descriptor table} *)
let rtd_table : (int, record_type) Hashtbl.t = Hashtbl.create 16
let rtd_counter = ref 0
(** {1 Parameter UID counter} *)
let param_counter = ref 0
(** {1 Environment operations} *)
let make_env () =
@@ -253,73 +159,37 @@ let make_env () =
let env_extend parent =
{ bindings = Hashtbl.create 16; parent = Some parent }
(* Optional hook: called after every env_bind with (env, name, value).
Used by browser kernel to sync VM globals table. *)
let _env_bind_hook : (env -> string -> value -> unit) option ref = ref None
(* Optional hook: called after VM GLOBAL_SET writes to vm.globals.
Used by browser kernel to sync mutations back to global_env. *)
let _vm_global_set_hook : (string -> value -> unit) option ref = ref None
(* Optional hook: called by cek_run on import suspension.
If set, the hook loads the library and returns true; cek_run then resumes. *)
let _import_hook : (value -> bool) option ref = ref None
(* Optional hook: called by vm_global_get when a symbol isn't found.
Receives the symbol name. If the hook can resolve it (e.g. by loading a
library that exports it), it returns Some value. Otherwise None.
This enables transparent lazy module loading — just use a symbol and
the VM loads whatever module provides it. *)
let _symbol_resolve_hook : (string -> value option) option ref = ref None
let env_bind env name v =
Hashtbl.replace env.bindings (intern name) v;
(match !_env_bind_hook with Some f -> f env name v | None -> ());
Nil
Hashtbl.replace env.bindings name v; Nil
(* Internal: scope-chain lookup with pre-interned ID *)
let rec env_has_id env id =
Hashtbl.mem env.bindings id ||
match env.parent with Some p -> env_has_id p id | None -> false
let rec env_has env name =
Hashtbl.mem env.bindings name ||
match env.parent with Some p -> env_has p name | None -> false
let env_has env name = env_has_id env (intern name)
let rec env_get_id env id name =
match Hashtbl.find_opt env.bindings id with
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_id p id name
| None ->
(* Symbol not in any scope — try the resolve hook (transparent lazy loading).
The hook loads the module that exports this symbol, making it available. *)
match !_symbol_resolve_hook with
| Some hook ->
(match hook name with
| Some v ->
(* Cache in the root env so subsequent lookups are instant *)
Hashtbl.replace env.bindings id v; v
| None -> raise (Eval_error ("Undefined symbol: " ^ name)))
| None -> raise (Eval_error ("Undefined symbol: " ^ name))
| Some p -> env_get p name
| None -> raise (Eval_error ("Undefined symbol: " ^ name))
let env_get env name = env_get_id env (intern name) name
let rec env_set_id env id v =
if Hashtbl.mem env.bindings id then begin
Hashtbl.replace env.bindings id v;
(match !_env_bind_hook with Some f -> f env (unintern id) v | None -> ());
Nil
end else
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_id p id v
| None -> Hashtbl.replace env.bindings id v; Nil
let env_set env name v = env_set_id env (intern name) v
| 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
@@ -328,9 +198,11 @@ let env_merge base overlay =
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 id v ->
if not (env_has_id base id) then Hashtbl.replace e.bindings id v
Hashtbl.iter (fun k v ->
if not (env_has base k) then Hashtbl.replace e.bindings k v
) overlay.bindings;
e
end
@@ -377,7 +249,7 @@ let make_component name params has_children body closure affinity =
Component {
c_name = n; c_params = ps; c_has_children = hc;
c_body = body; c_closure = unwrap_env_val closure; c_affinity = aff;
c_file = None; c_compiled = None;
c_compiled = None;
}
let make_island name params has_children body closure =
@@ -387,7 +259,6 @@ let make_island name params has_children body closure =
Island {
i_name = n; i_params = ps; i_has_children = hc;
i_body = body; i_closure = unwrap_env_val closure;
i_file = None; i_compiled = None;
}
let make_macro params rest_param body closure name =
@@ -422,7 +293,6 @@ let type_of = function
| Macro _ -> "macro"
| Thunk _ -> "thunk"
| Continuation (_, _) -> "continuation"
| CallccContinuation _ -> "continuation"
| NativeFn _ -> "function"
| Signal _ -> "signal"
| RawHTML _ -> "raw-html"
@@ -432,11 +302,6 @@ let type_of = function
| CekState _ -> "dict" (* CEK state behaves as a dict for type checks *)
| CekFrame _ -> "dict"
| VmClosure _ -> "function"
| VmFrame _ -> "vm-frame"
| VmMachine _ -> "vm-machine"
| Record r -> r.r_type.rt_name
| Parameter _ -> "parameter"
| Vector _ -> "vector"
let is_nil = function Nil -> true | _ -> false
let is_lambda = function Lambda _ -> true | _ -> false
@@ -449,10 +314,8 @@ let is_signal = function
| Dict d -> Hashtbl.mem d "__signal"
| _ -> false
let is_record = function Record _ -> true | _ -> false
let is_callable = function
| Lambda _ | NativeFn _ | Continuation (_, _) | CallccContinuation _ | VmClosure _ -> true
| Lambda _ | NativeFn _ | Continuation (_, _) | VmClosure _ -> true
| _ -> false
@@ -499,19 +362,6 @@ let component_name = function
| Island i -> String i.i_name
| v -> raise (Eval_error ("Expected component, got " ^ type_of v))
let component_file = function
| Component c -> (match c.c_file with Some f -> String f | None -> Nil)
| Island i -> (match i.i_file with Some f -> String f | None -> Nil)
| _ -> Nil
let component_set_file v f =
(match v, f with
| Component c, String s -> c.c_file <- Some s
| Island i, String s -> i.i_file <- Some s
| _ -> ()); Nil
let component_set_file_b = component_set_file
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)
@@ -562,144 +412,6 @@ let thunk_env = function
| v -> raise (Eval_error ("Expected thunk, got " ^ type_of v))
(** {1 Record operations} *)
let val_to_int = function
| Number n -> int_of_float n
| v -> raise (Eval_error ("Expected number, got " ^ type_of v))
(** [make_rtd name fields ctor_params] — create a record type descriptor.
Called as [make-rtd] from transpiled evaluator. Takes 3 separate args. *)
let make_rtd name fields ctor_params =
let uid = !rtd_counter in
incr rtd_counter;
let field_names = List.map value_to_string (match fields with List l -> l | _ -> []) in
let ctor_names = List.map value_to_string (match ctor_params with List l -> l | _ -> []) in
let field_arr = Array.of_list field_names in
let ctor_map = Array.of_list (List.map (fun cp ->
let rec find j = function
| [] -> raise (Eval_error (Printf.sprintf "make-rtd: ctor param %s not in fields" cp))
| f :: _ when f = cp -> j
| _ :: rest -> find (j + 1) rest
in find 0 field_names
) ctor_names) in
let rt = { rt_name = value_to_string name; rt_uid = uid; rt_fields = field_arr; rt_ctor_map = ctor_map } in
Hashtbl.add rtd_table uid rt;
Number (float_of_int uid)
(** [make_record uid_val args_list] — create a record from uid + args list.
2-arg direct call: (make-record rtd-uid ctor-args-list). *)
let make_record uid_val args_list =
let uid = val_to_int uid_val in
let ctor_args = match args_list with List l -> l | _ -> [] in
match Hashtbl.find_opt rtd_table uid with
| None -> raise (Eval_error "make-record: unknown rtd")
| Some rt ->
let n_ctor = Array.length rt.rt_ctor_map in
let n_args = List.length ctor_args in
if n_args <> n_ctor then
raise (Eval_error (Printf.sprintf "%s: expected %d args, got %d"
rt.rt_name n_ctor n_args));
let fields = Array.make (Array.length rt.rt_fields) Nil in
List.iteri (fun i arg ->
fields.(rt.rt_ctor_map.(i)) <- arg
) ctor_args;
Record { r_type = rt; r_fields = fields }
(** [record_ref v idx] — access field by index. 2-arg direct call. *)
let record_ref v idx =
match v with
| Record r ->
let i = val_to_int idx in
if i < 0 || i >= Array.length r.r_fields then
raise (Eval_error (Printf.sprintf "record-ref: index %d out of bounds for %s" i r.r_type.rt_name));
r.r_fields.(i)
| _ -> raise (Eval_error ("record-ref: not a record, got " ^ type_of v))
(** [record_set_b v idx new_val] — mutate field by index. 3-arg direct call.
Named record_set_b because transpiler mangles record-set! to record_set_b. *)
let record_set_b v idx new_val =
match v with
| Record r ->
let i = val_to_int idx in
if i < 0 || i >= Array.length r.r_fields then
raise (Eval_error (Printf.sprintf "record-set!: index %d out of bounds for %s" i r.r_type.rt_name));
r.r_fields.(i) <- new_val; Nil
| _ -> raise (Eval_error ("record-set!: not a record, got " ^ type_of v))
(** [record_type_p v uid_val] — type predicate. 2-arg direct call.
Named record_type_p because transpiler mangles record-type? to record_type_p. *)
let record_type_p v uid_val =
match v with
| Record r -> Bool (r.r_type.rt_uid = val_to_int uid_val)
| _ -> Bool false
(** [record_p v] — generic record predicate.
Named record_p because transpiler mangles record? to record_p. *)
let record_p v = Bool (is_record v)
(** [make_record_constructor rtd_uid] — returns a NativeFn that constructs records.
Called from transpiled sf-define-record-type. *)
let make_record_constructor uid_val =
let uid = val_to_int uid_val in
let rt = match Hashtbl.find_opt rtd_table uid with
| Some rt -> rt | None -> raise (Eval_error "make-record-constructor: unknown rtd") in
NativeFn (rt.rt_name, fun args ->
let n_ctor = Array.length rt.rt_ctor_map in
let n_args = List.length args in
if n_args <> n_ctor then
raise (Eval_error (Printf.sprintf "%s: expected %d args, got %d" rt.rt_name n_ctor n_args));
let fields = Array.make (Array.length rt.rt_fields) Nil in
List.iteri (fun i arg -> fields.(rt.rt_ctor_map.(i)) <- arg) args;
Record { r_type = rt; r_fields = fields })
(** [make_record_predicate rtd_uid] — returns a NativeFn that tests record type. *)
let make_record_predicate uid_val =
let uid = val_to_int uid_val in
NativeFn ("?", fun args ->
match args with
| [Record r] -> Bool (r.r_type.rt_uid = uid)
| [_] -> Bool false
| _ -> raise (Eval_error "record predicate: expected 1 arg"))
(** [make_record_accessor field_idx] — returns a NativeFn that reads a field. *)
let make_record_accessor idx_val =
let idx = val_to_int idx_val in
NativeFn ("ref", fun args ->
match args with
| [Record r] ->
if idx < 0 || idx >= Array.length r.r_fields then
raise (Eval_error (Printf.sprintf "record accessor: index %d out of bounds" idx));
r.r_fields.(idx)
| [v] -> raise (Eval_error ("record accessor: not a record, got " ^ type_of v))
| _ -> raise (Eval_error "record accessor: expected 1 arg"))
(** [make_record_mutator field_idx] — returns a NativeFn that sets a field. *)
let make_record_mutator idx_val =
let idx = val_to_int idx_val in
NativeFn ("set!", fun args ->
match args with
| [Record r; new_val] ->
if idx < 0 || idx >= Array.length r.r_fields then
raise (Eval_error (Printf.sprintf "record mutator: index %d out of bounds" idx));
r.r_fields.(idx) <- new_val; Nil
| _ -> raise (Eval_error "record mutator: expected (record value)"))
(** {1 R7RS parameter accessors — called from transpiled evaluator} *)
let parameter_p v = match v with Parameter _ -> Bool true | _ -> Bool false
let parameter_uid v = match v with
| Parameter p -> String p.pm_uid
| _ -> raise (Eval_error "parameter-uid: not a parameter")
let parameter_default v = match v with
| Parameter p -> p.pm_default
| _ -> raise (Eval_error "parameter-default: not a parameter")
let parameter_converter v = match v with
| Parameter p -> (match p.pm_converter with Some c -> c | None -> Nil)
| _ -> raise (Eval_error "parameter-converter: not a parameter")
(** {1 Dict operations} *)
let make_dict () : dict = Hashtbl.create 8
@@ -761,24 +473,12 @@ let rec inspect = function
Printf.sprintf "<%s(%s)>" tag (String.concat ", " m.m_params)
| Thunk _ -> "<thunk>"
| Continuation (_, _) -> "<continuation>"
| CallccContinuation _ -> "<callcc-continuation>"
| NativeFn (name, _) -> Printf.sprintf "<native:%s>" name
| Signal _ -> "<signal>"
| RawHTML s -> Printf.sprintf "\"<raw-html:%d>\"" (String.length s)
| RawHTML s -> Printf.sprintf "<raw-html:%d chars>" (String.length s)
| Spread _ -> "<spread>"
| SxExpr s -> Printf.sprintf "\"<sx-expr:%d>\"" (String.length s)
| SxExpr s -> Printf.sprintf "<sx-expr:%d chars>" (String.length s)
| Env _ -> "<env>"
| CekState _ -> "<cek-state>"
| CekFrame f -> Printf.sprintf "<frame:%s>" f.cf_type
| VmClosure cl -> Printf.sprintf "<vm:%s>" (match cl.vm_name with Some n -> n | None -> "anon")
| Record r ->
let fields = Array.to_list (Array.mapi (fun i v ->
Printf.sprintf "%s=%s" r.r_type.rt_fields.(i) (inspect v)
) r.r_fields) in
Printf.sprintf "<record:%s %s>" r.r_type.rt_name (String.concat " " fields)
| Parameter p -> Printf.sprintf "<parameter:%s>" p.pm_uid
| Vector arr ->
let elts = Array.to_list (Array.map inspect arr) in
Printf.sprintf "#(%s)" (String.concat " " elts)
| VmFrame f -> Printf.sprintf "<vm-frame:ip=%d base=%d>" f.vf_ip f.vf_base
| VmMachine m -> Printf.sprintf "<vm-machine:sp=%d frames=%d>" m.vm_sp (List.length m.vm_frames)

773
hosts/ocaml/lib/sx_vm.ml
View File

@@ -20,29 +20,14 @@ type frame = {
local_cells : (int, vm_upvalue_cell) Hashtbl.t; (* slot → shared cell for captured locals *)
}
(** Exception handler entry on the handler stack. *)
type handler_entry = {
h_catch_ip : int; (* IP to jump to when exception is raised *)
h_frame_depth : int; (* number of frames when handler was pushed *)
h_sp : int; (* stack pointer when handler was pushed *)
h_frame : frame; (* the frame that pushed the handler *)
}
(** VM state. *)
type vm = {
mutable stack : value array;
mutable sp : int;
mutable frames : frame list;
globals : (string, value) Hashtbl.t; (* live reference to kernel env *)
mutable pending_cek : value option; (* suspended CEK state from Component/Lambda call *)
mutable handler_stack : handler_entry list; (* exception handler stack *)
}
(** Raised when OP_PERFORM is executed. Carries the IO request dict
and a reference to the VM (which is in a resumable state:
ip past OP_PERFORM, stack ready for a result push). *)
exception VmSuspended of value * vm
(** Forward reference for JIT compilation — set after definition. *)
let jit_compile_ref : (lambda -> (string, value) Hashtbl.t -> vm_closure option) ref =
ref (fun _ _ -> None)
@@ -50,22 +35,14 @@ let jit_compile_ref : (lambda -> (string, value) Hashtbl.t -> vm_closure option)
(** Sentinel closure indicating JIT compilation was attempted and failed.
Prevents retrying compilation on every call. *)
let jit_failed_sentinel = {
vm_code = { vc_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||];
vc_bytecode_list = None; vc_constants_list = None };
vm_code = { vc_arity = -1; vc_locals = 0; vc_bytecode = [||]; vc_constants = [||] };
vm_upvalues = [||]; vm_name = Some "__jit_failed__"; vm_env_ref = Hashtbl.create 0; vm_closure_env = None
}
let is_jit_failed cl = cl.vm_code.vc_arity = -1
(** Current active VM — allows HO primitives (map, filter, for-each, some)
to call VmClosure callbacks on the same VM instead of creating a new one.
This is critical: creating a new VM per callback loses the calling VM's
stack/frame context, causing upvalue-captured host objects to become
inaccessible. *)
let _active_vm : vm option ref = ref None
let create globals =
{ stack = Array.make 4096 Nil; sp = 0; frames = []; globals; pending_cek = None; handler_stack = [] }
{ stack = Array.make 4096 Nil; sp = 0; frames = []; globals }
(** Stack ops — inlined for speed. *)
let push vm v =
@@ -104,34 +81,13 @@ let closure_to_value cl =
fun args -> raise (Eval_error ("VM_CLOSURE_CALL:" ^ String.concat "," (List.map Sx_runtime.value_to_str args))))
(* Placeholder — actual calls go through vm_call below *)
(** Parse keyword args from an evaluated args list.
The compiler converts :keyword to its string name, so we need the
component's param list to identify which strings are keyword names.
Returns (kwargs_hashtbl, children_list). *)
let parse_keyword_args params args =
let param_set = Hashtbl.create (List.length params) in
List.iter (fun p -> Hashtbl.replace param_set p true) params;
let kwargs = Hashtbl.create 8 in
let children = ref [] in
let rec go = function
| (String k | Keyword k) :: v :: rest when Hashtbl.mem param_set k ->
Hashtbl.replace kwargs k v; go rest
| v :: rest -> children := v :: !children; go rest
| [] -> ()
in
go args;
(kwargs, List.rev !children)
let _vm_comp_jit_count = ref 0
let _vm_comp_cek_count = ref 0
let _vm_insn_count = ref 0
let _vm_call_count = ref 0
let _vm_cek_count = ref 0
let vm_reset_counters () = _vm_insn_count := 0; _vm_call_count := 0; _vm_cek_count := 0;
_vm_comp_jit_count := 0; _vm_comp_cek_count := 0
let vm_reset_counters () = _vm_insn_count := 0; _vm_call_count := 0; _vm_cek_count := 0
let vm_report_counters () =
Printf.eprintf "[vm-perf] insns=%d calls=%d cek_fallbacks=%d comp_jit=%d comp_cek=%d\n%!"
!_vm_insn_count !_vm_call_count !_vm_cek_count !_vm_comp_jit_count !_vm_comp_cek_count
Printf.eprintf "[vm-perf] insns=%d calls=%d cek_fallbacks=%d\n%!"
!_vm_insn_count !_vm_call_count !_vm_cek_count
(** Push a VM closure frame onto the current VM — no new VM allocation.
This is the fast path for intra-VM closure calls. *)
@@ -162,76 +118,18 @@ let code_from_value v =
let arity = match Hashtbl.find_opt d "arity" with
| Some (Number n) -> int_of_float n | _ -> 0
in
{ vc_arity = arity; vc_locals = arity + 16; vc_bytecode = bc_list; vc_constants = constants;
vc_bytecode_list = None; vc_constants_list = None }
| _ -> { vc_arity = 0; vc_locals = 16; vc_bytecode = [||]; vc_constants = [||];
vc_bytecode_list = None; vc_constants_list = None }
(** JIT-compile a component or island body.
Wraps body as (fn (param1 param2 ... [children]) body) and compiles.
Returns Some vm_closure on success, None on failure. *)
let jit_compile_comp ~name ~params ~has_children ~body ~closure globals =
try
let _compile_fn = try Hashtbl.find globals "compile"
with Not_found -> raise (Eval_error "JIT: compiler not loaded") in
let param_names = params @ (if has_children then ["children"] else []) in
let param_syms = List (List.map (fun s -> Symbol s) param_names) in
let fn_expr = List [Symbol "fn"; param_syms; body] in
let quoted = List [Symbol "quote"; fn_expr] in
let compile_env = Sx_types.env_extend (Sx_types.make_env ()) in
Hashtbl.iter (fun k v -> Hashtbl.replace compile_env.bindings (Sx_types.intern k) v) globals;
let result = Sx_ref.eval_expr (List [Symbol "compile"; quoted]) (Env compile_env) in
(match result with
| Dict d when Hashtbl.mem d "bytecode" ->
let outer_code = code_from_value result in
let bc = outer_code.vc_bytecode in
if Array.length bc >= 4 && bc.(0) = 51 (* OP_CLOSURE *) then begin
let idx = bc.(1) lor (bc.(2) lsl 8) in
if idx < Array.length outer_code.vc_constants then
let inner_val = outer_code.vc_constants.(idx) in
let code = code_from_value inner_val in
Some { vm_code = code; vm_upvalues = [||];
vm_name = Some name; vm_env_ref = globals;
vm_closure_env = Some closure }
else None
end else None
| _ -> None)
with e ->
Printf.eprintf "[jit-comp] FAIL %s: %s\n%!" name (Printexc.to_string e);
None
(** Call an SX value via CEK, detecting suspension instead of erroring.
Returns the result value, or raises VmSuspended if CEK suspends.
Saves the suspended CEK state in vm.pending_cek for later resume. *)
let cek_call_or_suspend vm f args =
incr _vm_cek_count;
let a = match args with Nil -> [] | List l -> l | _ -> [args] in
let state = Sx_ref.continue_with_call f (List a) (Env (Sx_types.make_env ())) (List a) (List []) in
let final = Sx_ref.cek_step_loop state in
match Sx_runtime.get_val final (String "phase") with
| String "io-suspended" ->
vm.pending_cek <- Some final;
raise (VmSuspended (Sx_runtime.get_val final (String "request"), vm))
| _ -> Sx_ref.cek_value final
{ vc_arity = arity; vc_locals = arity + 16; vc_bytecode = bc_list; vc_constants = constants }
| _ -> { vc_arity = 0; vc_locals = 16; vc_bytecode = [||]; vc_constants = [||] }
(** Execute a closure with arguments — creates a fresh VM.
Used for entry points: JIT Lambda calls, module execution, cross-boundary. *)
let rec call_closure cl args globals =
incr _vm_call_count;
let prev_vm = !_active_vm in
let vm = create globals in
_active_vm := Some vm;
push_closure_frame vm cl args;
(try run vm with e -> _active_vm := prev_vm; raise e);
_active_vm := prev_vm;
(try run vm with e -> raise e);
pop vm
(** Call a VmClosure on the active VM if one exists, otherwise create a new one.
This is the path used by HO primitives (map, filter, for-each, some) so
callbacks can access upvalues that reference the calling VM's state. *)
and call_closure_reuse cl args =
call_closure cl args cl.vm_env_ref
(** Call a value as a function — dispatch by type.
VmClosure: pushes frame on current VM (fast intra-VM path).
Lambda: tries JIT then falls back to CEK.
@@ -247,15 +145,12 @@ and vm_call vm f args =
| Lambda l ->
(match l.l_compiled with
| Some cl when not (is_jit_failed cl) ->
(* Cached bytecode — run on VM using the closure's captured env,
not the caller's globals. Closure vars were merged at compile time. *)
(try push vm (call_closure cl args cl.vm_env_ref)
with _e ->
(* Fallback to CEK — suspension-aware *)
push vm (cek_call_or_suspend vm f (List args)))
(* Cached bytecode — run on VM, fall back to CEK on runtime error *)
(try push vm (call_closure cl args vm.globals)
with _ -> push vm (Sx_ref.cek_call f (List args)))
| Some _ ->
(* Compile failed — CEK, suspension-aware *)
push vm (cek_call_or_suspend vm f (List args))
(* Compile failed — CEK *)
push vm (Sx_ref.cek_call f (List args))
| None ->
if l.l_name <> None
then begin
@@ -264,73 +159,20 @@ and vm_call vm f args =
match !jit_compile_ref l vm.globals with
| Some cl ->
l.l_compiled <- Some cl;
(try push vm (call_closure cl args cl.vm_env_ref)
with _e -> push vm (cek_call_or_suspend vm f (List args)))
(try push vm (call_closure cl args vm.globals)
with _ ->
l.l_compiled <- Some jit_failed_sentinel;
push vm (Sx_ref.cek_call f (List args)))
| None ->
push vm (cek_call_or_suspend vm f (List args))
push vm (Sx_ref.cek_call f (List args))
end
else
push vm (cek_call_or_suspend vm f (List args)))
| Component c ->
let (kwargs, children) = parse_keyword_args c.c_params args in
(* Get or compile the component body *)
let compiled = match c.c_compiled with
| Some cl when not (is_jit_failed cl) -> Some cl
| Some _ -> None
| None ->
c.c_compiled <- Some jit_failed_sentinel;
let result = jit_compile_comp ~name:c.c_name ~params:c.c_params
~has_children:c.c_has_children ~body:c.c_body
~closure:c.c_closure vm.globals in
(match result with Some cl -> c.c_compiled <- Some cl | None -> ());
result
in
(match compiled with
| Some cl ->
incr _vm_comp_jit_count;
(* Build positional args: keyword params in order, then children *)
let call_args = List.map (fun p ->
match Hashtbl.find_opt kwargs p with Some v -> v | None -> Nil
) c.c_params in
let call_args = if c.c_has_children
then call_args @ [List children]
else call_args in
(try push vm (call_closure cl call_args cl.vm_env_ref)
with _ ->
incr _vm_cek_count; incr _vm_comp_cek_count;
push vm (cek_call_or_suspend vm f (List args)))
| None ->
incr _vm_cek_count; incr _vm_comp_cek_count;
push vm (cek_call_or_suspend vm f (List args)))
| Island i ->
let (kwargs, children) = parse_keyword_args i.i_params args in
let compiled = match i.i_compiled with
| Some cl when not (is_jit_failed cl) -> Some cl
| Some _ -> None
| None ->
i.i_compiled <- Some jit_failed_sentinel;
let result = jit_compile_comp ~name:i.i_name ~params:i.i_params
~has_children:i.i_has_children ~body:i.i_body
~closure:i.i_closure vm.globals in
(match result with Some cl -> i.i_compiled <- Some cl | None -> ());
result
in
(match compiled with
| Some cl ->
incr _vm_comp_jit_count;
let call_args = List.map (fun p ->
match Hashtbl.find_opt kwargs p with Some v -> v | None -> Nil
) i.i_params in
let call_args = if i.i_has_children
then call_args @ [List children]
else call_args in
(try push vm (call_closure cl call_args cl.vm_env_ref)
with _ ->
incr _vm_cek_count; incr _vm_comp_cek_count;
push vm (cek_call_or_suspend vm f (List args)))
| None ->
incr _vm_cek_count; incr _vm_comp_cek_count;
push vm (cek_call_or_suspend vm f (List args)))
push vm (Sx_ref.cek_call f (List args)))
| Component _ | Island _ ->
(* Components use keyword-arg parsing — CEK handles this *)
incr _vm_cek_count;
let result = Sx_ref.cek_call f (List args) in
push vm result
| _ ->
raise (Eval_error ("VM: not callable: " ^ Sx_runtime.value_to_str f))
@@ -344,22 +186,12 @@ and run vm =
| frame :: rest_frames ->
let bc = frame.closure.vm_code.vc_bytecode in
let consts = frame.closure.vm_code.vc_constants in
if frame.ip >= Array.length bc then begin
(* Bytecode exhausted without explicit RETURN — pop frame like RETURN *)
let fn_name = match frame.closure.vm_name with Some n -> n | None -> "?" in
Printf.eprintf "[vm] WARN: bytecode exhausted without RETURN in %s (base=%d sp=%d frames=%d)\n%!"
fn_name frame.base vm.sp (List.length rest_frames);
let result = if vm.sp > frame.base then pop vm else Nil in
vm.frames <- rest_frames;
vm.sp <- frame.base;
if rest_frames <> [] then push vm result
(* If no more frames, result stays on stack for call_closure to pop *)
end
if frame.ip >= Array.length bc then
vm.frames <- [] (* bytecode exhausted — stop *)
else begin
let saved_ip = frame.ip in
let op = bc.(frame.ip) in
frame.ip <- frame.ip + 1;
incr _vm_insn_count;
(try match op with
(* ---- Constants ---- *)
| 1 (* OP_CONST *) ->
@@ -373,9 +205,6 @@ and run vm =
| 4 (* OP_FALSE *) -> push vm (Bool false)
| 5 (* OP_POP *) -> ignore (pop vm)
| 6 (* OP_DUP *) -> push vm (peek vm)
| 7 (* OP_SWAP *) ->
let a = pop vm in let b = pop vm in
push vm a; push vm b
(* ---- Variable access ---- *)
| 16 (* OP_LOCAL_GET *) ->
@@ -410,23 +239,20 @@ and run vm =
| 20 (* OP_GLOBAL_GET *) ->
let idx = read_u16 frame in
let name = match consts.(idx) with String s -> s | _ -> "" in
(* Check closure env first (matches OP_GLOBAL_SET priority) *)
let id = Sx_types.intern name in
let found_in_env = match frame.closure.vm_closure_env with
| Some env ->
let rec env_lookup e =
try Some (Hashtbl.find e.bindings id)
with Not_found ->
match e.parent with Some p -> env_lookup p | None -> None
in env_lookup env
| None -> None
in
let v = match found_in_env with
| Some v -> v
let v = try Hashtbl.find vm.globals name with Not_found ->
(* Walk the closure env chain for inner functions *)
let rec env_lookup e =
try Hashtbl.find e.bindings name
with Not_found ->
match e.parent with Some p -> env_lookup p | None ->
try Sx_primitives.get_primitive name
with _ -> raise (Eval_error ("VM undefined: " ^ name))
in
match frame.closure.vm_closure_env with
| Some env -> env_lookup env
| None ->
try Hashtbl.find vm.globals name with Not_found ->
try Sx_primitives.get_primitive name
with _ -> raise (Eval_error ("VM undefined: " ^ name))
try Sx_primitives.get_primitive name
with _ -> raise (Eval_error ("VM undefined: " ^ name))
in
push vm v
| 21 (* OP_GLOBAL_SET *) ->
@@ -435,19 +261,14 @@ and run vm =
(* Write to closure env if the name exists there (mutable closure vars) *)
let written = match frame.closure.vm_closure_env with
| Some env ->
let id = Sx_types.intern name in
let rec find_env e =
if Hashtbl.mem e.bindings id then
(Hashtbl.replace e.bindings id (peek vm); true)
if Hashtbl.mem e.bindings name then
(Hashtbl.replace e.bindings name (peek vm); true)
else match e.parent with Some p -> find_env p | None -> false
in find_env env
| None -> false
in
if not written then begin
let v = peek vm in
Hashtbl.replace vm.globals name v;
(match !Sx_types._vm_global_set_hook with Some f -> f name v | None -> ())
end
if not written then Hashtbl.replace vm.globals name (peek vm)
(* ---- Control flow ---- *)
| 32 (* OP_JUMP *) ->
@@ -462,40 +283,6 @@ and run vm =
let v = pop vm in
if sx_truthy v then frame.ip <- frame.ip + offset
(* ---- Exception handling ---- *)
| 35 (* OP_PUSH_HANDLER *) ->
let catch_offset = read_i16 frame in
let entry = {
h_catch_ip = frame.ip + catch_offset;
h_frame_depth = List.length vm.frames;
h_sp = vm.sp;
h_frame = frame;
} in
vm.handler_stack <- entry :: vm.handler_stack
| 36 (* OP_POP_HANDLER *) ->
(match vm.handler_stack with
| _ :: rest -> vm.handler_stack <- rest
| [] -> ())
| 37 (* OP_RAISE *) ->
let exn_val = pop vm in
(match vm.handler_stack with
| entry :: rest ->
vm.handler_stack <- rest;
(* Unwind frames to the handler's depth *)
while List.length vm.frames > entry.h_frame_depth do
match vm.frames with
| _ :: fs -> vm.frames <- fs
| [] -> ()
done;
(* Restore stack pointer and jump to catch *)
vm.sp <- entry.h_sp;
entry.h_frame.ip <- entry.h_catch_ip;
push vm exn_val
| [] ->
(* No handler — raise OCaml exception for CEK to catch *)
raise (Eval_error (Printf.sprintf "Unhandled exception: %s"
(Sx_runtime.value_to_str exn_val))))
(* ---- Function calls ---- *)
| 48 (* OP_CALL *) ->
let argc = read_u8 frame in
@@ -551,7 +338,7 @@ and run vm =
frame.closure.vm_upvalues.(index)
) in
let cl = { vm_code = code; vm_upvalues = upvalues; vm_name = None;
vm_env_ref = vm.globals; vm_closure_env = frame.closure.vm_closure_env } in
vm_env_ref = vm.globals; vm_closure_env = None } in
push vm (VmClosure cl)
| 52 (* OP_CALL_PRIM *) ->
let idx = read_u16 frame in
@@ -567,16 +354,15 @@ and run vm =
| _ -> v) args in
let result =
try
(* Single lookup: vm.globals is the sole source of truth.
Primitives are seeded into vm.globals at init as NativeFn values.
OP_DEFINE and registerNative naturally override them. *)
let fn_val = try Hashtbl.find vm.globals name with Not_found ->
(* Check primitives FIRST (native implementations of map/filter/etc.),
then globals (which may have ho_via_cek wrappers that route
through the CEK — these can't call VM closures). *)
let fn_val = try Sx_primitives.get_primitive name with _ ->
try Hashtbl.find vm.globals name with Not_found ->
raise (Eval_error ("VM: unknown primitive " ^ name))
in
(match fn_val with
| NativeFn (_, fn) -> fn args
| VmClosure _ | Lambda _ | Component _ | Island _ ->
Sx_ref.cek_call fn_val (List args)
| _ -> Nil)
with Eval_error msg ->
raise (Eval_error (Printf.sprintf "%s (in CALL_PRIM \"%s\" with %d args)"
@@ -612,52 +398,38 @@ and run vm =
let idx = read_u16 frame in
let name = match consts.(idx) with String s -> s | _ -> "" in
let v = peek vm in
Hashtbl.replace vm.globals name v;
(match !Sx_types._vm_global_set_hook with
| Some f -> f name v | None -> ())
Hashtbl.replace vm.globals name v
(* ---- Inline primitives ----
Fast path for common types; fallback to actual primitive
for edge cases (type coercion, thunks, RawHTML, etc.)
to guarantee behavioral parity with CALL_PRIM. *)
(* ---- Inline primitives (no hashtable lookup) ---- *)
| 160 (* OP_ADD *) ->
let b = pop vm and a = pop vm in
push vm (match a, b with
| Number x, Number y -> Number (x +. y)
| _ -> (Hashtbl.find Sx_primitives.primitives "+") [a; b])
| String x, String y -> String (x ^ y)
| _ -> Sx_primitives.(get_primitive "+" |> function NativeFn (_, f) -> f [a; b] | _ -> Nil))
| 161 (* OP_SUB *) ->
let b = pop vm and a = pop vm in
push vm (match a, b with
| Number x, Number y -> Number (x -. y)
| _ -> (Hashtbl.find Sx_primitives.primitives "-") [a; b])
push vm (match a, b with Number x, Number y -> Number (x -. y) | _ -> Nil)
| 162 (* OP_MUL *) ->
let b = pop vm and a = pop vm in
push vm (match a, b with
| Number x, Number y -> Number (x *. y)
| _ -> (Hashtbl.find Sx_primitives.primitives "*") [a; b])
push vm (match a, b with Number x, Number y -> Number (x *. y) | _ -> Nil)
| 163 (* OP_DIV *) ->
let b = pop vm and a = pop vm in
push vm (match a, b with
| Number x, Number y -> Number (x /. y)
| _ -> (Hashtbl.find Sx_primitives.primitives "/") [a; b])
push vm (match a, b with Number x, Number y -> Number (x /. y) | _ -> Nil)
| 164 (* OP_EQ *) ->
let b = pop vm and a = pop vm in
(* Must normalize ListRef→List before structural compare,
same as the "=" primitive in sx_primitives.ml *)
let rec norm = function
| ListRef { contents = l } -> List (List.map norm l)
| List l -> List (List.map norm l) | v -> v in
push vm (Bool (norm a = norm b))
| 165 (* OP_LT *) ->
let b = pop vm and a = pop vm in
push vm (match a, b with
| Number x, Number y -> Bool (x < y)
| String x, String y -> Bool (x < y)
| _ -> (Hashtbl.find Sx_primitives.primitives "<") [a; b])
push vm (match a, b with Number x, Number y -> Bool (x < y) | String x, String y -> Bool (x < y) | _ -> Bool false)
| 166 (* OP_GT *) ->
let b = pop vm and a = pop vm in
push vm (match a, b with
| Number x, Number y -> Bool (x > y)
| String x, String y -> Bool (x > y)
| _ -> (Hashtbl.find Sx_primitives.primitives ">") [a; b])
push vm (match a, b with Number x, Number y -> Bool (x > y) | String x, String y -> Bool (x > y) | _ -> Bool false)
| 167 (* OP_NOT *) ->
let v = pop vm in
push vm (Bool (not (sx_truthy v)))
@@ -667,57 +439,36 @@ and run vm =
| 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
| _ -> (Hashtbl.find Sx_primitives.primitives "len") [v])
| Nil -> Number 0.0 | _ -> Number 0.0)
| 169 (* OP_FIRST *) ->
let v = pop vm in
push vm (match v with
| List (x :: _) | ListRef { contents = x :: _ } -> x
| List [] | ListRef { contents = [] } | Nil -> Nil
| _ -> (Hashtbl.find Sx_primitives.primitives "first") [v])
push vm (match v with List (x :: _) | ListRef { contents = x :: _ } -> x | _ -> Nil)
| 170 (* OP_REST *) ->
let v = pop vm in
push vm (match v with
| List (_ :: xs) | ListRef { contents = _ :: xs } -> List xs
| List [] | ListRef { contents = [] } | Nil -> List []
| _ -> (Hashtbl.find Sx_primitives.primitives "rest") [v])
push vm (match v with List (_ :: xs) | ListRef { contents = _ :: xs } -> List xs | _ -> List [])
| 171 (* OP_NTH *) ->
let n = pop vm and coll = pop vm in
push vm (match coll, n with
| (List l | ListRef { contents = l }), Number f ->
(try List.nth l (int_of_float f) with _ -> Nil)
| String s, Number f ->
let i = int_of_float f in
if i >= 0 && i < String.length s then String (String.make 1 s.[i])
else Nil
| _ -> (Hashtbl.find Sx_primitives.primitives "nth") [coll; n])
let i = match n with Number f -> int_of_float f | _ -> 0 in
push vm (match coll with
| List l | ListRef { contents = l } ->
(try List.nth l i with _ -> Nil)
| _ -> Nil)
| 172 (* OP_CONS *) ->
let coll = pop vm and x = pop vm in
push vm (match coll with
| List l -> List (x :: l)
| ListRef { contents = l } -> List (x :: l)
| Nil -> List [x]
| _ -> (Hashtbl.find Sx_primitives.primitives "cons") [x; coll])
| _ -> List [x])
| 173 (* OP_NEG *) ->
let v = pop vm in
push vm (match v with
| Number x -> Number (-.x)
| _ -> (Hashtbl.find Sx_primitives.primitives "-") [v])
push vm (match v with Number x -> Number (-.x) | _ -> Nil)
| 174 (* OP_INC *) ->
let v = pop vm in
push vm (match v with
| Number x -> Number (x +. 1.0)
| _ -> (Hashtbl.find Sx_primitives.primitives "inc") [v])
push vm (match v with Number x -> Number (x +. 1.0) | _ -> Nil)
| 175 (* OP_DEC *) ->
let v = pop vm in
push vm (match v with
| Number x -> Number (x -. 1.0)
| _ -> (Hashtbl.find Sx_primitives.primitives "dec") [v])
(* ---- IO Suspension ---- *)
| 112 (* OP_PERFORM *) ->
let request = pop vm in
raise (VmSuspended (request, vm))
push vm (match v with Number x -> Number (x -. 1.0) | _ -> Nil)
| opcode ->
raise (Eval_error (Printf.sprintf "VM: unknown opcode %d at ip=%d"
@@ -731,26 +482,6 @@ and run vm =
end
done
(** Resume a suspended VM by pushing the IO result and continuing.
May raise VmSuspended again if the VM hits another OP_PERFORM. *)
let resume_vm vm result =
(match vm.pending_cek with
| Some cek_state ->
(* Resume the suspended CEK evaluation first *)
vm.pending_cek <- None;
let final = Sx_ref.cek_resume cek_state result in
(match Sx_runtime.get_val final (String "phase") with
| String "io-suspended" ->
(* CEK suspended again — re-suspend the VM *)
vm.pending_cek <- Some final;
raise (VmSuspended (Sx_runtime.get_val final (String "request"), vm))
| _ ->
push vm (Sx_ref.cek_value final))
| None ->
push vm result);
run vm;
pop vm
(** Execute a compiled module (top-level bytecode). *)
let execute_module code globals =
let cl = { vm_code = code; vm_upvalues = [||]; vm_name = Some "module"; vm_env_ref = globals; vm_closure_env = None } in
@@ -761,16 +492,6 @@ let execute_module code globals =
run vm;
pop vm
(** Execute module, catching VmSuspended locally (same compilation unit).
Returns [Ok result] or [Error (request, vm)] for import suspension.
Needed because js_of_ocaml can't catch exceptions across module boundaries. *)
let execute_module_safe code globals =
try
let result = execute_module code globals in
Ok result
with VmSuspended (request, vm) ->
Error (request, vm)
(** {1 Lazy JIT compilation} *)
@@ -793,20 +514,29 @@ let jit_compile_lambda (l : lambda) globals =
let param_syms = List (List.map (fun s -> Symbol s) l.l_params) in
let fn_expr = List [Symbol "fn"; param_syms; l.l_body] in
let quoted = List [Symbol "quote"; fn_expr] in
(* Use Symbol "compile" so the CEK resolves it from the env, not
an embedded VmClosure value — the CEK dispatches VmClosure calls
differently when the value is resolved from env vs embedded in AST. *)
ignore compile_fn;
let compile_env = Sx_types.env_extend (Sx_types.make_env ()) in
Hashtbl.iter (fun k v -> Hashtbl.replace compile_env.bindings (Sx_types.intern k) v) globals;
let result = Sx_ref.eval_expr (List [Symbol "compile"; quoted]) (Env compile_env) in
(* Closure vars are accessible via vm_closure_env (set on the VmClosure
at line ~617). OP_GLOBAL_GET falls back to vm_closure_env when vars
aren't in globals. No injection into the shared globals table —
that would break closure isolation for factory functions like
make-page-fn where multiple closures capture different values
for the same variable names. *)
let effective_globals = globals in
let result = Sx_ref.eval_expr (List [compile_fn; quoted]) (Env (make_env ())) in
(* If the lambda has closure-captured variables, merge them into globals
so the VM can find them via GLOBAL_GET. The compiler doesn't know
about the enclosing scope, so closure vars get compiled as globals. *)
let effective_globals =
let closure = l.l_closure in
if Hashtbl.length closure.bindings = 0 && closure.parent = None then
globals (* no closure vars — use globals directly *)
else begin
(* Merge: closure bindings layered on top of globals.
Use a shallow copy so we don't pollute the real globals. *)
let merged = Hashtbl.copy globals in
let rec inject env =
Hashtbl.iter (fun k v -> Hashtbl.replace merged k v) env.bindings;
match env.parent with Some p -> inject p | None -> ()
in
inject closure;
let n = Hashtbl.length merged - Hashtbl.length globals in
if n > 0 then
Printf.eprintf "[jit] %s: injected %d closure bindings\n%!" fn_name n;
merged
end
in
(match result with
| Dict d when Hashtbl.mem d "bytecode" ->
let outer_code = code_from_value result in
@@ -852,318 +582,3 @@ let jit_compile_lambda (l : lambda) globals =
(* Wire up forward references *)
let () = jit_compile_ref := jit_compile_lambda
let () = _vm_call_closure_ref := (fun cl args -> call_closure cl args cl.vm_env_ref)
(** {1 Debugging / introspection} *)
(** Map opcode integer to human-readable name. *)
let opcode_name = function
| 1 -> "CONST" | 2 -> "NIL" | 3 -> "TRUE" | 4 -> "FALSE"
| 5 -> "POP" | 6 -> "DUP" | 7 -> "SWAP"
| 16 -> "LOCAL_GET" | 17 -> "LOCAL_SET"
| 18 -> "UPVALUE_GET" | 19 -> "UPVALUE_SET"
| 20 -> "GLOBAL_GET" | 21 -> "GLOBAL_SET"
| 32 -> "JUMP" | 33 -> "JUMP_IF_FALSE" | 34 -> "JUMP_IF_TRUE"
| 35 -> "PUSH_HANDLER" | 36 -> "POP_HANDLER" | 37 -> "RAISE"
| 48 -> "CALL" | 49 -> "TAIL_CALL" | 50 -> "RETURN"
| 51 -> "CLOSURE" | 52 -> "CALL_PRIM"
| 64 -> "LIST" | 65 -> "DICT"
| 128 -> "DEFINE"
| 144 -> "STR_CONCAT"
| 160 -> "ADD" | 161 -> "SUB" | 162 -> "MUL" | 163 -> "DIV"
| 164 -> "EQ" | 165 -> "LT" | 166 -> "GT" | 167 -> "NOT"
| 168 -> "LEN" | 169 -> "FIRST" | 170 -> "REST" | 171 -> "NTH"
| 172 -> "CONS" | 173 -> "NEG" | 174 -> "INC" | 175 -> "DEC"
| n -> Printf.sprintf "UNKNOWN_%d" n
(** Number of extra operand bytes consumed by each opcode.
Returns (format, total_bytes) where format describes the operand types. *)
let opcode_operand_size = function
| 1 (* CONST *) | 20 (* GLOBAL_GET *) | 21 (* GLOBAL_SET *)
| 64 (* LIST *) | 65 (* DICT *) | 128 (* DEFINE *) -> 2 (* u16 *)
| 16 (* LOCAL_GET *) | 17 (* LOCAL_SET *)
| 18 (* UPVALUE_GET *) | 19 (* UPVALUE_SET *)
| 48 (* CALL *) | 49 (* TAIL_CALL *)
| 144 (* STR_CONCAT *) -> 1 (* u8 *)
| 32 (* JUMP *) | 33 (* JUMP_IF_FALSE *) | 34 (* JUMP_IF_TRUE *)
| 35 (* PUSH_HANDLER *) -> 2 (* i16 *)
| 51 (* CLOSURE *) -> 2 (* u16 for constant index; upvalue descriptors follow dynamically *)
| 52 (* CALL_PRIM *) -> 3 (* u16 + u8 *)
| _ -> 0 (* no operand *)
(** Trace a single execution — compile + run, collecting trace entries.
Each entry is a dict with :opcode, :stack, :depth. *)
let trace_run src globals =
(* Compile *)
let compile_fn = try Hashtbl.find globals "compile"
with Not_found -> raise (Eval_error "trace: compiler not loaded") in
let exprs = Sx_parser.parse_all src in
let expr = match exprs with [e] -> e | _ -> List (Symbol "do" :: exprs) in
let quoted = List [Symbol "quote"; expr] in
let code_val = Sx_ref.eval_expr (List [compile_fn; quoted]) (Env (make_env ())) in
let code = code_from_value code_val in
let cl = { vm_code = code; vm_upvalues = [||]; vm_name = Some "trace";
vm_env_ref = globals; vm_closure_env = None } in
let vm = create globals in
let frame0 = { closure = cl; ip = 0; base = 0; local_cells = Hashtbl.create 4 } in
for _ = 0 to code.vc_locals - 1 do push vm Nil done;
vm.frames <- [frame0];
(* Run with tracing *)
let trace = ref [] in
let max_steps = 10000 in
let steps = ref 0 in
(try
while vm.frames <> [] && !steps < max_steps do
match vm.frames with
| [] -> ()
| frame :: _ ->
let bc = frame.closure.vm_code.vc_bytecode in
if frame.ip >= Array.length bc then
vm.frames <- []
else begin
let op = bc.(frame.ip) in
(* Snapshot stack top 5 *)
let stack_snap = List.init (min 5 vm.sp) (fun i ->
let v = vm.stack.(vm.sp - 1 - i) in
String (Sx_types.inspect v)) in
let entry = Hashtbl.create 4 in
Hashtbl.replace entry "opcode" (String (opcode_name op));
Hashtbl.replace entry "stack" (List stack_snap);
Hashtbl.replace entry "depth" (Number (float_of_int (List.length vm.frames)));
trace := Dict entry :: !trace;
incr steps;
(* Execute one step — use the main run loop for 1 step.
We do this by saving the state and running the original dispatch. *)
let saved_ip = frame.ip in
frame.ip <- frame.ip + 1;
let rest_frames = List.tl vm.frames in
(try match op with
| 1 -> let idx = read_u16 frame in push vm frame.closure.vm_code.vc_constants.(idx)
| 2 -> push vm Nil
| 3 -> push vm (Bool true)
| 4 -> push vm (Bool false)
| 5 -> ignore (pop vm)
| 6 -> push vm (peek vm)
| 7 -> let a = pop vm in let b = pop vm in push vm a; push vm b
| 16 -> let slot = read_u8 frame in
let v = match Hashtbl.find_opt frame.local_cells slot with
| Some cell -> cell.uv_value
| None -> vm.stack.(frame.base + slot) in
push vm v
| 17 -> let slot = read_u8 frame in let v = peek vm in
(match Hashtbl.find_opt frame.local_cells slot with
| Some cell -> cell.uv_value <- v
| None -> vm.stack.(frame.base + slot) <- v)
| 18 -> let idx = read_u8 frame in
push vm frame.closure.vm_upvalues.(idx).uv_value
| 19 -> let idx = read_u8 frame in
frame.closure.vm_upvalues.(idx).uv_value <- peek vm
| 20 -> let idx = read_u16 frame in
let name = match frame.closure.vm_code.vc_constants.(idx) with String s -> s | _ -> "" in
let v = try Hashtbl.find vm.globals name with Not_found ->
try Sx_primitives.get_primitive name with _ ->
raise (Eval_error ("VM undefined: " ^ name)) in
push vm v
| 21 -> let idx = read_u16 frame in
let name = match frame.closure.vm_code.vc_constants.(idx) with String s -> s | _ -> "" in
Hashtbl.replace vm.globals name (peek vm)
| 32 -> let offset = read_i16 frame in frame.ip <- frame.ip + offset
| 33 -> let offset = read_i16 frame in let v = pop vm in
if not (sx_truthy v) then frame.ip <- frame.ip + offset
| 34 -> let offset = read_i16 frame in let v = pop vm in
if sx_truthy v then frame.ip <- frame.ip + offset
| 35 -> let catch_offset = read_i16 frame in
vm.handler_stack <- { h_catch_ip = frame.ip + catch_offset;
h_frame_depth = List.length vm.frames; h_sp = vm.sp;
h_frame = frame } :: vm.handler_stack
| 36 -> (match vm.handler_stack with _ :: r -> vm.handler_stack <- r | [] -> ())
| 37 -> let exn_val = pop vm in
(match vm.handler_stack with
| entry :: rest ->
vm.handler_stack <- rest;
while List.length vm.frames > entry.h_frame_depth do
match vm.frames with _ :: fs -> vm.frames <- fs | [] -> () done;
vm.sp <- entry.h_sp; entry.h_frame.ip <- entry.h_catch_ip;
push vm exn_val
| [] -> vm.frames <- [])
| 48 -> let argc = read_u8 frame in
let args = Array.init argc (fun _ -> pop vm) in
let f = pop vm in
vm_call vm f (List.rev (Array.to_list args))
| 49 -> let argc = read_u8 frame in
let args = Array.init argc (fun _ -> pop vm) in
let f = pop vm in
vm.frames <- rest_frames; vm.sp <- frame.base;
vm_call vm f (List.rev (Array.to_list args))
| 50 -> let result = pop vm in
vm.frames <- rest_frames; vm.sp <- frame.base; push vm result
| 51 -> (* CLOSURE — skip for trace, just advance past upvalue descriptors *)
let idx = read_u16 frame in
let code_val2 = frame.closure.vm_code.vc_constants.(idx) in
let uv_count = match code_val2 with
| Dict d -> (match Hashtbl.find_opt d "upvalue-count" with
| Some (Number n) -> int_of_float n | _ -> 0)
| _ -> 0 in
let upvalues = Array.init uv_count (fun _ ->
let is_local = read_u8 frame in
let index = read_u8 frame in
if is_local = 1 then begin
let cell = match Hashtbl.find_opt frame.local_cells index with
| Some existing -> existing
| None ->
let c = { uv_value = vm.stack.(frame.base + index) } in
Hashtbl.replace frame.local_cells index c; c in
cell
end else frame.closure.vm_upvalues.(index)
) in
let inner_code = code_from_value code_val2 in
let c = { vm_code = inner_code; vm_upvalues = upvalues; vm_name = None;
vm_env_ref = vm.globals; vm_closure_env = frame.closure.vm_closure_env } in
push vm (VmClosure c)
| 52 -> let idx = read_u16 frame in let argc = read_u8 frame in
let name = match frame.closure.vm_code.vc_constants.(idx) with String s -> s | _ -> "" in
let args = List.init argc (fun _ -> pop vm) |> List.rev in
let fn_val = try Sx_primitives.get_primitive name with _ ->
try Hashtbl.find vm.globals name with Not_found ->
raise (Eval_error ("VM: unknown primitive " ^ name)) in
(match fn_val with NativeFn (_, fn) -> push vm (fn args) | _ -> push vm Nil)
| 64 -> let count = read_u16 frame in
let items = List.init count (fun _ -> pop vm) |> List.rev in
push vm (List items)
| 65 -> let count = read_u16 frame in
let d = Hashtbl.create count in
for _ = 1 to count do let v = pop vm in let k = pop vm in
let key = match k with String s -> s | Keyword s -> s | _ -> Sx_runtime.value_to_str k in
Hashtbl.replace d key v done;
push vm (Dict d)
| 128 -> let idx = read_u16 frame in
let name = match frame.closure.vm_code.vc_constants.(idx) with String s -> s | _ -> "" in
Hashtbl.replace vm.globals name (peek vm)
| 144 -> let count = read_u8 frame in
let parts = List.init count (fun _ -> pop vm) |> List.rev in
push vm (String (String.concat "" (List.map Sx_runtime.value_to_str parts)))
| 160 -> let b = pop vm and a = pop vm in
push vm (match a, b with Number x, Number y -> Number (x +. y) | _ -> Nil)
| 161 -> let b = pop vm and a = pop vm in
push vm (match a, b with Number x, Number y -> Number (x -. y) | _ -> Nil)
| 162 -> let b = pop vm and a = pop vm in
push vm (match a, b with Number x, Number y -> Number (x *. y) | _ -> Nil)
| 163 -> let b = pop vm and a = pop vm in
push vm (match a, b with Number x, Number y -> Number (x /. y) | _ -> Nil)
| 164 -> let b = pop vm and a = pop vm in push vm (Bool (a = b))
| 165 -> let b = pop vm and a = pop vm in
push vm (match a, b with Number x, Number y -> Bool (x < y) | _ -> Bool false)
| 166 -> let b = pop vm and a = pop vm in
push vm (match a, b with Number x, Number y -> Bool (x > y) | _ -> Bool false)
| 167 -> let v = pop vm in push vm (Bool (not (sx_truthy v)))
| 168 -> let v = pop vm in
push vm (match v with
| List l | ListRef { contents = l } -> Number (float_of_int (List.length l))
| String s -> Number (float_of_int (String.length s))
| _ -> Number 0.0)
| 169 -> let v = pop vm in
push vm (match v with List (x :: _) | ListRef { contents = x :: _ } -> x | _ -> Nil)
| 170 -> let v = pop vm in
push vm (match v with
| List (_ :: xs) | ListRef { contents = _ :: xs } -> List xs | _ -> List [])
| 171 -> let n = pop vm and coll = pop vm in
push vm (match coll, n with
| (List l | ListRef { contents = l }), Number f ->
(try List.nth l (int_of_float f) with _ -> Nil) | _ -> Nil)
| 172 -> let coll = pop vm and x = pop vm in
push vm (match coll with List l -> List (x :: l) | _ -> List [x])
| 173 -> let v = pop vm in
push vm (match v with Number x -> Number (-.x) | _ -> Nil)
| 174 -> let v = pop vm in
push vm (match v with Number x -> Number (x +. 1.0) | _ -> Nil)
| 175 -> let v = pop vm in
push vm (match v with Number x -> Number (x -. 1.0) | _ -> Nil)
| _ -> ()
with e ->
let _ = e in
ignore saved_ip;
(* On error during trace, just stop *)
vm.frames <- [])
end
done
with _ -> ());
List (List.rev !trace)
(** Disassemble a vm_code into a list of instruction dicts. *)
let disassemble (code : vm_code) =
let bc = code.vc_bytecode in
let len = Array.length bc in
let consts = code.vc_constants in
let instrs = ref [] in
let ip = ref 0 in
while !ip < len do
let offset = !ip in
let op = bc.(!ip) in
ip := !ip + 1;
let name = opcode_name op in
let operands = ref [] in
(match op with
| 1 (* CONST *) | 20 (* GLOBAL_GET *) | 21 (* GLOBAL_SET *)
| 128 (* DEFINE *) ->
if !ip + 1 < len then begin
let lo = bc.(!ip) in let hi = bc.(!ip + 1) in
let idx = lo lor (hi lsl 8) in
ip := !ip + 2;
let const_str = if idx < Array.length consts
then Sx_types.inspect consts.(idx) else "?" in
operands := [Number (float_of_int idx); String const_str]
end
| 64 (* LIST *) | 65 (* DICT *) | 51 (* CLOSURE *) ->
if !ip + 1 < len then begin
let lo = bc.(!ip) in let hi = bc.(!ip + 1) in
let idx = lo lor (hi lsl 8) in
ip := !ip + 2;
operands := [Number (float_of_int idx)];
(* For CLOSURE, skip upvalue descriptors *)
if op = 51 && idx < Array.length consts then begin
let uv_count = match consts.(idx) with
| Dict d -> (match Hashtbl.find_opt d "upvalue-count" with
| Some (Number n) -> int_of_float n | _ -> 0)
| _ -> 0 in
ip := !ip + uv_count * 2
end
end
| 16 (* LOCAL_GET *) | 17 (* LOCAL_SET *)
| 18 (* UPVALUE_GET *) | 19 (* UPVALUE_SET *)
| 48 (* CALL *) | 49 (* TAIL_CALL *)
| 144 (* STR_CONCAT *) ->
if !ip < len then begin
let v = bc.(!ip) in ip := !ip + 1;
operands := [Number (float_of_int v)]
end
| 32 (* JUMP *) | 33 (* JUMP_IF_FALSE *) | 34 (* JUMP_IF_TRUE *) ->
if !ip + 1 < len then begin
let lo = bc.(!ip) in let hi = bc.(!ip + 1) in
let raw = lo lor (hi lsl 8) in
let signed = if raw >= 32768 then raw - 65536 else raw in
ip := !ip + 2;
operands := [Number (float_of_int signed)]
end
| 52 (* CALL_PRIM *) ->
if !ip + 2 < len then begin
let lo = bc.(!ip) in let hi = bc.(!ip + 1) in
let idx = lo lor (hi lsl 8) in
let argc = bc.(!ip + 2) in
ip := !ip + 3;
let prim_name = if idx < Array.length consts
then (match consts.(idx) with String s -> s | _ -> "?") else "?" in
operands := [Number (float_of_int idx); String prim_name; Number (float_of_int argc)]
end
| _ -> ());
let entry = Hashtbl.create 4 in
Hashtbl.replace entry "offset" (Number (float_of_int offset));
Hashtbl.replace entry "opcode" (String name);
Hashtbl.replace entry "operands" (List !operands);
instrs := Dict entry :: !instrs
done;
let result = Hashtbl.create 4 in
Hashtbl.replace result "arity" (Number (float_of_int code.vc_arity));
Hashtbl.replace result "num_locals" (Number (float_of_int code.vc_locals));
Hashtbl.replace result "constants" (List (Array.to_list (Array.map (fun v -> String (Sx_types.inspect v)) consts)));
Hashtbl.replace result "bytecode" (List (List.rev !instrs));
Dict result

521
hosts/ocaml/lib/sx_vm_ref.ml
View File

File diff suppressed because one or more lines are too long

516
hosts/ocaml/sx_vm_ref.ml
View File

File diff suppressed because one or more lines are too long

3060
hosts/ocaml/transpiler.sx
View File

File diff suppressed because it is too large Load Diff

94
lib/bytecode.sx
View File

@@ -19,94 +19,6 @@
;; --------------------------------------------------------------------------
;; Stack / Constants
(define-library (sx bytecode)
(export
OP_CONST
OP_NIL
OP_TRUE
OP_FALSE
OP_POP
OP_DUP
OP_LOCAL_GET
OP_LOCAL_SET
OP_UPVALUE_GET
OP_UPVALUE_SET
OP_GLOBAL_GET
OP_GLOBAL_SET
OP_JUMP
OP_JUMP_IF_FALSE
OP_JUMP_IF_TRUE
OP_CALL
OP_TAIL_CALL
OP_RETURN
OP_CLOSURE
OP_CALL_PRIM
OP_APPLY
OP_LIST
OP_DICT
OP_APPEND_BANG
OP_ITER_INIT
OP_ITER_NEXT
OP_MAP_OPEN
OP_MAP_APPEND
OP_MAP_CLOSE
OP_FILTER_TEST
OP_HO_MAP
OP_HO_FILTER
OP_HO_REDUCE
OP_HO_FOR_EACH
OP_HO_SOME
OP_HO_EVERY
OP_SCOPE_PUSH
OP_SCOPE_POP
OP_PROVIDE_PUSH
OP_PROVIDE_POP
OP_CONTEXT
OP_EMIT
OP_EMITTED
OP_RESET
OP_SHIFT
OP_DEFINE
OP_DEFCOMP
OP_DEFISLAND
OP_DEFMACRO
OP_EXPAND_MACRO
OP_STR_CONCAT
OP_STR_JOIN
OP_SERIALIZE
OP_ADD
OP_SUB
OP_MUL
OP_DIV
OP_EQ
OP_LT
OP_GT
OP_NOT
OP_LEN
OP_FIRST
OP_REST
OP_NTH
OP_CONS
OP_NEG
OP_INC
OP_DEC
OP_ASER_TAG
OP_ASER_FRAG
BYTECODE_MAGIC
BYTECODE_VERSION
CONST_NUMBER
CONST_STRING
CONST_BOOL
CONST_NIL
CONST_SYMBOL
CONST_KEYWORD
CONST_LIST
CONST_DICT
CONST_CODE
opcode-name)
(begin
(define OP_CONST 1) ;; u16 pool_idx — push constant
(define OP_NIL 2) ;; push nil
(define OP_TRUE 3) ;; push true
@@ -249,9 +161,3 @@
(= op 50) "RETURN" (= op 52) "CALL_PRIM"
(= op 128) "DEFINE" (= op 144) "STR_CONCAT"
:else (str "OP_" op))))
)) ;; end define-library
;; Re-export to global namespace for backward compatibility
(import (sx bytecode))

12
lib/callcc.sx
View File

@@ -77,12 +77,6 @@
;; 2. call/cc — call with current continuation
;; --------------------------------------------------------------------------
(define-library (sx callcc)
(export
sf-callcc)
(begin
(define sf-callcc
(fn (args env)
;; Single argument: a function to call with the current continuation.
@@ -249,9 +243,3 @@
;; dispatch in eval-list (same path as lambda calls).
;;
;; --------------------------------------------------------------------------
)) ;; end define-library
;; Re-export to global namespace for backward compatibility
(import (sx callcc))

1941
lib/compiler.sx
View File

File diff suppressed because it is too large Load Diff

17
lib/content.sx
View File

@@ -11,17 +11,6 @@
;; localStorage or IPFS by providing their own store backend.
;; ==========================================================================
(define-library (sx content)
(export
content-store
content-hash
content-put
content-get
freeze-to-cid
thaw-from-cid)
(begin
(define content-store (dict))
(define content-hash :effects []
@@ -57,9 +46,3 @@
(when sx-text
(thaw-from-sx sx-text)
true))))
)) ;; end define-library
;; Re-export to global namespace for backward compatibility
(import (sx content))

175
lib/freeze.sx
View File

@@ -20,110 +20,75 @@
;; ==========================================================================
;; Registry of freeze scopes: name → list of {name signal} entries
(define freeze-registry (dict))
(define-library
(sx freeze)
(export
freeze-registry
freeze-signal
freeze-scope
cek-freeze-scope
cek-freeze-all
cek-thaw-scope
cek-thaw-all
freeze-to-sx
thaw-from-sx)
(begin
(define freeze-registry (dict))
(define
freeze-signal
:effects (mutation)
(fn
(name sig)
(let
((scope-name (context "sx-freeze-scope" nil)))
(when
scope-name
(let
((entries (or (get freeze-registry scope-name) (list))))
(append! entries (dict "name" name "signal" sig))
(dict-set! freeze-registry scope-name entries))))))
(define
freeze-scope
:effects (mutation)
(fn
(name body-fn)
(scope-push! "sx-freeze-scope" name)
(dict-set! freeze-registry name (list))
(cek-call body-fn nil)
(scope-pop! "sx-freeze-scope")
nil))
(define
cek-freeze-scope
:effects ()
(fn
(name)
(let
((entries (or (get freeze-registry name) (list)))
(signals-dict (dict)))
(for-each
(fn
(entry)
(dict-set!
signals-dict
(get entry "name")
(signal-value (get entry "signal"))))
entries)
(dict "name" name "signals" signals-dict))))
(define
cek-freeze-all
:effects ()
(fn
()
(map (fn (name) (cek-freeze-scope name)) (keys freeze-registry))))
(define
cek-thaw-scope
:effects (mutation)
(fn
(name frozen)
(let
((entries (or (get freeze-registry name) (list)))
(values (get frozen "signals")))
(when
values
(for-each
(fn
(entry)
(let
((sig-name (get entry "name"))
(sig (get entry "signal"))
(val (get values sig-name)))
(when (not (nil? val)) (reset! sig val))))
entries)))))
(define
cek-thaw-all
:effects (mutation)
(fn
(frozen-list)
(for-each
(fn (frozen) (cek-thaw-scope (get frozen "name") frozen))
frozen-list)))
(define
freeze-to-sx
:effects ()
(fn (name) (sx-serialize (cek-freeze-scope name))))
(define
thaw-from-sx
:effects (mutation)
(fn
(sx-text)
(let
((parsed (sx-parse sx-text)))
(when
(not (empty? parsed))
(let
((frozen (first parsed)))
(cek-thaw-scope (get frozen "name") frozen)))))))) ;; end define-library
;; Register a signal in the current freeze scope
(define freeze-signal :effects [mutation]
(fn (name sig)
(let ((scope-name (context "sx-freeze-scope" nil)))
(when scope-name
(let ((entries (or (get freeze-registry scope-name) (list))))
(append! entries (dict "name" name "signal" sig))
(dict-set! freeze-registry scope-name entries))))))
;; Re-export to global namespace for backward compatibility
(import (sx freeze))
;; Freeze scope delimiter — collects signals registered within body
(define freeze-scope :effects [mutation]
(fn (name body-fn)
(scope-push! "sx-freeze-scope" name)
;; Initialize empty entry list for this scope
(dict-set! freeze-registry name (list))
(cek-call body-fn nil)
(scope-pop! "sx-freeze-scope")
nil))
;; Freeze a named scope → SX dict of signal values
(define cek-freeze-scope :effects []
(fn (name)
(let ((entries (or (get freeze-registry name) (list)))
(signals-dict (dict)))
(for-each (fn (entry)
(dict-set! signals-dict
(get entry "name")
(signal-value (get entry "signal"))))
entries)
(dict "name" name "signals" signals-dict))))
;; Freeze all scopes
(define cek-freeze-all :effects []
(fn ()
(map (fn (name) (cek-freeze-scope name))
(keys freeze-registry))))
;; Thaw a named scope — restore signal values from frozen data
(define cek-thaw-scope :effects [mutation]
(fn (name frozen)
(let ((entries (or (get freeze-registry name) (list)))
(values (get frozen "signals")))
(when values
(for-each (fn (entry)
(let ((sig-name (get entry "name"))
(sig (get entry "signal"))
(val (get values sig-name)))
(when (not (nil? val))
(reset! sig val))))
entries)))))
;; Thaw all scopes from a list of frozen scope dicts
(define cek-thaw-all :effects [mutation]
(fn (frozen-list)
(for-each (fn (frozen)
(cek-thaw-scope (get frozen "name") frozen))
frozen-list)))
;; Serialize a frozen scope to SX text
(define freeze-to-sx :effects []
(fn (name)
(sx-serialize (cek-freeze-scope name))))
;; Restore from SX text
(define thaw-from-sx :effects [mutation]
(fn (sx-text)
(let ((parsed (sx-parse sx-text)))
(when (not (empty? parsed))
(let ((frozen (first parsed)))
(cek-thaw-scope (get frozen "name") frozen))))))

340
lib/highlight.sx
View File

@@ -1,340 +0,0 @@
(define-library
(sx highlight)
(export
sx-specials
sx-special?
hl-digit?
hl-alpha?
hl-sym-char?
hl-ws?
hl-escape
hl-span
tokenize-sx
sx-token-classes
render-sx-tokens
highlight-sx
highlight)
(begin
(define
sx-specials
(list
"defcomp"
"defrelation"
"defisland"
"defpage"
"defhelper"
"define"
"defmacro"
"defconfig"
"deftest"
"if"
"when"
"cond"
"case"
"and"
"or"
"not"
"let"
"let*"
"lambda"
"fn"
"do"
"begin"
"quote"
"quasiquote"
"->"
"map"
"filter"
"reduce"
"some"
"every?"
"map-indexed"
"for-each"
"&key"
"&rest"
"set!"
"satisfies?"
"match"
"let-match"
"define-protocol"
"implement"
"->>"
"|>"
"as->"
"define-library"
"import"
"perform"
"guard"
"call/cc"
"raise"
"define-syntax"
"syntax-rules"
"make-parameter"
"parameterize"))
(define sx-special? (fn (s) (some (fn (x) (= x s)) sx-specials)))
(define hl-digit? (fn (c) (and (>= c "0") (<= c "9"))))
(define
hl-alpha?
(fn
(c)
(or (and (>= c "a") (<= c "z")) (and (>= c "A") (<= c "Z")))))
(define
hl-sym-char?
(fn
(c)
(or
(hl-alpha? c)
(hl-digit? c)
(= c "_")
(= c "-")
(= c "?")
(= c "!")
(= c "+")
(= c "*")
(= c "/")
(= c "<")
(= c ">")
(= c "=")
(= c "&")
(= c "."))))
(define
hl-ws?
(fn (c) (or (= c " ") (= c "\n") (= c "\t") (= c "\r"))))
(define hl-escape (fn (s) s))
(define
hl-span
(fn
(class text)
(if
(= class "")
(list (quote span) text)
(list (quote span) (make-keyword "class") class text))))
(define
tokenize-sx
(fn
(code)
(let
((tokens (list)) (i 0) (len (string-length code)))
(let
loop
()
(when
(< i len)
(let
((c (substring code i (+ i 1))))
(if
(= c ";")
(let
((start i))
(set! i (+ i 1))
(let
scan
()
(when
(and
(< i len)
(not (= (substring code i (+ i 1)) "\n")))
(set! i (+ i 1))
(scan)))
(set!
tokens
(append
tokens
(list (list "comment" (substring code start i))))))
(if
(= c "\"")
(let
((start i))
(set! i (+ i 1))
(let
sloop
()
(when
(< i len)
(let
((sc (substring code i (+ i 1))))
(if
(= sc "\\")
(do (set! i (+ i 2)) (sloop))
(if
(= sc "\"")
(set! i (+ i 1))
(do (set! i (+ i 1)) (sloop)))))))
(set!
tokens
(append
tokens
(list (list "string" (substring code start i))))))
(if
(= c ":")
(let
((start i))
(set! i (+ i 1))
(when
(and
(< i len)
(hl-alpha? (substring code i (+ i 1))))
(let
scan
()
(when
(and
(< i len)
(hl-sym-char? (substring code i (+ i 1))))
(set! i (+ i 1))
(scan))))
(set!
tokens
(append
tokens
(list (list "keyword" (substring code start i))))))
(if
(= c "~")
(let
((start i))
(set! i (+ i 1))
(let
scan
()
(when
(and
(< i len)
(let
((x (substring code i (+ i 1))))
(or (hl-sym-char? x) (= x "/"))))
(set! i (+ i 1))
(scan)))
(set!
tokens
(append
tokens
(list
(list "component" (substring code start i))))))
(if
(or
(= c "(")
(= c ")")
(= c "[")
(= c "]")
(= c "{")
(= c "}"))
(do
(set!
tokens
(append tokens (list (list "paren" c))))
(set! i (+ i 1)))
(if
(hl-digit? c)
(let
((start i))
(let
scan
()
(when
(and
(< i len)
(let
((x (substring code i (+ i 1))))
(or (hl-digit? x) (= x "."))))
(set! i (+ i 1))
(scan)))
(set!
tokens
(append
tokens
(list
(list "number" (substring code start i))))))
(if
(hl-sym-char? c)
(let
((start i))
(let
scan
()
(when
(and
(< i len)
(hl-sym-char?
(substring code i (+ i 1))))
(set! i (+ i 1))
(scan)))
(let
((text (substring code start i)))
(if
(or
(= text "true")
(= text "false")
(= text "nil"))
(set!
tokens
(append
tokens
(list (list "boolean" text))))
(if
(sx-special? text)
(set!
tokens
(append
tokens
(list (list "special" text))))
(set!
tokens
(append
tokens
(list (list "symbol" text))))))))
(if
(hl-ws? c)
(let
((start i))
(let
scan
()
(when
(and
(< i len)
(hl-ws? (substring code i (+ i 1))))
(set! i (+ i 1))
(scan)))
(set!
tokens
(append
tokens
(list
(list "ws" (substring code start i))))))
(do
(set!
tokens
(append tokens (list (list "other" c))))
(set! i (+ i 1))))))))))))
(loop)))
tokens)))
(define sx-token-classes {:boolean "text-orange-600" :component "text-rose-600 font-semibold" :number "text-amber-700" :string "text-emerald-700" :special "text-sky-700 font-semibold" :paren "text-stone-400" :keyword "text-violet-600" :comment "text-stone-400 italic"})
(define
render-sx-tokens
(fn
(tokens)
(map
(fn
(tok)
(let
((cls (or (dict-get sx-token-classes (first tok)) "")))
(hl-span cls (nth tok 1))))
tokens)))
(define highlight-sx (fn (code) (-> code tokenize-sx render-sx-tokens)))
(define
highlight
(fn
(code lang)
(if
(or
(= lang "lisp")
(= lang "sx")
(= lang "sexp")
(= lang "scheme"))
(highlight-sx code)
(list (quote code) code)))))) ;; end define-library
;; Re-export to global namespace for backward compatibility
(import (sx highlight))

569
lib/hyperscript/compiler.sx
View File

@@ -1,569 +0,0 @@
;; _hyperscript compiler — AST → SX expressions
;;
;; Input: AST from hs-parse (list structures)
;; Output: SX expressions targeting web/lib/dom.sx primitives
;;
;; Usage:
;; (hs-to-sx (hs-compile "on click add .active to me"))
;; → (hs-on me "click" (fn (event) (dom-add-class me "active")))
(define
hs-to-sx
(let
((dot-sym (make-symbol ".")) (pct-sym (make-symbol "%")))
(define emit-target (fn (ast) (hs-to-sx ast)))
(define
emit-set
(fn
(target value)
(if
(not (list? target))
(list (quote set!) target value)
(let
((th (first target)))
(cond
((= th dot-sym)
(list
(quote dom-set-prop)
(hs-to-sx (nth target 1))
(nth target 2)
value))
((= th (quote attr))
(list
(quote dom-set-attr)
(hs-to-sx (nth target 2))
(nth target 1)
value))
((= th (quote style))
(list
(quote dom-set-style)
(hs-to-sx (nth target 2))
(nth target 1)
value))
((= th (quote ref))
(list (quote set!) (make-symbol (nth target 1)) value))
((= th (quote local))
(list (quote set!) (make-symbol (nth target 1)) value))
((= th (quote me))
(list (quote dom-set-inner-html) (quote me) value))
((= th (quote it)) (list (quote set!) (quote it) value))
(true (list (quote set!) (hs-to-sx target) value)))))))
(define
emit-on
(fn
(ast)
(let
((parts (rest ast)))
(let
((event-name (first parts)))
(define
scan-on
(fn
(items source filter every?)
(cond
((<= (len items) 1)
(let
((body (if (> (len items) 0) (first items) nil)))
(let
((target (if source (hs-to-sx source) (quote me))))
(let
((handler (list (quote fn) (list (quote event)) (hs-to-sx body))))
(if
every?
(list
(quote hs-on-every)
target
event-name
handler)
(list (quote hs-on) target event-name handler))))))
((= (first items) :from)
(scan-on
(rest (rest items))
(nth items 1)
filter
every?))
((= (first items) :filter)
(scan-on
(rest (rest items))
source
(nth items 1)
every?))
((= (first items) :every)
(scan-on (rest (rest items)) source filter true))
(true (scan-on (rest items) source filter every?)))))
(scan-on (rest parts) nil nil false)))))
(define
emit-send
(fn
(ast)
(let
((name (nth ast 1)) (rest-parts (rest (rest ast))))
(cond
((and (= (len ast) 4) (list? (nth ast 2)) (= (first (nth ast 2)) (quote dict)))
(list
(quote dom-dispatch)
(hs-to-sx (nth ast 3))
name
(hs-to-sx (nth ast 2))))
((= (len ast) 3)
(list (quote dom-dispatch) (hs-to-sx (nth ast 2)) name nil))
(true (list (quote dom-dispatch) (quote me) name nil))))))
(define
emit-repeat
(fn
(ast)
(let
((mode (nth ast 1)) (body (hs-to-sx (nth ast 2))))
(cond
((and (list? mode) (= (first mode) (quote forever)))
(list
(quote hs-repeat-forever)
(list (quote fn) (list) body)))
((and (list? mode) (= (first mode) (quote times)))
(list
(quote hs-repeat-times)
(hs-to-sx (nth mode 1))
(list (quote fn) (list) body)))
((number? mode)
(list
(quote hs-repeat-times)
mode
(list (quote fn) (list) body)))
(true
(list
(quote hs-repeat-times)
(hs-to-sx mode)
(list (quote fn) (list) body)))))))
(define
emit-for
(fn
(ast)
(let
((var-name (nth ast 1))
(collection (hs-to-sx (nth ast 2)))
(body (hs-to-sx (nth ast 3))))
(if
(and (> (len ast) 4) (= (nth ast 4) :index))
(list
(quote for-each)
(list
(quote fn)
(list (make-symbol var-name) (make-symbol (nth ast 5)))
body)
collection)
(list
(quote for-each)
(list (quote fn) (list (make-symbol var-name)) body)
collection)))))
(define
emit-wait-for
(fn
(ast)
(let
((event-name (nth ast 1)))
(if
(and (> (len ast) 2) (= (nth ast 2) :from))
(list (quote hs-wait-for) (hs-to-sx (nth ast 3)) event-name)
(list (quote hs-wait-for) (quote me) event-name)))))
(define
emit-transition
(fn
(ast)
(let
((prop (nth ast 1)) (value (hs-to-sx (nth ast 2))))
(if
(= (len ast) 5)
(list
(quote hs-transition)
(hs-to-sx (nth ast 4))
prop
value
(nth ast 3))
(list
(quote hs-transition)
(hs-to-sx (nth ast 3))
prop
value
nil)))))
(define
emit-make
(fn
(ast)
(if
(= (len ast) 3)
(list
(quote let)
(list
(list
(make-symbol (nth ast 2))
(list (quote hs-make) (nth ast 1))))
(make-symbol (nth ast 2)))
(list (quote hs-make) (nth ast 1)))))
(define
emit-inc
(fn
(target)
(let
((t (hs-to-sx target)))
(if
(and (list? target) (= (first target) (quote attr)))
(list
(quote dom-set-attr)
(hs-to-sx (nth target 2))
(nth target 1)
(list
(quote +)
(list
(quote dom-get-attr)
(hs-to-sx (nth target 2))
(nth target 1))
1))
(list (quote set!) t (list (quote +) t 1))))))
(define
emit-dec
(fn
(target)
(let
((t (hs-to-sx target)))
(if
(and (list? target) (= (first target) (quote attr)))
(list
(quote dom-set-attr)
(hs-to-sx (nth target 2))
(nth target 1)
(list
(quote -)
(list
(quote dom-get-attr)
(hs-to-sx (nth target 2))
(nth target 1))
1))
(list (quote set!) t (list (quote -) t 1))))))
(define
emit-behavior
(fn
(ast)
(let
((name (nth ast 1)) (params (nth ast 2)) (body (nth ast 3)))
(list
(quote define)
(make-symbol name)
(list
(quote fn)
(cons (quote me) (map make-symbol params))
(cons (quote do) (map hs-to-sx body)))))))
(fn
(ast)
(cond
((nil? ast) nil)
((number? ast) ast)
((string? ast) ast)
((boolean? ast) ast)
((not (list? ast)) ast)
(true
(let
((head (first ast)))
(cond
((= head (quote me)) (quote me))
((= head (quote it)) (quote it))
((= head (quote event)) (quote event))
((= head dot-sym)
(list (quote get) (hs-to-sx (nth ast 1)) (nth ast 2)))
((= head (quote ref)) (make-symbol (nth ast 1)))
((= head (quote query))
(list (quote dom-query) (nth ast 1)))
((= head (quote attr))
(list
(quote dom-get-attr)
(hs-to-sx (nth ast 2))
(nth ast 1)))
((= head (quote style))
(list
(quote dom-get-style)
(hs-to-sx (nth ast 2))
(nth ast 1)))
((= head (quote local)) (make-symbol (nth ast 1)))
((= head (quote array))
(cons (quote list) (map hs-to-sx (rest ast))))
((= head (quote not))
(list (quote not) (hs-to-sx (nth ast 1))))
((= head (quote no))
(list (quote not) (hs-to-sx (nth ast 1))))
((= head (quote and))
(list
(quote and)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote or))
(list
(quote or)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote =))
(list
(quote =)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote +))
(list
(quote +)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote -))
(list
(quote -)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote *))
(list
(quote *)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote /))
(list
(quote /)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head pct-sym)
(list
pct-sym
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote empty?))
(list (quote empty?) (hs-to-sx (nth ast 1))))
((= head (quote exists?))
(list
(quote not)
(list (quote nil?) (hs-to-sx (nth ast 1)))))
((= head (quote matches?))
(list
(quote dom-matches?)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote contains?))
(list
(quote contains?)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote as))
(list (quote hs-coerce) (hs-to-sx (nth ast 1)) (nth ast 2)))
((= head (quote in?))
(list
(quote contains?)
(hs-to-sx (nth ast 2))
(hs-to-sx (nth ast 1))))
((= head (quote of))
(list
(quote get)
(hs-to-sx (nth ast 2))
(hs-to-sx (nth ast 1))))
((= head "!=")
(list
(quote not)
(list
(quote =)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2)))))
((= head "<")
(list
(quote <)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head ">")
(list
(quote >)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head "<=")
(list
(quote <=)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head ">=")
(list
(quote >=)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote closest))
(list
(quote dom-closest)
(hs-to-sx (nth ast 2))
(nth ast 1)))
((= head (quote next))
(list (quote hs-next) (hs-to-sx (nth ast 2)) (nth ast 1)))
((= head (quote previous))
(list
(quote hs-previous)
(hs-to-sx (nth ast 2))
(nth ast 1)))
((= head (quote first))
(if
(> (len ast) 2)
(list
(quote hs-first)
(hs-to-sx (nth ast 2))
(nth ast 1))
(list (quote hs-query-first) (nth ast 1))))
((= head (quote last))
(if
(> (len ast) 2)
(list (quote hs-last) (hs-to-sx (nth ast 2)) (nth ast 1))
(list (quote hs-query-last) (nth ast 1))))
((= head (quote add-class))
(list
(quote dom-add-class)
(hs-to-sx (nth ast 2))
(nth ast 1)))
((= head (quote remove-class))
(list
(quote dom-remove-class)
(hs-to-sx (nth ast 2))
(nth ast 1)))
((= head (quote toggle-class))
(list
(quote hs-toggle-class!)
(hs-to-sx (nth ast 2))
(nth ast 1)))
((= head (quote toggle-between))
(list
(quote hs-toggle-between!)
(hs-to-sx (nth ast 3))
(nth ast 1)
(nth ast 2)))
((= head (quote set!))
(emit-set (nth ast 1) (hs-to-sx (nth ast 2))))
((= head (quote put!))
(list
(quote hs-put!)
(hs-to-sx (nth ast 1))
(nth ast 2)
(hs-to-sx (nth ast 3))))
((= head (quote if))
(if
(> (len ast) 3)
(list
(quote if)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))
(hs-to-sx (nth ast 3)))
(list
(quote when)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2)))))
((= head (quote do))
(cons (quote do) (map hs-to-sx (rest ast))))
((= head (quote wait)) (list (quote hs-wait) (nth ast 1)))
((= head (quote wait-for)) (emit-wait-for ast))
((= head (quote log))
(list (quote log) (hs-to-sx (nth ast 1))))
((= head (quote send)) (emit-send ast))
((= head (quote trigger))
(list
(quote dom-dispatch)
(hs-to-sx (nth ast 2))
(nth ast 1)
nil))
((= head (quote hide))
(list
(quote dom-set-style)
(hs-to-sx (nth ast 1))
"display"
"none"))
((= head (quote show))
(list
(quote dom-set-style)
(hs-to-sx (nth ast 1))
"display"
""))
((= head (quote transition)) (emit-transition ast))
((= head (quote repeat)) (emit-repeat ast))
((= head (quote fetch))
(list (quote hs-fetch) (hs-to-sx (nth ast 1)) (nth ast 2)))
((= head (quote call))
(cons
(make-symbol (nth ast 1))
(map hs-to-sx (rest (rest ast)))))
((= head (quote return)) (hs-to-sx (nth ast 1)))
((= head (quote throw))
(list (quote raise) (hs-to-sx (nth ast 1))))
((= head (quote settle))
(list (quote hs-settle) (quote me)))
((= head (quote go))
(list (quote hs-navigate!) (hs-to-sx (nth ast 1))))
((= head (quote append!))
(list
(quote dom-append)
(hs-to-sx (nth ast 2))
(hs-to-sx (nth ast 1))))
((= head (quote tell))
(list
(quote let)
(list (list (quote me) (hs-to-sx (nth ast 1))))
(hs-to-sx (nth ast 2))))
((= head (quote for)) (emit-for ast))
((= head (quote take))
(list (quote hs-take!) (hs-to-sx (nth ast 2)) (nth ast 1)))
((= head (quote make)) (emit-make ast))
((= head (quote install))
(cons (quote hs-install) (map hs-to-sx (rest ast))))
((= head (quote measure))
(list (quote hs-measure) (hs-to-sx (nth ast 1))))
((= head (quote increment!)) (emit-inc (nth ast 1)))
((= head (quote decrement!)) (emit-dec (nth ast 1)))
((= head (quote on)) (emit-on ast))
((= head (quote init))
(list
(quote hs-init)
(list (quote fn) (list) (hs-to-sx (nth ast 1)))))
((= head (quote def))
(list
(quote define)
(make-symbol (nth ast 1))
(list
(quote fn)
(map make-symbol (nth ast 2))
(hs-to-sx (nth ast 3)))))
((= head (quote behavior)) (emit-behavior ast))
((= head (quote sx-eval))
(let
((src (nth ast 1)))
(if
(string? src)
(first (sx-parse src))
(list (quote cek-eval) (hs-to-sx src)))))
((= head (quote component)) (make-symbol (nth ast 1)))
((= head (quote render))
(let
((comp-raw (nth ast 1))
(kwargs (nth ast 2))
(pos (if (> (len ast) 3) (nth ast 3) nil))
(target
(if (> (len ast) 4) (hs-to-sx (nth ast 4)) nil)))
(let
((comp (if (string? comp-raw) (make-symbol comp-raw) (hs-to-sx comp-raw))))
(define
emit-kw-pairs
(fn
(pairs)
(if
(< (len pairs) 2)
(list)
(cons
(make-keyword (first pairs))
(cons
(hs-to-sx (nth pairs 1))
(emit-kw-pairs (rest (rest pairs))))))))
(let
((render-call (cons (quote render-to-html) (cons comp (emit-kw-pairs kwargs)))))
(if
pos
(list
(quote hs-put!)
render-call
pos
(if target target (quote me)))
render-call)))))
(true ast))))))))
;; ── Convenience: source → SX ─────────────────────────────────
(define hs-to-sx-from-source (fn (src) (hs-to-sx (hs-compile src))))

66
lib/hyperscript/integration.sx
View File

@@ -1,66 +0,0 @@
;; _hyperscript integration — wire _="..." attributes to compiled SX
;;
;; Entry points:
;; (hs-handler src) — compile source to callable (fn (me) ...)
;; (hs-activate! el) — activate hyperscript on a single element
;; (hs-boot!) — scan DOM, activate all _="..." elements
;; (hs-boot-subtree! root) — activate within a subtree (for HTMX swaps)
;; ── Compile source to a handler function ────────────────────────
;; Returns a function (fn (me) ...) that can be called with a DOM element.
;; Uses eval-expr-cek to turn the SX data structure into a live closure.
(define
hs-handler
(fn
(src)
(let
((sx (hs-to-sx-from-source src)))
(eval-expr-cek
(list
(quote fn)
(list (quote me))
(list
(quote let)
(list (list (quote it) nil) (list (quote event) nil))
sx))))))
;; ── Activate a single element ───────────────────────────────────
;; Reads the _="..." attribute, compiles, and executes with me=element.
;; Marks the element to avoid double-activation.
(define
hs-activate!
(fn
(el)
(let
((src (dom-get-attr el "_")))
(when
(and src (not (dom-get-data el "hs-active")))
(dom-set-data el "hs-active" true)
(let ((handler (hs-handler src))) (handler el))))))
;; ── Boot: scan entire document ──────────────────────────────────
;; Called once at page load. Finds all elements with _ attribute,
;; compiles their hyperscript, and activates them.
(define
hs-boot!
(fn
()
(let
((elements (dom-query-all (dom-body) "[_]")))
(for-each (fn (el) (hs-activate! el)) elements))))
;; ── Boot subtree: for dynamic content ───────────────────────────
;; Called after HTMX swaps or dynamic DOM insertion.
;; Only activates elements within the given root.
(define
hs-boot-subtree!
(fn
(root)
(let
((elements (dom-query-all root "[_]")))
(for-each (fn (el) (hs-activate! el)) elements))
(when (dom-get-attr root "_") (hs-activate! root))))

928
lib/hyperscript/parser.sx
View File

@@ -1,928 +0,0 @@
;; _hyperscript parser — token stream → SX AST
;;
;; Input: list of {:type T :value V :pos P} tokens from hs-tokenize
;; Output: SX AST forms that map to runtime primitives
;; ── Parser entry point ────────────────────────────────────────────
(define
hs-parse
(fn
(tokens src)
(let
((p 0) (tok-len (len tokens)))
(define tp (fn () (if (< p tok-len) (nth tokens p) nil)))
(define
tp-type
(fn () (let ((t (tp))) (if t (get t "type") "eof"))))
(define
tp-val
(fn () (let ((t (tp))) (if t (get t "value") nil))))
(define
adv!
(fn () (let ((t (nth tokens p))) (set! p (+ p 1)) t)))
(define at-end? (fn () (or (>= p tok-len) (= (tp-type) "eof"))))
(define
match-kw
(fn
(kw)
(if
(and (= (tp-type) "keyword") (= (tp-val) kw))
(do (adv!) true)
nil)))
(define
expect-kw!
(fn
(kw)
(if
(match-kw kw)
true
(error (str "Expected '" kw "' at position " p)))))
(define
parse-dur
(fn
(val)
(let
((slen (len val)))
(cond
((and (>= slen 3) (= (substring val (- slen 2) slen) "ms"))
(string->number (substring val 0 (- slen 2))))
((and (>= slen 2) (= (nth val (- slen 1)) "s"))
(* 1000 (string->number (substring val 0 (- slen 1)))))
(true (string->number val))))))
(define
parse-poss-tail
(fn
(owner)
(let
((typ (tp-type)) (val (tp-val)))
(cond
((or (= typ "ident") (= typ "keyword"))
(do (adv!) (parse-prop-chain (list (quote .) owner val))))
((= typ "class")
(let
((prop (get (adv!) "value")))
(parse-prop-chain (list (quote .) owner prop))))
(true owner)))))
(define
parse-prop-chain
(fn
(base)
(if
(and (= (tp-type) "class") (not (at-end?)))
(let
((prop (get (adv!) "value")))
(parse-prop-chain (list (quote .) base prop)))
base)))
(define
parse-trav
(fn
(kind)
(let
((typ (tp-type)) (val (tp-val)))
(cond
((= typ "selector")
(do (adv!) (list kind val (list (quote me)))))
((= typ "class")
(do (adv!) (list kind (str "." val) (list (quote me)))))
((= typ "id")
(do (adv!) (list kind (str "#" val) (list (quote me)))))
(true (list kind "*" (list (quote me))))))))
(define
parse-pos-kw
(fn
(kind)
(let
((typ (tp-type)) (val (tp-val)))
(let
((sel (cond ((= typ "selector") (do (adv!) val)) ((= typ "class") (do (adv!) (str "." val))) ((= typ "id") (do (adv!) (str "#" val))) (true "*"))))
(if
(match-kw "in")
(list kind sel (parse-expr))
(list kind sel))))))
(define
parse-atom
(fn
()
(let
((typ (tp-type)) (val (tp-val)))
(cond
((= typ "number") (do (adv!) (parse-dur val)))
((= typ "string") (do (adv!) val))
((and (= typ "keyword") (= val "true")) (do (adv!) true))
((and (= typ "keyword") (= val "false")) (do (adv!) false))
((and (= typ "keyword") (or (= val "null") (= val "nil")))
(do (adv!) nil))
((and (= typ "keyword") (= val "not"))
(do (adv!) (list (quote not) (parse-expr))))
((and (= typ "keyword") (= val "no"))
(do (adv!) (list (quote no) (parse-expr))))
((and (= typ "keyword") (= val "eval"))
(do
(adv!)
(if
(= (tp-type) "paren-open")
(list (quote sx-eval) (collect-sx-source))
(list (quote sx-eval) (parse-expr)))))
((and (= typ "keyword") (= val "the"))
(do (adv!) (parse-the-expr)))
((and (= typ "keyword") (= val "me"))
(do (adv!) (list (quote me))))
((and (= typ "keyword") (or (= val "it") (= val "result")))
(do (adv!) (list (quote it))))
((and (= typ "keyword") (= val "event"))
(do (adv!) (list (quote event))))
((and (= typ "keyword") (= val "target"))
(do
(adv!)
(list (make-symbol ".") (list (quote event)) "target")))
((and (= typ "keyword") (= val "detail"))
(do
(adv!)
(list (make-symbol ".") (list (quote event)) "detail")))
((and (= typ "keyword") (= val "my"))
(do (adv!) (parse-poss-tail (list (quote me)))))
((and (= typ "keyword") (= val "its"))
(do (adv!) (parse-poss-tail (list (quote it)))))
((and (= typ "keyword") (= val "closest"))
(do (adv!) (parse-trav (quote closest))))
((and (= typ "keyword") (= val "next"))
(do (adv!) (parse-trav (quote next))))
((and (= typ "keyword") (= val "previous"))
(do (adv!) (parse-trav (quote previous))))
((and (= typ "keyword") (= val "first"))
(do (adv!) (parse-pos-kw (quote first))))
((and (= typ "keyword") (= val "last"))
(do (adv!) (parse-pos-kw (quote last))))
((= typ "id")
(do (adv!) (list (quote query) (str "#" val))))
((= typ "selector") (do (adv!) (list (quote query) val)))
((= typ "attr")
(do (adv!) (list (quote attr) val (list (quote me)))))
((= typ "style")
(do (adv!) (list (quote style) val (list (quote me)))))
((= typ "local") (do (adv!) (list (quote local) val)))
((= typ "class") (do (adv!) (str "." val)))
((= typ "ident") (do (adv!) (list (quote ref) val)))
((= typ "paren-open")
(do
(adv!)
(let
((expr (parse-expr)))
(if (= (tp-type) "paren-close") (adv!) nil)
expr)))
((= typ "bracket-open") (do (adv!) (parse-array-lit)))
((and (= typ "op") (= val "-"))
(do
(adv!)
(let
((operand (parse-atom)))
(list (quote -) 0 operand))))
((= typ "component")
(do (adv!) (list (quote component) val)))
(true nil)))))
(define
parse-poss
(fn
(obj)
(cond
((and (= (tp-type) "op") (= (tp-val) "'s"))
(do (adv!) (parse-poss-tail obj)))
((= (tp-type) "class") (parse-prop-chain obj))
(true obj))))
(define
parse-cmp
(fn
(left)
(let
((typ (tp-type)) (val (tp-val)))
(cond
((and (= typ "op") (or (= val "==") (= val "!=") (= val "<") (= val ">") (= val "<=") (= val ">=")))
(do
(adv!)
(let
((right (parse-expr)))
(list (if (= val "==") (quote =) val) left right))))
((and (= typ "keyword") (= val "is"))
(do
(adv!)
(cond
((match-kw "not")
(if
(match-kw "empty")
(list (quote not) (list (quote empty?) left))
(let
((right (parse-expr)))
(list (quote not) (list (quote =) left right)))))
((match-kw "empty") (list (quote empty?) left))
(true
(let
((right (parse-expr)))
(list (quote =) left right))))))
((and (= typ "keyword") (= val "exists"))
(do (adv!) (list (quote exists?) left)))
((and (= typ "keyword") (= val "matches"))
(do (adv!) (list (quote matches?) left (parse-expr))))
((and (= typ "keyword") (= val "contains"))
(do (adv!) (list (quote contains?) left (parse-expr))))
((and (= typ "keyword") (= val "and"))
(do (adv!) (list (quote and) left (parse-expr))))
((and (= typ "keyword") (= val "or"))
(do (adv!) (list (quote or) left (parse-expr))))
((and (= typ "keyword") (= val "as"))
(do
(adv!)
(let
((type-name (tp-val)))
(adv!)
(list (quote as) left type-name))))
((and (= typ "keyword") (= val "of"))
(do
(adv!)
(let
((target (parse-expr)))
(if
(and (list? left) (= (first left) (quote ref)))
(list (make-symbol ".") target (nth left 1))
(list (quote of) left target)))))
((and (= typ "keyword") (= val "in"))
(do (adv!) (list (quote in?) left (parse-expr))))
(true left)))))
(define
parse-expr
(fn
()
(let
((left (parse-atom)))
(if
(nil? left)
nil
(let
((left2 (parse-poss left)))
(let ((left3 (parse-arith left2))) (parse-cmp left3)))))))
(define
parse-tgt-kw
(fn (kw default) (if (match-kw kw) (parse-expr) default)))
(define
parse-add-cmd
(fn
()
(if
(= (tp-type) "class")
(let
((cls (get (adv!) "value")))
(let
((tgt (parse-tgt-kw "to" (list (quote me)))))
(list (quote add-class) cls tgt)))
nil)))
(define
parse-remove-cmd
(fn
()
(if
(= (tp-type) "class")
(let
((cls (get (adv!) "value")))
(let
((tgt (parse-tgt-kw "from" (list (quote me)))))
(list (quote remove-class) cls tgt)))
nil)))
(define
parse-toggle-cmd
(fn
()
(cond
((match-kw "between")
(if
(= (tp-type) "class")
(let
((cls1 (get (adv!) "value")))
(expect-kw! "and")
(if
(= (tp-type) "class")
(let
((cls2 (get (adv!) "value")))
(let
((tgt (parse-tgt-kw "on" (list (quote me)))))
(list (quote toggle-between) cls1 cls2 tgt)))
nil))
nil))
((= (tp-type) "class")
(let
((cls (get (adv!) "value")))
(let
((tgt (parse-tgt-kw "on" (list (quote me)))))
(list (quote toggle-class) cls tgt))))
(true nil))))
(define
parse-set-cmd
(fn
()
(let
((tgt (parse-expr)))
(expect-kw! "to")
(let ((value (parse-expr))) (list (quote set!) tgt value)))))
(define
parse-put-cmd
(fn
()
(let
((value (parse-expr)))
(cond
((match-kw "into") (list (quote set!) (parse-expr) value))
((match-kw "before")
(list (quote put!) value "before" (parse-expr)))
((match-kw "after")
(list (quote put!) value "after" (parse-expr)))
(true
(error (str "Expected into/before/after at position " p)))))))
(define
parse-if-cmd
(fn
()
(let
((cnd (parse-expr)))
(let
((then-body (parse-cmd-list)))
(let
((else-body (if (or (match-kw "else") (match-kw "otherwise")) (parse-cmd-list) nil)))
(match-kw "end")
(if
else-body
(list (quote if) cnd then-body else-body)
(list (quote if) cnd then-body)))))))
(define
parse-wait-cmd
(fn
()
(cond
((match-kw "for")
(let
((event-name (tp-val)))
(adv!)
(let
((source (if (match-kw "from") (parse-expr) nil)))
(if
source
(list (quote wait-for) event-name :from source)
(list (quote wait-for) event-name)))))
((= (tp-type) "number")
(let
((tok (adv!)))
(list (quote wait) (parse-dur (get tok "value")))))
(true (list (quote wait) 0)))))
(define
parse-detail-dict
(fn
()
(adv!)
(define
dd-collect
(fn
(acc)
(if
(or (= (tp-type) "paren-close") (at-end?))
(do (if (= (tp-type) "paren-close") (adv!) nil) acc)
(let
((key (get (adv!) "value")))
(if (= (tp-type) "colon") (adv!) nil)
(let
((val (parse-expr)))
(if (= (tp-type) "comma") (adv!) nil)
(dd-collect (append acc (list key val))))))))
(cons (quote dict) (dd-collect (list)))))
(define
parse-send-cmd
(fn
()
(let
((name (get (adv!) "value")))
(let
((dtl (if (= (tp-type) "paren-open") (parse-detail-dict) nil)))
(let
((tgt (parse-tgt-kw "to" (list (quote me)))))
(if
dtl
(list (quote send) name dtl tgt)
(list (quote send) name tgt)))))))
(define
parse-trigger-cmd
(fn
()
(let
((name (get (adv!) "value")))
(let
((tgt (parse-tgt-kw "on" (list (quote me)))))
(list (quote trigger) name tgt)))))
(define parse-log-cmd (fn () (list (quote log) (parse-expr))))
(define parse-inc-cmd (fn () (list (quote increment!) (parse-expr))))
(define parse-dec-cmd (fn () (list (quote decrement!) (parse-expr))))
(define
parse-hide-cmd
(fn
()
(let
((tgt (if (at-end?) (list (quote me)) (if (or (= (tp-type) "id") (= (tp-type) "selector")) (parse-expr) (list (quote me))))))
(list (quote hide) tgt))))
(define
parse-show-cmd
(fn
()
(let
((tgt (if (at-end?) (list (quote me)) (if (or (= (tp-type) "id") (= (tp-type) "selector")) (parse-expr) (list (quote me))))))
(list (quote show) tgt))))
(define
parse-transition-cmd
(fn
()
(let
((prop (get (adv!) "value")))
(expect-kw! "to")
(let
((value (parse-expr)))
(let
((dur (if (match-kw "over") (if (= (tp-type) "number") (parse-dur (get (adv!) "value")) 400) nil)))
(let
((tgt (parse-tgt-kw "on" (list (quote me)))))
(if
dur
(list (quote transition) prop value dur tgt)
(list (quote transition) prop value tgt))))))))
(define
parse-repeat-cmd
(fn
()
(let
((mode (cond ((match-kw "forever") (list (quote forever))) ((match-kw "while") (list (quote while) (parse-expr))) ((match-kw "until") (list (quote until) (parse-expr))) ((= (tp-type) "number") (let ((n (parse-dur (get (adv!) "value")))) (expect-kw! "times") (list (quote times) n))) (true (list (quote forever))))))
(let
((body (parse-cmd-list)))
(match-kw "end")
(list (quote repeat) mode body)))))
(define
parse-fetch-cmd
(fn
()
(let
((url-atom (parse-atom)))
(let
((url (if (nil? url-atom) url-atom (parse-arith (parse-poss url-atom)))))
(let
((fmt (if (match-kw "as") (let ((f (tp-val))) (adv!) f) "json")))
(list (quote fetch) url fmt))))))
(define
parse-call-args
(fn
()
(adv!)
(define
ca-collect
(fn
(acc)
(if
(or (= (tp-type) "paren-close") (at-end?))
(do (if (= (tp-type) "paren-close") (adv!) nil) acc)
(let
((arg (parse-expr)))
(if (= (tp-type) "comma") (adv!) nil)
(ca-collect (append acc (list arg)))))))
(ca-collect (list))))
(define
parse-call-cmd
(fn
()
(let
((name (get (adv!) "value")))
(if
(= (tp-type) "paren-open")
(let
((args (parse-call-args)))
(cons (quote call) (cons name args)))
(list (quote call) name)))))
(define
parse-take-cmd
(fn
()
(if
(= (tp-type) "class")
(let
((cls (get (adv!) "value")))
(let
((tgt (parse-tgt-kw "from" (list (quote me)))))
(list (quote take) cls tgt)))
nil)))
(define
parse-go-cmd
(fn () (match-kw "to") (list (quote go) (parse-expr))))
(do
(define
parse-arith
(fn
(left)
(let
((typ (tp-type)) (val (tp-val)))
(if
(and
(= typ "op")
(or
(= val "+")
(= val "-")
(= val "*")
(= val "/")
(= val "%")))
(do
(adv!)
(let
((op (cond ((= val "+") (quote +)) ((= val "-") (quote -)) ((= val "*") (quote *)) ((= val "/") (quote /)) ((= val "%") (make-symbol "%")))))
(let
((right (let ((a (parse-atom))) (if (nil? a) a (parse-poss a)))))
(parse-arith (list op left right)))))
left))))
(define
parse-the-expr
(fn
()
(let
((typ (tp-type)) (val (tp-val)))
(if
(or (= typ "ident") (= typ "keyword"))
(do
(adv!)
(if
(match-kw "of")
(list (make-symbol ".") (parse-expr) val)
(cond
((= val "result") (list (quote it)))
((= val "first") (parse-pos-kw (quote first)))
((= val "last") (parse-pos-kw (quote last)))
((= val "closest") (parse-trav (quote closest)))
((= val "next") (parse-trav (quote next)))
((= val "previous") (parse-trav (quote previous)))
(true (list (quote ref) val)))))
(parse-atom)))))
(define
parse-array-lit
(fn
()
(define
al-collect
(fn
(acc)
(if
(or (= (tp-type) "bracket-close") (at-end?))
(do (if (= (tp-type) "bracket-close") (adv!) nil) acc)
(let
((elem (parse-expr)))
(if (= (tp-type) "comma") (adv!) nil)
(al-collect (append acc (list elem)))))))
(cons (quote array) (al-collect (list)))))
(define
parse-return-cmd
(fn
()
(if
(or
(at-end?)
(and
(= (tp-type) "keyword")
(or
(= (tp-val) "end")
(= (tp-val) "then")
(= (tp-val) "else"))))
(list (quote return) nil)
(list (quote return) (parse-expr)))))
(define parse-throw-cmd (fn () (list (quote throw) (parse-expr))))
(define
parse-append-cmd
(fn
()
(let
((value (parse-expr)))
(expect-kw! "to")
(let
((target (parse-expr)))
(list (quote append!) value target)))))
(define
parse-tell-cmd
(fn
()
(let
((target (parse-expr)))
(let
((body (parse-cmd-list)))
(match-kw "end")
(list (quote tell) target body)))))
(define
parse-for-cmd
(fn
()
(let
((var-name (tp-val)))
(adv!)
(expect-kw! "in")
(let
((collection (parse-expr)))
(let
((idx (if (match-kw "index") (let ((iname (tp-val))) (adv!) iname) nil)))
(let
((body (parse-cmd-list)))
(match-kw "end")
(if
idx
(list (quote for) var-name collection body :index idx)
(list (quote for) var-name collection body))))))))
(define
parse-make-cmd
(fn
()
(if (= (tp-val) "a") (adv!) nil)
(let
((type-name (tp-val)))
(adv!)
(let
((called (if (match-kw "called") (let ((n (tp-val))) (adv!) n) nil)))
(if
called
(list (quote make) type-name called)
(list (quote make) type-name))))))
(define
parse-install-cmd
(fn
()
(let
((name (tp-val)))
(adv!)
(if
(= (tp-type) "paren-open")
(let
((args (parse-call-args)))
(cons (quote install) (cons name args)))
(list (quote install) name)))))
(define
parse-measure-cmd
(fn
()
(let
((tgt (parse-expr)))
(list (quote measure) (if (nil? tgt) (list (quote me)) tgt)))))
(define
parse-param-list
(fn () (if (= (tp-type) "paren-open") (parse-call-args) (list))))
(define
parse-feat-body
(fn
()
(define
fb-collect
(fn
(acc)
(if
(or
(at-end?)
(and (= (tp-type) "keyword") (= (tp-val) "end")))
acc
(let
((feat (parse-feat)))
(if
(nil? feat)
acc
(fb-collect (append acc (list feat))))))))
(fb-collect (list))))
(define
parse-def-feat
(fn
()
(let
((name (tp-val)))
(adv!)
(let
((params (parse-param-list)))
(let
((body (parse-cmd-list)))
(match-kw "end")
(list (quote def) name params body))))))
(define
parse-behavior-feat
(fn
()
(let
((name (tp-val)))
(adv!)
(let
((params (parse-param-list)))
(let
((body (parse-feat-body)))
(match-kw "end")
(list (quote behavior) name params body))))))
(define
parse-render-kwargs
(fn
()
(define
collect-kw
(fn
(acc)
(if
(= (tp-type) "local")
(let
((key (tp-val)))
(adv!)
(let
((val (parse-expr)))
(collect-kw (append acc (list key val)))))
acc)))
(collect-kw (list))))
(define
parse-render-cmd
(fn
()
(let
((comp (cond ((= (tp-type) "component") (let ((name (tp-val))) (adv!) name)) ((= (tp-type) "paren-open") (do (adv!) (let ((expr (parse-expr))) (if (= (tp-type) "paren-close") (adv!) nil) expr))) (true (let ((name (tp-val))) (adv!) name)))))
(let
((kwargs (parse-render-kwargs)))
(let
((pos (cond ((match-kw "into") "into") ((match-kw "before") "before") ((match-kw "after") "after") (true nil))))
(let
((target (if pos (parse-expr) nil)))
(if
pos
(list (quote render) comp kwargs pos target)
(list (quote render) comp kwargs))))))))
(define
collect-sx-source
(fn
()
(let
((start-pos (get (tp) "pos")))
(adv!)
(define
skip-to-close
(fn
(depth)
(cond
((at-end?) start-pos)
((= (tp-type) "paren-open")
(do (adv!) (skip-to-close (+ depth 1))))
((= (tp-type) "paren-close")
(if
(= depth 0)
(let
((end-pos (+ (get (tp) "pos") 1)))
(adv!)
end-pos)
(do (adv!) (skip-to-close (- depth 1)))))
(true (do (adv!) (skip-to-close depth))))))
(let
((end-pos (skip-to-close 0)))
(substring src start-pos end-pos))))))
(define
parse-cmd
(fn
()
(let
((typ (tp-type)) (val (tp-val)))
(cond
((and (= typ "keyword") (= val "add"))
(do (adv!) (parse-add-cmd)))
((and (= typ "keyword") (= val "remove"))
(do (adv!) (parse-remove-cmd)))
((and (= typ "keyword") (= val "toggle"))
(do (adv!) (parse-toggle-cmd)))
((and (= typ "keyword") (= val "set"))
(do (adv!) (parse-set-cmd)))
((and (= typ "keyword") (= val "put"))
(do (adv!) (parse-put-cmd)))
((and (= typ "keyword") (= val "if"))
(do (adv!) (parse-if-cmd)))
((and (= typ "keyword") (= val "wait"))
(do (adv!) (parse-wait-cmd)))
((and (= typ "keyword") (= val "send"))
(do (adv!) (parse-send-cmd)))
((and (= typ "keyword") (= val "trigger"))
(do (adv!) (parse-trigger-cmd)))
((and (= typ "keyword") (= val "log"))
(do (adv!) (parse-log-cmd)))
((and (= typ "keyword") (= val "increment"))
(do (adv!) (parse-inc-cmd)))
((and (= typ "keyword") (= val "decrement"))
(do (adv!) (parse-dec-cmd)))
((and (= typ "keyword") (= val "hide"))
(do (adv!) (parse-hide-cmd)))
((and (= typ "keyword") (= val "show"))
(do (adv!) (parse-show-cmd)))
((and (= typ "keyword") (= val "transition"))
(do (adv!) (parse-transition-cmd)))
((and (= typ "keyword") (= val "repeat"))
(do (adv!) (parse-repeat-cmd)))
((and (= typ "keyword") (= val "fetch"))
(do (adv!) (parse-fetch-cmd)))
((and (= typ "keyword") (= val "call"))
(do (adv!) (parse-call-cmd)))
((and (= typ "keyword") (= val "take"))
(do (adv!) (parse-take-cmd)))
((and (= typ "keyword") (= val "settle"))
(do (adv!) (list (quote settle))))
((and (= typ "keyword") (= val "go"))
(do (adv!) (parse-go-cmd)))
((and (= typ "keyword") (= val "return"))
(do (adv!) (parse-return-cmd)))
((and (= typ "keyword") (= val "throw"))
(do (adv!) (parse-throw-cmd)))
((and (= typ "keyword") (= val "append"))
(do (adv!) (parse-append-cmd)))
((and (= typ "keyword") (= val "tell"))
(do (adv!) (parse-tell-cmd)))
((and (= typ "keyword") (= val "for"))
(do (adv!) (parse-for-cmd)))
((and (= typ "keyword") (= val "make"))
(do (adv!) (parse-make-cmd)))
((and (= typ "keyword") (= val "install"))
(do (adv!) (parse-install-cmd)))
((and (= typ "keyword") (= val "measure"))
(do (adv!) (parse-measure-cmd)))
((and (= typ "keyword") (= val "render"))
(do (adv!) (parse-render-cmd)))
(true (parse-expr))))))
(define
parse-cmd-list
(fn
()
(define
cl-collect
(fn
(acc)
(let
((cmd (parse-cmd)))
(if
(nil? cmd)
acc
(let
((acc2 (append acc (list cmd))))
(if (match-kw "then") (cl-collect acc2) acc2))))))
(let
((cmds (cl-collect (list))))
(cond
((= (len cmds) 0) nil)
((= (len cmds) 1) (first cmds))
(true (cons (quote do) cmds))))))
(define
parse-on-feat
(fn
()
(let
((every? (match-kw "every")))
(let
((event-name (let ((v (tp-val))) (adv!) v)))
(let
((flt (if (= (tp-type) "bracket-open") (do (adv!) (let ((f (parse-expr))) (if (= (tp-type) "bracket-close") (adv!) nil) f)) nil)))
(let
((source (if (match-kw "from") (parse-expr) nil)))
(let
((body (parse-cmd-list)))
(match-kw "end")
(let
((parts (list (quote on) event-name)))
(let
((parts (if every? (append parts (list :every true)) parts)))
(let
((parts (if flt (append parts (list :filter flt)) parts)))
(let
((parts (if source (append parts (list :from source)) parts)))
(append parts (list body)))))))))))))
(define
parse-init-feat
(fn
()
(let
((body (parse-cmd-list)))
(match-kw "end")
(list (quote init) body))))
(define
parse-feat
(fn
()
(let
((val (tp-val)))
(cond
((= val "on") (do (adv!) (parse-on-feat)))
((= val "init") (do (adv!) (parse-init-feat)))
((= val "def") (do (adv!) (parse-def-feat)))
((= val "behavior") (do (adv!) (parse-behavior-feat)))
(true (parse-cmd-list))))))
(define
coll-feats
(fn
(acc)
(if
(at-end?)
acc
(let
((feat (parse-feat)))
(if (nil? feat) acc (coll-feats (append acc (list feat))))))))
(let
((features (coll-feats (list))))
(if
(= (len features) 1)
(first features)
(cons (quote do) features))))))
;; ── Convenience: source string → AST ─────────────────────────────
(define hs-compile (fn (src) (hs-parse (hs-tokenize src) src)))

265
lib/hyperscript/runtime.sx
View File

@@ -1,265 +0,0 @@
;; _hyperscript runtime shims
;;
;; Thin wrappers over web/lib/dom.sx and web/lib/browser.sx primitives
;; that implement hyperscript-specific semantics (async transparency,
;; class toggling, event waiting, iteration, type coercion).
;;
;; These are the functions that hs-to-sx (compiler.sx) emits calls to.
;; Each is a pure define — no platform dependency beyond the DOM/browser
;; primitives already available in the SX web platform.
;; ── Event handling ──────────────────────────────────────────────
;; Register an event listener. Returns unlisten function.
;; (hs-on target event-name handler) → unlisten-fn
(define
hs-on
(fn (target event-name handler) (dom-listen target event-name handler)))
;; Register for every occurrence (no queuing — each fires independently).
;; Stock hyperscript queues by default; "every" disables queuing.
(define
hs-on-every
(fn (target event-name handler) (dom-listen target event-name handler)))
;; Run an initializer function immediately.
;; (hs-init thunk) — called at element boot time
(define hs-init (fn (thunk) (thunk)))
;; ── Async / timing ──────────────────────────────────────────────
;; Wait for a duration in milliseconds.
;; In hyperscript, wait is async-transparent — execution pauses.
;; Here we use perform/IO suspension for true pause semantics.
(define hs-wait (fn (ms) (perform (list (quote io-sleep) ms))))
;; Wait for a DOM event on a target.
;; (hs-wait-for target event-name) — suspends until event fires
(define
hs-wait-for
(fn
(target event-name)
(perform (list (quote io-wait-event) target event-name))))
;; Wait for CSS transitions/animations to settle on an element.
(define hs-settle (fn (target) (perform (list (quote io-settle) target))))
;; ── Class manipulation ──────────────────────────────────────────
;; Toggle a single class on an element.
(define
hs-toggle-class!
(fn
(target cls)
(if
(dom-has-class? target cls)
(dom-remove-class target cls)
(dom-add-class target cls))))
;; Toggle between two classes — exactly one is active at a time.
(define
hs-toggle-between!
(fn
(target cls1 cls2)
(if
(dom-has-class? target cls1)
(do (dom-remove-class target cls1) (dom-add-class target cls2))
(do (dom-remove-class target cls2) (dom-add-class target cls1)))))
;; Take a class from siblings — add to target, remove from others.
;; (hs-take! target cls) — like radio button class behavior
(define
hs-take!
(fn
(target cls)
(let
((parent (dom-parent target)))
(when
parent
(for-each
(fn (child) (dom-remove-class child cls))
(dom-child-list parent)))
(dom-add-class target cls))))
;; ── DOM insertion ───────────────────────────────────────────────
;; Put content at a position relative to a target.
;; pos: "into" | "before" | "after"
(define
hs-put!
(fn
(value pos target)
(cond
((= pos "into") (dom-set-inner-html target value))
((= pos "before")
(dom-insert-adjacent-html target "beforebegin" value))
((= pos "after") (dom-insert-adjacent-html target "afterend" value)))))
;; ── Navigation / traversal ──────────────────────────────────────
;; Navigate to a URL.
(define hs-navigate! (fn (url) (perform (list (quote io-navigate) url))))
;; Find next sibling matching a selector (or any sibling).
(define
hs-next
(fn
(target sel)
(if
(= sel "*")
(dom-next-sibling target)
(let
((sibling (dom-next-sibling target)))
(define
find-next
(fn
(el)
(cond
((nil? el) nil)
((dom-matches? el sel) el)
(true (find-next (dom-next-sibling el))))))
(find-next sibling)))))
;; Find previous sibling matching a selector.
(define
hs-previous
(fn
(target sel)
(if
(= sel "*")
(dom-get-prop target "previousElementSibling")
(let
((sibling (dom-get-prop target "previousElementSibling")))
(define
find-prev
(fn
(el)
(cond
((nil? el) nil)
((dom-matches? el sel) el)
(true (find-prev (dom-get-prop el "previousElementSibling"))))))
(find-prev sibling)))))
;; First element matching selector within a scope.
(define hs-query-first (fn (sel) (dom-query sel)))
;; Last element matching selector.
(define
hs-query-last
(fn
(sel)
(let
((all (dom-query-all (dom-body) sel)))
(if (> (len all) 0) (nth all (- (len all) 1)) nil))))
;; First/last within a specific scope.
(define hs-first (fn (scope sel) (dom-query-all scope sel)))
(define
hs-last
(fn
(scope sel)
(let
((all (dom-query-all scope sel)))
(if (> (len all) 0) (nth all (- (len all) 1)) nil))))
;; ── Iteration ───────────────────────────────────────────────────
;; Repeat a thunk N times.
(define
hs-repeat-times
(fn
(n thunk)
(define
do-repeat
(fn (i) (when (< i n) (thunk) (do-repeat (+ i 1)))))
(do-repeat 0)))
;; Repeat forever (until break — relies on exception/continuation).
(define
hs-repeat-forever
(fn
(thunk)
(define do-forever (fn () (thunk) (do-forever)))
(do-forever)))
;; ── Fetch ───────────────────────────────────────────────────────
;; Fetch a URL, parse response according to format.
;; (hs-fetch url format) — format is "json" | "text" | "html"
(define
hs-fetch
(fn
(url format)
(let
((response (perform (list (quote io-fetch) url))))
(cond
((= format "json") (perform (list (quote io-parse-json) response)))
((= format "text") (perform (list (quote io-parse-text) response)))
((= format "html") (perform (list (quote io-parse-html) response)))
(true response)))))
;; ── Type coercion ───────────────────────────────────────────────
;; Coerce a value to a type by name.
;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc.
(define
hs-coerce
(fn
(value type-name)
(cond
((= type-name "Int") (+ value 0))
((= type-name "Integer") (+ value 0))
((= type-name "Float") (+ value 0))
((= type-name "Number") (+ value 0))
((= type-name "String") (str value))
((= type-name "Boolean") (if value true false))
((= type-name "Array") (if (list? value) value (list value)))
(true value))))
;; ── Object creation ─────────────────────────────────────────────
;; Make a new object of a given type.
;; (hs-make type-name) — creates empty object/collection
(define
hs-make
(fn
(type-name)
(cond
((= type-name "Object") (dict))
((= type-name "Array") (list))
((= type-name "Set") (list))
((= type-name "Map") (dict))
(true (dict)))))
;; ── Behavior installation ───────────────────────────────────────
;; Install a behavior on an element.
;; A behavior is a function that takes (me ...params) and sets up features.
;; (hs-install behavior-fn me ...args)
(define hs-install (fn (behavior-fn) (behavior-fn me)))
;; ── Measurement ─────────────────────────────────────────────────
;; Measure an element's bounding rect, store as local variables.
;; Returns a dict with x, y, width, height, top, left, right, bottom.
(define
hs-measure
(fn (target) (perform (list (quote io-measure) target))))
;; ── Transition ──────────────────────────────────────────────────
;; Transition a CSS property to a value, optionally with duration.
;; (hs-transition target prop value duration)
(define
hs-transition
(fn
(target prop value duration)
(when
duration
(dom-set-style
target
"transition"
(str prop " " (/ duration 1000) "s")))
(dom-set-style target prop value)
(when duration (hs-settle target))))

533
lib/hyperscript/tokenizer.sx
View File

@@ -1,533 +0,0 @@
;; _hyperscript tokenizer — produces token stream from hyperscript source
;;
;; Tokens: {:type T :value V :pos P}
;; Types: "keyword" "ident" "number" "string" "class" "id" "attr" "style"
;; "selector" "op" "dot" "paren-open" "paren-close" "bracket-open"
;; "bracket-close" "brace-open" "brace-close" "comma" "colon"
;; "template" "local" "eof"
;; ── Token constructor ─────────────────────────────────────────────
(define hs-make-token (fn (type value pos) {:pos pos :value value :type type}))
;; ── Character predicates ──────────────────────────────────────────
(define hs-digit? (fn (c) (and (>= c "0") (<= c "9"))))
(define
hs-letter?
(fn (c) (or (and (>= c "a") (<= c "z")) (and (>= c "A") (<= c "Z")))))
(define hs-ident-start? (fn (c) (or (hs-letter? c) (= c "_") (= c "$"))))
(define
hs-ident-char?
(fn
(c)
(or (hs-letter? c) (hs-digit? c) (= c "_") (= c "$") (= c "-"))))
(define hs-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r"))))
;; ── Keyword set ───────────────────────────────────────────────────
(define
hs-keywords
(list
"on"
"end"
"set"
"to"
"put"
"into"
"before"
"after"
"add"
"remove"
"toggle"
"if"
"else"
"otherwise"
"then"
"from"
"in"
"of"
"for"
"until"
"wait"
"send"
"trigger"
"call"
"get"
"take"
"log"
"hide"
"show"
"repeat"
"while"
"times"
"forever"
"break"
"continue"
"return"
"throw"
"catch"
"finally"
"def"
"tell"
"make"
"fetch"
"as"
"with"
"every"
"or"
"and"
"not"
"is"
"no"
"the"
"my"
"me"
"it"
"its"
"result"
"true"
"false"
"null"
"when"
"between"
"at"
"by"
"queue"
"elsewhere"
"event"
"target"
"detail"
"sender"
"index"
"increment"
"decrement"
"append"
"settle"
"transition"
"over"
"closest"
"next"
"previous"
"first"
"last"
"random"
"empty"
"exists"
"matches"
"contains"
"do"
"unless"
"you"
"your"
"new"
"init"
"start"
"go"
"js"
"less"
"than"
"greater"
"class"
"anything"
"install"
"measure"
"behavior"
"called"
"render"
"eval"))
(define hs-keyword? (fn (word) (some (fn (k) (= k word)) hs-keywords)))
;; ── Main tokenizer ────────────────────────────────────────────────
(define
hs-tokenize
(fn
(src)
(let
((tokens (list)) (pos 0) (src-len (len src)))
(define
hs-peek
(fn
(offset)
(if (< (+ pos offset) src-len) (nth src (+ pos offset)) nil)))
(define hs-cur (fn () (hs-peek 0)))
(define hs-advance! (fn (n) (set! pos (+ pos n))))
(define
skip-ws!
(fn
()
(when
(and (< pos src-len) (hs-ws? (hs-cur)))
(hs-advance! 1)
(skip-ws!))))
(define
skip-comment!
(fn
()
(when
(and (< pos src-len) (not (= (hs-cur) "\n")))
(hs-advance! 1)
(skip-comment!))))
(define
read-ident
(fn
(start)
(when
(and (< pos src-len) (hs-ident-char? (hs-cur)))
(hs-advance! 1)
(read-ident start))
(slice src start pos)))
(define
read-number
(fn
(start)
(when
(and (< pos src-len) (hs-digit? (hs-cur)))
(hs-advance! 1)
(read-number start))
(when
(and
(< pos src-len)
(= (hs-cur) ".")
(< (+ pos 1) src-len)
(hs-digit? (hs-peek 1)))
(hs-advance! 1)
(define
read-frac
(fn
()
(when
(and (< pos src-len) (hs-digit? (hs-cur)))
(hs-advance! 1)
(read-frac))))
(read-frac))
(let
((num-end pos))
(when
(and
(< pos src-len)
(or (= (hs-cur) "m") (= (hs-cur) "s")))
(if
(and
(= (hs-cur) "m")
(< (+ pos 1) src-len)
(= (hs-peek 1) "s"))
(hs-advance! 2)
(when (= (hs-cur) "s") (hs-advance! 1))))
(slice src start pos))))
(define
read-string
(fn
(quote-char)
(let
((chars (list)))
(hs-advance! 1)
(define
loop
(fn
()
(cond
(>= pos src-len)
nil
(= (hs-cur) "\\")
(do
(hs-advance! 1)
(when
(< pos src-len)
(let
((ch (hs-cur)))
(cond
(= ch "n")
(append! chars "\n")
(= ch "t")
(append! chars "\t")
(= ch "\\")
(append! chars "\\")
(= ch quote-char)
(append! chars quote-char)
:else (do (append! chars "\\") (append! chars ch)))
(hs-advance! 1)))
(loop))
(= (hs-cur) quote-char)
(hs-advance! 1)
:else (do (append! chars (hs-cur)) (hs-advance! 1) (loop)))))
(loop)
(join "" chars))))
(define
read-template
(fn
()
(let
((chars (list)))
(hs-advance! 1)
(define
loop
(fn
()
(cond
(>= pos src-len)
nil
(= (hs-cur) "`")
(hs-advance! 1)
(and
(= (hs-cur) "$")
(< (+ pos 1) src-len)
(= (hs-peek 1) "{"))
(do
(append! chars "${")
(hs-advance! 2)
(let
((depth 1))
(define
inner
(fn
()
(when
(and (< pos src-len) (> depth 0))
(cond
(= (hs-cur) "{")
(do
(set! depth (+ depth 1))
(append! chars (hs-cur))
(hs-advance! 1)
(inner))
(= (hs-cur) "}")
(do
(set! depth (- depth 1))
(when (> depth 0) (append! chars (hs-cur)))
(hs-advance! 1)
(when (> depth 0) (inner)))
:else (do
(append! chars (hs-cur))
(hs-advance! 1)
(inner))))))
(inner))
(append! chars "}")
(loop))
:else (do (append! chars (hs-cur)) (hs-advance! 1) (loop)))))
(loop)
(join "" chars))))
(define
read-selector
(fn
()
(let
((chars (list)))
(hs-advance! 1)
(define
loop
(fn
()
(cond
(>= pos src-len)
nil
(and
(= (hs-cur) "/")
(< (+ pos 1) src-len)
(= (hs-peek 1) ">"))
(hs-advance! 2)
:else (do (append! chars (hs-cur)) (hs-advance! 1) (loop)))))
(loop)
(join "" chars))))
(define
read-class-name
(fn
(start)
(when
(and
(< pos src-len)
(or
(hs-ident-char? (hs-cur))
(= (hs-cur) ":")
(= (hs-cur) "\\")
(= (hs-cur) "[")
(= (hs-cur) "]")
(= (hs-cur) "(")
(= (hs-cur) ")")))
(when (= (hs-cur) "\\") (hs-advance! 1))
(hs-advance! 1)
(read-class-name start))
(slice src start pos)))
(define
hs-emit!
(fn
(type value start)
(append! tokens (hs-make-token type value start))))
(define
scan!
(fn
()
(skip-ws!)
(when
(< pos src-len)
(let
((ch (hs-cur)) (start pos))
(cond
(and (= ch "/") (< (+ pos 1) src-len) (= (hs-peek 1) "/"))
(do (hs-advance! 2) (skip-comment!) (scan!))
(and
(= ch "<")
(< (+ pos 1) src-len)
(not (= (hs-peek 1) "="))
(or
(hs-letter? (hs-peek 1))
(= (hs-peek 1) ".")
(= (hs-peek 1) "#")
(= (hs-peek 1) "[")
(= (hs-peek 1) "*")
(= (hs-peek 1) ":")))
(do (hs-emit! "selector" (read-selector) start) (scan!))
(and
(= ch ".")
(< (+ pos 1) src-len)
(or
(hs-letter? (hs-peek 1))
(= (hs-peek 1) "-")
(= (hs-peek 1) "_")))
(do
(hs-advance! 1)
(hs-emit! "class" (read-class-name pos) start)
(scan!))
(and
(= ch "#")
(< (+ pos 1) src-len)
(hs-ident-start? (hs-peek 1)))
(do
(hs-advance! 1)
(hs-emit! "id" (read-ident pos) start)
(scan!))
(and
(= ch "@")
(< (+ pos 1) src-len)
(hs-ident-char? (hs-peek 1)))
(do
(hs-advance! 1)
(hs-emit! "attr" (read-ident pos) start)
(scan!))
(and
(= ch "~")
(< (+ pos 1) src-len)
(hs-letter? (hs-peek 1)))
(do
(hs-advance! 1)
(hs-emit! "component" (str "~" (read-ident pos)) start)
(scan!))
(and
(= ch "*")
(< (+ pos 1) src-len)
(hs-letter? (hs-peek 1)))
(do
(hs-advance! 1)
(hs-emit! "style" (read-ident pos) start)
(scan!))
(and
(= ch ":")
(< (+ pos 1) src-len)
(hs-ident-start? (hs-peek 1)))
(do
(hs-advance! 1)
(hs-emit! "local" (read-ident pos) start)
(scan!))
(or
(= ch "\"")
(and
(= ch "'")
(not
(and
(< (+ pos 1) src-len)
(= (hs-peek 1) "s")
(or
(>= (+ pos 2) src-len)
(not (hs-ident-char? (hs-peek 2))))))))
(do (hs-emit! "string" (read-string ch) start) (scan!))
(= ch "`")
(do (hs-emit! "template" (read-template) start) (scan!))
(hs-digit? ch)
(do (hs-emit! "number" (read-number start) start) (scan!))
(hs-ident-start? ch)
(do
(let
((word (read-ident start)))
(hs-emit!
(if (hs-keyword? word) "keyword" "ident")
word
start))
(scan!))
(and
(or (= ch "=") (= ch "!") (= ch "<") (= ch ">"))
(< (+ pos 1) src-len)
(= (hs-peek 1) "="))
(do
(hs-emit! "op" (str ch "=") start)
(hs-advance! 2)
(scan!))
(and
(= ch "'")
(< (+ pos 1) src-len)
(= (hs-peek 1) "s")
(or
(>= (+ pos 2) src-len)
(not (hs-ident-char? (hs-peek 2)))))
(do (hs-emit! "op" "'s" start) (hs-advance! 2) (scan!))
(= ch "(")
(do
(hs-emit! "paren-open" "(" start)
(hs-advance! 1)
(scan!))
(= ch ")")
(do
(hs-emit! "paren-close" ")" start)
(hs-advance! 1)
(scan!))
(= ch "[")
(do
(hs-emit! "bracket-open" "[" start)
(hs-advance! 1)
(scan!))
(= ch "]")
(do
(hs-emit! "bracket-close" "]" start)
(hs-advance! 1)
(scan!))
(= ch "{")
(do
(hs-emit! "brace-open" "{" start)
(hs-advance! 1)
(scan!))
(= ch "}")
(do
(hs-emit! "brace-close" "}" start)
(hs-advance! 1)
(scan!))
(= ch ",")
(do (hs-emit! "comma" "," start) (hs-advance! 1) (scan!))
(= ch "+")
(do (hs-emit! "op" "+" start) (hs-advance! 1) (scan!))
(= ch "-")
(do (hs-emit! "op" "-" start) (hs-advance! 1) (scan!))
(= ch "/")
(do (hs-emit! "op" "/" start) (hs-advance! 1) (scan!))
(= ch "=")
(do (hs-emit! "op" "=" start) (hs-advance! 1) (scan!))
(= ch "<")
(do (hs-emit! "op" "<" start) (hs-advance! 1) (scan!))
(= ch ">")
(do (hs-emit! "op" ">" start) (hs-advance! 1) (scan!))
(= ch "!")
(do (hs-emit! "op" "!" start) (hs-advance! 1) (scan!))
(= ch "*")
(do (hs-emit! "op" "*" start) (hs-advance! 1) (scan!))
(= ch "%")
(do (hs-emit! "op" "%" start) (hs-advance! 1) (scan!))
(= ch ".")
(do (hs-emit! "dot" "." start) (hs-advance! 1) (scan!))
:else (do (hs-advance! 1) (scan!)))))))
(scan!)
(hs-emit! "eof" nil pos)
tokens)))

485
lib/parser-combinators.sx
View File

@@ -1,485 +0,0 @@
;; Parser Combinator Library — Pure SX
;;
;; A parser is (fn (input pos) result) where:
;; Success: {:ok true :value val :pos new-pos}
;; Failure: {:ok false :expected desc :pos pos}
;;
;; Combinators compose parsers: seq, alt, many, sep-by, between, etc.
;; Recursive grammars use (lazy-parser (fn () ...)) thunks.
;; ── Layer 0: Result constructors ──────────────────────────────────
(define make-ok (fn (val pos) {:pos pos :ok true :value val}))
(define make-fail (fn (expected pos) {:pos pos :ok false :expected expected}))
(define ok? (fn (r) (get r "ok")))
(define result-value (fn (r) (get r "value")))
(define result-pos (fn (r) (get r "pos")))
(define result-expected (fn (r) (get r "expected")))
;; ── Layer 1: Primitive parsers ────────────────────────────────────
(define
satisfy
(fn
(pred desc)
(fn
(input pos)
(if
(< pos (len input))
(let
((ch (nth input pos)))
(if (pred ch) (make-ok ch (+ pos 1)) (make-fail desc pos)))
(make-fail desc pos)))))
(define
parse-char
(fn (ch) (satisfy (fn (c) (= c ch)) (str "'" ch "'"))))
(define any-char (satisfy (fn (c) true) "any character"))
(define
parse-string
(fn
(target)
(let
((target-len (len target)))
(fn
(input pos)
(if
(<= (+ pos target-len) (len input))
(if
(= (slice input pos (+ pos target-len)) target)
(make-ok target (+ pos target-len))
(make-fail (str "\"" target "\"") pos))
(make-fail (str "\"" target "\"") pos))))))
(define
eof
(fn
(input pos)
(if
(>= pos (len input))
(make-ok nil pos)
(make-fail "end of input" pos))))
;; ── Layer 2: Core combinators ─────────────────────────────────────
(define
fmap
(fn
(f parser)
(fn
(input pos)
(let
((r (parser input pos)))
(if (ok? r) (make-ok (f (result-value r)) (result-pos r)) r)))))
(define
parse-bind
(fn
(parser f)
(fn
(input pos)
(let
((r (parser input pos)))
(if (ok? r) ((f (result-value r)) input (result-pos r)) r)))))
(define
seq
(fn
(parsers)
(fn
(input pos)
(let
((results (list)) (cur-pos pos) (failed nil))
(for-each
(fn
(p)
(when
(not failed)
(let
((r (p input cur-pos)))
(if
(ok? r)
(do
(append! results (result-value r))
(set! cur-pos (result-pos r)))
(set! failed r)))))
parsers)
(if failed failed (make-ok results cur-pos))))))
(define seq2 (fn (p1 p2) (seq (list p1 p2))))
(define
alt
(fn
(parsers)
(fn
(input pos)
(let
((best-fail nil))
(define
loop
(fn
(ps)
(if
(empty? ps)
(or best-fail (make-fail "no alternatives" pos))
(let
((r ((first ps) input pos)))
(if
(ok? r)
r
(do
(when
(or
(not best-fail)
(> (result-pos r) (result-pos best-fail)))
(set! best-fail r))
(loop (rest ps))))))))
(loop parsers)))))
(define alt2 (fn (p1 p2) (alt (list p1 p2))))
(define
label
(fn
(name parser)
(fn
(input pos)
(let ((r (parser input pos))) (if (ok? r) r (make-fail name pos))))))
(define lazy-parser (fn (thunk) (fn (input pos) ((thunk) input pos))))
;; ── Layer 3: Repetition combinators ───────────────────────────────
(define
many
(fn
(parser)
(fn
(input pos)
(let
((results (list)) (cur-pos pos))
(define
loop
(fn
()
(let
((r (parser input cur-pos)))
(if
(ok? r)
(do
(append! results (result-value r))
(set! cur-pos (result-pos r))
(loop))
(make-ok results cur-pos)))))
(loop)))))
(define
many1
(fn
(parser)
(fn
(input pos)
(let
((r (parser input pos)))
(if
(ok? r)
(let
((rest-r ((many parser) input (result-pos r))))
(make-ok
(cons (result-value r) (result-value rest-r))
(result-pos rest-r)))
r)))))
(define
optional
(fn
(parser)
(fn
(input pos)
(let ((r (parser input pos))) (if (ok? r) r (make-ok nil pos))))))
(define
skip-many
(fn
(parser)
(fn
(input pos)
(let
((cur-pos pos))
(define
loop
(fn
()
(let
((r (parser input cur-pos)))
(if
(ok? r)
(do (set! cur-pos (result-pos r)) (loop))
(make-ok nil cur-pos)))))
(loop)))))
;; ── Layer 4: Structural combinators ───────────────────────────────
(define
between
(fn
(open close body)
(fmap (fn (results) (nth results 1)) (seq (list open body close)))))
(define
sep-by1
(fn
(parser sep)
(fn
(input pos)
(let
((first-r (parser input pos)))
(if
(ok? first-r)
(let
((rest-r ((many (fmap (fn (pair) (nth pair 1)) (seq (list sep parser)))) input (result-pos first-r))))
(make-ok
(cons (result-value first-r) (result-value rest-r))
(result-pos rest-r)))
first-r)))))
(define
sep-by
(fn
(parser sep)
(alt
(list (sep-by1 parser sep) (fn (input pos) (make-ok (list) pos))))))
(define
skip-left
(fn
(skip keep)
(fmap (fn (results) (nth results 1)) (seq (list skip keep)))))
(define
skip-right
(fn
(keep skip)
(fmap (fn (results) (first results)) (seq (list keep skip)))))
(define
not-followed-by
(fn
(parser)
(fn
(input pos)
(let
((r (parser input pos)))
(if (ok? r) (make-fail "not followed by" pos) (make-ok nil pos))))))
(define
look-ahead
(fn
(parser)
(fn
(input pos)
(let
((r (parser input pos)))
(if (ok? r) (make-ok (result-value r) pos) r)))))
;; ── Layer 5: Character class parsers ──────────────────────────────
(define digit (satisfy (fn (c) (and (>= c "0") (<= c "9"))) "digit"))
(define
letter
(satisfy
(fn
(c)
(or (and (>= c "a") (<= c "z")) (and (>= c "A") (<= c "Z"))))
"letter"))
(define alpha-num (alt2 letter digit))
(define
whitespace-char
(satisfy
(fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r")))
"whitespace"))
(define skip-spaces (skip-many whitespace-char))
;; ── Layer 6: Literal parsers ──────────────────────────────────────
(define
number-literal
(fn
(input pos)
(let
((start pos) (cur pos) (input-len (len input)))
(when
(and (< cur input-len) (= (nth input cur) "-"))
(set! cur (+ cur 1)))
(let
((digit-start cur))
(define
scan-digits
(fn
()
(when
(and
(< cur input-len)
(>= (nth input cur) "0")
(<= (nth input cur) "9"))
(set! cur (+ cur 1))
(scan-digits))))
(scan-digits)
(if
(= cur digit-start)
(make-fail "number" pos)
(do
(when
(and (< cur input-len) (= (nth input cur) "."))
(set! cur (+ cur 1))
(scan-digits))
(make-ok (parse-float (slice input start cur)) cur)))))))
(define
string-literal
(fn
(input pos)
(if
(and (< pos (len input)) (= (nth input pos) "\""))
(let
((cur (+ pos 1)) (input-len (len input)) (chars (list)))
(define
loop
(fn
()
(if
(>= cur input-len)
(make-fail "closing quote" cur)
(let
((ch (nth input cur)))
(cond
(= ch "\"")
(make-ok (join "" chars) (+ cur 1))
(= ch "\\")
(if
(>= (+ cur 1) input-len)
(make-fail "escape character" cur)
(let
((next (nth input (+ cur 1))))
(cond
(= next "n")
(do
(append! chars "\n")
(set! cur (+ cur 2))
(loop))
(= next "t")
(do
(append! chars "\t")
(set! cur (+ cur 2))
(loop))
(= next "\\")
(do
(append! chars "\\")
(set! cur (+ cur 2))
(loop))
(= next "\"")
(do
(append! chars "\"")
(set! cur (+ cur 2))
(loop))
:else (do
(append! chars next)
(set! cur (+ cur 2))
(loop)))))
:else (do (append! chars ch) (set! cur (+ cur 1)) (loop)))))))
(loop))
(make-fail "string" pos))))
(define
identifier
(let
((id-start (satisfy (fn (c) (or (and (>= c "a") (<= c "z")) (and (>= c "A") (<= c "Z")) (= c "_") (= c "~"))) "identifier start"))
(id-char
(satisfy
(fn
(c)
(or
(and (>= c "a") (<= c "z"))
(and (>= c "A") (<= c "Z"))
(and (>= c "0") (<= c "9"))
(= c "-")
(= c "_")
(= c "?")
(= c "!")
(= c "~")
(= c "/")))
"identifier char")))
(fmap
(fn (pair) (str (first pair) (join "" (nth pair 1))))
(seq (list id-start (many id-char))))))
;; ── Layer 7: Run parser ───────────────────────────────────────────
(define run-parser (fn (parser input) (parser input 0)))
;; ── Layer 8: SX tokenizer ─────────────────────────────────────────
(define
sx-comment
(fn
(input pos)
(if
(and (< pos (len input)) (= (nth input pos) ";"))
(let
((cur (+ pos 1)) (input-len (len input)))
(define
loop
(fn
()
(if
(or (>= cur input-len) (= (nth input cur) "\n"))
(make-ok {:type "comment"} cur)
(do (set! cur (+ cur 1)) (loop)))))
(loop))
(make-fail "comment" pos))))
(define
sx-keyword
(parse-bind
(parse-char ":")
(fn (colon) (fmap (fn (name) {:value (str ":" name) :type "keyword"}) identifier))))
(define
sx-symbol
(let
((sym-char (satisfy (fn (c) (or (and (>= c "a") (<= c "z")) (and (>= c "A") (<= c "Z")) (and (>= c "0") (<= c "9")) (= c "-") (= c "_") (= c "?") (= c "!") (= c "+") (= c "*") (= c "/") (= c "<") (= c ">") (= c "=") (= c "~") (= c "&") (= c ".") (= c "#"))) "symbol char")))
(fmap (fn (chars) {:value (join "" chars) :type "symbol"}) (many1 sym-char))))
(define sx-number (fmap (fn (n) {:value n :type "number"}) number-literal))
(define sx-string (fmap (fn (s) {:value s :type "string"}) string-literal))
(define
sx-token
(alt
(list
sx-comment
sx-number
sx-string
sx-keyword
(fmap (fn (c) {:type "open-paren"}) (parse-char "("))
(fmap (fn (c) {:type "close-paren"}) (parse-char ")"))
(fmap (fn (c) {:type "open-brace"}) (parse-char "{"))
(fmap (fn (c) {:type "close-brace"}) (parse-char "}"))
(fmap (fn (c) {:type "quote"}) (parse-char "'"))
sx-symbol)))
(define
sx-tokenize
(fmap
(fn
(tokens)
(filter (fn (t) (not (= (get t "type") "comment"))) tokens))
(skip-left skip-spaces (many (skip-right sx-token skip-spaces)))))

86
lib/r7rs.sx
View File

@@ -1,86 +0,0 @@
(define-library (sx r7rs)
(export
make-error-object
error-object?
error-message
error-object-irritants
with-exception-handler
car
cdr
cadr
cddr
caar
cdar
caddr
cadddr
null?
pair?
procedure?
boolean=?
symbol->string
string->symbol
number->string
string->number)
(begin
(define make-error-object (fn (message irritants) {:irritants irritants :type "error-object" :message message}))
(define
error-object?
(fn (x) (and (dict? x) (= (get x "type") "error-object"))))
(define
error-message
(fn (x) (if (error-object? x) (get x "message") (str x))))
(define
error-object-irritants
(fn (x) (if (error-object? x) (get x "irritants") (list))))
(defmacro
with-exception-handler
(handler thunk)
(quasiquote
(handler-bind (((fn (c) true) (unquote handler))) ((unquote thunk)))))
(define car first)
(define cdr rest)
(define cadr (fn (x) (first (rest x))))
(define cddr (fn (x) (rest (rest x))))
(define caar (fn (x) (first (first x))))
(define cdar (fn (x) (rest (first x))))
(define caddr (fn (x) (first (rest (rest x)))))
(define cadddr (fn (x) (first (rest (rest (rest x))))))
(define null? (fn (x) (or (nil? x) (and (list? x) (empty? x)))))
(define pair? (fn (x) (and (list? x) (not (empty? x)))))
(define procedure? (fn (x) (or (lambda? x) (callable? x))))
(define boolean=? (fn (a b) (= a b)))
(define symbol->string symbol-name)
(define string->symbol make-symbol)
(define number->string (fn (n) (str n)))
(define
string->number
(fn (s) (if (string-contains? s ".") (parse-float s) (parse-int s))))
)) ;; end define-library
;; Re-export to global namespace for backward compatibility
(import (sx r7rs))

71
lib/render-trace.sx
View File

@@ -1,71 +0,0 @@
(define-library (sx render-trace)
(export
*render-trace*
*render-trace-log*
*render-trace-depth*
render-trace-reset!
render-trace-push!
render-trace-enter!
render-trace-exit!
format-render-trace)
(begin
(define *render-trace* false)
(define *render-trace-log* (list))
(define *render-trace-depth* 0)
(define
render-trace-reset!
(fn () (set! *render-trace-log* (list)) (set! *render-trace-depth* 0)))
(define
render-trace-push!
(fn
(kind detail result)
(when
*render-trace*
(set! *render-trace-log* (append *render-trace-log* (list {:result (if (> (len (str result)) 80) (str (slice (str result) 0 77) "...") (str result)) :depth *render-trace-depth* :kind kind :detail detail}))))))
(define
render-trace-enter!
(fn
(kind detail)
(when
*render-trace*
(render-trace-push! kind detail "...")
(set! *render-trace-depth* (+ *render-trace-depth* 1)))))
(define
render-trace-exit!
(fn
(result)
(when
*render-trace*
(set! *render-trace-depth* (- *render-trace-depth* 1)))))
(define
format-render-trace
(fn
()
(join
"\n"
(map
(fn
(entry)
(let
((indent (join "" (map (fn (_) " ") (range 0 (get entry :depth)))))
(kind (get entry :kind))
(detail (get entry :detail))
(result (get entry :result)))
(str indent kind " " detail " → " result)))
*render-trace-log*))))
)) ;; end define-library
;; Re-export to global namespace for backward compatibility
(import (sx render-trace))

Some files were not shown because too many files have changed in this diff Show More