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

HS: intersection observer mock + on intersection (+3 tests)

Browse Source 
Applied from worktree-agent-ad6e17cbc4ea0c94b (commit 0a0fe314)
with manual re-apply onto post-cluster-26 HEAD:

- Parser: parse-on-feat collects `having margin X threshold Y`
  clauses between `from X` and the body; packs them into a
  `:having {"margin" M "threshold" T}` dict on the parts list.
- Compiler: scan-on threads a new `having-info` parameter through
  all recursions; when event-name is "intersection", wraps the
  hs-on call with `(do on-call (hs-on-intersection-attach! target
  margin threshold))`.
- Runtime: hs-on-intersection-attach! constructs an
  IntersectionObserver with {rootMargin, threshold} options and a
  callback that dispatches an "intersection" DOM event carrying
  {intersecting, entry} detail.
- Runner: HsIntersectionObserver mock fires the callback
  synchronously on observe() with isIntersecting=true so handlers
  run during activation; ignores margin/threshold (tests assert
  only that the handler fires).

Suite hs-upstream-on: 33/70 -> 36/70 (on intersection: 0/3 -> 3/3).
Smoke 0-195 unchanged at 165/195.
This commit is contained in:
giles
2026-04-24 10:44:01 +00:00
parent cee9ae7f22
commit 0c31dd2735
7 changed files with 350 additions and 213 deletions
Download Patch File Download Diff File Expand all files Collapse all files

82
lib/hyperscript/compiler.sx
View File

@@ -158,7 +158,13 @@
(define (define
scan-on scan-on
(fn (fn
(items source filter every? catch-info finally-info) (items
source
filter
every?
catch-info
finally-info
having-info)
(cond (cond
((<= (len items) 1) ((<= (len items) 1)
(let (let
@@ -174,33 +180,28 @@
(let (let
((compiled-body (if (> (len event-refs) 0) (let ((bindings (map (fn (r) (let ((name (nth r 1))) (list (make-symbol name) (list (quote host-get) (list (quote host-get) (quote event) "detail") name)))) event-refs))) (list (quote let) bindings raw-compiled)) raw-compiled))) ((compiled-body (if (> (len event-refs) 0) (let ((bindings (map (fn (r) (let ((name (nth r 1))) (list (make-symbol name) (list (quote host-get) (list (quote host-get) (quote event) "detail") name)))) event-refs))) (list (quote let) bindings raw-compiled)) raw-compiled)))
(let (let
((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 do) (list (quote guard) (list var (list true catch-body)) compiled-body) (hs-to-sx finally-info)) (list (quote guard) (list var (list true catch-body)) compiled-body))) (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 do) (list (quote guard) (list var (list true catch-body)) compiled-body) (hs-to-sx finally-info)) (list (quote guard) (list var (list true catch-body)) compiled-body))) (if finally-info (list (quote do) compiled-body (hs-to-sx finally-info)) compiled-body))))
(handler (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))))) (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)))))
((uses-the-result? (fn (expr) (cond ((= expr (quote the-result)) true) ((list? expr) (some (fn (x) (uses-the-result? x)) expr)) (true false))))) (let
((on-call (if every? (list (quote hs-on-every) target event-name handler) (list (quote hs-on) target event-name handler))))
(if
(= event-name "intersection")
(list (list
(quote fn) (quote do)
(list (quote event)) on-call
(if (list
(uses-the-result? wrapped-body) (quote hs-on-intersection-attach!)
(list target
(quote let) (if
(list having-info
(list (quote the-result) nil)) (get having-info "margin")
wrapped-body) nil)
wrapped-body))))) (if
(if having-info
every? (get having-info "threshold")
(list nil)))
(quote hs-on-every) on-call)))))))))))
target
event-name
handler)
(list
(quote hs-on)
target
event-name
handler))))))))))
((= (first items) :from) ((= (first items) :from)
(scan-on (scan-on
(rest (rest items)) (rest (rest items))
@@ -208,7 +209,8 @@
filter filter
every? every?
catch-info catch-info
finally-info)) finally-info
having-info))
((= (first items) :filter) ((= (first items) :filter)
(scan-on (scan-on
(rest (rest items)) (rest (rest items))
@@ -216,7 +218,8 @@
(nth items 1) (nth items 1)
every? every?
catch-info catch-info
finally-info)) finally-info
having-info))
((= (first items) :every) ((= (first items) :every)
(scan-on (scan-on
(rest (rest items)) (rest (rest items))
@@ -224,7 +227,8 @@
filter filter
true true
catch-info catch-info
finally-info)) finally-info
having-info))
((= (first items) :catch) ((= (first items) :catch)
(scan-on (scan-on
(rest (rest items)) (rest (rest items))
@@ -232,7 +236,8 @@
filter filter
every? every?
(nth items 1) (nth items 1)
finally-info)) finally-info
having-info))
((= (first items) :finally) ((= (first items) :finally)
(scan-on (scan-on
(rest (rest items)) (rest (rest items))
@@ -240,6 +245,16 @@
filter filter
every? every?
catch-info catch-info
(nth items 1)
having-info))
((= (first items) :having)
(scan-on
(rest (rest items))
source
filter
every?
catch-info
finally-info
(nth items 1))) (nth items 1)))
(true (true
(scan-on (scan-on
@@ -248,8 +263,9 @@
filter filter
every? every?
catch-info catch-info
finally-info))))) finally-info
(scan-on (rest parts) nil nil false nil nil))))) having-info)))))
(scan-on (rest parts) nil nil false nil nil nil)))))
(define (define
emit-send emit-send
(fn (fn

54
lib/hyperscript/parser.sx
View File

@@ -2543,27 +2543,55 @@
(let (let
((source (if (match-kw "from") (parse-expr) nil))) ((source (if (match-kw "from") (parse-expr) nil)))
(let (let
((body (parse-cmd-list))) ((h-margin nil) (h-threshold nil))
(define
consume-having!
(fn
()
(cond
((and (= (tp-type) "ident") (= (tp-val) "having"))
(do
(adv!)
(cond
((and (= (tp-type) "ident") (= (tp-val) "margin"))
(do
(adv!)
(set! h-margin (parse-expr))
(consume-having!)))
((and (= (tp-type) "ident") (= (tp-val) "threshold"))
(do
(adv!)
(set! h-threshold (parse-expr))
(consume-having!)))
(true nil))))
(true nil))))
(consume-having!)
(let (let
((catch-clause (if (match-kw "catch") (let ((var (let ((v (tp-val))) (adv!) v)) (handler (parse-cmd-list))) (list var handler)) nil)) ((having (if (or h-margin h-threshold) (dict "margin" h-margin "threshold" h-threshold) nil)))
(finally-clause
(if (match-kw "finally") (parse-cmd-list) nil)))
(match-kw "end")
(let (let
((parts (list (quote on) event-name))) ((body (parse-cmd-list)))
(let (let
((parts (if every? (append parts (list :every true)) parts))) ((catch-clause (if (match-kw "catch") (let ((var (let ((v (tp-val))) (adv!) v)) (handler (parse-cmd-list))) (list var handler)) nil))
(finally-clause
(if (match-kw "finally") (parse-cmd-list) nil)))
(match-kw "end")
(let (let
((parts (if flt (append parts (list :filter flt)) parts))) ((parts (list (quote on) event-name)))
(let (let
((parts (if source (append parts (list :from source)) parts))) ((parts (if every? (append parts (list :every true)) parts)))
(let (let
((parts (if catch-clause (append parts (list :catch catch-clause)) parts))) ((parts (if flt (append parts (list :filter flt)) parts)))
(let (let
((parts (if finally-clause (append parts (list :finally finally-clause)) parts))) ((parts (if source (append parts (list :from source)) parts)))
(let (let
((parts (append parts (list body)))) ((parts (if having (append parts (list :having having)) parts)))
parts))))))))))))))) (let
((parts (if catch-clause (append parts (list :catch catch-clause)) parts)))
(let
((parts (if finally-clause (append parts (list :finally finally-clause)) parts)))
(let
((parts (append parts (list body))))
parts))))))))))))))))))
(define (define
parse-init-feat parse-init-feat
(fn (fn

135
lib/hyperscript/runtime.sx
View File

@@ -66,14 +66,30 @@
;; Wait for a DOM event on a target. ;; Wait for a DOM event on a target.
;; (hs-wait-for target event-name) — suspends until event fires ;; (hs-wait-for target event-name) — suspends until event fires
(define hs-init (fn (thunk) (thunk))) (define
hs-on-intersection-attach!
(fn
(target margin threshold)
(let
((opts (dict)))
(when margin (dict-set! opts "rootMargin" margin))
(when threshold (dict-set! opts "threshold" threshold))
(let
((cb (fn (entries observer) (let ((entry (if (> (len entries) 0) (nth entries 0) nil))) (when entry (let ((intersecting (host-get entry "isIntersecting"))) (dom-dispatch target "intersection" (dict "intersecting" intersecting "entry" entry))))))))
(let
((observer (host-new "IntersectionObserver" cb opts)))
(host-call observer "observe" target)
observer)))))
;; Wait for CSS transitions/animations to settle on an element. ;; Wait for CSS transitions/animations to settle on an element.
(define hs-wait (fn (ms) (perform (list (quote io-sleep) ms)))) (define hs-init (fn (thunk) (thunk)))
;; ── Class manipulation ────────────────────────────────────────── ;; ── Class manipulation ──────────────────────────────────────────
;; Toggle a single class on an element. ;; Toggle a single class on an element.
(define hs-wait (fn (ms) (perform (list (quote io-sleep) ms))))
;; Toggle between two classes — exactly one is active at a time.
(begin (begin
(define (define
hs-wait-for hs-wait-for
@@ -86,19 +102,21 @@
(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)))))
;; Toggle between two classes — exactly one is active at a time.
(define hs-settle (fn (target) (perform (list (quote io-settle) target))))
;; Take a class from siblings — add to target, remove from others. ;; Take a class from siblings — add to target, remove from others.
;; (hs-take! target cls) — like radio button class behavior ;; (hs-take! target cls) — like radio button class behavior
(define (define hs-settle (fn (target) (perform (list (quote io-settle) target))))
hs-toggle-class!
(fn (target cls) (host-call (host-get target "classList") "toggle" cls)))
;; ── 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-toggle-class!
(fn (target cls) (host-call (host-get target "classList") "toggle" cls)))
;; ── Navigation / traversal ──────────────────────────────────────
;; Navigate to a URL.
(define (define
hs-toggle-between! hs-toggle-between!
(fn (fn
@@ -108,9 +126,7 @@
(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)))))
;; ── Navigation / traversal ────────────────────────────────────── ;; Find next sibling matching a selector (or any sibling).
;; Navigate to a URL.
(define (define
hs-toggle-style! hs-toggle-style!
(fn (fn
@@ -134,7 +150,7 @@
(dom-set-style target prop "hidden") (dom-set-style target prop "hidden")
(dom-set-style target prop ""))))))) (dom-set-style target prop "")))))))
;; Find next sibling matching a selector (or any sibling). ;; Find previous sibling matching a selector.
(define (define
hs-toggle-style-between! hs-toggle-style-between!
(fn (fn
@@ -146,7 +162,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)))))
;; Find previous sibling matching a selector. ;; First element matching selector within a scope.
(define (define
hs-toggle-style-cycle! hs-toggle-style-cycle!
(fn (fn
@@ -167,7 +183,7 @@
(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)))))
;; First element matching selector within a scope. ;; Last element matching selector.
(define (define
hs-take! hs-take!
(fn (fn
@@ -207,7 +223,7 @@
(dom-set-attr target name attr-val) (dom-set-attr target name attr-val)
(dom-set-attr target name "")))))))) (dom-set-attr target name ""))))))))
;; Last element matching selector. ;; First/last within a specific scope.
(begin (begin
(define (define
hs-element? hs-element?
@@ -319,7 +335,6 @@
(dom-insert-adjacent-html target "beforeend" value) (dom-insert-adjacent-html target "beforeend" value)
(hs-boot-subtree! target))))))))) (hs-boot-subtree! target)))))))))
;; First/last within a specific scope.
(define (define
hs-add-to! hs-add-to!
(fn (fn
@@ -332,6 +347,9 @@
(append target (list value)))) (append target (list value))))
(true (do (host-call target "push" value) target))))) (true (do (host-call target "push" value) target)))))
;; ── Iteration ───────────────────────────────────────────────────
;; Repeat a thunk N times.
(define (define
hs-remove-from! hs-remove-from!
(fn (fn
@@ -341,9 +359,7 @@
(filter (fn (x) (not (= x value))) target) (filter (fn (x) (not (= x value))) target)
(host-call target "splice" (host-call target "indexOf" value) 1)))) (host-call target "splice" (host-call target "indexOf" value) 1))))
;; ── Iteration ─────────────────────────────────────────────────── ;; Repeat forever (until break — relies on exception/continuation).
;; Repeat a thunk N times.
(define (define
hs-splice-at! hs-splice-at!
(fn (fn
@@ -367,7 +383,10 @@
(host-call target "splice" i 1)))) (host-call target "splice" i 1))))
target)))) target))))
;; 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-put-at! hs-put-at!
(fn (fn
@@ -386,10 +405,10 @@
((= pos "start") (host-call target "unshift" value))) ((= pos "start") (host-call target "unshift" value)))
target))))) target)))))
;; ── 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.
(define (define
hs-dict-without hs-dict-without
(fn (fn
@@ -410,27 +429,27 @@
(host-call (host-global "Reflect") "deleteProperty" out key) (host-call (host-global "Reflect") "deleteProperty" out key)
out))))) out)))))
;; ── 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-set-on! hs-set-on!
(fn (fn
(props target) (props target)
(for-each (fn (k) (host-set! target k (get props k))) (keys props)))) (for-each (fn (k) (host-set! target k (get props k))) (keys props))))
;; ── Object creation ─────────────────────────────────────────────
;; Make a new object of a given type.
;; (hs-make type-name) — creates empty object/collection
(define hs-navigate! (fn (url) (perform (list (quote io-navigate) url))))
;; ── Behavior installation ─────────────────────────────────────── ;; ── Behavior installation ───────────────────────────────────────
;; Install a behavior on an element. ;; Install a behavior on an element.
;; A behavior is a function that takes (me ...params) and sets up features. ;; A behavior is a function that takes (me ...params) and sets up features.
;; (hs-install behavior-fn me ...args) ;; (hs-install behavior-fn me ...args)
(define hs-navigate! (fn (url) (perform (list (quote io-navigate) url))))
;; ── Measurement ─────────────────────────────────────────────────
;; Measure an element's bounding rect, store as local variables.
;; Returns a dict with x, y, width, height, top, left, right, bottom.
(define (define
hs-scroll! hs-scroll!
(fn (fn
@@ -443,10 +462,10 @@
((= position "bottom") (dict :block "end")) ((= position "bottom") (dict :block "end"))
(true (dict :block "start"))))))) (true (dict :block "start")))))))
;; ── 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-halt! hs-halt!
(fn (fn
@@ -467,17 +486,13 @@
(host-call ev "stopPropagation"))))) (host-call ev "stopPropagation")))))
(when (not (= mode "the-event")) (raise (list "hs-return" nil)))))) (when (not (= mode "the-event")) (raise (list "hs-return" nil))))))
;; Return the current text selection as a string. In the browser this is
;; `window.getSelection().toString()`. In the mock test runner, a test
;; setup stashes the desired selection text at `window.__test_selection`
;; and the fallback path returns that so tests can assert on the result.
(define hs-select! (fn (target) (host-call target "select" (list))))
;; ── Transition ────────────────────────────────────────────────── ;; ── Transition ──────────────────────────────────────────────────
;; Transition a CSS property to a value, optionally with duration. ;; Transition a CSS property to a value, optionally with duration.
;; (hs-transition target prop value duration) ;; (hs-transition target prop value duration)
(define hs-select! (fn (target) (host-call target "select" (list))))
(define (define
hs-get-selection hs-get-selection
(fn (fn
@@ -612,12 +627,12 @@
((all (dom-query-all (dom-body) sel))) ((all (dom-query-all (dom-body) sel)))
(if (> (len all) 0) (nth all (- (len all) 1)) nil)))) (if (> (len all) 0) (nth all (- (len all) 1)) nil))))
(define hs-first (fn (scope sel) (dom-query-all scope sel))) (define hs-first (fn (scope sel) (dom-query-all scope sel)))
(define (define
hs-last hs-last
(fn (fn
@@ -625,7 +640,8 @@
(let (let
((all (dom-query-all scope sel))) ((all (dom-query-all scope sel)))
(if (> (len all) 0) (nth all (- (len all) 1)) nil)))) (if (> (len all) 0) (nth all (- (len all) 1)) nil))))
;; ── Sandbox/test runtime additions ──────────────────────────────
;; Property access — dot notation and .length
(define (define
hs-repeat-times hs-repeat-times
(fn (fn
@@ -643,8 +659,7 @@
((= signal "hs-continue") (do-repeat (+ i 1))) ((= signal "hs-continue") (do-repeat (+ i 1)))
(true (do-repeat (+ i 1)))))))) (true (do-repeat (+ i 1))))))))
(do-repeat 0))) (do-repeat 0)))
;; ── Sandbox/test runtime additions ────────────────────────────── ;; DOM query stub — sandbox returns empty list
;; Property access — dot notation and .length
(define (define
hs-repeat-forever hs-repeat-forever
(fn (fn
@@ -660,7 +675,7 @@
((= signal "hs-continue") (do-forever)) ((= signal "hs-continue") (do-forever))
(true (do-forever)))))) (true (do-forever))))))
(do-forever))) (do-forever)))
;; DOM query stub — sandbox returns empty list ;; Method dispatch — obj.method(args)
(define (define
hs-repeat-while hs-repeat-while
(fn (fn
@@ -673,7 +688,9 @@
((= signal "hs-break") nil) ((= signal "hs-break") nil)
((= signal "hs-continue") (hs-repeat-while cond-fn thunk)) ((= signal "hs-continue") (hs-repeat-while cond-fn thunk))
(true (hs-repeat-while cond-fn thunk))))))) (true (hs-repeat-while cond-fn thunk)))))))
;; Method dispatch — obj.method(args)
;; ── 0.9.90 features ─────────────────────────────────────────────
;; beep! — debug logging, returns value unchanged
(define (define
hs-repeat-until hs-repeat-until
(fn (fn
@@ -685,9 +702,7 @@
((= signal "hs-continue") ((= signal "hs-continue")
(if (cond-fn) nil (hs-repeat-until cond-fn thunk))) (if (cond-fn) nil (hs-repeat-until cond-fn thunk)))
(true (if (cond-fn) nil (hs-repeat-until cond-fn thunk))))))) (true (if (cond-fn) nil (hs-repeat-until cond-fn thunk)))))))
;; Property-based is — check obj.key truthiness
;; ── 0.9.90 features ─────────────────────────────────────────────
;; beep! — debug logging, returns value unchanged
(define (define
hs-for-each hs-for-each
(fn (fn
@@ -707,7 +722,7 @@
((= signal "hs-continue") (do-loop (rest remaining))) ((= signal "hs-continue") (do-loop (rest remaining)))
(true (do-loop (rest remaining)))))))) (true (do-loop (rest remaining))))))))
(do-loop items)))) (do-loop items))))
;; Property-based is — check obj.key truthiness ;; Array slicing (inclusive both ends)
(begin (begin
(define (define
hs-append hs-append
@@ -735,7 +750,7 @@
((hs-element? target) ((hs-element? target)
(dom-insert-adjacent-html target "beforeend" (str value))) (dom-insert-adjacent-html target "beforeend" (str value)))
(true nil))))) (true nil)))))
;; Array slicing (inclusive both ends) ;; Collection: sorted by
(define (define
hs-sender hs-sender
(fn (fn
@@ -743,7 +758,7 @@
(let (let
((detail (host-get event "detail"))) ((detail (host-get event "detail")))
(if detail (host-get detail "sender") nil)))) (if detail (host-get detail "sender") nil))))
;; Collection: sorted by ;; Collection: sorted by descending
(define (define
hs-host-to-sx hs-host-to-sx
(fn (fn
@@ -797,7 +812,7 @@
(dict-set! out k (hs-host-to-sx (host-get v k)))) (dict-set! out k (hs-host-to-sx (host-get v k))))
(host-call (host-global "Object") "keys" v)) (host-call (host-global "Object") "keys" v))
out))))))))))) out)))))))))))
;; Collection: sorted by descending ;; Collection: split by
(define (define
hs-fetch hs-fetch
(fn (fn
@@ -807,7 +822,7 @@
(let (let
((raw (perform (list "io-fetch" url fmt)))) ((raw (perform (list "io-fetch" url fmt))))
(cond ((= fmt "json") (hs-host-to-sx raw)) (true raw)))))) (cond ((= fmt "json") (hs-host-to-sx raw)) (true raw))))))
;; Collection: split by ;; Collection: joined by
(define (define
hs-json-escape hs-json-escape
(fn (fn
@@ -838,7 +853,7 @@
(walk) (walk)
out) out)
"\""))) "\"")))
;; Collection: joined by
(define (define
hs-json-stringify hs-json-stringify
(fn (fn

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

@@ -158,7 +158,13 @@
(define (define
scan-on scan-on
(fn (fn
(items source filter every? catch-info finally-info) (items
source
filter
every?
catch-info
finally-info
having-info)
(cond (cond
((<= (len items) 1) ((<= (len items) 1)
(let (let
@@ -174,33 +180,28 @@
(let (let
((compiled-body (if (> (len event-refs) 0) (let ((bindings (map (fn (r) (let ((name (nth r 1))) (list (make-symbol name) (list (quote host-get) (list (quote host-get) (quote event) "detail") name)))) event-refs))) (list (quote let) bindings raw-compiled)) raw-compiled))) ((compiled-body (if (> (len event-refs) 0) (let ((bindings (map (fn (r) (let ((name (nth r 1))) (list (make-symbol name) (list (quote host-get) (list (quote host-get) (quote event) "detail") name)))) event-refs))) (list (quote let) bindings raw-compiled)) raw-compiled)))
(let (let
((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 do) (list (quote guard) (list var (list true catch-body)) compiled-body) (hs-to-sx finally-info)) (list (quote guard) (list var (list true catch-body)) compiled-body))) (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 do) (list (quote guard) (list var (list true catch-body)) compiled-body) (hs-to-sx finally-info)) (list (quote guard) (list var (list true catch-body)) compiled-body))) (if finally-info (list (quote do) compiled-body (hs-to-sx finally-info)) compiled-body))))
(handler (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))))) (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)))))
((uses-the-result? (fn (expr) (cond ((= expr (quote the-result)) true) ((list? expr) (some (fn (x) (uses-the-result? x)) expr)) (true false))))) (let
((on-call (if every? (list (quote hs-on-every) target event-name handler) (list (quote hs-on) target event-name handler))))
(if
(= event-name "intersection")
(list (list
(quote fn) (quote do)
(list (quote event)) on-call
(if (list
(uses-the-result? wrapped-body) (quote hs-on-intersection-attach!)
(list target
(quote let) (if
(list having-info
(list (quote the-result) nil)) (get having-info "margin")
wrapped-body) nil)
wrapped-body))))) (if
(if having-info
every? (get having-info "threshold")
(list nil)))
(quote hs-on-every) on-call)))))))))))
target
event-name
handler)
(list
(quote hs-on)
target
event-name
handler))))))))))
((= (first items) :from) ((= (first items) :from)
(scan-on (scan-on
(rest (rest items)) (rest (rest items))
@@ -208,7 +209,8 @@
filter filter
every? every?
catch-info catch-info
finally-info)) finally-info
having-info))
((= (first items) :filter) ((= (first items) :filter)
(scan-on (scan-on
(rest (rest items)) (rest (rest items))
@@ -216,7 +218,8 @@
(nth items 1) (nth items 1)
every? every?
catch-info catch-info
finally-info)) finally-info
having-info))
((= (first items) :every) ((= (first items) :every)
(scan-on (scan-on
(rest (rest items)) (rest (rest items))
@@ -224,7 +227,8 @@
filter filter
true true
catch-info catch-info
finally-info)) finally-info
having-info))
((= (first items) :catch) ((= (first items) :catch)
(scan-on (scan-on
(rest (rest items)) (rest (rest items))
@@ -232,7 +236,8 @@
filter filter
every? every?
(nth items 1) (nth items 1)
finally-info)) finally-info
having-info))
((= (first items) :finally) ((= (first items) :finally)
(scan-on (scan-on
(rest (rest items)) (rest (rest items))
@@ -240,6 +245,16 @@
filter filter
every? every?
catch-info catch-info
(nth items 1)
having-info))
((= (first items) :having)
(scan-on
(rest (rest items))
source
filter
every?
catch-info
finally-info
(nth items 1))) (nth items 1)))
(true (true
(scan-on (scan-on
@@ -248,8 +263,9 @@
filter filter
every? every?
catch-info catch-info
finally-info))))) finally-info
(scan-on (rest parts) nil nil false nil nil))))) having-info)))))
(scan-on (rest parts) nil nil false nil nil nil)))))
(define (define
emit-send emit-send
(fn (fn

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

@@ -2543,27 +2543,55 @@
(let (let
((source (if (match-kw "from") (parse-expr) nil))) ((source (if (match-kw "from") (parse-expr) nil)))
(let (let
((body (parse-cmd-list))) ((h-margin nil) (h-threshold nil))
(define
consume-having!
(fn
()
(cond
((and (= (tp-type) "ident") (= (tp-val) "having"))
(do
(adv!)
(cond
((and (= (tp-type) "ident") (= (tp-val) "margin"))
(do
(adv!)
(set! h-margin (parse-expr))
(consume-having!)))
((and (= (tp-type) "ident") (= (tp-val) "threshold"))
(do
(adv!)
(set! h-threshold (parse-expr))
(consume-having!)))
(true nil))))
(true nil))))
(consume-having!)
(let (let
((catch-clause (if (match-kw "catch") (let ((var (let ((v (tp-val))) (adv!) v)) (handler (parse-cmd-list))) (list var handler)) nil)) ((having (if (or h-margin h-threshold) (dict "margin" h-margin "threshold" h-threshold) nil)))
(finally-clause
(if (match-kw "finally") (parse-cmd-list) nil)))
(match-kw "end")
(let (let
((parts (list (quote on) event-name))) ((body (parse-cmd-list)))
(let (let
((parts (if every? (append parts (list :every true)) parts))) ((catch-clause (if (match-kw "catch") (let ((var (let ((v (tp-val))) (adv!) v)) (handler (parse-cmd-list))) (list var handler)) nil))
(finally-clause
(if (match-kw "finally") (parse-cmd-list) nil)))
(match-kw "end")
(let (let
((parts (if flt (append parts (list :filter flt)) parts))) ((parts (list (quote on) event-name)))
(let (let
((parts (if source (append parts (list :from source)) parts))) ((parts (if every? (append parts (list :every true)) parts)))
(let (let
((parts (if catch-clause (append parts (list :catch catch-clause)) parts))) ((parts (if flt (append parts (list :filter flt)) parts)))
(let (let
((parts (if finally-clause (append parts (list :finally finally-clause)) parts))) ((parts (if source (append parts (list :from source)) parts)))
(let (let
((parts (append parts (list body)))) ((parts (if having (append parts (list :having having)) parts)))
parts))))))))))))))) (let
((parts (if catch-clause (append parts (list :catch catch-clause)) parts)))
(let
((parts (if finally-clause (append parts (list :finally finally-clause)) parts)))
(let
((parts (append parts (list body))))
parts))))))))))))))))))
(define (define
parse-init-feat parse-init-feat
(fn (fn

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

@@ -66,14 +66,30 @@
;; Wait for a DOM event on a target. ;; Wait for a DOM event on a target.
;; (hs-wait-for target event-name) — suspends until event fires ;; (hs-wait-for target event-name) — suspends until event fires
(define hs-init (fn (thunk) (thunk))) (define
hs-on-intersection-attach!
(fn
(target margin threshold)
(let
((opts (dict)))
(when margin (dict-set! opts "rootMargin" margin))
(when threshold (dict-set! opts "threshold" threshold))
(let
((cb (fn (entries observer) (let ((entry (if (> (len entries) 0) (nth entries 0) nil))) (when entry (let ((intersecting (host-get entry "isIntersecting"))) (dom-dispatch target "intersection" (dict "intersecting" intersecting "entry" entry))))))))
(let
((observer (host-new "IntersectionObserver" cb opts)))
(host-call observer "observe" target)
observer)))))
;; Wait for CSS transitions/animations to settle on an element. ;; Wait for CSS transitions/animations to settle on an element.
(define hs-wait (fn (ms) (perform (list (quote io-sleep) ms)))) (define hs-init (fn (thunk) (thunk)))
;; ── Class manipulation ────────────────────────────────────────── ;; ── Class manipulation ──────────────────────────────────────────
;; Toggle a single class on an element. ;; Toggle a single class on an element.
(define hs-wait (fn (ms) (perform (list (quote io-sleep) ms))))
;; Toggle between two classes — exactly one is active at a time.
(begin (begin
(define (define
hs-wait-for hs-wait-for
@@ -86,19 +102,21 @@
(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)))))
;; Toggle between two classes — exactly one is active at a time.
(define hs-settle (fn (target) (perform (list (quote io-settle) target))))
;; Take a class from siblings — add to target, remove from others. ;; Take a class from siblings — add to target, remove from others.
;; (hs-take! target cls) — like radio button class behavior ;; (hs-take! target cls) — like radio button class behavior
(define (define hs-settle (fn (target) (perform (list (quote io-settle) target))))
hs-toggle-class!
(fn (target cls) (host-call (host-get target "classList") "toggle" cls)))
;; ── 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-toggle-class!
(fn (target cls) (host-call (host-get target "classList") "toggle" cls)))
;; ── Navigation / traversal ──────────────────────────────────────
;; Navigate to a URL.
(define (define
hs-toggle-between! hs-toggle-between!
(fn (fn
@@ -108,9 +126,7 @@
(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)))))
;; ── Navigation / traversal ────────────────────────────────────── ;; Find next sibling matching a selector (or any sibling).
;; Navigate to a URL.
(define (define
hs-toggle-style! hs-toggle-style!
(fn (fn
@@ -134,7 +150,7 @@
(dom-set-style target prop "hidden") (dom-set-style target prop "hidden")
(dom-set-style target prop ""))))))) (dom-set-style target prop "")))))))
;; Find next sibling matching a selector (or any sibling). ;; Find previous sibling matching a selector.
(define (define
hs-toggle-style-between! hs-toggle-style-between!
(fn (fn
@@ -146,7 +162,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)))))
;; Find previous sibling matching a selector. ;; First element matching selector within a scope.
(define (define
hs-toggle-style-cycle! hs-toggle-style-cycle!
(fn (fn
@@ -167,7 +183,7 @@
(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)))))
;; First element matching selector within a scope. ;; Last element matching selector.
(define (define
hs-take! hs-take!
(fn (fn
@@ -207,7 +223,7 @@
(dom-set-attr target name attr-val) (dom-set-attr target name attr-val)
(dom-set-attr target name "")))))))) (dom-set-attr target name ""))))))))
;; Last element matching selector. ;; First/last within a specific scope.
(begin (begin
(define (define
hs-element? hs-element?
@@ -319,7 +335,6 @@
(dom-insert-adjacent-html target "beforeend" value) (dom-insert-adjacent-html target "beforeend" value)
(hs-boot-subtree! target))))))))) (hs-boot-subtree! target)))))))))
;; First/last within a specific scope.
(define (define
hs-add-to! hs-add-to!
(fn (fn
@@ -332,6 +347,9 @@
(append target (list value)))) (append target (list value))))
(true (do (host-call target "push" value) target))))) (true (do (host-call target "push" value) target)))))
;; ── Iteration ───────────────────────────────────────────────────
;; Repeat a thunk N times.
(define (define
hs-remove-from! hs-remove-from!
(fn (fn
@@ -341,9 +359,7 @@
(filter (fn (x) (not (= x value))) target) (filter (fn (x) (not (= x value))) target)
(host-call target "splice" (host-call target "indexOf" value) 1)))) (host-call target "splice" (host-call target "indexOf" value) 1))))
;; ── Iteration ─────────────────────────────────────────────────── ;; Repeat forever (until break — relies on exception/continuation).
;; Repeat a thunk N times.
(define (define
hs-splice-at! hs-splice-at!
(fn (fn
@@ -367,7 +383,10 @@
(host-call target "splice" i 1)))) (host-call target "splice" i 1))))
target)))) target))))
;; 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-put-at! hs-put-at!
(fn (fn
@@ -386,10 +405,10 @@
((= pos "start") (host-call target "unshift" value))) ((= pos "start") (host-call target "unshift" value)))
target))))) target)))))
;; ── 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.
(define (define
hs-dict-without hs-dict-without
(fn (fn
@@ -410,27 +429,27 @@
(host-call (host-global "Reflect") "deleteProperty" out key) (host-call (host-global "Reflect") "deleteProperty" out key)
out))))) out)))))
;; ── 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-set-on! hs-set-on!
(fn (fn
(props target) (props target)
(for-each (fn (k) (host-set! target k (get props k))) (keys props)))) (for-each (fn (k) (host-set! target k (get props k))) (keys props))))
;; ── Object creation ─────────────────────────────────────────────
;; Make a new object of a given type.
;; (hs-make type-name) — creates empty object/collection
(define hs-navigate! (fn (url) (perform (list (quote io-navigate) url))))
;; ── Behavior installation ─────────────────────────────────────── ;; ── Behavior installation ───────────────────────────────────────
;; Install a behavior on an element. ;; Install a behavior on an element.
;; A behavior is a function that takes (me ...params) and sets up features. ;; A behavior is a function that takes (me ...params) and sets up features.
;; (hs-install behavior-fn me ...args) ;; (hs-install behavior-fn me ...args)
(define hs-navigate! (fn (url) (perform (list (quote io-navigate) url))))
;; ── Measurement ─────────────────────────────────────────────────
;; Measure an element's bounding rect, store as local variables.
;; Returns a dict with x, y, width, height, top, left, right, bottom.
(define (define
hs-scroll! hs-scroll!
(fn (fn
@@ -443,10 +462,10 @@
((= position "bottom") (dict :block "end")) ((= position "bottom") (dict :block "end"))
(true (dict :block "start"))))))) (true (dict :block "start")))))))
;; ── 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-halt! hs-halt!
(fn (fn
@@ -467,17 +486,13 @@
(host-call ev "stopPropagation"))))) (host-call ev "stopPropagation")))))
(when (not (= mode "the-event")) (raise (list "hs-return" nil)))))) (when (not (= mode "the-event")) (raise (list "hs-return" nil))))))
;; Return the current text selection as a string. In the browser this is
;; `window.getSelection().toString()`. In the mock test runner, a test
;; setup stashes the desired selection text at `window.__test_selection`
;; and the fallback path returns that so tests can assert on the result.
(define hs-select! (fn (target) (host-call target "select" (list))))
;; ── Transition ────────────────────────────────────────────────── ;; ── Transition ──────────────────────────────────────────────────
;; Transition a CSS property to a value, optionally with duration. ;; Transition a CSS property to a value, optionally with duration.
;; (hs-transition target prop value duration) ;; (hs-transition target prop value duration)
(define hs-select! (fn (target) (host-call target "select" (list))))
(define (define
hs-get-selection hs-get-selection
(fn (fn
@@ -612,12 +627,12 @@
((all (dom-query-all (dom-body) sel))) ((all (dom-query-all (dom-body) sel)))
(if (> (len all) 0) (nth all (- (len all) 1)) nil)))) (if (> (len all) 0) (nth all (- (len all) 1)) nil))))
(define hs-first (fn (scope sel) (dom-query-all scope sel))) (define hs-first (fn (scope sel) (dom-query-all scope sel)))
(define (define
hs-last hs-last
(fn (fn
@@ -625,7 +640,8 @@
(let (let
((all (dom-query-all scope sel))) ((all (dom-query-all scope sel)))
(if (> (len all) 0) (nth all (- (len all) 1)) nil)))) (if (> (len all) 0) (nth all (- (len all) 1)) nil))))
;; ── Sandbox/test runtime additions ──────────────────────────────
;; Property access — dot notation and .length
(define (define
hs-repeat-times hs-repeat-times
(fn (fn
@@ -643,8 +659,7 @@
((= signal "hs-continue") (do-repeat (+ i 1))) ((= signal "hs-continue") (do-repeat (+ i 1)))
(true (do-repeat (+ i 1)))))))) (true (do-repeat (+ i 1))))))))
(do-repeat 0))) (do-repeat 0)))
;; ── Sandbox/test runtime additions ────────────────────────────── ;; DOM query stub — sandbox returns empty list
;; Property access — dot notation and .length
(define (define
hs-repeat-forever hs-repeat-forever
(fn (fn
@@ -660,7 +675,7 @@
((= signal "hs-continue") (do-forever)) ((= signal "hs-continue") (do-forever))
(true (do-forever)))))) (true (do-forever))))))
(do-forever))) (do-forever)))
;; DOM query stub — sandbox returns empty list ;; Method dispatch — obj.method(args)
(define (define
hs-repeat-while hs-repeat-while
(fn (fn
@@ -673,7 +688,9 @@
((= signal "hs-break") nil) ((= signal "hs-break") nil)
((= signal "hs-continue") (hs-repeat-while cond-fn thunk)) ((= signal "hs-continue") (hs-repeat-while cond-fn thunk))
(true (hs-repeat-while cond-fn thunk))))))) (true (hs-repeat-while cond-fn thunk)))))))
;; Method dispatch — obj.method(args)
;; ── 0.9.90 features ─────────────────────────────────────────────
;; beep! — debug logging, returns value unchanged
(define (define
hs-repeat-until hs-repeat-until
(fn (fn
@@ -685,9 +702,7 @@
((= signal "hs-continue") ((= signal "hs-continue")
(if (cond-fn) nil (hs-repeat-until cond-fn thunk))) (if (cond-fn) nil (hs-repeat-until cond-fn thunk)))
(true (if (cond-fn) nil (hs-repeat-until cond-fn thunk))))))) (true (if (cond-fn) nil (hs-repeat-until cond-fn thunk)))))))
;; Property-based is — check obj.key truthiness
;; ── 0.9.90 features ─────────────────────────────────────────────
;; beep! — debug logging, returns value unchanged
(define (define
hs-for-each hs-for-each
(fn (fn
@@ -707,7 +722,7 @@
((= signal "hs-continue") (do-loop (rest remaining))) ((= signal "hs-continue") (do-loop (rest remaining)))
(true (do-loop (rest remaining)))))))) (true (do-loop (rest remaining))))))))
(do-loop items)))) (do-loop items))))
;; Property-based is — check obj.key truthiness ;; Array slicing (inclusive both ends)
(begin (begin
(define (define
hs-append hs-append
@@ -735,7 +750,7 @@
((hs-element? target) ((hs-element? target)
(dom-insert-adjacent-html target "beforeend" (str value))) (dom-insert-adjacent-html target "beforeend" (str value)))
(true nil))))) (true nil)))))
;; Array slicing (inclusive both ends) ;; Collection: sorted by
(define (define
hs-sender hs-sender
(fn (fn
@@ -743,7 +758,7 @@
(let (let
((detail (host-get event "detail"))) ((detail (host-get event "detail")))
(if detail (host-get detail "sender") nil)))) (if detail (host-get detail "sender") nil))))
;; Collection: sorted by ;; Collection: sorted by descending
(define (define
hs-host-to-sx hs-host-to-sx
(fn (fn
@@ -797,7 +812,7 @@
(dict-set! out k (hs-host-to-sx (host-get v k)))) (dict-set! out k (hs-host-to-sx (host-get v k))))
(host-call (host-global "Object") "keys" v)) (host-call (host-global "Object") "keys" v))
out))))))))))) out)))))))))))
;; Collection: sorted by descending ;; Collection: split by
(define (define
hs-fetch hs-fetch
(fn (fn
@@ -807,7 +822,7 @@
(let (let
((raw (perform (list "io-fetch" url fmt)))) ((raw (perform (list "io-fetch" url fmt))))
(cond ((= fmt "json") (hs-host-to-sx raw)) (true raw)))))) (cond ((= fmt "json") (hs-host-to-sx raw)) (true raw))))))
;; Collection: split by ;; Collection: joined by
(define (define
hs-json-escape hs-json-escape
(fn (fn
@@ -838,7 +853,7 @@
(walk) (walk)
out) out)
"\""))) "\"")))
;; Collection: joined by
(define (define
hs-json-stringify hs-json-stringify
(fn (fn

21
tests/hs-run-filtered.js
View File

@@ -354,7 +354,26 @@ class HsResizeObserver {
} }
} }
globalThis.ResizeObserver=HsResizeObserver; globalThis.ResizeObserverEntry=class{}; globalThis.ResizeObserver=HsResizeObserver; globalThis.ResizeObserverEntry=class{};
globalThis.IntersectionObserver=class{observe(){}disconnect(){}}; // HsIntersectionObserver — cluster-27 intersection mock. Fires the callback
// synchronously on observe() with isIntersecting=true so `on intersection`
// handlers run during activation. `margin`/`threshold` options are parsed
// but ignored (tests only assert the handler fires).
class HsIntersectionObserver {
constructor(cb, opts) { this._cb = cb; this._opts = opts || {}; this._els = new Set(); }
observe(el) {
if (!el) return;
this._els.add(el);
const entry = { target: el, isIntersecting: true, intersectionRatio: 1,
boundingClientRect: (el.getBoundingClientRect && el.getBoundingClientRect()) || {},
intersectionRect: {}, rootBounds: null, time: 0 };
try { this._cb([entry], this); } catch (e) {}
}
unobserve(el) { if (el) this._els.delete(el); }
disconnect() { this._els.clear(); }
takeRecords() { return []; }
}
globalThis.IntersectionObserver = HsIntersectionObserver;
globalThis.IntersectionObserverEntry = class {};
globalThis.navigator={userAgent:'node'}; globalThis.location={href:'http://localhost/',pathname:'/',search:'',hash:''}; globalThis.navigator={userAgent:'node'}; globalThis.location={href:'http://localhost/',pathname:'/',search:'',hash:''};
globalThis.history={pushState(){},replaceState(){},back(){},forward(){}}; globalThis.history={pushState(){},replaceState(){},back(){},forward(){}};
globalThis.getSelection=()=>({toString:()=>(globalThis.__test_selection||'')}); globalThis.getSelection=()=>({toString:()=>(globalThis.__test_selection||'')});