coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions 7 Packages Projects Releases Wiki Activity
Files
327995423490c43e7bdeac0c144072722af7084a
rose-ash/lib/hyperscript/compiler.sx
giles 6b0334affe HS: remove bare @attr, set X @attr, JSON clean, FormEncoded, HTML join 
- parser remove/set: accept bare @attr (not just [@attr])
- parser set: wrap tgt as (attr name tgt) when @attr follows target
- runtime: hs-json-stringify walks sx-dict/list to emit plain JSON
  (strips _type key which leaked via JSON.stringify)
- hs-coerce JSON / JSONString: use hs-json-stringify
- hs-coerce FormEncoded: dict → k=v&... (list values repeat key)
- hs-coerce HTML: join list elements; element → outerHTML

+4 tests (button query in form, JSONString value, array→HTML,
form | JSONString now fails only on key order).

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
2026-04-23 20:14:03 +00:00

1948 lines
77 KiB
Plaintext
Raw Blame History

;; _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))
(if
(= target (quote the-result))
(list
(quote let)
(list (list (quote __hs-r) value))
(list
(quote begin)
(list (quote set!) (quote the-result) (quote __hs-r))
(list (quote set!) (quote it) (quote __hs-r))
(quote __hs-r)))
(list (quote set!) target value))
(let
((th (first target)))
(cond
((= th dot-sym)
(let
((base-ast (nth target 1)) (prop (nth target 2)))
(cond
((and (list? base-ast) (= (first base-ast) (quote query)) (let ((s (nth base-ast 1))) (and (string? s) (> (len s) 0) (= (substring s 0 1) "."))))
(list
(quote for-each)
(list
(quote fn)
(list (quote __hs-el))
(list
(quote dom-set-prop)
(quote __hs-el)
prop
value))
(list (quote hs-query-all) (nth base-ast 1))))
((and (list? base-ast) (= (first base-ast) dot-sym) (let ((inner (nth base-ast 1))) (and (list? inner) (= (first inner) (quote query)) (let ((s (nth inner 1))) (and (string? s) (> (len s) 0) (= (substring s 0 1) "."))))))
(let
((inner (nth base-ast 1))
(mid-prop (nth base-ast 2)))
(list
(quote for-each)
(list
(quote fn)
(list (quote __hs-el))
(list
(quote dom-set-prop)
(list
(quote host-get)
(quote __hs-el)
mid-prop)
prop
value))
(list (quote hs-query-all) (nth inner 1)))))
(true
(list
(quote dom-set-prop)
(hs-to-sx base-ast)
prop
value)))))
((= th (quote attr))
(list
(quote hs-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 hs-scoped-set!)
(quote me)
(nth target 1)
value))
((= th (quote dom-ref))
(list
(quote hs-dom-set!)
(hs-to-sx (nth target 2))
(nth target 1)
value))
((= th (quote me))
(list (quote hs-set-inner-html!) (quote me) value))
((= th (quote it)) (list (quote set!) (quote it) value))
((= th (quote query))
(list (quote hs-set-inner-html!) (hs-to-sx target) value))
((= th (quote array-index))
(list
(quote hs-array-set!)
(hs-to-sx (nth target 1))
(hs-to-sx (nth target 2))
value))
((or (= th (quote next)) (= th (quote previous)) (= th (quote closest)))
(list (quote hs-set-inner-html!) (hs-to-sx target) value))
((= th (quote of))
(let
((prop-ast (nth target 1)) (obj-ast (nth target 2)))
(if
(and (list? prop-ast) (= (first prop-ast) dot-sym))
(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))
(if
(and
(list? prop-ast)
(= (first prop-ast) (quote attr)))
(list
(quote hs-set-attr!)
(hs-to-sx obj-ast)
(nth prop-ast 1)
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)
(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
((event-refs (if (and (list? body) (= (first body) (quote do))) (filter (fn (x) (and (list? x) (= (first x) (quote ref)))) (rest body)) (list))))
(let
((stripped-body (if (> (len event-refs) 0) (let ((remaining (filter (fn (x) (not (and (list? x) (= (first x) (quote ref))))) (rest body)))) (if (= (len remaining) 1) (first remaining) (cons (quote do) remaining))) body)))
(let
((raw-compiled (hs-to-sx stripped-body)))
(let
((compiled-body (if (> (len event-refs) 0) (let ((bindings (map (fn (r) (let ((name (nth r 1))) (list (make-symbol name) (list (quote host-get) (list (quote host-get) (quote event) "detail") name)))) event-refs))) (list (quote let) bindings raw-compiled)) raw-compiled)))
(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)))
(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)))))
(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)))
((and (list? mode) (= (first mode) (quote while)))
(let
((cond-expr (hs-to-sx (nth mode 1))))
(list
(quote hs-repeat-while)
(list (quote fn) (list) cond-expr)
(list (quote fn) (list) body))))
((and (list? mode) (= (first mode) (quote until)))
(let
((cond-expr (hs-to-sx (nth mode 1))))
(list
(quote hs-repeat-until)
(list (quote fn) (list) cond-expr)
(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))
(raw-coll (hs-to-sx (nth ast 2)))
(collection
(if
(symbol? raw-coll)
(list
(quote hs-safe-call)
(list (quote fn) (list) raw-coll))
raw-coll))
(body (hs-to-sx (nth ast 3))))
(if
(and (> (len ast) 4) (= (nth ast 4) :index))
(list
(quote map-indexed)
(list
(quote fn)
(list (make-symbol (nth ast 5)) (make-symbol var-name))
body)
collection)
(list
(quote hs-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)
(let
((type-name (nth ast 1))
(called (if (>= (len ast) 3) (nth ast 2) nil))
(args (if (>= (len ast) 4) (nth ast 3) nil))
(kind (if (>= (len ast) 5) (nth ast 4) (quote auto))))
(let
((make-call (cond ((nil? args) (list (quote hs-make) type-name)) (true (cons (quote hs-make) (cons type-name (map hs-to-sx args)))))))
(cond
((and called (> (len called) 1) (= (substring called 0 1) "$"))
(list
(quote let)
(list (list (quote __hs-mk) make-call))
(list
(quote do)
(list
(quote host-set!)
(list (quote host-global) "window")
called
(quote __hs-mk))
(list (quote set!) (quote it) (quote __hs-mk))
(quote __hs-mk))))
(called
(list
(quote do)
(list (quote set!) (make-symbol called) make-call)
(list (quote set!) (quote it) (make-symbol called))
(make-symbol called)))
(true
(list
(quote let)
(list (list (quote __hs-mk) make-call))
(list
(quote do)
(list (quote set!) (quote it) (quote __hs-mk))
(quote __hs-mk)))))))))
(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)))
(attr-name (nth expr 1)))
(list
(quote let)
(list
(list
(quote __hs-new)
(list
(quote +)
(list
(quote hs-to-number)
(list (quote dom-get-attr) el attr-name))
amount)))
(list
(quote do)
(list (quote dom-set-attr) el attr-name (quote __hs-new))
(list (quote set!) (quote it) (quote __hs-new))))))
((and (list? expr) (= (first expr) dot-sym))
(let
((obj (hs-to-sx (nth expr 1))) (prop (nth expr 2)))
(list
(quote let)
(list
(list
(quote __hs-new)
(list
(quote +)
(list
(quote hs-to-number)
(list (quote host-get) obj prop))
amount)))
(list
(quote do)
(list (quote host-set!) obj prop (quote __hs-new))
(list (quote set!) (quote it) (quote __hs-new))))))
((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 let)
(list
(list
(quote __hs-new)
(list
(quote +)
(list
(quote hs-to-number)
(list (quote dom-get-style) el prop))
amount)))
(list
(quote do)
(list (quote dom-set-style) el prop (quote __hs-new))
(list (quote set!) (quote it) (quote __hs-new))))))
((and (list? expr) (= (first expr) (quote dom-ref)))
(let
((el (hs-to-sx (nth expr 2))) (name (nth expr 1)))
(list
(quote let)
(list
(list
(quote __hs-new)
(list
(quote +)
(list
(quote hs-to-number)
(list (quote hs-dom-get) el name))
amount)))
(list
(quote do)
(list (quote hs-dom-set!) el name (quote __hs-new))
(list (quote set!) (quote it) (quote __hs-new))))))
((and (list? expr) (= (first expr) (quote array-index)) (list? (nth expr 1)) (= (first (nth expr 1)) (quote ref)))
(let
((var-sym (make-symbol (nth (nth expr 1) 1)))
(idx (hs-to-sx (nth expr 2))))
(list
(quote let)
(list (list (quote __hs-idx) idx))
(list
(quote let)
(list
(list
(quote __hs-new)
(list
(quote +)
(list (quote nth) var-sym (quote __hs-idx))
amount)))
(list
(quote do)
(list
(quote set!)
var-sym
(list
(quote hs-list-set)
var-sym
(quote __hs-idx)
(quote __hs-new)))
(list (quote set!) (quote it) (quote __hs-new)))))))
(true
(let
((t (hs-to-sx expr)))
(list
(quote let)
(list (list (quote __hs-new) (list (quote +) t amount)))
(list
(quote do)
(list (quote set!) t (quote __hs-new))
(list (quote set!) (quote it) (quote __hs-new)))))))))
(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)))
(attr-name (nth expr 1)))
(list
(quote let)
(list
(list
(quote __hs-new)
(list
(quote -)
(list
(quote hs-to-number)
(list (quote dom-get-attr) el attr-name))
amount)))
(list
(quote do)
(list (quote dom-set-attr) el attr-name (quote __hs-new))
(list (quote set!) (quote it) (quote __hs-new))))))
((and (list? expr) (= (first expr) dot-sym))
(let
((obj (hs-to-sx (nth expr 1))) (prop (nth expr 2)))
(list
(quote let)
(list
(list
(quote __hs-new)
(list
(quote -)
(list
(quote hs-to-number)
(list (quote host-get) obj prop))
amount)))
(list
(quote do)
(list (quote host-set!) obj prop (quote __hs-new))
(list (quote set!) (quote it) (quote __hs-new))))))
((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 let)
(list
(list
(quote __hs-new)
(list
(quote -)
(list
(quote hs-to-number)
(list (quote dom-get-style) el prop))
amount)))
(list
(quote do)
(list (quote dom-set-style) el prop (quote __hs-new))
(list (quote set!) (quote it) (quote __hs-new))))))
((and (list? expr) (= (first expr) (quote dom-ref)))
(let
((el (hs-to-sx (nth expr 2))) (name (nth expr 1)))
(list
(quote let)
(list
(list
(quote __hs-new)
(list
(quote -)
(list
(quote hs-to-number)
(list (quote hs-dom-get) el name))
amount)))
(list
(quote do)
(list (quote hs-dom-set!) el name (quote __hs-new))
(list (quote set!) (quote it) (quote __hs-new))))))
((and (list? expr) (= (first expr) (quote array-index)) (list? (nth expr 1)) (= (first (nth expr 1)) (quote ref)))
(let
((var-sym (make-symbol (nth (nth expr 1) 1)))
(idx (hs-to-sx (nth expr 2))))
(list
(quote let)
(list (list (quote __hs-idx) idx))
(list
(quote let)
(list
(list
(quote __hs-new)
(list
(quote -)
(list (quote nth) var-sym (quote __hs-idx))
amount)))
(list
(quote do)
(list
(quote set!)
var-sym
(list
(quote hs-list-set)
var-sym
(quote __hs-idx)
(quote __hs-new)))
(list (quote set!) (quote it) (quote __hs-new)))))))
(true
(let
((t (hs-to-sx expr)))
(list
(quote let)
(list (list (quote __hs-new) (list (quote -) t amount)))
(list
(quote do)
(list (quote set!) t (quote __hs-new))
(list (quote set!) (quote it) (quote __hs-new)))))))))
(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 and)) (= head (quote or)) (= head (quote >=)) (= head (quote <=)) (= head (quote >)) (= head (quote <)))
(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 pick-first))
(list
(quote set!)
(quote it)
(list
(quote hs-pick-first)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2)))))
((= head (quote pick-last))
(list
(quote set!)
(quote it)
(list
(quote hs-pick-last)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2)))))
((= head (quote pick-random))
(list
(quote set!)
(quote it)
(list
(quote hs-pick-random)
(hs-to-sx (nth ast 1))
(if (nil? (nth ast 2)) nil (hs-to-sx (nth ast 2))))))
((= head (quote pick-items))
(list
(quote set!)
(quote it)
(list
(quote hs-pick-items)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))
(hs-to-sx (nth ast 3)))))
((= head (quote pick-match))
(list
(quote set!)
(quote it)
(list
(quote hs-pick-match)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2)))))
((= head (quote pick-matches))
(list
(quote set!)
(quote it)
(list
(quote hs-pick-matches)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2)))))
((= 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 query-scoped))
(list
(quote hs-query-all-in)
(nth ast 1)
(hs-to-sx (nth ast 2))))
((= 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 dom-ref))
(list
(quote hs-dom-get)
(hs-to-sx (nth ast 2))
(nth ast 1)))
((= head (quote has-class?))
(list
(quote dom-has-class?)
(hs-to-sx (nth ast 1))
(nth ast 2)))
((= head (quote local))
(list (quote hs-scoped-get) (quote me) (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?))
(let
((left (nth ast 1)) (right (nth ast 2)))
(if
(and (list? right) (= (first right) (quote query)))
(list (quote hs-matches?) (hs-to-sx left) (nth right 1))
(list
(quote hs-matches?)
(hs-to-sx left)
(hs-to-sx right)))))
((= 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 starts-with-ic?))
(list
(quote hs-starts-with-ic?)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote ends-with-ic?))
(list
(quote hs-ends-with-ic?)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote starts-with?))
(list
(quote hs-starts-with?)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote ends-with?))
(list
(quote hs-ends-with?)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote precedes?))
(list
(quote hs-precedes?)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote follows?))
(list
(quote hs-follows?)
(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 set-style))
(list
(quote dom-set-style)
(hs-to-sx (nth ast 3))
(nth ast 1)
(nth ast 2)))
((= head (quote set-styles))
(let
((pairs (nth ast 1)) (tgt (hs-to-sx (nth ast 2))))
(cons
(quote do)
(map
(fn
(p)
(list (quote dom-set-style) tgt (first p) (nth p 1)))
pairs))))
((= 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 add-class-when))
(let
((cls (nth ast 1))
(raw-tgt (nth ast 2))
(when-cond (nth ast 3)))
(let
((tgt-expr (cond ((and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-query-all) (nth raw-tgt 1))) ((and (list? raw-tgt) (= (first raw-tgt) (quote in?)) (list? (nth raw-tgt 1)) (= (first (nth raw-tgt 1)) (quote query))) (list (quote host-call) (hs-to-sx (nth raw-tgt 2)) "querySelectorAll" (nth (nth raw-tgt 1) 1))) (true (hs-to-sx raw-tgt)))))
(list
(quote let)
(list
(list
(quote __hs-matched)
(list
(quote filter)
(list
(quote fn)
(list (quote it))
(hs-to-sx when-cond))
tgt-expr)))
(list
(quote begin)
(list
(quote set!)
(quote the-result)
(quote __hs-matched))
(list (quote set!) (quote it) (quote __hs-matched))
(list
(quote for-each)
(list
(quote fn)
(list (quote it))
(list (quote dom-add-class) (quote it) cls))
(quote __hs-matched))
(quote __hs-matched))))))
((= head (quote add-attr-when))
(let
((attr-name (nth ast 1))
(attr-val (hs-to-sx (nth ast 2)))
(raw-tgt (nth ast 3))
(when-cond (nth ast 4)))
(let
((tgt-expr (cond ((and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-query-all) (nth raw-tgt 1))) (true (hs-to-sx raw-tgt)))))
(list
(quote let)
(list
(list
(quote __hs-matched)
(list
(quote filter)
(list
(quote fn)
(list (quote it))
(hs-to-sx when-cond))
tgt-expr)))
(list
(quote begin)
(list
(quote set!)
(quote the-result)
(quote __hs-matched))
(list (quote set!) (quote it) (quote __hs-matched))
(list
(quote for-each)
(list
(quote fn)
(list (quote it))
(list
(quote hs-set-attr!)
(quote it)
attr-name
attr-val))
(quote __hs-matched))
(quote __hs-matched))))))
((= 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))
(let
((tgt (nth ast 1)))
(cond
((and (list? tgt) (= (first tgt) (quote array-index)))
(let
((coll (nth tgt 1)) (idx (hs-to-sx (nth tgt 2))))
(emit-set
coll
(list (quote hs-splice-at!) (hs-to-sx coll) idx))))
((and (list? tgt) (= (first tgt) dot-sym))
(let
((obj (nth tgt 1)) (prop (nth tgt 2)))
(emit-set
obj
(list (quote hs-dict-without) (hs-to-sx obj) prop))))
((and (list? tgt) (= (first tgt) (quote of)))
(let
((prop-ast (nth tgt 1)) (obj-ast (nth tgt 2)))
(let
((prop (cond ((string? prop-ast) prop-ast) ((and (list? prop-ast) (= (first prop-ast) (quote ref))) (nth prop-ast 1)) (true (hs-to-sx prop-ast)))))
(emit-set
obj-ast
(list
(quote hs-dict-without)
(hs-to-sx obj-ast)
prop)))))
(true (list (quote dom-remove) (hs-to-sx tgt))))))
((= head (quote add-value))
(let
((val (hs-to-sx (nth ast 1))) (tgt (nth ast 2)))
(emit-set
tgt
(list (quote hs-add-to!) val (hs-to-sx tgt)))))
((= head (quote add-attr))
(let
((tgt (nth ast 3)))
(list
(quote hs-set-attr!)
(hs-to-sx tgt)
(nth ast 1)
(hs-to-sx (nth ast 2)))))
((= head (quote remove-value))
(let
((val (hs-to-sx (nth ast 1))) (tgt (nth ast 2)))
(emit-set
tgt
(list (quote hs-remove-from!) val (hs-to-sx tgt)))))
((= head (quote empty-target))
(let
((tgt (nth ast 1)))
(cond
((and (list? tgt) (= (first tgt) (quote local)))
(emit-set
tgt
(list (quote hs-empty-like) (hs-to-sx tgt))))
(true (list (quote hs-empty-target!) (hs-to-sx tgt))))))
((= 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 morph!))
(list
(quote hs-morph!)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= 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-class-for))
(list
(quote do)
(list
(quote hs-toggle-class!)
(hs-to-sx (nth ast 2))
(nth ast 1))
(list
(quote perform)
(list
(quote list)
(quote io-sleep)
(hs-to-sx (nth ast 3))))
(list
(quote hs-toggle-class!)
(hs-to-sx (nth ast 2))
(nth ast 1))))
((= head (quote set-on))
(list
(quote hs-set-on!)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote set-on!))
(let
((lhs (nth ast 1))
(tgt-ast (nth ast 2))
(val-ast (nth ast 3)))
(if
(and (list? lhs) (= (first lhs) (quote dom-ref)))
(list
(quote hs-dom-set!)
(hs-to-sx tgt-ast)
(nth lhs 1)
(hs-to-sx val-ast))
(list
(quote hs-set-on!)
(hs-to-sx lhs)
(hs-to-sx tgt-ast)
(hs-to-sx val-ast)))))
((= 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))
(let
((raw-tgt (nth ast 2)))
(list
(quote hs-toggle-style!)
(if (nil? raw-tgt) (quote me) (hs-to-sx raw-tgt))
(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-style-cycle))
(list
(quote hs-toggle-style-cycle!)
(hs-to-sx (nth ast 2))
(nth ast 1)
(cons
(quote list)
(map hs-to-sx (slice ast 3 (len ast))))))
((= 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 toggle-attr-val))
(list
(quote hs-toggle-attr-val!)
(hs-to-sx (nth ast 3))
(nth ast 1)
(hs-to-sx (nth ast 2))))
((= head (quote toggle-attr-diff))
(list
(quote hs-toggle-attr-diff!)
(hs-to-sx (nth ast 5))
(nth ast 1)
(hs-to-sx (nth ast 2))
(nth ast 3)
(hs-to-sx (nth ast 4))))
((= head (quote set!))
(emit-set (nth ast 1) (hs-to-sx (nth ast 2))))
((= head (quote put!))
(let
((val (hs-to-sx (nth ast 1)))
(pos (nth ast 2))
(raw-tgt (nth ast 3)))
(cond
((and (or (= pos "end") (= pos "start")) (list? raw-tgt) (or (= (first raw-tgt) (quote local)) (= (first raw-tgt) (quote ref))))
(emit-set
raw-tgt
(list (quote hs-put-at!) val pos (hs-to-sx raw-tgt))))
(true (list (quote hs-put!) val pos (hs-to-sx raw-tgt))))))
((= 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))
(let
((compiled (map hs-to-sx (rest ast))))
(if
(and
(> (len compiled) 1)
(some
(fn
(c)
(and
(list? c)
(or
(= (first c) (quote hs-fetch))
(= (first c) (quote hs-wait))
(= (first c) (quote hs-wait-for))
(= (first c) (quote hs-query-first))
(= (first c) (quote hs-query-all))
(= (first c) (quote perform)))))
compiled))
(reduce
(fn
(body cmd)
(if
(and
(list? cmd)
(= (first cmd) (quote hs-fetch)))
(list
(quote let)
(list (list (quote it) cmd))
(list
(quote begin)
(list
(quote set!)
(quote the-result)
(quote it))
body))
(list
(quote let)
(list (list (quote it) cmd))
body)))
(nth compiled (- (len compiled) 1))
(rest (reverse compiled)))
(cons (quote do) compiled))))
((= 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))
(let
((name (nth ast 1))
(has-detail
(and
(= (len ast) 4)
(list? (nth ast 2))
(= (first (nth ast 2)) (quote dict))))
(tgt (if (= (len ast) 4) (nth ast 3) (nth ast 2)))
(detail (if (= (len ast) 4) (nth ast 2) nil)))
(list
(quote dom-dispatch)
(hs-to-sx tgt)
name
(if has-detail (hs-to-sx detail) nil))))
((= head (quote hide))
(let
((tgt (let ((raw-tgt (nth ast 1))) (if (and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-query-all) (nth raw-tgt 1)) (hs-to-sx raw-tgt))))
(strategy (if (> (len ast) 2) (nth ast 2) "display"))
(when-cond (if (> (len ast) 3) (nth ast 3) nil)))
(if
(nil? when-cond)
(list (quote hs-hide!) tgt strategy)
(list
(quote hs-hide-when!)
tgt
strategy
(list
(quote fn)
(list (quote it))
(hs-to-sx when-cond))))))
((= head (quote show))
(let
((tgt (let ((raw-tgt (nth ast 1))) (if (and (list? raw-tgt) (= (first raw-tgt) (quote query))) (list (quote hs-query-all) (nth raw-tgt 1)) (hs-to-sx raw-tgt))))
(strategy (if (> (len ast) 2) (nth ast 2) "display"))
(when-cond (if (> (len ast) 3) (nth ast 3) nil)))
(if
(nil? when-cond)
(list (quote hs-show!) tgt strategy)
(list
(quote let)
(list
(list
(quote __hs-show-r)
(list
(quote hs-show-when!)
tgt
strategy
(list
(quote fn)
(list (quote it))
(hs-to-sx when-cond)))))
(list
(quote begin)
(list
(quote set!)
(quote the-result)
(quote __hs-show-r))
(list (quote set!) (quote it) (quote __hs-show-r))
(quote __hs-show-r))))))
((= 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 repeat-until))
(list
(quote hs-repeat-until)
(list (quote fn) (list) (hs-to-sx (nth ast 1)))
(list (quote fn) (list) (hs-to-sx (nth ast 2)))))
((= head (quote repeat-while))
(list
(quote hs-repeat-while)
(list (quote fn) (list) (hs-to-sx (nth ast 1)))
(list (quote fn) (list) (hs-to-sx (nth ast 2)))))
((= 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
((raw-fn (nth ast 1))
(fn-expr
(if
(string? raw-fn)
(make-symbol raw-fn)
(hs-to-sx raw-fn)))
(args (map hs-to-sx (rest (rest ast)))))
(cons fn-expr args)))
((= head (quote return))
(let
((val (nth ast 1)))
(if
(nil? val)
(list (quote raise) (list (quote list) "hs-return" nil))
(list
(quote raise)
(list (quote list) "hs-return" (hs-to-sx val))))))
((= 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 __get-cmd))
(let
((val (hs-to-sx (nth ast 1))))
(list
(quote let)
(list (list (quote __hs-g) val))
(list
(quote begin)
(list (quote set!) (quote the-result) (quote __hs-g))
(list (quote set!) (quote it) (quote __hs-g))
(quote __hs-g)))))
((= head (quote append!))
(let
((tgt (hs-to-sx (nth ast 2)))
(val (hs-to-sx (nth ast 1)))
(raw-tgt (nth ast 2)))
(cond
((symbol? tgt)
(list
(quote set!)
tgt
(list (quote hs-append) tgt val)))
((and (list? raw-tgt) (or (= (first raw-tgt) (quote local)) (= (first raw-tgt) (quote ref))))
(emit-set raw-tgt (list (quote hs-append) tgt val)))
(true (list (quote hs-append!) val tgt)))))
((= 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))
(attr-val (if (> (len ast) 5) (nth ast 5) nil))
(with-val (if (> (len ast) 6) (nth ast 6) 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))))
(with-sx
(if
with-val
(if
(string? with-val)
with-val
(hs-to-sx with-val))
nil)))
(cond
((and (= kind "attr") (or attr-val with-val))
(list
(quote hs-take!)
target
kind
name
scope
attr-val
with-sx))
((and (= kind "class") with-val)
(list
(quote hs-take!)
target
kind
name
scope
nil
with-sx))
(true (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!))
(if
(= (len ast) 3)
(emit-inc (nth ast 1) 1 (nth ast 2))
(emit-inc
(nth ast 1)
(nth ast 2)
(if (> (len ast) 3) (nth ast 3) nil))))
((= head (quote decrement!))
(if
(= (len ast) 3)
(emit-dec (nth ast 1) 1 (nth ast 2))
(emit-dec
(nth ast 1)
(nth ast 2)
(if (> (len ast) 3) (nth ast 3) nil))))
((= head (quote break)) (list (quote raise) "hs-break"))
((= head (quote continue))
(list (quote raise) "hs-continue"))
((= head (quote exit)) nil)
((= head (quote live-no-op)) nil)
((= head (quote when-feat-no-op)) nil)
((= head (quote on)) (emit-on ast))
((= head (quote when-changes))
(let
((expr (nth ast 1)) (body (nth ast 2)))
(if
(and (list? expr) (= (first expr) (quote dom-ref)))
(list
(quote hs-dom-watch!)
(hs-to-sx (nth expr 2))
(nth expr 1)
(list (quote fn) (list (quote it)) (hs-to-sx body)))
nil)))
((= head (quote init))
(list
(quote hs-init)
(list (quote fn) (list) (hs-to-sx (nth ast 1)))))
((= head (quote def))
(let
((body (hs-to-sx (nth ast 3)))
(params
(map
(fn
(p)
(if
(and (list? p) (= (first p) (quote ref)))
(make-symbol (nth p 1))
(make-symbol p)))
(nth ast 2))))
(list
(quote define)
(make-symbol (nth ast 1))
(list
(quote fn)
params
(list
(quote guard)
(list
(quote _e)
(list
(quote true)
(list
(quote if)
(list
(quote and)
(list (quote list?) (quote _e))
(list
(quote =)
(list (quote first) (quote _e))
"hs-return"))
(list (quote nth) (quote _e) 1)
(list (quote raise) (quote _e)))))
body)))))
((= 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 type-assert))
(list
(quote hs-type-assert)
(hs-to-sx (nth ast 1))
(nth ast 2)))
((= head (quote type-assert-strict))
(list
(quote hs-type-assert-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!))
(let
((raw-tgt (nth ast 1)))
(cond
((and (list? raw-tgt) (= (first raw-tgt) (quote query)))
(list
(quote hs-reset!)
(list (quote hs-query-all) (nth raw-tgt 1))))
(true (list (quote hs-reset!) (hs-to-sx raw-tgt))))))
((= head (quote default!))
(let
((tgt-ast (nth ast 1))
(read (hs-to-sx (nth ast 1)))
(v (hs-to-sx (nth ast 2))))
(list
(quote when)
(list (quote hs-default?) read)
(emit-set tgt-ast v))))
((= head (quote hs-is))
(list
(quote hs-is)
(hs-to-sx (nth ast 1))
(list (quote fn) (list) (hs-to-sx (nth (nth ast 2) 2)))
(nth ast 3)))
((= head (quote halt!))
(list (quote hs-halt!) (quote event) (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))))
Reference in New Issue View Git Blame Copy Permalink