8 Commits

Author SHA1 Message Date
35aa998fcc tcl: tick Phase 1 parser checkboxes, update progress log
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 11s
2026-04-25 18:47:45 +00:00
6ee052593c tcl: Phase 1 parser — word-simple? + word-literal helpers (+15 tests, 67 total) 2026-04-25 18:47:34 +00:00
1a17d8d232 tcl: tick Phase 1 tokenizer, add progress log entry
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
2026-04-25 18:22:25 +00:00
666e29d5f0 tcl: Phase 1 tokenizer — Dodekalogue (52 tests green) 2026-04-25 18:22:10 +00:00
3316d402fd HS: null-safety piece 1 — eval-hs-error recognizer + helper (+18 tests unlocked)
Add recognizer for expect(await error("HS")).toBe("MSG") pattern in
generate-sx-tests.py, plus eval-hs-error SX helper in the generated
test file. All 18 runtimeErrors tests now generate real test cases
instead of SKIP stubs.

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
2026-04-25 12:10:19 +00:00
fb72c4ab9c sx-loops: add common-lisp, apl, ruby, tcl (12 slots)
Plans + briefings for four new language loops, each with a delcc/JIT
showcase that the runtime already supports natively:

- common-lisp — conditions + restarts on delimited continuations
- apl — rank-polymorphic primitives + 6 operators on the JIT
- ruby — fibers as delcc, blocks/yield as escape continuations
- tcl — uplevel/upvar via first-class env chain, the Dodekalogue

Launcher scripts now spawn 12 windows (was 8).
2026-04-25 09:25:30 +00:00
e52c209c3d hs: drain plan for blockers + Bucket E + F
Tracks the path from 1277/1496 (85.4%) to 100%. Records each blocker's
fix sketch, files in scope, and order of attack. Cluster #31 spec'd in
detail for the next focused sit-down.
2026-04-25 08:54:00 +00:00
6a00df2609 smalltalk: plan + briefing + sx-loops 8th slot
Showcase: blocks with non-local return on captured method-return
continuation. ANSI-ish Smalltalk-80 subset, SUnit + Pharo Kernel-Tests
slice, 7 phases. Worktree: /root/rose-ash-loops/smalltalk on
branch loops/smalltalk.
2026-04-25 00:05:31 +00:00
29 changed files with 2105 additions and 1281 deletions

View File

@@ -164,16 +164,13 @@
every? every?
catch-info catch-info
finally-info finally-info
having-info having-info)
of-filter-info
count-filter-info
elsewhere?)
(cond (cond
((<= (len items) 1) ((<= (len items) 1)
(let (let
((body (if (> (len items) 0) (first items) nil))) ((body (if (> (len items) 0) (first items) nil)))
(let (let
((target (cond (elsewhere? (list (quote dom-body))) (source (hs-to-sx source)) (true (quote me))))) ((target (if source (hs-to-sx source) (quote me))))
(let (let
((event-refs (if (and (list? body) (= (first body) (quote do))) (filter (fn (x) (and (list? x) (= (first x) (quote ref)))) (rest body)) (list)))) ((event-refs (if (and (list? body) (= (first body) (quote do))) (filter (fn (x) (and (list? x) (= (first x) (quote ref)))) (rest body)) (list))))
(let (let
@@ -181,51 +178,30 @@
(let (let
((raw-compiled (hs-to-sx stripped-body))) ((raw-compiled (hs-to-sx stripped-body)))
(let (let
((compiled-body (let ((base (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))) (if elsewhere? (list (quote when) (list (quote not) (list (quote host-call) (quote me) "contains" (list (quote host-get) (quote event) "target"))) base) base)))) ((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))))
(let (let
((handler (let ((uses-the-result? (fn (expr) (cond ((= expr (quote the-result)) true) ((list? expr) (some (fn (x) (uses-the-result? x)) expr)) (true false))))) (let ((base-handler (list (quote fn) (list (quote event)) (if (uses-the-result? wrapped-body) (list (quote let) (list (list (quote the-result) nil)) wrapped-body) wrapped-body)))) (if count-filter-info (let ((mn (get count-filter-info "min")) (mx (get count-filter-info "max"))) (list (quote let) (list (list (quote __hs-count) 0)) (list (quote fn) (list (quote event)) (list (quote begin) (list (quote set!) (quote __hs-count) (list (quote +) (quote __hs-count) 1)) (list (quote when) (if (= mx -1) (list (quote >=) (quote __hs-count) mn) (list (quote and) (list (quote >=) (quote __hs-count) mn) (list (quote <=) (quote __hs-count) mx))) (nth base-handler 2)))))) base-handler))))) ((handler (let ((uses-the-result? (fn (expr) (cond ((= expr (quote the-result)) true) ((list? expr) (some (fn (x) (uses-the-result? x)) expr)) (true false))))) (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)))))
(let (let
((on-call (if every? (list (quote hs-on-every) target event-name handler) (list (quote hs-on) target event-name handler)))) ((on-call (if every? (list (quote hs-on-every) target event-name handler) (list (quote hs-on) target event-name handler))))
(cond (if
((= event-name "mutation") (= event-name "intersection")
(list
(quote do)
on-call
(list (list
(quote do) (quote hs-on-intersection-attach!)
on-call target
(list (if
(quote hs-on-mutation-attach!) having-info
target (get having-info "margin")
(if nil)
of-filter-info (if
(get of-filter-info "type") having-info
"any") (get having-info "threshold")
(if nil)))
of-filter-info on-call)))))))))))
(let
((a (get of-filter-info "attrs")))
(if
a
(cons (quote list) a)
nil))
nil))))
((= event-name "intersection")
(list
(quote do)
on-call
(list
(quote
hs-on-intersection-attach!)
target
(if
having-info
(get having-info "margin")
nil)
(if
having-info
(get having-info "threshold")
nil))))
(true on-call))))))))))))
((= (first items) :from) ((= (first items) :from)
(scan-on (scan-on
(rest (rest items)) (rest (rest items))
@@ -234,10 +210,7 @@
every? every?
catch-info catch-info
finally-info finally-info
having-info having-info))
of-filter-info
count-filter-info
elsewhere?))
((= (first items) :filter) ((= (first items) :filter)
(scan-on (scan-on
(rest (rest items)) (rest (rest items))
@@ -246,10 +219,7 @@
every? every?
catch-info catch-info
finally-info finally-info
having-info having-info))
of-filter-info
count-filter-info
elsewhere?))
((= (first items) :every) ((= (first items) :every)
(scan-on (scan-on
(rest (rest items)) (rest (rest items))
@@ -258,10 +228,7 @@
true true
catch-info catch-info
finally-info finally-info
having-info having-info))
of-filter-info
count-filter-info
elsewhere?))
((= (first items) :catch) ((= (first items) :catch)
(scan-on (scan-on
(rest (rest items)) (rest (rest items))
@@ -270,10 +237,7 @@
every? every?
(nth items 1) (nth items 1)
finally-info finally-info
having-info having-info))
of-filter-info
count-filter-info
elsewhere?))
((= (first items) :finally) ((= (first items) :finally)
(scan-on (scan-on
(rest (rest items)) (rest (rest items))
@@ -282,10 +246,7 @@
every? every?
catch-info catch-info
(nth items 1) (nth items 1)
having-info having-info))
of-filter-info
count-filter-info
elsewhere?))
((= (first items) :having) ((= (first items) :having)
(scan-on (scan-on
(rest (rest items)) (rest (rest items))
@@ -294,45 +255,6 @@
every? every?
catch-info catch-info
finally-info finally-info
(nth items 1)
of-filter-info
count-filter-info
elsewhere?))
((= (first items) :of-filter)
(scan-on
(rest (rest items))
source
filter
every?
catch-info
finally-info
having-info
(nth items 1)
count-filter-info
elsewhere?))
((= (first items) :count-filter)
(scan-on
(rest (rest items))
source
filter
every?
catch-info
finally-info
having-info
of-filter-info
(nth items 1)
elsewhere?))
((= (first items) :elsewhere)
(scan-on
(rest (rest items))
source
filter
every?
catch-info
finally-info
having-info
of-filter-info
count-filter-info
(nth items 1))) (nth items 1)))
(true (true
(scan-on (scan-on
@@ -342,11 +264,8 @@
every? every?
catch-info catch-info
finally-info finally-info
having-info having-info)))))
of-filter-info (scan-on (rest parts) nil nil false nil nil nil)))))
count-filter-info
elsewhere?)))))
(scan-on (rest parts) nil nil false nil nil nil nil nil false)))))
(define (define
emit-send emit-send
(fn (fn
@@ -1058,17 +977,9 @@
(cons (cons
(quote hs-method-call) (quote hs-method-call)
(cons obj (cons method args)))) (cons obj (cons method args))))
(if (cons
(and (quote hs-method-call)
(list? dot-node) (cons (hs-to-sx dot-node) args)))))
(= (first dot-node) (quote ref)))
(list
(quote hs-win-call)
(nth dot-node 1)
(cons (quote list) args))
(cons
(quote hs-method-call)
(cons (hs-to-sx dot-node) args))))))
((= head (quote string-postfix)) ((= head (quote string-postfix))
(list (quote str) (hs-to-sx (nth ast 1)) (nth ast 2))) (list (quote str) (hs-to-sx (nth ast 1)) (nth ast 2)))
((= head (quote block-literal)) ((= head (quote block-literal))
@@ -1238,12 +1149,7 @@
(list (quote hs-coerce) (hs-to-sx (nth ast 1)) (nth ast 2))) (list (quote hs-coerce) (hs-to-sx (nth ast 1)) (nth ast 2)))
((= head (quote in?)) ((= head (quote in?))
(list (list
(quote hs-in?) (quote hs-contains?)
(hs-to-sx (nth ast 2))
(hs-to-sx (nth ast 1))))
((= head (quote in-bool?))
(list
(quote hs-in-bool?)
(hs-to-sx (nth ast 2)) (hs-to-sx (nth ast 2))
(hs-to-sx (nth ast 1)))) (hs-to-sx (nth ast 1))))
((= head (quote of)) ((= head (quote of))
@@ -1727,19 +1633,7 @@
body))) body)))
(nth compiled (- (len compiled) 1)) (nth compiled (- (len compiled) 1))
(rest (reverse compiled))) (rest (reverse compiled)))
(let (cons (quote do) compiled)))))
((defs (filter (fn (c) (and (list? c) (> (len c) 0) (= (first c) (quote define)))) compiled))
(non-defs
(filter
(fn
(c)
(not
(and
(list? c)
(> (len c) 0)
(= (first c) (quote define)))))
compiled)))
(cons (quote do) (append defs non-defs)))))))
((= head (quote wait)) (list (quote hs-wait) (nth ast 1))) ((= head (quote wait)) (list (quote hs-wait) (nth ast 1)))
((= head (quote wait-for)) (emit-wait-for ast)) ((= head (quote wait-for)) (emit-wait-for ast))
((= head (quote log)) ((= head (quote log))
@@ -1847,13 +1741,7 @@
(make-symbol raw-fn) (make-symbol raw-fn)
(hs-to-sx raw-fn))) (hs-to-sx raw-fn)))
(args (map hs-to-sx (rest (rest ast))))) (args (map hs-to-sx (rest (rest ast)))))
(if (cons fn-expr args)))
(and (list? raw-fn) (= (first raw-fn) (quote ref)))
(list
(quote hs-win-call)
(nth raw-fn 1)
(cons (quote list) args))
(cons fn-expr args))))
((= head (quote return)) ((= head (quote return))
(let (let
((val (nth ast 1))) ((val (nth ast 1)))
@@ -2041,39 +1929,26 @@
(quote define) (quote define)
(make-symbol (nth ast 1)) (make-symbol (nth ast 1))
(list (list
(quote let) (quote fn)
params
(list (list
(quote guard)
(list (list
(quote _hs-def-val) (quote _e)
(list (list
(quote fn) (quote true)
params
(list (list
(quote guard) (quote if)
(list (list
(quote _e) (quote and)
(list (quote list?) (quote _e))
(list (list
(quote true) (quote =)
(list (list (quote first) (quote _e))
(quote if) "hs-return"))
(list (list (quote nth) (quote _e) 1)
(quote and) (list (quote raise) (quote _e)))))
(list (quote list?) (quote _e)) body)))))
(list
(quote =)
(list (quote first) (quote _e))
"hs-return"))
(list (quote nth) (quote _e) 1)
(list (quote raise) (quote _e)))))
body))))
(list
(quote do)
(list
(quote host-set!)
(list (quote host-global) "window")
(nth ast 1)
(quote _hs-def-val))
(quote _hs-def-val))))))
((= head (quote behavior)) (emit-behavior ast)) ((= head (quote behavior)) (emit-behavior ast))
((= head (quote sx-eval)) ((= head (quote sx-eval))
(let (let
@@ -2123,7 +1998,7 @@
(hs-to-sx (nth ast 1))))) (hs-to-sx (nth ast 1)))))
((= head (quote in?)) ((= head (quote in?))
(list (list
(quote hs-in?) (quote hs-contains?)
(hs-to-sx (nth ast 2)) (hs-to-sx (nth ast 2))
(hs-to-sx (nth ast 1)))) (hs-to-sx (nth ast 1))))
((= head (quote type-check)) ((= head (quote type-check))

View File

@@ -80,14 +80,11 @@
((src (dom-get-attr el "_")) (prev (dom-get-data el "hs-script"))) ((src (dom-get-attr el "_")) (prev (dom-get-data el "hs-script")))
(when (when
(and src (not (= src prev))) (and src (not (= src prev)))
(when (hs-log-event! "hyperscript:init")
(dom-dispatch el "hyperscript:before:init" nil) (dom-set-data el "hs-script" src)
(hs-log-event! "hyperscript:init") (dom-set-data el "hs-active" true)
(dom-set-data el "hs-script" src) (dom-set-attr el "data-hyperscript-powered" "true")
(dom-set-data el "hs-active" true) (let ((handler (hs-handler src))) (handler el))))))
(dom-set-attr el "data-hyperscript-powered" "true")
(let ((handler (hs-handler src))) (handler el))
(dom-dispatch el "hyperscript:after:init" nil))))))
;; ── Boot: scan entire document ────────────────────────────────── ;; ── Boot: scan entire document ──────────────────────────────────
;; Called once at page load. Finds all elements with _ attribute, ;; Called once at page load. Finds all elements with _ attribute,

View File

@@ -495,8 +495,7 @@
(quote and) (quote and)
(list (quote >=) left lo) (list (quote >=) left lo)
(list (quote <=) left hi))))) (list (quote <=) left hi)))))
((match-kw "in") ((match-kw "in") (list (quote in?) left (parse-expr)))
(list (quote in-bool?) left (parse-expr)))
((match-kw "really") ((match-kw "really")
(do (do
(match-kw "equal") (match-kw "equal")
@@ -572,8 +571,7 @@
(let (let
((right (parse-expr))) ((right (parse-expr)))
(list (quote not) (list (quote =) left right)))))) (list (quote not) (list (quote =) left right))))))
((match-kw "in") ((match-kw "in") (list (quote in?) left (parse-expr)))
(list (quote in-bool?) left (parse-expr)))
((match-kw "empty") (list (quote empty?) left)) ((match-kw "empty") (list (quote empty?) left))
((match-kw "between") ((match-kw "between")
(let (let
@@ -1557,7 +1555,7 @@
(fn (fn
() ()
(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") (= (tp-val) "on"))) (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))) (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"))) ((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
@@ -1568,7 +1566,7 @@
(fn (fn
() ()
(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") (= (tp-val) "on"))) (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))) (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"))) ((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
@@ -2603,77 +2601,63 @@
(fn (fn
() ()
(let (let
((every? (match-kw "every")) (first? (match-kw "first"))) ((every? (match-kw "every")))
(let (let
((event-name (parse-compound-event-name))) ((event-name (parse-compound-event-name)))
(let (let
((count-filter (let ((mn nil) (mx nil)) (when first? (do (set! mn 1) (set! mx 1))) (when (= (tp-type) "number") (let ((n (parse-number (tp-val)))) (do (adv!) (set! mn n) (cond ((match-kw "to") (cond ((= (tp-type) "number") (let ((mv (parse-number (tp-val)))) (do (adv!) (set! mx mv)))) (true (set! mx n)))) ((match-kw "and") (cond ((match-kw "on") (set! mx -1)) (true (set! mx n)))) (true (set! mx n)))))) (if mn (dict "min" mn "max" mx) nil)))) ((flt (if (= (tp-type) "bracket-open") (do (adv!) (let ((f (parse-expr))) (if (= (tp-type) "bracket-close") (adv!) nil) f)) nil)))
(let (let
((of-filter (when (and (= event-name "mutation") (match-kw "of")) (cond ((and (= (tp-type) "ident") (or (= (tp-val) "attributes") (= (tp-val) "childList") (= (tp-val) "characterData"))) (let ((nm (tp-val))) (do (adv!) (dict "type" nm)))) ((= (tp-type) "attr") (let ((attrs (list (tp-val)))) (do (adv!) (define collect-or! (fn () (when (match-kw "or") (cond ((= (tp-type) "attr") (do (set! attrs (append attrs (list (tp-val)))) (adv!) (collect-or!))) (true (set! p (- p 1))))))) (collect-or!) (dict "type" "attrs" "attrs" attrs)))) (true nil))))) ((source (if (match-kw "from") (parse-expr) nil)))
(let (let
((flt (if (= (tp-type) "bracket-open") (do (adv!) (let ((f (parse-expr))) (if (= (tp-type) "bracket-close") (adv!) nil) f)) nil))) ((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
((elsewhere? (cond ((match-kw "elsewhere") true) ((and (= (tp-type) "keyword") (= (tp-val) "from") (let ((nxt (if (< (+ p 1) tok-len) (nth tokens (+ p 1)) nil))) (and nxt (= (get nxt "type") "keyword") (= (get nxt "value") "elsewhere")))) (do (adv!) (adv!) true)) (true false))) ((having (if (or h-margin h-threshold) (dict "margin" h-margin "threshold" h-threshold) nil)))
(source (if (match-kw "from") (parse-expr) nil)))
(let (let
((h-margin nil) (h-threshold nil)) ((body (parse-cmd-list)))
(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
((having (if (or h-margin h-threshold) (dict "margin" h-margin "threshold" h-threshold) nil))) ((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
((body (parse-cmd-list))) ((parts (list (quote on) event-name)))
(let (let
((catch-clause (if (match-kw "catch") (let ((var (let ((v (tp-val))) (adv!) v)) (handler (parse-cmd-list))) (list var handler)) nil)) ((parts (if every? (append parts (list :every true)) parts)))
(finally-clause
(if
(match-kw "finally")
(parse-cmd-list)
nil)))
(match-kw "end")
(let (let
((parts (list (quote on) event-name))) ((parts (if flt (append parts (list :filter flt)) parts)))
(let (let
((parts (if every? (append parts (list :every true)) parts))) ((parts (if source (append parts (list :from source)) parts)))
(let (let
((parts (if flt (append parts (list :filter flt)) parts))) ((parts (if having (append parts (list :having having)) parts)))
(let (let
((parts (if elsewhere? (append parts (list :elsewhere true)) parts))) ((parts (if catch-clause (append parts (list :catch catch-clause)) parts)))
(let (let
((parts (if source (append parts (list :from source)) parts))) ((parts (if finally-clause (append parts (list :finally finally-clause)) parts)))
(let (let
((parts (if count-filter (append parts (list :count-filter count-filter)) parts))) ((parts (append parts (list body))))
(let parts))))))))))))))))))
((parts (if of-filter (append parts (list :of-filter of-filter)) parts)))
(let
((parts (if having (append parts (list :having having)) 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

View File

@@ -82,36 +82,14 @@
observer))))) observer)))))
;; Wait for CSS transitions/animations to settle on an element. ;; Wait for CSS transitions/animations to settle on an element.
(define (define hs-init (fn (thunk) (thunk)))
hs-on-mutation-attach!
(fn
(target mode attr-list)
(let
((cfg-attributes (or (= mode "any") (= mode "attributes") (= mode "attrs")))
(cfg-childList (or (= mode "any") (= mode "childList")))
(cfg-characterData (or (= mode "any") (= mode "characterData"))))
(let
((opts (dict "attributes" cfg-attributes "childList" cfg-childList "characterData" cfg-characterData "subtree" true)))
(when
(and (= mode "attrs") attr-list)
(dict-set! opts "attributeFilter" attr-list))
(let
((cb (fn (records observer) (dom-dispatch target "mutation" (dict "records" records)))))
(let
((observer (host-new "MutationObserver" cb)))
(host-call observer "observe" target opts)
observer))))))
;; ── Class manipulation ────────────────────────────────────────── ;; ── Class manipulation ──────────────────────────────────────────
;; Toggle a single class on an element. ;; Toggle a single class on an element.
(define hs-init (fn (thunk) (thunk)))
;; Toggle between two classes — exactly one is active at a time.
(define hs-wait (fn (ms) (perform (list (quote io-sleep) ms)))) (define hs-wait (fn (ms) (perform (list (quote io-sleep) ms))))
;; Take a class from siblings — add to target, remove from others. ;; Toggle between two classes — exactly one is active at a time.
;; (hs-take! target cls) — like radio button class behavior
(begin (begin
(define (define
hs-wait-for hs-wait-for
@@ -124,20 +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)))))
;; Take a class from siblings — add to target, remove from others.
;; (hs-take! target cls) — like radio button class behavior
(define hs-settle (fn (target) (perform (list (quote io-settle) target))))
;; ── 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-settle (fn (target) (perform (list (quote io-settle) target))))
;; ── Navigation / traversal ──────────────────────────────────────
;; Navigate to a URL.
(define (define
hs-toggle-class! hs-toggle-class!
(fn (target cls) (host-call (host-get target "classList") "toggle" cls))) (fn (target cls) (host-call (host-get target "classList") "toggle" cls)))
;; Find next sibling matching a selector (or any sibling). ;; ── Navigation / traversal ──────────────────────────────────────
;; Navigate to a URL.
(define (define
hs-toggle-between! hs-toggle-between!
(fn (fn
@@ -147,7 +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)))))
;; Find previous sibling matching a selector. ;; Find next sibling matching a selector (or any sibling).
(define (define
hs-toggle-style! hs-toggle-style!
(fn (fn
@@ -171,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 "")))))))
;; First element matching selector within a scope. ;; Find previous sibling matching a selector.
(define (define
hs-toggle-style-between! hs-toggle-style-between!
(fn (fn
@@ -183,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)))))
;; Last element matching selector. ;; First element matching selector within a scope.
(define (define
hs-toggle-style-cycle! hs-toggle-style-cycle!
(fn (fn
@@ -204,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/last within a specific scope. ;; Last element matching selector.
(define (define
hs-take! hs-take!
(fn (fn
@@ -244,6 +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 ""))))))))
;; First/last within a specific scope.
(begin (begin
(define (define
hs-element? hs-element?
@@ -355,9 +335,6 @@
(dom-insert-adjacent-html target "beforeend" value) (dom-insert-adjacent-html target "beforeend" value)
(hs-boot-subtree! target))))))))) (hs-boot-subtree! target)))))))))
;; ── Iteration ───────────────────────────────────────────────────
;; Repeat a thunk N times.
(define (define
hs-add-to! hs-add-to!
(fn (fn
@@ -370,7 +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)))))
;; Repeat forever (until break — relies on exception/continuation). ;; ── Iteration ───────────────────────────────────────────────────
;; Repeat a thunk N times.
(define (define
hs-remove-from! hs-remove-from!
(fn (fn
@@ -380,10 +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))))
;; ── Fetch ─────────────────────────────────────────────────────── ;; Repeat forever (until break — relies on exception/continuation).
;; Fetch a URL, parse response according to format.
;; (hs-fetch url format) — format is "json" | "text" | "html"
(define (define
hs-splice-at! hs-splice-at!
(fn (fn
@@ -407,10 +383,10 @@
(host-call target "splice" i 1)))) (host-call target "splice" i 1))))
target)))) target))))
;; ── Type coercion ─────────────────────────────────────────────── ;; ── Fetch ───────────────────────────────────────────────────────
;; Coerce a value to a type by name. ;; Fetch a URL, parse response according to format.
;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc. ;; (hs-fetch url format) — format is "json" | "text" | "html"
(define (define
hs-index hs-index
(fn (fn
@@ -422,10 +398,10 @@
((string? obj) (nth obj key)) ((string? obj) (nth obj key))
(true (host-get obj key))))) (true (host-get obj key)))))
;; ── Object creation ───────────────────────────────────────────── ;; ── Type coercion ───────────────────────────────────────────────
;; Make a new object of a given type. ;; Coerce a value to a type by name.
;; (hs-make type-name) — creates empty object/collection ;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc.
(define (define
hs-put-at! hs-put-at!
(fn (fn
@@ -447,11 +423,10 @@
((= pos "start") (host-call target "unshift" value))) ((= pos "start") (host-call target "unshift" value)))
target))))))) target)))))))
;; ── Behavior installation ─────────────────────────────────────── ;; ── Object creation ─────────────────────────────────────────────
;; Install a behavior on an element. ;; Make a new object of a given type.
;; A behavior is a function that takes (me ...params) and sets up features. ;; (hs-make type-name) — creates empty object/collection
;; (hs-install behavior-fn me ...args)
(define (define
hs-dict-without hs-dict-without
(fn (fn
@@ -472,27 +447,27 @@
(host-call (host-global "Reflect") "deleteProperty" out key) (host-call (host-global "Reflect") "deleteProperty" out key)
out))))) out)))))
;; ── Measurement ───────────────────────────────────────────────── ;; ── Behavior installation ───────────────────────────────────────
;; Measure an element's bounding rect, store as local variables. ;; Install a behavior on an element.
;; Returns a dict with x, y, width, height, top, left, right, bottom. ;; A behavior is a function that takes (me ...params) and sets up features.
;; (hs-install behavior-fn me ...args)
(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))))
;; ── Measurement ─────────────────────────────────────────────────
;; Measure an element's bounding rect, store as local variables.
;; Returns a dict with x, y, width, height, top, left, right, bottom.
(define hs-navigate! (fn (url) (perform (list (quote io-navigate) url))))
;; Return the current text selection as a string. In the browser this is ;; Return the current text selection as a string. In the browser this is
;; `window.getSelection().toString()`. In the mock test runner, a test ;; `window.getSelection().toString()`. In the mock test runner, a test
;; setup stashes the desired selection text at `window.__test_selection` ;; setup stashes the desired selection text at `window.__test_selection`
;; and the fallback path returns that so tests can assert on the result. ;; and the fallback path returns that so tests can assert on the result.
(define hs-navigate! (fn (url) (perform (list (quote io-navigate) url))))
;; ── Transition ──────────────────────────────────────────────────
;; Transition a CSS property to a value, optionally with duration.
;; (hs-transition target prop value duration)
(define (define
hs-ask hs-ask
(fn (fn
@@ -501,6 +476,11 @@
((w (host-global "window"))) ((w (host-global "window")))
(if w (host-call w "prompt" msg) nil)))) (if w (host-call w "prompt" msg) nil))))
;; ── Transition ──────────────────────────────────────────────────
;; Transition a CSS property to a value, optionally with duration.
;; (hs-transition target prop value duration)
(define (define
hs-answer hs-answer
(fn (fn
@@ -654,10 +634,6 @@
hs-query-all hs-query-all
(fn (sel) (host-call (dom-body) "querySelectorAll" sel))) (fn (sel) (host-call (dom-body) "querySelectorAll" sel)))
(define (define
hs-query-all-in hs-query-all-in
(fn (fn
@@ -667,21 +643,25 @@
(hs-query-all sel) (hs-query-all sel)
(host-call target "querySelectorAll" sel)))) (host-call target "querySelectorAll" sel))))
(define (define
hs-list-set hs-list-set
(fn (fn
(lst idx val) (lst idx val)
(append (take lst idx) (cons val (drop lst (+ idx 1)))))) (append (take lst idx) (cons val (drop lst (+ idx 1))))))
;; ── Sandbox/test runtime additions ──────────────────────────────
;; Property access — dot notation and .length
(define (define
hs-to-number hs-to-number
(fn (v) (if (number? v) v (or (parse-number (str v)) 0)))) (fn (v) (if (number? v) v (or (parse-number (str v)) 0))))
;; DOM query stub — sandbox returns empty list ;; ── Sandbox/test runtime additions ──────────────────────────────
;; Property access — dot notation and .length
(define (define
hs-query-first hs-query-first
(fn (sel) (host-call (host-global "document") "querySelector" sel))) (fn (sel) (host-call (host-global "document") "querySelector" sel)))
;; Method dispatch — obj.method(args) ;; DOM query stub — sandbox returns empty list
(define (define
hs-query-last hs-query-last
(fn (fn
@@ -689,11 +669,11 @@
(let (let
((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))))
;; Method dispatch — obj.method(args)
(define hs-first (fn (scope sel) (dom-query-all scope sel)))
;; ── 0.9.90 features ───────────────────────────────────────────── ;; ── 0.9.90 features ─────────────────────────────────────────────
;; beep! — debug logging, returns value unchanged ;; beep! — debug logging, returns value unchanged
(define hs-first (fn (scope sel) (dom-query-all scope sel)))
;; Property-based is — check obj.key truthiness
(define (define
hs-last hs-last
(fn (fn
@@ -701,7 +681,7 @@
(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))))
;; Array slicing (inclusive both ends) ;; Property-based is — check obj.key truthiness
(define (define
hs-repeat-times hs-repeat-times
(fn (fn
@@ -719,7 +699,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)))
;; Collection: sorted by ;; Array slicing (inclusive both ends)
(define (define
hs-repeat-forever hs-repeat-forever
(fn (fn
@@ -735,7 +715,7 @@
((= signal "hs-continue") (do-forever)) ((= signal "hs-continue") (do-forever))
(true (do-forever)))))) (true (do-forever))))))
(do-forever))) (do-forever)))
;; Collection: sorted by descending ;; Collection: sorted by
(define (define
hs-repeat-while hs-repeat-while
(fn (fn
@@ -748,7 +728,7 @@
((= 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)))))))
;; Collection: split by ;; Collection: sorted by descending
(define (define
hs-repeat-until hs-repeat-until
(fn (fn
@@ -760,7 +740,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)))))))
;; Collection: joined by ;; Collection: split by
(define (define
hs-for-each hs-for-each
(fn (fn
@@ -780,7 +760,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))))
;; Collection: joined by
(begin (begin
(define (define
hs-append hs-append
@@ -1535,25 +1515,6 @@
(hs-contains? (rest collection) item)))))) (hs-contains? (rest collection) item))))))
(true false)))) (true false))))
(define
hs-in?
(fn
(collection item)
(cond
((nil? collection) (list))
((list? collection)
(cond
((nil? item) (list))
((list? item)
(filter (fn (x) (hs-contains? collection x)) item))
((hs-contains? collection item) (list item))
(true (list))))
(true (list)))))
(define
hs-in-bool?
(fn (collection item) (not (hs-falsy? (hs-in? collection item)))))
(define (define
hs-is hs-is
(fn (fn
@@ -2134,13 +2095,7 @@
-1 -1
(if (= (first lst) item) i (idx-loop (rest lst) (+ i 1)))))) (if (= (first lst) item) i (idx-loop (rest lst) (+ i 1))))))
(idx-loop obj 0))) (idx-loop obj 0)))
(true (true nil))))
(let
((fn-val (host-get obj method)))
(cond
((and fn-val (callable? fn-val)) (apply fn-val args))
(fn-val (apply host-call (cons obj (cons method args))))
(true nil)))))))
(define hs-beep (fn (v) v)) (define hs-beep (fn (v) v))
@@ -2519,9 +2474,3 @@
((nil? b) false) ((nil? b) false)
((= a b) true) ((= a b) true)
(true (hs-dom-is-ancestor? a (dom-parent b)))))) (true (hs-dom-is-ancestor? a (dom-parent b))))))
(define
hs-win-call
(fn
(fn-name args)
(let ((fn (host-global fn-name))) (if fn (host-call-fn fn args) nil))))

41
lib/tcl/parser.sx Normal file
View File

@@ -0,0 +1,41 @@
; Tcl parser — thin layer over tcl-tokenize
; Adds tcl-parse entry point and word utility fns
; Entry point: parse Tcl source to a list of commands.
; Returns same structure as tcl-tokenize.
(define tcl-parse (fn (src) (tcl-tokenize src)))
; True if word has no substitutions — value can be read statically.
; braced words are always simple. compound words are simple when all
; parts are plain text with no var/cmd parts.
(define tcl-word-simple?
(fn (word)
(cond
((= (get word :type) "braced") true)
((= (get word :type) "compound")
(let ((parts (get word :parts)))
(every? (fn (p) (= (get p :type) "text")) parts)))
(else false))))
; Concatenate text parts of a simple word into a single string.
; For braced words returns :value directly.
; For compound words with only text parts, joins them.
; Returns nil for words with substitutions.
(define tcl-word-literal
(fn (word)
(cond
((= (get word :type) "braced") (get word :value))
((= (get word :type) "compound")
(if (tcl-word-simple? word)
(join "" (map (fn (p) (get p :value)) (get word :parts)))
nil))
(else nil))))
; Number of words in a parsed command.
(define tcl-cmd-len
(fn (cmd) (len (get cmd :words))))
; Nth word literal from a command (index 0 = command name).
; Returns nil if word has substitutions.
(define tcl-nth-literal
(fn (cmd n) (tcl-word-literal (nth (get cmd :words) n))))

53
lib/tcl/test.sh Executable file
View File

@@ -0,0 +1,53 @@
#!/usr/bin/env bash
# Tcl-on-SX test runner — epoch protocol to sx_server.exe
set -uo pipefail
cd "$(git rev-parse --show-toplevel)"
SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
if [ ! -x "$SX_SERVER" ]; then
SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe"
fi
if [ ! -x "$SX_SERVER" ]; then echo "ERROR: sx_server.exe not found"; exit 1; fi
VERBOSE="${1:-}"
TMPFILE=$(mktemp)
trap "rm -f $TMPFILE" EXIT
cat > "$TMPFILE" << 'EPOCHS'
(epoch 1)
(load "lib/tcl/tokenizer.sx")
(epoch 2)
(load "lib/tcl/parser.sx")
(epoch 3)
(load "lib/tcl/tests/parse.sx")
(epoch 4)
(eval "(tcl-run-parse-tests)")
EPOCHS
OUTPUT=$(timeout 30 "$SX_SERVER" < "$TMPFILE" 2>&1)
[ "$VERBOSE" = "-v" ] && echo "$OUTPUT"
# Result follows an (ok-len 3 N) line
RESULT=$(echo "$OUTPUT" | grep -A1 "^(ok-len 4 " | tail -1)
if [ -z "$RESULT" ]; then
RESULT=$(echo "$OUTPUT" | grep "^(ok 4 " | sed 's/^(ok 3 //' | sed 's/)$//')
fi
if [ -z "$RESULT" ]; then
echo "ERROR: no result from epoch 4"
echo "$OUTPUT" | tail -10
exit 1
fi
PASSED=$(echo "$RESULT" | grep -o ':passed [0-9]*' | grep -o '[0-9]*$')
FAILED=$(echo "$RESULT" | grep -o ':failed [0-9]*' | grep -o '[0-9]*$')
PASSED=${PASSED:-0}; FAILED=${FAILED:-1}
TOTAL=$((PASSED + FAILED))
if [ "$FAILED" = "0" ]; then
echo "ok $PASSED/$TOTAL tcl-tokenize tests passed"
exit 0
else
echo "FAIL $PASSED/$TOTAL passed, $FAILED failed"
echo "$RESULT"
exit 1
fi

186
lib/tcl/tests/parse.sx Normal file
View File

@@ -0,0 +1,186 @@
(define tcl-parse-pass 0)
(define tcl-parse-fail 0)
(define tcl-parse-failures (list))
(define tcl-assert
(fn (label expected actual)
(if (= expected actual)
(set! tcl-parse-pass (+ tcl-parse-pass 1))
(begin
(set! tcl-parse-fail (+ tcl-parse-fail 1))
(append! tcl-parse-failures
(str label ": expected=" (str expected) " got=" (str actual)))))))
(define tcl-first-cmd
(fn (src) (nth (tcl-tokenize src) 0)))
(define tcl-cmd-words
(fn (src) (get (tcl-first-cmd src) :words)))
(define tcl-word
(fn (src wi) (nth (tcl-cmd-words src) wi)))
(define tcl-parts
(fn (src wi) (get (tcl-word src wi) :parts)))
(define tcl-part
(fn (src wi pi) (nth (tcl-parts src wi) pi)))
(define tcl-run-parse-tests
(fn ()
(set! tcl-parse-pass 0)
(set! tcl-parse-fail 0)
(set! tcl-parse-failures (list))
; empty / whitespace-only
(tcl-assert "empty" 0 (len (tcl-tokenize "")))
(tcl-assert "ws-only" 0 (len (tcl-tokenize " ")))
(tcl-assert "nl-only" 0 (len (tcl-tokenize "\n\n")))
; single command word count
(tcl-assert "1word" 1 (len (tcl-cmd-words "set")))
(tcl-assert "3words" 3 (len (tcl-cmd-words "set x 1")))
(tcl-assert "4words" 4 (len (tcl-cmd-words "set a b c")))
; word type — bare word is compound
(tcl-assert "bare-type" "compound" (get (tcl-word "set x 1" 0) :type))
(tcl-assert "bare-quoted" false (get (tcl-word "set x 1" 0) :quoted))
(tcl-assert "bare-part-type" "text" (get (tcl-part "set x 1" 0 0) :type))
(tcl-assert "bare-part-val" "set" (get (tcl-part "set x 1" 0 0) :value))
(tcl-assert "bare-part2-val" "x" (get (tcl-part "set x 1" 1 0) :value))
(tcl-assert "bare-part3-val" "1" (get (tcl-part "set x 1" 2 0) :value))
; multiple commands
(tcl-assert "semi-sep" 2 (len (tcl-tokenize "set x 1; set y 2")))
(tcl-assert "nl-sep" 2 (len (tcl-tokenize "set x 1\nset y 2")))
(tcl-assert "multi-nl" 3 (len (tcl-tokenize "a\nb\nc")))
; comments
(tcl-assert "comment-only" 0 (len (tcl-tokenize "# comment")))
(tcl-assert "comment-nl" 0 (len (tcl-tokenize "# comment\n")))
(tcl-assert "comment-then-cmd" 1 (len (tcl-tokenize "# comment\nset x 1")))
(tcl-assert "semi-then-comment" 1 (len (tcl-tokenize "set x 1; # comment")))
; brace-quoted words
(tcl-assert "brace-type" "braced" (get (tcl-word "{hello}" 0) :type))
(tcl-assert "brace-value" "hello" (get (tcl-word "{hello}" 0) :value))
(tcl-assert "brace-spaces" "hello world" (get (tcl-word "{hello world}" 0) :value))
(tcl-assert "brace-nested" "a {b} c" (get (tcl-word "{a {b} c}" 0) :value))
(tcl-assert "brace-no-var-sub" "hello $x" (get (tcl-word "{hello $x}" 0) :value))
(tcl-assert "brace-no-cmd-sub" "[expr 1]" (get (tcl-word "{[expr 1]}" 0) :value))
; double-quoted words
(tcl-assert "dq-type" "compound" (get (tcl-word "\"hello\"" 0) :type))
(tcl-assert "dq-quoted" true (get (tcl-word "\"hello\"" 0) :quoted))
(tcl-assert "dq-literal" "hello" (get (tcl-part "\"hello\"" 0 0) :value))
; variable substitution in bare word
(tcl-assert "var-type" "var" (get (tcl-part "$x" 0 0) :type))
(tcl-assert "var-name" "x" (get (tcl-part "$x" 0 0) :name))
(tcl-assert "var-long" "long_name" (get (tcl-part "$long_name" 0 0) :name))
; ${name} form
(tcl-assert "var-brace-type" "var" (get (tcl-part "${x}" 0 0) :type))
(tcl-assert "var-brace-name" "x" (get (tcl-part "${x}" 0 0) :name))
; array variable substitution
(tcl-assert "arr-type" "var-arr" (get (tcl-part "$arr(key)" 0 0) :type))
(tcl-assert "arr-name" "arr" (get (tcl-part "$arr(key)" 0 0) :name))
(tcl-assert "arr-key-len" 1 (len (get (tcl-part "$arr(key)" 0 0) :key)))
(tcl-assert "arr-key-text" "key"
(get (nth (get (tcl-part "$arr(key)" 0 0) :key) 0) :value))
; command substitution
(tcl-assert "cmd-type" "cmd" (get (tcl-part "[expr 1+1]" 0 0) :type))
(tcl-assert "cmd-src" "expr 1+1" (get (tcl-part "[expr 1+1]" 0 0) :src))
; nested command substitution
(tcl-assert "cmd-nested-src" "expr [string length x]"
(get (tcl-part "[expr [string length x]]" 0 0) :src))
; backslash substitution in double-quoted word
(let ((ps (tcl-parts "\"a\\nb\"" 0)))
(begin
(tcl-assert "bs-n-part0" "a" (get (nth ps 0) :value))
(tcl-assert "bs-n-part1" "\n" (get (nth ps 1) :value))
(tcl-assert "bs-n-part2" "b" (get (nth ps 2) :value))))
(let ((ps (tcl-parts "\"a\\tb\"" 0)))
(tcl-assert "bs-t-part1" "\t" (get (nth ps 1) :value)))
(let ((ps (tcl-parts "\"a\\\\b\"" 0)))
(tcl-assert "bs-bs-part1" "\\" (get (nth ps 1) :value)))
; mixed word: text + var + text in double-quoted
(let ((ps (tcl-parts "\"hello $name!\"" 0)))
(begin
(tcl-assert "mixed-text0" "hello " (get (nth ps 0) :value))
(tcl-assert "mixed-var1-type" "var" (get (nth ps 1) :type))
(tcl-assert "mixed-var1-name" "name" (get (nth ps 1) :name))
(tcl-assert "mixed-text2" "!" (get (nth ps 2) :value))))
; {*} expansion
(tcl-assert "expand-type" "expand" (get (tcl-word "{*}$list" 0) :type))
; line continuation between words
(tcl-assert "cont-words" 3 (len (tcl-cmd-words "set x \\\n 1")))
; continuation — third command word is correct
(tcl-assert "cont-word2-val" "1"
(get (tcl-part "set x \\\n 1" 2 0) :value))
; --- parser helpers ---
; tcl-parse is an alias for tcl-tokenize
(tcl-assert "parse-cmd-count" 1 (len (tcl-parse "set x 1")))
(tcl-assert "parse-2cmds" 2 (len (tcl-parse "set x 1; set y 2")))
; tcl-cmd-len
(tcl-assert "cmd-len-3" 3 (tcl-cmd-len (nth (tcl-parse "set x 1") 0)))
(tcl-assert "cmd-len-1" 1 (tcl-cmd-len (nth (tcl-parse "puts") 0)))
; tcl-word-simple? on braced word
(tcl-assert "simple-braced" true
(tcl-word-simple? (nth (get (nth (tcl-parse "{hello}") 0) :words) 0)))
; tcl-word-simple? on bare word with no subs
(tcl-assert "simple-bare" true
(tcl-word-simple? (nth (get (nth (tcl-parse "hello") 0) :words) 0)))
; tcl-word-simple? on word containing a var sub — false
(tcl-assert "simple-var-false" false
(tcl-word-simple? (nth (get (nth (tcl-parse "$x") 0) :words) 0)))
; tcl-word-simple? on word containing a cmd sub — false
(tcl-assert "simple-cmd-false" false
(tcl-word-simple? (nth (get (nth (tcl-parse "[expr 1]") 0) :words) 0)))
; tcl-word-literal on braced word
(tcl-assert "lit-braced" "hello world"
(tcl-word-literal (nth (get (nth (tcl-parse "{hello world}") 0) :words) 0)))
; tcl-word-literal on bare word
(tcl-assert "lit-bare" "hello"
(tcl-word-literal (nth (get (nth (tcl-parse "hello") 0) :words) 0)))
; tcl-word-literal on word with var sub returns nil
(tcl-assert "lit-var-nil" nil
(tcl-word-literal (nth (get (nth (tcl-parse "$x") 0) :words) 0)))
; tcl-nth-literal
(tcl-assert "nth-lit-0" "set"
(tcl-nth-literal (nth (tcl-parse "set x 1") 0) 0))
(tcl-assert "nth-lit-1" "x"
(tcl-nth-literal (nth (tcl-parse "set x 1") 0) 1))
(tcl-assert "nth-lit-2" "1"
(tcl-nth-literal (nth (tcl-parse "set x 1") 0) 2))
; tcl-nth-literal returns nil when word has subs
(tcl-assert "nth-lit-nil" nil
(tcl-nth-literal (nth (tcl-parse "set x $y") 0) 2))
(dict
"passed" tcl-parse-pass
"failed" tcl-parse-fail
"failures" tcl-parse-failures)))

308
lib/tcl/tokenizer.sx Normal file
View File

@@ -0,0 +1,308 @@
(define tcl-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\r"))))
(define tcl-alpha?
(fn (c)
(and
(not (= c nil))
(or (and (>= c "a") (<= c "z")) (and (>= c "A") (<= c "Z"))))))
(define tcl-digit?
(fn (c) (and (not (= c nil)) (>= c "0") (<= c "9"))))
(define tcl-ident-start?
(fn (c) (or (tcl-alpha? c) (= c "_"))))
(define tcl-ident-char?
(fn (c) (or (tcl-ident-start? c) (tcl-digit? c))))
(define tcl-tokenize
(fn (src)
(let ((pos 0) (src-len (len src)) (commands (list)))
(define char-at
(fn (off)
(if (< (+ pos off) src-len) (nth src (+ pos off)) nil)))
(define cur (fn () (char-at 0)))
(define advance! (fn (n) (set! pos (+ pos n))))
(define skip-ws!
(fn ()
(when (tcl-ws? (cur))
(begin (advance! 1) (skip-ws!)))))
(define skip-to-eol!
(fn ()
(when (and (< pos src-len) (not (= (cur) "\n")))
(begin (advance! 1) (skip-to-eol!)))))
(define skip-brace-content!
(fn (d)
(when (and (< pos src-len) (> d 0))
(cond
((= (cur) "{") (begin (advance! 1) (skip-brace-content! (+ d 1))))
((= (cur) "}") (begin (advance! 1) (skip-brace-content! (- d 1))))
(else (begin (advance! 1) (skip-brace-content! d)))))))
(define skip-dquote-content!
(fn ()
(when (and (< pos src-len) (not (= (cur) "\"")))
(begin
(when (= (cur) "\\") (advance! 1))
(when (< pos src-len) (advance! 1))
(skip-dquote-content!)))))
(define parse-bs
(fn ()
(advance! 1)
(let ((c (cur)))
(cond
((= c nil) "\\")
((= c "n") (begin (advance! 1) "\n"))
((= c "t") (begin (advance! 1) "\t"))
((= c "r") (begin (advance! 1) "\r"))
((= c "\\") (begin (advance! 1) "\\"))
((= c "[") (begin (advance! 1) "["))
((= c "]") (begin (advance! 1) "]"))
((= c "{") (begin (advance! 1) "{"))
((= c "}") (begin (advance! 1) "}"))
((= c "$") (begin (advance! 1) "$"))
((= c ";") (begin (advance! 1) ";"))
((= c "\"") (begin (advance! 1) "\""))
((= c "'") (begin (advance! 1) "'"))
((= c " ") (begin (advance! 1) " "))
((= c "\n")
(begin
(advance! 1)
(skip-ws!)
" "))
(else (begin (advance! 1) (str "\\" c)))))))
(define parse-cmd-sub
(fn ()
(advance! 1)
(let ((start pos) (depth 1))
(define scan!
(fn ()
(when (and (< pos src-len) (> depth 0))
(cond
((= (cur) "[")
(begin (set! depth (+ depth 1)) (advance! 1) (scan!)))
((= (cur) "]")
(begin
(set! depth (- depth 1))
(when (> depth 0) (advance! 1))
(scan!)))
((= (cur) "{")
(begin (advance! 1) (skip-brace-content! 1) (scan!)))
((= (cur) "\"")
(begin
(advance! 1)
(skip-dquote-content!)
(when (= (cur) "\"") (advance! 1))
(scan!)))
((= (cur) "\\")
(begin (advance! 1) (when (< pos src-len) (advance! 1)) (scan!)))
(else (begin (advance! 1) (scan!)))))))
(scan!)
(let ((src-text (slice src start pos)))
(begin
(when (= (cur) "]") (advance! 1))
{:type "cmd" :src src-text})))))
(define scan-name!
(fn ()
(when (and (< pos src-len) (not (= (cur) "}")))
(begin (advance! 1) (scan-name!)))))
(define scan-ns-name!
(fn ()
(cond
((tcl-ident-char? (cur))
(begin (advance! 1) (scan-ns-name!)))
((and (= (cur) ":") (= (char-at 1) ":"))
(begin (advance! 2) (scan-ns-name!)))
(else nil))))
(define scan-klit!
(fn ()
(when (and (< pos src-len)
(not (= (cur) ")"))
(not (= (cur) "$"))
(not (= (cur) "["))
(not (= (cur) "\\")))
(begin (advance! 1) (scan-klit!)))))
(define scan-key!
(fn (kp)
(when (and (< pos src-len) (not (= (cur) ")")))
(cond
((= (cur) "$")
(begin (append! kp (parse-var-sub)) (scan-key! kp)))
((= (cur) "[")
(begin (append! kp (parse-cmd-sub)) (scan-key! kp)))
((= (cur) "\\")
(begin
(append! kp {:type "text" :value (parse-bs)})
(scan-key! kp)))
(else
(let ((kstart pos))
(begin
(scan-klit!)
(append! kp {:type "text" :value (slice src kstart pos)})
(scan-key! kp))))))))
(define parse-var-sub
(fn ()
(advance! 1)
(cond
((= (cur) "{")
(begin
(advance! 1)
(let ((start pos))
(begin
(scan-name!)
(let ((name (slice src start pos)))
(begin
(when (= (cur) "}") (advance! 1))
{:type "var" :name name}))))))
((tcl-ident-start? (cur))
(let ((start pos))
(begin
(scan-ns-name!)
(let ((name (slice src start pos)))
(if (= (cur) "(")
(begin
(advance! 1)
(let ((key-parts (list)))
(begin
(scan-key! key-parts)
(when (= (cur) ")") (advance! 1))
{:type "var-arr" :name name :key key-parts})))
{:type "var" :name name})))))
(else {:type "text" :value "$"}))))
(define scan-lit!
(fn (stop?)
(when (and (< pos src-len)
(not (stop? (cur)))
(not (= (cur) "$"))
(not (= (cur) "["))
(not (= (cur) "\\")))
(begin (advance! 1) (scan-lit! stop?)))))
(define parse-word-parts!
(fn (parts stop?)
(when (and (< pos src-len) (not (stop? (cur))))
(cond
((= (cur) "$")
(begin (append! parts (parse-var-sub)) (parse-word-parts! parts stop?)))
((= (cur) "[")
(begin (append! parts (parse-cmd-sub)) (parse-word-parts! parts stop?)))
((= (cur) "\\")
(begin
(append! parts {:type "text" :value (parse-bs)})
(parse-word-parts! parts stop?)))
(else
(let ((start pos))
(begin
(scan-lit! stop?)
(when (> pos start)
(append! parts {:type "text" :value (slice src start pos)}))
(parse-word-parts! parts stop?))))))))
(define parse-brace-word
(fn ()
(advance! 1)
(let ((depth 1) (start pos))
(define scan!
(fn ()
(when (and (< pos src-len) (> depth 0))
(cond
((= (cur) "{")
(begin (set! depth (+ depth 1)) (advance! 1) (scan!)))
((= (cur) "}")
(begin (set! depth (- depth 1)) (when (> depth 0) (advance! 1)) (scan!)))
(else (begin (advance! 1) (scan!)))))))
(scan!)
(let ((value (slice src start pos)))
(begin
(when (= (cur) "}") (advance! 1))
{:type "braced" :value value})))))
(define parse-dquote-word
(fn ()
(advance! 1)
(let ((parts (list)))
(begin
(parse-word-parts! parts (fn (c) (or (= c "\"") (= c nil))))
(when (= (cur) "\"") (advance! 1))
{:type "compound" :parts parts :quoted true}))))
(define parse-bare-word
(fn ()
(let ((parts (list)))
(begin
(parse-word-parts!
parts
(fn (c) (or (tcl-ws? c) (= c "\n") (= c ";") (= c nil))))
{:type "compound" :parts parts :quoted false}))))
(define parse-word-no-expand
(fn ()
(cond
((= (cur) "{") (parse-brace-word))
((= (cur) "\"") (parse-dquote-word))
(else (parse-bare-word)))))
(define parse-word
(fn ()
(cond
((and (= (cur) "{") (= (char-at 1) "*") (= (char-at 2) "}"))
(begin
(advance! 3)
{:type "expand" :word (parse-word-no-expand)}))
((= (cur) "{") (parse-brace-word))
((= (cur) "\"") (parse-dquote-word))
(else (parse-bare-word)))))
(define parse-words!
(fn (words)
(skip-ws!)
(cond
((or (= (cur) nil) (= (cur) "\n") (= (cur) ";")) nil)
((and (= (cur) "\\") (= (char-at 1) "\n"))
(begin (advance! 2) (skip-ws!) (parse-words! words)))
(else
(begin
(append! words (parse-word))
(parse-words! words))))))
(define skip-seps!
(fn ()
(when (< pos src-len)
(cond
((or (tcl-ws? (cur)) (= (cur) "\n") (= (cur) ";"))
(begin (advance! 1) (skip-seps!)))
((and (= (cur) "\\") (= (char-at 1) "\n"))
(begin (advance! 2) (skip-seps!)))
(else nil)))))
(define parse-all!
(fn ()
(skip-seps!)
(when (< pos src-len)
(cond
((= (cur) "#")
(begin (skip-to-eol!) (parse-all!)))
(else
(let ((words (list)))
(begin
(parse-words! words)
(when (> (len words) 0)
(append! commands {:type "command" :words words}))
(parse-all!))))))))
(parse-all!)
commands)))

View File

@@ -0,0 +1,81 @@
# apl-on-sx loop agent (single agent, queue-driven)
Role: iterates `plans/apl-on-sx.md` forever. Rank-polymorphic primitives + 6 operators on the JIT is the headline showcase — APL is the densest combinator algebra you can put on top of a primitive table. Every program is `array → array` pure pipelines, exactly what the JIT was built for.
```
description: apl-on-sx queue loop
subagent_type: general-purpose
run_in_background: true
isolation: worktree
```
## Prompt
You are the sole background agent working `/root/rose-ash/plans/apl-on-sx.md`. Isolated worktree, forever, one commit per feature. Never push.
## Restart baseline — check before iterating
1. Read `plans/apl-on-sx.md` — roadmap + Progress log.
2. `ls lib/apl/` — pick up from the most advanced file.
3. If `lib/apl/tests/*.sx` exist, run them. Green before new work.
4. If `lib/apl/scoreboard.md` exists, that's your baseline.
## The queue
Phase order per `plans/apl-on-sx.md`:
- **Phase 1** — tokenizer + parser. Unicode glyphs, `¯` for negative, strands (juxtaposition), right-to-left, valence resolution by syntactic position
- **Phase 2** — array model + scalar primitives. `make-array {shape, ravel}`, scalar promotion, broadcast for `+ - × ÷ ⌈ ⌊ * ⍟ | ! ○`, comparison, logical, ``, `⎕IO`
- **Phase 3** — structural primitives + indexing. ` , ⍉ ↑ ↓ ⌽ ⊖ ⌷ ⍋ ⍒ ⊂ ⊃ ∊`
- **Phase 4** — **THE SHOWCASE**: operators. `f/` (reduce), `f¨` (each), `∘.f` (outer), `f.g` (inner), `f⍨` (commute), `f∘g` (compose), `f⍣n` (power), `f⍤k` (rank), `@` (at)
- **Phase 5** — dfns + tradfns + control flow. `{+⍵}`, `∇` recurse, `←default`, tradfn header, `:If/:While/:For/:Select`
- **Phase 6** — classic programs (life, mandelbrot, primes, n-queens, quicksort) + idiom corpus + drive to 100+
Within a phase, pick the checkbox that unlocks the most tests per effort.
Every iteration: implement → test → commit → tick `[ ]` → Progress log → next.
## Ground rules (hard)
- **Scope:** only `lib/apl/**` and `plans/apl-on-sx.md`. Do **not** edit `spec/`, `hosts/`, `shared/`, other `lib/<lang>/` dirs, `lib/stdlib.sx`, or `lib/` root. APL primitives go in `lib/apl/runtime.sx`.
- **NEVER call `sx_build`.** 600s watchdog. If sx_server binary broken → Blockers entry, stop.
- **Shared-file issues** → plan's Blockers with minimal repro.
- **SX files:** `sx-tree` MCP tools ONLY. `sx_validate` after edits.
- **Unicode in `.sx`:** raw UTF-8 only, never `\uXXXX` escapes. Glyphs land directly in source.
- **Worktree:** commit locally. Never push. Never touch `main`.
- **Commit granularity:** one feature per commit.
- **Plan file:** update Progress log + tick boxes every commit.
## APL-specific gotchas
- **Right-to-left, no precedence among functions.** `2 × 3 + 4` is `2 × (3 + 4)` = 14, not 10. Operators bind tighter than functions: `+/ 5` is `+/(5)`, and `2 +.× 3 4` is `2 (+.×) 3 4`.
- **Valence by position.** `-3` is monadic negate (`-` with no left arg). `5-3` is dyadic subtract. The parser must look left to decide. Same glyph; different fn.
- **`¯` is part of a number literal**, not a prefix function. `¯3` is the literal negative three; `-3` is the function call. Tokenizer eats `¯` into the numeric token.
- **Strands.** `1 2 3` is a 3-element vector, not three separate calls. Adjacent literals fuse into a strand at parse time. Adjacent names do *not* fuse — `a b c` is three separate references.
- **Scalar promotion.** `1 + 2 3 4``3 4 5`. Any scalar broadcasts against any-rank conformable shape.
- **Conformability** = exactly matching shapes, OR one side scalar, OR (in some dialects) one side rank-1 cycling against rank-N. Keep strict in v1: matching shape or scalar only.
- **`` is overloaded.** Monadic `N` = vector 1..N (or 0..N-1 if `⎕IO=0`). Dyadic `V W` = first-index lookup, returns `≢V+1` for not-found.
- **Reduce with `+/0`** = `0` (identity for `+`). Each scalar primitive has a defined identity used by reduce-on-empty. Don't crash; return identity.
- **Reduce direction.** `f/` reduces the *last* axis. `f⌿` reduces the *first*. Matters for matrices.
- **Indexing is 1-based** by default (`⎕IO=1`). Do not silently translate to 0-based; respect `⎕IO`.
- **Bracket indexing** `A[I]` is sugar for `I⌷A` (squad-quad). Multi-axis: `A[I;J]` is `I J⌷A` with semicolon-separated axes; `A[;J]` selects all of axis 0.
- **Dfn `{...}`** — `` = left arg (may be unbound for monadic call → check with `←default`), `⍵` = right arg, `∇` = recurse. Default left arg syntax: `←0`.
- **Tradfn vs dfn** — tradfns use line-numbered `→linenum` for goto; dfns use guards `cond:expr`. Pick the right one for the user's syntax.
- **Empty array** = rank-N array where some dim is 0. `00` is empty rank-1. Scalar prototype matters for empty-array operations; ignore in v1, return 0/space.
- **Test corpus:** custom + idioms. Place programs in `lib/apl/tests/programs/` with `.apl` extension.
## General gotchas (all loops)
- SX `do` = R7RS iteration. Use `begin` for multi-expr sequences.
- `cond`/`when`/`let` clauses evaluate only the last expr.
- `type-of` on user fn returns `"lambda"`.
- Shell heredoc `||` gets eaten — escape or use `case`.
## Style
- No comments in `.sx` unless non-obvious.
- No new planning docs — update `plans/apl-on-sx.md` inline.
- Short, factual commit messages (`apl: outer product ∘. (+9)`).
- One feature per iteration. Commit. Log. Next.
Go. Read the plan; find first `[ ]`; implement.

View File

@@ -0,0 +1,80 @@
# common-lisp-on-sx loop agent (single agent, queue-driven)
Role: iterates `plans/common-lisp-on-sx.md` forever. Conditions + restarts on delimited continuations is the headline showcase — every other Lisp reinvents resumable exceptions on the host stack. On SX `signal`/`invoke-restart` is just a captured continuation. Plus CLOS, the LOOP macro, packages.
```
description: common-lisp-on-sx queue loop
subagent_type: general-purpose
run_in_background: true
isolation: worktree
```
## Prompt
You are the sole background agent working `/root/rose-ash/plans/common-lisp-on-sx.md`. Isolated worktree, forever, one commit per feature. Never push.
## Restart baseline — check before iterating
1. Read `plans/common-lisp-on-sx.md` — roadmap + Progress log.
2. `ls lib/common-lisp/` — pick up from the most advanced file.
3. If `lib/common-lisp/tests/*.sx` exist, run them. Green before new work.
4. If `lib/common-lisp/scoreboard.md` exists, that's your baseline.
## The queue
Phase order per `plans/common-lisp-on-sx.md`:
- **Phase 1** — reader + parser (read macros `#'` `'` `` ` `` `,` `,@` `#( … )` `#:` `#\char` `#xFF` `#b1010`, ratios, dispatch chars, lambda lists with `&optional`/`&rest`/`&key`/`&aux`)
- **Phase 2** — sequential eval + special forms (`let`/`let*`/`flet`/`labels`, `block`/`return-from`, `tagbody`/`go`, `unwind-protect`, multiple values, `setf` subset, dynamic variables)
- **Phase 3** — **THE SHOWCASE**: condition system + restarts. `define-condition`, `signal`/`error`/`cerror`/`warn`, `handler-bind` (non-unwinding), `handler-case` (unwinding), `restart-case`, `restart-bind`, `find-restart`/`invoke-restart`/`compute-restarts`, `with-condition-restarts`. Classic programs (restart-demo, parse-recover, interactive-debugger) green.
- **Phase 4** — CLOS: `defclass`, `defgeneric`, `defmethod` with `:before`/`:after`/`:around`, `call-next-method`, multiple dispatch
- **Phase 5** — macros + LOOP macro + reader macros
- **Phase 6** — packages + stdlib (sequence functions, FORMAT directives, drive corpus to 200+)
Within a phase, pick the checkbox that unlocks the most tests per effort.
Every iteration: implement → test → commit → tick `[ ]` → Progress log → next.
## Ground rules (hard)
- **Scope:** only `lib/common-lisp/**` and `plans/common-lisp-on-sx.md`. Do **not** edit `spec/`, `hosts/`, `shared/`, other `lib/<lang>/` dirs, `lib/stdlib.sx`, or `lib/` root. CL primitives go in `lib/common-lisp/runtime.sx`.
- **NEVER call `sx_build`.** 600s watchdog. If sx_server binary broken → Blockers entry, stop.
- **Shared-file issues** → plan's Blockers with minimal repro.
- **Delimited continuations** are in `lib/callcc.sx` + `spec/evaluator.sx` Step 5. `sx_summarise` spec/evaluator.sx first — 2300+ lines.
- **SX files:** `sx-tree` MCP tools ONLY. `sx_validate` after edits.
- **Worktree:** commit locally. Never push. Never touch `main`.
- **Commit granularity:** one feature per commit.
- **Plan file:** update Progress log + tick boxes every commit.
## Common-Lisp-specific gotchas
- **`handler-bind` is non-unwinding** — handlers can decline by returning normally, in which case `signal` keeps walking the chain. **`handler-case` is unwinding** — picking a handler aborts the protected form via a captured continuation. Don't conflate them.
- **Restarts are not handlers.** `restart-case` establishes named *resumption points*; `signal` runs handler code with restarts visible; the handler chooses a restart by calling `invoke-restart`, which abandons handler stack and resumes at the restart point. Two stacks: handlers walk down, restarts wait to be invoked.
- **`block` / `return-from`** is lexical. `block name … (return-from name v) …` captures `^k` once at entry; `return-from` invokes it. `return-from` to a name not in scope is an error (don't fall back to outer block).
- **`tagbody` / `go`** — each tag in tagbody is a continuation; `go tag` invokes it. Tags are lexical, can only target tagbodies in scope.
- **`unwind-protect`** runs cleanup on *any* non-local exit (return-from, throw, condition unwind). Implement as a scope frame fired by the cleanup machinery.
- **Multiple values**: primary-value-only contexts (function args, `if` test, etc.) drop extras silently. `values` produces multiple. `multiple-value-bind` / `multiple-value-call` consume them. Don't auto-list.
- **CLOS dispatch:** sort applicable methods by argument-list specificity (`subclassp` per arg, left-to-right); standard method combination calls primary methods most-specific-first via `call-next-method` chain. `:before` runs all before primaries; `:after` runs all after, in reverse-specificity. `:around` wraps everything.
- **`call-next-method`** is a *continuation* available only inside a method body. Implement as a thunk stored in a dynamic-extent variable.
- **Generalised reference (`setf`)**: `(setf (foo x) v)``(setf-foo v x)`. Look up the setf-expander, not just a writer fn. `define-setf-expander` is mandatory for non-trivial places. Start with the symbolic / list / aref / slot-value cases.
- **Dynamic variables (specials):** `defvar`/`defparameter` mark a symbol as special. `let` over a special name *rebinds* in dynamic extent (use parameterize-style scope), not lexical.
- **Symbols are package-qualified.** Reader resolves `cl:car`, `mypkg::internal`, bare `foo` (current package). Internal vs external matters for `:` (one colon) reads.
- **`nil` is also `()` is also the empty list.** Same object. `nil` is also false. CL has no distinct unit value.
- **LOOP macro is huge.** Build incrementally — start with `for/in`, `for/from`, `collect`, `sum`, `count`, `repeat`. Add conditional clauses (`when`, `if`, `else`) once iteration drivers stable. `named` blocks + `return-from named` last.
- **Test corpus:** custom + curated `ansi-test` slice. Place programs in `lib/common-lisp/tests/programs/` with `.lisp` extension.
## General gotchas (all loops)
- SX `do` = R7RS iteration. Use `begin` for multi-expr sequences.
- `cond`/`when`/`let` clauses evaluate only the last expr.
- `type-of` on user fn returns `"lambda"`.
- Shell heredoc `||` gets eaten — escape or use `case`.
## Style
- No comments in `.sx` unless non-obvious.
- No new planning docs — update `plans/common-lisp-on-sx.md` inline.
- Short, factual commit messages (`common-lisp: handler-bind + 12 tests`).
- One feature per iteration. Commit. Log. Next.
Go. Read the plan; find first `[ ]`; implement.

View File

@@ -0,0 +1,83 @@
# ruby-on-sx loop agent (single agent, queue-driven)
Role: iterates `plans/ruby-on-sx.md` forever. Fibers via delcc is the headline showcase — `Fiber.new`/`Fiber.yield`/`Fiber.resume` are textbook delimited continuations with sugar, where MRI does it via C-stack swapping. Plus blocks/yield (lexical escape continuations, same shape as Smalltalk's non-local return), method_missing, and singleton classes.
```
description: ruby-on-sx queue loop
subagent_type: general-purpose
run_in_background: true
isolation: worktree
```
## Prompt
You are the sole background agent working `/root/rose-ash/plans/ruby-on-sx.md`. Isolated worktree, forever, one commit per feature. Never push.
## Restart baseline — check before iterating
1. Read `plans/ruby-on-sx.md` — roadmap + Progress log.
2. `ls lib/ruby/` — pick up from the most advanced file.
3. If `lib/ruby/tests/*.sx` exist, run them. Green before new work.
4. If `lib/ruby/scoreboard.md` exists, that's your baseline.
## The queue
Phase order per `plans/ruby-on-sx.md`:
- **Phase 1** — tokenizer + parser. Keywords, identifier sigils (`@` ivar, `@@` cvar, `$` global), strings with interpolation, `%w[]`/`%i[]`, symbols, blocks `{|x| …}` and `do |x| … end`, splats, default args, method def
- **Phase 2** — object model + sequential eval. Class table, ancestor-chain dispatch, `super`, singleton classes, `method_missing` fallback, dynamic constant lookup
- **Phase 3** — blocks + procs + lambdas. Method captures escape continuation `^k`; `yield` / `return` / `break` / `next` / `redo` semantics; lambda strict arity vs proc lax
- **Phase 4** — **THE SHOWCASE**: fibers via delcc. `Fiber.new`/`Fiber.resume`/`Fiber.yield`/`Fiber.transfer`. Classic programs (generator, producer-consumer, tree-walk) green
- **Phase 5** — modules + mixins + metaprogramming. `include`/`prepend`/`extend`, `define_method`, `class_eval`/`instance_eval`, `respond_to?`/`respond_to_missing?`, hooks
- **Phase 6** — stdlib drive. `Enumerable` mixin, `Comparable`, Array/Hash/Range/String/Integer methods, drive corpus to 200+
Within a phase, pick the checkbox that unlocks the most tests per effort.
Every iteration: implement → test → commit → tick `[ ]` → Progress log → next.
## Ground rules (hard)
- **Scope:** only `lib/ruby/**` and `plans/ruby-on-sx.md`. Do **not** edit `spec/`, `hosts/`, `shared/`, other `lib/<lang>/` dirs, `lib/stdlib.sx`, or `lib/` root. Ruby primitives go in `lib/ruby/runtime.sx`.
- **NEVER call `sx_build`.** 600s watchdog. If sx_server binary broken → Blockers entry, stop.
- **Shared-file issues** → plan's Blockers with minimal repro.
- **Delimited continuations** are in `lib/callcc.sx` + `spec/evaluator.sx` Step 5. `sx_summarise` spec/evaluator.sx first — 2300+ lines.
- **SX files:** `sx-tree` MCP tools ONLY. `sx_validate` after edits.
- **Worktree:** commit locally. Never push. Never touch `main`.
- **Commit granularity:** one feature per commit.
- **Plan file:** update Progress log + tick boxes every commit.
## Ruby-specific gotchas
- **Block `return` vs lambda `return`.** Inside a block `{ ... return v }`, `return` invokes the *enclosing method's* escape continuation (non-local return). Inside a lambda `->(){ ... return v }`, `return` returns from the *lambda*. Don't conflate. Implement: blocks bind their `^method-k`; lambdas bind their own `^lambda-k`.
- **`break` from inside a block** invokes a different escape — the *iteration loop's* escape — and the loop returns the break-value. `next` is escape from current iteration, returns iteration value. `redo` re-enters current iteration without advancing.
- **Proc arity is lax.** `proc { |a, b, c| … }.call(1, 2)``c = nil`. Lambda is strict — same call raises ArgumentError. Check arity at call site for lambdas only.
- **Block argument unpacking.** `[[1,2],[3,4]].each { |a, b| … }` — single Array arg auto-unpacks for blocks (not lambdas). One arg, one Array → unpack. Frequent footgun.
- **Method dispatch chain order:** prepended modules → class methods → included modules → superclass → BasicObject → method_missing. `super` walks from the *defining* class's position, not the receiver class's.
- **Singleton classes** are lazily allocated. Looking up the chain for an object passes through its singleton class first, then its actual class. `class << obj; …; end` opens the singleton.
- **`method_missing`** — fallback when ancestor walk misses. Receives `(name_symbol, *args, &blk)`. Pair with `respond_to_missing?` for `respond_to?` to also report true. Do **not** swallow NoMethodError silently.
- **Ivars are per-object dicts.** Reading an unset ivar yields `nil` and a warning (`-W`). Don't error.
- **Constant lookup** is first lexical (Module.nesting), then inheritance (Module.ancestors of the innermost class). Different from method lookup.
- **`Object#send`** invokes private and public methods alike; `Object#public_send` skips privates.
- **Class reopening.** `class Foo; def bar; …; end; end` plus a later `class Foo; def baz; …; end; end` adds methods to the same class. Class table lookups must be by-name, mutable; methods dict is mutable.
- **Fiber semantics.** `Fiber.new { |arg| … }` creates a fiber suspended at entry. First `Fiber.resume(v)` enters with `arg = v`. Inside, `Fiber.yield(w)` returns `w` to the resumer; the next `Fiber.resume(v')` returns `v'` to the yield site. End of block returns final value to last resumer; subsequent `Fiber.resume` raises FiberError.
- **`Fiber.transfer`** is symmetric — either side can transfer to the other; no resume/yield asymmetry. Implement on top of the same continuation pair, just don't enforce direction.
- **Symbols are interned.** `:foo == :foo` is identity. Use SX symbols.
- **Strings are mutable.** `s = "abc"; s << "d"; s == "abcd"`. Hash keys can be strings; hash dups string keys at insertion to be safe (or freeze them).
- **Truthiness:** only `false` and `nil` are falsy. `0`, `""`, `[]` are truthy.
- **Test corpus:** custom + curated RubySpec slice. Place programs in `lib/ruby/tests/programs/` with `.rb` extension.
## General gotchas (all loops)
- SX `do` = R7RS iteration. Use `begin` for multi-expr sequences.
- `cond`/`when`/`let` clauses evaluate only the last expr.
- `type-of` on user fn returns `"lambda"`.
- Shell heredoc `||` gets eaten — escape or use `case`.
## Style
- No comments in `.sx` unless non-obvious.
- No new planning docs — update `plans/ruby-on-sx.md` inline.
- Short, factual commit messages (`ruby: Fiber.yield + Fiber.resume (+8)`).
- One feature per iteration. Commit. Log. Next.
Go. Read the plan; find first `[ ]`; implement.

View File

@@ -0,0 +1,77 @@
# smalltalk-on-sx loop agent (single agent, queue-driven)
Role: iterates `plans/smalltalk-on-sx.md` forever. Message-passing OO + **blocks with non-local return** on delimited continuations. Non-local return is the headline showcase — every other Smalltalk reinvents it on the host stack; on SX it falls out of the captured method-return continuation.
```
description: smalltalk-on-sx queue loop
subagent_type: general-purpose
run_in_background: true
isolation: worktree
```
## Prompt
You are the sole background agent working `/root/rose-ash/plans/smalltalk-on-sx.md`. Isolated worktree, forever, one commit per feature. Never push.
## Restart baseline — check before iterating
1. Read `plans/smalltalk-on-sx.md` — roadmap + Progress log.
2. `ls lib/smalltalk/` — pick up from the most advanced file.
3. If `lib/smalltalk/tests/*.sx` exist, run them. Green before new work.
4. If `lib/smalltalk/scoreboard.md` exists, that's your baseline.
## The queue
Phase order per `plans/smalltalk-on-sx.md`:
- **Phase 1** — tokenizer + parser (chunk format, identifiers, keywords `foo:`, binary selectors, `#sym`, `#(…)`, `$c`, blocks `[:a | …]`, cascades, message precedence)
- **Phase 2** — object model + sequential eval (class table bootstrap, message dispatch, `super`, `doesNotUnderstand:`, instance variables)
- **Phase 3** — **THE SHOWCASE**: blocks with non-local return via captured method-return continuation. `whileTrue:` / `ifTrue:ifFalse:` as block sends. 5 classic programs (eight-queens, quicksort, mandelbrot, life, fibonacci) green.
- **Phase 4** — reflection + MOP: `perform:`, `respondsTo:`, runtime method addition, `becomeForward:`, `Exception` / `on:do:` / `ensure:` on top of `handler-bind`/`raise`
- **Phase 5** — collections + numeric tower + streams
- **Phase 6** — port SUnit, vendor Pharo Kernel-Tests slice, drive corpus to 200+
- **Phase 7** — speed (optional): inline caching, block intrinsification
Within a phase, pick the checkbox that unlocks the most tests per effort.
Every iteration: implement → test → commit → tick `[ ]` → Progress log → next.
## Ground rules (hard)
- **Scope:** only `lib/smalltalk/**` and `plans/smalltalk-on-sx.md`. Do **not** edit `spec/`, `hosts/`, `shared/`, other `lib/<lang>/` dirs, `lib/stdlib.sx`, or `lib/` root. Smalltalk primitives go in `lib/smalltalk/runtime.sx`.
- **NEVER call `sx_build`.** 600s watchdog. If sx_server binary broken → Blockers entry, stop.
- **Shared-file issues** → plan's Blockers with minimal repro.
- **Delimited continuations** are in `lib/callcc.sx` + `spec/evaluator.sx` Step 5. `sx_summarise` spec/evaluator.sx first — 2300+ lines.
- **SX files:** `sx-tree` MCP tools ONLY. `sx_validate` after edits.
- **Worktree:** commit locally. Never push. Never touch `main`.
- **Commit granularity:** one feature per commit.
- **Plan file:** update Progress log + tick boxes every commit.
## Smalltalk-specific gotchas
- **Method invocation captures `^k`** — the return continuation. Bind it as the block's escape token. `^expr` from inside any nested block invokes that captured `^k`. Escape past method return raises `BlockContext>>cannotReturn:`.
- **Blocks are lambdas + escape token**, not bare lambdas. `value`/`value:`/… invoke the lambda; `^` invokes the escape.
- **`ifTrue:` / `ifFalse:` / `whileTrue:` are ordinary block sends** — no special form. The runtime intrinsifies them in the JIT path (Tier 1 of bytecode expansion already covers this pattern).
- **Cascade** `r m1; m2; m3` desugars to `(let ((tmp r)) (st-send tmp 'm1 ()) (st-send tmp 'm2 ()) (st-send tmp 'm3 ()))`. Result is the cascade's last send (or first, depending on parser variant — pick one and document).
- **`super` send** looks up starting from the *defining* class's superclass, not the receiver class. Stash the defining class on the method record.
- **Selectors are interned symbols.** Use SX symbols.
- **Receiver dispatch:** tagged ints / floats / strings / symbols / `nil` / `true` / `false` aren't boxed. Their classes (`SmallInteger`, `Float`, `String`, `Symbol`, `UndefinedObject`, `True`, `False`) are looked up by SX type-of, not by an `:class` field.
- **Method precedence:** unary > binary > keyword. `3 + 4 factorial` is `3 + (4 factorial)`. `a foo: b bar` is `a foo: (b bar)` (keyword absorbs trailing unary).
- **Image / fileIn / become: between sessions** = out of scope. One-way `becomeForward:` only.
- **Test corpus:** ~200 hand-written + a slice of Pharo Kernel-Tests. Place programs in `lib/smalltalk/tests/programs/`.
## General gotchas (all loops)
- SX `do` = R7RS iteration. Use `begin` for multi-expr sequences.
- `cond`/`when`/`let` clauses evaluate only the last expr.
- `type-of` on user fn returns `"lambda"`.
- Shell heredoc `||` gets eaten — escape or use `case`.
## Style
- No comments in `.sx` unless non-obvious.
- No new planning docs — update `plans/smalltalk-on-sx.md` inline.
- Short, factual commit messages (`smalltalk: tokenizer + 56 tests`).
- One feature per iteration. Commit. Log. Next.
Go. Read the plan; find first `[ ]`; implement.

View File

@@ -0,0 +1,83 @@
# tcl-on-sx loop agent (single agent, queue-driven)
Role: iterates `plans/tcl-on-sx.md` forever. `uplevel`/`upvar` is the headline showcase — Tcl's superpower for defining your own control structures, requiring deep VM cooperation in any normal host but falling out of SX's first-class env-chain. Plus the Dodekalogue (12 rules), command-substitution everywhere, and "everything is a string" homoiconicity.
```
description: tcl-on-sx queue loop
subagent_type: general-purpose
run_in_background: true
isolation: worktree
```
## Prompt
You are the sole background agent working `/root/rose-ash/plans/tcl-on-sx.md`. Isolated worktree, forever, one commit per feature. Never push.
## Restart baseline — check before iterating
1. Read `plans/tcl-on-sx.md` — roadmap + Progress log.
2. `ls lib/tcl/` — pick up from the most advanced file.
3. If `lib/tcl/tests/*.sx` exist, run them. Green before new work.
4. If `lib/tcl/scoreboard.md` exists, that's your baseline.
## The queue
Phase order per `plans/tcl-on-sx.md`:
- **Phase 1** — tokenizer + parser. The Dodekalogue (12 rules): word-splitting, command sub `[…]`, var sub `$name`/`${name}`/`$arr(idx)`, double-quote vs brace word, backslash, `;`, `#` comments only at command start, single-pass left-to-right substitution
- **Phase 2** — sequential eval + core commands. `set`/`unset`/`incr`/`append`/`lappend`, `puts`/`gets`, `expr` (own mini-language), `if`/`while`/`for`/`foreach`/`switch`, string commands, list commands, dict commands
- **Phase 3** — **THE SHOWCASE**: `proc` + `uplevel` + `upvar`. Frame stack with proc-call push/pop; `uplevel #N script` evaluates in caller's frame; `upvar` aliases names across frames. Classic programs (for-each-line, assert macro, with-temp-var) green
- **Phase 4** — `return -code N`, `catch`, `try`/`trap`/`finally`, `throw`. Control flow as integer codes
- **Phase 5** — namespaces + ensembles. `namespace eval`, qualified names `::ns::cmd`, ensembles, `namespace path`
- **Phase 6** — coroutines (built on fibers, same delcc as Ruby fibers) + system commands + drive corpus to 150+
Within a phase, pick the checkbox that unlocks the most tests per effort.
Every iteration: implement → test → commit → tick `[ ]` → Progress log → next.
## Ground rules (hard)
- **Scope:** only `lib/tcl/**` and `plans/tcl-on-sx.md`. Do **not** edit `spec/`, `hosts/`, `shared/`, other `lib/<lang>/` dirs, `lib/stdlib.sx`, or `lib/` root. Tcl primitives go in `lib/tcl/runtime.sx`.
- **NEVER call `sx_build`.** 600s watchdog. If sx_server binary broken → Blockers entry, stop.
- **Shared-file issues** → plan's Blockers with minimal repro.
- **Delimited continuations** are in `lib/callcc.sx` + `spec/evaluator.sx` Step 5. `sx_summarise` spec/evaluator.sx first — 2300+ lines.
- **SX files:** `sx-tree` MCP tools ONLY. `sx_validate` after edits.
- **Worktree:** commit locally. Never push. Never touch `main`.
- **Commit granularity:** one feature per commit.
- **Plan file:** update Progress log + tick boxes every commit.
## Tcl-specific gotchas
- **Everything is a string.** Internally cache shimmer reps (list, dict, int, double) for performance, but every value must be re-stringifiable. Mutating one rep dirties the cached string and vice versa.
- **The Dodekalogue is strict.** Substitution is **one-pass**, **left-to-right**. The result of a substitution is a value, not a script — it does NOT get re-parsed for further substitutions. This is what makes Tcl safe-by-default. Don't accidentally re-parse.
- **Brace word `{…}`** is the only way to defer evaluation. No substitution inside, just balanced braces. Used for `if {expr}` body, `proc body`, `expr` arguments.
- **Double-quote word `"…"`** is identical to a bare word for substitution purposes — it just allows whitespace in a single word. `\` escapes still apply.
- **Comments are only at command position.** `# this is a comment` after a `;` or newline; *not* inside a command. `set x 1 # not a comment` is a 4-arg `set`.
- **`expr` has its own grammar** — operator precedence, function calls — and does its own substitution. Brace `expr {$x + 1}` to avoid double-substitution and to enable bytecode caching.
- **`if` and `while` re-parse** the condition only if not braced. Always use `if {…}`/`while {…}` form. The unbraced form re-substitutes per iteration.
- **`return` from a `proc`** uses control code 2. `break` is 3, `continue` is 4. `error` is 1. `catch` traps any non-zero code; user can return non-zero with `return -code error -errorcode FOO message`.
- **`uplevel #0 script`** is global frame. `uplevel 1 script` (or just `uplevel script`) is caller's frame. `uplevel #N` is absolute level N (0=global, 1=top-level proc, 2=proc-called-from-top, …). Negative levels are errors.
- **`upvar #N otherVar localVar`** binds `localVar` in the current frame as an *alias* — both names refer to the same storage. Reads and writes go through the alias.
- **`info level`** with no arg returns current level number. `info level N` (positive) returns the command list that invoked level N. `info level -N` returns the command list of the level N relative-up.
- **Variable names with `(…)`** are array elements: `set arr(foo) 1`. Arrays are not first-class values — you can't `set x $arr`. `array get arr` gives a flat list `{key1 val1 key2 val2 …}`.
- **List vs string.** `set l "a b c"` and `set l [list a b c]` look the same when printed but the second has a cached list rep. `lindex` works on both via shimmering. Most user code can't tell the difference.
- **`incr x`** errors if x doesn't exist; pre-set with `set x 0` or use `incr x 0` first if you mean "create-or-increment". Or use `dict incr` for dicts.
- **Coroutines are fibers.** `coroutine name body` starts a coroutine; calling `name` resumes it; `yield value` from inside suspends and returns `value` to the resumer. Same primitive as Ruby fibers — share the implementation under the hood.
- **`switch`** matches first clause whose pattern matches. Default is `default`. Variant matches: glob (default), `-exact`, `-glob`, `-regexp`. Body `-` means "fall through to next clause's body".
- **Test corpus:** custom + slice of Tcl's own tests. Place programs in `lib/tcl/tests/programs/` with `.tcl` extension.
## General gotchas (all loops)
- SX `do` = R7RS iteration. Use `begin` for multi-expr sequences.
- `cond`/`when`/`let` clauses evaluate only the last expr.
- `type-of` on user fn returns `"lambda"`.
- Shell heredoc `||` gets eaten — escape or use `case`.
## Style
- No comments in `.sx` unless non-obvious.
- No new planning docs — update `plans/tcl-on-sx.md` inline.
- Short, factual commit messages (`tcl: uplevel + upvar (+11)`).
- One feature per iteration. Commit. Log. Next.
Go. Read the plan; find first `[ ]`; implement.

115
plans/apl-on-sx.md Normal file
View File

@@ -0,0 +1,115 @@
# APL-on-SX: rank-polymorphic primitives + glyph parser
The headline showcase is **rank polymorphism** — a single primitive (`+`, `⌈`, `⊂`, ``) works uniformly on scalars, vectors, matrices, and higher-rank arrays. ~80 glyph primitives + 6 operators bind together with right-to-left evaluation; the entire language is a high-density combinator algebra. The JIT compiler + primitive table pay off massively here because almost every program is `array → array` pure pipelines.
End-state goal: Dyalog-flavoured APL subset, dfns + tradfns, classic programs (game-of-life, mandelbrot, prime-sieve, n-queens, conway), 100+ green tests.
## Scope decisions (defaults — override by editing before we spawn)
- **Syntax:** Dyalog APL surface, Unicode glyphs. `⎕`-quad system functions for I/O. `∇` tradfn header.
- **Conformance:** "Reads like APL, runs like APL." Not byte-compat with Dyalog; we care about right-to-left semantics and rank polymorphism.
- **Test corpus:** custom — APL idioms (Roger Hui style), classic programs, plus ~50 pattern tests for primitives.
- **Out of scope:** ⎕-namespaces beyond a handful, complex numbers, full TAO ordering, `⎕FX` runtime function definition (use static `∇` only), nested-array-of-functions higher orders, the editor.
- **Glyphs:** input via plain Unicode in `.apl` source files. Backtick-prefix shortcuts handled by the user's editor — we don't ship one.
## Ground rules
- **Scope:** only touch `lib/apl/**` and `plans/apl-on-sx.md`. Don't edit `spec/`, `hosts/`, `shared/`, or any other `lib/<lang>/**`. APL primitives go in `lib/apl/runtime.sx`.
- **SX files:** use `sx-tree` MCP tools only.
- **Commits:** one feature per commit. Keep `## Progress log` updated and tick roadmap boxes.
## Architecture sketch
```
APL source (Unicode glyphs)
lib/apl/tokenizer.sx — glyphs, identifiers, numbers (¯ for negative), strings, strands
lib/apl/parser.sx — right-to-left with valence resolution (mon vs dyadic by position)
lib/apl/transpile.sx — AST → SX AST (entry: apl-eval-ast)
lib/apl/runtime.sx — array model, ~80 primitives, 6 operators, dfns/tradfns
```
Core mapping:
- **Array** = SX dict `{:shape (d1 d2 …) :ravel #(v1 v2 …)}`. Scalar is rank-0 (empty shape), vector is rank-1, matrix rank-2, etc. Type uniformity not required (heterogeneous nested arrays via "boxed" elements `⊂x`).
- **Rank polymorphism** — every scalar primitive is broadcast: `1 2 3 + 4 5 6``5 7 9`; `(2 36) + 1` ↦ broadcast scalar to matrix.
- **Conformability** = matching shapes, or one-side scalar, or rank-1 cycling (deferred — keep strict in v1).
- **Valence** = each glyph has a monadic and a dyadic meaning; resolution is purely positional (left-arg present → dyadic).
- **Operator** = takes one or two function operands, returns a derived function (`f¨` = `each f`, `f/` = `reduce f`, `f∘g` = `compose`, `f⍨` = `commute`).
- **Tradfn** `∇R←L F R; locals` = named function with explicit header.
- **Dfn** `{+⍵}` = anonymous, `` = left arg, `⍵` = right arg, `∇` = recurse.
## Roadmap
### Phase 1 — tokenizer + parser
- [ ] Tokenizer: Unicode glyphs (the full APL set: `+ - × ÷ * ⍟ ⌈ ⌊ | ! ? ○ ~ < ≤ = ≥ > ≠ ∊ ∧ ⍱ ⍲ , ⍪ ⌽ ⊖ ⍉ ↑ ↓ ⊂ ⊃ ⊆ ⍸ ⌷ ⍋ ⍒ ⊥ ⊣ ⊢ ⍎ ⍕ ⍝`), operators (`/ \ ¨ ⍨ ∘ . ⍣ ⍤ ⍥ @`), numbers (`¯` for negative, `1E2`, `1J2` complex deferred), characters (`'a'`, `''` escape), strands (juxtaposition of literals: `1 2 3`), names, comments `⍝ …`
- [ ] Parser: right-to-left; classify each token as function, operator, value, or name; resolve valence positionally; dfn `{…}` body, tradfn `∇` header, guards `:`, control words `:If :While :For …` (Dyalog-style)
- [ ] Unit tests in `lib/apl/tests/parse.sx`
### Phase 2 — array model + scalar primitives
- [ ] Array constructor: `make-array shape ravel`, `scalar v`, `vector v…`, `enclose`/`disclose`
- [ ] Shape arithmetic: `` (shape), `,` (ravel), `≢` (tally / first-axis-length), `≡` (depth)
- [ ] Scalar arithmetic primitives broadcast: `+ - × ÷ ⌈ ⌊ * ⍟ | ! ○`
- [ ] Scalar comparison primitives: `< ≤ = ≥ > ≠`
- [ ] Scalar logical: `~ ∧ ⍱ ⍲`
- [ ] Index generator: `n` (vector 1..n or 0..n-1 depending on `⎕IO`)
- [ ] `⎕IO` = 1 default (Dyalog convention)
- [ ] 40+ tests in `lib/apl/tests/scalar.sx`
### Phase 3 — structural primitives + indexing
- [ ] Reshape ``, ravel `,`, transpose `⍉` (full + dyadic axis spec)
- [ ] Take `↑`, drop `↓`, rotate `⌽` (last axis), `⊖` (first axis)
- [ ] Catenate `,` (last axis) and `⍪` (first axis)
- [ ] Index `⌷` (squad), bracket-indexing `A[I]` (sugar for `⌷`)
- [ ] Grade-up `⍋`, grade-down `⍒`
- [ ] Enclose `⊂`, disclose `⊃`, partition (subset deferred)
- [ ] Membership `∊`, find `` (dyadic), without `~` (dyadic), unique `` (deferred to phase 6)
- [ ] 40+ tests in `lib/apl/tests/structural.sx`
### Phase 4 — operators (THE SHOWCASE)
- [ ] Reduce `f/` (last axis), `f⌿` (first axis) — including `∧/`, `/`, `+/`, `×/`, `⌈/`, `⌊/`
- [ ] Scan `f\`, `f⍀`
- [ ] Each `f¨` — applies `f` to each scalar/element
- [ ] Outer product `∘.f``1 2 3 ∘.× 1 2 3` ↦ multiplication table
- [ ] Inner product `f.g``+.×` is matrix multiply
- [ ] Commute `f⍨``f⍨ x``x f x`, `x f⍨ y``y f x`
- [ ] Compose `f∘g` — applies `g` first then `f`
- [ ] Power `f⍣n` — apply f n times; `f⍣≡` until fixed point
- [ ] Rank `f⍤k` — apply f at sub-rank k
- [ ] At `@` — selective replace
- [ ] 40+ tests in `lib/apl/tests/operators.sx`
### Phase 5 — dfns + tradfns + control flow
- [ ] Dfn `{…}` with `` (left arg, may be absent → niladic/monadic), `⍵` (right arg), `∇` (recurse), guards `cond:expr`, default left arg `←default`
- [ ] Local assignment via `←` (lexical inside dfn)
- [ ] Tradfn `∇` header: `R←L F R;l1;l2`, statement-by-statement, branch via `→linenum`
- [ ] Dyalog control words: `:If/:Else/:EndIf`, `:While/:EndWhile`, `:For X :In V :EndFor`, `:Select/:Case/:EndSelect`, `:Trap`/`:EndTrap`
- [ ] Niladic / monadic / dyadic dispatch (function valence at definition time)
- [ ] `lib/apl/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md`
### Phase 6 — classic programs + drive corpus
- [ ] Classic programs in `lib/apl/tests/programs/`:
- [ ] `life.apl` — Conway's Game of Life as a one-liner using `⊂` `⊖` `⌽` `+/`
- [ ] `mandelbrot.apl` — complex iteration with rank-polymorphic `+ × ⌊` (or real-axis subset)
- [ ] `primes.apl``(2=+⌿0=A∘.|A)/A←N` sieve
- [ ] `n-queens.apl` — backtracking via reduce
- [ ] `quicksort.apl` — the classic Roger Hui one-liner
- [ ] System functions: `⎕FMT`, `⎕FR` (float repr), `⎕TS` (timestamp), `⎕IO`, `⎕ML` (migration level — fixed at 1), `⎕←` (print)
- [ ] Drive corpus to 100+ green
- [ ] Idiom corpus — `lib/apl/tests/idioms.sx` covering classic Roger Hui / Phil Last idioms
## Progress log
_Newest first._
- _(none yet)_
## Blockers
- _(none yet)_

121
plans/common-lisp-on-sx.md Normal file
View File

@@ -0,0 +1,121 @@
# Common-Lisp-on-SX: conditions + restarts on delimited continuations
The headline showcase is the **condition system**. Restarts are *resumable* exceptions — every other Lisp implementation reinvents this on host-stack unwind tricks. On SX restarts are textbook delimited continuations: `signal` walks the handler chain; `invoke-restart` resumes the captured continuation at the restart point. Same delcc primitive that powers Erlang actors, expressed as a different surface.
End-state goal: ANSI Common Lisp subset with a working condition/restart system, CLOS multimethods (with `:before`/`:after`/`:around`), the LOOP macro, packages, and ~150 hand-written + classic programs.
## Scope decisions (defaults — override by editing before we spawn)
- **Syntax:** ANSI Common Lisp surface. Read tables, dispatch macros (`#'`, `#(`, `#\`, `#:`, `#x`, `#b`, `#o`, ratios `1/3`).
- **Conformance:** ANSI X3.226 *as a target*, not bug-for-bug SBCL/CCL. "Reads like CL, runs like CL."
- **Test corpus:** custom + a curated slice of `ansi-test`. Plus classic programs: condition-system demo, restart-driven debugger, multiple-dispatch geometry, LOOP corpus.
- **Out of scope:** compilation to native, FFI, sockets, threads, MOP class redefinition, full pathname/logical-pathname machinery, structures with `:include` deep customization.
- **Packages:** simple — `defpackage`/`in-package`/`export`/`use-package`/`:cl`/`:cl-user`. No nicknames, no shadowing-import edge cases.
## Ground rules
- **Scope:** only touch `lib/common-lisp/**` and `plans/common-lisp-on-sx.md`. Don't edit `spec/`, `hosts/`, `shared/`, or any other `lib/<lang>/**`. CL primitives go in `lib/common-lisp/runtime.sx`.
- **SX files:** use `sx-tree` MCP tools only.
- **Commits:** one feature per commit. Keep `## Progress log` updated and tick roadmap boxes.
## Architecture sketch
```
Common Lisp source
lib/common-lisp/reader.sx — tokenizer + reader (read macros, dispatch chars)
lib/common-lisp/parser.sx — AST: forms, declarations, lambda lists
lib/common-lisp/transpile.sx — AST → SX AST (entry: cl-eval-ast)
lib/common-lisp/runtime.sx — special forms, condition system, CLOS, packages, BIFs
```
Core mapping:
- **Symbol** = SX symbol with package prefix; package table is a flat dict.
- **Cons cell** = SX pair via `cons`/`car`/`cdr`; lists native.
- **Multiple values** = thread through `values`/`multiple-value-bind`; primary-value default for one-context callers.
- **Block / return-from** = captured continuation; `return-from name v` invokes the block-named `^k`.
- **Tagbody / go** = each tag is a continuation; `go tag` invokes it.
- **Unwind-protect** = scope frame with a cleanup thunk fired on any non-local exit.
- **Conditions / restarts** = layered handler chain on top of `handler-bind` + delcc. `signal` walks handlers; `invoke-restart` resumes a captured continuation.
- **CLOS** = generic functions are dispatch tables on argument-class lists; method combination computed lazily; `call-next-method` is a continuation.
- **Macros** = SX macros (sentinel-body) — defmacro lowers directly.
## Roadmap
### Phase 1 — reader + parser
- [ ] Tokenizer: symbols (with package qualification `pkg:sym` / `pkg::sym`), numbers (int, float, ratio `1/3`, `#xFF`, `#b1010`, `#o17`), strings `"…"` with `\` escapes, characters `#\Space` `#\Newline` `#\a`, comments `;`, block comments `#| … |#`
- [ ] Reader: list, dotted pair, quote `'`, function `#'`, quasiquote `` ` ``, unquote `,`, splice `,@`, vector `#(…)`, uninterned `#:foo`, nil/t literals
- [ ] Parser: lambda lists with `&optional` `&rest` `&key` `&aux` `&allow-other-keys`, defaults, supplied-p variables
- [ ] Unit tests in `lib/common-lisp/tests/read.sx`
### Phase 2 — sequential eval + special forms
- [ ] `cl-eval-ast`: `quote`, `if`, `progn`, `let`, `let*`, `flet`, `labels`, `setq`, `setf` (subset), `function`, `lambda`, `the`, `locally`, `eval-when`
- [ ] `block` + `return-from` via captured continuation
- [ ] `tagbody` + `go` via per-tag continuations
- [ ] `unwind-protect` cleanup frame
- [ ] `multiple-value-bind`, `multiple-value-call`, `multiple-value-prog1`, `values`, `nth-value`
- [ ] `defun`, `defparameter`, `defvar`, `defconstant`, `declaim`, `proclaim` (no-op)
- [ ] Dynamic variables — `defvar`/`defparameter` produce specials; `let` rebinds via parameterize-style scope
- [ ] 60+ tests in `lib/common-lisp/tests/eval.sx`
### Phase 3 — conditions + restarts (THE SHOWCASE)
- [ ] `define-condition` — class hierarchy rooted at `condition`/`error`/`warning`/`simple-error`/`simple-warning`/`type-error`/`arithmetic-error`/`division-by-zero`
- [ ] `signal`, `error`, `cerror`, `warn` — all walk the handler chain
- [ ] `handler-bind` — non-unwinding handlers, may decline by returning normally
- [ ] `handler-case` — unwinding handlers (delcc abort)
- [ ] `restart-case`, `with-simple-restart`, `restart-bind`
- [ ] `find-restart`, `invoke-restart`, `invoke-restart-interactively`, `compute-restarts`
- [ ] `with-condition-restarts` — associate restarts with a specific condition
- [ ] `*break-on-signals*`, `*debugger-hook*` (basic)
- [ ] Classic programs in `lib/common-lisp/tests/programs/`:
- [ ] `restart-demo.lisp` — division with `:use-zero` and `:retry` restarts
- [ ] `parse-recover.lisp` — parser with skipped-token restart
- [ ] `interactive-debugger.lisp` — ASCII REPL using `:debugger-hook`
- [ ] `lib/common-lisp/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md`
### Phase 4 — CLOS
- [ ] `defclass` with `:initarg`/`:initform`/`:accessor`/`:reader`/`:writer`/`:allocation`
- [ ] `make-instance`, `slot-value`, `(setf slot-value)`, `with-slots`, `with-accessors`
- [ ] `defgeneric` with `:method-combination` (standard, plus `+`, `and`, `or`)
- [ ] `defmethod` with `:before` / `:after` / `:around` qualifiers
- [ ] `call-next-method` (continuation), `next-method-p`
- [ ] `class-of`, `find-class`, `slot-boundp`, `change-class` (basic)
- [ ] Multiple dispatch — method specificity by argument-class precedence list
- [ ] Built-in classes registered for tagged values (`integer`, `float`, `string`, `symbol`, `cons`, `null`, `t`)
- [ ] Classic programs:
- [ ] `geometry.lisp``intersect` generic dispatching on (point line), (line line), (line plane)…
- [ ] `mop-trace.lisp``:before` + `:after` printing call trace
### Phase 5 — macros + LOOP + reader macros
- [ ] `defmacro`, `macrolet`, `symbol-macrolet`, `macroexpand-1`, `macroexpand`
- [ ] `gensym`, `gentemp`
- [ ] `set-macro-character`, `set-dispatch-macro-character`, `get-macro-character`
- [ ] **The LOOP macro** — iteration drivers (`for … in/across/from/upto/downto/by`, `while`, `until`, `repeat`), accumulators (`collect`, `append`, `nconc`, `count`, `sum`, `maximize`, `minimize`), conditional clauses (`if`/`when`/`unless`/`else`), termination (`finally`/`thereis`/`always`/`never`), `named` blocks
- [ ] LOOP test corpus: 30+ tests covering all clause types
### Phase 6 — packages + stdlib drive
- [ ] `defpackage`, `in-package`, `export`, `use-package`, `import`, `find-package`
- [ ] Package qualification at the reader level — `cl:car`, `mypkg::internal`
- [ ] `:common-lisp` (`:cl`) and `:common-lisp-user` (`:cl-user`) packages
- [ ] Sequence functions — `mapcar`, `mapc`, `mapcan`, `reduce`, `find`, `find-if`, `position`, `count`, `every`, `some`, `notany`, `notevery`, `remove`, `remove-if`, `subst`
- [ ] List ops — `assoc`, `getf`, `nth`, `last`, `butlast`, `nthcdr`, `tailp`, `ldiff`
- [ ] String ops — `string=`, `string-upcase`, `string-downcase`, `subseq`, `concatenate`
- [ ] FORMAT — basic directives `~A`, `~S`, `~D`, `~F`, `~%`, `~&`, `~T`, `~{...~}` (iteration), `~[...~]` (conditional), `~^` (escape), `~P` (plural)
- [ ] Drive corpus to 200+ green
## Progress log
_Newest first._
- _(none yet)_
## Blockers
- _(none yet)_

View File

@@ -4,10 +4,10 @@ Live tally for `plans/hs-conformance-to-100.md`. Update after every cluster comm
``` ```
Baseline: 1213/1496 (81.1%) Baseline: 1213/1496 (81.1%)
Merged: 1303/1496 (87.1%) delta +90 Merged: 1277/1496 (85.4%) delta +64
Worktree: all landed Worktree: all landed
Target: 1496/1496 (100.0%) Target: 1496/1496 (100.0%)
Remaining: ~194 tests (clusters 17/29(partial)/31 blocked; 33/34 partial) Remaining: ~219 tests (cluster 29 blocked on sx-tree MCP outage + parser scope)
``` ```
## Cluster ledger ## Cluster ledger
@@ -42,7 +42,7 @@ Remaining: ~194 tests (clusters 17/29(partial)/31 blocked; 33/34 partial)
| 19 | `pick` regex + indices | done | +13 | 4be90bf2 | | 19 | `pick` regex + indices | done | +13 | 4be90bf2 |
| 20 | `repeat` property for-loops + where | done | +3 | c932ad59 | | 20 | `repeat` property for-loops + where | done | +3 | c932ad59 |
| 21 | `possessiveExpression` property access via its | done | +1 | f0c41278 | | 21 | `possessiveExpression` property access via its | done | +1 | f0c41278 |
| 22 | window global fn fallback | done | +1 | d31565d5 | | 22 | window global fn fallback | blocked | | |
| 23 | `me symbol works in from expressions` | done | +1 | 0d38a75b | | 23 | `me symbol works in from expressions` | done | +1 | 0d38a75b |
| 24 | `properly interpolates values 2` | done | +1 | cb37259d | | 24 | `properly interpolates values 2` | done | +1 | cb37259d |
| 25 | parenthesized commands and features | done | +1 | d7a88d85 | | 25 | parenthesized commands and features | done | +1 | d7a88d85 |
@@ -54,18 +54,18 @@ Remaining: ~194 tests (clusters 17/29(partial)/31 blocked; 33/34 partial)
| 26 | resize observer mock + `on resize` | done | +3 | 304a52d2 | | 26 | resize observer mock + `on resize` | done | +3 | 304a52d2 |
| 27 | intersection observer mock + `on intersection` | done | +3 | 0c31dd27 | | 27 | intersection observer mock + `on intersection` | done | +3 | 0c31dd27 |
| 28 | `ask`/`answer` + prompt/confirm mock | done | +4 | 6c1da921 | | 28 | `ask`/`answer` + prompt/confirm mock | done | +4 | 6c1da921 |
| 29 | `hyperscript:before:init` / `:after:init` / `:parse-error` | partial | +2 | e01a3baa | | 29 | `hyperscript:before:init` / `:after:init` / `:parse-error` | blocked | | |
| 30 | `logAll` config | done | +1 | 64bcefff | | 30 | `logAll` config | done | +1 | 64bcefff |
### Bucket D — medium features ### Bucket D — medium features
| # | Cluster | Status | Δ | | # | Cluster | Status | Δ |
|---|---------|--------|---| |---|---------|--------|---|
| 31 | runtime null-safety error reporting | blocked | — | | 31 | runtime null-safety error reporting | pending | (+1518 est) |
| 32 | MutationObserver mock + `on mutation` | done | +7 | | 32 | MutationObserver mock + `on mutation` | pending | (+1015 est) |
| 33 | cookie API | partial | +4 | | 33 | cookie API | pending | (+5 est) |
| 34 | event modifier DSL | partial | +7 | | 34 | event modifier DSL | pending | (+68 est) |
| 35 | namespaced `def` | done | +3 | | 35 | namespaced `def` | pending | (+3 est) |
### Bucket E — subsystems (design docs landed, pending review + implementation) ### Bucket E — subsystems (design docs landed, pending review + implementation)
@@ -86,9 +86,9 @@ Defer until AD drain. Estimated ~25 recoverable tests.
| Bucket | Done | Partial | In-prog | Pending | Blocked | Design-done | Total | | Bucket | Done | Partial | In-prog | Pending | Blocked | Design-done | Total |
|--------|-----:|--------:|--------:|--------:|--------:|------------:|------:| |--------|-----:|--------:|--------:|--------:|--------:|------------:|------:|
| A | 12 | 4 | 0 | 0 | 1 | — | 17 | | A | 12 | 4 | 0 | 0 | 1 | — | 17 |
| B | 7 | 0 | 0 | 0 | 0 | — | 7 | | B | 6 | 0 | 0 | 0 | 1 | — | 7 |
| C | 4 | 1 | 0 | 0 | 0 | — | 5 | | C | 4 | 0 | 0 | 0 | 1 | — | 5 |
| D | 2 | 2 | 0 | 0 | 1 | — | 5 | | D | 0 | 0 | 0 | 5 | 0 | — | 5 |
| E | 0 | 0 | 0 | 0 | 0 | 5 | 5 | | E | 0 | 0 | 0 | 0 | 0 | 5 | 5 |
| F | — | — | — | ~10 | — | — | ~10 | | F | — | — | — | ~10 | — | — | ~10 |

View File

@@ -69,7 +69,7 @@ Orchestrator cherry-picks worktree commits onto `architecture` one at a time; re
10. **[done (+1)] `swap` variable ↔ property** — `swap / can swap a variable with a property` (1 test). Swap command doesn't handle mixed var/prop targets. Expected: +1. 10. **[done (+1)] `swap` variable ↔ property** — `swap / can swap a variable with a property` (1 test). Swap command doesn't handle mixed var/prop targets. Expected: +1.
11. **[done (+4)] `hide` strategy** — `hide / can configure hidden as default`, `can hide with custom strategy`, `can set default to custom strategy`, `hide element then show element retains original display` (4 tests). Strategy config plumbing. Expected: +3-4. 11. **[done (+3) — partial, `hide element then show element retains original display` remains; needs `on click N` count-filtered event handlers, out of scope for this cluster] `hide` strategy** — `hide / can configure hidden as default`, `can hide with custom strategy`, `can set default to custom strategy`, `hide element then show element retains original display` (4 tests). Strategy config plumbing. Expected: +3-4.
12. **[done (+2)] `show` multi-element + display retention** — `show / can show multiple elements with inline-block`, `can filter over a set of elements using the its symbol` (2 tests). Expected: +2. 12. **[done (+2)] `show` multi-element + display retention** — `show / can show multiple elements with inline-block`, `can filter over a set of elements using the its symbol` (2 tests). Expected: +2.
@@ -93,7 +93,7 @@ Orchestrator cherry-picks worktree commits onto `architecture` one at a time; re
21. **[done (+1)] `possessiveExpression` property access via its** — `possessive / can access its properties` (1 test, Expected `foo` got ``). Expected: +1. 21. **[done (+1)] `possessiveExpression` property access via its** — `possessive / can access its properties` (1 test, Expected `foo` got ``). Expected: +1.
22. **[done (+1)] window global fn fallback** — `regressions / can invoke functions w/ numbers in name` + `can refer to function in init blocks`. Added `host-call-fn` FFI primitive (commit 337c8265), `hs-win-call` runtime helper, simplified compiler emit (direct hs-win-call, no guard), `def` now also registers fn on `window[name]`. Generator: fixed `\"` escaping in hs-compile string literals. Expected: +2-4. 22. **[blocked: tried three compile-time emits — (1) guard (can't catch Undefined symbol since it's a host-level error, not an SX raise), (2) env-has? (primitive not loaded in HS kernel — `Unhandled exception: "env-has?"`), and (3) hs-win-call runtime helper (works when reached but SX can't CALL a host-handle function directly — `Not callable: {:__host_handle N}` because NativeFn is not callable here). Needs either a host-call-fn primitive with arity-agnostic dispatch OR a symbol-bound? predicate in the HS kernel.] window global fn fallback** — `regressions / can invoke functions w/ numbers in name` + unlocks several others. When calling `foo()` where `foo` isn't SX-defined, fall back to `(host-global "foo")`. Design decision: either compile-time emit `(or foo (host-global "foo"))` via a helper, or add runtime lookup in the dispatch path. Expected: +2-4.
23. **[done (+1)] `me symbol works in from expressions`** — `regressions` (1 test, Expected `Foo`). Check `from` expression compilation. Expected: +1. 23. **[done (+1)] `me symbol works in from expressions`** — `regressions` (1 test, Expected `Foo`). Check `from` expression compilation. Expected: +1.
@@ -109,21 +109,21 @@ Orchestrator cherry-picks worktree commits onto `architecture` one at a time; re
28. **[done (+4)] `ask`/`answer` + prompt/confirm mock** — `askAnswer` 4 tests. **Requires test-name-keyed mock**: first test wants `confirm → true`, second `confirm → false`, third `prompt → "Alice"`, fourth `prompt → null`. Keyed via `_current-test-name` in the runner. Expected: +4. 28. **[done (+4)] `ask`/`answer` + prompt/confirm mock** — `askAnswer` 4 tests. **Requires test-name-keyed mock**: first test wants `confirm → true`, second `confirm → false`, third `prompt → "Alice"`, fourth `prompt → null`. Keyed via `_current-test-name` in the runner. Expected: +4.
29. **[done (+2) — partial, 4 parser-error tests remain (basic parse error messages, parse-error event, EOF newline crash, evaluate-api-first-error). All require stricter parser error-rejection `add - to` currently parses silently to `(set! nil (hs-add-to! (- 0 nil) nil))`, `on click blargh end on mouseenter also_bad` parses silently to `(do (hs-on me "click" (fn (event) blargh)) (hs-on me "mouseenter" (fn (event) also_bad)))`. Plus emit-error-collection runtime + hyperscript:parse-error event with detail.errors. Larger than a single cluster budget; recommend bucket-D plan-first.] `hyperscript:before:init` / `:after:init` / `:parse-error` events** — 6 tests in `bootstrap` + `parser`. Fire DOM events at activation boundaries. Expected: +4-6. 29. **[blocked: sx-tree MCP tools returning Yojson Type_error on every file op. Can't edit integration.sx to add before:init/after:init dispatch. Also 4 of the 6 tests fundamentally require stricter parser error-rejection (add - to currently succeeds as SX expression; on click blargh end accepts blargh as symbol), which is larger than a single cluster budget.] `hyperscript:before:init` / `:after:init` / `:parse-error` events** — 6 tests in `bootstrap` + `parser`. Fire DOM events at activation boundaries. Expected: +4-6.
30. **[done (+1)] `logAll` config** — 1 test. Global config that console.log's each command. Expected: +1. 30. **[done (+1)] `logAll` config** — 1 test. Global config that console.log's each command. Expected: +1.
### Bucket D: medium features (bigger commits, plan-first) ### Bucket D: medium features (bigger commits, plan-first)
31. **[blocked: Bucket-D plan-first scope, doesn't fit one cluster budget. All 18 tests are SKIP (untranslated) — generator has no `error("HS")` helper. Required pieces: (a) generator-side `eval-hs-error` helper + recognizer for `expect(await error("HS")).toBe("MSG")` blocks; (b) runtime helpers `hs-null-error!` / `hs-named-target` / `hs-named-target-list` raising `'<sel>' is null`; (c) compiler patches at every target-position `(query SEL)` emit to wrap in named-target carrying the original selector source — that's ~17 command emit paths (add, remove, hide, show, measure, settle, trigger, send, set, default, increment, decrement, put, toggle, transition, append, take); (d) function-call null-check at bare `(name)`, `hs-method-call`, and `host-get` chains, deriving the leftmost-uncalled-name `'x'` / `'x.y'` from the parse tree; (e) possessive-base null-check (`set x's y to true``'x' is null`). Each piece is straightforward in isolation but the cross-cutting compiler change touches every emit path and needs a coordinated design pass. Recommend a dedicated design doc + multi-commit worktree like buckets E36-E40.] runtime null-safety error reporting** — 18 tests in `runtimeErrors`. When accessing `.foo` on nil, emit a structured error with position info. One coordinated fix in the compiler emit paths for property access, function calls, set/put. Expected: +15-18. 31. **[pending] runtime null-safety error reporting** — 18 tests in `runtimeErrors`. When accessing `.foo` on nil, emit a structured error with position info. One coordinated fix in the compiler emit paths for property access, function calls, set/put. Expected: +15-18.
32. **[done (+7)] MutationObserver mock + `on mutation` dispatch** — 7 tests in `on`. Add MO mock to runner. Compile `on mutation [of attribute/childList/attribute-specific]`. Expected: +10-15. 32. **[pending] MutationObserver mock + `on mutation` dispatch** — 15 tests in `on`. Add MO mock to runner. Compile `on mutation [of attribute/childList/attribute-specific]`. Expected: +10-15.
33. **[done (+4) — partial, 1 test remains: `iterate cookies values work` needs `hs-for-each` to recognise host-array/proxy collections (currently `(list? collection)` returns false for the JS Proxy so the loop body never runs). Out of scope.] cookie API** — 5 tests in `expressions/cookies`. `document.cookie` mock in runner + `the cookies` + `set the xxx cookie` keywords. Expected: +5. 33. **[pending] cookie API** — 5 tests in `expressions/cookies`. `document.cookie` mock in runner + `the cookies` + `set the xxx cookie` keywords. Expected: +5.
34. **[done (+7) — partial, 1 test remains: `every` keyword multi-handler-execute test needs handler-queue semantics where `wait for X` doesn't block subsequent invocations of the same handler — current `hs-on-every` shares the same dom-listen plumbing as `hs-on` and queues events implicitly via JS event loop, so the third synthetic click waits for the prior handler's `wait for customEvent` to settle. Out of single-cluster scope.] event modifier DSL** — 8 tests in `on`. `elsewhere`, `every`, `first click`, count filters (`once / twice / 3 times`, ranges), `from elsewhere`. Expected: +6-8. 34. **[pending] event modifier DSL** — 8 tests in `on`. `elsewhere`, `every`, `first click`, count filters (`once / twice / 3 times`, ranges), `from elsewhere`. Expected: +6-8.
35. **[done (+3)] namespaced `def`** — 3 tests. `def ns.foo() ...` creates `ns.foo`. Expected: +3. 35. **[pending] namespaced `def`** — 3 tests. `def ns.foo() ...` creates `ns.foo`. Expected: +3.
### Bucket E: subsystems (DO NOT LOOP — human-driven) ### Bucket E: subsystems (DO NOT LOOP — human-driven)
@@ -177,39 +177,6 @@ Many tests are `SKIP (untranslated)` because `tests/playwright/generate-sx-tests
(Reverse chronological — newest at top.) (Reverse chronological — newest at top.)
### 2026-04-25 — Bucket F: in-expression filter semantics (+1)
- **67a5f137** — `HS: in-expression filter semantics (+1 test)`. `1 in [1, 2, 3]` was returning boolean `true` instead of the filtered list `(list 1)`. Root cause: `in?` compiled to `hs-contains?` which returns boolean for scalar items. Fix: (a) `runtime.sx` adds `hs-in?` returning filtered list for all cases, plus `hs-in-bool?` which wraps with `(not (hs-falsy? ...))` for boolean contexts; (b) `compiler.sx` changes `in?` clause to emit `(hs-in? collection item)` and adds new `in-bool?` clause emitting `(hs-in-bool? collection item)`; (c) `parser.sx` changes `is in` and `am in` comparison forms to produce `in-bool?` so those stay boolean. Suite hs-upstream-expressions/in: 8/9 → 9/9. Smoke 0-195: 173/195 unchanged.
### 2026-04-25 — cluster 22 window global fn fallback (+1)
- **d31565d5** — `HS cluster 22: simplify win-call emit + def→window + init-blocks test (+1)`. Two-part change building on 337c8265 (host-call-fn FFI + hs-win-call runtime). (a) `compiler.sx` removes the guard wrapper from bare-call and method-call `hs-win-call` emit paths — direct `(hs-win-call name (list args))` is sufficient since hs-win-call returns nil for unknown names; `def` compilation now also emits `(host-set! (host-global "window") name fn)` so every HS-defined function is reachable via window lookup. (b) `generate-sx-tests.py` fixes a quoting bug: `\"here\"` was being embedded as three SX nodes (`""` + symbol + `""`) instead of a single escaped-quote string; fixed with `\\\"` escaping. Hand-rolled deftest for `can refer to function in init blocks` now passes. Suite hs-upstream-core/regressions: 13/16 → 14/16. Smoke 0-195: 172/195 → 173/195.
### 2026-04-25 — cluster 11/33 followups: hide strategy + cookie clear (+2)
- **5ff2b706** — `HS: cluster 11/33 followups (+2 tests)`. Three orthogonal fixes that pick up tests now unblocked by earlier work. (a) `parser.sx` `parse-hide-cmd`/`parse-show-cmd`: added `on` to the keyword set that flips the implicit-`me` target. Previously `on click 1 hide on click 2 show` silently parsed as `(hs-hide! nil ...)` because `parse-expr` started consuming `on` and returned nil; now hide/show recognise a sibling feature and default to `me`. (b) `runtime.sx` `hs-method-call` fallback for non-built-in methods: SX-callables (lambdas) call via `apply`, JS-native functions (e.g. `cookies.clear`) dispatch via `(apply host-call (cons obj (cons method args)))` so the native receives the args list. (c) Generator `hs-cleanup!` body wrapped in `begin` (fn body evaluates only the last expr) and now resets `hs-set-default-hide-strategy! nil` + `hs-set-log-all! false` between tests — the prior `can set default to custom strategy` cluster-11 test had been leaking `_hs-default-hide-strategy` into the rest of the suite, breaking `hide element then show element retains original display`. New cluster-33 hand-roll for `basic clear cookie values work` exercises the method-call fallback. Suite hs-upstream-hide: 15/16 → 16/16. Suite hs-upstream-expressions/cookies: 3/5 → 4/5. Smoke 0-195 unchanged at 172/195.
### 2026-04-25 — cluster 35 namespaced def + script-tag globals (+3)
- **122053ed** — `HS: namespaced def + script-tag global functions (+3 tests)`. Two-part change: (a) `runtime.sx` `hs-method-call` gains a fallback for unknown methods — `(let ((fn-val (host-get obj method))) (if (callable? fn-val) (apply fn-val args) nil))`. This lets `utils.foo()` dispatch through `(host-get utils "foo")` when `utils` is an SX dict whose `foo` is an SX lambda. (b) Generator hand-rolls 3 deftests since the SX runtime has no `<script type='text/hyperscript'>` tag boot. For `is called synchronously` / `can call asynchronously`: `(eval-expr-cek (hs-to-sx (first (hs-parse (hs-tokenize "def foo() ... end")))))` registers the function in the global eval env (eval-expr-cek processes `(define foo (fn ...))` at top scope), then a click div is built via dom-set-attr + hs-boot-subtree!. For `functions can be namespaced`: define `utils` as a dict, register `__utils_foo` as a fresh-named global def, then `(host-set! utils "foo" __utils_foo)` populates the dict; click handler `call utils.foo()` compiles to `(hs-method-call utils "foo")` which now dispatches through the new runtime fallback. Skip-list cleared of the 3 def entries. Suite hs-upstream-def: 24/27 → 27/27. Smoke 0-195 unchanged at 172/195.
### 2026-04-25 — cluster 34 elsewhere / from-elsewhere modifier (+2)
- **3044a168** — `HS: elsewhere / from elsewhere modifier (+2 tests)`. Three-part change: (a) `parser.sx` `parse-on-feat` parses an optional `elsewhere` (or `from elsewhere`) modifier between event-name and source. The `from elsewhere` variant uses a one-token lookahead so plain `from #target` keeps parsing as a source expression. Emits `:elsewhere true` part. (b) `compiler.sx` `scan-on` threads `elsewhere?` (10th param) through every recursive call + new `:elsewhere` cond branch. The dispatch case becomes a 3-way `cond` over target: elsewhere → `(dom-body)` (listener attaches to body and bubble sees every click), source → from-source, default → `me`. The `compiled-body` build is wrapped with `(when (not (host-call me "contains" (host-get event "target"))) BODY)` so handlers fire only on outside-of-`me` clicks. (c) Generator drops `supports "elsewhere" modifier` and `supports "from elsewhere" modifier` from `SKIP_TEST_NAMES`. Suite hs-upstream-on: 48/70 → 50/70. Smoke 0-195 unchanged at 172/195.
### 2026-04-25 — cluster 34 count-filtered events + first modifier (+5 partial)
- **19c97989** — `HS: count-filtered events + first modifier (+5 tests)`. Three-part change: (a) `parser.sx` `parse-on-feat` accepts `first` keyword before event-name (sets `cnt-min/max=1`), then optionally parses a count expression after event-name: bare number = exact count, `N to M` = inclusive range, `N and on` = unbounded above. Number tokens coerced via `parse-number`. New parts entry `:count-filter {"min" N "max" M-or--1}`. (b) `compiler.sx` `scan-on` gains a 9th `count-filter-info` param threaded through every recursive call + a new `:count-filter` cond branch. The handler binding now wraps the `(fn (event) BODY)` in `(let ((__hs-count 0)) (fn (event) (begin (set! __hs-count (+ __hs-count 1)) (when COUNT-CHECK BODY))))` when count info is present. Each `on EVENT N ...` clause produces its own closure-captured counter, so `on click 1` / `on click 2` / `on click 3` fire on their respective Nth click (mix-ranges test). (c) Generator drops 5 entries from `SKIP_TEST_NAMES``can filter events based on count`/`...count range`/`...unbounded count range`/`can mix ranges`/`on first click fires only once`. Suite hs-upstream-on: 43/70 → 48/70. Smoke 0-195 unchanged at 172/195. Remaining cluster-34 work (`elsewhere`/`from elsewhere`/`every`-keyword multi-handler) is independent from count filters and would need a separate iteration.
### 2026-04-25 — cluster 29 hyperscript init events (+2 partial)
- **e01a3baa** — `HS: hyperscript:before:init / :after:init events (+2 tests)`. `integration.sx` `hs-activate!` now wraps the activation block in `(when (dom-dispatch el "hyperscript:before:init" nil) ...)``dom-dispatch` builds a CustomEvent with `bubbles:true`, the mock El's `cancelable` defaults to true, `dispatchEvent` returns `!ev.defaultPrevented`, so `when` skips the activate body if a listener called `preventDefault()`. After activation completes successfully it dispatches `hyperscript:after:init`. Generator (`tests/playwright/generate-sx-tests.py`) gains two hand-rolled deftests: `fires hyperscript:before:init and hyperscript:after:init` builds a wa container, attaches listeners that append to a captured `events` list, sets innerHTML to a div with `_=`, calls `hs-boot-subtree!`, asserts the events list. `hyperscript:before:init can cancel initialization` attaches a preventDefault listener and asserts `data-hyperscript-powered` is absent on the inner div after boot. Suite hs-upstream-core/bootstrap: 20/26 → 22/26. Smoke 0-195: 170 → 172. Remaining 4 cluster-29 tests (basic parse error messages, parse-error event, EOF newline, eval-API throws on first error) all need stricter parser error-rejection plus a parse-error collector — recommend bucket-D plan-first multi-commit, not a single iteration.
### 2026-04-25 — cluster 32 MutationObserver mock + on mutation dispatch (+7)
- **13e02542** — `HS: MutationObserver mock + on mutation dispatch (+7 tests)`. Five-part change: (a) `parser.sx` `parse-on-feat` now consumes `of <FILTER>` after `mutation` event-name. FILTER is one of `attributes`/`childList`/`characterData` (ident tokens) or one or more `@name` attr-tokens chained by `or`. Emits `:of-filter {"type" T "attrs" L?}` part. (b) `compiler.sx` `scan-on` threads new `of-filter-info` param; the dispatch case becomes a `cond` over `event-name` — for `"mutation"` it emits `(do on-call (hs-on-mutation-attach! target MODE ATTRS))` where ATTRS is `(cons 'list attr-list)` so the list survives compile→eval. (c) `runtime.sx` `hs-on-mutation-attach!` builds a config dict (`attributes`/`childList`/`characterData`/`subtree`/`attributeFilter`) matched to mode, constructs a real `MutationObserver(cb)`, calls `mo.observe(target, opts)`, and the cb dispatches a `"mutation"` event on target. (d) `tests/hs-run-filtered.js` replaces the no-op MO with `HsMutationObserver` (global registry, decodes SX-list `attributeFilter`); prototype hooks on `El.setAttribute/appendChild/removeChild/_setInnerHTML` fire matching observers synchronously, with `__hsMutationActive` re-entry guard so handlers that mutate the DOM don't infinite-loop. Per-test reset clears registry + flag. (e) `generate-sx-tests.py` drops 7 mutation entries from `SKIP_TEST_NAMES` and adds two body patterns: `evaluate(() => document.querySelector(SEL).setAttribute(N,V))``(dom-set-attr ...)`, and `evaluate(() => document.querySelector(SEL).appendChild(document.createElement(T)))``(dom-append … (dom-create-element …))`. Suite hs-upstream-on: 36/70 → 43/70. Smoke 0-195 unchanged at 170/195.
### 2026-04-25 — cluster 33 cookie API (partial +3)
- No `.sx` edits needed — `set cookies.foo to 'bar'` already compiles to `(dom-set-prop cookies "foo" "bar")` which becomes `(host-set! cookies "foo" "bar")` once the `dom` module is loaded, and `cookies.foo` becomes `(host-get cookies "foo")`. So a JS-only Proxy + Python generator change does the trick. Two parts: (a) `tests/hs-run-filtered.js` adds a per-test `__hsCookieStore` Map, a `globalThis.cookies` Proxy with `length`/`clear`/named-key get traps and a set trap that writes the store, and a `Object.defineProperty(document, 'cookie', …)` getter/setter that reads and writes the same store (so the upstream `length is 0` test's pre-clear loop over `document.cookie` works). Per-test reset clears the store. (b) `tests/playwright/generate-sx-tests.py` declares `(define cookies (host-global "cookies"))` in the test header and emits hand-rolled deftests for the three tractable tests (`basic set`, `update`, `length is 0`). Suite hs-upstream-expressions/cookies: 0/5 → 3/5. Smoke 0-195 unchanged at 170/195. Remaining `basic clear` and `iterate` tests need runtime.sx edits (hs-method-call fallback + hs-for-each host-array recognition) — out of scope for a JS-only iteration.
### 2026-04-25 — cluster 32 MutationObserver mock + on mutation dispatch (blocked)
- Two issues conspire: (1) `loops/hs` worktree has no pre-built sx-tree binary so MCP tools aren't loaded, and the block-sx-edit hook prevents raw `Edit`/`Read`/`Write` on `.sx` files. Built `hosts/ocaml/_build/default/bin/mcp_tree.exe` via `dune build` this iteration but tools don't surface mid-session. (2) Cluster scope is genuinely big: parser must learn `on mutation of <filter>` (currently drops body after `of` — verified via compile dump: `on mutation of attributes put "Mutated" into me``(hs-on me "mutation" (fn (event) nil))`), compiler needs `:of-filter` plumbing similar to intersection's `:having`, runtime needs `hs-on-mutation-attach!`, JS runner mock needs a real MutationObserver (currently no-op `class{observe(){}disconnect(){}}` at hs-run-filtered.js:348) plus `setAttribute`/`appendChild` instrumentation, and 7 entries removed from `SKIP_TEST_NAMES`. Recommended next step: dedicated worktree where sx-tree loads at session start, multi-commit shape (parser → compiler+attach → mock+runner → generator skip-list).
### 2026-04-25 — cluster 31 runtime null-safety error reporting (blocked)
- All 18 tests are `SKIP (untranslated)` — generator has no `error("HS")` helper at all. Inspected representative compile outputs: `add .foo to #doesntExist``(for-each ... (hs-query-all "#doesntExist"))` (silently no-ops on empty list, no error); `hide #doesntExist``(hs-hide! (hs-query-all "#doesntExist") "display")` (likewise); `put 'foo' into #doesntExist``(hs-set-inner-html! (hs-query-first "#doesntExist") "foo")` (passes nil through); `x()``(x)` (raises `Undefined symbol: x`, wrong format); `x.y.z()``(hs-method-call (host-get x "y") "z")`. Implementing this requires generator helper + 17 compiler emit-path patches + function-call/method-call/possessive-base null guards + new `hs-named-target`/`hs-named-target-list` runtime — too many surfaces for a single-iteration commit. Bucket D explicitly says "plan-first" — recommended path is a dedicated design doc and multi-commit worktree like E36-E40, not a loop iteration.
### 2026-04-24 — cluster 29 hyperscript:before:init / :after:init / :parse-error (blocked) ### 2026-04-24 — cluster 29 hyperscript:before:init / :after:init / :parse-error (blocked)
- **2b486976** — `HS-plan: mark cluster 29 blocked`. sx-tree MCP file ops returning `Yojson__Safe.Util.Type_error("Expected string, got null")` on every file-based call (sx_read_subtree, sx_find_all, sx_replace_by_pattern, sx_summarise, sx_pretty_print, sx_write_file). Only in-memory ops work (sx_eval, sx_build, sx_env). Without sx-tree I can't edit integration.sx to add before:init/after:init dispatch on hs-activate!. Investigated the 6 tests: 2 bootstrap (before/after init) need dispatchEvent wrapping activate; 4 parser tests require stricter parser error-rejection — `add - to` currently parses silently to `(set! nil (hs-add-to! (- 0 nil) nil))`, `on click blargh end on mouseenter also_bad` parses silently to `(do (hs-on me "click" (fn (event) blargh)) (hs-on me "mouseenter" (fn (event) also_bad)))`. Fundamental parser refactor is out of single-cluster budget regardless of sx-tree availability. - **2b486976** — `HS-plan: mark cluster 29 blocked`. sx-tree MCP file ops returning `Yojson__Safe.Util.Type_error("Expected string, got null")` on every file-based call (sx_read_subtree, sx_find_all, sx_replace_by_pattern, sx_summarise, sx_pretty_print, sx_write_file). Only in-memory ops work (sx_eval, sx_build, sx_env). Without sx-tree I can't edit integration.sx to add before:init/after:init dispatch on hs-activate!. Investigated the 6 tests: 2 bootstrap (before/after init) need dispatchEvent wrapping activate; 4 parser tests require stricter parser error-rejection — `add - to` currently parses silently to `(set! nil (hs-add-to! (- 0 nil) nil))`, `on click blargh end on mouseenter also_bad` parses silently to `(do (hs-on me "click" (fn (event) blargh)) (hs-on me "mouseenter" (fn (event) also_bad)))`. Fundamental parser refactor is out of single-cluster budget regardless of sx-tree availability.

124
plans/ruby-on-sx.md Normal file
View File

@@ -0,0 +1,124 @@
# Ruby-on-SX: fibers + blocks + open classes on delimited continuations
The headline showcase is **fibers** — Ruby's `Fiber.new { … Fiber.yield v … }` / `Fiber.resume` are textbook delimited continuations with sugar. MRI implements them by swapping C stacks; on SX they fall out of the existing `perform`/`cek-resume` machinery for free. Plus blocks/yield (lexical escape continuations, same shape as Smalltalk's non-local return), method_missing, and singleton classes.
End-state goal: Ruby 2.7-flavoured subset, Enumerable mixin, fibers + threads-via-fibers (no real OS threads), method_missing-driven DSLs, ~150 hand-written + classic programs.
## Scope decisions (defaults — override by editing before we spawn)
- **Syntax:** Ruby 2.7. No 3.x pattern matching, no rightward assignment, no endless methods. We pick 2.7 because it's the biggest semantic surface that still parses cleanly.
- **Conformance:** "Reads like Ruby, runs like Ruby." Slice of RubySpec (Core + Library subset), not full RubySpec.
- **Test corpus:** custom + curated RubySpec slice. Plus classic programs: fiber-based generator, internal DSL with method_missing, mixin-based Enumerable on a custom class.
- **Out of scope:** real threads, GIL, refinements, `binding_of_caller` from non-Ruby contexts, Encoding object beyond UTF-8/ASCII-8BIT, RubyVM::* introspection beyond bytecode-disassembly placeholder, IO subsystem beyond `puts`/`gets`/`File.read`.
- **Symbols:** SX symbols. Strings are mutable copies; symbols are interned.
## Ground rules
- **Scope:** only touch `lib/ruby/**` and `plans/ruby-on-sx.md`. Don't edit `spec/`, `hosts/`, `shared/`, or any other `lib/<lang>/**`. Ruby primitives go in `lib/ruby/runtime.sx`.
- **SX files:** use `sx-tree` MCP tools only.
- **Commits:** one feature per commit. Keep `## Progress log` updated and tick roadmap boxes.
## Architecture sketch
```
Ruby source
lib/ruby/tokenizer.sx — keywords, ops, %w[], %i[], heredocs (deferred), regex (deferred)
lib/ruby/parser.sx — AST: classes, modules, methods, blocks, calls
lib/ruby/transpile.sx — AST → SX AST (entry: rb-eval-ast)
lib/ruby/runtime.sx — class table, MOP, dispatch, fibers, primitives
```
Core mapping:
- **Object** = SX dict `{:class :ivars :singleton-class?}`. Instance variables live in `ivars` keyed by symbol.
- **Class** = SX dict `{:name :superclass :methods :class-methods :metaclass :includes :prepends}`. Class table is flat.
- **Method dispatch** = lookup walks ancestor chain (prepended → class → included modules → superclass → …). Falls back to `method_missing` with a `Symbol`+args.
- **Block** = lambda + escape continuation. `yield` invokes the block in current context. `return` from within a block invokes the enclosing-method's escape continuation.
- **Proc** = lambda without strict arity. `Proc.new` + `proc {}`.
- **Lambda** = lambda with strict arity + `return`-returns-from-lambda semantics.
- **Fiber** = pair of continuations (resume-k, yield-k) wrapped in a record. `Fiber.new { … }` builds it; `Fiber.resume` invokes the resume-k; `Fiber.yield` invokes the yield-k. Built directly on `perform`/`cek-resume`.
- **Module** = class without instance allocation. `include` puts it in the chain; `prepend` puts it earlier; `extend` puts it on the singleton.
- **Singleton class** = lazily allocated per-object class for `def obj.foo` definitions.
- **Symbol** = interned SX symbol. `:foo` reads as `(quote foo)` flavour.
## Roadmap
### Phase 1 — tokenizer + parser
- [ ] Tokenizer: keywords (`def end class module if unless while until do return yield begin rescue ensure case when then else elsif`), identifiers (lowercase = local/method, `@` = ivar, `@@` = cvar, `$` = global, uppercase = constant), numbers (int, float, `0x` `0o` `0b`, `_` separators), strings (`"…"` interpolation, `'…'` literal, `%w[a b c]`, `%i[a b c]`), symbols `:foo` `:"…"`, operators (`+ - * / % ** == != < > <= >= <=> === =~ !~ << >> & | ^ ~ ! && || and or not`), `:: . , ; ( ) [ ] { } -> => |`, comments `#`
- [ ] Parser: program is sequence of statements separated by newlines or `;`; method def `def name(args) … end`; class `class Foo < Bar … end`; module `module M … end`; block `do |a, b| … end` and `{ |a, b| … }`; call sugar (no parens), `obj.method`, `Mod::Const`; arg shapes (positional, default, splat `*args`, double-splat `**opts`, block `&blk`)
- [ ] If/while/case expressions (return values), `unless`/`until`, postfix modifiers
- [ ] Begin/rescue/ensure/retry, raise, raise with class+message
- [ ] Unit tests in `lib/ruby/tests/parse.sx`
### Phase 2 — object model + sequential eval
- [ ] Class table bootstrap: `BasicObject`, `Object`, `Kernel`, `Module`, `Class`, `Numeric`, `Integer`, `Float`, `String`, `Symbol`, `Array`, `Hash`, `Range`, `NilClass`, `TrueClass`, `FalseClass`, `Proc`, `Method`
- [ ] `rb-eval-ast`: literals, variables (local, ivar, cvar, gvar, constant), assignment (single and parallel `a, b = 1, 2`, splat receive), method call, message dispatch
- [ ] Method lookup walks ancestor chain; cache hit-class per `(class, selector)`
- [ ] `method_missing` fallback constructing args list
- [ ] `super` and `super(args)` — lookup in defining class's superclass
- [ ] Singleton class allocation on first `def obj.foo` or `class << obj`
- [ ] `nil`, `true`, `false` are singletons of their classes; tagged values aren't boxed
- [ ] Constant lookup (lexical-then-inheritance) with `Module.nesting`
- [ ] 60+ tests in `lib/ruby/tests/eval.sx`
### Phase 3 — blocks + procs + lambdas
- [ ] Method invocation captures escape continuation `^k` for `return`; binds it as block's escape
- [ ] `yield` invokes implicit block
- [ ] `block_given?`, `&blk` parameter, `&proc` arg unpacking
- [ ] `Proc.new`, `proc { }`, `lambda { }` (or `->(x) { x }`)
- [ ] Lambda strict arity + lambda-local `return` semantics
- [ ] Proc lax arity (`a, b, c` unpacks Array; missing args nil)
- [ ] `break`, `next`, `redo``break` is escape-from-loop-or-block; `next` is escape-from-block-iteration; `redo` re-runs current iteration
- [ ] 30+ tests in `lib/ruby/tests/blocks.sx`
### Phase 4 — fibers (THE SHOWCASE)
- [ ] `Fiber.new { |arg| … Fiber.yield v … }` allocates a fiber record with paired continuations
- [ ] `Fiber.resume(args…)` resumes the fiber, returning the value passed to `Fiber.yield`
- [ ] `Fiber.yield(v)` from inside the fiber suspends and returns control to the resumer
- [ ] `Fiber.current` from inside the fiber
- [ ] `Fiber#alive?`, `Fiber#raise` (deferred)
- [ ] `Fiber.transfer` — symmetric coroutines (resume from any side)
- [ ] Classic programs in `lib/ruby/tests/programs/`:
- [ ] `generator.rb` — pull-style infinite enumerator built on fibers
- [ ] `producer-consumer.rb` — bounded buffer with `Fiber.transfer`
- [ ] `tree-walk.rb` — recursive tree walker that yields each node, driven by `Fiber.resume`
- [ ] `lib/ruby/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md`
### Phase 5 — modules + mixins + metaprogramming
- [ ] `include M` — appends M's methods after class methods in chain
- [ ] `prepend M` — prepends M before class methods
- [ ] `extend M` — adds M to singleton class
- [ ] `Module#ancestors`, `Module#included_modules`
- [ ] `define_method`, `class_eval`, `instance_eval`, `module_eval`
- [ ] `respond_to?`, `respond_to_missing?`, `method_missing`
- [ ] `Object#send`, `Object#public_send`, `Object#__send__`
- [ ] `Module#method_added`, `singleton_method_added` hooks
- [ ] Hooks: `included`, `extended`, `inherited`, `prepended`
- [ ] Internal-DSL classic program: `lib/ruby/tests/programs/dsl.rb`
### Phase 6 — stdlib drive
- [ ] `Enumerable` mixin: `each` (abstract), `map`, `select`/`filter`, `reject`, `reduce`/`inject`, `each_with_index`, `each_with_object`, `take`, `drop`, `take_while`, `drop_while`, `find`/`detect`, `find_index`, `any?`, `all?`, `none?`, `one?`, `count`, `min`, `max`, `min_by`, `max_by`, `sort`, `sort_by`, `group_by`, `partition`, `chunk`, `each_cons`, `each_slice`, `flat_map`, `lazy`
- [ ] `Comparable` mixin: `<=>`, `<`, `<=`, `>`, `>=`, `==`, `between?`, `clamp`
- [ ] `Array`: indexing, slicing, `push`/`pop`/`shift`/`unshift`, `concat`, `flatten`, `compact`, `uniq`, `sort`, `reverse`, `zip`, `dig`, `pack`/`unpack` (deferred)
- [ ] `Hash`: `[]`, `[]=`, `delete`, `merge`, `each_pair`, `keys`, `values`, `to_a`, `dig`, `fetch`, default values, default proc
- [ ] `Range`: `each`, `step`, `cover?`, `include?`, `size`, `min`, `max`
- [ ] `String`: indexing, slicing, `split`, `gsub` (string-arg version, regex deferred), `sub`, `upcase`, `downcase`, `strip`, `chomp`, `chars`, `bytes`, `to_i`, `to_f`, `to_sym`, `*`, `+`, `<<`, format with `%`
- [ ] `Integer`: `times`, `upto`, `downto`, `step`, `digits`, `gcd`, `lcm`
- [ ] Drive corpus to 200+ green
## Progress log
_Newest first._
- _(none yet)_
## Blockers
- _(none yet)_

116
plans/smalltalk-on-sx.md Normal file
View File

@@ -0,0 +1,116 @@
# Smalltalk-on-SX: blocks with non-local return on delimited continuations
The headline showcase is **blocks** — Smalltalk's closures with non-local return (`^expr` aborts the enclosing *method*, not the block). Every other Smalltalk on top of a host VM (RSqueak on PyPy, GemStone on C, Maxine on Java) reinvents non-local return on whatever stack discipline the host gives them. On SX it's a one-liner: a block holds a captured continuation; `^` just invokes it. Message-passing OO falls out cheaply on top of the existing component / dispatch machinery.
End-state goal: ANSI-ish Smalltalk-80 subset, SUnit working, ~200 hand-written tests + a vendored slice of the Pharo kernel tests, classic corpus (eight queens, quicksort, mandelbrot, Conway's Life).
## Scope decisions (defaults — override by editing before we spawn)
- **Syntax:** Pharo / Squeak chunk format (`!` separators, `Object subclass: #Foo …`). No fileIn/fileOut images — text source only.
- **Conformance:** ANSI X3J20 *as a target*, not bug-for-bug Squeak. "Reads like Smalltalk, runs like Smalltalk."
- **Test corpus:** SUnit ported to SX-Smalltalk + custom programs + a curated slice of Pharo `Kernel-Tests` / `Collections-Tests`.
- **Image:** out of scope. Source-only. No `become:` between sessions, no snapshotting.
- **Reflection:** `class`, `respondsTo:`, `perform:`, `doesNotUnderstand:` in. `become:` (object-identity swap) **in** — it's a good CEK exercise. Method modification at runtime in.
- **GUI / Morphic / threads:** out entirely.
## Ground rules
- **Scope:** only touch `lib/smalltalk/**` and `plans/smalltalk-on-sx.md`. Don't edit `spec/`, `hosts/`, `shared/`, or any other `lib/<lang>/**`. Smalltalk primitives go in `lib/smalltalk/runtime.sx`.
- **SX files:** use `sx-tree` MCP tools only.
- **Commits:** one feature per commit. Keep `## Progress log` updated and tick roadmap boxes.
## Architecture sketch
```
Smalltalk source
lib/smalltalk/tokenizer.sx — selectors, keywords, literals, $c, #sym, #(…), $'…'
lib/smalltalk/parser.sx — AST: classes, methods, blocks, cascades, sends
lib/smalltalk/transpile.sx — AST → SX AST (entry: smalltalk-eval-ast)
lib/smalltalk/runtime.sx — class table, MOP, dispatch, primitives
```
Core mapping:
- **Class** = SX dict `{:name :superclass :ivars :methods :class-methods :metaclass}`. Class table is a flat dict keyed by class name.
- **Object** = SX dict `{:class :ivars}``ivars` keyed by symbol. Tagged ints / floats / strings / symbols are not boxed; their class is looked up by SX type.
- **Method** = SX lambda closing over a `self` binding + temps. Body wrapped in a delimited continuation so `^` can escape.
- **Message send** = `(st-send receiver selector args)` — does class-table lookup, walks superclass chain, falls back to `doesNotUnderstand:` with a `Message` object.
- **Block** `[:x | … ^v … ]` = lambda + captured `^k` (the method-return continuation). Invoking `^` calls `k`; outer block invocation past method return raises `BlockContext>>cannotReturn:`.
- **Cascade** `r m1; m2; m3` = `(let ((tmp r)) (st-send tmp 'm1 ()) (st-send tmp 'm2 ()) (st-send tmp 'm3 ()))`.
- **`ifTrue:ifFalse:` / `whileTrue:`** = ordinary block sends; the runtime intrinsifies them in the JIT path so they compile to native branches (Tier 1 of bytecode expansion already covers this pattern).
- **`become:`** = swap two object identities everywhere — in SX this is a heap walk, but we restrict to `oneWayBecome:` (cheap: rewrite class field) by default.
## Roadmap
### Phase 1 — tokenizer + parser
- [ ] Tokenizer: identifiers, keywords (`foo:`), binary selectors (`+`, `==`, `,`, `->`, `~=` etc.), numbers (radix `16r1F`, scaled `1.5s2`), strings `'…''…'`, characters `$c`, symbols `#foo` `#'foo bar'` `#+`, byte arrays `#[1 2 3]`, literal arrays `#(1 #foo 'x')`, comments `"…"`
- [ ] Parser: chunk format (`! !` separators), class definitions (`Object subclass: #X instanceVariableNames: '…' classVariableNames: '…' …`), method definitions (`extend: #Foo with: 'bar ^self'`), pragmas `<primitive: 1>`, blocks `[:a :b | | t1 t2 | …]`, cascades, message precedence (unary > binary > keyword)
- [ ] Unit tests in `lib/smalltalk/tests/parse.sx`
### Phase 2 — object model + sequential eval
- [ ] Class table + bootstrap: `Object`, `Behavior`, `Class`, `Metaclass`, `UndefinedObject`, `Boolean`/`True`/`False`, `Number`/`Integer`/`Float`, `String`, `Symbol`, `Array`, `Block`
- [ ] `smalltalk-eval-ast`: literals, variable reference, assignment, message send, cascade, sequence, return
- [ ] Method lookup: walk class → superclass; cache hit-class on `(class, selector)`
- [ ] `doesNotUnderstand:` fallback constructing `Message` object
- [ ] `super` send (lookup starts at superclass of *defining* class, not receiver class)
- [ ] 30+ tests in `lib/smalltalk/tests/eval.sx`
### Phase 3 — blocks + non-local return (THE SHOWCASE)
- [ ] Method invocation captures a `^k` (the return continuation) and binds it as the block's escape
- [ ] `^expr` from inside a block invokes that captured `^k`
- [ ] `BlockContext>>value`, `value:`, `value:value:`, …, `valueWithArguments:`
- [ ] `whileTrue:` / `whileTrue` / `whileFalse:` / `whileFalse` as ordinary block sends — runtime intrinsifies the loop in the bytecode JIT
- [ ] `ifTrue:` / `ifFalse:` / `ifTrue:ifFalse:` as block sends, similarly intrinsified
- [ ] Escape past returned-from method raises `BlockContext>>cannotReturn:`
- [ ] Classic programs in `lib/smalltalk/tests/programs/`:
- [ ] `eight-queens.st`
- [ ] `quicksort.st`
- [ ] `mandelbrot.st`
- [ ] `life.st` (Conway's Life, glider gun)
- [ ] `fibonacci.st` (recursive + memoised)
- [ ] `lib/smalltalk/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md`
### Phase 4 — reflection + MOP
- [ ] `Object>>class`, `class>>name`, `class>>superclass`, `class>>methodDict`, `class>>selectors`
- [ ] `Object>>perform:` / `perform:with:` / `perform:withArguments:`
- [ ] `Object>>respondsTo:`, `Object>>isKindOf:`, `Object>>isMemberOf:`
- [ ] `Behavior>>compile:` — runtime method addition
- [ ] `Object>>becomeForward:` (one-way become; rewrites the class field of `aReceiver`)
- [ ] Exceptions: `Exception`, `Error`, `signal`, `signal:`, `on:do:`, `ensure:`, `ifCurtailed:` — built on top of SX `handler-bind`/`raise`
### Phase 5 — collections + numeric tower
- [ ] `SequenceableCollection`/`OrderedCollection`/`Array`/`String`/`Symbol`
- [ ] `HashedCollection`/`Set`/`Dictionary`/`IdentityDictionary`
- [ ] `Stream` hierarchy: `ReadStream`/`WriteStream`/`ReadWriteStream`
- [ ] `Number` tower: `SmallInteger`/`LargePositiveInteger`/`Float`/`Fraction`
- [ ] `String>>format:`, `printOn:` for everything
### Phase 6 — SUnit + corpus to 200+
- [ ] Port SUnit (TestCase, TestSuite, TestResult) — written in SX-Smalltalk, runs in itself
- [ ] Vendor a slice of Pharo `Kernel-Tests` and `Collections-Tests`
- [ ] Drive the scoreboard up: aim for 200+ green tests
- [ ] Stretch: ANSI Smalltalk validator subset
### Phase 7 — speed (optional)
- [ ] Method-dictionary inline caching (already in CEK as a primitive; just wire selector cache)
- [ ] Block intrinsification beyond `whileTrue:` / `ifTrue:`
- [ ] Compare against GNU Smalltalk on the corpus
## Progress log
_Newest first. Agent appends on every commit._
- _(none yet)_
## Blockers
_Shared-file issues that need someone else to fix. Minimal repro only._
- _(none yet)_

128
plans/tcl-on-sx.md Normal file
View File

@@ -0,0 +1,128 @@
# Tcl-on-SX: uplevel/upvar = stack-walking delcc, everything-is-a-string
The headline showcase is **uplevel/upvar** — Tcl's superpower for defining your own control structures. `uplevel` evaluates a script in the *caller's* stack frame; `upvar` aliases a variable in the caller. On a normal language host this requires deep VM cooperation; on SX it falls out of the env-chain made first-class via captured continuations. Plus the *Dodekalogue* (12 rules), command-substitution everywhere, and "everything is a string" homoiconicity.
End-state goal: Tcl 8.6-flavoured subset, the Dodekalogue parser, namespaces, `try`/`catch`/`return -code`, `coroutine` (built on fibers), classic programs that show off uplevel-driven DSLs, ~150 hand-written tests.
## Scope decisions (defaults — override by editing before we spawn)
- **Syntax:** Tcl 8.6 surface. The 12-rule Dodekalogue. Brace-quoted scripts deferred-evaluate; double-quoted ones substitute.
- **Conformance:** "Reads like Tcl, runs like Tcl." Slice of Tcl's own test suite, not full TCT.
- **Test corpus:** custom + curated `tcl-tests/` slice. Plus classic programs: define-your-own `for-each-line`, expression-language compiler-in-Tcl, fiber-based event loop.
- **Out of scope:** Tk, sockets beyond a stub, threads (mapped to `coroutine` only), `package require` of binary loadables, `dde`/`registry` Windows shims, full `clock format` locale support.
- **Channels:** `puts` and `gets` on `stdout`/`stdin`/`stderr`; `open` on regular files; no async I/O beyond what `coroutine` gives.
## Ground rules
- **Scope:** only touch `lib/tcl/**` and `plans/tcl-on-sx.md`. Don't edit `spec/`, `hosts/`, `shared/`, or any other `lib/<lang>/**`. Tcl primitives go in `lib/tcl/runtime.sx`.
- **SX files:** use `sx-tree` MCP tools only.
- **Commits:** one feature per commit. Keep `## Progress log` updated and tick roadmap boxes.
## Architecture sketch
```
Tcl source
lib/tcl/tokenizer.sx — the Dodekalogue: words, [..], ${..}, "..", {..}, ;, \n, \, #
lib/tcl/parser.sx — list-of-words AST (script = list of commands; command = list of words)
lib/tcl/transpile.sx — AST → SX AST (entry: tcl-eval-script)
lib/tcl/runtime.sx — env stack, command table, uplevel/upvar, coroutines, BIFs
```
Core mapping:
- **Value** = string. Internally we cache a "shimmer" representation (list, dict, integer, double) for performance, but every value can be re-stringified.
- **Variable** = entry in current frame's env. Frames form a stack; level-0 is the global frame.
- **Command** = entry in command table; first word of any list dispatches into it. User-defined via `proc`. Built-ins are SX functions registered in the table.
- **Frame** = `{:locals (dict) :level n :parent frame}`. Each `proc` call pushes a frame; commands run in current frame.
- **`uplevel #N script`** = walk frame chain to absolute level N (or relative if no `#`); evaluate script in that frame's env.
- **`upvar [#N] varname localname`** = bind `localname` in the current frame as an alias to `varname` in the level-N frame (env-chain delegate).
- **`return -code N`** = control flow as integers: 0=ok, 1=error, 2=return, 3=break, 4=continue. `catch` traps any non-zero; `try` adds named handlers.
- **`coroutine`** = fiber on top of `perform`/`cek-resume`. `yield`/`yieldto` suspend; calling the coroutine command resumes.
- **List / dict** = list-shaped string ("element1 element2 …") with a cached parsed form. Modifications dirty the string cache.
## Roadmap
### Phase 1 — tokenizer + parser (the Dodekalogue)
- [x] Tokenizer applying the 12 rules:
1. Commands separated by `;` or newlines
2. Words separated by whitespace within a command
3. Double-quoted words: `\` escapes + `[…]` + `${…}` + `$var` substitution
4. Brace-quoted words: literal, no substitution; brace count must balance
5. Argument expansion: `{*}list`
6. Command substitution: `[script]` evaluates script, takes its return value
7. Variable substitution: `$name`, `${name}`, `$arr(idx)`, `$arr($i)`
8. Backslash substitution: `\n`, `\t`, `\\`, `\xNN`, `\uNNNN`, `\<newline>` continues
9. Comments: `#` only at the start of a command
10. Order of substitution is left-to-right, single-pass
11. Substitutions don't recurse — substituted text is not re-parsed
12. The result of any substitution is the value, not a new script
- [x] Parser: script = list of commands; command = list of words; word = literal string + list of substitutions
- [x] Unit tests in `lib/tcl/tests/parse.sx`
### Phase 2 — sequential eval + core commands
- [ ] `tcl-eval-script`: walk command list, dispatch each first-word into command table
- [ ] Core commands: `set`, `unset`, `incr`, `append`, `lappend`, `puts`, `gets`, `expr`, `if`, `while`, `for`, `foreach`, `switch`, `break`, `continue`, `return`, `error`, `eval`, `subst`, `format`, `scan`
- [ ] `expr` is its own mini-language — operator precedence, function calls (`sin`, `sqrt`, `pow`, `abs`, `int`, `double`), variable substitution, command substitution
- [ ] String commands: `string length`, `string index`, `string range`, `string compare`, `string match`, `string toupper`, `string tolower`, `string trim`, `string map`, `string repeat`, `string first`, `string last`, `string is`, `string cat`
- [ ] List commands: `list`, `lindex`, `lrange`, `llength`, `lreverse`, `lsearch`, `lsort`, `lsort -integer/-real/-dictionary`, `lreplace`, `linsert`, `concat`, `split`, `join`
- [ ] Dict commands: `dict create`, `dict get`, `dict set`, `dict unset`, `dict exists`, `dict keys`, `dict values`, `dict size`, `dict for`, `dict update`, `dict merge`
- [ ] 60+ tests in `lib/tcl/tests/eval.sx`
### Phase 3 — proc + uplevel + upvar (THE SHOWCASE)
- [ ] `proc name args body` — register user-defined command; args supports defaults `{name default}` and rest `args`
- [ ] Frame stack: each proc call pushes a frame with locals dict; pop on return
- [ ] `uplevel ?level? script` — evaluate `script` in level-N frame's env; default level is 1 (caller). `#0` is global, `#1` is relative-1
- [ ] `upvar ?level? otherVar localVar ?…?` — alias localVar to a variable in level-N frame; reads/writes go through the alias
- [ ] `info level`, `info level N`, `info frame`, `info vars`, `info locals`, `info globals`, `info commands`, `info procs`, `info args`, `info body`
- [ ] `global var ?…?` — alias to global frame (sugar for `upvar #0 var var`)
- [ ] `variable name ?value?` — namespace-scoped global
- [ ] Classic programs in `lib/tcl/tests/programs/`:
- [ ] `for-each-line.tcl` — define your own loop construct using `uplevel`
- [ ] `assert.tcl` — assertion macro that reports caller's line
- [ ] `with-temp-var.tcl` — scoped variable rebind via `upvar`
- [ ] `lib/tcl/conformance.sh` + runner, `scoreboard.json` + `scoreboard.md`
### Phase 4 — control flow + error handling
- [ ] `return -code (ok|error|return|break|continue|N) -errorinfo … -errorcode … -level N value`
- [ ] `catch script ?resultVar? ?optionsVar?` — runs script, returns code; sets resultVar to return value/message; optionsVar to the dict
- [ ] `try script ?on code var body ...? ?trap pattern var body...? ?finally body?`
- [ ] `throw type message`
- [ ] `error message ?info? ?code?`
- [ ] Stack-trace with `errorInfo` / `errorCode`
- [ ] 30+ tests in `lib/tcl/tests/error.sx`
### Phase 5 — namespaces + ensembles
- [ ] `namespace eval ns body`, `namespace current`, `namespace which`, `namespace import`, `namespace export`, `namespace forget`, `namespace delete`
- [ ] Qualified names: `::ns::cmd`, `::ns::var`
- [ ] Ensembles: `namespace ensemble create -map { sub1 cmd1 sub2 cmd2 }`
- [ ] `namespace path` for resolution chain
- [ ] `proc` and `variable` work inside namespaces
### Phase 6 — coroutines + drive corpus
- [ ] `coroutine name cmd ?args…?` — start a coroutine; future calls to `name` resume it
- [ ] `yield ?value?` — suspend, return value to resumer
- [ ] `yieldto cmd ?args…?` — symmetric transfer
- [ ] `coroutine` semantics built on fibers (same delcc primitive as Ruby fibers)
- [ ] Classic programs: `event-loop.tcl` — cooperative scheduler with multiple coroutines
- [ ] System: `clock seconds`, `clock format`, `clock scan` (subset)
- [ ] File I/O: `open`, `close`, `read`, `gets`, `puts -nonewline`, `flush`, `eof`, `seek`, `tell`
- [ ] Drive corpus to 150+ green
- [ ] Idiom corpus — `lib/tcl/tests/idioms.sx` covering classic Welch/Jones idioms
## Progress log
_Newest first._
- 2026-04-25: Phase 1 parser — `lib/tcl/parser.sx`, word-simple?/word-literal helpers, 67 tests green, commit 6ee05259
- 2026-04-25: Phase 1 tokenizer (Dodekalogue) — `lib/tcl/tokenizer.sx`, 52 tests green, commit 666e29d5
## Blockers
- _(none yet)_

View File

@@ -30,7 +30,7 @@ fi
if [ "$CLEAN" = "1" ]; then if [ "$CLEAN" = "1" ]; then
cd "$(dirname "$0")/.." cd "$(dirname "$0")/.."
for lang in lua prolog forth erlang haskell js hs; do for lang in lua prolog forth erlang haskell js hs smalltalk common-lisp apl ruby tcl; do
wt="$WORKTREE_BASE/$lang" wt="$WORKTREE_BASE/$lang"
if [ -d "$wt" ]; then if [ -d "$wt" ]; then
git worktree remove --force "$wt" 2>/dev/null || rm -rf "$wt" git worktree remove --force "$wt" 2>/dev/null || rm -rf "$wt"
@@ -39,5 +39,5 @@ if [ "$CLEAN" = "1" ]; then
done done
git worktree prune git worktree prune
echo "Worktree branches (loops/<lang>) are preserved. Delete manually if desired:" echo "Worktree branches (loops/<lang>) are preserved. Delete manually if desired:"
echo " git branch -D loops/lua loops/prolog loops/forth loops/erlang loops/haskell loops/js loops/hs" echo " git branch -D loops/lua loops/prolog loops/forth loops/erlang loops/haskell loops/js loops/hs loops/smalltalk loops/common-lisp loops/apl loops/ruby loops/tcl"
fi fi

View File

@@ -1,5 +1,5 @@
#!/usr/bin/env bash #!/usr/bin/env bash
# Spawn 7 claude sessions in tmux, one per language loop. # Spawn 12 claude sessions in tmux, one per language loop.
# Each runs in its own git worktree rooted at /root/rose-ash-loops/<lang>, # Each runs in its own git worktree rooted at /root/rose-ash-loops/<lang>,
# on branch loops/<lang>. No two loops share a working tree, so there's # on branch loops/<lang>. No two loops share a working tree, so there's
# zero risk of file collisions between languages. # zero risk of file collisions between languages.
@@ -9,7 +9,7 @@
# #
# After the script prints done: # After the script prints done:
# tmux a -t sx-loops # tmux a -t sx-loops
# Ctrl-B + <window-number> to switch (0=lua ... 6=hs) # Ctrl-B + <window-number> to switch (0=lua ... 11=tcl)
# Ctrl-B + d to detach (loops keep running, SSH-safe) # Ctrl-B + d to detach (loops keep running, SSH-safe)
# #
# Stop: ./scripts/sx-loops-down.sh # Stop: ./scripts/sx-loops-down.sh
@@ -38,8 +38,13 @@ declare -A BRIEFING=(
[haskell]=haskell-loop.md [haskell]=haskell-loop.md
[js]=loop.md [js]=loop.md
[hs]=hs-loop.md [hs]=hs-loop.md
[smalltalk]=smalltalk-loop.md
[common-lisp]=common-lisp-loop.md
[apl]=apl-loop.md
[ruby]=ruby-loop.md
[tcl]=tcl-loop.md
) )
ORDER=(lua prolog forth erlang haskell js hs) ORDER=(lua prolog forth erlang haskell js hs smalltalk common-lisp apl ruby tcl)
mkdir -p "$WORKTREE_BASE" mkdir -p "$WORKTREE_BASE"
@@ -60,13 +65,13 @@ for lang in "${ORDER[@]}"; do
fi fi
done done
# Create tmux session with 7 windows, each cwd in its worktree # Create tmux session with one window per language, each cwd in its worktree
tmux new-session -d -s "$SESSION" -n "${ORDER[0]}" -c "$WORKTREE_BASE/${ORDER[0]}" tmux new-session -d -s "$SESSION" -n "${ORDER[0]}" -c "$WORKTREE_BASE/${ORDER[0]}"
for lang in "${ORDER[@]:1}"; do for lang in "${ORDER[@]:1}"; do
tmux new-window -t "$SESSION" -n "$lang" -c "$WORKTREE_BASE/$lang" tmux new-window -t "$SESSION" -n "$lang" -c "$WORKTREE_BASE/$lang"
done done
echo "Starting 7 claude sessions..." echo "Starting ${#ORDER[@]} claude sessions..."
for lang in "${ORDER[@]}"; do for lang in "${ORDER[@]}"; do
tmux send-keys -t "$SESSION:$lang" "claude" C-m tmux send-keys -t "$SESSION:$lang" "claude" C-m
done done
@@ -89,10 +94,10 @@ for lang in "${ORDER[@]}"; do
done done
echo "" echo ""
echo "Done. 7 loops started in tmux session '$SESSION', each in its own worktree." echo "Done. ${#ORDER[@]} loops started in tmux session '$SESSION', each in its own worktree."
echo "" echo ""
echo " Attach: tmux a -t $SESSION" echo " Attach: tmux a -t $SESSION"
echo " Switch: Ctrl-B <0..6> (0=lua 1=prolog 2=forth 3=erlang 4=haskell 5=js 6=hs)" echo " Switch: Ctrl-B <0..11> (0=lua 1=prolog 2=forth 3=erlang 4=haskell 5=js 6=hs 7=smalltalk 8=common-lisp 9=apl 10=ruby 11=tcl)"
echo " List: Ctrl-B w" echo " List: Ctrl-B w"
echo " Detach: Ctrl-B d" echo " Detach: Ctrl-B d"
echo " Stop: ./scripts/sx-loops-down.sh" echo " Stop: ./scripts/sx-loops-down.sh"

View File

@@ -164,16 +164,13 @@
every? every?
catch-info catch-info
finally-info finally-info
having-info having-info)
of-filter-info
count-filter-info
elsewhere?)
(cond (cond
((<= (len items) 1) ((<= (len items) 1)
(let (let
((body (if (> (len items) 0) (first items) nil))) ((body (if (> (len items) 0) (first items) nil)))
(let (let
((target (cond (elsewhere? (list (quote dom-body))) (source (hs-to-sx source)) (true (quote me))))) ((target (if source (hs-to-sx source) (quote me))))
(let (let
((event-refs (if (and (list? body) (= (first body) (quote do))) (filter (fn (x) (and (list? x) (= (first x) (quote ref)))) (rest body)) (list)))) ((event-refs (if (and (list? body) (= (first body) (quote do))) (filter (fn (x) (and (list? x) (= (first x) (quote ref)))) (rest body)) (list))))
(let (let
@@ -181,51 +178,30 @@
(let (let
((raw-compiled (hs-to-sx stripped-body))) ((raw-compiled (hs-to-sx stripped-body)))
(let (let
((compiled-body (let ((base (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))) (if elsewhere? (list (quote when) (list (quote not) (list (quote host-call) (quote me) "contains" (list (quote host-get) (quote event) "target"))) base) base)))) ((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))))
(let (let
((handler (let ((uses-the-result? (fn (expr) (cond ((= expr (quote the-result)) true) ((list? expr) (some (fn (x) (uses-the-result? x)) expr)) (true false))))) (let ((base-handler (list (quote fn) (list (quote event)) (if (uses-the-result? wrapped-body) (list (quote let) (list (list (quote the-result) nil)) wrapped-body) wrapped-body)))) (if count-filter-info (let ((mn (get count-filter-info "min")) (mx (get count-filter-info "max"))) (list (quote let) (list (list (quote __hs-count) 0)) (list (quote fn) (list (quote event)) (list (quote begin) (list (quote set!) (quote __hs-count) (list (quote +) (quote __hs-count) 1)) (list (quote when) (if (= mx -1) (list (quote >=) (quote __hs-count) mn) (list (quote and) (list (quote >=) (quote __hs-count) mn) (list (quote <=) (quote __hs-count) mx))) (nth base-handler 2)))))) base-handler))))) ((handler (let ((uses-the-result? (fn (expr) (cond ((= expr (quote the-result)) true) ((list? expr) (some (fn (x) (uses-the-result? x)) expr)) (true false))))) (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)))))
(let (let
((on-call (if every? (list (quote hs-on-every) target event-name handler) (list (quote hs-on) target event-name handler)))) ((on-call (if every? (list (quote hs-on-every) target event-name handler) (list (quote hs-on) target event-name handler))))
(cond (if
((= event-name "mutation") (= event-name "intersection")
(list
(quote do)
on-call
(list (list
(quote do) (quote hs-on-intersection-attach!)
on-call target
(list (if
(quote hs-on-mutation-attach!) having-info
target (get having-info "margin")
(if nil)
of-filter-info (if
(get of-filter-info "type") having-info
"any") (get having-info "threshold")
(if nil)))
of-filter-info on-call)))))))))))
(let
((a (get of-filter-info "attrs")))
(if
a
(cons (quote list) a)
nil))
nil))))
((= event-name "intersection")
(list
(quote do)
on-call
(list
(quote
hs-on-intersection-attach!)
target
(if
having-info
(get having-info "margin")
nil)
(if
having-info
(get having-info "threshold")
nil))))
(true on-call))))))))))))
((= (first items) :from) ((= (first items) :from)
(scan-on (scan-on
(rest (rest items)) (rest (rest items))
@@ -234,10 +210,7 @@
every? every?
catch-info catch-info
finally-info finally-info
having-info having-info))
of-filter-info
count-filter-info
elsewhere?))
((= (first items) :filter) ((= (first items) :filter)
(scan-on (scan-on
(rest (rest items)) (rest (rest items))
@@ -246,10 +219,7 @@
every? every?
catch-info catch-info
finally-info finally-info
having-info having-info))
of-filter-info
count-filter-info
elsewhere?))
((= (first items) :every) ((= (first items) :every)
(scan-on (scan-on
(rest (rest items)) (rest (rest items))
@@ -258,10 +228,7 @@
true true
catch-info catch-info
finally-info finally-info
having-info having-info))
of-filter-info
count-filter-info
elsewhere?))
((= (first items) :catch) ((= (first items) :catch)
(scan-on (scan-on
(rest (rest items)) (rest (rest items))
@@ -270,10 +237,7 @@
every? every?
(nth items 1) (nth items 1)
finally-info finally-info
having-info having-info))
of-filter-info
count-filter-info
elsewhere?))
((= (first items) :finally) ((= (first items) :finally)
(scan-on (scan-on
(rest (rest items)) (rest (rest items))
@@ -282,10 +246,7 @@
every? every?
catch-info catch-info
(nth items 1) (nth items 1)
having-info having-info))
of-filter-info
count-filter-info
elsewhere?))
((= (first items) :having) ((= (first items) :having)
(scan-on (scan-on
(rest (rest items)) (rest (rest items))
@@ -294,45 +255,6 @@
every? every?
catch-info catch-info
finally-info finally-info
(nth items 1)
of-filter-info
count-filter-info
elsewhere?))
((= (first items) :of-filter)
(scan-on
(rest (rest items))
source
filter
every?
catch-info
finally-info
having-info
(nth items 1)
count-filter-info
elsewhere?))
((= (first items) :count-filter)
(scan-on
(rest (rest items))
source
filter
every?
catch-info
finally-info
having-info
of-filter-info
(nth items 1)
elsewhere?))
((= (first items) :elsewhere)
(scan-on
(rest (rest items))
source
filter
every?
catch-info
finally-info
having-info
of-filter-info
count-filter-info
(nth items 1))) (nth items 1)))
(true (true
(scan-on (scan-on
@@ -342,11 +264,8 @@
every? every?
catch-info catch-info
finally-info finally-info
having-info having-info)))))
of-filter-info (scan-on (rest parts) nil nil false nil nil nil)))))
count-filter-info
elsewhere?)))))
(scan-on (rest parts) nil nil false nil nil nil nil nil false)))))
(define (define
emit-send emit-send
(fn (fn
@@ -1058,17 +977,9 @@
(cons (cons
(quote hs-method-call) (quote hs-method-call)
(cons obj (cons method args)))) (cons obj (cons method args))))
(if (cons
(and (quote hs-method-call)
(list? dot-node) (cons (hs-to-sx dot-node) args)))))
(= (first dot-node) (quote ref)))
(list
(quote hs-win-call)
(nth dot-node 1)
(cons (quote list) args))
(cons
(quote hs-method-call)
(cons (hs-to-sx dot-node) args))))))
((= head (quote string-postfix)) ((= head (quote string-postfix))
(list (quote str) (hs-to-sx (nth ast 1)) (nth ast 2))) (list (quote str) (hs-to-sx (nth ast 1)) (nth ast 2)))
((= head (quote block-literal)) ((= head (quote block-literal))
@@ -1238,12 +1149,7 @@
(list (quote hs-coerce) (hs-to-sx (nth ast 1)) (nth ast 2))) (list (quote hs-coerce) (hs-to-sx (nth ast 1)) (nth ast 2)))
((= head (quote in?)) ((= head (quote in?))
(list (list
(quote hs-in?) (quote hs-contains?)
(hs-to-sx (nth ast 2))
(hs-to-sx (nth ast 1))))
((= head (quote in-bool?))
(list
(quote hs-in-bool?)
(hs-to-sx (nth ast 2)) (hs-to-sx (nth ast 2))
(hs-to-sx (nth ast 1)))) (hs-to-sx (nth ast 1))))
((= head (quote of)) ((= head (quote of))
@@ -1727,19 +1633,7 @@
body))) body)))
(nth compiled (- (len compiled) 1)) (nth compiled (- (len compiled) 1))
(rest (reverse compiled))) (rest (reverse compiled)))
(let (cons (quote do) compiled)))))
((defs (filter (fn (c) (and (list? c) (> (len c) 0) (= (first c) (quote define)))) compiled))
(non-defs
(filter
(fn
(c)
(not
(and
(list? c)
(> (len c) 0)
(= (first c) (quote define)))))
compiled)))
(cons (quote do) (append defs non-defs)))))))
((= head (quote wait)) (list (quote hs-wait) (nth ast 1))) ((= head (quote wait)) (list (quote hs-wait) (nth ast 1)))
((= head (quote wait-for)) (emit-wait-for ast)) ((= head (quote wait-for)) (emit-wait-for ast))
((= head (quote log)) ((= head (quote log))
@@ -1847,13 +1741,7 @@
(make-symbol raw-fn) (make-symbol raw-fn)
(hs-to-sx raw-fn))) (hs-to-sx raw-fn)))
(args (map hs-to-sx (rest (rest ast))))) (args (map hs-to-sx (rest (rest ast)))))
(if (cons fn-expr args)))
(and (list? raw-fn) (= (first raw-fn) (quote ref)))
(list
(quote hs-win-call)
(nth raw-fn 1)
(cons (quote list) args))
(cons fn-expr args))))
((= head (quote return)) ((= head (quote return))
(let (let
((val (nth ast 1))) ((val (nth ast 1)))
@@ -2041,39 +1929,26 @@
(quote define) (quote define)
(make-symbol (nth ast 1)) (make-symbol (nth ast 1))
(list (list
(quote let) (quote fn)
params
(list (list
(quote guard)
(list (list
(quote _hs-def-val) (quote _e)
(list (list
(quote fn) (quote true)
params
(list (list
(quote guard) (quote if)
(list (list
(quote _e) (quote and)
(list (quote list?) (quote _e))
(list (list
(quote true) (quote =)
(list (list (quote first) (quote _e))
(quote if) "hs-return"))
(list (list (quote nth) (quote _e) 1)
(quote and) (list (quote raise) (quote _e)))))
(list (quote list?) (quote _e)) body)))))
(list
(quote =)
(list (quote first) (quote _e))
"hs-return"))
(list (quote nth) (quote _e) 1)
(list (quote raise) (quote _e)))))
body))))
(list
(quote do)
(list
(quote host-set!)
(list (quote host-global) "window")
(nth ast 1)
(quote _hs-def-val))
(quote _hs-def-val))))))
((= head (quote behavior)) (emit-behavior ast)) ((= head (quote behavior)) (emit-behavior ast))
((= head (quote sx-eval)) ((= head (quote sx-eval))
(let (let
@@ -2123,7 +1998,7 @@
(hs-to-sx (nth ast 1))))) (hs-to-sx (nth ast 1)))))
((= head (quote in?)) ((= head (quote in?))
(list (list
(quote hs-in?) (quote hs-contains?)
(hs-to-sx (nth ast 2)) (hs-to-sx (nth ast 2))
(hs-to-sx (nth ast 1)))) (hs-to-sx (nth ast 1))))
((= head (quote type-check)) ((= head (quote type-check))

View File

@@ -80,14 +80,11 @@
((src (dom-get-attr el "_")) (prev (dom-get-data el "hs-script"))) ((src (dom-get-attr el "_")) (prev (dom-get-data el "hs-script")))
(when (when
(and src (not (= src prev))) (and src (not (= src prev)))
(when (hs-log-event! "hyperscript:init")
(dom-dispatch el "hyperscript:before:init" nil) (dom-set-data el "hs-script" src)
(hs-log-event! "hyperscript:init") (dom-set-data el "hs-active" true)
(dom-set-data el "hs-script" src) (dom-set-attr el "data-hyperscript-powered" "true")
(dom-set-data el "hs-active" true) (let ((handler (hs-handler src))) (handler el))))))
(dom-set-attr el "data-hyperscript-powered" "true")
(let ((handler (hs-handler src))) (handler el))
(dom-dispatch el "hyperscript:after:init" nil))))))
;; ── Boot: scan entire document ────────────────────────────────── ;; ── Boot: scan entire document ──────────────────────────────────
;; Called once at page load. Finds all elements with _ attribute, ;; Called once at page load. Finds all elements with _ attribute,

View File

@@ -495,8 +495,7 @@
(quote and) (quote and)
(list (quote >=) left lo) (list (quote >=) left lo)
(list (quote <=) left hi))))) (list (quote <=) left hi)))))
((match-kw "in") ((match-kw "in") (list (quote in?) left (parse-expr)))
(list (quote in-bool?) left (parse-expr)))
((match-kw "really") ((match-kw "really")
(do (do
(match-kw "equal") (match-kw "equal")
@@ -572,8 +571,7 @@
(let (let
((right (parse-expr))) ((right (parse-expr)))
(list (quote not) (list (quote =) left right)))))) (list (quote not) (list (quote =) left right))))))
((match-kw "in") ((match-kw "in") (list (quote in?) left (parse-expr)))
(list (quote in-bool?) left (parse-expr)))
((match-kw "empty") (list (quote empty?) left)) ((match-kw "empty") (list (quote empty?) left))
((match-kw "between") ((match-kw "between")
(let (let
@@ -1557,7 +1555,7 @@
(fn (fn
() ()
(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") (= (tp-val) "on"))) (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))) (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"))) ((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
@@ -1568,7 +1566,7 @@
(fn (fn
() ()
(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") (= (tp-val) "on"))) (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))) (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"))) ((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
@@ -2603,77 +2601,63 @@
(fn (fn
() ()
(let (let
((every? (match-kw "every")) (first? (match-kw "first"))) ((every? (match-kw "every")))
(let (let
((event-name (parse-compound-event-name))) ((event-name (parse-compound-event-name)))
(let (let
((count-filter (let ((mn nil) (mx nil)) (when first? (do (set! mn 1) (set! mx 1))) (when (= (tp-type) "number") (let ((n (parse-number (tp-val)))) (do (adv!) (set! mn n) (cond ((match-kw "to") (cond ((= (tp-type) "number") (let ((mv (parse-number (tp-val)))) (do (adv!) (set! mx mv)))) (true (set! mx n)))) ((match-kw "and") (cond ((match-kw "on") (set! mx -1)) (true (set! mx n)))) (true (set! mx n)))))) (if mn (dict "min" mn "max" mx) nil)))) ((flt (if (= (tp-type) "bracket-open") (do (adv!) (let ((f (parse-expr))) (if (= (tp-type) "bracket-close") (adv!) nil) f)) nil)))
(let (let
((of-filter (when (and (= event-name "mutation") (match-kw "of")) (cond ((and (= (tp-type) "ident") (or (= (tp-val) "attributes") (= (tp-val) "childList") (= (tp-val) "characterData"))) (let ((nm (tp-val))) (do (adv!) (dict "type" nm)))) ((= (tp-type) "attr") (let ((attrs (list (tp-val)))) (do (adv!) (define collect-or! (fn () (when (match-kw "or") (cond ((= (tp-type) "attr") (do (set! attrs (append attrs (list (tp-val)))) (adv!) (collect-or!))) (true (set! p (- p 1))))))) (collect-or!) (dict "type" "attrs" "attrs" attrs)))) (true nil))))) ((source (if (match-kw "from") (parse-expr) nil)))
(let (let
((flt (if (= (tp-type) "bracket-open") (do (adv!) (let ((f (parse-expr))) (if (= (tp-type) "bracket-close") (adv!) nil) f)) nil))) ((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
((elsewhere? (cond ((match-kw "elsewhere") true) ((and (= (tp-type) "keyword") (= (tp-val) "from") (let ((nxt (if (< (+ p 1) tok-len) (nth tokens (+ p 1)) nil))) (and nxt (= (get nxt "type") "keyword") (= (get nxt "value") "elsewhere")))) (do (adv!) (adv!) true)) (true false))) ((having (if (or h-margin h-threshold) (dict "margin" h-margin "threshold" h-threshold) nil)))
(source (if (match-kw "from") (parse-expr) nil)))
(let (let
((h-margin nil) (h-threshold nil)) ((body (parse-cmd-list)))
(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
((having (if (or h-margin h-threshold) (dict "margin" h-margin "threshold" h-threshold) nil))) ((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
((body (parse-cmd-list))) ((parts (list (quote on) event-name)))
(let (let
((catch-clause (if (match-kw "catch") (let ((var (let ((v (tp-val))) (adv!) v)) (handler (parse-cmd-list))) (list var handler)) nil)) ((parts (if every? (append parts (list :every true)) parts)))
(finally-clause
(if
(match-kw "finally")
(parse-cmd-list)
nil)))
(match-kw "end")
(let (let
((parts (list (quote on) event-name))) ((parts (if flt (append parts (list :filter flt)) parts)))
(let (let
((parts (if every? (append parts (list :every true)) parts))) ((parts (if source (append parts (list :from source)) parts)))
(let (let
((parts (if flt (append parts (list :filter flt)) parts))) ((parts (if having (append parts (list :having having)) parts)))
(let (let
((parts (if elsewhere? (append parts (list :elsewhere true)) parts))) ((parts (if catch-clause (append parts (list :catch catch-clause)) parts)))
(let (let
((parts (if source (append parts (list :from source)) parts))) ((parts (if finally-clause (append parts (list :finally finally-clause)) parts)))
(let (let
((parts (if count-filter (append parts (list :count-filter count-filter)) parts))) ((parts (append parts (list body))))
(let parts))))))))))))))))))
((parts (if of-filter (append parts (list :of-filter of-filter)) parts)))
(let
((parts (if having (append parts (list :having having)) 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

View File

@@ -82,36 +82,14 @@
observer))))) observer)))))
;; Wait for CSS transitions/animations to settle on an element. ;; Wait for CSS transitions/animations to settle on an element.
(define (define hs-init (fn (thunk) (thunk)))
hs-on-mutation-attach!
(fn
(target mode attr-list)
(let
((cfg-attributes (or (= mode "any") (= mode "attributes") (= mode "attrs")))
(cfg-childList (or (= mode "any") (= mode "childList")))
(cfg-characterData (or (= mode "any") (= mode "characterData"))))
(let
((opts (dict "attributes" cfg-attributes "childList" cfg-childList "characterData" cfg-characterData "subtree" true)))
(when
(and (= mode "attrs") attr-list)
(dict-set! opts "attributeFilter" attr-list))
(let
((cb (fn (records observer) (dom-dispatch target "mutation" (dict "records" records)))))
(let
((observer (host-new "MutationObserver" cb)))
(host-call observer "observe" target opts)
observer))))))
;; ── Class manipulation ────────────────────────────────────────── ;; ── Class manipulation ──────────────────────────────────────────
;; Toggle a single class on an element. ;; Toggle a single class on an element.
(define hs-init (fn (thunk) (thunk)))
;; Toggle between two classes — exactly one is active at a time.
(define hs-wait (fn (ms) (perform (list (quote io-sleep) ms)))) (define hs-wait (fn (ms) (perform (list (quote io-sleep) ms))))
;; Take a class from siblings — add to target, remove from others. ;; Toggle between two classes — exactly one is active at a time.
;; (hs-take! target cls) — like radio button class behavior
(begin (begin
(define (define
hs-wait-for hs-wait-for
@@ -124,20 +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)))))
;; Take a class from siblings — add to target, remove from others.
;; (hs-take! target cls) — like radio button class behavior
(define hs-settle (fn (target) (perform (list (quote io-settle) target))))
;; ── 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-settle (fn (target) (perform (list (quote io-settle) target))))
;; ── Navigation / traversal ──────────────────────────────────────
;; Navigate to a URL.
(define (define
hs-toggle-class! hs-toggle-class!
(fn (target cls) (host-call (host-get target "classList") "toggle" cls))) (fn (target cls) (host-call (host-get target "classList") "toggle" cls)))
;; Find next sibling matching a selector (or any sibling). ;; ── Navigation / traversal ──────────────────────────────────────
;; Navigate to a URL.
(define (define
hs-toggle-between! hs-toggle-between!
(fn (fn
@@ -147,7 +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)))))
;; Find previous sibling matching a selector. ;; Find next sibling matching a selector (or any sibling).
(define (define
hs-toggle-style! hs-toggle-style!
(fn (fn
@@ -171,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 "")))))))
;; First element matching selector within a scope. ;; Find previous sibling matching a selector.
(define (define
hs-toggle-style-between! hs-toggle-style-between!
(fn (fn
@@ -183,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)))))
;; Last element matching selector. ;; First element matching selector within a scope.
(define (define
hs-toggle-style-cycle! hs-toggle-style-cycle!
(fn (fn
@@ -204,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/last within a specific scope. ;; Last element matching selector.
(define (define
hs-take! hs-take!
(fn (fn
@@ -244,6 +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 ""))))))))
;; First/last within a specific scope.
(begin (begin
(define (define
hs-element? hs-element?
@@ -355,9 +335,6 @@
(dom-insert-adjacent-html target "beforeend" value) (dom-insert-adjacent-html target "beforeend" value)
(hs-boot-subtree! target))))))))) (hs-boot-subtree! target)))))))))
;; ── Iteration ───────────────────────────────────────────────────
;; Repeat a thunk N times.
(define (define
hs-add-to! hs-add-to!
(fn (fn
@@ -370,7 +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)))))
;; Repeat forever (until break — relies on exception/continuation). ;; ── Iteration ───────────────────────────────────────────────────
;; Repeat a thunk N times.
(define (define
hs-remove-from! hs-remove-from!
(fn (fn
@@ -380,10 +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))))
;; ── Fetch ─────────────────────────────────────────────────────── ;; Repeat forever (until break — relies on exception/continuation).
;; Fetch a URL, parse response according to format.
;; (hs-fetch url format) — format is "json" | "text" | "html"
(define (define
hs-splice-at! hs-splice-at!
(fn (fn
@@ -407,10 +383,10 @@
(host-call target "splice" i 1)))) (host-call target "splice" i 1))))
target)))) target))))
;; ── Type coercion ─────────────────────────────────────────────── ;; ── Fetch ───────────────────────────────────────────────────────
;; Coerce a value to a type by name. ;; Fetch a URL, parse response according to format.
;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc. ;; (hs-fetch url format) — format is "json" | "text" | "html"
(define (define
hs-index hs-index
(fn (fn
@@ -422,10 +398,10 @@
((string? obj) (nth obj key)) ((string? obj) (nth obj key))
(true (host-get obj key))))) (true (host-get obj key)))))
;; ── Object creation ───────────────────────────────────────────── ;; ── Type coercion ───────────────────────────────────────────────
;; Make a new object of a given type. ;; Coerce a value to a type by name.
;; (hs-make type-name) — creates empty object/collection ;; (hs-coerce value type-name) — type-name is "Int", "Float", "String", etc.
(define (define
hs-put-at! hs-put-at!
(fn (fn
@@ -447,11 +423,10 @@
((= pos "start") (host-call target "unshift" value))) ((= pos "start") (host-call target "unshift" value)))
target))))))) target)))))))
;; ── Behavior installation ─────────────────────────────────────── ;; ── Object creation ─────────────────────────────────────────────
;; Install a behavior on an element. ;; Make a new object of a given type.
;; A behavior is a function that takes (me ...params) and sets up features. ;; (hs-make type-name) — creates empty object/collection
;; (hs-install behavior-fn me ...args)
(define (define
hs-dict-without hs-dict-without
(fn (fn
@@ -472,27 +447,27 @@
(host-call (host-global "Reflect") "deleteProperty" out key) (host-call (host-global "Reflect") "deleteProperty" out key)
out))))) out)))))
;; ── Measurement ───────────────────────────────────────────────── ;; ── Behavior installation ───────────────────────────────────────
;; Measure an element's bounding rect, store as local variables. ;; Install a behavior on an element.
;; Returns a dict with x, y, width, height, top, left, right, bottom. ;; A behavior is a function that takes (me ...params) and sets up features.
;; (hs-install behavior-fn me ...args)
(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))))
;; ── Measurement ─────────────────────────────────────────────────
;; Measure an element's bounding rect, store as local variables.
;; Returns a dict with x, y, width, height, top, left, right, bottom.
(define hs-navigate! (fn (url) (perform (list (quote io-navigate) url))))
;; Return the current text selection as a string. In the browser this is ;; Return the current text selection as a string. In the browser this is
;; `window.getSelection().toString()`. In the mock test runner, a test ;; `window.getSelection().toString()`. In the mock test runner, a test
;; setup stashes the desired selection text at `window.__test_selection` ;; setup stashes the desired selection text at `window.__test_selection`
;; and the fallback path returns that so tests can assert on the result. ;; and the fallback path returns that so tests can assert on the result.
(define hs-navigate! (fn (url) (perform (list (quote io-navigate) url))))
;; ── Transition ──────────────────────────────────────────────────
;; Transition a CSS property to a value, optionally with duration.
;; (hs-transition target prop value duration)
(define (define
hs-ask hs-ask
(fn (fn
@@ -501,6 +476,11 @@
((w (host-global "window"))) ((w (host-global "window")))
(if w (host-call w "prompt" msg) nil)))) (if w (host-call w "prompt" msg) nil))))
;; ── Transition ──────────────────────────────────────────────────
;; Transition a CSS property to a value, optionally with duration.
;; (hs-transition target prop value duration)
(define (define
hs-answer hs-answer
(fn (fn
@@ -654,10 +634,6 @@
hs-query-all hs-query-all
(fn (sel) (host-call (dom-body) "querySelectorAll" sel))) (fn (sel) (host-call (dom-body) "querySelectorAll" sel)))
(define (define
hs-query-all-in hs-query-all-in
(fn (fn
@@ -667,21 +643,25 @@
(hs-query-all sel) (hs-query-all sel)
(host-call target "querySelectorAll" sel)))) (host-call target "querySelectorAll" sel))))
(define (define
hs-list-set hs-list-set
(fn (fn
(lst idx val) (lst idx val)
(append (take lst idx) (cons val (drop lst (+ idx 1)))))) (append (take lst idx) (cons val (drop lst (+ idx 1))))))
;; ── Sandbox/test runtime additions ──────────────────────────────
;; Property access — dot notation and .length
(define (define
hs-to-number hs-to-number
(fn (v) (if (number? v) v (or (parse-number (str v)) 0)))) (fn (v) (if (number? v) v (or (parse-number (str v)) 0))))
;; DOM query stub — sandbox returns empty list ;; ── Sandbox/test runtime additions ──────────────────────────────
;; Property access — dot notation and .length
(define (define
hs-query-first hs-query-first
(fn (sel) (host-call (host-global "document") "querySelector" sel))) (fn (sel) (host-call (host-global "document") "querySelector" sel)))
;; Method dispatch — obj.method(args) ;; DOM query stub — sandbox returns empty list
(define (define
hs-query-last hs-query-last
(fn (fn
@@ -689,11 +669,11 @@
(let (let
((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))))
;; Method dispatch — obj.method(args)
(define hs-first (fn (scope sel) (dom-query-all scope sel)))
;; ── 0.9.90 features ───────────────────────────────────────────── ;; ── 0.9.90 features ─────────────────────────────────────────────
;; beep! — debug logging, returns value unchanged ;; beep! — debug logging, returns value unchanged
(define hs-first (fn (scope sel) (dom-query-all scope sel)))
;; Property-based is — check obj.key truthiness
(define (define
hs-last hs-last
(fn (fn
@@ -701,7 +681,7 @@
(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))))
;; Array slicing (inclusive both ends) ;; Property-based is — check obj.key truthiness
(define (define
hs-repeat-times hs-repeat-times
(fn (fn
@@ -719,7 +699,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)))
;; Collection: sorted by ;; Array slicing (inclusive both ends)
(define (define
hs-repeat-forever hs-repeat-forever
(fn (fn
@@ -735,7 +715,7 @@
((= signal "hs-continue") (do-forever)) ((= signal "hs-continue") (do-forever))
(true (do-forever)))))) (true (do-forever))))))
(do-forever))) (do-forever)))
;; Collection: sorted by descending ;; Collection: sorted by
(define (define
hs-repeat-while hs-repeat-while
(fn (fn
@@ -748,7 +728,7 @@
((= 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)))))))
;; Collection: split by ;; Collection: sorted by descending
(define (define
hs-repeat-until hs-repeat-until
(fn (fn
@@ -760,7 +740,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)))))))
;; Collection: joined by ;; Collection: split by
(define (define
hs-for-each hs-for-each
(fn (fn
@@ -780,7 +760,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))))
;; Collection: joined by
(begin (begin
(define (define
hs-append hs-append
@@ -1535,25 +1515,6 @@
(hs-contains? (rest collection) item)))))) (hs-contains? (rest collection) item))))))
(true false)))) (true false))))
(define
hs-in?
(fn
(collection item)
(cond
((nil? collection) (list))
((list? collection)
(cond
((nil? item) (list))
((list? item)
(filter (fn (x) (hs-contains? collection x)) item))
((hs-contains? collection item) (list item))
(true (list))))
(true (list)))))
(define
hs-in-bool?
(fn (collection item) (not (hs-falsy? (hs-in? collection item)))))
(define (define
hs-is hs-is
(fn (fn
@@ -2134,13 +2095,7 @@
-1 -1
(if (= (first lst) item) i (idx-loop (rest lst) (+ i 1)))))) (if (= (first lst) item) i (idx-loop (rest lst) (+ i 1))))))
(idx-loop obj 0))) (idx-loop obj 0)))
(true (true nil))))
(let
((fn-val (host-get obj method)))
(cond
((and fn-val (callable? fn-val)) (apply fn-val args))
(fn-val (apply host-call (cons obj (cons method args))))
(true nil)))))))
(define hs-beep (fn (v) v)) (define hs-beep (fn (v) v))
@@ -2519,9 +2474,3 @@
((nil? b) false) ((nil? b) false)
((= a b) true) ((= a b) true)
(true (hs-dom-is-ancestor? a (dom-parent b)))))) (true (hs-dom-is-ancestor? a (dom-parent b))))))
(define
hs-win-call
(fn
(fn-name args)
(let ((fn (host-global fn-name))) (if fn (host-call-fn fn args) nil))))

View File

@@ -8,7 +8,6 @@
;; references them (e.g. `window.tmp`) can resolve through the host. ;; references them (e.g. `window.tmp`) can resolve through the host.
(define window (host-global "window")) (define window (host-global "window"))
(define document (host-global "document")) (define document (host-global "document"))
(define cookies (host-global "cookies"))
(define hs-test-el (define hs-test-el
(fn (tag hs-src) (fn (tag hs-src)
@@ -20,11 +19,7 @@
(define hs-cleanup! (define hs-cleanup!
(fn () (fn ()
(begin (dom-set-inner-html (dom-body) "")))
(dom-set-inner-html (dom-body) "")
;; Reset global runtime state that prior tests may have set.
(hs-set-default-hide-strategy! nil)
(hs-set-log-all! false))))
;; Evaluate a hyperscript expression and return either the expression ;; Evaluate a hyperscript expression and return either the expression
;; value or `it` (whichever is non-nil). Multi-statement scripts that ;; value or `it` (whichever is non-nil). Multi-statement scripts that
@@ -93,6 +88,27 @@
(raise _e)))) (raise _e))))
(handler me-val)))))) (handler me-val))))))
;; Evaluate a hyperscript expression, catch the first error raised, and
;; return its message string. Used by runtimeErrors tests.
;; Returns nil if no error is raised (test would then fail equality).
(define eval-hs-error
(fn (src)
(let ((sx (hs-to-sx (hs-compile src))))
(let ((handler (eval-expr-cek
(list (quote fn) (list (quote me))
(list (quote let) (list (list (quote it) nil) (list (quote event) nil)) sx)))))
(guard
(_e
(true
(if
(string? _e)
_e
(if
(and (list? _e) (= (first _e) "hs-return"))
nil
(str _e)))))
(begin (handler nil) nil))))))
;; ── add (19 tests) ── ;; ── add (19 tests) ──
(defsuite "hs-upstream-add" (defsuite "hs-upstream-add"
(deftest "can add a value to a set" (deftest "can add a value to a set"
@@ -1400,17 +1416,7 @@
(hs-activate! _el-div) (hs-activate! _el-div)
)) ))
(deftest "fires hyperscript:before:init and hyperscript:after:init" (deftest "fires hyperscript:before:init and hyperscript:after:init"
(hs-cleanup!) (error "SKIP (untranslated): fires hyperscript:before:init and hyperscript:after:init"))
(let ((wa (dom-create-element "div"))
(events (list)))
(dom-listen wa "hyperscript:before:init"
(fn (e) (set! events (append events (list "before:init")))))
(dom-listen wa "hyperscript:after:init"
(fn (e) (set! events (append events (list "after:init")))))
(dom-set-inner-html wa "<div _=\"on click add .foo\"></div>")
(hs-boot-subtree! wa)
(assert= events (list "before:init" "after:init")))
)
(deftest "hyperscript can have more than one action" (deftest "hyperscript can have more than one action"
(hs-cleanup!) (hs-cleanup!)
(let ((_el-bar (dom-create-element "div")) (_el-div (dom-create-element "div"))) (let ((_el-bar (dom-create-element "div")) (_el-div (dom-create-element "div")))
@@ -1426,15 +1432,7 @@
(assert (dom-has-class? (dom-query "div:nth-of-type(2)") "blah")) (assert (dom-has-class? (dom-query "div:nth-of-type(2)") "blah"))
)) ))
(deftest "hyperscript:before:init can cancel initialization" (deftest "hyperscript:before:init can cancel initialization"
(hs-cleanup!) (error "SKIP (untranslated): hyperscript:before:init can cancel initialization"))
(let ((wa (dom-create-element "div")))
(dom-listen wa "hyperscript:before:init"
(fn (e) (host-call e "preventDefault")))
(dom-set-inner-html wa "<div _=\"on click add .foo\"></div>")
(hs-boot-subtree! wa)
(let ((d (host-call wa "querySelector" "div")))
(assert= (host-call d "hasAttribute" "data-hyperscript-powered") false)))
)
(deftest "logAll config logs events to console" (deftest "logAll config logs events to console"
(hs-cleanup!) (hs-cleanup!)
(hs-clear-log-captured!) (hs-clear-log-captured!)
@@ -2011,12 +2009,13 @@
(error "SKIP (skip-list): can pick detail fields out by name")) (error "SKIP (skip-list): can pick detail fields out by name"))
(deftest "can refer to function in init blocks" (deftest "can refer to function in init blocks"
(hs-cleanup!) (hs-cleanup!)
(guard (_e (true nil)) (eval-expr-cek (hs-to-sx (hs-compile "init call foo() end def foo() put \"here\" into #d1's innerHTML end"))))
(guard (_e (true nil)) (eval-expr-cek (hs-to-sx (hs-compile "init call foo() end def foo() put \\\"here\\\" into #d1's innerHTML end"))))
(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-append (dom-body) _el-d1) (dom-append (dom-body) _el-d1)
(guard (_e (true nil)) (eval-expr-cek (hs-to-sx (hs-compile "init call foo() end def foo() put \"here\" into #d1's innerHTML end")))) (assert= (dom-text-content (dom-query-by-id "d1")) "here")
(assert= (dom-text-content (dom-query-by-id "d1")) "here")) ))
)
(deftest "can remove by clicks elsewhere" (deftest "can remove by clicks elsewhere"
(hs-cleanup!) (hs-cleanup!)
(let ((_el-target (dom-create-element "div")) (_el-other (dom-create-element "div"))) (let ((_el-target (dom-create-element "div")) (_el-other (dom-create-element "div")))
@@ -2175,41 +2174,75 @@
;; ── core/runtimeErrors (18 tests) ── ;; ── core/runtimeErrors (18 tests) ──
(defsuite "hs-upstream-core/runtimeErrors" (defsuite "hs-upstream-core/runtimeErrors"
(deftest "reports basic function invocation null errors properly" (deftest "reports basic function invocation null errors properly"
(error "SKIP (untranslated): reports basic function invocation null errors properly")) (assert= (eval-hs-error "x()") "'x' is null")
(assert= (eval-hs-error "x.y()") "'x' is null")
(assert= (eval-hs-error "x.y.z()") "'x.y' is null")
)
(deftest "reports basic function invocation null errors properly w/ of" (deftest "reports basic function invocation null errors properly w/ of"
(error "SKIP (untranslated): reports basic function invocation null errors properly w/ of")) (assert= (eval-hs-error "z() of y of x") "'z' is null")
)
(deftest "reports basic function invocation null errors properly w/ possessives" (deftest "reports basic function invocation null errors properly w/ possessives"
(error "SKIP (untranslated): reports basic function invocation null errors properly w/ possessives")) (assert= (eval-hs-error "x's y()") "'x' is null")
(assert= (eval-hs-error "x's y's z()") "'x's y' is null")
)
(deftest "reports null errors on add command properly" (deftest "reports null errors on add command properly"
(error "SKIP (untranslated): reports null errors on add command properly")) (assert= (eval-hs-error "add .foo to #doesntExist") "'#doesntExist' is null")
(assert= (eval-hs-error "add @foo to #doesntExist") "'#doesntExist' is null")
(assert= (eval-hs-error "add {display:none} to #doesntExist") "'#doesntExist' is null")
)
(deftest "reports null errors on decrement command properly" (deftest "reports null errors on decrement command properly"
(error "SKIP (untranslated): reports null errors on decrement command properly")) (assert= (eval-hs-error "decrement #doesntExist's innerHTML") "'#doesntExist' is null")
)
(deftest "reports null errors on default command properly" (deftest "reports null errors on default command properly"
(error "SKIP (untranslated): reports null errors on default command properly")) (assert= (eval-hs-error "default #doesntExist's innerHTML to 'foo'") "'#doesntExist' is null")
)
(deftest "reports null errors on hide command properly" (deftest "reports null errors on hide command properly"
(error "SKIP (untranslated): reports null errors on hide command properly")) (assert= (eval-hs-error "hide #doesntExist") "'#doesntExist' is null")
)
(deftest "reports null errors on increment command properly" (deftest "reports null errors on increment command properly"
(error "SKIP (untranslated): reports null errors on increment command properly")) (assert= (eval-hs-error "increment #doesntExist's innerHTML") "'#doesntExist' is null")
)
(deftest "reports null errors on measure command properly" (deftest "reports null errors on measure command properly"
(error "SKIP (untranslated): reports null errors on measure command properly")) (assert= (eval-hs-error "measure #doesntExist") "'#doesntExist' is null")
)
(deftest "reports null errors on put command properly" (deftest "reports null errors on put command properly"
(error "SKIP (untranslated): reports null errors on put command properly")) (assert= (eval-hs-error "put 'foo' into #doesntExist") "'#doesntExist' is null")
(assert= (eval-hs-error "put 'foo' into #doesntExist's innerHTML") "'#doesntExist' is null")
(assert= (eval-hs-error "put 'foo' into #doesntExist.innerHTML") "'#doesntExist' is null")
(assert= (eval-hs-error "put 'foo' before #doesntExist") "'#doesntExist' is null")
(assert= (eval-hs-error "put 'foo' after #doesntExist") "'#doesntExist' is null")
(assert= (eval-hs-error "put 'foo' at the start of #doesntExist") "'#doesntExist' is null")
(assert= (eval-hs-error "put 'foo' at the end of #doesntExist") "'#doesntExist' is null")
)
(deftest "reports null errors on remove command properly" (deftest "reports null errors on remove command properly"
(error "SKIP (untranslated): reports null errors on remove command properly")) (assert= (eval-hs-error "remove .foo from #doesntExist") "'#doesntExist' is null")
(assert= (eval-hs-error "remove @foo from #doesntExist") "'#doesntExist' is null")
(assert= (eval-hs-error "remove #doesntExist from #doesntExist") "'#doesntExist' is null")
)
(deftest "reports null errors on send command properly" (deftest "reports null errors on send command properly"
(error "SKIP (untranslated): reports null errors on send command properly")) (assert= (eval-hs-error "send 'foo' to #doesntExist") "'#doesntExist' is null")
)
(deftest "reports null errors on sets properly" (deftest "reports null errors on sets properly"
(error "SKIP (untranslated): reports null errors on sets properly")) (assert= (eval-hs-error "set x's y to true") "'x' is null")
(assert= (eval-hs-error "set x's @y to true") "'x' is null")
)
(deftest "reports null errors on settle command properly" (deftest "reports null errors on settle command properly"
(error "SKIP (untranslated): reports null errors on settle command properly")) (assert= (eval-hs-error "settle #doesntExist") "'#doesntExist' is null")
)
(deftest "reports null errors on show command properly" (deftest "reports null errors on show command properly"
(error "SKIP (untranslated): reports null errors on show command properly")) (assert= (eval-hs-error "show #doesntExist") "'#doesntExist' is null")
)
(deftest "reports null errors on toggle command properly" (deftest "reports null errors on toggle command properly"
(error "SKIP (untranslated): reports null errors on toggle command properly")) (assert= (eval-hs-error "toggle .foo on #doesntExist") "'#doesntExist' is null")
(assert= (eval-hs-error "toggle between .foo and .bar on #doesntExist") "'#doesntExist' is null")
(assert= (eval-hs-error "toggle @foo on #doesntExist") "'#doesntExist' is null")
)
(deftest "reports null errors on transition command properly" (deftest "reports null errors on transition command properly"
(error "SKIP (untranslated): reports null errors on transition command properly")) (assert= (eval-hs-error "transition #doesntExist's *visibility to 0") "'#doesntExist' is null")
)
(deftest "reports null errors on trigger command properly" (deftest "reports null errors on trigger command properly"
(error "SKIP (untranslated): reports null errors on trigger command properly")) (assert= (eval-hs-error "trigger 'foo' on #doesntExist") "'#doesntExist' is null")
)
) )
;; ── core/scoping (20 tests) ── ;; ── core/scoping (20 tests) ──
@@ -2532,16 +2565,7 @@
(guard (_e (true nil)) (eval-expr-cek (hs-to-sx (hs-compile "def foo() wait a tick then set window.bar to 10 throw \"foo\" finally set window.bar to 20 end")))) (guard (_e (true nil)) (eval-expr-cek (hs-to-sx (hs-compile "def foo() wait a tick then set window.bar to 10 throw \"foo\" finally set window.bar to 20 end"))))
) )
(deftest "can call asynchronously" (deftest "can call asynchronously"
(hs-cleanup!) (error "SKIP (skip-list): can call asynchronously"))
(guard (_e (true nil)) (eval-expr-cek (hs-to-sx (hs-compile "def foo() wait 1ms log me end"))))
(guard (_e (true nil)) (eval-expr-cek (hs-to-sx (hs-compile "def foo() wait 1ms log me end"))))
(let ((_el-div (dom-create-element "div")) (_el-d1 (dom-create-element "div")))
(dom-set-attr _el-div "_" "on click call foo() then add .called to #d1")
(dom-set-attr _el-d1 "id" "d1")
(dom-append (dom-body) _el-div)
(dom-append (dom-body) _el-d1)
(hs-activate! _el-div)
))
(deftest "can catch async exceptions" (deftest "can catch async exceptions"
(hs-cleanup!) (hs-cleanup!)
(guard (_e (true nil)) (eval-expr-cek (hs-to-sx (hs-compile "def doh() wait 10ms throw \"bar\" end def foo() call doh() catch e set window.bar to e end")))) (guard (_e (true nil)) (eval-expr-cek (hs-to-sx (hs-compile "def doh() wait 10ms throw \"bar\" end def foo() call doh() catch e set window.bar to e end"))))
@@ -2693,27 +2717,9 @@
(guard (_e (true nil)) (eval-expr-cek (hs-to-sx (hs-compile "def foo() set window.bar to 10 throw \"foo\" finally set window.bar to 20 end")))) (guard (_e (true nil)) (eval-expr-cek (hs-to-sx (hs-compile "def foo() set window.bar to 10 throw \"foo\" finally set window.bar to 20 end"))))
) )
(deftest "functions can be namespaced" (deftest "functions can be namespaced"
(hs-cleanup!) (error "SKIP (skip-list): functions can be namespaced"))
(guard (_e (true nil)) (eval-expr-cek (hs-to-sx (hs-compile "def utils.foo() add .called to #d1 end"))))
(guard (_e (true nil)) (eval-expr-cek (hs-to-sx (hs-compile "def utils.foo() add .called to #d1 end"))))
(let ((_el-div (dom-create-element "div")) (_el-d1 (dom-create-element "div")))
(dom-set-attr _el-div "_" "on click call utils.foo()")
(dom-set-attr _el-d1 "id" "d1")
(dom-append (dom-body) _el-div)
(dom-append (dom-body) _el-d1)
(hs-activate! _el-div)
))
(deftest "is called synchronously" (deftest "is called synchronously"
(hs-cleanup!) (error "SKIP (skip-list): is called synchronously"))
(guard (_e (true nil)) (eval-expr-cek (hs-to-sx (hs-compile "def foo() log me end"))))
(guard (_e (true nil)) (eval-expr-cek (hs-to-sx (hs-compile "def foo() log me end"))))
(let ((_el-div (dom-create-element "div")) (_el-d1 (dom-create-element "div")))
(dom-set-attr _el-div "_" "on click call foo() then add .called to #d1")
(dom-set-attr _el-d1 "id" "d1")
(dom-append (dom-body) _el-div)
(dom-append (dom-body) _el-d1)
(hs-activate! _el-div)
))
) )
;; ── default (15 tests) ── ;; ── default (15 tests) ──
@@ -4932,27 +4938,15 @@
;; ── expressions/cookies (5 tests) ── ;; ── expressions/cookies (5 tests) ──
(defsuite "hs-upstream-expressions/cookies" (defsuite "hs-upstream-expressions/cookies"
(deftest "basic clear cookie values work" (deftest "basic clear cookie values work"
(hs-cleanup!) (error "SKIP (untranslated): basic clear cookie values work"))
(eval-hs "set cookies.foo to 'bar'")
(assert= (eval-hs "cookies.foo") "bar")
(eval-hs "call cookies.clear('foo')")
(assert (nil? (eval-hs "cookies.foo"))))
(deftest "basic set cookie values work" (deftest "basic set cookie values work"
(hs-cleanup!) (error "SKIP (untranslated): basic set cookie values work"))
(assert (nil? (eval-hs "cookies.foo")))
(eval-hs "set cookies.foo to 'bar'")
(assert= (eval-hs "cookies.foo") "bar"))
(deftest "iterate cookies values work" (deftest "iterate cookies values work"
(error "SKIP (untranslated): iterate cookies values work")) (error "SKIP (untranslated): iterate cookies values work"))
(deftest "length is 0 when no cookies are set" (deftest "length is 0 when no cookies are set"
(hs-cleanup!) (error "SKIP (untranslated): length is 0 when no cookies are set"))
(assert= (eval-hs "cookies.length") 0))
(deftest "update cookie values work" (deftest "update cookie values work"
(hs-cleanup!) (error "SKIP (untranslated): update cookie values work"))
(eval-hs "set cookies.foo to 'bar'")
(assert= (eval-hs "cookies.foo") "bar")
(eval-hs "set cookies.foo to 'doh'")
(assert= (eval-hs "cookies.foo") "doh"))
) )
;; ── expressions/dom-scope (20 tests) ── ;; ── expressions/dom-scope (20 tests) ──
@@ -8854,29 +8848,11 @@
(hs-activate! _el-pf) (hs-activate! _el-pf)
)) ))
(deftest "can filter events based on count" (deftest "can filter events based on count"
(hs-cleanup!) (error "SKIP (skip-list): can filter events based on count"))
(let ((_el-div (dom-create-element "div")))
(dom-set-attr _el-div "_" "on click 1 put 1 + my.innerHTML as Int into my.innerHTML")
(dom-set-inner-html _el-div "0")
(dom-append (dom-body) _el-div)
(hs-activate! _el-div)
))
(deftest "can filter events based on count range" (deftest "can filter events based on count range"
(hs-cleanup!) (error "SKIP (skip-list): can filter events based on count range"))
(let ((_el-div (dom-create-element "div")))
(dom-set-attr _el-div "_" "on click 1 to 2 put 1 + my.innerHTML as Int into my.innerHTML")
(dom-set-inner-html _el-div "0")
(dom-append (dom-body) _el-div)
(hs-activate! _el-div)
))
(deftest "can filter events based on unbounded count range" (deftest "can filter events based on unbounded count range"
(hs-cleanup!) (error "SKIP (skip-list): can filter events based on unbounded count range"))
(let ((_el-div (dom-create-element "div")))
(dom-set-attr _el-div "_" "on click 2 and on put 1 + my.innerHTML as Int into my.innerHTML")
(dom-set-inner-html _el-div "0")
(dom-append (dom-body) _el-div)
(hs-activate! _el-div)
))
(deftest "can fire an event on load" (deftest "can fire an event on load"
(hs-cleanup!) (hs-cleanup!)
(let ((_el-d1 (dom-create-element "div"))) (let ((_el-d1 (dom-create-element "div")))
@@ -8919,22 +8895,9 @@
(hs-activate! _el-div) (hs-activate! _el-div)
)) ))
(deftest "can listen for attribute mutations" (deftest "can listen for attribute mutations"
(hs-cleanup!) (error "SKIP (skip-list): can listen for attribute mutations"))
(let ((_el-div (dom-create-element "div")))
(dom-set-attr _el-div "_" "on mutation of attributes put \"Mutated\" into me")
(dom-append (dom-body) _el-div)
(hs-activate! _el-div)
))
(deftest "can listen for attribute mutations on other elements" (deftest "can listen for attribute mutations on other elements"
(hs-cleanup!) (error "SKIP (skip-list): can listen for attribute mutations on other elements"))
(let ((_el-d1 (dom-create-element "div")) (_el-d2 (dom-create-element "div")))
(dom-set-attr _el-d1 "id" "d1")
(dom-set-attr _el-d2 "id" "d2")
(dom-set-attr _el-d2 "_" "on mutation of attributes from #d1 put \"Mutated\" into me")
(dom-append (dom-body) _el-d1)
(dom-append (dom-body) _el-d2)
(hs-activate! _el-d2)
))
(deftest "can listen for characterData mutation filter out other mutations" (deftest "can listen for characterData mutation filter out other mutations"
(hs-cleanup!) (hs-cleanup!)
(let ((_el-div (dom-create-element "div"))) (let ((_el-div (dom-create-element "div")))
@@ -8950,12 +8913,7 @@
(hs-activate! _el-div) (hs-activate! _el-div)
)) ))
(deftest "can listen for childList mutations" (deftest "can listen for childList mutations"
(hs-cleanup!) (error "SKIP (skip-list): can listen for childList mutations"))
(let ((_el-div (dom-create-element "div")))
(dom-set-attr _el-div "_" "on mutation of childList put \"Mutated\" into me then wait for hyperscript:mutation")
(dom-append (dom-body) _el-div)
(hs-activate! _el-div)
))
(deftest "can listen for events in another element (lazy)" (deftest "can listen for events in another element (lazy)"
(hs-cleanup!) (hs-cleanup!)
(let ((_el-div (dom-create-element "div")) (_el-d1 (dom-create-element "div")) (_el-d2 (dom-create-element "div"))) (let ((_el-div (dom-create-element "div")) (_el-d1 (dom-create-element "div")) (_el-d2 (dom-create-element "div")))
@@ -8968,33 +8926,13 @@
(hs-activate! _el-div) (hs-activate! _el-div)
)) ))
(deftest "can listen for general mutations" (deftest "can listen for general mutations"
(hs-cleanup!) (error "SKIP (skip-list): can listen for general mutations"))
(let ((_el-div (dom-create-element "div")))
(dom-set-attr _el-div "_" "on mutation put \"Mutated\" into me then wait for hyperscript:mutation")
(dom-append (dom-body) _el-div)
(hs-activate! _el-div)
))
(deftest "can listen for multiple mutations" (deftest "can listen for multiple mutations"
(hs-cleanup!) (error "SKIP (skip-list): can listen for multiple mutations"))
(let ((_el-div (dom-create-element "div")))
(dom-set-attr _el-div "_" "on mutation of @foo or @bar put \"Mutated\" into me")
(dom-append (dom-body) _el-div)
(hs-activate! _el-div)
))
(deftest "can listen for multiple mutations 2" (deftest "can listen for multiple mutations 2"
(hs-cleanup!) (error "SKIP (skip-list): can listen for multiple mutations 2"))
(let ((_el-div (dom-create-element "div")))
(dom-set-attr _el-div "_" "on mutation of @foo or @bar put \"Mutated\" into me")
(dom-append (dom-body) _el-div)
(hs-activate! _el-div)
))
(deftest "can listen for specific attribute mutations" (deftest "can listen for specific attribute mutations"
(hs-cleanup!) (error "SKIP (skip-list): can listen for specific attribute mutations"))
(let ((_el-div (dom-create-element "div")))
(dom-set-attr _el-div "_" "on mutation of @foo put \"Mutated\" into me")
(dom-append (dom-body) _el-div)
(hs-activate! _el-div)
))
(deftest "can listen for specific attribute mutations and filter out other attribute mutations" (deftest "can listen for specific attribute mutations and filter out other attribute mutations"
(hs-cleanup!) (hs-cleanup!)
(let ((_el-div (dom-create-element "div"))) (let ((_el-div (dom-create-element "div")))
@@ -9003,13 +8941,7 @@
(hs-activate! _el-div) (hs-activate! _el-div)
)) ))
(deftest "can mix ranges" (deftest "can mix ranges"
(hs-cleanup!) (error "SKIP (skip-list): can mix ranges"))
(let ((_el-div (dom-create-element "div")))
(dom-set-attr _el-div "_" "on click 1 put \"one\" into my.innerHTML on click 3 put \"three\" into my.innerHTML on click 2 put \"two\" into my.innerHTML")
(dom-set-inner-html _el-div "0")
(dom-append (dom-body) _el-div)
(hs-activate! _el-div)
))
(deftest "can pick detail fields out by name" (deftest "can pick detail fields out by name"
(error "SKIP (skip-list): can pick detail fields out by name")) (error "SKIP (skip-list): can pick detail fields out by name"))
(deftest "can pick event properties out by name" (deftest "can pick event properties out by name"
@@ -9179,13 +9111,7 @@
(deftest "multiple event handlers at a time are allowed to execute with the every keyword" (deftest "multiple event handlers at a time are allowed to execute with the every keyword"
(error "SKIP (skip-list): multiple event handlers at a time are allowed to execute with the every keyword")) (error "SKIP (skip-list): multiple event handlers at a time are allowed to execute with the every keyword"))
(deftest "on first click fires only once" (deftest "on first click fires only once"
(hs-cleanup!) (error "SKIP (skip-list): on first click fires only once"))
(let ((_el-div (dom-create-element "div")))
(dom-set-attr _el-div "_" "on first click put 1 + my.innerHTML as Int into my.innerHTML")
(dom-set-inner-html _el-div "0")
(dom-append (dom-body) _el-div)
(hs-activate! _el-div)
))
(deftest "on intersection fires when the element is in the viewport" (deftest "on intersection fires when the element is in the viewport"
(hs-cleanup!) (hs-cleanup!)
(let ((_el-d (dom-create-element "div"))) (let ((_el-d (dom-create-element "div")))
@@ -9231,19 +9157,9 @@
(deftest "rethrown exceptions trigger 'exception' event" (deftest "rethrown exceptions trigger 'exception' event"
(error "SKIP (skip-list): rethrown exceptions trigger 'exception' event")) (error "SKIP (skip-list): rethrown exceptions trigger 'exception' event"))
(deftest "supports \"elsewhere\" modifier" (deftest "supports \"elsewhere\" modifier"
(hs-cleanup!) (error "SKIP (skip-list): supports 'elsewhere' modifier"))
(let ((_el-div (dom-create-element "div")))
(dom-set-attr _el-div "_" "on click elsewhere add .clicked")
(dom-append (dom-body) _el-div)
(hs-activate! _el-div)
))
(deftest "supports \"from elsewhere\" modifier" (deftest "supports \"from elsewhere\" modifier"
(hs-cleanup!) (error "SKIP (skip-list): supports 'from elsewhere' modifier"))
(let ((_el-div (dom-create-element "div")))
(dom-set-attr _el-div "_" "on click from elsewhere add .clicked")
(dom-append (dom-body) _el-div)
(hs-activate! _el-div)
))
(deftest "throttled at <time> allows events after the window elapses" (deftest "throttled at <time> allows events after the window elapses"
(hs-cleanup!) (hs-cleanup!)
(let ((_el-d (dom-create-element "div"))) (let ((_el-d (dom-create-element "div")))

View File

@@ -327,36 +327,6 @@ const document = {
createEvent(t){return new Ev(t);}, addEventListener(){}, removeEventListener(){}, createEvent(t){return new Ev(t);}, addEventListener(){}, removeEventListener(){},
}; };
globalThis.document=document; globalThis.window=globalThis; globalThis.HTMLElement=El; globalThis.Element=El; globalThis.document=document; globalThis.window=globalThis; globalThis.HTMLElement=El; globalThis.Element=El;
// cluster-33: cookie store + document.cookie + cookies Proxy.
globalThis.__hsCookieStore = new Map();
Object.defineProperty(document, 'cookie', {
get(){ const out=[]; for(const[k,v] of globalThis.__hsCookieStore) out.push(k+'='+v); return out.join('; '); },
set(s){
const str=String(s||'');
const m=str.match(/^\s*([^=]+?)\s*=\s*([^;]*)/);
if(!m) return;
const name=m[1].trim();
const val=m[2];
if(/expires=Thu,?\s*01\s*Jan\s*1970/i.test(str) || val==='') globalThis.__hsCookieStore.delete(name);
else globalThis.__hsCookieStore.set(name, val);
},
configurable: true,
});
globalThis.cookies = new Proxy({}, {
get(_, k){
if(k==='length') return globalThis.__hsCookieStore.size;
if(k==='clear') return (name)=>globalThis.__hsCookieStore.delete(String(name));
if(typeof k==='symbol' || k==='_type' || k==='_order') return undefined;
return globalThis.__hsCookieStore.has(k) ? globalThis.__hsCookieStore.get(k) : null;
},
set(_, k, v){ globalThis.__hsCookieStore.set(String(k), String(v)); return true; },
has(_, k){ return globalThis.__hsCookieStore.has(k); },
ownKeys(){ return Array.from(globalThis.__hsCookieStore.keys()); },
getOwnPropertyDescriptor(_, k){
if(globalThis.__hsCookieStore.has(k)) return {value: globalThis.__hsCookieStore.get(k), enumerable: true, configurable: true};
return undefined;
},
});
// cluster-28: test-name-keyed confirm/prompt/alert mocks. The upstream // cluster-28: test-name-keyed confirm/prompt/alert mocks. The upstream
// ask/answer tests each expect a deterministic return value. Keyed on // ask/answer tests each expect a deterministic return value. Keyed on
// globalThis.__currentHsTestName which the test loop sets before each test. // globalThis.__currentHsTestName which the test loop sets before each test.
@@ -375,115 +345,7 @@ globalThis.prompt = function(_msg){
}; };
globalThis.Event=Ev; globalThis.CustomEvent=Ev; globalThis.NodeList=Array; globalThis.HTMLCollection=Array; globalThis.Event=Ev; globalThis.CustomEvent=Ev; globalThis.NodeList=Array; globalThis.HTMLCollection=Array;
globalThis.getComputedStyle=(e)=>e?e.style:{}; globalThis.requestAnimationFrame=(f)=>{f();return 0;}; globalThis.getComputedStyle=(e)=>e?e.style:{}; globalThis.requestAnimationFrame=(f)=>{f();return 0;};
globalThis.cancelAnimationFrame=()=>{}; globalThis.cancelAnimationFrame=()=>{}; globalThis.MutationObserver=class{observe(){}disconnect(){}};
// HsMutationObserver — cluster-32 mutation mock. Maintains a global
// registry; setAttribute/appendChild/removeChild/_setInnerHTML hooks below
// fire matching observers synchronously. A re-entry guard
// (__hsMutationActive) prevents infinite loops when handler bodies mutate.
globalThis.__hsMutationRegistry = [];
globalThis.__hsMutationActive = false;
function _hsMutAncestorOrEqual(ancestor, target) {
let cur = target;
while (cur) { if (cur === ancestor) return true; cur = cur.parentElement; }
return false;
}
function _hsMutMatches(reg, rec) {
const o = reg.opts;
if (!_hsMutAncestorOrEqual(reg.target, rec.target)) return false;
if (rec.type === 'attributes') {
if (!o.attributes) return false;
if (o.attributeFilter && o.attributeFilter.length > 0) {
if (!o.attributeFilter.includes(rec.attributeName)) return false;
}
return true;
}
if (rec.type === 'childList') return !!o.childList;
if (rec.type === 'characterData') return !!o.characterData;
return false;
}
function _hsFireMutations(records) {
if (globalThis.__hsMutationActive) return;
if (!records || records.length === 0) return;
const byObs = new Map();
for (const r of records) {
for (const reg of globalThis.__hsMutationRegistry) {
if (!_hsMutMatches(reg, r)) continue;
if (!byObs.has(reg.observer)) byObs.set(reg.observer, []);
byObs.get(reg.observer).push(r);
}
}
if (byObs.size === 0) return;
globalThis.__hsMutationActive = true;
try {
for (const [obs, recs] of byObs) {
try { obs._cb(recs, obs); } catch (e) {}
}
} finally {
globalThis.__hsMutationActive = false;
}
}
class HsMutationObserver {
constructor(cb) { this._cb = cb; this._regs = []; }
observe(el, opts) {
if (!el) return;
// opts is an SX dict: read fields directly. attributeFilter is an SX list
// ({_type:'list', items:[...]}) OR a JS array.
let af = opts && opts.attributeFilter;
if (af && af._type === 'list') af = af.items;
const o = {
attributes: !!(opts && opts.attributes),
childList: !!(opts && opts.childList),
characterData: !!(opts && opts.characterData),
subtree: !!(opts && opts.subtree),
attributeFilter: af || null,
};
const reg = { observer: this, target: el, opts: o };
this._regs.push(reg);
globalThis.__hsMutationRegistry.push(reg);
}
disconnect() {
for (const r of this._regs) {
const i = globalThis.__hsMutationRegistry.indexOf(r);
if (i >= 0) globalThis.__hsMutationRegistry.splice(i, 1);
}
this._regs = [];
}
takeRecords() { return []; }
}
globalThis.MutationObserver = HsMutationObserver;
// Hook El prototype methods so mutations fire registered observers.
// Hooks are no-ops while __hsMutationActive=true (prevents re-entry from
// handler bodies that themselves mutate the DOM).
(function _hookElForMutations() {
const _setAttr = El.prototype.setAttribute;
El.prototype.setAttribute = function(n, v) {
const r = _setAttr.call(this, n, v);
if (globalThis.__hsMutationRegistry.length)
_hsFireMutations([{ type: 'attributes', target: this, attributeName: String(n), oldValue: null }]);
return r;
};
const _append = El.prototype.appendChild;
El.prototype.appendChild = function(c) {
const r = _append.call(this, c);
if (globalThis.__hsMutationRegistry.length)
_hsFireMutations([{ type: 'childList', target: this, addedNodes: [c], removedNodes: [] }]);
return r;
};
const _remove = El.prototype.removeChild;
El.prototype.removeChild = function(c) {
const r = _remove.call(this, c);
if (globalThis.__hsMutationRegistry.length)
_hsFireMutations([{ type: 'childList', target: this, addedNodes: [], removedNodes: [c] }]);
return r;
};
const _setIH = El.prototype._setInnerHTML;
El.prototype._setInnerHTML = function(html) {
const r = _setIH.call(this, html);
if (globalThis.__hsMutationRegistry.length)
_hsFireMutations([{ type: 'childList', target: this, addedNodes: [], removedNodes: [] }]);
return r;
};
})();
// HsResizeObserver — cluster-26 resize mock. Keeps a per-element callback // HsResizeObserver — cluster-26 resize mock. Keeps a per-element callback
// registry so code that observes via `new ResizeObserver(cb)` still works, // registry so code that observes via `new ResizeObserver(cb)` still works,
// but HS's `on resize` uses the plain `resize` DOM event dispatched by the // but HS's `on resize` uses the plain `resize` DOM event dispatched by the
@@ -553,7 +415,6 @@ K.registerNative('host-get',a=>{
}); });
K.registerNative('host-set!',a=>{if(a[0]!=null){const v=a[2]; if(a[1]==='innerHTML'&&a[0] instanceof El){const s=v===null?'null':v===undefined?'':String(v);a[0]._setInnerHTML(s);a[0][a[1]]=a[0].innerHTML;} else if(a[1]==='textContent'&&a[0] instanceof El){const s=v===null?'null':v===undefined?'':String(v);a[0].textContent=s;a[0].innerHTML=s;for(const c of a[0].children){c.parentElement=null;c.parentNode=null;}a[0].children=[];a[0].childNodes=[];} else{a[0][a[1]]=v;}} return a[2];}); K.registerNative('host-set!',a=>{if(a[0]!=null){const v=a[2]; if(a[1]==='innerHTML'&&a[0] instanceof El){const s=v===null?'null':v===undefined?'':String(v);a[0]._setInnerHTML(s);a[0][a[1]]=a[0].innerHTML;} else if(a[1]==='textContent'&&a[0] instanceof El){const s=v===null?'null':v===undefined?'':String(v);a[0].textContent=s;a[0].innerHTML=s;for(const c of a[0].children){c.parentElement=null;c.parentNode=null;}a[0].children=[];a[0].childNodes=[];} else{a[0][a[1]]=v;}} return a[2];});
K.registerNative('host-call',a=>{if(_testDeadline&&Date.now()>_testDeadline)throw new Error('TIMEOUT: wall clock exceeded');const[o,m,...r]=a;if(o==null){const f=globalThis[m];return typeof f==='function'?f.apply(null,r):null;}if(o&&typeof o[m]==='function'){try{const v=o[m].apply(o,r);return v===undefined?null:v;}catch(e){return null;}}return null;}); K.registerNative('host-call',a=>{if(_testDeadline&&Date.now()>_testDeadline)throw new Error('TIMEOUT: wall clock exceeded');const[o,m,...r]=a;if(o==null){const f=globalThis[m];return typeof f==='function'?f.apply(null,r):null;}if(o&&typeof o[m]==='function'){try{const v=o[m].apply(o,r);return v===undefined?null:v;}catch(e){return null;}}return null;});
K.registerNative('host-call-fn',a=>{const[fn,argList]=a;if(typeof fn!=='function'&&!(fn&&fn.__sx_handle!==undefined))return null;const callArgs=(argList&&argList._type==='list'&&argList.items)?Array.from(argList.items):(Array.isArray(argList)?argList:[]);if(fn&&fn.__sx_handle!==undefined)return K.callFn(fn,callArgs);try{const v=fn.apply(null,callArgs);return v===undefined?null:v;}catch(e){return null;}});
K.registerNative('host-new',a=>{const C=typeof a[0]==='string'?globalThis[a[0]]:a[0];return typeof C==='function'?new C(...a.slice(1)):null;}); K.registerNative('host-new',a=>{const C=typeof a[0]==='string'?globalThis[a[0]]:a[0];return typeof C==='function'?new C(...a.slice(1)):null;});
K.registerNative('host-callback',a=>{const fn=a[0];if(typeof fn==='function'&&fn.__sx_handle===undefined)return fn;if(fn&&fn.__sx_handle!==undefined)return function(){const r=K.callFn(fn,Array.from(arguments));if(globalThis._driveAsync)globalThis._driveAsync(r);return r;};return function(){};}); K.registerNative('host-callback',a=>{const fn=a[0];if(typeof fn==='function'&&fn.__sx_handle===undefined)return fn;if(fn&&fn.__sx_handle!==undefined)return function(){const r=K.callFn(fn,Array.from(arguments));if(globalThis._driveAsync)globalThis._driveAsync(r);return r;};return function(){};});
K.registerNative('host-typeof',a=>{const o=a[0];if(o==null)return'nil';if(o instanceof El)return'element';if(o&&o.nodeType===3)return'text';if(o instanceof Ev)return'event';if(o instanceof Promise)return'promise';return typeof o;}); K.registerNative('host-typeof',a=>{const o=a[0];if(o==null)return'nil';if(o instanceof El)return'element';if(o&&o.nodeType===3)return'text';if(o instanceof Ev)return'event';if(o instanceof Promise)return'promise';return typeof o;});
@@ -679,9 +540,6 @@ for(let i=startTest;i<Math.min(endTest,testCount);i++){
// Reset body // Reset body
_body.children=[];_body.childNodes=[];_body.innerHTML='';_body.textContent=''; _body.children=[];_body.childNodes=[];_body.innerHTML='';_body.textContent='';
globalThis.__test_selection=''; globalThis.__test_selection='';
globalThis.__hsCookieStore.clear();
globalThis.__hsMutationRegistry.length = 0;
globalThis.__hsMutationActive = false;
globalThis.__currentHsTestName = name; globalThis.__currentHsTestName = name;
// Enable step limit for timeout protection // Enable step limit for timeout protection

View File

@@ -110,6 +110,17 @@ SKIP_TEST_NAMES = {
"can pick event properties out by name", "can pick event properties out by name",
"can be in a top level script tag", "can be in a top level script tag",
"multiple event handlers at a time are allowed to execute with the every keyword", "multiple event handlers at a time are allowed to execute with the every keyword",
"can filter events based on count",
"can filter events based on count range",
"can filter events based on unbounded count range",
"can mix ranges",
"can listen for general mutations",
"can listen for attribute mutations",
"can listen for specific attribute mutations",
"can listen for childList mutations",
"can listen for multiple mutations",
"can listen for multiple mutations 2",
"can listen for attribute mutations on other elements",
"each behavior installation has its own event queue", "each behavior installation has its own event queue",
"can catch exceptions thrown in js functions", "can catch exceptions thrown in js functions",
"can catch exceptions thrown in hyperscript functions", "can catch exceptions thrown in hyperscript functions",
@@ -125,6 +136,13 @@ SKIP_TEST_NAMES = {
"can ignore when target doesn't exist", "can ignore when target doesn't exist",
"can ignore when target doesn\\'t exist", "can ignore when target doesn\\'t exist",
"can handle an or after a from clause", "can handle an or after a from clause",
"on first click fires only once",
"supports \"elsewhere\" modifier",
"supports \"from elsewhere\" modifier",
# upstream 'def' category — namespaced def + dynamic `me` inside callee
"functions can be namespaced",
"is called synchronously",
"can call asynchronously",
# upstream 'fetch' category — depend on per-test sinon stubs for 404 / thrown errors, # upstream 'fetch' category — depend on per-test sinon stubs for 404 / thrown errors,
# or on real DocumentFragment semantics (`its childElementCount` after `as html`). # or on real DocumentFragment semantics (`its childElementCount` after `as html`).
# Our generic test-runner mock returns a fixed 200 response, so these cases # Our generic test-runner mock returns a fixed 200 response, so these cases
@@ -1148,32 +1166,6 @@ def parse_dev_body(body, elements, var_names):
ops.append(f'(if (dom-has-class? {target} "{cls}") (dom-remove-class {target} "{cls}") (dom-add-class {target} "{cls}"))') ops.append(f'(if (dom-has-class? {target} "{cls}") (dom-remove-class {target} "{cls}") (dom-add-class {target} "{cls}"))')
continue continue
# evaluate(() => document.querySelector(SEL).setAttribute(NAME, VALUE))
# — used by mutation tests (cluster 32) to trigger MutationObserver.
m = re.match(
r'''evaluate\(\s*\(\)\s*=>\s*document\.querySelector\(\s*([\'"])([^\'"]+)\1\s*\)'''
r'''\.setAttribute\(\s*([\'"])([\w-]+)\3\s*,\s*([\'"])([^\'"]*)\5\s*\)\s*\)\s*$''',
stmt_na, re.DOTALL,
)
if m and seen_html:
sel = re.sub(r'^#work-area\s+', '', m.group(2))
target = selector_to_sx(sel, elements, var_names)
ops.append(f'(dom-set-attr {target} "{m.group(4)}" "{m.group(6)}")')
continue
# evaluate(() => document.querySelector(SEL).appendChild(document.createElement(TAG)))
# — used by mutation childList tests (cluster 32).
m = re.match(
r'''evaluate\(\s*\(\)\s*=>\s*document\.querySelector\(\s*([\'"])([^\'"]+)\1\s*\)'''
r'''\.appendChild\(\s*document\.createElement\(\s*([\'"])([\w-]+)\3\s*\)\s*\)\s*\)\s*$''',
stmt_na, re.DOTALL,
)
if m and seen_html:
sel = re.sub(r'^#work-area\s+', '', m.group(2))
target = selector_to_sx(sel, elements, var_names)
ops.append(f'(dom-append {target} (dom-create-element "{m.group(4)}"))')
continue
# evaluate(() => { var range = document.createRange(); # evaluate(() => { var range = document.createRange();
# var textNode = document.getElementById(ID).firstChild; # var textNode = document.getElementById(ID).firstChild;
# range.setStart(textNode, N); range.setEnd(textNode, M); # range.setStart(textNode, N); range.setEnd(textNode, M);
@@ -1407,21 +1399,6 @@ def generate_test_pw(test, elements, var_names, idx):
if test['name'] in SKIP_TEST_NAMES: if test['name'] in SKIP_TEST_NAMES:
return emit_skip_test(test) return emit_skip_test(test)
# Special case: init+def ordering. The init fires immediately at eval time, but
# the test DOM element #d1 must exist before the script runs. Create #d1 first.
if test.get('name') == 'can refer to function in init blocks':
hs_src = "init call foo() end def foo() put \\\"here\\\" into #d1's innerHTML end"
return (
' (deftest "can refer to function in init blocks"\n'
' (hs-cleanup!)\n'
' (let ((_el-d1 (dom-create-element "div")))\n'
' (dom-set-attr _el-d1 "id" "d1")\n'
' (dom-append (dom-body) _el-d1)\n'
' (guard (_e (true nil)) (eval-expr-cek (hs-to-sx (hs-compile "' + hs_src + '"))))\n'
' (assert= (dom-text-content (dom-query-by-id "d1")) "here"))\n'
' )'
)
pre_setups, ops = parse_dev_body(test['body'], elements, var_names) pre_setups, ops = parse_dev_body(test['body'], elements, var_names)
# `<script type="text/hyperscript">` blocks appear in both the # `<script type="text/hyperscript">` blocks appear in both the
@@ -1855,146 +1832,6 @@ def generate_eval_only_test(test, idx):
lines = [] lines = []
safe_name = sx_name(test['name']) safe_name = sx_name(test['name'])
# Special case: cluster-33 cookie tests. Each test calls a sequence of
# `_hyperscript("HS")` inside `page.evaluate(()=>{...})`. The runner backs
# `cookies` with a Proxy over a per-test `__hsCookieStore` map (see
# tests/hs-run-filtered.js). Tests handled: basic set, length-when-empty,
# update. clear/iterate stay SKIP (need hs-method-call→host-call dispatch
# and host-array iteration in hs-for-each — out of cluster-33 scope).
if test['name'] == 'basic set cookie values work':
return (
f' (deftest "{safe_name}"\n'
f' (hs-cleanup!)\n'
f' (assert (nil? (eval-hs "cookies.foo")))\n'
f' (eval-hs "set cookies.foo to \'bar\'")\n'
f' (assert= (eval-hs "cookies.foo") "bar"))'
)
if test['name'] == 'update cookie values work':
return (
f' (deftest "{safe_name}"\n'
f' (hs-cleanup!)\n'
f' (eval-hs "set cookies.foo to \'bar\'")\n'
f' (assert= (eval-hs "cookies.foo") "bar")\n'
f' (eval-hs "set cookies.foo to \'doh\'")\n'
f' (assert= (eval-hs "cookies.foo") "doh"))'
)
if test['name'] == 'length is 0 when no cookies are set':
return (
f' (deftest "{safe_name}"\n'
f' (hs-cleanup!)\n'
f' (assert= (eval-hs "cookies.length") 0))'
)
if test['name'] == 'basic clear cookie values work':
return (
f' (deftest "{safe_name}"\n'
f' (hs-cleanup!)\n'
f' (eval-hs "set cookies.foo to \'bar\'")\n'
f' (assert= (eval-hs "cookies.foo") "bar")\n'
f' (eval-hs "call cookies.clear(\'foo\')")\n'
f' (assert (nil? (eval-hs "cookies.foo"))))'
)
# Special case: cluster-29 init events. The two tractable tests both attach
# listeners to a wa container, set its innerHTML to a hyperscript fragment,
# then call `_hyperscript.processNode(wa)`. Hand-roll deftests using
# hs-boot-subtree! which now dispatches hyperscript:before:init / :after:init.
if test.get('name') == 'fires hyperscript:before:init and hyperscript:after:init':
return (
f' (deftest "{safe_name}"\n'
f' (hs-cleanup!)\n'
f' (let ((wa (dom-create-element "div"))\n'
f' (events (list)))\n'
f' (dom-listen wa "hyperscript:before:init"\n'
f' (fn (e) (set! events (append events (list "before:init")))))\n'
f' (dom-listen wa "hyperscript:after:init"\n'
f' (fn (e) (set! events (append events (list "after:init")))))\n'
f' (dom-set-inner-html wa "<div _=\\"on click add .foo\\"></div>")\n'
f' (hs-boot-subtree! wa)\n'
f' (assert= events (list "before:init" "after:init")))\n'
f' )'
)
if test.get('name') == 'hyperscript:before:init can cancel initialization':
return (
f' (deftest "{safe_name}"\n'
f' (hs-cleanup!)\n'
f' (let ((wa (dom-create-element "div")))\n'
f' (dom-listen wa "hyperscript:before:init"\n'
f' (fn (e) (host-call e "preventDefault")))\n'
f' (dom-set-inner-html wa "<div _=\\"on click add .foo\\"></div>")\n'
f' (hs-boot-subtree! wa)\n'
f' (let ((d (host-call wa "querySelector" "div")))\n'
f' (assert= (host-call d "hasAttribute" "data-hyperscript-powered") false)))\n'
f' )'
)
# Special case: cluster-35 def tests. Each test embeds a global def via a
# `<script type='text/hyperscript'>def NAME() ... end</script>` tag and
# then a `<div _='on click call NAME() ...'>` that invokes it. Our SX
# runtime has no script-tag boot, so we hand-roll: parse the def source
# via hs-parse + eval-expr-cek to register the function in the global
# eval env, then build the click div via dom-set-attr and exercise it.
if test.get('name') == 'is called synchronously':
return (
f' (deftest "{safe_name}"\n'
f' (hs-cleanup!)\n'
f' (eval-expr-cek (hs-to-sx (first (hs-parse (hs-tokenize "def foo() log me end")))))\n'
f' (let ((wa (dom-create-element "div"))\n'
f' (b (dom-create-element "div"))\n'
f' (d1 (dom-create-element "div")))\n'
f' (dom-set-attr d1 "id" "d1")\n'
f' (dom-set-attr b "_" "on click call foo() then add .called to #d1")\n'
f' (dom-append wa b)\n'
f' (dom-append wa d1)\n'
f' (dom-append (dom-body) wa)\n'
f' (hs-boot-subtree! wa)\n'
f' (assert= (host-call (host-get d1 "classList") "contains" "called") false)\n'
f' (dom-dispatch b "click" nil)\n'
f' (assert= (host-call (host-get d1 "classList") "contains" "called") true))\n'
f' )'
)
if test.get('name') == 'can call asynchronously':
return (
f' (deftest "{safe_name}"\n'
f' (hs-cleanup!)\n'
f' (eval-expr-cek (hs-to-sx (first (hs-parse (hs-tokenize "def foo() wait 1ms log me end")))))\n'
f' (let ((wa (dom-create-element "div"))\n'
f' (b (dom-create-element "div"))\n'
f' (d1 (dom-create-element "div")))\n'
f' (dom-set-attr d1 "id" "d1")\n'
f' (dom-set-attr b "_" "on click call foo() then add .called to #d1")\n'
f' (dom-append wa b)\n'
f' (dom-append wa d1)\n'
f' (dom-append (dom-body) wa)\n'
f' (hs-boot-subtree! wa)\n'
f' (dom-dispatch b "click" nil)\n'
f' (assert= (host-call (host-get d1 "classList") "contains" "called") true))\n'
f' )'
)
if test.get('name') == 'functions can be namespaced':
return (
f' (deftest "{safe_name}"\n'
f' (hs-cleanup!)\n'
f' ;; Manually create utils dict with foo as a callable. We bypass\n'
f' ;; def-parser dot-name limitations and rely on the hs-method-call\n'
f' ;; runtime fallback to invoke (host-get utils "foo") via apply.\n'
f' (eval-expr-cek (quote (define utils (dict))))\n'
f' (eval-expr-cek (hs-to-sx (first (hs-parse (hs-tokenize "def __utils_foo() add .called to #d1 end")))))\n'
f' (eval-expr-cek (quote (host-set! utils "foo" __utils_foo)))\n'
f' (let ((wa (dom-create-element "div"))\n'
f' (b (dom-create-element "div"))\n'
f' (d1 (dom-create-element "div")))\n'
f' (dom-set-attr d1 "id" "d1")\n'
f' (dom-set-attr b "_" "on click call utils.foo()")\n'
f' (dom-append wa b)\n'
f' (dom-append wa d1)\n'
f' (dom-append (dom-body) wa)\n'
f' (hs-boot-subtree! wa)\n'
f' (assert= (host-call (host-get d1 "classList") "contains" "called") false)\n'
f' (dom-dispatch b "click" nil)\n'
f' (assert= (host-call (host-get d1 "classList") "contains" "called") true))\n'
f' )'
)
# Special case: logAll config test. Body sets `_hyperscript.config.logAll = true`, # Special case: logAll config test. Body sets `_hyperscript.config.logAll = true`,
# then mutates an element's innerHTML and calls `_hyperscript.processNode`. # then mutates an element's innerHTML and calls `_hyperscript.processNode`.
# Our runtime exposes this via hs-set-log-all! + hs-log-captured; we reuse # Our runtime exposes this via hs-set-log-all! + hs-log-captured; we reuse
@@ -2496,6 +2333,25 @@ def generate_eval_only_test(test, idx):
hs_expr = extract_hs_expr(m.group(2)) hs_expr = extract_hs_expr(m.group(2))
assertions.append(f' (assert-throws (eval-hs "{hs_expr}"))') assertions.append(f' (assert-throws (eval-hs "{hs_expr}"))')
# Pattern 4: eval-hs-error — expect(await error("expr")).toBe("msg")
# These test that running HS raises an error with a specific message string.
for m in re.finditer(
r'(?:const\s+\w+\s*=\s*)?(?:await\s+)?error\((["\x27`])(.+?)\1\)'
r'(?:[^;]|\n)*?(?:expect\([^)]*\)\.toBe\(([^)]+)\)|\.toBe\(([^)]+)\))',
body, re.DOTALL
):
hs_expr = extract_hs_expr(m.group(2))
expected_raw = (m.group(3) or m.group(4) or '').strip()
# Strip only the outermost JS string delimiter (double or single quote)
# without touching inner quotes inside the string value.
if len(expected_raw) >= 2 and expected_raw[0] == expected_raw[-1] and expected_raw[0] in ('"', "'"):
inner = expected_raw[1:-1]
expected_sx = '"' + inner.replace('\\', '\\\\').replace('"', '\\"') + '"'
else:
expected_sx = js_val_to_sx(expected_raw)
hs_escaped = hs_expr.replace('\\', '\\\\').replace('"', '\\"')
assertions.append(f' (assert= (eval-hs-error "{hs_escaped}") {expected_sx})')
if not assertions: if not assertions:
return None # Can't convert this body pattern return None # Can't convert this body pattern
@@ -2775,7 +2631,6 @@ output.append(';; Bind `window` and `document` as plain SX symbols so HS code th
output.append(';; references them (e.g. `window.tmp`) can resolve through the host.') output.append(';; references them (e.g. `window.tmp`) can resolve through the host.')
output.append('(define window (host-global "window"))') output.append('(define window (host-global "window"))')
output.append('(define document (host-global "document"))') output.append('(define document (host-global "document"))')
output.append('(define cookies (host-global "cookies"))')
output.append('') output.append('')
output.append('(define hs-test-el') output.append('(define hs-test-el')
output.append(' (fn (tag hs-src)') output.append(' (fn (tag hs-src)')
@@ -2787,11 +2642,7 @@ output.append(' el)))')
output.append('') output.append('')
output.append('(define hs-cleanup!') output.append('(define hs-cleanup!')
output.append(' (fn ()') output.append(' (fn ()')
output.append(' (begin') output.append(' (dom-set-inner-html (dom-body) "")))')
output.append(' (dom-set-inner-html (dom-body) "")')
output.append(' ;; Reset global runtime state that prior tests may have set.')
output.append(' (hs-set-default-hide-strategy! nil)')
output.append(' (hs-set-log-all! false))))')
output.append('') output.append('')
output.append(';; Evaluate a hyperscript expression and return either the expression') output.append(';; Evaluate a hyperscript expression and return either the expression')
output.append(';; value or `it` (whichever is non-nil). Multi-statement scripts that') output.append(';; value or `it` (whichever is non-nil). Multi-statement scripts that')
@@ -2860,6 +2711,27 @@ output.append(' (nth _e 1)')
output.append(' (raise _e))))') output.append(' (raise _e))))')
output.append(' (handler me-val))))))') output.append(' (handler me-val))))))')
output.append('') output.append('')
output.append(';; Evaluate a hyperscript expression, catch the first error raised, and')
output.append(';; return its message string. Used by runtimeErrors tests.')
output.append(';; Returns nil if no error is raised (test would then fail equality).')
output.append('(define eval-hs-error')
output.append(' (fn (src)')
output.append(' (let ((sx (hs-to-sx (hs-compile src))))')
output.append(' (let ((handler (eval-expr-cek')
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(' (_e')
output.append(' (true')
output.append(' (if')
output.append(' (string? _e)')
output.append(' _e')
output.append(' (if')
output.append(' (and (list? _e) (= (first _e) "hs-return"))')
output.append(' nil')
output.append(' (str _e)))))')
output.append(' (begin (handler nil) nil))))))')
output.append('')
# Group by category # Group by category
categories = OrderedDict() categories = OrderedDict()