coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
abbb1fe5c6e6955551614ecd7b9ed44f1f8097b0
rose-ash/shared/static/wasm/sx/hs-compiler.sx
giles abbb1fe5c6
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 48s
Details
HS: asyncError — rejected promise triggers catch block (+1 test) 
Three-part fix for hs-upstream-core/asyncError test 2/2:

1. runtime.sx hs-win-call: when an async call returns a rejected promise,
   store the error value in window.__hs_async_error (side-channel) and
   raise the sentinel "__hs_async_error__" so the value survives the
   raise boundary intact.

2. compiler.sx catch clause: inject `(let ((var (host-hs-normalize-exc var))) ...)`
   around the catch body so the sentinel gets swapped for the real error
   object before user code runs. Uses let (not set!) so shadowing works
   correctly for guard catch variables.

3. tests/hs-run-filtered.js:
   - host-promise-state wraps JS Error objects as plain {message:...} dicts
     before they cross the WASM boundary (Error.toString() was producing
     "Error: boom" strings instead of accessible objects)
   - host-hs-normalize-exc native retrieves the side-channel value when
     the sentinel arrives in a catch variable
   - host-get coercion restricted to El instances — plain JS objects with
     a "value" key were being stringified to "[object Object]"

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
2026-05-05 02:07:52 +00:00

2590 lines
109 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
((or (= th dot-sym) (= th (make-symbol "poss")))
(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 let)
(list
(list
(quote __hs-obj)
(if
(or
(symbol? base-ast)
(and
(list? base-ast)
(= (str (first base-ast)) "ref")))
(let
((sel (if (symbol? base-ast) (str base-ast) (nth base-ast 1))))
(list
(quote do)
(list
(quote host-set!)
(list (quote host-global) "window")
"_hs_last_query_sel"
sel)
(hs-to-sx base-ast)))
(hs-to-sx base-ast))))
(list
(quote do)
(list (quote hs-null-raise!) (quote __hs-obj))
(list
(quote when)
(list
(quote not)
(list (quote nil?) (quote __hs-obj)))
(list
(quote dom-set-prop)
(quote __hs-obj)
prop
value))))))))
((= th (quote attr))
(let
((base-ast (nth target 2)))
(if
(and (list? base-ast) (= (str (first base-ast)) "ref"))
(list
(quote do)
(list
(quote set!)
(quote _hs-last-query-sel)
(nth base-ast 1))
(list
(quote hs-set-attr!)
(hs-to-sx base-ast)
(nth target 1)
value))
(list
(quote hs-set-attr!)
(hs-to-sx base-ast)
(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)) (= th (quote closest-parent)))
(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)
(if
(and
(list? prop-ast)
(= (first prop-ast) (quote style)))
(list
(quote dom-set-style)
(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
having-info
of-filter-info
count-filter-info
elsewhere?)
(cond
((<= (len items) 1)
(let
((body (if (> (len items) 0) (first items) nil)))
(let
((target (cond (elsewhere? (list (quote dom-body))) (source (hs-to-sx source)) (true (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 (let ((base (if (> (len event-refs) 0) (let ((bindings (map (fn (r) (let ((name (nth r 1))) (list (make-symbol name) (list (quote let) (list (list (quote _det) (list (quote host-get) (quote event) "detail"))) (list (quote if) (list (quote and) (quote _det) (list (quote not) (list (quote nil?) (list (quote host-get) (quote _det) name)))) (list (quote host-get) (quote _det) name) (list (quote host-get) (quote event) 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))))
(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 let) (list (list (quote __hs-exc) nil) (list (quote __hs-reraise) false)) (list (quote do) (list (quote guard) (list var (list true (list (quote let) (list (list var (list (quote host-hs-normalize-exc) var))) (list (quote guard) (list (quote __inner-exc) (list true (list (quote do) (list (quote set!) (quote __hs-exc) (quote __inner-exc)) (list (quote set!) (quote __hs-reraise) true)))) catch-body)))) compiled-body) (hs-to-sx finally-info) (list (quote when) (quote __hs-reraise) (list (quote raise) (quote __hs-exc))))) (list (quote let) (list (list (quote __hs-exc) nil) (list (quote __hs-reraise) false)) (list (quote guard) (list var (list true (list (quote let) (list (list var (list (quote host-hs-normalize-exc) var))) (list (quote guard) (list (quote __inner-exc) (list true (list (quote do) (list (quote set!) (quote __hs-exc) (quote __inner-exc)) (list (quote set!) (quote __hs-reraise) true)))) catch-body)))) compiled-body) (list (quote when) (quote __hs-reraise) (list (quote raise) (quote __hs-exc)))))) (if finally-info (list (quote do) compiled-body (hs-to-sx finally-info)) compiled-body))))
(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)))))
(let
((on-call (if every? (list (quote hs-on-every) target event-name handler) (list (quote hs-on) target event-name handler))))
(cond
((= event-name "mutation")
(list
(quote do)
on-call
(list
(quote hs-on-mutation-attach!)
target
(if
of-filter-info
(get of-filter-info "type")
"any")
(if
of-filter-info
(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)
(scan-on
(rest (rest items))
(nth items 1)
filter
every?
catch-info
finally-info
having-info
of-filter-info
count-filter-info
elsewhere?))
((= (first items) :filter)
(scan-on
(rest (rest items))
source
(nth items 1)
every?
catch-info
finally-info
having-info
of-filter-info
count-filter-info
elsewhere?))
((= (first items) :every)
(scan-on
(rest (rest items))
source
filter
true
catch-info
finally-info
having-info
of-filter-info
count-filter-info
elsewhere?))
((= (first items) :catch)
(scan-on
(rest (rest items))
source
filter
every?
(nth items 1)
finally-info
having-info
of-filter-info
count-filter-info
elsewhere?))
((= (first items) :finally)
(scan-on
(rest (rest items))
source
filter
every?
catch-info
(nth items 1)
having-info
of-filter-info
count-filter-info
elsewhere?))
((= (first items) :having)
(scan-on
(rest (rest items))
source
filter
every?
catch-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)))
(true
(scan-on
(rest items)
source
filter
every?
catch-info
finally-info
having-info
of-filter-info
count-filter-info
elsewhere?)))))
(scan-on (rest parts) nil nil false nil nil nil 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 hs-dispatch!)
(hs-to-sx (nth ast 3))
name
(hs-to-sx (nth ast 2))))
((= (len ast) 3)
(list
(quote hs-dispatch!)
(hs-to-sx (nth ast 2))
name
(list (quote dict) "sender" (quote me))))
(true
(list
(quote dom-dispatch)
(quote me)
name
(list (quote dict) "sender" (quote me))))))))
(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
hs-reserved-var?
(fn (name) (or (= name "meta") (= name "event") (= name "result"))))
(define
emit-for
(fn
(ast)
(let
((var-name (nth ast 1))
(safe-param
(if
(hs-reserved-var? var-name)
(str "_hs_lv_" var-name)
var-name))
(raw-coll-ast (nth ast 2))
(where-cond
(if
(and
(list? raw-coll-ast)
(= (first raw-coll-ast) (quote coll-where)))
(hs-to-sx (nth raw-coll-ast 2))
nil))
(inner-coll-ast
(if where-cond (nth raw-coll-ast 1) raw-coll-ast))
(raw-coll (hs-to-sx inner-coll-ast))
(safe-coll
(if
(symbol? raw-coll)
(list
(quote cek-try)
(list (quote fn) (list) raw-coll)
(list (quote fn) (list (quote _e)) nil))
raw-coll))
(collection
(if
where-cond
(list
(quote filter)
(list (quote fn) (list (make-symbol var-name)) where-cond)
safe-coll)
safe-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 safe-param))
body)
collection)
(list
(quote hs-for-each)
(list (quote fn) (list (make-symbol safe-param)) body)
collection)))))
(define
emit-wait-for
(fn
(ast)
(let
((event-name (nth ast 1))
(has-from (and (> (len ast) 2) (= (nth ast 2) :from)))
(has-from-or
(and
(> (len ast) 4)
(= (nth ast 2) :from)
(= (nth ast 4) :or)))
(has-or (and (> (len ast) 2) (= (nth ast 2) :or))))
(cond
(has-from-or
(list
(quote hs-wait-for-or)
(hs-to-sx (nth ast 3))
event-name
(nth ast 5)))
(has-from
(list (quote hs-wait-for) (hs-to-sx (nth ast 3)) event-name))
(has-or
(list
(quote hs-wait-for-or)
(quote me)
event-name
(nth ast 3)))
(true (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) (or (= (first expr) dot-sym) (= (first expr) (make-symbol "poss"))))
(let
((obj (hs-to-sx (nth expr 1))) (prop (nth expr 2)))
(list
(quote let)
(list (list (quote __hs-obj) obj))
(list
(quote do)
(list (quote hs-null-raise!) (quote __hs-obj))
(list
(quote when)
(list (quote not) (list (quote nil?) (quote __hs-obj)))
(list
(quote let)
(list
(list
(quote __hs-new)
(list
(quote +)
(list
(quote hs-to-number)
(list (quote host-get) (quote __hs-obj) prop))
amount)))
(list
(quote do)
(list
(quote host-set!)
(quote __hs-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) (or (= (first expr) dot-sym) (= (first expr) (make-symbol "poss"))))
(let
((obj (hs-to-sx (nth expr 1))) (prop (nth expr 2)))
(list
(quote let)
(list (list (quote __hs-obj) obj))
(list
(quote do)
(list (quote hs-null-raise!) (quote __hs-obj))
(list
(quote when)
(list (quote not) (list (quote nil?) (quote __hs-obj)))
(list
(quote let)
(list
(list
(quote __hs-new)
(list
(quote -)
(list
(quote hs-to-number)
(list (quote host-get) (quote __hs-obj) prop))
amount)))
(list
(quote do)
(list
(quote host-set!)
(quote __hs-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
(fn
(p)
(if (list? p) (make-symbol (nth p 1)) (make-symbol p)))
params))
(list
(quote let)
(list (list (quote beingTold) (quote me)))
(cons (quote do) (map hs-to-sx body))))))))
(fn
(ast)
(let
((ast (if (and (dict? ast) (get ast :hs-ast)) (get ast :children) ast)))
(cond
((nil? ast) nil)
((number? ast) ast)
((string? ast) ast)
((boolean? ast) ast)
((and (symbol? ast) (= (str ast) "sender"))
(list (quote hs-sender) (quote event)))
((not (list? ast)) ast)
(true
(let
((head (first ast)))
(cond
((= head (quote __bind-from-detail__))
(let
((name-str (nth ast 1)))
(list
(quote define)
(make-symbol name-str)
(list
(quote host-get)
(list (quote host-get) (quote it) "detail")
name-str))))
((= head (quote sender))
(list (quote hs-sender) (quote event)))
((= 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)
(= (nth raw (+ i 1)) "$"))
(do
(set! buf (str buf "$"))
(set! i (+ i 2))
(tpl-collect))
(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 hs-index)
(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))
(let
((raw-coll (hs-to-sx (nth ast 1))))
(list
(quote filter)
(list
(quote fn)
(list (quote it))
(hs-to-sx (nth ast 2)))
(if
(symbol? raw-coll)
(list
(quote cek-try)
(list (quote fn) (list) raw-coll)
(list (quote fn) (list (quote _e)) nil))
raw-coll))))
((= 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)
(or
(= (str (first dot-node)) ".")
(= (str (first dot-node)) "poss")))
(let
((receiver-ast (nth dot-node 1))
(method (nth dot-node 2))
(sel
(hs-receiver-selector (nth dot-node 1) "poss")))
(list
(quote let)
(list
(list (quote __hs-recv) (hs-to-sx receiver-ast)))
(list
(quote do)
(list
(quote host-set!)
(list (quote host-global) "window")
"_hs_last_query_sel"
sel)
(list (quote hs-null-raise!) (quote __hs-recv))
(cons
(quote hs-method-call)
(cons (quote __hs-recv) (cons method args))))))
(if
(and
(list? dot-node)
(= (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))
(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))))
(list (quote fn) params body)))
((= head (quote me)) (quote me))
((= head (quote beingTold)) (quote beingTold))
((= head (quote it)) (quote it))
((= head (quote event)) (quote event))
((= head dot-sym)
(let
((target (let ((t (hs-to-sx (nth ast 1)))) (if (and (symbol? t) (or (= (str t) "window") (= (str t) "document") (= (str t) "navigator") (= (str t) "location") (= (str t) "history") (= (str t) "screen") (= (str t) "localStorage") (= (str t) "sessionStorage") (= (str t) "console"))) (list (quote host-global) (str t)) t)))
(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 (make-symbol "poss"))
(let
((target (hs-to-sx (nth ast 1))) (prop (nth ast 2)))
(list (quote host-get) target prop)))
((= head (quote ref))
(cond
((= (nth ast 1) "selection")
(list (quote hs-get-selection)))
((= (nth ast 1) "element") (make-symbol "me"))
(else (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 hs-falsy?))
(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 hs-id=))
(list
(quote hs-id=)
(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-in?)
(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 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 closest-parent))
(list
(quote dom-closest)
(list
(quote host-get)
(hs-to-sx (nth ast 2))
"parentElement")
(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-checked) (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))))
(list
(quote let)
(list (list (quote __hs-tgt) tgt))
(list
(quote do)
(list (quote hs-null-raise!) (quote __hs-tgt))
(cons
(quote when)
(cons
(list
(quote not)
(list (quote nil?) (quote __hs-tgt)))
(map
(fn
(p)
(list
(quote dom-set-style)
(quote __hs-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-checked) (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-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))) (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 for-each)
(list
(quote fn)
(list (quote it))
(list (quote dom-remove-class) (quote it) cls))
(quote __hs-matched))))))
((= 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
(let
((tgt (hs-to-sx tgt)))
(list
(quote let)
(list (list (quote __hs-tgt) tgt))
(list
(quote do)
(list (quote hs-null-raise!) (quote __hs-tgt))
(list
(quote when)
(list
(quote not)
(list (quote nil?) (quote __hs-tgt)))
(list (quote dom-remove) (quote __hs-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))))
((and (list? tgt) (= (first tgt) (quote query)))
(list
(quote for-each)
(list
(quote fn)
(list (quote _el))
(list (quote hs-empty-target!) (quote _el)))
(list (quote hs-query-all) (nth tgt 1))))
(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 let)
(list (list (quote __hs-tgt) tgt))
(list
(quote do)
(list (quote hs-null-raise!) (quote __hs-tgt))
(list
(quote when)
(list
(quote not)
(list (quote nil?) (quote __hs-tgt)))
(list
(quote dom-remove-attr)
(quote __hs-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 toggle-class-until))
(let
((cls (nth ast 1))
(tgt (hs-to-sx (nth ast 2)))
(event-name (nth ast 3))
(source (nth ast 4)))
(list
(quote do)
(list (quote hs-toggle-class!) tgt cls)
(list
(quote hs-wait-for)
(if source (hs-to-sx source) (quote me))
event-name)
(list (quote hs-toggle-class!) tgt cls))))
((= head (quote toggle-var-cycle))
(list
(quote hs-toggle-var-cycle!)
(list (quote host-global) "window")
(nth ast 1)
(cons (quote list) (map hs-to-sx (nth ast 2)))))
((= 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 set-el!))
(list
(quote hs-set-element!)
(hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2))))
((= head (quote view-transition!))
(let
((body (nth ast 2)))
(list
(quote hs-view-transition!)
(hs-to-sx (nth ast 1))
(if (nil? body) (quote nil) (hs-to-sx body)))))
((= 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
((expanded (reduce (fn (acc c) (if (and (list? c) (> (len c) 0) (= (first c) (quote wait-for)) (contains? c :destructure)) (let ((dest-names (let ((lst c)) (define scan-dest (fn (i) (cond ((>= i (- (len lst) 1)) (list)) ((= (nth lst i) :destructure) (nth lst (+ i 1))) (true (scan-dest (+ i 2)))))) (scan-dest 2))) (stripped (let ((lst c)) (define strip-dest (fn (i) (cond ((>= i (len lst)) (list)) ((and (< i (- (len lst) 1)) (= (nth lst i) :destructure)) (strip-dest (+ i 2))) (true (cons (nth lst i) (strip-dest (+ i 1))))))) (strip-dest 0)))) (append (append acc (list stripped)) (map (fn (n) (list (quote __bind-from-detail__) n)) dest-names))) (append acc (list c)))) (list) (rest ast))))
(let
((compiled (map hs-to-sx expanded)))
(if
(and
(> (len compiled) 1)
(some
(fn
(c)
(and
(list? c)
(or
(= (first c) (quote hs-fetch))
(= (first c) (quote hs-fetch-no-throw))
(= (first c) (quote hs-wait))
(= (first c) (quote hs-wait-for))
(= (first c) (quote hs-wait-for-or))
(= (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)
(or
(= (first cmd) (quote hs-fetch))
(= (first cmd) (quote hs-fetch-no-throw))))
(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)))
(let
((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-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 hs-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
(if
(nth ast 3)
(quote hs-fetch-no-throw)
(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)))))
(cond
((and (list? raw-fn) (= (first raw-fn) (quote ref)))
(emit-set
(quote the-result)
(list
(quote hs-win-call)
(nth raw-fn 1)
(cons (quote list) args))))
((and (list? raw-fn) (= (str (first raw-fn)) "."))
(let
((receiver-ast (nth raw-fn 1))
(prop-name (nth raw-fn 2))
(sel (hs-receiver-selector (nth raw-fn 1) "dot")))
(list
(quote let)
(list
(list
(quote __hs-recv)
(hs-to-sx receiver-ast)))
(list
(quote do)
(list
(quote set!)
(quote _hs-last-query-sel)
sel)
(list (quote hs-null-raise!) (quote __hs-recv))
(emit-set
(quote the-result)
(cons
(list
(quote host-get)
(quote __hs-recv)
prop-name)
args))))))
(true
(emit-set (quote the-result) (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))
(let
((raw-tgt (if (> (len ast) 1) (nth ast 1) nil)))
(list
(quote hs-settle)
(if (nil? raw-tgt) (quote me) (hs-to-sx raw-tgt)))))
((= head (quote go))
(list (quote hs-navigate!) (hs-to-sx (nth ast 1))))
((= head (quote ask))
(let
((val (list (quote hs-ask) (hs-to-sx (nth ast 1)))))
(list
(quote let)
(list (list (quote __hs-a) val))
(list
(quote begin)
(list
(quote set!)
(quote the-result)
(quote __hs-a))
(list (quote set!) (quote it) (quote __hs-a))
(quote __hs-a)))))
((= head (quote answer))
(let
((val (list (quote hs-answer) (hs-to-sx (nth ast 1)) (hs-to-sx (nth ast 2)) (hs-to-sx (nth ast 3)))))
(list
(quote let)
(list (list (quote __hs-a) val))
(list
(quote begin)
(list
(quote set!)
(quote the-result)
(quote __hs-a))
(list (quote set!) (quote it) (quote __hs-a))
(quote __hs-a)))))
((= head (quote answer-alert))
(let
((val (list (quote hs-answer-alert) (hs-to-sx (nth ast 1)))))
(list
(quote let)
(list (list (quote __hs-a) val))
(list
(quote begin)
(list
(quote set!)
(quote the-result)
(quote __hs-a))
(list (quote set!) (quote it) (quote __hs-a))
(quote __hs-a)))))
((= 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 beingTold) 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))
(let
((bname (nth ast 1)))
(cons
(make-symbol bname)
(cons
(quote me)
(map
(fn
(arg)
(if
(and
(list? arg)
(= (first arg) (quote type-assert)))
(+ (nth arg 2) 0)
(hs-to-sx arg)))
(rest (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 bind-feat)) 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 let)
(list
(list
(quote _hs-def-val)
(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))))
(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 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-in?)
(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))))
((= head (quote js-block))
(let
((params (nth ast 1)) (js-src (nth ast 2)))
(let
((bound-syms (map (fn (p) (make-symbol p)) params)))
(list
(quote let)
(list
(list
(quote __hs-js)
(list
(quote hs-js-exec)
(cons (quote list) params)
js-src
(cons (quote list) bound-syms))))
(list
(quote begin)
(list (quote set!) (quote it) (quote __hs-js))
(quote __hs-js))))))
(true ast)))))))))
;; ── Convenience: source → SX ─────────────────────────────────
(define
hs-receiver-selector
(fn
(ast notation)
(cond
((and (list? ast) (= (str (first ast)) "ref")) (nth ast 1))
((and (list? ast) (= (str (first ast)) "."))
(str (hs-receiver-selector (nth ast 1) notation) "." (nth ast 2)))
((and (list? ast) (= (str (first ast)) "poss"))
(str (hs-receiver-selector (nth ast 1) "poss") "'s " (nth ast 2)))
(true "?"))))
(define hs-to-sx-from-source (fn (src) (hs-to-sx (hs-compile src))))
Reference in New Issue View Git Blame Copy Permalink