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

host/engine: visible error/retry state for failed fetches + retry on network failure
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 30s
Details

Browse Source 
Two engine fixes in web/orchestration.sx (rebuilt into the WASM bytecode) plus the
blog CSS that surfaces them.

1. Retry on NETWORK failure, not just HTTP errors. The fetch error/catch path (the
   real offline / DNS / connection-refused case) previously dispatched
   sx:requestError and stopped — only a non-ok HTTP response with an empty body
   ever reached handle-retry. So "no connection" never recovered. Now the catch
   path calls handle-retry too, so an sx-retry element actually self-heals when the
   connection returns (the cap bounds the backoff interval, not the attempt count —
   it retries forever).

2. Visible failure state. On any failed/aborted fetch the engine adds an `.sx-error`
   class to the element (cleared, with the retry backoff reset, on the next
   success). Without it a stuck retry loop is invisible — the picker just sits
   "Loading…". The blog shell ships CSS so the relate picker shows "Connection
   problem — retrying…" / "offline, retrying…" on .sx-error.

Platform-wide: any sx-get/sx-post element benefits, not just the picker.

Tests: relate-picker.spec.js gains a 6th case — abort relate-options, assert
.sx-error appears, un-abort, assert it clears and the picker repopulates (proving
the retry loop is live). 6/6 browser + 272/272 conformance. WASM web stack rebuilt
(orchestration.sxbc + the static hs-* copies refreshed by the same build).

Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
This commit is contained in:
giles
2026-06-29 14:48:35 +00:00
parent bdc7e02fbc
commit db4809b01e
15 changed files with 657 additions and 252 deletions
Download Patch File Download Diff File Expand all files Collapse all files

11
lib/host/blog.sx
View File

@@ -450,7 +450,16 @@
(script :type "application/json" :data-sx-manifest "1" (script :type "application/json" :data-sx-manifest "1"
(raw! (unquote (host/static-manifest-json)))) (raw! (unquote (host/static-manifest-json))))
(script :src "/static/wasm/sx_browser.bc.wasm.js") (script :src "/static/wasm/sx_browser.bc.wasm.js")
(script :src "/static/wasm/sx-platform.js")) (script :src "/static/wasm/sx-platform.js")
;; Visible failure state for the SX engine's .sx-error class (added
;; on a failed/offline fetch, cleared on the next success). Without
;; it a stuck retry is invisible — the picker just sits "Loading…".
(style (raw! (unquote (str
".rp-more.sx-error{color:#b00}"
".rp-more.sx-error::after{content:\" — offline, retrying…\"}"
".relate-picker.sx-error .rp-results::before{"
"content:\"Connection problem — retrying…\";display:block;"
"padding:.5em;color:#b00;font-size:.9em}")))))
(body (body
;; sx-boost must be on a DESCENDANT of <body> (process-boosted ;; sx-boost must be on a DESCENDANT of <body> (process-boosted
;; queries [sx-boost] WITHIN the body, so it can't sit on body ;; queries [sx-boost] WITHIN the body, so it can't sit on body

16
lib/host/playwright/relate-picker.spec.js
View File

@@ -109,4 +109,20 @@ test.describe('relate picker', () => {
await expect.poll(() => page.locator(RELROWS).count(), { timeout: 12000 }).toBeGreaterThanOrEqual(1); await expect.poll(() => page.locator(RELROWS).count(), { timeout: 12000 }).toBeGreaterThanOrEqual(1);
await expect(page.locator(RELR)).toContainText('Picker Item'); await expect(page.locator(RELR)).toContainText('Picker Item');
}); });
test('a dropped relate-options fetch shows a visible error/retry state', async ({ page }) => {
// Simulate the connection dropping for the candidate endpoint. The engine's
// fetch rejects -> it marks .sx-error on the picker (and keeps retrying), so a
// stuck/offline picker is VISIBLE instead of an endless silent "Loading…".
await page.route('**/relate-options*', (route) => route.abort());
await loginTo(page, `/${HOST}/edit`);
await waitReady(page);
// the filter form's "load" fetch fails -> .sx-error lands on the picker form
await expect(page.locator(`${REL}.sx-error`)).toHaveCount(1, { timeout: 12000 });
// and recovery: once the endpoint works again, the next retry clears the error
// and populates (proves the retry loop is live, not a dead end).
await page.unroute('**/relate-options*');
await expect(page.locator(`${REL}.sx-error`)).toHaveCount(0, { timeout: 35000 });
await expect.poll(() => page.locator(RELROWS).count(), { timeout: 12000 }).toBeGreaterThan(0);
});
}); });

13
shared/static/wasm/sx-platform.js
View File

@@ -643,19 +643,6 @@
loadLibrary(entry.deps[i], loading); loadLibrary(entry.deps[i], loading);
} }
// Also eagerly load lazy-deps. Lazy symbol resolution (the _resolve-symbol
// hook) only fires on the VM GLOBAL_GET path, but source-loaded modules run
// their callbacks via the CEK, which raises "Undefined symbol" instead of
// lazy-loading. So when bytecode is unavailable (source fallback), the swap
// post-processing (hs-boot-subtree! / htmx-boot-subtree! in process-elements)
// would fail. Preload them to keep every symbol defined.
var lazyDeps = entry["lazy-deps"] || entry.lazyDeps;
if (lazyDeps) {
for (var li = 0; li < lazyDeps.length; li++) {
loadLibrary(lazyDeps[li], loading);
}
}
// Load entry point itself (boot.sx — not a library, just defines + init) // Load entry point itself (boot.sx — not a library, just defines + init)
loadBytecodeFile("sx/" + entry.file) || loadSxFile("sx/" + entry.file.replace(/\.sxbc$/, '.sx')); loadBytecodeFile("sx/" + entry.file) || loadSxFile("sx/" + entry.file.replace(/\.sxbc$/, '.sx'));

44
shared/static/wasm/sx/hs-compiler.sx
View File

@@ -226,6 +226,28 @@
value) value)
(list (quote set!) (hs-to-sx target) value))))))) (list (quote set!) (hs-to-sx target) value)))))))
(true (list (quote set!) (hs-to-sx target) value))))))) (true (list (quote set!) (hs-to-sx target) value)))))))
;; Throttle/debounce extraction state — module-level so they don't get
;; redefined on every emit-on call (which was causing JIT churn). Set
;; via _strip-throttle-debounce at the start of each emit-on, used in
;; the handler-build step inside scan-on.
(define _throttle-ms nil)
(define _debounce-ms nil)
(define
_strip-throttle-debounce
(fn
(lst)
(cond
((<= (len lst) 1) lst)
((= (first lst) :throttle)
(do
(set! _throttle-ms (nth lst 1))
(_strip-throttle-debounce (rest (rest lst)))))
((= (first lst) :debounce)
(do
(set! _debounce-ms (nth lst 1))
(_strip-throttle-debounce (rest (rest lst)))))
(true
(cons (first lst) (_strip-throttle-debounce (rest lst)))))))
(define (define
emit-on emit-on
(fn (fn
@@ -234,6 +256,8 @@
((parts (rest ast))) ((parts (rest ast)))
(let (let
((event-name (first parts))) ((event-name (first parts)))
(set! _throttle-ms nil)
(set! _debounce-ms nil)
(define (define
scan-on scan-on
(fn (fn
@@ -266,6 +290,13 @@
((wrapped-body (if catch-info (let ((var (make-symbol (nth catch-info 0))) (catch-body (hs-to-sx (nth catch-info 1)))) (if finally-info (list (quote let) (list (list (quote __hs-exc) nil) (list (quote __hs-reraise) false)) (list (quote do) (list (quote guard) (list var (list true (list (quote let) (list (list var (list (quote host-hs-normalize-exc) var))) (list (quote guard) (list (quote __inner-exc) (list true (list (quote do) (list (quote set!) (quote __hs-exc) (quote __inner-exc)) (list (quote set!) (quote __hs-reraise) true)))) catch-body)))) compiled-body) (hs-to-sx finally-info) (list (quote when) (quote __hs-reraise) (list (quote raise) (quote __hs-exc))))) (list (quote let) (list (list (quote __hs-exc) nil) (list (quote __hs-reraise) false)) (list (quote do) (list (quote guard) (list var (list true (list (quote let) (list (list var (list (quote host-hs-normalize-exc) var))) (list (quote guard) (list (quote __inner-exc) (list true (list (quote do) (list (quote set!) (quote __hs-exc) (quote __inner-exc)) (list (quote set!) (quote __hs-reraise) true)))) catch-body)))) compiled-body) (list (quote when) (quote __hs-reraise) (list (quote raise) (quote __hs-exc))))))) (if finally-info (list (quote do) compiled-body (hs-to-sx finally-info)) compiled-body)))) ((wrapped-body (if catch-info (let ((var (make-symbol (nth catch-info 0))) (catch-body (hs-to-sx (nth catch-info 1)))) (if finally-info (list (quote let) (list (list (quote __hs-exc) nil) (list (quote __hs-reraise) false)) (list (quote do) (list (quote guard) (list var (list true (list (quote let) (list (list var (list (quote host-hs-normalize-exc) var))) (list (quote guard) (list (quote __inner-exc) (list true (list (quote do) (list (quote set!) (quote __hs-exc) (quote __inner-exc)) (list (quote set!) (quote __hs-reraise) true)))) catch-body)))) compiled-body) (hs-to-sx finally-info) (list (quote when) (quote __hs-reraise) (list (quote raise) (quote __hs-exc))))) (list (quote let) (list (list (quote __hs-exc) nil) (list (quote __hs-reraise) false)) (list (quote do) (list (quote guard) (list var (list true (list (quote let) (list (list var (list (quote host-hs-normalize-exc) var))) (list (quote guard) (list (quote __inner-exc) (list true (list (quote do) (list (quote set!) (quote __hs-exc) (quote __inner-exc)) (list (quote set!) (quote __hs-reraise) true)))) catch-body)))) compiled-body) (list (quote when) (quote __hs-reraise) (list (quote raise) (quote __hs-exc))))))) (if finally-info (list (quote do) compiled-body (hs-to-sx finally-info)) compiled-body))))
(let (let
((handler (let ((uses-the-result? (fn (expr) (cond ((= expr (quote the-result)) true) ((list? expr) (some (fn (x) (uses-the-result? x)) expr)) (true false))))) (let ((base-handler (list (quote fn) (list (quote event)) (if (uses-the-result? wrapped-body) (list (quote let) (list (list (quote the-result) nil)) wrapped-body) wrapped-body)))) (if count-filter-info (let ((mn (get count-filter-info "min")) (mx (get count-filter-info "max"))) (list (quote let) (list (list (quote __hs-count) 0)) (list (quote fn) (list (quote event)) (list (quote begin) (list (quote set!) (quote __hs-count) (list (quote +) (quote __hs-count) 1)) (list (quote when) (if (= mx -1) (list (quote >=) (quote __hs-count) mn) (list (quote and) (list (quote >=) (quote __hs-count) mn) (list (quote <=) (quote __hs-count) mx))) (nth base-handler 2)))))) base-handler))))) ((handler (let ((uses-the-result? (fn (expr) (cond ((= expr (quote the-result)) true) ((list? expr) (some (fn (x) (uses-the-result? x)) expr)) (true false))))) (let ((base-handler (list (quote fn) (list (quote event)) (if (uses-the-result? wrapped-body) (list (quote let) (list (list (quote the-result) nil)) wrapped-body) wrapped-body)))) (if count-filter-info (let ((mn (get count-filter-info "min")) (mx (get count-filter-info "max"))) (list (quote let) (list (list (quote __hs-count) 0)) (list (quote fn) (list (quote event)) (list (quote begin) (list (quote set!) (quote __hs-count) (list (quote +) (quote __hs-count) 1)) (list (quote when) (if (= mx -1) (list (quote >=) (quote __hs-count) mn) (list (quote and) (list (quote >=) (quote __hs-count) mn) (list (quote <=) (quote __hs-count) mx))) (nth base-handler 2)))))) base-handler)))))
(let
((handler (cond
(_throttle-ms
(list (quote hs-throttle!) handler (hs-to-sx _throttle-ms)))
(_debounce-ms
(list (quote hs-debounce!) handler (hs-to-sx _debounce-ms)))
(true handler))))
(let (let
((on-call (if every? (list (quote hs-on-every) target event-name handler) (list (quote hs-on) target event-name handler)))) ((on-call (if every? (list (quote hs-on-every) target event-name handler) (list (quote hs-on) target event-name handler))))
(cond (cond
@@ -325,7 +356,7 @@
(first pair) (first pair)
handler)) handler))
or-sources))) or-sources)))
on-call))))))))))))) on-call))))))))))))))
((= (first items) :from) ((= (first items) :from)
(scan-on (scan-on
(rest (rest items)) (rest (rest items))
@@ -469,7 +500,7 @@
count-filter-info count-filter-info
elsewhere? elsewhere?
or-sources))))) or-sources)))))
(scan-on (rest parts) nil nil false nil nil nil nil nil false nil))))) (scan-on (_strip-throttle-debounce (rest parts)) nil nil false nil nil nil nil nil false nil)))))
(define (define
emit-send emit-send
(fn (fn
@@ -2490,6 +2521,15 @@
(quote fn) (quote fn)
(list (quote it)) (list (quote it))
(hs-to-sx body)))) (hs-to-sx body))))
((and (list? expr) (= (first expr) (quote attr)))
(list
(quote hs-attr-watch!)
(hs-to-sx (nth expr 2))
(nth expr 1)
(list
(quote fn)
(list (quote it))
(hs-to-sx body))))
(true nil)))) (true nil))))
((= head (quote init)) ((= head (quote init))
(list (list

4
shared/static/wasm/sx/hs-compiler.sxbc
View File

File diff suppressed because one or more lines are too long

31
shared/static/wasm/sx/hs-parser.sx
View File

@@ -1358,7 +1358,17 @@
cls cls
(first extra-classes) (first extra-classes)
tgt)) tgt))
((match-kw "for") ((and
(= (tp-type) "keyword") (= (tp-val) "for")
;; Only consume 'for' as a duration clause if the next
;; token is NOT '<ident> in ...' — that pattern is a
;; for-in loop, not a toggle duration.
(not
(and
(> (len tokens) (+ p 2))
(= (get (nth tokens (+ p 1)) "type") "ident")
(= (get (nth tokens (+ p 2)) "value") "in")))
(do (adv!) true))
(let (let
((dur (parse-expr))) ((dur (parse-expr)))
(list (quote toggle-class-for) cls tgt dur))) (list (quote toggle-class-for) cls tgt dur)))
@@ -3090,7 +3100,17 @@
(= (tp-val) "queue")) (= (tp-val) "queue"))
(do (adv!) (adv!))) (do (adv!) (adv!)))
(let (let
((every? (match-kw "every"))) ((every? (match-kw "every"))
(throttle-ms nil)
(debounce-ms nil))
;; 'throttled at <duration>' / 'debounced at <duration>'
;; — parsed as handler modifiers, captured as :throttle / :debounce parts.
(when (and (= (tp-type) "ident") (= (tp-val) "throttled"))
(adv!)
(when (match-kw "at") (set! throttle-ms (parse-expr))))
(when (and (= (tp-type) "ident") (= (tp-val) "debounced"))
(adv!)
(when (match-kw "at") (set! debounce-ms (parse-expr))))
(let (let
((having (if (or h-margin h-threshold) (dict "margin" h-margin "threshold" h-threshold) nil))) ((having (if (or h-margin h-threshold) (dict "margin" h-margin "threshold" h-threshold) nil)))
(let (let
@@ -3105,6 +3125,10 @@
(match-kw "end") (match-kw "end")
(let (let
((parts (list (quote on) event-name))) ((parts (list (quote on) event-name)))
(let
((parts (if throttle-ms (append parts (list :throttle throttle-ms)) parts)))
(let
((parts (if debounce-ms (append parts (list :debounce debounce-ms)) parts)))
(let (let
((parts (if every? (append parts (list :every true)) parts))) ((parts (if every? (append parts (list :every true)) parts)))
(let (let
@@ -3127,7 +3151,7 @@
((parts (if finally-clause (append parts (list :finally finally-clause)) parts))) ((parts (if finally-clause (append parts (list :finally finally-clause)) parts)))
(let (let
((parts (append parts (list (if (> (len event-vars) 0) (cons (quote do) (append (map (fn (nm) (list (quote ref) nm)) event-vars) (if (and (list? body) (= (first body) (quote do))) (rest body) (list body)))) body))))) ((parts (append parts (list (if (> (len event-vars) 0) (cons (quote do) (append (map (fn (nm) (list (quote ref) nm)) event-vars) (if (and (list? body) (= (first body) (quote do))) (rest body) (list body)))) body)))))
parts)))))))))))))))))))))))))) parts))))))))))))))))))))))))))))
(define (define
parse-init-feat parse-init-feat
(fn (fn
@@ -3177,6 +3201,7 @@
(or (or
(= (tp-type) "hat") (= (tp-type) "hat")
(= (tp-type) "local") (= (tp-type) "local")
(= (tp-type) "attr")
(and (= (tp-type) "keyword") (= (tp-val) "dom"))) (and (= (tp-type) "keyword") (= (tp-val) "dom")))
(let (let
((expr (parse-expr))) ((expr (parse-expr)))

4
shared/static/wasm/sx/hs-parser.sxbc
View File

File diff suppressed because one or more lines are too long

474
shared/static/wasm/sx/hs-runtime.sx
View File

@@ -12,6 +12,29 @@
;; Register an event listener. Returns unlisten function. ;; Register an event listener. Returns unlisten function.
;; (hs-on target event-name handler) → unlisten-fn ;; (hs-on target event-name handler) → unlisten-fn
(begin
(define _hs-config-log-all false)
(define _hs-log-captured (list))
(define
hs-set-log-all!
(fn (flag) (set! _hs-config-log-all (if flag true false))))
(define hs-get-log-captured (fn () _hs-log-captured))
(define
hs-clear-log-captured!
(fn () (begin (set! _hs-log-captured (list)) nil)))
(define
hs-log-event!
(fn
(msg)
(when
_hs-config-log-all
(begin
(set! _hs-log-captured (append _hs-log-captured (list msg)))
(host-call (host-global "console") "log" msg)
nil)))))
;; Run an initializer function immediately.
;; (hs-init thunk) — called at element boot time
(define (define
hs-each hs-each
(fn (fn
@@ -22,17 +45,52 @@
;; (hs-init thunk) — called at element boot time ;; (hs-init thunk) — called at element boot time
(define meta (host-new "Object")) (define meta (host-new "Object"))
;; Run an initializer function immediately.
;; (hs-init thunk) — called at element boot time
(define
hs-on-every
(fn (target event-name handler) (dom-listen target event-name handler)))
;; ── Async / timing ────────────────────────────────────────────── ;; ── Async / timing ──────────────────────────────────────────────
;; Wait for a duration in milliseconds. ;; Wait for a duration in milliseconds.
;; In hyperscript, wait is async-transparent — execution pauses. ;; In hyperscript, wait is async-transparent — execution pauses.
;; Here we use perform/IO suspension for true pause semantics. ;; Here we use perform/IO suspension for true pause semantics.
(define
hs-on-every
(fn (target event-name handler) (dom-listen target event-name handler)))
;; Throttle: drops events that arrive within the window. First event fires
;; immediately; subsequent events within `ms` of the previous fire are dropped.
;; Returns a wrapped handler suitable for hs-on / hs-on-every.
(define
hs-throttle!
(fn
(handler ms)
(let
((__hs-last-fire 0))
(fn
(event)
(let
((__hs-now (host-call (host-global "Date") "now")))
(when
(>= (- __hs-now __hs-last-fire) ms)
(set! __hs-last-fire __hs-now)
(handler event)))))))
;; Debounce: waits until `ms` has elapsed since the last event before firing.
;; In our synchronous test mock no time passes, so the timer fires immediately
;; via setTimeout(_, 0); the wrapped handler still gets called once per burst.
(define
hs-debounce!
(fn
(handler ms)
(let
((__hs-timer nil))
(fn
(event)
(when __hs-timer (host-call (host-global "window") "clearTimeout" __hs-timer))
(set! __hs-timer
(host-call (host-global "window") "setTimeout"
(host-new-function (list "ev") "return arguments[0](arguments[1]);")
ms handler event))))))
;; Wait for a DOM event on a target.
;; (hs-wait-for target event-name) — suspends until event fires
(define (define
_hs-on-caller _hs-on-caller
(let (let
@@ -45,8 +103,7 @@
(host-set! _ctx "meta" _m) (host-set! _ctx "meta" _m)
_ctx))) _ctx)))
;; Wait for a DOM event on a target. ;; Wait for CSS transitions/animations to settle on an element.
;; (hs-wait-for target event-name) — suspends until event fires
(define (define
hs-on hs-on
(fn (fn
@@ -66,14 +123,14 @@
(append prev (list unlisten))) (append prev (list unlisten)))
unlisten)))))) unlisten))))))
;; Wait for CSS transitions/animations to settle on an element. ;; ── Class manipulation ──────────────────────────────────────────
;; Toggle a single class on an element.
(define (define
hs-on-every hs-on-every
(fn (target event-name handler) (dom-listen target event-name handler))) (fn (target event-name handler) (dom-listen target event-name handler)))
;; ── Class manipulation ────────────────────────────────────────── ;; Toggle between two classes — exactly one is active at a time.
;; Toggle a single class on an element.
(define (define
hs-on-intersection-attach! hs-on-intersection-attach!
(fn (fn
@@ -89,7 +146,8 @@
(host-call observer "observe" target) (host-call observer "observe" target)
observer))))) observer)))))
;; Toggle between two classes — exactly one is active at a time. ;; Take a class from siblings — add to target, remove from others.
;; (hs-take! target cls) — like radio button class behavior
(define (define
hs-on-mutation-attach! hs-on-mutation-attach!
(fn (fn
@@ -110,19 +168,18 @@
(host-call observer "observe" target opts) (host-call observer "observe" target opts)
observer)))))) observer))))))
;; Take a class from siblings — add to target, remove from others.
;; (hs-take! target cls) — like radio button class behavior
(define hs-init (fn (thunk) (thunk)))
;; ── DOM insertion ─────────────────────────────────────────────── ;; ── DOM insertion ───────────────────────────────────────────────
;; Put content at a position relative to a target. ;; Put content at a position relative to a target.
;; pos: "into" | "before" | "after" ;; pos: "into" | "before" | "after"
(define hs-wait (fn (ms) (perform (list (quote io-sleep) ms)))) (define hs-init (fn (thunk) (thunk)))
;; ── Navigation / traversal ────────────────────────────────────── ;; ── Navigation / traversal ──────────────────────────────────────
;; Navigate to a URL. ;; Navigate to a URL.
(define hs-wait (fn (ms) (perform (list (quote io-sleep) ms))))
;; Find next sibling matching a selector (or any sibling).
(begin (begin
(define (define
hs-wait-for hs-wait-for
@@ -135,7 +192,7 @@
(target event-name timeout-ms) (target event-name timeout-ms)
(perform (list (quote io-wait-event) target event-name timeout-ms))))) (perform (list (quote io-wait-event) target event-name timeout-ms)))))
;; Find next sibling matching a selector (or any sibling). ;; Find previous sibling matching a selector.
(define (define
hs-settle hs-settle
(fn (fn
@@ -143,7 +200,7 @@
(hs-null-raise! target) (hs-null-raise! target)
(when (not (nil? target)) (perform (list (quote io-settle) target))))) (when (not (nil? target)) (perform (list (quote io-settle) target)))))
;; Find previous sibling matching a selector. ;; First element matching selector within a scope.
(define (define
hs-toggle-class! hs-toggle-class!
(fn (fn
@@ -153,7 +210,7 @@
(not (nil? target)) (not (nil? target))
(host-call (host-get target "classList") "toggle" cls)))) (host-call (host-get target "classList") "toggle" cls))))
;; First element matching selector within a scope. ;; Last element matching selector.
(define (define
hs-toggle-var-cycle! hs-toggle-var-cycle!
(fn (fn
@@ -175,7 +232,7 @@
var-name var-name
(if (= idx -1) (first values) (nth values (mod (+ idx 1) n)))))))) (if (= idx -1) (first values) (nth values (mod (+ idx 1) n))))))))
;; Last element matching selector. ;; First/last within a specific scope.
(define (define
hs-toggle-between! hs-toggle-between!
(fn (fn
@@ -188,7 +245,6 @@
(do (dom-remove-class target cls1) (dom-add-class target cls2)) (do (dom-remove-class target cls1) (dom-add-class target cls2))
(do (dom-remove-class target cls2) (dom-add-class target cls1)))))) (do (dom-remove-class target cls2) (dom-add-class target cls1))))))
;; First/last within a specific scope.
(define (define
hs-toggle-style! hs-toggle-style!
(fn (fn
@@ -212,6 +268,9 @@
(dom-set-style target prop "hidden") (dom-set-style target prop "hidden")
(dom-set-style target prop ""))))))) (dom-set-style target prop "")))))))
;; ── Iteration ───────────────────────────────────────────────────
;; Repeat a thunk N times.
(define (define
hs-toggle-style-between! hs-toggle-style-between!
(fn (fn
@@ -223,9 +282,7 @@
(dom-set-style target prop val2) (dom-set-style target prop val2)
(dom-set-style target prop val1))))) (dom-set-style target prop val1)))))
;; ── Iteration ─────────────────────────────────────────────────── ;; Repeat forever (until break — relies on exception/continuation).
;; Repeat a thunk N times.
(define (define
hs-toggle-style-cycle! hs-toggle-style-cycle!
(fn (fn
@@ -246,7 +303,10 @@
(true (find-next (rest remaining)))))) (true (find-next (rest remaining))))))
(dom-set-style target prop (find-next vals))))) (dom-set-style target prop (find-next vals)))))
;; Repeat forever (until break — relies on exception/continuation). ;; ── Fetch ───────────────────────────────────────────────────────
;; Fetch a URL, parse response according to format.
;; (hs-fetch url format) — format is "json" | "text" | "html"
(define (define
hs-take! hs-take!
(fn (fn
@@ -269,8 +329,7 @@
(when with-cls (dom-remove-class target with-cls)))) (when with-cls (dom-remove-class target with-cls))))
(let (let
((attr-val (if (> (len extra) 0) (first extra) nil)) ((attr-val (if (> (len extra) 0) (first extra) nil))
(with-val (with-val (if (> (len extra) 1) (nth extra 1) nil)))
(if (> (len extra) 1) (nth extra 1) nil)))
(do (do
(for-each (for-each
(fn (fn
@@ -287,10 +346,10 @@
(dom-set-attr target name attr-val) (dom-set-attr target name attr-val)
(dom-set-attr target name "")))))))) (dom-set-attr target name ""))))))))
;; ── Fetch ─────────────────────────────────────────────────────── ;; ── Type coercion ───────────────────────────────────────────────
;; Fetch a URL, parse response according to format. ;; Coerce a value to a type by name.
;; (hs-fetch url format) — format is "json" | "text" | "html" ;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc.
(begin (begin
(define (define
hs-element? hs-element?
@@ -447,10 +506,10 @@
(dom-insert-adjacent-html target "beforeend" value) (dom-insert-adjacent-html target "beforeend" value)
(hs-boot-subtree! target))))))))))) (hs-boot-subtree! target)))))))))))
;; ── Type coercion ─────────────────────────────────────────────── ;; ── Object creation ─────────────────────────────────────────────
;; Coerce a value to a type by name. ;; Make a new object of a given type.
;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc. ;; (hs-make type-name) — creates empty object/collection
(define (define
hs-add-to! hs-add-to!
(fn (fn
@@ -464,10 +523,11 @@
((hs-is-set? target) (do (host-call target "add" value) target)) ((hs-is-set? target) (do (host-call target "add" value) target))
(true (do (host-call target "push" value) target))))) (true (do (host-call target "push" value) target)))))
;; ── Object creation ───────────────────────────────────────────── ;; ── Behavior installation ───────────────────────────────────────
;; Make a new object of a given type. ;; Install a behavior on an element.
;; (hs-make type-name) — creates empty object/collection ;; A behavior is a function that takes (me ...params) and sets up features.
;; (hs-install behavior-fn me ...args)
(define (define
hs-remove-from! hs-remove-from!
(fn (fn
@@ -477,11 +537,10 @@
((hs-is-set? target) (do (host-call target "delete" value) target)) ((hs-is-set? target) (do (host-call target "delete" value) target))
(true (host-call target "splice" (host-call target "indexOf" value) 1))))) (true (host-call target "splice" (host-call target "indexOf" value) 1)))))
;; ── Behavior installation ─────────────────────────────────────── ;; ── Measurement ─────────────────────────────────────────────────
;; Install a behavior on an element. ;; Measure an element's bounding rect, store as local variables.
;; A behavior is a function that takes (me ...params) and sets up features. ;; Returns a dict with x, y, width, height, top, left, right, bottom.
;; (hs-install behavior-fn me ...args)
(define (define
hs-splice-at! hs-splice-at!
(fn (fn
@@ -494,10 +553,7 @@
((i (if (< idx 0) (+ n idx) idx))) ((i (if (< idx 0) (+ n idx) idx)))
(cond (cond
((or (< i 0) (>= i n)) target) ((or (< i 0) (>= i n)) target)
(true (true (concat (slice target 0 i) (slice target (+ i 1) n))))))
(concat
(slice target 0 i)
(slice target (+ i 1) n))))))
(do (do
(when (when
target target
@@ -508,10 +564,10 @@
(host-call target "splice" i 1)))) (host-call target "splice" i 1))))
target)))) target))))
;; ── Measurement ───────────────────────────────────────────────── ;; Return the current text selection as a string. In the browser this is
;; `window.getSelection().toString()`. In the mock test runner, a test
;; Measure an element's bounding rect, store as local variables. ;; setup stashes the desired selection text at `window.__test_selection`
;; Returns a dict with x, y, width, height, top, left, right, bottom. ;; and the fallback path returns that so tests can assert on the result.
(define (define
hs-index hs-index
(fn (fn
@@ -523,10 +579,11 @@
((string? obj) (nth obj key)) ((string? obj) (nth obj key))
(true (host-get obj key))))) (true (host-get obj key)))))
;; Return the current text selection as a string. In the browser this is
;; `window.getSelection().toString()`. In the mock test runner, a test ;; ── Transition ──────────────────────────────────────────────────
;; setup stashes the desired selection text at `window.__test_selection`
;; and the fallback path returns that so tests can assert on the result. ;; Transition a CSS property to a value, optionally with duration.
;; (hs-transition target prop value duration)
(define (define
hs-put-at! hs-put-at!
(fn (fn
@@ -548,11 +605,6 @@
((= pos "start") (host-call target "unshift" value))) ((= pos "start") (host-call target "unshift" value)))
target))))))) target)))))))
;; ── Transition ──────────────────────────────────────────────────
;; Transition a CSS property to a value, optionally with duration.
;; (hs-transition target prop value duration)
(define (define
hs-dict-without hs-dict-without
(fn (fn
@@ -589,6 +641,11 @@
((w (host-global "window"))) ((w (host-global "window")))
(if w (host-call w "prompt" msg) nil)))) (if w (host-call w "prompt" msg) nil))))
;; ── Transition ──────────────────────────────────────────────────
;; Transition a CSS property to a value, optionally with duration.
;; (hs-transition target prop value duration)
(define (define
hs-answer hs-answer
(fn (fn
@@ -597,11 +654,6 @@
((w (host-global "window"))) ((w (host-global "window")))
(if w (if (host-call w "confirm" msg) yes-val no-val) no-val)))) (if w (if (host-call w "confirm" msg) yes-val no-val) no-val))))
;; ── Transition ──────────────────────────────────────────────────
;; Transition a CSS property to a value, optionally with duration.
;; (hs-transition target prop value duration)
(define (define
hs-answer-alert hs-answer-alert
(fn (fn
@@ -662,6 +714,10 @@
(if (nil? sel) "" (host-call sel "toString" (list)))) (if (nil? sel) "" (host-call sel "toString" (list))))
stash))))) stash)))))
(define (define
hs-reset! hs-reset!
(fn (fn
@@ -708,10 +764,6 @@
(when default-val (dom-set-prop target "value" default-val))))) (when default-val (dom-set-prop target "value" default-val)))))
(true nil))))))) (true nil)))))))
(define (define
hs-next hs-next
(fn (fn
@@ -730,7 +782,8 @@
((dom-matches? el sel) el) ((dom-matches? el sel) el)
(true (find-next (dom-next-sibling el)))))) (true (find-next (dom-next-sibling el))))))
(find-next sibling))))) (find-next sibling)))))
;; ── Sandbox/test runtime additions ──────────────────────────────
;; Property access — dot notation and .length
(define (define
hs-previous hs-previous
(fn (fn
@@ -749,10 +802,9 @@
((dom-matches? el sel) el) ((dom-matches? el sel) el)
(true (find-prev (dom-get-prop el "previousElementSibling")))))) (true (find-prev (dom-get-prop el "previousElementSibling"))))))
(find-prev sibling))))) (find-prev sibling)))))
;; ── Sandbox/test runtime additions ──────────────────────────────
;; Property access — dot notation and .length
(define _hs-last-query-sel nil)
;; DOM query stub — sandbox returns empty list ;; DOM query stub — sandbox returns empty list
(define _hs-last-query-sel nil)
;; Method dispatch — obj.method(args)
(define (define
hs-null-raise! hs-null-raise!
(fn (fn
@@ -763,7 +815,9 @@
((msg (str "'" (or (host-get (host-global "window") "_hs_last_query_sel") "target") "' is null"))) ((msg (str "'" (or (host-get (host-global "window") "_hs_last_query_sel") "target") "' is null")))
(host-set! (host-global "window") "_hs_null_error" msg) (host-set! (host-global "window") "_hs_null_error" msg)
(guard (_null-e (true nil)) (raise msg)))))) (guard (_null-e (true nil)) (raise msg))))))
;; Method dispatch — obj.method(args)
;; ── 0.9.90 features ─────────────────────────────────────────────
;; beep! — debug logging, returns value unchanged
(define (define
hs-empty-raise! hs-empty-raise!
(fn (fn
@@ -777,9 +831,7 @@
((msg (str "'" (or (host-get (host-global "window") "_hs_last_query_sel") "target") "' is null"))) ((msg (str "'" (or (host-get (host-global "window") "_hs_last_query_sel") "target") "' is null")))
(host-set! (host-global "window") "_hs_null_error" msg) (host-set! (host-global "window") "_hs_null_error" msg)
(guard (_null-e (true nil)) (raise msg)))))) (guard (_null-e (true nil)) (raise msg))))))
;; Property-based is — check obj.key truthiness
;; ── 0.9.90 features ─────────────────────────────────────────────
;; beep! — debug logging, returns value unchanged
(define (define
hs-query-all-checked hs-query-all-checked
(fn (fn
@@ -787,14 +839,14 @@
(let (let
((result (hs-query-all sel))) ((result (hs-query-all sel)))
(do (hs-empty-raise! result) result)))) (do (hs-empty-raise! result) result))))
;; Property-based is — check obj.key truthiness ;; Array slicing (inclusive both ends)
(define (define
hs-dispatch! hs-dispatch!
(fn (fn
(target event detail) (target event detail)
(hs-null-raise! target) (hs-null-raise! target)
(when (not (nil? target)) (dom-dispatch target event detail)))) (when (not (nil? target)) (dom-dispatch target event detail))))
;; Array slicing (inclusive both ends) ;; Collection: sorted by
(define (define
hs-query-all hs-query-all
(fn (fn
@@ -802,7 +854,7 @@
(do (do
(host-set! (host-global "window") "_hs_last_query_sel" sel) (host-set! (host-global "window") "_hs_last_query_sel" sel)
(dom-query-all (dom-document) sel)))) (dom-query-all (dom-document) sel))))
;; Collection: sorted by ;; Collection: sorted by descending
(define (define
hs-query-all-in hs-query-all-in
(fn (fn
@@ -811,17 +863,17 @@
(nil? target) (nil? target)
(hs-query-all sel) (hs-query-all sel)
(host-call target "querySelectorAll" sel)))) (host-call target "querySelectorAll" sel))))
;; Collection: sorted by descending ;; Collection: split by
(define (define
hs-list-set hs-list-set
(fn (fn
(lst idx val) (lst idx val)
(append (take lst idx) (cons val (drop lst (+ idx 1)))))) (append (take lst idx) (cons val (drop lst (+ idx 1))))))
;; Collection: split by ;; Collection: joined by
(define (define
hs-to-number hs-to-number
(fn (v) (if (number? v) v (or (parse-number (str v)) 0)))) (fn (v) (if (number? v) v (or (parse-number (str v)) 0))))
;; Collection: joined by
(define (define
hs-query-first hs-query-first
(fn (fn
@@ -951,7 +1003,7 @@
((= (str ex) "hs-continue") (do-loop (rest remaining))) ((= (str ex) "hs-continue") (do-loop (rest remaining)))
(true (raise ex)))))))) (true (raise ex))))))))
(do-loop items)))) (do-loop items))))
;; Collection: joined by
(begin (begin
(define (define
hs-append hs-append
@@ -992,7 +1044,7 @@
(host-get value "outerHTML") (host-get value "outerHTML")
(str value)))) (str value))))
(true nil))))) (true nil)))))
;; Collection: joined by
(define (define
hs-sender hs-sender
(fn (fn
@@ -1084,6 +1136,7 @@
(hs-host-to-sx (perform (list "io-parse-json" raw)))) (hs-host-to-sx (perform (list "io-parse-json" raw))))
((= fmt "number") ((= fmt "number")
(hs-to-number (perform (list "io-parse-text" raw)))) (hs-to-number (perform (list "io-parse-text" raw))))
((= fmt "html") (perform (list "io-parse-html" raw)))
(true (perform (list "io-parse-text" raw))))))))) (true (perform (list "io-parse-text" raw)))))))))
(define hs-fetch (fn (url format) (hs-fetch-impl url format false))) (define hs-fetch (fn (url format) (hs-fetch-impl url format false)))
@@ -1623,14 +1676,10 @@
((ch (substring sel i (+ i 1)))) ((ch (substring sel i (+ i 1))))
(cond (cond
((= ch ".") ((= ch ".")
(do (do (flush!) (set! mode "class") (walk (+ i 1))))
(flush!)
(set! mode "class")
(walk (+ i 1))))
((= ch "#") ((= ch "#")
(do (flush!) (set! mode "id") (walk (+ i 1)))) (do (flush!) (set! mode "id") (walk (+ i 1))))
(true (true (do (set! cur (str cur ch)) (walk (+ i 1)))))))))
(do (set! cur (str cur ch)) (walk (+ i 1)))))))))
(walk 0) (walk 0)
(flush!) (flush!)
{:tag tag :classes classes :id id})))) {:tag tag :classes classes :id id}))))
@@ -1724,11 +1773,11 @@
(value type-name) (value type-name)
(if (nil? value) false (hs-type-check value type-name)))) (if (nil? value) false (hs-type-check value type-name))))
(define (define
hs-strict-eq hs-strict-eq
(fn (a b) (and (= (type-of a) (type-of b)) (= a b)))) (fn (a b) (and (= (type-of a) (type-of b)) (= a b))))
(define (define
hs-id= hs-id=
(fn (fn
@@ -1760,6 +1809,20 @@
((nil? suffix) false) ((nil? suffix) false)
(true (ends-with? (str s) (str suffix)))))) (true (ends-with? (str s) (str suffix))))))
(define
hs-attr-watch!
(fn
(target attr-name handler)
(let
((mo-class (host-get (host-global "window") "MutationObserver")))
(when
mo-class
(let
((cb (fn (records observer) (for-each (fn (rec) (when (= (host-get rec "attributeName") attr-name) (handler (host-call target "getAttribute" attr-name)))) records))))
(let
((mo (host-new "MutationObserver" cb)))
(host-call mo "observe" target {:attributeFilter (list attr-name) :attributes true})))))))
(define (define
hs-scoped-set! hs-scoped-set!
(fn (fn
@@ -1805,10 +1868,7 @@
((and (dict? a) (dict? b)) ((and (dict? a) (dict? b))
(let (let
((pos (host-call a "compareDocumentPosition" b))) ((pos (host-call a "compareDocumentPosition" b)))
(if (if (number? pos) (not (= 0 (mod (/ pos 4) 2))) false)))
(number? pos)
(not (= 0 (mod (/ pos 4) 2)))
false)))
(true (< (str a) (str b)))))) (true (< (str a) (str b))))))
(define (define
@@ -1929,10 +1989,7 @@
((and (dict? a) (dict? b)) ((and (dict? a) (dict? b))
(let (let
((pos (host-call a "compareDocumentPosition" b))) ((pos (host-call a "compareDocumentPosition" b)))
(if (if (number? pos) (not (= 0 (mod (/ pos 4) 2))) false)))
(number? pos)
(not (= 0 (mod (/ pos 4) 2)))
false)))
(true (< (str a) (str b)))))) (true (< (str a) (str b))))))
(define (define
@@ -1985,9 +2042,7 @@
(define (define
hs-morph-char hs-morph-char
(fn (fn (s p) (if (or (< p 0) (>= p (string-length s))) nil (nth s p))))
(s p)
(if (or (< p 0) (>= p (string-length s))) nil (nth s p))))
(define (define
hs-morph-index-from hs-morph-index-from
@@ -2015,10 +2070,7 @@
(q) (q)
(let (let
((c (hs-morph-char s q))) ((c (hs-morph-char s q)))
(if (if (and c (< (index-of stop c) 0)) (loop (+ q 1)) q))))
(and c (< (index-of stop c) 0))
(loop (+ q 1))
q))))
(let ((e (loop p))) (list (substring s p e) e)))) (let ((e (loop p))) (list (substring s p e) e))))
(define (define
@@ -2060,9 +2112,7 @@
(append (append
acc acc
(list (list
(list (list name (substring s (+ p4 1) close)))))))
name
(substring s (+ p4 1) close)))))))
((= c2 "'") ((= c2 "'")
(let (let
((close (hs-morph-index-from s "'" (+ p4 1)))) ((close (hs-morph-index-from s "'" (+ p4 1))))
@@ -2072,9 +2122,7 @@
(append (append
acc acc
(list (list
(list (list name (substring s (+ p4 1) close)))))))
name
(substring s (+ p4 1) close)))))))
(true (true
(let (let
((r2 (hs-morph-read-until s p4 " \t\n/>"))) ((r2 (hs-morph-read-until s p4 " \t\n/>")))
@@ -2158,9 +2206,7 @@
(for-each (for-each
(fn (fn
(c) (c)
(when (when (> (string-length c) 0) (dom-add-class el c)))
(> (string-length c) 0)
(dom-add-class el c)))
(split v " "))) (split v " ")))
((and keep-id (= n "id")) nil) ((and keep-id (= n "id")) nil)
(true (dom-set-attr el n v))))) (true (dom-set-attr el n v)))))
@@ -2261,8 +2307,7 @@
((parts (split resolved ":"))) ((parts (split resolved ":")))
(let (let
((prop (first parts)) ((prop (first parts))
(val (val (if (> (len parts) 1) (nth parts 1) nil)))
(if (> (len parts) 1) (nth parts 1) nil)))
(cond (cond
((and (not (= prop "display")) (not (= prop "opacity")) (not (= prop "visibility")) (not (= prop "hidden")) (not (= prop "class-hidden")) (not (= prop "class-invisible")) (not (= prop "class-opacity")) (not (= prop "details")) (not (= prop "dialog")) (dict-has? _hs-hide-strategies prop)) ((and (not (= prop "display")) (not (= prop "opacity")) (not (= prop "visibility")) (not (= prop "hidden")) (not (= prop "class-hidden")) (not (= prop "class-invisible")) (not (= prop "class-opacity")) (not (= prop "details")) (not (= prop "dialog")) (dict-has? _hs-hide-strategies prop))
(let (let
@@ -2302,8 +2347,7 @@
((parts (split resolved ":"))) ((parts (split resolved ":")))
(let (let
((prop (first parts)) ((prop (first parts))
(val (val (if (> (len parts) 1) (nth parts 1) nil)))
(if (> (len parts) 1) (nth parts 1) nil)))
(cond (cond
((and (not (= prop "display")) (not (= prop "opacity")) (not (= prop "visibility")) (not (= prop "hidden")) (not (= prop "class-hidden")) (not (= prop "class-invisible")) (not (= prop "class-opacity")) (not (= prop "details")) (not (= prop "dialog")) (dict-has? _hs-hide-strategies prop)) ((and (not (= prop "display")) (not (= prop "opacity")) (not (= prop "visibility")) (not (= prop "hidden")) (not (= prop "class-hidden")) (not (= prop "class-invisible")) (not (= prop "class-opacity")) (not (= prop "details")) (not (= prop "dialog")) (dict-has? _hs-hide-strategies prop))
(let (let
@@ -2408,14 +2452,10 @@
(if (if
(= depth 1) (= depth 1)
j j
(find-close (find-close (+ j 1) (- depth 1)))
(+ j 1)
(- depth 1)))
(if (if
(= (nth raw j) "{") (= (nth raw j) "{")
(find-close (find-close (+ j 1) (+ depth 1))
(+ j 1)
(+ depth 1))
(find-close (+ j 1) depth)))))) (find-close (+ j 1) depth))))))
(let (let
((close (find-close start 1))) ((close (find-close start 1)))
@@ -2526,10 +2566,7 @@
(if (if
(= (len lst) 0) (= (len lst) 0)
-1 -1
(if (if (= (first lst) item) i (idx-loop (rest lst) (+ i 1))))))
(= (first lst) item)
i
(idx-loop (rest lst) (+ i 1))))))
(idx-loop obj 0))) (idx-loop obj 0)))
(true (true
(let (let
@@ -2621,8 +2658,7 @@
(cond (cond
((= end "hs-pick-end") n) ((= end "hs-pick-end") n)
((= end "hs-pick-start") 0) ((= end "hs-pick-start") 0)
((and (number? end) (< end 0)) ((and (number? end) (< end 0)) (max 0 (+ n end)))
(max 0 (+ n end)))
(true end)))) (true end))))
(cond (cond
((string? col) (slice col s e)) ((string? col) (slice col s e))
@@ -2802,6 +2838,8 @@
hs-sorted-by-desc hs-sorted-by-desc
(fn (col key-fn) (reverse (hs-sorted-by col key-fn)))) (fn (col key-fn) (reverse (hs-sorted-by col key-fn))))
;; ── SourceInfo API ────────────────────────────────────────────────
(define (define
hs-dom-has-var? hs-dom-has-var?
(fn (fn
@@ -2821,8 +2859,6 @@
((store (host-get el "__hs_vars"))) ((store (host-get el "__hs_vars")))
(if (nil? store) nil (host-get store name))))) (if (nil? store) nil (host-get store name)))))
;; ── SourceInfo API ────────────────────────────────────────────────
(define (define
hs-dom-set-var-raw! hs-dom-set-var-raw!
(fn (fn
@@ -2913,7 +2949,12 @@
(define (define
hs-null-error! hs-null-error!
(fn (selector) (raise (str "'" selector "' is null")))) (fn
(selector)
(let
((msg (str "'" selector "' is null")))
(host-set! (host-global "window") "_hs_null_error" msg)
(guard (_null-e (true nil)) (raise msg)))))
(define (define
hs-named-target hs-named-target
@@ -2933,9 +2974,7 @@
((results (hs-query-all selector))) ((results (hs-query-all selector)))
(if (if
(and (and
(or (or (nil? results) (and (list? results) (= (len results) 0)))
(nil? results)
(and (list? results) (= (len results) 0)))
(string? selector) (string? selector)
(> (len selector) 0) (> (len selector) 0)
(= (substring selector 0 1) "#")) (= (substring selector 0 1) "#"))
@@ -3203,97 +3242,112 @@
(define hs-token-op? (fn (tok) (dict-get tok :op))) (define hs-token-op? (fn (tok) (dict-get tok :op)))
;; ── WebSocket / socket feature ───────────────────────────────────
(define (define
hs-try-json-parse hs-try-json-parse
(fn (data) (if (string? data) (guard (_e nil) (json-parse data)) nil))) (fn (s) (host-call (host-global "JSON") "parse" s)))
(define
hs-socket-normalise-url
(fn
(url)
(if
(or (starts-with? url "ws://") (starts-with? url "wss://"))
url
(let
((proto (host-get (host-global "location") "protocol"))
(host-str (host-get (host-global "location") "host")))
(let
((scheme (if (= proto "https:") "wss://" "ws://")))
(str scheme host-str url))))))
(define
hs-socket-bind-name!
(fn
(name-path wrapper)
(let
((win (host-global "window")))
(if
(= (len name-path) 1)
(host-set! win (first name-path) wrapper)
(do
(when
(nil? (host-get win (first name-path)))
(host-set! win (first name-path) (host-new "Object")))
(host-set!
(host-get win (first name-path))
(nth name-path 1)
wrapper))))))
(define (define
hs-socket-resolve-rpc! hs-socket-resolve-rpc!
(fn (fn
(wrapper data) (wrapper msg)
(let (let
((iid (host-get data "iid"))) ((pending (host-get wrapper "pending")) (iid (host-get msg "iid")))
(when
(not (nil? iid))
(let (let
((pending (host-get wrapper "_pending"))) ((resolver (host-get pending iid)))
(when (when
(not (nil? pending)) (not (nil? resolver))
(let
((entry (host-get pending iid)))
(when
(not (nil? entry))
(host-set! pending iid nil)
(if (if
(not (nil? (host-get data "throw"))) (not (nil? (host-get msg "return")))
(host-call-fn (host-call resolver "resolve" (host-get msg "return"))
(host-get entry "reject") (host-call resolver "reject" (host-get msg "throw")))
(list (host-get data "throw"))) (host-set! pending iid nil))))))
(host-call-fn
(host-get entry "resolve")
(list (host-get data "return"))))))))))))
(define (define
hs-socket-register! hs-socket-register!
(fn (fn
(name-path url timeout on-message-handler json?) (name-path url timeout-ms handler json?)
(let (let
((norm-url (hs-socket-normalise-url url))) ((ws-url (cond ((or (starts-with? url "ws://") (starts-with? url "wss://")) url) (true (let ((proto (host-get (host-global "location") "protocol")) (h (host-get (host-global "location") "host"))) (str (if (= proto "https:") "wss:" "ws:") "//" h url))))))
(let
((ws (host-new "WebSocket" ws-url)))
(let (let
((wrapper (host-new "Object"))) ((wrapper (host-new "Object")))
(do (host-set! wrapper "raw" ws)
(host-set! wrapper "_url" norm-url) (host-set! wrapper "url" ws-url)
(host-set! wrapper "_timeout" (if (nil? timeout) 0 timeout)) (host-set! wrapper "timeout" timeout-ms)
(host-set! wrapper "_pending" (host-new "Object")) (host-set! wrapper "pending" (host-new "Object"))
(host-set! wrapper "_closed" false) (host-set! wrapper "handler" handler)
(host-set! wrapper "json?" json?)
(host-set! wrapper "closed?" false)
(host-set! wrapper "closedFlag" nil)
(let (let
((ws (host-new "WebSocket" norm-url))) ((proxy-factory (host-global "_hs_make_rpc_proxy")))
(do (when
(host-set! wrapper "_ws" ws) proxy-factory
(let (host-set!
((msg-handler (host-callback (fn (evt) (do (let ((parsed (hs-try-json-parse (host-get evt "data")))) (when (and (not (nil? parsed)) (not (nil? (host-get parsed "iid")))) (hs-socket-resolve-rpc! wrapper parsed))) (when (not (nil? on-message-handler)) (if json? (let ((data (hs-try-json-parse (host-get evt "data")))) (when (not (nil? data)) (on-message-handler data))) (on-message-handler evt)))))))) wrapper
(do "rpc"
(host-set! ws "onmessage" msg-handler) (host-call proxy-factory "call" nil wrapper))))
(host-set! wrapper "_onmessage_handler" msg-handler)
(host-set! (host-set!
ws ws
"onclose" "onmessage"
(host-callback (host-callback
(fn (e) (host-set! wrapper "_closed" true)))) (fn
(host-call-fn (event)
(host-global "_hsSetupSocket") (let
(list wrapper)) ((data (host-get event "data")))
(hs-socket-bind-name! name-path wrapper) (let
wrapper))))))))) ((parsed (hs-try-json-parse data)))
(cond
((and (not (nil? parsed)) (not (nil? (host-get parsed "iid"))))
(hs-socket-resolve-rpc! wrapper parsed))
((not (nil? handler))
(if
json?
(if
(not (nil? parsed))
(handler parsed)
(error "Received non-JSON message"))
(handler event)))))))))
(host-call
ws
"addEventListener"
"close"
(host-callback
(fn
(evt)
(host-set! wrapper "closedFlag" "1"))))
(host-set!
wrapper
"dispatchEvent"
(host-callback
(fn
(evt)
(let
((payload (host-new "Object")))
(host-set! payload "type" (host-get evt "type"))
(host-call
(host-get wrapper "raw")
"send"
(host-call
(host-global "JSON")
"stringify"
payload))))))
(define
bind-path!
(fn
(obj path)
(if
(= (len path) 1)
(host-set! obj (first path) wrapper)
(let
((key (first path)) (rest-path (rest path)))
(let
((next (or (host-get obj key) (host-new "Object"))))
(host-set! obj key next)
(bind-path! next rest-path))))))
(bind-path! (host-global "window") name-path)
wrapper)))))

4
shared/static/wasm/sx/hs-runtime.sxbc
View File

File diff suppressed because one or more lines are too long

226
shared/static/wasm/sx/hs-tokenizer.sx
View File

@@ -856,3 +856,229 @@
(scan-template!) (scan-template!)
(t-emit! "eof" nil) (t-emit! "eof" nil)
tokens))) tokens)))
;; ── Stream wrapper for upstream-style stateful tokenizer API ───────────────
;;
;; Upstream _hyperscript exposes a Tokens object with cursor + follow-set
;; semantics on _hyperscript.internals.tokenizer. Our hs-tokenize returns a
;; flat list; the stream wrapper adds the stateful operations.
;;
;; Type names map ours → upstream's (e.g. "ident" → "IDENTIFIER").
(define
hs-stream-type-map
(fn
(t)
(cond
((= t "ident") "IDENTIFIER")
((= t "number") "NUMBER")
((= t "string") "STRING")
((= t "class") "CLASS_REF")
((= t "id") "ID_REF")
((= t "attr") "ATTRIBUTE_REF")
((= t "style") "STYLE_REF")
((= t "whitespace") "WHITESPACE")
((= t "op") "OPERATOR")
((= t "eof") "EOF")
(true (upcase t)))))
;; Create a stream from a source string.
;; Returns a dict — mutable via dict-set!.
(define
hs-stream
(fn
(src)
{:tokens (hs-tokenize src) :pos 0 :follows (list) :last-match nil :last-ws nil}))
;; Skip whitespace tokens, advancing pos to the next non-WS token.
;; Captures the last skipped whitespace value into :last-ws.
(define
hs-stream-skip-ws!
(fn
(s)
(let
((tokens (get s :tokens)))
(define
loop
(fn
()
(let
((p (get s :pos)))
(when
(and (< p (len tokens))
(= (get (nth tokens p) :type) "whitespace"))
(do
(dict-set! s :last-ws (get (nth tokens p) :value))
(dict-set! s :pos (+ p 1))
(loop))))))
(loop))))
;; Current token (after skipping whitespace).
(define
hs-stream-current
(fn
(s)
(do
(hs-stream-skip-ws! s)
(let
((tokens (get s :tokens)) (p (get s :pos)))
(if (< p (len tokens)) (nth tokens p) nil)))))
;; Returns the current token if its value matches; advances and updates
;; :last-match. Returns nil otherwise (no advance).
;; Honors the follow set: tokens whose value is in :follows do NOT match.
(define
hs-stream-match
(fn
(s value)
(let
((cur (hs-stream-current s)))
(cond
((nil? cur) nil)
((some (fn (f) (= f value)) (get s :follows)) nil)
((= (get cur :value) value)
(do
(dict-set! s :pos (+ (get s :pos) 1))
(dict-set! s :last-match cur)
cur))
(true nil)))))
;; Match by upstream-style type name. Accepts any number of allowed types.
(define
hs-stream-match-type
(fn
(s &rest types)
(let
((cur (hs-stream-current s)))
(cond
((nil? cur) nil)
((some (fn (t) (= (hs-stream-type-map (get cur :type)) t)) types)
(do
(dict-set! s :pos (+ (get s :pos) 1))
(dict-set! s :last-match cur)
cur))
(true nil)))))
;; Match if value is one of the given names.
(define
hs-stream-match-any
(fn
(s &rest names)
(let
((cur (hs-stream-current s)))
(cond
((nil? cur) nil)
((some (fn (n) (= (get cur :value) n)) names)
(do
(dict-set! s :pos (+ (get s :pos) 1))
(dict-set! s :last-match cur)
cur))
(true nil)))))
;; Match an op token whose value is in the list.
(define
hs-stream-match-any-op
(fn
(s &rest ops)
(let
((cur (hs-stream-current s)))
(cond
((nil? cur) nil)
((and (= (get cur :type) "op")
(some (fn (o) (= (get cur :value) o)) ops))
(do
(dict-set! s :pos (+ (get s :pos) 1))
(dict-set! s :last-match cur)
cur))
(true nil)))))
;; Peek N non-WS tokens ahead. Returns the token if its value matches; nil otherwise.
(define
hs-stream-peek
(fn
(s value offset)
(let
((tokens (get s :tokens)))
(define
skip-n-non-ws
(fn
(p remaining)
(cond
((>= p (len tokens)) -1)
((= (get (nth tokens p) :type) "whitespace")
(skip-n-non-ws (+ p 1) remaining))
((= remaining 0) p)
(true (skip-n-non-ws (+ p 1) (- remaining 1))))))
(let
((p (skip-n-non-ws (get s :pos) offset)))
(if (and (>= p 0) (< p (len tokens))
(= (get (nth tokens p) :value) value))
(nth tokens p)
nil)))))
;; Consume tokens until one whose value matches the marker. Returns
;; the consumed list (excluding the marker). Marker becomes current.
(define
hs-stream-consume-until
(fn
(s marker)
(let
((tokens (get s :tokens)) (out (list)))
(define
loop
(fn
(acc)
(let
((p (get s :pos)))
(cond
((>= p (len tokens)) acc)
((= (get (nth tokens p) :value) marker) acc)
(true
(do
(dict-set! s :pos (+ p 1))
(loop (append acc (list (nth tokens p))))))))))
(loop out))))
;; Consume until the next whitespace token; returns the consumed list.
(define
hs-stream-consume-until-ws
(fn
(s)
(let
((tokens (get s :tokens)))
(define
loop
(fn
(acc)
(let
((p (get s :pos)))
(cond
((>= p (len tokens)) acc)
((= (get (nth tokens p) :type) "whitespace") acc)
(true
(do
(dict-set! s :pos (+ p 1))
(loop (append acc (list (nth tokens p))))))))))
(loop (list)))))
;; Follow-set management.
(define hs-stream-push-follow! (fn (s v) (dict-set! s :follows (cons v (get s :follows)))))
(define
hs-stream-pop-follow!
(fn (s) (let ((f (get s :follows))) (when (> (len f) 0) (dict-set! s :follows (rest f))))))
(define
hs-stream-push-follows!
(fn (s vs) (for-each (fn (v) (hs-stream-push-follow! s v)) vs)))
(define
hs-stream-pop-follows!
(fn (s n) (when (> n 0) (do (hs-stream-pop-follow! s) (hs-stream-pop-follows! s (- n 1))))))
(define
hs-stream-clear-follows!
(fn (s) (let ((saved (get s :follows))) (do (dict-set! s :follows (list)) saved))))
(define
hs-stream-restore-follows!
(fn (s saved) (dict-set! s :follows saved)))
;; Last-consumed token / whitespace.
(define hs-stream-last-match (fn (s) (get s :last-match)))
(define hs-stream-last-ws (fn (s) (get s :last-ws)))

4
shared/static/wasm/sx/hs-tokenizer.sxbc
View File

File diff suppressed because one or more lines are too long

26
shared/static/wasm/sx/module-manifest.json
View File

@@ -951,7 +951,26 @@
"hs-keywords", "hs-keywords",
"hs-keyword?", "hs-keyword?",
"hs-tokenize", "hs-tokenize",
"hs-tokenize-template" "hs-tokenize-template",
"hs-stream-type-map",
"hs-stream",
"hs-stream-skip-ws!",
"hs-stream-current",
"hs-stream-match",
"hs-stream-match-type",
"hs-stream-match-any",
"hs-stream-match-any-op",
"hs-stream-peek",
"hs-stream-consume-until",
"hs-stream-consume-until-ws",
"hs-stream-push-follow!",
"hs-stream-pop-follow!",
"hs-stream-push-follows!",
"hs-stream-pop-follows!",
"hs-stream-clear-follows!",
"hs-stream-restore-follows!",
"hs-stream-last-match",
"hs-stream-last-ws"
] ]
}, },
"hs-parser": { "hs-parser": {
@@ -989,6 +1008,8 @@
"hs-each", "hs-each",
"meta", "meta",
"hs-on-every", "hs-on-every",
"hs-throttle!",
"hs-debounce!",
"_hs-on-caller", "_hs-on-caller",
"hs-on", "hs-on",
"hs-on-every", "hs-on-every",
@@ -1067,6 +1088,7 @@
"hs-eq-ignore-case", "hs-eq-ignore-case",
"hs-starts-with?", "hs-starts-with?",
"hs-ends-with?", "hs-ends-with?",
"hs-attr-watch!",
"hs-scoped-set!", "hs-scoped-set!",
"hs-scoped-get", "hs-scoped-get",
"hs-precedes?", "hs-precedes?",
@@ -1156,8 +1178,6 @@
"hs-token-value", "hs-token-value",
"hs-token-op?", "hs-token-op?",
"hs-try-json-parse", "hs-try-json-parse",
"hs-socket-normalise-url",
"hs-socket-bind-name!",
"hs-socket-resolve-rpc!", "hs-socket-resolve-rpc!",
"hs-socket-register!" "hs-socket-register!"
] ]

16
shared/static/wasm/sx/orchestration.sx
View File

@@ -223,6 +223,9 @@
el el
"sx:responseError" "sx:responseError"
(dict "status" status "text" text)) (dict "status" status "text" text))
;; visible failure state (CSS hooks .sx-error); cleared on
;; the next success in handle-fetch-success.
(dom-add-class el "sx-error")
(if (if
(and text (> (len text) 0)) (and text (> (len text) 0))
(handle-fetch-success (handle-fetch-success
@@ -260,7 +263,14 @@
final-url final-url
" — " " — "
err)) err))
(dom-dispatch el "sx:requestError" (dict "error" err)))))))))))) (dom-dispatch el "sx:requestError" (dict "error" err))
;; A network failure (offline, DNS, connection refused)
;; rejects the fetch — it never reaches the not-ok branch.
;; Mark the visible error state AND retry here too, so an
;; sx-retry element actually recovers when the connection
;; returns (previously only an empty HTTP error retried).
(dom-add-class el "sx-error")
(handle-retry el verb method final-url extraParams)))))))))))
(define (define
handle-fetch-success handle-fetch-success
:effects (mutation io) :effects (mutation io)
@@ -273,6 +283,10 @@
(text :as string)) (text :as string))
(let (let
((resp-headers (process-response-headers get-header))) ((resp-headers (process-response-headers get-header)))
;; a successful response clears any visible error state + resets the
;; retry backoff so the next failure starts fresh.
(dom-remove-class el "sx-error")
(dom-remove-attr el "data-sx-retry-ms")
(dispatch-trigger-events el (get resp-headers "trigger")) (dispatch-trigger-events el (get resp-headers "trigger"))
(process-cache-directives el resp-headers text) (process-cache-directives el resp-headers text)
(cond (cond

4
shared/static/wasm/sx/orchestration.sxbc
View File

File diff suppressed because one or more lines are too long

16
web/orchestration.sx
View File

@@ -223,6 +223,9 @@
el el
"sx:responseError" "sx:responseError"
(dict "status" status "text" text)) (dict "status" status "text" text))
;; visible failure state (CSS hooks .sx-error); cleared on
;; the next success in handle-fetch-success.
(dom-add-class el "sx-error")
(if (if
(and text (> (len text) 0)) (and text (> (len text) 0))
(handle-fetch-success (handle-fetch-success
@@ -260,7 +263,14 @@
final-url final-url
" — " " — "
err)) err))
(dom-dispatch el "sx:requestError" (dict "error" err)))))))))))) (dom-dispatch el "sx:requestError" (dict "error" err))
;; A network failure (offline, DNS, connection refused)
;; rejects the fetch — it never reaches the not-ok branch.
;; Mark the visible error state AND retry here too, so an
;; sx-retry element actually recovers when the connection
;; returns (previously only an empty HTTP error retried).
(dom-add-class el "sx-error")
(handle-retry el verb method final-url extraParams)))))))))))
(define (define
handle-fetch-success handle-fetch-success
:effects (mutation io) :effects (mutation io)
@@ -273,6 +283,10 @@
(text :as string)) (text :as string))
(let (let
((resp-headers (process-response-headers get-header))) ((resp-headers (process-response-headers get-header)))
;; a successful response clears any visible error state + resets the
;; retry backoff so the next failure starts fresh.
(dom-remove-class el "sx-error")
(dom-remove-attr el "data-sx-retry-ms")
(dispatch-trigger-events el (get resp-headers "trigger")) (dispatch-trigger-events el (get resp-headers "trigger"))
(process-cache-directives el resp-headers text) (process-cache-directives el resp-headers text)
(cond (cond