Step 18 (part 4): _hyperscript compiler — AST → SX expressions

lib/hyperscript/compiler.sx — transforms parsed hyperscript AST into
SX expressions targeting web/lib/dom.sx primitives. Two entry points:
  hs-to-sx    — AST node → SX expression
  hs-to-sx-from-source — source string → SX (tokenize+parse+emit)

Compiler handles:
  Expressions: me/it/event, refs, queries, attrs, styles, locals,
    arithmetic, comparison, boolean, array literals, property access,
    DOM traversal (closest/next/previous/first/last), type conversion,
    membership test, exists/empty/matches/contains predicates
  Commands: add/remove/toggle class, set (var/attr/style/prop dispatch),
    put, if/else, do, wait, wait-for, log, send, trigger, hide, show,
    transition, repeat, fetch, call, return, throw, settle, go, append,
    tell (rebinds me), for, take, make, install, measure, inc/dec
  Features: on (with from/filter/every), init, def, behavior

Maps to SX primitives: dom-add-class, dom-set-attr, dom-set-style,
dom-set-prop, dom-query, dom-closest, dom-dispatch, dom-append, etc.

33 compiler tests across 10 suites. 3076/3076 full build, zero regressions.

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
2026-04-06 08:31:32 +00:00
parent f1ba7177e7
commit c5d2fa8c96
3 changed files with 773 additions and 0 deletions

530
lib/hyperscript/compiler.sx Normal file
View File

@@ -0,0 +1,530 @@
;; _hyperscript compiler — AST → SX expressions
;;
;; Input: AST from hs-parse (list structures)
;; Output: SX expressions targeting web/lib/dom.sx primitives
;;
;; Usage:
;; (hs-to-sx (hs-compile "on click add .active to me"))
;; → (hs-on me "click" (fn (event) (dom-add-class me "active")))
(define
hs-to-sx
(let
((dot-sym (make-symbol ".")) (pct-sym (make-symbol "%")))
(define emit-target (fn (ast) (hs-to-sx ast)))
(define
emit-set
(fn
(target value)
(if
(not (list? target))
(list (quote set!) target value)
(let
((th (first target)))
(cond
((= th dot-sym)
(list
(quote dom-set-prop)
(hs-to-sx (nth target 1))
(nth target 2)
value))
((= th (quote attr))
(list
(quote dom-set-attr)
(hs-to-sx (nth target 2))
(nth target 1)
value))
((= th (quote style))
(list
(quote dom-set-style)
(hs-to-sx (nth target 2))
(nth target 1)
value))
((= th (quote ref))
(list (quote set!) (make-symbol (nth target 1)) value))
((= th (quote local))
(list (quote set!) (make-symbol (nth target 1)) value))
((= th (quote me))
(list (quote dom-set-inner-html) (quote me) value))
((= th (quote it)) (list (quote set!) (quote it) value))
(true (list (quote set!) (hs-to-sx target) value)))))))
(define
emit-on
(fn
(ast)
(let
((parts (rest ast)))
(let
((event-name (first parts)))
(define
scan-on
(fn
(items source filter every?)
(cond
((<= (len items) 1)
(let
((body (if (> (len items) 0) (first items) nil)))
(let
((target (if source (hs-to-sx source) (quote me))))
(let
((handler (list (quote fn) (list (quote event)) (hs-to-sx body))))
(if
every?
(list
(quote hs-on-every)
target
event-name
handler)
(list (quote hs-on) target event-name handler))))))
((= (first items) :from)
(scan-on
(rest (rest items))
(nth items 1)
filter
every?))
((= (first items) :filter)
(scan-on
(rest (rest items))
source
(nth items 1)
every?))
((= (first items) :every)
(scan-on (rest (rest items)) source filter true))
(true (scan-on (rest items) source filter every?)))))
(scan-on (rest parts) nil nil false)))))
(define
emit-send
(fn
(ast)
(let
((name (nth ast 1)) (rest-parts (rest (rest ast))))
(cond
((and (= (len ast) 4) (list? (nth ast 2)) (= (first (nth ast 2)) (quote dict)))
(list
(quote dom-dispatch)
(hs-to-sx (nth ast 3))
name
(hs-to-sx (nth ast 2))))
((= (len ast) 3)
(list (quote dom-dispatch) (hs-to-sx (nth ast 2)) name nil))
(true (list (quote dom-dispatch) (quote me) name nil))))))
(define
emit-repeat
(fn
(ast)
(let
((mode (nth ast 1)) (body (hs-to-sx (nth ast 2))))
(cond
((and (list? mode) (= (first mode) (quote forever)))
(list
(quote hs-repeat-forever)
(list (quote fn) (list) body)))
((and (list? mode) (= (first mode) (quote times)))
(list
(quote hs-repeat-times)
(hs-to-sx (nth mode 1))
(list (quote fn) (list) body)))
((number? mode)
(list
(quote hs-repeat-times)
mode
(list (quote fn) (list) body)))
(true
(list
(quote hs-repeat-times)
(hs-to-sx mode)
(list (quote fn) (list) body)))))))
(define
emit-for
(fn
(ast)
(let
((var-name (nth ast 1))
(collection (hs-to-sx (nth ast 2)))
(body (hs-to-sx (nth ast 3))))
(if
(and (> (len ast) 4) (= (nth ast 4) :index))
(list
(quote for-each)
(list
(quote fn)
(list (make-symbol var-name) (make-symbol (nth ast 5)))
body)
collection)
(list
(quote for-each)
(list (quote fn) (list (make-symbol var-name)) body)
collection)))))
(define
emit-wait-for
(fn
(ast)
(let
((event-name (nth ast 1)))
(if
(and (> (len ast) 2) (= (nth ast 2) :from))
(list (quote hs-wait-for) (hs-to-sx (nth ast 3)) event-name)
(list (quote hs-wait-for) (quote me) event-name)))))
(define
emit-transition
(fn
(ast)
(let
((prop (nth ast 1)) (value (hs-to-sx (nth ast 2))))
(if
(= (len ast) 5)
(list
(quote hs-transition)
(hs-to-sx (nth ast 4))
prop
value
(nth ast 3))
(list
(quote hs-transition)
(hs-to-sx (nth ast 3))
prop
value
nil)))))
(define
emit-make
(fn
(ast)
(if
(= (len ast) 3)
(list
(quote let)
(list
(list
(make-symbol (nth ast 2))
(list (quote hs-make) (nth ast 1))))
(make-symbol (nth ast 2)))
(list (quote hs-make) (nth ast 1)))))
(define
emit-inc
(fn
(target)
(let
((t (hs-to-sx target)))
(if
(and (list? target) (= (first target) (quote attr)))
(list
(quote dom-set-attr)
(hs-to-sx (nth target 2))
(nth target 1)
(list
(quote +)
(list
(quote dom-get-attr)
(hs-to-sx (nth target 2))
(nth target 1))
1))
(list (quote set!) t (list (quote +) t 1))))))
(define
emit-dec
(fn
(target)
(let
((t (hs-to-sx target)))
(if
(and (list? target) (= (first target) (quote attr)))
(list
(quote dom-set-attr)
(hs-to-sx (nth target 2))
(nth target 1)
(list
(quote -)
(list
(quote dom-get-attr)
(hs-to-sx (nth target 2))
(nth target 1))
1))
(list (quote set!) t (list (quote -) t 1))))))
(define
emit-behavior
(fn
(ast)
(let
((name (nth ast 1)) (params (nth ast 2)) (body (nth ast 3)))
(list
(quote define)
(make-symbol name)
(list
(quote fn)
(cons (quote me) (map make-symbol params))
(cons (quote do) (map hs-to-sx body)))))))
(fn
(ast)
(cond
((nil? ast) nil)
((number? ast) ast)
((string? ast) ast)
((boolean? ast) ast)
((not (list? ast)) ast)
(true
(let
((head (first ast)))
(cond
((= head (quote me)) (quote me))
((= head (quote it)) (quote it))
((= head (quote event)) (quote event))
((= head dot-sym)
(list (quote get) (hs-to-sx (nth ast 1)) (nth ast 2)))
((= head (quote ref)) (make-symbol (nth ast 1)))
((= head (quote query))
(list (quote dom-query) (nth ast 1)))
((= head (quote attr))
(list
(quote dom-get-attr)
(hs-to-sx (nth ast 2))
(nth ast 1)))
((= head (quote style))
(list
(quote dom-get-style)
(hs-to-sx (nth ast 2))
(nth ast 1)))
((= head (quote local)) (make-symbol (nth ast 1)))
((= head (quote array))
(cons (quote list) (map hs-to-sx (rest ast))))
((= head (quote not))
(list (quote not) (hs-to-sx (nth ast 1))))
((= head (quote no))
(list (quote not) (hs-to-sx (nth ast 1))))
((= head (quote and))
(list
(quote and)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote or))
(list
(quote or)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote =))
(list
(quote =)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote +))
(list
(quote +)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote -))
(list
(quote -)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote *))
(list
(quote *)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote /))
(list
(quote /)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head pct-sym)
(list
pct-sym
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote empty?))
(list (quote empty?) (hs-to-sx (nth ast 1))))
((= head (quote exists?))
(list
(quote not)
(list (quote nil?) (hs-to-sx (nth ast 1)))))
((= head (quote matches?))
(list
(quote dom-matches?)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote contains?))
(list
(quote contains?)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote as))
(list (quote hs-coerce) (hs-to-sx (nth ast 1)) (nth ast 2)))
((= head (quote in?))
(list
(quote contains?)
(hs-to-sx (nth ast 2))
(hs-to-sx (nth ast 1))))
((= head (quote of))
(list
(quote get)
(hs-to-sx (nth ast 2))
(hs-to-sx (nth ast 1))))
((= head "!=")
(list
(quote not)
(list
(quote =)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2)))))
((= head "<")
(list
(quote <)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head ">")
(list
(quote >)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head "<=")
(list
(quote <=)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head ">=")
(list
(quote >=)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote closest))
(list
(quote dom-closest)
(hs-to-sx (nth ast 2))
(nth ast 1)))
((= head (quote next))
(list (quote hs-next) (hs-to-sx (nth ast 2)) (nth ast 1)))
((= head (quote previous))
(list
(quote hs-previous)
(hs-to-sx (nth ast 2))
(nth ast 1)))
((= head (quote first))
(if
(> (len ast) 2)
(list
(quote hs-first)
(hs-to-sx (nth ast 2))
(nth ast 1))
(list (quote hs-query-first) (nth ast 1))))
((= head (quote last))
(if
(> (len ast) 2)
(list (quote hs-last) (hs-to-sx (nth ast 2)) (nth ast 1))
(list (quote hs-query-last) (nth ast 1))))
((= head (quote add-class))
(list
(quote dom-add-class)
(hs-to-sx (nth ast 2))
(nth ast 1)))
((= head (quote remove-class))
(list
(quote dom-remove-class)
(hs-to-sx (nth ast 2))
(nth ast 1)))
((= head (quote toggle-class))
(list
(quote hs-toggle-class!)
(hs-to-sx (nth ast 2))
(nth ast 1)))
((= head (quote toggle-between))
(list
(quote hs-toggle-between!)
(hs-to-sx (nth ast 3))
(nth ast 1)
(nth ast 2)))
((= head (quote set!))
(emit-set (nth ast 1) (hs-to-sx (nth ast 2))))
((= head (quote put!))
(list
(quote hs-put!)
(hs-to-sx (nth ast 1))
(nth ast 2)
(hs-to-sx (nth ast 3))))
((= head (quote if))
(if
(> (len ast) 3)
(list
(quote if)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))
(hs-to-sx (nth ast 3)))
(list
(quote when)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2)))))
((= head (quote do))
(cons (quote do) (map hs-to-sx (rest ast))))
((= head (quote wait)) (list (quote hs-wait) (nth ast 1)))
((= head (quote wait-for)) (emit-wait-for ast))
((= head (quote log))
(list (quote log) (hs-to-sx (nth ast 1))))
((= head (quote send)) (emit-send ast))
((= head (quote trigger))
(list
(quote dom-dispatch)
(hs-to-sx (nth ast 2))
(nth ast 1)
nil))
((= head (quote hide))
(list
(quote dom-set-style)
(hs-to-sx (nth ast 1))
"display"
"none"))
((= head (quote show))
(list
(quote dom-set-style)
(hs-to-sx (nth ast 1))
"display"
""))
((= head (quote transition)) (emit-transition ast))
((= head (quote repeat)) (emit-repeat ast))
((= head (quote fetch))
(list (quote hs-fetch) (hs-to-sx (nth ast 1)) (nth ast 2)))
((= head (quote call))
(cons
(make-symbol (nth ast 1))
(map hs-to-sx (rest (rest ast)))))
((= head (quote return)) (hs-to-sx (nth ast 1)))
((= head (quote throw))
(list (quote raise) (hs-to-sx (nth ast 1))))
((= head (quote settle))
(list (quote hs-settle) (quote me)))
((= head (quote go))
(list (quote hs-navigate!) (hs-to-sx (nth ast 1))))
((= head (quote append!))
(list
(quote dom-append)
(hs-to-sx (nth ast 2))
(hs-to-sx (nth ast 1))))
((= head (quote tell))
(list
(quote let)
(list (list (quote me) (hs-to-sx (nth ast 1))))
(hs-to-sx (nth ast 2))))
((= head (quote for)) (emit-for ast))
((= head (quote take))
(list (quote hs-take!) (hs-to-sx (nth ast 2)) (nth ast 1)))
((= head (quote make)) (emit-make ast))
((= head (quote install))
(cons (quote hs-install) (map hs-to-sx (rest ast))))
((= head (quote measure))
(list (quote hs-measure) (hs-to-sx (nth ast 1))))
((= head (quote increment!)) (emit-inc (nth ast 1)))
((= head (quote decrement!)) (emit-dec (nth ast 1)))
((= head (quote on)) (emit-on ast))
((= head (quote init))
(list
(quote hs-init)
(list (quote fn) (list) (hs-to-sx (nth ast 1)))))
((= head (quote def))
(list
(quote define)
(make-symbol (nth ast 1))
(list
(quote fn)
(map make-symbol (nth ast 2))
(hs-to-sx (nth ast 3)))))
((= head (quote behavior)) (emit-behavior ast))
(true ast))))))))
;; ── Convenience: source → SX ─────────────────────────────────
(define hs-to-sx-from-source (fn (src) (hs-to-sx (hs-compile src))))