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

HS test generator: fix toHaveCSS, locals, and \"-escapes — +28 tests

Browse Source 
Generator changes (tests/playwright/generate-sx-tests.py):
- toHaveCSS regex: balance parens so `'rgb(255, 0, 0)'` is captured intact
  (was truncating at first `)`)
- Map browser-computed colors `rgb(R,G,B)` back to CSS keywords
  (red/green/blue/black/white) — our DOM mock returns the inline value
- js_val_to_sx now handles object literals `{a: 1, b: {c: 2}}` → `{:a 1 :b {:c 2}}`
- Pattern 2 (`var x = await run(...)`) now captures locals via balanced-brace
  scan and emits `eval-hs-locals` instead of `eval-hs`
- Pattern 1 with locals: emit `eval-hs-locals` (was wrapping in `let`, which
  doesn't reach the inner HS env)
- Stop collapsing `\"` → `"` in raw HTML (line 218): the backslash escapes
  are legitimate in single-quoted `_='...'` HS attribute values containing
  nested HS scripts

Test-framework changes (regenerated into spec/tests/test-hyperscript-behavioral.sx):
- `_hs-wrap-body`: returns expression value if non-nil, else `it`. Lets bare
  expressions (`foo.foo`) and `it`-mutating scripts (`pick first 3 of arr;
  set $test to it`) both round-trip through the same wrapper
- `eval-hs-locals` now injects locals via `(let ((name (quote val)) ...) sx)`
  rather than `apply handler (cons nil vals)` — works around a JIT loop on
  some compiled forms (e.g. `bar.doh of foo` with undefined `bar`)

Also synced lib/hyperscript/*.sx → shared/static/wasm/sx/hs-*.sx (the WASM
test runner reads from the wasm/sx/ copies).

Net per-cluster pass counts (vs prior baseline):
- put: 23 → 29 (+6)
- set: 21 → 28 (+7)
- show: 7 → 15 (+8)
- expressions/propertyAccess: 3 → 9 (+6)
- expressions/possessiveExpression: 17 → 18 (+1)

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-23 09:18:21 +00:00
parent 0515295317
commit a11d0941e9
7 changed files with 451 additions and 194 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -77,7 +77,11 @@
((= th (quote ref)) ((= th (quote ref))
(list (quote set!) (make-symbol (nth target 1)) value)) (list (quote set!) (make-symbol (nth target 1)) value))
((= th (quote local)) ((= th (quote local))
(list (quote define) (make-symbol (nth target 1)) value)) (list
(quote hs-scoped-set!)
(quote me)
(nth target 1)
value))
((= th (quote dom-ref)) ((= th (quote dom-ref))
(list (list
(quote hs-dom-set!) (quote hs-dom-set!)
@@ -753,35 +757,53 @@
(hs-to-sx (nth ast 3)))) (hs-to-sx (nth ast 3))))
((= head (quote pick-first)) ((= head (quote pick-first))
(list (list
(quote hs-pick-first) (quote set!)
(hs-to-sx (nth ast 1)) (quote it)
(hs-to-sx (nth ast 2)))) (list
(quote hs-pick-first)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2)))))
((= head (quote pick-last)) ((= head (quote pick-last))
(list (list
(quote hs-pick-last) (quote set!)
(hs-to-sx (nth ast 1)) (quote it)
(hs-to-sx (nth ast 2)))) (list
(quote hs-pick-last)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2)))))
((= head (quote pick-random)) ((= head (quote pick-random))
(list (list
(quote hs-pick-random) (quote set!)
(hs-to-sx (nth ast 1)) (quote it)
(if (nil? (nth ast 2)) nil (hs-to-sx (nth ast 2))))) (list
(quote hs-pick-random)
(hs-to-sx (nth ast 1))
(if (nil? (nth ast 2)) nil (hs-to-sx (nth ast 2))))))
((= head (quote pick-items)) ((= head (quote pick-items))
(list (list
(quote hs-pick-items) (quote set!)
(hs-to-sx (nth ast 1)) (quote it)
(hs-to-sx (nth ast 2)) (list
(hs-to-sx (nth ast 3)))) (quote hs-pick-items)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))
(hs-to-sx (nth ast 3)))))
((= head (quote pick-match)) ((= head (quote pick-match))
(list (list
(quote regex-match) (quote set!)
(hs-to-sx (nth ast 1)) (quote it)
(hs-to-sx (nth ast 2)))) (list
(quote regex-match)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2)))))
((= head (quote pick-matches)) ((= head (quote pick-matches))
(list (list
(quote regex-find-all) (quote set!)
(hs-to-sx (nth ast 1)) (quote it)
(hs-to-sx (nth ast 2)))) (list
(quote regex-find-all)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2)))))
((= head (quote prop-is)) ((= head (quote prop-is))
(list (list
(quote hs-prop-is) (quote hs-prop-is)
@@ -894,7 +916,8 @@
(quote dom-has-class?) (quote dom-has-class?)
(hs-to-sx (nth ast 1)) (hs-to-sx (nth ast 1))
(nth ast 2))) (nth ast 2)))
((= head (quote local)) (make-symbol (nth ast 1))) ((= head (quote local))
(list (quote hs-scoped-get) (quote me) (nth ast 1)))
((= head (quote array)) ((= head (quote array))
(cons (quote list) (map hs-to-sx (rest ast)))) (cons (quote list) (map hs-to-sx (rest ast))))
((= head (quote not)) ((= head (quote not))
@@ -1384,7 +1407,7 @@
nil)) nil))
((= head (quote hide)) ((= head (quote hide))
(let (let
((tgt (hs-to-sx (nth ast 1))) ((tgt (let ((raw-tgt (nth ast 1))) (if (and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-query-all) (nth raw-tgt 1)) (hs-to-sx raw-tgt))))
(strategy (if (> (len ast) 2) (nth ast 2) "display")) (strategy (if (> (len ast) 2) (nth ast 2) "display"))
(when-cond (if (> (len ast) 3) (nth ast 3) nil))) (when-cond (if (> (len ast) 3) (nth ast 3) nil)))
(if (if
@@ -1400,7 +1423,7 @@
(hs-to-sx when-cond)))))) (hs-to-sx when-cond))))))
((= head (quote show)) ((= head (quote show))
(let (let
((tgt (hs-to-sx (nth ast 1))) ((tgt (let ((raw-tgt (nth ast 1))) (if (and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-query-all) (nth raw-tgt 1)) (hs-to-sx raw-tgt))))
(strategy (if (> (len ast) 2) (nth ast 2) "display")) (strategy (if (> (len ast) 2) (nth ast 2) "display"))
(when-cond (if (> (len ast) 3) (nth ast 3) nil))) (when-cond (if (> (len ast) 3) (nth ast 3) nil)))
(if (if

45
shared/static/wasm/sx/hs-integration.sx
View File

@@ -53,13 +53,20 @@
((sx (hs-to-sx-from-source src))) ((sx (hs-to-sx-from-source src)))
(let (let
((extra-vars (hs-collect-vars sx))) ((extra-vars (hs-collect-vars sx)))
(let (do
((bindings (append (list (list (quote it) nil) (list (quote event) nil)) (map (fn (v) (list v nil)) extra-vars)))) (for-each
(eval-expr-cek (fn (v) (eval-expr-cek (list (quote define) v nil)))
(list extra-vars)
(quote fn) (let
(list (quote me)) ((guarded (list (quote guard) (list (quote _e) (list (quote true) (list (quote if) (list (quote and) (list (quote list?) (quote _e)) (list (quote =) (list (quote first) (quote _e)) "hs-return")) (list (quote nth) (quote _e) 1) (list (quote raise) (quote _e))))) sx)))
(list (quote let) bindings sx))))))))) (eval-expr-cek
(list
(quote fn)
(list (quote me))
(list
(quote let)
(list (list (quote it) nil) (list (quote event) nil))
guarded))))))))))
;; ── Activate a single element ─────────────────────────────────── ;; ── Activate a single element ───────────────────────────────────
;; Reads the _="..." attribute, compiles, and executes with me=element. ;; Reads the _="..." attribute, compiles, and executes with me=element.
@@ -70,9 +77,10 @@
(fn (fn
(el) (el)
(let (let
((src (dom-get-attr el "_"))) ((src (dom-get-attr el "_")) (prev (dom-get-data el "hs-script")))
(when (when
(and src (not (dom-get-data el "hs-active"))) (and src (not (= src prev)))
(dom-set-data el "hs-script" src)
(dom-set-data el "hs-active" true) (dom-set-data el "hs-active" true)
(let ((handler (hs-handler src))) (handler el)))))) (let ((handler (hs-handler src))) (handler el))))))
@@ -80,6 +88,21 @@
;; Called once at page load. Finds all elements with _ attribute, ;; Called once at page load. Finds all elements with _ attribute,
;; compiles their hyperscript, and activates them. ;; compiles their hyperscript, and activates them.
(define
hs-deactivate!
(fn
(el)
(let
((unlisteners (or (dom-get-data el "hs-unlisteners") (list))))
(for-each (fn (u) (when u (u))) unlisteners)
(dom-set-data el "hs-unlisteners" (list))
(dom-set-data el "hs-active" false)
(dom-set-data el "hs-script" nil))))
;; ── Boot subtree: for dynamic content ───────────────────────────
;; Called after HTMX swaps or dynamic DOM insertion.
;; Only activates elements within the given root.
(define (define
hs-boot! hs-boot!
(fn (fn
@@ -88,10 +111,6 @@
((elements (dom-query-all (host-get (host-global "document") "body") "[_]"))) ((elements (dom-query-all (host-get (host-global "document") "body") "[_]")))
(for-each (fn (el) (hs-activate! el)) elements)))) (for-each (fn (el) (hs-activate! el)) elements))))
;; ── Boot subtree: for dynamic content ───────────────────────────
;; Called after HTMX swaps or dynamic DOM insertion.
;; Only activates elements within the given root.
(define (define
hs-boot-subtree! hs-boot-subtree!
(fn (fn

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

@@ -550,6 +550,14 @@
(quote and) (quote and)
(list (quote >=) left lo) (list (quote >=) left lo)
(list (quote <=) left hi)))))) (list (quote <=) left hi))))))
((or (and (or (= (tp-val) "a") (= (tp-val) "an")) (do (adv!) true)))
(let
((type-name (tp-val)))
(do
(adv!)
(list
(quote not)
(list (quote type-check) left type-name)))))
(true (true
(let (let
((right (parse-expr))) ((right (parse-expr)))
@@ -566,6 +574,10 @@
(quote and) (quote and)
(list (quote >=) left lo) (list (quote >=) left lo)
(list (quote <=) left hi))))) (list (quote <=) left hi)))))
((or (and (or (= (tp-val) "a") (= (tp-val) "an")) (do (adv!) true)))
(let
((type-name (tp-val)))
(do (adv!) (list (quote type-check) left type-name))))
(true (true
(let (let
((right (parse-expr))) ((right (parse-expr)))
@@ -596,7 +608,7 @@
(match-kw "case") (match-kw "case")
(list (quote ends-with-ic?) left rhs)) (list (quote ends-with-ic?) left rhs))
(list (quote ends-with?) left rhs))))) (list (quote ends-with?) left rhs)))))
((and (= typ "keyword") (= val "matches")) ((and (= typ "keyword") (or (= val "matches") (= val "match")))
(do (do
(adv!) (adv!)
(let (let
@@ -638,7 +650,22 @@
(quote as) (quote as)
left left
(str type-name ":" param))))) (str type-name ":" param)))))
(list (quote as) left type-name)))))) (let
loop
((result (list (quote as) left type-name)))
(if
(and (= (tp-type) "op") (= (tp-val) "|"))
(do
(adv!)
(when
(or (= (tp-val) "a") (= (tp-val) "an"))
(adv!))
(let
((next-type (tp-val)))
(do
(adv!)
(loop (list (quote as) result next-type)))))
result)))))))
((and (= typ "colon")) ((and (= typ "colon"))
(do (do
(adv!) (adv!)
@@ -713,7 +740,7 @@
(list (quote strict-eq) left (parse-expr)))) (list (quote strict-eq) left (parse-expr))))
((and (= typ "keyword") (or (= val "contain") (= val "include") (= val "includes"))) ((and (= typ "keyword") (or (= val "contain") (= val "include") (= val "includes")))
(do (adv!) (list (quote contains?) left (parse-expr)))) (do (adv!) (list (quote contains?) left (parse-expr))))
((and (= typ "keyword") (= val "precedes")) ((and (= typ "keyword") (or (= val "precedes") (= val "precede")))
(do (adv!) (list (quote precedes?) left (parse-atom)))) (do (adv!) (list (quote precedes?) left (parse-atom))))
((and (= typ "keyword") (= val "follows")) ((and (= typ "keyword") (= val "follows"))
(do (adv!) (list (quote follows?) left (parse-atom)))) (do (adv!) (list (quote follows?) left (parse-atom))))
@@ -792,7 +819,7 @@
(= (tp-val) "starts") (= (tp-val) "starts")
(= (tp-val) "ends") (= (tp-val) "ends")
(= (tp-val) "contains") (= (tp-val) "contains")
(= (tp-val) "matches") (or (= (tp-val) "matches") (= (tp-val) "match"))
(= (tp-val) "is") (= (tp-val) "is")
(= (tp-val) "does") (= (tp-val) "does")
(= (tp-val) "in") (= (tp-val) "in")
@@ -1082,38 +1109,67 @@
(match-kw "between") (match-kw "between")
(let (let
((val1 (parse-atom))) ((val1 (parse-atom)))
(expect-kw! "and") (do
(let (when (= (tp-type) "comma") (adv!))
((val2 (parse-atom)))
(if (if
(match-kw "and") (and (= (tp-type) "keyword") (= (tp-val) "and"))
(let (adv!)
((val3 (parse-atom))) nil)
(if (let
(match-kw "and") ((val2 (parse-atom)))
(if
(or
(= (tp-type) "comma")
(and
(= (tp-type) "keyword")
(= (tp-val) "and")))
(do
(when (= (tp-type) "comma") (adv!))
(if
(and
(= (tp-type) "keyword")
(= (tp-val) "and"))
(adv!)
nil)
(let (let
((val4 (parse-atom))) ((val3 (parse-atom)))
(list (if
(quote toggle-style-cycle) (or
prop (= (tp-type) "comma")
tgt (and
val1 (= (tp-type) "keyword")
val2 (= (tp-val) "and")))
val3 (do
val4)) (when (= (tp-type) "comma") (adv!))
(list (if
(quote toggle-style-cycle) (and
prop (= (tp-type) "keyword")
tgt (= (tp-val) "and"))
val1 (adv!)
val2 nil)
val3))) (let
(list ((val4 (parse-atom)))
(quote toggle-style-between) (list
prop (quote toggle-style-cycle)
val1 prop
val2 tgt
tgt)))) val1
val2
val3
val4)))
(list
(quote toggle-style-cycle)
prop
tgt
val1
val2
val3))))
(list
(quote toggle-style-between)
prop
val1
val2
tgt)))))
(list (quote toggle-style) prop tgt))))) (list (quote toggle-style) prop tgt)))))
((= (tp-type) "attr") ((= (tp-type) "attr")
(let (let
@@ -1422,7 +1478,7 @@
(let (let
((tgt (cond ((at-end?) (list (quote me))) ((and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end") (= (tp-val) "with") (= (tp-val) "when") (= (tp-val) "add") (= (tp-val) "remove") (= (tp-val) "set") (= (tp-val) "put") (= (tp-val) "toggle") (= (tp-val) "hide") (= (tp-val) "show"))) (list (quote me))) (true (parse-expr))))) ((tgt (cond ((at-end?) (list (quote me))) ((and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end") (= (tp-val) "with") (= (tp-val) "when") (= (tp-val) "add") (= (tp-val) "remove") (= (tp-val) "set") (= (tp-val) "put") (= (tp-val) "toggle") (= (tp-val) "hide") (= (tp-val) "show"))) (list (quote me))) (true (parse-expr)))))
(let (let
((strategy (if (match-kw "with") (if (at-end?) "display" (let ((s (tp-val))) (adv!) s)) "display"))) ((strategy (if (match-kw "with") (if (at-end?) "display" (let ((s (tp-val))) (do (adv!) (cond ((at-end?) s) ((= (tp-type) "colon") (do (adv!) (let ((v (tp-val))) (do (adv!) (str s ":" v))))) ((= (tp-type) "local") (let ((v (tp-val))) (do (adv!) (str s ":" v)))) (true s))))) "display")))
(let (let
((when-cond (if (and (= (tp-type) "keyword") (= (tp-val) "when")) (do (adv!) (parse-expr)) nil))) ((when-cond (if (and (= (tp-type) "keyword") (= (tp-val) "when")) (do (adv!) (parse-expr)) nil)))
(list (quote hide) tgt strategy when-cond)))))) (list (quote hide) tgt strategy when-cond))))))
@@ -1433,7 +1489,7 @@
(let (let
((tgt (cond ((at-end?) (list (quote me))) ((and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end") (= (tp-val) "with") (= (tp-val) "when") (= (tp-val) "add") (= (tp-val) "remove") (= (tp-val) "set") (= (tp-val) "put") (= (tp-val) "toggle") (= (tp-val) "hide") (= (tp-val) "show"))) (list (quote me))) (true (parse-expr))))) ((tgt (cond ((at-end?) (list (quote me))) ((and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end") (= (tp-val) "with") (= (tp-val) "when") (= (tp-val) "add") (= (tp-val) "remove") (= (tp-val) "set") (= (tp-val) "put") (= (tp-val) "toggle") (= (tp-val) "hide") (= (tp-val) "show"))) (list (quote me))) (true (parse-expr)))))
(let (let
((strategy (if (match-kw "with") (if (at-end?) "display" (let ((s (tp-val))) (adv!) s)) "display"))) ((strategy (if (match-kw "with") (if (at-end?) "display" (let ((s (tp-val))) (do (adv!) (cond ((at-end?) s) ((= (tp-type) "colon") (do (adv!) (let ((v (tp-val))) (do (adv!) (str s ":" v))))) ((= (tp-type) "local") (let ((v (tp-val))) (do (adv!) (str s ":" v)))) (true s))))) "display")))
(let (let
((when-cond (if (and (= (tp-type) "keyword") (= (tp-val) "when")) (do (adv!) (parse-expr)) nil))) ((when-cond (if (and (= (tp-type) "keyword") (= (tp-val) "when")) (do (adv!) (parse-expr)) nil)))
(list (quote show) tgt strategy when-cond)))))) (list (quote show) tgt strategy when-cond))))))
@@ -1648,7 +1704,9 @@
(let (let
((n (parse-atom))) ((n (parse-atom)))
(do (do
(expect-kw! "of") (if
(not (or (match-kw "of") (match-kw "from")))
(error (str "Expected 'of' or 'from' at position " p)))
(let (let
((coll (parse-expr))) ((coll (parse-expr)))
(list (quote pick-first) coll n)))))) (list (quote pick-first) coll n))))))
@@ -1658,7 +1716,9 @@
(let (let
((n (parse-atom))) ((n (parse-atom)))
(do (do
(expect-kw! "of") (if
(not (or (match-kw "of") (match-kw "from")))
(error (str "Expected 'of' or 'from' at position " p)))
(let (let
((coll (parse-expr))) ((coll (parse-expr)))
(list (quote pick-last) coll n)))))) (list (quote pick-last) coll n))))))
@@ -1666,14 +1726,17 @@
(do (do
(adv!) (adv!)
(if (if
(match-kw "of") (or (match-kw "of") (match-kw "from"))
(let (let
((coll (parse-expr))) ((coll (parse-expr)))
(list (quote pick-random) coll nil)) (list (quote pick-random) coll nil))
(let (let
((n (parse-atom))) ((n (parse-atom)))
(do (do
(expect-kw! "of") (if
(not (or (match-kw "of") (match-kw "from")))
(error
(str "Expected 'of' or 'from' at position " p)))
(let (let
((coll (parse-expr))) ((coll (parse-expr)))
(list (quote pick-random) coll n))))))) (list (quote pick-random) coll n)))))))
@@ -1687,7 +1750,10 @@
(let (let
((end-expr (parse-atom))) ((end-expr (parse-atom)))
(do (do
(expect-kw! "of") (if
(not (or (match-kw "of") (match-kw "from")))
(error
(str "Expected 'of' or 'from' at position " p)))
(let (let
((coll (parse-expr))) ((coll (parse-expr)))
(list (quote pick-items) coll start-expr end-expr)))))))) (list (quote pick-items) coll start-expr end-expr))))))))
@@ -1727,10 +1793,26 @@
(let (let
((haystack (parse-expr))) ((haystack (parse-expr)))
(list (quote pick-matches) regex haystack)))))) (list (quote pick-matches) regex haystack))))))
((and (= typ "ident") (= val "item"))
(do
(adv!)
(let
((n (parse-expr)))
(do
(if
(not (or (match-kw "of") (match-kw "from")))
(error (str "Expected 'of' or 'from' at position " p)))
(let
((coll (parse-expr)))
(list
(quote pick-items)
coll
n
(list (quote +) n 1)))))))
(true (true
(error (error
(str (str
"Expected first/last/random/items/match/matches after 'pick' at " "Expected first/last/random/item/items/match/matches after 'pick' at "
p))))))) p)))))))
(define (define
parse-go-cmd parse-go-cmd

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

@@ -94,7 +94,7 @@
((or (= prop "display") (= prop "opacity")) ((or (= prop "display") (= prop "opacity"))
(if (if
(or (= cur "none") (= cur "0")) (or (= cur "none") (= cur "0"))
(dom-set-style target prop (if (= prop "opacity") "1" "")) (dom-set-style target prop (if (= prop "opacity") "1" "block"))
(dom-set-style target prop (if (= prop "display") "none" "0")))) (dom-set-style target prop (if (= prop "display") "none" "0"))))
(true (true
(if (if
@@ -821,11 +821,26 @@
((nil? suffix) false) ((nil? suffix) false)
(true (ends-with? (str s) (str suffix)))))) (true (ends-with? (str s) (str suffix))))))
(define
hs-scoped-set!
(fn (el name val) (dom-set-data el (str "hs-local-" name) val)))
(define
hs-scoped-get
(fn (el name) (dom-get-data el (str "hs-local-" name))))
(define (define
hs-precedes? hs-precedes?
(fn (fn
(a b) (a b)
(cond ((nil? a) false) ((nil? b) false) (true (< (str a) (str b)))))) (cond
((nil? a) false)
((nil? b) false)
((and (dict? a) (dict? b))
(let
((pos (host-call a "compareDocumentPosition" b)))
(if (number? pos) (not (= 0 (mod (/ pos 4) 2))) false)))
(true (< (str a) (str b))))))
(define (define
hs-follows? hs-follows?
@@ -916,7 +931,18 @@
(= obj (nth r 1)) (= obj (nth r 1))
(= obj nil))))))) (= obj nil)))))))
(define precedes? (fn (a b) (< (str a) (str b)))) (define
precedes?
(fn
(a b)
(cond
((nil? a) false)
((nil? b) false)
((and (dict? a) (dict? b))
(let
((pos (host-call a "compareDocumentPosition" b)))
(if (number? pos) (not (= 0 (mod (/ pos 4) 2))) false)))
(true (< (str a) (str b))))))
(define (define
hs-empty? hs-empty?
@@ -1206,15 +1232,23 @@
(fn (fn
(el strategy) (el strategy)
(let (let
((tag (dom-get-prop el "tagName"))) ((parts (split strategy ":")) (tag (dom-get-prop el "tagName")))
(cond (let
((= tag "DIALOG") ((prop (first parts))
(when (dom-has-attr? el "open") (host-call el "close"))) (val (if (> (len parts) 1) (nth parts 1) nil)))
((= tag "DETAILS") (dom-set-prop el "open" false)) (cond
((= strategy "opacity") (dom-set-style el "opacity" "0")) ((= tag "DIALOG")
((= strategy "visibility") (when (dom-has-attr? el "open") (host-call el "close")))
(dom-set-style el "visibility" "hidden")) ((= tag "DETAILS") (dom-set-prop el "open" false))
(true (dom-set-style el "display" "none")))))) ((= prop "opacity")
(dom-set-style el "opacity" (if val val "0")))
((= prop "visibility")
(dom-set-style el "visibility" (if val val "hidden")))
((= prop "hidden") (dom-set-attr el "hidden" ""))
((= prop "twDisplay") (dom-add-class el "hidden"))
((= prop "twVisibility") (dom-add-class el "invisible"))
((= prop "twOpacity") (dom-add-class el "opacity-0"))
(true (dom-set-style el "display" (if val val "none"))))))))
(define (define
hs-hide! hs-hide!
(fn (fn
@@ -1230,17 +1264,25 @@
(fn (fn
(el strategy) (el strategy)
(let (let
((tag (dom-get-prop el "tagName"))) ((parts (split strategy ":")) (tag (dom-get-prop el "tagName")))
(cond (let
((= tag "DIALOG") ((prop (first parts))
(when (val (if (> (len parts) 1) (nth parts 1) nil)))
(not (dom-has-attr? el "open")) (cond
(host-call el "showModal"))) ((= tag "DIALOG")
((= tag "DETAILS") (dom-set-prop el "open" true)) (when
((= strategy "opacity") (dom-set-style el "opacity" "1")) (not (dom-has-attr? el "open"))
((= strategy "visibility") (host-call el "showModal")))
(dom-set-style el "visibility" "visible")) ((= tag "DETAILS") (dom-set-prop el "open" true))
(true (dom-set-style el "display" "")))))) ((= prop "opacity")
(dom-set-style el "opacity" (if val val "1")))
((= prop "visibility")
(dom-set-style el "visibility" (if val val "visible")))
((= prop "hidden") (dom-remove-attr el "hidden"))
((= prop "twDisplay") (dom-remove-class el "hidden"))
((= prop "twVisibility") (dom-remove-class el "invisible"))
((= prop "twOpacity") (dom-remove-class el "opacity-0"))
(true (dom-set-style el "display" (if val val "block"))))))))
(define (define
hs-show! hs-show!
(fn (fn

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

@@ -436,6 +436,8 @@
(let (let
((ch (hs-cur)) (start pos)) ((ch (hs-cur)) (start pos))
(cond (cond
(and (= ch "-") (< (+ pos 1) src-len) (= (hs-peek 1) "-"))
(do (hs-advance! 2) (skip-comment!) (scan!))
(and (= ch "/") (< (+ pos 1) src-len) (= (hs-peek 1) "/")) (and (= ch "/") (< (+ pos 1) src-len) (= (hs-peek 1) "/"))
(do (hs-advance! 2) (skip-comment!) (scan!)) (do (hs-advance! 2) (skip-comment!) (scan!))
(and (and
@@ -613,6 +615,8 @@
(do (hs-emit! "op" "\\" start) (hs-advance! 1) (scan!)) (do (hs-emit! "op" "\\" start) (hs-advance! 1) (scan!))
(= ch ":") (= ch ":")
(do (hs-emit! "colon" ":" start) (hs-advance! 1) (scan!)) (do (hs-emit! "colon" ":" start) (hs-advance! 1) (scan!))
(= ch "|")
(do (hs-emit! "op" "|" start) (hs-advance! 1) (scan!))
:else (do (hs-advance! 1) (scan!))))))) :else (do (hs-advance! 1) (scan!)))))))
(scan!) (scan!)
(hs-emit! "eof" nil pos) (hs-emit! "eof" nil pos)

147
spec/tests/test-hyperscript-behavioral.sx
View File

@@ -16,13 +16,24 @@
(fn () (fn ()
(dom-set-inner-html (dom-body) ""))) (dom-set-inner-html (dom-body) "")))
;; Evaluate a hyperscript expression and return the last-expression value. ;; Evaluate a hyperscript expression and return either the expression
;; Compiles the expression, wraps in a thunk, evaluates, returns result. ;; value or `it` (whichever is non-nil). Multi-statement scripts that
;; mutate `it` (e.g. `pick first 3 of arr; set $test to it`) get `it` back;
;; bare expressions (e.g. `foo.foo`) get the expression value back.
(define _hs-wrap-body
(fn (sx)
(list (quote let)
(list (list (quote it) nil) (list (quote event) nil))
(list (quote let)
(list (list (quote _ret) sx))
(list (quote if) (list (quote nil?) (quote _ret)) (quote it) (quote _ret))))))
(define eval-hs (define eval-hs
(fn (src) (fn (src)
(let ((sx (hs-to-sx (hs-compile src)))) (let ((sx (hs-to-sx (hs-compile src))))
(let ((handler (eval-expr-cek (let ((handler (eval-expr-cek
(list (quote fn) (list (quote me)) (list (quote let) (list (list (quote it) nil) (list (quote event) nil)) sx))))) (list (quote fn) (list (quote me))
(list (quote let) (list (list (quote it) nil) (list (quote event) nil)) sx)))))
(guard (guard
(_e (_e
(true (true
@@ -33,18 +44,16 @@
(handler nil)))))) (handler nil))))))
;; Evaluate a hyperscript expression with locals. bindings = list of (symbol value). ;; Evaluate a hyperscript expression with locals. bindings = list of (symbol value).
;; The locals are injected as fn params so they resolve in the handler body. ;; Locals are injected as a `let` wrapping the compiled body, then evaluated
;; in a fresh CEK env. Avoids `apply` (whose JIT path can loop on some forms).
(define eval-hs-locals (define eval-hs-locals
(fn (src bindings) (fn (src bindings)
(let ((sx (hs-to-sx (hs-compile src)))) (let ((sx (hs-to-sx (hs-compile src))))
(let ((names (map (fn (b) (first b)) bindings)) ;; Build (let ((name1 (quote val1)) ...) <wrap-body>)
(vals (map (fn (b) (nth b 1)) bindings))) (let ((let-binds (map (fn (b) (list (first b) (list (quote quote) (nth b 1)))) bindings)))
(let ((param-list (cons (quote me) names))) (let ((wrapped (list (quote let) let-binds (_hs-wrap-body sx))))
(let ((wrapper (list (quote fn) param-list (let ((thunk (list (quote fn) (list (quote me)) wrapped)))
(list (quote let) (let ((handler (eval-expr-cek thunk)))
(list (list (quote it) nil) (list (quote event) nil))
sx (quote it)))))
(let ((handler (eval-expr-cek wrapper)))
(guard (guard
(_e (_e
(true (true
@@ -52,14 +61,14 @@
(and (list? _e) (= (first _e) "hs-return")) (and (list? _e) (= (first _e) "hs-return"))
(nth _e 1) (nth _e 1)
(raise _e)))) (raise _e))))
(apply handler (cons nil vals)))))))))) (handler nil)))))))))
;; Evaluate with a specific me value (for "I am between" etc.) ;; Evaluate with a specific me value (for "I am between" etc.)
(define eval-hs-with-me (define eval-hs-with-me
(fn (src me-val) (fn (src me-val)
(let ((sx (hs-to-sx (hs-compile src)))) (let ((sx (hs-to-sx (hs-compile src))))
(let ((handler (eval-expr-cek (let ((handler (eval-expr-cek
(list (quote fn) (list (quote me)) (list (quote let) (list (list (quote it) nil) (list (quote event) nil)) sx))))) (list (quote fn) (list (quote me)) (_hs-wrap-body sx)))))
(guard (guard
(_e (_e
(true (true
@@ -133,7 +142,7 @@
(dom-append (dom-body) _el-div) (dom-append (dom-body) _el-div)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-div "click" nil) (dom-dispatch _el-div "click" nil)
(assert= (dom-get-style _el-div "color") "") (assert= (dom-get-style _el-div "color") "red")
(assert= (dom-get-style _el-div "font-family") "monospace") (assert= (dom-get-style _el-div "font-family") "monospace")
)) ))
(deftest "can add multiple class refs" (deftest "can add multiple class refs"
@@ -163,7 +172,7 @@
(dom-append (dom-body) _el-div) (dom-append (dom-body) _el-div)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-div "click" nil) (dom-dispatch _el-div "click" nil)
(assert= (dom-get-style _el-div "color") "") (assert= (dom-get-style _el-div "color") "red")
)) ))
(deftest "can add to an HTMLCollection" (deftest "can add to an HTMLCollection"
(hs-cleanup!) (hs-cleanup!)
@@ -1287,7 +1296,7 @@
(dom-append (dom-body) _el-div) (dom-append (dom-body) _el-div)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-div "click" nil) (dom-dispatch _el-div "click" nil)
(assert= (dom-get-style _el-div "color") "") (assert= (dom-get-style _el-div "color") "red")
)) ))
(deftest "can take a class from other elements" (deftest "can take a class from other elements"
(hs-cleanup!) (hs-cleanup!)
@@ -2693,7 +2702,7 @@
(dom-append (dom-body) _el-div) (dom-append (dom-body) _el-div)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-div "click" nil) (dom-dispatch _el-div "click" nil)
(assert= (dom-get-style _el-div "background-color") "") (assert= (dom-get-style _el-div "background-color") "red")
)) ))
(deftest "can default variables" (deftest "can default variables"
(hs-cleanup!) (hs-cleanup!)
@@ -2770,7 +2779,7 @@
(dom-append (dom-body) _el-div) (dom-append (dom-body) _el-div)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-div "click" nil) (dom-dispatch _el-div "click" nil)
(assert= (dom-get-style _el-div "color") "") (assert= (dom-get-style _el-div "color") "blue")
)) ))
(deftest "default variables respect existing values" (deftest "default variables respect existing values"
(hs-cleanup!) (hs-cleanup!)
@@ -3286,7 +3295,7 @@
(assert= (eval-hs "[1 + 1, 2 * 3, 10 - 5]") (list 2 6 5)) (assert= (eval-hs "[1 + 1, 2 * 3, 10 - 5]") (list 2 6 5))
) )
(deftest "arrays containing objects work" (deftest "arrays containing objects work"
(assert= (eval-hs "[{a: 1}, {b: 2}]") (list "{a: 1}" "{b: 2}")) (assert= (eval-hs "[{a: 1}, {b: 2}]") (list {:a 1} {:b 2}))
) )
(deftest "deeply nested array literals work" (deftest "deeply nested array literals work"
(assert= (eval-hs "[[[1]], [[2, 3]]]") (list (list (list 1)) (list (list 2 3)))) (assert= (eval-hs "[[[1]], [[2, 3]]]") (list (list (list 1)) (list (list 2 3))))
@@ -3359,7 +3368,7 @@
(dom-dispatch (dom-query-by-id "qsdiv") "click" nil) (dom-dispatch (dom-query-by-id "qsdiv") "click" nil)
)) ))
(deftest "converts an array into HTML" (deftest "converts an array into HTML"
(assert= (eval-hs "d as HTML") "`this-is-html`") (assert= (eval-hs-locals "d as HTML" (list (list (quote d) (list "this-" "is-" "html")))) "`this-is-html`")
) )
(deftest "converts an element into HTML" (deftest "converts an element into HTML"
(error "SKIP (untranslated): converts an element into HTML")) (error "SKIP (untranslated): converts an element into HTML"))
@@ -3389,7 +3398,7 @@
(deftest "converts null as null" (deftest "converts null as null"
(error "SKIP (untranslated): converts null as null")) (error "SKIP (untranslated): converts null as null"))
(deftest "converts numbers things 'HTML'" (deftest "converts numbers things 'HTML'"
(assert= (eval-hs "value as HTML") "123") (assert= (eval-hs-locals "value as HTML" (list (list (quote value) 123))) "123")
) )
(deftest "converts object as Entries" (deftest "converts object as Entries"
(assert= (eval-hs "{a:1} as Entries") (list (list "a" 1))) (assert= (eval-hs "{a:1} as Entries") (list (list "a" 1)))
@@ -3434,7 +3443,7 @@
(assert= (eval-hs "'10' as Number") 10.4) (assert= (eval-hs "'10' as Number") 10.4)
) )
(deftest "converts value as Object" (deftest "converts value as Object"
(assert= (host-get (eval-hs "x as Object") "foo") "bar") (assert= (host-get (eval-hs-locals "x as Object" (list (list (quote x) {:foo "bar"}))) "foo") "bar")
) )
(deftest "converts value as String" (deftest "converts value as String"
(assert= (eval-hs "10 as String") "10") (assert= (eval-hs "10 as String") "10")
@@ -4160,7 +4169,7 @@
(dom-append _el-container _el-span3) (dom-append _el-container _el-span3)
)) ))
(deftest "where binds after property access" (deftest "where binds after property access"
(assert= (eval-hs "obj.items where it > 2") (list 3 4)) (assert= (eval-hs-locals "obj.items where it > 2" (list (list (quote obj) {:items (list 1 2 3 4)}))) (list 3 4))
) )
(deftest "where in component init followed by on feature" (deftest "where in component init followed by on feature"
(hs-cleanup!) (hs-cleanup!)
@@ -4332,8 +4341,8 @@
(assert= (eval-hs "'Hello World' contains 'missing' ignoring case") false) (assert= (eval-hs "'Hello World' contains 'missing' ignoring case") false)
) )
(deftest "contains works with arrays" (deftest "contains works with arrays"
(let ((that 1)) (assert= (eval-hs "I contain that") true)) (assert= (eval-hs-locals "I contain that" (list (list (quote that) 1))) true)
(let ((that "[1")) (assert= (eval-hs "that contains me") true)) (assert= (eval-hs-locals "that contains me" (list (list (quote that) "[1"))) true)
) )
(deftest "contains works with css literals" (deftest "contains works with css literals"
(hs-cleanup!) (hs-cleanup!)
@@ -4486,14 +4495,14 @@
(assert= (eval-hs "2 > 2") false) (assert= (eval-hs "2 > 2") false)
) )
(deftest "include works" (deftest "include works"
(let ((foo "foo") (foobar "foobar")) (assert= (eval-hs "foo includes foobar") false)) (assert= (eval-hs-locals "foo includes foobar" (list (list (quote foo) "foo") (list (quote foobar) "foobar"))) false)
(let ((foo "foo") (foobar "foobar")) (assert= (eval-hs "foobar includes foo") true)) (assert= (eval-hs-locals "foobar includes foo" (list (list (quote foo) "foo") (list (quote foobar) "foobar"))) true)
(let ((foo "foo") (foobar "foobar")) (assert= (eval-hs "foo does not include foobar") true)) (assert= (eval-hs-locals "foo does not include foobar" (list (list (quote foo) "foo") (list (quote foobar) "foobar"))) true)
(let ((foo "foo") (foobar "foobar")) (assert= (eval-hs "foobar does not include foo") false)) (assert= (eval-hs-locals "foobar does not include foo" (list (list (quote foo) "foo") (list (quote foobar) "foobar"))) false)
) )
(deftest "includes works with arrays" (deftest "includes works with arrays"
(let ((that 1)) (assert= (eval-hs "I include that") true)) (assert= (eval-hs-locals "I include that" (list (list (quote that) 1))) true)
(let ((that "[1")) (assert= (eval-hs "that includes me") true)) (assert= (eval-hs-locals "that includes me" (list (list (quote that) "[1"))) true)
) )
(deftest "includes works with css literals" (deftest "includes works with css literals"
(hs-cleanup!) (hs-cleanup!)
@@ -4706,8 +4715,8 @@
(assert= (eval-hs "2 is really '2'") false) (assert= (eval-hs "2 is really '2'") false)
) )
(deftest "is still does equality when rhs variable exists" (deftest "is still does equality when rhs variable exists"
(let ((x 5) (y 5)) (assert= (eval-hs "x is y") true)) (assert= (eval-hs-locals "x is y" (list (list (quote x) 5) (list (quote y) 5))) true)
(let ((x 5) (y 6)) (assert= (eval-hs "x is y") false)) (assert= (eval-hs-locals "x is y" (list (list (quote x) 5) (list (quote y) 6))) false)
) )
(deftest "is works" (deftest "is works"
(assert= (eval-hs "1 is 2") false) (assert= (eval-hs "1 is 2") false)
@@ -5658,7 +5667,7 @@
(dom-append (dom-body) _el-pDiv) (dom-append (dom-body) _el-pDiv)
)) ))
(deftest "can access basic properties" (deftest "can access basic properties"
(assert= (eval-hs "foo's foo") "foo") (assert= (eval-hs-locals "foo's foo" (list (list (quote foo) {:foo "foo"}))) "foo")
) )
(deftest "can access basic style" (deftest "can access basic style"
(hs-cleanup!) (hs-cleanup!)
@@ -5805,32 +5814,32 @@
;; ── expressions/propertyAccess (12 tests) ── ;; ── expressions/propertyAccess (12 tests) ──
(defsuite "hs-upstream-expressions/propertyAccess" (defsuite "hs-upstream-expressions/propertyAccess"
(deftest "can access basic properties" (deftest "can access basic properties"
(assert= (eval-hs "foo.foo") "foo") (assert= (eval-hs-locals "foo.foo" (list (list (quote foo) {:foo "foo"}))) "foo")
) )
(deftest "chained property access (four levels)" (deftest "chained property access (four levels)"
(assert= (eval-hs "a.b.c.d") 42) (assert= (eval-hs-locals "a.b.c.d" (list (list (quote a) {:b {:c {:d 42}}}))) 42)
) )
(deftest "chained property access (three levels)" (deftest "chained property access (three levels)"
(assert= (eval-hs "a.b.c") "deep") (assert= (eval-hs-locals "a.b.c" (list (list (quote a) {:b {:c "deep"}}))) "deep")
) )
(deftest "is null safe" (deftest "is null safe"
(error "SKIP (untranslated): is null safe")) (error "SKIP (untranslated): is null safe"))
(deftest "mixing dot and of forms" (deftest "mixing dot and of forms"
(assert= (eval-hs "c of a.b") "mixed") (assert= (eval-hs-locals "c of a.b" (list (list (quote a) {:b {:c "mixed"}}))) "mixed")
) )
(deftest "null-safe access through an undefined intermediate" (deftest "null-safe access through an undefined intermediate"
(error "SKIP (untranslated): null-safe access through an undefined intermediate")) (error "SKIP (untranslated): null-safe access through an undefined intermediate"))
(deftest "of form chains through multiple levels" (deftest "of form chains through multiple levels"
(assert= (eval-hs "c of b of a") "deep") (assert= (eval-hs-locals "c of b of a" (list (list (quote a) {:b {:c "deep"}}))) "deep")
) )
(deftest "of form works" (deftest "of form works"
(assert= (eval-hs "foo of foo") "foo") (assert= (eval-hs-locals "foo of foo" (list (list (quote foo) {:foo "foo"}))) "foo")
) )
(deftest "of form works w/ complex left side" (deftest "of form works w/ complex left side"
(assert= (eval-hs "bar.doh of foo") "foo") (assert= (eval-hs-locals "bar.doh of foo" (list (list (quote foo) {:bar {:doh "foo"}}))) "foo")
) )
(deftest "of form works w/ complex right side" (deftest "of form works w/ complex right side"
(assert= (eval-hs "doh of foo.bar") "foo") (assert= (eval-hs-locals "doh of foo.bar" (list (list (quote foo) {:bar {:doh "foo"}}))) "foo")
) )
(deftest "property access on function result" (deftest "property access on function result"
(assert= (eval-hs "makeObj().name") "hi") (assert= (eval-hs "makeObj().name") "hi")
@@ -6350,7 +6359,7 @@
(assert= (eval-hs "\"foo\"") "foo") (assert= (eval-hs "\"foo\"") "foo")
) )
(deftest "should handle back slashes in non-template content" (deftest "should handle back slashes in non-template content"
(assert= (eval-hs "`https://${foo}`") "https://bar") (assert= (eval-hs-locals "`https://${foo}`" (list (list (quote foo) "bar"))) "https://bar")
) )
(deftest "should handle strings with tags and quotes" (deftest "should handle strings with tags and quotes"
(error "SKIP (untranslated): should handle strings with tags and quotes")) (error "SKIP (untranslated): should handle strings with tags and quotes"))
@@ -6425,7 +6434,7 @@
(deftest "resolves global context properly" (deftest "resolves global context properly"
(error "SKIP (untranslated): resolves global context properly")) (error "SKIP (untranslated): resolves global context properly"))
(deftest "resolves local context properly" (deftest "resolves local context properly"
(assert= (eval-hs "foo") 42) (assert= (eval-hs-locals "foo" (list (list (quote foo) 42))) 42)
) )
) )
@@ -9348,7 +9357,7 @@
(dom-append (dom-body) _el-div) (dom-append (dom-body) _el-div)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-div "click" nil) (dom-dispatch _el-div "click" nil)
(assert= (dom-get-style _el-div "color") "") (assert= (dom-get-style _el-div "color") "red")
)) ))
(deftest "can put array vals w/ array access syntax and var" (deftest "can put array vals w/ array access syntax and var"
(hs-cleanup!) (hs-cleanup!)
@@ -9358,7 +9367,7 @@
(dom-append (dom-body) _el-div) (dom-append (dom-body) _el-div)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-div "click" nil) (dom-dispatch _el-div "click" nil)
(assert= (dom-get-style _el-div "color") "") (assert= (dom-get-style _el-div "color") "red")
)) ))
(deftest "can put at end of an array" (deftest "can put at end of an array"
(hs-cleanup!) (hs-cleanup!)
@@ -9416,7 +9425,7 @@
(dom-append (dom-body) _el-div) (dom-append (dom-body) _el-div)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-div "click" nil) (dom-dispatch _el-div "click" nil)
(assert= (dom-get-style _el-div "color") "") (assert= (dom-get-style _el-div "color") "red")
)) ))
(deftest "can put properties w/ array access syntax and var" (deftest "can put properties w/ array access syntax and var"
(hs-cleanup!) (hs-cleanup!)
@@ -9426,7 +9435,7 @@
(dom-append (dom-body) _el-div) (dom-append (dom-body) _el-div)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-div "click" nil) (dom-dispatch _el-div "click" nil)
(assert= (dom-get-style _el-div "color") "") (assert= (dom-get-style _el-div "color") "red")
)) ))
(deftest "can set into attribute ref" (deftest "can set into attribute ref"
(hs-cleanup!) (hs-cleanup!)
@@ -9526,7 +9535,7 @@
(dom-append (dom-body) _el-div) (dom-append (dom-body) _el-div)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-div "click" nil) (dom-dispatch _el-div "click" nil)
(assert= (dom-get-style _el-div "color") "") (assert= (dom-get-style _el-div "color") "red")
)) ))
(deftest "can set into indirect style ref 2" (deftest "can set into indirect style ref 2"
(hs-cleanup!) (hs-cleanup!)
@@ -9538,7 +9547,7 @@
(dom-append (dom-body) _el-div2) (dom-append (dom-body) _el-div2)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-div "click" nil) (dom-dispatch _el-div "click" nil)
(assert= (dom-get-style (dom-query-by-id "div2") "color") "") (assert= (dom-get-style (dom-query-by-id "div2") "color") "red")
)) ))
(deftest "can set into indirect style ref 3" (deftest "can set into indirect style ref 3"
(hs-cleanup!) (hs-cleanup!)
@@ -9550,7 +9559,7 @@
(dom-append (dom-body) _el-div2) (dom-append (dom-body) _el-div2)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-div "click" nil) (dom-dispatch _el-div "click" nil)
(assert= (dom-get-style (dom-query-by-id "div2") "color") "") (assert= (dom-get-style (dom-query-by-id "div2") "color") "red")
)) ))
(deftest "can set into style ref" (deftest "can set into style ref"
(hs-cleanup!) (hs-cleanup!)
@@ -9560,7 +9569,7 @@
(dom-append (dom-body) _el-div) (dom-append (dom-body) _el-div)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-div "click" nil) (dom-dispatch _el-div "click" nil)
(assert= (dom-get-style _el-div "color") "") (assert= (dom-get-style _el-div "color") "red")
)) ))
(deftest "can set javascript globals" (deftest "can set javascript globals"
(hs-cleanup!) (hs-cleanup!)
@@ -9599,7 +9608,7 @@
(dom-append (dom-body) _el-div) (dom-append (dom-body) _el-div)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-div "click" nil) (dom-dispatch _el-div "click" nil)
(assert= (dom-get-style _el-div "color") "") (assert= (dom-get-style _el-div "color") "red")
)) ))
(deftest "is null tolerant" (deftest "is null tolerant"
(hs-cleanup!) (hs-cleanup!)
@@ -9623,7 +9632,7 @@
(hs-cleanup!) (hs-cleanup!)
(let ((_el-d1 (dom-create-element "div"))) (let ((_el-d1 (dom-create-element "div")))
(dom-set-attr _el-d1 "id" "d1") (dom-set-attr _el-d1 "id" "d1")
(dom-set-attr _el-d1 "_" "on click put \"<button id=\"b1\" _=\"on click put 42 into me\">40</button>\" after me") (dom-set-attr _el-d1 "_" "on click put \"<button id=\\\"b1\\\" _=\\\"on click put 42 into me\\\">40</button>\" after me")
(dom-append (dom-body) _el-d1) (dom-append (dom-body) _el-d1)
(hs-activate! _el-d1) (hs-activate! _el-d1)
(dom-dispatch (dom-query-by-id "d1") "click" nil) (dom-dispatch (dom-query-by-id "d1") "click" nil)
@@ -9635,7 +9644,7 @@
(hs-cleanup!) (hs-cleanup!)
(let ((_el-d1 (dom-create-element "div"))) (let ((_el-d1 (dom-create-element "div")))
(dom-set-attr _el-d1 "id" "d1") (dom-set-attr _el-d1 "id" "d1")
(dom-set-attr _el-d1 "_" "on click put \"<button id=\"b1\" _=\"on click put 42 into me\">40</button>\" at the end of me") (dom-set-attr _el-d1 "_" "on click put \"<button id=\\\"b1\\\" _=\\\"on click put 42 into me\\\">40</button>\" at the end of me")
(dom-append (dom-body) _el-d1) (dom-append (dom-body) _el-d1)
(hs-activate! _el-d1) (hs-activate! _el-d1)
(dom-dispatch (dom-query-by-id "d1") "click" nil) (dom-dispatch (dom-query-by-id "d1") "click" nil)
@@ -9646,7 +9655,7 @@
(hs-cleanup!) (hs-cleanup!)
(let ((_el-d1 (dom-create-element "div"))) (let ((_el-d1 (dom-create-element "div")))
(dom-set-attr _el-d1 "id" "d1") (dom-set-attr _el-d1 "id" "d1")
(dom-set-attr _el-d1 "_" "on click put \"<button id=\"b1\" _=\"on click put 42 into me\">40</button>\" at the start of me") (dom-set-attr _el-d1 "_" "on click put \"<button id=\\\"b1\\\" _=\\\"on click put 42 into me\\\">40</button>\" at the start of me")
(dom-append (dom-body) _el-d1) (dom-append (dom-body) _el-d1)
(hs-activate! _el-d1) (hs-activate! _el-d1)
(dom-dispatch (dom-query-by-id "d1") "click" nil) (dom-dispatch (dom-query-by-id "d1") "click" nil)
@@ -9657,7 +9666,7 @@
(hs-cleanup!) (hs-cleanup!)
(let ((_el-d1 (dom-create-element "div"))) (let ((_el-d1 (dom-create-element "div")))
(dom-set-attr _el-d1 "id" "d1") (dom-set-attr _el-d1 "id" "d1")
(dom-set-attr _el-d1 "_" "on click put \"<button id=\"b1\" _=\"on click put 42 into me\">40</button>\" before me") (dom-set-attr _el-d1 "_" "on click put \"<button id=\\\"b1\\\" _=\\\"on click put 42 into me\\\">40</button>\" before me")
(dom-append (dom-body) _el-d1) (dom-append (dom-body) _el-d1)
(hs-activate! _el-d1) (hs-activate! _el-d1)
(dom-dispatch (dom-query-by-id "d1") "click" nil) (dom-dispatch (dom-query-by-id "d1") "click" nil)
@@ -9669,7 +9678,7 @@
(hs-cleanup!) (hs-cleanup!)
(let ((_el-d1 (dom-create-element "div"))) (let ((_el-d1 (dom-create-element "div")))
(dom-set-attr _el-d1 "id" "d1") (dom-set-attr _el-d1 "id" "d1")
(dom-set-attr _el-d1 "_" "on click put \"<button id=\"b1\" _=\"on click put 42 into me\">40</button>\" into <div#d1/>") (dom-set-attr _el-d1 "_" "on click put \"<button id=\\\"b1\\\" _=\\\"on click put 42 into me\\\">40</button>\" into <div#d1/>")
(dom-append (dom-body) _el-d1) (dom-append (dom-body) _el-d1)
(hs-activate! _el-d1) (hs-activate! _el-d1)
(dom-dispatch (dom-query-by-id "d1") "click" nil) (dom-dispatch (dom-query-by-id "d1") "click" nil)
@@ -9679,7 +9688,7 @@
(deftest "properly processes hyperscript in new content in a symbol write" (deftest "properly processes hyperscript in new content in a symbol write"
(hs-cleanup!) (hs-cleanup!)
(let ((_el-div (dom-create-element "div"))) (let ((_el-div (dom-create-element "div")))
(dom-set-attr _el-div "_" "on click put \"<button id=\"b1\" _=\"on click put 42 into me\">40</button>\" into me") (dom-set-attr _el-div "_" "on click put \"<button id=\\\"b1\\\" _=\\\"on click put 42 into me\\\">40</button>\" into me")
(dom-append (dom-body) _el-div) (dom-append (dom-body) _el-div)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-div "click" nil) (dom-dispatch _el-div "click" nil)
@@ -10736,7 +10745,7 @@
(dom-append (dom-body) _el-div) (dom-append (dom-body) _el-div)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-div "click" nil) (dom-dispatch _el-div "click" nil)
(assert= (dom-get-style _el-div "color") "") (assert= (dom-get-style _el-div "color") "red")
)) ))
(deftest "can set arrays w/ array access syntax and var" (deftest "can set arrays w/ array access syntax and var"
(hs-cleanup!) (hs-cleanup!)
@@ -10746,7 +10755,7 @@
(dom-append (dom-body) _el-div) (dom-append (dom-body) _el-div)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-div "click" nil) (dom-dispatch _el-div "click" nil)
(assert= (dom-get-style _el-div "color") "") (assert= (dom-get-style _el-div "color") "red")
)) ))
(deftest "can set chained indirect properties" (deftest "can set chained indirect properties"
(hs-cleanup!) (hs-cleanup!)
@@ -10869,7 +10878,7 @@
(dom-append (dom-body) _el-div2) (dom-append (dom-body) _el-div2)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-div "click" nil) (dom-dispatch _el-div "click" nil)
(assert= (dom-get-style (dom-query-by-id "div2") "color") "") (assert= (dom-get-style (dom-query-by-id "div2") "color") "red")
)) ))
(deftest "can set into indirect style ref 2" (deftest "can set into indirect style ref 2"
(hs-cleanup!) (hs-cleanup!)
@@ -10881,7 +10890,7 @@
(dom-append (dom-body) _el-div2) (dom-append (dom-body) _el-div2)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-div "click" nil) (dom-dispatch _el-div "click" nil)
(assert= (dom-get-style (dom-query-by-id "div2") "color") "") (assert= (dom-get-style (dom-query-by-id "div2") "color") "red")
)) ))
(deftest "can set into indirect style ref 3" (deftest "can set into indirect style ref 3"
(hs-cleanup!) (hs-cleanup!)
@@ -10893,7 +10902,7 @@
(dom-append (dom-body) _el-div2) (dom-append (dom-body) _el-div2)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-div "click" nil) (dom-dispatch _el-div "click" nil)
(assert= (dom-get-style (dom-query-by-id "div2") "color") "") (assert= (dom-get-style (dom-query-by-id "div2") "color") "red")
)) ))
(deftest "can set into style ref" (deftest "can set into style ref"
(hs-cleanup!) (hs-cleanup!)
@@ -10903,7 +10912,7 @@
(dom-append (dom-body) _el-div) (dom-append (dom-body) _el-div)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-div "click" nil) (dom-dispatch _el-div "click" nil)
(assert= (dom-get-style _el-div "color") "") (assert= (dom-get-style _el-div "color") "red")
)) ))
(deftest "can set javascript globals" (deftest "can set javascript globals"
(hs-cleanup!) (hs-cleanup!)
@@ -10950,7 +10959,7 @@
(dom-append (dom-body) _el-div) (dom-append (dom-body) _el-div)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-div "click" nil) (dom-dispatch _el-div "click" nil)
(assert= (dom-get-style _el-div "color") "") (assert= (dom-get-style _el-div "color") "red")
)) ))
(deftest "can set props w/ array access syntax and var" (deftest "can set props w/ array access syntax and var"
(hs-cleanup!) (hs-cleanup!)
@@ -10960,7 +10969,7 @@
(dom-append (dom-body) _el-div) (dom-append (dom-body) _el-div)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-div "click" nil) (dom-dispatch _el-div "click" nil)
(assert= (dom-get-style _el-div "color") "") (assert= (dom-get-style _el-div "color") "red")
)) ))
(deftest "can set styles" (deftest "can set styles"
(hs-cleanup!) (hs-cleanup!)
@@ -10970,7 +10979,7 @@
(dom-append (dom-body) _el-div) (dom-append (dom-body) _el-div)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-div "click" nil) (dom-dispatch _el-div "click" nil)
(assert= (dom-get-style _el-div "color") "") (assert= (dom-get-style _el-div "color") "red")
)) ))
(deftest "global ($) variables are allowed at the feature level" (deftest "global ($) variables are allowed at the feature level"
(hs-cleanup!) (hs-cleanup!)

126
tests/playwright/generate-sx-tests.py
View File

@@ -214,8 +214,10 @@ def parse_html(html):
# Remove | separators # Remove | separators
html = html.replace(' | ', '') html = html.replace(' | ', '')
# Fix escaped attribute delimiters from JSON extraction (\" → ") # Note: previously we collapsed `\"` → `"` here, but that destroys legitimate
html = html.replace('\\"', '"') # HS string escapes inside single-quoted `_='...'` attributes (e.g. nested
# button HTML in `properly processes hyperscript X` tests). HTMLParser handles
# backslashes in attribute values as literal characters, so we leave them.
elements = [] elements = []
stack = [] stack = []
@@ -680,6 +682,17 @@ def pw_assertion_to_sx(target, negated, assert_type, args_str):
elif assert_type == 'toHaveCSS': elif assert_type == 'toHaveCSS':
prop = args[0] if args else '' prop = args[0] if args else ''
val = args[1] if len(args) >= 2 else '' val = args[1] if len(args) >= 2 else ''
# Browsers normalize colors to rgb()/rgba(); our DOM mock returns the
# raw inline value. Map common rgb() forms back to keywords.
rgb_to_name = {
'rgb(255, 0, 0)': 'red',
'rgb(0, 255, 0)': 'green',
'rgb(0, 0, 255)': 'blue',
'rgb(0, 0, 0)': 'black',
'rgb(255, 255, 255)': 'white',
}
if val in rgb_to_name:
val = rgb_to_name[val]
escaped = val.replace('\\', '\\\\').replace('"', '\\"') escaped = val.replace('\\', '\\\\').replace('"', '\\"')
if negated: if negated:
return f'(assert (!= (dom-get-style {target} "{prop}") "{escaped}"))' return f'(assert (!= (dom-get-style {target} "{prop}") "{escaped}"))'
@@ -764,7 +777,7 @@ def parse_dev_body(body, elements, var_names):
m = re.search( m = re.search(
r"expect\(find\((['\"])(.+?)\1\)(?:\.(?:first|last)\(\))?\)\.(not\.)?" r"expect\(find\((['\"])(.+?)\1\)(?:\.(?:first|last)\(\))?\)\.(not\.)?"
r"(toHaveText|toHaveClass|toHaveCSS|toHaveAttribute|toHaveValue|toBeVisible|toBeHidden|toBeChecked)" r"(toHaveText|toHaveClass|toHaveCSS|toHaveAttribute|toHaveValue|toBeVisible|toBeHidden|toBeChecked)"
r"\(([^)]*)\)", r"\(((?:[^()]|\([^()]*\))*)\)",
line line
) )
if m: if m:
@@ -956,6 +969,24 @@ def js_val_to_sx(val):
return '(list)' return '(list)'
items = [js_val_to_sx(x.strip()) for x in split_top_level(inner)] items = [js_val_to_sx(x.strip()) for x in split_top_level(inner)]
return '(list ' + ' '.join(items) + ')' return '(list ' + ' '.join(items) + ')'
# Objects: { foo: "bar", baz: 1 } → {:foo "bar" :baz 1}
if val.startswith('{') and val.endswith('}'):
inner = val[1:-1].strip()
if not inner:
return '{}'
parts = []
for kv in split_top_level(inner):
kv = kv.strip()
if not kv:
continue
# key: value (key is identifier or quoted string)
m = re.match(r'^(?:"([^"]+)"|\'([^\']+)\'|(\w+))\s*:\s*(.+)$', kv, re.DOTALL)
if not m:
return f'"{val}"'
key = m.group(1) or m.group(2) or m.group(3)
v = js_val_to_sx(m.group(4))
parts.append(f':{key} {v}')
return '{' + ' '.join(parts) + '}'
try: try:
float(val) float(val)
return val return val
@@ -1044,12 +1075,13 @@ def generate_eval_only_test(test, idx):
me_match = re.search(r'\bme:\s*(\d+)', opts_str) me_match = re.search(r'\bme:\s*(\d+)', opts_str)
locals_match = re.search(r'locals:\s*\{([^}]+)\}', opts_str) locals_match = re.search(r'locals:\s*\{([^}]+)\}', opts_str)
if locals_match: if locals_match:
local_bindings = [] local_pairs = []
for lm in re.finditer(r'(\w+)\s*:\s*([^,}]+)', locals_match.group(1)): for lm in re.finditer(r'(\w+)\s*:\s*([^,}]+)', locals_match.group(1)):
lname = lm.group(1) lname = lm.group(1)
lval = js_val_to_sx(lm.group(2).strip()) lval = js_val_to_sx(lm.group(2).strip())
local_bindings.append(f'({lname} {lval})') local_pairs.append((lname, lval))
assertions.append(f' (let ({" ".join(local_bindings)}) (assert= (eval-hs "{hs_expr}") {expected_sx}))') locals_sx = '(list ' + ' '.join(f'(list (quote {n}) {v})' for n, v in local_pairs) + ')' if local_pairs else '(list)'
assertions.append(f' (assert= (eval-hs-locals "{hs_expr}" {locals_sx}) {expected_sx})')
elif me_match: elif me_match:
me_val = me_match.group(1) me_val = me_match.group(1)
assertions.append(f' (assert= (eval-hs-with-me "{hs_expr}" {me_val}) {expected_sx})') assertions.append(f' (assert= (eval-hs-with-me "{hs_expr}" {me_val}) {expected_sx})')
@@ -1088,6 +1120,43 @@ def generate_eval_only_test(test, idx):
if run_match: if run_match:
hs_expr = extract_hs_expr(run_match.group(2)) hs_expr = extract_hs_expr(run_match.group(2))
var_name = re.search(r'(?:var|let|const)\s+(\w+)', body).group(1) var_name = re.search(r'(?:var|let|const)\s+(\w+)', body).group(1)
# Capture locals from the run() call, if present. Use balanced-brace
# extraction so nested {a: {b: 1}} doesn't truncate at the inner }.
local_pairs = []
locals_idx = body.find('locals:')
if locals_idx >= 0:
# Find the opening { after "locals:"
open_idx = body.find('{', locals_idx)
if open_idx >= 0:
depth = 0
end_idx = -1
in_str = None
for i in range(open_idx, len(body)):
ch = body[i]
if in_str:
if ch == in_str and body[i-1] != '\\':
in_str = None
continue
if ch in ('"', "'", '`'):
in_str = ch
continue
if ch == '{':
depth += 1
elif ch == '}':
depth -= 1
if depth == 0:
end_idx = i
break
if end_idx > open_idx:
locals_str = body[open_idx + 1:end_idx].strip()
for kv in split_top_level(locals_str):
kv = kv.strip()
m = re.match(r'^(\w+)\s*:\s*(.+)$', kv, re.DOTALL)
if m:
local_pairs.append((m.group(1), js_val_to_sx(m.group(2).strip())))
locals_sx = '(list ' + ' '.join(f'(list (quote {n}) {v})' for n, v in local_pairs) + ')' if local_pairs else None
def eval_call(expr):
return f'(eval-hs-locals "{expr}" {locals_sx})' if locals_sx else f'(eval-hs "{expr}")'
for m in re.finditer(r'expect\((' + re.escape(var_name) + r'(?:\["[^"]+"\]|\.\w+)?)\)\.toBe\(([^)]+)\)', body): for m in re.finditer(r'expect\((' + re.escape(var_name) + r'(?:\["[^"]+"\]|\.\w+)?)\)\.toBe\(([^)]+)\)', body):
accessor = m.group(1) accessor = m.group(1)
expected_sx = js_val_to_sx(m.group(2)) expected_sx = js_val_to_sx(m.group(2))
@@ -1095,17 +1164,17 @@ def generate_eval_only_test(test, idx):
prop_m = re.search(r'\["([^"]+)"\]|\.(\w+)', accessor[len(var_name):]) prop_m = re.search(r'\["([^"]+)"\]|\.(\w+)', accessor[len(var_name):])
if prop_m: if prop_m:
prop = prop_m.group(1) or prop_m.group(2) prop = prop_m.group(1) or prop_m.group(2)
assertions.append(f' (assert= (host-get (eval-hs "{hs_expr}") "{prop}") {expected_sx})') assertions.append(f' (assert= (host-get {eval_call(hs_expr)} "{prop}") {expected_sx})')
else: else:
assertions.append(f' (assert= (eval-hs "{hs_expr}") {expected_sx})') assertions.append(f' (assert= {eval_call(hs_expr)} {expected_sx})')
for m in re.finditer(r'expect\(' + re.escape(var_name) + r'(?:\.\w+)?\)\.toEqual\((\[.*?\])\)', body, re.DOTALL): for m in re.finditer(r'expect\(' + re.escape(var_name) + r'(?:\.\w+)?\)\.toEqual\((\[.*?\])\)', body, re.DOTALL):
expected_sx = js_val_to_sx(m.group(1)) expected_sx = js_val_to_sx(m.group(1))
assertions.append(f' (assert= (eval-hs "{hs_expr}") {expected_sx})') assertions.append(f' (assert= {eval_call(hs_expr)} {expected_sx})')
# Handle .map(x => x.prop) before toEqual # Handle .map(x => x.prop) before toEqual
for m in re.finditer(r'expect\(' + re.escape(var_name) + r'\.map\(\w+\s*=>\s*\w+\.(\w+)\)\)\.toEqual\((\[.*?\])\)', body, re.DOTALL): for m in re.finditer(r'expect\(' + re.escape(var_name) + r'\.map\(\w+\s*=>\s*\w+\.(\w+)\)\)\.toEqual\((\[.*?\])\)', body, re.DOTALL):
prop = m.group(1) prop = m.group(1)
expected_sx = js_val_to_sx(m.group(2)) expected_sx = js_val_to_sx(m.group(2))
assertions.append(f' (assert= (map (fn (x) (get x "{prop}")) (eval-hs "{hs_expr}")) {expected_sx})') assertions.append(f' (assert= (map (fn (x) (get x "{prop}")) {eval_call(hs_expr)}) {expected_sx})')
# Pattern 2b: run() with locals + evaluate(window.X) + expect().toBe/toEqual # Pattern 2b: run() with locals + evaluate(window.X) + expect().toBe/toEqual
# e.g.: await run(`expr`, {locals: {arr: [1,2,3]}}); # e.g.: await run(`expr`, {locals: {arr: [1,2,3]}});
@@ -1480,13 +1549,24 @@ output.append('(define hs-cleanup!')
output.append(' (fn ()') output.append(' (fn ()')
output.append(' (dom-set-inner-html (dom-body) "")))') output.append(' (dom-set-inner-html (dom-body) "")))')
output.append('') output.append('')
output.append(';; Evaluate a hyperscript expression and return the last-expression value.') output.append(';; Evaluate a hyperscript expression and return either the expression')
output.append(';; Compiles the expression, wraps in a thunk, evaluates, returns result.') output.append(';; value or `it` (whichever is non-nil). Multi-statement scripts that')
output.append(';; mutate `it` (e.g. `pick first 3 of arr; set $test to it`) get `it` back;')
output.append(';; bare expressions (e.g. `foo.foo`) get the expression value back.')
output.append('(define _hs-wrap-body')
output.append(' (fn (sx)')
output.append(' (list (quote let)')
output.append(' (list (list (quote it) nil) (list (quote event) nil))')
output.append(' (list (quote let)')
output.append(' (list (list (quote _ret) sx))')
output.append(' (list (quote if) (list (quote nil?) (quote _ret)) (quote it) (quote _ret))))))')
output.append('')
output.append('(define eval-hs') output.append('(define eval-hs')
output.append(' (fn (src)') output.append(' (fn (src)')
output.append(' (let ((sx (hs-to-sx (hs-compile src))))') output.append(' (let ((sx (hs-to-sx (hs-compile src))))')
output.append(' (let ((handler (eval-expr-cek') output.append(' (let ((handler (eval-expr-cek')
output.append(' (list (quote fn) (list (quote me)) (list (quote let) (list (list (quote it) nil) (list (quote event) nil)) sx)))))') output.append(' (list (quote fn) (list (quote me))')
output.append(' (list (quote let) (list (list (quote it) nil) (list (quote event) nil)) sx)))))')
output.append(' (guard') output.append(' (guard')
output.append(' (_e') output.append(' (_e')
output.append(' (true') output.append(' (true')
@@ -1497,18 +1577,16 @@ output.append(' (raise _e))))')
output.append(' (handler nil))))))') output.append(' (handler nil))))))')
output.append('') output.append('')
output.append(';; Evaluate a hyperscript expression with locals. bindings = list of (symbol value).') output.append(';; Evaluate a hyperscript expression with locals. bindings = list of (symbol value).')
output.append(';; The locals are injected as fn params so they resolve in the handler body.') output.append(';; Locals are injected as a `let` wrapping the compiled body, then evaluated')
output.append(';; in a fresh CEK env. Avoids `apply` (whose JIT path can loop on some forms).')
output.append('(define eval-hs-locals') output.append('(define eval-hs-locals')
output.append(' (fn (src bindings)') output.append(' (fn (src bindings)')
output.append(' (let ((sx (hs-to-sx (hs-compile src))))') output.append(' (let ((sx (hs-to-sx (hs-compile src))))')
output.append(' (let ((names (map (fn (b) (first b)) bindings))') output.append(' ;; Build (let ((name1 (quote val1)) ...) <wrap-body>)')
output.append(' (vals (map (fn (b) (nth b 1)) bindings)))') output.append(' (let ((let-binds (map (fn (b) (list (first b) (list (quote quote) (nth b 1)))) bindings)))')
output.append(' (let ((param-list (cons (quote me) names)))') output.append(' (let ((wrapped (list (quote let) let-binds (_hs-wrap-body sx))))')
output.append(' (let ((wrapper (list (quote fn) param-list') output.append(' (let ((thunk (list (quote fn) (list (quote me)) wrapped)))')
output.append(' (list (quote let)') output.append(' (let ((handler (eval-expr-cek thunk)))')
output.append(' (list (list (quote it) nil) (list (quote event) nil))')
output.append(' sx (quote it)))))')
output.append(' (let ((handler (eval-expr-cek wrapper)))')
output.append(' (guard') output.append(' (guard')
output.append(' (_e') output.append(' (_e')
output.append(' (true') output.append(' (true')
@@ -1516,14 +1594,14 @@ output.append(' (if')
output.append(' (and (list? _e) (= (first _e) "hs-return"))') output.append(' (and (list? _e) (= (first _e) "hs-return"))')
output.append(' (nth _e 1)') output.append(' (nth _e 1)')
output.append(' (raise _e))))') output.append(' (raise _e))))')
output.append(' (apply handler (cons nil vals))))))))))') output.append(' (handler nil)))))))))')
output.append('') output.append('')
output.append(';; Evaluate with a specific me value (for "I am between" etc.)') output.append(';; Evaluate with a specific me value (for "I am between" etc.)')
output.append('(define eval-hs-with-me') output.append('(define eval-hs-with-me')
output.append(' (fn (src me-val)') output.append(' (fn (src me-val)')
output.append(' (let ((sx (hs-to-sx (hs-compile src))))') output.append(' (let ((sx (hs-to-sx (hs-compile src))))')
output.append(' (let ((handler (eval-expr-cek') output.append(' (let ((handler (eval-expr-cek')
output.append(' (list (quote fn) (list (quote me)) (list (quote let) (list (list (quote it) nil) (list (quote event) nil)) sx)))))') output.append(' (list (quote fn) (list (quote me)) (_hs-wrap-body sx)))))')
output.append(' (guard') output.append(' (guard')
output.append(' (_e') output.append(' (_e')
output.append(' (true') output.append(' (true')