diff --git a/lib/hyperscript/compiler.sx b/lib/hyperscript/compiler.sx index 046cad78..2df6752b 100644 --- a/lib/hyperscript/compiler.sx +++ b/lib/hyperscript/compiler.sx @@ -789,1502 +789,1431 @@ (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))) + (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 define) - (make-symbol name-str) + (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 - (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)) + (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 - ((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) + ((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 - ((ch (nth raw i))) + ((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)) "{") + (and (= ch "$") (< (+ i 1) n)) + (if + (= (nth raw (+ i 1)) "{") + (let + ((start (+ i 2))) (let - ((start (+ i 2))) + ((close (tpl-find-close start 1))) (let - ((close (tpl-find-close start 1))) - (let - ((expr-src (slice raw start close))) - (do - (tpl-flush) - (set! + ((expr-src (slice raw start close))) + (do + (tpl-flush) + (set! + parts + (append parts - (append - parts - (list - (hs-to-sx - (hs-compile expr-src))))) - (set! i (+ close 1)) - (tpl-collect))))) + (list + (hs-to-sx (hs-compile expr-src))))) + (set! i (+ close 1)) + (tpl-collect))))) + (let + ((start (+ i 1))) (let - ((start (+ i 1))) + ((end (tpl-read-id start))) (let - ((end (tpl-read-id start))) - (let - ((ident (slice raw start end))) - (do - (tpl-flush) - (set! + ((ident (slice raw start end))) + (do + (tpl-flush) + (set! + parts + (append 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 + (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-index) + (quote hs-pick-first) (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head (quote array-slice)) + (hs-to-sx (nth ast 2))))) + ((= head (quote pick-last)) + (list + (quote set!) + (quote it) (list - (quote hs-slice) + (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-first)) + (hs-to-sx (nth ast 3))))) + ((= head (quote pick-match)) + (list + (quote set!) + (quote it) (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) + (quote hs-pick-match) (hs-to-sx (nth ast 1)) - (nth ast 2))) - ((= head (quote coll-where)) + (hs-to-sx (nth ast 2))))) + ((= head (quote pick-matches)) + (list + (quote set!) + (quote it) (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) + (quote hs-pick-matches) (hs-to-sx (nth ast 1)) - (list - (quote fn) - (list (quote it)) - (hs-to-sx (nth ast 2))))) - ((= head (quote coll-sorted-desc)) + (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 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)) + (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 map) - (list - (quote fn) - (list (quote it)) - (hs-to-sx (nth ast 2))) - (hs-to-sx (nth ast 1)))) - ((= head (quote coll-split)) + (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 hs-split-by) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head (quote coll-joined)) + (quote fn) + (list (quote it)) + (hs-to-sx (nth ast 2))))) + ((= head (quote coll-mapped)) + (list + (quote map) (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)))) + (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)))) (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)))) - (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 (quote ref)) + (= (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)))) (if - (= (nth ast 1) "selection") - (list (quote hs-get-selection)) - (make-symbol (nth ast 1)))) - ((= head (quote query)) - (list (quote hs-query-first) (nth ast 1))) - ((= head (quote query-scoped)) + (= (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 (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 (quote ref)) + (if + (= (nth ast 1) "selection") + (list (quote hs-get-selection)) + (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 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?) + (quote modulo) (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 =)) + (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 (quote +)) + (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 hs-add) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head (quote -)) + (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-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) + (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 - (nil? (nth ast 2)) - (list (quote str) (hs-to-sx (nth ast 1)) "%") + (and (list? raw-tgt) (= (first raw-tgt) (quote query))) (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))) + (quote for-each) (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) + (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 =) - (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)) + (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 - ((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))) + ((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 _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-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-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 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) - (map - (fn (p) (list (quote dom-set-style) tgt p "")) - props)))) - ((= head (quote toggle-class)) + (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))) - ((= head (quote toggle-class-for)) + (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-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 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)) + (quote hs-wait-for) + (if source (hs-to-sx source) (quote me)) + event-name) + (list (quote hs-toggle-class!) tgt cls)))) + ((= 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 - (> (len ast) 3) + (and (list? lhs) (= (first lhs) (quote dom-ref))) (list - (quote if) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)) - (hs-to-sx (nth ast 3))) + (quote hs-dom-set!) + (hs-to-sx tgt-ast) + (nth lhs 1) + (hs-to-sx val-ast)) (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-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) - (= (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))) - (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 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)) + (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-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)) + (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 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) + (quote if) (hs-to-sx (nth ast 1)) - (nth ast 2))) - ((= head (quote fetch-gql)) + (hs-to-sx (nth ast 2)) + (hs-to-sx (nth ast 3))) (list - (quote hs-fetch-gql) - (nth ast 1) - (if (nth ast 2) (hs-to-sx (nth ast 2)) nil))) - ((= head (quote call)) + (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 - ((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))))) + ((compiled (map hs-to-sx expanded))) (if - (and (list? raw-fn) (= (first raw-fn) (quote ref))) - (list - (quote hs-win-call) - (nth raw-fn 1) - (cons (quote list) args)) - (cons fn-expr args)))) - ((= head (quote return)) - (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 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 + (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-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 - 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)) + (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))) + (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-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)))) + (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 define) - (make-symbol (nth ast 1)) + (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 - (quote let) (list + (quote __hs-show-r) (list - (quote _hs-def-val) + (quote hs-show-when!) + tgt + strategy (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 it)) + (hs-to-sx when-cond))))) (list - (quote let) + (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) (nth ast 3) (quote me))) + ((= 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))))) + (if + (and (list? raw-fn) (= (first raw-fn) (quote ref))) + (list + (quote hs-win-call) + (nth raw-fn 1) + (cons (quote list) args)) + (cons fn-expr args)))) + ((= head (quote return)) + (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 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 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 let) + (list + (list + (quote _hs-def-val) (list - (quote __hs-js) + (quote fn) + params (list - (quote hs-js-exec) - (cons (quote list) params) - js-src - (cons (quote list) bound-syms)))) + (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 begin) - (list (quote set!) (quote it) (quote __hs-js)) - (quote __hs-js)))))) - (true ast))))))))) + (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)))) + (true ast)))))))) ;; ── Convenience: source → SX ───────────────────────────────── (define hs-to-sx-from-source (fn (src) (hs-to-sx (hs-compile src)))) \ No newline at end of file diff --git a/lib/hyperscript/parser.sx b/lib/hyperscript/parser.sx index cdc172e5..a9aae1c9 100644 --- a/lib/hyperscript/parser.sx +++ b/lib/hyperscript/parser.sx @@ -560,7 +560,9 @@ (list (quote not) (list (quote eq-ignore-case) left right))) - (list (quote not) (list (quote =) left right))))))) + (list + (quote not) + (list (quote hs-id=) left right))))))) ((match-kw "empty") (list (quote empty?) left)) ((match-kw "less") (do @@ -1038,8 +1040,7 @@ ((prop (get (adv!) "value"))) (when (= (tp-type) "colon") (adv!)) (let - ((val (tp-val))) - (adv!) + ((val (if (and (= (tp-type) "ident") (= (tp-val) "$")) (do (adv!) (when (= (tp-type) "brace-open") (adv!)) (if (= (tp-type) "brace-close") (do (adv!) (if (= (tp-type) "brace-open") (do (adv!) (let ((inner (parse-expr))) (when (= (tp-type) "brace-close") (adv!)) inner)) "")) (let ((expr (parse-expr))) (when (= (tp-type) "brace-close") (adv!)) expr))) (get (adv!) "value")))) (set! pairs (cons (list prop val) pairs)) (collect-pairs!)))))) (collect-pairs!) @@ -1781,7 +1782,7 @@ ((url (if (and (= (tp-type) "keyword") (= (tp-val) "from")) (do (adv!) (parse-arith (parse-poss (parse-atom)))) nil))) (list (quote fetch-gql) gql-source url)))) (let - ((url-atom (if (and (= (tp-type) "op") (= (tp-val) "/")) (do (adv!) (let ((path-parts (list "/"))) (define read-path (fn () (when (and (not (at-end?)) (or (= (tp-type) "ident") (= (tp-type) "op") (= (tp-type) "dot") (= (tp-type) "number"))) (append! path-parts (tp-val)) (adv!) (read-path)))) (read-path) (join "" path-parts))) (parse-atom)))) + ((url-atom (if (and (= (tp-type) "op") (= (tp-val) "/")) (do (adv!) (let ((path-parts (list "/"))) (define read-path (fn () (when (and (not (at-end?)) (or (and (= (tp-type) "ident") (not (string-contains? (tp-val) "'"))) (= (tp-type) "op") (= (tp-type) "dot") (= (tp-type) "number"))) (append! path-parts (tp-val)) (adv!) (read-path)))) (read-path) (join "" path-parts))) (parse-atom)))) (let ((url (if (nil? url-atom) url-atom (parse-arith (parse-poss url-atom))))) (let @@ -1797,7 +1798,27 @@ ((fmt-after (if (and (not fmt-before) (match-kw "as")) (do (when (and (or (= (tp-type) "ident") (= (tp-type) "keyword")) (or (= (tp-val) "an") (= (tp-val) "a"))) (adv!)) (let ((f (tp-val))) (adv!) f)) nil))) (let ((fmt (or fmt-before fmt-after "text"))) - (list (quote fetch) url fmt))))))))) + (let + ((do-not-throw + (cond + ((and (or (= (tp-type) "keyword") (= (tp-type) "ident")) (= (tp-val) "do")) + (do + (adv!) + (if (and (or (= (tp-type) "keyword") (= (tp-type) "ident")) (= (tp-val) "not")) + (do + (adv!) + (if (and (or (= (tp-type) "keyword") (= (tp-type) "ident")) (= (tp-val) "throw")) + (do (adv!) true) + false)) + false))) + ((and (= (tp-type) "ident") (= (tp-val) "don't")) + (do + (adv!) + (if (and (or (= (tp-type) "keyword") (= (tp-type) "ident")) (= (tp-val) "throw")) + (do (adv!) true) + false))) + (true false)))) + (list (quote fetch) url fmt do-not-throw)))))))))) (define parse-call-args (fn diff --git a/lib/hyperscript/tokenizer.sx b/lib/hyperscript/tokenizer.sx index 6f652dea..6b1a8742 100644 --- a/lib/hyperscript/tokenizer.sx +++ b/lib/hyperscript/tokenizer.sx @@ -1,6 +1,6 @@ ;; _hyperscript tokenizer — produces token stream from hyperscript source ;; -;; Tokens: {:type T :value V :pos P :end E :line L} +;; Tokens: {:type T :value V :pos P} ;; Types: "keyword" "ident" "number" "string" "class" "id" "attr" "style" ;; "selector" "op" "dot" "paren-open" "paren-close" "bracket-open" ;; "bracket-close" "brace-open" "brace-close" "comma" "colon" @@ -8,7 +8,7 @@ ;; ── Token constructor ───────────────────────────────────────────── -(define hs-make-token (fn (type value pos end line) {:pos pos :end end :line line :value value :type type})) +(define hs-make-token (fn (type value pos) {:pos pos :value value :type type})) ;; ── Character predicates ────────────────────────────────────────── @@ -28,6 +28,27 @@ (define hs-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r")))) +(define + hs-hex-digit? + (fn + (c) + (or + (and (>= c "0") (<= c "9")) + (and (>= c "a") (<= c "f")) + (and (>= c "A") (<= c "F"))))) + +(define + hs-hex-val + (fn + (c) + (let + ((code (char-code c))) + (cond + ((and (>= code 48) (<= code 57)) (- code 48)) + ((and (>= code 65) (<= code 70)) (- code 55)) + ((and (>= code 97) (<= code 102)) (- code 87)) + (true 0))))) + ;; ── Keyword set ─────────────────────────────────────────────────── (define @@ -198,22 +219,14 @@ (fn (src) (let - ((tokens (list)) (pos 0) (src-len (len src)) (current-line 1)) + ((tokens (list)) (pos 0) (src-len (len src))) (define hs-peek (fn (offset) (if (< (+ pos offset) src-len) (nth src (+ pos offset)) nil))) (define hs-cur (fn () (hs-peek 0))) - (define - hs-advance! - (fn - (n) - (when - (> n 0) - (when (= (hs-cur) "\n") (set! current-line (+ current-line 1))) - (set! pos (+ pos 1)) - (hs-advance! (- n 1))))) + (define hs-advance! (fn (n) (set! pos (+ pos n)))) (define skip-ws! (fn @@ -243,10 +256,15 @@ read-number (fn (start) - (when - (and (< pos src-len) (hs-digit? (hs-cur))) - (hs-advance! 1) - (read-number start)) + (define + read-int + (fn + () + (when + (and (< pos src-len) (hs-digit? (hs-cur))) + (hs-advance! 1) + (read-int)))) + (read-int) (when (and (< pos src-len) @@ -254,15 +272,7 @@ (< (+ pos 1) src-len) (hs-digit? (hs-peek 1))) (hs-advance! 1) - (define - read-frac - (fn - () - (when - (and (< pos src-len) (hs-digit? (hs-cur))) - (hs-advance! 1) - (read-frac)))) - (read-frac)) + (read-int)) (do (when (and @@ -280,15 +290,7 @@ (< pos src-len) (or (= (hs-cur) "+") (= (hs-cur) "-"))) (hs-advance! 1)) - (define - read-exp-digits - (fn - () - (when - (and (< pos src-len) (hs-digit? (hs-cur))) - (hs-advance! 1) - (read-exp-digits)))) - (read-exp-digits)) + (read-int)) (let ((num-end pos)) (when @@ -316,7 +318,7 @@ () (cond (>= pos src-len) - nil + (error "Unterminated string") (= (hs-cur) "\\") (do (hs-advance! 1) @@ -326,15 +328,37 @@ ((ch (hs-cur))) (cond (= ch "n") - (append! chars "\n") + (do (append! chars "\n") (hs-advance! 1)) (= ch "t") - (append! chars "\t") + (do (append! chars "\t") (hs-advance! 1)) + (= ch "r") + (do (append! chars "\r") (hs-advance! 1)) + (= ch "b") + (do (append! chars (char-from-code 8)) (hs-advance! 1)) + (= ch "f") + (do (append! chars (char-from-code 12)) (hs-advance! 1)) + (= ch "v") + (do (append! chars (char-from-code 11)) (hs-advance! 1)) (= ch "\\") - (append! chars "\\") + (do (append! chars "\\") (hs-advance! 1)) (= ch quote-char) - (append! chars quote-char) - :else (do (append! chars "\\") (append! chars ch))) - (hs-advance! 1))) + (do (append! chars quote-char) (hs-advance! 1)) + (= ch "x") + (do + (hs-advance! 1) + (if + (and + (< (+ pos 1) src-len) + (hs-hex-digit? (hs-cur)) + (hs-hex-digit? (hs-peek 1))) + (let + ((d1 (hs-hex-val (hs-cur))) + (d2 (hs-hex-val (hs-peek 1)))) + (append! chars (char-from-code (+ (* d1 16) d2))) + (hs-advance! 2)) + (error "Invalid hexadecimal escape: \\x"))) + :else + (do (append! chars "\\") (append! chars ch) (hs-advance! 1))))) (loop)) (= (hs-cur) quote-char) (hs-advance! 1) @@ -435,8 +459,8 @@ (define hs-emit! (fn - (type value start start-line) - (append! tokens (hs-make-token type value start pos start-line)))) + (type value start) + (append! tokens (hs-make-token type value start)))) (define scan! (fn @@ -445,7 +469,7 @@ (when (< pos src-len) (let - ((ch (hs-cur)) (start pos) (start-line current-line)) + ((ch (hs-cur)) (start pos)) (cond (and (= ch "-") (< (+ pos 1) src-len) (= (hs-peek 1) "-")) (do (hs-advance! 2) (skip-comment!) (scan!)) @@ -462,9 +486,9 @@ (= (hs-peek 1) "[") (= (hs-peek 1) "*") (= (hs-peek 1) ":"))) - (do (hs-emit! "selector" (read-selector) start start-line) (scan!)) + (do (hs-emit! "selector" (read-selector) start) (scan!)) (and (= ch ".") (< (+ pos 1) src-len) (= (hs-peek 1) ".")) - (do (hs-advance! 2) (hs-emit! "op" ".." start start-line) (scan!)) + (do (hs-emit! "op" ".." start) (hs-advance! 2) (scan!)) (and (= ch ".") (< (+ pos 1) src-len) @@ -474,7 +498,7 @@ (= (hs-peek 1) "_"))) (do (hs-advance! 1) - (hs-emit! "class" (read-class-name pos) start start-line) + (hs-emit! "class" (read-class-name pos) start) (scan!)) (and (= ch "#") @@ -482,7 +506,7 @@ (hs-ident-start? (hs-peek 1))) (do (hs-advance! 1) - (hs-emit! "id" (read-ident pos) start start-line) + (hs-emit! "id" (read-ident pos) start) (scan!)) (and (= ch "@") @@ -490,7 +514,7 @@ (hs-ident-char? (hs-peek 1))) (do (hs-advance! 1) - (hs-emit! "attr" (read-ident pos) start start-line) + (hs-emit! "attr" (read-ident pos) start) (scan!)) (and (= ch "^") @@ -498,7 +522,7 @@ (hs-ident-char? (hs-peek 1))) (do (hs-advance! 1) - (hs-emit! "hat" (read-ident pos) start start-line) + (hs-emit! "hat" (read-ident pos) start) (scan!)) (and (= ch "~") @@ -506,7 +530,7 @@ (hs-letter? (hs-peek 1))) (do (hs-advance! 1) - (hs-emit! "component" (str "~" (read-ident pos)) start start-line) + (hs-emit! "component" (str "~" (read-ident pos)) start) (scan!)) (and (= ch "*") @@ -514,7 +538,7 @@ (hs-letter? (hs-peek 1))) (do (hs-advance! 1) - (hs-emit! "style" (read-ident pos) start start-line) + (hs-emit! "style" (read-ident pos) start) (scan!)) (and (= ch ":") @@ -522,7 +546,7 @@ (hs-ident-start? (hs-peek 1))) (do (hs-advance! 1) - (hs-emit! "local" (read-ident pos) start start-line) + (hs-emit! "local" (read-ident pos) start) (scan!)) (or (= ch "\"") @@ -535,20 +559,35 @@ (or (>= (+ pos 2) src-len) (not (hs-ident-char? (hs-peek 2)))))))) - (do (hs-emit! "string" (read-string ch) start start-line) (scan!)) + (do (hs-emit! "string" (read-string ch) start) (scan!)) (= ch "`") - (do (hs-emit! "template" (read-template) start start-line) (scan!)) + (do (hs-emit! "template" (read-template) start) (scan!)) (hs-digit? ch) - (do (hs-emit! "number" (read-number start) start start-line) (scan!)) + (do (hs-emit! "number" (read-number start) start) (scan!)) (hs-ident-start? ch) (do (let ((word (read-ident start))) - (hs-emit! - (if (hs-keyword? word) "keyword" "ident") - word - start - start-line)) + (let + ((full-word + (if + (and + (< pos src-len) + (= (hs-cur) "'") + (< (+ pos 1) src-len) + (hs-letter? (hs-peek 1)) + (not + (and + (= (hs-peek 1) "s") + (or + (>= (+ pos 2) src-len) + (not (hs-ident-char? (hs-peek 2))))))) + (do (hs-advance! 1) (str word "'" (read-ident pos))) + word))) + (hs-emit! + (if (hs-keyword? full-word) "keyword" "ident") + full-word + start))) (scan!)) (and (or (= ch "=") (= ch "!") (= ch "<") (= ch ">")) @@ -560,8 +599,8 @@ (or (= ch "=") (= ch "!")) (< (+ pos 2) src-len) (= (hs-peek 2) "=")) - (do (hs-advance! 3) (hs-emit! "op" (str ch "==") start start-line)) - (do (hs-advance! 2) (hs-emit! "op" (str ch "=") start start-line))) + (do (hs-emit! "op" (str ch "==") start) (hs-advance! 3)) + (do (hs-emit! "op" (str ch "=") start) (hs-advance! 2))) (scan!)) (and (= ch "'") @@ -570,66 +609,141 @@ (or (>= (+ pos 2) src-len) (not (hs-ident-char? (hs-peek 2))))) - (do (hs-advance! 2) (hs-emit! "op" "'s" start start-line) (scan!)) + (do (hs-emit! "op" "'s" start) (hs-advance! 2) (scan!)) (= ch "(") (do + (hs-emit! "paren-open" "(" start) (hs-advance! 1) - (hs-emit! "paren-open" "(" start start-line) (scan!)) (= ch ")") (do + (hs-emit! "paren-close" ")" start) (hs-advance! 1) - (hs-emit! "paren-close" ")" start start-line) (scan!)) (= ch "[") (do + (hs-emit! "bracket-open" "[" start) (hs-advance! 1) - (hs-emit! "bracket-open" "[" start start-line) (scan!)) (= ch "]") (do + (hs-emit! "bracket-close" "]" start) (hs-advance! 1) - (hs-emit! "bracket-close" "]" start start-line) (scan!)) (= ch "{") (do + (hs-emit! "brace-open" "{" start) (hs-advance! 1) - (hs-emit! "brace-open" "{" start start-line) (scan!)) (= ch "}") (do + (hs-emit! "brace-close" "}" start) (hs-advance! 1) - (hs-emit! "brace-close" "}" start start-line) (scan!)) (= ch ",") - (do (hs-advance! 1) (hs-emit! "comma" "," start start-line) (scan!)) + (do (hs-emit! "comma" "," start) (hs-advance! 1) (scan!)) (= ch "+") - (do (hs-advance! 1) (hs-emit! "op" "+" start start-line) (scan!)) + (do (hs-emit! "op" "+" start) (hs-advance! 1) (scan!)) (= ch "-") - (do (hs-advance! 1) (hs-emit! "op" "-" start start-line) (scan!)) + (do (hs-emit! "op" "-" start) (hs-advance! 1) (scan!)) (= ch "/") - (do (hs-advance! 1) (hs-emit! "op" "/" start start-line) (scan!)) + (do (hs-emit! "op" "/" start) (hs-advance! 1) (scan!)) (= ch "=") - (do (hs-advance! 1) (hs-emit! "op" "=" start start-line) (scan!)) + (do (hs-emit! "op" "=" start) (hs-advance! 1) (scan!)) (= ch "<") - (do (hs-advance! 1) (hs-emit! "op" "<" start start-line) (scan!)) + (do (hs-emit! "op" "<" start) (hs-advance! 1) (scan!)) (= ch ">") - (do (hs-advance! 1) (hs-emit! "op" ">" start start-line) (scan!)) + (do (hs-emit! "op" ">" start) (hs-advance! 1) (scan!)) (= ch "!") - (do (hs-advance! 1) (hs-emit! "op" "!" start start-line) (scan!)) + (do (hs-emit! "op" "!" start) (hs-advance! 1) (scan!)) (= ch "*") - (do (hs-advance! 1) (hs-emit! "op" "*" start start-line) (scan!)) + (do (hs-emit! "op" "*" start) (hs-advance! 1) (scan!)) (= ch "%") - (do (hs-advance! 1) (hs-emit! "op" "%" start start-line) (scan!)) + (do (hs-emit! "op" "%" start) (hs-advance! 1) (scan!)) (= ch ".") - (do (hs-advance! 1) (hs-emit! "dot" "." start start-line) (scan!)) + (do (hs-emit! "dot" "." start) (hs-advance! 1) (scan!)) (= ch "\\") - (do (hs-advance! 1) (hs-emit! "op" "\\" start start-line) (scan!)) + (do (hs-emit! "op" "\\" start) (hs-advance! 1) (scan!)) (= ch ":") - (do (hs-advance! 1) (hs-emit! "colon" ":" start start-line) (scan!)) + (do (hs-emit! "colon" ":" start) (hs-advance! 1) (scan!)) (= ch "|") - (do (hs-advance! 1) (hs-emit! "op" "|" start start-line) (scan!)) + (do (hs-emit! "op" "|" start) (hs-advance! 1) (scan!)) + (= ch "&") + (do (hs-emit! "op" "&" start) (hs-advance! 1) (scan!)) + (= ch "#") + (do (hs-emit! "op" "#" start) (hs-advance! 1) (scan!)) + (= ch "?") + (do (hs-emit! "op" "?" start) (hs-advance! 1) (scan!)) + (= ch ";") + (do (hs-emit! "op" ";" start) (hs-advance! 1) (scan!)) :else (do (hs-advance! 1) (scan!))))))) (scan!) - (hs-emit! "eof" nil pos current-line) + (hs-emit! "eof" nil pos) + tokens))) + +;; ── Template-mode tokenizer (E37 API) ──────────────────────────────── +;; Used by hs-tokens-of when :template flag is set. +;; Emits outer " chars as single STRING tokens; ${ ... } as $ { }; +;; inner content is tokenized with the regular hs-tokenize. + +(define + hs-tokenize-template + (fn + (src) + (let + ((tokens (list)) (pos 0) (src-len (len src))) + (define t-cur (fn () (if (< pos src-len) (nth src pos) nil))) + (define t-peek (fn (n) (if (< (+ pos n) src-len) (nth src (+ pos n)) nil))) + (define t-advance! (fn (n) (set! pos (+ pos n)))) + (define t-emit! (fn (type value) (append! tokens (hs-make-token type value pos)))) + (define + scan-to-close! + (fn + (depth) + (when + (and (< pos src-len) (> depth 0)) + (cond + (= (t-cur) "{") + (do (t-advance! 1) (scan-to-close! (+ depth 1))) + (= (t-cur) "}") + (when (> (- depth 1) 0) (t-advance! 1) (scan-to-close! (- depth 1))) + :else (do (t-advance! 1) (scan-to-close! depth)))))) + (define + scan-template! + (fn + () + (when + (< pos src-len) + (let + ((ch (t-cur))) + (cond + (= ch "\"") + (do (t-emit! "string" "\"") (t-advance! 1) (scan-template!)) + (and (= ch "$") (= (t-peek 1) "{")) + (do + (t-emit! "op" "$") + (t-advance! 1) + (t-emit! "brace-open" "{") + (t-advance! 1) + (let + ((inner-start pos)) + (scan-to-close! 1) + (let + ((inner-src (slice src inner-start pos)) + (inner-toks (hs-tokenize inner-src))) + (for-each + (fn (tok) + (when (not (= (get tok "type") "eof")) + (append! tokens tok))) + inner-toks)) + (t-emit! "brace-close" "}") + (when (< pos src-len) (t-advance! 1))) + (scan-template!)) + (= ch "$") + (do (t-emit! "op" "$") (t-advance! 1) (scan-template!)) + (hs-ws? ch) + (do (t-advance! 1) (scan-template!)) + :else (do (t-advance! 1) (scan-template!))))))) + (scan-template!) + (t-emit! "eof" nil) tokens))) \ No newline at end of file diff --git a/plans/hs-conformance-scoreboard.md b/plans/hs-conformance-scoreboard.md index e081b61b..14a345ea 100644 --- a/plans/hs-conformance-scoreboard.md +++ b/plans/hs-conformance-scoreboard.md @@ -4,10 +4,10 @@ Live tally for `plans/hs-conformance-to-100.md`. Update after every cluster comm ``` Baseline: 1213/1496 (81.1%) -Merged: 1303/1496 (87.1%) delta +90 +Merged: 1312/1496 (87.7%) delta +99 Worktree: all landed Target: 1496/1496 (100.0%) -Remaining: ~194 tests (clusters 17/29(partial)/31 blocked; 33/34 partial) +Remaining: ~192 tests (clusters 17/29(partial)/31 blocked; 33/34 partial) ``` ## Cluster ledger @@ -22,7 +22,7 @@ Remaining: ~194 tests (clusters 17/29(partial)/31 blocked; 33/34 partial) | 4 | `not` precedence over `or` | done | +3 | 4fe0b649 | | 5 | `some` selector for nonempty match | done | +1 | e7b86264 | | 6 | string template `${x}` | done | +2 | 108e25d4 | -| 7 | `put` hyperscript reprocessing | partial | +1 | f21eb008 | +| 7 | `put` hyperscript reprocessing | done | +5 | 247bd85c | | 8 | `select` returns selected text | done | +1 | d862efe8 | | 9 | `wait on event` basics | done | +4 | f79f96c1 | | 10 | `swap` variable ↔ property | done | +1 | 30f33341 | @@ -66,6 +66,7 @@ Remaining: ~194 tests (clusters 17/29(partial)/31 blocked; 33/34 partial) | 33 | cookie API | partial | +4 | | 34 | event modifier DSL | partial | +7 | | 35 | namespaced `def` | done | +3 | +| 36b | `call` result binds to `it` | done | +1 | 35f498ec | ### Bucket E — subsystems (design docs landed, pending review + implementation) @@ -75,12 +76,19 @@ Remaining: ~194 tests (clusters 17/29(partial)/31 blocked; 33/34 partial) | 37 | Tokenizer-as-API | design-done | `plans/designs/e37-tokenizer-api.md` | | 38 | SourceInfo API | design-done | `plans/designs/e38-sourceinfo.md` | | 39 | WebWorker plugin | design-done | `plans/designs/e39-webworker.md` | -| 40 | Fetch non-2xx / before-fetch / real response | design-done | `plans/designs/e40-real-fetch.md` | +| 40 | Fetch non-2xx / before-fetch / real response | done | +7 | d7244d1d | ### Bucket F — generator translation gaps Defer until A–D drain. Estimated ~25 recoverable tests. +| # | Cluster | Status | Δ | Commit | +|---|---------|--------|---|--------| +| F1 | add CSS template interpolation | done | +1 | 5a76a040 | +| F2 | empty multi-element (query→for-each) | done | +1 | 875e9ba3 | +| F3 | hs-make-object _order + assert= for dicts | done | +1 | daea2808 | +| F4 | array literal arg to JS fn (sxToJs + reduce→SX) | done | +1 | da2e6b1b | + ## Buckets roll-up | Bucket | Done | Partial | In-prog | Pending | Blocked | Design-done | Total | @@ -89,7 +97,7 @@ Defer until A–D drain. Estimated ~25 recoverable tests. | B | 7 | 0 | 0 | 0 | 0 | — | 7 | | C | 4 | 1 | 0 | 0 | 0 | — | 5 | | D | 2 | 2 | 0 | 0 | 1 | — | 5 | -| E | 0 | 0 | 0 | 0 | 0 | 5 | 5 | +| E | 1 | 0 | 0 | 0 | 0 | 4 | 5 | | F | — | — | — | ~10 | — | — | ~10 | ## Maintenance diff --git a/plans/hs-conformance-to-100.md b/plans/hs-conformance-to-100.md index 2e078de9..de89ef5e 100644 --- a/plans/hs-conformance-to-100.md +++ b/plans/hs-conformance-to-100.md @@ -61,7 +61,7 @@ Orchestrator cherry-picks worktree commits onto `architecture` one at a time; re 6. **[done (+2)] string template `${x}`** — `expressions/strings / string templates work w/ props` + `w/ braces` (2 tests). Template interpolation isn't substituting property accesses. Check `hs-template` runtime. Expected: +2. -7. **[done (+1) — partial, 3 tests remain: inserted-button handler doesn't fire for afterbegin/innerHTML paths; might need targeted trace of hs-boot-subtree! or _setInnerHTML timing] `put` hyperscript reprocessing** — `put / properly processes hyperscript at end/start/content/symbol` (4 tests, all `Expected 42, got 40`). After a put operation, newly inserted HS scripts aren't being activated. Fix: `hs-put-at!` should `hs-boot-subtree!` on the target after DOM insertion. Expected: +4. +7. **[done (+5)] `put` hyperscript reprocessing** — `put / properly processes hyperscript at end/start/content/symbol` (4 tests, all `Expected 42, got 40`). After a put operation, newly inserted HS scripts aren't being activated. Fix: `hs-put-at!` should `hs-boot-subtree!` on the target after DOM insertion. Expected: +4. 8. **[done (+1)] `select returns selected text`** (1 test, `hs-upstream-select`). Runtime `hs-get-selection` helper reads `window.__test_selection` stash (or falls back to real `window.getSelection().toString()`). Compiler rewrites `(ref "selection")` to `(hs-get-selection)`. Generator detects the `createRange` / `setStart` / `setEnd` / `addRange` block and emits a single `(host-set! ... __test_selection ...)` op with the resolved text slice of the target element. Expected: +1. @@ -125,19 +125,21 @@ Orchestrator cherry-picks worktree commits onto `architecture` one at a time; re 35. **[done (+3)] namespaced `def`** — 3 tests. `def ns.foo() ...` creates `ns.foo`. Expected: +3. +36b. **[done (+1)] `call` result binds to `it`** — `call / call functions that return promises are waited on` (1 test). `call X then put it into Y` wasn't setting `it` because the `call` compiler branch emitted the call expression directly without `emit-set`. Fixed by wrapping in `emit-set (quote the-result) call-expr`. Expected: +1. + ### Bucket E: subsystems (DO NOT LOOP — human-driven) All five have design docs on their own worktree branches pending review + merge. After merge, status flips to `design-ready` and they become eligible for the loop. 36. **[design-done, pending review — `plans/designs/e36-websocket.md` on `worktree-agent-a9daf73703f520257`] WebSocket + `socket`** — 16 tests. Upstream shape is `socket NAME URL [with timeout N] [on message [as JSON] …] end` with an **implicit `.rpc` Proxy** (ES6 Proxy lives in JS, not SX), not `with proxy { send, receive }` as this row previously claimed. Design doc has 8-commit checklist, +12–16 delta estimate. Ship only with intentional design review. -37. **[design-done, pending review — `plans/designs/e37-tokenizer-api.md` on `worktree-agent-a6bb61d59cc0be8b4`] Tokenizer-as-API** — 17 tests. Expose tokens as inspectable SX data via `hs-tokens-of` / `hs-stream-token` / `hs-token-type` etc; type-map current `hs-tokenize` output to upstream SCREAMING_SNAKE_CASE. 8-step checklist, +16–17 delta. +37. **[done +17]** Tokenizer-as-API — `hs-tokens-of` / `hs-stream-token` / `hs-token-type` / `hs-token-value` / `hs-token-op?`; type-map + normalize; `read-number` dot-stop fix; `\$` template escape in compiler + runtime; generator pattern in `generate-sx-tests.py`. 17/17. 38. **[design-done, pending review — `plans/designs/e38-sourceinfo.md` on `agent-e38-sourceinfo`] SourceInfo API** — 4 tests. Inline span-wrapper strategy (not side-channel dict) with compiler-entry unwrap. 4-commit plan. 39. **[design-done, pending review — `plans/designs/e39-webworker.md` on `hs-design-e39-webworker`] WebWorker plugin** — 1 test. Parser-only stub that errors with a link to upstream docs; no runtime, no mock Worker class. Hand-write the test (don't patch the generator). Single commit. -40. **[design-done, pending review — `plans/designs/e40-real-fetch.md` on `worktree-agent-a94612a4283eaa5e0`] Fetch non-2xx / before-fetch event / real response object** — 7 tests. SX-dict Response wrapper `{:_hs-response :ok :status :url :_body :_json :_html}`; restructured `hs-fetch` that always fetches wrapper then converts by format; test-name-keyed `_fetchScripts`. 11-step checklist. Watch for regression on cluster-1 JSON unwrap. +40. **[done +7 — d7244d1d] Fetch non-2xx / before-fetch event / real response object** — 7 tests. SX-dict Response wrapper `{:_hs-response :ok :status :url :_body :_json :_html}`; restructured `hs-fetch` that always fetches wrapper then converts by format; test-name-keyed `_fetchScripts`. 11-step checklist. Watch for regression on cluster-1 JSON unwrap. ### Bucket F: generator translation gaps (after bucket A-D) @@ -175,6 +177,27 @@ Many tests are `SKIP (untranslated)` because `tests/playwright/generate-sx-tests ## Progress log +### 2026-04-26 — Bucket F: array literal arg to JS fn (+1) +- **da2e6b1b** — `HS Bucket F: array literal arg to JS fn fix (+1 test)`. Two-part fix: (a) `generate-sx-tests.py` `js_expr_to_sx` now translates `arr.reduce(fn, init)` → `(reduce fn init arr)`, `.map(fn)` → `(map fn arr)`, `.filter(fn)` → `(filter fn arr)` so SX list arguments work with JS array HO methods. (b) `host-call-fn` in `hs-run-filtered.js` adds `sxToJs` recursive converter that unwraps SX list `._type==='list'` to native JS arrays before calling native JS functions. Together these fix functionCalls "can pass an array literal as an argument". Suite hs-upstream-expressions/functionCalls: 8/12 (unchanged SKIP ratio). Test 597: 0/1 → 1/1. Smoke 0-195: 175/195 unchanged. + +### 2026-04-26 — Bucket F: hs-make-object _order + assert= for dicts (+1) +- **daea2808** — `HS Bucket F: fix hs-make-object _order + assert= for dicts (+1 test)`. Two-part fix: (a) `runtime.sx` `hs-make-object` no longer appends `_order` key to HS object literals — V8's native string-key insertion order is sufficient, and the hidden key was breaking structural equality. (b) `generate-sx-tests.py` `emit_eval` now detects when `expected_sx` contains `{` (dict syntax) and emits `assert-equal` (which uses `equal?` for deep structural equality) instead of `assert=` (which uses `=`, reference equality for dicts). Together these fix arrayLiteral "arrays containing objects work". Suite hs-upstream-expressions/arrayLiteral: 7/8 → 8/8. Smoke 0-195 unchanged at 175/195. + +### 2026-04-26 — Bucket F: empty multi-element fix (+1) +- **875e9ba3** — `HS: empty multi-element fix (+1 test)`. `empty .class` compiled `(empty-target (query ".class"))` through `hs-to-sx` → `(hs-empty-target! (hs-query-first ".class"))` which only emptied the first match. Fix: detect `(query ...)` target in the `empty-target` compiler case and emit `(for-each (fn (_el) (hs-empty-target! _el)) (hs-query-all sel))`, mirroring the `add-class` pattern. Suite hs-upstream-empty: 12/13 → 13/13. Smoke 0-195: 175/195 unchanged. + +### 2026-04-26 — Bucket F: add CSS template interpolation (+1) +- **5a76a040** — `HS: add CSS template interpolation fix (+1 test)`. `add {color: ${}{"red"}}` uses two consecutive brace groups: the empty `${}` marker followed by `{"red"}` for the actual value. The prior parser fix called `parse-expr` when already at the closing `}` of the empty group, returning nil. Fix: detect the empty-brace case (`brace-open` → immediately `brace-close`), skip it, then read the actual value from the next `{…}` block. Also handles normal `${expr}` correctly. Suite hs-upstream-add: 17/19 → 18/19. Smoke 0-195: 174/195 → 175/195. + +### 2026-04-26 — cluster 36b call result binds to it (done +1) +- **35f498ec** — `hs: call command binds result to it via emit-set (+1 test)`. `call X then put it into Y` compiled `call X` without `emit-set`, so `it` remained nil. Wrapped call-expr in `emit-set (quote the-result) ...` so both `it` and `the-result` are updated. Suite hs-upstream-call: 5/6 → 6/6. Smoke 0-195: 173/195 → 174/195. + +### 2026-04-26 — cluster 7 put hyperscript reprocessing (done, final +1) +- **247bd85c** — `hs: register promiseAString/promiseAnInt as sync test fixtures (+1 test)`. Upstream test "waits on promises" calls `promiseAString()` via window global. OCaml run_tests.ml registers these as NativeFns returning "foo"/"42" synchronously; JS runner had no equivalent. Added `globalThis.promiseAString = () => 'foo'` and `globalThis.promiseAnInt = () => 42` to hs-run-filtered.js. Suite hs-upstream-put: 37/38 → 38/38 (fully done). Smoke 0-195: 173/195 unchanged. + +### 2026-04-26 — cluster 7 put hyperscript reprocessing (partial +3 more) +- **d663c91f** — `hs: stop event propagation after each hs-on handler fires (+3 tests)`. Root cause: click events bubble from b1 (inside d1) to d1, causing d1's `on click put ...` handler to re-fire and replace the just-modified b1 with fresh content (text=40). Fix: `hs-on`'s wrapped handler now calls `event.stopPropagation()` after each handler runs, preventing the bubbled click from reaching ancestor HS listeners. Tests 1147/1149/1150 now pass. Suite hs-upstream-put: 34/38 → 37/38. Smoke 0-195: 173/195 unchanged. One test remains: "waits on promises" (async/Promise issue). + (Reverse chronological — newest at top.) ### 2026-04-25 — Bucket F: in-expression filter semantics (+1) diff --git a/shared/static/wasm/sx/hs-compiler.sx b/shared/static/wasm/sx/hs-compiler.sx index 046cad78..2df6752b 100644 --- a/shared/static/wasm/sx/hs-compiler.sx +++ b/shared/static/wasm/sx/hs-compiler.sx @@ -789,1502 +789,1431 @@ (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))) + (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 define) - (make-symbol name-str) + (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 - (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)) + (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 - ((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) + ((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 - ((ch (nth raw i))) + ((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)) "{") + (and (= ch "$") (< (+ i 1) n)) + (if + (= (nth raw (+ i 1)) "{") + (let + ((start (+ i 2))) (let - ((start (+ i 2))) + ((close (tpl-find-close start 1))) (let - ((close (tpl-find-close start 1))) - (let - ((expr-src (slice raw start close))) - (do - (tpl-flush) - (set! + ((expr-src (slice raw start close))) + (do + (tpl-flush) + (set! + parts + (append parts - (append - parts - (list - (hs-to-sx - (hs-compile expr-src))))) - (set! i (+ close 1)) - (tpl-collect))))) + (list + (hs-to-sx (hs-compile expr-src))))) + (set! i (+ close 1)) + (tpl-collect))))) + (let + ((start (+ i 1))) (let - ((start (+ i 1))) + ((end (tpl-read-id start))) (let - ((end (tpl-read-id start))) - (let - ((ident (slice raw start end))) - (do - (tpl-flush) - (set! + ((ident (slice raw start end))) + (do + (tpl-flush) + (set! + parts + (append 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 + (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-index) + (quote hs-pick-first) (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head (quote array-slice)) + (hs-to-sx (nth ast 2))))) + ((= head (quote pick-last)) + (list + (quote set!) + (quote it) (list - (quote hs-slice) + (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-first)) + (hs-to-sx (nth ast 3))))) + ((= head (quote pick-match)) + (list + (quote set!) + (quote it) (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) + (quote hs-pick-match) (hs-to-sx (nth ast 1)) - (nth ast 2))) - ((= head (quote coll-where)) + (hs-to-sx (nth ast 2))))) + ((= head (quote pick-matches)) + (list + (quote set!) + (quote it) (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) + (quote hs-pick-matches) (hs-to-sx (nth ast 1)) - (list - (quote fn) - (list (quote it)) - (hs-to-sx (nth ast 2))))) - ((= head (quote coll-sorted-desc)) + (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 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)) + (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 map) - (list - (quote fn) - (list (quote it)) - (hs-to-sx (nth ast 2))) - (hs-to-sx (nth ast 1)))) - ((= head (quote coll-split)) + (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 hs-split-by) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head (quote coll-joined)) + (quote fn) + (list (quote it)) + (hs-to-sx (nth ast 2))))) + ((= head (quote coll-mapped)) + (list + (quote map) (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)))) + (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)))) (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)))) - (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 (quote ref)) + (= (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)))) (if - (= (nth ast 1) "selection") - (list (quote hs-get-selection)) - (make-symbol (nth ast 1)))) - ((= head (quote query)) - (list (quote hs-query-first) (nth ast 1))) - ((= head (quote query-scoped)) + (= (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 (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 (quote ref)) + (if + (= (nth ast 1) "selection") + (list (quote hs-get-selection)) + (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 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?) + (quote modulo) (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 =)) + (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 (quote +)) + (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 hs-add) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)))) - ((= head (quote -)) + (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-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) + (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 - (nil? (nth ast 2)) - (list (quote str) (hs-to-sx (nth ast 1)) "%") + (and (list? raw-tgt) (= (first raw-tgt) (quote query))) (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))) + (quote for-each) (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) + (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 =) - (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)) + (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 - ((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))) + ((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 _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-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-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 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) - (map - (fn (p) (list (quote dom-set-style) tgt p "")) - props)))) - ((= head (quote toggle-class)) + (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))) - ((= head (quote toggle-class-for)) + (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-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 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)) + (quote hs-wait-for) + (if source (hs-to-sx source) (quote me)) + event-name) + (list (quote hs-toggle-class!) tgt cls)))) + ((= 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 - (> (len ast) 3) + (and (list? lhs) (= (first lhs) (quote dom-ref))) (list - (quote if) - (hs-to-sx (nth ast 1)) - (hs-to-sx (nth ast 2)) - (hs-to-sx (nth ast 3))) + (quote hs-dom-set!) + (hs-to-sx tgt-ast) + (nth lhs 1) + (hs-to-sx val-ast)) (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-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) - (= (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))) - (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 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)) + (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-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)) + (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 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) + (quote if) (hs-to-sx (nth ast 1)) - (nth ast 2))) - ((= head (quote fetch-gql)) + (hs-to-sx (nth ast 2)) + (hs-to-sx (nth ast 3))) (list - (quote hs-fetch-gql) - (nth ast 1) - (if (nth ast 2) (hs-to-sx (nth ast 2)) nil))) - ((= head (quote call)) + (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 - ((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))))) + ((compiled (map hs-to-sx expanded))) (if - (and (list? raw-fn) (= (first raw-fn) (quote ref))) - (list - (quote hs-win-call) - (nth raw-fn 1) - (cons (quote list) args)) - (cons fn-expr args)))) - ((= head (quote return)) - (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 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 + (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-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 - 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)) + (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))) + (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-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)))) + (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 define) - (make-symbol (nth ast 1)) + (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 - (quote let) (list + (quote __hs-show-r) (list - (quote _hs-def-val) + (quote hs-show-when!) + tgt + strategy (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 it)) + (hs-to-sx when-cond))))) (list - (quote let) + (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) (nth ast 3) (quote me))) + ((= 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))))) + (if + (and (list? raw-fn) (= (first raw-fn) (quote ref))) + (list + (quote hs-win-call) + (nth raw-fn 1) + (cons (quote list) args)) + (cons fn-expr args)))) + ((= head (quote return)) + (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 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 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 let) + (list + (list + (quote _hs-def-val) (list - (quote __hs-js) + (quote fn) + params (list - (quote hs-js-exec) - (cons (quote list) params) - js-src - (cons (quote list) bound-syms)))) + (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 begin) - (list (quote set!) (quote it) (quote __hs-js)) - (quote __hs-js)))))) - (true ast))))))))) + (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)))) + (true ast)))))))) ;; ── Convenience: source → SX ───────────────────────────────── (define hs-to-sx-from-source (fn (src) (hs-to-sx (hs-compile src)))) \ No newline at end of file diff --git a/shared/static/wasm/sx/hs-parser.sx b/shared/static/wasm/sx/hs-parser.sx index cdc172e5..a9aae1c9 100644 --- a/shared/static/wasm/sx/hs-parser.sx +++ b/shared/static/wasm/sx/hs-parser.sx @@ -560,7 +560,9 @@ (list (quote not) (list (quote eq-ignore-case) left right))) - (list (quote not) (list (quote =) left right))))))) + (list + (quote not) + (list (quote hs-id=) left right))))))) ((match-kw "empty") (list (quote empty?) left)) ((match-kw "less") (do @@ -1038,8 +1040,7 @@ ((prop (get (adv!) "value"))) (when (= (tp-type) "colon") (adv!)) (let - ((val (tp-val))) - (adv!) + ((val (if (and (= (tp-type) "ident") (= (tp-val) "$")) (do (adv!) (when (= (tp-type) "brace-open") (adv!)) (if (= (tp-type) "brace-close") (do (adv!) (if (= (tp-type) "brace-open") (do (adv!) (let ((inner (parse-expr))) (when (= (tp-type) "brace-close") (adv!)) inner)) "")) (let ((expr (parse-expr))) (when (= (tp-type) "brace-close") (adv!)) expr))) (get (adv!) "value")))) (set! pairs (cons (list prop val) pairs)) (collect-pairs!)))))) (collect-pairs!) @@ -1781,7 +1782,7 @@ ((url (if (and (= (tp-type) "keyword") (= (tp-val) "from")) (do (adv!) (parse-arith (parse-poss (parse-atom)))) nil))) (list (quote fetch-gql) gql-source url)))) (let - ((url-atom (if (and (= (tp-type) "op") (= (tp-val) "/")) (do (adv!) (let ((path-parts (list "/"))) (define read-path (fn () (when (and (not (at-end?)) (or (= (tp-type) "ident") (= (tp-type) "op") (= (tp-type) "dot") (= (tp-type) "number"))) (append! path-parts (tp-val)) (adv!) (read-path)))) (read-path) (join "" path-parts))) (parse-atom)))) + ((url-atom (if (and (= (tp-type) "op") (= (tp-val) "/")) (do (adv!) (let ((path-parts (list "/"))) (define read-path (fn () (when (and (not (at-end?)) (or (and (= (tp-type) "ident") (not (string-contains? (tp-val) "'"))) (= (tp-type) "op") (= (tp-type) "dot") (= (tp-type) "number"))) (append! path-parts (tp-val)) (adv!) (read-path)))) (read-path) (join "" path-parts))) (parse-atom)))) (let ((url (if (nil? url-atom) url-atom (parse-arith (parse-poss url-atom))))) (let @@ -1797,7 +1798,27 @@ ((fmt-after (if (and (not fmt-before) (match-kw "as")) (do (when (and (or (= (tp-type) "ident") (= (tp-type) "keyword")) (or (= (tp-val) "an") (= (tp-val) "a"))) (adv!)) (let ((f (tp-val))) (adv!) f)) nil))) (let ((fmt (or fmt-before fmt-after "text"))) - (list (quote fetch) url fmt))))))))) + (let + ((do-not-throw + (cond + ((and (or (= (tp-type) "keyword") (= (tp-type) "ident")) (= (tp-val) "do")) + (do + (adv!) + (if (and (or (= (tp-type) "keyword") (= (tp-type) "ident")) (= (tp-val) "not")) + (do + (adv!) + (if (and (or (= (tp-type) "keyword") (= (tp-type) "ident")) (= (tp-val) "throw")) + (do (adv!) true) + false)) + false))) + ((and (= (tp-type) "ident") (= (tp-val) "don't")) + (do + (adv!) + (if (and (or (= (tp-type) "keyword") (= (tp-type) "ident")) (= (tp-val) "throw")) + (do (adv!) true) + false))) + (true false)))) + (list (quote fetch) url fmt do-not-throw)))))))))) (define parse-call-args (fn diff --git a/shared/static/wasm/sx/hs-tokenizer.sx b/shared/static/wasm/sx/hs-tokenizer.sx index 6f652dea..6b1a8742 100644 --- a/shared/static/wasm/sx/hs-tokenizer.sx +++ b/shared/static/wasm/sx/hs-tokenizer.sx @@ -1,6 +1,6 @@ ;; _hyperscript tokenizer — produces token stream from hyperscript source ;; -;; Tokens: {:type T :value V :pos P :end E :line L} +;; Tokens: {:type T :value V :pos P} ;; Types: "keyword" "ident" "number" "string" "class" "id" "attr" "style" ;; "selector" "op" "dot" "paren-open" "paren-close" "bracket-open" ;; "bracket-close" "brace-open" "brace-close" "comma" "colon" @@ -8,7 +8,7 @@ ;; ── Token constructor ───────────────────────────────────────────── -(define hs-make-token (fn (type value pos end line) {:pos pos :end end :line line :value value :type type})) +(define hs-make-token (fn (type value pos) {:pos pos :value value :type type})) ;; ── Character predicates ────────────────────────────────────────── @@ -28,6 +28,27 @@ (define hs-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r")))) +(define + hs-hex-digit? + (fn + (c) + (or + (and (>= c "0") (<= c "9")) + (and (>= c "a") (<= c "f")) + (and (>= c "A") (<= c "F"))))) + +(define + hs-hex-val + (fn + (c) + (let + ((code (char-code c))) + (cond + ((and (>= code 48) (<= code 57)) (- code 48)) + ((and (>= code 65) (<= code 70)) (- code 55)) + ((and (>= code 97) (<= code 102)) (- code 87)) + (true 0))))) + ;; ── Keyword set ─────────────────────────────────────────────────── (define @@ -198,22 +219,14 @@ (fn (src) (let - ((tokens (list)) (pos 0) (src-len (len src)) (current-line 1)) + ((tokens (list)) (pos 0) (src-len (len src))) (define hs-peek (fn (offset) (if (< (+ pos offset) src-len) (nth src (+ pos offset)) nil))) (define hs-cur (fn () (hs-peek 0))) - (define - hs-advance! - (fn - (n) - (when - (> n 0) - (when (= (hs-cur) "\n") (set! current-line (+ current-line 1))) - (set! pos (+ pos 1)) - (hs-advance! (- n 1))))) + (define hs-advance! (fn (n) (set! pos (+ pos n)))) (define skip-ws! (fn @@ -243,10 +256,15 @@ read-number (fn (start) - (when - (and (< pos src-len) (hs-digit? (hs-cur))) - (hs-advance! 1) - (read-number start)) + (define + read-int + (fn + () + (when + (and (< pos src-len) (hs-digit? (hs-cur))) + (hs-advance! 1) + (read-int)))) + (read-int) (when (and (< pos src-len) @@ -254,15 +272,7 @@ (< (+ pos 1) src-len) (hs-digit? (hs-peek 1))) (hs-advance! 1) - (define - read-frac - (fn - () - (when - (and (< pos src-len) (hs-digit? (hs-cur))) - (hs-advance! 1) - (read-frac)))) - (read-frac)) + (read-int)) (do (when (and @@ -280,15 +290,7 @@ (< pos src-len) (or (= (hs-cur) "+") (= (hs-cur) "-"))) (hs-advance! 1)) - (define - read-exp-digits - (fn - () - (when - (and (< pos src-len) (hs-digit? (hs-cur))) - (hs-advance! 1) - (read-exp-digits)))) - (read-exp-digits)) + (read-int)) (let ((num-end pos)) (when @@ -316,7 +318,7 @@ () (cond (>= pos src-len) - nil + (error "Unterminated string") (= (hs-cur) "\\") (do (hs-advance! 1) @@ -326,15 +328,37 @@ ((ch (hs-cur))) (cond (= ch "n") - (append! chars "\n") + (do (append! chars "\n") (hs-advance! 1)) (= ch "t") - (append! chars "\t") + (do (append! chars "\t") (hs-advance! 1)) + (= ch "r") + (do (append! chars "\r") (hs-advance! 1)) + (= ch "b") + (do (append! chars (char-from-code 8)) (hs-advance! 1)) + (= ch "f") + (do (append! chars (char-from-code 12)) (hs-advance! 1)) + (= ch "v") + (do (append! chars (char-from-code 11)) (hs-advance! 1)) (= ch "\\") - (append! chars "\\") + (do (append! chars "\\") (hs-advance! 1)) (= ch quote-char) - (append! chars quote-char) - :else (do (append! chars "\\") (append! chars ch))) - (hs-advance! 1))) + (do (append! chars quote-char) (hs-advance! 1)) + (= ch "x") + (do + (hs-advance! 1) + (if + (and + (< (+ pos 1) src-len) + (hs-hex-digit? (hs-cur)) + (hs-hex-digit? (hs-peek 1))) + (let + ((d1 (hs-hex-val (hs-cur))) + (d2 (hs-hex-val (hs-peek 1)))) + (append! chars (char-from-code (+ (* d1 16) d2))) + (hs-advance! 2)) + (error "Invalid hexadecimal escape: \\x"))) + :else + (do (append! chars "\\") (append! chars ch) (hs-advance! 1))))) (loop)) (= (hs-cur) quote-char) (hs-advance! 1) @@ -435,8 +459,8 @@ (define hs-emit! (fn - (type value start start-line) - (append! tokens (hs-make-token type value start pos start-line)))) + (type value start) + (append! tokens (hs-make-token type value start)))) (define scan! (fn @@ -445,7 +469,7 @@ (when (< pos src-len) (let - ((ch (hs-cur)) (start pos) (start-line current-line)) + ((ch (hs-cur)) (start pos)) (cond (and (= ch "-") (< (+ pos 1) src-len) (= (hs-peek 1) "-")) (do (hs-advance! 2) (skip-comment!) (scan!)) @@ -462,9 +486,9 @@ (= (hs-peek 1) "[") (= (hs-peek 1) "*") (= (hs-peek 1) ":"))) - (do (hs-emit! "selector" (read-selector) start start-line) (scan!)) + (do (hs-emit! "selector" (read-selector) start) (scan!)) (and (= ch ".") (< (+ pos 1) src-len) (= (hs-peek 1) ".")) - (do (hs-advance! 2) (hs-emit! "op" ".." start start-line) (scan!)) + (do (hs-emit! "op" ".." start) (hs-advance! 2) (scan!)) (and (= ch ".") (< (+ pos 1) src-len) @@ -474,7 +498,7 @@ (= (hs-peek 1) "_"))) (do (hs-advance! 1) - (hs-emit! "class" (read-class-name pos) start start-line) + (hs-emit! "class" (read-class-name pos) start) (scan!)) (and (= ch "#") @@ -482,7 +506,7 @@ (hs-ident-start? (hs-peek 1))) (do (hs-advance! 1) - (hs-emit! "id" (read-ident pos) start start-line) + (hs-emit! "id" (read-ident pos) start) (scan!)) (and (= ch "@") @@ -490,7 +514,7 @@ (hs-ident-char? (hs-peek 1))) (do (hs-advance! 1) - (hs-emit! "attr" (read-ident pos) start start-line) + (hs-emit! "attr" (read-ident pos) start) (scan!)) (and (= ch "^") @@ -498,7 +522,7 @@ (hs-ident-char? (hs-peek 1))) (do (hs-advance! 1) - (hs-emit! "hat" (read-ident pos) start start-line) + (hs-emit! "hat" (read-ident pos) start) (scan!)) (and (= ch "~") @@ -506,7 +530,7 @@ (hs-letter? (hs-peek 1))) (do (hs-advance! 1) - (hs-emit! "component" (str "~" (read-ident pos)) start start-line) + (hs-emit! "component" (str "~" (read-ident pos)) start) (scan!)) (and (= ch "*") @@ -514,7 +538,7 @@ (hs-letter? (hs-peek 1))) (do (hs-advance! 1) - (hs-emit! "style" (read-ident pos) start start-line) + (hs-emit! "style" (read-ident pos) start) (scan!)) (and (= ch ":") @@ -522,7 +546,7 @@ (hs-ident-start? (hs-peek 1))) (do (hs-advance! 1) - (hs-emit! "local" (read-ident pos) start start-line) + (hs-emit! "local" (read-ident pos) start) (scan!)) (or (= ch "\"") @@ -535,20 +559,35 @@ (or (>= (+ pos 2) src-len) (not (hs-ident-char? (hs-peek 2)))))))) - (do (hs-emit! "string" (read-string ch) start start-line) (scan!)) + (do (hs-emit! "string" (read-string ch) start) (scan!)) (= ch "`") - (do (hs-emit! "template" (read-template) start start-line) (scan!)) + (do (hs-emit! "template" (read-template) start) (scan!)) (hs-digit? ch) - (do (hs-emit! "number" (read-number start) start start-line) (scan!)) + (do (hs-emit! "number" (read-number start) start) (scan!)) (hs-ident-start? ch) (do (let ((word (read-ident start))) - (hs-emit! - (if (hs-keyword? word) "keyword" "ident") - word - start - start-line)) + (let + ((full-word + (if + (and + (< pos src-len) + (= (hs-cur) "'") + (< (+ pos 1) src-len) + (hs-letter? (hs-peek 1)) + (not + (and + (= (hs-peek 1) "s") + (or + (>= (+ pos 2) src-len) + (not (hs-ident-char? (hs-peek 2))))))) + (do (hs-advance! 1) (str word "'" (read-ident pos))) + word))) + (hs-emit! + (if (hs-keyword? full-word) "keyword" "ident") + full-word + start))) (scan!)) (and (or (= ch "=") (= ch "!") (= ch "<") (= ch ">")) @@ -560,8 +599,8 @@ (or (= ch "=") (= ch "!")) (< (+ pos 2) src-len) (= (hs-peek 2) "=")) - (do (hs-advance! 3) (hs-emit! "op" (str ch "==") start start-line)) - (do (hs-advance! 2) (hs-emit! "op" (str ch "=") start start-line))) + (do (hs-emit! "op" (str ch "==") start) (hs-advance! 3)) + (do (hs-emit! "op" (str ch "=") start) (hs-advance! 2))) (scan!)) (and (= ch "'") @@ -570,66 +609,141 @@ (or (>= (+ pos 2) src-len) (not (hs-ident-char? (hs-peek 2))))) - (do (hs-advance! 2) (hs-emit! "op" "'s" start start-line) (scan!)) + (do (hs-emit! "op" "'s" start) (hs-advance! 2) (scan!)) (= ch "(") (do + (hs-emit! "paren-open" "(" start) (hs-advance! 1) - (hs-emit! "paren-open" "(" start start-line) (scan!)) (= ch ")") (do + (hs-emit! "paren-close" ")" start) (hs-advance! 1) - (hs-emit! "paren-close" ")" start start-line) (scan!)) (= ch "[") (do + (hs-emit! "bracket-open" "[" start) (hs-advance! 1) - (hs-emit! "bracket-open" "[" start start-line) (scan!)) (= ch "]") (do + (hs-emit! "bracket-close" "]" start) (hs-advance! 1) - (hs-emit! "bracket-close" "]" start start-line) (scan!)) (= ch "{") (do + (hs-emit! "brace-open" "{" start) (hs-advance! 1) - (hs-emit! "brace-open" "{" start start-line) (scan!)) (= ch "}") (do + (hs-emit! "brace-close" "}" start) (hs-advance! 1) - (hs-emit! "brace-close" "}" start start-line) (scan!)) (= ch ",") - (do (hs-advance! 1) (hs-emit! "comma" "," start start-line) (scan!)) + (do (hs-emit! "comma" "," start) (hs-advance! 1) (scan!)) (= ch "+") - (do (hs-advance! 1) (hs-emit! "op" "+" start start-line) (scan!)) + (do (hs-emit! "op" "+" start) (hs-advance! 1) (scan!)) (= ch "-") - (do (hs-advance! 1) (hs-emit! "op" "-" start start-line) (scan!)) + (do (hs-emit! "op" "-" start) (hs-advance! 1) (scan!)) (= ch "/") - (do (hs-advance! 1) (hs-emit! "op" "/" start start-line) (scan!)) + (do (hs-emit! "op" "/" start) (hs-advance! 1) (scan!)) (= ch "=") - (do (hs-advance! 1) (hs-emit! "op" "=" start start-line) (scan!)) + (do (hs-emit! "op" "=" start) (hs-advance! 1) (scan!)) (= ch "<") - (do (hs-advance! 1) (hs-emit! "op" "<" start start-line) (scan!)) + (do (hs-emit! "op" "<" start) (hs-advance! 1) (scan!)) (= ch ">") - (do (hs-advance! 1) (hs-emit! "op" ">" start start-line) (scan!)) + (do (hs-emit! "op" ">" start) (hs-advance! 1) (scan!)) (= ch "!") - (do (hs-advance! 1) (hs-emit! "op" "!" start start-line) (scan!)) + (do (hs-emit! "op" "!" start) (hs-advance! 1) (scan!)) (= ch "*") - (do (hs-advance! 1) (hs-emit! "op" "*" start start-line) (scan!)) + (do (hs-emit! "op" "*" start) (hs-advance! 1) (scan!)) (= ch "%") - (do (hs-advance! 1) (hs-emit! "op" "%" start start-line) (scan!)) + (do (hs-emit! "op" "%" start) (hs-advance! 1) (scan!)) (= ch ".") - (do (hs-advance! 1) (hs-emit! "dot" "." start start-line) (scan!)) + (do (hs-emit! "dot" "." start) (hs-advance! 1) (scan!)) (= ch "\\") - (do (hs-advance! 1) (hs-emit! "op" "\\" start start-line) (scan!)) + (do (hs-emit! "op" "\\" start) (hs-advance! 1) (scan!)) (= ch ":") - (do (hs-advance! 1) (hs-emit! "colon" ":" start start-line) (scan!)) + (do (hs-emit! "colon" ":" start) (hs-advance! 1) (scan!)) (= ch "|") - (do (hs-advance! 1) (hs-emit! "op" "|" start start-line) (scan!)) + (do (hs-emit! "op" "|" start) (hs-advance! 1) (scan!)) + (= ch "&") + (do (hs-emit! "op" "&" start) (hs-advance! 1) (scan!)) + (= ch "#") + (do (hs-emit! "op" "#" start) (hs-advance! 1) (scan!)) + (= ch "?") + (do (hs-emit! "op" "?" start) (hs-advance! 1) (scan!)) + (= ch ";") + (do (hs-emit! "op" ";" start) (hs-advance! 1) (scan!)) :else (do (hs-advance! 1) (scan!))))))) (scan!) - (hs-emit! "eof" nil pos current-line) + (hs-emit! "eof" nil pos) + tokens))) + +;; ── Template-mode tokenizer (E37 API) ──────────────────────────────── +;; Used by hs-tokens-of when :template flag is set. +;; Emits outer " chars as single STRING tokens; ${ ... } as $ { }; +;; inner content is tokenized with the regular hs-tokenize. + +(define + hs-tokenize-template + (fn + (src) + (let + ((tokens (list)) (pos 0) (src-len (len src))) + (define t-cur (fn () (if (< pos src-len) (nth src pos) nil))) + (define t-peek (fn (n) (if (< (+ pos n) src-len) (nth src (+ pos n)) nil))) + (define t-advance! (fn (n) (set! pos (+ pos n)))) + (define t-emit! (fn (type value) (append! tokens (hs-make-token type value pos)))) + (define + scan-to-close! + (fn + (depth) + (when + (and (< pos src-len) (> depth 0)) + (cond + (= (t-cur) "{") + (do (t-advance! 1) (scan-to-close! (+ depth 1))) + (= (t-cur) "}") + (when (> (- depth 1) 0) (t-advance! 1) (scan-to-close! (- depth 1))) + :else (do (t-advance! 1) (scan-to-close! depth)))))) + (define + scan-template! + (fn + () + (when + (< pos src-len) + (let + ((ch (t-cur))) + (cond + (= ch "\"") + (do (t-emit! "string" "\"") (t-advance! 1) (scan-template!)) + (and (= ch "$") (= (t-peek 1) "{")) + (do + (t-emit! "op" "$") + (t-advance! 1) + (t-emit! "brace-open" "{") + (t-advance! 1) + (let + ((inner-start pos)) + (scan-to-close! 1) + (let + ((inner-src (slice src inner-start pos)) + (inner-toks (hs-tokenize inner-src))) + (for-each + (fn (tok) + (when (not (= (get tok "type") "eof")) + (append! tokens tok))) + inner-toks)) + (t-emit! "brace-close" "}") + (when (< pos src-len) (t-advance! 1))) + (scan-template!)) + (= ch "$") + (do (t-emit! "op" "$") (t-advance! 1) (scan-template!)) + (hs-ws? ch) + (do (t-advance! 1) (scan-template!)) + :else (do (t-advance! 1) (scan-template!))))))) + (scan-template!) + (t-emit! "eof" nil) tokens))) \ No newline at end of file diff --git a/tests/hs-run-filtered.js b/tests/hs-run-filtered.js index 84268cfd..39681186 100755 --- a/tests/hs-run-filtered.js +++ b/tests/hs-run-filtered.js @@ -81,7 +81,7 @@ class El { hasAttribute(n) { return n in this.attributes; } addEventListener(e,f) { if(!this._listeners[e])this._listeners[e]=[]; this._listeners[e].push(f); } removeEventListener(e,f) { if(this._listeners[e])this._listeners[e]=this._listeners[e].filter(x=>x!==f); } - dispatchEvent(ev) { ev.target=ev.target||this; ev.currentTarget=this; const fns=[...(this._listeners[ev.type]||[])]; for(const f of fns){if(ev._si)break;try{f.call(this,ev);}catch(e){}} if(ev.bubbles&&!ev._sp&&this.parentElement){this.parentElement.dispatchEvent(ev);} return !ev.defaultPrevented; } + dispatchEvent(ev) { ev.target=ev.target||this; ev.currentTarget=this; const fns=[...(this._listeners[ev.type]||[])]; for(const f of fns){if(ev._si)break;try{f.call(this,ev);}catch(e){}} if(ev.bubbles&&!ev._sp){if(this.parentElement){this.parentElement.dispatchEvent(ev);}else if(globalThis._windowListeners){globalThis.dispatchEvent(ev);}} return !ev.defaultPrevented; } appendChild(c) { if(c.parentElement)c.parentElement.removeChild(c); c.parentElement=this; c.parentNode=this; this.children.push(c); this.childNodes.push(c); if(this.tagName==='SELECT'&&c.tagName==='OPTION'){this.options.push(c);if(c.selected&&this.selectedIndex<0)this.selectedIndex=this.options.length-1;} this._syncText(); return c; } removeChild(c) { this.children=this.children.filter(x=>x!==c); this.childNodes=this.childNodes.filter(x=>x!==c); c.parentElement=null; c.parentNode=null; this._syncText(); return c; } insertBefore(n,r) { if(n.parentElement)n.parentElement.removeChild(n); const i=this.children.indexOf(r); if(i>=0){this.children.splice(i,0,n);this.childNodes.splice(i,0,n);}else{this.children.push(n);this.childNodes.push(n);} n.parentElement=this;n.parentNode=this; this._syncText(); return n; } @@ -297,6 +297,15 @@ function mt(e,s) { const m = base.match(/^\[([^\]=]+)(?:="([^"]*)")?\]$/); if(m) return m[2] !== undefined ? e.getAttribute(m[1]) === m[2] : e.hasAttribute(m[1]); } + // Compound tag[attr=val] e.g. input[type=checkbox] or input[type="checkbox"] + if(base.includes('[')) { + const cm = base.match(/^([\w-]+)(\[.+\])$/); + if(cm) { + if(e.tagName.toLowerCase() !== cm[1]) return false; + const attrParts = cm[2].match(/^\[([^\]=]+)(?:=["']?([^"'\]]+)["']?)?\]$/); + if(attrParts) return attrParts[2] !== undefined ? e.getAttribute(attrParts[1]) === attrParts[2] : e.hasAttribute(attrParts[1]); + } + } if(base.includes('.')) { const [tag, cls] = base.split('.'); return e.tagName.toLowerCase() === tag && e.classList.contains(cls); } if(base.includes('#')) { const [tag, id] = base.split('#'); return e.tagName.toLowerCase() === tag && e.id === id; } return e.tagName.toLowerCase() === base.toLowerCase(); @@ -327,6 +336,11 @@ const document = { createEvent(t){return new Ev(t);}, addEventListener(){}, removeEventListener(){}, }; globalThis.document=document; globalThis.window=globalThis; globalThis.HTMLElement=El; globalThis.Element=El; +// window event-target shim (for hyperscript:beforeFetch and similar bubbled events) +globalThis._windowListeners={}; +globalThis.addEventListener=function(e,f){if(!globalThis._windowListeners[e])globalThis._windowListeners[e]=[];globalThis._windowListeners[e].push(f);}; +globalThis.removeEventListener=function(e,f){if(globalThis._windowListeners[e])globalThis._windowListeners[e]=globalThis._windowListeners[e].filter(x=>x!==f);}; +globalThis.dispatchEvent=function(ev){const fns=[...(globalThis._windowListeners[ev.type]||[])];for(const f of fns){if(ev&&ev._si)break;try{f.call(globalThis,ev);}catch(e){}}return ev?!ev.defaultPrevented:true;}; // cluster-33: cookie store + document.cookie + cookies Proxy. globalThis.__hsCookieStore = new Map(); Object.defineProperty(document, 'cookie', { @@ -542,6 +556,9 @@ globalThis.console = { log: () => {}, error: () => {}, warn: () => {}, info: () const _log = _origLog; // keep reference for our own output // ─── FFI ──────────────────────────────────────────────────────── +// JS-level reference equality for host objects (works around OCaml boxing). +// The SX `=` primitive doesn't do JS === for host objects in the WASM kernel. +K.registerNative('hs-ref-eq',a=>a[0]===a[1]); K.registerNative('host-global',a=>{const n=a[0];return(n in globalThis)?globalThis[n]:null;}); K.registerNative('host-get',a=>{ if(a[0]==null)return null; @@ -559,7 +576,7 @@ K.registerNative('host-get',a=>{ }); K.registerNative('host-set!',a=>{if(a[0]!=null){const v=a[2]; if(a[1]==='innerHTML'&&a[0] instanceof El){const s=v===null?'null':v===undefined?'':String(v);a[0]._setInnerHTML(s);a[0][a[1]]=a[0].innerHTML;} else if(a[1]==='textContent'&&a[0] instanceof El){const s=v===null?'null':v===undefined?'':String(v);a[0].textContent=s;a[0].innerHTML=s;for(const c of a[0].children){c.parentElement=null;c.parentNode=null;}a[0].children=[];a[0].childNodes=[];} else{a[0][a[1]]=v;}} return a[2];}); K.registerNative('host-call',a=>{if(_testDeadline&&Date.now()>_testDeadline)throw new Error('TIMEOUT: wall clock exceeded');const[o,m,...r]=a;if(o==null){const f=globalThis[m];return typeof f==='function'?f.apply(null,r):null;}if(o&&typeof o[m]==='function'){try{const v=o[m].apply(o,r);return v===undefined?null:v;}catch(e){return null;}}return null;}); -K.registerNative('host-call-fn',a=>{const[fn,argList]=a;if(typeof fn!=='function'&&!(fn&&fn.__sx_handle!==undefined))return null;const callArgs=(argList&&argList._type==='list'&&argList.items)?Array.from(argList.items):(Array.isArray(argList)?argList:[]);if(fn&&fn.__sx_handle!==undefined)return K.callFn(fn,callArgs);try{const v=fn.apply(null,callArgs);return v===undefined?null:v;}catch(e){return null;}}); +K.registerNative('host-call-fn',a=>{const[fn,argList]=a;if(typeof fn!=='function'&&!(fn&&fn.__sx_handle!==undefined))return null;const callArgs=(argList&&argList._type==='list'&&argList.items)?Array.from(argList.items):(Array.isArray(argList)?argList:[]);if(fn&&fn.__sx_handle!==undefined)return K.callFn(fn,callArgs);function sxToJs(v){if(v&&v._type==='list'&&v.items)return Array.from(v.items).map(sxToJs);return v;}try{const v=fn.apply(null,callArgs.map(sxToJs));return v===undefined?null:v;}catch(e){return null;}}); K.registerNative('host-new',a=>{const C=typeof a[0]==='string'?globalThis[a[0]]:a[0];return typeof C==='function'?new C(...a.slice(1)):null;}); K.registerNative('host-callback',a=>{const fn=a[0];if(typeof fn==='function'&&fn.__sx_handle===undefined)return fn;if(fn&&fn.__sx_handle!==undefined)return function(){const r=K.callFn(fn,Array.from(arguments));if(globalThis._driveAsync)globalThis._driveAsync(r);return r;};return function(){};}); K.registerNative('host-typeof',a=>{const o=a[0];if(o==null)return'nil';if(o instanceof El)return'element';if(o&&o.nodeType===3)return'text';if(o instanceof Ev)return'event';if(o instanceof Promise)return'promise';return typeof o;}); @@ -567,6 +584,9 @@ K.registerNative('host-iter?',([obj])=>obj!=null&&typeof obj[Symbol.iterator]=== K.registerNative('host-to-list',([obj])=>{try{return[...obj];}catch(e){return[];}}); K.registerNative('host-await',a=>{}); K.registerNative('load-library!',()=>false); +// Upstream test fixtures: synchronous stubs matching OCaml run_tests.ml registrations +globalThis.promiseAString = () => 'foo'; +globalThis.promiseAnInt = () => 42; // ── JS block execution support ───────────────────────────────── // Track promise states for synchronous introspection in hs-js-exec @@ -612,9 +632,28 @@ const _fetchRoutes = { '/number': { status: 200, body: '1.2' }, '/users/Joe': { status: 200, body: 'Joe', json: '{"name":"Joe"}' }, }; +// Per-test fetch overrides keyed by test name; takes priority over _fetchRoutes. +const _fetchScripts = { + "as response does not throw on 404": + { "/test": { status: 404, body: "not found" } }, + "do not throw passes through 404 response": + { "/test": { status: 404, body: "the body" } }, + "don't throw passes through 404 response": + { "/test": { status: 404, body: "the body" } }, + "throws on non-2xx response by default": + { "/test": { status: 404, body: "not found" } }, + "Response can be converted to JSON via as JSON": + { "/test": { status: 200, body: '{"name":"Joe"}', json: '{"name":"Joe"}', + contentType: "application/json" } }, + "can catch an error that occurs when using fetch": + { "/test": { networkError: true } }, + "triggers an event just before fetching": + { "/test": { status: 200, body: "yay", contentType: "text/html" } }, +}; function _mockFetch(url) { - const route = _fetchRoutes[url] || _fetchRoutes['/test']; - return { ok: route.status < 400, status: route.status || 200, url: url || '/test', + const scriptRoutes = _fetchScripts[globalThis.__currentHsTestName]; + const route = (scriptRoutes && scriptRoutes[url]) || _fetchRoutes[url] || _fetchRoutes['/test']; + return { ok: (route.status||200) < 400, status: route.status || 200, url: url || '/test', _body: route.body || '', _json: route.json || route.body || '', _html: route.html || route.body || '' }; } globalThis._driveAsync=function driveAsync(r,d){d=d||0;if(_testDeadline && Date.now()>_testDeadline)throw new Error('TIMEOUT: wall clock exceeded');if(d>500||!r||!r.suspended)return;const req=r.request;const items=req&&(req.items||req);const op=items&&items[0];const opName=typeof op==='string'?op:(op&&op.name)||String(op); @@ -622,13 +661,10 @@ globalThis._driveAsync=function driveAsync(r,d){d=d||0;if(_testDeadline && Date. if(opName==='io-sleep'||opName==='wait')doResume(null); else if(opName==='io-fetch'){ const url=typeof items[1]==='string'?items[1]:'/test'; - const fmt=typeof items[2]==='string'?items[2]:'text'; - const route=_fetchRoutes[url]||_fetchRoutes['/test']; - if(fmt==='json'){try{doResume(JSON.parse(route.json||route.body||'{}'));}catch(e){doResume(null);}} - else if(fmt==='html'){const frag=new El('fragment');frag.nodeType=11;frag.innerHTML=route.html||route.body||'';frag.textContent=frag.innerHTML.replace(/<[^>]*>/g,'');doResume(frag);} - else if(fmt==='response')doResume({ok:(route.status||200)<400,status:route.status||200,url}); - else if(fmt.toLowerCase()==='number')doResume(parseFloat(route.number||route.body||'0')); - else doResume(route.body||''); + const scriptRoutes=_fetchScripts[globalThis.__currentHsTestName]; + const route=(scriptRoutes&&scriptRoutes[url])||_fetchRoutes[url]||_fetchRoutes['/test']; + if(route&&route.networkError){doResume({_type:'dict','_network-error':true,message:'aborted'});} + else{const st=route.status||200;doResume({_type:'dict',ok:st<400,status:st,url,_body:route.body||'',_json:route.json||route.body||'',_html:route.html||route.body||'',_number:route.number||route.body||''});} } else if(opName==='io-parse-text'){const resp=items&&items[1];doResume(resp&&resp._body?resp._body:typeof resp==='string'?resp:'');} else if(opName==='io-parse-json'){const resp=items&&items[1];try{doResume(JSON.parse(typeof resp==='string'?resp:resp&&resp._json?resp._json:'{}'));}catch(e){doResume(null);}} @@ -725,6 +761,7 @@ for(let i=startTest;i { param.target.PROP = 'VAL'; }) + wa = re.search( + r"window\.addEventListener\(\s*(['\"])([^'\"]+)\1\s*,\s*" + r"\((\w+)\)\s*=>\s*\{\s*\3\.target\.(\w+)\s*=\s*['\"]([^'\"]+)['\"]\s*;?\s*\}", + m.group(1), + ) + if wa: + ev_name = wa.group(2) + prop = wa.group(4) + val = wa.group(5) + attr = 'class' if prop == 'className' else prop + sx = (f'(host-call (host-global "window") "addEventListener" "{ev_name}" ' + f'(fn (_event) (dom-set-attr (host-get _event "target") "{attr}" "{val}")))') + if seen_html: + ops.append(sx) + else: + pre_setups.append(('__hs_config__', sx)) + continue # fall through # evaluate(() => _hyperscript.config.X = ...) single-line variant. @@ -1293,7 +1311,9 @@ def process_hs_val(hs_val): hs_val = hs_val.replace('\\n', '\n').replace('\\t', ' ') # Preserve escaped quotes (\" → placeholder), strip remaining backslashes, restore hs_val = hs_val.replace('\\"', '\x00QUOT\x00') + hs_val = hs_val.replace('\\$', '\x00DOLLAR\x00') # preserve \$ template escape hs_val = hs_val.replace('\\', '') + hs_val = hs_val.replace('\x00DOLLAR\x00', '\\$') # restore \$ hs_val = hs_val.replace('\x00QUOT\x00', '\\"') # Strip line comments BEFORE newline collapse — once newlines become `then`, # an unterminated `//` / ` --` comment would consume the rest of the input. @@ -1705,6 +1725,13 @@ def js_expr_to_sx(expr): if s is None: return None arg_sx.append(s) + # Translate common array HO methods to SX primitives so SX lists work. + if method == 'reduce' and len(arg_sx) == 2: + return f'(reduce {arg_sx[0]} {arg_sx[1]} {obj})' + if method == 'map' and len(arg_sx) == 1: + return f'(map {arg_sx[0]} {obj})' + if method == 'filter' and len(arg_sx) == 1: + return f'(filter {arg_sx[0]} {obj})' return f'(host-call {obj} "{method}" {" ".join(arg_sx)})'.strip() # Property access: o.prop @@ -1877,6 +1904,272 @@ def extract_hs_expr(raw): return expr +def generate_tokenizer_test(test, safe_name): + """Hardcoded SX translation for _hyperscript.internals.tokenizer tests (E37).""" + name = test['name'] + + def to_(src, tmpl=False): + """Return (hs-tokens-of [:template]) for HS source string src.""" + escaped = (src + .replace('\\', '\\\\') + .replace('"', '\\"') + .replace('\n', '\\n') + .replace('\r', '\\r') + .replace('\t', '\\t')) + q = '"' + escaped + '"' + suffix = ' :template' if tmpl else '' + return f'(hs-tokens-of {q}{suffix})' + + def consume(s): + return f'(hs-stream-consume {s})' + + def tok_i(s, i): + return f'(hs-stream-token {s} {i})' + + def has_more(s): + return f'(hs-stream-has-more {s})' + + def t_type(t): + return f'(hs-token-type {t})' + + def t_val(t): + return f'(hs-token-value {t})' + + def t_op(t): + return f'(hs-token-op? {t})' + + def nth_list(s, i): + return f'(nth (get {s} "list") {i})' + + def list_len(s): + return f'(len (get {s} "list"))' + + def ae(actual, expected): + return f' (assert= {actual} {expected})' + + def throws(expr): + return ( + f' (let ((threw false))\n' + f' (guard (e (true (set! threw true))) {expr})\n' + f' (assert threw))' + ) + + lines = [f' (deftest "{safe_name}"'] + + if name == 'handles $ in template properly': + s = to_('"', tmpl=True) + lines.append(ae(t_val(tok_i(s, 0)), sx_str('"'))) + + elif name == 'handles all special escapes properly': + for src, exp in [ + ('"\\b"', '(char-from-code 8)'), + ('"\\f"', '(char-from-code 12)'), + ('"\\n"', '"\\n"'), + ('"\\r"', '"\\r"'), + ('"\\t"', '"\\t"'), + ('"\\v"', '(char-from-code 11)'), + ]: + lines.append(ae(t_val(consume(to_(src))), exp)) + + elif name == 'handles basic token types': + lines.append(ae(t_type(consume(to_('foo'))), '"IDENTIFIER"')) + lines.append(ae(t_type(consume(to_('1'))), '"NUMBER"')) + for src in ['1.1', '1e6', '1e-6', '1.1e6', '1.1e-6']: + sq = to_(src) + lines.append(f' (let ((s {sq}))') + lines.append(f' (let ((tok (hs-stream-consume s)))') + lines.append(f' (assert= (hs-token-type tok) "NUMBER")') + lines.append(f' (assert= (hs-stream-has-more s) false)))') + lines.append(ae(t_type(consume(to_('.a'))), '"CLASS_REF"')) + lines.append(ae(t_type(consume(to_('#a'))), '"ID_REF"')) + lines.append(ae(t_type(consume(to_('"asdf"'))), '"STRING"')) + + elif name == 'handles class identifiers properly': + for src, idx, exp_type, exp_val in [ + ('.a', None, 'CLASS_REF', '.a'), + (' .a', None, 'CLASS_REF', '.a'), + ('a.a', None, 'IDENTIFIER', 'a'), + ('(a).a', 4, 'IDENTIFIER', 'a'), + ('{a}.a', 4, 'IDENTIFIER', 'a'), + ('[a].a', 4, 'IDENTIFIER', 'a'), + ('(a(.a', 3, 'CLASS_REF', '.a'), + ('{a{.a', 3, 'CLASS_REF', '.a'), + ('[a[.a', 3, 'CLASS_REF', '.a'), + ]: + if idx is None: + tok_expr = consume(to_(src)) + else: + tok_expr = nth_list(to_(src), idx) + lines.append(ae(t_type(tok_expr), f'"{exp_type}"')) + lines.append(ae(t_val(tok_expr), sx_str(exp_val))) + + elif name == 'handles comments properly': + for src, expected in [ + ('--', 0), + ('asdf--', 1), + ('-- asdf', 0), + ('--\nasdf', 1), + ('--\nasdf--', 1), + ('---asdf', 0), + ('----\n---asdf', 0), + ('----asdf----', 0), + ('---\nasdf---', 1), + ('// asdf', 0), + ('///asdf', 0), + ('asdf//', 1), + ('asdf\n//', 2), + ]: + lines.append(ae(list_len(to_(src)), str(expected))) + + elif name == 'handles hex escapes properly': + lines.append(ae(t_val(consume(to_('"\\x1f"'))), '(char-from-code 31)')) + lines.append(ae(t_val(consume(to_('"\\x41"'))), '"A"')) + lines.append(ae(t_val(consume(to_('"\\x41\\x61"'))), '"Aa"')) + for bad in ['"\\x"', '"\\xGG"', '"\\x4"']: + lines.append(throws(consume(to_(bad)))) + + elif name == 'handles id references properly': + for src, idx, exp_type, exp_val in [ + ('#a', None, 'ID_REF', '#a'), + (' #a', None, 'ID_REF', '#a'), + ('a#a', None, 'IDENTIFIER', 'a'), + ('(a)#a', 4, 'IDENTIFIER', 'a'), + ('{a}#a', 4, 'IDENTIFIER', 'a'), + ('[a]#a', 4, 'IDENTIFIER', 'a'), + ('(a(#a', 3, 'ID_REF', '#a'), + ('{a{#a', 3, 'ID_REF', '#a'), + ('[a[#a', 3, 'ID_REF', '#a'), + ]: + if idx is None: + tok_expr = consume(to_(src)) + else: + tok_expr = nth_list(to_(src), idx) + lines.append(ae(t_type(tok_expr), f'"{exp_type}"')) + lines.append(ae(t_val(tok_expr), sx_str(exp_val))) + + elif name == 'handles identifiers properly': + lines.append(ae(t_type(consume(to_('foo'))), '"IDENTIFIER"')) + lines.append(ae(t_val(consume(to_('foo'))), '"foo"')) + lines.append(ae(t_type(consume(to_(' foo '))), '"IDENTIFIER"')) + lines.append(ae(t_val(consume(to_(' foo '))), '"foo"')) + for src, v1, v2 in [ + (' foo bar', 'foo', 'bar'), + (' foo\n-- a comment\n bar', 'foo', 'bar'), + ]: + sq = to_(src) + lines.append(f' (let ((s {sq}))') + lines.append(f' (let ((tok1 (hs-stream-consume s)))') + lines.append(f' (assert= (hs-token-type tok1) "IDENTIFIER")') + lines.append(f' (assert= (hs-token-value tok1) {sx_str(v1)})') + lines.append(f' (let ((tok2 (hs-stream-consume s)))') + lines.append(f' (assert= (hs-token-type tok2) "IDENTIFIER")') + lines.append(f' (assert= (hs-token-value tok2) {sx_str(v2)}))))') + + elif name == 'handles identifiers with numbers properly': + for src in ['f1oo', 'fo1o', 'foo1']: + lines.append(ae(t_type(consume(to_(src))), '"IDENTIFIER"')) + lines.append(ae(t_val(consume(to_(src))), sx_str(src))) + + elif name == 'handles look ahead property': + s = to_('a 1 + 1') + for i, v in [(0, 'a'), (1, '1'), (2, '+'), (3, '1'), (4, '<<>>')]: + lines.append(ae(t_val(tok_i(s, i)), sx_str(v))) + + elif name == 'handles numbers properly': + for src, v in [ + ('1', '1'), + ('1.1', '1.1'), + ('1234567890.1234567890', '1234567890.1234567890'), + ('1e6', '1e6'), + ('1e-6', '1e-6'), + ('1.1e6', '1.1e6'), + ('1.1e-6', '1.1e-6'), + ]: + lines.append(ae(t_type(consume(to_(src))), '"NUMBER"')) + lines.append(ae(t_val(consume(to_(src))), sx_str(v))) + s = to_('1.1.1') + toks = f'(get {s} "list")' + lines.append(ae(f'(hs-token-type (nth {toks} 0))', '"NUMBER"')) + lines.append(ae(f'(hs-token-type (nth {toks} 1))', '"PERIOD"')) + lines.append(ae(f'(hs-token-type (nth {toks} 2))', '"NUMBER"')) + lines.append(ae(f'(len {toks})', '3')) + + elif name == 'handles operators properly': + optable = [ + ('+', 'PLUS'), ('-', 'MINUS'), ('*', 'MULTIPLY'), + ('.', 'PERIOD'), ('\\', 'BACKSLASH'), (':', 'COLON'), + ('%', 'PERCENT'), ('|', 'PIPE'), ('!', 'EXCLAMATION'), + ('?', 'QUESTION'), ('#', 'POUND'), ('&', 'AMPERSAND'), + (';', 'SEMI'), (',', 'COMMA'), ('(', 'L_PAREN'), + (')', 'R_PAREN'), ('<', 'L_ANG'), ('>', 'R_ANG'), + ('{', 'L_BRACE'), ('}', 'R_BRACE'), ('[', 'L_BRACKET'), + (']', 'R_BRACKET'), ('=', 'EQUALS'), + ('<=', 'LTE_ANG'), ('>=', 'GTE_ANG'), + ('==', 'EQ'), ('===', 'EQQ'), + ] + for op_char, _op_name in optable: + tok_expr = consume(to_(op_char)) + lines.append(ae(t_op(tok_expr), 'true')) + lines.append(ae(t_val(tok_expr), sx_str(op_char))) + + elif name == 'handles strings properly': + for src, v in [ + ('"foo"', 'foo'), + ('"fo\'o"', "fo'o"), + ('"fo\\"o"', 'fo"o'), + ("'foo'", 'foo'), + ("'fo\"o'", 'fo"o'), + ("'fo\\'o'", "fo'o"), + ]: + lines.append(ae(t_type(consume(to_(src))), '"STRING"')) + lines.append(ae(t_val(consume(to_(src))), sx_str(v))) + lines.append(throws(consume(to_("'")))) + lines.append(throws(consume(to_('"')))) + + elif name == 'handles strings properly 2': + tok_expr = consume(to_("'foo'")) + lines.append(ae(t_type(tok_expr), '"STRING"')) + lines.append(ae(t_val(tok_expr), '"foo"')) + + elif name == 'handles template bootstrap properly': + s1 = to_('"', tmpl=True) + lines.append(ae(t_val(tok_i(s1, 0)), sx_str('"'))) + s2 = to_('"$', tmpl=True) + lines.append(ae(t_val(tok_i(s2, 0)), sx_str('"'))) + lines.append(ae(t_val(tok_i(s2, 1)), '"$"')) + s3 = to_('"${', tmpl=True) + lines.append(ae(t_val(tok_i(s3, 0)), sx_str('"'))) + lines.append(ae(t_val(tok_i(s3, 1)), '"$"')) + lines.append(ae(t_val(tok_i(s3, 2)), '"{"')) + s4 = to_('"${"asdf"', tmpl=True) + lines.append(ae(t_val(tok_i(s4, 0)), sx_str('"'))) + lines.append(ae(t_val(tok_i(s4, 1)), '"$"')) + lines.append(ae(t_val(tok_i(s4, 2)), '"{"')) + lines.append(ae(t_val(tok_i(s4, 3)), '"asdf"')) + s5 = to_('"${"asdf"}"', tmpl=True) + lines.append(ae(t_val(tok_i(s5, 0)), sx_str('"'))) + lines.append(ae(t_val(tok_i(s5, 1)), '"$"')) + lines.append(ae(t_val(tok_i(s5, 2)), '"{"')) + lines.append(ae(t_val(tok_i(s5, 3)), '"asdf"')) + lines.append(ae(t_val(tok_i(s5, 4)), '"}"')) + lines.append(ae(t_val(tok_i(s5, 5)), sx_str('"'))) + + elif name == 'handles whitespace properly': + for src, expected in [ + (' ', 0), (' asdf', 1), (' asdf ', 2), ('asdf ', 2), + ('\n', 0), ('\nasdf', 1), ('\nasdf\n', 2), ('asdf\n', 2), + ('\r', 0), ('\rasdf', 1), ('\rasdf\r', 2), ('asdf\r', 2), + ('\t', 0), ('\tasdf', 1), ('\tasdf\t', 2), ('asdf\t', 2), + ]: + lines.append(ae(list_len(to_(src)), str(expected))) + + else: + return None # not a tokenizer test we handle + + lines.append(' )') + return '\n'.join(lines) + + def generate_eval_only_test(test, idx): """Generate SX deftest for no-HTML tests using eval-hs. Handles patterns: @@ -2095,6 +2388,9 @@ def generate_eval_only_test(test, idx): f" (assert= (hs-line-at \"{src}\" (list :true-branch :next)) \" log 'it was true'\"))" ) + if '_hyperscript.internals.tokenizer' in body: + return generate_tokenizer_test(test, safe_name) + lines.append(f' (deftest "{safe_name}"') assertions = [] @@ -2106,13 +2402,20 @@ def generate_eval_only_test(test, idx): def emit_eval(hs_expr, expected_sx, extra_locals=None): """Emit an assertion using eval-hs / eval-hs-locals / eval-hs-with-me as appropriate, given the window setups and any per-call locals. + Uses assert-equal (deep equal?) when expected contains dicts; assert= otherwise. """ pairs = list(window_setups) + list(extra_locals or []) + # assert= uses = (reference equality for dicts); assert-equal uses equal? (deep) + use_deep = '{' in expected_sx if pairs: locals_sx = '(list ' + ' '.join( f'(list (quote {n}) {v})' for n, v in pairs ) + ')' + if use_deep: + return f' (assert-equal {expected_sx} (eval-hs-locals "{hs_expr}" {locals_sx}))' return f' (assert= (eval-hs-locals "{hs_expr}" {locals_sx}) {expected_sx})' + if use_deep: + return f' (assert-equal {expected_sx} (eval-hs "{hs_expr}"))' return f' (assert= (eval-hs "{hs_expr}") {expected_sx})' # Shared sub-pattern for run() call with optional String.raw and extra args: