68 Commits

Author SHA1 Message Date
da1ca6009a GraphSX URL routing: s-expression URLs for sx-docs
All checks were successful
Build and Deploy / build-and-deploy (push) Successful in 5m50s
Replace path-based URLs with nested s-expression URLs across the sx app.
URLs like /language/docs/introduction become /(language.(doc.introduction)),
making the URL simultaneously a query, render instruction, and address.

- Add sx_router.py: catch-all route evaluator with dot→space conversion,
  auto-quoting slugs, two-phase eval, streaming detection, 301 redirects
- Add page-functions.sx: section + page functions for URL dispatch
- Rewrite nav-data.sx: ~200 hrefs to SX expression format, tree-descent
  nav matching via has-descendant-href? (replaces prefix heuristics)
- Convert ~120 old-style hrefs across 26 .sx content files
- Add SX Protocol proposal (etc/plans/sx-protocol)
- Wire catch-all route in app.py with before_request redirect handler

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-12 09:51:04 +00:00
0cc2f178a9 Fix component-source calls: use explicit ~name, no magic prefix
All checks were successful
Build and Deploy / build-and-deploy (push) Successful in 19m57s
Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-12 02:37:07 +00:00
2d3c79d999 Fix component-source lookup: prefix ~ for component env key
Some checks failed
Build and Deploy / build-and-deploy (push) Has been cancelled
Components are stored as ~name in the env. The helper was looking up
bare name without the tilde prefix.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-12 02:35:12 +00:00
78b4d0f1ac Fix handler execution: inject page helpers into handler env
Some checks failed
Build and Deploy / build-and-deploy (push) Has been cancelled
component-source and handler-source are page helpers, not IO primitives.
They need to be in the handler evaluation env just like defpage evaluation.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-12 02:31:52 +00:00
c440c26292 Change strapline to "A framework-free reactive hypermedium"
Some checks failed
Build and Deploy / build-and-deploy (push) Has been cancelled
Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-12 02:20:55 +00:00
33586024a7 Merge worktree-typed: increment 2 — rings 2-4
Some checks failed
Build and Deploy / build-and-deploy (push) Has been cancelled
2026-03-12 01:45:35 +00:00
1fce4970fb Add Rings 2-4: JS/Z3 translations, cross-refs, test matching
Ring 2 (bootstrapper): JavaScript translation via js.sx,
Z3/SMT-LIB translation via reader_z3.py. Each define card
now shows SX, Python, JavaScript, and Z3 collapsible panels.

Ring 3 (bridge): Cross-reference index maps function names
to spec files. Each define shows which other spec functions
it references.

Ring 4 (runtime): Test file parsing extracts defsuite/deftest
structure. Fuzzy name matching links tests to functions.
Stats bar shows test count.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-12 01:45:28 +00:00
17c58a2b5b Fix examples.sx: paren balance + dict eval crash at startup
1. Extra closing paren in ex-tabs handler
2. tab-content dict values contained (div ...) HTML tags which crash
   during register_components since HTML primitives aren't in env

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-12 01:31:10 +00:00
c23d0888ea Fix extra closing paren in ex-tabs handler (examples.sx)
Two issues: `)` inside string content wasn't a syntactic paren,
and one extra syntactic `)` at end of handler. Removed both.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-12 01:28:33 +00:00
95e42f9a87 Fix lower-case → lower in specs-explorer.sx
The SX primitive is called 'lower', not 'lower-case'.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-12 00:39:11 +00:00
1b6612fd08 Merge worktree-typed: fix lower-case primitive name 2026-03-12 00:39:11 +00:00
00cf6bbd75 Merge worktree-typed: fix paren balance in docs.sx 2026-03-12 00:30:04 +00:00
6a68894f7d Fix extra closing paren in specs-page after removing cond wrapper
Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-12 00:30:00 +00:00
ac72a4de8d Merge worktree-typed: separate defpage for spec explorer 2026-03-12 00:26:07 +00:00
2dc13ab34f Add separate defpage for spec explorer route
The <slug> route param doesn't match slashes, so
/language/specs/explore/<slug> needs its own defpage
instead of being handled inside specs-page.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-12 00:26:04 +00:00
7515634901 Add spec-explorer-data page helper to boundary.sx
Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-12 00:22:53 +00:00
c5a4340293 Fix spec-explorer-data: pass metadata from SX routing instead of env lookup
The helper was trying to look up all-spec-items from get_component_env(),
but that only contains defcomp/defmacro — not regular defines. Now the
SX routing layer calls find-spec and passes filename/title/desc directly.

Also adds boundary declaration for spec-explorer-data.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-12 00:22:25 +00:00
365440d42f Add spec-explorer-data page helper to boundary.sx
Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-12 00:21:44 +00:00
fe36877c71 Merge worktree-typed into macros: spec explorer increment 1 2026-03-12 00:16:37 +00:00
4aa2133b39 Add spec explorer: structured interactive view of SX spec files
- _spec_explorer_data() helper: parses spec files into sections, defines,
  effects, params, source blocks, and Python translations via PyEmitter
- specs-explorer.sx: 10 defcomp components for explorer UI — cards with
  effect badges, typed param lists, collapsible SX/Python translation panels
- Route at /language/specs/explore/<slug> via docs.sx
- "Explore" link on existing spec detail pages

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-12 00:16:33 +00:00
c2d9a3d2b1 Merge worktree-endpoints: migrate all ref endpoints to SX with typed handlers 2026-03-12 00:15:22 +00:00
575d100f67 Migrate remaining 7 ref endpoints to SX, add :returns type annotations
Add 14 new IO primitives to boundary.sx: web interop (request-form,
request-json, request-header, request-content-type, request-args-all,
request-form-all, request-headers-all, request-file-name), response
manipulation (set-response-header, set-response-status), ephemeral
state (state-get, state-set!), and timing (now, sleep).

All 19 reference handlers now have :returns type annotations using
types.sx vocabulary. Response meta (headers/status) flows through
context vars, applied by register_route_handlers after execution.

Only SSE endpoint remains in Python (async generator paradigm).

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-12 00:14:40 +00:00
56f49f29fb Merge worktree-typed into macros: spec explorer plan 2026-03-12 00:05:49 +00:00
e046542aa0 Add spec explorer plan to sx-docs plans section
New plan page at /etc/plans/spec-explorer describing the "fifth ring"
architecture: SX exploring itself through per-function cards showing
source, Python/JS/Z3 translations, platform deps, tests, proofs, and
usage examples.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-12 00:05:45 +00:00
89e8645d8f Merge branch 'worktree-endpoints' into macros 2026-03-11 23:48:30 +00:00
fba84540e2 Extend defhandler with :path/:method/:csrf, migrate 12 ref endpoints to SX
defhandler now supports keyword options for public route registration:
  (defhandler name :path "/..." :method :post :csrf false (&key) body)

Infrastructure: forms.sx parses options, HandlerDef stores path/method/csrf,
register_route_handlers() mounts path-based handlers as app routes.

New IO primitives (boundary.sx "Web interop" section): now, sleep,
request-form, request-json, request-header, request-content-type.

First migration: 12 reference API endpoints from Python f-string SX
to declarative .sx handlers in sx/sx/handlers/ref-api.sx.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 23:48:05 +00:00
4e96997e09 Merge worktree-typed into macros: deftype, defeffect, and effect annotations 2026-03-11 23:24:37 +00:00
2f42e8826c Add :effects annotations to all spec files and update bootstrappers
Bootstrappers (bootstrap_py.py, js.sx) now skip :effects keyword in
define forms, enabling effect annotations throughout the spec without
changing generated output.

Annotated 180+ functions across 14 spec files:
- signals.sx: signal/deref [] pure, reset!/swap!/effect/batch [mutation]
- engine.sx: parse-* [] pure, morph-*/swap-* [mutation io]
- orchestration.sx: all [mutation io] (browser event binding)
- adapter-html.sx: render-* [render]
- adapter-dom.sx: render-* [render], reactive-* [render mutation]
- adapter-sx.sx: aser-* [render]
- adapter-async.sx: async-render-*/async-aser-* [render io]
- parser.sx: all [] pure
- render.sx: predicates [] pure, process-bindings [mutation]
- boot.sx: all [mutation io] (browser init)
- deps.sx: scan-*/transitive-* [] pure, compute-all-* [mutation]
- router.sx: all [] pure (URL matching)

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 23:22:34 +00:00
524c99e4ff Restructure specs into hierarchical sections, add "The Art Chain" essay
Specs nav reorganized from flat list into 6 sections with children:
Core (5), Adapters (4), Browser (4), Reactive (1), Host Interface (3),
Extensions (4). Added missing spec items: adapter-async, signals,
boundary, forms, page-helpers, types. Architecture page updated to
match. New essay on ars, techne, and the self-making artifact chain.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 23:11:24 +00:00
0f9b449315 Add :effects annotations to boundary.sx IO and signal primitives
All 11 define-io-primitive entries now declare :effects [io].
Signal primitives annotated: signal/deref/computed = [] (pure),
reset!/swap!/effect/batch = [mutation].

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 23:02:22 +00:00
a69604acaf Add type annotations to remaining untyped spec params
trampoline (eval.sx), signal/deref (signals.sx), aser (adapter-sx.sx).

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 22:57:20 +00:00
ce7ad125b6 Add deftype and defeffect to SX type system (Phases 6-7)
Phase 6 — deftype: named type aliases, unions, records, and parameterized
types. Type definitions stored as plain dicts in *type-registry*. Includes
resolve-type for named type resolution, substitute-type-vars for
parameterized instantiation, subtype-resolved? for structural record
subtyping, and infer-type extension for record field type inference via get.

Phase 7 — defeffect: static effect annotations. Effects stored in
*effect-registry* and *effect-annotations*. Supports :effects keyword on
defcomp and define. Gradual: unannotated = all effects, empty list = pure.
check-body-walk validates effect containment at call sites.

Standard types defined: (maybe a), type-def, diagnostic, prim-param-sig.
Standard effects declared: io, mutation, render.

84/84 type system tests pass. Both Python and JS bootstrappers succeed.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 22:51:19 +00:00
8f88e52b27 Add DOM primitives (dom-set-prop, dom-call-method, dom-post-message), bump SW cache v2, remove video demo
All checks were successful
Build and Deploy / build-and-deploy (push) Successful in 6m57s
New platform_js primitives for direct DOM property/method access and
cross-origin iframe communication. Service worker static cache bumped
to v2 to flush stale assets. Removed experimental video embed from
header island, routes, and home page.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 21:51:05 +00:00
b8018ba385 Add type annotations to federation-choose-username defcomp params
Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 21:03:17 +00:00
95ffc0ecb7 Merge worktree-typed into macros: defcomp type annotations 2026-03-11 21:02:12 +00:00
477ce766ff Add (param :as type) annotations to defcomp params across all services and templates
Annotates ~500 defcomp params across 62 files: market (5), blog (7), cart (5),
events (3), federation (4), account (3), orders (2), shared templates (11),
sx docs (14), plus remaining spec fn params (z3, test-framework, adapter-dom,
adapter-async, engine, eval). Total annotations in codebase: 1043.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 21:01:02 +00:00
98c1023b81 Merge branch 'worktree-typed' into macros 2026-03-11 20:27:43 +00:00
b99e69d1bb Add (param :as type) annotations to all fn/lambda params across SX spec
Extend the type annotation system from defcomp-only to fn/lambda params:
- Infrastructure: sf-lambda, py/js-collect-params-loop, and bootstrap_py.py
  now recognize (name :as type) in param lists, extracting just the name
- bootstrap_py.py: add _extract_param_name() helper, fix _emit_for_each_stmt
- 521 type annotations across 22 .sx spec files (eval, types, adapters,
  transpilers, engine, orchestration, deps, signals, router, prove, etc.)
- Zero behavioral change: annotations are metadata for static analysis only
- All bootstrappers (Python, JS, G1) pass, 81/81 spec tests pass

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 20:27:36 +00:00
a425ea8ed4 Marsh demo: video embed with reactive+hypermedia interplay
- ~video-player defisland persists across SPA navigations (morph-safe)
- Clicking "reactive" cycles colour (signal) + fetches random YouTube video (sx-get)
- sx-trigger="fetch-video" + dom-first-child check: video keeps playing on repeat clicks
- Close button (x) clears video via /api/clear-video hypermedia endpoint
- Autoplay+mute removes YouTube's red play button overlay
- Header restructured: logo in anchor, tagline outside (no accidental navigation)
- Flex centering on video container

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 20:27:04 +00:00
c82941d93c Merge main into macros: resolve nav restructure conflicts
Take HEAD's updated typed-sx content (deftype, effect system details)
with main's /etc/plans/ path prefix. Take main's newer sx-browser.js
timestamp.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 19:26:56 +00:00
9b38ef2ce9 Add deftype and static effect system to typed-sx plan
Phase 6 (deftype): type aliases, unions, records (typed dict shapes),
parameterized types. Phase 7: pragmatic static effect checking — io,
dom, async, state annotations with render-mode enforcement, no
algebraic handlers, zero runtime cost. Phases 1-5 marked done.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 19:12:37 +00:00
4d54be6b6b Restructure SX docs nav into 4 top-level sections with nested routing
New hierarchy: Geography (Reactive Islands, Hypermedia Lakes, Marshes,
Isomorphism), Language (Docs, Specs, Bootstrappers, Testing),
Applications (CSSX, Protocols), Etc (Essays, Philosophy, Plans).

All routes updated to match: /reactive/* → /geography/reactive/*,
/docs/* → /language/docs/*, /essays/* → /etc/essays/*, etc.
Updates nav-data.sx, all defpage routes, API endpoints, internal links
across 43 files. Enhanced find-nav-match for nested group resolution.

Also includes: page-helpers-demo sf-total fix (reduce instead of set!),
rebootstrapped sx-browser.js and sx_ref.py, defensive slice/rest guards.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 18:50:31 +00:00
5d5512e74a Add typed params to 67 primitives, implement check-primitive-call
Annotate all primitives in primitives.sx with (:as type) param types
where meaningful (67/80 — 13 polymorphic ops stay untyped). Add
parse_primitive_param_types() to boundary_parser.py for extraction.
Implement check-primitive-call in types.sx with full positional + rest
param validation, thread prim-param-types through check-body-walk,
check-component, and check-all. 10 new tests (438 total, all pass).

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 18:39:20 +00:00
8a530569a2 Add (name :as type) annotation syntax for defcomp params
parse-comp-params now recognizes (name :as type) — a 3-element list
with :as keyword separator. Type annotations are stored on the
Component via component-param-types and used by types.sx for call-site
checking. Unannotated params default to any. 428/428 tests pass (50
types tests including 6 annotation tests).

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 17:12:54 +00:00
b82fd7822d Merge branch 'main' into worktree-typed-sx
# Conflicts:
#	shared/sx/ref/platform_py.py
#	shared/sx/ref/sx_ref.py
2026-03-11 17:06:30 +00:00
e5dbe9f3da Add types.sx gradual type system spec module with 44 tests
Implements subtype checking, type inference, type narrowing, and
component call-site checking. All type logic is in types.sx (spec),
bootstrapped to every host. Adds test-types.sx with full coverage.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 17:06:09 +00:00
0174fbfea3 Regenerate sx-browser.js — file was accidentally emptied in previous commit
Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 16:56:51 +00:00
cd7653d8c3 Fix cond ambiguity: check ALL clauses with cond-scheme?, not just first
The cond special form misclassified Clojure-style as scheme-style when
the first test was a 2-element list like (nil? x) — treating it as a
scheme clause ((test body)) instead of a function call. Define
cond-scheme? using every? to check ALL clauses, fix eval.sx sf-cond and
render.sx eval-cond, rewrite engine.sx parse-time/filter-params as
nested if to avoid the ambiguity, add regression tests across eval/
render/aser specs. 378/378 tests pass.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 16:51:41 +00:00
ff6c1fab71 Fix process-bindings scope loss and async-invoke arity, bootstrap async adapter
Two bugs fixed:
1. process-bindings used merge(env) which returns {} for Env objects
   (Env is not a dict subclass). Changed to env-extend in render.sx
   and adapter-async.sx. This caused "Undefined symbol: theme" etc.
2. async-aser-eval-call passed evaled-args list to async-invoke(&rest),
   double-wrapping it. Changed to inline apply + coroutine check.

Also: bootstrap define-async into sx_ref.py (Phase 6), replace ~1000 LOC
hand-written async_eval_ref.py with 24-line thin re-export shim.

Test runner now uses Env (not flat dict) for render envs to catch scope bugs.
8 new regression tests (4 scope chain, 2 native callable arity, 2 render).

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 16:38:47 +00:00
e843602ac9 Fix aser list flattening bug, add wire format test suite (41 tests)
The sync aser-call in adapter-sx.sx didn't flatten list results from
map/filter in positional children — serialize(list) wrapped in parens
creating ((div ...) ...) which re-parses as an invalid call. Rewrote
aser-call from reduce to for-each (bootstrapper can't nest for-each
inside reduce lambdas) and added list flattening in both aser-call
and aser-fragment.

Also adds test-aser.sx (41 tests), render-sx platform function,
expanded test-render.sx (+7 map/filter children tests), and specs
async-eval-slot-inner in adapter-async.sx.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 14:59:31 +00:00
c95e19dcf2 Page helpers demo: defisland, map-in-children fix, _eval_slot ref evaluator
- Add page-helpers-demo page with defisland ~demo-client-runner (pure SX,
  zero JS files) showing spec functions running on both server and client
- Fix _aser_component children serialization: flatten list results from map
  instead of serialize(list) which wraps in parens creating ((div ...) ...)
  that re-parses as invalid function call. Fixed in adapter-async.sx spec
  and async_eval_ref.py
- Switch _eval_slot to use async_eval_ref.py when SX_USE_REF=1 (was
  hardcoded to async_eval.py)
- Add Island type support to async_eval_ref.py: import, SSR rendering,
  aser dispatch, thread-first, defisland in _ASER_FORMS
- Add server affinity check: components with :affinity :server expand
  even when _expand_components is False
- Add diagnostic _aser_stack context to EvalError messages
- New spec files: adapter-async.sx, page-helpers.sx, platform_js.py
- Bootstrappers: page-helpers module support, performance.now() timing
- 0-arity lambda event handler fix in adapter-dom.sx

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 14:30:12 +00:00
29c90a625b Delete evaluator.py shim: all imports go directly to bootstrapped sx_ref.py
EvalError moved to types.py. All 27 files updated to import eval_expr,
trampoline, call_lambda, etc. directly from shared.sx.ref.sx_ref instead
of through the evaluator.py indirection layer. 320/320 spec tests pass.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 11:15:48 +00:00
4c4806c8dd Fix all 9 spec test failures: Env scope chain, IO detection, offline mutation
All checks were successful
Build and Deploy / build-and-deploy (push) Successful in 4m11s
- env.py: Add MergedEnv with dual-parent lookup (primary for set!,
  secondary for reads), add dict-compat methods to Env
- platform_py.py: make_lambda stores env reference (no copy), env_merge
  uses MergedEnv for proper set! propagation, ancestor detection prevents
  unbounded chains in TCO recursion, sf_set_bang walks scope chain
- types.py: Component/Island io_refs defaults to None (not computed)
  instead of empty set, so component-pure? falls through to scan
- run.py: Test env uses Env class, mock execute-action calls SX lambdas
  via _call_sx instead of direct Python call

Spec tests: 320/320 (was 311/320)

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 09:42:04 +00:00
d8cddbd971 Replace hand-written evaluator with bootstrapped spec, emit flat Python
- evaluator.py: replace 1200 lines of hand-written eval with thin shim
  that re-exports from bootstrapped sx_ref.py
- bootstrap_py.py: emit all fn-bodied defines as `def` (not `lambda`),
  flatten tail-position if/cond/case/when to if/elif with returns,
  fix &rest handling in _emit_define_as_def
- platform_py.py: EvalError imports from evaluator.py so catches work
- __init__.py: remove SX_USE_REF conditional, always use bootstrapped
- tests/run.py: reset render_active after render tests for isolation
- Removes setrecursionlimit(5000) hack — no longer needed with flat code

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 09:18:17 +00:00
3906ab3558 Fix quasiquote flattening bug, decouple relations from evaluator
- Fix qq-expand in eval.sx: use concat+list instead of append to prevent
  nested lists from being flattened during quasiquote expansion
- Update append primitive to match spec ("if x is list, concatenate")
- Rebuild sx_ref.py with quasiquote fix
- Make relations.py self-contained: parse defrelation AST directly
  without depending on the evaluator (25/25 tests pass)
- Replace hand-written JSEmitter with js.sx self-hosting bootstrapper
- Guard server-only tests in test-eval.sx with runtime check

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 04:53:34 +00:00
46cd179703 Fix multi-body lambda in evaluator, rebuild sx_ref.py with router module
evaluator.py _sf_lambda used only expr[2] (first body expression) instead
of collecting all body expressions and wrapping in (begin ...) when multiple.
This caused multi-body lambdas to silently discard all but the first expression.

Rebuilt sx_ref.py with --spec-modules deps,router,engine,signals so the
router functions are available from the bootstrapped code. The test runner
already had _load_router_from_bootstrap() but it was falling back to the
hand-written evaluator (which has set! scoping issues) because the router
functions weren't in sx_ref.py. Now 134/134 eval+router tests pass.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 04:34:17 +00:00
5d3676d751 Register component-affinity as JS primitive for runtime SX access
Fixes 4 test-eval.sx failures (component affinity tests).
Remaining 24 failures are server-only features (defpage, stream-*)
that don't belong in the browser evaluator.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 03:56:18 +00:00
86363d9f34 Fix browser: set render-active in DOM adapter + on adapter init
Browser always evaluates in render context — _renderMode must be true
when DOM adapter is loaded, and render-to-dom must call set-render-active!.
Fixes 'Undefined symbol: <>' error in browser.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 03:51:59 +00:00
8586f54dcb Add render-active? gate to JS platform, fix parity test for &rest
- JS platform: add renderActiveP/setRenderActiveB + RENAMES for
  render-active?/set-render-active! so eval-list gate works in browser
- Rebuild sx-browser.js from updated spec
- Fix test_rest_params: &rest not supported in bare lambda (spec-correct)

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 03:50:13 +00:00
f54ebf26f8 Separate eval from render: render-active? gate in eval-list
eval-list only dispatches to the render adapter when render-active? is true.
render-to-html and aser set render-active! on entry. Pure evaluate() calls
no longer stringify component results through the render adapter.

Fixes component children parity: (defcomp ~wrap (&key &rest children) children)
now returns [1,2,3] in eval mode, renders to "123" only in render mode.

Parity: 112/116 pass (remaining 4 are hand-written evaluator.py bugs).

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 03:42:04 +00:00
0a7a9aa5ae Add parity test suite: 116 tests comparing hand-written vs bootstrapped evaluator
110 pass, 6 known gaps identified (multi-body lambda, &rest in bare lambda,
component body evaluation, void element self-closing style).

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 03:20:33 +00:00
f1e0e0d0a3 Extract platform_py.py: single source of truth for bootstrapper platform sections
bootstrap_py.py (G0) and run_py_sx.py (G1) now both import static
platform sections from platform_py.py instead of duplicating them.
bootstrap_py.py shrinks from 2287 to 1176 lines — only the PyEmitter
transpiler and build orchestration remain.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-11 03:11:33 +00:00
1341c144da URL restructure, 404 page, trailing slash normalization, layout fixes
- Rename /reactive-islands/ → /reactive/, /reference/ → /hypermedia/reference/,
  /examples/ → /hypermedia/examples/ across all .sx and .py files
- Add 404 error page (not-found.sx) working on both server refresh and
  client-side SX navigation via orchestration.sx error response handling
- Add trailing slash redirect (GET only, excludes /api/, /static/, /internal/)
- Remove blue sky-500 header bar from SX docs layout (conditional on header-rows)
- Fix 405 on API endpoints from trailing slash redirect hitting POST/PUT/DELETE
- Fix client-side 404: orchestration.sx now swaps error response content
  instead of silently dropping it
- Add new plan files and home page component

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-10 21:30:18 +00:00
e149dfe968 Fix island hydration double-render bug, add marshes plan
Client-rendered islands were re-hydrated by boot.sx because
renderDomIsland didn't mark them as processed. Hydration read
empty data-sx-state, overwriting kwargs (e.g. path) with NIL.
Fix: mark-processed! in adapter-dom.sx so boot skips them.

New plan: marshes — where reactivity and hypermedia interpenetrate.
Three patterns: server writes to signals, reactive marsh zones with
transforms, and signal-bound hypermedia interpretation.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-10 15:53:44 +00:00
b8c5426093 Lake demo: page path in copyright updates across navigation morphs
The ~sx-header island now shows the current page path (faded, after
the copyright) inside the copyright lake. Navigate between pages:
the path text updates via server-driven lake morph while the reactive
colour-cycling signal persists. Subtle visible proof of L2-3.

Also fixes Island &key param serialization in component-source helper.

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-10 15:05:19 +00:00
9b9fc6b6a5 Level 2-3: lake morphing — server content flows through reactive islands
Lake tag (lake :id "name" children...) creates server-morphable slots
within islands. During morph, the engine enters hydrated islands and
updates data-sx-lake elements by ID while preserving surrounding
reactive DOM (signals, effects, event listeners).

Specced in .sx, bootstrapped to JS and Python:
- adapter-dom.sx: render-dom-lake, reactive-attr marks data-sx-reactive-attrs
- adapter-html.sx: render-html-lake SSR output
- adapter-sx.sx: lake serialized in wire format
- engine.sx: morph-island-children (lake-by-ID matching),
  sync-attrs skips reactive attributes
- ~sx-header uses lakes for logo and copyright
- Hegelian essay updated with lake code example

Also includes: lambda nil-padding for missing args, page env ordering fix

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-10 14:29:54 +00:00
d5e416e478 Reactive island preservation across server-driven morphs
Islands survive hypermedia swaps: morph-node skips hydrated
data-sx-island elements when the same island exists in new content.
dispose-islands-in skips hydrated islands to prevent premature cleanup.

- @client directive: .sx files marked ;; @client send define forms to browser
- CSSX client-side: cssxgroup renamed (no hyphen) to avoid isRenderExpr
  matching it as a custom element — was producing [object HTMLElement]
- Island wrappers: div→span to avoid block-in-inline HTML parse breakage
- ~sx-header is now a defisland with inline reactive colour cycling
- bootstrap_js.py defaults output to shared/static/scripts/sx-browser.js
- Deleted stale sx-ref.js (sx-browser.js is the canonical browser build)
- Hegelian Synthesis essay: dialectic of hypertext and reactivity
- component-source helper handles Island types for docs pretty-printing

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-10 14:10:35 +00:00
8a5c115557 SX docs: configurable shell, SX-native event handlers, nav fixes
- Configurable page shell (~sx-page-shell kwargs + SX_SHELL app config)
  so each app controls its own assets — sx docs loads only sx-browser.js
- SX-evaluated sx-on:* handlers (eval-expr instead of new Function)
  with DOM primitives registered in PRIMITIVES table
- data-init boot mode for pure SX initialization scripts
- Jiggle animation on links while fetching
- Nav: 3-column grid for centered alignment, is-leaf sizing,
  fix map-indexed param order (index, item), guard mod-by-zero
- Async route eval failure now falls back to server fetch
  instead of silently rendering nothing
- Remove duplicate h1 title from ~doc-page
- Re-bootstrap sx-ref.js + sx-browser.js

Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
2026-03-10 11:00:59 +00:00
180 changed files with 23845 additions and 14857 deletions

View File

@@ -1,12 +1,12 @@
;; Auth page components (device auth — account-specific) ;; Auth page components (device auth — account-specific)
;; Login and check-email components are shared: see shared/sx/templates/auth.sx ;; Login and check-email components are shared: see shared/sx/templates/auth.sx
(defcomp ~account-device-error (&key error) (defcomp ~account-device-error (&key (error :as string))
(when error (when error
(div :class "bg-red-50 border border-red-200 text-red-700 p-3 rounded mb-4" (div :class "bg-red-50 border border-red-200 text-red-700 p-3 rounded mb-4"
error))) error)))
(defcomp ~account-device-form (&key error action csrf-token code) (defcomp ~account-device-form (&key error (action :as string) (csrf-token :as string) (code :as string))
(div :class "py-8 max-w-md mx-auto" (div :class "py-8 max-w-md mx-auto"
(h1 :class "text-2xl font-bold mb-6" "Authorize device") (h1 :class "text-2xl font-bold mb-6" "Authorize device")
(p :class "text-stone-600 mb-4" "Enter the code shown in your terminal to sign in.") (p :class "text-stone-600 mb-4" "Enter the code shown in your terminal to sign in.")
@@ -29,21 +29,21 @@
;; Assembled auth page content — replaces Python _login_page_content etc. ;; Assembled auth page content — replaces Python _login_page_content etc.
(defcomp ~account-login-content (&key error email) (defcomp ~account-login-content (&key (error :as string?) (email :as string?))
(~auth-login-form (~auth-login-form
:error (when error (~auth-error-banner :error error)) :error (when error (~auth-error-banner :error error))
:action (url-for "auth.start_login") :action (url-for "auth.start_login")
:csrf-token (csrf-token) :csrf-token (csrf-token)
:email (or email ""))) :email (or email "")))
(defcomp ~account-device-content (&key error code) (defcomp ~account-device-content (&key (error :as string?) (code :as string?))
(~account-device-form (~account-device-form
:error (when error (~account-device-error :error error)) :error (when error (~account-device-error :error error))
:action (url-for "auth.device_submit") :action (url-for "auth.device_submit")
:csrf-token (csrf-token) :csrf-token (csrf-token)
:code (or code ""))) :code (or code "")))
(defcomp ~account-check-email-content (&key email email-error) (defcomp ~account-check-email-content (&key (email :as string?) (email-error :as string?))
(~auth-check-email (~auth-check-email
:email (escape (or email "")) :email (escape (or email ""))
:error (when email-error :error (when email-error

View File

@@ -1,26 +1,26 @@
;; Account dashboard components ;; Account dashboard components
(defcomp ~account-error-banner (&key error) (defcomp ~account-error-banner (&key (error :as string))
(when error (when error
(div :class "rounded-lg border border-red-200 bg-red-50 text-red-800 px-4 py-3 text-sm" (div :class "rounded-lg border border-red-200 bg-red-50 text-red-800 px-4 py-3 text-sm"
error))) error)))
(defcomp ~account-user-email (&key email) (defcomp ~account-user-email (&key (email :as string))
(when email (when email
(p :class "text-sm text-stone-500 mt-1" email))) (p :class "text-sm text-stone-500 mt-1" email)))
(defcomp ~account-user-name (&key name) (defcomp ~account-user-name (&key (name :as string))
(when name (when name
(p :class "text-sm text-stone-600" name))) (p :class "text-sm text-stone-600" name)))
(defcomp ~account-logout-form (&key csrf-token) (defcomp ~account-logout-form (&key (csrf-token :as string))
(form :action "/auth/logout/" :method "post" (form :action "/auth/logout/" :method "post"
(input :type "hidden" :name "csrf_token" :value csrf-token) (input :type "hidden" :name "csrf_token" :value csrf-token)
(button :type "submit" (button :type "submit"
:class "inline-flex items-center gap-2 rounded-full border border-stone-300 px-4 py-2 text-sm font-medium text-stone-700 hover:bg-stone-50 transition" :class "inline-flex items-center gap-2 rounded-full border border-stone-300 px-4 py-2 text-sm font-medium text-stone-700 hover:bg-stone-50 transition"
(i :class "fa-solid fa-right-from-bracket text-xs") " Sign out"))) (i :class "fa-solid fa-right-from-bracket text-xs") " Sign out")))
(defcomp ~account-label-item (&key name) (defcomp ~account-label-item (&key (name :as string))
(span :class "inline-flex items-center rounded-full border border-stone-200 px-3 py-1 text-xs font-medium bg-white/60" (span :class "inline-flex items-center rounded-full border border-stone-200 px-3 py-1 text-xs font-medium bg-white/60"
name)) name))
@@ -43,7 +43,7 @@
labels))) labels)))
;; Assembled dashboard content — replaces Python _account_main_panel_sx ;; Assembled dashboard content — replaces Python _account_main_panel_sx
(defcomp ~account-dashboard-content (&key error) (defcomp ~account-dashboard-content (&key (error :as string?))
(let* ((user (current-user)) (let* ((user (current-user))
(csrf (csrf-token))) (csrf (csrf-token)))
(~account-main-panel (~account-main-panel

View File

@@ -1,17 +1,17 @@
;; Newsletter management components ;; Newsletter management components
(defcomp ~account-newsletter-desc (&key description) (defcomp ~account-newsletter-desc (&key (description :as string))
(when description (when description
(p :class "text-xs text-stone-500 mt-0.5 truncate" description))) (p :class "text-xs text-stone-500 mt-0.5 truncate" description)))
(defcomp ~account-newsletter-toggle (&key id url hdrs target cls checked knob-cls) (defcomp ~account-newsletter-toggle (&key (id :as string) (url :as string) (hdrs :as dict) (target :as string) (cls :as string) (checked :as string) (knob-cls :as string))
(div :id id :class "flex items-center" (div :id id :class "flex items-center"
(button :sx-post url :sx-headers hdrs :sx-target target :sx-swap "outerHTML" (button :sx-post url :sx-headers hdrs :sx-target target :sx-swap "outerHTML"
:class cls :role "switch" :aria-checked checked :class cls :role "switch" :aria-checked checked
(span :class knob-cls)))) (span :class knob-cls))))
(defcomp ~account-newsletter-item (&key name desc toggle) (defcomp ~account-newsletter-item (&key (name :as string) desc toggle)
(div :class "flex items-center justify-between py-4 first:pt-0 last:pb-0" (div :class "flex items-center justify-between py-4 first:pt-0 last:pb-0"
(div :class "min-w-0 flex-1" (div :class "min-w-0 flex-1"
(p :class "text-sm font-medium text-stone-800" name) (p :class "text-sm font-medium text-stone-800" name)
@@ -32,7 +32,7 @@
;; Assembled newsletters content — replaces Python _newsletters_panel_sx ;; Assembled newsletters content — replaces Python _newsletters_panel_sx
;; Takes pre-fetched newsletter-list from page helper ;; Takes pre-fetched newsletter-list from page helper
(defcomp ~account-newsletters-content (&key newsletter-list account-url) (defcomp ~account-newsletters-content (&key (newsletter-list :as list) (account-url :as string?))
(let* ((csrf (csrf-token))) (let* ((csrf (csrf-token)))
(if (empty? newsletter-list) (if (empty? newsletter-list)
(~account-newsletter-empty) (~account-newsletter-empty)

View File

@@ -1,6 +1,6 @@
;; Blog admin panel components ;; Blog admin panel components
(defcomp ~blog-cache-panel (&key clear-url csrf) (defcomp ~blog-cache-panel (&key (clear-url :as string) (csrf :as string))
(div :class "max-w-2xl mx-auto px-4 py-6 space-y-6" (div :class "max-w-2xl mx-auto px-4 py-6 space-y-6"
(div :class "flex flex-col md:flex-row gap-3 items-start" (div :class "flex flex-col md:flex-row gap-3 items-start"
(form :sx-post clear-url :sx-trigger "submit" :sx-target "#cache-status" :sx-swap "innerHTML" (form :sx-post clear-url :sx-trigger "submit" :sx-target "#cache-status" :sx-swap "innerHTML"
@@ -19,10 +19,10 @@
:sx-headers hx-headers :class "text-sm border border-stone-300 rounded px-2 py-1" :sx-headers hx-headers :class "text-sm border border-stone-300 rounded px-2 py-1"
options)) options))
(defcomp ~blog-snippet-option (&key value selected label) (defcomp ~blog-snippet-option (&key (value :as string) (selected :as boolean) (label :as string))
(option :value value :selected selected label)) (option :value value :selected selected label))
(defcomp ~blog-snippet-row (&key name owner badge-cls visibility extra) (defcomp ~blog-snippet-row (&key (name :as string) (owner :as string) (badge-cls :as string) (visibility :as string) extra)
(div :class "flex items-center gap-4 p-4 hover:bg-stone-50 transition" (div :class "flex items-center gap-4 p-4 hover:bg-stone-50 transition"
(div :class "flex-1 min-w-0" (div :class "flex-1 min-w-0"
(div :class "font-medium truncate" name) (div :class "font-medium truncate" name)
@@ -42,7 +42,7 @@
(div :id "menu-item-form" :class "mb-6") (div :id "menu-item-form" :class "mb-6")
(div :id "menu-items-list" list))) (div :id "menu-items-list" list)))
(defcomp ~blog-menu-item-row (&key img label slug sort-order edit-url delete-url confirm-text hx-headers) (defcomp ~blog-menu-item-row (&key img (label :as string) (slug :as string) (sort-order :as string) (edit-url :as string) (delete-url :as string) (confirm-text :as string) hx-headers)
(div :class "flex items-center gap-4 p-4 hover:bg-stone-50 transition" (div :class "flex items-center gap-4 p-4 hover:bg-stone-50 transition"
(div :class "text-stone-400 cursor-move" (i :class "fa fa-grip-vertical")) (div :class "text-stone-400 cursor-move" (i :class "fa fa-grip-vertical"))
img img
@@ -81,7 +81,7 @@
(div :class "h-8 w-8 rounded-full text-xs font-semibold flex items-center justify-center border border-stone-300 flex-shrink-0" (div :class "h-8 w-8 rounded-full text-xs font-semibold flex items-center justify-center border border-stone-300 flex-shrink-0"
:style style initial)) :style style initial))
(defcomp ~blog-tag-group-li (&key icon edit-href name slug sort-order) (defcomp ~blog-tag-group-li (&key icon (edit-href :as string) (name :as string) (slug :as string) (sort-order :as number))
(li :class "border rounded p-3 bg-white flex items-center gap-3" (li :class "border rounded p-3 bg-white flex items-center gap-3"
icon icon
(div :class "flex-1" (div :class "flex-1"
@@ -106,7 +106,7 @@
;; Tag group edit ;; Tag group edit
(defcomp ~blog-tag-checkbox (&key tag-id checked img name) (defcomp ~blog-tag-checkbox (&key (tag-id :as string) (checked :as boolean) img (name :as string))
(label :class "flex items-center gap-2 px-2 py-1 hover:bg-stone-50 rounded text-sm cursor-pointer" (label :class "flex items-center gap-2 px-2 py-1 hover:bg-stone-50 rounded text-sm cursor-pointer"
(input :type "checkbox" :name "tag_ids" :value tag-id :checked checked :class "rounded border-stone-300") (input :type "checkbox" :name "tag_ids" :value tag-id :checked checked :class "rounded border-stone-300")
img (span name))) img (span name)))
@@ -114,7 +114,7 @@
(defcomp ~blog-tag-checkbox-image (&key src) (defcomp ~blog-tag-checkbox-image (&key src)
(img :src src :alt "" :class "h-4 w-4 rounded-full object-cover")) (img :src src :alt "" :class "h-4 w-4 rounded-full object-cover"))
(defcomp ~blog-tag-group-edit-form (&key save-url csrf name colour sort-order feature-image tags) (defcomp ~blog-tag-group-edit-form (&key (save-url :as string) (csrf :as string) (name :as string) (colour :as string?) (sort-order :as number) (feature-image :as string?) tags)
(form :method "post" :action save-url :class "border rounded p-4 bg-white space-y-4" (form :method "post" :action save-url :class "border rounded p-4 bg-white space-y-4"
(input :type "hidden" :name "csrf_token" :value csrf) (input :type "hidden" :name "csrf_token" :value csrf)
(div :class "space-y-3" (div :class "space-y-3"
@@ -133,7 +133,7 @@
(div :class "flex gap-3" (div :class "flex gap-3"
(button :type "submit" :class "border rounded px-4 py-2 bg-stone-800 text-white text-sm" "Save")))) (button :type "submit" :class "border rounded px-4 py-2 bg-stone-800 text-white text-sm" "Save"))))
(defcomp ~blog-tag-group-delete-form (&key delete-url csrf) (defcomp ~blog-tag-group-delete-form (&key (delete-url :as string) (csrf :as string))
(form :method "post" :action delete-url :class "border-t pt-4" (form :method "post" :action delete-url :class "border-t pt-4"
:onsubmit "return confirm('Delete this tag group? Tags will not be deleted.')" :onsubmit "return confirm('Delete this tag group? Tags will not be deleted.')"
(input :type "hidden" :name "csrf_token" :value csrf) (input :type "hidden" :name "csrf_token" :value csrf)

View File

@@ -4,17 +4,17 @@
(div :class "absolute top-20 right-2 z-10 text-6xl md:text-4xl" (div :class "absolute top-20 right-2 z-10 text-6xl md:text-4xl"
(~blog-like-toggle :like-url like-url :hx-headers hx-headers :heart heart))) (~blog-like-toggle :like-url like-url :hx-headers hx-headers :heart heart)))
(defcomp ~blog-draft-status (&key publish-requested timestamp) (defcomp ~blog-draft-status (&key (publish-requested :as boolean) (timestamp :as string?))
(<> (div :class "flex justify-center gap-2 mt-1" (<> (div :class "flex justify-center gap-2 mt-1"
(span :class "inline-block px-2 py-0.5 rounded-full text-xs font-semibold bg-amber-100 text-amber-800" "Draft") (span :class "inline-block px-2 py-0.5 rounded-full text-xs font-semibold bg-amber-100 text-amber-800" "Draft")
(when publish-requested (span :class "inline-block px-2 py-0.5 rounded-full text-xs font-semibold bg-blue-100 text-blue-800" "Publish requested"))) (when publish-requested (span :class "inline-block px-2 py-0.5 rounded-full text-xs font-semibold bg-blue-100 text-blue-800" "Publish requested")))
(when timestamp (p :class "text-sm text-stone-500" (str "Updated: " timestamp))))) (when timestamp (p :class "text-sm text-stone-500" (str "Updated: " timestamp)))))
(defcomp ~blog-published-status (&key timestamp) (defcomp ~blog-published-status (&key (timestamp :as string))
(p :class "text-sm text-stone-500" (str "Published: " timestamp))) (p :class "text-sm text-stone-500" (str "Published: " timestamp)))
;; Tag components — accept data, not HTML ;; Tag components — accept data, not HTML
(defcomp ~blog-tag-icon (&key src name initial) (defcomp ~blog-tag-icon (&key (src :as string?) (name :as string) (initial :as string))
(if src (if src
(img :src src :alt name :class "h-4 w-4 rounded-full object-cover border border-stone-300 flex-shrink-0") (img :src src :alt name :class "h-4 w-4 rounded-full object-cover border border-stone-300 flex-shrink-0")
(div :class "h-4 w-4 rounded-full text-[8px] font-semibold flex items-center justify-center border border-stone-300 flex-shrink-0 bg-stone-200 text-stone-600" initial))) (div :class "h-4 w-4 rounded-full text-[8px] font-semibold flex items-center justify-center border border-stone-300 flex-shrink-0 bg-stone-200 text-stone-600" initial)))
@@ -45,12 +45,12 @@
(span :class "text-stone-700" name))) (span :class "text-stone-700" name)))
;; Card — accepts pure data ;; Card — accepts pure data
(defcomp ~blog-card (&key slug href hx-select title (defcomp ~blog-card (&key (slug :as string) (href :as string) (hx-select :as string?) (title :as string)
feature-image excerpt (feature-image :as string?) (excerpt :as string?)
status is-draft publish-requested status-timestamp status (is-draft :as boolean) (publish-requested :as boolean) (status-timestamp :as string?)
liked like-url csrf-token (liked :as boolean) (like-url :as string?) (csrf-token :as string?)
has-like (has-like :as boolean)
tags authors widget) (tags :as list?) (authors :as list?) widget)
(article :class "border-b pb-6 last:border-b-0 relative" (article :class "border-b pb-6 last:border-b-0 relative"
(when has-like (when has-like
(~blog-like-button (~blog-like-button
@@ -80,9 +80,9 @@
(ul :class "flex flex-wrap gap-2 text-sm" (ul :class "flex flex-wrap gap-2 text-sm"
(map (lambda (a) (~blog-author-item :image (get a "image") :name (get a "name"))) authors)))))))) (map (lambda (a) (~blog-author-item :image (get a "image") :name (get a "name"))) authors))))))))
(defcomp ~blog-card-tile (&key href hx-select feature-image title (defcomp ~blog-card-tile (&key (href :as string) (hx-select :as string?) (feature-image :as string?) (title :as string)
is-draft publish-requested status-timestamp (is-draft :as boolean) (publish-requested :as boolean) (status-timestamp :as string?)
excerpt tags authors) (excerpt :as string?) (tags :as list?) (authors :as list?))
(article :class "relative" (article :class "relative"
(a :href href :sx-get href :sx-target "#main-panel" (a :href href :sx-get href :sx-target "#main-panel"
:sx-select (or hx-select "#main-panel") :sx-swap "outerHTML" :sx-push-url "true" :sx-select (or hx-select "#main-panel") :sx-swap "outerHTML" :sx-push-url "true"
@@ -107,7 +107,7 @@
(map (lambda (a) (~blog-author-item :image (get a "image") :name (get a "name"))) authors)))))))) (map (lambda (a) (~blog-author-item :image (get a "image") :name (get a "name"))) authors))))))))
;; Data-driven blog cards list (replaces Python _blog_cards_sx loop) ;; Data-driven blog cards list (replaces Python _blog_cards_sx loop)
(defcomp ~blog-cards-from-data (&key posts view sentinel) (defcomp ~blog-cards-from-data (&key (posts :as list?) (view :as string?) sentinel)
(<> (<>
(map (lambda (p) (map (lambda (p)
(if (= view "tile") (if (= view "tile")
@@ -131,7 +131,7 @@
sentinel)) sentinel))
;; Data-driven page cards list (replaces Python _page_cards_sx loop) ;; Data-driven page cards list (replaces Python _page_cards_sx loop)
(defcomp ~page-cards-from-data (&key pages sentinel) (defcomp ~page-cards-from-data (&key (pages :as list?) sentinel)
(<> (<>
(map (lambda (pg) (map (lambda (pg)
(~blog-page-card (~blog-page-card
@@ -150,7 +150,7 @@
(when has-market (span :class "inline-block px-2 py-0.5 rounded-full text-xs font-semibold bg-green-100 text-green-800" (when has-market (span :class "inline-block px-2 py-0.5 rounded-full text-xs font-semibold bg-green-100 text-green-800"
(i :class "fa fa-shopping-bag mr-1") "Market")))) (i :class "fa fa-shopping-bag mr-1") "Market"))))
(defcomp ~blog-page-card (&key href hx-select title has-calendar has-market pub-timestamp feature-image excerpt) (defcomp ~blog-page-card (&key (href :as string) (hx-select :as string?) (title :as string) (has-calendar :as boolean) (has-market :as boolean) (pub-timestamp :as string?) (feature-image :as string?) (excerpt :as string?))
(article :class "border-b pb-6 last:border-b-0 relative" (article :class "border-b pb-6 last:border-b-0 relative"
(a :href href :sx-get href :sx-target "#main-panel" (a :href href :sx-get href :sx-target "#main-panel"
:sx-select (or hx-select "#main-panel") :sx-swap "outerHTML" :sx-push-url "true" :sx-select (or hx-select "#main-panel") :sx-swap "outerHTML" :sx-push-url "true"

View File

@@ -1,6 +1,6 @@
;; Blog post detail components ;; Blog post detail components
(defcomp ~blog-detail-edit-link (&key href hx-select) (defcomp ~blog-detail-edit-link (&key (href :as string) (hx-select :as string))
(a :href href :sx-get href :sx-target "#main-panel" (a :href href :sx-get href :sx-target "#main-panel"
:sx-select hx-select :sx-swap "outerHTML" :sx-push-url "true" :sx-select hx-select :sx-swap "outerHTML" :sx-push-url "true"
:class "inline-block px-3 py-1 rounded-full text-sm font-semibold bg-stone-700 text-white hover:bg-stone-800 transition-colors" :class "inline-block px-3 py-1 rounded-full text-sm font-semibold bg-stone-700 text-white hover:bg-stone-800 transition-colors"
@@ -20,7 +20,7 @@
(div :class "absolute top-2 right-2 z-10 text-8xl md:text-6xl" (div :class "absolute top-2 right-2 z-10 text-8xl md:text-6xl"
(~blog-like-toggle :like-url like-url :hx-headers hx-headers :heart heart))) (~blog-like-toggle :like-url like-url :hx-headers hx-headers :heart heart)))
(defcomp ~blog-detail-excerpt (&key excerpt) (defcomp ~blog-detail-excerpt (&key (excerpt :as string))
(div :class "w-full text-center italic text-3xl p-2" excerpt)) (div :class "w-full text-center italic text-3xl p-2" excerpt))
(defcomp ~blog-detail-chrome (&key like excerpt at-bar) (defcomp ~blog-detail-chrome (&key like excerpt at-bar)
@@ -43,10 +43,10 @@
;; Data-driven composition — replaces _post_main_panel_sx ;; Data-driven composition — replaces _post_main_panel_sx
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~blog-post-detail-content (&key slug is-draft publish-requested can-edit edit-href (defcomp ~blog-post-detail-content (&key (slug :as string) (is-draft :as boolean) (publish-requested :as boolean) (can-edit :as boolean) (edit-href :as string?)
is-page has-user liked like-url csrf (is-page :as boolean) (has-user :as boolean) (liked :as boolean) (like-url :as string?) (csrf :as string?)
custom-excerpt tags authors (custom-excerpt :as string?) (tags :as list?) (authors :as list?)
feature-image html-content sx-content) (feature-image :as string?) (html-content :as string?) (sx-content :as string?))
(let* ((hx-select "#main-panel") (let* ((hx-select "#main-panel")
(draft-sx (when is-draft (draft-sx (when is-draft
(~blog-detail-draft (~blog-detail-draft
@@ -70,7 +70,7 @@
:html-content html-content :html-content html-content
:sx-content sx-content))) :sx-content sx-content)))
(defcomp ~blog-meta (&key robots page-title desc canonical og-type og-title image twitter-card twitter-title) (defcomp ~blog-meta (&key (robots :as string) (page-title :as string) (desc :as string) (canonical :as string?) (og-type :as string) (og-title :as string) (image :as string?) (twitter-card :as string) (twitter-title :as string))
(<> (<>
(meta :name "robots" :content robots) (meta :name "robots" :content robots)
(title page-title) (title page-title)

View File

@@ -4,7 +4,7 @@
(div :class "max-w-[768px] mx-auto mt-[16px] rounded-[8px] border border-red-300 bg-red-50 px-[16px] py-[12px] text-[14px] text-red-700" (div :class "max-w-[768px] mx-auto mt-[16px] rounded-[8px] border border-red-300 bg-red-50 px-[16px] py-[12px] text-[14px] text-red-700"
(strong "Save failed:") " " error)) (strong "Save failed:") " " error))
(defcomp ~blog-editor-form (&key csrf title-placeholder create-label) (defcomp ~blog-editor-form (&key (csrf :as string) (title-placeholder :as string) (create-label :as string))
(form :id "post-new-form" :method "post" :class "max-w-[768px] mx-auto pb-[48px]" (form :id "post-new-form" :method "post" :class "max-w-[768px] mx-auto pb-[48px]"
(input :type "hidden" :name "csrf_token" :value csrf) (input :type "hidden" :name "csrf_token" :value csrf)
(input :type "hidden" :id "lexical-json-input" :name "lexical" :value "") (input :type "hidden" :id "lexical-json-input" :name "lexical" :value "")
@@ -56,11 +56,11 @@
:class "px-[20px] py-[6px] bg-stone-700 text-white text-[14px] rounded-[8px] hover:bg-stone-800 transition-colors cursor-pointer" create-label)))) :class "px-[20px] py-[6px] bg-stone-700 text-white text-[14px] rounded-[8px] hover:bg-stone-800 transition-colors cursor-pointer" create-label))))
;; Edit form — pre-populated version for /<slug>/admin/edit/ ;; Edit form — pre-populated version for /<slug>/admin/edit/
(defcomp ~blog-editor-edit-form (&key csrf updated-at title-val excerpt-val (defcomp ~blog-editor-edit-form (&key (csrf :as string) (updated-at :as string) (title-val :as string?) (excerpt-val :as string?)
feature-image feature-image-caption (feature-image :as string?) (feature-image-caption :as string?)
sx-content-val lexical-json (sx-content-val :as string?) (lexical-json :as string?)
has-sx title-placeholder (has-sx :as boolean) (title-placeholder :as string)
status already-emailed (status :as string) (already-emailed :as boolean)
newsletter-options footer-extra) newsletter-options footer-extra)
(let* ((sel-cls "text-[14px] rounded-[4px] border border-stone-200 px-[8px] py-[6px] bg-white text-stone-600") (let* ((sel-cls "text-[14px] rounded-[4px] border border-stone-200 px-[8px] py-[6px] bg-white text-stone-600")
(active "px-[12px] py-[6px] text-[13px] font-medium text-stone-700 border-b-2 border-stone-700 cursor-pointer bg-transparent") (active "px-[12px] py-[6px] text-[13px] font-medium text-stone-700 border-b-2 border-stone-700 cursor-pointer bg-transparent")
@@ -153,14 +153,14 @@
" sync();" " sync();"
"})();")) "})();"))
(defcomp ~blog-editor-styles (&key css-href) (defcomp ~blog-editor-styles (&key (css-href :as string))
(<> (link :rel "stylesheet" :href css-href) (<> (link :rel "stylesheet" :href css-href)
(style (style
"#lexical-editor { display: flow-root; }" "#lexical-editor { display: flow-root; }"
"#lexical-editor [data-kg-card=\"html\"] * { float: none !important; }" "#lexical-editor [data-kg-card=\"html\"] * { float: none !important; }"
"#lexical-editor [data-kg-card=\"html\"] table { width: 100% !important; }"))) "#lexical-editor [data-kg-card=\"html\"] table { width: 100% !important; }")))
(defcomp ~blog-editor-scripts (&key js-src sx-editor-js-src init-js) (defcomp ~blog-editor-scripts (&key (js-src :as string) (sx-editor-js-src :as string?) (init-js :as string))
(<> (script :src js-src) (<> (script :src js-src)
(when sx-editor-js-src (script :src sx-editor-js-src)) (when sx-editor-js-src (script :src sx-editor-js-src))
(script init-js))) (script init-js)))

View File

@@ -1,11 +1,11 @@
;; Blog filter components ;; Blog filter components
(defcomp ~blog-action-button (&key href hx-select btn-class title icon-class label) (defcomp ~blog-action-button (&key (href :as string) (hx-select :as string) (btn-class :as string) (title :as string) (icon-class :as string) (label :as string))
(a :href href :sx-get href :sx-target "#main-panel" (a :href href :sx-get href :sx-target "#main-panel"
:sx-select hx-select :sx-swap "outerHTML" :sx-push-url "true" :sx-select hx-select :sx-swap "outerHTML" :sx-push-url "true"
:class btn-class :title title (i :class icon-class) label)) :class btn-class :title title (i :class icon-class) label))
(defcomp ~blog-drafts-button (&key href hx-select btn-class title label draft-count) (defcomp ~blog-drafts-button (&key (href :as string) (hx-select :as string) (btn-class :as string) (title :as string) (label :as string) (draft-count :as number))
(a :href href :sx-get href :sx-target "#main-panel" (a :href href :sx-get href :sx-target "#main-panel"
:sx-select hx-select :sx-swap "outerHTML" :sx-push-url "true" :sx-select hx-select :sx-swap "outerHTML" :sx-push-url "true"
:class btn-class :title title (i :class "fa fa-file-text-o mr-1") " Drafts " :class btn-class :title title (i :class "fa fa-file-text-o mr-1") " Drafts "
@@ -61,7 +61,7 @@
(span :class "flex-1") (span :class "flex-1")
(span :class "inline-block bg-stone-100 text-stone-600 px-2 py-1 text-xs font-medium border border-stone-200" count)))) (span :class "inline-block bg-stone-100 text-stone-600 px-2 py-1 text-xs font-medium border border-stone-200" count))))
(defcomp ~blog-filter-summary (&key text) (defcomp ~blog-filter-summary (&key (text :as string))
(span :class "text-sm text-stone-600" text)) (span :class "text-sm text-stone-600" text))
;; Data-driven tag groups filter (replaces Python _tag_groups_filter_sx loop) ;; Data-driven tag groups filter (replaces Python _tag_groups_filter_sx loop)

View File

@@ -7,7 +7,7 @@
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
;; Image card ;; Image card
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~kg-image (&key src alt caption width href) (defcomp ~kg-image (&key (src :as string) (alt :as string?) (caption :as string?) (width :as string?) (href :as string?))
(figure :class (str "kg-card kg-image-card" (figure :class (str "kg-card kg-image-card"
(if (= width "wide") " kg-width-wide" (if (= width "wide") " kg-width-wide"
(if (= width "full") " kg-width-full" ""))) (if (= width "full") " kg-width-full" "")))
@@ -19,7 +19,7 @@
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
;; Gallery card ;; Gallery card
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~kg-gallery (&key images caption) (defcomp ~kg-gallery (&key (images :as list) (caption :as string?))
(figure :class "kg-card kg-gallery-card kg-width-wide" (figure :class "kg-card kg-gallery-card kg-width-wide"
(div :class "kg-gallery-container" (div :class "kg-gallery-container"
(map (lambda (row) (map (lambda (row)
@@ -48,7 +48,7 @@
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
;; Embed card ;; Embed card
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~kg-embed (&key html caption) (defcomp ~kg-embed (&key (html :as string) (caption :as string?))
(figure :class "kg-card kg-embed-card" (figure :class "kg-card kg-embed-card"
(~rich-text :html html) (~rich-text :html html)
(when caption (figcaption caption)))) (when caption (figcaption caption))))
@@ -56,7 +56,7 @@
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
;; Bookmark card ;; Bookmark card
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~kg-bookmark (&key url title description icon author publisher thumbnail caption) (defcomp ~kg-bookmark (&key (url :as string) (title :as string?) (description :as string?) (icon :as string?) (author :as string?) (publisher :as string?) (thumbnail :as string?) (caption :as string?))
(figure :class "kg-card kg-bookmark-card" (figure :class "kg-card kg-bookmark-card"
(a :class "kg-bookmark-container" :href url (a :class "kg-bookmark-container" :href url
(div :class "kg-bookmark-content" (div :class "kg-bookmark-content"
@@ -75,7 +75,7 @@
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
;; Callout card ;; Callout card
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~kg-callout (&key color emoji content) (defcomp ~kg-callout (&key (color :as string?) (emoji :as string?) (content :as string?))
(div :class (str "kg-card kg-callout-card kg-callout-card-" (or color "grey")) (div :class (str "kg-card kg-callout-card kg-callout-card-" (or color "grey"))
(when emoji (div :class "kg-callout-emoji" emoji)) (when emoji (div :class "kg-callout-emoji" emoji))
(div :class "kg-callout-text" (or content "")))) (div :class "kg-callout-text" (or content ""))))
@@ -83,14 +83,14 @@
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
;; Button card ;; Button card
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~kg-button (&key url text alignment) (defcomp ~kg-button (&key (url :as string) (text :as string?) (alignment :as string?))
(div :class (str "kg-card kg-button-card kg-align-" (or alignment "center")) (div :class (str "kg-card kg-button-card kg-align-" (or alignment "center"))
(a :href url :class "kg-btn kg-btn-accent" (or text "")))) (a :href url :class "kg-btn kg-btn-accent" (or text ""))))
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
;; Toggle card (accordion) ;; Toggle card (accordion)
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~kg-toggle (&key heading content) (defcomp ~kg-toggle (&key (heading :as string?) (content :as string?))
(div :class "kg-card kg-toggle-card" :data-kg-toggle-state "close" (div :class "kg-card kg-toggle-card" :data-kg-toggle-state "close"
(div :class "kg-toggle-heading" (div :class "kg-toggle-heading"
(h4 :class "kg-toggle-heading-text" (or heading "")) (h4 :class "kg-toggle-heading-text" (or heading ""))
@@ -101,7 +101,7 @@
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
;; Audio card ;; Audio card
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~kg-audio (&key src title duration thumbnail) (defcomp ~kg-audio (&key (src :as string) (title :as string?) (duration :as string?) (thumbnail :as string?))
(div :class "kg-card kg-audio-card" (div :class "kg-card kg-audio-card"
(if thumbnail (if thumbnail
(img :src thumbnail :alt "audio-thumbnail" :class "kg-audio-thumbnail") (img :src thumbnail :alt "audio-thumbnail" :class "kg-audio-thumbnail")
@@ -124,7 +124,7 @@
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
;; Video card ;; Video card
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~kg-video (&key src caption width thumbnail loop) (defcomp ~kg-video (&key (src :as string) (caption :as string?) (width :as string?) (thumbnail :as string?) (loop :as boolean?))
(figure :class (str "kg-card kg-video-card" (figure :class (str "kg-card kg-video-card"
(if (= width "wide") " kg-width-wide" (if (= width "wide") " kg-width-wide"
(if (= width "full") " kg-width-full" ""))) (if (= width "full") " kg-width-full" "")))
@@ -136,7 +136,7 @@
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
;; File card ;; File card
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~kg-file (&key src filename title filesize caption) (defcomp ~kg-file (&key (src :as string) (filename :as string?) (title :as string?) (filesize :as string?) (caption :as string?))
(div :class "kg-card kg-file-card" (div :class "kg-card kg-file-card"
(a :class "kg-file-card-container" :href src :download (or filename "") (a :class "kg-file-card-container" :href src :download (or filename "")
(div :class "kg-file-card-contents" (div :class "kg-file-card-contents"

View File

@@ -1,6 +1,6 @@
;; Blog settings panel components (features, markets, associated entries) ;; Blog settings panel components (features, markets, associated entries)
(defcomp ~blog-features-form (&key features-url calendar-checked market-checked hs-trigger) (defcomp ~blog-features-form (&key (features-url :as string) (calendar-checked :as boolean) (market-checked :as boolean) (hs-trigger :as string))
(form :sx-put features-url :sx-target "#features-panel" :sx-swap "outerHTML" (form :sx-put features-url :sx-target "#features-panel" :sx-swap "outerHTML"
:sx-headers {:Content-Type "application/json"} :sx-encoding "json" :class "space-y-3" :sx-headers {:Content-Type "application/json"} :sx-encoding "json" :class "space-y-3"
(label :class "flex items-center gap-3 cursor-pointer" (label :class "flex items-center gap-3 cursor-pointer"
@@ -31,7 +31,7 @@
;; Markets panel ;; Markets panel
(defcomp ~blog-market-item (&key name slug delete-url confirm-text) (defcomp ~blog-market-item (&key (name :as string) (slug :as string) (delete-url :as string) (confirm-text :as string))
(li :class "flex items-center justify-between p-3 bg-stone-50 rounded" (li :class "flex items-center justify-between p-3 bg-stone-50 rounded"
(div (span :class "font-medium" name) (div (span :class "font-medium" name)
(span :class "text-stone-400 text-sm ml-2" (str "/" slug "/"))) (span :class "text-stone-400 text-sm ml-2" (str "/" slug "/")))
@@ -93,11 +93,11 @@
;; Associated entries ;; Associated entries
(defcomp ~blog-entry-image (&key src title) (defcomp ~blog-entry-image (&key (src :as string?) (title :as string))
(if src (img :src src :alt title :class "w-8 h-8 rounded-full object-cover flex-shrink-0") (if src (img :src src :alt title :class "w-8 h-8 rounded-full object-cover flex-shrink-0")
(div :class "w-8 h-8 rounded-full bg-stone-200 flex-shrink-0"))) (div :class "w-8 h-8 rounded-full bg-stone-200 flex-shrink-0")))
(defcomp ~blog-associated-entry (&key confirm-text toggle-url hx-headers img name date-str) (defcomp ~blog-associated-entry (&key (confirm-text :as string) (toggle-url :as string) hx-headers img (name :as string) (date-str :as string))
(button :type "button" (button :type "button"
:class "w-full text-left p-3 rounded border bg-green-50 border-green-300 transition hover:bg-green-100" :class "w-full text-left p-3 rounded border bg-green-50 border-green-300 transition hover:bg-green-100"
:data-confirm "" :data-confirm-title "Remove entry?" :data-confirm "" :data-confirm-title "Remove entry?"
@@ -150,7 +150,7 @@
;; Entries browser composition — replaces _h_post_entries_content ;; Entries browser composition — replaces _h_post_entries_content
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~blog-calendar-browser-item (&key name title image view-url) (defcomp ~blog-calendar-browser-item (&key (name :as string) (title :as string) (image :as string?) (view-url :as string))
(details :class "border rounded-lg bg-white" :data-toggle-group "calendar-browser" (details :class "border rounded-lg bg-white" :data-toggle-group "calendar-browser"
(summary :class "p-4 cursor-pointer hover:bg-stone-50 flex items-center gap-3" (summary :class "p-4 cursor-pointer hover:bg-stone-50 flex items-center gap-3"
(if image (if image
@@ -182,11 +182,11 @@
;; Post settings form composition — replaces _h_post_settings_content ;; Post settings form composition — replaces _h_post_settings_content
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~blog-settings-field-label (&key text field-for) (defcomp ~blog-settings-field-label (&key (text :as string) (field-for :as string))
(label :for field-for (label :for field-for
:class "block text-[13px] font-medium text-stone-500 mb-[4px]" text)) :class "block text-[13px] font-medium text-stone-500 mb-[4px]" text))
(defcomp ~blog-settings-section (&key title content is-open) (defcomp ~blog-settings-section (&key (title :as string) content (is-open :as boolean))
(details :class "border border-stone-200 rounded-[8px] overflow-hidden" :open is-open (details :class "border border-stone-200 rounded-[8px] overflow-hidden" :open is-open
(summary :class "px-[16px] py-[10px] bg-stone-50 text-[14px] font-medium text-stone-600 cursor-pointer select-none hover:bg-stone-100 transition-colors" (summary :class "px-[16px] py-[10px] bg-stone-50 text-[14px] font-medium text-stone-600 cursor-pointer select-none hover:bg-stone-100 transition-colors"
title) title)

View File

@@ -1,6 +1,6 @@
;; Cart calendar entry components ;; Cart calendar entry components
(defcomp ~cart-cal-entry (&key name date-str cost) (defcomp ~cart-cal-entry (&key (name :as string) (date-str :as string) (cost :as string))
(li :class "flex items-start justify-between text-sm" (li :class "flex items-start justify-between text-sm"
(div (div :class "font-medium" name) (div (div :class "font-medium" name)
(div :class "text-xs text-stone-500" date-str)) (div :class "text-xs text-stone-500" date-str))

View File

@@ -1,12 +1,12 @@
;; Cart item components ;; Cart item components
(defcomp ~cart-item-img (&key src alt) (defcomp ~cart-item-img (&key (src :as string) (alt :as string))
(img :src src :alt alt :class "w-24 h-24 sm:w-32 sm:h-28 object-cover rounded-xl border border-stone-100" :loading "lazy")) (img :src src :alt alt :class "w-24 h-24 sm:w-32 sm:h-28 object-cover rounded-xl border border-stone-100" :loading "lazy"))
(defcomp ~cart-item-price (&key text) (defcomp ~cart-item-price (&key (text :as string))
(p :class "text-sm sm:text-base font-semibold text-stone-900" text)) (p :class "text-sm sm:text-base font-semibold text-stone-900" text))
(defcomp ~cart-item-price-was (&key text) (defcomp ~cart-item-price-was (&key (text :as string))
(p :class "text-xs text-stone-400 line-through" text)) (p :class "text-xs text-stone-400 line-through" text))
(defcomp ~cart-item-no-price () (defcomp ~cart-item-no-price ()
@@ -17,13 +17,13 @@
(i :class "fa-solid fa-triangle-exclamation text-[0.6rem]" :aria-hidden "true") (i :class "fa-solid fa-triangle-exclamation text-[0.6rem]" :aria-hidden "true")
" This item is no longer available or price has changed")) " This item is no longer available or price has changed"))
(defcomp ~cart-item-brand (&key brand) (defcomp ~cart-item-brand (&key (brand :as string))
(p :class "mt-0.5 text-[0.7rem] sm:text-xs text-stone-500" brand)) (p :class "mt-0.5 text-[0.7rem] sm:text-xs text-stone-500" brand))
(defcomp ~cart-item-line-total (&key text) (defcomp ~cart-item-line-total (&key (text :as string))
(p :class "text-sm sm:text-base font-semibold text-stone-900" text)) (p :class "text-sm sm:text-base font-semibold text-stone-900" text))
(defcomp ~cart-item (&key id img prod-url title brand deleted price qty-url csrf minus qty plus line-total) (defcomp ~cart-item (&key (id :as string) img (prod-url :as string) (title :as string) brand deleted price (qty-url :as string) (csrf :as string) (minus :as string) (qty :as string) (plus :as string) line-total)
(article :id id :class "flex flex-col sm:flex-row gap-3 sm:gap-4 rounded-2xl bg-white shadow-sm border border-stone-200 p-3 sm:p-4 md:p-5" (article :id id :class "flex flex-col sm:flex-row gap-3 sm:gap-4 rounded-2xl bg-white shadow-sm border border-stone-200 p-3 sm:p-4 md:p-5"
(div :class "w-full sm:w-32 shrink-0 flex justify-center sm:block" (when img img)) (div :class "w-full sm:w-32 shrink-0 flex justify-center sm:block" (when img img))
(div :class "flex-1 min-w-0" (div :class "flex-1 min-w-0"
@@ -54,7 +54,7 @@
summary)))) summary))))
;; Assembled cart item from serialized data — replaces Python _cart_item_sx ;; Assembled cart item from serialized data — replaces Python _cart_item_sx
(defcomp ~cart-item-from-data (&key item) (defcomp ~cart-item-from-data (&key (item :as dict))
(let* ((slug (or (get item "slug") "")) (let* ((slug (or (get item "slug") ""))
(title (or (get item "title") "")) (title (or (get item "title") ""))
(image (get item "image")) (image (get item "image"))
@@ -96,7 +96,7 @@
(~cart-item-line-total :text (str "Line total: " symbol (format-decimal line-total 2))))))) (~cart-item-line-total :text (str "Line total: " symbol (format-decimal line-total 2)))))))
;; Assembled calendar entries section — replaces Python _calendar_entries_sx ;; Assembled calendar entries section — replaces Python _calendar_entries_sx
(defcomp ~cart-cal-section-from-data (&key entries) (defcomp ~cart-cal-section-from-data (&key (entries :as list))
(when (not (empty? entries)) (when (not (empty? entries))
(~cart-cal-section (~cart-cal-section
:items (map (lambda (e) :items (map (lambda (e)
@@ -108,7 +108,7 @@
entries)))) entries))))
;; Assembled ticket groups section — replaces Python _ticket_groups_sx ;; Assembled ticket groups section — replaces Python _ticket_groups_sx
(defcomp ~cart-tickets-section-from-data (&key ticket-groups) (defcomp ~cart-tickets-section-from-data (&key (ticket-groups :as list))
(when (not (empty? ticket-groups)) (when (not (empty? ticket-groups))
(let* ((csrf (csrf-token)) (let* ((csrf (csrf-token))
(qty-url (url-for "cart_global.update_ticket_quantity"))) (qty-url (url-for "cart_global.update_ticket_quantity")))
@@ -137,7 +137,7 @@
ticket-groups))))) ticket-groups)))))
;; Assembled cart summary — replaces Python _cart_summary_sx ;; Assembled cart summary — replaces Python _cart_summary_sx
(defcomp ~cart-summary-from-data (&key item-count grand-total symbol is-logged-in checkout-action login-href user-email) (defcomp ~cart-summary-from-data (&key (item-count :as number) (grand-total :as number) (symbol :as string) (is-logged-in :as boolean) (checkout-action :as string) (login-href :as string) (user-email :as string?))
(~cart-summary-panel (~cart-summary-panel
:item-count (str item-count) :item-count (str item-count)
:subtotal (str symbol (format-decimal grand-total 2)) :subtotal (str symbol (format-decimal grand-total 2))
@@ -148,7 +148,7 @@
(~cart-checkout-signin :href login-href)))) (~cart-checkout-signin :href login-href))))
;; Assembled page cart content — replaces Python _page_cart_main_panel_sx ;; Assembled page cart content — replaces Python _page_cart_main_panel_sx
(defcomp ~cart-page-cart-content (&key cart-items cal-entries ticket-groups summary) (defcomp ~cart-page-cart-content (&key (cart-items :as list?) (cal-entries :as list?) (ticket-groups :as list?) summary)
(if (and (empty? (or cart-items (list))) (if (and (empty? (or cart-items (list)))
(empty? (or cal-entries (list))) (empty? (or cal-entries (list)))
(empty? (or ticket-groups (list)))) (empty? (or ticket-groups (list))))

View File

@@ -1,6 +1,6 @@
;; Cart overview components ;; Cart overview components
(defcomp ~cart-badge (&key icon text) (defcomp ~cart-badge (&key (icon :as string) (text :as string))
(span :class "inline-flex items-center gap-1 px-2 py-0.5 rounded-full bg-stone-100" (span :class "inline-flex items-center gap-1 px-2 py-0.5 rounded-full bg-stone-100"
(i :class icon :aria-hidden "true") text)) (i :class icon :aria-hidden "true") text))
@@ -8,13 +8,13 @@
(div :class "mt-1 flex flex-wrap gap-2 text-xs text-stone-600" (div :class "mt-1 flex flex-wrap gap-2 text-xs text-stone-600"
badges)) badges))
(defcomp ~cart-group-card-img (&key src alt) (defcomp ~cart-group-card-img (&key (src :as string) (alt :as string))
(img :src src :alt alt :class "h-16 w-16 rounded-xl object-cover border border-stone-200 flex-shrink-0")) (img :src src :alt alt :class "h-16 w-16 rounded-xl object-cover border border-stone-200 flex-shrink-0"))
(defcomp ~cart-mp-subtitle (&key title) (defcomp ~cart-mp-subtitle (&key (title :as string))
(p :class "text-xs text-stone-500 truncate" title)) (p :class "text-xs text-stone-500 truncate" title))
(defcomp ~cart-group-card (&key href img display-title subtitle badges total) (defcomp ~cart-group-card (&key (href :as string) img (display-title :as string) subtitle badges (total :as string))
(a :href href :class "block rounded-2xl border border-stone-200 bg-white shadow-sm hover:shadow-md hover:border-stone-300 transition p-4 sm:p-5" (a :href href :class "block rounded-2xl border border-stone-200 bg-white shadow-sm hover:shadow-md hover:border-stone-300 transition p-4 sm:p-5"
(div :class "flex items-start gap-4" (div :class "flex items-start gap-4"
img img
@@ -25,7 +25,7 @@
(div :class "text-lg font-bold text-stone-900" total) (div :class "text-lg font-bold text-stone-900" total)
(div :class "mt-1 text-xs text-emerald-700 font-medium" "View cart \u2192"))))) (div :class "mt-1 text-xs text-emerald-700 font-medium" "View cart \u2192")))))
(defcomp ~cart-orphan-card (&key badges total) (defcomp ~cart-orphan-card (&key badges (total :as string))
(div :class "rounded-2xl border border-dashed border-amber-300 bg-amber-50/60 p-4 sm:p-5" (div :class "rounded-2xl border border-dashed border-amber-300 bg-amber-50/60 p-4 sm:p-5"
(div :class "flex items-start gap-4" (div :class "flex items-start gap-4"
(div :class "h-16 w-16 rounded-xl bg-amber-100 flex items-center justify-center flex-shrink-0" (div :class "h-16 w-16 rounded-xl bg-amber-100 flex items-center justify-center flex-shrink-0"
@@ -46,7 +46,7 @@
(~empty-state :icon "fa fa-shopping-cart" :message "Your cart is empty" :cls "text-center")))) (~empty-state :icon "fa fa-shopping-cart" :message "Your cart is empty" :cls "text-center"))))
;; Assembled page group card — replaces Python _page_group_card_sx ;; Assembled page group card — replaces Python _page_group_card_sx
(defcomp ~cart-page-group-card-from-data (&key grp cart-url-base) (defcomp ~cart-page-group-card-from-data (&key (grp :as dict) (cart-url-base :as string))
(let* ((post (get grp "post")) (let* ((post (get grp "post"))
(product-count (or (get grp "product_count") 0)) (product-count (or (get grp "product_count") 0))
(calendar-count (or (get grp "calendar_count") 0)) (calendar-count (or (get grp "calendar_count") 0))
@@ -85,7 +85,7 @@
:total (str "\u00a3" (format-decimal total 2)))))) :total (str "\u00a3" (format-decimal total 2))))))
;; Assembled cart overview content — replaces Python _overview_main_panel_sx ;; Assembled cart overview content — replaces Python _overview_main_panel_sx
(defcomp ~cart-overview-content (&key page-groups cart-url-base) (defcomp ~cart-overview-content (&key (page-groups :as list) (cart-url-base :as string))
(if (empty? page-groups) (if (empty? page-groups)
(~cart-empty) (~cart-empty)
(~cart-overview-panel (~cart-overview-panel

View File

@@ -1,17 +1,17 @@
;; Cart summary / checkout components ;; Cart summary / checkout components
(defcomp ~cart-checkout-form (&key action csrf label) (defcomp ~cart-checkout-form (&key (action :as string) (csrf :as string) (label :as string))
(form :method "post" :action action :class "w-full" (form :method "post" :action action :class "w-full"
(input :type "hidden" :name "csrf_token" :value csrf) (input :type "hidden" :name "csrf_token" :value csrf)
(button :type "submit" :class "w-full inline-flex items-center justify-center px-4 py-2 text-xs sm:text-sm rounded-full border border-emerald-600 bg-emerald-600 text-white hover:bg-emerald-700 transition" (button :type "submit" :class "w-full inline-flex items-center justify-center px-4 py-2 text-xs sm:text-sm rounded-full border border-emerald-600 bg-emerald-600 text-white hover:bg-emerald-700 transition"
(i :class "fa-solid fa-credit-card mr-2" :aria-hidden "true") label))) (i :class "fa-solid fa-credit-card mr-2" :aria-hidden "true") label)))
(defcomp ~cart-checkout-signin (&key href) (defcomp ~cart-checkout-signin (&key (href :as string))
(div :class "w-full flex" (div :class "w-full flex"
(a :href href :class "w-full cursor-pointer flex flex-row items-center justify-center p-3 gap-2 rounded bg-stone-200 text-black hover:bg-stone-300 transition" (a :href href :class "w-full cursor-pointer flex flex-row items-center justify-center p-3 gap-2 rounded bg-stone-200 text-black hover:bg-stone-300 transition"
(i :class "fa-solid fa-key") (span "sign in or register to checkout")))) (i :class "fa-solid fa-key") (span "sign in or register to checkout"))))
(defcomp ~cart-summary-panel (&key item-count subtotal checkout) (defcomp ~cart-summary-panel (&key (item-count :as string) (subtotal :as string) checkout)
(aside :id "cart-summary" :class "lg:pl-2" (aside :id "cart-summary" :class "lg:pl-2"
(div :class "rounded-2xl bg-white shadow-sm border border-stone-200 p-4 sm:p-5" (div :class "rounded-2xl bg-white shadow-sm border border-stone-200 p-4 sm:p-5"
(h2 :class "text-sm sm:text-base font-semibold text-stone-900 mb-3 sm:mb-4" "Order summary") (h2 :class "text-sm sm:text-base font-semibold text-stone-900 mb-3 sm:mb-4" "Order summary")

View File

@@ -1,12 +1,12 @@
;; Cart ticket components ;; Cart ticket components
(defcomp ~cart-ticket-type-name (&key name) (defcomp ~cart-ticket-type-name (&key (name :as string))
(p :class "mt-0.5 text-[0.7rem] sm:text-xs text-stone-500" name)) (p :class "mt-0.5 text-[0.7rem] sm:text-xs text-stone-500" name))
(defcomp ~cart-ticket-type-hidden (&key value) (defcomp ~cart-ticket-type-hidden (&key (value :as string))
(input :type "hidden" :name "ticket_type_id" :value value)) (input :type "hidden" :name "ticket_type_id" :value value))
(defcomp ~cart-ticket-article (&key name type-name date-str price qty-url csrf entry-id type-hidden minus qty plus line-total) (defcomp ~cart-ticket-article (&key (name :as string) type-name (date-str :as string) (price :as string) (qty-url :as string) (csrf :as string) (entry-id :as string) type-hidden (minus :as string) (qty :as string) (plus :as string) (line-total :as string))
(article :class "flex flex-col sm:flex-row gap-3 sm:gap-4 rounded-2xl bg-white shadow-sm border border-stone-200 p-3 sm:p-4" (article :class "flex flex-col sm:flex-row gap-3 sm:gap-4 rounded-2xl bg-white shadow-sm border border-stone-200 p-3 sm:p-4"
(div :class "flex-1 min-w-0" (div :class "flex-1 min-w-0"
(div :class "flex flex-col sm:flex-row sm:items-start justify-between gap-2 sm:gap-3" (div :class "flex flex-col sm:flex-row sm:items-start justify-between gap-2 sm:gap-3"

View File

@@ -1,28 +1,28 @@
;; Events calendar components ;; Events calendar components
(defcomp ~events-calendar-nav-arrow (&key pill-cls href label) (defcomp ~events-calendar-nav-arrow (&key (pill-cls :as string) (href :as string) (label :as string))
(a :class (str pill-cls " text-xl") :href href (a :class (str pill-cls " text-xl") :href href
:sx-get href :sx-target "#main-panel" :sx-select "#main-panel" :sx-swap "outerHTML" :sx-push-url "true" label)) :sx-get href :sx-target "#main-panel" :sx-select "#main-panel" :sx-swap "outerHTML" :sx-push-url "true" label))
(defcomp ~events-calendar-month-label (&key month-name year) (defcomp ~events-calendar-month-label (&key (month-name :as string) (year :as string))
(div :class "px-3 font-medium" (str month-name " " year))) (div :class "px-3 font-medium" (str month-name " " year)))
(defcomp ~events-calendar-weekday (&key name) (defcomp ~events-calendar-weekday (&key (name :as string))
(div :class "py-1" name)) (div :class "py-1" name))
(defcomp ~events-calendar-day-short (&key day-str) (defcomp ~events-calendar-day-short (&key (day-str :as string))
(span :class "sm:hidden text-[16px] text-stone-500" day-str)) (span :class "sm:hidden text-[16px] text-stone-500" day-str))
(defcomp ~events-calendar-day-num (&key pill-cls href num) (defcomp ~events-calendar-day-num (&key (pill-cls :as string) (href :as string) (num :as string))
(a :class pill-cls :href href :sx-get href :sx-target "#main-panel" :sx-select "#main-panel" (a :class pill-cls :href href :sx-get href :sx-target "#main-panel" :sx-select "#main-panel"
:sx-swap "outerHTML" :sx-push-url "true" num)) :sx-swap "outerHTML" :sx-push-url "true" num))
(defcomp ~events-calendar-entry-badge (&key bg-cls name state-label) (defcomp ~events-calendar-entry-badge (&key (bg-cls :as string) (name :as string) (state-label :as string))
(div :class (str "flex items-center justify-between gap-1 text-[11px] rounded px-1 py-0.5 " bg-cls) (div :class (str "flex items-center justify-between gap-1 text-[11px] rounded px-1 py-0.5 " bg-cls)
(span :class "truncate" name) (span :class "truncate" name)
(span :class "shrink-0 text-[10px] font-semibold uppercase tracking-tight" state-label))) (span :class "shrink-0 text-[10px] font-semibold uppercase tracking-tight" state-label)))
(defcomp ~events-calendar-cell (&key cell-cls day-short day-num badges) (defcomp ~events-calendar-cell (&key (cell-cls :as string) day-short day-num badges)
(div :class cell-cls (div :class cell-cls
(div :class "flex justify-between items-center" (div :class "flex justify-between items-center"
(div :class "flex flex-col" day-short day-num)) (div :class "flex flex-col" day-short day-num))
@@ -37,10 +37,10 @@
(div :class "grid grid-cols-1 sm:grid-cols-7 gap-px bg-stone-200 rounded-xl overflow-hidden" cells)))) (div :class "grid grid-cols-1 sm:grid-cols-7 gap-px bg-stone-200 rounded-xl overflow-hidden" cells))))
;; Calendar grid from data — all iteration in sx ;; Calendar grid from data — all iteration in sx
(defcomp ~events-calendar-grid-from-data (&key pill-cls month-name year (defcomp ~events-calendar-grid-from-data (&key (pill-cls :as string) (month-name :as string) (year :as string)
prev-year-href prev-month-href (prev-year-href :as string) (prev-month-href :as string)
next-month-href next-year-href (next-month-href :as string) (next-year-href :as string)
weekday-names cells) (weekday-names :as list) (cells :as list))
(~events-calendar-grid (~events-calendar-grid
:arrows (<> :arrows (<>
(~events-calendar-nav-arrow :pill-cls pill-cls :href prev-year-href :label "\u00ab") (~events-calendar-nav-arrow :pill-cls pill-cls :href prev-year-href :label "\u00ab")
@@ -66,7 +66,7 @@
(get cell "badges")))))) (get cell "badges"))))))
(or cells (list)))))) (or cells (list))))))
(defcomp ~events-calendar-description-display (&key description edit-url) (defcomp ~events-calendar-description-display (&key (description :as string?) (edit-url :as string))
(div :id "calendar-description" (div :id "calendar-description"
(if description (if description
(p :class "text-stone-700 whitespace-pre-line break-all" description) (p :class "text-stone-700 whitespace-pre-line break-all" description)
@@ -75,12 +75,12 @@
:sx-get edit-url :sx-target "#calendar-description" :sx-swap "outerHTML" :sx-get edit-url :sx-target "#calendar-description" :sx-swap "outerHTML"
(i :class "fas fa-edit")))) (i :class "fas fa-edit"))))
(defcomp ~events-calendar-description-title-oob (&key description) (defcomp ~events-calendar-description-title-oob (&key (description :as string))
(div :id "calendar-description-title" :sx-swap-oob "outerHTML" (div :id "calendar-description-title" :sx-swap-oob "outerHTML"
:class "text-base font-normal break-words whitespace-normal min-w-0 break-all w-full text-center block" :class "text-base font-normal break-words whitespace-normal min-w-0 break-all w-full text-center block"
description)) description))
(defcomp ~events-calendar-description-edit-form (&key save-url cancel-url csrf description) (defcomp ~events-calendar-description-edit-form (&key (save-url :as string) (cancel-url :as string) (csrf :as string) (description :as string?))
(div :id "calendar-description" (div :id "calendar-description"
(form :sx-post save-url :sx-target "#calendar-description" :sx-swap "outerHTML" (form :sx-post save-url :sx-target "#calendar-description" :sx-swap "outerHTML"
(input :type "hidden" :name "csrf_token" :value csrf) (input :type "hidden" :name "csrf_token" :value csrf)

View File

@@ -1,6 +1,6 @@
;; Events day components ;; Events day components
(defcomp ~events-day-entry-link (&key href name time-str) (defcomp ~events-day-entry-link (&key (href :as string) (name :as string) (time-str :as string))
(a :href href :class "flex items-center gap-2 px-3 py-2 hover:bg-stone-100 rounded transition text-sm border sm:whitespace-nowrap sm:flex-shrink-0" (a :href href :class "flex items-center gap-2 px-3 py-2 hover:bg-stone-100 rounded transition text-sm border sm:whitespace-nowrap sm:flex-shrink-0"
(div :class "flex-1 min-w-0" (div :class "flex-1 min-w-0"
(div :class "font-medium truncate" name) (div :class "font-medium truncate" name)
@@ -12,7 +12,7 @@
(div :class "flex overflow-x-auto gap-1 scrollbar-thin" (div :class "flex overflow-x-auto gap-1 scrollbar-thin"
inner))) inner)))
(defcomp ~events-day-table (&key list-container rows pre-action add-url) (defcomp ~events-day-table (&key (list-container :as string) rows (pre-action :as string) (add-url :as string))
(section :id "day-entries" :class list-container (section :id "day-entries" :class list-container
(table :class "w-full text-sm border table-fixed" (table :class "w-full text-sm border table-fixed"
(thead :class "bg-stone-100" (thead :class "bg-stone-100"
@@ -32,27 +32,27 @@
(defcomp ~events-day-empty-row () (defcomp ~events-day-empty-row ()
(tr (td :colspan "6" :class "p-3 text-stone-500" "No entries yet."))) (tr (td :colspan "6" :class "p-3 text-stone-500" "No entries yet.")))
(defcomp ~events-day-row-name (&key href pill-cls name) (defcomp ~events-day-row-name (&key (href :as string) (pill-cls :as string) (name :as string))
(td :class "p-2 align-top w-2/6" (div :class "font-medium" (td :class "p-2 align-top w-2/6" (div :class "font-medium"
(a :href href :class pill-cls :sx-get href :sx-target "#main-panel" :sx-select "#main-panel" (a :href href :class pill-cls :sx-get href :sx-target "#main-panel" :sx-select "#main-panel"
:sx-swap "outerHTML" :sx-push-url "true" name)))) :sx-swap "outerHTML" :sx-push-url "true" name))))
(defcomp ~events-day-row-slot (&key href pill-cls slot-name time-str) (defcomp ~events-day-row-slot (&key (href :as string) (pill-cls :as string) (slot-name :as string) (time-str :as string))
(td :class "p-2 align-top w-1/6" (div :class "text-xs font-medium" (td :class "p-2 align-top w-1/6" (div :class "text-xs font-medium"
(a :href href :class pill-cls :sx-get href :sx-target "#main-panel" :sx-select "#main-panel" (a :href href :class pill-cls :sx-get href :sx-target "#main-panel" :sx-select "#main-panel"
:sx-swap "outerHTML" :sx-push-url "true" slot-name) :sx-swap "outerHTML" :sx-push-url "true" slot-name)
(span :class "text-stone-600 font-normal" time-str)))) (span :class "text-stone-600 font-normal" time-str))))
(defcomp ~events-day-row-time (&key start end) (defcomp ~events-day-row-time (&key (start :as string) (end :as string))
(td :class "p-2 align-top w-1/6" (div :class "text-xs text-stone-600" (str start end)))) (td :class "p-2 align-top w-1/6" (div :class "text-xs text-stone-600" (str start end))))
(defcomp ~events-day-row-state (&key state-id badge) (defcomp ~events-day-row-state (&key (state-id :as string) badge)
(td :class "p-2 align-top w-1/6" (div :id state-id badge))) (td :class "p-2 align-top w-1/6" (div :id state-id badge)))
(defcomp ~events-day-row-cost (&key cost-str) (defcomp ~events-day-row-cost (&key (cost-str :as string))
(td :class "p-2 align-top w-1/6" (span :class "font-medium text-green-600" cost-str))) (td :class "p-2 align-top w-1/6" (span :class "font-medium text-green-600" cost-str)))
(defcomp ~events-day-row-tickets (&key price-str count-str) (defcomp ~events-day-row-tickets (&key (price-str :as string) (count-str :as string))
(td :class "p-2 align-top w-1/6" (div :class "text-xs space-y-1" (td :class "p-2 align-top w-1/6" (div :class "text-xs space-y-1"
(div :class "font-medium text-green-600" price-str) (div :class "font-medium text-green-600" price-str)
(div :class "text-stone-600" count-str)))) (div :class "text-stone-600" count-str))))
@@ -63,7 +63,7 @@
(defcomp ~events-day-row-actions () (defcomp ~events-day-row-actions ()
(td :class "p-2 align-top w-1/6")) (td :class "p-2 align-top w-1/6"))
(defcomp ~events-day-row (&key tr-cls name slot state cost tickets actions) (defcomp ~events-day-row (&key (tr-cls :as string) name slot state cost tickets actions)
(tr :class tr-cls name slot state cost tickets actions)) (tr :class tr-cls name slot state cost tickets actions))
(defcomp ~events-day-admin-panel () (defcomp ~events-day-admin-panel ()
@@ -77,14 +77,14 @@
:id "day-entries-nav-wrapper" :sx-swap-oob "true" :id "day-entries-nav-wrapper" :sx-swap-oob "true"
(div :class "flex overflow-x-auto gap-1 scrollbar-thin" items))) (div :class "flex overflow-x-auto gap-1 scrollbar-thin" items)))
(defcomp ~events-day-nav-entry (&key href nav-btn name time-str) (defcomp ~events-day-nav-entry (&key (href :as string) (nav-btn :as string) (name :as string) (time-str :as string))
(a :href href :class nav-btn (a :href href :class nav-btn
(div :class "flex-1 min-w-0" (div :class "flex-1 min-w-0"
(div :class "font-medium truncate" name) (div :class "font-medium truncate" name)
(div :class "text-xs text-stone-600 truncate" time-str)))) (div :class "text-xs text-stone-600 truncate" time-str))))
;; Day table from data — all row iteration in sx ;; Day table from data — all row iteration in sx
(defcomp ~events-day-table-from-data (&key list-container pre-action add-url tr-cls pill-cls rows) (defcomp ~events-day-table-from-data (&key (list-container :as string) (pre-action :as string) (add-url :as string) (tr-cls :as string) (pill-cls :as string) (rows :as list?))
(~events-day-table (~events-day-table
:list-container list-container :list-container list-container
:rows (if (empty? (or rows (list))) :rows (if (empty? (or rows (list)))
@@ -112,7 +112,7 @@
:pre-action pre-action :add-url add-url)) :pre-action pre-action :add-url add-url))
;; Day entries nav OOB from data ;; Day entries nav OOB from data
(defcomp ~events-day-entries-nav-oob-from-data (&key nav-btn entries) (defcomp ~events-day-entries-nav-oob-from-data (&key (nav-btn :as string) (entries :as list?))
(if (empty? (or entries (list))) (if (empty? (or entries (list)))
(~events-day-entries-nav-oob-empty) (~events-day-entries-nav-oob-empty)
(~events-day-entries-nav-oob (~events-day-entries-nav-oob

View File

@@ -1,6 +1,6 @@
;; Events ticket components ;; Events ticket components
(defcomp ~events-ticket-card (&key href entry-name type-name time-str cal-name badge code-prefix) (defcomp ~events-ticket-card (&key (href :as string) (entry-name :as string) (type-name :as string?) (time-str :as string?) (cal-name :as string?) badge (code-prefix :as string))
(a :href href :class "block rounded-xl border border-stone-200 bg-white p-4 hover:shadow-md transition" (a :href href :class "block rounded-xl border border-stone-200 bg-white p-4 hover:shadow-md transition"
(div :class "flex items-start justify-between gap-4" (div :class "flex items-start justify-between gap-4"
(div :class "flex-1 min-w-0" (div :class "flex-1 min-w-0"
@@ -12,7 +12,7 @@
badge badge
(span :class "text-xs text-stone-400 font-mono" (str code-prefix "...")))))) (span :class "text-xs text-stone-400 font-mono" (str code-prefix "..."))))))
(defcomp ~events-tickets-panel (&key list-container has-tickets cards) (defcomp ~events-tickets-panel (&key (list-container :as string) (has-tickets :as boolean) cards)
(section :id "tickets-list" :class list-container (section :id "tickets-list" :class list-container
(h1 :class "text-2xl font-bold mb-6" "My Tickets") (h1 :class "text-2xl font-bold mb-6" "My Tickets")
(if has-tickets (if has-tickets
@@ -22,9 +22,9 @@
(p :class "text-lg" "No tickets yet") (p :class "text-lg" "No tickets yet")
(p :class "text-sm mt-1" "Tickets will appear here after you purchase them."))))) (p :class "text-sm mt-1" "Tickets will appear here after you purchase them.")))))
(defcomp ~events-ticket-detail (&key list-container back-href header-bg entry-name badge (defcomp ~events-ticket-detail (&key (list-container :as string) (back-href :as string) (header-bg :as string) (entry-name :as string) badge
type-name code time-date time-range cal-name (type-name :as string?) (code :as string) (time-date :as string?) (time-range :as string?) (cal-name :as string?)
type-desc checkin-str qr-script) (type-desc :as string?) (checkin-str :as string?) (qr-script :as string))
(section :id "ticket-detail" :class (str list-container " max-w-lg mx-auto") (section :id "ticket-detail" :class (str list-container " max-w-lg mx-auto")
(a :href back-href :class "inline-flex items-center gap-1 text-sm text-stone-500 hover:text-stone-700 mb-4" (a :href back-href :class "inline-flex items-center gap-1 text-sm text-stone-500 hover:text-stone-700 mb-4"
(i :class "fa fa-arrow-left" :aria-hidden "true") " Back to my tickets") (i :class "fa fa-arrow-left" :aria-hidden "true") " Back to my tickets")
@@ -54,25 +54,25 @@
(script :src "https://cdn.jsdelivr.net/npm/qrcode@1.5.3/build/qrcode.min.js") (script :src "https://cdn.jsdelivr.net/npm/qrcode@1.5.3/build/qrcode.min.js")
(script qr-script))) (script qr-script)))
(defcomp ~events-ticket-admin-stat (&key border bg text-cls label-cls value label) (defcomp ~events-ticket-admin-stat (&key (border :as string) (bg :as string) (text-cls :as string) (label-cls :as string) (value :as string) (label :as string))
(div :class (str "rounded-xl border " border " " bg " p-4 text-center") (div :class (str "rounded-xl border " border " " bg " p-4 text-center")
(div :class (str "text-2xl font-bold " text-cls) value) (div :class (str "text-2xl font-bold " text-cls) value)
(div :class (str "text-xs " label-cls " uppercase tracking-wide") label))) (div :class (str "text-xs " label-cls " uppercase tracking-wide") label)))
(defcomp ~events-ticket-admin-date (&key date-str) (defcomp ~events-ticket-admin-date (&key (date-str :as string))
(div :class "text-xs text-stone-500" date-str)) (div :class "text-xs text-stone-500" date-str))
(defcomp ~events-ticket-admin-checkin-form (&key checkin-url code csrf) (defcomp ~events-ticket-admin-checkin-form (&key (checkin-url :as string) (code :as string) (csrf :as string))
(form :sx-post checkin-url :sx-target (str "#ticket-row-" code) :sx-swap "outerHTML" (form :sx-post checkin-url :sx-target (str "#ticket-row-" code) :sx-swap "outerHTML"
(input :type "hidden" :name "csrf_token" :value csrf) (input :type "hidden" :name "csrf_token" :value csrf)
(button :type "submit" :class "px-3 py-1 bg-blue-600 text-white text-xs rounded hover:bg-blue-700 transition" (button :type "submit" :class "px-3 py-1 bg-blue-600 text-white text-xs rounded hover:bg-blue-700 transition"
(i :class "fa fa-check mr-1" :aria-hidden "true") "Check in"))) (i :class "fa fa-check mr-1" :aria-hidden "true") "Check in")))
(defcomp ~events-ticket-admin-checked-in (&key time-str) (defcomp ~events-ticket-admin-checked-in (&key (time-str :as string))
(span :class "text-xs text-blue-600" (span :class "text-xs text-blue-600"
(i :class "fa fa-check-circle" :aria-hidden "true") (str " " time-str))) (i :class "fa fa-check-circle" :aria-hidden "true") (str " " time-str)))
(defcomp ~events-ticket-admin-row (&key code code-short entry-name date type-name badge action) (defcomp ~events-ticket-admin-row (&key (code :as string) (code-short :as string) (entry-name :as string) date (type-name :as string) badge action)
(tr :class "hover:bg-stone-50 transition" :id (str "ticket-row-" code) (tr :class "hover:bg-stone-50 transition" :id (str "ticket-row-" code)
(td :class "px-4 py-3" (span :class "font-mono text-xs" code-short)) (td :class "px-4 py-3" (span :class "font-mono text-xs" code-short))
(td :class "px-4 py-3" (div :class "font-medium" entry-name) date) (td :class "px-4 py-3" (div :class "font-medium" entry-name) date)
@@ -80,7 +80,7 @@
(td :class "px-4 py-3" badge) (td :class "px-4 py-3" badge)
(td :class "px-4 py-3" action))) (td :class "px-4 py-3" action)))
(defcomp ~events-ticket-admin-panel (&key list-container stats lookup-url has-tickets rows) (defcomp ~events-ticket-admin-panel (&key (list-container :as string) stats (lookup-url :as string) (has-tickets :as boolean) rows)
(section :id "ticket-admin" :class list-container (section :id "ticket-admin" :class list-container
(h1 :class "text-2xl font-bold mb-6" "Ticket Admin") (h1 :class "text-2xl font-bold mb-6" "Ticket Admin")
(div :class "grid grid-cols-2 sm:grid-cols-4 gap-3 mb-8" stats) (div :class "grid grid-cols-2 sm:grid-cols-4 gap-3 mb-8" stats)
@@ -113,11 +113,11 @@
(tbody :class "divide-y divide-stone-100" rows)) (tbody :class "divide-y divide-stone-100" rows))
(div :class "px-6 py-8 text-center text-stone-500" "No tickets yet")))))) (div :class "px-6 py-8 text-center text-stone-500" "No tickets yet"))))))
(defcomp ~events-checkin-error (&key message) (defcomp ~events-checkin-error (&key (message :as string))
(div :class "rounded-lg border border-red-200 bg-red-50 p-3 text-sm text-red-800" (div :class "rounded-lg border border-red-200 bg-red-50 p-3 text-sm text-red-800"
(i :class "fa fa-exclamation-circle mr-2" :aria-hidden "true") message)) (i :class "fa fa-exclamation-circle mr-2" :aria-hidden "true") message))
(defcomp ~events-checkin-success-row (&key code code-short entry-name date type-name badge time-str) (defcomp ~events-checkin-success-row (&key (code :as string) (code-short :as string) (entry-name :as string) date (type-name :as string) badge (time-str :as string))
(tr :class "bg-blue-50" :id (str "ticket-row-" code) (tr :class "bg-blue-50" :id (str "ticket-row-" code)
(td :class "px-4 py-3" (span :class "font-mono text-xs" code-short)) (td :class "px-4 py-3" (span :class "font-mono text-xs" code-short))
(td :class "px-4 py-3" (div :class "font-medium" entry-name) date) (td :class "px-4 py-3" (div :class "font-medium" entry-name) date)
@@ -127,29 +127,29 @@
(span :class "text-xs text-blue-600" (span :class "text-xs text-blue-600"
(i :class "fa fa-check-circle" :aria-hidden "true") (str " " time-str))))) (i :class "fa fa-check-circle" :aria-hidden "true") (str " " time-str)))))
(defcomp ~events-lookup-error (&key message) (defcomp ~events-lookup-error (&key (message :as string))
(div :class "rounded-lg border border-red-200 bg-red-50 p-4 text-sm text-red-800" (div :class "rounded-lg border border-red-200 bg-red-50 p-4 text-sm text-red-800"
(i :class "fa fa-exclamation-circle mr-2" :aria-hidden "true") message)) (i :class "fa fa-exclamation-circle mr-2" :aria-hidden "true") message))
(defcomp ~events-lookup-info (&key entry-name) (defcomp ~events-lookup-info (&key (entry-name :as string))
(div :class "font-semibold text-lg" entry-name)) (div :class "font-semibold text-lg" entry-name))
(defcomp ~events-lookup-type (&key type-name) (defcomp ~events-lookup-type (&key (type-name :as string))
(div :class "text-sm text-stone-600" type-name)) (div :class "text-sm text-stone-600" type-name))
(defcomp ~events-lookup-date (&key date-str) (defcomp ~events-lookup-date (&key (date-str :as string))
(div :class "text-sm text-stone-500 mt-1" date-str)) (div :class "text-sm text-stone-500 mt-1" date-str))
(defcomp ~events-lookup-cal (&key cal-name) (defcomp ~events-lookup-cal (&key (cal-name :as string))
(div :class "text-xs text-stone-400 mt-0.5" cal-name)) (div :class "text-xs text-stone-400 mt-0.5" cal-name))
(defcomp ~events-lookup-status (&key badge code) (defcomp ~events-lookup-status (&key badge (code :as string))
(div :class "mt-2" badge (span :class "text-xs text-stone-400 ml-2 font-mono" code))) (div :class "mt-2" badge (span :class "text-xs text-stone-400 ml-2 font-mono" code)))
(defcomp ~events-lookup-checkin-time (&key date-str) (defcomp ~events-lookup-checkin-time (&key (date-str :as string))
(div :class "text-xs text-blue-600 mt-1" (str "Checked in: " date-str))) (div :class "text-xs text-blue-600 mt-1" (str "Checked in: " date-str)))
(defcomp ~events-lookup-checkin-btn (&key checkin-url code csrf) (defcomp ~events-lookup-checkin-btn (&key (checkin-url :as string) (code :as string) (csrf :as string))
(form :sx-post checkin-url :sx-target (str "#checkin-action-" code) :sx-swap "innerHTML" (form :sx-post checkin-url :sx-target (str "#checkin-action-" code) :sx-swap "innerHTML"
(input :type "hidden" :name "csrf_token" :value csrf) (input :type "hidden" :name "csrf_token" :value csrf)
(button :type "submit" (button :type "submit"
@@ -166,20 +166,20 @@
(i :class "fa fa-times-circle text-3xl" :aria-hidden "true") (i :class "fa fa-times-circle text-3xl" :aria-hidden "true")
(div :class "text-sm font-medium mt-1" "Cancelled"))) (div :class "text-sm font-medium mt-1" "Cancelled")))
(defcomp ~events-lookup-card (&key info code action) (defcomp ~events-lookup-card (&key info (code :as string) action)
(div :class "rounded-lg border border-stone-200 bg-stone-50 p-4" (div :class "rounded-lg border border-stone-200 bg-stone-50 p-4"
(div :class "flex items-start justify-between gap-4" (div :class "flex items-start justify-between gap-4"
(div :class "flex-1" info) (div :class "flex-1" info)
(div :id (str "checkin-action-" code) action)))) (div :id (str "checkin-action-" code) action))))
(defcomp ~events-entry-tickets-admin-row (&key code code-short type-name badge action) (defcomp ~events-entry-tickets-admin-row (&key (code :as string) (code-short :as string) (type-name :as string) badge action)
(tr :class "hover:bg-stone-50" :id (str "entry-ticket-row-" code) (tr :class "hover:bg-stone-50" :id (str "entry-ticket-row-" code)
(td :class "px-4 py-2 font-mono text-xs" code-short) (td :class "px-4 py-2 font-mono text-xs" code-short)
(td :class "px-4 py-2" type-name) (td :class "px-4 py-2" type-name)
(td :class "px-4 py-2" badge) (td :class "px-4 py-2" badge)
(td :class "px-4 py-2" action))) (td :class "px-4 py-2" action)))
(defcomp ~events-entry-tickets-admin-checkin (&key checkin-url code csrf) (defcomp ~events-entry-tickets-admin-checkin (&key (checkin-url :as string) (code :as string) (csrf :as string))
(form :sx-post checkin-url :sx-target (str "#entry-ticket-row-" code) :sx-swap "outerHTML" (form :sx-post checkin-url :sx-target (str "#entry-ticket-row-" code) :sx-swap "outerHTML"
(input :type "hidden" :name "csrf_token" :value csrf) (input :type "hidden" :name "csrf_token" :value csrf)
(button :type "submit" :class "px-3 py-1 bg-blue-600 text-white text-xs rounded hover:bg-blue-700" (button :type "submit" :class "px-3 py-1 bg-blue-600 text-white text-xs rounded hover:bg-blue-700"
@@ -198,7 +198,7 @@
(defcomp ~events-entry-tickets-admin-empty () (defcomp ~events-entry-tickets-admin-empty ()
(div :class "text-center py-6 text-stone-500 text-sm" "No tickets for this entry")) (div :class "text-center py-6 text-stone-500 text-sm" "No tickets for this entry"))
(defcomp ~events-entry-tickets-admin-panel (&key entry-name count-label body) (defcomp ~events-entry-tickets-admin-panel (&key (entry-name :as string) (count-label :as string) body)
(div :class "space-y-4" (div :class "space-y-4"
(div :class "flex items-center justify-between" (div :class "flex items-center justify-between"
(h3 :class "text-lg font-semibold" (str "Tickets for: " entry-name)) (h3 :class "text-lg font-semibold" (str "Tickets for: " entry-name))
@@ -211,7 +211,7 @@
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
;; My tickets panel from data ;; My tickets panel from data
(defcomp ~events-tickets-panel-from-data (&key list-container tickets) (defcomp ~events-tickets-panel-from-data (&key (list-container :as string) (tickets :as list?))
(~events-tickets-panel (~events-tickets-panel
:list-container list-container :list-container list-container
:has-tickets (not (empty? (or tickets (list)))) :has-tickets (not (empty? (or tickets (list))))
@@ -225,9 +225,9 @@
(or tickets (list)))))) (or tickets (list))))))
;; Ticket detail from data — uses lg badge variant ;; Ticket detail from data — uses lg badge variant
(defcomp ~events-ticket-detail-from-data (&key list-container back-href header-bg entry-name (defcomp ~events-ticket-detail-from-data (&key (list-container :as string) (back-href :as string) (header-bg :as string) (entry-name :as string)
state type-name code time-date time-range (state :as string) (type-name :as string?) (code :as string) (time-date :as string?) (time-range :as string?)
cal-name type-desc checkin-str qr-script) (cal-name :as string?) (type-desc :as string?) (checkin-str :as string?) (qr-script :as string))
(~events-ticket-detail (~events-ticket-detail
:list-container list-container :back-href back-href :list-container list-container :back-href back-href
:header-bg header-bg :entry-name entry-name :header-bg header-bg :entry-name entry-name
@@ -238,9 +238,9 @@
:checkin-str checkin-str :qr-script qr-script)) :checkin-str checkin-str :qr-script qr-script))
;; Ticket admin row from data — conditional action column ;; Ticket admin row from data — conditional action column
(defcomp ~events-ticket-admin-row-from-data (&key code code-short entry-name date-str (defcomp ~events-ticket-admin-row-from-data (&key (code :as string) (code-short :as string) (entry-name :as string) (date-str :as string?)
type-name state checkin-url csrf (type-name :as string) (state :as string) (checkin-url :as string) (csrf :as string)
checked-in-time) (checked-in-time :as string?))
(~events-ticket-admin-row (~events-ticket-admin-row
:code code :code-short code-short :code code :code-short code-short
:entry-name entry-name :entry-name entry-name
@@ -256,8 +256,8 @@
(true nil)))) (true nil))))
;; Ticket admin panel from data ;; Ticket admin panel from data
(defcomp ~events-ticket-admin-panel-from-data (&key list-container lookup-url tickets (defcomp ~events-ticket-admin-panel-from-data (&key (list-container :as string) (lookup-url :as string) (tickets :as list?)
total confirmed checked-in reserved) (total :as number?) (confirmed :as number?) (checked-in :as number?) (reserved :as number?))
(~events-ticket-admin-panel (~events-ticket-admin-panel
:list-container list-container :list-container list-container
:stats (<> :stats (<>
@@ -285,7 +285,7 @@
(or tickets (list)))))) (or tickets (list))))))
;; Entry tickets admin from data ;; Entry tickets admin from data
(defcomp ~events-entry-tickets-admin-from-data (&key entry-name count-label tickets csrf) (defcomp ~events-entry-tickets-admin-from-data (&key (entry-name :as string) (count-label :as string) (tickets :as list?) (csrf :as string))
(~events-entry-tickets-admin-panel (~events-entry-tickets-admin-panel
:entry-name entry-name :count-label count-label :entry-name entry-name :count-label count-label
:body (if (empty? (or tickets (list))) :body (if (empty? (or tickets (list)))
@@ -306,7 +306,7 @@
(or tickets (list)))))))) (or tickets (list))))))))
;; Checkin success row from data ;; Checkin success row from data
(defcomp ~events-checkin-success-row-from-data (&key code code-short entry-name date-str type-name time-str) (defcomp ~events-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))
(~events-checkin-success-row (~events-checkin-success-row
:code code :code-short code-short :code code :code-short code-short
:entry-name entry-name :entry-name entry-name
@@ -316,8 +316,8 @@
:time-str time-str)) :time-str time-str))
;; Ticket types table from data ;; Ticket types table from data
(defcomp ~events-ticket-types-table-from-data (&key list-container ticket-types action-btn add-url (defcomp ~events-ticket-types-table-from-data (&key (list-container :as string) (ticket-types :as list?) (action-btn :as string) (add-url :as string)
tr-cls pill-cls hx-select csrf-hdr) (tr-cls :as string) (pill-cls :as string) (hx-select :as string) (csrf-hdr :as string))
(~events-ticket-types-table (~events-ticket-types-table
:list-container list-container :list-container list-container
:rows (if (empty? (or ticket-types (list))) :rows (if (empty? (or ticket-types (list)))
@@ -333,9 +333,9 @@
:action-btn action-btn :add-url add-url)) :action-btn action-btn :add-url add-url))
;; Lookup result from data ;; Lookup result from data
(defcomp ~events-lookup-result-from-data (&key entry-name type-name date-str cal-name (defcomp ~events-lookup-result-from-data (&key (entry-name :as string) (type-name :as string?) (date-str :as string?) (cal-name :as string?)
state code checked-in-str (state :as string) (code :as string) (checked-in-str :as string?)
checkin-url csrf) (checkin-url :as string) (csrf :as string))
(~events-lookup-card (~events-lookup-card
:info (<> :info (<>
(~events-lookup-info :entry-name entry-name) (~events-lookup-info :entry-name entry-name)

View File

@@ -1,7 +1,7 @@
;; Auth components (choose username — federation-specific) ;; Auth components (choose username — federation-specific)
;; Login and check-email components are shared: see shared/sx/templates/auth.sx ;; Login and check-email components are shared: see shared/sx/templates/auth.sx
(defcomp ~federation-choose-username (&key domain error csrf username check-url) (defcomp ~federation-choose-username (&key (domain :as string) error (csrf :as string) (username :as string) (check-url :as string))
(div :class "py-8 max-w-md mx-auto" (div :class "py-8 max-w-md mx-auto"
(h1 :class "text-2xl font-bold mb-2" "Choose your username") (h1 :class "text-2xl font-bold mb-2" "Choose your username")
(p :class "text-stone-600 mb-6" "This will be your identity on the fediverse: " (p :class "text-stone-600 mb-6" "This will be your identity on the fediverse: "

View File

@@ -1,9 +1,9 @@
;; Notification components ;; Notification components
(defcomp ~federation-notification-preview (&key preview) (defcomp ~federation-notification-preview (&key (preview :as string))
(div :class "text-sm text-stone-500 mt-1 truncate" preview)) (div :class "text-sm text-stone-500 mt-1 truncate" preview))
(defcomp ~federation-notification-card (&key cls avatar from-name from-username from-domain action-text preview time) (defcomp ~federation-notification-card (&key (cls :as string) avatar (from-name :as string) (from-username :as string) (from-domain :as string) (action-text :as string) preview (time :as string))
(div :class cls (div :class cls
(div :class "flex items-start gap-3" (div :class "flex items-start gap-3"
avatar avatar
@@ -15,14 +15,14 @@
preview preview
(div :class "text-xs text-stone-400 mt-1" time))))) (div :class "text-xs text-stone-400 mt-1" time)))))
(defcomp ~federation-notifications-list (&key items) (defcomp ~federation-notifications-list (&key (items :as list))
(div :class "space-y-2" items)) (div :class "space-y-2" items))
(defcomp ~federation-notifications-page (&key notifs) (defcomp ~federation-notifications-page (&key notifs)
(h1 :class "text-2xl font-bold mb-6" "Notifications") notifs) (h1 :class "text-2xl font-bold mb-6" "Notifications") notifs)
;; Assembled notification card — replaces Python _notification_sx ;; Assembled notification card — replaces Python _notification_sx
(defcomp ~federation-notification-from-data (&key notif) (defcomp ~federation-notification-from-data (&key (notif :as dict))
(let* ((from-name (or (get notif "from_actor_name") "?")) (let* ((from-name (or (get notif "from_actor_name") "?"))
(from-username (or (get notif "from_actor_username") "")) (from-username (or (get notif "from_actor_username") ""))
(from-domain (or (get notif "from_actor_domain") "")) (from-domain (or (get notif "from_actor_domain") ""))
@@ -59,7 +59,7 @@
:time created))) :time created)))
;; Assembled notifications content — replaces Python _notifications_content_sx ;; Assembled notifications content — replaces Python _notifications_content_sx
(defcomp ~federation-notifications-content (&key notifications) (defcomp ~federation-notifications-content (&key (notifications :as list))
(~federation-notifications-page (~federation-notifications-page
:notifs (if (empty? notifications) :notifs (if (empty? notifications)
(~empty-state :message "No notifications yet." :cls "text-stone-500") (~empty-state :message "No notifications yet." :cls "text-stone-500")

View File

@@ -1,6 +1,6 @@
;; Profile and actor timeline components ;; Profile and actor timeline components
(defcomp ~federation-actor-profile-header (&key avatar display-name username domain summary follow) (defcomp ~federation-actor-profile-header (&key avatar (display-name :as string) (username :as string) (domain :as string) summary follow)
(div :class "bg-white rounded-lg shadow-sm border border-stone-200 p-6 mb-6" (div :class "bg-white rounded-lg shadow-sm border border-stone-200 p-6 mb-6"
(div :class "flex items-center gap-4" (div :class "flex items-center gap-4"
avatar avatar
@@ -14,35 +14,35 @@
header header
(div :id "timeline" timeline)) (div :id "timeline" timeline))
(defcomp ~federation-follow-form (&key action csrf actor-url label cls) (defcomp ~federation-follow-form (&key (action :as string) (csrf :as string) (actor-url :as string) (label :as string) (cls :as string))
(div :class "flex-shrink-0" (div :class "flex-shrink-0"
(form :method "post" :action action (form :method "post" :action action
(input :type "hidden" :name "csrf_token" :value csrf) (input :type "hidden" :name "csrf_token" :value csrf)
(input :type "hidden" :name "actor_url" :value actor-url) (input :type "hidden" :name "actor_url" :value actor-url)
(button :type "submit" :class cls label)))) (button :type "submit" :class cls label))))
(defcomp ~federation-profile-summary (&key summary) (defcomp ~federation-profile-summary (&key (summary :as string))
(div :class "text-sm text-stone-600 mt-2" (~rich-text :html summary))) (div :class "text-sm text-stone-600 mt-2" (~rich-text :html summary)))
;; Public profile page ;; Public profile page
(defcomp ~federation-activity-obj-type (&key obj-type) (defcomp ~federation-activity-obj-type (&key (obj-type :as string))
(span :class "text-sm text-stone-500" obj-type)) (span :class "text-sm text-stone-500" obj-type))
(defcomp ~federation-activity-card (&key activity-type published obj-type) (defcomp ~federation-activity-card (&key (activity-type :as string) (published :as string) obj-type)
(div :class "bg-white rounded-lg shadow p-4" (div :class "bg-white rounded-lg shadow p-4"
(div :class "flex justify-between items-start" (div :class "flex justify-between items-start"
(span :class "font-medium" activity-type) (span :class "font-medium" activity-type)
(span :class "text-sm text-stone-400" published)) (span :class "text-sm text-stone-400" published))
obj-type)) obj-type))
(defcomp ~federation-activities-list (&key items) (defcomp ~federation-activities-list (&key (items :as list))
(div :class "space-y-4" items)) (div :class "space-y-4" items))
(defcomp ~federation-activities-empty () (defcomp ~federation-activities-empty ()
(p :class "text-stone-500" "No activities yet.")) (p :class "text-stone-500" "No activities yet."))
(defcomp ~federation-profile-page (&key display-name username domain summary activities-heading activities) (defcomp ~federation-profile-page (&key (display-name :as string) (username :as string) (domain :as string) summary (activities-heading :as string) activities)
(div :class "py-8" (div :class "py-8"
(div :class "bg-white rounded-lg shadow p-6 mb-6" (div :class "bg-white rounded-lg shadow p-6 mb-6"
(h1 :class "text-2xl font-bold" display-name) (h1 :class "text-2xl font-bold" display-name)
@@ -51,11 +51,11 @@
(h2 :class "text-xl font-bold mb-4" activities-heading) (h2 :class "text-xl font-bold mb-4" activities-heading)
activities)) activities))
(defcomp ~federation-profile-summary-text (&key text) (defcomp ~federation-profile-summary-text (&key (text :as string))
(p :class "mt-2" text)) (p :class "mt-2" text))
;; Assembled actor timeline content — replaces Python _actor_timeline_content_sx ;; Assembled actor timeline content — replaces Python _actor_timeline_content_sx
(defcomp ~federation-actor-timeline-content (&key remote-actor items is-following actor) (defcomp ~federation-actor-timeline-content (&key (remote-actor :as dict) (items :as list) (is-following :as boolean) actor)
(let* ((display-name (or (get remote-actor "display_name") (get remote-actor "preferred_username") "")) (let* ((display-name (or (get remote-actor "display_name") (get remote-actor "preferred_username") ""))
(icon-url (get remote-actor "icon_url")) (icon-url (get remote-actor "icon_url"))
(summary (get remote-actor "summary")) (summary (get remote-actor "summary"))
@@ -92,7 +92,7 @@
:before (get (last items) "before_cursor"))))))) :before (get (last items) "before_cursor")))))))
;; Data-driven activities list (replaces Python loop in render_profile_page) ;; Data-driven activities list (replaces Python loop in render_profile_page)
(defcomp ~federation-activities-from-data (&key activities) (defcomp ~federation-activities-from-data (&key (activities :as list))
(if (empty? (or activities (list))) (if (empty? (or activities (list)))
(~federation-activities-empty) (~federation-activities-empty)
(~federation-activities-list (~federation-activities-list

View File

@@ -1,37 +1,37 @@
;; Search and actor card components ;; Search and actor card components
;; Aliases — delegate to shared ~avatar ;; Aliases — delegate to shared ~avatar
(defcomp ~federation-actor-avatar-img (&key src cls) (defcomp ~federation-actor-avatar-img (&key (src :as string) (cls :as string))
(~avatar :src src :cls cls)) (~avatar :src src :cls cls))
(defcomp ~federation-actor-avatar-placeholder (&key cls initial) (defcomp ~federation-actor-avatar-placeholder (&key (cls :as string) (initial :as string))
(~avatar :cls cls :initial initial)) (~avatar :cls cls :initial initial))
(defcomp ~federation-actor-name-link (&key href name) (defcomp ~federation-actor-name-link (&key (href :as string) (name :as string))
(a :href href :class "font-semibold text-stone-900 hover:underline" name)) (a :href href :class "font-semibold text-stone-900 hover:underline" name))
(defcomp ~federation-actor-name-link-external (&key href name) (defcomp ~federation-actor-name-link-external (&key (href :as string) (name :as string))
(a :href href :target "_blank" :rel "noopener" (a :href href :target "_blank" :rel "noopener"
:class "font-semibold text-stone-900 hover:underline" name)) :class "font-semibold text-stone-900 hover:underline" name))
(defcomp ~federation-actor-summary (&key summary) (defcomp ~federation-actor-summary (&key (summary :as string))
(div :class "text-sm text-stone-600 mt-1 truncate" (~rich-text :html summary))) (div :class "text-sm text-stone-600 mt-1 truncate" (~rich-text :html summary)))
(defcomp ~federation-unfollow-button (&key action csrf actor-url) (defcomp ~federation-unfollow-button (&key (action :as string) (csrf :as string) (actor-url :as string))
(div :class "flex-shrink-0" (div :class "flex-shrink-0"
(form :method "post" :action action :sx-post action :sx-target "closest article" :sx-swap "outerHTML" (form :method "post" :action action :sx-post action :sx-target "closest article" :sx-swap "outerHTML"
(input :type "hidden" :name "csrf_token" :value csrf) (input :type "hidden" :name "csrf_token" :value csrf)
(input :type "hidden" :name "actor_url" :value actor-url) (input :type "hidden" :name "actor_url" :value actor-url)
(button :type "submit" :class "text-sm border border-stone-300 rounded px-3 py-1 hover:bg-stone-100" "Unfollow")))) (button :type "submit" :class "text-sm border border-stone-300 rounded px-3 py-1 hover:bg-stone-100" "Unfollow"))))
(defcomp ~federation-follow-button (&key action csrf actor-url label) (defcomp ~federation-follow-button (&key (action :as string) (csrf :as string) (actor-url :as string) (label :as string))
(div :class "flex-shrink-0" (div :class "flex-shrink-0"
(form :method "post" :action action :sx-post action :sx-target "closest article" :sx-swap "outerHTML" (form :method "post" :action action :sx-post action :sx-target "closest article" :sx-swap "outerHTML"
(input :type "hidden" :name "csrf_token" :value csrf) (input :type "hidden" :name "csrf_token" :value csrf)
(input :type "hidden" :name "actor_url" :value actor-url) (input :type "hidden" :name "actor_url" :value actor-url)
(button :type "submit" :class "text-sm bg-stone-800 text-white rounded px-3 py-1 hover:bg-stone-700" label)))) (button :type "submit" :class "text-sm bg-stone-800 text-white rounded px-3 py-1 hover:bg-stone-700" label))))
(defcomp ~federation-actor-card (&key cls id avatar name username domain summary button) (defcomp ~federation-actor-card (&key (cls :as string) (id :as string) avatar name (username :as string) (domain :as string) summary button)
(article :class cls :id id (article :class cls :id id
avatar avatar
(div :class "flex-1 min-w-0" (div :class "flex-1 min-w-0"
@@ -41,7 +41,7 @@
button)) button))
;; Data-driven actor card (replaces Python _actor_card_sx loop) ;; Data-driven actor card (replaces Python _actor_card_sx loop)
(defcomp ~federation-actor-card-from-data (&key d has-actor csrf follow-url unfollow-url list-type) (defcomp ~federation-actor-card-from-data (&key (d :as dict) (has-actor :as boolean) (csrf :as string) (follow-url :as string) (unfollow-url :as string) (list-type :as string))
(let* ((icon-url (get d "icon_url")) (let* ((icon-url (get d "icon_url"))
(display-name (get d "display_name")) (display-name (get d "display_name"))
(username (get d "username")) (username (get d "username"))
@@ -72,8 +72,8 @@
:summary summary-sx :button button))) :summary summary-sx :button button)))
;; Data-driven actor list (replaces Python _search_results_sx / _actor_list_items_sx loops) ;; Data-driven actor list (replaces Python _search_results_sx / _actor_list_items_sx loops)
(defcomp ~federation-actor-list-from-data (&key actors next-url has-actor csrf (defcomp ~federation-actor-list-from-data (&key (actors :as list) (next-url :as string?) (has-actor :as boolean) (csrf :as string)
follow-url unfollow-url list-type) (follow-url :as string) (unfollow-url :as string) (list-type :as string))
(<> (<>
(map (lambda (d) (map (lambda (d)
(~federation-actor-card-from-data :d d :has-actor has-actor :csrf csrf (~federation-actor-card-from-data :d d :has-actor has-actor :csrf csrf
@@ -81,10 +81,10 @@
(or actors (list))) (or actors (list)))
(when next-url (~federation-scroll-sentinel :url next-url)))) (when next-url (~federation-scroll-sentinel :url next-url))))
(defcomp ~federation-search-info (&key cls text) (defcomp ~federation-search-info (&key (cls :as string) (text :as string))
(p :class cls text)) (p :class cls text))
(defcomp ~federation-search-page (&key search-url search-page-url query info results) (defcomp ~federation-search-page (&key (search-url :as string) (search-page-url :as string) (query :as string) info results)
(h1 :class "text-2xl font-bold mb-6" "Search") (h1 :class "text-2xl font-bold mb-6" "Search")
(form :method "get" :action search-url :class "mb-6" (form :method "get" :action search-url :class "mb-6"
:sx-get search-page-url :sx-target "#search-results" :sx-push-url search-url :sx-get search-page-url :sx-target "#search-results" :sx-push-url search-url
@@ -97,7 +97,7 @@
(div :id "search-results" results)) (div :id "search-results" results))
;; Following / Followers list page ;; Following / Followers list page
(defcomp ~federation-actor-list-page (&key title count-str items) (defcomp ~federation-actor-list-page (&key (title :as string) (count-str :as string) items)
(h1 :class "text-2xl font-bold mb-6" title " " (h1 :class "text-2xl font-bold mb-6" title " "
(span :class "text-stone-400 font-normal" count-str)) (span :class "text-stone-400 font-normal" count-str))
(div :id "actor-list" items)) (div :id "actor-list" items))
@@ -106,7 +106,7 @@
;; Assembled actor card — replaces Python _actor_card_sx ;; Assembled actor card — replaces Python _actor_card_sx
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~federation-actor-card-from-data (&key a actor followed-urls list-type) (defcomp ~federation-actor-card-from-data (&key (a :as dict) actor (followed-urls :as list) (list-type :as string))
(let* ((display-name (or (get a "display_name") (get a "preferred_username") "")) (let* ((display-name (or (get a "display_name") (get a "preferred_username") ""))
(username (or (get a "preferred_username") "")) (username (or (get a "preferred_username") ""))
(domain (or (get a "domain") "")) (domain (or (get a "domain") ""))
@@ -146,7 +146,7 @@
:label (if (= list-type "followers") "Follow Back" "Follow"))))))) :label (if (= list-type "followers") "Follow Back" "Follow")))))))
;; Assembled search content — replaces Python _search_content_sx ;; Assembled search content — replaces Python _search_content_sx
(defcomp ~federation-search-content (&key query actors total followed-urls actor) (defcomp ~federation-search-content (&key (query :as string?) (actors :as list) (total :as number) (followed-urls :as list) actor)
(~federation-search-page (~federation-search-page
:search-url (url-for "social.defpage_search") :search-url (url-for "social.defpage_search")
:search-page-url (url-for "social.search_page") :search-page-url (url-for "social.search_page")
@@ -172,7 +172,7 @@
:url (url-for "social.search_page" :q query :page 2))))))) :url (url-for "social.search_page" :q query :page 2)))))))
;; Assembled following/followers content — replaces Python _following_content_sx etc. ;; Assembled following/followers content — replaces Python _following_content_sx etc.
(defcomp ~federation-following-content (&key actors total actor) (defcomp ~federation-following-content (&key (actors :as list) (total :as number) actor)
(~federation-actor-list-page (~federation-actor-list-page
:title "Following" :count-str (str "(" total ")") :title "Following" :count-str (str "(" total ")")
:items (when (not (empty? actors)) :items (when (not (empty? actors))
@@ -185,7 +185,7 @@
(~federation-scroll-sentinel (~federation-scroll-sentinel
:url (url-for "social.following_list_page" :page 2))))))) :url (url-for "social.following_list_page" :page 2)))))))
(defcomp ~federation-followers-content (&key actors total followed-urls actor) (defcomp ~federation-followers-content (&key (actors :as list) (total :as number) (followed-urls :as list) actor)
(~federation-actor-list-page (~federation-actor-list-page
:title "Followers" :count-str (str "(" total ")") :title "Followers" :count-str (str "(" total ")")
:items (when (not (empty? actors)) :items (when (not (empty? actors))

View File

@@ -2,11 +2,11 @@
;; --- Navigation --- ;; --- Navigation ---
(defcomp ~federation-nav-choose-username (&key url) (defcomp ~federation-nav-choose-username (&key (url :as string))
(nav :class "flex gap-3 text-sm items-center" (nav :class "flex gap-3 text-sm items-center"
(a :href url :class "px-2 py-1 rounded hover:bg-stone-200 font-bold" "Choose username"))) (a :href url :class "px-2 py-1 rounded hover:bg-stone-200 font-bold" "Choose username")))
(defcomp ~federation-nav-notification-link (&key href cls count-url) (defcomp ~federation-nav-notification-link (&key (href :as string) (cls :as string) (count-url :as string))
(a :href href :class cls "Notifications" (a :href href :class cls "Notifications"
(span :sx-get count-url :sx-trigger "load, every 30s" :sx-swap "innerHTML" (span :sx-get count-url :sx-trigger "load, every 30s" :sx-swap "innerHTML"
:class "absolute -top-2 -right-3 text-xs bg-red-500 text-white rounded-full px-1 empty:hidden"))) :class "absolute -top-2 -right-3 text-xs bg-red-500 text-white rounded-full px-1 empty:hidden")))
@@ -20,28 +20,28 @@
;; --- Post card --- ;; --- Post card ---
(defcomp ~federation-boost-label (&key name) (defcomp ~federation-boost-label (&key (name :as string))
(div :class "text-sm text-stone-500 mb-2" "Boosted by " name)) (div :class "text-sm text-stone-500 mb-2" "Boosted by " name))
;; Aliases — delegate to shared ~avatar ;; Aliases — delegate to shared ~avatar
(defcomp ~federation-avatar-img (&key src cls) (defcomp ~federation-avatar-img (&key (src :as string) (cls :as string))
(~avatar :src src :cls cls)) (~avatar :src src :cls cls))
(defcomp ~federation-avatar-placeholder (&key cls initial) (defcomp ~federation-avatar-placeholder (&key (cls :as string) (initial :as string))
(~avatar :cls cls :initial initial)) (~avatar :cls cls :initial initial))
(defcomp ~federation-content (&key content summary) (defcomp ~federation-content (&key (content :as string) (summary :as string?))
(if summary (if summary
(details :class "mt-2" (details :class "mt-2"
(summary :class "text-stone-500 cursor-pointer" "CW: " (~rich-text :html summary)) (summary :class "text-stone-500 cursor-pointer" "CW: " (~rich-text :html summary))
(div :class "mt-2 prose prose-sm prose-stone max-w-none" (~rich-text :html content))) (div :class "mt-2 prose prose-sm prose-stone max-w-none" (~rich-text :html content)))
(div :class "mt-2 prose prose-sm prose-stone max-w-none" (~rich-text :html content)))) (div :class "mt-2 prose prose-sm prose-stone max-w-none" (~rich-text :html content))))
(defcomp ~federation-original-link (&key url) (defcomp ~federation-original-link (&key (url :as string))
(a :href url :target "_blank" :rel "noopener" (a :href url :target "_blank" :rel "noopener"
:class "text-sm text-stone-400 hover:underline mt-1 inline-block" "original")) :class "text-sm text-stone-400 hover:underline mt-1 inline-block" "original"))
(defcomp ~federation-post-card (&key boost avatar actor-name actor-username domain time content original interactions) (defcomp ~federation-post-card (&key boost avatar (actor-name :as string) (actor-username :as string) (domain :as string) (time :as string) content original interactions)
(article :class "bg-white rounded-lg shadow-sm border border-stone-200 p-4 mb-4" (article :class "bg-white rounded-lg shadow-sm border border-stone-200 p-4 mb-4"
boost boost
(div :class "flex items-start gap-3" (div :class "flex items-start gap-3"
@@ -55,17 +55,17 @@
;; --- Interaction buttons --- ;; --- Interaction buttons ---
(defcomp ~federation-reply-link (&key url) (defcomp ~federation-reply-link (&key (url :as string))
(a :href url :class "hover:text-stone-700" "Reply")) (a :href url :class "hover:text-stone-700" "Reply"))
(defcomp ~federation-like-form (&key action target oid ainbox csrf cls icon count) (defcomp ~federation-like-form (&key (action :as string) (target :as string) (oid :as string) (ainbox :as string) (csrf :as string) (cls :as string) (icon :as string) count)
(form :sx-post action :sx-target target :sx-swap "innerHTML" (form :sx-post action :sx-target target :sx-swap "innerHTML"
(input :type "hidden" :name "object_id" :value oid) (input :type "hidden" :name "object_id" :value oid)
(input :type "hidden" :name "author_inbox" :value ainbox) (input :type "hidden" :name "author_inbox" :value ainbox)
(input :type "hidden" :name "csrf_token" :value csrf) (input :type "hidden" :name "csrf_token" :value csrf)
(button :type "submit" :class cls (span icon) " " count))) (button :type "submit" :class cls (span icon) " " count)))
(defcomp ~federation-boost-form (&key action target oid ainbox csrf cls count) (defcomp ~federation-boost-form (&key (action :as string) (target :as string) (oid :as string) (ainbox :as string) (csrf :as string) (cls :as string) count)
(form :sx-post action :sx-target target :sx-swap "innerHTML" (form :sx-post action :sx-target target :sx-swap "innerHTML"
(input :type "hidden" :name "object_id" :value oid) (input :type "hidden" :name "object_id" :value oid)
(input :type "hidden" :name "author_inbox" :value ainbox) (input :type "hidden" :name "author_inbox" :value ainbox)
@@ -78,13 +78,13 @@
;; --- Timeline --- ;; --- Timeline ---
(defcomp ~federation-scroll-sentinel (&key url) (defcomp ~federation-scroll-sentinel (&key (url :as string))
(div :sx-get url :sx-trigger "revealed" :sx-swap "outerHTML")) (div :sx-get url :sx-trigger "revealed" :sx-swap "outerHTML"))
(defcomp ~federation-compose-button (&key url) (defcomp ~federation-compose-button (&key (url :as string))
(a :href url :class "bg-stone-800 text-white px-4 py-2 rounded hover:bg-stone-700" "Compose")) (a :href url :class "bg-stone-800 text-white px-4 py-2 rounded hover:bg-stone-700" "Compose"))
(defcomp ~federation-timeline-page (&key label compose timeline) (defcomp ~federation-timeline-page (&key (label :as string) compose timeline)
(div :class "flex items-center justify-between mb-6" (div :class "flex items-center justify-between mb-6"
(h1 :class "text-2xl font-bold" label " Timeline") (h1 :class "text-2xl font-bold" label " Timeline")
compose) compose)
@@ -92,9 +92,9 @@
;; --- Data-driven post card (replaces Python _post_card_sx loop) --- ;; --- Data-driven post card (replaces Python _post_card_sx loop) ---
(defcomp ~federation-post-card-from-data (&key d has-actor csrf (defcomp ~federation-post-card-from-data (&key (d :as dict) (has-actor :as boolean) (csrf :as string)
like-url unlike-url (like-url :as string) (unlike-url :as string)
boost-url unboost-url) (boost-url :as string) (unboost-url :as string))
(let* ((boosted-by (get d "boosted_by")) (let* ((boosted-by (get d "boosted_by"))
(actor-icon (get d "actor_icon")) (actor-icon (get d "actor_icon"))
(actor-name (get d "actor_name")) (actor-name (get d "actor_name"))
@@ -140,8 +140,8 @@
:interactions interactions))) :interactions interactions)))
;; Data-driven timeline items (replaces Python _timeline_items_sx loop) ;; Data-driven timeline items (replaces Python _timeline_items_sx loop)
(defcomp ~federation-timeline-items-from-data (&key items next-url has-actor csrf (defcomp ~federation-timeline-items-from-data (&key (items :as list) (next-url :as string?) (has-actor :as boolean) (csrf :as string)
like-url unlike-url boost-url unboost-url) (like-url :as string) (unlike-url :as string) (boost-url :as string) (unboost-url :as string))
(<> (<>
(map (lambda (d) (map (lambda (d)
(~federation-post-card-from-data :d d :has-actor has-actor :csrf csrf (~federation-post-card-from-data :d d :has-actor has-actor :csrf csrf
@@ -151,11 +151,11 @@
;; --- Compose --- ;; --- Compose ---
(defcomp ~federation-compose-reply (&key reply-to) (defcomp ~federation-compose-reply (&key (reply-to :as string))
(input :type "hidden" :name "in_reply_to" :value reply-to) (input :type "hidden" :name "in_reply_to" :value reply-to)
(div :class "text-sm text-stone-500" "Replying to " (span :class "font-mono" reply-to))) (div :class "text-sm text-stone-500" "Replying to " (span :class "font-mono" reply-to)))
(defcomp ~federation-compose-form (&key action csrf reply) (defcomp ~federation-compose-form (&key (action :as string) (csrf :as string) reply)
(h1 :class "text-2xl font-bold mb-6" "Compose") (h1 :class "text-2xl font-bold mb-6" "Compose")
(form :method "post" :action action :class "space-y-4" (form :method "post" :action action :class "space-y-4"
(input :type "hidden" :name "csrf_token" :value csrf) (input :type "hidden" :name "csrf_token" :value csrf)
@@ -208,7 +208,7 @@
;; Assembled post card — replaces Python _post_card_sx ;; Assembled post card — replaces Python _post_card_sx
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~federation-post-card-from-data (&key item actor) (defcomp ~federation-post-card-from-data (&key (item :as dict) actor)
(let* ((boosted-by (get item "boosted_by")) (let* ((boosted-by (get item "boosted_by"))
(actor-icon (get item "actor_icon")) (actor-icon (get item "actor_icon"))
(actor-name (or (get item "actor_name") "?")) (actor-name (or (get item "actor_name") "?"))
@@ -267,7 +267,7 @@
;; Assembled timeline items — replaces Python _timeline_items_sx ;; Assembled timeline items — replaces Python _timeline_items_sx
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~federation-timeline-items (&key items timeline-type actor next-url) (defcomp ~federation-timeline-items (&key (items :as list) (timeline-type :as string) actor (next-url :as string?))
(<> (<>
(map (lambda (item) (map (lambda (item)
(~federation-post-card-from-data :item item :actor actor)) (~federation-post-card-from-data :item item :actor actor))
@@ -276,7 +276,7 @@
(~federation-scroll-sentinel :url next-url)))) (~federation-scroll-sentinel :url next-url))))
;; Assembled timeline content — replaces Python _timeline_content_sx ;; Assembled timeline content — replaces Python _timeline_content_sx
(defcomp ~federation-timeline-content (&key items timeline-type actor) (defcomp ~federation-timeline-content (&key (items :as list) (timeline-type :as string) actor)
(let* ((label (if (= timeline-type "home") "Home" "Public"))) (let* ((label (if (= timeline-type "home") "Home" "Public")))
(~federation-timeline-page (~federation-timeline-page
:label label :label label
@@ -289,7 +289,7 @@
:before (get (last items) "before_cursor"))))))) :before (get (last items) "before_cursor")))))))
;; Assembled compose content — replaces Python _compose_content_sx ;; Assembled compose content — replaces Python _compose_content_sx
(defcomp ~federation-compose-content (&key reply-to) (defcomp ~federation-compose-content (&key (reply-to :as string?))
(~federation-compose-form (~federation-compose-form
:action (url-for "social.compose_submit") :action (url-for "social.compose_submit")
:csrf (csrf-token) :csrf (csrf-token)

View File

@@ -1,10 +1,10 @@
;; Market card components — pure data, no raw! HTML injection ;; Market card components — pure data, no raw! HTML injection
(defcomp ~market-label-overlay (&key src) (defcomp ~market-label-overlay (&key (src :as string))
(img :src src :alt "" (img :src src :alt ""
:class "pointer-events-none absolute inset-0 w-full h-full object-contain object-top")) :class "pointer-events-none absolute inset-0 w-full h-full object-contain object-top"))
(defcomp ~market-card-image (&key image labels brand brand-highlight) (defcomp ~market-card-image (&key (image :as string) (labels :as list?) (brand :as string) (brand-highlight :as string?))
(div :class "w-full aspect-square bg-stone-100 relative" (div :class "w-full aspect-square bg-stone-100 relative"
(figure :class "inline-block w-full h-full" (figure :class "inline-block w-full h-full"
(div :class "relative w-full h-full" (div :class "relative w-full h-full"
@@ -12,35 +12,35 @@
(when labels (map (lambda (src) (~market-label-overlay :src src)) labels))) (when labels (map (lambda (src) (~market-label-overlay :src src)) labels)))
(figcaption :class (str "mt-2 text-sm text-center" brand-highlight " text-stone-600") brand)))) (figcaption :class (str "mt-2 text-sm text-center" brand-highlight " text-stone-600") brand))))
(defcomp ~market-card-no-image (&key labels brand) (defcomp ~market-card-no-image (&key (labels :as list?) (brand :as string))
(div :class "w-full aspect-square bg-stone-100 relative" (div :class "w-full aspect-square bg-stone-100 relative"
(div :class "p-2 flex flex-col items-center justify-center gap-2 text-red-500 h-full relative" (div :class "p-2 flex flex-col items-center justify-center gap-2 text-red-500 h-full relative"
(div :class "text-stone-400 text-xs" "No image") (div :class "text-stone-400 text-xs" "No image")
(when labels (ul :class "flex flex-row gap-1" (map (lambda (l) (li l)) labels))) (when labels (ul :class "flex flex-row gap-1" (map (lambda (l) (li l)) labels)))
(div :class "text-stone-900 text-center line-clamp-3 break-words [overflow-wrap:anywhere]" brand)))) (div :class "text-stone-900 text-center line-clamp-3 break-words [overflow-wrap:anywhere]" brand))))
(defcomp ~market-card-sticker (&key src name ring-cls) (defcomp ~market-card-sticker (&key (src :as string) (name :as string) (ring-cls :as string?))
(img :src src :alt name :class (str "w-6 h-6" ring-cls))) (img :src src :alt name :class (str "w-6 h-6" ring-cls)))
(defcomp ~market-card-stickers (&key stickers) (defcomp ~market-card-stickers (&key (stickers :as list))
(div :class "flex flex-row justify-center gap-2 p-2" (div :class "flex flex-row justify-center gap-2 p-2"
(map (lambda (s) (~market-card-sticker :src (get s "src") :name (get s "name") :ring-cls (get s "ring-cls"))) stickers))) (map (lambda (s) (~market-card-sticker :src (get s "src") :name (get s "name") :ring-cls (get s "ring-cls"))) stickers)))
(defcomp ~market-card-highlight (&key pre mid post) (defcomp ~market-card-highlight (&key (pre :as string) (mid :as string) (post :as string))
(<> pre (mark mid) post)) (<> pre (mark mid) post))
;; Price — delegates to shared ~price ;; Price — delegates to shared ~price
(defcomp ~market-card-price (&key special-price regular-price) (defcomp ~market-card-price (&key (special-price :as string?) (regular-price :as string?))
(~price :special-price special-price :regular-price regular-price)) (~price :special-price special-price :regular-price regular-price))
;; Main product card — accepts pure data, composes sub-components ;; Main product card — accepts pure data, composes sub-components
(defcomp ~market-product-card (&key href hx-select (defcomp ~market-product-card (&key (href :as string) (hx-select :as string)
has-like liked slug csrf like-action (has-like :as boolean) (liked :as boolean?) (slug :as string) (csrf :as string) (like-action :as string?)
image labels brand brand-highlight (image :as string?) (labels :as list?) (brand :as string) (brand-highlight :as string?)
special-price regular-price (special-price :as string?) (regular-price :as string?)
cart-action quantity cart-href (cart-action :as string) (quantity :as number?) (cart-href :as string)
stickers (stickers :as list?)
title has-highlight search-pre search-mid search-post) (title :as string) (has-highlight :as boolean) (search-pre :as string?) (search-mid :as string?) (search-post :as string?))
(div :class "flex flex-col rounded-xl bg-white shadow hover:shadow-md transition overflow-hidden relative" (div :class "flex flex-col rounded-xl bg-white shadow hover:shadow-md transition overflow-hidden relative"
(when has-like (when has-like
(~market-like-button :form-id (str "like-" slug) :action like-action :slug slug :csrf csrf (~market-like-button :form-id (str "like-" slug) :action like-action :slug slug :csrf csrf
@@ -65,7 +65,7 @@
(~market-card-highlight :pre search-pre :mid search-mid :post search-post) (~market-card-highlight :pre search-pre :mid search-mid :post search-post)
title))))) title)))))
(defcomp ~market-like-button (&key form-id action slug csrf icon-cls) (defcomp ~market-like-button (&key (form-id :as string) (action :as string) (slug :as string) (csrf :as string) (icon-cls :as string))
(div :class "absolute top-2 right-2 z-10 text-6xl md:text-xl" (div :class "absolute top-2 right-2 z-10 text-6xl md:text-xl"
(form :id form-id :action action :method "post" (form :id form-id :action action :method "post"
:sx-post action :sx-target (str "#like-" slug) :sx-swap "outerHTML" :sx-post action :sx-target (str "#like-" slug) :sx-swap "outerHTML"
@@ -73,22 +73,22 @@
(button :type "submit" :class "cursor-pointer" (button :type "submit" :class "cursor-pointer"
(i :class icon-cls :aria-hidden "true"))))) (i :class icon-cls :aria-hidden "true")))))
(defcomp ~market-market-card-title-link (&key href name) (defcomp ~market-market-card-title-link (&key (href :as string) (name :as string))
(a :href href :class "hover:text-emerald-700" (a :href href :class "hover:text-emerald-700"
(h2 :class "text-lg font-semibold text-stone-900" name))) (h2 :class "text-lg font-semibold text-stone-900" name)))
(defcomp ~market-market-card-title (&key name) (defcomp ~market-market-card-title (&key (name :as string))
(h2 :class "text-lg font-semibold text-stone-900" name)) (h2 :class "text-lg font-semibold text-stone-900" name))
(defcomp ~market-market-card-desc (&key description) (defcomp ~market-market-card-desc (&key (description :as string))
(p :class "text-sm text-stone-600 mt-1 line-clamp-2" description)) (p :class "text-sm text-stone-600 mt-1 line-clamp-2" description))
(defcomp ~market-market-card-badge (&key href title) (defcomp ~market-market-card-badge (&key (href :as string) (title :as string))
(div :class "flex flex-wrap items-center gap-1.5 mt-3" (div :class "flex flex-wrap items-center gap-1.5 mt-3"
(a :href href :class "inline-block px-2 py-0.5 rounded-full text-xs font-medium bg-amber-100 text-amber-800 hover:bg-amber-200" (a :href href :class "inline-block px-2 py-0.5 rounded-full text-xs font-medium bg-amber-100 text-amber-800 hover:bg-amber-200"
title))) title)))
(defcomp ~market-market-card (&key title-content desc-content badge-content title desc badge) (defcomp ~market-market-card (&key (title-content :as list?) (desc-content :as list?) (badge-content :as list?) (title :as string?) (desc :as string?) (badge :as string?))
(article :class "rounded-xl bg-white shadow-sm border border-stone-200 p-5 flex flex-col justify-between hover:border-stone-400 transition-colors" (article :class "rounded-xl bg-white shadow-sm border border-stone-200 p-5 flex flex-col justify-between hover:border-stone-400 transition-colors"
(div (div
(if title-content title-content (when title title)) (if title-content title-content (when title title))
@@ -101,8 +101,8 @@
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
;; Product cards grid with infinite scroll sentinels ;; Product cards grid with infinite scroll sentinels
(defcomp ~market-product-cards-content (&key products page total-pages next-url (defcomp ~market-product-cards-content (&key (products :as list) (page :as number) (total-pages :as number) (next-url :as string)
mobile-sentinel-hs desktop-sentinel-hs) (mobile-sentinel-hs :as string?) (desktop-sentinel-hs :as string?))
(<> (<>
(map (lambda (p) (map (lambda (p)
(~market-product-card (~market-product-card
@@ -126,7 +126,7 @@
(~end-of-results)))) (~end-of-results))))
;; Single market card from data (handles conditional title/desc/badge) ;; Single market card from data (handles conditional title/desc/badge)
(defcomp ~market-card-from-data (&key name description href show-badge badge-href badge-title) (defcomp ~market-card-from-data (&key (name :as string) (description :as string?) (href :as string?) (show-badge :as boolean) (badge-href :as string?) (badge-title :as string?))
(~market-market-card (~market-market-card
:title-content (if href :title-content (if href
(~market-market-card-title-link :href href :name name) (~market-market-card-title-link :href href :name name)
@@ -137,7 +137,7 @@
(~market-market-card-badge :href badge-href :title badge-title)))) (~market-market-card-badge :href badge-href :title badge-title))))
;; Market cards list with infinite scroll sentinel ;; Market cards list with infinite scroll sentinel
(defcomp ~market-cards-content (&key markets page has-more next-url) (defcomp ~market-cards-content (&key (markets :as list) (page :as number) (has-more :as boolean) (next-url :as string))
(<> (<>
(map (lambda (m) (map (lambda (m)
(~market-card-from-data (~market-card-from-data
@@ -149,7 +149,7 @@
(~sentinel-simple :id (str "sentinel-" page) :next-url next-url)))) (~sentinel-simple :id (str "sentinel-" page) :next-url next-url))))
;; Market landing page content from data ;; Market landing page content from data
(defcomp ~market-landing-from-data (&key excerpt feature-image html) (defcomp ~market-landing-from-data (&key (excerpt :as string?) (feature-image :as string?) (html :as string?))
(~market-landing-content :inner (~market-landing-content :inner
(<> (when excerpt (~market-landing-excerpt :text excerpt)) (<> (when excerpt (~market-landing-excerpt :text excerpt))
(when feature-image (~market-landing-image :src feature-image)) (when feature-image (~market-landing-image :src feature-image))

View File

@@ -1,6 +1,6 @@
;; Market product detail components ;; Market product detail components
(defcomp ~market-detail-gallery-inner (&key like image alt labels brand) (defcomp ~market-detail-gallery-inner (&key (like :as list?) (image :as string) (alt :as string) (labels :as list?) (brand :as string))
(<> like (<> like
(figure :class "inline-block" (figure :class "inline-block"
(div :class "relative w-full aspect-square" (div :class "relative w-full aspect-square"
@@ -18,79 +18,79 @@
:class "absolute right-2 top-1/2 -translate-y-1/2 z-10 grid place-items-center w-12 h-12 md:w-14 md:h-14 rounded-full bg-white/90 hover:bg-white shadow-lg text-3xl md:text-4xl" :class "absolute right-2 top-1/2 -translate-y-1/2 z-10 grid place-items-center w-12 h-12 md:w-14 md:h-14 rounded-full bg-white/90 hover:bg-white shadow-lg text-3xl md:text-4xl"
:title "Next" "\u203a"))) :title "Next" "\u203a")))
(defcomp ~market-detail-gallery (&key inner nav) (defcomp ~market-detail-gallery (&key (inner :as list) (nav :as list?))
(div :class "relative rounded-xl overflow-hidden bg-stone-100" (div :class "relative rounded-xl overflow-hidden bg-stone-100"
inner nav)) inner nav))
(defcomp ~market-detail-thumb (&key title src alt) (defcomp ~market-detail-thumb (&key (title :as string) (src :as string) (alt :as string))
(<> (button :type "button" :data-thumb "" (<> (button :type "button" :data-thumb ""
:class "shrink-0 rounded-lg overflow-hidden bg-stone-100 hover:opacity-90 ring-offset-2" :class "shrink-0 rounded-lg overflow-hidden bg-stone-100 hover:opacity-90 ring-offset-2"
:title title :title title
(img :src src :class "h-16 w-16 object-contain" :alt alt :loading "lazy" :decoding "async")) (img :src src :class "h-16 w-16 object-contain" :alt alt :loading "lazy" :decoding "async"))
(span :data-image-src src :class "hidden"))) (span :data-image-src src :class "hidden")))
(defcomp ~market-detail-thumbs (&key thumbs) (defcomp ~market-detail-thumbs (&key (thumbs :as list))
(div :class "flex flex-row justify-center" (div :class "flex flex-row justify-center"
(div :class "mt-3 flex gap-2 overflow-x-auto no-scrollbar" thumbs))) (div :class "mt-3 flex gap-2 overflow-x-auto no-scrollbar" thumbs)))
(defcomp ~market-detail-no-image (&key like) (defcomp ~market-detail-no-image (&key (like :as list?))
(div :class "relative aspect-square bg-stone-100 rounded-xl flex items-center justify-center text-stone-400" (div :class "relative aspect-square bg-stone-100 rounded-xl flex items-center justify-center text-stone-400"
like "No image")) like "No image"))
(defcomp ~market-detail-sticker (&key src name) (defcomp ~market-detail-sticker (&key (src :as string) (name :as string))
(img :src src :alt name :class "w-10 h-10")) (img :src src :alt name :class "w-10 h-10"))
(defcomp ~market-detail-stickers (&key items) (defcomp ~market-detail-stickers (&key (items :as list))
(div :class "p-2 flex flex-row justify-center gap-2" items)) (div :class "p-2 flex flex-row justify-center gap-2" items))
(defcomp ~market-detail-unit-price (&key price) (defcomp ~market-detail-unit-price (&key (price :as string))
(div (str "Unit price: " price))) (div (str "Unit price: " price)))
(defcomp ~market-detail-case-size (&key size) (defcomp ~market-detail-case-size (&key (size :as string))
(div (str "Case size: " size))) (div (str "Case size: " size)))
(defcomp ~market-detail-extras (&key inner) (defcomp ~market-detail-extras (&key (inner :as list))
(div :class "mt-2 space-y-1 text-sm text-stone-600" inner)) (div :class "mt-2 space-y-1 text-sm text-stone-600" inner))
(defcomp ~market-detail-desc-short (&key text) (defcomp ~market-detail-desc-short (&key (text :as string))
(p :class "leading-relaxed text-lg" text)) (p :class "leading-relaxed text-lg" text))
(defcomp ~market-detail-desc-html (&key html) (defcomp ~market-detail-desc-html (&key (html :as string))
(div :class "max-w-none text-sm leading-relaxed" (~rich-text :html html))) (div :class "max-w-none text-sm leading-relaxed" (~rich-text :html html)))
(defcomp ~market-detail-desc-wrapper (&key inner) (defcomp ~market-detail-desc-wrapper (&key (inner :as list))
(div :class "mt-4 text-stone-800 space-y-3" inner)) (div :class "mt-4 text-stone-800 space-y-3" inner))
(defcomp ~market-detail-section (&key title html) (defcomp ~market-detail-section (&key (title :as string) (html :as string))
(details :class "group rounded-xl border bg-white shadow-sm open:shadow p-0" (details :class "group rounded-xl border bg-white shadow-sm open:shadow p-0"
(summary :class "cursor-pointer select-none px-4 py-3 flex items-center justify-between" (summary :class "cursor-pointer select-none px-4 py-3 flex items-center justify-between"
(span :class "font-medium" title) (span :class "font-medium" title)
(span :class "ml-2 text-xl transition-transform group-open:rotate-180" "\u2304")) (span :class "ml-2 text-xl transition-transform group-open:rotate-180" "\u2304"))
(div :class "px-4 pb-4 max-w-none text-sm leading-relaxed" (~rich-text :html html)))) (div :class "px-4 pb-4 max-w-none text-sm leading-relaxed" (~rich-text :html html))))
(defcomp ~market-detail-sections (&key items) (defcomp ~market-detail-sections (&key (items :as list))
(div :class "mt-8 space-y-3" items)) (div :class "mt-8 space-y-3" items))
(defcomp ~market-detail-right-col (&key inner) (defcomp ~market-detail-right-col (&key (inner :as list))
(div :class "md:col-span-3" inner)) (div :class "md:col-span-3" inner))
(defcomp ~market-detail-layout (&key gallery stickers details) (defcomp ~market-detail-layout (&key (gallery :as list) (stickers :as list?) (details :as list))
(<> (div :class "mt-3 grid grid-cols-1 md:grid-cols-5 gap-6" :data-gallery-root "" (<> (div :class "mt-3 grid grid-cols-1 md:grid-cols-5 gap-6" :data-gallery-root ""
(div :class "md:col-span-2" gallery stickers) (div :class "md:col-span-2" gallery stickers)
details) details)
(div :class "pb-8"))) (div :class "pb-8")))
(defcomp ~market-landing-excerpt (&key text) (defcomp ~market-landing-excerpt (&key (text :as string))
(div :class "w-full text-center italic text-3xl p-2" text)) (div :class "w-full text-center italic text-3xl p-2" text))
(defcomp ~market-landing-image (&key src) (defcomp ~market-landing-image (&key (src :as string))
(div :class "mb-3 flex justify-center" (div :class "mb-3 flex justify-center"
(img :src src :alt "" :class "rounded-lg w-full md:w-3/4 object-cover"))) (img :src src :alt "" :class "rounded-lg w-full md:w-3/4 object-cover")))
(defcomp ~market-landing-html (&key html) (defcomp ~market-landing-html (&key (html :as string))
(div :class "blog-content p-2" (~rich-text :html html))) (div :class "blog-content p-2" (~rich-text :html html)))
(defcomp ~market-landing-content (&key inner) (defcomp ~market-landing-content (&key (inner :as list))
(<> (article :class "relative w-full" inner) (div :class "pb-8"))) (<> (article :class "relative w-full" inner) (div :class "pb-8")))
@@ -99,7 +99,7 @@
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
;; Gallery section from pre-computed data ;; Gallery section from pre-computed data
(defcomp ~market-detail-gallery-from-data (&key images labels brand like-data has-nav-buttons thumbs) (defcomp ~market-detail-gallery-from-data (&key (images :as list?) (labels :as list?) (brand :as string) (like-data :as dict?) (has-nav-buttons :as boolean) (thumbs :as list?))
(let ((like-sx (when like-data (let ((like-sx (when like-data
(~market-like-button (~market-like-button
:form-id (get like-data "form-id") :action (get like-data "action") :form-id (get like-data "form-id") :action (get like-data "action")
@@ -124,7 +124,7 @@
(~market-detail-no-image :like like-sx)))) (~market-detail-no-image :like like-sx))))
;; Right column details from data ;; Right column details from data
(defcomp ~market-detail-info-from-data (&key extras desc-short desc-html sections) (defcomp ~market-detail-info-from-data (&key (extras :as list?) (desc-short :as string?) (desc-html :as string?) (sections :as list?))
(~market-detail-right-col :inner (~market-detail-right-col :inner
(<> (<>
(when extras (when extras
@@ -145,9 +145,9 @@
sections))))))) sections)))))))
;; Full product detail layout from data ;; Full product detail layout from data
(defcomp ~market-product-detail-from-data (&key images labels brand like-data (defcomp ~market-product-detail-from-data (&key (images :as list?) (labels :as list?) (brand :as string) (like-data :as dict?)
has-nav-buttons thumbs sticker-items (has-nav-buttons :as boolean) (thumbs :as list?) (sticker-items :as list?)
extras desc-short desc-html sections) (extras :as list?) (desc-short :as string?) (desc-html :as string?) (sections :as list?))
(~market-detail-layout (~market-detail-layout
:gallery (~market-detail-gallery-from-data :gallery (~market-detail-gallery-from-data
:images images :labels labels :brand brand :like-data like-data :images images :labels labels :brand brand :like-data like-data

View File

@@ -1,21 +1,21 @@
;; Market meta/SEO components ;; Market meta/SEO components
(defcomp ~market-meta-title (&key title) (defcomp ~market-meta-title (&key (title :as string))
(title title)) (title title))
(defcomp ~market-meta-description (&key description) (defcomp ~market-meta-description (&key (description :as string))
(meta :name "description" :content description)) (meta :name "description" :content description))
(defcomp ~market-meta-canonical (&key href) (defcomp ~market-meta-canonical (&key (href :as string))
(link :rel "canonical" :href href)) (link :rel "canonical" :href href))
(defcomp ~market-meta-og (&key property content) (defcomp ~market-meta-og (&key (property :as string) (content :as string))
(meta :property property :content content)) (meta :property property :content content))
(defcomp ~market-meta-twitter (&key name content) (defcomp ~market-meta-twitter (&key (name :as string) (content :as string))
(meta :name name :content content)) (meta :name name :content content))
(defcomp ~market-meta-jsonld (&key json) (defcomp ~market-meta-jsonld (&key (json :as string))
(script :type "application/ld+json" (~rich-text :html json))) (script :type "application/ld+json" (~rich-text :html json)))
@@ -23,9 +23,10 @@
;; Composition: all product meta tags from data ;; Composition: all product meta tags from data
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~market-product-meta-from-data (&key title description canonical image-url (defcomp ~market-product-meta-from-data (&key (title :as string) (description :as string) (canonical :as string?)
site-title brand price price-currency (image-url :as string?)
jsonld-json) (site-title :as string) (brand :as string?) (price :as string?) (price-currency :as string?)
(jsonld-json :as string))
(<> (<>
(~market-meta-title :title title) (~market-meta-title :title title)
(~market-meta-description :description description) (~market-meta-description :description description)

View File

@@ -1,6 +1,6 @@
;; Market navigation components ;; Market navigation components
(defcomp ~market-category-link (&key href hx-select active select-colours label) (defcomp ~market-category-link (&key (href :as string) (hx-select :as string) (active :as boolean) (select-colours :as string) (label :as string))
(div :class "relative nav-group" (div :class "relative nav-group"
(a :href href :sx-get href :sx-target "#main-panel" (a :href href :sx-get href :sx-target "#main-panel"
:sx-select hx-select :sx-swap "outerHTML" :sx-push-url "true" :sx-select hx-select :sx-swap "outerHTML" :sx-push-url "true"
@@ -8,14 +8,14 @@
:class (str "block px-2 py-1 rounded text-center whitespace-normal break-words leading-snug bg-stone-200 text-black " select-colours) :class (str "block px-2 py-1 rounded text-center whitespace-normal break-words leading-snug bg-stone-200 text-black " select-colours)
label))) label)))
(defcomp ~market-desktop-category-nav (&key links admin) (defcomp ~market-desktop-category-nav (&key (links :as list) (admin :as list?))
(nav :class "hidden md:flex gap-4 text-sm ml-2 w-full justify-end items-center" (nav :class "hidden md:flex gap-4 text-sm ml-2 w-full justify-end items-center"
links admin)) links admin))
(defcomp ~market-mobile-nav-wrapper (&key items) (defcomp ~market-mobile-nav-wrapper (&key (items :as list))
(div :class "px-4 py-2" (div :class "divide-y" items))) (div :class "px-4 py-2" (div :class "divide-y" items)))
(defcomp ~market-mobile-all-link (&key href hx-select active select-colours) (defcomp ~market-mobile-all-link (&key (href :as string) (hx-select :as string) (active :as boolean) (select-colours :as string))
(a :role "option" :href href :sx-get href :sx-target "#main-panel" (a :role "option" :href href :sx-get href :sx-target "#main-panel"
:sx-select hx-select :sx-swap "outerHTML" :sx-push-url "true" :sx-select hx-select :sx-swap "outerHTML" :sx-push-url "true"
:aria-selected (if active "true" "false") :aria-selected (if active "true" "false")
@@ -28,7 +28,7 @@
(path :fill-rule "evenodd" :clip-rule "evenodd" (path :fill-rule "evenodd" :clip-rule "evenodd"
:d "M5.293 7.293a1 1 0 011.414 0L10 10.586l3.293-3.293a1 1 0 111.414 1.414l-4 4a1 1 0 01-1.414 0l-4-4a1 1 0 010-1.414z"))) :d "M5.293 7.293a1 1 0 011.414 0L10 10.586l3.293-3.293a1 1 0 111.414 1.414l-4 4a1 1 0 01-1.414 0l-4-4a1 1 0 010-1.414z")))
(defcomp ~market-mobile-cat-summary (&key bg-cls href hx-select select-colours cat-name count-label count-str chevron) (defcomp ~market-mobile-cat-summary (&key (bg-cls :as string) (href :as string) (hx-select :as string) (select-colours :as string) (cat-name :as string) (count-label :as string) (count-str :as string) (chevron :as list))
(summary :class (str "flex items-center justify-between cursor-pointer select-none block rounded-lg px-3 py-3 text-base hover:bg-stone-50" bg-cls) (summary :class (str "flex items-center justify-between cursor-pointer select-none block rounded-lg px-3 py-3 text-base hover:bg-stone-50" bg-cls)
(a :href href :sx-get href :sx-target "#main-panel" (a :href href :sx-get href :sx-target "#main-panel"
:sx-select hx-select :sx-swap "outerHTML" :sx-push-url "true" :sx-select hx-select :sx-swap "outerHTML" :sx-push-url "true"
@@ -37,7 +37,7 @@
(div :aria-label count-label count-str)) (div :aria-label count-label count-str))
chevron)) chevron))
(defcomp ~market-mobile-sub-link (&key select-colours active href hx-select label count-label count-str) (defcomp ~market-mobile-sub-link (&key (select-colours :as string) (active :as boolean) (href :as string) (hx-select :as string) (label :as string) (count-label :as string) (count-str :as string))
(a :class (str "snap-start px-2 py-3 rounded " select-colours " flex flex-row gap-2") (a :class (str "snap-start px-2 py-3 rounded " select-colours " flex flex-row gap-2")
:aria-selected (if active "true" "false") :aria-selected (if active "true" "false")
:href href :sx-get href :sx-target "#main-panel" :href href :sx-get href :sx-target "#main-panel"
@@ -45,20 +45,20 @@
(div label) (div label)
(div :aria-label count-label count-str))) (div :aria-label count-label count-str)))
(defcomp ~market-mobile-subs-panel (&key links) (defcomp ~market-mobile-subs-panel (&key (links :as list))
(div :class "pb-3 pl-2" (div :class "pb-3 pl-2"
(div :data-peek-viewport "" :data-peek-size-px "18" :data-peek-edge "bottom" :data-peek-mask "true" :class "m-2 bg-stone-100" (div :data-peek-viewport "" :data-peek-size-px "18" :data-peek-edge "bottom" :data-peek-mask "true" :class "m-2 bg-stone-100"
(div :data-peek-inner "" :class "grid grid-cols-1 gap-1 snap-y snap-mandatory pr-1" :aria-label "Subcategories" (div :data-peek-inner "" :class "grid grid-cols-1 gap-1 snap-y snap-mandatory pr-1" :aria-label "Subcategories"
links)))) links))))
(defcomp ~market-mobile-view-all (&key href hx-select) (defcomp ~market-mobile-view-all (&key (href :as string) (hx-select :as string))
(div :class "pb-3 pl-2" (div :class "pb-3 pl-2"
(a :class "px-2 py-1 rounded hover:bg-stone-100 block" (a :class "px-2 py-1 rounded hover:bg-stone-100 block"
:href href :sx-get href :sx-target "#main-panel" :href href :sx-get href :sx-target "#main-panel"
:sx-select hx-select :sx-swap "outerHTML" :sx-push-url "true" :sx-select hx-select :sx-swap "outerHTML" :sx-push-url "true"
"View all"))) "View all")))
(defcomp ~market-mobile-cat-details (&key open summary subs) (defcomp ~market-mobile-cat-details (&key (open :as boolean) (summary :as list) (subs :as list))
(details :class "group/cat py-1" :open open (details :class "group/cat py-1" :open open
summary subs)) summary subs))
@@ -67,7 +67,7 @@
;; Composition: mobile nav panel from pre-computed category data ;; Composition: mobile nav panel from pre-computed category data
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~market-mobile-nav-from-data (&key categories all-href all-active hx-select select-colours) (defcomp ~market-mobile-nav-from-data (&key (categories :as list) (all-href :as string) (all-active :as boolean) (hx-select :as string) (select-colours :as string))
(~market-mobile-nav-wrapper :items (~market-mobile-nav-wrapper :items
(<> (<>
(~market-mobile-all-link :href all-href :hx-select hx-select (~market-mobile-all-link :href all-href :hx-select hx-select

View File

@@ -1,36 +1,36 @@
;; Market price display components ;; Market price display components
(defcomp ~market-price-special (&key price) (defcomp ~market-price-special (&key (price :as string))
(div :class "text-lg font-semibold text-emerald-700" price)) (div :class "text-lg font-semibold text-emerald-700" price))
(defcomp ~market-price-regular-strike (&key price) (defcomp ~market-price-regular-strike (&key (price :as string))
(div :class "text-sm line-through text-stone-500" price)) (div :class "text-sm line-through text-stone-500" price))
(defcomp ~market-price-regular (&key price) (defcomp ~market-price-regular (&key (price :as string))
(div :class "mt-1 text-lg font-semibold" price)) (div :class "mt-1 text-lg font-semibold" price))
(defcomp ~market-price-line (&key inner) (defcomp ~market-price-line (&key (inner :as list))
(div :class "mt-1 flex items-baseline gap-2 justify-center" inner)) (div :class "mt-1 flex items-baseline gap-2 justify-center" inner))
(defcomp ~market-header-price-special-label () (defcomp ~market-header-price-special-label ()
(div :class "text-md font-bold text-emerald-700" "Special price")) (div :class "text-md font-bold text-emerald-700" "Special price"))
(defcomp ~market-header-price-special (&key price) (defcomp ~market-header-price-special (&key (price :as string))
(div :class "text-xl font-semibold text-emerald-700" price)) (div :class "text-xl font-semibold text-emerald-700" price))
(defcomp ~market-header-price-strike (&key price) (defcomp ~market-header-price-strike (&key (price :as string))
(div :class "text-base text-md line-through text-stone-500" price)) (div :class "text-base text-md line-through text-stone-500" price))
(defcomp ~market-header-price-regular-label () (defcomp ~market-header-price-regular-label ()
(div :class "hidden md:block text-xl font-bold" "Our price")) (div :class "hidden md:block text-xl font-bold" "Our price"))
(defcomp ~market-header-price-regular (&key price) (defcomp ~market-header-price-regular (&key (price :as string))
(div :class "text-xl font-semibold" price)) (div :class "text-xl font-semibold" price))
(defcomp ~market-header-rrp (&key rrp) (defcomp ~market-header-rrp (&key (rrp :as string))
(div :class "text-base text-stone-400" (span "rrp:") " " (span rrp))) (div :class "text-base text-stone-400" (span "rrp:") " " (span rrp)))
(defcomp ~market-prices-row (&key inner) (defcomp ~market-prices-row (&key (inner :as list))
(div :class "flex flex-row items-center justify-between md:gap-2 md:px-2" inner)) (div :class "flex flex-row items-center justify-between md:gap-2 md:px-2" inner))
@@ -38,8 +38,9 @@
;; Composition: prices header + cart button from data ;; Composition: prices header + cart button from data
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~market-prices-header-from-data (&key cart-id cart-action csrf quantity cart-href (defcomp ~market-prices-header-from-data (&key (cart-id :as string) (cart-action :as string) (csrf :as string) (quantity :as number?)
sp-val sp-str rp-val rp-str rrp-str) (cart-href :as string)
(sp-val :as number?) (sp-str :as string?) (rp-val :as number?) (rp-str :as string?) (rrp-str :as string?))
(~market-prices-row :inner (~market-prices-row :inner
(<> (<>
(if quantity (if quantity
@@ -57,7 +58,7 @@
(when rrp-str (~market-header-rrp :rrp rrp-str))))) (when rrp-str (~market-header-rrp :rrp rrp-str)))))
;; Card price line from data (used in product cards) ;; Card price line from data (used in product cards)
(defcomp ~market-card-price-from-data (&key sp-val sp-str rp-val rp-str) (defcomp ~market-card-price-from-data (&key (sp-val :as number?) (sp-str :as string?) (rp-val :as number?) (rp-str :as string?))
(~market-price-line :inner (~market-price-line :inner
(<> (<>
(when sp-val (when sp-val

View File

@@ -1,6 +1,6 @@
;; Checkout return page components ;; Checkout return page components
(defcomp ~checkout-return-header (&key status) (defcomp ~checkout-return-header (&key (status :as string))
(header :class "mb-1 sm:mb-2 flex flex-col sm:flex-row sm:items-center justify-between gap-3 sm:gap-4" (header :class "mb-1 sm:mb-2 flex flex-col sm:flex-row sm:items-center justify-between gap-3 sm:gap-4"
(div :class "space-y-1" (div :class "space-y-1"
(h1 :class "text-xl sm:text-2xl md:text-3xl font-semibold tracking-tight" (h1 :class "text-xl sm:text-2xl md:text-3xl font-semibold tracking-tight"
@@ -21,7 +21,7 @@
(div :class "rounded-2xl border border-dashed border-rose-300 bg-rose-50/80 p-4 sm:p-6 text-sm text-rose-800" (div :class "rounded-2xl border border-dashed border-rose-300 bg-rose-50/80 p-4 sm:p-6 text-sm text-rose-800"
"We couldn\u2019t find that order. If you reached this page from an old link, please start a new order."))) "We couldn\u2019t find that order. If you reached this page from an old link, please start a new order.")))
(defcomp ~checkout-return-failed (&key order-id) (defcomp ~checkout-return-failed (&key (order-id :as string))
(div :class "rounded-2xl border border-rose-200 bg-rose-50/80 p-4 sm:p-6 text-sm text-rose-900 space-y-2" (div :class "rounded-2xl border border-rose-200 bg-rose-50/80 p-4 sm:p-6 text-sm text-rose-900 space-y-2"
(p :class "font-medium" "Your payment was not completed.") (p :class "font-medium" "Your payment was not completed.")
(p "You can go back to your cart and try checkout again. If the problem persists, please contact us and mention order " (p "You can go back to your cart and try checkout again. If the problem persists, please contact us and mention order "
@@ -32,7 +32,7 @@
(p :class "font-medium" "All done!") (p :class "font-medium" "All done!")
(p "We\u2019ll start processing your order shortly."))) (p "We\u2019ll start processing your order shortly.")))
(defcomp ~checkout-return-ticket (&key name pill state type-name date-str code price) (defcomp ~checkout-return-ticket (&key (name :as string) (pill :as string) (state :as string) (type-name :as string?) (date-str :as string) (code :as string) (price :as string))
(li :class "px-4 py-3 flex items-start justify-between text-sm" (li :class "px-4 py-3 flex items-start justify-between text-sm"
(div (div
(div :class "font-medium flex items-center gap-2" (div :class "font-medium flex items-center gap-2"
@@ -48,7 +48,7 @@
(ul :class "divide-y divide-stone-200 rounded-2xl border border-stone-200 bg-white/80" items))) (ul :class "divide-y divide-stone-200 rounded-2xl border border-stone-200 bg-white/80" items)))
;; Data-driven ticket items (replaces Python loop) ;; Data-driven ticket items (replaces Python loop)
(defcomp ~checkout-return-tickets-from-data (&key tickets) (defcomp ~checkout-return-tickets-from-data (&key (tickets :as list))
(~checkout-return-tickets (~checkout-return-tickets
:items (<> (map (lambda (tk) :items (<> (map (lambda (tk)
(~checkout-return-ticket (~checkout-return-ticket

View File

@@ -3,13 +3,13 @@
;; --- orders layout: root + auth + orders rows --- ;; --- orders layout: root + auth + orders rows ---
(defcomp ~orders-layout-full (&key list-url) (defcomp ~orders-layout-full (&key (list-url :as string))
(<> (~root-header-auto) (<> (~root-header-auto)
(~header-child-sx (~header-child-sx
:inner (<> (~auth-header-row-auto) :inner (<> (~auth-header-row-auto)
(~orders-header-row :list-url (or list-url "/")))))) (~orders-header-row :list-url (or list-url "/"))))))
(defcomp ~orders-layout-oob (&key list-url) (defcomp ~orders-layout-oob (&key (list-url :as string))
(<> (~auth-header-row-auto true) (<> (~auth-header-row-auto true)
(~oob-header-sx (~oob-header-sx
:parent-id "auth-header-child" :parent-id "auth-header-child"
@@ -21,7 +21,7 @@
;; --- order-detail layout: root + auth + orders + order rows --- ;; --- order-detail layout: root + auth + orders + order rows ---
(defcomp ~order-detail-layout-full (&key list-url detail-url) (defcomp ~order-detail-layout-full (&key (list-url :as string) (detail-url :as string))
(<> (~root-header-auto) (<> (~root-header-auto)
(~order-detail-header-stack (~order-detail-header-stack
:auth (~auth-header-row-auto) :auth (~auth-header-row-auto)
@@ -30,7 +30,7 @@
:link-href (or detail-url "/") :link-label "Order" :link-href (or detail-url "/") :link-label "Order"
:icon "fa fa-gbp")))) :icon "fa fa-gbp"))))
(defcomp ~order-detail-layout-oob (&key detail-url) (defcomp ~order-detail-layout-oob (&key (detail-url :as string))
(<> (~oob-header-sx (<> (~oob-header-sx
:parent-id "orders-header-child" :parent-id "orders-header-child"
:row (~menu-row-sx :id "order-row" :level 3 :colour "sky" :row (~menu-row-sx :id "order-row" :level 3 :colour "sky"

View File

@@ -302,9 +302,10 @@ def create_base_app(
return return
return redirect(f"/auth/login?prompt=none&next={_quote(request.url, safe='')}") return redirect(f"/auth/login?prompt=none&next={_quote(request.url, safe='')}")
@app.before_request if not no_db:
async def _load_user(): @app.before_request
await load_current_user() async def _load_user():
await load_current_user()
# Register any app-specific before-request hooks (e.g. cart loader) # Register any app-specific before-request hooks (e.g. cart loader)
if before_request_fns: if before_request_fns:

File diff suppressed because it is too large Load Diff

View File

@@ -14,7 +14,7 @@
var IDB_NAME = "sx-offline"; var IDB_NAME = "sx-offline";
var IDB_VERSION = 1; var IDB_VERSION = 1;
var IDB_STORE = "responses"; var IDB_STORE = "responses";
var STATIC_CACHE = "sx-static-v1"; var STATIC_CACHE = "sx-static-v2";
// --------------------------------------------------------------------------- // ---------------------------------------------------------------------------
// IndexedDB helpers // IndexedDB helpers

View File

@@ -49,3 +49,13 @@
.sx-loading-btn .sx-spinner { .sx-loading-btn .sx-spinner {
display: none; display: none;
} }
/* Subtle jiggle on links while fetching */
@keyframes sxJiggle {
0%, 100% { transform: translateX(0); }
25% { transform: translateX(-0.5px); }
75% { transform: translateX(0.5px); }
}
a.sx-request {
animation: sxJiggle 0.3s ease-in-out infinite;
}

View File

@@ -31,20 +31,8 @@ from .parser import (
parse_all, parse_all,
serialize, serialize,
) )
import os as _os from .types import EvalError
from .ref.sx_ref import evaluate, make_env
if _os.environ.get("SX_USE_REF") == "1":
from .ref.sx_ref import (
EvalError,
evaluate,
make_env,
)
else:
from .evaluator import (
EvalError,
evaluate,
make_env,
)
from .primitives import ( from .primitives import (
all_primitives, all_primitives,

View File

@@ -53,7 +53,8 @@ from .types import Component, Island, Keyword, Lambda, Macro, NIL, Symbol
_expand_components: contextvars.ContextVar[bool] = contextvars.ContextVar( _expand_components: contextvars.ContextVar[bool] = contextvars.ContextVar(
"_expand_components", default=False "_expand_components", default=False
) )
from .evaluator import _expand_macro, EvalError from .ref.sx_ref import expand_macro as _expand_macro
from .types import EvalError
from .primitives import _PRIMITIVES from .primitives import _PRIMITIVES
from .primitives_io import IO_PRIMITIVES, RequestContext, execute_io from .primitives_io import IO_PRIMITIVES, RequestContext, execute_io
from .parser import SxExpr, serialize from .parser import SxExpr, serialize
@@ -205,12 +206,16 @@ async def _parse_io_args(
async def _async_call_lambda( async def _async_call_lambda(
fn: Lambda, args: list[Any], caller_env: dict[str, Any], ctx: RequestContext, fn: Lambda, args: list[Any], caller_env: dict[str, Any], ctx: RequestContext,
) -> Any: ) -> Any:
if len(args) != len(fn.params): # Too many args is an error; too few pads with nil
if len(args) > len(fn.params):
raise EvalError(f"{fn!r} expects {len(fn.params)} args, got {len(args)}") raise EvalError(f"{fn!r} expects {len(fn.params)} args, got {len(args)}")
local = dict(fn.closure) local = dict(fn.closure)
local.update(caller_env) local.update(caller_env)
for p, v in zip(fn.params, args): for p, v in zip(fn.params, args):
local[p] = v local[p] = v
# Pad missing params with nil
for p in fn.params[len(args):]:
local[p] = None
return _AsyncThunk(fn.body, local, ctx) return _AsyncThunk(fn.body, local, ctx)
@@ -416,23 +421,23 @@ async def _asf_define(expr, env, ctx):
async def _asf_defcomp(expr, env, ctx): async def _asf_defcomp(expr, env, ctx):
from .evaluator import _sf_defcomp from .ref.sx_ref import sf_defcomp
return _sf_defcomp(expr, env) return sf_defcomp(expr[1:], env)
async def _asf_defstyle(expr, env, ctx): async def _asf_defstyle(expr, env, ctx):
from .evaluator import _sf_defstyle from .ref.sx_ref import sf_defstyle
return _sf_defstyle(expr, env) return sf_defstyle(expr[1:], env)
async def _asf_defmacro(expr, env, ctx): async def _asf_defmacro(expr, env, ctx):
from .evaluator import _sf_defmacro from .ref.sx_ref import sf_defmacro
return _sf_defmacro(expr, env) return sf_defmacro(expr[1:], env)
async def _asf_defhandler(expr, env, ctx): async def _asf_defhandler(expr, env, ctx):
from .evaluator import _sf_defhandler from .ref.sx_ref import sf_defhandler
return _sf_defhandler(expr, env) return sf_defhandler(expr[1:], env)
async def _asf_begin(expr, env, ctx): async def _asf_begin(expr, env, ctx):
@@ -595,7 +600,7 @@ async def _asf_reset(expr, env, ctx):
_ASYNC_RESET_RESUME.append(value if value is not None else NIL) _ASYNC_RESET_RESUME.append(value if value is not None else NIL)
try: try:
# Sync re-evaluation; the async caller will trampoline # Sync re-evaluation; the async caller will trampoline
from .evaluator import _eval as sync_eval, _trampoline from .ref.sx_ref import eval_expr as sync_eval, trampoline as _trampoline
return _trampoline(sync_eval(body, env)) return _trampoline(sync_eval(body, env))
finally: finally:
_ASYNC_RESET_RESUME.pop() _ASYNC_RESET_RESUME.pop()
@@ -1332,6 +1337,14 @@ async def _aser(expr: Any, env: dict[str, Any], ctx: RequestContext) -> Any:
return await _aser_call(name, expr[1:], env, ctx) return await _aser_call(name, expr[1:], env, ctx)
return await sf(expr, env, ctx) return await sf(expr, env, ctx)
# Lake — serialize (server-morphable slot within island)
if name == "lake":
return await _aser_call(name, expr[1:], env, ctx)
# Marsh — serialize (reactive server-morphable slot within island)
if name == "marsh":
return await _aser_call(name, expr[1:], env, ctx)
# HTML tag — serialize (don't render to HTML) # HTML tag — serialize (don't render to HTML)
if name in HTML_TAGS: if name in HTML_TAGS:
return await _aser_call(name, expr[1:], env, ctx) return await _aser_call(name, expr[1:], env, ctx)

View File

@@ -20,7 +20,7 @@ class Env:
bindings: dict[str, Any] | None = None, bindings: dict[str, Any] | None = None,
parent: Env | None = None, parent: Env | None = None,
): ):
self._bindings: dict[str, Any] = bindings or {} self._bindings: dict[str, Any] = {} if bindings is None else bindings
self._parent = parent self._parent = parent
# -- lookup ------------------------------------------------------------- # -- lookup -------------------------------------------------------------
@@ -46,12 +46,30 @@ class Env:
def __getitem__(self, name: str) -> Any: def __getitem__(self, name: str) -> Any:
return self.lookup(name) return self.lookup(name)
def __setitem__(self, name: str, value: Any) -> None:
"""Set *name* in the **current** scope (like ``define``)."""
self._bindings[name] = value
def get(self, name: str, default: Any = None) -> Any: def get(self, name: str, default: Any = None) -> Any:
try: try:
return self.lookup(name) return self.lookup(name)
except KeyError: except KeyError:
return default return default
def update(self, other: dict[str, Any] | Env) -> None:
"""Merge *other*'s bindings into the **current** scope."""
if isinstance(other, Env):
self._bindings.update(other._bindings)
else:
self._bindings.update(other)
def keys(self):
"""All keys visible from this scope (current + parents)."""
return self.to_dict().keys()
def __iter__(self):
return iter(self.to_dict())
# -- mutation ----------------------------------------------------------- # -- mutation -----------------------------------------------------------
def define(self, name: str, value: Any) -> None: def define(self, name: str, value: Any) -> None:
@@ -74,7 +92,7 @@ class Env:
def extend(self, bindings: dict[str, Any] | None = None) -> Env: def extend(self, bindings: dict[str, Any] | None = None) -> Env:
"""Return a child environment.""" """Return a child environment."""
return Env(bindings or {}, parent=self) return Env({} if bindings is None else bindings, parent=self)
# -- conversion --------------------------------------------------------- # -- conversion ---------------------------------------------------------
@@ -95,3 +113,58 @@ class Env:
depth += 1 depth += 1
p = p._parent p = p._parent
return f"<Env depth={depth} keys={keys}>" return f"<Env depth={depth} keys={keys}>"
class MergedEnv(Env):
"""Env with two parent chains: primary (closure) and secondary (caller).
Reads walk: local bindings → primary chain → secondary chain.
set! walks: local bindings → primary chain (skips secondary).
This allows set! to modify variables in the defining scope (closure)
without being confused by overlay copies from the calling scope.
"""
__slots__ = ("_secondary",)
def __init__(
self,
bindings: dict[str, Any] | None = None,
primary: Env | None = None,
secondary: Env | None = None,
):
super().__init__(bindings, parent=primary)
self._secondary = secondary
def lookup(self, name: str) -> Any:
try:
return super().lookup(name)
except KeyError:
if self._secondary is not None:
return self._secondary.lookup(name)
raise
def __contains__(self, name: str) -> bool:
if super().__contains__(name):
return True
if self._secondary is not None:
return name in self._secondary
return False
def get(self, name: str, default: Any = None) -> Any:
try:
return self.lookup(name)
except KeyError:
return default
def to_dict(self) -> dict[str, Any]:
if self._secondary is not None:
d = self._secondary.to_dict()
else:
d = {}
if self._parent is not None:
d.update(self._parent.to_dict())
d.update(self._bindings)
return d
def extend(self, bindings: dict[str, Any] | None = None) -> Env:
return Env(bindings or {}, parent=self)

File diff suppressed because it is too large Load Diff

View File

@@ -70,10 +70,7 @@ def load_handler_file(filepath: str, service_name: str) -> list[HandlerDef]:
"""Parse an .sx file, evaluate it, and register any HandlerDef values.""" """Parse an .sx file, evaluate it, and register any HandlerDef values."""
from .parser import parse_all from .parser import parse_all
import os import os
if os.environ.get("SX_USE_REF") == "1": from .ref.sx_ref import eval_expr as _raw_eval, trampoline as _trampoline
from .ref.sx_ref import eval_expr as _raw_eval, trampoline as _trampoline
else:
from .evaluator import _eval as _raw_eval, _trampoline
_eval = lambda expr, env: _trampoline(_raw_eval(expr, env)) _eval = lambda expr, env: _trampoline(_raw_eval(expr, env))
from .jinja_bridge import get_component_env from .jinja_bridge import get_component_env
@@ -130,6 +127,7 @@ async def execute_handler(
4. Return ``SxExpr`` wire format 4. Return ``SxExpr`` wire format
""" """
from .jinja_bridge import get_component_env, _get_request_context from .jinja_bridge import get_component_env, _get_request_context
from .pages import get_page_helpers
import os import os
if os.environ.get("SX_USE_REF") == "1": if os.environ.get("SX_USE_REF") == "1":
from .ref.async_eval_ref import async_eval_to_sx from .ref.async_eval_ref import async_eval_to_sx
@@ -142,6 +140,7 @@ async def execute_handler(
# Build environment # Build environment
env = dict(get_component_env()) env = dict(get_component_env())
env.update(get_page_helpers(service_name))
env.update(handler_def.closure) env.update(handler_def.closure)
# Bind handler params from request args # Bind handler params from request args
@@ -218,6 +217,65 @@ def create_handler_blueprint(service_name: str) -> Any:
return bp return bp
# ---------------------------------------------------------------------------
# Public route registration — handlers with :path get mounted as routes
# ---------------------------------------------------------------------------
def register_route_handlers(app_or_bp: Any, service_name: str) -> int:
"""Register public routes for all handlers with :path defined.
Returns the number of routes registered.
"""
from quart import Response, request
from shared.browser.app.csrf import csrf_exempt
handlers = get_all_handlers(service_name)
count = 0
for name, hdef in handlers.items():
if not hdef.is_route:
continue
# Capture hdef in closure
_hdef = hdef
async def _route_view(_h=_hdef, **path_kwargs):
from shared.sx.helpers import sx_response
from shared.sx.primitives_io import reset_response_meta, get_response_meta
reset_response_meta()
args = dict(request.args)
args.update(path_kwargs)
result = await execute_handler(_h, service_name, args=args)
resp = sx_response(result)
meta = get_response_meta()
if meta:
if meta.get("status"):
resp.status_code = meta["status"]
for k, v in meta.get("headers", {}).items():
resp.headers[k] = v
return resp
endpoint = f"sx_route_{name}"
view_fn = _route_view
if not _hdef.csrf:
view_fn = csrf_exempt(view_fn)
method = _hdef.method.lower()
route_reg = getattr(app_or_bp, method, None)
if route_reg is None:
logger.warning("Unsupported HTTP method %s for handler %s",
_hdef.method, name)
continue
route_reg(_hdef.path, endpoint=endpoint)(view_fn)
logger.info("Registered route %s %s → handler:%s",
_hdef.method.upper(), _hdef.path, name)
count += 1
return count
# --------------------------------------------------------------------------- # ---------------------------------------------------------------------------
# Direct app mount — replaces per-service fragment blueprint boilerplate # Direct app mount — replaces per-service fragment blueprint boilerplate
# --------------------------------------------------------------------------- # ---------------------------------------------------------------------------

View File

@@ -293,7 +293,12 @@ async def oob_page_sx(*, oobs: str = "", filter: str = "", aside: str = "",
async def full_page_sx(ctx: dict, *, header_rows: str, async def full_page_sx(ctx: dict, *, header_rows: str,
filter: str = "", aside: str = "", filter: str = "", aside: str = "",
content: str = "", menu: str = "", content: str = "", menu: str = "",
meta_html: str = "", meta: str = "") -> str: meta_html: str = "", meta: str = "",
head_scripts: list[str] | None = None,
inline_css: str | None = None,
inline_head_js: str | None = None,
init_sx: str | None = None,
body_scripts: list[str] | None = None) -> str:
"""Build a full page using sx_page() with ~app-body. """Build a full page using sx_page() with ~app-body.
meta_html: raw HTML injected into the <head> shell (legacy). meta_html: raw HTML injected into the <head> shell (legacy).
@@ -313,7 +318,10 @@ async def full_page_sx(ctx: dict, *, header_rows: str,
# Wrap body + meta in a fragment so sx.js renders both; # Wrap body + meta in a fragment so sx.js renders both;
# auto-hoist moves meta/title/link elements to <head>. # auto-hoist moves meta/title/link elements to <head>.
body_sx = _sx_fragment(meta, body_sx) body_sx = _sx_fragment(meta, body_sx)
return await sx_page(ctx, body_sx, meta_html=meta_html) return await sx_page(ctx, body_sx, meta_html=meta_html,
head_scripts=head_scripts, inline_css=inline_css,
inline_head_js=inline_head_js, init_sx=init_sx,
body_scripts=body_scripts)
def _build_component_ast(__name: str, **kwargs: Any) -> list: def _build_component_ast(__name: str, **kwargs: Any) -> list:
@@ -518,8 +526,12 @@ def components_for_request(source: str = "",
if val.has_children: if val.has_children:
param_strs.extend(["&rest", "children"]) param_strs.extend(["&rest", "children"])
params_sx = "(" + " ".join(param_strs) + ")" params_sx = "(" + " ".join(param_strs) + ")"
body_sx = serialize(val.body, pretty=True) body_sx = serialize(val.body, indent=1, pretty=True)
parts.append(f"(defcomp ~{val.name} {params_sx} {body_sx})") head = f"(defcomp ~{val.name} {params_sx}"
if "\n" in body_sx:
parts.append(f"{head}\n {body_sx})")
else:
parts.append(f"{head} {body_sx})")
elif isinstance(val, Macro): elif isinstance(val, Macro):
if val.name in loaded: if val.name in loaded:
continue continue
@@ -527,8 +539,12 @@ def components_for_request(source: str = "",
if val.rest_param: if val.rest_param:
param_strs.extend(["&rest", val.rest_param]) param_strs.extend(["&rest", val.rest_param])
params_sx = "(" + " ".join(param_strs) + ")" params_sx = "(" + " ".join(param_strs) + ")"
body_sx = serialize(val.body, pretty=True) body_sx = serialize(val.body, indent=1, pretty=True)
parts.append(f"(defmacro {val.name} {params_sx} {body_sx})") head = f"(defmacro {val.name} {params_sx}"
if "\n" in body_sx:
parts.append(f"{head}\n {body_sx})")
else:
parts.append(f"{head} {body_sx})")
return "\n".join(parts) return "\n".join(parts)
@@ -752,7 +768,12 @@ def _sx_literal(v: object) -> str:
async def sx_page(ctx: dict, page_sx: str, *, async def sx_page(ctx: dict, page_sx: str, *,
meta_html: str = "") -> str: meta_html: str = "",
head_scripts: list[str] | None = None,
inline_css: str | None = None,
inline_head_js: str | None = None,
init_sx: str | None = None,
body_scripts: list[str] | None = None) -> str:
"""Return a minimal HTML shell that boots the page from sx source. """Return a minimal HTML shell that boots the page from sx source.
The browser loads component definitions and page sx, then sx.js The browser loads component definitions and page sx, then sx.js
@@ -817,8 +838,21 @@ async def sx_page(ctx: dict, page_sx: str, *,
if isinstance(page_sx, SxExpr): if isinstance(page_sx, SxExpr):
page_sx = "".join([page_sx]) page_sx = "".join([page_sx])
return await render_to_html( # Per-app shell config: check explicit args, then app config, then defaults
"sx-page-shell", from quart import current_app as _app
_shell_cfg = _app.config.get("SX_SHELL", {})
if head_scripts is None:
head_scripts = _shell_cfg.get("head_scripts")
if inline_css is None:
inline_css = _shell_cfg.get("inline_css")
if inline_head_js is None:
inline_head_js = _shell_cfg.get("inline_head_js")
if init_sx is None:
init_sx = _shell_cfg.get("init_sx")
if body_scripts is None:
body_scripts = _shell_cfg.get("body_scripts")
shell_kwargs: dict[str, Any] = dict(
title=_html_escape(title), title=_html_escape(title),
asset_url=asset_url, asset_url=asset_url,
meta_html=meta_html, meta_html=meta_html,
@@ -832,6 +866,17 @@ async def sx_page(ctx: dict, page_sx: str, *,
sx_js_hash=_script_hash("sx-browser.js"), sx_js_hash=_script_hash("sx-browser.js"),
body_js_hash=_script_hash("body.js"), body_js_hash=_script_hash("body.js"),
) )
if head_scripts is not None:
shell_kwargs["head_scripts"] = head_scripts
if inline_css is not None:
shell_kwargs["inline_css"] = inline_css
if inline_head_js is not None:
shell_kwargs["inline_head_js"] = inline_head_js
if init_sx is not None:
shell_kwargs["init_sx"] = init_sx
if body_scripts is not None:
shell_kwargs["body_scripts"] = body_scripts
return await render_to_html("sx-page-shell", **shell_kwargs)
_SX_STREAMING_RESOLVE = """\ _SX_STREAMING_RESOLVE = """\

View File

@@ -28,7 +28,7 @@ import contextvars
from typing import Any from typing import Any
from .types import Component, Island, Keyword, Lambda, Macro, NIL, Symbol from .types import Component, Island, Keyword, Lambda, Macro, NIL, Symbol
from .evaluator import _eval as _raw_eval, _call_component as _raw_call_component, _expand_macro, _trampoline from .ref.sx_ref import eval_expr as _raw_eval, call_component as _raw_call_component, expand_macro as _expand_macro, trampoline as _trampoline
def _eval(expr, env): def _eval(expr, env):
"""Evaluate and unwrap thunks — all html.py _eval calls are non-tail.""" """Evaluate and unwrap thunks — all html.py _eval calls are non-tail."""
@@ -414,10 +414,10 @@ def _render_component(comp: Component, args: list, env: dict[str, Any]) -> str:
def _render_island(island: Island, args: list, env: dict[str, Any]) -> str: def _render_island(island: Island, args: list, env: dict[str, Any]) -> str:
"""Render an island as static HTML with hydration attributes. """Render an island as static HTML with hydration attributes.
Produces: <div data-sx-island="name" data-sx-state='{"k":"v",...}'>body HTML</div> Produces: <span data-sx-island="name" data-sx-state="{:k &quot;v&quot;}">body HTML</span>
The client hydrates this into a reactive island. The client hydrates this into a reactive island via sx-parse (not JSON).
""" """
import json as _json from .parser import serialize as _sx_serialize
kwargs: dict[str, Any] = {} kwargs: dict[str, Any] = {}
children: list[Any] = [] children: list[Any] = []
@@ -443,32 +443,86 @@ def _render_island(island: Island, args: list, env: dict[str, Any]) -> str:
body_html = _render(island.body, local) body_html = _render(island.body, local)
# Serialize state for hydration — only keyword args # Serialize state for hydration — SX format (not JSON)
state = {} state_sx = _escape_attr(_sx_serialize(kwargs)) if kwargs else ""
for k, v in kwargs.items():
if isinstance(v, (str, int, float, bool)):
state[k] = v
elif v is NIL or v is None:
state[k] = None
elif isinstance(v, list):
state[k] = v
elif isinstance(v, dict):
state[k] = v
else:
state[k] = str(v)
state_json = _escape_attr(_json.dumps(state, separators=(",", ":"))) if state else ""
island_name = _escape_attr(island.name) island_name = _escape_attr(island.name)
parts = [f'<div data-sx-island="{island_name}"'] parts = [f'<span data-sx-island="{island_name}"']
if state_json: if state_sx:
parts.append(f' data-sx-state="{state_json}"') parts.append(f' data-sx-state="{state_sx}"')
parts.append(">") parts.append(">")
parts.append(body_html) parts.append(body_html)
parts.append("</div>") parts.append("</span>")
return "".join(parts) return "".join(parts)
def _render_lake(args: list, env: dict[str, Any]) -> str:
"""Render a server-morphable lake slot.
(lake :id "name" :tag "div" children...)
→ <div data-sx-lake="name">children</div>
Lakes are server territory inside reactive islands. During morph,
the server can update lake content while surrounding reactive DOM
is preserved.
"""
lake_id = ""
lake_tag = "div"
children: list[Any] = []
i = 0
while i < len(args):
arg = args[i]
if isinstance(arg, Keyword) and i + 1 < len(args):
kname = arg.name
kval = _eval(args[i + 1], env)
if kname == "id":
lake_id = str(kval) if kval is not None and kval is not NIL else ""
elif kname == "tag":
lake_tag = str(kval) if kval is not None and kval is not NIL else "div"
i += 2
else:
children.append(arg)
i += 1
body = "".join(_render(c, env) for c in children)
return f'<{lake_tag} data-sx-lake="{_escape_attr(lake_id)}">{body}</{lake_tag}>'
def _render_marsh(args: list, env: dict[str, Any]) -> str:
"""Render a reactive server-morphable marsh slot.
(marsh :id "name" :tag "div" :transform fn children...)
→ <div data-sx-marsh="name">children</div>
Marshes are zones where reactivity and hypermedia interpenetrate.
Like lakes but content is parsed as SX on the client and re-evaluated
in the island's signal scope. :transform is consumed but not used
server-side (it's a client-side concern).
"""
marsh_id = ""
marsh_tag = "div"
children: list[Any] = []
i = 0
while i < len(args):
arg = args[i]
if isinstance(arg, Keyword) and i + 1 < len(args):
kname = arg.name
kval = _eval(args[i + 1], env)
if kname == "id":
marsh_id = str(kval) if kval is not None and kval is not NIL else ""
elif kname == "tag":
marsh_tag = str(kval) if kval is not None and kval is not NIL else "div"
elif kname == "transform":
pass # Client-side only; skip
i += 2
else:
children.append(arg)
i += 1
body = "".join(_render(c, env) for c in children)
return f'<{marsh_tag} data-sx-marsh="{_escape_attr(marsh_id)}">{body}</{marsh_tag}>'
def _render_list(expr: list, env: dict[str, Any]) -> str: def _render_list(expr: list, env: dict[str, Any]) -> str:
"""Render a list expression — could be an HTML element, special form, """Render a list expression — could be an HTML element, special form,
component call, or data list.""" component call, or data list."""
@@ -494,6 +548,14 @@ def _render_list(expr: list, env: dict[str, Any]) -> str:
if name == "<>": if name == "<>":
return "".join(_render(child, env) for child in expr[1:]) return "".join(_render(child, env) for child in expr[1:])
# --- lake → server-morphable slot within island -------------------
if name == "lake":
return _render_lake(expr[1:], env)
# --- marsh → reactive server-morphable slot within island --------
if name == "marsh":
return _render_marsh(expr[1:], env)
# --- html: prefix → force tag rendering -------------------------- # --- html: prefix → force tag rendering --------------------------
if name.startswith("html:"): if name.startswith("html:"):
return _render_element(name[5:], expr[1:], env) return _render_element(name[5:], expr[1:], env)

View File

@@ -46,6 +46,11 @@ _COMPONENT_ENV: dict[str, Any] = {}
# client-side localStorage caching. # client-side localStorage caching.
_COMPONENT_HASH: str = "" _COMPONENT_HASH: str = ""
# Raw source of .sx files marked with ;; @client — sent to the browser
# alongside component definitions so define forms (functions, data) are
# available for client-side evaluation (e.g. cssx colour/spacing functions).
_CLIENT_LIBRARY_SOURCES: list[str] = []
def get_component_env() -> dict[str, Any]: def get_component_env() -> dict[str, Any]:
"""Return the shared component environment.""" """Return the shared component environment."""
@@ -61,7 +66,7 @@ def _compute_component_hash() -> None:
"""Recompute _COMPONENT_HASH from all registered Component and Macro definitions.""" """Recompute _COMPONENT_HASH from all registered Component and Macro definitions."""
global _COMPONENT_HASH global _COMPONENT_HASH
from .parser import serialize from .parser import serialize
parts = [] parts = list(_CLIENT_LIBRARY_SOURCES)
for key in sorted(_COMPONENT_ENV): for key in sorted(_COMPONENT_ENV):
val = _COMPONENT_ENV[key] val = _COMPONENT_ENV[key]
if isinstance(val, Island): if isinstance(val, Island):
@@ -96,6 +101,8 @@ def load_sx_dir(directory: str) -> None:
"""Load all .sx files from a directory and register components. """Load all .sx files from a directory and register components.
Skips boundary.sx — those are parsed separately by the boundary validator. Skips boundary.sx — those are parsed separately by the boundary validator.
Files starting with ``;; @client`` have their source stored for delivery
to the browser (so ``define`` forms are available client-side).
""" """
for filepath in sorted( for filepath in sorted(
glob.glob(os.path.join(directory, "**", "*.sx"), recursive=True) glob.glob(os.path.join(directory, "**", "*.sx"), recursive=True)
@@ -103,7 +110,17 @@ def load_sx_dir(directory: str) -> None:
if os.path.basename(filepath) == "boundary.sx": if os.path.basename(filepath) == "boundary.sx":
continue continue
with open(filepath, encoding="utf-8") as f: with open(filepath, encoding="utf-8") as f:
register_components(f.read()) source = f.read()
if source.lstrip().startswith(";; @client"):
# Parse and re-serialize to normalize syntax sugar.
# The Python parser accepts ' for quote but the bootstrapped
# client parser uses #' — re-serializing emits (quote x).
from .parser import parse_all, serialize
exprs = parse_all(source)
_CLIENT_LIBRARY_SOURCES.append(
"\n".join(serialize(e) for e in exprs)
)
register_components(source)
# --------------------------------------------------------------------------- # ---------------------------------------------------------------------------
@@ -132,7 +149,11 @@ def watch_sx_dir(directory: str) -> None:
def reload_if_changed() -> None: def reload_if_changed() -> None:
"""Re-read sx files if any have changed on disk. Called per-request in dev.""" """Re-read sx files if any have changed on disk. Called per-request in dev."""
changed = False import logging
import time
_logger = logging.getLogger("sx.reload")
changed_files = []
for directory in _watched_dirs: for directory in _watched_dirs:
for fp in sorted( for fp in sorted(
glob.glob(os.path.join(directory, "**", "*.sx"), recursive=True) glob.glob(os.path.join(directory, "**", "*.sx"), recursive=True)
@@ -140,14 +161,28 @@ def reload_if_changed() -> None:
mtime = os.path.getmtime(fp) mtime = os.path.getmtime(fp)
if fp not in _file_mtimes or _file_mtimes[fp] != mtime: if fp not in _file_mtimes or _file_mtimes[fp] != mtime:
_file_mtimes[fp] = mtime _file_mtimes[fp] = mtime
changed = True changed_files.append(fp)
if changed: if changed_files:
for fp in changed_files:
_logger.info("Changed: %s", fp)
t0 = time.monotonic()
_COMPONENT_ENV.clear() _COMPONENT_ENV.clear()
_CLIENT_LIBRARY_SOURCES.clear()
# Reload SX libraries first (e.g. z3.sx) so reader macros resolve # Reload SX libraries first (e.g. z3.sx) so reader macros resolve
for cb in _reload_callbacks: for cb in _reload_callbacks:
cb() cb()
for directory in _watched_dirs: for directory in _watched_dirs:
load_sx_dir(directory) load_sx_dir(directory)
t1 = time.monotonic()
_logger.info("Reloaded %d file(s), components in %.1fms",
len(changed_files), (t1 - t0) * 1000)
# Recompute render plans for all services that have pages
from .pages import _PAGE_REGISTRY, compute_page_render_plans
for svc in _PAGE_REGISTRY:
t2 = time.monotonic()
compute_page_render_plans(svc)
_logger.info("Render plans for %s in %.1fms", svc, (time.monotonic() - t2) * 1000)
def load_service_components(service_dir: str, service_name: str | None = None) -> None: def load_service_components(service_dir: str, service_name: str | None = None) -> None:
@@ -194,10 +229,7 @@ def register_components(sx_source: str) -> None:
(div :class "..." (div :class "..." title))))) (div :class "..." (div :class "..." title)))))
''') ''')
""" """
if _os.environ.get("SX_USE_REF") == "1": from .ref.sx_ref import eval_expr as _raw_eval, trampoline as _trampoline
from .ref.sx_ref import eval_expr as _raw_eval, trampoline as _trampoline
else:
from .evaluator import _eval as _raw_eval, _trampoline
_eval = lambda expr, env: _trampoline(_raw_eval(expr, env)) _eval = lambda expr, env: _trampoline(_raw_eval(expr, env))
from .parser import parse_all from .parser import parse_all
from .css_registry import scan_classes_from_sx from .css_registry import scan_classes_from_sx
@@ -351,9 +383,10 @@ def client_components_tag(*names: str) -> str:
params_sx = "(" + " ".join(param_strs) + ")" params_sx = "(" + " ".join(param_strs) + ")"
body_sx = serialize(val.body, pretty=True) body_sx = serialize(val.body, pretty=True)
parts.append(f"(defmacro {val.name} {params_sx} {body_sx})") parts.append(f"(defmacro {val.name} {params_sx} {body_sx})")
if not parts: if not parts and not _CLIENT_LIBRARY_SOURCES:
return "" return ""
source = "\n".join(parts) all_parts = list(_CLIENT_LIBRARY_SOURCES) + parts
source = "\n".join(all_parts)
return f'<script type="text/sx" data-components>{source}</script>' return f'<script type="text/sx" data-components>{source}</script>'
@@ -420,10 +453,12 @@ def components_for_page(page_sx: str, service: str | None = None) -> tuple[str,
body_sx = serialize(val.body, pretty=True) body_sx = serialize(val.body, pretty=True)
parts.append(f"(defmacro {val.name} {params_sx} {body_sx})") parts.append(f"(defmacro {val.name} {params_sx} {body_sx})")
if not parts: if not parts and not _CLIENT_LIBRARY_SOURCES:
return "", "" return "", ""
source = "\n".join(parts) # Prepend client library sources (define forms) before component defs
all_parts = list(_CLIENT_LIBRARY_SOURCES) + parts
source = "\n".join(all_parts)
digest = hashlib.sha256(source.encode()).hexdigest()[:12] digest = hashlib.sha256(source.encode()).hexdigest()[:12]
return source, digest return source, digest

View File

@@ -76,7 +76,7 @@ def register_page_helpers(service: str, helpers: dict[str, Any]) -> None:
Then in .sx:: Then in .sx::
(defpage docs-page (defpage docs-page
:path "/docs/<slug>" :path "/language/docs/<slug>"
:auth :public :auth :public
:content (docs-content slug)) :content (docs-content slug))
""" """
@@ -127,7 +127,7 @@ def get_page_helpers(service: str) -> dict[str, Any]:
def load_page_file(filepath: str, service_name: str) -> list[PageDef]: def load_page_file(filepath: str, service_name: str) -> list[PageDef]:
"""Parse an .sx file, evaluate it, and register any PageDef values.""" """Parse an .sx file, evaluate it, and register any PageDef values."""
from .parser import parse_all from .parser import parse_all
from .evaluator import _eval as _raw_eval, _trampoline from .ref.sx_ref import eval_expr as _raw_eval, trampoline as _trampoline
_eval = lambda expr, env: _trampoline(_raw_eval(expr, env)) _eval = lambda expr, env: _trampoline(_raw_eval(expr, env))
from .jinja_bridge import get_component_env from .jinja_bridge import get_component_env
@@ -170,7 +170,11 @@ async def _eval_slot(expr: Any, env: dict, ctx: Any) -> str:
Expands component calls (so IO in the body executes) but serializes Expands component calls (so IO in the body executes) but serializes
the result as SX wire format, not HTML. the result as SX wire format, not HTML.
""" """
from .async_eval import async_eval_slot_to_sx import os
if os.environ.get("SX_USE_REF") == "1":
from .ref.async_eval_ref import async_eval_slot_to_sx
else:
from .async_eval import async_eval_slot_to_sx
return await async_eval_slot_to_sx(expr, env, ctx) return await async_eval_slot_to_sx(expr, env, ctx)
@@ -236,10 +240,11 @@ async def execute_page(
if url_params is None: if url_params is None:
url_params = {} url_params = {}
# Build environment # Build environment — closure first (page-local defines), then fresh
env = dict(get_component_env()) # component env on top so hot-reloaded components take priority.
env = dict(page_def.closure)
env.update(get_component_env())
env.update(get_page_helpers(service_name)) env.update(get_page_helpers(service_name))
env.update(page_def.closure)
# Inject URL params as kebab-case symbols # Inject URL params as kebab-case symbols
for key, val in url_params.items(): for key, val in url_params.items():
@@ -416,9 +421,9 @@ async def execute_page_streaming(
if url_params is None: if url_params is None:
url_params = {} url_params = {}
env = dict(get_component_env()) env = dict(page_def.closure)
env.update(get_component_env())
env.update(get_page_helpers(service_name)) env.update(get_page_helpers(service_name))
env.update(page_def.closure)
for key, val in url_params.items(): for key, val in url_params.items():
kebab = key.replace("_", "-") kebab = key.replace("_", "-")
env[kebab] = val env[kebab] = val
@@ -662,9 +667,9 @@ async def execute_page_streaming_oob(
if url_params is None: if url_params is None:
url_params = {} url_params = {}
env = dict(get_component_env()) env = dict(page_def.closure)
env.update(get_component_env())
env.update(get_page_helpers(service_name)) env.update(get_page_helpers(service_name))
env.update(page_def.closure)
for key, val in url_params.items(): for key, val in url_params.items():
kebab = key.replace("_", "-") kebab = key.replace("_", "-")
env[kebab] = val env[kebab] = val
@@ -846,17 +851,22 @@ def compute_page_render_plans(service_name: str) -> None:
Must be called after components are loaded (compute_all_deps/io_refs done) Must be called after components are loaded (compute_all_deps/io_refs done)
and pages are registered. Stores plans on PageDef.render_plan. and pages are registered. Stores plans on PageDef.render_plan.
""" """
import time
from .parser import serialize from .parser import serialize
from .deps import page_render_plan, get_all_io_names from .deps import page_render_plan, get_all_io_names
from .jinja_bridge import _COMPONENT_ENV from .jinja_bridge import _COMPONENT_ENV
t0 = time.monotonic()
io_names = get_all_io_names() io_names = get_all_io_names()
pages = get_all_pages(service_name) pages = get_all_pages(service_name)
count = 0
for page_def in pages.values(): for page_def in pages.values():
if page_def.content_expr is not None: if page_def.content_expr is not None:
content_src = serialize(page_def.content_expr) content_src = serialize(page_def.content_expr)
page_def.render_plan = page_render_plan(content_src, _COMPONENT_ENV, io_names) page_def.render_plan = page_render_plan(content_src, _COMPONENT_ENV, io_names)
logger.info("Computed render plans for %d pages in %s", len(pages), service_name) count += 1
elapsed = (time.monotonic() - t0) * 1000
logger.info("Computed render plans for %d pages in %s (%.1fms)", count, service_name, elapsed)
def auto_mount_pages(app: Any, service_name: str) -> None: def auto_mount_pages(app: Any, service_name: str) -> None:
@@ -1040,9 +1050,9 @@ async def evaluate_page_data(
url_params = {} url_params = {}
# Build environment (same as execute_page) # Build environment (same as execute_page)
env = dict(get_component_env()) env = dict(page_def.closure)
env.update(get_component_env())
env.update(get_page_helpers(service_name)) env.update(get_page_helpers(service_name))
env.update(page_def.closure)
for key, val in url_params.items(): for key, val in url_params.items():
kebab = key.replace("_", "-") kebab = key.replace("_", "-")

View File

@@ -41,7 +41,7 @@ def _resolve_sx_reader_macro(name: str):
""" """
try: try:
from .jinja_bridge import get_component_env from .jinja_bridge import get_component_env
from .evaluator import _trampoline, _call_lambda from .ref.sx_ref import trampoline as _trampoline, call_lambda as _call_lambda
from .types import Lambda from .types import Lambda
except ImportError: except ImportError:
return None return None

View File

@@ -561,3 +561,15 @@ def prim_into(target: Any, coll: Any) -> Any:
return result return result
raise ValueError(f"into: unsupported target type {type(target).__name__}") raise ValueError(f"into: unsupported target type {type(target).__name__}")
@register_primitive("random-int")
def prim_random_int(low: int, high: int) -> int:
import random
return random.randint(int(low), int(high))
@register_primitive("json-encode")
def prim_json_encode(value) -> str:
import json
return json.dumps(value, indent=2)

View File

@@ -46,6 +46,13 @@ _handler_service: contextvars.ContextVar[Any] = contextvars.ContextVar(
"_handler_service", default=None "_handler_service", default=None
) )
_response_meta: contextvars.ContextVar[dict | None] = contextvars.ContextVar(
"_response_meta", default=None
)
# Ephemeral per-process state — resets on restart. For demos/testing only.
_ephemeral_state: dict[str, Any] = {}
def set_handler_service(service_obj: Any) -> None: def set_handler_service(service_obj: Any) -> None:
"""Bind the local domain service for ``(service ...)`` primitive calls.""" """Bind the local domain service for ``(service ...)`` primitive calls."""
@@ -57,6 +64,16 @@ def get_handler_service() -> Any:
return _handler_service.get(None) return _handler_service.get(None)
def reset_response_meta() -> None:
"""Reset response meta for a new request."""
_response_meta.set(None)
def get_response_meta() -> dict | None:
"""Get response meta (headers/status) set by handler IO primitives."""
return _response_meta.get(None)
class RequestContext: class RequestContext:
"""Per-request context provided to I/O primitives.""" """Per-request context provided to I/O primitives."""
__slots__ = ("user", "is_htmx", "extras") __slots__ = ("user", "is_htmx", "extras")
@@ -297,6 +314,192 @@ async def _io_g(
return getattr(g, key, None) return getattr(g, key, None)
@register_io_handler("now")
async def _io_now(
args: list[Any], kwargs: dict[str, Any], ctx: RequestContext
) -> str:
"""``(now)`` or ``(now "%H:%M:%S")`` → formatted timestamp string."""
from datetime import datetime
fmt = str(args[0]) if args else None
dt = datetime.now()
return dt.strftime(fmt) if fmt else dt.isoformat()
@register_io_handler("sleep")
async def _io_sleep(
args: list[Any], kwargs: dict[str, Any], ctx: RequestContext
) -> Any:
"""``(sleep 800)`` → pause for 800ms."""
import asyncio
from .types import NIL
if not args:
raise ValueError("sleep requires milliseconds")
ms = int(args[0])
await asyncio.sleep(ms / 1000.0)
return NIL
@register_io_handler("request-form")
async def _io_request_form(
args: list[Any], kwargs: dict[str, Any], ctx: RequestContext
) -> Any:
"""``(request-form "name" default?)`` → read a form field."""
if not args:
raise ValueError("request-form requires a field name")
from quart import request
from .types import NIL
name = str(args[0])
default = args[1] if len(args) > 1 else NIL
form = await request.form
return form.get(name, default)
@register_io_handler("request-json")
async def _io_request_json(
args: list[Any], kwargs: dict[str, Any], ctx: RequestContext
) -> Any:
"""``(request-json)`` → JSON body as dict, or nil."""
from quart import request
from .types import NIL
data = await request.get_json(silent=True)
return data if data is not None else NIL
@register_io_handler("request-header")
async def _io_request_header(
args: list[Any], kwargs: dict[str, Any], ctx: RequestContext
) -> Any:
"""``(request-header "name" default?)`` → request header value."""
if not args:
raise ValueError("request-header requires a header name")
from quart import request
from .types import NIL
name = str(args[0])
default = args[1] if len(args) > 1 else NIL
return request.headers.get(name, default)
@register_io_handler("request-content-type")
async def _io_request_content_type(
args: list[Any], kwargs: dict[str, Any], ctx: RequestContext
) -> Any:
"""``(request-content-type)`` → content-type string or nil."""
from quart import request
from .types import NIL
return request.content_type or NIL
@register_io_handler("request-args-all")
async def _io_request_args_all(
args: list[Any], kwargs: dict[str, Any], ctx: RequestContext
) -> dict:
"""``(request-args-all)`` → all query params as dict."""
from quart import request
return dict(request.args)
@register_io_handler("request-form-all")
async def _io_request_form_all(
args: list[Any], kwargs: dict[str, Any], ctx: RequestContext
) -> dict:
"""``(request-form-all)`` → all form fields as dict."""
from quart import request
form = await request.form
return dict(form)
@register_io_handler("request-form-list")
async def _io_request_form_list(
args: list[Any], kwargs: dict[str, Any], ctx: RequestContext
) -> list:
"""``(request-form-list "field")`` → all values for a multi-value form field."""
if not args:
raise ValueError("request-form-list requires a field name")
from quart import request
form = await request.form
return form.getlist(str(args[0]))
@register_io_handler("request-headers-all")
async def _io_request_headers_all(
args: list[Any], kwargs: dict[str, Any], ctx: RequestContext
) -> dict:
"""``(request-headers-all)`` → all headers as dict (lowercase keys)."""
from quart import request
return {k.lower(): v for k, v in request.headers}
@register_io_handler("request-file-name")
async def _io_request_file_name(
args: list[Any], kwargs: dict[str, Any], ctx: RequestContext
) -> Any:
"""``(request-file-name "field")`` → filename or nil."""
if not args:
raise ValueError("request-file-name requires a field name")
from quart import request
from .types import NIL
files = await request.files
f = files.get(str(args[0]))
return f.filename if f else NIL
@register_io_handler("set-response-header")
async def _io_set_response_header(
args: list[Any], kwargs: dict[str, Any], ctx: RequestContext
) -> Any:
"""``(set-response-header "Name" "value")`` → set on response after handler."""
if len(args) < 2:
raise ValueError("set-response-header requires name and value")
from .types import NIL
meta = _response_meta.get(None)
if meta is None:
meta = {"headers": {}, "status": None}
_response_meta.set(meta)
meta["headers"][str(args[0])] = str(args[1])
return NIL
@register_io_handler("set-response-status")
async def _io_set_response_status(
args: list[Any], kwargs: dict[str, Any], ctx: RequestContext
) -> Any:
"""``(set-response-status 503)`` → set status code on response."""
if not args:
raise ValueError("set-response-status requires a status code")
from .types import NIL
meta = _response_meta.get(None)
if meta is None:
meta = {"headers": {}, "status": None}
_response_meta.set(meta)
meta["status"] = int(args[0])
return NIL
@register_io_handler("state-get")
async def _io_state_get(
args: list[Any], kwargs: dict[str, Any], ctx: RequestContext
) -> Any:
"""``(state-get "key" default?)`` → read from ephemeral state."""
if not args:
raise ValueError("state-get requires a key")
from .types import NIL
key = str(args[0])
default = args[1] if len(args) > 1 else NIL
return _ephemeral_state.get(key, default)
@register_io_handler("state-set!")
async def _io_state_set(
args: list[Any], kwargs: dict[str, Any], ctx: RequestContext
) -> Any:
"""``(state-set! "key" value)`` → write to ephemeral state."""
if len(args) < 2:
raise ValueError("state-set! requires key and value")
from .types import NIL
_ephemeral_state[str(args[0])] = args[1]
return NIL
@register_io_handler("csrf-token") @register_io_handler("csrf-token")
async def _io_csrf_token( async def _io_csrf_token(
args: list[Any], kwargs: dict[str, Any], ctx: RequestContext args: list[Any], kwargs: dict[str, Any], ctx: RequestContext

View File

@@ -78,7 +78,7 @@ def clear(service: str | None = None) -> None:
def load_query_file(filepath: str, service_name: str) -> list[QueryDef]: def load_query_file(filepath: str, service_name: str) -> list[QueryDef]:
"""Parse an .sx file and register any defquery definitions.""" """Parse an .sx file and register any defquery definitions."""
from .parser import parse_all from .parser import parse_all
from .evaluator import _eval as _raw_eval, _trampoline from .ref.sx_ref import eval_expr as _raw_eval, trampoline as _trampoline
_eval = lambda expr, env: _trampoline(_raw_eval(expr, env)) _eval = lambda expr, env: _trampoline(_raw_eval(expr, env))
from .jinja_bridge import get_component_env from .jinja_bridge import get_component_env
@@ -103,7 +103,7 @@ def load_query_file(filepath: str, service_name: str) -> list[QueryDef]:
def load_action_file(filepath: str, service_name: str) -> list[ActionDef]: def load_action_file(filepath: str, service_name: str) -> list[ActionDef]:
"""Parse an .sx file and register any defaction definitions.""" """Parse an .sx file and register any defaction definitions."""
from .parser import parse_all from .parser import parse_all
from .evaluator import _eval as _raw_eval, _trampoline from .ref.sx_ref import eval_expr as _raw_eval, trampoline as _trampoline
_eval = lambda expr, env: _trampoline(_raw_eval(expr, env)) _eval = lambda expr, env: _trampoline(_raw_eval(expr, env))
from .jinja_bridge import get_component_env from .jinja_bridge import get_component_env

File diff suppressed because it is too large Load Diff

View File

@@ -18,8 +18,9 @@
;; render-to-dom — main entry point ;; render-to-dom — main entry point
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define render-to-dom (define render-to-dom :effects [render]
(fn (expr env ns) (fn (expr (env :as dict) (ns :as string))
(set-render-active! true)
(case (type-of expr) (case (type-of expr)
;; nil / boolean false / boolean true → empty fragment ;; nil / boolean false / boolean true → empty fragment
"nil" (create-fragment) "nil" (create-fragment)
@@ -52,16 +53,21 @@
(create-fragment) (create-fragment)
(render-dom-list expr env ns)) (render-dom-list expr env ns))
;; Fallback ;; Signal → reactive text in island scope, deref outside
:else (create-text-node (str expr))))) :else
(if (signal? expr)
(if *island-scope*
(reactive-text expr)
(create-text-node (str (deref expr))))
(create-text-node (str expr))))))
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; render-dom-list — dispatch on list head ;; render-dom-list — dispatch on list head
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define render-dom-list (define render-dom-list :effects [render]
(fn (expr env ns) (fn (expr (env :as dict) (ns :as string))
(let ((head (first expr))) (let ((head (first expr)))
(cond (cond
;; Symbol head — dispatch on name ;; Symbol head — dispatch on name
@@ -77,6 +83,14 @@
(= name "<>") (= name "<>")
(render-dom-fragment args env ns) (render-dom-fragment args env ns)
;; lake — server-morphable slot within an island
(= name "lake")
(render-dom-lake args env ns)
;; marsh — reactive server-morphable slot within an island
(= name "marsh")
(render-dom-marsh args env ns)
;; html: prefix → force element rendering ;; html: prefix → force element rendering
(starts-with? name "html:") (starts-with? name "html:")
(render-dom-element (slice name 5) args env ns) (render-dom-element (slice name 5) args env ns)
@@ -151,8 +165,8 @@
;; render-dom-element — create a DOM element with attrs and children ;; render-dom-element — create a DOM element with attrs and children
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define render-dom-element (define render-dom-element :effects [render]
(fn (tag args env ns) (fn ((tag :as string) (args :as list) (env :as dict) (ns :as string))
;; Detect namespace from tag ;; Detect namespace from tag
(let ((new-ns (cond (= tag "svg") SVG_NS (let ((new-ns (cond (= tag "svg") SVG_NS
(= tag "math") MATH_NS (= tag "math") MATH_NS
@@ -222,8 +236,8 @@
;; render-dom-component — expand and render a component ;; render-dom-component — expand and render a component
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define render-dom-component (define render-dom-component :effects [render]
(fn (comp args env ns) (fn ((comp :as component) (args :as list) (env :as dict) (ns :as string))
;; Parse kwargs and children, bind into component env, render body. ;; Parse kwargs and children, bind into component env, render body.
(let ((kwargs (dict)) (let ((kwargs (dict))
(children (list))) (children (list)))
@@ -269,8 +283,8 @@
;; render-dom-fragment — render children into a DocumentFragment ;; render-dom-fragment — render children into a DocumentFragment
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define render-dom-fragment (define render-dom-fragment :effects [render]
(fn (args env ns) (fn ((args :as list) (env :as dict) (ns :as string))
(let ((frag (create-fragment))) (let ((frag (create-fragment)))
(for-each (for-each
(fn (x) (dom-append frag (render-to-dom x env ns))) (fn (x) (dom-append frag (render-to-dom x env ns)))
@@ -282,8 +296,8 @@
;; render-dom-raw — insert unescaped content ;; render-dom-raw — insert unescaped content
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define render-dom-raw (define render-dom-raw :effects [render]
(fn (args env) (fn ((args :as list) (env :as dict))
(let ((frag (create-fragment))) (let ((frag (create-fragment)))
(for-each (for-each
(fn (arg) (fn (arg)
@@ -303,8 +317,8 @@
;; render-dom-unknown-component — visible warning element ;; render-dom-unknown-component — visible warning element
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define render-dom-unknown-component (define render-dom-unknown-component :effects [render]
(fn (name) (fn ((name :as string))
(error (str "Unknown component: " name)))) (error (str "Unknown component: " name))))
@@ -320,12 +334,12 @@
"map" "map-indexed" "filter" "for-each" "portal" "map" "map-indexed" "filter" "for-each" "portal"
"error-boundary")) "error-boundary"))
(define render-dom-form? (define render-dom-form? :effects []
(fn (name) (fn ((name :as string))
(contains? RENDER_DOM_FORMS name))) (contains? RENDER_DOM_FORMS name)))
(define dispatch-render-form (define dispatch-render-form :effects [render]
(fn (name expr env ns) (fn ((name :as string) expr (env :as dict) (ns :as string))
(cond (cond
;; if — reactive inside islands (re-renders when signal deps change) ;; if — reactive inside islands (re-renders when signal deps change)
(= name "if") (= name "if")
@@ -486,7 +500,8 @@
(if (and *island-scope* (if (and *island-scope*
(= (type-of coll-expr) "list") (= (type-of coll-expr) "list")
(> (len coll-expr) 1) (> (len coll-expr) 1)
(= (first coll-expr) "deref")) (= (type-of (first coll-expr)) "symbol")
(= (symbol-name (first coll-expr)) "deref"))
;; Reactive path: pass signal to reactive-list ;; Reactive path: pass signal to reactive-list
(let ((f (trampoline (eval-expr (nth expr 1) env))) (let ((f (trampoline (eval-expr (nth expr 1) env)))
(sig (trampoline (eval-expr (nth coll-expr 1) env)))) (sig (trampoline (eval-expr (nth coll-expr 1) env))))
@@ -565,8 +580,8 @@
;; render-lambda-dom — render a lambda body in DOM context ;; render-lambda-dom — render a lambda body in DOM context
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define render-lambda-dom (define render-lambda-dom :effects [render]
(fn (f args env ns) (fn ((f :as lambda) (args :as list) (env :as dict) (ns :as string))
;; Bind lambda params and render body as DOM ;; Bind lambda params and render body as DOM
(let ((local (env-merge (lambda-closure f) env))) (let ((local (env-merge (lambda-closure f) env)))
(for-each-indexed (for-each-indexed
@@ -589,8 +604,8 @@
;; - Attribute bindings: (deref sig) in attr → reactive attribute ;; - Attribute bindings: (deref sig) in attr → reactive attribute
;; - Conditional fragments: (when (deref sig) ...) → reactive show/hide ;; - Conditional fragments: (when (deref sig) ...) → reactive show/hide
(define render-dom-island (define render-dom-island :effects [render mutation]
(fn (island args env ns) (fn ((island :as island) (args :as list) (env :as dict) (ns :as string))
;; Parse kwargs and children (same as component) ;; Parse kwargs and children (same as component)
(let ((kwargs (dict)) (let ((kwargs (dict))
(children (list))) (children (list)))
@@ -630,11 +645,12 @@
(env-set! local "children" child-frag))) (env-set! local "children" child-frag)))
;; Create the island container element ;; Create the island container element
(let ((container (dom-create-element "div" nil)) (let ((container (dom-create-element "span" nil))
(disposers (list))) (disposers (list)))
;; Mark as island ;; Mark as island + already hydrated (so boot.sx skips it)
(dom-set-attr container "data-sx-island" island-name) (dom-set-attr container "data-sx-island" island-name)
(mark-processed! container "island-hydrated")
;; Render island body inside a scope that tracks disposers ;; Render island body inside a scope that tracks disposers
(let ((body-dom (let ((body-dom
@@ -649,6 +665,100 @@
container)))))) container))))))
;; --------------------------------------------------------------------------
;; render-dom-lake — server-morphable slot within an island
;; --------------------------------------------------------------------------
;;
;; (lake :id "name" children...)
;;
;; Renders as <div data-sx-lake="name">children</div>.
;; During morph, the server can replace lake content while the surrounding
;; reactive island DOM is preserved. This is the "water around the rocks" —
;; server substance flowing through client territory.
;;
;; Supports :tag keyword to change wrapper element (default "div").
(define render-dom-lake :effects [render]
(fn ((args :as list) (env :as dict) (ns :as string))
(let ((lake-id nil)
(lake-tag "div")
(children (list)))
(reduce
(fn (state arg)
(let ((skip (get state "skip")))
(if skip
(assoc state "skip" false "i" (inc (get state "i")))
(if (and (= (type-of arg) "keyword")
(< (inc (get state "i")) (len args)))
(let ((kname (keyword-name arg))
(kval (trampoline (eval-expr (nth args (inc (get state "i"))) env))))
(cond
(= kname "id") (set! lake-id kval)
(= kname "tag") (set! lake-tag kval))
(assoc state "skip" true "i" (inc (get state "i"))))
(do
(append! children arg)
(assoc state "i" (inc (get state "i"))))))))
(dict "i" 0 "skip" false)
args)
(let ((el (dom-create-element lake-tag nil)))
(dom-set-attr el "data-sx-lake" (or lake-id ""))
(for-each
(fn (c) (dom-append el (render-to-dom c env ns)))
children)
el))))
;; --------------------------------------------------------------------------
;; render-dom-marsh — reactive server-morphable slot within an island
;; --------------------------------------------------------------------------
;;
;; (marsh :id "name" :tag "div" :transform fn children...)
;;
;; Like a lake but reactive: during morph, new content is parsed as SX and
;; re-evaluated in the island's signal scope. The :transform function (if
;; present) reshapes server content before evaluation.
;;
;; Renders as <div data-sx-marsh="name">children</div>.
;; Stores the island env and transform on the element for morph retrieval.
(define render-dom-marsh :effects [render]
(fn ((args :as list) (env :as dict) (ns :as string))
(let ((marsh-id nil)
(marsh-tag "div")
(marsh-transform nil)
(children (list)))
(reduce
(fn (state arg)
(let ((skip (get state "skip")))
(if skip
(assoc state "skip" false "i" (inc (get state "i")))
(if (and (= (type-of arg) "keyword")
(< (inc (get state "i")) (len args)))
(let ((kname (keyword-name arg))
(kval (trampoline (eval-expr (nth args (inc (get state "i"))) env))))
(cond
(= kname "id") (set! marsh-id kval)
(= kname "tag") (set! marsh-tag kval)
(= kname "transform") (set! marsh-transform kval))
(assoc state "skip" true "i" (inc (get state "i"))))
(do
(append! children arg)
(assoc state "i" (inc (get state "i"))))))))
(dict "i" 0 "skip" false)
args)
(let ((el (dom-create-element marsh-tag nil)))
(dom-set-attr el "data-sx-marsh" (or marsh-id ""))
;; Store transform function and island env for morph retrieval
(when marsh-transform
(dom-set-data el "sx-marsh-transform" marsh-transform))
(dom-set-data el "sx-marsh-env" env)
(for-each
(fn (c) (dom-append el (render-to-dom c env ns)))
children)
el))))
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; Reactive DOM rendering helpers ;; Reactive DOM rendering helpers
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
@@ -659,7 +769,7 @@
;; reactive-text — create a text node bound to a signal ;; reactive-text — create a text node bound to a signal
;; Used when (deref sig) appears in a text position inside an island. ;; Used when (deref sig) appears in a text position inside an island.
(define reactive-text (define reactive-text :effects [render mutation]
(fn (sig) (fn (sig)
(let ((node (create-text-node (str (deref sig))))) (let ((node (create-text-node (str (deref sig)))))
(effect (fn () (effect (fn ()
@@ -668,22 +778,31 @@
;; reactive-attr — bind an element attribute to a signal expression ;; reactive-attr — bind an element attribute to a signal expression
;; Used when an attribute value contains (deref sig) inside an island. ;; Used when an attribute value contains (deref sig) inside an island.
(define reactive-attr ;; Marks the attribute name on the element via data-sx-reactive-attrs so
(fn (el attr-name compute-fn) ;; the morph algorithm knows not to overwrite it with server content.
(define reactive-attr :effects [render mutation]
(fn (el (attr-name :as string) (compute-fn :as lambda))
;; Mark this attribute as reactively managed
(let ((existing (or (dom-get-attr el "data-sx-reactive-attrs") ""))
(updated (if (empty? existing) attr-name (str existing "," attr-name))))
(dom-set-attr el "data-sx-reactive-attrs" updated))
(effect (fn () (effect (fn ()
(let ((val (compute-fn))) (let ((raw (compute-fn)))
(cond ;; If compute-fn returned a signal (e.g. from computed), deref it
(or (nil? val) (= val false)) ;; to get the actual value and track the dependency
(dom-remove-attr el attr-name) (let ((val (if (signal? raw) (deref raw) raw)))
(= val true) (cond
(dom-set-attr el attr-name "") (or (nil? val) (= val false))
:else (dom-remove-attr el attr-name)
(dom-set-attr el attr-name (str val)))))))) (= val true)
(dom-set-attr el attr-name "")
:else
(dom-set-attr el attr-name (str val)))))))))
;; reactive-fragment — conditionally render a fragment based on a signal ;; reactive-fragment — conditionally render a fragment based on a signal
;; Used for (when (deref sig) ...) or (if (deref sig) ...) inside an island. ;; Used for (when (deref sig) ...) or (if (deref sig) ...) inside an island.
(define reactive-fragment (define reactive-fragment :effects [render mutation]
(fn (test-fn render-fn env ns) (fn ((test-fn :as lambda) (render-fn :as lambda) (env :as dict) (ns :as string))
(let ((marker (create-comment "island-fragment")) (let ((marker (create-comment "island-fragment"))
(current-nodes (list))) (current-nodes (list)))
(effect (fn () (effect (fn ()
@@ -704,14 +823,14 @@
;; existing DOM nodes are reused across updates. Only additions, removals, ;; existing DOM nodes are reused across updates. Only additions, removals,
;; and reorderings touch the DOM. Without keys, falls back to clear+rerender. ;; and reorderings touch the DOM. Without keys, falls back to clear+rerender.
(define render-list-item (define render-list-item :effects [render]
(fn (map-fn item env ns) (fn ((map-fn :as lambda) item (env :as dict) (ns :as string))
(if (lambda? map-fn) (if (lambda? map-fn)
(render-lambda-dom map-fn (list item) env ns) (render-lambda-dom map-fn (list item) env ns)
(render-to-dom (apply map-fn (list item)) env ns)))) (render-to-dom (apply map-fn (list item)) env ns))))
(define extract-key (define extract-key :effects [render]
(fn (node index) (fn (node (index :as number))
;; Extract key from rendered node: :key attr, data-key, or index fallback ;; Extract key from rendered node: :key attr, data-key, or index fallback
(let ((k (dom-get-attr node "key"))) (let ((k (dom-get-attr node "key")))
(if k (if k
@@ -719,8 +838,8 @@
(let ((dk (dom-get-data node "key"))) (let ((dk (dom-get-data node "key")))
(if dk (str dk) (str "__idx_" index))))))) (if dk (str dk) (str "__idx_" index)))))))
(define reactive-list (define reactive-list :effects [render mutation]
(fn (map-fn items-sig env ns) (fn ((map-fn :as lambda) (items-sig :as signal) (env :as dict) (ns :as string))
(let ((container (create-fragment)) (let ((container (create-fragment))
(marker (create-comment "island-list")) (marker (create-comment "island-list"))
(key-map (dict)) (key-map (dict))
@@ -805,8 +924,8 @@
;; ;;
;; Handles: input[text/number/email/...], textarea, select, checkbox, radio ;; Handles: input[text/number/email/...], textarea, select, checkbox, radio
(define bind-input (define bind-input :effects [render mutation]
(fn (el sig) (fn (el (sig :as signal))
(let ((input-type (lower (or (dom-get-attr el "type") ""))) (let ((input-type (lower (or (dom-get-attr el "type") "")))
(is-checkbox (or (= input-type "checkbox") (is-checkbox (or (= input-type "checkbox")
(= input-type "radio")))) (= input-type "radio"))))
@@ -840,8 +959,8 @@
;; position. Registers a disposer to clean up portal content on island ;; position. Registers a disposer to clean up portal content on island
;; teardown. ;; teardown.
(define render-dom-portal (define render-dom-portal :effects [render]
(fn (args env ns) (fn ((args :as list) (env :as dict) (ns :as string))
(let ((selector (trampoline (eval-expr (first args) env))) (let ((selector (trampoline (eval-expr (first args) env)))
(target (or (dom-query selector) (target (or (dom-query selector)
(dom-ensure-element selector)))) (dom-ensure-element selector))))
@@ -880,8 +999,8 @@
;; (fn (err retry) ...) ;; (fn (err retry) ...)
;; Calling (retry) re-renders the body, replacing the fallback. ;; Calling (retry) re-renders the body, replacing the fallback.
(define render-dom-error-boundary (define render-dom-error-boundary :effects [render]
(fn (args env ns) (fn ((args :as list) (env :as dict) (ns :as string))
(let ((fallback-expr (first args)) (let ((fallback-expr (first args))
(body-exprs (rest args)) (body-exprs (rest args))
(container (dom-create-element "div" nil)) (container (dom-create-element "div" nil))

View File

@@ -13,8 +13,9 @@
;; ========================================================================== ;; ==========================================================================
(define render-to-html (define render-to-html :effects [render]
(fn (expr env) (fn (expr (env :as dict))
(set-render-active! true)
(case (type-of expr) (case (type-of expr)
;; Literals — render directly ;; Literals — render directly
"nil" "" "nil" ""
@@ -32,8 +33,8 @@
;; Everything else — evaluate first ;; Everything else — evaluate first
:else (render-value-to-html (trampoline (eval-expr expr env)) env)))) :else (render-value-to-html (trampoline (eval-expr expr env)) env))))
(define render-value-to-html (define render-value-to-html :effects [render]
(fn (val env) (fn (val (env :as dict))
(case (type-of val) (case (type-of val)
"nil" "" "nil" ""
"string" (escape-html val) "string" (escape-html val)
@@ -51,10 +52,11 @@
(define RENDER_HTML_FORMS (define RENDER_HTML_FORMS
(list "if" "when" "cond" "case" "let" "let*" "begin" "do" (list "if" "when" "cond" "case" "let" "let*" "begin" "do"
"define" "defcomp" "defisland" "defmacro" "defstyle" "defhandler" "define" "defcomp" "defisland" "defmacro" "defstyle" "defhandler"
"deftype" "defeffect"
"map" "map-indexed" "filter" "for-each")) "map" "map-indexed" "filter" "for-each"))
(define render-html-form? (define render-html-form? :effects []
(fn (name) (fn ((name :as string))
(contains? RENDER_HTML_FORMS name))) (contains? RENDER_HTML_FORMS name)))
@@ -62,8 +64,8 @@
;; render-list-to-html — dispatch on list head ;; render-list-to-html — dispatch on list head
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define render-list-to-html (define render-list-to-html :effects [render]
(fn (expr env) (fn ((expr :as list) (env :as dict))
(if (empty? expr) (if (empty? expr)
"" ""
(let ((head (first expr))) (let ((head (first expr)))
@@ -81,6 +83,14 @@
(= name "raw!") (= name "raw!")
(join "" (map (fn (x) (str (trampoline (eval-expr x env)))) args)) (join "" (map (fn (x) (str (trampoline (eval-expr x env)))) args))
;; Lake — server-morphable slot within an island
(= name "lake")
(render-html-lake args env)
;; Marsh — reactive server-morphable slot within an island
(= name "marsh")
(render-html-marsh args env)
;; HTML tag ;; HTML tag
(contains? HTML_TAGS name) (contains? HTML_TAGS name)
(render-html-element name args env) (render-html-element name args env)
@@ -125,8 +135,8 @@
;; dispatch-html-form — render-aware special form handling for HTML output ;; dispatch-html-form — render-aware special form handling for HTML output
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define dispatch-html-form (define dispatch-html-form :effects [render]
(fn (name expr env) (fn ((name :as string) (expr :as list) (env :as dict))
(cond (cond
;; if ;; if
(= name "if") (= name "if")
@@ -225,8 +235,8 @@
;; render-lambda-html — render a lambda body in HTML context ;; render-lambda-html — render a lambda body in HTML context
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define render-lambda-html (define render-lambda-html :effects [render]
(fn (f args env) (fn ((f :as lambda) (args :as list) (env :as dict))
(let ((local (env-merge (lambda-closure f) env))) (let ((local (env-merge (lambda-closure f) env)))
(for-each-indexed (for-each-indexed
(fn (i p) (fn (i p)
@@ -239,8 +249,8 @@
;; render-html-component — expand and render a component ;; render-html-component — expand and render a component
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define render-html-component (define render-html-component :effects [render]
(fn (comp args env) (fn ((comp :as component) (args :as list) (env :as dict))
;; Expand component and render body through HTML adapter. ;; Expand component and render body through HTML adapter.
;; Component body contains rendering forms (HTML tags) that only the ;; Component body contains rendering forms (HTML tags) that only the
;; adapter understands, so expansion must happen here, not in eval-expr. ;; adapter understands, so expansion must happen here, not in eval-expr.
@@ -278,8 +288,8 @@
(render-to-html (component-body comp) local))))) (render-to-html (component-body comp) local)))))
(define render-html-element (define render-html-element :effects [render]
(fn (tag args env) (fn ((tag :as string) (args :as list) (env :as dict))
(let ((parsed (parse-element-args args env)) (let ((parsed (parse-element-args args env))
(attrs (first parsed)) (attrs (first parsed))
(children (nth parsed 1)) (children (nth parsed 1))
@@ -293,6 +303,83 @@
"</" tag ">")))))) "</" tag ">"))))))
;; --------------------------------------------------------------------------
;; render-html-lake — SSR rendering of a server-morphable slot
;; --------------------------------------------------------------------------
;;
;; (lake :id "name" children...) → <div data-sx-lake="name">children</div>
;;
;; Lakes are server territory inside islands. The morph can update lake
;; content while preserving surrounding reactive DOM.
(define render-html-lake :effects [render]
(fn ((args :as list) (env :as dict))
(let ((lake-id nil)
(lake-tag "div")
(children (list)))
(reduce
(fn (state arg)
(let ((skip (get state "skip")))
(if skip
(assoc state "skip" false "i" (inc (get state "i")))
(if (and (= (type-of arg) "keyword")
(< (inc (get state "i")) (len args)))
(let ((kname (keyword-name arg))
(kval (trampoline (eval-expr (nth args (inc (get state "i"))) env))))
(cond
(= kname "id") (set! lake-id kval)
(= kname "tag") (set! lake-tag kval))
(assoc state "skip" true "i" (inc (get state "i"))))
(do
(append! children arg)
(assoc state "i" (inc (get state "i"))))))))
(dict "i" 0 "skip" false)
args)
(str "<" lake-tag " data-sx-lake=\"" (escape-attr (or lake-id "")) "\">"
(join "" (map (fn (c) (render-to-html c env)) children))
"</" lake-tag ">"))))
;; --------------------------------------------------------------------------
;; render-html-marsh — SSR rendering of a reactive server-morphable slot
;; --------------------------------------------------------------------------
;;
;; (marsh :id "name" :tag "div" :transform fn children...)
;; → <div data-sx-marsh="name">children</div>
;;
;; Like a lake but reactive: during morph, new content is parsed as SX and
;; re-evaluated in the island's signal scope. Server renders children normally;
;; the :transform is a client-only concern.
(define render-html-marsh :effects [render]
(fn ((args :as list) (env :as dict))
(let ((marsh-id nil)
(marsh-tag "div")
(children (list)))
(reduce
(fn (state arg)
(let ((skip (get state "skip")))
(if skip
(assoc state "skip" false "i" (inc (get state "i")))
(if (and (= (type-of arg) "keyword")
(< (inc (get state "i")) (len args)))
(let ((kname (keyword-name arg))
(kval (trampoline (eval-expr (nth args (inc (get state "i"))) env))))
(cond
(= kname "id") (set! marsh-id kval)
(= kname "tag") (set! marsh-tag kval)
(= kname "transform") nil)
(assoc state "skip" true "i" (inc (get state "i"))))
(do
(append! children arg)
(assoc state "i" (inc (get state "i"))))))))
(dict "i" 0 "skip" false)
args)
(str "<" marsh-tag " data-sx-marsh=\"" (escape-attr (or marsh-id "")) "\">"
(join "" (map (fn (c) (render-to-html c env)) children))
"</" marsh-tag ">"))))
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; render-html-island — SSR rendering of a reactive island ;; render-html-island — SSR rendering of a reactive island
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
@@ -307,8 +394,8 @@
;; (reset! s v) → no-op ;; (reset! s v) → no-op
;; (swap! s f) → no-op ;; (swap! s f) → no-op
(define render-html-island (define render-html-island :effects [render]
(fn (island args env) (fn ((island :as island) (args :as list) (env :as dict))
;; Parse kwargs and children (same pattern as render-html-component) ;; Parse kwargs and children (same pattern as render-html-component)
(let ((kwargs (dict)) (let ((kwargs (dict))
(children (list))) (children (list)))
@@ -347,29 +434,29 @@
;; Render the island body as HTML ;; Render the island body as HTML
(let ((body-html (render-to-html (component-body island) local)) (let ((body-html (render-to-html (component-body island) local))
(state-json (serialize-island-state kwargs))) (state-sx (serialize-island-state kwargs)))
;; Wrap in container with hydration attributes ;; Wrap in container with hydration attributes
(str "<div data-sx-island=\"" (escape-attr island-name) "\"" (str "<span data-sx-island=\"" (escape-attr island-name) "\""
(if state-json (if state-sx
(str " data-sx-state=\"" (escape-attr state-json) "\"") (str " data-sx-state=\"" (escape-attr state-sx) "\"")
"") "")
">" ">"
body-html body-html
"</div>")))))) "</span>"))))))
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; serialize-island-state — serialize kwargs to JSON for hydration ;; serialize-island-state — serialize kwargs to SX for hydration
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; ;;
;; Only serializes simple values (numbers, strings, booleans, nil, lists, dicts). ;; Uses the SX serializer (not JSON) so the client can parse with sx-parse.
;; Functions, components, and other non-serializable values are skipped. ;; Handles all SX types natively: numbers, strings, booleans, nil, lists, dicts.
(define serialize-island-state (define serialize-island-state :effects []
(fn (kwargs) (fn ((kwargs :as dict))
(if (empty-dict? kwargs) (if (empty-dict? kwargs)
nil nil
(json-serialize kwargs)))) (sx-serialize kwargs))))
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
@@ -390,8 +477,8 @@
;; Raw HTML construction: ;; Raw HTML construction:
;; (make-raw-html s) → wrap string as raw HTML (not double-escaped) ;; (make-raw-html s) → wrap string as raw HTML (not double-escaped)
;; ;;
;; JSON serialization (for island state): ;; Island state serialization:
;; (json-serialize dict) → JSON string ;; (sx-serialize val) → SX source string (from parser.sx)
;; (empty-dict? d) → boolean ;; (empty-dict? d) → boolean
;; (escape-attr s) → HTML attribute escape ;; (escape-attr s) → HTML attribute escape
;; ;;

View File

@@ -11,8 +11,8 @@
;; ========================================================================== ;; ==========================================================================
(define render-to-sx (define render-to-sx :effects [render]
(fn (expr env) (fn (expr (env :as dict))
(let ((result (aser expr env))) (let ((result (aser expr env)))
;; aser-call already returns serialized SX strings; ;; aser-call already returns serialized SX strings;
;; only serialize non-string values ;; only serialize non-string values
@@ -20,10 +20,11 @@
result result
(serialize result))))) (serialize result)))))
(define aser (define aser :effects [render]
(fn (expr env) (fn ((expr :as any) (env :as dict))
;; Evaluate for SX wire format — serialize rendering forms, ;; Evaluate for SX wire format — serialize rendering forms,
;; evaluate control flow and function calls. ;; evaluate control flow and function calls.
(set-render-active! true)
(case (type-of expr) (case (type-of expr)
"number" expr "number" expr
"string" expr "string" expr
@@ -50,8 +51,8 @@
:else expr))) :else expr)))
(define aser-list (define aser-list :effects [render]
(fn (expr env) (fn ((expr :as list) (env :as dict))
(let ((head (first expr)) (let ((head (first expr))
(args (rest expr))) (args (rest expr)))
(if (not (= (type-of head) "symbol")) (if (not (= (type-of head) "symbol"))
@@ -66,6 +67,14 @@
(starts-with? name "~") (starts-with? name "~")
(aser-call name args env) (aser-call name args env)
;; Lake — serialize (server-morphable slot)
(= name "lake")
(aser-call name args env)
;; Marsh — serialize (reactive server-morphable slot)
(= name "marsh")
(aser-call name args env)
;; HTML tag — serialize ;; HTML tag — serialize
(contains? HTML_TAGS name) (contains? HTML_TAGS name)
(aser-call name args env) (aser-call name args env)
@@ -94,38 +103,59 @@
:else (error (str "Not callable: " (inspect f))))))))))) :else (error (str "Not callable: " (inspect f)))))))))))
(define aser-fragment (define aser-fragment :effects [render]
(fn (children env) (fn ((children :as list) (env :as dict))
;; Serialize (<> child1 child2 ...) to sx source string ;; Serialize (<> child1 child2 ...) to sx source string
(let ((parts (filter ;; Must flatten list results (e.g. from map/filter) to avoid nested parens
(fn (x) (not (nil? x))) (let ((parts (list)))
(map (fn (c) (aser c env)) children)))) (for-each
(fn (c)
(let ((result (aser c env)))
(if (= (type-of result) "list")
(for-each
(fn (item)
(when (not (nil? item))
(append! parts (serialize item))))
result)
(when (not (nil? result))
(append! parts (serialize result))))))
children)
(if (empty? parts) (if (empty? parts)
"" ""
(str "(<> " (join " " (map serialize parts)) ")"))))) (str "(<> " (join " " parts) ")")))))
(define aser-call (define aser-call :effects [render]
(fn (name args env) (fn ((name :as string) (args :as list) (env :as dict))
;; Serialize (name :key val child ...) — evaluate args but keep as sx ;; Serialize (name :key val child ...) — evaluate args but keep as sx
(let ((parts (list name))) ;; Uses for-each + mutable state (not reduce) so bootstrapper emits for-loops
(reduce ;; that can contain nested for-each for list flattening.
(fn (state arg) (let ((parts (list name))
(let ((skip (get state "skip"))) (skip false)
(if skip (i 0))
(assoc state "skip" false "i" (inc (get state "i"))) (for-each
(if (and (= (type-of arg) "keyword") (fn (arg)
(< (inc (get state "i")) (len args))) (if skip
(let ((val (aser (nth args (inc (get state "i"))) env))) (do (set! skip false)
(when (not (nil? val)) (set! i (inc i)))
(append! parts (str ":" (keyword-name arg))) (if (and (= (type-of arg) "keyword")
(append! parts (serialize val))) (< (inc i) (len args)))
(assoc state "skip" true "i" (inc (get state "i")))) (let ((val (aser (nth args (inc i)) env)))
(let ((val (aser arg env))) (when (not (nil? val))
(when (not (nil? val)) (append! parts (str ":" (keyword-name arg)))
(append! parts (serialize val))) (append! parts (serialize val)))
(assoc state "i" (inc (get state "i")))))))) (set! skip true)
(dict "i" 0 "skip" false) (set! i (inc i)))
(let ((val (aser arg env)))
(when (not (nil? val))
(if (= (type-of val) "list")
(for-each
(fn (item)
(when (not (nil? item))
(append! parts (serialize item))))
val)
(append! parts (serialize val))))
(set! i (inc i))))))
args) args)
(str "(" (join " " parts) ")")))) (str "(" (join " " parts) ")"))))
@@ -140,18 +170,19 @@
"define" "defcomp" "defmacro" "defstyle" "define" "defcomp" "defmacro" "defstyle"
"defhandler" "defpage" "defquery" "defaction" "defrelation" "defhandler" "defpage" "defquery" "defaction" "defrelation"
"begin" "do" "quote" "quasiquote" "begin" "do" "quote" "quasiquote"
"->" "set!" "letrec" "dynamic-wind" "defisland")) "->" "set!" "letrec" "dynamic-wind" "defisland"
"deftype" "defeffect"))
(define HO_FORM_NAMES (define HO_FORM_NAMES
(list "map" "map-indexed" "filter" "reduce" (list "map" "map-indexed" "filter" "reduce"
"some" "every?" "for-each")) "some" "every?" "for-each"))
(define special-form? (define special-form? :effects []
(fn (name) (fn ((name :as string))
(contains? SPECIAL_FORM_NAMES name))) (contains? SPECIAL_FORM_NAMES name)))
(define ho-form? (define ho-form? :effects []
(fn (name) (fn ((name :as string))
(contains? HO_FORM_NAMES name))) (contains? HO_FORM_NAMES name)))
@@ -163,8 +194,8 @@
;; through aser (serializing tags/components instead of rendering HTML). ;; through aser (serializing tags/components instead of rendering HTML).
;; Definition forms evaluate for side effects and return nil. ;; Definition forms evaluate for side effects and return nil.
(define aser-special (define aser-special :effects [render]
(fn (name expr env) (fn ((name :as string) (expr :as list) (env :as dict))
(let ((args (rest expr))) (let ((args (rest expr)))
(cond (cond
;; if — evaluate condition, aser chosen branch ;; if — evaluate condition, aser chosen branch
@@ -274,7 +305,8 @@
;; Definition forms — evaluate for side effects ;; Definition forms — evaluate for side effects
(or (= name "define") (= name "defcomp") (= name "defmacro") (or (= name "define") (= name "defcomp") (= name "defmacro")
(= name "defstyle") (= name "defhandler") (= name "defpage") (= name "defstyle") (= name "defhandler") (= name "defpage")
(= name "defquery") (= name "defaction") (= name "defrelation")) (= name "defquery") (= name "defaction") (= name "defrelation")
(= name "deftype") (= name "defeffect"))
(do (trampoline (eval-expr expr env)) nil) (do (trampoline (eval-expr expr env)) nil)
;; Everything else — evaluate normally ;; Everything else — evaluate normally
@@ -283,8 +315,8 @@
;; Helper: case dispatch for aser mode ;; Helper: case dispatch for aser mode
(define eval-case-aser (define eval-case-aser :effects [render]
(fn (match-val clauses env) (fn (match-val (clauses :as list) (env :as dict))
(if (< (len clauses) 2) (if (< (len clauses) 2)
nil nil
(let ((test (first clauses)) (let ((test (first clauses))

File diff suppressed because it is too large Load Diff

View File

@@ -26,7 +26,7 @@
(define HEAD_HOIST_SELECTOR (define HEAD_HOIST_SELECTOR
"meta, title, link[rel='canonical'], script[type='application/ld+json']") "meta, title, link[rel='canonical'], script[type='application/ld+json']")
(define hoist-head-elements-full (define hoist-head-elements-full :effects [mutation io]
(fn (root) (fn (root)
(let ((els (dom-query-all root HEAD_HOIST_SELECTOR))) (let ((els (dom-query-all root HEAD_HOIST_SELECTOR)))
(for-each (for-each
@@ -71,8 +71,8 @@
;; Mount — render SX source into a DOM element ;; Mount — render SX source into a DOM element
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define sx-mount (define sx-mount :effects [mutation io]
(fn (target source extra-env) (fn (target (source :as string) (extra-env :as dict))
;; Render SX source string into target element. ;; Render SX source string into target element.
;; target: Element or CSS selector string ;; target: Element or CSS selector string
;; source: SX source string ;; source: SX source string
@@ -100,8 +100,8 @@
;; Finds the suspense wrapper by data-suspense attribute, renders the ;; Finds the suspense wrapper by data-suspense attribute, renders the
;; new SX content, and replaces the wrapper's children. ;; new SX content, and replaces the wrapper's children.
(define resolve-suspense (define resolve-suspense :effects [mutation io]
(fn (id sx) (fn ((id :as string) (sx :as string))
;; Process any new <script type="text/sx"> tags that arrived via ;; Process any new <script type="text/sx"> tags that arrived via
;; streaming (e.g. extra component defs) before resolving. ;; streaming (e.g. extra component defs) before resolving.
(process-sx-scripts nil) (process-sx-scripts nil)
@@ -127,7 +127,7 @@
;; Hydrate — render all [data-sx] elements ;; Hydrate — render all [data-sx] elements
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define sx-hydrate-elements (define sx-hydrate-elements :effects [mutation io]
(fn (root) (fn (root)
;; Find all [data-sx] elements within root and render them. ;; Find all [data-sx] elements within root and render them.
(let ((els (dom-query-all (or root (dom-body)) "[data-sx]"))) (let ((els (dom-query-all (or root (dom-body)) "[data-sx]")))
@@ -143,7 +143,7 @@
;; Update — re-render a [data-sx] element with new env data ;; Update — re-render a [data-sx] element with new env data
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define sx-update-element (define sx-update-element :effects [mutation io]
(fn (el new-env) (fn (el new-env)
;; Re-render a [data-sx] element. ;; Re-render a [data-sx] element.
;; Reads source from data-sx attr, base env from data-sx-env attr. ;; Reads source from data-sx attr, base env from data-sx-env attr.
@@ -165,8 +165,8 @@
;; Render component — build synthetic call from kwargs dict ;; Render component — build synthetic call from kwargs dict
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define sx-render-component (define sx-render-component :effects [mutation io]
(fn (name kwargs extra-env) (fn ((name :as string) (kwargs :as dict) (extra-env :as dict))
;; Render a named component with keyword args. ;; Render a named component with keyword args.
;; name: component name (with or without ~ prefix) ;; name: component name (with or without ~ prefix)
;; kwargs: dict of param-name → value ;; kwargs: dict of param-name → value
@@ -179,7 +179,7 @@
;; Build synthetic call expression ;; Build synthetic call expression
(let ((call-expr (list (make-symbol full-name)))) (let ((call-expr (list (make-symbol full-name))))
(for-each (for-each
(fn (k) (fn ((k :as string))
(append! call-expr (make-keyword (to-kebab k))) (append! call-expr (make-keyword (to-kebab k)))
(append! call-expr (dict-get kwargs k))) (append! call-expr (dict-get kwargs k)))
(keys kwargs)) (keys kwargs))
@@ -190,7 +190,7 @@
;; Script processing — <script type="text/sx"> ;; Script processing — <script type="text/sx">
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define process-sx-scripts (define process-sx-scripts :effects [mutation io]
(fn (root) (fn (root)
;; Process all <script type="text/sx"> tags. ;; Process all <script type="text/sx"> tags.
;; - data-components + data-hash → localStorage cache ;; - data-components + data-hash → localStorage cache
@@ -211,6 +211,13 @@
(or (nil? text) (empty? (trim text))) (or (nil? text) (empty? (trim text)))
nil nil
;; Init scripts — evaluate SX for side effects (event listeners etc.)
(dom-has-attr? s "data-init")
(let ((exprs (sx-parse text)))
(for-each
(fn (expr) (eval-expr expr (env-extend (dict))))
exprs))
;; Mount directive ;; Mount directive
(dom-has-attr? s "data-mount") (dom-has-attr? s "data-mount")
(let ((mount-sel (dom-get-attr s "data-mount")) (let ((mount-sel (dom-get-attr s "data-mount"))
@@ -228,8 +235,8 @@
;; Component script with caching ;; Component script with caching
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define process-component-script (define process-component-script :effects [mutation io]
(fn (script text) (fn (script (text :as string))
;; Handle <script type="text/sx" data-components data-hash="..."> ;; Handle <script type="text/sx" data-components data-hash="...">
(let ((hash (dom-get-attr script "data-hash"))) (let ((hash (dom-get-attr script "data-hash")))
(if (nil? hash) (if (nil? hash)
@@ -281,7 +288,7 @@
(define _page-routes (list)) (define _page-routes (list))
(define process-page-scripts (define process-page-scripts :effects [mutation io]
(fn () (fn ()
;; Process <script type="text/sx-pages"> tags. ;; Process <script type="text/sx-pages"> tags.
;; Parses SX page registry and builds route entries with parsed patterns. ;; Parses SX page registry and builds route entries with parsed patterns.
@@ -297,7 +304,7 @@
(let ((pages (parse text))) (let ((pages (parse text)))
(log-info (str "pages: parsed " (len pages) " entries")) (log-info (str "pages: parsed " (len pages) " entries"))
(for-each (for-each
(fn (page) (fn ((page :as dict))
(append! _page-routes (append! _page-routes
(merge page (merge page
{"parsed" (parse-route-pattern (get page "path"))}))) {"parsed" (parse-route-pattern (get page "path"))})))
@@ -324,7 +331,7 @@
;; 5. Morph existing DOM to preserve structure, focus, scroll ;; 5. Morph existing DOM to preserve structure, focus, scroll
;; 6. Store disposers on the element for cleanup ;; 6. Store disposers on the element for cleanup
(define sx-hydrate-islands (define sx-hydrate-islands :effects [mutation io]
(fn (root) (fn (root)
(let ((els (dom-query-all (or root (dom-body)) "[data-sx-island]"))) (let ((els (dom-query-all (or root (dom-body)) "[data-sx-island]")))
(for-each (for-each
@@ -334,24 +341,24 @@
(hydrate-island el))) (hydrate-island el)))
els)))) els))))
(define hydrate-island (define hydrate-island :effects [mutation io]
(fn (el) (fn (el)
(let ((name (dom-get-attr el "data-sx-island")) (let ((name (dom-get-attr el "data-sx-island"))
(state-json (or (dom-get-attr el "data-sx-state") "{}"))) (state-sx (or (dom-get-attr el "data-sx-state") "{}")))
(let ((comp-name (str "~" name)) (let ((comp-name (str "~" name))
(env (get-render-env nil))) (env (get-render-env nil)))
(let ((comp (env-get env comp-name))) (let ((comp (env-get env comp-name)))
(if (not (or (component? comp) (island? comp))) (if (not (or (component? comp) (island? comp)))
(log-warn (str "hydrate-island: unknown island " comp-name)) (log-warn (str "hydrate-island: unknown island " comp-name))
;; Parse state and build keyword args ;; Parse state and build keyword args — SX format, not JSON
(let ((kwargs (json-parse state-json)) (let ((kwargs (or (first (sx-parse state-sx)) {}))
(disposers (list)) (disposers (list))
(local (env-merge (component-closure comp) env))) (local (env-merge (component-closure comp) env)))
;; Bind params from kwargs ;; Bind params from kwargs
(for-each (for-each
(fn (p) (fn ((p :as string))
(env-set! local p (if (dict-has? kwargs p) (dict-get kwargs p) nil))) (env-set! local p (if (dict-has? kwargs p) (dict-get kwargs p) nil)))
(component-params comp)) (component-params comp))
@@ -381,31 +388,38 @@
;; Island disposal — clean up when island removed from DOM ;; Island disposal — clean up when island removed from DOM
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define dispose-island (define dispose-island :effects [mutation io]
(fn (el) (fn (el)
(let ((disposers (dom-get-data el "sx-disposers"))) (let ((disposers (dom-get-data el "sx-disposers")))
(when disposers (when disposers
(for-each (for-each
(fn (d) (fn ((d :as lambda))
(when (callable? d) (d))) (when (callable? d) (d)))
disposers) disposers)
(dom-set-data el "sx-disposers" nil))))) (dom-set-data el "sx-disposers" nil)))))
(define dispose-islands-in (define dispose-islands-in :effects [mutation io]
(fn (root) (fn (root)
;; Dispose all islands within root before a swap replaces them. ;; Dispose islands within root, but SKIP hydrated islands —
;; they may be preserved across morphs. Only dispose islands
;; that are not currently hydrated (e.g. freshly parsed content
;; being discarded) or that have been explicitly detached.
(when root (when root
(let ((islands (dom-query-all root "[data-sx-island]"))) (let ((islands (dom-query-all root "[data-sx-island]")))
(when (and islands (not (empty? islands))) (when (and islands (not (empty? islands)))
(log-info (str "disposing " (len islands) " island(s)")) (let ((to-dispose (filter
(for-each dispose-island islands)))))) (fn (el) (not (is-processed? el "island-hydrated")))
islands)))
(when (not (empty? to-dispose))
(log-info (str "disposing " (len to-dispose) " island(s)"))
(for-each dispose-island to-dispose))))))))
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; Full boot sequence ;; Full boot sequence
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define boot-init (define boot-init :effects [mutation io]
(fn () (fn ()
;; Full browser initialization: ;; Full browser initialization:
;; 1. CSS tracking ;; 1. CSS tracking
@@ -480,8 +494,8 @@
;; (log-info msg) → void (console.log with prefix) ;; (log-info msg) → void (console.log with prefix)
;; (log-parse-error label text err) → void (diagnostic parse error) ;; (log-parse-error label text err) → void (diagnostic parse error)
;; ;;
;; === JSON === ;; === Parsing (island state) ===
;; (json-parse str) → dict/list/value (JSON.parse) ;; (sx-parse str) → list of AST expressions (from parser.sx)
;; ;;
;; === Processing markers === ;; === Processing markers ===
;; (mark-processed! el key) → void ;; (mark-processed! el key) → void

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

View File

@@ -143,7 +143,7 @@ def _emit_py(suites: list[dict], preamble: list) -> str:
lines.append('') lines.append('')
lines.append('import pytest') lines.append('import pytest')
lines.append('from shared.sx.parser import parse_all') lines.append('from shared.sx.parser import parse_all')
lines.append('from shared.sx.evaluator import _eval, _trampoline') lines.append('from shared.sx.ref.sx_ref import eval_expr as _eval, trampoline as _trampoline')
lines.append('') lines.append('')
lines.append('') lines.append('')
lines.append(f"_PREAMBLE = '''{preamble_escaped}'''") lines.append(f"_PREAMBLE = '''{preamble_escaped}'''")

View File

@@ -12,6 +12,7 @@
;; (define-io-primitive "name" ;; (define-io-primitive "name"
;; :params (param1 param2 &key ...) ;; :params (param1 param2 &key ...)
;; :returns "type" ;; :returns "type"
;; :effects [io]
;; :async true ;; :async true
;; :doc "description" ;; :doc "description"
;; :context :request) ;; :context :request)
@@ -38,6 +39,7 @@
(define-io-primitive "current-user" (define-io-primitive "current-user"
:params () :params ()
:returns "dict?" :returns "dict?"
:effects [io]
:async true :async true
:doc "Current authenticated user dict, or nil." :doc "Current authenticated user dict, or nil."
:context :request) :context :request)
@@ -45,6 +47,7 @@
(define-io-primitive "request-arg" (define-io-primitive "request-arg"
:params (name &rest default) :params (name &rest default)
:returns "any" :returns "any"
:effects [io]
:async true :async true
:doc "Read a query string argument from the current request." :doc "Read a query string argument from the current request."
:context :request) :context :request)
@@ -52,6 +55,7 @@
(define-io-primitive "request-path" (define-io-primitive "request-path"
:params () :params ()
:returns "string" :returns "string"
:effects [io]
:async true :async true
:doc "Current request path." :doc "Current request path."
:context :request) :context :request)
@@ -59,6 +63,7 @@
(define-io-primitive "request-view-args" (define-io-primitive "request-view-args"
:params (key) :params (key)
:returns "any" :returns "any"
:effects [io]
:async true :async true
:doc "Read a URL view argument from the current request." :doc "Read a URL view argument from the current request."
:context :request) :context :request)
@@ -66,6 +71,7 @@
(define-io-primitive "csrf-token" (define-io-primitive "csrf-token"
:params () :params ()
:returns "string" :returns "string"
:effects [io]
:async true :async true
:doc "Current CSRF token string." :doc "Current CSRF token string."
:context :request) :context :request)
@@ -73,6 +79,7 @@
(define-io-primitive "abort" (define-io-primitive "abort"
:params (status &rest message) :params (status &rest message)
:returns "nil" :returns "nil"
:effects [io]
:async true :async true
:doc "Raise HTTP error from SX." :doc "Raise HTTP error from SX."
:context :request) :context :request)
@@ -82,6 +89,7 @@
(define-io-primitive "url-for" (define-io-primitive "url-for"
:params (endpoint &key) :params (endpoint &key)
:returns "string" :returns "string"
:effects [io]
:async true :async true
:doc "Generate URL for a named endpoint." :doc "Generate URL for a named endpoint."
:context :request) :context :request)
@@ -89,6 +97,7 @@
(define-io-primitive "route-prefix" (define-io-primitive "route-prefix"
:params () :params ()
:returns "string" :returns "string"
:effects [io]
:async true :async true
:doc "Service URL prefix for dev/prod routing." :doc "Service URL prefix for dev/prod routing."
:context :request) :context :request)
@@ -98,6 +107,7 @@
(define-io-primitive "app-url" (define-io-primitive "app-url"
:params (service &rest path) :params (service &rest path)
:returns "string" :returns "string"
:effects [io]
:async false :async false
:doc "Full URL for a service: (app-url \"blog\" \"/my-post/\")." :doc "Full URL for a service: (app-url \"blog\" \"/my-post/\")."
:context :config) :context :config)
@@ -105,6 +115,7 @@
(define-io-primitive "asset-url" (define-io-primitive "asset-url"
:params (&rest path) :params (&rest path)
:returns "string" :returns "string"
:effects [io]
:async false :async false
:doc "Versioned static asset URL." :doc "Versioned static asset URL."
:context :config) :context :config)
@@ -112,6 +123,7 @@
(define-io-primitive "config" (define-io-primitive "config"
:params (key) :params (key)
:returns "any" :returns "any"
:effects [io]
:async false :async false
:doc "Read a value from host configuration." :doc "Read a value from host configuration."
:context :config) :context :config)
@@ -126,6 +138,124 @@
"list" "dict" "sx-source")) "list" "dict" "sx-source"))
;; --------------------------------------------------------------------------
;; Web interop — reading non-SX request formats
;;
;; SX's native wire format is SX (text/sx). These primitives bridge to
;; legacy web formats: HTML form encoding, JSON bodies, HTTP headers.
;; They're useful for interop but not fundamental to SX-to-SX communication.
;; --------------------------------------------------------------------------
(define-io-primitive "now"
:params (&rest format)
:returns "string"
:async true
:doc "Current timestamp. Optional format string (strftime). Default ISO 8601."
:context :request)
(define-io-primitive "sleep"
:params (ms)
:returns "nil"
:async true
:doc "Pause execution for ms milliseconds. For demos and testing."
:context :request)
(define-io-primitive "request-form"
:params (name &rest default)
:returns "any"
:async true
:doc "Read a form field from a POST/PUT/PATCH request body."
:context :request)
(define-io-primitive "request-json"
:params ()
:returns "dict?"
:async true
:doc "Read JSON body from the current request, or nil if not JSON."
:context :request)
(define-io-primitive "request-header"
:params (name &rest default)
:returns "string?"
:async true
:doc "Read a request header value by name."
:context :request)
(define-io-primitive "request-content-type"
:params ()
:returns "string?"
:async true
:doc "Content-Type of the current request."
:context :request)
(define-io-primitive "request-args-all"
:params ()
:returns "dict"
:async true
:doc "All query string parameters as a dict."
:context :request)
(define-io-primitive "request-form-all"
:params ()
:returns "dict"
:async true
:doc "All form fields as a dict."
:context :request)
(define-io-primitive "request-form-list"
:params (field-name)
:returns "list"
:async true
:doc "All values for a multi-value form field as a list."
:context :request)
(define-io-primitive "request-headers-all"
:params ()
:returns "dict"
:async true
:doc "All request headers as a dict (lowercase keys)."
:context :request)
(define-io-primitive "request-file-name"
:params (field-name)
:returns "string?"
:async true
:doc "Filename of an uploaded file by field name, or nil."
:context :request)
;; Response manipulation
(define-io-primitive "set-response-header"
:params (name value)
:returns "nil"
:async true
:doc "Set a response header. Applied after handler returns."
:context :request)
(define-io-primitive "set-response-status"
:params (status)
:returns "nil"
:async true
:doc "Set the HTTP response status code. Applied after handler returns."
:context :request)
;; Ephemeral state — per-process, resets on restart
(define-io-primitive "state-get"
:params (key &rest default)
:returns "any"
:async true
:doc "Read from ephemeral per-process state dict."
:context :request)
(define-io-primitive "state-set!"
:params (key value)
:returns "nil"
:async true
:doc "Write to ephemeral per-process state dict."
:context :request)
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; Tier 3: Signal primitives — reactive state for islands ;; Tier 3: Signal primitives — reactive state for islands
;; ;;
@@ -138,11 +268,13 @@
(declare-signal-primitive "signal" (declare-signal-primitive "signal"
:params (initial-value) :params (initial-value)
:returns "signal" :returns "signal"
:effects []
:doc "Create a reactive signal container with an initial value.") :doc "Create a reactive signal container with an initial value.")
(declare-signal-primitive "deref" (declare-signal-primitive "deref"
:params (signal) :params (signal)
:returns "any" :returns "any"
:effects []
:doc "Read a signal's current value. In a reactive context (inside an island), :doc "Read a signal's current value. In a reactive context (inside an island),
subscribes the current DOM binding to the signal. Outside reactive subscribes the current DOM binding to the signal. Outside reactive
context, just returns the value.") context, just returns the value.")
@@ -150,23 +282,27 @@
(declare-signal-primitive "reset!" (declare-signal-primitive "reset!"
:params (signal value) :params (signal value)
:returns "nil" :returns "nil"
:effects [mutation]
:doc "Set a signal to a new value. Notifies all subscribers.") :doc "Set a signal to a new value. Notifies all subscribers.")
(declare-signal-primitive "swap!" (declare-signal-primitive "swap!"
:params (signal f &rest args) :params (signal f &rest args)
:returns "nil" :returns "nil"
:effects [mutation]
:doc "Update a signal by applying f to its current value. (swap! s inc) :doc "Update a signal by applying f to its current value. (swap! s inc)
is equivalent to (reset! s (inc (deref s))) but atomic.") is equivalent to (reset! s (inc (deref s))) but atomic.")
(declare-signal-primitive "computed" (declare-signal-primitive "computed"
:params (compute-fn) :params (compute-fn)
:returns "signal" :returns "signal"
:effects []
:doc "Create a derived signal that recomputes when its dependencies change. :doc "Create a derived signal that recomputes when its dependencies change.
Dependencies are discovered automatically by tracking deref calls.") Dependencies are discovered automatically by tracking deref calls.")
(declare-signal-primitive "effect" (declare-signal-primitive "effect"
:params (effect-fn) :params (effect-fn)
:returns "lambda" :returns "lambda"
:effects [mutation]
:doc "Run a side effect that re-runs when its signal dependencies change. :doc "Run a side effect that re-runs when its signal dependencies change.
Returns a dispose function. If the effect function returns a function, Returns a dispose function. If the effect function returns a function,
it is called as cleanup before the next run.") it is called as cleanup before the next run.")
@@ -174,5 +310,6 @@
(declare-signal-primitive "batch" (declare-signal-primitive "batch"
:params (thunk) :params (thunk)
:returns "any" :returns "any"
:effects [mutation]
:doc "Group multiple signal writes. Subscribers are notified once at the end, :doc "Group multiple signal writes. Subscribers are notified once at the end,
after all values have been updated.") after all values have been updated.")

View File

@@ -169,6 +169,83 @@ def parse_primitives_by_module() -> dict[str, frozenset[str]]:
return {mod: frozenset(names) for mod, names in modules.items()} return {mod: frozenset(names) for mod, names in modules.items()}
def _parse_param_type(param) -> tuple[str, str | None, bool]:
"""Parse a single param entry from a :params list.
Returns (name, type_or_none, is_rest).
A bare symbol like ``x`` → ("x", None, False).
A typed form ``(x :as number)`` → ("x", "number", False).
The ``&rest`` marker is tracked externally.
"""
if isinstance(param, Symbol):
return (param.name, None, False)
if isinstance(param, list) and len(param) == 3:
# (name :as type)
name_sym, kw, type_val = param
if (isinstance(name_sym, Symbol)
and isinstance(kw, Keyword) and kw.name == "as"):
type_str = type_val.name if isinstance(type_val, Symbol) else str(type_val)
return (name_sym.name, type_str, False)
return (str(param), None, False)
def parse_primitive_param_types() -> dict[str, dict]:
"""Parse primitives.sx and extract param type info for each primitive.
Returns a dict mapping primitive name to param type descriptor::
{
"+": {"positional": [], "rest_type": "number"},
"/": {"positional": [("a", "number"), ("b", "number")], "rest_type": None},
"get": {"positional": [("coll", None), ("key", None)], "rest_type": None},
}
Each positional entry is (name, type_or_none). rest_type is the
type of the &rest parameter (or None if no &rest, or None if untyped &rest).
"""
source = _read_file("primitives.sx")
exprs = parse_all(source)
result: dict[str, dict] = {}
for expr in exprs:
if not isinstance(expr, list) or len(expr) < 2:
continue
if not isinstance(expr[0], Symbol) or expr[0].name != "define-primitive":
continue
name = expr[1]
if not isinstance(name, str):
continue
params_list = _extract_keyword_arg(expr, "params")
if not isinstance(params_list, list):
continue
positional: list[tuple[str, str | None]] = []
rest_type: str | None = None
i = 0
while i < len(params_list):
item = params_list[i]
if isinstance(item, Symbol) and item.name == "&rest":
# Next item is the rest param
if i + 1 < len(params_list):
rname, rtype, _ = _parse_param_type(params_list[i + 1])
rest_type = rtype
i += 2
else:
pname, ptype, _ = _parse_param_type(item)
if pname != "&rest":
positional.append((pname, ptype))
i += 1
# Only store if at least one param has a type
has_types = rest_type is not None or any(t is not None for _, t in positional)
if has_types:
result[name] = {"positional": positional, "rest_type": rest_type}
return result
def parse_boundary_sx() -> tuple[frozenset[str], dict[str, frozenset[str]]]: def parse_boundary_sx() -> tuple[frozenset[str], dict[str, frozenset[str]]]:
"""Parse all boundary sources and return (io_names, {service: helper_names}). """Parse all boundary sources and return (io_names, {service: helper_names}).

View File

@@ -82,7 +82,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define sf-reset (define sf-reset
(fn (args env) (fn ((args :as list) (env :as dict))
;; Single argument: the body expression. ;; Single argument: the body expression.
;; Install a continuation delimiter, then evaluate body. ;; Install a continuation delimiter, then evaluate body.
;; The implementation is target-specific: ;; The implementation is target-specific:
@@ -136,7 +136,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define sf-shift (define sf-shift
(fn (args env) (fn ((args :as list) (env :as dict))
;; Two arguments: the continuation variable name, and the body. ;; Two arguments: the continuation variable name, and the body.
(let ((k-name (symbol-name (first args))) (let ((k-name (symbol-name (first args)))
(body (second args))) (body (second args)))

View File

@@ -31,15 +31,15 @@
;; Walks all branches of control flow (if/when/cond/case) to find ;; Walks all branches of control flow (if/when/cond/case) to find
;; every component that *could* be rendered. ;; every component that *could* be rendered.
(define scan-refs (define scan-refs :effects []
(fn (node) (fn (node)
(let ((refs (list))) (let ((refs (list)))
(scan-refs-walk node refs) (scan-refs-walk node refs)
refs))) refs)))
(define scan-refs-walk (define scan-refs-walk :effects []
(fn (node refs) (fn (node (refs :as list))
(cond (cond
;; Symbol starting with ~ → component reference ;; Symbol starting with ~ → component reference
(= (type-of node) "symbol") (= (type-of node) "symbol")
@@ -67,27 +67,27 @@
;; Given a component name and an environment, compute all components ;; Given a component name and an environment, compute all components
;; that it can transitively render. Handles cycles via seen-set. ;; that it can transitively render. Handles cycles via seen-set.
(define transitive-deps-walk (define transitive-deps-walk :effects []
(fn (n seen env) (fn ((n :as string) (seen :as list) (env :as dict))
(when (not (contains? seen n)) (when (not (contains? seen n))
(append! seen n) (append! seen n)
(let ((val (env-get env n))) (let ((val (env-get env n)))
(cond (cond
(= (type-of val) "component") (= (type-of val) "component")
(for-each (fn (ref) (transitive-deps-walk ref seen env)) (for-each (fn ((ref :as string)) (transitive-deps-walk ref seen env))
(scan-refs (component-body val))) (scan-refs (component-body val)))
(= (type-of val) "macro") (= (type-of val) "macro")
(for-each (fn (ref) (transitive-deps-walk ref seen env)) (for-each (fn ((ref :as string)) (transitive-deps-walk ref seen env))
(scan-refs (macro-body val))) (scan-refs (macro-body val)))
:else nil))))) :else nil)))))
(define transitive-deps (define transitive-deps :effects []
(fn (name env) (fn ((name :as string) (env :as dict))
(let ((seen (list)) (let ((seen (list))
(key (if (starts-with? name "~") name (str "~" name)))) (key (if (starts-with? name "~") name (str "~" name))))
(transitive-deps-walk key seen env) (transitive-deps-walk key seen env)
(filter (fn (x) (not (= x key))) seen)))) (filter (fn ((x :as string)) (not (= x key))) seen))))
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
@@ -100,10 +100,10 @@
;; (env-components env) → list of component names in env ;; (env-components env) → list of component names in env
;; (component-set-deps! comp deps) → store deps on component ;; (component-set-deps! comp deps) → store deps on component
(define compute-all-deps (define compute-all-deps :effects [mutation]
(fn (env) (fn ((env :as dict))
(for-each (for-each
(fn (name) (fn ((name :as string))
(let ((val (env-get env name))) (let ((val (env-get env name)))
(when (= (type-of val) "component") (when (= (type-of val) "component")
(component-set-deps! val (transitive-deps name env))))) (component-set-deps! val (transitive-deps name env)))))
@@ -119,10 +119,10 @@
;; Platform interface: ;; Platform interface:
;; (regex-find-all pattern source) → list of matched group strings ;; (regex-find-all pattern source) → list of matched group strings
(define scan-components-from-source (define scan-components-from-source :effects []
(fn (source) (fn ((source :as string))
(let ((matches (regex-find-all "\\(~([a-zA-Z_][a-zA-Z0-9_\\-]*)" source))) (let ((matches (regex-find-all "\\(~([a-zA-Z_][a-zA-Z0-9_\\-]*)" source)))
(map (fn (m) (str "~" m)) matches)))) (map (fn ((m :as string)) (str "~" m)) matches))))
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
@@ -131,14 +131,14 @@
;; Scans page source for direct component references, then computes ;; Scans page source for direct component references, then computes
;; the transitive closure. Returns list of ~names. ;; the transitive closure. Returns list of ~names.
(define components-needed (define components-needed :effects []
(fn (page-source env) (fn ((page-source :as string) (env :as dict))
(let ((direct (scan-components-from-source page-source)) (let ((direct (scan-components-from-source page-source))
(all-needed (list))) (all-needed (list)))
;; Add each direct ref + its transitive deps ;; Add each direct ref + its transitive deps
(for-each (for-each
(fn (name) (fn ((name :as string))
(when (not (contains? all-needed name)) (when (not (contains? all-needed name))
(append! all-needed name)) (append! all-needed name))
(let ((val (env-get env name))) (let ((val (env-get env name)))
@@ -147,7 +147,7 @@
(component-deps val) (component-deps val)
(transitive-deps name env)))) (transitive-deps name env))))
(for-each (for-each
(fn (dep) (fn ((dep :as string))
(when (not (contains? all-needed dep)) (when (not (contains? all-needed dep))
(append! all-needed dep))) (append! all-needed dep)))
deps)))) deps))))
@@ -165,8 +165,8 @@
;; ;;
;; This replaces the "send everything" approach with per-page bundles. ;; This replaces the "send everything" approach with per-page bundles.
(define page-component-bundle (define page-component-bundle :effects []
(fn (page-source env) (fn ((page-source :as string) (env :as dict))
(components-needed page-source env))) (components-needed page-source env)))
@@ -180,18 +180,18 @@
;; (component-css-classes c) → set/list of class strings ;; (component-css-classes c) → set/list of class strings
;; (scan-css-classes source) → set/list of class strings from source ;; (scan-css-classes source) → set/list of class strings from source
(define page-css-classes (define page-css-classes :effects []
(fn (page-source env) (fn ((page-source :as string) (env :as dict))
(let ((needed (components-needed page-source env)) (let ((needed (components-needed page-source env))
(classes (list))) (classes (list)))
;; Collect classes from needed components ;; Collect classes from needed components
(for-each (for-each
(fn (name) (fn ((name :as string))
(let ((val (env-get env name))) (let ((val (env-get env name)))
(when (= (type-of val) "component") (when (= (type-of val) "component")
(for-each (for-each
(fn (cls) (fn ((cls :as string))
(when (not (contains? classes cls)) (when (not (contains? classes cls))
(append! classes cls))) (append! classes cls)))
(component-css-classes val))))) (component-css-classes val)))))
@@ -199,7 +199,7 @@
;; Add classes from page source ;; Add classes from page source
(for-each (for-each
(fn (cls) (fn ((cls :as string))
(when (not (contains? classes cls)) (when (not (contains? classes cls))
(append! classes cls))) (append! classes cls)))
(scan-css-classes page-source)) (scan-css-classes page-source))
@@ -218,8 +218,8 @@
;; (component-io-refs c) → cached IO ref list (may be empty) ;; (component-io-refs c) → cached IO ref list (may be empty)
;; (component-set-io-refs! c r) → cache IO refs on component ;; (component-set-io-refs! c r) → cache IO refs on component
(define scan-io-refs-walk (define scan-io-refs-walk :effects []
(fn (node io-names refs) (fn (node (io-names :as list) (refs :as list))
(cond (cond
;; Symbol → check if name is in the IO set ;; Symbol → check if name is in the IO set
(= (type-of node) "symbol") (= (type-of node) "symbol")
@@ -241,8 +241,8 @@
:else nil))) :else nil)))
(define scan-io-refs (define scan-io-refs :effects []
(fn (node io-names) (fn (node (io-names :as list))
(let ((refs (list))) (let ((refs (list)))
(scan-io-refs-walk node io-names refs) (scan-io-refs-walk node io-names refs)
refs))) refs)))
@@ -252,8 +252,8 @@
;; 9. Transitive IO refs — follow component deps and union IO refs ;; 9. Transitive IO refs — follow component deps and union IO refs
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define transitive-io-refs-walk (define transitive-io-refs-walk :effects []
(fn (n seen all-refs env io-names) (fn ((n :as string) (seen :as list) (all-refs :as list) (env :as dict) (io-names :as list))
(when (not (contains? seen n)) (when (not (contains? seen n))
(append! seen n) (append! seen n)
(let ((val (env-get env n))) (let ((val (env-get env n)))
@@ -262,31 +262,31 @@
(do (do
;; Scan this component's body for IO refs ;; Scan this component's body for IO refs
(for-each (for-each
(fn (ref) (fn ((ref :as string))
(when (not (contains? all-refs ref)) (when (not (contains? all-refs ref))
(append! all-refs ref))) (append! all-refs ref)))
(scan-io-refs (component-body val) io-names)) (scan-io-refs (component-body val) io-names))
;; Recurse into component deps ;; Recurse into component deps
(for-each (for-each
(fn (dep) (transitive-io-refs-walk dep seen all-refs env io-names)) (fn ((dep :as string)) (transitive-io-refs-walk dep seen all-refs env io-names))
(scan-refs (component-body val)))) (scan-refs (component-body val))))
(= (type-of val) "macro") (= (type-of val) "macro")
(do (do
(for-each (for-each
(fn (ref) (fn ((ref :as string))
(when (not (contains? all-refs ref)) (when (not (contains? all-refs ref))
(append! all-refs ref))) (append! all-refs ref)))
(scan-io-refs (macro-body val) io-names)) (scan-io-refs (macro-body val) io-names))
(for-each (for-each
(fn (dep) (transitive-io-refs-walk dep seen all-refs env io-names)) (fn ((dep :as string)) (transitive-io-refs-walk dep seen all-refs env io-names))
(scan-refs (macro-body val)))) (scan-refs (macro-body val))))
:else nil))))) :else nil)))))
(define transitive-io-refs (define transitive-io-refs :effects []
(fn (name env io-names) (fn ((name :as string) (env :as dict) (io-names :as list))
(let ((all-refs (list)) (let ((all-refs (list))
(seen (list)) (seen (list))
(key (if (starts-with? name "~") name (str "~" name)))) (key (if (starts-with? name "~") name (str "~" name))))
@@ -298,19 +298,37 @@
;; 10. Compute IO refs for all components in an environment ;; 10. Compute IO refs for all components in an environment
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define compute-all-io-refs (define compute-all-io-refs :effects [mutation]
(fn (env io-names) (fn ((env :as dict) (io-names :as list))
(for-each (for-each
(fn (name) (fn ((name :as string))
(let ((val (env-get env name))) (let ((val (env-get env name)))
(when (= (type-of val) "component") (when (= (type-of val) "component")
(component-set-io-refs! val (transitive-io-refs name env io-names))))) (component-set-io-refs! val (transitive-io-refs name env io-names)))))
(env-components env)))) (env-components env))))
(define component-pure? (define component-io-refs-cached :effects []
(fn (name env io-names) (fn ((name :as string) (env :as dict) (io-names :as list))
(empty? (transitive-io-refs name env io-names)))) (let ((key (if (starts-with? name "~") name (str "~" name))))
(let ((val (env-get env key)))
(if (and (= (type-of val) "component")
(not (nil? (component-io-refs val)))
(not (empty? (component-io-refs val))))
(component-io-refs val)
;; Fallback: not yet cached (shouldn't happen after compute-all-io-refs)
(transitive-io-refs name env io-names))))))
(define component-pure? :effects []
(fn ((name :as string) (env :as dict) (io-names :as list))
(let ((key (if (starts-with? name "~") name (str "~" name))))
(let ((val (env-get env key)))
(if (and (= (type-of val) "component")
(not (nil? (component-io-refs val))))
;; Use cached io-refs (empty list = pure)
(empty? (component-io-refs val))
;; Fallback
(empty? (transitive-io-refs name env io-names)))))))
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
@@ -325,8 +343,8 @@
;; ;;
;; Returns: "server" | "client" ;; Returns: "server" | "client"
(define render-target (define render-target :effects []
(fn (name env io-names) (fn ((name :as string) (env :as dict) (io-names :as list))
(let ((key (if (starts-with? name "~") name (str "~" name)))) (let ((key (if (starts-with? name "~") name (str "~" name))))
(let ((val (env-get env key))) (let ((val (env-get env key)))
(if (not (= (type-of val) "component")) (if (not (= (type-of val) "component"))
@@ -354,8 +372,8 @@
;; The async evaluator and client router both use it to make decisions ;; The async evaluator and client router both use it to make decisions
;; without recomputing at every request. ;; without recomputing at every request.
(define page-render-plan (define page-render-plan :effects []
(fn (page-source env io-names) (fn ((page-source :as string) (env :as dict) (io-names :as list))
(let ((needed (components-needed page-source env)) (let ((needed (components-needed page-source env))
(comp-targets (dict)) (comp-targets (dict))
(server-list (list)) (server-list (list))
@@ -363,18 +381,18 @@
(io-deps (list))) (io-deps (list)))
(for-each (for-each
(fn (name) (fn ((name :as string))
(let ((target (render-target name env io-names))) (let ((target (render-target name env io-names)))
(dict-set! comp-targets name target) (dict-set! comp-targets name target)
(if (= target "server") (if (= target "server")
(do (do
(append! server-list name) (append! server-list name)
;; Collect IO deps from server components ;; Collect IO deps from server components (use cache)
(for-each (for-each
(fn (io-ref) (fn ((io-ref :as string))
(when (not (contains? io-deps io-ref)) (when (not (contains? io-deps io-ref))
(append! io-deps io-ref))) (append! io-deps io-ref)))
(transitive-io-refs name env io-names))) (component-io-refs-cached name env io-names)))
(append! client-list name)))) (append! client-list name))))
needed) needed)
@@ -432,10 +450,10 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; Moved from platform to spec: pure logic using type predicates. ;; Moved from platform to spec: pure logic using type predicates.
(define env-components (define env-components :effects []
(fn (env) (fn ((env :as dict))
(filter (filter
(fn (k) (fn ((k :as string))
(let ((v (env-get env k))) (let ((v (env-get env k)))
(or (component? v) (macro? v)))) (or (component? v) (macro? v))))
(keys env)))) (keys env))))

View File

@@ -31,18 +31,19 @@
;; Parses the sx-trigger attribute value into a list of trigger descriptors. ;; Parses the sx-trigger attribute value into a list of trigger descriptors.
;; Each descriptor is a dict with "event" and "modifiers" keys. ;; Each descriptor is a dict with "event" and "modifiers" keys.
(define parse-time (define parse-time :effects []
(fn (s) (fn ((s :as string))
;; Parse time string: "2s" → 2000, "500ms" → 500 ;; Parse time string: "2s" → 2000, "500ms" → 500
(cond ;; Uses nested if (not cond) because cond misclassifies 2-element
(nil? s) 0 ;; function calls like (nil? s) as scheme-style ((test body)) clauses.
(ends-with? s "ms") (parse-int s 0) (if (nil? s) 0
(ends-with? s "s") (* (parse-int (replace s "s" "") 0) 1000) (if (ends-with? s "ms") (parse-int s 0)
:else (parse-int s 0)))) (if (ends-with? s "s") (* (parse-int (replace s "s" "") 0) 1000)
(parse-int s 0))))))
(define parse-trigger-spec (define parse-trigger-spec :effects []
(fn (spec) (fn ((spec :as string))
;; Parse "click delay:500ms once,change" → list of trigger descriptors ;; Parse "click delay:500ms once,change" → list of trigger descriptors
(if (nil? spec) (if (nil? spec)
nil nil
@@ -50,7 +51,7 @@
(filter (filter
(fn (x) (not (nil? x))) (fn (x) (not (nil? x)))
(map (map
(fn (part) (fn ((part :as string))
(let ((tokens (split (trim part) " "))) (let ((tokens (split (trim part) " ")))
(if (empty? tokens) (if (empty? tokens)
nil nil
@@ -62,7 +63,7 @@
;; Normal trigger with optional modifiers ;; Normal trigger with optional modifiers
(let ((mods (dict))) (let ((mods (dict)))
(for-each (for-each
(fn (tok) (fn ((tok :as string))
(cond (cond
(= tok "once") (= tok "once")
(dict-set! mods "once" true) (dict-set! mods "once" true)
@@ -79,8 +80,8 @@
raw-parts)))))) raw-parts))))))
(define default-trigger (define default-trigger :effects []
(fn (tag-name) (fn ((tag-name :as string))
;; Default trigger for element type ;; Default trigger for element type
(cond (cond
(= tag-name "FORM") (= tag-name "FORM")
@@ -97,11 +98,11 @@
;; Verb extraction ;; Verb extraction
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define get-verb-info (define get-verb-info :effects [io]
(fn (el) (fn (el)
;; Check element for sx-get, sx-post, etc. Returns (dict "method" "url") or nil. ;; Check element for sx-get, sx-post, etc. Returns (dict "method" "url") or nil.
(some (some
(fn (verb) (fn ((verb :as string))
(let ((url (dom-get-attr el (str "sx-" verb)))) (let ((url (dom-get-attr el (str "sx-" verb))))
(if url (if url
(dict "method" (upper verb) "url" url) (dict "method" (upper verb) "url" url)
@@ -113,8 +114,8 @@
;; Request header building ;; Request header building
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define build-request-headers (define build-request-headers :effects [io]
(fn (el loaded-components css-hash) (fn (el (loaded-components :as list) (css-hash :as string))
;; Build the SX request headers dict ;; Build the SX request headers dict
(let ((headers (dict (let ((headers (dict
"SX-Request" "true" "SX-Request" "true"
@@ -139,7 +140,7 @@
(let ((parsed (parse-header-value extra-h))) (let ((parsed (parse-header-value extra-h)))
(when parsed (when parsed
(for-each (for-each
(fn (key) (dict-set! headers key (str (get parsed key)))) (fn ((key :as string)) (dict-set! headers key (str (get parsed key))))
(keys parsed)))))) (keys parsed))))))
headers))) headers)))
@@ -149,8 +150,8 @@
;; Response header processing ;; Response header processing
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define process-response-headers (define process-response-headers :effects []
(fn (get-header) (fn ((get-header :as lambda))
;; Extract all SX response header directives into a dict. ;; Extract all SX response header directives into a dict.
;; get-header is (fn (name) → string or nil). ;; get-header is (fn (name) → string or nil).
(dict (dict
@@ -173,14 +174,14 @@
;; Swap specification parsing ;; Swap specification parsing
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define parse-swap-spec (define parse-swap-spec :effects []
(fn (raw-swap global-transitions?) (fn ((raw-swap :as string) (global-transitions? :as boolean))
;; Parse "innerHTML transition:true" → dict with style + transition flag ;; Parse "innerHTML transition:true" → dict with style + transition flag
(let ((parts (split (or raw-swap DEFAULT_SWAP) " ")) (let ((parts (split (or raw-swap DEFAULT_SWAP) " "))
(style (first parts)) (style (first parts))
(use-transition global-transitions?)) (use-transition global-transitions?))
(for-each (for-each
(fn (p) (fn ((p :as string))
(cond (cond
(= p "transition:true") (set! use-transition true) (= p "transition:true") (set! use-transition true)
(= p "transition:false") (set! use-transition false))) (= p "transition:false") (set! use-transition false)))
@@ -192,8 +193,8 @@
;; Retry logic ;; Retry logic
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define parse-retry-spec (define parse-retry-spec :effects []
(fn (retry-attr) (fn ((retry-attr :as string))
;; Parse "exponential:1000:30000" → spec dict or nil ;; Parse "exponential:1000:30000" → spec dict or nil
(if (nil? retry-attr) (if (nil? retry-attr)
nil nil
@@ -204,8 +205,8 @@
"cap-ms" (parse-int (nth parts 2) 30000)))))) "cap-ms" (parse-int (nth parts 2) 30000))))))
(define next-retry-ms (define next-retry-ms :effects []
(fn (current-ms cap-ms) (fn ((current-ms :as number) (cap-ms :as number))
;; Exponential backoff: double current, cap at max ;; Exponential backoff: double current, cap at max
(min (* current-ms 2) cap-ms))) (min (* current-ms 2) cap-ms)))
@@ -214,32 +215,31 @@
;; Form parameter filtering ;; Form parameter filtering
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define filter-params (define filter-params :effects []
(fn (params-spec all-params) (fn ((params-spec :as string) (all-params :as list))
;; Filter form parameters by sx-params spec. ;; Filter form parameters by sx-params spec.
;; all-params is a list of (key value) pairs. ;; all-params is a list of (key value) pairs.
;; Returns filtered list of (key value) pairs. ;; Returns filtered list of (key value) pairs.
(cond ;; Uses nested if (not cond) — see parse-time comment.
(nil? params-spec) all-params (if (nil? params-spec) all-params
(= params-spec "none") (list) (if (= params-spec "none") (list)
(= params-spec "*") all-params (if (= params-spec "*") all-params
(starts-with? params-spec "not ") (if (starts-with? params-spec "not ")
(let ((excluded (map trim (split (slice params-spec 4) ",")))) (let ((excluded (map trim (split (slice params-spec 4) ","))))
(filter (filter
(fn (p) (not (contains? excluded (first p)))) (fn ((p :as list)) (not (contains? excluded (first p))))
all-params)) all-params))
:else (let ((allowed (map trim (split params-spec ","))))
(let ((allowed (map trim (split params-spec ",")))) (filter
(filter (fn ((p :as list)) (contains? allowed (first p)))
(fn (p) (contains? allowed (first p))) all-params))))))))
all-params)))))
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; Target resolution ;; Target resolution
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define resolve-target (define resolve-target :effects [io]
(fn (el) (fn (el)
;; Resolve the swap target for an element ;; Resolve the swap target for an element
(let ((sel (dom-get-attr el "sx-target"))) (let ((sel (dom-get-attr el "sx-target")))
@@ -253,7 +253,7 @@
;; Optimistic updates ;; Optimistic updates
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define apply-optimistic (define apply-optimistic :effects [mutation io]
(fn (el) (fn (el)
;; Apply optimistic update preview. Returns state for reverting, or nil. ;; Apply optimistic update preview. Returns state for reverting, or nil.
(let ((directive (dom-get-attr el "sx-optimistic"))) (let ((directive (dom-get-attr el "sx-optimistic")))
@@ -278,8 +278,8 @@
state))))) state)))))
(define revert-optimistic (define revert-optimistic :effects [mutation io]
(fn (state) (fn ((state :as dict))
;; Revert an optimistic update ;; Revert an optimistic update
(when state (when state
(let ((target (get state "target")) (let ((target (get state "target"))
@@ -299,13 +299,13 @@
;; Out-of-band swap identification ;; Out-of-band swap identification
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define find-oob-swaps (define find-oob-swaps :effects [mutation io]
(fn (container) (fn (container)
;; Find elements marked for out-of-band swapping. ;; Find elements marked for out-of-band swapping.
;; Returns list of (dict "element" el "swap-type" type "target-id" id). ;; Returns list of (dict "element" el "swap-type" type "target-id" id).
(let ((results (list))) (let ((results (list)))
(for-each (for-each
(fn (attr) (fn ((attr :as string))
(let ((oob-els (dom-query-all container (str "[" attr "]")))) (let ((oob-els (dom-query-all container (str "[" attr "]"))))
(for-each (for-each
(fn (oob) (fn (oob)
@@ -329,7 +329,7 @@
;; preserving event listeners, focus, scroll position, and form state ;; preserving event listeners, focus, scroll position, and form state
;; on keyed (id) elements. ;; on keyed (id) elements.
(define morph-node (define morph-node :effects [mutation io]
(fn (old-node new-node) (fn (old-node new-node)
;; Morph old-node to match new-node, preserving listeners/state. ;; Morph old-node to match new-node, preserving listeners/state.
(cond (cond
@@ -338,6 +338,18 @@
(dom-has-attr? old-node "sx-ignore")) (dom-has-attr? old-node "sx-ignore"))
nil nil
;; Hydrated island → preserve reactive state, morph lakes.
;; If old and new are the same island (by name), keep the old DOM
;; with its live signals, effects, and event listeners intact.
;; But recurse into data-sx-lake slots so the server can update
;; non-reactive content within the island.
(and (dom-has-attr? old-node "data-sx-island")
(is-processed? old-node "island-hydrated")
(dom-has-attr? new-node "data-sx-island")
(= (dom-get-attr old-node "data-sx-island")
(dom-get-attr new-node "data-sx-island")))
(morph-island-children old-node new-node)
;; Different node type or tag → replace wholesale ;; Different node type or tag → replace wholesale
(or (not (= (dom-node-type old-node) (dom-node-type new-node))) (or (not (= (dom-node-type old-node) (dom-node-type new-node)))
(not (= (dom-node-name old-node) (dom-node-name new-node)))) (not (= (dom-node-name old-node) (dom-node-name new-node))))
@@ -359,24 +371,34 @@
(morph-children old-node new-node)))))) (morph-children old-node new-node))))))
(define sync-attrs (define sync-attrs :effects [mutation io]
(fn (old-el new-el) (fn (old-el new-el)
;; Add/update attributes from new, remove those not in new ;; Sync attributes from new to old, but skip reactively managed attrs.
(for-each ;; data-sx-reactive-attrs="style,class" means those attrs are owned by
(fn (attr) ;; signal effects and must not be overwritten by the morph.
(let ((name (first attr)) (let ((ra-str (or (dom-get-attr old-el "data-sx-reactive-attrs") ""))
(val (nth attr 1))) (reactive-attrs (if (empty? ra-str) (list) (split ra-str ","))))
(when (not (= (dom-get-attr old-el name) val)) ;; Add/update attributes from new, skip reactive ones
(dom-set-attr old-el name val)))) (for-each
(dom-attr-list new-el)) (fn ((attr :as list))
(for-each (let ((name (first attr))
(fn (attr) (val (nth attr 1)))
(when (not (dom-has-attr? new-el (first attr))) (when (and (not (= (dom-get-attr old-el name) val))
(dom-remove-attr old-el (first attr)))) (not (contains? reactive-attrs name)))
(dom-attr-list old-el)))) (dom-set-attr old-el name val))))
(dom-attr-list new-el))
;; Remove attributes not in new, skip reactive + marker attrs
(for-each
(fn ((attr :as list))
(let ((aname (first attr)))
(when (and (not (dom-has-attr? new-el aname))
(not (contains? reactive-attrs aname))
(not (= aname "data-sx-reactive-attrs")))
(dom-remove-attr old-el aname))))
(dom-attr-list old-el)))))
(define morph-children (define morph-children :effects [mutation io]
(fn (old-parent new-parent) (fn (old-parent new-parent)
;; Reconcile children of old-parent to match new-parent. ;; Reconcile children of old-parent to match new-parent.
;; Keyed elements (with id) are matched and moved in-place. ;; Keyed elements (with id) are matched and moved in-place.
@@ -384,7 +406,7 @@
(new-kids (dom-child-list new-parent)) (new-kids (dom-child-list new-parent))
;; Build ID map of old children for keyed matching ;; Build ID map of old children for keyed matching
(old-by-id (reduce (old-by-id (reduce
(fn (acc kid) (fn ((acc :as dict) kid)
(let ((id (dom-id kid))) (let ((id (dom-id kid)))
(if id (do (dict-set! acc id kid) acc) acc))) (if id (do (dict-set! acc id kid) acc) acc)))
(dict) old-kids)) (dict) old-kids))
@@ -425,7 +447,7 @@
;; Remove leftover old children ;; Remove leftover old children
(for-each (for-each
(fn (i) (fn ((i :as number))
(when (>= i oi) (when (>= i oi)
(let ((leftover (nth old-kids i))) (let ((leftover (nth old-kids i)))
(when (and (dom-is-child-of? leftover old-parent) (when (and (dom-is-child-of? leftover old-parent)
@@ -435,12 +457,127 @@
(range oi (len old-kids)))))) (range oi (len old-kids))))))
;; --------------------------------------------------------------------------
;; morph-island-children — deep morph into hydrated islands via lakes
;; --------------------------------------------------------------------------
;;
;; Level 2-3 island morphing: the server can update non-reactive content
;; within hydrated islands by morphing data-sx-lake slots.
;;
;; The island's reactive DOM (signals, effects, event listeners) is preserved.
;; Only lake slots — explicitly marked server territory — receive new content.
;;
;; This is the Hegelian synthesis made concrete:
;; - Islands = client subjectivity (reactive state, preserved)
;; - Lakes = server substance (content, morphed)
;; - The morph = Aufhebung (cancellation/preservation/elevation of both)
(define morph-island-children :effects [mutation io]
(fn (old-island new-island)
;; Find all lake and marsh slots in both old and new islands
(let ((old-lakes (dom-query-all old-island "[data-sx-lake]"))
(new-lakes (dom-query-all new-island "[data-sx-lake]"))
(old-marshes (dom-query-all old-island "[data-sx-marsh]"))
(new-marshes (dom-query-all new-island "[data-sx-marsh]")))
;; Build ID→element maps for new lakes and marshes
(let ((new-lake-map (dict))
(new-marsh-map (dict)))
(for-each
(fn (lake)
(let ((id (dom-get-attr lake "data-sx-lake")))
(when id (dict-set! new-lake-map id lake))))
new-lakes)
(for-each
(fn (marsh)
(let ((id (dom-get-attr marsh "data-sx-marsh")))
(when id (dict-set! new-marsh-map id marsh))))
new-marshes)
;; Morph each old lake from its new counterpart
(for-each
(fn (old-lake)
(let ((id (dom-get-attr old-lake "data-sx-lake")))
(let ((new-lake (dict-get new-lake-map id)))
(when new-lake
(sync-attrs old-lake new-lake)
(morph-children old-lake new-lake)))))
old-lakes)
;; Morph each old marsh from its new counterpart
(for-each
(fn (old-marsh)
(let ((id (dom-get-attr old-marsh "data-sx-marsh")))
(let ((new-marsh (dict-get new-marsh-map id)))
(when new-marsh
(morph-marsh old-marsh new-marsh old-island)))))
old-marshes)
;; Process data-sx-signal attributes — server writes to named stores
(process-signal-updates new-island)))))
;; --------------------------------------------------------------------------
;; morph-marsh — re-evaluate server content in island's reactive scope
;; --------------------------------------------------------------------------
;;
;; Marshes are zones inside islands where server content is re-evaluated by
;; the island's reactive evaluator. During morph, the new content is parsed
;; as SX and rendered in the island's signal context. If the marsh has a
;; :transform function, it reshapes the content before evaluation.
(define morph-marsh :effects [mutation io]
(fn (old-marsh new-marsh island-el)
(let ((transform (dom-get-data old-marsh "sx-marsh-transform"))
(env (dom-get-data old-marsh "sx-marsh-env"))
(new-html (dom-inner-html new-marsh)))
(if (and env new-html (not (empty? new-html)))
;; Parse new content as SX and re-evaluate in island scope
(let ((parsed (parse new-html)))
(let ((sx-content (if transform (invoke transform parsed) parsed)))
;; Dispose old reactive bindings in this marsh
(dispose-marsh-scope old-marsh)
;; Evaluate the SX in a new marsh scope — creates new reactive bindings
(with-marsh-scope old-marsh
(fn ()
(let ((new-dom (render-to-dom sx-content env nil)))
;; Replace marsh children
(dom-remove-children-after old-marsh nil)
(dom-append old-marsh new-dom))))))
;; Fallback: morph like a lake
(do
(sync-attrs old-marsh new-marsh)
(morph-children old-marsh new-marsh))))))
;; --------------------------------------------------------------------------
;; process-signal-updates — server responses write to named store signals
;; --------------------------------------------------------------------------
;;
;; Elements with data-sx-signal="name:value" trigger signal writes.
;; After processing, the attribute is removed (consumed).
;;
;; Values are JSON-parsed: "7" → 7, "\"hello\"" → "hello", "true" → true.
(define process-signal-updates :effects [mutation io]
(fn (root)
(let ((signal-els (dom-query-all root "[data-sx-signal]")))
(for-each
(fn (el)
(let ((spec (dom-get-attr el "data-sx-signal")))
(when spec
(let ((colon-idx (index-of spec ":")))
(when (> colon-idx 0)
(let ((store-name (slice spec 0 colon-idx))
(raw-value (slice spec (+ colon-idx 1))))
(let ((parsed (json-parse raw-value)))
(reset! (use-store store-name) parsed))
(dom-remove-attr el "data-sx-signal")))))))
signal-els))))
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; Swap dispatch ;; Swap dispatch
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define swap-dom-nodes (define swap-dom-nodes :effects [mutation io]
(fn (target new-nodes strategy) (fn (target new-nodes (strategy :as string))
;; Execute a swap strategy on live DOM nodes. ;; Execute a swap strategy on live DOM nodes.
;; new-nodes is typically a DocumentFragment or Element. ;; new-nodes is typically a DocumentFragment or Element.
(case strategy (case strategy
@@ -493,7 +630,7 @@
(morph-children target wrapper)))))) (morph-children target wrapper))))))
(define insert-remaining-siblings (define insert-remaining-siblings :effects [mutation io]
(fn (parent ref-node sib) (fn (parent ref-node sib)
;; Insert sibling chain after ref-node ;; Insert sibling chain after ref-node
(when sib (when sib
@@ -506,8 +643,8 @@
;; String-based swap (fallback for HTML responses) ;; String-based swap (fallback for HTML responses)
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define swap-html-string (define swap-html-string :effects [mutation io]
(fn (target html strategy) (fn (target (html :as string) (strategy :as string))
;; Execute a swap strategy using an HTML string (DOMParser pipeline). ;; Execute a swap strategy using an HTML string (DOMParser pipeline).
(case strategy (case strategy
"innerHTML" "innerHTML"
@@ -537,8 +674,8 @@
;; History management ;; History management
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define handle-history (define handle-history :effects [io]
(fn (el url resp-headers) (fn (el (url :as string) (resp-headers :as dict))
;; Process history push/replace based on element attrs and response headers ;; Process history push/replace based on element attrs and response headers
(let ((push-url (dom-get-attr el "sx-push-url")) (let ((push-url (dom-get-attr el "sx-push-url"))
(replace-url (dom-get-attr el "sx-replace-url")) (replace-url (dom-get-attr el "sx-replace-url"))
@@ -563,8 +700,8 @@
(define PRELOAD_TTL 30000) ;; 30 seconds (define PRELOAD_TTL 30000) ;; 30 seconds
(define preload-cache-get (define preload-cache-get :effects [mutation]
(fn (cache url) (fn ((cache :as dict) (url :as string))
;; Get and consume a cached preload response. ;; Get and consume a cached preload response.
;; Returns (dict "text" ... "content-type" ...) or nil. ;; Returns (dict "text" ... "content-type" ...) or nil.
(let ((entry (dict-get cache url))) (let ((entry (dict-get cache url)))
@@ -575,8 +712,8 @@
(do (dict-delete! cache url) entry)))))) (do (dict-delete! cache url) entry))))))
(define preload-cache-set (define preload-cache-set :effects [mutation]
(fn (cache url text content-type) (fn ((cache :as dict) (url :as string) (text :as string) (content-type :as string))
;; Store a preloaded response ;; Store a preloaded response
(dict-set! cache url (dict-set! cache url
(dict "text" text "content-type" content-type "timestamp" (now-ms))))) (dict "text" text "content-type" content-type "timestamp" (now-ms)))))
@@ -588,8 +725,8 @@
;; Maps trigger event names to binding strategies. ;; Maps trigger event names to binding strategies.
;; This is the logic; actual browser event binding is platform interface. ;; This is the logic; actual browser event binding is platform interface.
(define classify-trigger (define classify-trigger :effects []
(fn (trigger) (fn ((trigger :as dict))
;; Classify a parsed trigger descriptor for binding. ;; Classify a parsed trigger descriptor for binding.
;; Returns one of: "poll", "intersect", "load", "revealed", "event" ;; Returns one of: "poll", "intersect", "load", "revealed", "event"
(let ((event (get trigger "event"))) (let ((event (get trigger "event")))
@@ -605,7 +742,7 @@
;; Boost logic ;; Boost logic
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define should-boost-link? (define should-boost-link? :effects [io]
(fn (link) (fn (link)
;; Whether a link inside an sx-boost container should be boosted ;; Whether a link inside an sx-boost container should be boosted
(let ((href (dom-get-attr link "href"))) (let ((href (dom-get-attr link "href")))
@@ -619,7 +756,7 @@
(not (dom-has-attr? link "sx-disable")))))) (not (dom-has-attr? link "sx-disable"))))))
(define should-boost-form? (define should-boost-form? :effects [io]
(fn (form) (fn (form)
;; Whether a form inside an sx-boost container should be boosted ;; Whether a form inside an sx-boost container should be boosted
(and (not (dom-has-attr? form "sx-get")) (and (not (dom-has-attr? form "sx-get"))
@@ -631,7 +768,7 @@
;; SSE event classification ;; SSE event classification
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define parse-sse-swap (define parse-sse-swap :effects [io]
(fn (el) (fn (el)
;; Parse sx-sse-swap attribute ;; Parse sx-sse-swap attribute
;; Returns event name to listen for (default "message") ;; Returns event name to listen for (default "message")

View File

@@ -55,7 +55,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define trampoline (define trampoline
(fn (val) (fn ((val :as any))
;; Iteratively resolve thunks until we get an actual value. ;; Iteratively resolve thunks until we get an actual value.
;; Each target implements thunk? and thunk-expr/thunk-env. ;; Each target implements thunk? and thunk-expr/thunk-env.
(let ((result val)) (let ((result val))
@@ -73,7 +73,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define eval-expr (define eval-expr
(fn (expr env) (fn (expr (env :as dict))
(case (type-of expr) (case (type-of expr)
;; --- literals pass through --- ;; --- literals pass through ---
@@ -91,7 +91,8 @@
(= name "true") true (= name "true") true
(= name "false") false (= name "false") false
(= name "nil") nil (= name "nil") nil
:else (error (str "Undefined symbol: " name)))) :else (do (debug-log "Undefined symbol:" name "primitive?:" (primitive? name))
(error (str "Undefined symbol: " name)))))
;; --- keyword → its string name --- ;; --- keyword → its string name ---
"keyword" (keyword-name expr) "keyword" (keyword-name expr)
@@ -115,7 +116,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define eval-list (define eval-list
(fn (expr env) (fn (expr (env :as dict))
(let ((head (first expr)) (let ((head (first expr))
(args (rest expr))) (args (rest expr)))
@@ -150,6 +151,8 @@
(= name "defpage") (sf-defpage args env) (= name "defpage") (sf-defpage args env)
(= name "defquery") (sf-defquery args env) (= name "defquery") (sf-defquery args env)
(= name "defaction") (sf-defaction args env) (= name "defaction") (sf-defaction args env)
(= name "deftype") (sf-deftype args env)
(= name "defeffect") (sf-defeffect args env)
(= name "begin") (sf-begin args env) (= name "begin") (sf-begin args env)
(= name "do") (sf-begin args env) (= name "do") (sf-begin args env)
(= name "quote") (sf-quote args env) (= name "quote") (sf-quote args env)
@@ -174,8 +177,8 @@
(let ((mac (env-get env name))) (let ((mac (env-get env name)))
(make-thunk (expand-macro mac args env) env)) (make-thunk (expand-macro mac args env) env))
;; Render expression — delegate to active adapter. ;; Render expression — delegate to active adapter (only when rendering).
(is-render-expr? expr) (and (render-active?) (is-render-expr? expr))
(render-expr expr env) (render-expr expr env)
;; Fall through to function call ;; Fall through to function call
@@ -190,7 +193,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define eval-call (define eval-call
(fn (head args env) (fn (head (args :as list) (env :as dict))
(let ((f (trampoline (eval-expr head env))) (let ((f (trampoline (eval-expr head env)))
(evaluated-args (map (fn (a) (trampoline (eval-expr a env))) args))) (evaluated-args (map (fn (a) (trampoline (eval-expr a env))) args)))
(cond (cond
@@ -214,23 +217,27 @@
(define call-lambda (define call-lambda
(fn (f args caller-env) (fn ((f :as lambda) (args :as list) (caller-env :as dict))
(let ((params (lambda-params f)) (let ((params (lambda-params f))
(local (env-merge (lambda-closure f) caller-env))) (local (env-merge (lambda-closure f) caller-env)))
(if (!= (len args) (len params)) ;; Too many args is an error; too few pads with nil
(if (> (len args) (len params))
(error (str (or (lambda-name f) "lambda") (error (str (or (lambda-name f) "lambda")
" expects " (len params) " args, got " (len args))) " expects " (len params) " args, got " (len args)))
(do (do
;; Bind params ;; Bind params — provided args first, then nil for missing
(for-each (for-each
(fn (pair) (env-set! local (first pair) (nth pair 1))) (fn (pair) (env-set! local (first pair) (nth pair 1)))
(zip params args)) (zip params args))
(for-each
(fn (p) (env-set! local p nil))
(slice params (len args)))
;; Return thunk for TCO ;; Return thunk for TCO
(make-thunk (lambda-body f) local)))))) (make-thunk (lambda-body f) local))))))
(define call-component (define call-component
(fn (comp raw-args env) (fn ((comp :as component) (raw-args :as list) (env :as dict))
;; Parse keyword args and children from unevaluated arg list ;; Parse keyword args and children from unevaluated arg list
(let ((parsed (parse-keyword-args raw-args env)) (let ((parsed (parse-keyword-args raw-args env))
(kwargs (first parsed)) (kwargs (first parsed))
@@ -248,7 +255,7 @@
(define parse-keyword-args (define parse-keyword-args
(fn (raw-args env) (fn ((raw-args :as list) (env :as dict))
;; Walk args: keyword + next-val → kwargs dict, else → children list ;; Walk args: keyword + next-val → kwargs dict, else → children list
(let ((kwargs (dict)) (let ((kwargs (dict))
(children (list)) (children (list))
@@ -282,7 +289,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define sf-if (define sf-if
(fn (args env) (fn ((args :as list) (env :as dict))
(let ((condition (trampoline (eval-expr (first args) env)))) (let ((condition (trampoline (eval-expr (first args) env))))
(if (and condition (not (nil? condition))) (if (and condition (not (nil? condition)))
(make-thunk (nth args 1) env) (make-thunk (nth args 1) env)
@@ -292,7 +299,7 @@
(define sf-when (define sf-when
(fn (args env) (fn ((args :as list) (env :as dict))
(let ((condition (trampoline (eval-expr (first args) env)))) (let ((condition (trampoline (eval-expr (first args) env))))
(if (and condition (not (nil? condition))) (if (and condition (not (nil? condition)))
(do (do
@@ -305,18 +312,22 @@
nil)))) nil))))
;; cond-scheme? — check if ALL clauses are 2-element lists (scheme-style).
;; Checking only the first arg is ambiguous — (nil? x) is a 2-element
;; function call, not a scheme clause ((test body)).
(define cond-scheme?
(fn ((clauses :as list))
(every? (fn (c) (and (= (type-of c) "list") (= (len c) 2)))
clauses)))
(define sf-cond (define sf-cond
(fn (args env) (fn ((args :as list) (env :as dict))
;; Detect scheme-style: first arg is a 2-element list (if (cond-scheme? args)
(if (and (= (type-of (first args)) "list")
(= (len (first args)) 2))
;; Scheme-style: ((test body) ...)
(sf-cond-scheme args env) (sf-cond-scheme args env)
;; Clojure-style: test body test body ...
(sf-cond-clojure args env)))) (sf-cond-clojure args env))))
(define sf-cond-scheme (define sf-cond-scheme
(fn (clauses env) (fn ((clauses :as list) (env :as dict))
(if (empty? clauses) (if (empty? clauses)
nil nil
(let ((clause (first clauses)) (let ((clause (first clauses))
@@ -333,7 +344,7 @@
(sf-cond-scheme (rest clauses) env))))))) (sf-cond-scheme (rest clauses) env)))))))
(define sf-cond-clojure (define sf-cond-clojure
(fn (clauses env) (fn ((clauses :as list) (env :as dict))
(if (< (len clauses) 2) (if (< (len clauses) 2)
nil nil
(let ((test (first clauses)) (let ((test (first clauses))
@@ -349,13 +360,13 @@
(define sf-case (define sf-case
(fn (args env) (fn ((args :as list) (env :as dict))
(let ((match-val (trampoline (eval-expr (first args) env))) (let ((match-val (trampoline (eval-expr (first args) env)))
(clauses (rest args))) (clauses (rest args)))
(sf-case-loop match-val clauses env)))) (sf-case-loop match-val clauses env))))
(define sf-case-loop (define sf-case-loop
(fn (match-val clauses env) (fn (match-val (clauses :as list) (env :as dict))
(if (< (len clauses) 2) (if (< (len clauses) 2)
nil nil
(let ((test (first clauses)) (let ((test (first clauses))
@@ -371,7 +382,7 @@
(define sf-and (define sf-and
(fn (args env) (fn ((args :as list) (env :as dict))
(if (empty? args) (if (empty? args)
true true
(let ((val (trampoline (eval-expr (first args) env)))) (let ((val (trampoline (eval-expr (first args) env))))
@@ -383,7 +394,7 @@
(define sf-or (define sf-or
(fn (args env) (fn ((args :as list) (env :as dict))
(if (empty? args) (if (empty? args)
false false
(let ((val (trampoline (eval-expr (first args) env)))) (let ((val (trampoline (eval-expr (first args) env))))
@@ -393,7 +404,7 @@
(define sf-let (define sf-let
(fn (args env) (fn ((args :as list) (env :as dict))
;; Detect named let: (let name ((x 0) ...) body) ;; Detect named let: (let name ((x 0) ...) body)
;; If first arg is a symbol, delegate to sf-named-let. ;; If first arg is a symbol, delegate to sf-named-let.
(if (= (type-of (first args)) "symbol") (if (= (type-of (first args)) "symbol")
@@ -434,7 +445,7 @@
;; Desugars to a self-recursive lambda called with initial values. ;; Desugars to a self-recursive lambda called with initial values.
;; The loop name is bound in the body so recursive calls produce TCO thunks. ;; The loop name is bound in the body so recursive calls produce TCO thunks.
(define sf-named-let (define sf-named-let
(fn (args env) (fn ((args :as list) (env :as dict))
(let ((loop-name (symbol-name (first args))) (let ((loop-name (symbol-name (first args)))
(bindings (nth args 1)) (bindings (nth args 1))
(body (slice args 2)) (body (slice args 2))
@@ -474,32 +485,60 @@
(define sf-lambda (define sf-lambda
(fn (args env) (fn ((args :as list) (env :as dict))
(let ((params-expr (first args)) (let ((params-expr (first args))
(body-exprs (rest args)) (body-exprs (rest args))
(body (if (= (len body-exprs) 1) (body (if (= (len body-exprs) 1)
(first body-exprs) (first body-exprs)
(cons (make-symbol "begin") body-exprs))) (cons (make-symbol "begin") body-exprs)))
(param-names (map (fn (p) (param-names (map (fn (p)
(if (= (type-of p) "symbol") (cond
(symbol-name p) (= (type-of p) "symbol")
p)) (symbol-name p)
;; Annotated param: (name :as type) → extract name
(and (= (type-of p) "list")
(= (len p) 3)
(= (type-of (nth p 1)) "keyword")
(= (keyword-name (nth p 1)) "as"))
(symbol-name (first p))
:else p))
params-expr))) params-expr)))
(make-lambda param-names body env)))) (make-lambda param-names body env))))
(define sf-define (define sf-define
(fn (args env) (fn ((args :as list) (env :as dict))
;; Detect :effects keyword: (define name :effects [...] value)
(let ((name-sym (first args)) (let ((name-sym (first args))
(value (trampoline (eval-expr (nth args 1) env)))) (has-effects (and (>= (len args) 4)
(= (type-of (nth args 1)) "keyword")
(= (keyword-name (nth args 1)) "effects")))
(val-idx (if (and (>= (len args) 4)
(= (type-of (nth args 1)) "keyword")
(= (keyword-name (nth args 1)) "effects"))
3 1))
(value (trampoline (eval-expr (nth args val-idx) env))))
(when (and (lambda? value) (nil? (lambda-name value))) (when (and (lambda? value) (nil? (lambda-name value)))
(set-lambda-name! value (symbol-name name-sym))) (set-lambda-name! value (symbol-name name-sym)))
(env-set! env (symbol-name name-sym) value) (env-set! env (symbol-name name-sym) value)
;; Store effect annotation if declared
(when has-effects
(let ((effects-raw (nth args 2))
(effect-list (if (= (type-of effects-raw) "list")
(map (fn (e) (if (= (type-of e) "symbol")
(symbol-name e) (str e)))
effects-raw)
(list (str effects-raw))))
(effect-anns (if (env-has? env "*effect-annotations*")
(env-get env "*effect-annotations*")
(dict))))
(dict-set! effect-anns (symbol-name name-sym) effect-list)
(env-set! env "*effect-annotations*" effect-anns)))
value))) value)))
(define sf-defcomp (define sf-defcomp
(fn (args env) (fn ((args :as list) (env :as dict))
;; (defcomp ~name (params) [:affinity :client|:server] body) ;; (defcomp ~name (params) [:affinity :client|:server] body)
;; Body is always the last element. Optional keyword annotations ;; Body is always the last element. Optional keyword annotations
;; may appear between the params list and the body. ;; may appear between the params list and the body.
@@ -510,13 +549,31 @@
(parsed (parse-comp-params params-raw)) (parsed (parse-comp-params params-raw))
(params (first parsed)) (params (first parsed))
(has-children (nth parsed 1)) (has-children (nth parsed 1))
(param-types (nth parsed 2))
(affinity (defcomp-kwarg args "affinity" "auto"))) (affinity (defcomp-kwarg args "affinity" "auto")))
(let ((comp (make-component comp-name params has-children body env affinity))) (let ((comp (make-component comp-name params has-children body env affinity))
(effects (defcomp-kwarg args "effects" nil)))
;; Store type annotations if any were declared
(when (and (not (nil? param-types))
(not (empty? (keys param-types))))
(component-set-param-types! comp param-types))
;; Store effect annotation if declared
(when (not (nil? effects))
(let ((effect-list (if (= (type-of effects) "list")
(map (fn (e) (if (= (type-of e) "symbol")
(symbol-name e) (str e)))
effects)
(list (str effects))))
(effect-anns (if (env-has? env "*effect-annotations*")
(env-get env "*effect-annotations*")
(dict))))
(dict-set! effect-anns (symbol-name name-sym) effect-list)
(env-set! env "*effect-annotations*" effect-anns)))
(env-set! env (symbol-name name-sym) comp) (env-set! env (symbol-name name-sym) comp)
comp)))) comp))))
(define defcomp-kwarg (define defcomp-kwarg
(fn (args key default) (fn ((args :as list) (key :as string) default)
;; Search for :key value between params (index 2) and body (last). ;; Search for :key value between params (index 2) and body (last).
(let ((end (- (len args) 1)) (let ((end (- (len args) 1))
(result default)) (result default))
@@ -532,29 +589,49 @@
result))) result)))
(define parse-comp-params (define parse-comp-params
(fn (params-expr) (fn ((params-expr :as list))
;; Parse (&key param1 param2 &children) → (params has-children) ;; Parse (&key param1 param2 &children) → (params has-children param-types)
;; Also accepts &rest as synonym for &children. ;; Also accepts &rest as synonym for &children.
;; Supports typed params: (name :as type) — a 3-element list where
;; the second element is the keyword :as. Unannotated params get no
;; type entry. param-types is a dict {name → type-expr} or empty dict.
(let ((params (list)) (let ((params (list))
(param-types (dict))
(has-children false) (has-children false)
(in-key false)) (in-key false))
(for-each (for-each
(fn (p) (fn (p)
(when (= (type-of p) "symbol") (if (and (= (type-of p) "list")
(let ((name (symbol-name p))) (= (len p) 3)
(cond (= (type-of (first p)) "symbol")
(= name "&key") (set! in-key true) (= (type-of (nth p 1)) "keyword")
(= name "&rest") (set! has-children true) (= (keyword-name (nth p 1)) "as"))
(= name "&children") (set! has-children true) ;; Typed param: (name :as type)
has-children nil ;; skip params after &children/&rest (let ((name (symbol-name (first p)))
in-key (append! params name) (ptype (nth p 2)))
:else (append! params name))))) ;; Convert type to string if it's a symbol
(let ((type-val (if (= (type-of ptype) "symbol")
(symbol-name ptype)
ptype)))
(when (not has-children)
(append! params name)
(dict-set! param-types name type-val))))
;; Untyped param or marker
(when (= (type-of p) "symbol")
(let ((name (symbol-name p)))
(cond
(= name "&key") (set! in-key true)
(= name "&rest") (set! has-children true)
(= name "&children") (set! has-children true)
has-children nil ;; skip params after &children/&rest
in-key (append! params name)
:else (append! params name))))))
params-expr) params-expr)
(list params has-children)))) (list params has-children param-types))))
(define sf-defisland (define sf-defisland
(fn (args env) (fn ((args :as list) (env :as dict))
;; (defisland ~name (params) body) ;; (defisland ~name (params) body)
;; Like defcomp but creates an island (reactive component). ;; Like defcomp but creates an island (reactive component).
;; Islands have the same calling convention as components but ;; Islands have the same calling convention as components but
@@ -572,7 +649,7 @@
(define sf-defmacro (define sf-defmacro
(fn (args env) (fn ((args :as list) (env :as dict))
(let ((name-sym (first args)) (let ((name-sym (first args))
(params-raw (nth args 1)) (params-raw (nth args 1))
(body (nth args 2)) (body (nth args 2))
@@ -584,7 +661,7 @@
mac)))) mac))))
(define parse-macro-params (define parse-macro-params
(fn (params-expr) (fn ((params-expr :as list))
;; Parse (a b &rest rest) → ((a b) rest) ;; Parse (a b &rest rest) → ((a b) rest)
(let ((params (list)) (let ((params (list))
(rest-param nil)) (rest-param nil))
@@ -605,7 +682,7 @@
(define sf-defstyle (define sf-defstyle
(fn (args env) (fn ((args :as list) (env :as dict))
;; (defstyle name expr) — bind name to evaluated expr (string, function, etc.) ;; (defstyle name expr) — bind name to evaluated expr (string, function, etc.)
(let ((name-sym (first args)) (let ((name-sym (first args))
(value (trampoline (eval-expr (nth args 1) env)))) (value (trampoline (eval-expr (nth args 1) env))))
@@ -613,8 +690,84 @@
value))) value)))
;; -- deftype helpers (must be in eval.sx, not types.sx, because
;; sf-deftype is always compiled but types.sx is a spec module) --
(define make-type-def
(fn ((name :as string) (params :as list) body)
{:name name :params params :body body}))
(define normalize-type-body
(fn (body)
;; Convert AST type expressions to type representation.
;; Symbols → strings, (union ...) → (or ...), dict keys → strings.
(cond
(nil? body) "nil"
(= (type-of body) "symbol")
(symbol-name body)
(= (type-of body) "string")
body
(= (type-of body) "keyword")
(keyword-name body)
(= (type-of body) "dict")
;; Record type — normalize values
(map-dict (fn (k v) (normalize-type-body v)) body)
(= (type-of body) "list")
(if (empty? body) "any"
(let ((head (first body)))
(let ((head-name (if (= (type-of head) "symbol")
(symbol-name head) (str head))))
;; (union a b) → (or a b)
(if (= head-name "union")
(cons "or" (map normalize-type-body (rest body)))
;; (or a b), (list-of t), (-> ...) etc.
(cons head-name (map normalize-type-body (rest body)))))))
:else (str body))))
(define sf-deftype
(fn ((args :as list) (env :as dict))
;; (deftype name body) or (deftype (name a b ...) body)
(let ((name-or-form (first args))
(body-expr (nth args 1))
(type-name nil)
(type-params (list)))
;; Parse name — symbol or (symbol params...)
(if (= (type-of name-or-form) "symbol")
(set! type-name (symbol-name name-or-form))
(when (= (type-of name-or-form) "list")
(set! type-name (symbol-name (first name-or-form)))
(set! type-params
(map (fn (p) (if (= (type-of p) "symbol")
(symbol-name p) (str p)))
(rest name-or-form)))))
;; Normalize and store in *type-registry*
(let ((body (normalize-type-body body-expr))
(registry (if (env-has? env "*type-registry*")
(env-get env "*type-registry*")
(dict))))
(dict-set! registry type-name
(make-type-def type-name type-params body))
(env-set! env "*type-registry*" registry)
nil))))
(define sf-defeffect
(fn ((args :as list) (env :as dict))
;; (defeffect name) — register an effect name
(let ((effect-name (if (= (type-of (first args)) "symbol")
(symbol-name (first args))
(str (first args))))
(registry (if (env-has? env "*effect-registry*")
(env-get env "*effect-registry*")
(list))))
(when (not (contains? registry effect-name))
(append! registry effect-name))
(env-set! env "*effect-registry*" registry)
nil)))
(define sf-begin (define sf-begin
(fn (args env) (fn ((args :as list) (env :as dict))
(if (empty? args) (if (empty? args)
nil nil
(do (do
@@ -625,16 +778,16 @@
(define sf-quote (define sf-quote
(fn (args env) (fn ((args :as list) (env :as dict))
(if (empty? args) nil (first args)))) (if (empty? args) nil (first args))))
(define sf-quasiquote (define sf-quasiquote
(fn (args env) (fn ((args :as list) (env :as dict))
(qq-expand (first args) env))) (qq-expand (first args) env)))
(define qq-expand (define qq-expand
(fn (template env) (fn (template (env :as dict))
(if (not (= (type-of template) "list")) (if (not (= (type-of template) "list"))
template template
(if (empty? template) (if (empty? template)
@@ -652,14 +805,14 @@
(let ((spliced (trampoline (eval-expr (nth item 1) env)))) (let ((spliced (trampoline (eval-expr (nth item 1) env))))
(if (= (type-of spliced) "list") (if (= (type-of spliced) "list")
(concat result spliced) (concat result spliced)
(if (nil? spliced) result (append result spliced)))) (if (nil? spliced) result (concat result (list spliced)))))
(append result (qq-expand item env)))) (concat result (list (qq-expand item env)))))
(list) (list)
template))))))) template)))))))
(define sf-thread-first (define sf-thread-first
(fn (args env) (fn ((args :as list) (env :as dict))
(let ((val (trampoline (eval-expr (first args) env)))) (let ((val (trampoline (eval-expr (first args) env))))
(reduce (reduce
(fn (result form) (fn (result form)
@@ -686,7 +839,7 @@
(define sf-set! (define sf-set!
(fn (args env) (fn ((args :as list) (env :as dict))
(let ((name (symbol-name (first args))) (let ((name (symbol-name (first args)))
(value (trampoline (eval-expr (nth args 1) env)))) (value (trampoline (eval-expr (nth args 1) env))))
(env-set! env name value) (env-set! env name value)
@@ -707,7 +860,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define sf-letrec (define sf-letrec
(fn (args env) (fn ((args :as list) (env :as dict))
(let ((bindings (first args)) (let ((bindings (first args))
(body (rest args)) (body (rest args))
(local (env-extend env)) (local (env-extend env))
@@ -782,7 +935,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define sf-dynamic-wind (define sf-dynamic-wind
(fn (args env) (fn ((args :as list) (env :as dict))
(let ((before (trampoline (eval-expr (first args) env))) (let ((before (trampoline (eval-expr (first args) env)))
(body (trampoline (eval-expr (nth args 1) env))) (body (trampoline (eval-expr (nth args 1) env)))
(after (trampoline (eval-expr (nth args 2) env)))) (after (trampoline (eval-expr (nth args 2) env))))
@@ -801,7 +954,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define expand-macro (define expand-macro
(fn (mac raw-args env) (fn ((mac :as macro) (raw-args :as list) (env :as dict))
(let ((local (env-merge (macro-closure mac) env))) (let ((local (env-merge (macro-closure mac) env)))
;; Bind positional params (unevaluated) ;; Bind positional params (unevaluated)
(for-each (for-each
@@ -825,20 +978,20 @@
;; call-fn: unified caller for HO forms — handles both Lambda and native callable ;; call-fn: unified caller for HO forms — handles both Lambda and native callable
(define call-fn (define call-fn
(fn (f args env) (fn (f (args :as list) (env :as dict))
(cond (cond
(lambda? f) (trampoline (call-lambda f args env)) (lambda? f) (trampoline (call-lambda f args env))
(callable? f) (apply f args) (callable? f) (apply f args)
:else (error (str "Not callable in HO form: " (inspect f)))))) :else (error (str "Not callable in HO form: " (inspect f))))))
(define ho-map (define ho-map
(fn (args env) (fn ((args :as list) (env :as dict))
(let ((f (trampoline (eval-expr (first args) env))) (let ((f (trampoline (eval-expr (first args) env)))
(coll (trampoline (eval-expr (nth args 1) env)))) (coll (trampoline (eval-expr (nth args 1) env))))
(map (fn (item) (call-fn f (list item) env)) coll)))) (map (fn (item) (call-fn f (list item) env)) coll))))
(define ho-map-indexed (define ho-map-indexed
(fn (args env) (fn ((args :as list) (env :as dict))
(let ((f (trampoline (eval-expr (first args) env))) (let ((f (trampoline (eval-expr (first args) env)))
(coll (trampoline (eval-expr (nth args 1) env)))) (coll (trampoline (eval-expr (nth args 1) env))))
(map-indexed (map-indexed
@@ -846,7 +999,7 @@
coll)))) coll))))
(define ho-filter (define ho-filter
(fn (args env) (fn ((args :as list) (env :as dict))
(let ((f (trampoline (eval-expr (first args) env))) (let ((f (trampoline (eval-expr (first args) env)))
(coll (trampoline (eval-expr (nth args 1) env)))) (coll (trampoline (eval-expr (nth args 1) env))))
(filter (filter
@@ -854,7 +1007,7 @@
coll)))) coll))))
(define ho-reduce (define ho-reduce
(fn (args env) (fn ((args :as list) (env :as dict))
(let ((f (trampoline (eval-expr (first args) env))) (let ((f (trampoline (eval-expr (first args) env)))
(init (trampoline (eval-expr (nth args 1) env))) (init (trampoline (eval-expr (nth args 1) env)))
(coll (trampoline (eval-expr (nth args 2) env)))) (coll (trampoline (eval-expr (nth args 2) env))))
@@ -864,7 +1017,7 @@
coll)))) coll))))
(define ho-some (define ho-some
(fn (args env) (fn ((args :as list) (env :as dict))
(let ((f (trampoline (eval-expr (first args) env))) (let ((f (trampoline (eval-expr (first args) env)))
(coll (trampoline (eval-expr (nth args 1) env)))) (coll (trampoline (eval-expr (nth args 1) env))))
(some (some
@@ -872,7 +1025,7 @@
coll)))) coll))))
(define ho-every (define ho-every
(fn (args env) (fn ((args :as list) (env :as dict))
(let ((f (trampoline (eval-expr (first args) env))) (let ((f (trampoline (eval-expr (first args) env)))
(coll (trampoline (eval-expr (nth args 1) env)))) (coll (trampoline (eval-expr (nth args 1) env))))
(every? (every?
@@ -881,7 +1034,7 @@
(define ho-for-each (define ho-for-each
(fn (args env) (fn ((args :as list) (env :as dict))
(let ((f (trampoline (eval-expr (first args) env))) (let ((f (trampoline (eval-expr (first args) env)))
(coll (trampoline (eval-expr (nth args 1) env)))) (coll (trampoline (eval-expr (nth args 1) env))))
(for-each (for-each

View File

@@ -22,7 +22,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define parse-key-params (define parse-key-params
(fn (params-expr) (fn ((params-expr :as list))
(let ((params (list)) (let ((params (list))
(in-key false)) (in-key false))
(for-each (for-each
@@ -38,17 +38,66 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; defhandler — (defhandler name (&key param...) body) ;; defhandler — (defhandler name [:path "..." :method :get :csrf false :returns "element"] (&key param...) body)
;;
;; Keyword options between name and params list:
;; :path — public route path (string). Without :path, handler is internal-only.
;; :method — HTTP method (keyword: :get :post :put :patch :delete). Default :get.
;; :csrf — CSRF protection (boolean). Default true; set false for POST/PUT etc.
;; :returns — return type annotation (types.sx vocabulary). Default "element".
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define parse-handler-args
(fn ((args :as list))
"Parse defhandler args after the name symbol.
Scans for :keyword value option pairs, then a list (params), then body.
Returns dict with keys: opts, params, body."
(let ((opts {})
(params (list))
(body nil)
(i 0)
(n (len args))
(done false))
(for-each
(fn (idx)
(when (and (not done) (= idx i))
(let ((arg (nth args idx)))
(cond
;; keyword-value pair → consume two items
(= (type-of arg) "keyword")
(do
(when (< (+ idx 1) n)
(let ((val (nth args (+ idx 1))))
;; For :method, extract keyword name; for :csrf, keep as-is
(dict-set! opts (keyword-name arg)
(if (= (type-of val) "keyword")
(keyword-name val)
val))))
(set! i (+ idx 2)))
;; list → params, next element is body
(= (type-of arg) "list")
(do
(set! params (parse-key-params arg))
(when (< (+ idx 1) n)
(set! body (nth args (+ idx 1))))
(set! done true))
;; anything else → no explicit params, this is body
:else
(do
(set! body arg)
(set! done true))))))
(range 0 n))
(dict :opts opts :params params :body body))))
(define sf-defhandler (define sf-defhandler
(fn (args env) (fn ((args :as list) (env :as dict))
(let ((name-sym (first args)) (let ((name-sym (first args))
(params-raw (nth args 1)) (name (symbol-name name-sym))
(body (nth args 2)) (parsed (parse-handler-args (rest args)))
(name (symbol-name name-sym)) (opts (get parsed "opts"))
(params (parse-key-params params-raw))) (params (get parsed "params"))
(let ((hdef (make-handler-def name params body env))) (body (get parsed "body")))
(let ((hdef (make-handler-def name params body env opts)))
(env-set! env (str "handler:" name) hdef) (env-set! env (str "handler:" name) hdef)
hdef)))) hdef))))
@@ -58,7 +107,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define sf-defquery (define sf-defquery
(fn (args env) (fn ((args :as list) (env :as dict))
(let ((name-sym (first args)) (let ((name-sym (first args))
(params-raw (nth args 1)) (params-raw (nth args 1))
(name (symbol-name name-sym)) (name (symbol-name name-sym))
@@ -77,7 +126,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define sf-defaction (define sf-defaction
(fn (args env) (fn ((args :as list) (env :as dict))
(let ((name-sym (first args)) (let ((name-sym (first args))
(params-raw (nth args 1)) (params-raw (nth args 1))
(name (symbol-name name-sym)) (name (symbol-name name-sym))
@@ -98,7 +147,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define sf-defpage (define sf-defpage
(fn (args env) (fn ((args :as list) (env :as dict))
(let ((name-sym (first args)) (let ((name-sym (first args))
(name (symbol-name name-sym)) (name (symbol-name name-sym))
(slots {})) (slots {}))
@@ -106,7 +155,7 @@
(let ((i 1) (let ((i 1)
(max-i (len args))) (max-i (len args)))
(for-each (for-each
(fn (idx) (fn ((idx :as number))
(when (and (< idx max-i) (when (and (< idx max-i)
(= (type-of (nth args idx)) "keyword")) (= (type-of (nth args idx)) "keyword"))
(when (< (+ idx 1) max-i) (when (< (+ idx 1) max-i)
@@ -195,28 +244,28 @@
;; Extract stream-id from a data chunk dict, defaulting to "stream-content" ;; Extract stream-id from a data chunk dict, defaulting to "stream-content"
(define stream-chunk-id (define stream-chunk-id
(fn (chunk) (fn ((chunk :as dict))
(if (has-key? chunk "stream-id") (if (has-key? chunk "stream-id")
(get chunk "stream-id") (get chunk "stream-id")
"stream-content"))) "stream-content")))
;; Remove stream-id from chunk, returning only the bindings ;; Remove stream-id from chunk, returning only the bindings
(define stream-chunk-bindings (define stream-chunk-bindings
(fn (chunk) (fn ((chunk :as dict))
(dissoc chunk "stream-id"))) (dissoc chunk "stream-id")))
;; Normalize binding keys: underscore → hyphen ;; Normalize binding keys: underscore → hyphen
(define normalize-binding-key (define normalize-binding-key
(fn (key) (fn ((key :as string))
(replace key "_" "-"))) (replace key "_" "-")))
;; Bind a data chunk's keys into a fresh env (isolated per chunk) ;; Bind a data chunk's keys into a fresh env (isolated per chunk)
(define bind-stream-chunk (define bind-stream-chunk
(fn (chunk base-env) (fn ((chunk :as dict) (base-env :as dict))
(let ((env (merge {} base-env)) (let ((env (merge {} base-env))
(bindings (stream-chunk-bindings chunk))) (bindings (stream-chunk-bindings chunk)))
(for-each (for-each
(fn (key) (fn ((key :as string))
(env-set! env (normalize-binding-key key) (env-set! env (normalize-binding-key key)
(get bindings key))) (get bindings key)))
(keys bindings)) (keys bindings))

View File

@@ -124,6 +124,8 @@
"eval-call" "evalCall" "eval-call" "evalCall"
"is-render-expr?" "isRenderExpr" "is-render-expr?" "isRenderExpr"
"render-expr" "renderExpr" "render-expr" "renderExpr"
"render-active?" "renderActiveP"
"set-render-active!" "setRenderActiveB"
"call-lambda" "callLambda" "call-lambda" "callLambda"
"call-component" "callComponent" "call-component" "callComponent"
"parse-keyword-args" "parseKeywordArgs" "parse-keyword-args" "parseKeywordArgs"
@@ -347,6 +349,8 @@
"promise-delayed" "promiseDelayed" "promise-delayed" "promiseDelayed"
"abort-previous" "abortPrevious" "abort-previous" "abortPrevious"
"track-controller" "trackController" "track-controller" "trackController"
"abort-previous-target" "abortPreviousTarget"
"track-controller-target" "trackControllerTarget"
"new-abort-controller" "newAbortController" "new-abort-controller" "newAbortController"
"controller-signal" "controllerSignal" "controller-signal" "controllerSignal"
"abort-error?" "isAbortError" "abort-error?" "isAbortError"
@@ -397,7 +401,6 @@
"try-async-eval-content" "tryAsyncEvalContent" "try-async-eval-content" "tryAsyncEvalContent"
"register-io-deps" "registerIoDeps" "register-io-deps" "registerIoDeps"
"url-pathname" "urlPathname" "url-pathname" "urlPathname"
"bind-inline-handler" "bindInlineHandler"
"bind-preload" "bindPreload" "bind-preload" "bindPreload"
"mark-processed!" "markProcessed" "mark-processed!" "markProcessed"
"is-processed?" "isProcessed" "is-processed?" "isProcessed"
@@ -507,6 +510,7 @@
"scan-io-refs-walk" "scanIoRefsWalk" "scan-io-refs-walk" "scanIoRefsWalk"
"transitive-io-refs" "transitiveIoRefs" "transitive-io-refs" "transitiveIoRefs"
"compute-all-io-refs" "computeAllIoRefs" "compute-all-io-refs" "computeAllIoRefs"
"component-io-refs-cached" "componentIoRefsCached"
"component-pure?" "componentPure_p" "component-pure?" "componentPure_p"
"render-target" "renderTarget" "render-target" "renderTarget"
"page-render-plan" "pageRenderPlan" "page-render-plan" "pageRenderPlan"
@@ -524,7 +528,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define js-mangle (define js-mangle
(fn (name) (fn ((name :as string))
(let ((renamed (get js-renames name))) (let ((renamed (get js-renames name)))
(if (not (nil? renamed)) (if (not (nil? renamed))
renamed renamed
@@ -545,7 +549,7 @@
result)))))))) result))))))))
(define js-kebab-to-camel (define js-kebab-to-camel
(fn (s) (fn ((s :as string))
(let ((parts (split s "-"))) (let ((parts (split s "-")))
(if (<= (len parts) 1) (if (<= (len parts) 1)
s s
@@ -553,7 +557,7 @@
(join "" (map (fn (p) (js-capitalize p)) (rest parts)))))))) (join "" (map (fn (p) (js-capitalize p)) (rest parts))))))))
(define js-capitalize (define js-capitalize
(fn (s) (fn ((s :as string))
(if (empty? s) s (if (empty? s) s
(str (upper (slice s 0 1)) (slice s 1))))) (str (upper (slice s 0 1)) (slice s 1)))))
@@ -563,7 +567,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define js-quote-string (define js-quote-string
(fn (s) (fn ((s :as string))
(str "\"" (str "\""
(replace (replace (replace (replace (replace (replace (replace (replace (replace (replace (replace (replace
s "\\" "\\\\") "\"" "\\\"") "\n" "\\n") "\r" "\\r") "\t" "\\t") "\0" "\\0") s "\\" "\\\\") "\"" "\\\"") "\n" "\\n") "\r" "\\r") "\t" "\\t") "\0" "\\0")
@@ -578,11 +582,11 @@
(list "+" "-" "*" "/" "=" "!=" "<" ">" "<=" ">=" "mod")) (list "+" "-" "*" "/" "=" "!=" "<" ">" "<=" ">=" "mod"))
(define js-infix? (define js-infix?
(fn (op) (fn ((op :as string))
(some (fn (x) (= x op)) js-infix-ops))) (some (fn (x) (= x op)) js-infix-ops)))
(define js-op-symbol (define js-op-symbol
(fn (op) (fn ((op :as string))
(case op (case op
"=" "==" "=" "=="
"!=" "!=" "!=" "!="
@@ -595,13 +599,13 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define js-is-self-tail-recursive? (define js-is-self-tail-recursive?
(fn (name body) (fn ((name :as string) (body :as list))
(if (empty? body) (if (empty? body)
false false
(js-has-tail-call? name (last body))))) (js-has-tail-call? name (last body)))))
(define js-has-tail-call? (define js-has-tail-call?
(fn (name expr) (fn ((name :as string) expr)
(if (not (and (list? expr) (not (empty? expr)))) (if (not (and (list? expr) (not (empty? expr))))
false false
(let ((head (first expr))) (let ((head (first expr)))
@@ -638,7 +642,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define js-emit-tail-as-stmt (define js-emit-tail-as-stmt
(fn (name expr) (fn ((name :as string) expr)
(if (not (and (list? expr) (not (empty? expr)))) (if (not (and (list? expr) (not (empty? expr))))
(str "return " (js-expr expr) ";") (str "return " (js-expr expr) ";")
(let ((head (first expr))) (let ((head (first expr)))
@@ -698,7 +702,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define js-emit-cond-as-loop-stmt (define js-emit-cond-as-loop-stmt
(fn (name clauses) (fn ((name :as string) (clauses :as list))
(if (empty? clauses) (if (empty? clauses)
"return NIL;" "return NIL;"
;; Detect scheme vs clojure ;; Detect scheme vs clojure
@@ -710,7 +714,7 @@
(js-cond-clojure-loop name clauses 0 0 false)))))) (js-cond-clojure-loop name clauses 0 0 false))))))
(define js-cond-scheme-loop (define js-cond-scheme-loop
(fn (name clauses i) (fn ((name :as string) (clauses :as list) (i :as number))
(if (>= i (len clauses)) (if (>= i (len clauses))
"else { return NIL; }" "else { return NIL; }"
(let ((clause (nth clauses i)) (let ((clause (nth clauses i))
@@ -724,7 +728,7 @@
(js-cond-scheme-loop name clauses (+ i 1)))))))) (js-cond-scheme-loop name clauses (+ i 1))))))))
(define js-cond-clojure-loop (define js-cond-clojure-loop
(fn (name clauses i clause-idx has-else) (fn ((name :as string) (clauses :as list) (i :as number) (clause-idx :as number) (has-else :as boolean))
(if (>= i (len clauses)) (if (>= i (len clauses))
(if has-else "" " else { return NIL; }") (if has-else "" " else { return NIL; }")
(let ((c (nth clauses i))) (let ((c (nth clauses i)))
@@ -745,7 +749,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define js-emit-loop-body (define js-emit-loop-body
(fn (name body) (fn ((name :as string) (body :as list))
(if (empty? body) (if (empty? body)
"return NIL;" "return NIL;"
(str (join "\n" (map (fn (e) (js-statement e)) (str (join "\n" (map (fn (e) (js-statement e))
@@ -801,7 +805,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define js-emit-native-dict (define js-emit-native-dict
(fn (d) (fn ((d :as dict))
(let ((items (keys d))) (let ((items (keys d)))
(str "{" (join ", " (map (fn (k) (str "{" (join ", " (map (fn (k)
(str (js-quote-string k) ": " (js-expr (get d k)))) (str (js-quote-string k) ": " (js-expr (get d k))))
@@ -959,11 +963,11 @@
(str "function(" params-str ") { " (join "\n" parts) " }"))))))))) (str "function(" params-str ") { " (join "\n" parts) " }")))))))))
(define js-collect-params (define js-collect-params
(fn (params) (fn ((params :as list))
(js-collect-params-loop params 0 (list) nil))) (js-collect-params-loop params 0 (list) nil)))
(define js-collect-params-loop (define js-collect-params-loop
(fn (params i result rest-name) (fn ((params :as list) (i :as number) (result :as list) rest-name)
(if (>= i (len params)) (if (>= i (len params))
(list result rest-name) (list result rest-name)
(let ((p (nth params i))) (let ((p (nth params i)))
@@ -971,13 +975,25 @@
;; &rest marker ;; &rest marker
(and (= (type-of p) "symbol") (= (symbol-name p) "&rest")) (and (= (type-of p) "symbol") (= (symbol-name p) "&rest"))
(if (< (+ i 1) (len params)) (if (< (+ i 1) (len params))
(js-collect-params-loop params (+ i 2) result (let ((rp (nth params (+ i 1))))
(js-mangle (symbol-name (nth params (+ i 1))))) (js-collect-params-loop params (+ i 2) result
(js-mangle
(if (and (= (type-of rp) "list") (= (len rp) 3)
(= (type-of (nth rp 1)) "keyword")
(= (keyword-name (nth rp 1)) "as"))
(symbol-name (first rp))
(if (= (type-of rp) "symbol") (symbol-name rp) (str rp))))))
(js-collect-params-loop params (+ i 1) result rest-name)) (js-collect-params-loop params (+ i 1) result rest-name))
;; Normal param ;; Normal param
(= (type-of p) "symbol") (= (type-of p) "symbol")
(js-collect-params-loop params (+ i 1) (js-collect-params-loop params (+ i 1)
(append result (js-mangle (symbol-name p))) rest-name) (append result (js-mangle (symbol-name p))) rest-name)
;; Annotated param: (name :as type) → extract name
(and (= (type-of p) "list") (= (len p) 3)
(= (type-of (nth p 1)) "keyword")
(= (keyword-name (nth p 1)) "as"))
(js-collect-params-loop params (+ i 1)
(append result (js-mangle (symbol-name (first p)))) rest-name)
;; Something else ;; Something else
:else :else
(js-collect-params-loop params (+ i 1) (js-collect-params-loop params (+ i 1)
@@ -1020,7 +1036,7 @@
(js-parse-clojure-let-bindings bindings 0 (list)))))) (js-parse-clojure-let-bindings bindings 0 (list))))))
(define js-parse-clojure-let-bindings (define js-parse-clojure-let-bindings
(fn (bindings i result) (fn (bindings (i :as number) (result :as list))
(if (>= i (- (len bindings) 1)) (if (>= i (- (len bindings) 1))
result result
(let ((vname (if (= (type-of (nth bindings i)) "symbol") (let ((vname (if (= (type-of (nth bindings i)) "symbol")
@@ -1046,7 +1062,7 @@
(str (js-emit-clojure-let-vars bindings 0 (list)) " "))))) (str (js-emit-clojure-let-vars bindings 0 (list)) " ")))))
(define js-emit-clojure-let-vars (define js-emit-clojure-let-vars
(fn (bindings i result) (fn (bindings (i :as number) (result :as list))
(if (>= i (- (len bindings) 1)) (if (>= i (- (len bindings) 1))
(join " " result) (join " " result)
(let ((vname (if (= (type-of (nth bindings i)) "symbol") (let ((vname (if (= (type-of (nth bindings i)) "symbol")
@@ -1058,7 +1074,7 @@
;; Helper to append let binding var declarations to a parts list ;; Helper to append let binding var declarations to a parts list
(define js-append-let-binding-parts (define js-append-let-binding-parts
(fn (bindings parts) (fn (bindings (parts :as list))
(when (and (list? bindings) (not (empty? bindings))) (when (and (list? bindings) (not (empty? bindings)))
(if (list? (first bindings)) (if (list? (first bindings))
;; Scheme-style ;; Scheme-style
@@ -1072,7 +1088,7 @@
(js-append-clojure-bindings bindings parts 0))))) (js-append-clojure-bindings bindings parts 0)))))
(define js-append-clojure-bindings (define js-append-clojure-bindings
(fn (bindings parts i) (fn (bindings (parts :as list) (i :as number))
(when (< i (- (len bindings) 1)) (when (< i (- (len bindings) 1))
(let ((vname (if (= (type-of (nth bindings i)) "symbol") (let ((vname (if (= (type-of (nth bindings i)) "symbol")
(symbol-name (nth bindings i)) (symbol-name (nth bindings i))
@@ -1101,7 +1117,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define js-emit-cond (define js-emit-cond
(fn (clauses) (fn ((clauses :as list))
(if (empty? clauses) (if (empty? clauses)
"NIL" "NIL"
;; Detect scheme vs clojure style ;; Detect scheme vs clojure style
@@ -1119,7 +1135,7 @@
(and (= (type-of test) "keyword") (= (keyword-name test) "else"))))) (and (= (type-of test) "keyword") (= (keyword-name test) "else")))))
(define js-cond-scheme (define js-cond-scheme
(fn (clauses) (fn ((clauses :as list))
(if (empty? clauses) (if (empty? clauses)
"NIL" "NIL"
(let ((clause (first clauses)) (let ((clause (first clauses))
@@ -1131,7 +1147,7 @@
" : " (js-cond-scheme (rest clauses)) ")")))))) " : " (js-cond-scheme (rest clauses)) ")"))))))
(define js-cond-clojure (define js-cond-clojure
(fn (clauses) (fn ((clauses :as list))
(if (< (len clauses) 2) (if (< (len clauses) 2)
"NIL" "NIL"
(let ((test (first clauses)) (let ((test (first clauses))
@@ -1147,14 +1163,14 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define js-emit-case (define js-emit-case
(fn (args) (fn ((args :as list))
(let ((match-expr (js-expr (first args))) (let ((match-expr (js-expr (first args)))
(clauses (rest args))) (clauses (rest args)))
(str "(function() { var _m = " match-expr "; " (str "(function() { var _m = " match-expr "; "
(js-case-chain clauses) " })()")))) (js-case-chain clauses) " })()"))))
(define js-case-chain (define js-case-chain
(fn (clauses) (fn ((clauses :as list))
(if (< (len clauses) 2) (if (< (len clauses) 2)
"return NIL;" "return NIL;"
(let ((test (nth clauses 0)) (let ((test (nth clauses 0))
@@ -1171,7 +1187,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define js-emit-and (define js-emit-and
(fn (args) (fn ((args :as list))
(let ((parts (map js-expr args))) (let ((parts (map js-expr args)))
(if (= (len parts) 1) (if (= (len parts) 1)
(first parts) (first parts)
@@ -1186,7 +1202,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define js-emit-or (define js-emit-or
(fn (args) (fn ((args :as list))
(if (= (len args) 1) (if (= (len args) 1)
(js-expr (first args)) (js-expr (first args))
(str "sxOr(" (join ", " (map js-expr args)) ")")))) (str "sxOr(" (join ", " (map js-expr args)) ")"))))
@@ -1197,7 +1213,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define js-emit-do (define js-emit-do
(fn (args) (fn ((args :as list))
(if (= (len args) 1) (if (= (len args) 1)
(js-expr (first args)) (js-expr (first args))
(str "(" (join ", " (map js-expr args)) ")")))) (str "(" (join ", " (map js-expr args)) ")"))))
@@ -1208,11 +1224,11 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define js-emit-dict-literal (define js-emit-dict-literal
(fn (pairs) (fn ((pairs :as list))
(str "{" (js-dict-pairs-str pairs 0 (list)) "}"))) (str "{" (js-dict-pairs-str pairs 0 (list)) "}")))
(define js-dict-pairs-str (define js-dict-pairs-str
(fn (pairs i result) (fn ((pairs :as list) (i :as number) (result :as list))
(if (>= i (- (len pairs) 1)) (if (>= i (- (len pairs) 1))
(join ", " result) (join ", " result)
(let ((key (nth pairs i)) (let ((key (nth pairs i))
@@ -1230,7 +1246,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define js-emit-infix (define js-emit-infix
(fn (op args) (fn ((op :as string) (args :as list))
(let ((js-op (js-op-symbol op))) (let ((js-op (js-op-symbol op)))
(if (and (= (len args) 1) (= op "-")) (if (and (= (len args) 1) (= op "-"))
(str "(-" (js-expr (first args)) ")") (str "(-" (js-expr (first args)) ")")
@@ -1286,8 +1302,9 @@
(= name "append!") (= name "append!")
(str (js-expr (nth expr 1)) ".push(" (js-expr (nth expr 2)) ");") (str (js-expr (nth expr 1)) ".push(" (js-expr (nth expr 2)) ");")
(= name "env-set!") (= name "env-set!")
(str (js-expr (nth expr 1)) "[" (js-expr (nth expr 2)) (str "envSet(" (js-expr (nth expr 1))
"] = " (js-expr (nth expr 3)) ";") ", " (js-expr (nth expr 2))
", " (js-expr (nth expr 3)) ");")
(= name "set-lambda-name!") (= name "set-lambda-name!")
(str (js-expr (nth expr 1)) ".name = " (js-expr (nth expr 2)) ";") (str (js-expr (nth expr 1)) ".name = " (js-expr (nth expr 2)) ";")
:else :else
@@ -1301,10 +1318,15 @@
(define js-emit-define (define js-emit-define
(fn (expr) (fn (expr)
;; Handle (define name :effects [...] value) — skip :effects annotation
(let ((name (if (= (type-of (nth expr 1)) "symbol") (let ((name (if (= (type-of (nth expr 1)) "symbol")
(symbol-name (nth expr 1)) (symbol-name (nth expr 1))
(str (nth expr 1)))) (str (nth expr 1))))
(val-expr (nth expr 2))) (val-expr (if (and (>= (len expr) 5)
(= (type-of (nth expr 2)) "keyword")
(= (keyword-name (nth expr 2)) "effects"))
(nth expr 4)
(nth expr 2))))
(if (nil? val-expr) (if (nil? val-expr)
(str "var " (js-mangle name) " = NIL;") (str "var " (js-mangle name) " = NIL;")
;; Detect zero-arg self-tail-recursive functions → while loops ;; Detect zero-arg self-tail-recursive functions → while loops
@@ -1352,9 +1374,16 @@
;; Inline lambda → for loop ;; Inline lambda → for loop
(let ((params (nth fn-expr 1)) (let ((params (nth fn-expr 1))
(body (rest (rest fn-expr))) (body (rest (rest fn-expr)))
(p (if (= (type-of (first params)) "symbol") (raw-p (first params))
(symbol-name (first params)) (p (cond
(str (first params)))) (= (type-of raw-p) "symbol")
(symbol-name raw-p)
;; (name :as type) annotation → extract name
(and (= (type-of raw-p) "list") (= (len raw-p) 3)
(= (type-of (nth raw-p 1)) "keyword")
(= (keyword-name (nth raw-p 1)) "as"))
(symbol-name (first raw-p))
:else (str raw-p)))
(p-js (js-mangle p))) (p-js (js-mangle p)))
(str "{ var _c = " coll "; for (var _i = 0; _i < _c.length; _i++) { var " (str "{ var _c = " coll "; for (var _i = 0; _i < _c.length; _i++) { var "
p-js " = _c[_i]; " p-js " = _c[_i]; "
@@ -1369,7 +1398,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define js-translate-file (define js-translate-file
(fn (defines) (fn ((defines :as list))
(join "\n" (map (fn (pair) (join "\n" (map (fn (pair)
(let ((name (first pair)) (let ((name (first pair))
(expr (nth pair 1))) (expr (nth pair 1)))

View File

@@ -33,8 +33,8 @@
;; Event dispatch helpers ;; Event dispatch helpers
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define dispatch-trigger-events (define dispatch-trigger-events :effects [mutation io]
(fn (el header-val) (fn (el (header-val :as string))
;; Dispatch events from SX-Trigger / SX-Trigger-After-Swap headers. ;; Dispatch events from SX-Trigger / SX-Trigger-After-Swap headers.
;; Value can be JSON object (name → detail) or comma-separated names. ;; Value can be JSON object (name → detail) or comma-separated names.
(when header-val (when header-val
@@ -42,12 +42,12 @@
(if parsed (if parsed
;; JSON object: keys are event names, values are detail ;; JSON object: keys are event names, values are detail
(for-each (for-each
(fn (key) (fn ((key :as string))
(dom-dispatch el key (get parsed key))) (dom-dispatch el key (get parsed key)))
(keys parsed)) (keys parsed))
;; Comma-separated event names ;; Comma-separated event names
(for-each (for-each
(fn (name) (fn ((name :as string))
(let ((trimmed (trim name))) (let ((trimmed (trim name)))
(when (not (empty? trimmed)) (when (not (empty? trimmed))
(dom-dispatch el trimmed (dict))))) (dom-dispatch el trimmed (dict)))))
@@ -58,7 +58,7 @@
;; CSS tracking ;; CSS tracking
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define init-css-tracking (define init-css-tracking :effects [mutation io]
(fn () (fn ()
;; Read initial CSS hash from meta tag ;; Read initial CSS hash from meta tag
(let ((meta (dom-query "meta[name=\"sx-css-classes\"]"))) (let ((meta (dom-query "meta[name=\"sx-css-classes\"]")))
@@ -72,8 +72,8 @@
;; Request execution ;; Request execution
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define execute-request (define execute-request :effects [mutation io]
(fn (el verbInfo extraParams) (fn (el (verbInfo :as dict) (extraParams :as dict))
;; Gate checks then delegate to do-fetch. ;; Gate checks then delegate to do-fetch.
;; verbInfo: dict with "method" and "url" (or nil to read from element). ;; verbInfo: dict with "method" and "url" (or nil to read from element).
;; Re-read from element in case attributes were morphed since binding. ;; Re-read from element in case attributes were morphed since binding.
@@ -105,16 +105,28 @@
extraParams)))))))))))) extraParams))))))))))))
(define do-fetch (define do-fetch :effects [mutation io]
(fn (el verb method url extraParams) (fn (el (verb :as string) (method :as string) (url :as string) (extraParams :as dict))
;; Execute the actual fetch. Manages abort, headers, body, loading state. ;; Execute the actual fetch. Manages abort, headers, body, loading state.
(let ((sync (dom-get-attr el "sx-sync"))) (let ((sync (dom-get-attr el "sx-sync")))
;; Abort previous if sync mode ;; Abort previous if sync mode (per-element)
(when (= sync "replace") (when (= sync "replace")
(abort-previous el)) (abort-previous el))
;; Abort any in-flight request targeting the same swap target,
;; but only when trigger and target are different elements.
;; This ensures rapid navigation (click A then B) cancels A's fetch,
;; while polling (element targets itself) doesn't abort its own requests.
(let ((target-el (resolve-target el)))
(when (and target-el (not (identical? el target-el)))
(abort-previous-target target-el)))
(let ((ctrl (new-abort-controller))) (let ((ctrl (new-abort-controller)))
(track-controller el ctrl) (track-controller el ctrl)
;; Also track against the swap target for cross-element cancellation
(let ((target-el (resolve-target el)))
(when target-el
(track-controller-target target-el ctrl)))
;; Build request ;; Build request
(let ((body-info (build-request-body el method url)) (let ((body-info (build-request-body el method url))
@@ -128,7 +140,7 @@
;; Merge extra params as headers ;; Merge extra params as headers
(when extraParams (when extraParams
(for-each (for-each
(fn (k) (dict-set! headers k (get extraParams k))) (fn ((k :as string)) (dict-set! headers k (get extraParams k)))
(keys extraParams))) (keys extraParams)))
;; Content-Type ;; Content-Type
@@ -160,7 +172,7 @@
"cross-origin" (cross-origin? final-url) "cross-origin" (cross-origin? final-url)
"preloaded" cached) "preloaded" cached)
;; Success callback ;; Success callback
(fn (resp-ok status get-header text) (fn ((resp-ok :as boolean) (status :as number) get-header (text :as string))
(do (do
(clear-loading-state el indicator disabled-elts) (clear-loading-state el indicator disabled-elts)
(revert-optimistic optimistic-state) (revert-optimistic optimistic-state)
@@ -168,7 +180,12 @@
(do (do
(dom-dispatch el "sx:responseError" (dom-dispatch el "sx:responseError"
(dict "status" status "text" text)) (dict "status" status "text" text))
(handle-retry el verb method final-url extraParams)) ;; If the error response has SX content, swap it in
;; (e.g. 404 pages) instead of just retrying
(if (and text (> (len text) 0))
(handle-fetch-success el final-url verb extraParams
get-header text)
(handle-retry el verb method final-url extraParams)))
(do (do
(dom-dispatch el "sx:afterRequest" (dom-dispatch el "sx:afterRequest"
(dict "status" status)) (dict "status" status))
@@ -184,8 +201,8 @@
(dict "error" err)))))))))))) (dict "error" err))))))))))))
(define handle-fetch-success (define handle-fetch-success :effects [mutation io]
(fn (el url verb extraParams get-header text) (fn (el (url :as string) (verb :as string) (extraParams :as dict) get-header (text :as string))
;; Route a successful response through the appropriate handler. ;; Route a successful response through the appropriate handler.
(let ((resp-headers (process-response-headers get-header))) (let ((resp-headers (process-response-headers get-header)))
;; CSS hash update ;; CSS hash update
@@ -236,20 +253,24 @@
;; History ;; History
(handle-history el url resp-headers) (handle-history el url resp-headers)
;; Settle triggers (after small delay) ;; Settle phase (after small delay): triggers + sx-on-settle hooks
(when (get resp-headers "trigger-settle") (set-timeout
(set-timeout (fn ()
(fn () (dispatch-trigger-events el ;; Server-driven settle triggers
(get resp-headers "trigger-settle"))) (when (get resp-headers "trigger-settle")
20)) (dispatch-trigger-events el
(get resp-headers "trigger-settle")))
;; sx-on-settle: evaluate SX expression after swap settles
(process-settle-hooks el))
20)
;; Lifecycle event ;; Lifecycle event
(dom-dispatch el "sx:afterSwap" (dom-dispatch el "sx:afterSwap"
(dict "target" target-el "swap" swap-style))))))) (dict "target" target-el "swap" swap-style)))))))
(define handle-sx-response (define handle-sx-response :effects [mutation io]
(fn (el target text swap-style use-transition) (fn (el target (text :as string) (swap-style :as string) (use-transition :as boolean))
;; Handle SX-format response: strip components, extract CSS, render, swap. ;; Handle SX-format response: strip components, extract CSS, render, swap.
(let ((cleaned (strip-component-scripts text))) (let ((cleaned (strip-component-scripts text)))
(let ((final (extract-response-css cleaned))) (let ((final (extract-response-css cleaned)))
@@ -260,7 +281,7 @@
(dom-append container rendered) (dom-append container rendered)
;; Process OOB swaps ;; Process OOB swaps
(process-oob-swaps container (process-oob-swaps container
(fn (t oob s) (fn (t oob (s :as string))
(dispose-islands-in t) (dispose-islands-in t)
(swap-dom-nodes t oob s) (swap-dom-nodes t oob s)
(sx-hydrate t) (sx-hydrate t)
@@ -279,8 +300,8 @@
(post-swap target))))))))))) (post-swap target)))))))))))
(define handle-html-response (define handle-html-response :effects [mutation io]
(fn (el target text swap-style use-transition) (fn (el target (text :as string) (swap-style :as string) (use-transition :as boolean))
;; Handle HTML-format response: parse, OOB, select, swap. ;; Handle HTML-format response: parse, OOB, select, swap.
(let ((doc (dom-parse-html-document text))) (let ((doc (dom-parse-html-document text)))
(when doc (when doc
@@ -299,7 +320,7 @@
(dom-set-inner-html container (dom-body-inner-html doc)) (dom-set-inner-html container (dom-body-inner-html doc))
;; Process OOB swaps ;; Process OOB swaps
(process-oob-swaps container (process-oob-swaps container
(fn (t oob s) (fn (t oob (s :as string))
(dispose-islands-in t) (dispose-islands-in t)
(swap-dom-nodes t oob s) (swap-dom-nodes t oob s)
(post-swap t))) (post-swap t)))
@@ -316,8 +337,8 @@
;; Retry ;; Retry
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define handle-retry (define handle-retry :effects [mutation io]
(fn (el verb method url extraParams) (fn (el (verb :as string) (method :as string) (url :as string) (extraParams :as dict))
;; Handle retry on failure if sx-retry is configured ;; Handle retry on failure if sx-retry is configured
(let ((retry-attr (dom-get-attr el "sx-retry")) (let ((retry-attr (dom-get-attr el "sx-retry"))
(spec (parse-retry-spec retry-attr))) (spec (parse-retry-spec retry-attr)))
@@ -336,13 +357,13 @@
;; Trigger binding ;; Trigger binding
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define bind-triggers (define bind-triggers :effects [mutation io]
(fn (el verbInfo) (fn (el (verbInfo :as dict))
;; Bind triggers from sx-trigger attribute (or defaults) ;; Bind triggers from sx-trigger attribute (or defaults)
(let ((triggers (or (parse-trigger-spec (dom-get-attr el "sx-trigger")) (let ((triggers (or (parse-trigger-spec (dom-get-attr el "sx-trigger"))
(default-trigger (dom-tag-name el))))) (default-trigger (dom-tag-name el)))))
(for-each (for-each
(fn (trigger) (fn ((trigger :as dict))
(let ((kind (classify-trigger trigger)) (let ((kind (classify-trigger trigger))
(mods (get trigger "modifiers"))) (mods (get trigger "modifiers")))
(cond (cond
@@ -371,8 +392,8 @@
triggers)))) triggers))))
(define bind-event (define bind-event :effects [mutation io]
(fn (el event-name mods verbInfo) (fn (el (event-name :as string) (mods :as dict) (verbInfo :as dict))
;; Bind a standard DOM event trigger. ;; Bind a standard DOM event trigger.
;; Handles delay, once, changed, optimistic, preventDefault. ;; Handles delay, once, changed, optimistic, preventDefault.
(let ((timer nil) (let ((timer nil)
@@ -432,7 +453,7 @@
;; Post-swap lifecycle ;; Post-swap lifecycle
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define post-swap (define post-swap :effects [mutation io]
(fn (root) (fn (root)
;; Run lifecycle after swap: activate scripts, process SX, hydrate, process ;; Run lifecycle after swap: activate scripts, process SX, hydrate, process
(activate-scripts root) (activate-scripts root)
@@ -442,7 +463,28 @@
(process-elements root))) (process-elements root)))
(define activate-scripts ;; --------------------------------------------------------------------------
;; sx-on-settle — post-swap SX evaluation
;; --------------------------------------------------------------------------
;;
;; After a swap settles, evaluate the SX expression in the trigger element's
;; sx-on-settle attribute. The expression has access to all primitives
;; (including use-store, reset!, deref) so it can update reactive state
;; based on what the server returned.
;;
;; Example: (button :sx-get "/search" :sx-on-settle "(reset! (use-store \"count\") 0)")
(define process-settle-hooks :effects [mutation io]
(fn (el)
(let ((settle-expr (dom-get-attr el "sx-on-settle")))
(when (and settle-expr (not (empty? settle-expr)))
(let ((exprs (sx-parse settle-expr)))
(for-each
(fn (expr) (eval-expr expr (env-extend (dict))))
exprs))))))
(define activate-scripts :effects [mutation io]
(fn (root) (fn (root)
;; Re-activate scripts in swapped content. ;; Re-activate scripts in swapped content.
;; Scripts inserted via innerHTML are inert — clone to make them execute. ;; Scripts inserted via innerHTML are inert — clone to make them execute.
@@ -463,13 +505,13 @@
;; OOB swap processing ;; OOB swap processing
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define process-oob-swaps (define process-oob-swaps :effects [mutation io]
(fn (container swap-fn) (fn (container (swap-fn :as lambda))
;; Find and process out-of-band swaps in container. ;; Find and process out-of-band swaps in container.
;; swap-fn is (fn (target oob-element swap-type) ...). ;; swap-fn is (fn (target oob-element swap-type) ...).
(let ((oobs (find-oob-swaps container))) (let ((oobs (find-oob-swaps container)))
(for-each (for-each
(fn (oob) (fn ((oob :as dict))
(let ((target-id (get oob "target-id")) (let ((target-id (get oob "target-id"))
(target (dom-query-by-id target-id)) (target (dom-query-by-id target-id))
(oob-el (get oob "element")) (oob-el (get oob "element"))
@@ -487,7 +529,7 @@
;; Head element hoisting ;; Head element hoisting
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define hoist-head-elements (define hoist-head-elements :effects [mutation io]
(fn (container) (fn (container)
;; Move style[data-sx-css] and link[rel=stylesheet] to <head> ;; Move style[data-sx-css] and link[rel=stylesheet] to <head>
;; so they take effect globally. ;; so they take effect globally.
@@ -509,7 +551,7 @@
;; Boost processing ;; Boost processing
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define process-boosted (define process-boosted :effects [mutation io]
(fn (root) (fn (root)
;; Find [sx-boost] containers and boost their descendants ;; Find [sx-boost] containers and boost their descendants
(for-each (for-each
@@ -518,7 +560,7 @@
(dom-query-all (or root (dom-body)) "[sx-boost]")))) (dom-query-all (or root (dom-body)) "[sx-boost]"))))
(define boost-descendants (define boost-descendants :effects [mutation io]
(fn (container) (fn (container)
;; Boost links and forms within a container. ;; Boost links and forms within a container.
;; The sx-boost attribute value is the default target selector ;; The sx-boost attribute value is the default target selector
@@ -567,8 +609,8 @@
(define _page-data-cache (dict)) (define _page-data-cache (dict))
(define _page-data-cache-ttl 30000) ;; 30 seconds in ms (define _page-data-cache-ttl 30000) ;; 30 seconds in ms
(define page-data-cache-key (define page-data-cache-key :effects []
(fn (page-name params) (fn ((page-name :as string) (params :as dict))
;; Build a cache key from page name + params. ;; Build a cache key from page name + params.
;; Params are from route matching so order is deterministic. ;; Params are from route matching so order is deterministic.
(let ((base page-name)) (let ((base page-name))
@@ -576,13 +618,13 @@
base base
(let ((parts (list))) (let ((parts (list)))
(for-each (for-each
(fn (k) (fn ((k :as string))
(append! parts (str k "=" (get params k)))) (append! parts (str k "=" (get params k))))
(keys params)) (keys params))
(str base ":" (join "&" parts))))))) (str base ":" (join "&" parts)))))))
(define page-data-cache-get (define page-data-cache-get :effects [mutation io]
(fn (cache-key) (fn ((cache-key :as string))
;; Return cached data if fresh, else nil. ;; Return cached data if fresh, else nil.
(let ((entry (get _page-data-cache cache-key))) (let ((entry (get _page-data-cache cache-key)))
(if (nil? entry) (if (nil? entry)
@@ -593,8 +635,8 @@
nil) nil)
(get entry "data")))))) (get entry "data"))))))
(define page-data-cache-set (define page-data-cache-set :effects [mutation io]
(fn (cache-key data) (fn ((cache-key :as string) data)
;; Store data with current timestamp. ;; Store data with current timestamp.
(dict-set! _page-data-cache cache-key (dict-set! _page-data-cache cache-key
{"data" data "ts" (now-ms)}))) {"data" data "ts" (now-ms)})))
@@ -604,28 +646,28 @@
;; Client-side routing — cache management ;; Client-side routing — cache management
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define invalidate-page-cache (define invalidate-page-cache :effects [mutation io]
(fn (page-name) (fn ((page-name :as string))
;; Clear cached data for a page. Removes all cache entries whose key ;; Clear cached data for a page. Removes all cache entries whose key
;; matches page-name (exact) or starts with "page-name:" (with params). ;; matches page-name (exact) or starts with "page-name:" (with params).
;; Also notifies the service worker to clear its IndexedDB entries. ;; Also notifies the service worker to clear its IndexedDB entries.
(for-each (for-each
(fn (k) (fn ((k :as string))
(when (or (= k page-name) (starts-with? k (str page-name ":"))) (when (or (= k page-name) (starts-with? k (str page-name ":")))
(dict-set! _page-data-cache k nil))) (dict-set! _page-data-cache k nil)))
(keys _page-data-cache)) (keys _page-data-cache))
(sw-post-message {"type" "invalidate" "page" page-name}) (sw-post-message {"type" "invalidate" "page" page-name})
(log-info (str "sx:cache invalidate " page-name)))) (log-info (str "sx:cache invalidate " page-name))))
(define invalidate-all-page-cache (define invalidate-all-page-cache :effects [mutation io]
(fn () (fn ()
;; Clear all cached page data and notify service worker. ;; Clear all cached page data and notify service worker.
(set! _page-data-cache (dict)) (set! _page-data-cache (dict))
(sw-post-message {"type" "invalidate" "page" "*"}) (sw-post-message {"type" "invalidate" "page" "*"})
(log-info "sx:cache invalidate *"))) (log-info "sx:cache invalidate *")))
(define update-page-cache (define update-page-cache :effects [mutation io]
(fn (page-name data) (fn ((page-name :as string) data)
;; Replace cached data for a page with server-provided data. ;; Replace cached data for a page with server-provided data.
;; Uses a bare page-name key (no params) — the server knows the ;; Uses a bare page-name key (no params) — the server knows the
;; canonical data shape for the page. ;; canonical data shape for the page.
@@ -633,8 +675,8 @@
(page-data-cache-set cache-key data) (page-data-cache-set cache-key data)
(log-info (str "sx:cache update " page-name))))) (log-info (str "sx:cache update " page-name)))))
(define process-cache-directives (define process-cache-directives :effects [mutation io]
(fn (el resp-headers response-text) (fn (el (resp-headers :as dict) (response-text :as string))
;; Process cache invalidation and update directives from both ;; Process cache invalidation and update directives from both
;; element attributes and response headers. ;; element attributes and response headers.
;; ;;
@@ -679,8 +721,8 @@
(define _optimistic-snapshots (dict)) (define _optimistic-snapshots (dict))
(define optimistic-cache-update (define optimistic-cache-update :effects [mutation]
(fn (cache-key mutator) (fn ((cache-key :as string) (mutator :as lambda))
;; Apply predicted mutation to cached data. Saves snapshot for rollback. ;; Apply predicted mutation to cached data. Saves snapshot for rollback.
;; Returns predicted data or nil if no cached data exists. ;; Returns predicted data or nil if no cached data exists.
(let ((cached (page-data-cache-get cache-key))) (let ((cached (page-data-cache-get cache-key)))
@@ -692,8 +734,8 @@
(page-data-cache-set cache-key predicted) (page-data-cache-set cache-key predicted)
predicted))))) predicted)))))
(define optimistic-cache-revert (define optimistic-cache-revert :effects [mutation]
(fn (cache-key) (fn ((cache-key :as string))
;; Revert to pre-mutation snapshot. Returns restored data or nil. ;; Revert to pre-mutation snapshot. Returns restored data or nil.
(let ((snapshot (get _optimistic-snapshots cache-key))) (let ((snapshot (get _optimistic-snapshots cache-key)))
(when snapshot (when snapshot
@@ -701,13 +743,13 @@
(dict-delete! _optimistic-snapshots cache-key) (dict-delete! _optimistic-snapshots cache-key)
snapshot)))) snapshot))))
(define optimistic-cache-confirm (define optimistic-cache-confirm :effects [mutation]
(fn (cache-key) (fn ((cache-key :as string))
;; Server accepted — discard the rollback snapshot. ;; Server accepted — discard the rollback snapshot.
(dict-delete! _optimistic-snapshots cache-key))) (dict-delete! _optimistic-snapshots cache-key)))
(define submit-mutation (define submit-mutation :effects [mutation io]
(fn (page-name params action-name payload mutator-fn on-complete) (fn ((page-name :as string) (params :as dict) (action-name :as string) payload (mutator-fn :as lambda) (on-complete :as lambda))
;; Optimistic mutation: predict locally, send to server, confirm or revert. ;; Optimistic mutation: predict locally, send to server, confirm or revert.
;; on-complete is called with "confirmed" or "reverted" status. ;; on-complete is called with "confirmed" or "reverted" status.
(let ((cache-key (page-data-cache-key page-name params)) (let ((cache-key (page-data-cache-key page-name params))
@@ -726,7 +768,7 @@
(try-rerender-page page-name params result)) (try-rerender-page page-name params result))
(log-info (str "sx:optimistic confirmed " page-name)) (log-info (str "sx:optimistic confirmed " page-name))
(when on-complete (on-complete "confirmed"))) (when on-complete (on-complete "confirmed")))
(fn (error) (fn ((error :as string))
;; Failure: revert to snapshot ;; Failure: revert to snapshot
(let ((reverted (optimistic-cache-revert cache-key))) (let ((reverted (optimistic-cache-revert cache-key)))
(when reverted (when reverted
@@ -745,15 +787,15 @@
(define _is-online true) (define _is-online true)
(define _offline-queue (list)) (define _offline-queue (list))
(define offline-is-online? (define offline-is-online? :effects [io]
(fn () _is-online)) (fn () _is-online))
(define offline-set-online! (define offline-set-online! :effects [mutation]
(fn (val) (fn ((val :as boolean))
(set! _is-online val))) (set! _is-online val)))
(define offline-queue-mutation (define offline-queue-mutation :effects [mutation io]
(fn (action-name payload page-name params mutator-fn) (fn ((action-name :as string) payload (page-name :as string) (params :as dict) (mutator-fn :as lambda))
;; Queue a mutation for later sync. Apply optimistic update locally. ;; Queue a mutation for later sync. Apply optimistic update locally.
(let ((cache-key (page-data-cache-key page-name params)) (let ((cache-key (page-data-cache-key page-name params))
(entry (dict (entry (dict
@@ -771,29 +813,29 @@
(log-info (str "sx:offline queued " action-name " (" (len _offline-queue) " pending)")) (log-info (str "sx:offline queued " action-name " (" (len _offline-queue) " pending)"))
entry))) entry)))
(define offline-sync (define offline-sync :effects [mutation io]
(fn () (fn ()
;; Replay all pending mutations. Called on reconnect. ;; Replay all pending mutations. Called on reconnect.
(let ((pending (filter (fn (e) (= (get e "status") "pending")) _offline-queue))) (let ((pending (filter (fn ((e :as dict)) (= (get e "status") "pending")) _offline-queue)))
(when (not (empty? pending)) (when (not (empty? pending))
(log-info (str "sx:offline syncing " (len pending) " mutations")) (log-info (str "sx:offline syncing " (len pending) " mutations"))
(for-each (for-each
(fn (entry) (fn ((entry :as dict))
(execute-action (get entry "action") (get entry "payload") (execute-action (get entry "action") (get entry "payload")
(fn (result) (fn (result)
(dict-set! entry "status" "synced") (dict-set! entry "status" "synced")
(log-info (str "sx:offline synced " (get entry "action")))) (log-info (str "sx:offline synced " (get entry "action"))))
(fn (error) (fn ((error :as string))
(dict-set! entry "status" "failed") (dict-set! entry "status" "failed")
(log-warn (str "sx:offline sync failed " (get entry "action") ": " error))))) (log-warn (str "sx:offline sync failed " (get entry "action") ": " error)))))
pending))))) pending)))))
(define offline-pending-count (define offline-pending-count :effects [io]
(fn () (fn ()
(len (filter (fn (e) (= (get e "status") "pending")) _offline-queue)))) (len (filter (fn ((e :as dict)) (= (get e "status") "pending")) _offline-queue))))
(define offline-aware-mutation (define offline-aware-mutation :effects [mutation io]
(fn (page-name params action-name payload mutator-fn on-complete) (fn ((page-name :as string) (params :as dict) (action-name :as string) payload (mutator-fn :as lambda) (on-complete :as lambda))
;; Top-level mutation function. Routes to submit-mutation when online, ;; Top-level mutation function. Routes to submit-mutation when online,
;; offline-queue-mutation when offline. ;; offline-queue-mutation when offline.
(if _is-online (if _is-online
@@ -807,7 +849,7 @@
;; Client-side routing ;; Client-side routing
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define current-page-layout (define current-page-layout :effects [io]
(fn () (fn ()
;; Find the layout name of the currently displayed page by matching ;; Find the layout name of the currently displayed page by matching
;; the browser URL against the page route table. ;; the browser URL against the page route table.
@@ -817,8 +859,8 @@
(or (get match "layout") ""))))) (or (get match "layout") "")))))
(define swap-rendered-content (define swap-rendered-content :effects [mutation io]
(fn (target rendered pathname) (fn (target rendered (pathname :as string))
;; Swap rendered DOM content into target and run post-processing. ;; Swap rendered DOM content into target and run post-processing.
;; Shared by pure and data page client routes. ;; Shared by pure and data page client routes.
(do (do
@@ -833,26 +875,26 @@
(log-info (str "sx:route client " pathname))))) (log-info (str "sx:route client " pathname)))))
(define resolve-route-target (define resolve-route-target :effects [io]
(fn (target-sel) (fn ((target-sel :as string))
;; Resolve a target selector to a DOM element, or nil. ;; Resolve a target selector to a DOM element, or nil.
(if (and target-sel (not (= target-sel "true"))) (if (and target-sel (not (= target-sel "true")))
(dom-query target-sel) (dom-query target-sel)
nil))) nil)))
(define deps-satisfied? (define deps-satisfied? :effects [io]
(fn (match) (fn ((match :as dict))
;; Check if all component deps for a page are loaded client-side. ;; Check if all component deps for a page are loaded client-side.
(let ((deps (get match "deps")) (let ((deps (get match "deps"))
(loaded (loaded-component-names))) (loaded (loaded-component-names)))
(if (or (nil? deps) (empty? deps)) (if (or (nil? deps) (empty? deps))
true true
(every? (fn (dep) (contains? loaded dep)) deps))))) (every? (fn ((dep :as string)) (contains? loaded dep)) deps)))))
(define try-client-route (define try-client-route :effects [mutation io]
(fn (pathname target-sel) (fn ((pathname :as string) (target-sel :as string))
;; Try to render a page client-side. Returns true if successful, false otherwise. ;; Try to render a page client-side. Returns true if successful, false otherwise.
;; target-sel is the CSS selector for the swap target (from sx-boost value). ;; target-sel is the CSS selector for the swap target (from sx-boost value).
;; For pure pages: renders immediately. For :data pages: fetches data then renders. ;; For pure pages: renders immediately. For :data pages: fetches data then renders.
@@ -909,7 +951,9 @@
(try-async-eval-content content-src env (try-async-eval-content content-src env
(fn (rendered) (fn (rendered)
(if (nil? rendered) (if (nil? rendered)
(log-warn (str "sx:route async eval failed for " pathname)) (do (log-warn (str "sx:route cache+async eval failed for " pathname " — server fallback"))
(fetch-and-restore target pathname
(build-request-headers target (loaded-component-names) _css-hash) 0))
(swap-rendered-content target rendered pathname)))) (swap-rendered-content target rendered pathname))))
true) true)
;; Sync render (data only) ;; Sync render (data only)
@@ -924,7 +968,7 @@
(do (do
(log-info (str "sx:route client+data " pathname)) (log-info (str "sx:route client+data " pathname))
(resolve-page-data page-name params (resolve-page-data page-name params
(fn (data) (fn ((data :as dict))
(page-data-cache-set cache-key data) (page-data-cache-set cache-key data)
(let ((env (merge closure params data))) (let ((env (merge closure params data)))
(if has-io (if has-io
@@ -932,12 +976,16 @@
(try-async-eval-content content-src env (try-async-eval-content content-src env
(fn (rendered) (fn (rendered)
(if (nil? rendered) (if (nil? rendered)
(log-warn (str "sx:route data+async eval failed for " pathname)) (do (log-warn (str "sx:route data+async eval failed for " pathname " — server fallback"))
(fetch-and-restore target pathname
(build-request-headers target (loaded-component-names) _css-hash) 0))
(swap-rendered-content target rendered pathname)))) (swap-rendered-content target rendered pathname))))
;; Sync render (data only) ;; Sync render (data only)
(let ((rendered (try-eval-content content-src env))) (let ((rendered (try-eval-content content-src env)))
(if (nil? rendered) (if (nil? rendered)
(log-warn (str "sx:route data eval failed for " pathname)) (do (log-warn (str "sx:route data eval failed for " pathname " — server fallback"))
(fetch-and-restore target pathname
(build-request-headers target (loaded-component-names) _css-hash) 0))
(swap-rendered-content target rendered pathname))))))) (swap-rendered-content target rendered pathname)))))))
true))) true)))
;; Non-data page ;; Non-data page
@@ -948,7 +996,9 @@
(try-async-eval-content content-src (merge closure params) (try-async-eval-content content-src (merge closure params)
(fn (rendered) (fn (rendered)
(if (nil? rendered) (if (nil? rendered)
(log-warn (str "sx:route async eval failed for " pathname)) (do (log-warn (str "sx:route async eval failed for " pathname " — server fallback"))
(fetch-and-restore target pathname
(build-request-headers target (loaded-component-names) _css-hash) 0))
(swap-rendered-content target rendered pathname)))) (swap-rendered-content target rendered pathname))))
true) true)
;; Pure page: render immediately ;; Pure page: render immediately
@@ -961,8 +1011,8 @@
true)))))))))))))))))) true))))))))))))))))))
(define bind-client-route-link (define bind-client-route-link :effects [mutation io]
(fn (link href) (fn (link (href :as string))
;; Bind a boost link with client-side routing. If the route can be ;; Bind a boost link with client-side routing. If the route can be
;; rendered client-side (pure page, no :data), do so. Otherwise ;; rendered client-side (pure page, no :data), do so. Otherwise
;; fall back to standard server fetch via bind-boost-link. ;; fall back to standard server fetch via bind-boost-link.
@@ -976,7 +1026,7 @@
;; SSE processing ;; SSE processing
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define process-sse (define process-sse :effects [mutation io]
(fn (root) (fn (root)
;; Find and bind SSE elements ;; Find and bind SSE elements
(for-each (for-each
@@ -987,7 +1037,7 @@
(dom-query-all (or root (dom-body)) "[sx-sse]")))) (dom-query-all (or root (dom-body)) "[sx-sse]"))))
(define bind-sse (define bind-sse :effects [mutation io]
(fn (el) (fn (el)
;; Connect to SSE endpoint and bind swap handler ;; Connect to SSE endpoint and bind swap handler
(let ((url (dom-get-attr el "sx-sse"))) (let ((url (dom-get-attr el "sx-sse")))
@@ -995,12 +1045,12 @@
(let ((source (event-source-connect url el)) (let ((source (event-source-connect url el))
(event-name (parse-sse-swap el))) (event-name (parse-sse-swap el)))
(event-source-listen source event-name (event-source-listen source event-name
(fn (data) (fn ((data :as string))
(bind-sse-swap el data)))))))) (bind-sse-swap el data))))))))
(define bind-sse-swap (define bind-sse-swap :effects [mutation io]
(fn (el data) (fn (el (data :as string))
;; Handle an SSE event: swap data into element ;; Handle an SSE event: swap data into element
(let ((target (resolve-target el)) (let ((target (resolve-target el))
(swap-spec (parse-swap-spec (swap-spec (parse-swap-spec
@@ -1031,29 +1081,41 @@
;; Inline event handlers ;; Inline event handlers
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define bind-inline-handlers (define bind-inline-handlers :effects [mutation io]
(fn (root) (fn (root)
;; Find elements with sx-on:* attributes and bind handlers ;; Find elements with sx-on:* attributes and bind SX event handlers.
;; Handler bodies are SX expressions evaluated with `event` and `this`
;; bound in scope. No raw JS — handlers are pure SX.
(for-each (for-each
(fn (el) (fn (el)
(for-each (for-each
(fn (attr) (fn ((attr :as list))
(let ((name (first attr)) (let ((name (first attr))
(body (nth attr 1))) (body (nth attr 1)))
(when (starts-with? name "sx-on:") (when (starts-with? name "sx-on:")
(let ((event-name (slice name 6))) (let ((event-name (slice name 6)))
(when (not (is-processed? el (str "on:" event-name))) (when (not (is-processed? el (str "on:" event-name)))
(mark-processed! el (str "on:" event-name)) (mark-processed! el (str "on:" event-name))
(bind-inline-handler el event-name body)))))) ;; Parse body as SX, bind handler that evaluates it
(let ((exprs (sx-parse body)))
(dom-listen el event-name
(fn (e)
(let ((handler-env (env-extend (dict))))
(env-set! handler-env "event" e)
(env-set! handler-env "this" el)
(env-set! handler-env "detail" (event-detail e))
(for-each
(fn (expr) (eval-expr expr handler-env))
exprs))))))))))
(dom-attr-list el))) (dom-attr-list el)))
(dom-query-all (or root (dom-body)) "[sx-on\\:beforeRequest],[sx-on\\:afterRequest],[sx-on\\:afterSwap],[sx-on\\:afterSettle],[sx-on\\:load]")))) (dom-query-all (or root (dom-body)) "[sx-on\\:]"))))
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; Preload ;; Preload
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define bind-preload-for (define bind-preload-for :effects [mutation io]
(fn (el) (fn (el)
;; Bind preload event listeners based on sx-preload attribute ;; Bind preload event listeners based on sx-preload attribute
(let ((preload-attr (dom-get-attr el "sx-preload"))) (let ((preload-attr (dom-get-attr el "sx-preload")))
@@ -1072,8 +1134,8 @@
(loaded-component-names) _css-hash))))))))))) (loaded-component-names) _css-hash)))))))))))
(define do-preload (define do-preload :effects [mutation io]
(fn (url headers) (fn ((url :as string) (headers :as dict))
;; Execute a preload fetch into the cache ;; Execute a preload fetch into the cache
(when (nil? (preload-cache-get _preload-cache url)) (when (nil? (preload-cache-get _preload-cache url))
(fetch-preload url headers _preload-cache)))) (fetch-preload url headers _preload-cache))))
@@ -1086,7 +1148,7 @@
(define VERB_SELECTOR (define VERB_SELECTOR
(str "[sx-get],[sx-post],[sx-put],[sx-delete],[sx-patch]")) (str "[sx-get],[sx-post],[sx-put],[sx-delete],[sx-patch]"))
(define process-elements (define process-elements :effects [mutation io]
(fn (root) (fn (root)
;; Find all elements with sx-* verb attributes and process them. ;; Find all elements with sx-* verb attributes and process them.
(let ((els (dom-query-all (or root (dom-body)) VERB_SELECTOR))) (let ((els (dom-query-all (or root (dom-body)) VERB_SELECTOR)))
@@ -1103,7 +1165,7 @@
(process-emit-elements root))) (process-emit-elements root)))
(define process-one (define process-one :effects [mutation io]
(fn (el) (fn (el)
;; Process a single element with an sx-* verb attribute ;; Process a single element with an sx-* verb attribute
(let ((verb-info (get-verb-info el))) (let ((verb-info (get-verb-info el)))
@@ -1131,7 +1193,7 @@
;; On click → dispatches CustomEvent "cart:add" with detail {id:42, name:"Widget"} ;; On click → dispatches CustomEvent "cart:add" with detail {id:42, name:"Widget"}
;; The event bubbles up to the island container where bridge-event catches it. ;; The event bubbles up to the island container where bridge-event catches it.
(define process-emit-elements (define process-emit-elements :effects [mutation io]
(fn (root) (fn (root)
(let ((els (dom-query-all (or root (dom-body)) "[data-sx-emit]"))) (let ((els (dom-query-all (or root (dom-body)) "[data-sx-emit]")))
(for-each (for-each
@@ -1152,8 +1214,8 @@
;; History: popstate handler ;; History: popstate handler
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define handle-popstate (define handle-popstate :effects [mutation io]
(fn (scrollY) (fn ((scrollY :as number))
;; Handle browser back/forward navigation. ;; Handle browser back/forward navigation.
;; Derive target from [sx-boost] container or fall back to #main-panel. ;; Derive target from [sx-boost] container or fall back to #main-panel.
;; Try client-side route first, fall back to server fetch. ;; Try client-side route first, fall back to server fetch.
@@ -1179,7 +1241,7 @@
;; Initialization ;; Initialization
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define engine-init (define engine-init :effects [mutation io]
(fn () (fn ()
;; Initialize: CSS tracking, scripts, hydrate, process. ;; Initialize: CSS tracking, scripts, hydrate, process.
(do (do
@@ -1209,6 +1271,8 @@
;; === Abort controllers === ;; === Abort controllers ===
;; (abort-previous el) → abort + remove controller for element ;; (abort-previous el) → abort + remove controller for element
;; (track-controller el ctrl) → store controller for element ;; (track-controller el ctrl) → store controller for element
;; (abort-previous-target el) → abort + remove controller for target element
;; (track-controller-target el c) → store controller keyed by target element
;; (new-abort-controller) → new AbortController() ;; (new-abort-controller) → new AbortController()
;; (controller-signal ctrl) → ctrl.signal ;; (controller-signal ctrl) → ctrl.signal
;; (abort-error? err) → boolean (err.name === "AbortError") ;; (abort-error? err) → boolean (err.name === "AbortError")
@@ -1274,7 +1338,7 @@
;; (bind-client-route-click link href fallback-fn) → void (client route click handler) ;; (bind-client-route-click link href fallback-fn) → void (client route click handler)
;; ;;
;; === Inline handlers === ;; === Inline handlers ===
;; (bind-inline-handler el event-name body) → void (new Function) ;; (sx-on:* handlers are now evaluated as SX, not delegated to platform)
;; ;;
;; === Preload === ;; === Preload ===
;; (bind-preload el events debounce-ms fn) → void ;; (bind-preload el events debounce-ms fn) → void

View File

@@ -0,0 +1,368 @@
;; ==========================================================================
;; page-helpers.sx — Pure data-transformation page helpers
;;
;; These functions take raw data (from Python I/O edge) and return
;; structured dicts for page rendering. No I/O — pure transformations
;; only. Bootstrapped to every host.
;; ==========================================================================
;; --------------------------------------------------------------------------
;; categorize-special-forms
;;
;; Parses define-special-form declarations from special-forms.sx AST,
;; categorizes each form by name lookup, returns dict of category → forms.
;; --------------------------------------------------------------------------
(define special-form-category-map
{"if" "Control Flow" "when" "Control Flow" "cond" "Control Flow"
"case" "Control Flow" "and" "Control Flow" "or" "Control Flow"
"let" "Binding" "let*" "Binding" "letrec" "Binding"
"define" "Binding" "set!" "Binding"
"lambda" "Functions & Components" "fn" "Functions & Components"
"defcomp" "Functions & Components" "defmacro" "Functions & Components"
"begin" "Sequencing & Threading" "do" "Sequencing & Threading"
"->" "Sequencing & Threading"
"quote" "Quoting" "quasiquote" "Quoting"
"reset" "Continuations" "shift" "Continuations"
"dynamic-wind" "Guards"
"map" "Higher-Order Forms" "map-indexed" "Higher-Order Forms"
"filter" "Higher-Order Forms" "reduce" "Higher-Order Forms"
"some" "Higher-Order Forms" "every?" "Higher-Order Forms"
"for-each" "Higher-Order Forms"
"defstyle" "Domain Definitions"
"defhandler" "Domain Definitions" "defpage" "Domain Definitions"
"defquery" "Domain Definitions" "defaction" "Domain Definitions"})
(define extract-define-kwargs
(fn ((expr :as list))
;; Extract keyword args from a define-special-form expression.
;; Returns dict of keyword-name → string value.
;; Walks items pairwise: when item[i] is a keyword, item[i+1] is its value.
(let ((result {})
(items (slice expr 2))
(n (len items)))
(for-each
(fn ((idx :as number))
(when (and (< (+ idx 1) n)
(= (type-of (nth items idx)) "keyword"))
(let ((key (keyword-name (nth items idx)))
(val (nth items (+ idx 1))))
(dict-set! result key
(if (= (type-of val) "list")
(str "(" (join " " (map serialize val)) ")")
(str val))))))
(range 0 n))
result)))
(define categorize-special-forms
(fn ((parsed-exprs :as list))
;; parsed-exprs: result of parse-all on special-forms.sx
;; Returns dict of category-name → list of form dicts.
(let ((categories {}))
(for-each
(fn (expr)
(when (and (= (type-of expr) "list")
(>= (len expr) 2)
(= (type-of (first expr)) "symbol")
(= (symbol-name (first expr)) "define-special-form"))
(let ((name (nth expr 1))
(kwargs (extract-define-kwargs expr))
(category (or (get special-form-category-map name) "Other")))
(when (not (has-key? categories category))
(dict-set! categories category (list)))
(append! (get categories category)
{"name" name
"syntax" (or (get kwargs "syntax") "")
"doc" (or (get kwargs "doc") "")
"tail-position" (or (get kwargs "tail-position") "")
"example" (or (get kwargs "example") "")}))))
parsed-exprs)
categories)))
;; --------------------------------------------------------------------------
;; build-reference-data
;;
;; Takes a slug and raw reference data, returns structured dict for rendering.
;; --------------------------------------------------------------------------
(define build-ref-items-with-href
(fn ((items :as list) (base-path :as string) (detail-keys :as list) (n-fields :as number))
;; items: list of lists (tuples), each with n-fields elements
;; base-path: e.g. "/geography/hypermedia/reference/attributes/"
;; detail-keys: list of strings (keys that have detail pages)
;; n-fields: 2 or 3 (number of fields per tuple)
(map
(fn ((item :as list))
(if (= n-fields 3)
;; [name, desc/value, exists/desc]
(let ((name (nth item 0))
(field2 (nth item 1))
(field3 (nth item 2)))
{"name" name
"desc" field2
"exists" field3
"href" (if (and field3 (some (fn ((k :as string)) (= k name)) detail-keys))
(str base-path name)
nil)})
;; [name, desc]
(let ((name (nth item 0))
(desc (nth item 1)))
{"name" name
"desc" desc
"href" (if (some (fn ((k :as string)) (= k name)) detail-keys)
(str base-path name)
nil)})))
items)))
(define build-reference-data
(fn ((slug :as string) (raw-data :as dict) (detail-keys :as list))
;; slug: "attributes", "headers", "events", "js-api"
;; raw-data: dict with the raw data lists for this slug
;; detail-keys: list of names that have detail pages
(case slug
"attributes"
{"req-attrs" (build-ref-items-with-href
(get raw-data "req-attrs")
"/geography/hypermedia/reference/attributes/" detail-keys 3)
"beh-attrs" (build-ref-items-with-href
(get raw-data "beh-attrs")
"/geography/hypermedia/reference/attributes/" detail-keys 3)
"uniq-attrs" (build-ref-items-with-href
(get raw-data "uniq-attrs")
"/geography/hypermedia/reference/attributes/" detail-keys 3)}
"headers"
{"req-headers" (build-ref-items-with-href
(get raw-data "req-headers")
"/geography/hypermedia/reference/headers/" detail-keys 3)
"resp-headers" (build-ref-items-with-href
(get raw-data "resp-headers")
"/geography/hypermedia/reference/headers/" detail-keys 3)}
"events"
{"events-list" (build-ref-items-with-href
(get raw-data "events-list")
"/geography/hypermedia/reference/events/" detail-keys 2)}
"js-api"
{"js-api-list" (map (fn ((item :as list)) {"name" (nth item 0) "desc" (nth item 1)})
(get raw-data "js-api-list"))}
;; default: attributes
:else
{"req-attrs" (build-ref-items-with-href
(get raw-data "req-attrs")
"/geography/hypermedia/reference/attributes/" detail-keys 3)
"beh-attrs" (build-ref-items-with-href
(get raw-data "beh-attrs")
"/geography/hypermedia/reference/attributes/" detail-keys 3)
"uniq-attrs" (build-ref-items-with-href
(get raw-data "uniq-attrs")
"/geography/hypermedia/reference/attributes/" detail-keys 3)})))
;; --------------------------------------------------------------------------
;; build-attr-detail / build-header-detail / build-event-detail
;;
;; Lookup a slug in a detail dict, reshape for page rendering.
;; --------------------------------------------------------------------------
(define build-attr-detail
(fn ((slug :as string) detail)
;; detail: dict with "description", "example", "handler", "demo" keys or nil
(if (nil? detail)
{"attr-not-found" true}
{"attr-not-found" nil
"attr-title" slug
"attr-description" (get detail "description")
"attr-example" (get detail "example")
"attr-handler" (get detail "handler")
"attr-demo" (get detail "demo")
"attr-wire-id" (if (has-key? detail "handler")
(str "ref-wire-"
(replace (replace slug ":" "-") "*" "star"))
nil)})))
(define build-header-detail
(fn ((slug :as string) detail)
(if (nil? detail)
{"header-not-found" true}
{"header-not-found" nil
"header-title" slug
"header-direction" (get detail "direction")
"header-description" (get detail "description")
"header-example" (get detail "example")
"header-demo" (get detail "demo")})))
(define build-event-detail
(fn ((slug :as string) detail)
(if (nil? detail)
{"event-not-found" true}
{"event-not-found" nil
"event-title" slug
"event-description" (get detail "description")
"event-example" (get detail "example")
"event-demo" (get detail "demo")})))
;; --------------------------------------------------------------------------
;; build-component-source
;;
;; Reconstruct defcomp/defisland source from component metadata.
;; --------------------------------------------------------------------------
(define build-component-source
(fn ((comp-data :as dict))
;; comp-data: dict with "type", "name", "params", "has-children", "body-sx", "affinity"
(let ((comp-type (get comp-data "type"))
(name (get comp-data "name"))
(params (get comp-data "params"))
(has-children (get comp-data "has-children"))
(body-sx (get comp-data "body-sx"))
(affinity (get comp-data "affinity")))
(if (= comp-type "not-found")
(str ";; component " name " not found")
(let ((param-strs (if (empty? params)
(if has-children
(list "&rest" "children")
(list))
(if has-children
(append (cons "&key" params) (list "&rest" "children"))
(cons "&key" params))))
(params-sx (str "(" (join " " param-strs) ")"))
(form-name (if (= comp-type "island") "defisland" "defcomp"))
(affinity-str (if (and (= comp-type "component")
(not (nil? affinity))
(not (= affinity "auto")))
(str " :affinity " affinity)
"")))
(str "(" form-name " " name " " params-sx affinity-str "\n " body-sx ")"))))))
;; --------------------------------------------------------------------------
;; build-bundle-analysis
;;
;; Compute per-page bundle stats from pre-extracted component data.
;; --------------------------------------------------------------------------
(define build-bundle-analysis
(fn ((pages-raw :as list) (components-raw :as dict) (total-components :as number) (total-macros :as number) (pure-count :as number) (io-count :as number))
;; pages-raw: list of {:name :path :direct :needed-names}
;; components-raw: dict of name → {:is-pure :affinity :render-target :io-refs :deps :source}
(let ((pages-data (list)))
(for-each
(fn ((page :as dict))
(let ((needed-names (get page "needed-names"))
(n (len needed-names))
(pct (if (> total-components 0)
(round (* (/ n total-components) 100))
0))
(savings (- 100 pct))
(pure-in-page 0)
(io-in-page 0)
(page-io-refs (list))
(comp-details (list)))
;; Walk needed components
(for-each
(fn ((comp-name :as string))
(let ((info (get components-raw comp-name)))
(when (not (nil? info))
(if (get info "is-pure")
(set! pure-in-page (+ pure-in-page 1))
(do
(set! io-in-page (+ io-in-page 1))
(for-each
(fn ((ref :as string)) (when (not (some (fn ((r :as string)) (= r ref)) page-io-refs))
(append! page-io-refs ref)))
(or (get info "io-refs") (list)))))
(append! comp-details
{"name" comp-name
"is-pure" (get info "is-pure")
"affinity" (get info "affinity")
"render-target" (get info "render-target")
"io-refs" (or (get info "io-refs") (list))
"deps" (or (get info "deps") (list))
"source" (get info "source")}))))
needed-names)
(append! pages-data
{"name" (get page "name")
"path" (get page "path")
"direct" (get page "direct")
"needed" n
"pct" pct
"savings" savings
"io-refs" (len page-io-refs)
"pure-in-page" pure-in-page
"io-in-page" io-in-page
"components" comp-details})))
pages-raw)
{"pages" pages-data
"total-components" total-components
"total-macros" total-macros
"pure-count" pure-count
"io-count" io-count})))
;; --------------------------------------------------------------------------
;; build-routing-analysis
;;
;; Classify pages by routing mode (client vs server).
;; --------------------------------------------------------------------------
(define build-routing-analysis
(fn ((pages-raw :as list))
;; pages-raw: list of {:name :path :has-data :content-src}
(let ((pages-data (list))
(client-count 0)
(server-count 0))
(for-each
(fn ((page :as dict))
(let ((has-data (get page "has-data"))
(content-src (or (get page "content-src") ""))
(mode nil)
(reason ""))
(cond
has-data
(do (set! mode "server")
(set! reason "Has :data expression — needs server IO")
(set! server-count (+ server-count 1)))
(empty? content-src)
(do (set! mode "server")
(set! reason "No content expression")
(set! server-count (+ server-count 1)))
:else
(do (set! mode "client")
(set! client-count (+ client-count 1))))
(append! pages-data
{"name" (get page "name")
"path" (get page "path")
"mode" mode
"has-data" has-data
"content-expr" (if (> (len content-src) 80)
(str (slice content-src 0 80) "...")
content-src)
"reason" reason})))
pages-raw)
{"pages" pages-data
"total-pages" (+ client-count server-count)
"client-count" client-count
"server-count" server-count})))
;; --------------------------------------------------------------------------
;; build-affinity-analysis
;;
;; Package component affinity info + page render plans for display.
;; --------------------------------------------------------------------------
(define build-affinity-analysis
(fn ((demo-components :as list) (page-plans :as list))
{"components" demo-components
"page-plans" page-plans}))

View File

@@ -49,20 +49,20 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; Returns a list of top-level AST expressions. ;; Returns a list of top-level AST expressions.
(define sx-parse (define sx-parse :effects []
(fn (source) (fn ((source :as string))
(let ((pos 0) (let ((pos 0)
(len-src (len source))) (len-src (len source)))
;; -- Cursor helpers (closure over pos, source, len-src) -- ;; -- Cursor helpers (closure over pos, source, len-src) --
(define skip-comment (define skip-comment :effects []
(fn () (fn ()
(when (and (< pos len-src) (not (= (nth source pos) "\n"))) (when (and (< pos len-src) (not (= (nth source pos) "\n")))
(set! pos (inc pos)) (set! pos (inc pos))
(skip-comment)))) (skip-comment))))
(define skip-ws (define skip-ws :effects []
(fn () (fn ()
(when (< pos len-src) (when (< pos len-src)
(let ((ch (nth source pos))) (let ((ch (nth source pos)))
@@ -80,11 +80,11 @@
;; -- Atom readers -- ;; -- Atom readers --
(define read-string (define read-string :effects []
(fn () (fn ()
(set! pos (inc pos)) ;; skip opening " (set! pos (inc pos)) ;; skip opening "
(let ((buf "")) (let ((buf ""))
(define read-str-loop (define read-str-loop :effects []
(fn () (fn ()
(if (>= pos len-src) (if (>= pos len-src)
(error "Unterminated string") (error "Unterminated string")
@@ -110,10 +110,10 @@
(read-str-loop) (read-str-loop)
buf))) buf)))
(define read-ident (define read-ident :effects []
(fn () (fn ()
(let ((start pos)) (let ((start pos))
(define read-ident-loop (define read-ident-loop :effects []
(fn () (fn ()
(when (and (< pos len-src) (when (and (< pos len-src)
(ident-char? (nth source pos))) (ident-char? (nth source pos)))
@@ -122,19 +122,19 @@
(read-ident-loop) (read-ident-loop)
(slice source start pos)))) (slice source start pos))))
(define read-keyword (define read-keyword :effects []
(fn () (fn ()
(set! pos (inc pos)) ;; skip : (set! pos (inc pos)) ;; skip :
(make-keyword (read-ident)))) (make-keyword (read-ident))))
(define read-number (define read-number :effects []
(fn () (fn ()
(let ((start pos)) (let ((start pos))
;; Optional leading minus ;; Optional leading minus
(when (and (< pos len-src) (= (nth source pos) "-")) (when (and (< pos len-src) (= (nth source pos) "-"))
(set! pos (inc pos))) (set! pos (inc pos)))
;; Integer digits ;; Integer digits
(define read-digits (define read-digits :effects []
(fn () (fn ()
(when (and (< pos len-src) (when (and (< pos len-src)
(let ((c (nth source pos))) (let ((c (nth source pos)))
@@ -158,7 +158,7 @@
(read-digits)) (read-digits))
(parse-number (slice source start pos))))) (parse-number (slice source start pos)))))
(define read-symbol (define read-symbol :effects []
(fn () (fn ()
(let ((name (read-ident))) (let ((name (read-ident)))
(cond (cond
@@ -169,10 +169,10 @@
;; -- Composite readers -- ;; -- Composite readers --
(define read-list (define read-list :effects []
(fn (close-ch) (fn ((close-ch :as string))
(let ((items (list))) (let ((items (list)))
(define read-list-loop (define read-list-loop :effects []
(fn () (fn ()
(skip-ws) (skip-ws)
(if (>= pos len-src) (if (>= pos len-src)
@@ -184,10 +184,10 @@
(read-list-loop) (read-list-loop)
items))) items)))
(define read-map (define read-map :effects []
(fn () (fn ()
(let ((result (dict))) (let ((result (dict)))
(define read-map-loop (define read-map-loop :effects []
(fn () (fn ()
(skip-ws) (skip-ws)
(if (>= pos len-src) (if (>= pos len-src)
@@ -206,10 +206,10 @@
;; -- Raw string reader (for #|...|) -- ;; -- Raw string reader (for #|...|) --
(define read-raw-string (define read-raw-string :effects []
(fn () (fn ()
(let ((buf "")) (let ((buf ""))
(define raw-loop (define raw-loop :effects []
(fn () (fn ()
(if (>= pos len-src) (if (>= pos len-src)
(error "Unterminated raw string") (error "Unterminated raw string")
@@ -224,7 +224,7 @@
;; -- Main expression reader -- ;; -- Main expression reader --
(define read-expr (define read-expr :effects []
(fn () (fn ()
(skip-ws) (skip-ws)
(if (>= pos len-src) (if (>= pos len-src)
@@ -322,7 +322,7 @@
;; -- Entry point: parse all top-level expressions -- ;; -- Entry point: parse all top-level expressions --
(let ((exprs (list))) (let ((exprs (list)))
(define parse-loop (define parse-loop :effects []
(fn () (fn ()
(skip-ws) (skip-ws)
(when (< pos len-src) (when (< pos len-src)
@@ -336,7 +336,7 @@
;; Serializer — AST → SX source text ;; Serializer — AST → SX source text
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define sx-serialize (define sx-serialize :effects []
(fn (val) (fn (val)
(case (type-of val) (case (type-of val)
"nil" "nil" "nil" "nil"
@@ -351,12 +351,12 @@
:else (str val)))) :else (str val))))
(define sx-serialize-dict (define sx-serialize-dict :effects []
(fn (d) (fn ((d :as dict))
(str "{" (str "{"
(join " " (join " "
(reduce (reduce
(fn (acc key) (fn ((acc :as list) (key :as string))
(concat acc (list (str ":" key) (sx-serialize (dict-get d key))))) (concat acc (list (str ":" key) (sx-serialize (dict-get d key)))))
(list) (list)
(keys d))) (keys d)))

3214
shared/sx/ref/platform_js.py Normal file

File diff suppressed because it is too large Load Diff

1458
shared/sx/ref/platform_py.py Normal file

File diff suppressed because it is too large Load Diff

View File

@@ -15,6 +15,15 @@
;; :doc "description" ;; :doc "description"
;; :body (reference-implementation ...)) ;; :body (reference-implementation ...))
;; ;;
;; Typed params use (name :as type) syntax:
;; (define-primitive "+"
;; :params (&rest (args :as number))
;; :returns "number"
;; :doc "Sum all arguments.")
;;
;; Untyped params default to `any`. Typed params enable the gradual
;; type checker (types.sx) to catch mistyped primitive calls.
;;
;; The :body is optional — when provided, it gives a reference ;; The :body is optional — when provided, it gives a reference
;; implementation in SX that bootstrap compilers MAY use for testing ;; implementation in SX that bootstrap compilers MAY use for testing
;; or as a fallback. Most targets will implement natively for performance. ;; or as a fallback. Most targets will implement natively for performance.
@@ -32,89 +41,100 @@
(define-module :core.arithmetic) (define-module :core.arithmetic)
(define-primitive "+" (define-primitive "+"
:params (&rest args) :params (&rest (args :as number))
:returns "number" :returns "number"
:doc "Sum all arguments." :doc "Sum all arguments."
:body (reduce (fn (a b) (native-add a b)) 0 args)) :body (reduce (fn (a b) (native-add a b)) 0 args))
(define-primitive "-" (define-primitive "-"
:params (a &rest b) :params ((a :as number) &rest (b :as number))
:returns "number" :returns "number"
:doc "Subtract. Unary: negate. Binary: a - b." :doc "Subtract. Unary: negate. Binary: a - b."
:body (if (empty? b) (native-neg a) (native-sub a (first b)))) :body (if (empty? b) (native-neg a) (native-sub a (first b))))
(define-primitive "*" (define-primitive "*"
:params (&rest args) :params (&rest (args :as number))
:returns "number" :returns "number"
:doc "Multiply all arguments." :doc "Multiply all arguments."
:body (reduce (fn (a b) (native-mul a b)) 1 args)) :body (reduce (fn (a b) (native-mul a b)) 1 args))
(define-primitive "/" (define-primitive "/"
:params (a b) :params ((a :as number) (b :as number))
:returns "number" :returns "number"
:doc "Divide a by b." :doc "Divide a by b."
:body (native-div a b)) :body (native-div a b))
(define-primitive "mod" (define-primitive "mod"
:params (a b) :params ((a :as number) (b :as number))
:returns "number" :returns "number"
:doc "Modulo a % b." :doc "Modulo a % b."
:body (native-mod a b)) :body (native-mod a b))
(define-primitive "random-int"
:params ((low :as number) (high :as number))
:returns "number"
:doc "Random integer in [low, high] inclusive."
:body (native-random-int low high))
(define-primitive "json-encode"
:params (value)
:returns "string"
:doc "Encode value as JSON string with indentation.")
(define-primitive "sqrt" (define-primitive "sqrt"
:params (x) :params ((x :as number))
:returns "number" :returns "number"
:doc "Square root.") :doc "Square root.")
(define-primitive "pow" (define-primitive "pow"
:params (x n) :params ((x :as number) (n :as number))
:returns "number" :returns "number"
:doc "x raised to power n.") :doc "x raised to power n.")
(define-primitive "abs" (define-primitive "abs"
:params (x) :params ((x :as number))
:returns "number" :returns "number"
:doc "Absolute value.") :doc "Absolute value.")
(define-primitive "floor" (define-primitive "floor"
:params (x) :params ((x :as number))
:returns "number" :returns "number"
:doc "Floor to integer.") :doc "Floor to integer.")
(define-primitive "ceil" (define-primitive "ceil"
:params (x) :params ((x :as number))
:returns "number" :returns "number"
:doc "Ceiling to integer.") :doc "Ceiling to integer.")
(define-primitive "round" (define-primitive "round"
:params (x &rest ndigits) :params ((x :as number) &rest (ndigits :as number))
:returns "number" :returns "number"
:doc "Round to ndigits decimal places (default 0).") :doc "Round to ndigits decimal places (default 0).")
(define-primitive "min" (define-primitive "min"
:params (&rest args) :params (&rest (args :as number))
:returns "number" :returns "number"
:doc "Minimum. Single list arg or variadic.") :doc "Minimum. Single list arg or variadic.")
(define-primitive "max" (define-primitive "max"
:params (&rest args) :params (&rest (args :as number))
:returns "number" :returns "number"
:doc "Maximum. Single list arg or variadic.") :doc "Maximum. Single list arg or variadic.")
(define-primitive "clamp" (define-primitive "clamp"
:params (x lo hi) :params ((x :as number) (lo :as number) (hi :as number))
:returns "number" :returns "number"
:doc "Clamp x to range [lo, hi]." :doc "Clamp x to range [lo, hi]."
:body (max lo (min hi x))) :body (max lo (min hi x)))
(define-primitive "inc" (define-primitive "inc"
:params (n) :params ((n :as number))
:returns "number" :returns "number"
:doc "Increment by 1." :doc "Increment by 1."
:body (+ n 1)) :body (+ n 1))
(define-primitive "dec" (define-primitive "dec"
:params (n) :params ((n :as number))
:returns "number" :returns "number"
:doc "Decrement by 1." :doc "Decrement by 1."
:body (- n 1)) :body (- n 1))
@@ -159,22 +179,22 @@
Same semantics as = but explicit Scheme name.") Same semantics as = but explicit Scheme name.")
(define-primitive "<" (define-primitive "<"
:params (a b) :params ((a :as number) (b :as number))
:returns "boolean" :returns "boolean"
:doc "Less than.") :doc "Less than.")
(define-primitive ">" (define-primitive ">"
:params (a b) :params ((a :as number) (b :as number))
:returns "boolean" :returns "boolean"
:doc "Greater than.") :doc "Greater than.")
(define-primitive "<=" (define-primitive "<="
:params (a b) :params ((a :as number) (b :as number))
:returns "boolean" :returns "boolean"
:doc "Less than or equal.") :doc "Less than or equal.")
(define-primitive ">=" (define-primitive ">="
:params (a b) :params ((a :as number) (b :as number))
:returns "boolean" :returns "boolean"
:doc "Greater than or equal.") :doc "Greater than or equal.")
@@ -186,19 +206,19 @@
(define-module :core.predicates) (define-module :core.predicates)
(define-primitive "odd?" (define-primitive "odd?"
:params (n) :params ((n :as number))
:returns "boolean" :returns "boolean"
:doc "True if n is odd." :doc "True if n is odd."
:body (= (mod n 2) 1)) :body (= (mod n 2) 1))
(define-primitive "even?" (define-primitive "even?"
:params (n) :params ((n :as number))
:returns "boolean" :returns "boolean"
:doc "True if n is even." :doc "True if n is even."
:body (= (mod n 2) 0)) :body (= (mod n 2) 0))
(define-primitive "zero?" (define-primitive "zero?"
:params (n) :params ((n :as number))
:returns "boolean" :returns "boolean"
:doc "True if n is zero." :doc "True if n is zero."
:body (= n 0)) :body (= n 0))
@@ -274,82 +294,82 @@
:doc "Concatenate all args as strings. nil → empty string, bool → true/false.") :doc "Concatenate all args as strings. nil → empty string, bool → true/false.")
(define-primitive "concat" (define-primitive "concat"
:params (&rest colls) :params (&rest (colls :as list))
:returns "list" :returns "list"
:doc "Concatenate multiple lists into one. Skips nil values.") :doc "Concatenate multiple lists into one. Skips nil values.")
(define-primitive "upper" (define-primitive "upper"
:params (s) :params ((s :as string))
:returns "string" :returns "string"
:doc "Uppercase string.") :doc "Uppercase string.")
(define-primitive "upcase" (define-primitive "upcase"
:params (s) :params ((s :as string))
:returns "string" :returns "string"
:doc "Alias for upper. Uppercase string.") :doc "Alias for upper. Uppercase string.")
(define-primitive "lower" (define-primitive "lower"
:params (s) :params ((s :as string))
:returns "string" :returns "string"
:doc "Lowercase string.") :doc "Lowercase string.")
(define-primitive "downcase" (define-primitive "downcase"
:params (s) :params ((s :as string))
:returns "string" :returns "string"
:doc "Alias for lower. Lowercase string.") :doc "Alias for lower. Lowercase string.")
(define-primitive "string-length" (define-primitive "string-length"
:params (s) :params ((s :as string))
:returns "number" :returns "number"
:doc "Length of string in characters.") :doc "Length of string in characters.")
(define-primitive "substring" (define-primitive "substring"
:params (s start end) :params ((s :as string) (start :as number) (end :as number))
:returns "string" :returns "string"
:doc "Extract substring from start (inclusive) to end (exclusive).") :doc "Extract substring from start (inclusive) to end (exclusive).")
(define-primitive "string-contains?" (define-primitive "string-contains?"
:params (s needle) :params ((s :as string) (needle :as string))
:returns "boolean" :returns "boolean"
:doc "True if string s contains substring needle.") :doc "True if string s contains substring needle.")
(define-primitive "trim" (define-primitive "trim"
:params (s) :params ((s :as string))
:returns "string" :returns "string"
:doc "Strip leading/trailing whitespace.") :doc "Strip leading/trailing whitespace.")
(define-primitive "split" (define-primitive "split"
:params (s &rest sep) :params ((s :as string) &rest (sep :as string))
:returns "list" :returns "list"
:doc "Split string by separator (default space).") :doc "Split string by separator (default space).")
(define-primitive "join" (define-primitive "join"
:params (sep coll) :params ((sep :as string) (coll :as list))
:returns "string" :returns "string"
:doc "Join collection items with separator string.") :doc "Join collection items with separator string.")
(define-primitive "replace" (define-primitive "replace"
:params (s old new) :params ((s :as string) (old :as string) (new :as string))
:returns "string" :returns "string"
:doc "Replace all occurrences of old with new in s.") :doc "Replace all occurrences of old with new in s.")
(define-primitive "slice" (define-primitive "slice"
:params (coll start &rest end) :params (coll (start :as number) &rest (end :as number))
:returns "any" :returns "any"
:doc "Slice a string or list from start to end (exclusive). End is optional.") :doc "Slice a string or list from start to end (exclusive). End is optional.")
(define-primitive "index-of" (define-primitive "index-of"
:params (s needle &rest from) :params ((s :as string) (needle :as string) &rest (from :as number))
:returns "number" :returns "number"
:doc "Index of first occurrence of needle in s, or -1 if not found. Optional start index.") :doc "Index of first occurrence of needle in s, or -1 if not found. Optional start index.")
(define-primitive "starts-with?" (define-primitive "starts-with?"
:params (s prefix) :params ((s :as string) (prefix :as string))
:returns "boolean" :returns "boolean"
:doc "True if string s starts with prefix.") :doc "True if string s starts with prefix.")
(define-primitive "ends-with?" (define-primitive "ends-with?"
:params (s suffix) :params ((s :as string) (suffix :as string))
:returns "boolean" :returns "boolean"
:doc "True if string s ends with suffix.") :doc "True if string s ends with suffix.")
@@ -371,7 +391,7 @@
:doc "Create a dict from key/value pairs: (dict :a 1 :b 2).") :doc "Create a dict from key/value pairs: (dict :a 1 :b 2).")
(define-primitive "range" (define-primitive "range"
:params (start end &rest step) :params ((start :as number) (end :as number) &rest (step :as number))
:returns "list" :returns "list"
:doc "Integer range [start, end) with optional step.") :doc "Integer range [start, end) with optional step.")
@@ -386,57 +406,57 @@
:doc "Length of string, list, or dict.") :doc "Length of string, list, or dict.")
(define-primitive "first" (define-primitive "first"
:params (coll) :params ((coll :as list))
:returns "any" :returns "any"
:doc "First element, or nil if empty.") :doc "First element, or nil if empty.")
(define-primitive "last" (define-primitive "last"
:params (coll) :params ((coll :as list))
:returns "any" :returns "any"
:doc "Last element, or nil if empty.") :doc "Last element, or nil if empty.")
(define-primitive "rest" (define-primitive "rest"
:params (coll) :params ((coll :as list))
:returns "list" :returns "list"
:doc "All elements except the first.") :doc "All elements except the first.")
(define-primitive "nth" (define-primitive "nth"
:params (coll n) :params ((coll :as list) (n :as number))
:returns "any" :returns "any"
:doc "Element at index n, or nil if out of bounds.") :doc "Element at index n, or nil if out of bounds.")
(define-primitive "cons" (define-primitive "cons"
:params (x coll) :params (x (coll :as list))
:returns "list" :returns "list"
:doc "Prepend x to coll.") :doc "Prepend x to coll.")
(define-primitive "append" (define-primitive "append"
:params (coll x) :params ((coll :as list) x)
:returns "list" :returns "list"
:doc "If x is a list, concatenate. Otherwise append x as single element.") :doc "If x is a list, concatenate. Otherwise append x as single element.")
(define-primitive "append!" (define-primitive "append!"
:params (coll x) :params ((coll :as list) x)
:returns "list" :returns "list"
:doc "Mutate coll by appending x in-place. Returns coll.") :doc "Mutate coll by appending x in-place. Returns coll.")
(define-primitive "reverse" (define-primitive "reverse"
:params (coll) :params ((coll :as list))
:returns "list" :returns "list"
:doc "Return coll in reverse order.") :doc "Return coll in reverse order.")
(define-primitive "flatten" (define-primitive "flatten"
:params (coll) :params ((coll :as list))
:returns "list" :returns "list"
:doc "Flatten one level of nesting. Nested lists become top-level elements.") :doc "Flatten one level of nesting. Nested lists become top-level elements.")
(define-primitive "chunk-every" (define-primitive "chunk-every"
:params (coll n) :params ((coll :as list) (n :as number))
:returns "list" :returns "list"
:doc "Split coll into sub-lists of size n.") :doc "Split coll into sub-lists of size n.")
(define-primitive "zip-pairs" (define-primitive "zip-pairs"
:params (coll) :params ((coll :as list))
:returns "list" :returns "list"
:doc "Consecutive pairs: (1 2 3 4) → ((1 2) (2 3) (3 4)).") :doc "Consecutive pairs: (1 2 3 4) → ((1 2) (2 3) (3 4)).")
@@ -448,37 +468,37 @@
(define-module :core.dict) (define-module :core.dict)
(define-primitive "keys" (define-primitive "keys"
:params (d) :params ((d :as dict))
:returns "list" :returns "list"
:doc "List of dict keys.") :doc "List of dict keys.")
(define-primitive "vals" (define-primitive "vals"
:params (d) :params ((d :as dict))
:returns "list" :returns "list"
:doc "List of dict values.") :doc "List of dict values.")
(define-primitive "merge" (define-primitive "merge"
:params (&rest dicts) :params (&rest (dicts :as dict))
:returns "dict" :returns "dict"
:doc "Merge dicts left to right. Later keys win. Skips nil.") :doc "Merge dicts left to right. Later keys win. Skips nil.")
(define-primitive "has-key?" (define-primitive "has-key?"
:params (d key) :params ((d :as dict) key)
:returns "boolean" :returns "boolean"
:doc "True if dict d contains key.") :doc "True if dict d contains key.")
(define-primitive "assoc" (define-primitive "assoc"
:params (d &rest pairs) :params ((d :as dict) &rest pairs)
:returns "dict" :returns "dict"
:doc "Return new dict with key/value pairs added/overwritten.") :doc "Return new dict with key/value pairs added/overwritten.")
(define-primitive "dissoc" (define-primitive "dissoc"
:params (d &rest keys) :params ((d :as dict) &rest keys)
:returns "dict" :returns "dict"
:doc "Return new dict with keys removed.") :doc "Return new dict with keys removed.")
(define-primitive "dict-set!" (define-primitive "dict-set!"
:params (d key val) :params ((d :as dict) key val)
:returns "any" :returns "any"
:doc "Mutate dict d by setting key to val in-place. Returns val.") :doc "Mutate dict d by setting key to val in-place. Returns val.")
@@ -495,12 +515,12 @@
(define-module :stdlib.format) (define-module :stdlib.format)
(define-primitive "format-date" (define-primitive "format-date"
:params (date-str fmt) :params ((date-str :as string) (fmt :as string))
:returns "string" :returns "string"
:doc "Parse ISO date string and format with strftime-style format.") :doc "Parse ISO date string and format with strftime-style format.")
(define-primitive "format-decimal" (define-primitive "format-decimal"
:params (val &rest places) :params ((val :as number) &rest (places :as number))
:returns "string" :returns "string"
:doc "Format number with fixed decimal places (default 2).") :doc "Format number with fixed decimal places (default 2).")
@@ -510,7 +530,7 @@
:doc "Parse string to integer with optional default on failure.") :doc "Parse string to integer with optional default on failure.")
(define-primitive "parse-datetime" (define-primitive "parse-datetime"
:params (s) :params ((s :as string))
:returns "string" :returns "string"
:doc "Parse datetime string — identity passthrough (returns string or nil).") :doc "Parse datetime string — identity passthrough (returns string or nil).")
@@ -522,17 +542,17 @@
(define-module :stdlib.text) (define-module :stdlib.text)
(define-primitive "pluralize" (define-primitive "pluralize"
:params (count &rest forms) :params ((count :as number) &rest (forms :as string))
:returns "string" :returns "string"
:doc "Pluralize: (pluralize 1) → \"\", (pluralize 2) → \"s\". Or (pluralize n \"item\" \"items\").") :doc "Pluralize: (pluralize 1) → \"\", (pluralize 2) → \"s\". Or (pluralize n \"item\" \"items\").")
(define-primitive "escape" (define-primitive "escape"
:params (s) :params ((s :as string))
:returns "string" :returns "string"
:doc "HTML-escape a string (&, <, >, \", ').") :doc "HTML-escape a string (&, <, >, \", ').")
(define-primitive "strip-tags" (define-primitive "strip-tags"
:params (s) :params ((s :as string))
:returns "string" :returns "string"
:doc "Remove HTML tags from string.") :doc "Remove HTML tags from string.")
@@ -567,16 +587,16 @@
:doc "Return type name: number, string, boolean, nil, symbol, keyword, list, dict, lambda, component, island, macro.") :doc "Return type name: number, string, boolean, nil, symbol, keyword, list, dict, lambda, component, island, macro.")
(define-primitive "symbol-name" (define-primitive "symbol-name"
:params (sym) :params ((sym :as symbol))
:returns "string" :returns "string"
:doc "Return the name string of a symbol.") :doc "Return the name string of a symbol.")
(define-primitive "keyword-name" (define-primitive "keyword-name"
:params (kw) :params ((kw :as keyword))
:returns "string" :returns "string"
:doc "Return the name string of a keyword.") :doc "Return the name string of a keyword.")
(define-primitive "sx-parse" (define-primitive "sx-parse"
:params (source) :params ((source :as string))
:returns "list" :returns "list"
:doc "Parse SX source string into a list of AST expressions.") :doc "Parse SX source string into a list of AST expressions.")

View File

@@ -25,7 +25,7 @@
;; Evaluate an SMT-LIB expression in a variable environment ;; Evaluate an SMT-LIB expression in a variable environment
(define smt-eval (define smt-eval
(fn (expr env) (fn (expr (env :as dict))
(cond (cond
;; Numbers ;; Numbers
(number? expr) expr (number? expr) expr
@@ -136,11 +136,11 @@
;; Bind parameter names to values ;; Bind parameter names to values
(define smt-bind-params (define smt-bind-params
(fn (params vals) (fn ((params :as list) (vals :as list))
(smt-bind-loop params vals {}))) (smt-bind-loop params vals {})))
(define smt-bind-loop (define smt-bind-loop
(fn (params vals acc) (fn ((params :as list) (vals :as list) (acc :as dict))
(if (or (empty? params) (empty? vals)) (if (or (empty? params) (empty? vals))
acc acc
(smt-bind-loop (rest params) (rest vals) (smt-bind-loop (rest params) (rest vals)
@@ -153,11 +153,11 @@
;; Extract declarations and assertions from parsed SMT-LIB ;; Extract declarations and assertions from parsed SMT-LIB
(define smt-extract-statements (define smt-extract-statements
(fn (exprs) (fn ((exprs :as list))
(smt-extract-loop exprs {} (list)))) (smt-extract-loop exprs {} (list))))
(define smt-extract-loop (define smt-extract-loop
(fn (exprs decls assertions) (fn ((exprs :as list) (decls :as dict) (assertions :as list))
(if (empty? exprs) (if (empty? exprs)
{:decls decls :assertions assertions} {:decls decls :assertions assertions}
(let ((expr (first exprs)) (let ((expr (first exprs))
@@ -286,7 +286,7 @@
;; Verify a single definitional assertion by construction + evaluation ;; Verify a single definitional assertion by construction + evaluation
(define smt-verify-definition (define smt-verify-definition
(fn (def-info decls) (fn ((def-info :as dict) (decls :as dict))
(let ((name (get def-info "name")) (let ((name (get def-info "name"))
(params (get def-info "params")) (params (get def-info "params"))
(body (get def-info "body")) (body (get def-info "body"))
@@ -295,10 +295,10 @@
;; Build the model: define f = λparams.body ;; Build the model: define f = λparams.body
(let ((model (assoc decls name {:params params :body body})) (let ((model (assoc decls name {:params params :body body}))
;; Select test values matching arity ;; Select test values matching arity
(tests (filter (fn (tv) (= (len tv) n-params)) smt-test-values)) (tests (filter (fn ((tv :as list)) (= (len tv) n-params)) smt-test-values))
;; Run tests ;; Run tests
(results (map (results (map
(fn (test-vals) (fn ((test-vals :as list))
(let ((env (merge model (smt-bind-params params test-vals))) (let ((env (merge model (smt-bind-params params test-vals)))
;; Evaluate body directly ;; Evaluate body directly
(body-result (smt-eval body env)) (body-result (smt-eval body env))
@@ -311,9 +311,9 @@
:equal (= body-result call-result)})) :equal (= body-result call-result)}))
tests))) tests)))
{:name name {:name name
:status (if (every? (fn (r) (get r "equal")) results) "sat" "FAIL") :status (if (every? (fn ((r :as dict)) (get r "equal")) results) "sat" "FAIL")
:proof "by construction (definition is the model)" :proof "by construction (definition is the model)"
:tests-passed (len (filter (fn (r) (get r "equal")) results)) :tests-passed (len (filter (fn ((r :as dict)) (get r "equal")) results))
:tests-total (len results) :tests-total (len results)
:sample (if (empty? results) nil (first results))})))) :sample (if (empty? results) nil (first results))}))))
@@ -325,16 +325,16 @@
;; Strip SMT-LIB comment lines (starting with ;) and return only actual forms. ;; Strip SMT-LIB comment lines (starting with ;) and return only actual forms.
;; Handles comments that contain ( characters. ;; Handles comments that contain ( characters.
(define smt-strip-comments (define smt-strip-comments
(fn (s) (fn ((s :as string))
(let ((lines (split s "\n")) (let ((lines (split s "\n"))
(non-comment (filter (non-comment (filter
(fn (line) (not (starts-with? (trim line) ";"))) (fn ((line :as string)) (not (starts-with? (trim line) ";")))
lines))) lines)))
(join "\n" non-comment)))) (join "\n" non-comment))))
;; Verify SMT-LIB output (string) — parse, classify, prove ;; Verify SMT-LIB output (string) — parse, classify, prove
(define prove-check (define prove-check
(fn (smtlib-str) (fn ((smtlib-str :as string))
(let ((parsed (sx-parse (smt-strip-comments smtlib-str))) (let ((parsed (sx-parse (smt-strip-comments smtlib-str)))
(stmts (smt-extract-statements parsed)) (stmts (smt-extract-statements parsed))
(decls (get stmts "decls")) (decls (get stmts "decls"))
@@ -351,7 +351,7 @@
{:status "unknown" {:status "unknown"
:reason "non-definitional assertion (needs full SMT solver)"})) :reason "non-definitional assertion (needs full SMT solver)"}))
assertions))) assertions)))
{:status (if (every? (fn (r) (= (get r "status") "sat")) results) {:status (if (every? (fn ((r :as dict)) (= (get r "status") "sat")) results)
"sat" "unknown") "sat" "unknown")
:assertions (len assertions) :assertions (len assertions)
:results results}))))) :results results})))))
@@ -377,7 +377,7 @@
;; Batch verify: translate and prove all define-* forms ;; Batch verify: translate and prove all define-* forms
(define prove-file (define prove-file
(fn (exprs) (fn ((exprs :as list))
(let ((translatable (let ((translatable
(filter (filter
(fn (expr) (fn (expr)
@@ -396,7 +396,7 @@
(name (nth expr 1))) (name (nth expr 1)))
(assoc proof "name" name))) (assoc proof "name" name)))
translatable)) translatable))
(sat-count (len (filter (fn (r) (= (get r "status") "sat")) results))) (sat-count (len (filter (fn ((r :as dict)) (= (get r "status") "sat")) results)))
(total (len results))) (total (len results)))
{:total total {:total total
:sat sat-count :sat sat-count
@@ -424,7 +424,7 @@
;; Default domain bounds by arity — balance coverage vs. combinatorics ;; Default domain bounds by arity — balance coverage vs. combinatorics
(define prove-domain-for (define prove-domain-for
(fn (arity) (fn ((arity :as number))
(cond (cond
(<= arity 1) (range -50 51) ;; 101 values (<= arity 1) (range -50 51) ;; 101 values
(= arity 2) (range -20 21) ;; 41^2 = 1,681 pairs (= arity 2) (range -20 21) ;; 41^2 = 1,681 pairs
@@ -433,7 +433,7 @@
;; Cartesian product: all n-tuples from a domain ;; Cartesian product: all n-tuples from a domain
(define prove-tuples (define prove-tuples
(fn (domain arity) (fn ((domain :as list) (arity :as number))
(if (<= arity 0) (list (list)) (if (<= arity 0) (list (list))
(if (= arity 1) (if (= arity 1)
(map (fn (x) (list x)) domain) (map (fn (x) (list x)) domain)
@@ -441,12 +441,12 @@
(prove-tuples-expand domain sub (list))))))) (prove-tuples-expand domain sub (list)))))))
(define prove-tuples-expand (define prove-tuples-expand
(fn (domain sub acc) (fn ((domain :as list) (sub :as list) (acc :as list))
(if (empty? domain) acc (if (empty? domain) acc
(prove-tuples-expand (prove-tuples-expand
(rest domain) sub (rest domain) sub
(append acc (append acc
(map (fn (t) (cons (first domain) t)) sub)))))) (map (fn ((t :as list)) (cons (first domain) t)) sub))))))
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
@@ -454,7 +454,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define prove-call (define prove-call
(fn (f vals) (fn ((f :as lambda) (vals :as list))
(let ((n (len vals))) (let ((n (len vals)))
(cond (cond
(= n 0) (f) (= n 0) (f)
@@ -472,13 +472,13 @@
;; Search for a counterexample. Returns nil if property holds for all tested ;; Search for a counterexample. Returns nil if property holds for all tested
;; values, or the first counterexample found. ;; values, or the first counterexample found.
(define prove-search (define prove-search
(fn (test-fn given-fn domain vars) (fn ((test-fn :as lambda) given-fn (domain :as list) (vars :as list))
(let ((arity (len vars)) (let ((arity (len vars))
(tuples (prove-tuples domain arity))) (tuples (prove-tuples domain arity)))
(prove-search-loop test-fn given-fn tuples 0 0)))) (prove-search-loop test-fn given-fn tuples 0 0))))
(define prove-search-loop (define prove-search-loop
(fn (test-fn given-fn tuples tested skipped) (fn ((test-fn :as lambda) given-fn (tuples :as list) (tested :as number) (skipped :as number))
(if (empty? tuples) (if (empty? tuples)
{:status "verified" :tested tested :skipped skipped} {:status "verified" :tested tested :skipped skipped}
(let ((vals (first tuples)) (let ((vals (first tuples))
@@ -505,7 +505,7 @@
;; Verify a single property via bounded model checking ;; Verify a single property via bounded model checking
(define prove-property (define prove-property
(fn (prop) (fn ((prop :as dict))
(let ((name (get prop "name")) (let ((name (get prop "name"))
(vars (get prop "vars")) (vars (get prop "vars"))
(test-fn (get prop "test")) (test-fn (get prop "test"))
@@ -519,10 +519,10 @@
;; Batch verify a list of properties ;; Batch verify a list of properties
(define prove-properties (define prove-properties
(fn (props) (fn ((props :as list))
(let ((results (map prove-property props)) (let ((results (map prove-property props))
(verified (filter (fn (r) (= (get r "status") "verified")) results)) (verified (filter (fn ((r :as dict)) (= (get r "status") "verified")) results))
(falsified (filter (fn (r) (= (get r "status") "falsified")) results))) (falsified (filter (fn ((r :as dict)) (= (get r "status") "falsified")) results)))
{:total (len results) {:total (len results)
:verified (len verified) :verified (len verified)
:falsified (len falsified) :falsified (len falsified)
@@ -537,13 +537,13 @@
;; Generate SMT-LIB for a property — asserts (not (forall ...)) so that ;; Generate SMT-LIB for a property — asserts (not (forall ...)) so that
;; Z3 returning "unsat" proves the property holds universally. ;; Z3 returning "unsat" proves the property holds universally.
(define prove-property-smtlib (define prove-property-smtlib
(fn (prop) (fn ((prop :as dict))
(let ((name (get prop "name")) (let ((name (get prop "name"))
(vars (get prop "vars")) (vars (get prop "vars"))
(holds (get prop "holds")) (holds (get prop "holds"))
(given-e (get prop "given-expr" nil)) (given-e (get prop "given-expr" nil))
(bindings (join " " (bindings (join " "
(map (fn (v) (str "(" v " Int)")) vars))) (map (fn ((v :as string)) (str "(" v " Int)")) vars)))
(holds-smt (z3-expr holds)) (holds-smt (z3-expr holds))
(body (if (nil? given-e) (body (if (nil? given-e)
holds-smt holds-smt
@@ -556,7 +556,7 @@
;; Generate SMT-LIB for all properties, including necessary definitions ;; Generate SMT-LIB for all properties, including necessary definitions
(define prove-properties-smtlib (define prove-properties-smtlib
(fn (props primitives-exprs) (fn ((props :as list) (primitives-exprs :as list))
(let ((defs (z3-translate-file primitives-exprs)) (let ((defs (z3-translate-file primitives-exprs))
(prop-smts (map prove-property-smtlib props))) (prop-smts (map prove-property-smtlib props)))
(str ";; ================================================================\n" (str ";; ================================================================\n"

View File

@@ -235,6 +235,7 @@
"scan-io-refs-walk" "scan_io_refs_walk" "scan-io-refs-walk" "scan_io_refs_walk"
"transitive-io-refs" "transitive_io_refs" "transitive-io-refs" "transitive_io_refs"
"compute-all-io-refs" "compute_all_io_refs" "compute-all-io-refs" "compute_all_io_refs"
"component-io-refs-cached" "component_io_refs_cached"
"component-pure?" "component_pure_p" "component-pure?" "component_pure_p"
"render-target" "render_target" "render-target" "render_target"
"page-render-plan" "page_render_plan" "page-render-plan" "page_render_plan"
@@ -252,7 +253,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define py-mangle (define py-mangle
(fn (name) (fn ((name :as string))
(let ((renamed (get py-renames name))) (let ((renamed (get py-renames name)))
(if (not (nil? renamed)) (if (not (nil? renamed))
renamed renamed
@@ -278,7 +279,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define py-quote-string (define py-quote-string
(fn (s) (fn ((s :as string))
;; Produce a Python repr-style string literal ;; Produce a Python repr-style string literal
(str "'" (replace (replace (replace (replace s "\\" "\\\\") "'" "\\'") "\n" "\\n") "\t" "\\t") "'"))) (str "'" (replace (replace (replace (replace s "\\" "\\\\") "'" "\\'") "\n" "\\n") "\t" "\\t") "'")))
@@ -291,11 +292,11 @@
(list "+" "-" "*" "/" "=" "!=" "<" ">" "<=" ">=" "mod")) (list "+" "-" "*" "/" "=" "!=" "<" ">" "<=" ">=" "mod"))
(define py-infix? (define py-infix?
(fn (op) (fn ((op :as string))
(some (fn (x) (= x op)) py-infix-ops))) (some (fn (x) (= x op)) py-infix-ops)))
(define py-op-symbol (define py-op-symbol
(fn (op) (fn ((op :as string))
(case op (case op
"=" "==" "=" "=="
"!=" "!=" "!=" "!="
@@ -308,7 +309,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define py-find-nested-set-vars (define py-find-nested-set-vars
(fn (body) (fn ((body :as list))
;; Returns a list of mangled variable names that are set! from within ;; Returns a list of mangled variable names that are set! from within
;; nested fn/lambda bodies ;; nested fn/lambda bodies
(let ((result (list))) (let ((result (list)))
@@ -317,7 +318,7 @@
result)))) result))))
(define py-scan-set-vars (define py-scan-set-vars
(fn (node in-nested result) (fn (node (in-nested :as boolean) (result :as list))
(when (and (list? node) (not (empty? node))) (when (and (list? node) (not (empty? node)))
(let ((head (first node))) (let ((head (first node)))
(cond (cond
@@ -352,7 +353,7 @@
(py-has-set? body)))) (py-has-set? body))))
(define py-has-set? (define py-has-set?
(fn (nodes) (fn ((nodes :as list))
(some (fn (node) (some (fn (node)
(and (list? node) (and (list? node)
(not (empty? node)) (not (empty? node))
@@ -371,7 +372,7 @@
(py-expr-with-cells expr (list)))) (py-expr-with-cells expr (list))))
(define py-expr-with-cells (define py-expr-with-cells
(fn (expr cell-vars) (fn (expr (cell-vars :as list))
(cond (cond
;; Bool MUST come before number check (Python: bool is subclass of int) ;; Bool MUST come before number check (Python: bool is subclass of int)
(= (type-of expr) "boolean") (= (type-of expr) "boolean")
@@ -416,7 +417,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define py-emit-native-dict (define py-emit-native-dict
(fn (d cell-vars) (fn ((d :as dict) (cell-vars :as list))
(let ((items (keys d))) (let ((items (keys d)))
(str "{" (join ", " (map (fn (k) (str "{" (join ", " (map (fn (k)
(str (py-quote-string k) ": " (py-expr-with-cells (get d k) cell-vars))) (str (py-quote-string k) ": " (py-expr-with-cells (get d k) cell-vars)))
@@ -428,7 +429,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define py-emit-list (define py-emit-list
(fn (expr cell-vars) (fn (expr (cell-vars :as list))
(let ((head (first expr)) (let ((head (first expr))
(args (rest expr))) (args (rest expr)))
(if (not (= (type-of head) "symbol")) (if (not (= (type-of head) "symbol"))
@@ -547,7 +548,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define py-emit-fn (define py-emit-fn
(fn (expr cell-vars) (fn (expr (cell-vars :as list))
(let ((params (nth expr 1)) (let ((params (nth expr 1))
(body (rest (rest expr))) (body (rest (rest expr)))
(param-strs (py-collect-params params))) (param-strs (py-collect-params params)))
@@ -561,11 +562,11 @@
"\n)[-1])")))))) "\n)[-1])"))))))
(define py-collect-params (define py-collect-params
(fn (params) (fn ((params :as list))
(py-collect-params-loop params 0 (list)))) (py-collect-params-loop params 0 (list))))
(define py-collect-params-loop (define py-collect-params-loop
(fn (params i result) (fn ((params :as list) (i :as number) (result :as list))
(if (>= i (len params)) (if (>= i (len params))
result result
(let ((p (nth params i))) (let ((p (nth params i)))
@@ -573,13 +574,25 @@
;; &rest marker ;; &rest marker
(and (= (type-of p) "symbol") (= (symbol-name p) "&rest")) (and (= (type-of p) "symbol") (= (symbol-name p) "&rest"))
(if (< (+ i 1) (len params)) (if (< (+ i 1) (len params))
(py-collect-params-loop params (+ i 2) (let ((rp (nth params (+ i 1))))
(append result (str "*" (py-mangle (symbol-name (nth params (+ i 1))))))) (py-collect-params-loop params (+ i 2)
(append result (str "*" (py-mangle
(if (and (= (type-of rp) "list") (= (len rp) 3)
(= (type-of (nth rp 1)) "keyword")
(= (keyword-name (nth rp 1)) "as"))
(symbol-name (first rp))
(if (= (type-of rp) "symbol") (symbol-name rp) (str rp))))))))
(py-collect-params-loop params (+ i 1) result)) (py-collect-params-loop params (+ i 1) result))
;; Normal param ;; Normal param
(= (type-of p) "symbol") (= (type-of p) "symbol")
(py-collect-params-loop params (+ i 1) (py-collect-params-loop params (+ i 1)
(append result (py-mangle (symbol-name p)))) (append result (py-mangle (symbol-name p))))
;; Annotated param: (name :as type) → extract name
(and (= (type-of p) "list") (= (len p) 3)
(= (type-of (nth p 1)) "keyword")
(= (keyword-name (nth p 1)) "as"))
(py-collect-params-loop params (+ i 1)
(append result (py-mangle (symbol-name (first p)))))
;; Something else ;; Something else
:else :else
(py-collect-params-loop params (+ i 1) (py-collect-params-loop params (+ i 1)
@@ -591,7 +604,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define py-emit-let (define py-emit-let
(fn (expr cell-vars) (fn (expr (cell-vars :as list))
(let ((bindings (nth expr 1)) (let ((bindings (nth expr 1))
(body (rest (rest expr)))) (body (rest (rest expr))))
(let ((assignments (py-parse-bindings bindings cell-vars))) (let ((assignments (py-parse-bindings bindings cell-vars)))
@@ -602,7 +615,7 @@
(py-wrap-let-bindings assignments body-str cell-vars)))))) (py-wrap-let-bindings assignments body-str cell-vars))))))
(define py-parse-bindings (define py-parse-bindings
(fn (bindings cell-vars) (fn (bindings (cell-vars :as list))
(if (and (list? bindings) (not (empty? bindings))) (if (and (list? bindings) (not (empty? bindings)))
(if (list? (first bindings)) (if (list? (first bindings))
;; Scheme-style: ((name val) ...) ;; Scheme-style: ((name val) ...)
@@ -617,7 +630,7 @@
(list)))) (list))))
(define py-parse-clojure-bindings (define py-parse-clojure-bindings
(fn (bindings i result cell-vars) (fn (bindings (i :as number) (result :as list) (cell-vars :as list))
(if (>= i (- (len bindings) 1)) (if (>= i (- (len bindings) 1))
result result
(let ((vname (if (= (type-of (nth bindings i)) "symbol") (let ((vname (if (= (type-of (nth bindings i)) "symbol")
@@ -628,7 +641,7 @@
cell-vars))))) cell-vars)))))
(define py-wrap-let-bindings (define py-wrap-let-bindings
(fn (assignments body-str cell-vars) (fn ((assignments :as list) (body-str :as string) (cell-vars :as list))
(if (empty? assignments) (if (empty? assignments)
body-str body-str
(let ((binding (last assignments)) (let ((binding (last assignments))
@@ -648,7 +661,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define py-emit-when (define py-emit-when
(fn (expr cell-vars) (fn (expr (cell-vars :as list))
(let ((cond-e (py-expr-with-cells (nth expr 1) cell-vars)) (let ((cond-e (py-expr-with-cells (nth expr 1) cell-vars))
(body-parts (rest (rest expr)))) (body-parts (rest (rest expr))))
(if (= (len body-parts) 1) (if (= (len body-parts) 1)
@@ -662,7 +675,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define py-emit-cond (define py-emit-cond
(fn (clauses cell-vars) (fn ((clauses :as list) (cell-vars :as list))
(if (empty? clauses) (if (empty? clauses)
"NIL" "NIL"
;; Detect scheme vs clojure style ;; Detect scheme vs clojure style
@@ -680,7 +693,7 @@
(and (= (type-of test) "keyword") (= (keyword-name test) "else"))))) (and (= (type-of test) "keyword") (= (keyword-name test) "else")))))
(define py-cond-scheme (define py-cond-scheme
(fn (clauses cell-vars) (fn ((clauses :as list) (cell-vars :as list))
(if (empty? clauses) (if (empty? clauses)
"NIL" "NIL"
(let ((clause (first clauses)) (let ((clause (first clauses))
@@ -693,7 +706,7 @@
") else " (py-cond-scheme (rest clauses) cell-vars) ")")))))) ") else " (py-cond-scheme (rest clauses) cell-vars) ")"))))))
(define py-cond-clojure (define py-cond-clojure
(fn (clauses cell-vars) (fn ((clauses :as list) (cell-vars :as list))
(if (< (len clauses) 2) (if (< (len clauses) 2)
"NIL" "NIL"
(let ((test (first clauses)) (let ((test (first clauses))
@@ -710,17 +723,17 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define py-emit-case (define py-emit-case
(fn (args cell-vars) (fn ((args :as list) (cell-vars :as list))
(let ((match-expr (py-expr-with-cells (first args) cell-vars)) (let ((match-expr (py-expr-with-cells (first args) cell-vars))
(clauses (rest args))) (clauses (rest args)))
(str "_sx_case(" match-expr ", [" (py-case-pairs clauses cell-vars) "])")))) (str "_sx_case(" match-expr ", [" (py-case-pairs clauses cell-vars) "])"))))
(define py-case-pairs (define py-case-pairs
(fn (clauses cell-vars) (fn ((clauses :as list) (cell-vars :as list))
(py-case-pairs-loop clauses 0 (list) cell-vars))) (py-case-pairs-loop clauses 0 (list) cell-vars)))
(define py-case-pairs-loop (define py-case-pairs-loop
(fn (clauses i result cell-vars) (fn ((clauses :as list) (i :as number) (result :as list) (cell-vars :as list))
(if (>= i (- (len clauses) 1)) (if (>= i (- (len clauses) 1))
(join ", " result) (join ", " result)
(let ((test (nth clauses i)) (let ((test (nth clauses i))
@@ -737,28 +750,28 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define py-emit-and (define py-emit-and
(fn (args cell-vars) (fn ((args :as list) (cell-vars :as list))
(let ((parts (map (fn (x) (py-expr-with-cells x cell-vars)) args))) (let ((parts (map (fn (x) (py-expr-with-cells x cell-vars)) args)))
(if (= (len parts) 1) (if (= (len parts) 1)
(first parts) (first parts)
(py-and-chain parts))))) (py-and-chain parts)))))
(define py-and-chain (define py-and-chain
(fn (parts) (fn ((parts :as list))
(if (= (len parts) 1) (if (= (len parts) 1)
(first parts) (first parts)
(let ((p (first parts))) (let ((p (first parts)))
(str "(" p " if not sx_truthy(" p ") else " (py-and-chain (rest parts)) ")"))))) (str "(" p " if not sx_truthy(" p ") else " (py-and-chain (rest parts)) ")")))))
(define py-emit-or (define py-emit-or
(fn (args cell-vars) (fn ((args :as list) (cell-vars :as list))
(if (= (len args) 1) (if (= (len args) 1)
(py-expr-with-cells (first args) cell-vars) (py-expr-with-cells (first args) cell-vars)
(let ((parts (map (fn (x) (py-expr-with-cells x cell-vars)) args))) (let ((parts (map (fn (x) (py-expr-with-cells x cell-vars)) args)))
(py-or-chain parts))))) (py-or-chain parts)))))
(define py-or-chain (define py-or-chain
(fn (parts) (fn ((parts :as list))
(if (= (len parts) 1) (if (= (len parts) 1)
(first parts) (first parts)
(let ((p (first parts))) (let ((p (first parts)))
@@ -770,7 +783,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define py-emit-do (define py-emit-do
(fn (args cell-vars) (fn ((args :as list) (cell-vars :as list))
(if (= (len args) 1) (if (= (len args) 1)
(py-expr-with-cells (first args) cell-vars) (py-expr-with-cells (first args) cell-vars)
(str "_sx_begin(" (join ", " (map (fn (e) (py-expr-with-cells e cell-vars)) args)) ")")))) (str "_sx_begin(" (join ", " (map (fn (e) (py-expr-with-cells e cell-vars)) args)) ")"))))
@@ -781,11 +794,11 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define py-emit-dict-literal (define py-emit-dict-literal
(fn (pairs cell-vars) (fn ((pairs :as list) (cell-vars :as list))
(str "{" (py-dict-pairs-str pairs 0 (list) cell-vars) "}"))) (str "{" (py-dict-pairs-str pairs 0 (list) cell-vars) "}")))
(define py-dict-pairs-str (define py-dict-pairs-str
(fn (pairs i result cell-vars) (fn ((pairs :as list) (i :as number) (result :as list) (cell-vars :as list))
(if (>= i (- (len pairs) 1)) (if (>= i (- (len pairs) 1))
(join ", " result) (join ", " result)
(let ((key (nth pairs i)) (let ((key (nth pairs i))
@@ -804,7 +817,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define py-emit-infix (define py-emit-infix
(fn (op args cell-vars) (fn ((op :as string) (args :as list) (cell-vars :as list))
(let ((py-op (py-op-symbol op))) (let ((py-op (py-op-symbol op)))
(if (and (= (len args) 1) (= op "-")) (if (and (= (len args) 1) (= op "-"))
(str "(-" (py-expr-with-cells (first args) cell-vars) ")") (str "(-" (py-expr-with-cells (first args) cell-vars) ")")
@@ -838,15 +851,15 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define py-pad (define py-pad
(fn (indent) (fn ((indent :as number))
(join "" (map (fn (i) " ") (range 0 indent))))) (join "" (map (fn (i) " ") (range 0 indent)))))
(define py-statement (define py-statement
(fn (expr indent) (fn (expr (indent :as number))
(py-statement-with-cells expr indent (list)))) (py-statement-with-cells expr indent (list))))
(define py-statement-with-cells (define py-statement-with-cells
(fn (expr indent cell-vars) (fn (expr (indent :as number) (cell-vars :as list))
(let ((pad (py-pad indent))) (let ((pad (py-pad indent)))
(if (and (list? expr) (not (empty? expr)) (if (and (list? expr) (not (empty? expr))
(= (type-of (first expr)) "symbol")) (= (type-of (first expr)) "symbol"))
@@ -888,7 +901,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define py-emit-define (define py-emit-define
(fn (expr indent cell-vars) (fn (expr (indent :as number) (cell-vars :as list))
(let ((pad (py-pad indent)) (let ((pad (py-pad indent))
(name (if (= (type-of (nth expr 1)) "symbol") (name (if (= (type-of (nth expr 1)) "symbol")
(symbol-name (nth expr 1)) (symbol-name (nth expr 1))
@@ -910,7 +923,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define py-emit-define-as-def (define py-emit-define-as-def
(fn (name fn-expr indent) (fn ((name :as string) fn-expr (indent :as number))
(let ((pad (py-pad indent)) (let ((pad (py-pad indent))
(params (nth fn-expr 1)) (params (nth fn-expr 1))
(body (rest (rest fn-expr))) (body (rest (rest fn-expr)))
@@ -931,13 +944,13 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define py-emit-body-stmts (define py-emit-body-stmts
(fn (body lines indent cell-vars) (fn ((body :as list) (lines :as list) (indent :as number) (cell-vars :as list))
(let ((pad (py-pad indent)) (let ((pad (py-pad indent))
(total (len body))) (total (len body)))
(py-emit-body-stmts-loop body lines indent cell-vars 0 total pad)))) (py-emit-body-stmts-loop body lines indent cell-vars 0 total pad))))
(define py-emit-body-stmts-loop (define py-emit-body-stmts-loop
(fn (body lines indent cell-vars i total pad) (fn ((body :as list) (lines :as list) (indent :as number) (cell-vars :as list) (i :as number) (total :as number) (pad :as string))
(when (< i total) (when (< i total)
(let ((expr (nth body i)) (let ((expr (nth body i))
(is-last (= i (- total 1)))) (is-last (= i (- total 1))))
@@ -967,7 +980,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define py-emit-let-as-stmts (define py-emit-let-as-stmts
(fn (expr lines indent is-last cell-vars) (fn (expr (lines :as list) (indent :as number) (is-last :as boolean) (cell-vars :as list))
(let ((pad (py-pad indent)) (let ((pad (py-pad indent))
(bindings (nth expr 1)) (bindings (nth expr 1))
(body (rest (rest expr)))) (body (rest (rest expr))))
@@ -980,7 +993,7 @@
(for-each (fn (b) (py-emit-stmt-recursive b lines indent cell-vars)) body)))))) (for-each (fn (b) (py-emit-stmt-recursive b lines indent cell-vars)) body))))))
(define py-emit-binding-assignments (define py-emit-binding-assignments
(fn (bindings lines indent cell-vars) (fn (bindings (lines :as list) (indent :as number) (cell-vars :as list))
(let ((pad (py-pad indent))) (let ((pad (py-pad indent)))
(when (and (list? bindings) (not (empty? bindings))) (when (and (list? bindings) (not (empty? bindings)))
(if (list? (first bindings)) (if (list? (first bindings))
@@ -1001,7 +1014,7 @@
(py-emit-clojure-binding-assignments bindings lines indent 0 cell-vars)))))) (py-emit-clojure-binding-assignments bindings lines indent 0 cell-vars))))))
(define py-emit-clojure-binding-assignments (define py-emit-clojure-binding-assignments
(fn (bindings lines indent i cell-vars) (fn (bindings (lines :as list) (indent :as number) (i :as number) (cell-vars :as list))
(let ((pad (py-pad indent))) (let ((pad (py-pad indent)))
(when (< i (- (len bindings) 1)) (when (< i (- (len bindings) 1))
(let ((vname (if (= (type-of (nth bindings i)) "symbol") (let ((vname (if (= (type-of (nth bindings i)) "symbol")
@@ -1023,7 +1036,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define py-emit-stmt-recursive (define py-emit-stmt-recursive
(fn (expr lines indent cell-vars) (fn (expr (lines :as list) (indent :as number) (cell-vars :as list))
(let ((pad (py-pad indent))) (let ((pad (py-pad indent)))
(if (not (and (list? expr) (not (empty? expr)))) (if (not (and (list? expr) (not (empty? expr))))
(append! lines (py-statement-with-cells expr indent cell-vars)) (append! lines (py-statement-with-cells expr indent cell-vars))
@@ -1081,7 +1094,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define py-emit-cond-stmt (define py-emit-cond-stmt
(fn (expr lines indent cell-vars) (fn (expr (lines :as list) (indent :as number) (cell-vars :as list))
(let ((pad (py-pad indent)) (let ((pad (py-pad indent))
(clauses (rest expr))) (clauses (rest expr)))
;; Detect scheme vs clojure ;; Detect scheme vs clojure
@@ -1093,7 +1106,7 @@
(py-cond-stmt-clojure clauses lines indent 0 true cell-vars)))))) (py-cond-stmt-clojure clauses lines indent 0 true cell-vars))))))
(define py-cond-stmt-scheme (define py-cond-stmt-scheme
(fn (clauses lines indent first-clause cell-vars) (fn ((clauses :as list) (lines :as list) (indent :as number) (first-clause :as boolean) (cell-vars :as list))
(let ((pad (py-pad indent))) (let ((pad (py-pad indent)))
(when (not (empty? clauses)) (when (not (empty? clauses))
(let ((clause (first clauses)) (let ((clause (first clauses))
@@ -1110,7 +1123,7 @@
(py-cond-stmt-scheme (rest clauses) lines indent false cell-vars))))))) (py-cond-stmt-scheme (rest clauses) lines indent false cell-vars)))))))
(define py-cond-stmt-clojure (define py-cond-stmt-clojure
(fn (clauses lines indent i first-clause cell-vars) (fn ((clauses :as list) (lines :as list) (indent :as number) (i :as number) (first-clause :as boolean) (cell-vars :as list))
(let ((pad (py-pad indent))) (let ((pad (py-pad indent)))
(when (< i (- (len clauses) 1)) (when (< i (- (len clauses) 1))
(let ((test (nth clauses i)) (let ((test (nth clauses i))
@@ -1131,7 +1144,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define py-emit-when-stmt (define py-emit-when-stmt
(fn (expr indent cell-vars) (fn (expr (indent :as number) (cell-vars :as list))
(let ((pad (py-pad indent)) (let ((pad (py-pad indent))
(cond-e (py-expr-with-cells (nth expr 1) cell-vars)) (cond-e (py-expr-with-cells (nth expr 1) cell-vars))
(body-parts (rest (rest expr)))) (body-parts (rest (rest expr))))
@@ -1145,7 +1158,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define py-emit-for-each-stmt (define py-emit-for-each-stmt
(fn (expr indent cell-vars) (fn (expr (indent :as number) (cell-vars :as list))
(let ((pad (py-pad indent)) (let ((pad (py-pad indent))
(fn-expr (nth expr 1)) (fn-expr (nth expr 1))
(coll-expr (nth expr 2)) (coll-expr (nth expr 2))
@@ -1174,7 +1187,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define py-translate-file (define py-translate-file
(fn (defines) (fn ((defines :as list))
(join "\n" (map (fn (pair) (join "\n" (map (fn (pair)
(let ((name (first pair)) (let ((name (first pair))
(expr (nth pair 1))) (expr (nth pair 1)))

View File

@@ -39,7 +39,7 @@ def _get_z3_env() -> dict[str, Any]:
return _z3_env return _z3_env
from shared.sx.parser import parse_all from shared.sx.parser import parse_all
from shared.sx.evaluator import make_env, _eval, _trampoline from shared.sx.ref.sx_ref import make_env, eval_expr as _eval, trampoline as _trampoline
env = make_env() env = make_env()
z3_path = os.path.join(os.path.dirname(__file__), "z3.sx") z3_path = os.path.join(os.path.dirname(__file__), "z3.sx")
@@ -60,7 +60,7 @@ def z3_translate(expr: Any) -> str:
Delegates to z3-translate defined in z3.sx. Delegates to z3-translate defined in z3.sx.
""" """
from shared.sx.evaluator import _trampoline, _call_lambda from shared.sx.ref.sx_ref import trampoline as _trampoline, call_lambda as _call_lambda
env = _get_z3_env() env = _get_z3_env()
return _trampoline(_call_lambda(env["z3-translate"], [expr], env)) return _trampoline(_call_lambda(env["z3-translate"], [expr], env))
@@ -72,7 +72,7 @@ def z3_translate_file(source: str) -> str:
Delegates to z3-translate-file defined in z3.sx. Delegates to z3-translate-file defined in z3.sx.
""" """
from shared.sx.parser import parse_all from shared.sx.parser import parse_all
from shared.sx.evaluator import _trampoline, _call_lambda from shared.sx.ref.sx_ref import trampoline as _trampoline, call_lambda as _call_lambda
env = _get_z3_env() env = _get_z3_env()
exprs = parse_all(source) exprs = parse_all(source)

View File

@@ -71,19 +71,20 @@
;; Shared utilities ;; Shared utilities
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define definition-form? (define definition-form? :effects []
(fn (name) (fn ((name :as string))
(or (= name "define") (= name "defcomp") (= name "defisland") (or (= name "define") (= name "defcomp") (= name "defisland")
(= name "defmacro") (= name "defstyle") (= name "defhandler")))) (= name "defmacro") (= name "defstyle") (= name "defhandler")
(= name "deftype") (= name "defeffect"))))
(define parse-element-args (define parse-element-args :effects [render]
(fn (args env) (fn ((args :as list) (env :as dict))
;; Parse (:key val :key2 val2 child1 child2) into (attrs-dict children-list) ;; Parse (:key val :key2 val2 child1 child2) into (attrs-dict children-list)
(let ((attrs (dict)) (let ((attrs (dict))
(children (list))) (children (list)))
(reduce (reduce
(fn (state arg) (fn ((state :as dict) arg)
(let ((skip (get state "skip"))) (let ((skip (get state "skip")))
(if skip (if skip
(assoc state "skip" false "i" (inc (get state "i"))) (assoc state "skip" false "i" (inc (get state "i")))
@@ -100,13 +101,13 @@
(list attrs children)))) (list attrs children))))
(define render-attrs (define render-attrs :effects []
(fn (attrs) (fn ((attrs :as dict))
;; Render an attrs dict to an HTML attribute string. ;; Render an attrs dict to an HTML attribute string.
;; Used by adapter-html.sx and adapter-sx.sx. ;; Used by adapter-html.sx and adapter-sx.sx.
(join "" (join ""
(map (map
(fn (key) (fn ((key :as string))
(let ((val (dict-get attrs key))) (let ((val (dict-get attrs key)))
(cond (cond
;; Boolean attrs ;; Boolean attrs
@@ -132,18 +133,14 @@
;; eval-cond: find matching cond branch, return unevaluated body expr. ;; eval-cond: find matching cond branch, return unevaluated body expr.
;; Handles both scheme-style ((test body) ...) and clojure-style ;; Handles both scheme-style ((test body) ...) and clojure-style
;; (test body test body ...). ;; (test body test body ...).
(define eval-cond (define eval-cond :effects []
(fn (clauses env) (fn ((clauses :as list) (env :as dict))
(if (and (not (empty? clauses)) (if (cond-scheme? clauses)
(= (type-of (first clauses)) "list")
(= (len (first clauses)) 2))
;; Scheme-style
(eval-cond-scheme clauses env) (eval-cond-scheme clauses env)
;; Clojure-style
(eval-cond-clojure clauses env)))) (eval-cond-clojure clauses env))))
(define eval-cond-scheme (define eval-cond-scheme :effects []
(fn (clauses env) (fn ((clauses :as list) (env :as dict))
(if (empty? clauses) (if (empty? clauses)
nil nil
(let ((clause (first clauses)) (let ((clause (first clauses))
@@ -159,8 +156,8 @@
body body
(eval-cond-scheme (rest clauses) env))))))) (eval-cond-scheme (rest clauses) env)))))))
(define eval-cond-clojure (define eval-cond-clojure :effects []
(fn (clauses env) (fn ((clauses :as list) (env :as dict))
(if (< (len clauses) 2) (if (< (len clauses) 2)
nil nil
(let ((test (first clauses)) (let ((test (first clauses))
@@ -176,11 +173,13 @@
;; process-bindings: evaluate let-binding pairs, return extended env. ;; process-bindings: evaluate let-binding pairs, return extended env.
;; bindings = ((name1 expr1) (name2 expr2) ...) ;; bindings = ((name1 expr1) (name2 expr2) ...)
(define process-bindings (define process-bindings :effects [mutation]
(fn (bindings env) (fn ((bindings :as list) (env :as dict))
(let ((local (merge env))) ;; env-extend (not merge) — Env is not a dict subclass, so merge()
;; returns an empty dict, losing all parent scope bindings.
(let ((local (env-extend env)))
(for-each (for-each
(fn (pair) (fn ((pair :as list))
(when (and (= (type-of pair) "list") (>= (len pair) 2)) (when (and (= (type-of pair) "list") (>= (len pair) 2))
(let ((name (if (= (type-of (first pair)) "symbol") (let ((name (if (= (type-of (first pair)) "symbol")
(symbol-name (first pair)) (symbol-name (first pair))
@@ -196,7 +195,7 @@
;; Used by eval-list to dispatch rendering forms to the active adapter ;; Used by eval-list to dispatch rendering forms to the active adapter
;; (HTML, SX wire, or DOM) rather than evaluating them as function calls. ;; (HTML, SX wire, or DOM) rather than evaluating them as function calls.
(define is-render-expr? (define is-render-expr? :effects []
(fn (expr) (fn (expr)
(if (or (not (= (type-of expr) "list")) (empty? expr)) (if (or (not (= (type-of expr) "list")) (empty? expr))
false false

View File

@@ -17,8 +17,8 @@
;; "/" → () ;; "/" → ()
;; "/docs/" → ("docs") ;; "/docs/" → ("docs")
(define split-path-segments (define split-path-segments :effects []
(fn (path) (fn ((path :as string))
(let ((trimmed (if (starts-with? path "/") (slice path 1) path))) (let ((trimmed (if (starts-with? path "/") (slice path 1) path)))
(let ((trimmed2 (if (and (not (empty? trimmed)) (let ((trimmed2 (if (and (not (empty? trimmed))
(ends-with? trimmed "/")) (ends-with? trimmed "/"))
@@ -35,8 +35,8 @@
;; "/docs/<slug>" → ({"type" "literal" "value" "docs"} ;; "/docs/<slug>" → ({"type" "literal" "value" "docs"}
;; {"type" "param" "value" "slug"}) ;; {"type" "param" "value" "slug"})
(define make-route-segment (define make-route-segment :effects []
(fn (seg) (fn ((seg :as string))
(if (and (starts-with? seg "<") (ends-with? seg ">")) (if (and (starts-with? seg "<") (ends-with? seg ">"))
(let ((param-name (slice seg 1 (- (len seg) 1)))) (let ((param-name (slice seg 1 (- (len seg) 1))))
(let ((d {})) (let ((d {}))
@@ -48,8 +48,8 @@
(dict-set! d "value" seg) (dict-set! d "value" seg)
d)))) d))))
(define parse-route-pattern (define parse-route-pattern :effects []
(fn (pattern) (fn ((pattern :as string))
(let ((segments (split-path-segments pattern))) (let ((segments (split-path-segments pattern)))
(map make-route-segment segments)))) (map make-route-segment segments))))
@@ -59,14 +59,14 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; Returns params dict if match, nil if no match. ;; Returns params dict if match, nil if no match.
(define match-route-segments (define match-route-segments :effects []
(fn (path-segs parsed-segs) (fn ((path-segs :as list) (parsed-segs :as list))
(if (not (= (len path-segs) (len parsed-segs))) (if (not (= (len path-segs) (len parsed-segs)))
nil nil
(let ((params {}) (let ((params {})
(matched true)) (matched true))
(for-each-indexed (for-each-indexed
(fn (i parsed-seg) (fn ((i :as number) (parsed-seg :as dict))
(when matched (when matched
(let ((path-seg (nth path-segs i)) (let ((path-seg (nth path-segs i))
(seg-type (get parsed-seg "type"))) (seg-type (get parsed-seg "type")))
@@ -87,8 +87,8 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; Returns params dict (may be empty for exact matches) or nil. ;; Returns params dict (may be empty for exact matches) or nil.
(define match-route (define match-route :effects []
(fn (path pattern) (fn ((path :as string) (pattern :as string))
(let ((path-segs (split-path-segments path)) (let ((path-segs (split-path-segments path))
(parsed-segs (parse-route-pattern pattern))) (parsed-segs (parse-route-pattern pattern)))
(match-route-segments path-segs parsed-segs)))) (match-route-segments path-segs parsed-segs))))
@@ -100,12 +100,12 @@
;; Each entry: {"pattern" "/docs/<slug>" "parsed" [...] "name" "docs-page" ...} ;; Each entry: {"pattern" "/docs/<slug>" "parsed" [...] "name" "docs-page" ...}
;; Returns matching entry with "params" added, or nil. ;; Returns matching entry with "params" added, or nil.
(define find-matching-route (define find-matching-route :effects []
(fn (path routes) (fn ((path :as string) (routes :as list))
(let ((path-segs (split-path-segments path)) (let ((path-segs (split-path-segments path))
(result nil)) (result nil))
(for-each (for-each
(fn (route) (fn ((route :as dict))
(when (nil? result) (when (nil? result)
(let ((params (match-route-segments path-segs (get route "parsed")))) (let ((params (match-route-segments path-segs (get route "parsed"))))
(when (not (nil? params)) (when (not (nil? params))

View File

@@ -1,16 +1,14 @@
#!/usr/bin/env python3 #!/usr/bin/env python3
""" """
Bootstrap runner: execute js.sx against spec files to produce sx-ref.js. Bootstrap compiler: js.sx (self-hosting SX-to-JS translator) → sx-browser.js.
This is the G1 bootstrapper js.sx (SX-to-JavaScript translator written in SX) This is the canonical JS bootstrapper. js.sx is loaded into the Python evaluator,
is loaded into the Python evaluator, which then uses it to translate the which uses it to translate the .sx spec files into JavaScript. Platform code
spec .sx files into JavaScript. (types, primitives, DOM interface) comes from platform_js.py.
The output (transpiled defines only) should be identical to what
bootstrap_js.py's JSEmitter produces.
Usage: Usage:
python run_js_sx.py > /tmp/sx_ref_g1.js python run_js_sx.py # stdout
python run_js_sx.py -o shared/static/scripts/sx-browser.js # file
""" """
from __future__ import annotations from __future__ import annotations
@@ -19,83 +17,228 @@ import sys
_HERE = os.path.dirname(os.path.abspath(__file__)) _HERE = os.path.dirname(os.path.abspath(__file__))
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", "..", "..")) _PROJECT = os.path.abspath(os.path.join(_HERE, "..", "..", ".."))
sys.path.insert(0, _PROJECT) if _PROJECT not in sys.path:
sys.path.insert(0, _PROJECT)
from shared.sx.parser import parse_all from shared.sx.parser import parse_all
from shared.sx.types import Symbol from shared.sx.types import Symbol
from shared.sx.ref.platform_js import (
extract_defines,
ADAPTER_FILES, ADAPTER_DEPS, SPEC_MODULES, EXTENSION_NAMES,
PREAMBLE, PLATFORM_JS_PRE, PLATFORM_JS_POST,
PRIMITIVES_JS_MODULES, _ALL_JS_MODULES, _assemble_primitives_js,
PLATFORM_DEPS_JS, PLATFORM_PARSER_JS, PLATFORM_DOM_JS,
PLATFORM_ENGINE_PURE_JS, PLATFORM_ORCHESTRATION_JS, PLATFORM_BOOT_JS,
CONTINUATIONS_JS, ASYNC_IO_JS,
fixups_js, public_api_js, EPILOGUE,
)
_js_sx_env = None # cached
def load_js_sx() -> dict: def load_js_sx() -> dict:
"""Load js.sx into an evaluator environment and return it.""" """Load js.sx into an evaluator environment and return it."""
global _js_sx_env
if _js_sx_env is not None:
return _js_sx_env
js_sx_path = os.path.join(_HERE, "js.sx") js_sx_path = os.path.join(_HERE, "js.sx")
with open(js_sx_path) as f: with open(js_sx_path) as f:
source = f.read() source = f.read()
exprs = parse_all(source) exprs = parse_all(source)
from shared.sx.evaluator import evaluate, make_env from shared.sx.ref.sx_ref import evaluate, make_env
env = make_env() env = make_env()
for expr in exprs: for expr in exprs:
evaluate(expr, env) evaluate(expr, env)
_js_sx_env = env
return env return env
def extract_defines(source: str) -> list[tuple[str, list]]: def compile_ref_to_js(
"""Parse .sx source, return list of (name, define-expr) for top-level defines.""" adapters: list[str] | None = None,
exprs = parse_all(source) modules: list[str] | None = None,
defines = [] extensions: list[str] | None = None,
for expr in exprs: spec_modules: list[str] | None = None,
if isinstance(expr, list) and expr and isinstance(expr[0], Symbol): ) -> str:
if expr[0].name == "define": """Compile SX spec files to JavaScript using js.sx.
name = expr[1].name if isinstance(expr[1], Symbol) else str(expr[1])
defines.append((name, expr))
return defines
Args:
adapters: List of adapter names to include. None = all.
modules: List of primitive module names. None = all.
extensions: List of extensions (continuations). None = none.
spec_modules: List of spec modules (deps, router, signals). None = auto.
"""
from datetime import datetime, timezone
from shared.sx.ref.sx_ref import evaluate
def main(): ref_dir = _HERE
from shared.sx.evaluator import evaluate
# Load js.sx into evaluator
env = load_js_sx() env = load_js_sx()
# Same file list and order as bootstrap_js.py compile_ref_to_js() with all adapters # Resolve adapter set
if adapters is None:
adapter_set = set(ADAPTER_FILES.keys())
else:
adapter_set = set()
for a in adapters:
if a not in ADAPTER_FILES:
raise ValueError(f"Unknown adapter: {a!r}. Valid: {', '.join(ADAPTER_FILES)}")
adapter_set.add(a)
for dep in ADAPTER_DEPS.get(a, []):
adapter_set.add(dep)
# Resolve spec modules
spec_mod_set = set()
if spec_modules:
for sm in spec_modules:
if sm not in SPEC_MODULES:
raise ValueError(f"Unknown spec module: {sm!r}. Valid: {', '.join(SPEC_MODULES)}")
spec_mod_set.add(sm)
if "dom" in adapter_set and "signals" in SPEC_MODULES:
spec_mod_set.add("signals")
if "boot" in adapter_set:
spec_mod_set.add("router")
spec_mod_set.add("deps")
if "page-helpers" in SPEC_MODULES:
spec_mod_set.add("page-helpers")
has_deps = "deps" in spec_mod_set
has_router = "router" in spec_mod_set
has_page_helpers = "page-helpers" in spec_mod_set
# Resolve extensions
ext_set = set()
if extensions:
for e in extensions:
if e not in EXTENSION_NAMES:
raise ValueError(f"Unknown extension: {e!r}. Valid: {', '.join(EXTENSION_NAMES)}")
ext_set.add(e)
has_continuations = "continuations" in ext_set
# Build file list: core + adapters + spec modules
sx_files = [ sx_files = [
("eval.sx", "eval"), ("eval.sx", "eval"),
("render.sx", "render (core)"), ("render.sx", "render (core)"),
("parser.sx", "parser"),
("adapter-html.sx", "adapter-html"),
("adapter-sx.sx", "adapter-sx"),
("adapter-dom.sx", "adapter-dom"),
("engine.sx", "engine"),
("orchestration.sx", "orchestration"),
("boot.sx", "boot"),
("deps.sx", "deps (component dependency analysis)"),
("router.sx", "router (client-side route matching)"),
("signals.sx", "signals (reactive signal runtime)"),
] ]
for name in ("parser", "html", "sx", "dom", "engine", "orchestration", "boot"):
if name in adapter_set:
sx_files.append(ADAPTER_FILES[name])
for name in sorted(spec_mod_set):
sx_files.append(SPEC_MODULES[name])
has_html = "html" in adapter_set
has_sx = "sx" in adapter_set
has_dom = "dom" in adapter_set
has_engine = "engine" in adapter_set
has_orch = "orchestration" in adapter_set
has_boot = "boot" in adapter_set
has_parser = "parser" in adapter_set
has_signals = "signals" in spec_mod_set
adapter_label = "+".join(sorted(adapter_set)) if adapter_set else "core-only"
# Platform JS blocks keyed by adapter name
adapter_platform = {
"parser": PLATFORM_PARSER_JS,
"dom": PLATFORM_DOM_JS,
"engine": PLATFORM_ENGINE_PURE_JS,
"orchestration": PLATFORM_ORCHESTRATION_JS,
"boot": PLATFORM_BOOT_JS,
}
# Determine primitive modules
prim_modules = None
if modules is not None:
prim_modules = [m for m in _ALL_JS_MODULES if m.startswith("core.")]
for m in modules:
if m not in prim_modules:
if m not in PRIMITIVES_JS_MODULES:
raise ValueError(f"Unknown module: {m!r}. Valid: {', '.join(PRIMITIVES_JS_MODULES)}")
prim_modules.append(m)
# Build output
parts = []
parts.append(PREAMBLE)
parts.append(PLATFORM_JS_PRE)
parts.append('\n // =========================================================================')
parts.append(' // Primitives')
parts.append(' // =========================================================================\n')
parts.append(' var PRIMITIVES = {};')
parts.append(_assemble_primitives_js(prim_modules))
parts.append(PLATFORM_JS_POST)
if has_deps:
parts.append(PLATFORM_DEPS_JS)
if has_parser:
parts.append(adapter_platform["parser"])
# Translate each spec file using js.sx # Translate each spec file using js.sx
for filename, label in sx_files: for filename, label in sx_files:
filepath = os.path.join(_HERE, filename) filepath = os.path.join(ref_dir, filename)
if not os.path.exists(filepath): if not os.path.exists(filepath):
continue continue
with open(filepath) as f: with open(filepath) as f:
src = f.read() src = f.read()
defines = extract_defines(src) defines = extract_defines(src)
# Convert defines to SX-compatible format
sx_defines = [[name, expr] for name, expr in defines] sx_defines = [[name, expr] for name, expr in defines]
print(f"\n // === Transpiled from {label} ===\n") parts.append(f"\n // === Transpiled from {label} ===\n")
env["_defines"] = sx_defines env["_defines"] = sx_defines
result = evaluate( result = evaluate(
[Symbol("js-translate-file"), Symbol("_defines")], [Symbol("js-translate-file"), Symbol("_defines")],
env, env,
) )
print(result) parts.append(result)
# Platform JS for selected adapters
if not has_dom:
parts.append("\n var _hasDom = false;\n")
for name in ("dom", "engine", "orchestration", "boot"):
if name in adapter_set and name in adapter_platform:
parts.append(adapter_platform[name])
parts.append(fixups_js(has_html, has_sx, has_dom, has_signals, has_deps, has_page_helpers))
if has_continuations:
parts.append(CONTINUATIONS_JS)
if has_dom:
parts.append(ASYNC_IO_JS)
parts.append(public_api_js(has_html, has_sx, has_dom, has_engine, has_orch, has_boot, has_parser, adapter_label, has_deps, has_router, has_signals, has_page_helpers))
parts.append(EPILOGUE)
build_ts = datetime.now(timezone.utc).strftime("%Y-%m-%dT%H:%M:%SZ")
return "\n".join(parts).replace("BUILD_TIMESTAMP", build_ts)
if __name__ == "__main__": if __name__ == "__main__":
main() import argparse
p = argparse.ArgumentParser(description="Bootstrap-compile SX reference spec to JavaScript via js.sx")
p.add_argument("--adapters", "-a",
help="Comma-separated adapter list (html,sx,dom,engine). Default: all")
p.add_argument("--modules", "-m",
help="Comma-separated primitive modules (core.* always included). Default: all")
p.add_argument("--extensions",
help="Comma-separated extensions (continuations). Default: none.")
p.add_argument("--spec-modules",
help="Comma-separated spec modules (deps). Default: none.")
default_output = os.path.join(_HERE, "..", "..", "static", "scripts", "sx-browser.js")
p.add_argument("--output", "-o", default=default_output,
help="Output file (default: shared/static/scripts/sx-browser.js)")
args = p.parse_args()
adapters = args.adapters.split(",") if args.adapters else None
modules = args.modules.split(",") if args.modules else None
extensions = args.extensions.split(",") if args.extensions else None
spec_modules = args.spec_modules.split(",") if args.spec_modules else None
js = compile_ref_to_js(adapters, modules, extensions, spec_modules)
with open(args.output, "w") as f:
f.write(js)
included = ", ".join(adapters) if adapters else "all"
mods = ", ".join(modules) if modules else "all"
ext_label = ", ".join(extensions) if extensions else "none"
print(f"Wrote {args.output} ({len(js)} bytes, adapters: {included}, modules: {mods}, extensions: {ext_label})",
file=sys.stderr)

View File

@@ -22,10 +22,9 @@ sys.path.insert(0, _PROJECT)
from shared.sx.parser import parse_all from shared.sx.parser import parse_all
from shared.sx.types import Symbol from shared.sx.types import Symbol
from shared.sx.ref.bootstrap_py import ( from shared.sx.ref.platform_py import (
PREAMBLE, PLATFORM_PY, PRIMITIVES_PY_PRE, PRIMITIVES_PY_POST, PREAMBLE, PLATFORM_PY, PRIMITIVES_PY_PRE, PRIMITIVES_PY_POST,
PLATFORM_DEPS_PY, FIXUPS_PY, CONTINUATIONS_PY, PLATFORM_DEPS_PY, FIXUPS_PY, CONTINUATIONS_PY,
ADAPTER_FILES, SPEC_MODULES,
_assemble_primitives_py, public_api_py, _assemble_primitives_py, public_api_py,
) )
@@ -39,7 +38,7 @@ def load_py_sx(evaluator_env: dict) -> dict:
exprs = parse_all(source) exprs = parse_all(source)
# Import the evaluator # Import the evaluator
from shared.sx.evaluator import evaluate, make_env from shared.sx.ref.sx_ref import evaluate, make_env
env = make_env() env = make_env()
for expr in exprs: for expr in exprs:
@@ -61,7 +60,7 @@ def extract_defines(source: str) -> list[tuple[str, list]]:
def main(): def main():
from shared.sx.evaluator import evaluate from shared.sx.ref.sx_ref import evaluate
# Load py.sx into evaluator # Load py.sx into evaluator
env = load_py_sx({}) env = load_py_sx({})

View File

@@ -0,0 +1,180 @@
#!/usr/bin/env python3
"""Run test-types.sx using the bootstrapped evaluator with types module loaded."""
from __future__ import annotations
import os, sys
_HERE = os.path.dirname(os.path.abspath(__file__))
_PROJECT = os.path.abspath(os.path.join(_HERE, "..", "..", ".."))
sys.path.insert(0, _PROJECT)
from shared.sx.parser import parse_all
from shared.sx.ref.sx_ref import eval_expr, trampoline, make_env
from shared.sx.types import NIL, Component
# Build env with primitives
env = make_env()
# Platform test functions
_suite_stack: list[str] = []
_pass_count = 0
_fail_count = 0
def _try_call(thunk):
try:
trampoline(eval_expr([thunk], env)) # call the thunk
return {"ok": True}
except Exception as e:
return {"ok": False, "error": str(e)}
def _report_pass(name):
global _pass_count
_pass_count += 1
ctx = " > ".join(_suite_stack)
print(f" PASS: {ctx} > {name}")
return NIL
def _report_fail(name, error):
global _fail_count
_fail_count += 1
ctx = " > ".join(_suite_stack)
print(f" FAIL: {ctx} > {name}: {error}")
return NIL
def _push_suite(name):
_suite_stack.append(name)
print(f"{' ' * (len(_suite_stack)-1)}Suite: {name}")
return NIL
def _pop_suite():
if _suite_stack:
_suite_stack.pop()
return NIL
env["try-call"] = _try_call
env["report-pass"] = _report_pass
env["report-fail"] = _report_fail
env["push-suite"] = _push_suite
env["pop-suite"] = _pop_suite
# Test fixtures — provide the functions that tests expect
# test-prim-types: dict of primitive return types for type inference
def _test_prim_types():
return {
"+": "number", "-": "number", "*": "number", "/": "number",
"mod": "number", "inc": "number", "dec": "number",
"abs": "number", "min": "number", "max": "number",
"floor": "number", "ceil": "number", "round": "number",
"str": "string", "upper": "string", "lower": "string",
"trim": "string", "join": "string", "replace": "string",
"format": "string", "substr": "string",
"=": "boolean", "<": "boolean", ">": "boolean",
"<=": "boolean", ">=": "boolean", "!=": "boolean",
"not": "boolean", "nil?": "boolean", "empty?": "boolean",
"number?": "boolean", "string?": "boolean", "boolean?": "boolean",
"list?": "boolean", "dict?": "boolean", "symbol?": "boolean",
"keyword?": "boolean", "contains?": "boolean", "has-key?": "boolean",
"starts-with?": "boolean", "ends-with?": "boolean",
"len": "number", "first": "any", "rest": "list",
"last": "any", "nth": "any", "cons": "list",
"append": "list", "concat": "list", "reverse": "list",
"sort": "list", "slice": "list", "range": "list",
"flatten": "list", "keys": "list", "vals": "list",
"map-dict": "dict", "assoc": "dict", "dissoc": "dict",
"merge": "dict", "dict": "dict",
"get": "any", "type-of": "string",
}
# test-prim-param-types: dict of primitive param type specs
# Format: {name → {"positional" [["name" "type"] ...] "rest-type" type-or-nil}}
def _test_prim_param_types():
return {
"+": {"positional": [["a", "number"]], "rest-type": "number"},
"-": {"positional": [["a", "number"]], "rest-type": "number"},
"*": {"positional": [["a", "number"]], "rest-type": "number"},
"/": {"positional": [["a", "number"]], "rest-type": "number"},
"inc": {"positional": [["n", "number"]], "rest-type": NIL},
"dec": {"positional": [["n", "number"]], "rest-type": NIL},
"upper": {"positional": [["s", "string"]], "rest-type": NIL},
"lower": {"positional": [["s", "string"]], "rest-type": NIL},
"keys": {"positional": [["d", "dict"]], "rest-type": NIL},
"vals": {"positional": [["d", "dict"]], "rest-type": NIL},
}
# test-env: returns a fresh env for use in tests (same as the test env)
def _test_env():
return env
# sx-parse: parse an SX string and return list of AST nodes
def _sx_parse(source):
return parse_all(source)
# dict-get: used in some legacy tests
def _dict_get(d, k):
v = d.get(k) if isinstance(d, dict) else NIL
return v if v is not None else NIL
# component-set-param-types! and component-param-types: type annotation accessors
def _component_set_param_types(comp, types_dict):
comp.param_types = types_dict
return NIL
def _component_param_types(comp):
return getattr(comp, 'param_types', NIL)
# Platform functions used by types.sx but not SX primitives
def _component_params(c):
return c.params
def _component_body(c):
return c.body
def _component_has_children(c):
return c.has_children
def _map_dict(fn, d):
from shared.sx.types import Lambda as _Lambda
result = {}
for k, v in d.items():
if isinstance(fn, _Lambda):
# Call SX lambda through the evaluator
result[k] = trampoline(eval_expr([fn, k, v], env))
else:
result[k] = fn(k, v)
return result
env["test-prim-types"] = _test_prim_types
env["test-prim-param-types"] = _test_prim_param_types
env["test-env"] = _test_env
env["sx-parse"] = _sx_parse
env["dict-get"] = _dict_get
env["component-set-param-types!"] = _component_set_param_types
env["component-param-types"] = _component_param_types
env["component-params"] = _component_params
env["component-body"] = _component_body
env["component-has-children"] = _component_has_children
env["map-dict"] = _map_dict
# Load test framework (macros + assertion helpers)
with open(os.path.join(_HERE, "test-framework.sx")) as f:
for expr in parse_all(f.read()):
trampoline(eval_expr(expr, env))
# Load types module
with open(os.path.join(_HERE, "types.sx")) as f:
for expr in parse_all(f.read()):
trampoline(eval_expr(expr, env))
# Run tests
print("=" * 60)
print("Running test-types.sx")
print("=" * 60)
with open(os.path.join(_HERE, "test-types.sx")) as f:
for expr in parse_all(f.read()):
trampoline(eval_expr(expr, env))
print("=" * 60)
print(f"Results: {_pass_count} passed, {_fail_count} failed")
print("=" * 60)
sys.exit(1 if _fail_count > 0 else 0)

View File

@@ -41,8 +41,8 @@
;; 1. signal — create a reactive container ;; 1. signal — create a reactive container
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define signal (define signal :effects []
(fn (initial-value) (fn ((initial-value :as any))
(make-signal initial-value))) (make-signal initial-value)))
@@ -54,8 +54,8 @@
;; signal as a dependency. Outside reactive context, deref just returns ;; signal as a dependency. Outside reactive context, deref just returns
;; the current value — no subscription, no overhead. ;; the current value — no subscription, no overhead.
(define deref (define deref :effects []
(fn (s) (fn ((s :as any))
(if (not (signal? s)) (if (not (signal? s))
s ;; non-signal values pass through s ;; non-signal values pass through
(let ((ctx (get-tracking-context))) (let ((ctx (get-tracking-context)))
@@ -71,8 +71,8 @@
;; 3. reset! — write a new value, notify subscribers ;; 3. reset! — write a new value, notify subscribers
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define reset! (define reset! :effects [mutation]
(fn (s value) (fn ((s :as signal) value)
(when (signal? s) (when (signal? s)
(let ((old (signal-value s))) (let ((old (signal-value s)))
(when (not (identical? old value)) (when (not (identical? old value))
@@ -84,8 +84,8 @@
;; 4. swap! — update signal via function ;; 4. swap! — update signal via function
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define swap! (define swap! :effects [mutation]
(fn (s f &rest args) (fn ((s :as signal) (f :as lambda) &rest args)
(when (signal? s) (when (signal? s)
(let ((old (signal-value s)) (let ((old (signal-value s))
(new-val (apply f (cons old args)))) (new-val (apply f (cons old args))))
@@ -102,8 +102,8 @@
;; of its dependencies change. The dependency set is discovered automatically ;; of its dependencies change. The dependency set is discovered automatically
;; by tracking deref calls during evaluation. ;; by tracking deref calls during evaluation.
(define computed (define computed :effects [mutation]
(fn (compute-fn) (fn ((compute-fn :as lambda))
(let ((s (make-signal nil)) (let ((s (make-signal nil))
(deps (list)) (deps (list))
(compute-ctx nil)) (compute-ctx nil))
@@ -113,7 +113,7 @@
(fn () (fn ()
;; Unsubscribe from old deps ;; Unsubscribe from old deps
(for-each (for-each
(fn (dep) (signal-remove-sub! dep recompute)) (fn ((dep :as signal)) (signal-remove-sub! dep recompute))
(signal-deps s)) (signal-deps s))
(signal-set-deps! s (list)) (signal-set-deps! s (list))
@@ -145,8 +145,8 @@
;; Like computed, but doesn't produce a signal value. Returns a dispose ;; Like computed, but doesn't produce a signal value. Returns a dispose
;; function that tears down the effect. ;; function that tears down the effect.
(define effect (define effect :effects [mutation]
(fn (effect-fn) (fn ((effect-fn :as lambda))
(let ((deps (list)) (let ((deps (list))
(disposed false) (disposed false)
(cleanup-fn nil)) (cleanup-fn nil))
@@ -159,7 +159,7 @@
;; Unsubscribe from old deps ;; Unsubscribe from old deps
(for-each (for-each
(fn (dep) (signal-remove-sub! dep run-effect)) (fn ((dep :as signal)) (signal-remove-sub! dep run-effect))
deps) deps)
(set! deps (list)) (set! deps (list))
@@ -183,7 +183,7 @@
(set! disposed true) (set! disposed true)
(when cleanup-fn (invoke cleanup-fn)) (when cleanup-fn (invoke cleanup-fn))
(for-each (for-each
(fn (dep) (signal-remove-sub! dep run-effect)) (fn ((dep :as signal)) (signal-remove-sub! dep run-effect))
deps) deps)
(set! deps (list))))) (set! deps (list)))))
;; Auto-register with island scope so disposal happens on swap ;; Auto-register with island scope so disposal happens on swap
@@ -201,8 +201,8 @@
(define *batch-depth* 0) (define *batch-depth* 0)
(define *batch-queue* (list)) (define *batch-queue* (list))
(define batch (define batch :effects [mutation]
(fn (thunk) (fn ((thunk :as lambda))
(set! *batch-depth* (+ *batch-depth* 1)) (set! *batch-depth* (+ *batch-depth* 1))
(invoke thunk) (invoke thunk)
(set! *batch-depth* (- *batch-depth* 1)) (set! *batch-depth* (- *batch-depth* 1))
@@ -214,15 +214,15 @@
(let ((seen (list)) (let ((seen (list))
(pending (list))) (pending (list)))
(for-each (for-each
(fn (s) (fn ((s :as signal))
(for-each (for-each
(fn (sub) (fn ((sub :as lambda))
(when (not (contains? seen sub)) (when (not (contains? seen sub))
(append! seen sub) (append! seen sub)
(append! pending sub))) (append! pending sub)))
(signal-subscribers s))) (signal-subscribers s)))
queue) queue)
(for-each (fn (sub) (sub)) pending)))))) (for-each (fn ((sub :as lambda)) (sub)) pending))))))
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
@@ -231,17 +231,17 @@
;; ;;
;; If inside a batch, queues the signal. Otherwise, notifies immediately. ;; If inside a batch, queues the signal. Otherwise, notifies immediately.
(define notify-subscribers (define notify-subscribers :effects [mutation]
(fn (s) (fn ((s :as signal))
(if (> *batch-depth* 0) (if (> *batch-depth* 0)
(when (not (contains? *batch-queue* s)) (when (not (contains? *batch-queue* s))
(append! *batch-queue* s)) (append! *batch-queue* s))
(flush-subscribers s)))) (flush-subscribers s))))
(define flush-subscribers (define flush-subscribers :effects [mutation]
(fn (s) (fn ((s :as signal))
(for-each (for-each
(fn (sub) (sub)) (fn ((sub :as lambda)) (sub))
(signal-subscribers s)))) (signal-subscribers s))))
@@ -268,11 +268,11 @@
;; For computed signals, unsubscribe from all dependencies. ;; For computed signals, unsubscribe from all dependencies.
;; For effects, the dispose function is returned by effect itself. ;; For effects, the dispose function is returned by effect itself.
(define dispose-computed (define dispose-computed :effects [mutation]
(fn (s) (fn ((s :as signal))
(when (signal? s) (when (signal? s)
(for-each (for-each
(fn (dep) (signal-remove-sub! dep nil)) (fn ((dep :as signal)) (signal-remove-sub! dep nil))
(signal-deps s)) (signal-deps s))
(signal-set-deps! s (list))))) (signal-set-deps! s (list)))))
@@ -287,8 +287,8 @@
(define *island-scope* nil) (define *island-scope* nil)
(define with-island-scope (define with-island-scope :effects [mutation]
(fn (scope-fn body-fn) (fn ((scope-fn :as lambda) (body-fn :as lambda))
(let ((prev *island-scope*)) (let ((prev *island-scope*))
(set! *island-scope* scope-fn) (set! *island-scope* scope-fn)
(let ((result (body-fn))) (let ((result (body-fn)))
@@ -299,14 +299,54 @@
;; The platform's make-signal should call (register-in-scope s) if ;; The platform's make-signal should call (register-in-scope s) if
;; *island-scope* is non-nil. ;; *island-scope* is non-nil.
(define register-in-scope (define register-in-scope :effects [mutation]
(fn (disposable) (fn ((disposable :as lambda))
(when *island-scope* (when *island-scope*
(*island-scope* disposable)))) (*island-scope* disposable))))
;; ========================================================================== ;; ==========================================================================
;; 12. Named stores — page-level signal containers (L3) ;; 12. Marsh scopes — child scopes within islands
;; ==========================================================================
;;
;; Marshes are zones inside islands where server content is re-evaluated
;; in the island's reactive context. When a marsh is re-morphed with new
;; content, its old effects and computeds must be disposed WITHOUT disturbing
;; the island's own reactive graph.
;;
;; Scope hierarchy: island → marsh → effects/computeds
;; Disposing a marsh disposes its subscope. Disposing an island disposes
;; all its marshes. The signal graph is a tree, not a flat list.
;;
;; Platform interface required:
;; (dom-set-data el key val) → void — store JS value on element
;; (dom-get-data el key) → any — retrieve stored value
(define with-marsh-scope :effects [mutation io]
(fn (marsh-el (body-fn :as lambda))
;; Execute body-fn collecting all disposables into a marsh-local list.
;; Nested under the current island scope — if the island is disposed,
;; the marsh is disposed too (because island scope collected the marsh's
;; own dispose function).
(let ((disposers (list)))
(with-island-scope
(fn (d) (append! disposers d))
body-fn)
;; Store disposers on the marsh element for later cleanup
(dom-set-data marsh-el "sx-marsh-disposers" disposers))))
(define dispose-marsh-scope :effects [mutation io]
(fn (marsh-el)
;; Dispose all effects/computeds registered in this marsh's scope.
;; Parent island scope and sibling marshes are unaffected.
(let ((disposers (dom-get-data marsh-el "sx-marsh-disposers")))
(when disposers
(for-each (fn ((d :as lambda)) (invoke d)) disposers)
(dom-set-data marsh-el "sx-marsh-disposers" nil)))))
;; ==========================================================================
;; 13. Named stores — page-level signal containers (L3)
;; ========================================================================== ;; ==========================================================================
;; ;;
;; Stores persist across island creation/destruction. They live at page ;; Stores persist across island creation/destruction. They live at page
@@ -318,22 +358,22 @@
(define *store-registry* (dict)) (define *store-registry* (dict))
(define def-store (define def-store :effects [mutation]
(fn (name init-fn) (fn ((name :as string) (init-fn :as lambda))
(let ((registry *store-registry*)) (let ((registry *store-registry*))
;; Only create the store once — subsequent calls return existing ;; Only create the store once — subsequent calls return existing
(when (not (has-key? registry name)) (when (not (has-key? registry name))
(set! *store-registry* (assoc registry name (invoke init-fn)))) (set! *store-registry* (assoc registry name (invoke init-fn))))
(get *store-registry* name)))) (get *store-registry* name))))
(define use-store (define use-store :effects []
(fn (name) (fn ((name :as string))
(if (has-key? *store-registry* name) (if (has-key? *store-registry* name)
(get *store-registry* name) (get *store-registry* name)
(error (str "Store not found: " name (error (str "Store not found: " name
". Call (def-store ...) before (use-store ...)."))))) ". Call (def-store ...) before (use-store ...).")))))
(define clear-stores (define clear-stores :effects [mutation]
(fn () (fn ()
(set! *store-registry* (dict)))) (set! *store-registry* (dict))))
@@ -361,12 +401,12 @@
;; ;;
;; These are platform primitives because they require browser DOM APIs. ;; These are platform primitives because they require browser DOM APIs.
(define emit-event (define emit-event :effects [io]
(fn (el event-name detail) (fn (el (event-name :as string) detail)
(dom-dispatch el event-name detail))) (dom-dispatch el event-name detail)))
(define on-event (define on-event :effects [io]
(fn (el event-name handler) (fn (el (event-name :as string) (handler :as lambda))
(dom-listen el event-name handler))) (dom-listen el event-name handler)))
;; Convenience: create an effect that listens for a DOM event on an ;; Convenience: create an effect that listens for a DOM event on an
@@ -375,8 +415,8 @@
;; When the effect is disposed (island teardown), the listener is ;; When the effect is disposed (island teardown), the listener is
;; removed automatically via the cleanup return. ;; removed automatically via the cleanup return.
(define bridge-event (define bridge-event :effects [mutation io]
(fn (el event-name target-signal transform-fn) (fn (el (event-name :as string) (target-signal :as signal) transform-fn)
(effect (fn () (effect (fn ()
(let ((remove (dom-listen el event-name (let ((remove (dom-listen el event-name
(fn (e) (fn (e)
@@ -409,8 +449,8 @@
;; Platform interface required: ;; Platform interface required:
;; (promise-then promise on-resolve on-reject) → void ;; (promise-then promise on-resolve on-reject) → void
(define resource (define resource :effects [mutation io]
(fn (fetch-fn) (fn ((fetch-fn :as lambda))
(let ((state (signal (dict "loading" true "data" nil "error" nil)))) (let ((state (signal (dict "loading" true "data" nil "error" nil))))
;; Kick off the async operation ;; Kick off the async operation
(promise-then (invoke fetch-fn) (promise-then (invoke fetch-fn)

View File

@@ -209,6 +209,29 @@
:example "(defmacro unless (condition &rest body) :example "(defmacro unless (condition &rest body)
`(when (not ~condition) ~@body))") `(when (not ~condition) ~@body))")
(define-special-form "deftype"
:syntax (deftype name body)
:doc "Define a named type. The name can be a simple symbol for type aliases
and records, or a list (name param ...) for parameterized types.
Body is a type expression: a symbol (alias), (union t1 t2 ...) for
union types, or {:field1 type1 :field2 type2} for record types.
Type definitions are metadata for the type checker with no runtime cost."
:tail-position "none"
:example "(deftype price number)
(deftype card-props {:title string :price number})
(deftype (maybe a) (union a nil))")
(define-special-form "defeffect"
:syntax (defeffect name)
:doc "Declare a named effect. Effects annotate functions and components
to track side effects. A pure function (:effects [pure]) cannot
call IO functions. Unannotated functions are assumed to have all
effects. Effect checking is gradual — annotations opt in."
:tail-position "none"
:example "(defeffect io)
(defeffect async)
(define add :effects [pure] (fn (a b) (+ a b)))")
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; Sequencing and threading ;; Sequencing and threading

File diff suppressed because it is too large Load Diff

272
shared/sx/ref/test-aser.sx Normal file
View File

@@ -0,0 +1,272 @@
;; ==========================================================================
;; test-aser.sx — Tests for the SX wire format (aser) adapter
;;
;; Requires: test-framework.sx loaded first.
;; Modules tested: adapter-sx.sx (aser, aser-call, aser-fragment, aser-special)
;;
;; Platform functions required (beyond test framework):
;; render-sx (sx-source) -> SX wire format string
;; Parses the sx-source string, evaluates via aser in a
;; fresh env, and returns the resulting SX wire format string.
;; ==========================================================================
;; --------------------------------------------------------------------------
;; Basic serialization
;; --------------------------------------------------------------------------
(defsuite "aser-basics"
(deftest "number literal passes through"
(assert-equal "42"
(render-sx "42")))
(deftest "string literal passes through"
;; aser returns the raw string value; render-sx concatenates it directly
(assert-equal "hello"
(render-sx "\"hello\"")))
(deftest "boolean true passes through"
(assert-equal "true"
(render-sx "true")))
(deftest "boolean false passes through"
(assert-equal "false"
(render-sx "false")))
(deftest "nil produces empty"
(assert-equal ""
(render-sx "nil"))))
;; --------------------------------------------------------------------------
;; HTML tag serialization
;; --------------------------------------------------------------------------
(defsuite "aser-tags"
(deftest "simple div"
(assert-equal "(div \"hello\")"
(render-sx "(div \"hello\")")))
(deftest "nested tags"
(assert-equal "(div (span \"hi\"))"
(render-sx "(div (span \"hi\"))")))
(deftest "multiple children"
(assert-equal "(div (p \"a\") (p \"b\"))"
(render-sx "(div (p \"a\") (p \"b\"))")))
(deftest "attributes serialize"
(assert-equal "(div :class \"foo\" \"bar\")"
(render-sx "(div :class \"foo\" \"bar\")")))
(deftest "multiple attributes"
(assert-equal "(a :href \"/home\" :class \"link\" \"Home\")"
(render-sx "(a :href \"/home\" :class \"link\" \"Home\")")))
(deftest "void elements"
(assert-equal "(br)"
(render-sx "(br)")))
(deftest "void element with attrs"
(assert-equal "(img :src \"pic.jpg\")"
(render-sx "(img :src \"pic.jpg\")"))))
;; --------------------------------------------------------------------------
;; Fragment serialization
;; --------------------------------------------------------------------------
(defsuite "aser-fragments"
(deftest "simple fragment"
(assert-equal "(<> (p \"a\") (p \"b\"))"
(render-sx "(<> (p \"a\") (p \"b\"))")))
(deftest "empty fragment"
(assert-equal ""
(render-sx "(<>)")))
(deftest "single-child fragment"
(assert-equal "(<> (div \"x\"))"
(render-sx "(<> (div \"x\"))"))))
;; --------------------------------------------------------------------------
;; Control flow in aser mode
;; --------------------------------------------------------------------------
(defsuite "aser-control-flow"
(deftest "if true branch"
(assert-equal "(p \"yes\")"
(render-sx "(if true (p \"yes\") (p \"no\"))")))
(deftest "if false branch"
(assert-equal "(p \"no\")"
(render-sx "(if false (p \"yes\") (p \"no\"))")))
(deftest "when true"
(assert-equal "(p \"ok\")"
(render-sx "(when true (p \"ok\"))")))
(deftest "when false"
(assert-equal ""
(render-sx "(when false (p \"ok\"))")))
(deftest "cond serializes matching branch"
(assert-equal "(p \"two\")"
(render-sx "(cond false (p \"one\") true (p \"two\") :else (p \"three\"))")))
(deftest "cond with 2-element predicate test"
;; Regression: cond misclassifies (nil? x) as scheme-style clause.
(assert-equal "(p \"yes\")"
(render-sx "(cond (nil? nil) (p \"yes\") :else (p \"no\"))"))
(assert-equal "(p \"no\")"
(render-sx "(cond (nil? \"x\") (p \"yes\") :else (p \"no\"))")))
(deftest "let binds then serializes"
(assert-equal "(p \"hello\")"
(render-sx "(let ((x \"hello\")) (p x))")))
(deftest "let preserves outer scope bindings"
;; Regression: process-bindings must preserve parent env scope chain.
;; Using merge() instead of env-extend loses parent scope items.
(assert-equal "(p \"outer\")"
(render-sx "(do (define theme \"outer\") (let ((x 1)) (p theme)))")))
(deftest "nested let preserves outer scope"
(assert-equal "(div (span \"hello\") (span \"world\"))"
(render-sx "(do (define a \"hello\")
(define b \"world\")
(div (let ((x 1)) (span a))
(let ((y 2)) (span b))))")))
(deftest "begin serializes last"
(assert-equal "(p \"last\")"
(render-sx "(begin (p \"first\") (p \"last\"))"))))
;; --------------------------------------------------------------------------
;; THE BUG — map/filter list flattening in children (critical regression)
;; --------------------------------------------------------------------------
(defsuite "aser-list-flattening"
(deftest "map inside tag flattens children"
(assert-equal "(div (span \"a\") (span \"b\") (span \"c\"))"
(render-sx "(do (define items (list \"a\" \"b\" \"c\"))
(div (map (fn (x) (span x)) items)))")))
(deftest "map inside tag with other children"
(assert-equal "(ul (li \"first\") (li \"a\") (li \"b\"))"
(render-sx "(do (define items (list \"a\" \"b\"))
(ul (li \"first\") (map (fn (x) (li x)) items)))")))
(deftest "filter result via let binding as children"
;; Note: (filter ...) is treated as an SVG tag in aser dispatch (SVG has <filter>),
;; so we evaluate filter via let binding + map to serialize children
(assert-equal "(ul (li \"a\") (li \"b\"))"
(render-sx "(do (define items (list \"a\" nil \"b\"))
(define kept (filter (fn (x) (not (nil? x))) items))
(ul (map (fn (x) (li x)) kept)))")))
(deftest "map inside fragment flattens"
(assert-equal "(<> (p \"a\") (p \"b\"))"
(render-sx "(do (define items (list \"a\" \"b\"))
(<> (map (fn (x) (p x)) items)))")))
(deftest "nested map does not double-wrap"
(assert-equal "(div (span \"1\") (span \"2\"))"
(render-sx "(do (define nums (list 1 2))
(div (map (fn (n) (span (str n))) nums)))")))
(deftest "map with component-like output flattens"
(assert-equal "(div (li \"x\") (li \"y\"))"
(render-sx "(do (define items (list \"x\" \"y\"))
(div (map (fn (x) (li x)) items)))"))))
;; --------------------------------------------------------------------------
;; Component serialization (NOT expanded in basic aser mode)
;; --------------------------------------------------------------------------
(defsuite "aser-components"
(deftest "unknown component serializes as-is"
(assert-equal "(~foo :title \"bar\")"
(render-sx "(~foo :title \"bar\")")))
(deftest "defcomp then unexpanded component call"
(assert-equal "(~card :title \"Hi\")"
(render-sx "(do (defcomp ~card (&key title) (h1 title)) (~card :title \"Hi\"))")))
(deftest "component with children serializes unexpanded"
(assert-equal "(~box (p \"inside\"))"
(render-sx "(do (defcomp ~box (&key &rest children) (div children))
(~box (p \"inside\")))"))))
;; --------------------------------------------------------------------------
;; Definition forms in aser mode
;; --------------------------------------------------------------------------
(defsuite "aser-definitions"
(deftest "define evaluates for side effects, returns nil"
(assert-equal "(p 42)"
(render-sx "(do (define x 42) (p x))")))
(deftest "defcomp evaluates and returns nil"
(assert-equal "(~tag :x 1)"
(render-sx "(do (defcomp ~tag (&key x) (span x)) (~tag :x 1))")))
(deftest "defisland evaluates AND serializes"
(let ((result (render-sx "(defisland ~counter (&key count) (span count))")))
(assert-true (string-contains? result "defisland")))))
;; --------------------------------------------------------------------------
;; Function calls in aser mode
;; --------------------------------------------------------------------------
(defsuite "aser-function-calls"
(deftest "named function call evaluates fully"
(assert-equal "3"
(render-sx "(do (define inc1 (fn (x) (+ x 1))) (inc1 2))")))
(deftest "define + call"
(assert-equal "10"
(render-sx "(do (define double (fn (x) (* x 2))) (double 5))")))
(deftest "native callable with multiple args"
;; Regression: async-aser-eval-call passed evaled-args list to
;; async-invoke (&rest), wrapping it in another list. apply(f, [list])
;; calls f(list) instead of f(*list).
(assert-equal "3"
(render-sx "(do (define my-add +) (my-add 1 2))")))
(deftest "native callable with two args via alias"
(assert-equal "hello world"
(render-sx "(do (define my-join str) (my-join \"hello\" \" world\"))")))
(deftest "higher-order: map returns list"
(let ((result (render-sx "(map (fn (x) (+ x 1)) (list 1 2 3))")))
;; map at top level returns a list, not serialized tags
(assert-true (not (nil? result))))))
;; --------------------------------------------------------------------------
;; and/or short-circuit in aser mode
;; --------------------------------------------------------------------------
(defsuite "aser-logic"
(deftest "and short-circuits on false"
(assert-equal "false"
(render-sx "(and true false true)")))
(deftest "and returns last truthy"
(assert-equal "3"
(render-sx "(and 1 2 3)")))
(deftest "or short-circuits on true"
(assert-equal "1"
(render-sx "(or 1 2 3)")))
(deftest "or returns last falsy"
(assert-equal "false"
(render-sx "(or false false)"))))

View File

@@ -277,6 +277,29 @@
false "b" false "b"
:else "c"))) :else "c")))
(deftest "cond with 2-element predicate as first test"
;; Regression: cond misclassifies Clojure-style as scheme-style when
;; the first test is a 2-element list like (nil? x) or (empty? x).
;; The evaluator checks: is first arg a 2-element list? If yes, treats
;; as scheme-style ((test body) ...) — returning the arg instead of
;; evaluating the predicate call.
(assert-equal 0 (cond (nil? nil) 0 :else 1))
(assert-equal 1 (cond (nil? "x") 0 :else 1))
(assert-equal "empty" (cond (empty? (list)) "empty" :else "not-empty"))
(assert-equal "not-empty" (cond (empty? (list 1)) "empty" :else "not-empty"))
(assert-equal "yes" (cond (not false) "yes" :else "no"))
(assert-equal "no" (cond (not true) "yes" :else "no")))
(deftest "cond with 2-element predicate and no :else"
;; Same bug, but without :else — this is the worst case because the
;; bootstrapper heuristic also breaks (all clauses are 2-element lists).
(assert-equal "found"
(cond (nil? nil) "found"
(nil? "x") "other"))
(assert-equal "b"
(cond (nil? "x") "a"
(not false) "b")))
(deftest "and" (deftest "and"
(assert-true (and true true)) (assert-true (and true true))
(assert-false (and true false)) (assert-false (and true false))
@@ -545,9 +568,12 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; defpage ;; Server-only tests — skip in browser (defpage, streaming functions)
;; These require forms.sx which is only loaded server-side.
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(when (get (try-call (fn () stream-chunk-id)) "ok")
(defsuite "defpage" (defsuite "defpage"
(deftest "basic defpage returns page-def" (deftest "basic defpage returns page-def"
(let ((p (defpage test-basic :path "/test" :auth :public :content (div "hello")))) (let ((p (defpage test-basic :path "/test" :auth :public :content (div "hello"))))
@@ -716,3 +742,5 @@
:content (~chunk :val val)))) :content (~chunk :val val))))
(assert-equal true (get p "stream")) (assert-equal true (get p "stream"))
(assert-true (not (nil? (get p "shell"))))))) (assert-true (not (nil? (get p "shell")))))))
) ;; end (when has-server-forms?)

View File

@@ -57,7 +57,7 @@
(assert (nil? val) (str "Expected nil but got " (str val))))) (assert (nil? val) (str "Expected nil but got " (str val)))))
(define assert-type (define assert-type
(fn (expected-type val) (fn ((expected-type :as string) val)
(let ((actual-type (let ((actual-type
(if (nil? val) "nil" (if (nil? val) "nil"
(if (boolean? val) "boolean" (if (boolean? val) "boolean"
@@ -70,17 +70,17 @@
(str "Expected type " expected-type " but got " actual-type))))) (str "Expected type " expected-type " but got " actual-type)))))
(define assert-length (define assert-length
(fn (expected-len col) (fn ((expected-len :as number) (col :as list))
(assert (= (len col) expected-len) (assert (= (len col) expected-len)
(str "Expected length " expected-len " but got " (len col))))) (str "Expected length " expected-len " but got " (len col)))))
(define assert-contains (define assert-contains
(fn (item col) (fn (item (col :as list))
(assert (some (fn (x) (equal? x item)) col) (assert (some (fn (x) (equal? x item)) col)
(str "Expected collection to contain " (str item))))) (str "Expected collection to contain " (str item)))))
(define assert-throws (define assert-throws
(fn (thunk) (fn ((thunk :as lambda))
(let ((result (try-call thunk))) (let ((result (try-call thunk)))
(assert (not (get result "ok")) (assert (not (get result "ok"))
"Expected an error to be thrown but none was")))) "Expected an error to be thrown but none was"))))

View File

@@ -149,7 +149,27 @@
(deftest "let in render context" (deftest "let in render context"
(assert-equal "<p>hello</p>" (assert-equal "<p>hello</p>"
(render-html "(let ((x \"hello\")) (p x))")))) (render-html "(let ((x \"hello\")) (p x))")))
(deftest "cond with 2-element predicate test"
;; Regression: cond misclassifies (nil? x) as scheme-style clause.
(assert-equal "<p>yes</p>"
(render-html "(cond (nil? nil) (p \"yes\") :else (p \"no\"))"))
(assert-equal "<p>no</p>"
(render-html "(cond (nil? \"x\") (p \"yes\") :else (p \"no\"))")))
(deftest "let preserves outer scope bindings"
;; Regression: process-bindings must preserve parent env scope chain.
;; Using merge() on Env objects returns empty dict (Env is not dict subclass).
(assert-equal "<p>outer</p>"
(render-html "(do (define theme \"outer\") (let ((x 1)) (p theme)))")))
(deftest "nested let preserves outer scope"
(assert-equal "<div><span>hello</span><span>world</span></div>"
(render-html "(do (define a \"hello\")
(define b \"world\")
(div (let ((x 1)) (span a))
(let ((y 2)) (span b))))"))))
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
@@ -165,3 +185,46 @@
(let ((html (render-html "(do (defcomp ~box (&key &rest children) (div :class \"box\" children)) (~box (p \"inside\")))"))) (let ((html (render-html "(do (defcomp ~box (&key &rest children) (div :class \"box\" children)) (~box (p \"inside\")))")))
(assert-true (string-contains? html "class=\"box\"")) (assert-true (string-contains? html "class=\"box\""))
(assert-true (string-contains? html "<p>inside</p>"))))) (assert-true (string-contains? html "<p>inside</p>")))))
;; --------------------------------------------------------------------------
;; Map/filter producing multiple children (aser-adjacent regression tests)
;; --------------------------------------------------------------------------
(defsuite "render-map-children"
(deftest "map producing multiple children inside tag"
(assert-equal "<ul><li>a</li><li>b</li><li>c</li></ul>"
(render-html "(do (define items (list \"a\" \"b\" \"c\"))
(ul (map (fn (x) (li x)) items)))")))
(deftest "map with other siblings"
(assert-equal "<ul><li>first</li><li>a</li><li>b</li></ul>"
(render-html "(do (define items (list \"a\" \"b\"))
(ul (li \"first\") (map (fn (x) (li x)) items)))")))
(deftest "filter with nil results inside tag"
(assert-equal "<ul><li>a</li><li>c</li></ul>"
(render-html "(do (define items (list \"a\" nil \"c\"))
(ul (map (fn (x) (li x))
(filter (fn (x) (not (nil? x))) items))))")))
(deftest "nested map inside let"
(assert-equal "<div><span>1</span><span>2</span></div>"
(render-html "(let ((nums (list 1 2)))
(div (map (fn (n) (span n)) nums)))")))
(deftest "component with &rest receiving mapped results"
(let ((html (render-html "(do (defcomp ~list-box (&key &rest children) (div :class \"lb\" children))
(define items (list \"x\" \"y\"))
(~list-box (map (fn (x) (p x)) items)))")))
(assert-true (string-contains? html "class=\"lb\""))
(assert-true (string-contains? html "<p>x</p>"))
(assert-true (string-contains? html "<p>y</p>"))))
(deftest "map-indexed renders with index"
(assert-equal "<li>0: a</li><li>1: b</li>"
(render-html "(map-indexed (fn (i x) (li (str i \": \" x))) (list \"a\" \"b\"))")))
(deftest "for-each renders each item"
(assert-equal "<p>1</p><p>2</p>"
(render-html "(for-each (fn (x) (p x)) (list 1 2))"))))

599
shared/sx/ref/test-types.sx Normal file
View File

@@ -0,0 +1,599 @@
;; ==========================================================================
;; test-types.sx — Tests for the SX gradual type system
;;
;; Requires: test-framework.sx loaded first.
;; Modules tested: types.sx (subtype?, infer-type, check-component, etc.)
;;
;; Platform functions required (beyond test framework):
;; All type system functions from types.sx must be loaded.
;; test-prim-types — a dict of primitive return types for testing.
;; ==========================================================================
;; --------------------------------------------------------------------------
;; Subtype checking
;; --------------------------------------------------------------------------
(defsuite "subtype-basics"
(deftest "any accepts everything"
(assert-true (subtype? "number" "any"))
(assert-true (subtype? "string" "any"))
(assert-true (subtype? "nil" "any"))
(assert-true (subtype? "boolean" "any"))
(assert-true (subtype? "any" "any")))
(deftest "never is subtype of everything"
(assert-true (subtype? "never" "number"))
(assert-true (subtype? "never" "string"))
(assert-true (subtype? "never" "any"))
(assert-true (subtype? "never" "nil")))
(deftest "identical types"
(assert-true (subtype? "number" "number"))
(assert-true (subtype? "string" "string"))
(assert-true (subtype? "boolean" "boolean"))
(assert-true (subtype? "nil" "nil")))
(deftest "different base types are not subtypes"
(assert-false (subtype? "number" "string"))
(assert-false (subtype? "string" "number"))
(assert-false (subtype? "boolean" "number"))
(assert-false (subtype? "string" "boolean")))
(deftest "any is not subtype of specific type"
(assert-false (subtype? "any" "number"))
(assert-false (subtype? "any" "string"))))
(defsuite "subtype-nullable"
(deftest "nil is subtype of nullable types"
(assert-true (subtype? "nil" "string?"))
(assert-true (subtype? "nil" "number?"))
(assert-true (subtype? "nil" "dict?"))
(assert-true (subtype? "nil" "boolean?")))
(deftest "base is subtype of its nullable"
(assert-true (subtype? "string" "string?"))
(assert-true (subtype? "number" "number?"))
(assert-true (subtype? "dict" "dict?")))
(deftest "nullable is not subtype of base"
(assert-false (subtype? "string?" "string"))
(assert-false (subtype? "number?" "number")))
(deftest "different nullable types are not subtypes"
(assert-false (subtype? "number" "string?"))
(assert-false (subtype? "string" "number?"))))
(defsuite "subtype-unions"
(deftest "member is subtype of union"
(assert-true (subtype? "number" (list "or" "number" "string")))
(assert-true (subtype? "string" (list "or" "number" "string"))))
(deftest "non-member is not subtype of union"
(assert-false (subtype? "boolean" (list "or" "number" "string"))))
(deftest "union is subtype if all members are"
(assert-true (subtype? (list "or" "number" "string")
(list "or" "number" "string" "boolean")))
(assert-true (subtype? (list "or" "number" "string") "any")))
(deftest "union is not subtype if any member is not"
(assert-false (subtype? (list "or" "number" "string") "number"))))
(defsuite "subtype-list-of"
(deftest "list-of covariance"
(assert-true (subtype? (list "list-of" "number") (list "list-of" "number")))
(assert-true (subtype? (list "list-of" "number") (list "list-of" "any"))))
(deftest "list-of is subtype of list"
(assert-true (subtype? (list "list-of" "number") "list")))
(deftest "list is subtype of list-of any"
(assert-true (subtype? "list" (list "list-of" "any")))))
;; --------------------------------------------------------------------------
;; Type union
;; --------------------------------------------------------------------------
(defsuite "type-union"
(deftest "same types"
(assert-equal "number" (type-union "number" "number"))
(assert-equal "string" (type-union "string" "string")))
(deftest "any absorbs"
(assert-equal "any" (type-union "any" "number"))
(assert-equal "any" (type-union "number" "any")))
(deftest "never is identity"
(assert-equal "number" (type-union "never" "number"))
(assert-equal "string" (type-union "string" "never")))
(deftest "nil + base creates nullable"
(assert-equal "string?" (type-union "nil" "string"))
(assert-equal "number?" (type-union "number" "nil")))
(deftest "subtype collapses"
(assert-equal "string?" (type-union "string" "string?"))
(assert-equal "string?" (type-union "string?" "string")))
(deftest "incompatible creates union"
(let ((result (type-union "number" "string")))
(assert-true (= (type-of result) "list"))
(assert-equal "or" (first result))
(assert-true (contains? result "number"))
(assert-true (contains? result "string")))))
;; --------------------------------------------------------------------------
;; Type narrowing
;; --------------------------------------------------------------------------
(defsuite "type-narrowing"
(deftest "nil? narrows to nil in then branch"
(let ((result (narrow-type "string?" "nil?")))
(assert-equal "nil" (first result))
(assert-equal "string" (nth result 1))))
(deftest "nil? narrows any stays any"
(let ((result (narrow-type "any" "nil?")))
(assert-equal "nil" (first result))
(assert-equal "any" (nth result 1))))
(deftest "string? narrows to string in then branch"
(let ((result (narrow-type "any" "string?")))
(assert-equal "string" (first result))
;; else branch — can't narrow any
(assert-equal "any" (nth result 1))))
(deftest "nil? on nil type narrows to never in else"
(let ((result (narrow-type "nil" "nil?")))
(assert-equal "nil" (first result))
(assert-equal "never" (nth result 1)))))
;; --------------------------------------------------------------------------
;; Type inference
;; --------------------------------------------------------------------------
(defsuite "infer-literals"
(deftest "number literal"
(assert-equal "number" (infer-type 42 (dict) (test-prim-types))))
(deftest "string literal"
(assert-equal "string" (infer-type "hello" (dict) (test-prim-types))))
(deftest "boolean literal"
(assert-equal "boolean" (infer-type true (dict) (test-prim-types))))
(deftest "nil"
(assert-equal "nil" (infer-type nil (dict) (test-prim-types)))))
(defsuite "infer-calls"
(deftest "known primitive return type"
;; (+ 1 2) → number
(let ((expr (sx-parse "(+ 1 2)")))
(assert-equal "number"
(infer-type (first expr) (dict) (test-prim-types)))))
(deftest "str returns string"
(let ((expr (sx-parse "(str 1 2)")))
(assert-equal "string"
(infer-type (first expr) (dict) (test-prim-types)))))
(deftest "comparison returns boolean"
(let ((expr (sx-parse "(= 1 2)")))
(assert-equal "boolean"
(infer-type (first expr) (dict) (test-prim-types)))))
(deftest "component call returns element"
(let ((expr (sx-parse "(~card :title \"hi\")")))
(assert-equal "element"
(infer-type (first expr) (dict) (test-prim-types)))))
(deftest "unknown function returns any"
(let ((expr (sx-parse "(unknown-fn 1 2)")))
(assert-equal "any"
(infer-type (first expr) (dict) (test-prim-types))))))
(defsuite "infer-special-forms"
(deftest "if produces union of branches"
(let ((expr (sx-parse "(if true 42 \"hello\")")))
(let ((t (infer-type (first expr) (dict) (test-prim-types))))
;; number | string — should be a union
(assert-true (or (= t (list "or" "number" "string"))
(= t "any"))))))
(deftest "if with no else includes nil"
(let ((expr (sx-parse "(if true 42)")))
(let ((t (infer-type (first expr) (dict) (test-prim-types))))
(assert-equal "number?" t))))
(deftest "when includes nil"
(let ((expr (sx-parse "(when true 42)")))
(let ((t (infer-type (first expr) (dict) (test-prim-types))))
(assert-equal "number?" t))))
(deftest "do returns last type"
(let ((expr (sx-parse "(do 1 2 \"hello\")")))
(assert-equal "string"
(infer-type (first expr) (dict) (test-prim-types)))))
(deftest "let infers binding types"
(let ((expr (sx-parse "(let ((x 42)) x)")))
(assert-equal "number"
(infer-type (first expr) (dict) (test-prim-types)))))
(deftest "lambda returns lambda"
(let ((expr (sx-parse "(fn (x) (+ x 1))")))
(assert-equal "lambda"
(infer-type (first expr) (dict) (test-prim-types))))))
;; --------------------------------------------------------------------------
;; Component call checking
;; --------------------------------------------------------------------------
(defsuite "check-component-calls"
(deftest "type mismatch produces error"
;; Create a component with typed params, then check a bad call
(let ((env (test-env)))
;; Define a typed component
(do
(define dummy-env env)
(defcomp ~typed-card (&key title price) (div title price))
(component-set-param-types! ~typed-card
{:title "string" :price "number"}))
;; Check a call with wrong type
(let ((diagnostics
(check-component-call "~typed-card" ~typed-card
(rest (first (sx-parse "(~typed-card :title 42 :price \"bad\")")))
(dict) (test-prim-types))))
(assert-true (> (len diagnostics) 0))
(assert-equal "error" (dict-get (first diagnostics) "level")))))
(deftest "correct call produces no errors"
(let ((env (test-env)))
(do
(define dummy-env env)
(defcomp ~ok-card (&key title price) (div title price))
(component-set-param-types! ~ok-card
{:title "string" :price "number"}))
(let ((diagnostics
(check-component-call "~ok-card" ~ok-card
(rest (first (sx-parse "(~ok-card :title \"hi\" :price 42)")))
(dict) (test-prim-types))))
(assert-equal 0 (len diagnostics)))))
(deftest "unknown kwarg produces warning"
(let ((env (test-env)))
(do
(define dummy-env env)
(defcomp ~warn-card (&key title) (div title))
(component-set-param-types! ~warn-card
{:title "string"}))
(let ((diagnostics
(check-component-call "~warn-card" ~warn-card
(rest (first (sx-parse "(~warn-card :title \"hi\" :colour \"red\")")))
(dict) (test-prim-types))))
(assert-true (> (len diagnostics) 0))
(assert-equal "warning" (dict-get (first diagnostics) "level"))))))
;; --------------------------------------------------------------------------
;; Annotation syntax: (name :as type) in defcomp params
;; --------------------------------------------------------------------------
(defsuite "typed-defcomp"
(deftest "typed params are parsed and stored"
(let ((env (test-env)))
(defcomp ~typed-widget (&key (title :as string) (count :as number)) (div title count))
(let ((pt (component-param-types ~typed-widget)))
(assert-true (not (nil? pt)))
(assert-equal "string" (dict-get pt "title"))
(assert-equal "number" (dict-get pt "count")))))
(deftest "mixed typed and untyped params"
(let ((env (test-env)))
(defcomp ~mixed-widget (&key (title :as string) subtitle) (div title subtitle))
(let ((pt (component-param-types ~mixed-widget)))
(assert-true (not (nil? pt)))
(assert-equal "string" (dict-get pt "title"))
;; subtitle has no annotation — should not be in param-types
(assert-false (has-key? pt "subtitle")))))
(deftest "untyped defcomp has nil param-types"
(let ((env (test-env)))
(defcomp ~plain-widget (&key title subtitle) (div title subtitle))
(assert-true (nil? (component-param-types ~plain-widget)))))
(deftest "typed component catches type error on call"
(let ((env (test-env)))
(defcomp ~strict-card (&key (title :as string) (price :as number)) (div title price))
;; Call with wrong types
(let ((diagnostics
(check-component-call "~strict-card" ~strict-card
(rest (first (sx-parse "(~strict-card :title 42 :price \"bad\")")))
(dict) (test-prim-types))))
;; Should have errors for both wrong-type args
(assert-true (>= (len diagnostics) 1))
(assert-equal "error" (dict-get (first diagnostics) "level")))))
(deftest "typed component passes correct call"
(let ((env (test-env)))
(defcomp ~ok-widget (&key (name :as string) (age :as number)) (div name age))
(let ((diagnostics
(check-component-call "~ok-widget" ~ok-widget
(rest (first (sx-parse "(~ok-widget :name \"Alice\" :age 30)")))
(dict) (test-prim-types))))
(assert-equal 0 (len diagnostics)))))
(deftest "nullable type accepts nil"
(let ((env (test-env)))
(defcomp ~nullable-widget (&key (title :as string) (subtitle :as string?)) (div title subtitle))
;; Passing nil for nullable param should be fine
(let ((diagnostics
(check-component-call "~nullable-widget" ~nullable-widget
(rest (first (sx-parse "(~nullable-widget :title \"hi\" :subtitle nil)")))
(dict) (test-prim-types))))
(assert-equal 0 (len diagnostics))))))
;; --------------------------------------------------------------------------
;; Primitive call checking (Phase 5)
;; --------------------------------------------------------------------------
(defsuite "check-primitive-calls"
(deftest "correct types produce no errors"
(let ((ppt (test-prim-param-types)))
(let ((diagnostics
(check-primitive-call "+" (rest (first (sx-parse "(+ 1 2 3)")))
(dict) (test-prim-types) ppt nil)))
(assert-equal 0 (len diagnostics)))))
(deftest "string arg to numeric primitive produces error"
(let ((ppt (test-prim-param-types)))
(let ((diagnostics
(check-primitive-call "+" (rest (first (sx-parse "(+ 1 \"hello\")")))
(dict) (test-prim-types) ppt nil)))
(assert-true (> (len diagnostics) 0))
(assert-equal "error" (get (first diagnostics) "level")))))
(deftest "number arg to string primitive produces error"
(let ((ppt (test-prim-param-types)))
(let ((diagnostics
(check-primitive-call "upper" (rest (first (sx-parse "(upper 42)")))
(dict) (test-prim-types) ppt nil)))
(assert-true (> (len diagnostics) 0))
(assert-equal "error" (get (first diagnostics) "level")))))
(deftest "positional and rest params both checked"
;; (- "bad" 1) — first positional arg is string, expects number
(let ((ppt (test-prim-param-types)))
(let ((diagnostics
(check-primitive-call "-" (rest (first (sx-parse "(- \"bad\" 1)")))
(dict) (test-prim-types) ppt nil)))
(assert-true (> (len diagnostics) 0)))))
(deftest "dict arg to keys is valid"
(let ((ppt (test-prim-param-types)))
(let ((diagnostics
(check-primitive-call "keys" (rest (first (sx-parse "(keys {:a 1})")))
(dict) (test-prim-types) ppt nil)))
(assert-equal 0 (len diagnostics)))))
(deftest "number arg to keys produces error"
(let ((ppt (test-prim-param-types)))
(let ((diagnostics
(check-primitive-call "keys" (rest (first (sx-parse "(keys 42)")))
(dict) (test-prim-types) ppt nil)))
(assert-true (> (len diagnostics) 0)))))
(deftest "variable with known type passes check"
;; Variable n is known to be number in type-env
(let ((ppt (test-prim-param-types))
(tenv {"n" "number"}))
(let ((diagnostics
(check-primitive-call "inc" (rest (first (sx-parse "(inc n)")))
tenv (test-prim-types) ppt nil)))
(assert-equal 0 (len diagnostics)))))
(deftest "variable with wrong type fails check"
;; Variable s is known to be string in type-env
(let ((ppt (test-prim-param-types))
(tenv {"s" "string"}))
(let ((diagnostics
(check-primitive-call "inc" (rest (first (sx-parse "(inc s)")))
tenv (test-prim-types) ppt nil)))
(assert-true (> (len diagnostics) 0)))))
(deftest "any-typed variable skips check"
;; Variable x has type any — should not produce errors
(let ((ppt (test-prim-param-types))
(tenv {"x" "any"}))
(let ((diagnostics
(check-primitive-call "upper" (rest (first (sx-parse "(upper x)")))
tenv (test-prim-types) ppt nil)))
(assert-equal 0 (len diagnostics)))))
(deftest "body-walk catches primitive errors in component"
;; Manually build a component and check it via check-body-walk directly
(let ((ppt (test-prim-param-types))
(body (first (sx-parse "(div (+ name 1))")))
(type-env {"name" "string"})
(diagnostics (list)))
(check-body-walk body "~bad-math" type-env (test-prim-types) ppt (test-env) diagnostics nil nil)
(assert-true (> (len diagnostics) 0))
(assert-equal "error" (get (first diagnostics) "level")))))
;; --------------------------------------------------------------------------
;; deftype — type aliases
;; --------------------------------------------------------------------------
(defsuite "deftype-alias"
(deftest "simple alias resolves"
(let ((registry {"price" {:name "price" :params () :body "number"}}))
(assert-equal "number" (resolve-type "price" registry))))
(deftest "alias chain resolves"
(let ((registry {"price" {:name "price" :params () :body "number"}
"cost" {:name "cost" :params () :body "price"}}))
(assert-equal "number" (resolve-type "cost" registry))))
(deftest "unknown type passes through"
(let ((registry {"price" {:name "price" :params () :body "number"}}))
(assert-equal "string" (resolve-type "string" registry))))
(deftest "subtype-resolved? works through alias"
(let ((registry {"price" {:name "price" :params () :body "number"}}))
(assert-true (subtype-resolved? "price" "number" registry))
(assert-true (subtype-resolved? "number" "price" registry)))))
;; --------------------------------------------------------------------------
;; deftype — union types
;; --------------------------------------------------------------------------
(defsuite "deftype-union"
(deftest "union resolves"
(let ((registry {"status" {:name "status" :params () :body ("or" "string" "number")}}))
(let ((resolved (resolve-type "status" registry)))
(assert-true (= (type-of resolved) "list"))
(assert-equal "or" (first resolved)))))
(deftest "subtype through named union"
(let ((registry {"status" {:name "status" :params () :body ("or" "string" "number")}}))
(assert-true (subtype-resolved? "string" "status" registry))
(assert-true (subtype-resolved? "number" "status" registry))
(assert-false (subtype-resolved? "boolean" "status" registry)))))
;; --------------------------------------------------------------------------
;; deftype — record types
;; --------------------------------------------------------------------------
(defsuite "deftype-record"
(deftest "record resolves to dict"
(let ((registry {"card-props" {:name "card-props" :params ()
:body {"title" "string" "price" "number"}}}))
(let ((resolved (resolve-type "card-props" registry)))
(assert-equal "dict" (type-of resolved))
(assert-equal "string" (get resolved "title"))
(assert-equal "number" (get resolved "price")))))
(deftest "record structural subtyping"
(let ((registry {"card-props" {:name "card-props" :params ()
:body {"title" "string" "price" "number"}}
"titled" {:name "titled" :params ()
:body {"title" "string"}}}))
;; card-props has title+price, titled has just title
;; card-props <: titled (has all required fields)
(assert-true (subtype-resolved? "card-props" "titled" registry))))
(deftest "get infers field type from record"
(let ((registry {"card-props" {:name "card-props" :params ()
:body {"title" "string" "price" "number"}}})
(type-env {"d" "card-props"})
(expr (first (sx-parse "(get d :title)"))))
(assert-equal "string"
(infer-type expr type-env (test-prim-types) registry)))))
;; --------------------------------------------------------------------------
;; deftype — parameterized types
;; --------------------------------------------------------------------------
(defsuite "deftype-parameterized"
(deftest "maybe instantiation"
(let ((registry {"maybe" {:name "maybe" :params ("a")
:body ("or" "a" "nil")}}))
(let ((resolved (resolve-type (list "maybe" "string") registry)))
(assert-true (= (type-of resolved) "list"))
(assert-equal "or" (first resolved))
(assert-true (contains? resolved "string"))
(assert-true (contains? resolved "nil")))))
(deftest "subtype through parameterized type"
(let ((registry {"maybe" {:name "maybe" :params ("a")
:body ("or" "a" "nil")}}))
(assert-true (subtype-resolved? "string" (list "maybe" "string") registry))
(assert-true (subtype-resolved? "nil" (list "maybe" "string") registry))
(assert-false (subtype-resolved? "number" (list "maybe" "string") registry))))
(deftest "substitute-type-vars works"
(let ((result (substitute-type-vars ("or" "a" "nil") (list "a") (list "number"))))
(assert-equal "or" (first result))
(assert-true (contains? result "number"))
(assert-true (contains? result "nil")))))
;; --------------------------------------------------------------------------
;; defeffect — effect basics
;; --------------------------------------------------------------------------
(defsuite "defeffect-basics"
(deftest "get-effects returns nil for unannotated"
(let ((anns {"fetch" ("io")}))
(assert-true (nil? (get-effects "unknown" anns)))))
(deftest "get-effects returns effects for annotated"
(let ((anns {"fetch" ("io")}))
(assert-equal (list "io") (get-effects "fetch" anns))))
(deftest "nil annotations returns nil"
(assert-true (nil? (get-effects "anything" nil)))))
;; --------------------------------------------------------------------------
;; defeffect — effect checking
;; --------------------------------------------------------------------------
(defsuite "effect-checking"
(deftest "pure cannot call io"
(let ((anns {"~pure-comp" () "fetch" ("io")}))
(let ((diagnostics (check-effect-call "fetch" (list) anns "~pure-comp")))
(assert-true (> (len diagnostics) 0))
(assert-equal "error" (get (first diagnostics) "level")))))
(deftest "io context allows io"
(let ((anns {"~io-comp" ("io") "fetch" ("io")}))
(let ((diagnostics (check-effect-call "fetch" (list "io") anns "~io-comp")))
(assert-equal 0 (len diagnostics)))))
(deftest "unannotated caller allows everything"
(let ((anns {"fetch" ("io")}))
(let ((diagnostics (check-effect-call "fetch" nil anns "~unknown")))
(assert-equal 0 (len diagnostics)))))
(deftest "unannotated callee skips check"
(let ((anns {"~pure-comp" ()}))
(let ((diagnostics (check-effect-call "unknown-fn" (list) anns "~pure-comp")))
(assert-equal 0 (len diagnostics))))))
;; --------------------------------------------------------------------------
;; defeffect — subset checking
;; --------------------------------------------------------------------------
(defsuite "effect-subset"
(deftest "empty is subset of anything"
(assert-true (effects-subset? (list) (list "io")))
(assert-true (effects-subset? (list) (list))))
(deftest "io is subset of io"
(assert-true (effects-subset? (list "io") (list "io" "async"))))
(deftest "io is not subset of pure"
(assert-false (effects-subset? (list "io") (list))))
(deftest "nil callee skips check"
(assert-true (effects-subset? nil (list))))
(deftest "nil caller allows all"
(assert-true (effects-subset? (list "io") nil))))

883
shared/sx/ref/types.sx Normal file
View File

@@ -0,0 +1,883 @@
;; ==========================================================================
;; types.sx — Gradual type system for SX
;;
;; Registration-time type checking: zero runtime cost.
;; Annotations are optional — unannotated code defaults to `any`.
;;
;; Depends on: eval.sx (type-of, component accessors, env ops)
;; primitives.sx, boundary.sx (return type declarations)
;;
;; Platform interface (from eval.sx, already provided):
;; (type-of x) → type string
;; (symbol-name s) → string
;; (keyword-name k) → string
;; (component-body c) → AST
;; (component-params c) → list of param name strings
;; (component-has-children c) → boolean
;; (env-get env k) → value or nil
;;
;; New platform functions for types.sx:
;; (component-param-types c) → dict {param-name → type} or nil
;; (component-set-param-types! c d) → store param types on component
;; ==========================================================================
;; --------------------------------------------------------------------------
;; 1. Type representation
;; --------------------------------------------------------------------------
;; Types are plain SX values:
;; - Strings for base types: "number", "string", "boolean", "nil",
;; "symbol", "keyword", "element", "any", "never"
;; - Nullable shorthand: "string?", "number?", "dict?", "boolean?"
;; → equivalent to (or string nil) etc.
;; - Lists for compound types:
;; (or t1 t2 ...) — union
;; (list-of t) — homogeneous list
;; (dict-of tk tv) — typed dict
;; (-> t1 t2 ... treturn) — function type (last is return)
;; Base type names
(define base-types
(list "number" "string" "boolean" "nil" "symbol" "keyword"
"element" "any" "never" "list" "dict"
"lambda" "component" "island" "macro" "signal"))
;; --------------------------------------------------------------------------
;; 2. Type predicates
;; --------------------------------------------------------------------------
(define type-any?
(fn (t) (= t "any")))
(define type-never?
(fn (t) (= t "never")))
(define type-nullable?
(fn (t)
;; A type is nullable if it's "any", "nil", a "?" shorthand, or
;; a union containing "nil".
(if (= t "any") true
(if (= t "nil") true
(if (and (= (type-of t) "string") (ends-with? t "?")) true
(if (and (= (type-of t) "list")
(not (empty? t))
(= (first t) "or"))
(contains? (rest t) "nil")
false))))))
(define nullable-base
(fn (t)
;; Strip "?" from nullable shorthand: "string?" → "string"
(if (and (= (type-of t) "string")
(ends-with? t "?")
(not (= t "?")))
(slice t 0 (- (string-length t) 1))
t)))
;; --------------------------------------------------------------------------
;; 3. Subtype checking
;; --------------------------------------------------------------------------
;; subtype?(a, b) — is type `a` assignable to type `b`?
(define subtype?
(fn (a b)
;; any accepts everything
(if (type-any? b) true
;; never is subtype of everything
(if (type-never? a) true
;; any is not a subtype of a specific type
(if (type-any? a) false
;; identical types
(if (= a b) true
;; nil is subtype of nullable types
(if (= a "nil")
(type-nullable? b)
;; nullable shorthand: "string?" = (or string nil)
(if (and (= (type-of b) "string") (ends-with? b "?"))
(let ((base (nullable-base b)))
(or (= a base) (= a "nil")))
;; a is a union: (or t1 t2 ...) <: b if ALL members <: b
;; Must check before b-union — (or A B) <: (or A B C) needs
;; each member of a checked against the full union b.
(if (and (= (type-of a) "list")
(not (empty? a))
(= (first a) "or"))
(every? (fn (member) (subtype? member b)) (rest a))
;; union: a <: (or t1 t2 ...) if a <: any member
(if (and (= (type-of b) "list")
(not (empty? b))
(= (first b) "or"))
(some (fn (member) (subtype? a member)) (rest b))
;; list-of covariance
(if (and (= (type-of a) "list") (= (type-of b) "list")
(= (len a) 2) (= (len b) 2)
(= (first a) "list-of") (= (first b) "list-of"))
(subtype? (nth a 1) (nth b 1))
;; "list" <: (list-of any)
(if (and (= a "list")
(= (type-of b) "list")
(= (len b) 2)
(= (first b) "list-of"))
(type-any? (nth b 1))
;; (list-of t) <: "list"
(if (and (= (type-of a) "list")
(= (len a) 2)
(= (first a) "list-of")
(= b "list"))
true
;; "element" is subtype of "string?" (rendered HTML)
false)))))))))))))
;; --------------------------------------------------------------------------
;; 4. Type union
;; --------------------------------------------------------------------------
(define type-union
(fn (a b)
;; Compute the smallest type that encompasses both a and b.
(if (= a b) a
(if (type-any? a) "any"
(if (type-any? b) "any"
(if (type-never? a) b
(if (type-never? b) a
(if (subtype? a b) b
(if (subtype? b a) a
;; neither is subtype — create a union
(if (= a "nil")
;; nil + string → string?
(if (and (= (type-of b) "string")
(not (ends-with? b "?")))
(str b "?")
(list "or" a b))
(if (= b "nil")
(if (and (= (type-of a) "string")
(not (ends-with? a "?")))
(str a "?")
(list "or" a b))
(list "or" a b))))))))))))
;; --------------------------------------------------------------------------
;; 5. Type narrowing
;; --------------------------------------------------------------------------
(define narrow-type
(fn (t (predicate-name :as string))
;; Narrow type based on a predicate test in a truthy branch.
;; (if (nil? x) ..then.. ..else..) → in else, x excludes nil.
;; Returns (narrowed-then narrowed-else).
(if (= predicate-name "nil?")
(list "nil" (narrow-exclude-nil t))
(if (= predicate-name "string?")
(list "string" (narrow-exclude t "string"))
(if (= predicate-name "number?")
(list "number" (narrow-exclude t "number"))
(if (= predicate-name "list?")
(list "list" (narrow-exclude t "list"))
(if (= predicate-name "dict?")
(list "dict" (narrow-exclude t "dict"))
(if (= predicate-name "boolean?")
(list "boolean" (narrow-exclude t "boolean"))
;; Unknown predicate — no narrowing
(list t t)))))))))
(define narrow-exclude-nil
(fn (t)
;; Remove nil from a type.
(if (= t "nil") "never"
(if (= t "any") "any" ;; can't narrow any
(if (and (= (type-of t) "string") (ends-with? t "?"))
(nullable-base t)
(if (and (= (type-of t) "list")
(not (empty? t))
(= (first t) "or"))
(let ((members (filter (fn (m) (not (= m "nil"))) (rest t))))
(if (= (len members) 1) (first members)
(if (empty? members) "never"
(cons "or" members))))
t))))))
(define narrow-exclude
(fn (t excluded)
;; Remove a specific type from a union.
(if (= t excluded) "never"
(if (= t "any") "any"
(if (and (= (type-of t) "list")
(not (empty? t))
(= (first t) "or"))
(let ((members (filter (fn (m) (not (= m excluded))) (rest t))))
(if (= (len members) 1) (first members)
(if (empty? members) "never"
(cons "or" members))))
t)))))
;; --------------------------------------------------------------------------
;; 6. Type inference
;; --------------------------------------------------------------------------
;; infer-type walks an AST node and returns its inferred type.
;; type-env is a dict mapping variable names → types.
(define infer-type
(fn (node (type-env :as dict) (prim-types :as dict) type-registry)
(let ((kind (type-of node)))
(if (= kind "number") "number"
(if (= kind "string") "string"
(if (= kind "boolean") "boolean"
(if (nil? node) "nil"
(if (= kind "keyword") "keyword"
(if (= kind "symbol")
(let ((name (symbol-name node)))
;; Look up in type env
(if (has-key? type-env name)
(get type-env name)
;; Builtins
(if (= name "true") "boolean"
(if (= name "false") "boolean"
(if (= name "nil") "nil"
;; Check primitive return types
(if (has-key? prim-types name)
(get prim-types name)
"any"))))))
(if (= kind "dict") "dict"
(if (= kind "list")
(infer-list-type node type-env prim-types type-registry)
"any")))))))))))
(define infer-list-type
(fn (node (type-env :as dict) (prim-types :as dict) type-registry)
;; Infer type of a list expression (function call, special form, etc.)
(if (empty? node) "list"
(let ((head (first node))
(args (rest node)))
(if (not (= (type-of head) "symbol"))
"any" ;; complex head — can't infer
(let ((name (symbol-name head)))
;; Special forms
(if (= name "if")
(infer-if-type args type-env prim-types type-registry)
(if (= name "when")
(if (>= (len args) 2)
(type-union (infer-type (last args) type-env prim-types type-registry) "nil")
"nil")
(if (or (= name "cond") (= name "case"))
"any" ;; complex — could be refined later
(if (= name "let")
(infer-let-type args type-env prim-types type-registry)
(if (or (= name "do") (= name "begin"))
(if (empty? args) "nil"
(infer-type (last args) type-env prim-types type-registry))
(if (or (= name "lambda") (= name "fn"))
"lambda"
(if (= name "and")
(if (empty? args) "boolean"
(infer-type (last args) type-env prim-types type-registry))
(if (= name "or")
(if (empty? args) "boolean"
;; or returns first truthy — union of all args
(reduce type-union "never"
(map (fn (a) (infer-type a type-env prim-types type-registry)) args)))
(if (= name "map")
;; map returns a list
(if (>= (len args) 2)
(let ((fn-type (infer-type (first args) type-env prim-types type-registry)))
;; If the fn's return type is known, produce (list-of return-type)
(if (and (= (type-of fn-type) "list")
(= (first fn-type) "->"))
(list "list-of" (last fn-type))
"list"))
"list")
(if (= name "filter")
;; filter preserves element type
(if (>= (len args) 2)
(infer-type (nth args 1) type-env prim-types type-registry)
"list")
(if (= name "reduce")
;; reduce returns the accumulator type — too complex to infer
"any"
(if (= name "list")
"list"
(if (= name "dict")
"dict"
(if (= name "quote")
"any"
(if (= name "str")
"string"
(if (= name "not")
"boolean"
(if (= name "get")
;; get — resolve record field type from type registry
(if (and (>= (len args) 2) (not (nil? type-registry)))
(let ((dict-type (infer-type (first args) type-env prim-types type-registry))
(key-arg (nth args 1))
(key-name (cond
(= (type-of key-arg) "keyword") (keyword-name key-arg)
(= (type-of key-arg) "string") key-arg
:else nil)))
(if (and key-name
(= (type-of dict-type) "string")
(has-key? type-registry dict-type))
(let ((resolved (resolve-type dict-type type-registry)))
(if (and (= (type-of resolved) "dict")
(has-key? resolved key-name))
(get resolved key-name)
"any"))
"any"))
"any")
(if (starts-with? name "~")
"element" ;; component call
;; Regular function call: look up return type
(if (has-key? prim-types name)
(get prim-types name)
"any")))))))))))))))))))))))))
(define infer-if-type
(fn ((args :as list) (type-env :as dict) (prim-types :as dict) type-registry)
;; (if test then else?) → union of then and else types
(if (< (len args) 2) "nil"
(let ((then-type (infer-type (nth args 1) type-env prim-types type-registry)))
(if (>= (len args) 3)
(type-union then-type (infer-type (nth args 2) type-env prim-types type-registry))
(type-union then-type "nil"))))))
(define infer-let-type
(fn ((args :as list) (type-env :as dict) (prim-types :as dict) type-registry)
;; (let ((x expr) ...) body) → type of body in extended type-env
(if (< (len args) 2) "nil"
(let ((bindings (first args))
(body (last args))
(extended (merge type-env (dict))))
;; Add binding types
(for-each
(fn (binding)
(when (and (= (type-of binding) "list") (>= (len binding) 2))
(let ((name (if (= (type-of (first binding)) "symbol")
(symbol-name (first binding))
(str (first binding))))
(val-type (infer-type (nth binding 1) extended prim-types type-registry)))
(dict-set! extended name val-type))))
bindings)
(infer-type body extended prim-types type-registry)))))
;; --------------------------------------------------------------------------
;; 7. Diagnostic types
;; --------------------------------------------------------------------------
;; Diagnostics are dicts:
;; {:level "error"|"warning"|"info"
;; :message "human-readable explanation"
;; :component "~name" (or nil for top-level)
;; :expr <the offending AST node>}
(define make-diagnostic
(fn ((level :as string) (message :as string) component expr)
{:level level
:message message
:component component
:expr expr}))
;; --------------------------------------------------------------------------
;; 8. Call-site checking
;; --------------------------------------------------------------------------
(define check-primitive-call
(fn ((name :as string) (args :as list) (type-env :as dict) (prim-types :as dict) prim-param-types (comp-name :as string) type-registry)
;; Check a primitive call site against declared param types.
;; prim-param-types is a dict: {prim-name → {:positional [...] :rest-type type-or-nil}}
;; Each positional entry is a list (name type-or-nil).
;; Returns list of diagnostics.
(let ((diagnostics (list)))
(when (and (not (nil? prim-param-types))
(has-key? prim-param-types name))
(let ((sig (get prim-param-types name))
(positional (get sig "positional"))
(rest-type (get sig "rest-type")))
;; Check each positional arg
(for-each
(fn (idx)
(when (< idx (len args))
(if (< idx (len positional))
;; Positional param — check against declared type
(let ((param-info (nth positional idx))
(arg-expr (nth args idx)))
(let ((expected-type (nth param-info 1)))
(when (not (nil? expected-type))
(let ((actual (infer-type arg-expr type-env prim-types type-registry)))
(when (and (not (type-any? expected-type))
(not (type-any? actual))
(not (subtype-resolved? actual expected-type type-registry)))
(append! diagnostics
(make-diagnostic "error"
(str "Argument " (+ idx 1) " of `" name
"` expects " expected-type ", got " actual)
comp-name arg-expr)))))))
;; Rest param — check against rest-type
(when (not (nil? rest-type))
(let ((arg-expr (nth args idx))
(actual (infer-type arg-expr type-env prim-types type-registry)))
(when (and (not (type-any? rest-type))
(not (type-any? actual))
(not (subtype-resolved? actual rest-type type-registry)))
(append! diagnostics
(make-diagnostic "error"
(str "Argument " (+ idx 1) " of `" name
"` expects " rest-type ", got " actual)
comp-name arg-expr))))))))
(range 0 (len args) 1))))
diagnostics)))
(define check-component-call
(fn ((comp-name :as string) (comp :as component) (call-args :as list) (type-env :as dict) (prim-types :as dict) type-registry)
;; Check a component call site against its declared param types.
;; comp is the component value, call-args is the list of args
;; from the call site (after the component name).
(let ((diagnostics (list))
(param-types (component-param-types comp))
(params (component-params comp)))
(when (and (not (nil? param-types))
(not (empty? (keys param-types))))
;; Parse keyword args from call site
(let ((i 0)
(provided-keys (list)))
(for-each
(fn (idx)
(when (< idx (len call-args))
(let ((arg (nth call-args idx)))
(when (= (type-of arg) "keyword")
(let ((key-name (keyword-name arg)))
(append! provided-keys key-name)
(when (< (+ idx 1) (len call-args))
(let ((val-expr (nth call-args (+ idx 1))))
;; Check type of value against declared param type
(when (has-key? param-types key-name)
(let ((expected (get param-types key-name))
(actual (infer-type val-expr type-env prim-types type-registry)))
(when (and (not (type-any? expected))
(not (type-any? actual))
(not (subtype-resolved? actual expected type-registry)))
(append! diagnostics
(make-diagnostic "error"
(str "Keyword :" key-name " of " comp-name
" expects " expected ", got " actual)
comp-name val-expr))))))))))))
(range 0 (len call-args) 1))
;; Check for missing required params (those with declared types)
(for-each
(fn (param-name)
(when (and (has-key? param-types param-name)
(not (contains? provided-keys param-name))
(not (type-nullable? (get param-types param-name))))
(append! diagnostics
(make-diagnostic "warning"
(str "Required param :" param-name " of " comp-name " not provided")
comp-name nil))))
params)
;; Check for unknown kwargs
(for-each
(fn (key)
(when (not (contains? params key))
(append! diagnostics
(make-diagnostic "warning"
(str "Unknown keyword :" key " passed to " comp-name)
comp-name nil))))
provided-keys)))
diagnostics)))
;; --------------------------------------------------------------------------
;; 9. AST walker — check a component body
;; --------------------------------------------------------------------------
(define check-body-walk
(fn (node (comp-name :as string) (type-env :as dict) (prim-types :as dict) prim-param-types env (diagnostics :as list) type-registry effect-annotations)
;; Recursively walk an AST and collect diagnostics.
;; prim-param-types: dict of {name → {:positional [...] :rest-type t}} or nil
;; type-registry: dict of {type-name → type-def} or nil
;; effect-annotations: dict of {fn-name → effect-list} or nil
(let ((kind (type-of node)))
(when (= kind "list")
(when (not (empty? node))
(let ((head (first node))
(args (rest node)))
;; Check calls when head is a symbol
(when (= (type-of head) "symbol")
(let ((name (symbol-name head)))
;; Component call
(when (starts-with? name "~")
(let ((comp-val (env-get env name)))
(when (= (type-of comp-val) "component")
(for-each
(fn (d) (append! diagnostics d))
(check-component-call name comp-val args
type-env prim-types type-registry))))
;; Effect check for component calls
(when (not (nil? effect-annotations))
(let ((caller-effects (get-effects comp-name effect-annotations)))
(for-each
(fn (d) (append! diagnostics d))
(check-effect-call name caller-effects effect-annotations comp-name)))))
;; Primitive call — check param types
(when (and (not (starts-with? name "~"))
(not (nil? prim-param-types))
(has-key? prim-param-types name))
(for-each
(fn (d) (append! diagnostics d))
(check-primitive-call name args type-env prim-types
prim-param-types comp-name type-registry)))
;; Effect check for function calls
(when (and (not (starts-with? name "~"))
(not (nil? effect-annotations)))
(let ((caller-effects (get-effects comp-name effect-annotations)))
(for-each
(fn (d) (append! diagnostics d))
(check-effect-call name caller-effects effect-annotations comp-name))))
;; Recurse into let with extended type env
(when (or (= name "let") (= name "let*"))
(when (>= (len args) 2)
(let ((bindings (first args))
(body-exprs (rest args))
(extended (merge type-env (dict))))
(for-each
(fn (binding)
(when (and (= (type-of binding) "list")
(>= (len binding) 2))
(let ((bname (if (= (type-of (first binding)) "symbol")
(symbol-name (first binding))
(str (first binding))))
(val-type (infer-type (nth binding 1) extended prim-types type-registry)))
(dict-set! extended bname val-type))))
bindings)
(for-each
(fn (body)
(check-body-walk body comp-name extended prim-types prim-param-types env diagnostics type-registry effect-annotations))
body-exprs))))
;; Recurse into define with type binding
(when (= name "define")
(when (>= (len args) 2)
(let ((def-name (if (= (type-of (first args)) "symbol")
(symbol-name (first args))
nil))
(def-val (nth args 1)))
(when def-name
(dict-set! type-env def-name
(infer-type def-val type-env prim-types type-registry)))
(check-body-walk def-val comp-name type-env prim-types prim-param-types env diagnostics type-registry effect-annotations))))))
;; Recurse into all child expressions
(for-each
(fn (child)
(check-body-walk child comp-name type-env prim-types prim-param-types env diagnostics type-registry effect-annotations))
args)))))))
;; --------------------------------------------------------------------------
;; 10. Check a single component
;; --------------------------------------------------------------------------
(define check-component
(fn ((comp-name :as string) env (prim-types :as dict) prim-param-types type-registry effect-annotations)
;; Type-check a component's body. Returns list of diagnostics.
;; prim-param-types: dict of param type info, or nil to skip primitive checking.
;; type-registry: dict of {type-name → type-def} or nil
;; effect-annotations: dict of {fn-name → effect-list} or nil
(let ((comp (env-get env comp-name))
(diagnostics (list)))
(when (= (type-of comp) "component")
(let ((body (component-body comp))
(params (component-params comp))
(param-types (component-param-types comp))
;; Build initial type env from component params
(type-env (dict)))
;; Add param types (annotated or default to any)
(for-each
(fn (p)
(dict-set! type-env p
(if (and (not (nil? param-types))
(has-key? param-types p))
(get param-types p)
"any")))
params)
;; Add children as (list-of element) if component has children
(when (component-has-children comp)
(dict-set! type-env "children" (list "list-of" "element")))
(check-body-walk body comp-name type-env prim-types prim-param-types env diagnostics type-registry effect-annotations)))
diagnostics)))
;; --------------------------------------------------------------------------
;; 11. Check all components in an environment
;; --------------------------------------------------------------------------
(define check-all
(fn (env (prim-types :as dict) prim-param-types type-registry effect-annotations)
;; Type-check every component in the environment.
;; prim-param-types: dict of param type info, or nil to skip primitive checking.
;; type-registry: dict of {type-name → type-def} or nil
;; effect-annotations: dict of {fn-name → effect-list} or nil
;; Returns list of all diagnostics.
(let ((all-diagnostics (list)))
(for-each
(fn (name)
(let ((val (env-get env name)))
(when (= (type-of val) "component")
(for-each
(fn (d) (append! all-diagnostics d))
(check-component name env prim-types prim-param-types type-registry effect-annotations)))))
(keys env))
all-diagnostics)))
;; --------------------------------------------------------------------------
;; 12. Build primitive type registry
;; --------------------------------------------------------------------------
;; Builds a dict mapping primitive-name → return-type from
;; the declarations parsed by boundary_parser.py.
;; This is called by the host at startup with the parsed declarations.
(define build-type-registry
(fn ((prim-declarations :as list) (io-declarations :as list))
;; Both are lists of dicts: {:name "+" :returns "number" :params (...)}
;; Returns a flat dict: {"+" "number", "str" "string", ...}
(let ((registry (dict)))
(for-each
(fn (decl)
(let ((name (get decl "name"))
(returns (get decl "returns")))
(when (and (not (nil? name)) (not (nil? returns)))
(dict-set! registry name returns))))
prim-declarations)
(for-each
(fn (decl)
(let ((name (get decl "name"))
(returns (get decl "returns")))
(when (and (not (nil? name)) (not (nil? returns)))
(dict-set! registry name returns))))
io-declarations)
registry)))
;; --------------------------------------------------------------------------
;; 13. User-defined types (deftype)
;; --------------------------------------------------------------------------
;; Type definitions are plain dicts: {:name "price" :params [] :body "number"}
;; Stored in env under "*type-registry*" mapping type names to defs.
;; make-type-def and normalize-type-body are defined in eval.sx
;; (always compiled). They're available when types.sx is compiled as a spec module.
;; -- Standard type definitions --
;; These define the record types used throughout the type system itself.
;; Universal: nullable shorthand
(deftype (maybe a) (union a nil))
;; A type definition entry in the registry
(deftype type-def
{:name string :params list :body any})
;; A diagnostic produced by the type checker
(deftype diagnostic
{:level string :message string :component string? :expr any})
;; Primitive parameter type signature
(deftype prim-param-sig
{:positional list :rest-type string?})
;; Effect declarations
(defeffect io)
(defeffect mutation)
(defeffect render)
(define type-def-name
(fn (td) (get td "name")))
(define type-def-params
(fn (td) (get td "params")))
(define type-def-body
(fn (td) (get td "body")))
(define resolve-type
(fn (t registry)
;; Resolve a type through the registry.
;; Returns the resolved type representation.
(if (nil? registry) t
(cond
;; String — might be a named type alias
(= (type-of t) "string")
(if (has-key? registry t)
(let ((td (get registry t)))
(let ((params (type-def-params td))
(body (type-def-body td)))
(if (empty? params)
;; Simple alias — resolve the body recursively
(resolve-type body registry)
;; Parameterized with no args — return as-is
t)))
t)
;; List — might be parameterized type application or compound
(= (type-of t) "list")
(if (empty? t) t
(let ((head (first t)))
(cond
;; (or ...), (list-of ...), (-> ...) — recurse into members
(or (= head "or") (= head "list-of") (= head "->")
(= head "dict-of"))
(cons head (map (fn (m) (resolve-type m registry)) (rest t)))
;; Parameterized type application: ("maybe" "string") etc.
(and (= (type-of head) "string")
(has-key? registry head))
(let ((td (get registry head))
(params (type-def-params td))
(body (type-def-body td))
(args (rest t)))
(if (= (len params) (len args))
(resolve-type
(substitute-type-vars body params args)
registry)
;; Wrong arity — return as-is
t))
:else t)))
;; Dict — record type, resolve field types
(= (type-of t) "dict")
(map-dict (fn (k v) (resolve-type v registry)) t)
;; Anything else — return as-is
:else t))))
(define substitute-type-vars
(fn (body (params :as list) (args :as list))
;; Substitute type variables in body.
;; params is a list of type var names, args is corresponding types.
(let ((subst (dict)))
(for-each
(fn (i)
(dict-set! subst (nth params i) (nth args i)))
(range 0 (len params) 1))
(substitute-in-type body subst))))
(define substitute-in-type
(fn (t (subst :as dict))
;; Recursively substitute type variables.
(cond
(= (type-of t) "string")
(if (has-key? subst t) (get subst t) t)
(= (type-of t) "list")
(map (fn (m) (substitute-in-type m subst)) t)
(= (type-of t) "dict")
(map-dict (fn (k v) (substitute-in-type v subst)) t)
:else t)))
(define subtype-resolved?
(fn (a b registry)
;; Resolve both sides through the registry, then check subtype.
(if (nil? registry)
(subtype? a b)
(let ((ra (resolve-type a registry))
(rb (resolve-type b registry)))
;; Handle record structural subtyping: dict a <: dict b
;; if every field in b exists in a with compatible type
(if (and (= (type-of ra) "dict") (= (type-of rb) "dict"))
(every?
(fn (key)
(and (has-key? ra key)
(subtype-resolved? (get ra key) (get rb key) registry)))
(keys rb))
(subtype? ra rb))))))
;; --------------------------------------------------------------------------
;; 14. Effect checking (defeffect)
;; --------------------------------------------------------------------------
;; Effects are annotations on functions/components describing their
;; side effects. A pure function cannot call IO functions.
(define get-effects
(fn ((name :as string) effect-annotations)
;; Look up declared effects for a function/component.
;; Returns list of effect strings, or nil if unannotated.
(if (nil? effect-annotations) nil
(if (has-key? effect-annotations name)
(get effect-annotations name)
nil))))
(define effects-subset?
(fn (callee-effects caller-effects)
;; Are all callee effects allowed by caller?
;; nil effects = unannotated = assumed to have all effects.
;; Empty list = pure = no effects.
(if (nil? caller-effects) true ;; unannotated caller allows everything
(if (nil? callee-effects) true ;; unannotated callee — skip check
(every?
(fn (e) (contains? caller-effects e))
callee-effects)))))
(define check-effect-call
(fn ((callee-name :as string) caller-effects effect-annotations (comp-name :as string))
;; Check that callee's effects are allowed by caller's effects.
;; Returns list of diagnostics.
(let ((diagnostics (list))
(callee-effects (get-effects callee-name effect-annotations)))
(when (and (not (nil? caller-effects))
(not (nil? callee-effects))
(not (effects-subset? callee-effects caller-effects)))
(append! diagnostics
(make-diagnostic "error"
(str "`" callee-name "` has effects "
(join ", " callee-effects)
" but `" comp-name "` only allows "
(if (empty? caller-effects) "[pure]"
(join ", " caller-effects)))
comp-name nil)))
diagnostics)))
(define build-effect-annotations
(fn ((io-declarations :as list))
;; Assign [io] effect to all IO primitives.
(let ((annotations (dict)))
(for-each
(fn (decl)
(let ((name (get decl "name")))
(when (not (nil? name))
(dict-set! annotations name (list "io")))))
io-declarations)
annotations)))
;; --------------------------------------------------------------------------
;; Platform interface summary
;; --------------------------------------------------------------------------
;;
;; From eval.sx (already provided):
;; (type-of x), (symbol-name s), (keyword-name k), (env-get env k)
;; (component-body c), (component-params c), (component-has-children c)
;;
;; New for types.sx (each host implements):
;; (component-param-types c) → dict {param-name → type} or nil
;; (component-set-param-types! c d) → store param types on component
;; (merge d1 d2) → new dict merging d1 and d2
;;
;; Primitive param types:
;; The host provides prim-param-types as a dict mapping primitive names
;; to param type descriptors. Each descriptor is a dict:
;; {"positional" [["name" "type-or-nil"] ...] "rest-type" "type-or-nil"}
;; Built by boundary_parser.parse_primitive_param_types() in Python.
;; Passed to check-component/check-all as an optional extra argument.
;;
;; --------------------------------------------------------------------------

View File

@@ -25,7 +25,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define z3-sort (define z3-sort
(fn (sx-type) (fn ((sx-type :as string))
(case sx-type (case sx-type
"number" "Int" "number" "Int"
"boolean" "Bool" "boolean" "Bool"
@@ -40,7 +40,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define z3-name (define z3-name
(fn (name) (fn ((name :as string))
(cond (cond
(= name "!=") "neq" (= name "!=") "neq"
(= name "+") "+" (= name "+") "+"
@@ -74,7 +74,7 @@
;; Operators that get renamed ;; Operators that get renamed
(define z3-rename-op (define z3-rename-op
(fn (op) (fn ((op :as string))
(case op (case op
"if" "ite" "if" "ite"
"str" "str.++" "str" "str.++"
@@ -176,7 +176,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define z3-extract-kwargs (define z3-extract-kwargs
(fn (expr) (fn ((expr :as list))
;; Returns a dict of keyword args from a define-* form ;; Returns a dict of keyword args from a define-* form
;; (define-primitive "name" :params (...) :returns "type" ...) → {:params ... :returns ...} ;; (define-primitive "name" :params (...) :returns "type" ...) → {:params ... :returns ...}
(let ((result {}) (let ((result {})
@@ -184,7 +184,7 @@
(z3-extract-kwargs-loop items result)))) (z3-extract-kwargs-loop items result))))
(define z3-extract-kwargs-loop (define z3-extract-kwargs-loop
(fn (items result) (fn ((items :as list) (result :as dict))
(if (or (empty? items) (< (len items) 2)) (if (or (empty? items) (< (len items) 2))
result result
(if (= (type-of (first items)) "keyword") (if (= (type-of (first items)) "keyword")
@@ -199,12 +199,12 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define z3-params-to-sorts (define z3-params-to-sorts
(fn (params) (fn ((params :as list))
;; Convert SX param list to list of (name sort) pairs, skipping &rest/&key ;; Convert SX param list to list of (name sort) pairs, skipping &rest/&key
(z3-params-loop params false (list)))) (z3-params-loop params false (list))))
(define z3-params-loop (define z3-params-loop
(fn (params skip-next acc) (fn ((params :as list) (skip-next :as boolean) (acc :as list))
(if (empty? params) (if (empty? params)
acc acc
(let ((p (first params)) (let ((p (first params))
@@ -227,7 +227,7 @@
(z3-params-loop rest-p false acc)))))) (z3-params-loop rest-p false acc))))))
(define z3-has-rest? (define z3-has-rest?
(fn (params) (fn ((params :as list))
(some (fn (p) (and (= (type-of p) "symbol") (= (symbol-name p) "&rest"))) (some (fn (p) (and (= (type-of p) "symbol") (= (symbol-name p) "&rest")))
params))) params)))
@@ -237,7 +237,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define z3-translate-primitive (define z3-translate-primitive
(fn (expr) (fn ((expr :as list))
(let ((name (nth expr 1)) (let ((name (nth expr 1))
(kwargs (z3-extract-kwargs expr)) (kwargs (z3-extract-kwargs expr))
(params (or (get kwargs "params") (list))) (params (or (get kwargs "params") (list)))
@@ -282,7 +282,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define z3-translate-io (define z3-translate-io
(fn (expr) (fn ((expr :as list))
(let ((name (nth expr 1)) (let ((name (nth expr 1))
(kwargs (z3-extract-kwargs expr)) (kwargs (z3-extract-kwargs expr))
(doc (or (get kwargs "doc") "")) (doc (or (get kwargs "doc") ""))
@@ -297,7 +297,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define z3-translate-special-form (define z3-translate-special-form
(fn (expr) (fn ((expr :as list))
(let ((name (nth expr 1)) (let ((name (nth expr 1))
(kwargs (z3-extract-kwargs expr)) (kwargs (z3-extract-kwargs expr))
(doc (or (get kwargs "doc") ""))) (doc (or (get kwargs "doc") "")))
@@ -342,7 +342,7 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
(define z3-translate-file (define z3-translate-file
(fn (exprs) (fn ((exprs :as list))
;; Filter to translatable forms and translate each ;; Filter to translatable forms and translate each
(let ((translatable (let ((translatable
(filter (filter

View File

@@ -4,11 +4,14 @@ Relation registry — declarative entity relationship definitions.
Relations are defined as s-expressions using ``defrelation`` and stored Relations are defined as s-expressions using ``defrelation`` and stored
in a global registry. All services load the same definitions at startup in a global registry. All services load the same definitions at startup
via ``load_relation_registry()``. via ``load_relation_registry()``.
No evaluator dependency — defrelation forms are parsed directly from the
AST since they're just structured data (keyword args → RelationDef).
""" """
from __future__ import annotations from __future__ import annotations
from shared.sx.types import RelationDef from shared.sx.types import Keyword, RelationDef, Symbol
# --------------------------------------------------------------------------- # ---------------------------------------------------------------------------
@@ -48,6 +51,102 @@ def clear_registry() -> None:
_RELATION_REGISTRY.clear() _RELATION_REGISTRY.clear()
# ---------------------------------------------------------------------------
# defrelation parsing — direct AST walk, no evaluator needed
# ---------------------------------------------------------------------------
_VALID_CARDINALITIES = {"one-to-one", "one-to-many", "many-to-many"}
_VALID_NAV = {"submenu", "tab", "badge", "inline", "hidden"}
class RelationError(Exception):
"""Error parsing a defrelation form."""
pass
def _parse_defrelation(expr: list) -> RelationDef:
"""Parse a (defrelation :name :key val ...) AST into a RelationDef."""
if len(expr) < 2:
raise RelationError("defrelation requires a name")
name_kw = expr[1]
if not isinstance(name_kw, Keyword):
raise RelationError(
f"defrelation name must be a keyword, got {type(name_kw).__name__}"
)
rel_name = name_kw.name
# Parse keyword args
kwargs: dict[str, str | None] = {}
i = 2
while i < len(expr):
key = expr[i]
if isinstance(key, Keyword):
if i + 1 < len(expr):
val = expr[i + 1]
kwargs[key.name] = val.name if isinstance(val, Keyword) else val
i += 2
else:
kwargs[key.name] = None
i += 1
else:
i += 1
for field in ("from", "to", "cardinality"):
if field not in kwargs:
raise RelationError(
f"defrelation {rel_name} missing required :{field}"
)
card = kwargs["cardinality"]
if card not in _VALID_CARDINALITIES:
raise RelationError(
f"defrelation {rel_name}: invalid cardinality {card!r}, "
f"expected one of {_VALID_CARDINALITIES}"
)
nav = kwargs.get("nav", "hidden")
if nav not in _VALID_NAV:
raise RelationError(
f"defrelation {rel_name}: invalid nav {nav!r}, "
f"expected one of {_VALID_NAV}"
)
return RelationDef(
name=rel_name,
from_type=kwargs["from"],
to_type=kwargs["to"],
cardinality=card,
inverse=kwargs.get("inverse"),
nav=nav,
nav_icon=kwargs.get("nav-icon"),
nav_label=kwargs.get("nav-label"),
)
def evaluate_defrelation(expr: list) -> RelationDef:
"""Parse a defrelation form, register it, and return the RelationDef.
Also handles (begin (defrelation ...) ...) wrappers.
"""
if not isinstance(expr, list) or not expr:
raise RelationError(f"Expected list expression, got {type(expr).__name__}")
head = expr[0]
if isinstance(head, Symbol) and head.name == "begin":
result = None
for child in expr[1:]:
result = evaluate_defrelation(child)
return result
if not (isinstance(head, Symbol) and head.name == "defrelation"):
raise RelationError(f"Expected defrelation, got {head}")
defn = _parse_defrelation(expr)
register_relation(defn)
return defn
# --------------------------------------------------------------------------- # ---------------------------------------------------------------------------
# Built-in relation definitions (s-expression source) # Built-in relation definitions (s-expression source)
# --------------------------------------------------------------------------- # ---------------------------------------------------------------------------
@@ -94,8 +193,7 @@ _BUILTIN_RELATIONS = '''
def load_relation_registry() -> None: def load_relation_registry() -> None:
"""Parse built-in defrelation s-expressions and populate the registry.""" """Parse built-in defrelation s-expressions and populate the registry."""
from shared.sx.evaluator import evaluate
from shared.sx.parser import parse from shared.sx.parser import parse
tree = parse(_BUILTIN_RELATIONS) tree = parse(_BUILTIN_RELATIONS)
evaluate(tree) evaluate_defrelation(tree)

View File

@@ -31,7 +31,7 @@ import asyncio
from typing import Any from typing import Any
from .types import Component, Keyword, Lambda, NIL, Symbol from .types import Component, Keyword, Lambda, NIL, Symbol
from .evaluator import _eval as _raw_eval, _trampoline from .ref.sx_ref import eval_expr as _raw_eval, trampoline as _trampoline
def _eval(expr, env): def _eval(expr, env):
"""Evaluate and unwrap thunks — all resolver.py _eval calls are non-tail.""" """Evaluate and unwrap thunks — all resolver.py _eval calls are non-tail."""

View File

@@ -6,7 +6,7 @@
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
;; Auth section nav items (newsletters link + account_nav slot) ;; Auth section nav items (newsletters link + account_nav slot)
(defcomp ~auth-nav-items (&key account-url select-colours account-nav) (defcomp ~auth-nav-items (&key (account-url :as string?) (select-colours :as string?) account-nav)
(<> (<>
(~nav-link :href (str (or account-url "") "/newsletters/") (~nav-link :href (str (or account-url "") "/newsletters/")
:label "newsletters" :label "newsletters"
@@ -14,7 +14,7 @@
(when account-nav account-nav))) (when account-nav account-nav)))
;; Auth header row — wraps ~menu-row-sx for account section ;; Auth header row — wraps ~menu-row-sx for account section
(defcomp ~auth-header-row (&key account-url select-colours account-nav oob) (defcomp ~auth-header-row (&key (account-url :as string?) (select-colours :as string?) account-nav (oob :as boolean?))
(~menu-row-sx :id "auth-row" :level 1 :colour "sky" (~menu-row-sx :id "auth-row" :level 1 :colour "sky"
:link-href (str (or account-url "") "/") :link-href (str (or account-url "") "/")
:link-label "account" :icon "fa-solid fa-user" :link-label "account" :icon "fa-solid fa-user"
@@ -24,7 +24,7 @@
:child-id "auth-header-child" :oob oob)) :child-id "auth-header-child" :oob oob))
;; Auth header row without nav (for cart service) ;; Auth header row without nav (for cart service)
(defcomp ~auth-header-row-simple (&key account-url oob) (defcomp ~auth-header-row-simple (&key (account-url :as string?) (oob :as boolean?))
(~menu-row-sx :id "auth-row" :level 1 :colour "sky" (~menu-row-sx :id "auth-row" :level 1 :colour "sky"
:link-href (str (or account-url "") "/") :link-href (str (or account-url "") "/")
:link-label "account" :icon "fa-solid fa-user" :link-label "account" :icon "fa-solid fa-user"
@@ -52,7 +52,7 @@
:account-nav (account-nav-ctx)))) :account-nav (account-nav-ctx))))
;; Orders header row ;; Orders header row
(defcomp ~orders-header-row (&key list-url) (defcomp ~orders-header-row (&key (list-url :as string))
(~menu-row-sx :id "orders-row" :level 2 :colour "sky" (~menu-row-sx :id "orders-row" :level 2 :colour "sky"
:link-href list-url :link-label "Orders" :icon "fa fa-gbp" :link-href list-url :link-label "Orders" :icon "fa fa-gbp"
:child-id "orders-header-child")) :child-id "orders-header-child"))
@@ -61,12 +61,12 @@
;; Auth forms — login flow, check email ;; Auth forms — login flow, check email
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~auth-error-banner (&key error) (defcomp ~auth-error-banner (&key (error :as string?))
(when error (when error
(div :class "bg-red-50 border border-red-200 text-red-700 p-3 rounded mb-4" (div :class "bg-red-50 border border-red-200 text-red-700 p-3 rounded mb-4"
error))) error)))
(defcomp ~auth-login-form (&key error action csrf-token email) (defcomp ~auth-login-form (&key error (action :as string) (csrf-token :as string) (email :as string?))
(div :class "py-8 max-w-md mx-auto" (div :class "py-8 max-w-md mx-auto"
(h1 :class "text-2xl font-bold mb-6" "Sign in") (h1 :class "text-2xl font-bold mb-6" "Sign in")
error error
@@ -80,12 +80,12 @@
:class "w-full bg-stone-800 text-white py-2 px-4 rounded hover:bg-stone-700 transition" :class "w-full bg-stone-800 text-white py-2 px-4 rounded hover:bg-stone-700 transition"
"Send magic link")))) "Send magic link"))))
(defcomp ~auth-check-email-error (&key error) (defcomp ~auth-check-email-error (&key (error :as string?))
(when error (when error
(div :class "bg-yellow-50 border border-yellow-200 text-yellow-700 p-3 rounded mt-4" (div :class "bg-yellow-50 border border-yellow-200 text-yellow-700 p-3 rounded mt-4"
error))) error)))
(defcomp ~auth-check-email (&key email error) (defcomp ~auth-check-email (&key (email :as string) error)
(div :class "py-8 max-w-md mx-auto text-center" (div :class "py-8 max-w-md mx-auto text-center"
(h1 :class "text-2xl font-bold mb-4" "Check your email") (h1 :class "text-2xl font-bold mb-4" "Check your email")
(p :class "text-stone-600 mb-2" "We sent a sign-in link to " (strong email) ".") (p :class "text-stone-600 mb-2" "We sent a sign-in link to " (strong email) ".")

View File

@@ -1,6 +1,6 @@
(defcomp ~post-card (&key title slug href feature-image excerpt (defcomp ~post-card (&key (title :as string) (slug :as string) (href :as string) (feature-image :as string?)
status published-at updated-at publish-requested (excerpt :as string?) (status :as string?) (published-at :as string?) (updated-at :as string?)
hx-select like widgets at-bar) (publish-requested :as boolean?) (hx-select :as string?) like widgets at-bar)
(article :class "border-b pb-6 last:border-b-0 relative" (article :class "border-b pb-6 last:border-b-0 relative"
(when like like) (when like like)
(a :href href (a :href href
@@ -31,7 +31,8 @@
(when widgets widgets) (when widgets widgets)
(when at-bar at-bar))) (when at-bar at-bar)))
(defcomp ~order-summary-card (&key order-id created-at description status currency total-amount) (defcomp ~order-summary-card (&key (order-id :as string) (created-at :as string?) (description :as string?)
(status :as string?) (currency :as string?) (total-amount :as string?))
(div :class "rounded-2xl border border-stone-200 bg-white/80 p-4 sm:p-6 space-y-2 text-xs sm:text-sm text-stone-800" (div :class "rounded-2xl border border-stone-200 bg-white/80 p-4 sm:p-6 space-y-2 text-xs sm:text-sm text-stone-800"
(p (span :class "font-medium" "Order ID:") " " (span :class "font-mono" (str "#" order-id))) (p (span :class "font-medium" "Order ID:") " " (span :class "font-mono" (str "#" order-id)))
(p (span :class "font-medium" "Created:") " " (or created-at "\u2014")) (p (span :class "font-medium" "Created:") " " (or created-at "\u2014"))

View File

@@ -1,4 +1,5 @@
(defcomp ~search-mobile (&key current-local-href search search-count hx-select search-headers-mobile) (defcomp ~search-mobile (&key (current-local-href :as string) (search :as string?) (search-count :as number?)
(hx-select :as string?) (search-headers-mobile :as string?))
(div :id "search-mobile-wrapper" (div :id "search-mobile-wrapper"
:class "flex flex-row gap-2 items-center flex-1 min-w-0 pr-2" :class "flex flex-row gap-2 items-center flex-1 min-w-0 pr-2"
(input :id "search-mobile" (input :id "search-mobile"
@@ -20,7 +21,8 @@
:class (if (not search-count) "text-xl text-red-500" "") :class (if (not search-count) "text-xl text-red-500" "")
(when search (str search-count))))) (when search (str search-count)))))
(defcomp ~search-desktop (&key current-local-href search search-count hx-select search-headers-desktop) (defcomp ~search-desktop (&key (current-local-href :as string) (search :as string?) (search-count :as number?)
(hx-select :as string?) (search-headers-desktop :as string?))
(div :id "search-desktop-wrapper" (div :id "search-desktop-wrapper"
:class "flex flex-row gap-2 items-center" :class "flex flex-row gap-2 items-center"
(input :id "search-desktop" (input :id "search-desktop"
@@ -62,7 +64,8 @@
(div :id "filter-details-mobile" :style "display:contents" (div :id "filter-details-mobile" :style "display:contents"
(when filter-details filter-details)))) (when filter-details filter-details))))
(defcomp ~infinite-scroll (&key url page total-pages id-prefix colspan) (defcomp ~infinite-scroll (&key (url :as string) (page :as number) (total-pages :as number)
(id-prefix :as string) (colspan :as number))
(if (< page total-pages) (if (< page total-pages)
(tr :id (str id-prefix "-sentinel-" page) (tr :id (str id-prefix "-sentinel-" page)
:sx-get url :sx-get url
@@ -82,7 +85,7 @@
(tr (td :colspan colspan :class "px-3 py-4 text-center text-xs text-stone-400" (tr (td :colspan colspan :class "px-3 py-4 text-center text-xs text-stone-400"
"End of results")))) "End of results"))))
(defcomp ~status-pill (&key status size) (defcomp ~status-pill (&key (status :as string?) (size :as string?))
(let* ((s (or status "pending")) (let* ((s (or status "pending"))
(lower (lower s)) (lower (lower s))
(sz (or size "xs")) (sz (or size "xs"))

219
shared/sx/templates/cssx.sx Normal file
View File

@@ -0,0 +1,219 @@
;; @client — send all define forms to browser for client-side use.
;; CSSX — computed CSS from s-expressions.
;;
;; Generic mechanism: cssx is a macro that groups CSS property declarations.
;; The vocabulary (property mappings, value functions) is pluggable — the
;; Tailwind-inspired defaults below are just one possible style system.
;;
;; Usage:
;; (cssx (:text (colour "violet" 699) (size "4xl") (weight "bold") (family "mono"))
;; (:bg (colour "stone" 50)))
;;
;; Each group is (:keyword value ...modifiers):
;; - keyword maps to a CSS property via cssx-properties dict
;; - value is the CSS value for that property
;; - modifiers are extra CSS declaration strings, concatenated in
;;
;; Single group:
;; (cssx (:text (colour "violet" 699)))
;;
;; Modifiers without a colour:
;; (cssx (:text nil (size "4xl") (weight "bold")))
;;
;; Unknown keywords pass through as raw CSS property names:
;; (cssx (:outline (colour "red" 500))) → "outline:hsl(0,72%,53%);"
;;
;; Standalone modifiers work outside cssx too:
;; :style (size "4xl")
;; :style (str (weight "bold") (family "mono"))
;; =========================================================================
;; Layer 1: Generic mechanism — cssx macro + cssxgroup function
;; =========================================================================
;; Property keyword → CSS property name. Extend this dict for new mappings.
(define cssx-properties
{"text" "color"
"bg" "background-color"
"border" "border-color"})
;; Evaluate one property group: (:text value modifier1 modifier2 ...)
;; If value is nil, only modifiers are emitted (no property declaration).
;; NOTE: name must NOT contain hyphens — the evaluator's isRenderExpr check
;; treats (hyphenated-name :keyword ...) as a custom HTML element.
(define cssxgroup
(fn (prop value b c d e)
(let ((css-prop (or (get cssx-properties prop) prop)))
(str (if (nil? value) "" (str css-prop ":" value ";"))
(or b "") (or c "") (or d "") (or e "")))))
;; cssx macro — takes one or more property groups, expands to (str ...).
;; (cssx (:text val ...) (:bg val ...))
;; → (str (cssxgroup :text val ...) (cssxgroup :bg val ...))
(defmacro cssx (&rest groups)
`(str ,@(map (fn (g) (cons 'cssxgroup g)) groups)))
;; =========================================================================
;; Layer 2: Value vocabulary — colour, size, weight, family
;; These are independent functions. Use inside cssx groups or standalone.
;; Replace or extend with any style system.
;; =========================================================================
;; ---------------------------------------------------------------------------
;; Colour — compute CSS colour value from name + shade
;; ---------------------------------------------------------------------------
(define colour-bases
{"violet" {"h" 263 "s" 70}
"purple" {"h" 271 "s" 81}
"indigo" {"h" 239 "s" 84}
"blue" {"h" 217 "s" 91}
"sky" {"h" 199 "s" 89}
"cyan" {"h" 188 "s" 94}
"teal" {"h" 173 "s" 80}
"emerald" {"h" 160 "s" 84}
"green" {"h" 142 "s" 71}
"lime" {"h" 84 "s" 78}
"yellow" {"h" 48 "s" 96}
"amber" {"h" 38 "s" 92}
"orange" {"h" 25 "s" 95}
"red" {"h" 0 "s" 72}
"rose" {"h" 350 "s" 89}
"pink" {"h" 330 "s" 81}
"stone" {"h" 25 "s" 6}
"slate" {"h" 215 "s" 16}
"gray" {"h" 220 "s" 9}
"zinc" {"h" 240 "s" 5}
"neutral" {"h" 0 "s" 0}})
(define lerp (fn (a b t) (+ a (* t (- b a)))))
(define shade-to-lightness
(fn (shade)
(cond
(<= shade 50) (lerp 100 97 (/ shade 50))
(<= shade 100) (lerp 97 93 (/ (- shade 50) 50))
(<= shade 200) (lerp 93 87 (/ (- shade 100) 100))
(<= shade 300) (lerp 87 77 (/ (- shade 200) 100))
(<= shade 400) (lerp 77 64 (/ (- shade 300) 100))
(<= shade 500) (lerp 64 53 (/ (- shade 400) 100))
(<= shade 600) (lerp 53 45 (/ (- shade 500) 100))
(<= shade 700) (lerp 45 38 (/ (- shade 600) 100))
(<= shade 800) (lerp 38 30 (/ (- shade 700) 100))
(<= shade 900) (lerp 30 21 (/ (- shade 800) 100))
(<= shade 950) (lerp 21 13 (/ (- shade 900) 50))
true 13)))
(define colour
(fn (name shade)
(let ((base (get colour-bases name)))
(if (nil? base)
name
(let ((h (get base "h"))
(s (get base "s"))
(l (shade-to-lightness shade)))
(str "hsl(" h "," s "%," (round l) "%)"))))))
;; ---------------------------------------------------------------------------
;; Font sizes — named size → font-size + line-height (Tailwind v3 scale)
;; ---------------------------------------------------------------------------
(define cssx-sizes
{"xs" "font-size:0.75rem;line-height:1rem;"
"sm" "font-size:0.875rem;line-height:1.25rem;"
"base" "font-size:1rem;line-height:1.5rem;"
"lg" "font-size:1.125rem;line-height:1.75rem;"
"xl" "font-size:1.25rem;line-height:1.75rem;"
"2xl" "font-size:1.5rem;line-height:2rem;"
"3xl" "font-size:1.875rem;line-height:2.25rem;"
"4xl" "font-size:2.25rem;line-height:2.5rem;"
"5xl" "font-size:3rem;line-height:1;"
"6xl" "font-size:3.75rem;line-height:1;"
"7xl" "font-size:4.5rem;line-height:1;"
"8xl" "font-size:6rem;line-height:1;"
"9xl" "font-size:8rem;line-height:1;"})
;; ---------------------------------------------------------------------------
;; Font weights — named weight → numeric value
;; ---------------------------------------------------------------------------
(define cssx-weights
{"thin" "100"
"extralight" "200"
"light" "300"
"normal" "400"
"medium" "500"
"semibold" "600"
"bold" "700"
"extrabold" "800"
"black" "900"})
;; ---------------------------------------------------------------------------
;; Font families — named family → CSS font stack
;; ---------------------------------------------------------------------------
(define cssx-families
{"sans" "ui-sans-serif,system-ui,-apple-system,BlinkMacSystemFont,\"Segoe UI\",Roboto,\"Helvetica Neue\",Arial,\"Noto Sans\",sans-serif"
"serif" "ui-serif,Georgia,Cambria,\"Times New Roman\",Times,serif"
"mono" "ui-monospace,SFMono-Regular,Menlo,Monaco,Consolas,\"Liberation Mono\",\"Courier New\",monospace"})
;; ---------------------------------------------------------------------------
;; Standalone modifier functions — return CSS declaration strings
;; Each returns a complete CSS declaration string. Use inside cssx groups
;; or standalone on :style with str.
;; ---------------------------------------------------------------------------
;; -- Typography --
(define size
(fn (s) (or (get cssx-sizes s) (str "font-size:" s ";"))))
(define weight
(fn (w)
(let ((v (get cssx-weights w)))
(str "font-weight:" (or v w) ";"))))
(define family
(fn (f)
(let ((v (get cssx-families f)))
(str "font-family:" (or v f) ";"))))
(define align
(fn (a) (str "text-align:" a ";")))
(define decoration
(fn (d) (str "text-decoration:" d ";")))
;; -- Spacing (Tailwind scale: 1 unit = 0.25rem) --
(define spacing (fn (n) (str (* n 0.25) "rem")))
(define p (fn (n) (str "padding:" (spacing n) ";")))
(define px (fn (n) (str "padding-left:" (spacing n) ";padding-right:" (spacing n) ";")))
(define py (fn (n) (str "padding-top:" (spacing n) ";padding-bottom:" (spacing n) ";")))
(define pt (fn (n) (str "padding-top:" (spacing n) ";")))
(define pb (fn (n) (str "padding-bottom:" (spacing n) ";")))
(define pl (fn (n) (str "padding-left:" (spacing n) ";")))
(define pr (fn (n) (str "padding-right:" (spacing n) ";")))
(define m (fn (n) (str "margin:" (spacing n) ";")))
(define mx (fn (n) (str "margin-left:" (spacing n) ";margin-right:" (spacing n) ";")))
(define my (fn (n) (str "margin-top:" (spacing n) ";margin-bottom:" (spacing n) ";")))
(define mt (fn (n) (str "margin-top:" (spacing n) ";")))
(define mb (fn (n) (str "margin-bottom:" (spacing n) ";")))
(define ml (fn (n) (str "margin-left:" (spacing n) ";")))
(define mr (fn (n) (str "margin-right:" (spacing n) ";")))
(define mx-auto (fn () "margin-left:auto;margin-right:auto;"))
;; -- Display & layout --
(define display (fn (d) (str "display:" d ";")))
(define max-w (fn (w) (str "max-width:" w ";")))
;; Named max-widths (Tailwind scale)
(define cssx-max-widths
{"xs" "20rem" "sm" "24rem" "md" "28rem"
"lg" "32rem" "xl" "36rem" "2xl" "42rem"
"3xl" "48rem" "4xl" "56rem" "5xl" "64rem"
"6xl" "72rem" "7xl" "80rem"
"full" "100%" "none" "none"})

View File

@@ -1,4 +1,5 @@
(defcomp ~link-card (&key link title image icon subtitle detail data-app) (defcomp ~link-card (&key (link :as string) (title :as string) (image :as string?) (icon :as string?)
(subtitle :as string?) (detail :as string?) (data-app :as string?))
(a :href link (a :href link
:class "block rounded border border-stone-200 bg-white hover:bg-stone-50 transition-colors no-underline" :class "block rounded border border-stone-200 bg-white hover:bg-stone-50 transition-colors no-underline"
:data-fragment "link-card" :data-fragment "link-card"
@@ -16,7 +17,7 @@
(when detail (when detail
(div :class "text-xs text-stone-400 mt-1" detail)))))) (div :class "text-xs text-stone-400 mt-1" detail))))))
(defcomp ~cart-mini (&key cart-count blog-url cart-url oob) (defcomp ~cart-mini (&key (cart-count :as number) (blog-url :as string) (cart-url :as string) (oob :as string?))
(div :id "cart-mini" (div :id "cart-mini"
:sx-swap-oob oob :sx-swap-oob oob
(if (= cart-count 0) (if (= cart-count 0)
@@ -33,7 +34,7 @@
(span :class "absolute top-1/2 left-1/2 -translate-x-1/2 -translate-y-1/2 inline-flex items-center justify-center rounded-full bg-emerald-600 text-white text-sm w-5 h-5" (span :class "absolute top-1/2 left-1/2 -translate-x-1/2 -translate-y-1/2 inline-flex items-center justify-center rounded-full bg-emerald-600 text-white text-sm w-5 h-5"
cart-count))))) cart-count)))))
(defcomp ~auth-menu (&key user-email account-url) (defcomp ~auth-menu (&key (user-email :as string?) (account-url :as string))
(<> (<>
(span :id "auth-menu-desktop" :class "hidden md:inline-flex" (span :id "auth-menu-desktop" :class "hidden md:inline-flex"
(if user-email (if user-email
@@ -65,7 +66,7 @@
(i :class "fa-solid fa-key") (i :class "fa-solid fa-key")
(span "sign in or register")))))) (span "sign in or register"))))))
(defcomp ~account-nav-item (&key href label) (defcomp ~account-nav-item (&key (href :as string) (label :as string))
(div :class "relative nav-group" (div :class "relative nav-group"
(a :href href (a :href href
:class "justify-center cursor-pointer flex flex-row items-center gap-2 rounded bg-stone-200 text-black p-3" :class "justify-center cursor-pointer flex flex-row items-center gap-2 rounded bg-stone-200 text-black p-3"

View File

@@ -1,15 +1,16 @@
(defcomp ~app-body (&key header-rows filter aside menu content) (defcomp ~app-body (&key header-rows filter aside menu content)
(div :class "max-w-screen-2xl mx-auto py-1 px-1" (div :class "max-w-screen-2xl mx-auto py-1 px-1"
(div :class "w-full" (when header-rows
(details :class "group/root p-2" :data-toggle-group "mobile-panels" (div :class "w-full"
(summary (details :class "group/root p-2" :data-toggle-group "mobile-panels"
(header :class "z-50" (summary
(div :id "root-header-summary" (header :class "z-50"
:class "flex items-start gap-2 p-1 bg-sky-500" (div :id "root-header-summary"
(div :id "root-header-child" :class "flex flex-col w-full items-center" :class "flex items-start gap-2 p-1 bg-sky-500"
(when header-rows header-rows))))) (div :id "root-header-child" :class "flex flex-col w-full items-center"
(div :id "root-menu" :sx-swap-oob "outerHTML" :class "md:hidden" header-rows))))
(when menu menu)))) (div :id "root-menu" :sx-swap-oob "outerHTML" :class "md:hidden"
(when menu menu)))))
(div :id "filter" (div :id "filter"
(when filter filter)) (when filter filter))
(main :id "root-panel" :class "max-w-full" (main :id "root-panel" :class "max-w-full"
@@ -47,19 +48,19 @@
:class "w-12 h-12 rotate-180 transition-transform group-open/root:block hidden self-start" :class "w-12 h-12 rotate-180 transition-transform group-open/root:block hidden self-start"
(path :d "M6 9l6 6 6-6" :fill "currentColor")))) (path :d "M6 9l6 6 6-6" :fill "currentColor"))))
(defcomp ~post-label (&key feature-image title) (defcomp ~post-label (&key (feature-image :as string?) (title :as string))
(<> (when feature-image (<> (when feature-image
(img :src feature-image :class "h-8 w-8 rounded-full object-cover border border-stone-300 flex-shrink-0")) (img :src feature-image :class "h-8 w-8 rounded-full object-cover border border-stone-300 flex-shrink-0"))
(span title))) (span title)))
(defcomp ~page-cart-badge (&key href count) (defcomp ~page-cart-badge (&key (href :as string) (count :as string))
(a :href href :class "relative inline-flex items-center gap-1.5 px-3 py-1.5 text-sm rounded-full border border-emerald-300 bg-emerald-50 text-emerald-800 hover:bg-emerald-100 transition" (a :href href :class "relative inline-flex items-center gap-1.5 px-3 py-1.5 text-sm rounded-full border border-emerald-300 bg-emerald-50 text-emerald-800 hover:bg-emerald-100 transition"
(i :class "fa fa-shopping-cart" :aria-hidden "true") (i :class "fa fa-shopping-cart" :aria-hidden "true")
(span count))) (span count)))
(defcomp ~header-row-sx (&key cart-mini blog-url site-title app-label (defcomp ~header-row-sx (&key cart-mini (blog-url :as string?) (site-title :as string?)
nav-tree auth-menu nav-panel (app-label :as string?) nav-tree auth-menu nav-panel
settings-url is-admin oob) (settings-url :as string?) (is-admin :as boolean?) (oob :as boolean?))
(<> (<>
(div :id "root-row" (div :id "root-row"
:sx-swap-oob (if oob "outerHTML" nil) :sx-swap-oob (if oob "outerHTML" nil)
@@ -84,8 +85,10 @@
; @css bg-sky-400 bg-sky-300 bg-sky-200 bg-sky-100 bg-violet-400 bg-violet-300 bg-violet-200 bg-violet-100 ; @css bg-sky-400 bg-sky-300 bg-sky-200 bg-sky-100 bg-violet-400 bg-violet-300 bg-violet-200 bg-violet-100
; @css aria-selected:bg-violet-200 aria-selected:text-violet-900 aria-selected:bg-stone-500 aria-selected:text-white ; @css aria-selected:bg-violet-200 aria-selected:text-violet-900 aria-selected:bg-stone-500 aria-selected:text-white
(defcomp ~menu-row-sx (&key id level colour link-href link-label link-label-content icon (defcomp ~menu-row-sx (&key (id :as string) (level :as number?) (colour :as string?)
selected hx-select nav child-id child oob external) (link-href :as string) (link-label :as string?) link-label-content
(icon :as string?) (selected :as string?) (hx-select :as string?)
nav (child-id :as string?) child (oob :as boolean?) (external :as boolean?))
(let* ((c (or colour "sky")) (let* ((c (or colour "sky"))
(lv (or level 1)) (lv (or level 1))
(shade (str (- 500 (* lv 100))))) (shade (str (- 500 (* lv 100)))))
@@ -114,11 +117,11 @@
(div :id child-id :class "flex flex-col w-full items-center" (div :id child-id :class "flex flex-col w-full items-center"
(when child child)))))) (when child child))))))
(defcomp ~oob-header-sx (&key parent-id row) (defcomp ~oob-header-sx (&key (parent-id :as string) row)
(div :id parent-id :sx-swap-oob "outerHTML" :class "flex flex-col w-full items-center" (div :id parent-id :sx-swap-oob "outerHTML" :class "flex flex-col w-full items-center"
row)) row))
(defcomp ~header-child-sx (&key id inner) (defcomp ~header-child-sx (&key (id :as string?) inner)
(div :id (or id "root-header-child") :class "flex flex-col w-full items-center" inner)) (div :id (or id "root-header-child") :class "flex flex-col w-full items-center" inner))
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
@@ -126,7 +129,8 @@
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
;; Labelled section: colour bar header + vertical nav items ;; Labelled section: colour bar header + vertical nav items
(defcomp ~mobile-menu-section (&key label href colour level items) (defcomp ~mobile-menu-section (&key (label :as string) (href :as string?) (colour :as string?)
(level :as number?) items)
(let* ((c (or colour "sky")) (let* ((c (or colour "sky"))
(lv (or level 1)) (lv (or level 1))
(shade (str (- 500 (* lv 100))))) (shade (str (- 500 (* lv 100)))))
@@ -152,8 +156,9 @@
;; nested component calls in _aser are serialized without expansion. ;; nested component calls in _aser are serialized without expansion.
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~root-header (&key cart-mini blog-url site-title app-label (defcomp ~root-header (&key cart-mini (blog-url :as string?) (site-title :as string?)
nav-tree auth-menu nav-panel settings-url is-admin oob) (app-label :as string?) nav-tree auth-menu nav-panel
(settings-url :as string?) (is-admin :as boolean?) (oob :as boolean?))
(~header-row-sx :cart-mini cart-mini :blog-url blog-url :site-title site-title (~header-row-sx :cart-mini cart-mini :blog-url blog-url :site-title site-title
:app-label app-label :nav-tree nav-tree :auth-menu auth-menu :app-label app-label :nav-tree nav-tree :auth-menu auth-menu
:nav-panel nav-panel :settings-url settings-url :is-admin is-admin :nav-panel nav-panel :settings-url settings-url :is-admin is-admin
@@ -225,18 +230,18 @@
(~root-mobile-auto)))) (~root-mobile-auto))))
;; Post-admin layout — root + post header with nested admin row ;; Post-admin layout — root + post header with nested admin row
(defcomp ~layout-post-admin-full (&key selected) (defcomp ~layout-post-admin-full (&key (selected :as string?))
(let ((__admin-hdr (~post-admin-header-auto nil selected))) (let ((__admin-hdr (~post-admin-header-auto nil selected)))
(<> (~root-header-auto) (<> (~root-header-auto)
(~header-child-sx (~header-child-sx
:inner (~post-header-auto nil))))) :inner (~post-header-auto nil)))))
(defcomp ~layout-post-admin-oob (&key selected) (defcomp ~layout-post-admin-oob (&key (selected :as string?))
(<> (~post-header-auto true) (<> (~post-header-auto true)
(~oob-header-sx :parent-id "post-header-child" (~oob-header-sx :parent-id "post-header-child"
:row (~post-admin-header-auto nil selected)))) :row (~post-admin-header-auto nil selected))))
(defcomp ~layout-post-admin-mobile (&key selected) (defcomp ~layout-post-admin-mobile (&key (selected :as string?))
(let ((__phctx (post-header-ctx))) (let ((__phctx (post-header-ctx)))
(<> (<>
(when (get __phctx "slug") (when (get __phctx "slug")
@@ -253,7 +258,7 @@
:items (~post-nav-auto))) :items (~post-nav-auto)))
(~root-mobile-auto)))) (~root-mobile-auto))))
(defcomp ~error-content (&key errnum message image) (defcomp ~error-content (&key (errnum :as string) (message :as string) (image :as string?))
(div :class "text-center p-8 max-w-lg mx-auto" (div :class "text-center p-8 max-w-lg mx-auto"
(div :class "font-bold text-2xl md:text-4xl text-red-500 mb-4" errnum) (div :class "font-bold text-2xl md:text-4xl text-red-500 mb-4" errnum)
(div :class "text-stone-600 mb-4" message) (div :class "text-stone-600 mb-4" message)
@@ -261,7 +266,7 @@
(div :class "flex justify-center" (div :class "flex justify-center"
(img :src image :width "300" :height "300"))))) (img :src image :width "300" :height "300")))))
(defcomp ~clear-oob-div (&key id) (defcomp ~clear-oob-div (&key (id :as string))
(div :id id :sx-swap-oob "outerHTML")) (div :id id :sx-swap-oob "outerHTML"))
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
@@ -353,21 +358,22 @@
content)) content))
; @css justify-center cursor-pointer flex flex-row items-center gap-2 rounded bg-stone-200 text-black p-3 !bg-stone-500 !text-white ; @css justify-center cursor-pointer flex flex-row items-center gap-2 rounded bg-stone-200 text-black p-3 !bg-stone-500 !text-white
(defcomp ~admin-cog-button (&key href is-admin-page) (defcomp ~admin-cog-button (&key (href :as string) (is-admin-page :as boolean?))
(div :class "relative nav-group" (div :class "relative nav-group"
(a :href href (a :href href
:class (str "justify-center cursor-pointer flex flex-row items-center gap-2 rounded bg-stone-200 text-black p-3 " :class (str "justify-center cursor-pointer flex flex-row items-center gap-2 rounded bg-stone-200 text-black p-3 "
(if is-admin-page "!bg-stone-500 !text-white" "")) (if is-admin-page "!bg-stone-500 !text-white" ""))
(i :class "fa fa-cog" :aria-hidden "true")))) (i :class "fa fa-cog" :aria-hidden "true"))))
(defcomp ~post-admin-label (&key selected) (defcomp ~post-admin-label (&key (selected :as string?))
(<> (<>
(i :class "fa fa-shield-halved" :aria-hidden "true") (i :class "fa fa-shield-halved" :aria-hidden "true")
" admin" " admin"
(when selected (when selected
(span :class "text-white" selected)))) (span :class "text-white" selected))))
(defcomp ~nav-link (&key href hx-select label icon aclass select-colours is-selected) (defcomp ~nav-link (&key (href :as string) (hx-select :as string?) (label :as string?) (icon :as string?)
(aclass :as string?) (select-colours :as string?) (is-selected :as string?))
(div :class "relative nav-group" (div :class "relative nav-group"
(a :href href (a :href href
:sx-get href :sx-get href

View File

@@ -2,32 +2,33 @@
;; The single place where raw! lives — for CMS content (Ghost post body, ;; The single place where raw! lives — for CMS content (Ghost post body,
;; product descriptions, etc.) that arrives as pre-rendered HTML. ;; product descriptions, etc.) that arrives as pre-rendered HTML.
(defcomp ~rich-text (&key html) (defcomp ~rich-text (&key (html :as string))
(raw! html)) (raw! html))
(defcomp ~error-inline (&key message) (defcomp ~error-inline (&key (message :as string))
(div :class "text-red-600 text-sm" message)) (div :class "text-red-600 text-sm" message))
(defcomp ~notification-badge (&key count) (defcomp ~notification-badge (&key (count :as number))
(span :class "bg-red-500 text-white text-xs rounded-full px-1.5 py-0.5" count)) (span :class "bg-red-500 text-white text-xs rounded-full px-1.5 py-0.5" count))
(defcomp ~cache-cleared (&key time-str) (defcomp ~cache-cleared (&key (time-str :as string))
(span :class "text-green-600 font-bold" "Cache cleared at " time-str)) (span :class "text-green-600 font-bold" "Cache cleared at " time-str))
(defcomp ~error-list (&key items) (defcomp ~error-list (&key (items :as list?))
(ul :class "list-disc pl-5 space-y-1 text-sm text-red-600" (ul :class "list-disc pl-5 space-y-1 text-sm text-red-600"
(when items items))) (when items items)))
(defcomp ~error-list-item (&key message) (defcomp ~error-list-item (&key (message :as string))
(li message)) (li message))
(defcomp ~fragment-error (&key service) (defcomp ~fragment-error (&key (service :as string))
(p :class "text-sm text-red-600" "Service " (b service) " is unavailable.")) (p :class "text-sm text-red-600" "Service " (b service) " is unavailable."))
(defcomp ~htmx-sentinel (&key id hx-get hx-trigger hx-swap class extra-attrs) (defcomp ~htmx-sentinel (&key (id :as string) (hx-get :as string) (hx-trigger :as string)
(hx-swap :as string) (class :as string?) extra-attrs)
(div :id id :sx-get hx-get :sx-trigger hx-trigger :sx-swap hx-swap :class class)) (div :id id :sx-get hx-get :sx-trigger hx-trigger :sx-swap hx-swap :class class))
(defcomp ~nav-group-link (&key href hx-select nav-class label) (defcomp ~nav-group-link (&key (href :as string) (hx-select :as string?) (nav-class :as string?) (label :as string))
(div :class "relative nav-group" (div :class "relative nav-group"
(a :href href :sx-get href :sx-target "#main-panel" (a :href href :sx-get href :sx-target "#main-panel"
:sx-select hx-select :sx-swap "outerHTML" :sx-select hx-select :sx-swap "outerHTML"
@@ -38,7 +39,7 @@
;; Shared sentinel components — infinite scroll triggers ;; Shared sentinel components — infinite scroll triggers
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~sentinel-mobile (&key id next-url hyperscript) (defcomp ~sentinel-mobile (&key (id :as string) (next-url :as string) (hyperscript :as string?))
(div :id id :class "block md:hidden h-[60vh] opacity-0 pointer-events-none js-mobile-sentinel" (div :id id :class "block md:hidden h-[60vh] opacity-0 pointer-events-none js-mobile-sentinel"
:sx-get next-url :sx-trigger "intersect once delay:250ms, sentinelmobile:retry" :sx-get next-url :sx-trigger "intersect once delay:250ms, sentinelmobile:retry"
:sx-swap "outerHTML" :_ hyperscript :sx-swap "outerHTML" :_ hyperscript
@@ -49,7 +50,7 @@
(i :class "fa fa-exclamation-triangle text-2xl") (i :class "fa fa-exclamation-triangle text-2xl")
(p :class "mt-2" "Loading failed \u2014 retrying\u2026")))) (p :class "mt-2" "Loading failed \u2014 retrying\u2026"))))
(defcomp ~sentinel-desktop (&key id next-url hyperscript) (defcomp ~sentinel-desktop (&key (id :as string) (next-url :as string) (hyperscript :as string?))
(div :id id :class "hidden md:block h-4 opacity-0 pointer-events-none" (div :id id :class "hidden md:block h-4 opacity-0 pointer-events-none"
:sx-get next-url :sx-trigger "intersect once delay:250ms, sentinel:retry" :sx-get next-url :sx-trigger "intersect once delay:250ms, sentinel:retry"
:sx-swap "outerHTML" :_ hyperscript :sx-swap "outerHTML" :_ hyperscript
@@ -58,20 +59,20 @@
(div :class "animate-spin h-6 w-6 border-2 border-stone-300 border-t-stone-600 rounded-full")) (div :class "animate-spin h-6 w-6 border-2 border-stone-300 border-t-stone-600 rounded-full"))
(div :class "js-neterr hidden text-center py-2 text-stone-400 text-sm" "Retry\u2026"))) (div :class "js-neterr hidden text-center py-2 text-stone-400 text-sm" "Retry\u2026")))
(defcomp ~sentinel-simple (&key id next-url) (defcomp ~sentinel-simple (&key (id :as string) (next-url :as string))
(div :id id :class "h-4 opacity-0 pointer-events-none" (div :id id :class "h-4 opacity-0 pointer-events-none"
:sx-get next-url :sx-trigger "intersect once delay:250ms" :sx-swap "outerHTML" :sx-get next-url :sx-trigger "intersect once delay:250ms" :sx-swap "outerHTML"
:role "status" :aria-hidden "true" :role "status" :aria-hidden "true"
(div :class "text-center text-xs text-stone-400" "loading..."))) (div :class "text-center text-xs text-stone-400" "loading...")))
(defcomp ~end-of-results (&key cls) (defcomp ~end-of-results (&key (cls :as string?))
(div :class (or cls "col-span-full mt-4 text-center text-xs text-stone-400") "End of results")) (div :class (or cls "col-span-full mt-4 text-center text-xs text-stone-400") "End of results"))
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
;; Shared empty state — icon + message + optional action ;; Shared empty state — icon + message + optional action
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~empty-state (&key icon message cls &rest children) (defcomp ~empty-state (&key (icon :as string?) (message :as string) (cls :as string?) &rest children)
(div :class (or cls "p-8 text-center text-stone-400") (div :class (or cls "p-8 text-center text-stone-400")
(when icon (div (i :class (str icon " text-4xl mb-2") :aria-hidden "true"))) (when icon (div (i :class (str icon " text-4xl mb-2") :aria-hidden "true")))
(p message) (p message)
@@ -81,7 +82,7 @@
;; Shared badge — inline pill with configurable colours ;; Shared badge — inline pill with configurable colours
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~badge (&key label cls) (defcomp ~badge (&key (label :as string) (cls :as string?))
(span :class (str "inline-flex items-center rounded-full px-2 py-0.5 text-xs font-medium " (or cls "bg-stone-100 text-stone-700")) (span :class (str "inline-flex items-center rounded-full px-2 py-0.5 text-xs font-medium " (or cls "bg-stone-100 text-stone-700"))
label)) label))
@@ -89,8 +90,9 @@
;; Shared delete button with confirm dialog ;; Shared delete button with confirm dialog
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~delete-btn (&key url trigger-target title text confirm-text cancel-text (defcomp ~delete-btn (&key (url :as string) (trigger-target :as string) (title :as string?)
sx-headers cls) (text :as string?) (confirm-text :as string?) (cancel-text :as string?)
(sx-headers :as string?) (cls :as string?))
(button :type "button" (button :type "button"
:data-confirm "" :data-confirm-title (or title "Delete?") :data-confirm "" :data-confirm-title (or title "Delete?")
:data-confirm-text (or text "Are you sure?") :data-confirm-text (or text "Are you sure?")
@@ -108,7 +110,7 @@
;; Shared price display — special + regular with strikethrough ;; Shared price display — special + regular with strikethrough
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~price (&key special-price regular-price) (defcomp ~price (&key (special-price :as string?) (regular-price :as string?))
(div :class "mt-1 flex items-baseline gap-2 justify-center" (div :class "mt-1 flex items-baseline gap-2 justify-center"
(when special-price (div :class "text-lg font-semibold text-emerald-700" special-price)) (when special-price (div :class "text-lg font-semibold text-emerald-700" special-price))
(when (and special-price regular-price) (div :class "text-sm line-through text-stone-500" regular-price)) (when (and special-price regular-price) (div :class "text-sm line-through text-stone-500" regular-price))
@@ -118,7 +120,8 @@
;; Shared image-or-placeholder ;; Shared image-or-placeholder
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~img-or-placeholder (&key src alt size-cls placeholder-icon placeholder-text) (defcomp ~img-or-placeholder (&key (src :as string?) (alt :as string?) (size-cls :as string?)
(placeholder-icon :as string?) (placeholder-text :as string?))
(if src (if src
(img :src src :alt (or alt "") :class (or size-cls "w-12 h-12 rounded-full object-cover flex-shrink-0")) (img :src src :alt (or alt "") :class (or size-cls "w-12 h-12 rounded-full object-cover flex-shrink-0"))
(div :class (str (or size-cls "w-12 h-12 rounded-full") " bg-stone-200 flex items-center justify-center flex-shrink-0") (div :class (str (or size-cls "w-12 h-12 rounded-full") " bg-stone-200 flex items-center justify-center flex-shrink-0")
@@ -141,8 +144,9 @@
(path :stroke-linecap "round" :stroke-linejoin "round" (path :stroke-linecap "round" :stroke-linejoin "round"
:d "M4 5a1 1 0 011-1h4a1 1 0 011 1v4a1 1 0 01-1 1H5a1 1 0 01-1-1V5zM14 5a1 1 0 011-1h4a1 1 0 011 1v4a1 1 0 01-1 1h-4a1 1 0 01-1-1V5zM4 15a1 1 0 011-1h4a1 1 0 011 1v4a1 1 0 01-1 1H5a1 1 0 01-1-1v-4zM14 15a1 1 0 011-1h4a1 1 0 011 1v4a1 1 0 01-1 1h-4a1 1 0 01-1-1v-4z"))) :d "M4 5a1 1 0 011-1h4a1 1 0 011 1v4a1 1 0 01-1 1H5a1 1 0 01-1-1V5zM14 5a1 1 0 011-1h4a1 1 0 011 1v4a1 1 0 01-1 1h-4a1 1 0 01-1-1V5zM4 15a1 1 0 011-1h4a1 1 0 011 1v4a1 1 0 01-1 1H5a1 1 0 01-1-1v-4zM14 15a1 1 0 011-1h4a1 1 0 011 1v4a1 1 0 01-1 1h-4a1 1 0 01-1-1v-4z")))
(defcomp ~view-toggle (&key list-href tile-href hx-select list-cls tile-cls (defcomp ~view-toggle (&key (list-href :as string) (tile-href :as string) (hx-select :as string?)
storage-key list-svg tile-svg) (list-cls :as string?) (tile-cls :as string?) (storage-key :as string?)
list-svg tile-svg)
(div :class "hidden md:flex justify-end px-3 pt-3 gap-1" (div :class "hidden md:flex justify-end px-3 pt-3 gap-1"
(a :href list-href :sx-get list-href :sx-target "#main-panel" :sx-select hx-select (a :href list-href :sx-get list-href :sx-target "#main-panel" :sx-select hx-select
:sx-swap "outerHTML" :sx-push-url "true" :class (str "p-1.5 rounded " list-cls) :title "List view" :sx-swap "outerHTML" :sx-push-url "true" :class (str "p-1.5 rounded " list-cls) :title "List view"
@@ -157,7 +161,9 @@
;; Shared CRUD admin panel — for calendars, markets, etc. ;; Shared CRUD admin panel — for calendars, markets, etc.
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~crud-create-form (&key create-url csrf errors-id list-id placeholder label btn-label) (defcomp ~crud-create-form (&key (create-url :as string) (csrf :as string) (errors-id :as string?)
(list-id :as string?) (placeholder :as string?) (label :as string?)
(btn-label :as string?))
(<> (<>
(div :id (or errors-id "crud-create-errors") :class "mt-2 text-sm text-red-600") (div :id (or errors-id "crud-create-errors") :class "mt-2 text-sm text-red-600")
(form :class "mt-4 flex gap-2 items-end" :sx-post create-url (form :class "mt-4 flex gap-2 items-end" :sx-post create-url
@@ -171,13 +177,14 @@
:placeholder (or placeholder "Name"))) :placeholder (or placeholder "Name")))
(button :type "submit" :class "border rounded px-3 py-2" (or btn-label "Add"))))) (button :type "submit" :class "border rounded px-3 py-2" (or btn-label "Add")))))
(defcomp ~crud-panel (&key form list list-id) (defcomp ~crud-panel (&key form list (list-id :as string?))
(section :class "p-4" (section :class "p-4"
form form
(div :id (or list-id "crud-list") :class "mt-6" list))) (div :id (or list-id "crud-list") :class "mt-6" list)))
(defcomp ~crud-item (&key href name slug del-url csrf-hdr list-id (defcomp ~crud-item (&key (href :as string) (name :as string) (slug :as string) (del-url :as string)
confirm-title confirm-text) (csrf-hdr :as string) (list-id :as string?) (confirm-title :as string?)
(confirm-text :as string?))
(div :class "mt-6 border rounded-lg p-4" (div :class "mt-6 border rounded-lg p-4"
(div :class "flex items-center justify-between gap-3" (div :class "flex items-center justify-between gap-3"
(a :class "flex items-baseline gap-3" :href href (a :class "flex items-baseline gap-3" :href href
@@ -199,9 +206,10 @@
;; checkout prefix) used by blog, events, and cart admin panels. ;; checkout prefix) used by blog, events, and cart admin panels.
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~sumup-settings-form (&key update-url csrf merchant-code placeholder (defcomp ~sumup-settings-form (&key (update-url :as string) (csrf :as string?) (merchant-code :as string?)
input-cls sumup-configured checkout-prefix (placeholder :as string?) (input-cls :as string?)
panel-id sx-select) (sumup-configured :as boolean?) (checkout-prefix :as string?)
(panel-id :as string?) (sx-select :as string?))
(div :id (or panel-id "payments-panel") :class "space-y-4 p-4 bg-white rounded-lg border border-stone-200" (div :id (or panel-id "payments-panel") :class "space-y-4 p-4 bg-white rounded-lg border border-stone-200"
(h3 :class "text-lg font-semibold text-stone-800" (h3 :class "text-lg font-semibold text-stone-800"
(i :class "fa fa-credit-card text-purple-600 mr-1") " SumUp Payment") (i :class "fa fa-credit-card text-purple-600 mr-1") " SumUp Payment")
@@ -233,7 +241,7 @@
;; Shared avatar — image or initial-letter placeholder ;; Shared avatar — image or initial-letter placeholder
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~avatar (&key src cls initial) (defcomp ~avatar (&key (src :as string?) (cls :as string?) (initial :as string?))
(if src (if src
(img :src src :alt "" :class cls) (img :src src :alt "" :class cls)
(div :class cls initial))) (div :class cls initial)))
@@ -242,7 +250,9 @@
;; Shared scroll-nav wrapper — horizontal scrollable nav with arrows ;; Shared scroll-nav wrapper — horizontal scrollable nav with arrows
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~scroll-nav-wrapper (&key wrapper-id container-id arrow-cls left-hs scroll-hs right-hs items oob) (defcomp ~scroll-nav-wrapper (&key (wrapper-id :as string) (container-id :as string) (arrow-cls :as string?)
(left-hs :as string?) (scroll-hs :as string?) (right-hs :as string?)
items (oob :as boolean?))
(div :class "flex flex-col sm:flex-row sm:items-center gap-2 border-r border-stone-200 mr-2 sm:max-w-2xl" (div :class "flex flex-col sm:flex-row sm:items-center gap-2 border-r border-stone-200 mr-2 sm:max-w-2xl"
:id wrapper-id :sx-swap-oob (if oob "outerHTML" nil) :id wrapper-id :sx-swap-oob (if oob "outerHTML" nil)
(button :class (str (or arrow-cls "nav-arrow") " hidden flex-shrink-0 p-2 hover:bg-stone-200 rounded") (button :class (str (or arrow-cls "nav-arrow") " hidden flex-shrink-0 p-2 hover:bg-stone-200 rounded")

View File

@@ -1,11 +1,12 @@
(defcomp ~calendar-entry-nav (&key href name date-str nav-class) (defcomp ~calendar-entry-nav (&key (href :as string) (name :as string) (date-str :as string) (nav-class :as string?))
(a :href href :class nav-class (a :href href :class nav-class
(div :class "w-8 h-8 rounded bg-stone-200 flex-shrink-0") (div :class "w-8 h-8 rounded bg-stone-200 flex-shrink-0")
(div :class "flex-1 min-w-0" (div :class "flex-1 min-w-0"
(div :class "font-medium truncate" name) (div :class "font-medium truncate" name)
(div :class "text-xs text-stone-600 truncate" date-str)))) (div :class "text-xs text-stone-600 truncate" date-str))))
(defcomp ~calendar-link-nav (&key href name nav-class is-selected select-colours) (defcomp ~calendar-link-nav (&key (href :as string) (name :as string) (nav-class :as string?)
(is-selected :as string?) (select-colours :as string?))
(a :href href (a :href href
:sx-get href :sx-get href
:sx-target "#main-panel" :sx-target "#main-panel"
@@ -17,12 +18,14 @@
(i :class "fa fa-calendar" :aria-hidden "true") (i :class "fa fa-calendar" :aria-hidden "true")
(span name))) (span name)))
(defcomp ~market-link-nav (&key href name nav-class select-colours) (defcomp ~market-link-nav (&key (href :as string) (name :as string) (nav-class :as string?)
(select-colours :as string?))
(a :href href :class (str (or nav-class "") " " (or select-colours "")) (a :href href :class (str (or nav-class "") " " (or select-colours ""))
(i :class "fa fa-shopping-bag" :aria-hidden "true") (i :class "fa fa-shopping-bag" :aria-hidden "true")
(span name))) (span name)))
(defcomp ~relation-nav (&key href name icon nav-class relation-type) (defcomp ~relation-nav (&key (href :as string) (name :as string) (icon :as string?)
(nav-class :as string?) (relation-type :as string?))
(a :href href :class (or nav-class "flex items-center gap-3 rounded-lg py-2 px-3 text-sm text-stone-700 hover:bg-stone-100 transition-colors") (a :href href :class (or nav-class "flex items-center gap-3 rounded-lg py-2 px-3 text-sm text-stone-700 hover:bg-stone-100 transition-colors")
(when icon (when icon
(div :class "w-8 h-8 rounded bg-stone-200 flex items-center justify-center flex-shrink-0" (div :class "w-8 h-8 rounded bg-stone-200 flex items-center justify-center flex-shrink-0"

View File

@@ -6,7 +6,8 @@
;; Order table rows ;; Order table rows
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~order-row-desktop (&key oid created desc total pill status url) (defcomp ~order-row-desktop (&key (oid :as string) (created :as string) (desc :as string) (total :as string)
(pill :as string) (status :as string) (url :as string))
(tr :class "hidden sm:table-row border-t border-stone-100 hover:bg-stone-50/60" (tr :class "hidden sm:table-row border-t border-stone-100 hover:bg-stone-50/60"
(td :class "px-3 py-2 align-top" (span :class "font-mono text-[11px] sm:text-xs" oid)) (td :class "px-3 py-2 align-top" (span :class "font-mono text-[11px] sm:text-xs" oid))
(td :class "px-3 py-2 align-top text-stone-700 text-xs sm:text-sm" created) (td :class "px-3 py-2 align-top text-stone-700 text-xs sm:text-sm" created)
@@ -16,7 +17,8 @@
(td :class "px-3 py-0.5 align-top text-right" (td :class "px-3 py-0.5 align-top text-right"
(a :href url :class "inline-flex items-center px-3 py-1.5 text-xs sm:text-sm rounded-full border border-stone-300 bg-white hover:bg-stone-50 transition" "View")))) (a :href url :class "inline-flex items-center px-3 py-1.5 text-xs sm:text-sm rounded-full border border-stone-300 bg-white hover:bg-stone-50 transition" "View"))))
(defcomp ~order-row-mobile (&key oid created total pill status url) (defcomp ~order-row-mobile (&key (oid :as string) (created :as string) (total :as string)
(pill :as string) (status :as string) (url :as string))
(tr :class "sm:hidden border-t border-stone-100" (tr :class "sm:hidden border-t border-stone-100"
(td :colspan "5" :class "px-3 py-3" (td :colspan "5" :class "px-3 py-3"
(div :class "flex flex-col gap-2 text-xs" (div :class "flex flex-col gap-2 text-xs"
@@ -61,13 +63,14 @@
;; Order detail panels ;; Order detail panels
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~order-item-image (&key src alt) (defcomp ~order-item-image (&key (src :as string) (alt :as string))
(img :src src :alt alt :class "w-full h-full object-contain object-center" :loading "lazy" :decoding "async")) (img :src src :alt alt :class "w-full h-full object-contain object-center" :loading "lazy" :decoding "async"))
(defcomp ~order-item-no-image () (defcomp ~order-item-no-image ()
(div :class "w-full h-full flex items-center justify-center text-[9px] text-stone-400" "No image")) (div :class "w-full h-full flex items-center justify-center text-[9px] text-stone-400" "No image"))
(defcomp ~order-item-row (&key href img title pid qty price) (defcomp ~order-item-row (&key (href :as string) img (title :as string) (pid :as string)
(qty :as string) (price :as string))
(li (a :class "w-full py-2 flex gap-3" :href href (li (a :class "w-full py-2 flex gap-3" :href href
(div :class "w-12 h-12 sm:w-14 sm:h-14 rounded-md bg-stone-100 flex-shrink-0 overflow-hidden" img) (div :class "w-12 h-12 sm:w-14 sm:h-14 rounded-md bg-stone-100 flex-shrink-0 overflow-hidden" img)
(div :class "flex-1 flex justify-between gap-3" (div :class "flex-1 flex justify-between gap-3"
@@ -83,7 +86,8 @@
(h2 :class "text-sm sm:text-base font-semibold mb-3" "Items") (h2 :class "text-sm sm:text-base font-semibold mb-3" "Items")
(ul :class "divide-y divide-stone-100 text-xs sm:text-sm" items))) (ul :class "divide-y divide-stone-100 text-xs sm:text-sm" items)))
(defcomp ~order-calendar-entry (&key name pill status date-str cost) (defcomp ~order-calendar-entry (&key (name :as string) (pill :as string) (status :as string)
(date-str :as string) (cost :as string))
(li :class "px-4 py-3 flex items-start justify-between text-sm" (li :class "px-4 py-3 flex items-start justify-between text-sm"
(div (div :class "font-medium flex items-center gap-2" (div (div :class "font-medium flex items-center gap-2"
name (span :class pill status)) name (span :class pill status))
@@ -98,11 +102,12 @@
(defcomp ~order-detail-panel (&key summary items calendar) (defcomp ~order-detail-panel (&key summary items calendar)
(div :class "max-w-full px-3 py-3 space-y-4" summary items calendar)) (div :class "max-w-full px-3 py-3 space-y-4" summary items calendar))
(defcomp ~order-pay-btn (&key url) (defcomp ~order-pay-btn (&key (url :as string))
(a :href url :class "inline-flex items-center px-3 py-2 text-xs sm:text-sm rounded-full border border-emerald-600 bg-emerald-600 text-white hover:bg-emerald-700 transition" (a :href url :class "inline-flex items-center px-3 py-2 text-xs sm:text-sm rounded-full border border-emerald-600 bg-emerald-600 text-white hover:bg-emerald-700 transition"
(i :class "fa fa-credit-card mr-2" :aria-hidden "true") "Open payment page")) (i :class "fa fa-credit-card mr-2" :aria-hidden "true") "Open payment page"))
(defcomp ~order-detail-filter (&key info list-url recheck-url csrf pay) (defcomp ~order-detail-filter (&key (info :as string) (list-url :as string) (recheck-url :as string)
(csrf :as string) pay)
(header :class "mb-6 sm:mb-8 flex flex-col sm:flex-row sm:items-center justify-between gap-3 sm:gap-4" (header :class "mb-6 sm:mb-8 flex flex-col sm:flex-row sm:items-center justify-between gap-3 sm:gap-4"
(div :class "space-y-1" (div :class "space-y-1"
(p :class "text-xs sm:text-sm text-stone-600" info)) (p :class "text-xs sm:text-sm text-stone-600" info))
@@ -124,7 +129,8 @@
;; Data-driven order rows (replaces Python loop) ;; Data-driven order rows (replaces Python loop)
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~order-rows-from-data (&key orders page total-pages next-url) (defcomp ~order-rows-from-data (&key (orders :as list?) (page :as number) (total-pages :as number)
(next-url :as string?))
(<> (<>
(map (lambda (o) (map (lambda (o)
(<> (<>
@@ -144,7 +150,7 @@
;; Data-driven order items (replaces Python loop) ;; Data-driven order items (replaces Python loop)
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~order-items-from-data (&key items) (defcomp ~order-items-from-data (&key (items :as list?))
(~order-items-panel (~order-items-panel
:items (<> (map (lambda (item) :items (<> (map (lambda (item)
(let* ((img (if (get item "product_image") (let* ((img (if (get item "product_image")
@@ -162,7 +168,7 @@
;; Data-driven calendar entries (replaces Python loop) ;; Data-driven calendar entries (replaces Python loop)
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~order-calendar-from-data (&key entries) (defcomp ~order-calendar-from-data (&key (entries :as list?))
(~order-calendar-section (~order-calendar-section
:items (<> (map (lambda (e) :items (<> (map (lambda (e)
(~order-calendar-entry (~order-calendar-entry
@@ -180,7 +186,7 @@
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
;; Status pill class mapping ;; Status pill class mapping
(defcomp ~order-status-pill-cls (&key status) (defcomp ~order-status-pill-cls (&key (status :as string?))
(let* ((sl (lower (or status "")))) (let* ((sl (lower (or status ""))))
(cond (cond
((= sl "paid") "border-emerald-300 bg-emerald-50 text-emerald-700") ((= sl "paid") "border-emerald-300 bg-emerald-50 text-emerald-700")
@@ -188,7 +194,7 @@
(true "border-stone-300 bg-stone-50 text-stone-700")))) (true "border-stone-300 bg-stone-50 text-stone-700"))))
;; Single order row pair (desktop + mobile) — takes serialized order data dict ;; Single order row pair (desktop + mobile) — takes serialized order data dict
(defcomp ~order-row-pair (&key order detail-url-prefix) (defcomp ~order-row-pair (&key (order :as dict) (detail-url-prefix :as string))
(let* ((status (or (get order "status") "pending")) (let* ((status (or (get order "status") "pending"))
(pill-base (~order-status-pill-cls :status status)) (pill-base (~order-status-pill-cls :status status))
(oid (str "#" (get order "id"))) (oid (str "#" (get order "id")))
@@ -207,7 +213,8 @@
:status status :url url)))) :status status :url url))))
;; Assembled orders list content ;; Assembled orders list content
(defcomp ~orders-list-content (&key orders page total-pages rows-url detail-url-prefix) (defcomp ~orders-list-content (&key (orders :as list) (page :as number) (total-pages :as number)
(rows-url :as string) (detail-url-prefix :as string))
(if (empty? orders) (if (empty? orders)
(~order-empty-state) (~order-empty-state)
(~order-table (~order-table
@@ -223,7 +230,7 @@
(~order-end-row)))))) (~order-end-row))))))
;; Assembled order detail content — replaces Python _order_main_sx ;; Assembled order detail content — replaces Python _order_main_sx
(defcomp ~order-detail-content (&key order calendar-entries) (defcomp ~order-detail-content (&key (order :as dict) (calendar-entries :as list?))
(let* ((items (get order "items"))) (let* ((items (get order "items")))
(~order-detail-panel (~order-detail-panel
:summary (~order-summary-card :summary (~order-summary-card
@@ -265,7 +272,8 @@
calendar-entries)))))) calendar-entries))))))
;; Assembled order detail filter — replaces Python _order_filter_sx ;; Assembled order detail filter — replaces Python _order_filter_sx
(defcomp ~order-detail-filter-content (&key order list-url recheck-url pay-url csrf) (defcomp ~order-detail-filter-content (&key (order :as dict) (list-url :as string) (recheck-url :as string)
(pay-url :as string) (csrf :as string))
(let* ((status (or (get order "status") "pending")) (let* ((status (or (get order "status") "pending"))
(created (or (get order "created_at_formatted") "\u2014"))) (created (or (get order "created_at_formatted") "\u2014")))
(~order-detail-filter (~order-detail-filter
@@ -280,7 +288,7 @@
;; Checkout return components ;; Checkout return components
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~checkout-return-header (&key status) (defcomp ~checkout-return-header (&key (status :as string))
(header :class "mb-6 sm:mb-8" (header :class "mb-6 sm:mb-8"
(h1 :class "text-xl sm:text-2xl md:text-3xl font-semibold tracking-tight" "Payment complete") (h1 :class "text-xl sm:text-2xl md:text-3xl font-semibold tracking-tight" "Payment complete")
(p :class "text-xs sm:text-sm text-stone-600" (p :class "text-xs sm:text-sm text-stone-600"
@@ -290,7 +298,9 @@
(div :class "max-w-full px-3 py-3 space-y-4" (div :class "max-w-full px-3 py-3 space-y-4"
(p :class "text-sm text-stone-600" "Order not found."))) (p :class "text-sm text-stone-600" "Order not found.")))
(defcomp ~checkout-return-ticket (&key name pill state type-name date-str code price) (defcomp ~checkout-return-ticket (&key (name :as string) (pill :as string) (state :as string)
(type-name :as string?) (date-str :as string) (code :as string?)
(price :as string))
(li :class "px-4 py-3 flex items-start justify-between text-sm" (li :class "px-4 py-3 flex items-start justify-between text-sm"
(div (div
(div :class "font-medium flex items-center gap-2" (div :class "font-medium flex items-center gap-2"
@@ -305,7 +315,7 @@
(h2 :class "text-base sm:text-lg font-semibold" "Tickets") (h2 :class "text-base sm:text-lg font-semibold" "Tickets")
(ul :class "divide-y divide-stone-200 rounded-2xl border border-stone-200 bg-white/80" items))) (ul :class "divide-y divide-stone-200 rounded-2xl border border-stone-200 bg-white/80" items)))
(defcomp ~checkout-return-failed (&key order-id) (defcomp ~checkout-return-failed (&key (order-id :as string?))
(div :class "rounded-lg border border-rose-200 bg-rose-50 p-4 text-sm text-rose-900" (div :class "rounded-lg border border-rose-200 bg-rose-50 p-4 text-sm text-rose-900"
(p :class "font-medium" "Payment failed") (p :class "font-medium" "Payment failed")
(p "Please try again or contact support." (p "Please try again or contact support."
@@ -329,10 +339,10 @@
(h1 :class "text-xl sm:text-2xl md:text-3xl font-semibold tracking-tight" "Checkout error") (h1 :class "text-xl sm:text-2xl md:text-3xl font-semibold tracking-tight" "Checkout error")
(p :class "text-xs sm:text-sm text-stone-600" "We tried to start your payment with SumUp but hit a problem."))) (p :class "text-xs sm:text-sm text-stone-600" "We tried to start your payment with SumUp but hit a problem.")))
(defcomp ~checkout-error-order-id (&key oid) (defcomp ~checkout-error-order-id (&key (oid :as string))
(p :class "text-xs text-rose-800/80" "Order ID: " (span :class "font-mono" oid))) (p :class "text-xs text-rose-800/80" "Order ID: " (span :class "font-mono" oid)))
(defcomp ~checkout-error-content (&key msg order back-url) (defcomp ~checkout-error-content (&key (msg :as string) order (back-url :as string))
(div :class "max-w-full px-3 py-3 space-y-4" (div :class "max-w-full px-3 py-3 space-y-4"
(div :class "rounded-2xl border border-rose-200 bg-rose-50/80 p-4 sm:p-6 text-sm text-rose-900 space-y-2" (div :class "rounded-2xl border border-rose-200 bg-rose-50/80 p-4 sm:p-6 text-sm text-rose-900 space-y-2"
(p :class "font-medium" "Something went wrong.") (p :class "font-medium" "Something went wrong.")

View File

@@ -1,4 +1,4 @@
(defcomp ~base-shell (&key title asset-url &rest children) (defcomp ~base-shell (&key (title :as string) (asset-url :as string) &rest children)
(<> (<>
(raw! "<!doctype html>") (raw! "<!doctype html>")
(html :lang "en" (html :lang "en"
@@ -23,13 +23,13 @@
;; <script>__sxResolve("id", "(resolved sx ...)")</script> ;; <script>__sxResolve("id", "(resolved sx ...)")</script>
;; --------------------------------------------------------------------------- ;; ---------------------------------------------------------------------------
(defcomp ~suspense (&key id fallback &rest children) (defcomp ~suspense (&key (id :as string) fallback &rest children)
(div :id (str "sx-suspense-" id) (div :id (str "sx-suspense-" id)
:data-suspense id :data-suspense id
:style "display:contents" :style "display:contents"
(if (not (empty? children)) children fallback))) (if (not (empty? children)) children fallback)))
(defcomp ~error-page (&key title message image asset-url) (defcomp ~error-page (&key (title :as string) (message :as string) (image :as string?) (asset-url :as string))
(~base-shell :title title :asset-url asset-url (~base-shell :title title :asset-url asset-url
(div :class "text-center p-8 max-w-lg mx-auto" (div :class "text-center p-8 max-w-lg mx-auto"
(div :class "font-bold text-2xl md:text-4xl text-red-500 mb-4" (div :class "font-bold text-2xl md:text-4xl text-red-500 mb-4"

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