giles
e5e3e90ee7
Adds attribute reference case to the 'of' branch in emit-set: (set @bar of #div2 to "foo") now compiles to (dom-set-attr target "bar" "foo") instead of falling through to the broken (set! (host-get ...)) catchall. 417/831 (50.2%), +2 from attr-of fix. Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
1168 lines
44 KiB
Plaintext
1168 lines
44 KiB
Plaintext
;; _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))
|
|
((= th (quote query))
|
|
(list (quote dom-set-inner-html) (hs-to-sx target) value))
|
|
((= th (quote array-index))
|
|
(list
|
|
(quote host-set!)
|
|
(hs-to-sx (nth target 1))
|
|
(hs-to-sx (nth target 2))
|
|
value))
|
|
((= th (quote of))
|
|
;; Decompose (of prop-expr target) into a set operation
|
|
;; e.g. (of (. (ref "parentNode") "innerHTML") (query "#d1"))
|
|
;; → set parentNode.innerHTML of #d1 → need to navigate target, then set final prop
|
|
(let ((prop-ast (nth target 1))
|
|
(obj-ast (nth target 2)))
|
|
(if (and (list? prop-ast) (= (first prop-ast) dot-sym))
|
|
;; (. base "prop") of obj → (dom-set-prop (host-get (compiled-obj) (compiled-base-name)) "prop" value)
|
|
(let ((base (nth prop-ast 1))
|
|
(prop-name (nth prop-ast 2)))
|
|
(list (quote dom-set-prop)
|
|
(list (quote host-get) (hs-to-sx obj-ast) (nth base 1))
|
|
prop-name
|
|
value))
|
|
;; (attr "name") of obj → (dom-set-attr (compiled-obj) "name" value)
|
|
(if (and (list? prop-ast) (= (first prop-ast) (quote attr)))
|
|
(list (quote dom-set-attr)
|
|
(hs-to-sx obj-ast)
|
|
(nth prop-ast 1)
|
|
value)
|
|
;; Simple: (ref "prop") of obj → (dom-set-prop (compiled-obj) "prop" value)
|
|
(if (and (list? prop-ast) (= (first prop-ast) (quote ref)))
|
|
(list (quote dom-set-prop)
|
|
(hs-to-sx obj-ast)
|
|
(nth prop-ast 1)
|
|
value)
|
|
;; Fallback
|
|
(list (quote set!) (hs-to-sx target) 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? catch-info finally-info)
|
|
(cond
|
|
((<= (len items) 1)
|
|
(let
|
|
((body (if (> (len items) 0) (first items) nil)))
|
|
(let
|
|
((target (if source (hs-to-sx source) (quote me))))
|
|
(let
|
|
((compiled-body (hs-to-sx body))
|
|
(wrapped-body
|
|
(if
|
|
catch-info
|
|
(let
|
|
((var (make-symbol (first catch-info)))
|
|
(catch-body
|
|
(hs-to-sx (nth catch-info 1))))
|
|
(if
|
|
finally-info
|
|
(list
|
|
(quote do)
|
|
(list
|
|
(quote guard)
|
|
(list var (list true catch-body))
|
|
compiled-body)
|
|
(hs-to-sx finally-info))
|
|
(list
|
|
(quote guard)
|
|
(list var (list true catch-body))
|
|
compiled-body)))
|
|
(if
|
|
finally-info
|
|
(list
|
|
(quote do)
|
|
compiled-body
|
|
(hs-to-sx finally-info))
|
|
compiled-body)))
|
|
(handler
|
|
(list
|
|
(quote fn)
|
|
(list (quote event))
|
|
wrapped-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?
|
|
catch-info
|
|
finally-info))
|
|
((= (first items) :filter)
|
|
(scan-on
|
|
(rest (rest items))
|
|
source
|
|
(nth items 1)
|
|
every?
|
|
catch-info
|
|
finally-info))
|
|
((= (first items) :every)
|
|
(scan-on
|
|
(rest (rest items))
|
|
source
|
|
filter
|
|
true
|
|
catch-info
|
|
finally-info))
|
|
((= (first items) :catch)
|
|
(scan-on
|
|
(rest (rest items))
|
|
source
|
|
filter
|
|
every?
|
|
(nth items 1)
|
|
finally-info))
|
|
((= (first items) :finally)
|
|
(scan-on
|
|
(rest (rest items))
|
|
source
|
|
filter
|
|
every?
|
|
catch-info
|
|
(nth items 1)))
|
|
(true
|
|
(scan-on
|
|
(rest items)
|
|
source
|
|
filter
|
|
every?
|
|
catch-info
|
|
finally-info)))))
|
|
(scan-on (rest parts) nil nil false nil nil)))))
|
|
(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 (hs-to-sx (nth ast 1)))
|
|
(value (hs-to-sx (nth ast 2)))
|
|
(dur (nth ast 3))
|
|
(raw-tgt (nth ast 4)))
|
|
(list
|
|
(quote hs-transition)
|
|
(if (nil? raw-tgt) (quote me) (hs-to-sx raw-tgt))
|
|
prop
|
|
value
|
|
(if dur (hs-to-sx dur) 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
|
|
(expr amount tgt-override)
|
|
(cond
|
|
((and (list? expr) (= (first expr) (quote attr)))
|
|
(let
|
|
((el (if tgt-override (hs-to-sx tgt-override) (quote me))))
|
|
(list
|
|
(quote dom-set-attr)
|
|
el
|
|
(nth expr 1)
|
|
(list
|
|
(quote +)
|
|
(list
|
|
(quote parse-number)
|
|
(list (quote dom-get-attr) el (nth expr 1)))
|
|
amount))))
|
|
((and (list? expr) (= (first expr) dot-sym))
|
|
(let
|
|
((obj (hs-to-sx (nth expr 1))) (prop (nth expr 2)))
|
|
(list
|
|
(quote host-set!)
|
|
obj
|
|
prop
|
|
(list
|
|
(quote +)
|
|
(list
|
|
(quote parse-number)
|
|
(list (quote host-get) obj prop))
|
|
amount))))
|
|
((and (list? expr) (= (first expr) (quote style)))
|
|
(let
|
|
((el (if tgt-override (hs-to-sx tgt-override) (quote me)))
|
|
(prop (nth expr 1)))
|
|
(list
|
|
(quote dom-set-style)
|
|
el
|
|
prop
|
|
(list
|
|
(quote +)
|
|
(list
|
|
(quote parse-number)
|
|
(list (quote dom-get-style) el prop))
|
|
amount))))
|
|
(true
|
|
(let
|
|
((t (hs-to-sx expr)))
|
|
(list
|
|
(quote set!)
|
|
t
|
|
(list (quote +) (list (quote or) t 0) amount)))))))
|
|
(define
|
|
emit-dec
|
|
(fn
|
|
(expr amount tgt-override)
|
|
(cond
|
|
((and (list? expr) (= (first expr) (quote attr)))
|
|
(let
|
|
((el (if tgt-override (hs-to-sx tgt-override) (quote me))))
|
|
(list
|
|
(quote dom-set-attr)
|
|
el
|
|
(nth expr 1)
|
|
(list
|
|
(quote -)
|
|
(list
|
|
(quote parse-number)
|
|
(list (quote dom-get-attr) el (nth expr 1)))
|
|
amount))))
|
|
((and (list? expr) (= (first expr) dot-sym))
|
|
(let
|
|
((obj (hs-to-sx (nth expr 1))) (prop (nth expr 2)))
|
|
(list
|
|
(quote host-set!)
|
|
obj
|
|
prop
|
|
(list
|
|
(quote -)
|
|
(list
|
|
(quote parse-number)
|
|
(list (quote host-get) obj prop))
|
|
amount))))
|
|
((and (list? expr) (= (first expr) (quote style)))
|
|
(let
|
|
((el (if tgt-override (hs-to-sx tgt-override) (quote me)))
|
|
(prop (nth expr 1)))
|
|
(list
|
|
(quote dom-set-style)
|
|
el
|
|
prop
|
|
(list
|
|
(quote -)
|
|
(list
|
|
(quote parse-number)
|
|
(list (quote dom-get-style) el prop))
|
|
amount))))
|
|
(true
|
|
(let
|
|
((t (hs-to-sx expr)))
|
|
(list
|
|
(quote set!)
|
|
t
|
|
(list (quote -) (list (quote or) t 0) amount)))))))
|
|
(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 null-literal)) nil)
|
|
((= head (quote not))
|
|
(list (quote not) (hs-to-sx (nth ast 1))))
|
|
((or (= head (quote starts-with?)) (= head (quote ends-with?)) (= head (quote contains?)) (= head (quote matches?)) (= head (quote precedes?)) (= head (quote follows?)) (= head (quote exists?)))
|
|
(cons head (map hs-to-sx (rest ast))))
|
|
((= head (quote object-literal))
|
|
(let
|
|
((pairs (nth ast 1)))
|
|
(if
|
|
(= (len pairs) 0)
|
|
(list (quote dict))
|
|
(cons
|
|
(quote hs-make-object)
|
|
(list
|
|
(cons
|
|
(quote list)
|
|
(map
|
|
(fn
|
|
(pair)
|
|
(list
|
|
(quote list)
|
|
(first pair)
|
|
(hs-to-sx (nth pair 1))))
|
|
pairs)))))))
|
|
((= head (quote template))
|
|
(let
|
|
((raw (nth ast 1)))
|
|
(let
|
|
((parts (list)) (buf "") (i 0) (n (len raw)))
|
|
(define
|
|
tpl-flush
|
|
(fn
|
|
()
|
|
(when
|
|
(> (len buf) 0)
|
|
(set! parts (append parts (list buf)))
|
|
(set! buf ""))))
|
|
(define
|
|
tpl-read-id
|
|
(fn
|
|
(j)
|
|
(if
|
|
(and
|
|
(< j n)
|
|
(let
|
|
((c (nth raw j)))
|
|
(or
|
|
(and (>= c "a") (<= c "z"))
|
|
(and (>= c "A") (<= c "Z"))
|
|
(and (>= c "0") (<= c "9"))
|
|
(= c "_")
|
|
(= c "."))))
|
|
(tpl-read-id (+ j 1))
|
|
j)))
|
|
(define
|
|
tpl-find-close
|
|
(fn
|
|
(j depth)
|
|
(if
|
|
(>= j n)
|
|
j
|
|
(if
|
|
(= (nth raw j) "}")
|
|
(if
|
|
(= depth 1)
|
|
j
|
|
(tpl-find-close (+ j 1) (- depth 1)))
|
|
(if
|
|
(= (nth raw j) "{")
|
|
(tpl-find-close (+ j 1) (+ depth 1))
|
|
(tpl-find-close (+ j 1) depth))))))
|
|
(define
|
|
tpl-collect
|
|
(fn
|
|
()
|
|
(when
|
|
(< i n)
|
|
(let
|
|
((ch (nth raw i)))
|
|
(if
|
|
(and (= ch "$") (< (+ i 1) n))
|
|
(if
|
|
(= (nth raw (+ i 1)) "{")
|
|
(let
|
|
((start (+ i 2)))
|
|
(let
|
|
((close (tpl-find-close start 1)))
|
|
(let
|
|
((expr-src (slice raw start close)))
|
|
(do
|
|
(tpl-flush)
|
|
(set!
|
|
parts
|
|
(append
|
|
parts
|
|
(list
|
|
(hs-to-sx (hs-compile expr-src)))))
|
|
(set! i (+ close 1))
|
|
(tpl-collect)))))
|
|
(let
|
|
((start (+ i 1)))
|
|
(let
|
|
((end (tpl-read-id start)))
|
|
(let
|
|
((ident (slice raw start end)))
|
|
(do
|
|
(tpl-flush)
|
|
(set!
|
|
parts
|
|
(append
|
|
parts
|
|
(list
|
|
(hs-to-sx (hs-compile ident)))))
|
|
(set! i end)
|
|
(tpl-collect))))))
|
|
(do
|
|
(set! buf (str buf ch))
|
|
(set! i (+ i 1))
|
|
(tpl-collect)))))))
|
|
(tpl-collect)
|
|
(tpl-flush)
|
|
(cons (quote str) parts))))
|
|
((= head (quote beep!))
|
|
(list (quote hs-beep) (hs-to-sx (nth ast 1))))
|
|
((= head (quote array-index))
|
|
(list
|
|
(quote nth)
|
|
(hs-to-sx (nth ast 1))
|
|
(hs-to-sx (nth ast 2))))
|
|
((= head (quote array-slice))
|
|
(list
|
|
(quote hs-slice)
|
|
(hs-to-sx (nth ast 1))
|
|
(hs-to-sx (nth ast 2))
|
|
(hs-to-sx (nth ast 3))))
|
|
((= head (quote prop-is))
|
|
(list
|
|
(quote hs-prop-is)
|
|
(hs-to-sx (nth ast 1))
|
|
(nth ast 2)))
|
|
((= head (quote coll-where))
|
|
(list
|
|
(quote filter)
|
|
(list
|
|
(quote fn)
|
|
(list (quote it))
|
|
(hs-to-sx (nth ast 2)))
|
|
(hs-to-sx (nth ast 1))))
|
|
((= head (quote coll-sorted))
|
|
(list
|
|
(quote hs-sorted-by)
|
|
(hs-to-sx (nth ast 1))
|
|
(list
|
|
(quote fn)
|
|
(list (quote it))
|
|
(hs-to-sx (nth ast 2)))))
|
|
((= head (quote coll-sorted-desc))
|
|
(list
|
|
(quote hs-sorted-by-desc)
|
|
(hs-to-sx (nth ast 1))
|
|
(list
|
|
(quote fn)
|
|
(list (quote it))
|
|
(hs-to-sx (nth ast 2)))))
|
|
((= head (quote coll-mapped))
|
|
(list
|
|
(quote map)
|
|
(list
|
|
(quote fn)
|
|
(list (quote it))
|
|
(hs-to-sx (nth ast 2)))
|
|
(hs-to-sx (nth ast 1))))
|
|
((= head (quote coll-split))
|
|
(list
|
|
(quote hs-split-by)
|
|
(hs-to-sx (nth ast 1))
|
|
(hs-to-sx (nth ast 2))))
|
|
((= head (quote coll-joined))
|
|
(list
|
|
(quote hs-joined-by)
|
|
(hs-to-sx (nth ast 1))
|
|
(hs-to-sx (nth ast 2))))
|
|
((= head (quote method-call))
|
|
(let
|
|
((dot-node (nth ast 1))
|
|
(args (map hs-to-sx (nth ast 2))))
|
|
(if
|
|
(and
|
|
(list? dot-node)
|
|
(= (first dot-node) (make-symbol ".")))
|
|
(let
|
|
((obj (hs-to-sx (nth dot-node 1)))
|
|
(method (nth dot-node 2)))
|
|
(cons
|
|
(quote hs-method-call)
|
|
(cons obj (cons method args))))
|
|
(cons
|
|
(quote hs-method-call)
|
|
(cons (hs-to-sx dot-node) args)))))
|
|
((= head (quote string-postfix))
|
|
(list (quote str) (hs-to-sx (nth ast 1)) (nth ast 2)))
|
|
((= head (quote block-literal))
|
|
(let
|
|
((params (map make-symbol (nth ast 1)))
|
|
(body (hs-to-sx (nth ast 2))))
|
|
(if
|
|
(= (len params) 0)
|
|
body
|
|
(list (quote fn) params body))))
|
|
((= head (quote me)) (quote me))
|
|
((= head (quote it)) (quote it))
|
|
((= head (quote event)) (quote event))
|
|
((= head dot-sym)
|
|
(let
|
|
((target (hs-to-sx (nth ast 1))) (prop (nth ast 2)))
|
|
(cond
|
|
((= prop "first") (list (quote hs-first) target))
|
|
((= prop "last") (list (quote hs-last) target))
|
|
(true (list (quote host-get) target prop)))))
|
|
((= head (quote ref)) (make-symbol (nth ast 1)))
|
|
((= head (quote query))
|
|
(list (quote hs-query-first) (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 hs-falsy?) (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-add)
|
|
(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)
|
|
(if
|
|
(nil? (nth ast 2))
|
|
(list (quote str) (hs-to-sx (nth ast 1)) "%")
|
|
(list
|
|
(quote modulo)
|
|
(hs-to-sx (nth ast 1))
|
|
(hs-to-sx (nth ast 2)))))
|
|
((= head (quote empty?))
|
|
(list (quote hs-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 hs-matches?)
|
|
(hs-to-sx (nth ast 1))
|
|
(hs-to-sx (nth ast 2))))
|
|
((= head (quote matches-ignore-case?))
|
|
(list
|
|
(quote hs-matches-ignore-case?)
|
|
(hs-to-sx (nth ast 1))
|
|
(hs-to-sx (nth ast 2))))
|
|
((= head (quote contains?))
|
|
(list
|
|
(quote hs-contains?)
|
|
(hs-to-sx (nth ast 1))
|
|
(hs-to-sx (nth ast 2))))
|
|
((= head (quote contains-ignore-case?))
|
|
(list
|
|
(quote hs-contains-ignore-case?)
|
|
(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 hs-contains?)
|
|
(hs-to-sx (nth ast 2))
|
|
(hs-to-sx (nth ast 1))))
|
|
((= head (quote of))
|
|
(let
|
|
((prop (hs-to-sx (nth ast 1)))
|
|
(target (hs-to-sx (nth ast 2))))
|
|
(cond
|
|
((= prop (quote first)) (list (quote first) target))
|
|
((= prop (quote last)) (list (quote last) target))
|
|
(true (list (quote host-get) target prop)))))
|
|
((= 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))
|
|
(let
|
|
((raw-tgt (nth ast 2)))
|
|
(if
|
|
(and (list? raw-tgt) (= (first raw-tgt) (quote query)))
|
|
(list
|
|
(quote for-each)
|
|
(list
|
|
(quote fn)
|
|
(list (quote _el))
|
|
(list (quote dom-add-class) (quote _el) (nth ast 1)))
|
|
(list (quote hs-query-all) (nth raw-tgt 1)))
|
|
(list
|
|
(quote dom-add-class)
|
|
(hs-to-sx raw-tgt)
|
|
(nth ast 1)))))
|
|
((= head (quote multi-add-class))
|
|
(let
|
|
((target (hs-to-sx (nth ast 1)))
|
|
(classes (rest (rest ast))))
|
|
(cons
|
|
(quote do)
|
|
(map
|
|
(fn (cls) (list (quote dom-add-class) target cls))
|
|
classes))))
|
|
((= head (quote multi-remove-class))
|
|
(let
|
|
((target (hs-to-sx (nth ast 1)))
|
|
(classes (rest (rest ast))))
|
|
(cons
|
|
(quote do)
|
|
(map
|
|
(fn (cls) (list (quote dom-remove-class) target cls))
|
|
classes))))
|
|
((= head (quote remove-class))
|
|
(let
|
|
((raw-tgt (nth ast 2)))
|
|
(if
|
|
(and (list? raw-tgt) (= (first raw-tgt) (quote query)))
|
|
(list
|
|
(quote for-each)
|
|
(list
|
|
(quote fn)
|
|
(list (quote _el))
|
|
(list
|
|
(quote dom-remove-class)
|
|
(quote _el)
|
|
(nth ast 1)))
|
|
(list (quote hs-query-all) (nth raw-tgt 1)))
|
|
(list
|
|
(quote dom-remove-class)
|
|
(if (nil? raw-tgt) (quote me) (hs-to-sx raw-tgt))
|
|
(nth ast 1)))))
|
|
((= head (quote remove-element))
|
|
(list (quote dom-remove) (hs-to-sx (nth ast 1))))
|
|
((= head (quote empty-target))
|
|
(list (quote hs-empty-target!) (hs-to-sx (nth ast 1))))
|
|
((= head (quote open-element))
|
|
(list (quote hs-open!) (hs-to-sx (nth ast 1))))
|
|
((= head (quote close-element))
|
|
(list (quote hs-close!) (hs-to-sx (nth ast 1))))
|
|
((= head (quote swap!))
|
|
(let
|
|
((lhs (nth ast 1)) (rhs (nth ast 2)))
|
|
(list
|
|
(quote let)
|
|
(list (list (quote _swap_tmp) (hs-to-sx lhs)))
|
|
(list
|
|
(quote do)
|
|
(emit-set lhs (hs-to-sx rhs))
|
|
(emit-set rhs (quote _swap_tmp))))))
|
|
((= head (quote remove-attr))
|
|
(let
|
|
((tgt (if (nil? (nth ast 2)) (quote me) (hs-to-sx (nth ast 2)))))
|
|
(list (quote dom-remove-attr) tgt (nth ast 1))))
|
|
((= head (quote remove-css))
|
|
(let
|
|
((tgt (if (nil? (nth ast 2)) (quote me) (hs-to-sx (nth ast 2))))
|
|
(props (nth ast 1)))
|
|
(cons
|
|
(quote do)
|
|
(map
|
|
(fn (p) (list (quote dom-set-style) tgt p ""))
|
|
props))))
|
|
((= 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 toggle-style))
|
|
(list
|
|
(quote hs-toggle-style!)
|
|
(hs-to-sx (nth ast 2))
|
|
(nth ast 1)))
|
|
((= head (quote toggle-style-between))
|
|
(list
|
|
(quote hs-toggle-style-between!)
|
|
(hs-to-sx (nth ast 4))
|
|
(nth ast 1)
|
|
(hs-to-sx (nth ast 2))
|
|
(hs-to-sx (nth ast 3))))
|
|
((= head (quote toggle-attr))
|
|
(list
|
|
(quote hs-toggle-attr!)
|
|
(hs-to-sx (nth ast 2))
|
|
(nth ast 1)))
|
|
((= head (quote toggle-attr-between))
|
|
(list
|
|
(quote hs-toggle-attr-between!)
|
|
(hs-to-sx (nth ast 4))
|
|
(nth ast 1)
|
|
(hs-to-sx (nth ast 2))
|
|
(hs-to-sx (nth ast 3))))
|
|
((= 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 console-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))
|
|
(let
|
|
((tgt (hs-to-sx (nth ast 1)))
|
|
(strategy (if (> (len ast) 2) (nth ast 2) "display")))
|
|
(list (quote hs-hide!) tgt strategy)))
|
|
((= head (quote show))
|
|
(let
|
|
((tgt (hs-to-sx (nth ast 1)))
|
|
(strategy (if (> (len ast) 2) (nth ast 2) "display")))
|
|
(list (quote hs-show!) tgt strategy)))
|
|
((= head (quote transition)) (emit-transition ast))
|
|
((= head (quote transition-from))
|
|
(let
|
|
((prop (hs-to-sx (nth ast 1)))
|
|
(from-val (hs-to-sx (nth ast 2)))
|
|
(to-val (hs-to-sx (nth ast 3)))
|
|
(dur (nth ast 4))
|
|
(raw-tgt (nth ast 5)))
|
|
(list
|
|
(quote hs-transition-from)
|
|
(if (nil? raw-tgt) (quote me) (hs-to-sx raw-tgt))
|
|
prop
|
|
from-val
|
|
to-val
|
|
(if dur (hs-to-sx dur) nil))))
|
|
((= head (quote repeat)) (emit-repeat ast))
|
|
((= head (quote fetch))
|
|
(list (quote hs-fetch) (hs-to-sx (nth ast 1)) (nth ast 2)))
|
|
((= head (quote fetch-gql))
|
|
(list
|
|
(quote hs-fetch-gql)
|
|
(nth ast 1)
|
|
(if (nth ast 2) (hs-to-sx (nth ast 2)) nil)))
|
|
((= head (quote call))
|
|
(let
|
|
((fn-expr (hs-to-sx (nth ast 1)))
|
|
(args (map hs-to-sx (nth ast 2))))
|
|
(cons fn-expr args)))
|
|
((= 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))
|
|
(let
|
|
((tgt (hs-to-sx (nth ast 1))))
|
|
(list
|
|
(quote let)
|
|
(list
|
|
(list (quote me) tgt)
|
|
(list (quote you) tgt)
|
|
(list (quote yourself) tgt))
|
|
(hs-to-sx (nth ast 2)))))
|
|
((= head (quote for)) (emit-for ast))
|
|
((= head (quote take!))
|
|
(let
|
|
((kind (nth ast 1))
|
|
(name (nth ast 2))
|
|
(from-sel (if (> (len ast) 3) (nth ast 3) nil))
|
|
(for-tgt (if (> (len ast) 4) (nth ast 4) nil)))
|
|
(let
|
|
((target (if for-tgt (hs-to-sx for-tgt) (quote me)))
|
|
(scope
|
|
(cond
|
|
((nil? from-sel) nil)
|
|
((and (list? from-sel) (= (first from-sel) (quote query)))
|
|
(list (quote hs-query-all) (nth from-sel 1)))
|
|
(true (hs-to-sx from-sel)))))
|
|
(list (quote hs-take!) target kind name scope))))
|
|
((= 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)
|
|
(nth ast 2)
|
|
(if (> (len ast) 3) (nth ast 3) nil)))
|
|
((= head (quote decrement!))
|
|
(emit-dec
|
|
(nth ast 1)
|
|
(nth ast 2)
|
|
(if (> (len ast) 3) (nth ast 3) nil)))
|
|
((= 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))
|
|
((= head (quote sx-eval))
|
|
(let
|
|
((src (nth ast 1)))
|
|
(if
|
|
(string? src)
|
|
(first (sx-parse src))
|
|
(list (quote cek-eval) (hs-to-sx src)))))
|
|
((= head (quote component)) (make-symbol (nth ast 1)))
|
|
((= head (quote render))
|
|
(let
|
|
((comp-raw (nth ast 1))
|
|
(kwargs (nth ast 2))
|
|
(pos (if (> (len ast) 3) (nth ast 3) nil))
|
|
(target
|
|
(if (> (len ast) 4) (hs-to-sx (nth ast 4)) nil)))
|
|
(let
|
|
((comp (if (string? comp-raw) (make-symbol comp-raw) (hs-to-sx comp-raw))))
|
|
(define
|
|
emit-kw-pairs
|
|
(fn
|
|
(pairs)
|
|
(if
|
|
(< (len pairs) 2)
|
|
(list)
|
|
(cons
|
|
(make-keyword (first pairs))
|
|
(cons
|
|
(hs-to-sx (nth pairs 1))
|
|
(emit-kw-pairs (rest (rest pairs))))))))
|
|
(let
|
|
((render-call (cons (quote render-to-html) (cons comp (emit-kw-pairs kwargs)))))
|
|
(if
|
|
pos
|
|
(list
|
|
(quote hs-put!)
|
|
render-call
|
|
pos
|
|
(if target target (quote me)))
|
|
render-call)))))
|
|
((= head (quote not-in?))
|
|
(list
|
|
(quote not)
|
|
(list
|
|
(quote hs-contains?)
|
|
(hs-to-sx (nth ast 2))
|
|
(hs-to-sx (nth ast 1)))))
|
|
((= head (quote in?))
|
|
(list
|
|
(quote hs-contains?)
|
|
(hs-to-sx (nth ast 2))
|
|
(hs-to-sx (nth ast 1))))
|
|
((= head (quote type-check))
|
|
(list
|
|
(quote hs-type-check)
|
|
(hs-to-sx (nth ast 1))
|
|
(nth ast 2)))
|
|
((= head (quote type-check-strict))
|
|
(list
|
|
(quote hs-type-check-strict)
|
|
(hs-to-sx (nth ast 1))
|
|
(nth ast 2)))
|
|
((= head (quote strict-eq))
|
|
(list
|
|
(quote hs-strict-eq)
|
|
(hs-to-sx (nth ast 1))
|
|
(hs-to-sx (nth ast 2))))
|
|
((= head (quote eq-ignore-case))
|
|
(list
|
|
(quote hs-eq-ignore-case)
|
|
(hs-to-sx (nth ast 1))
|
|
(hs-to-sx (nth ast 2))))
|
|
((= head (quote some))
|
|
(list
|
|
(quote some)
|
|
(list
|
|
(quote fn)
|
|
(list (make-symbol (nth ast 1)))
|
|
(hs-to-sx (nth ast 3)))
|
|
(hs-to-sx (nth ast 2))))
|
|
((= head (quote every))
|
|
(list
|
|
(quote every?)
|
|
(list
|
|
(quote fn)
|
|
(list (make-symbol (nth ast 1)))
|
|
(hs-to-sx (nth ast 3)))
|
|
(hs-to-sx (nth ast 2))))
|
|
((= head (quote scroll!))
|
|
(list
|
|
(quote hs-scroll!)
|
|
(hs-to-sx (nth ast 1))
|
|
(nth ast 2)))
|
|
((= head (quote select!))
|
|
(list (quote hs-select!) (hs-to-sx (nth ast 1))))
|
|
((= head (quote reset!))
|
|
(list (quote hs-reset!) (hs-to-sx (nth ast 1))))
|
|
((= head (quote default!))
|
|
(let
|
|
((t (hs-to-sx (nth ast 1))) (v (hs-to-sx (nth ast 2))))
|
|
(list
|
|
(quote when)
|
|
(list (quote nil?) t)
|
|
(list (quote set!) t v))))
|
|
((= head (quote halt!)) (list (quote hs-halt!) (nth ast 1)))
|
|
((= head (quote focus!))
|
|
(list (quote dom-focus) (hs-to-sx (nth ast 1))))
|
|
(true ast))))))))
|
|
|
|
;; ── Convenience: source → SX ─────────────────────────────────
|
|
(define hs-to-sx-from-source (fn (src) (hs-to-sx (hs-compile src)))) |