diff --git a/lib/hyperscript/compiler.sx b/lib/hyperscript/compiler.sx index 4c429cdf..30297f78 100644 --- a/lib/hyperscript/compiler.sx +++ b/lib/hyperscript/compiler.sx @@ -789,1496 +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)))) - (if - (= (len params) 0) - body - (list (quote fn) params body)))) - ((= head (quote me)) (quote me)) - ((= head (quote it)) (quote it)) - ((= head (quote event)) (quote event)) - ((= head dot-sym) - (let - ((target (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-id=)) + (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-id=) - (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-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) + (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 - (if - (and (list? tgt) (= (first tgt) (quote query))) - (list - (quote for-each) - (list - (quote fn) - (list (quote _el)) - (list (quote hs-empty-target!) (quote _el))) - (list (quote hs-query-all) (nth tgt 1))) - (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))))) - (let - ((call-expr (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)))) - (emit-set (quote the-result) call-expr)))) - ((= head (quote return)) - (let - ((val (nth ast 1))) + ((compiled (map hs-to-sx expanded))) (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 + (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 it)) + (hs-to-sx when-cond))))) + (list + (quote begin) (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)) + (quote set!) + (quote the-result) + (quote __hs-show-r)) + (list (quote set!) (quote it) (quote __hs-show-r)) + (quote __hs-show-r)))))) + ((= head (quote transition)) (emit-transition ast)) + ((= head (quote transition-from)) + (let + ((prop (hs-to-sx (nth ast 1))) + (from-val (hs-to-sx (nth ast 2))) + (to-val (hs-to-sx (nth ast 3))) + (dur (nth ast 4)) + (raw-tgt (nth ast 5))) + (list + (quote hs-transition-from) + (if (nil? raw-tgt) (quote me) (hs-to-sx raw-tgt)) + prop + from-val + to-val + (if dur (hs-to-sx dur) nil)))) + ((= head (quote repeat)) (emit-repeat ast)) + ((= head (quote repeat-until)) + (list + (quote hs-repeat-until) + (list (quote fn) (list) (hs-to-sx (nth ast 1))) + (list (quote fn) (list) (hs-to-sx (nth ast 2))))) + ((= head (quote repeat-while)) + (list + (quote hs-repeat-while) + (list (quote fn) (list) (hs-to-sx (nth ast 1))) + (list (quote fn) (list) (hs-to-sx (nth ast 2))))) + ((= head (quote fetch)) + (list (quote hs-fetch) (hs-to-sx (nth ast 1)) (nth ast 2))) + ((= head (quote fetch-gql)) + (list + (quote hs-fetch-gql) + (nth ast 1) + (if (nth ast 2) (hs-to-sx (nth ast 2)) nil))) + ((= head (quote call)) + (let + ((raw-fn (nth ast 1)) + (fn-expr + (if + (string? raw-fn) + (make-symbol raw-fn) + (hs-to-sx raw-fn))) + (args (map hs-to-sx (rest (rest ast))))) + (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 - ((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))))) + ((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 - 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))) + with-val + (if + (string? with-val) + with-val + (hs-to-sx with-val)) + nil))) (cond - ((and (list? raw-tgt) (= (first raw-tgt) (quote query))) + ((and (= kind "attr") (or attr-val with-val)) (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)))) + (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 when) - (list (quote hs-default?) read) - (emit-set tgt-ast v)))) - ((= head (quote hs-is)) + (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 hs-is) - (hs-to-sx (nth ast 1)) + (quote define) + (make-symbol (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))))))))) + (quote let) + (list + (list + (quote _hs-def-val) + (list + (quote fn) + params + (list + (quote guard) + (list + (quote _e) + (list + (quote true) + (list + (quote if) + (list + (quote and) + (list (quote list?) (quote _e)) + (list + (quote =) + (list (quote first) (quote _e)) + "hs-return")) + (list (quote nth) (quote _e) 1) + (list (quote raise) (quote _e))))) + body)))) + (list + (quote do) + (list + (quote host-set!) + (list (quote host-global) "window") + (nth ast 1) + (quote _hs-def-val)) + (quote _hs-def-val)))))) + ((= head (quote behavior)) (emit-behavior ast)) + ((= head (quote sx-eval)) + (let + ((src (nth ast 1))) + (if + (string? src) + (first (sx-parse src)) + (list (quote cek-eval) (hs-to-sx src))))) + ((= head (quote component)) (make-symbol (nth ast 1))) + ((= head (quote render)) + (let + ((comp-raw (nth ast 1)) + (kwargs (nth ast 2)) + (pos (if (> (len ast) 3) (nth ast 3) nil)) + (target + (if (> (len ast) 4) (hs-to-sx (nth ast 4)) nil))) + (let + ((comp (if (string? comp-raw) (make-symbol comp-raw) (hs-to-sx comp-raw)))) + (define + emit-kw-pairs + (fn + (pairs) + (if + (< (len pairs) 2) + (list) + (cons + (make-keyword (first pairs)) + (cons + (hs-to-sx (nth pairs 1)) + (emit-kw-pairs (rest (rest pairs)))))))) + (let + ((render-call (cons (quote render-to-html) (cons comp (emit-kw-pairs kwargs))))) + (if + pos + (list + (quote hs-put!) + render-call + pos + (if target target (quote me))) + render-call))))) + ((= head (quote not-in?)) + (list + (quote not) + (list + (quote hs-contains?) + (hs-to-sx (nth ast 2)) + (hs-to-sx (nth ast 1))))) + ((= head (quote in?)) + (list + (quote hs-in?) + (hs-to-sx (nth ast 2)) + (hs-to-sx (nth ast 1)))) + ((= head (quote type-check)) + (list + (quote hs-type-check) + (hs-to-sx (nth ast 1)) + (nth ast 2))) + ((= head (quote type-check-strict)) + (list + (quote hs-type-check-strict) + (hs-to-sx (nth ast 1)) + (nth ast 2))) + ((= head (quote type-assert)) + (list + (quote hs-type-assert) + (hs-to-sx (nth ast 1)) + (nth ast 2))) + ((= head (quote type-assert-strict)) + (list + (quote hs-type-assert-strict) + (hs-to-sx (nth ast 1)) + (nth ast 2))) + ((= head (quote strict-eq)) + (list + (quote hs-strict-eq) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote eq-ignore-case)) + (list + (quote hs-eq-ignore-case) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote some)) + (list + (quote some) + (list + (quote fn) + (list (make-symbol (nth ast 1))) + (hs-to-sx (nth ast 3))) + (hs-to-sx (nth ast 2)))) + ((= head (quote every)) + (list + (quote every?) + (list + (quote fn) + (list (make-symbol (nth ast 1))) + (hs-to-sx (nth ast 3))) + (hs-to-sx (nth ast 2)))) + ((= head (quote scroll!)) + (list + (quote hs-scroll!) + (hs-to-sx (nth ast 1)) + (nth ast 2))) + ((= head (quote select!)) + (list (quote hs-select!) (hs-to-sx (nth ast 1)))) + ((= head (quote reset!)) + (let + ((raw-tgt (nth ast 1))) + (cond + ((and (list? raw-tgt) (= (first raw-tgt) (quote query))) + (list + (quote hs-reset!) + (list (quote hs-query-all) (nth raw-tgt 1)))) + (true (list (quote hs-reset!) (hs-to-sx raw-tgt)))))) + ((= head (quote default!)) + (let + ((tgt-ast (nth ast 1)) + (read (hs-to-sx (nth ast 1))) + (v (hs-to-sx (nth ast 2)))) + (list + (quote when) + (list (quote hs-default?) read) + (emit-set tgt-ast v)))) + ((= head (quote hs-is)) + (list + (quote hs-is) + (hs-to-sx (nth ast 1)) + (list (quote fn) (list) (hs-to-sx (nth (nth ast 2) 2))) + (nth ast 3))) + ((= head (quote halt!)) + (list (quote hs-halt!) (quote event) (nth ast 1))) + ((= head (quote focus!)) + (list (quote dom-focus) (hs-to-sx (nth ast 1)))) + (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/tokenizer.sx b/lib/hyperscript/tokenizer.sx index 6f652dea..bee0b7a7 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,11 +559,11 @@ (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 @@ -547,8 +571,7 @@ (hs-emit! (if (hs-keyword? word) "keyword" "ident") word - start - start-line)) + start)) (scan!)) (and (or (= ch "=") (= ch "!") (= ch "<") (= ch ">")) @@ -560,8 +583,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 +593,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-to-100.md b/plans/hs-conformance-to-100.md index 1f63a671..7d123a77 100644 --- a/plans/hs-conformance-to-100.md +++ b/plans/hs-conformance-to-100.md @@ -133,7 +133,7 @@ All five have design docs on their own worktree branches pending review + merge. 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. diff --git a/shared/static/wasm/sx/hs-compiler.sx b/shared/static/wasm/sx/hs-compiler.sx index 4c429cdf..30297f78 100644 --- a/shared/static/wasm/sx/hs-compiler.sx +++ b/shared/static/wasm/sx/hs-compiler.sx @@ -789,1496 +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)))) - (if - (= (len params) 0) - body - (list (quote fn) params body)))) - ((= head (quote me)) (quote me)) - ((= head (quote it)) (quote it)) - ((= head (quote event)) (quote event)) - ((= head dot-sym) - (let - ((target (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-id=)) + (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-id=) - (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-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) + (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 - (if - (and (list? tgt) (= (first tgt) (quote query))) - (list - (quote for-each) - (list - (quote fn) - (list (quote _el)) - (list (quote hs-empty-target!) (quote _el))) - (list (quote hs-query-all) (nth tgt 1))) - (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))))) - (let - ((call-expr (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)))) - (emit-set (quote the-result) call-expr)))) - ((= head (quote return)) - (let - ((val (nth ast 1))) + ((compiled (map hs-to-sx expanded))) (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 + (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 it)) + (hs-to-sx when-cond))))) + (list + (quote begin) (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)) + (quote set!) + (quote the-result) + (quote __hs-show-r)) + (list (quote set!) (quote it) (quote __hs-show-r)) + (quote __hs-show-r)))))) + ((= head (quote transition)) (emit-transition ast)) + ((= head (quote transition-from)) + (let + ((prop (hs-to-sx (nth ast 1))) + (from-val (hs-to-sx (nth ast 2))) + (to-val (hs-to-sx (nth ast 3))) + (dur (nth ast 4)) + (raw-tgt (nth ast 5))) + (list + (quote hs-transition-from) + (if (nil? raw-tgt) (quote me) (hs-to-sx raw-tgt)) + prop + from-val + to-val + (if dur (hs-to-sx dur) nil)))) + ((= head (quote repeat)) (emit-repeat ast)) + ((= head (quote repeat-until)) + (list + (quote hs-repeat-until) + (list (quote fn) (list) (hs-to-sx (nth ast 1))) + (list (quote fn) (list) (hs-to-sx (nth ast 2))))) + ((= head (quote repeat-while)) + (list + (quote hs-repeat-while) + (list (quote fn) (list) (hs-to-sx (nth ast 1))) + (list (quote fn) (list) (hs-to-sx (nth ast 2))))) + ((= head (quote fetch)) + (list (quote hs-fetch) (hs-to-sx (nth ast 1)) (nth ast 2))) + ((= head (quote fetch-gql)) + (list + (quote hs-fetch-gql) + (nth ast 1) + (if (nth ast 2) (hs-to-sx (nth ast 2)) nil))) + ((= head (quote call)) + (let + ((raw-fn (nth ast 1)) + (fn-expr + (if + (string? raw-fn) + (make-symbol raw-fn) + (hs-to-sx raw-fn))) + (args (map hs-to-sx (rest (rest ast))))) + (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 - ((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))))) + ((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 - 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))) + with-val + (if + (string? with-val) + with-val + (hs-to-sx with-val)) + nil))) (cond - ((and (list? raw-tgt) (= (first raw-tgt) (quote query))) + ((and (= kind "attr") (or attr-val with-val)) (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)))) + (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 when) - (list (quote hs-default?) read) - (emit-set tgt-ast v)))) - ((= head (quote hs-is)) + (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 hs-is) - (hs-to-sx (nth ast 1)) + (quote define) + (make-symbol (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))))))))) + (quote let) + (list + (list + (quote _hs-def-val) + (list + (quote fn) + params + (list + (quote guard) + (list + (quote _e) + (list + (quote true) + (list + (quote if) + (list + (quote and) + (list (quote list?) (quote _e)) + (list + (quote =) + (list (quote first) (quote _e)) + "hs-return")) + (list (quote nth) (quote _e) 1) + (list (quote raise) (quote _e))))) + body)))) + (list + (quote do) + (list + (quote host-set!) + (list (quote host-global) "window") + (nth ast 1) + (quote _hs-def-val)) + (quote _hs-def-val)))))) + ((= head (quote behavior)) (emit-behavior ast)) + ((= head (quote sx-eval)) + (let + ((src (nth ast 1))) + (if + (string? src) + (first (sx-parse src)) + (list (quote cek-eval) (hs-to-sx src))))) + ((= head (quote component)) (make-symbol (nth ast 1))) + ((= head (quote render)) + (let + ((comp-raw (nth ast 1)) + (kwargs (nth ast 2)) + (pos (if (> (len ast) 3) (nth ast 3) nil)) + (target + (if (> (len ast) 4) (hs-to-sx (nth ast 4)) nil))) + (let + ((comp (if (string? comp-raw) (make-symbol comp-raw) (hs-to-sx comp-raw)))) + (define + emit-kw-pairs + (fn + (pairs) + (if + (< (len pairs) 2) + (list) + (cons + (make-keyword (first pairs)) + (cons + (hs-to-sx (nth pairs 1)) + (emit-kw-pairs (rest (rest pairs)))))))) + (let + ((render-call (cons (quote render-to-html) (cons comp (emit-kw-pairs kwargs))))) + (if + pos + (list + (quote hs-put!) + render-call + pos + (if target target (quote me))) + render-call))))) + ((= head (quote not-in?)) + (list + (quote not) + (list + (quote hs-contains?) + (hs-to-sx (nth ast 2)) + (hs-to-sx (nth ast 1))))) + ((= head (quote in?)) + (list + (quote hs-in?) + (hs-to-sx (nth ast 2)) + (hs-to-sx (nth ast 1)))) + ((= head (quote type-check)) + (list + (quote hs-type-check) + (hs-to-sx (nth ast 1)) + (nth ast 2))) + ((= head (quote type-check-strict)) + (list + (quote hs-type-check-strict) + (hs-to-sx (nth ast 1)) + (nth ast 2))) + ((= head (quote type-assert)) + (list + (quote hs-type-assert) + (hs-to-sx (nth ast 1)) + (nth ast 2))) + ((= head (quote type-assert-strict)) + (list + (quote hs-type-assert-strict) + (hs-to-sx (nth ast 1)) + (nth ast 2))) + ((= head (quote strict-eq)) + (list + (quote hs-strict-eq) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote eq-ignore-case)) + (list + (quote hs-eq-ignore-case) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote some)) + (list + (quote some) + (list + (quote fn) + (list (make-symbol (nth ast 1))) + (hs-to-sx (nth ast 3))) + (hs-to-sx (nth ast 2)))) + ((= head (quote every)) + (list + (quote every?) + (list + (quote fn) + (list (make-symbol (nth ast 1))) + (hs-to-sx (nth ast 3))) + (hs-to-sx (nth ast 2)))) + ((= head (quote scroll!)) + (list + (quote hs-scroll!) + (hs-to-sx (nth ast 1)) + (nth ast 2))) + ((= head (quote select!)) + (list (quote hs-select!) (hs-to-sx (nth ast 1)))) + ((= head (quote reset!)) + (let + ((raw-tgt (nth ast 1))) + (cond + ((and (list? raw-tgt) (= (first raw-tgt) (quote query))) + (list + (quote hs-reset!) + (list (quote hs-query-all) (nth raw-tgt 1)))) + (true (list (quote hs-reset!) (hs-to-sx raw-tgt)))))) + ((= head (quote default!)) + (let + ((tgt-ast (nth ast 1)) + (read (hs-to-sx (nth ast 1))) + (v (hs-to-sx (nth ast 2)))) + (list + (quote when) + (list (quote hs-default?) read) + (emit-set tgt-ast v)))) + ((= head (quote hs-is)) + (list + (quote hs-is) + (hs-to-sx (nth ast 1)) + (list (quote fn) (list) (hs-to-sx (nth (nth ast 2) 2))) + (nth ast 3))) + ((= head (quote halt!)) + (list (quote hs-halt!) (quote event) (nth ast 1))) + ((= head (quote focus!)) + (list (quote dom-focus) (hs-to-sx (nth ast 1)))) + (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-tokenizer.sx b/shared/static/wasm/sx/hs-tokenizer.sx index 6f652dea..bee0b7a7 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,11 +559,11 @@ (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 @@ -547,8 +571,7 @@ (hs-emit! (if (hs-keyword? word) "keyword" "ident") word - start - start-line)) + start)) (scan!)) (and (or (= ch "=") (= ch "!") (= ch "<") (= ch ">")) @@ -560,8 +583,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 +593,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/spec/tests/test-hyperscript-behavioral.sx b/spec/tests/test-hyperscript-behavioral.sx index 4b22cae6..8e41cb14 100644 --- a/spec/tests/test-hyperscript-behavioral.sx +++ b/spec/tests/test-hyperscript-behavioral.sx @@ -2494,41 +2494,287 @@ ;; ── core/tokenizer (17 tests) ── (defsuite "hs-upstream-core/tokenizer" (deftest "handles $ in template properly" - (error "SKIP (untranslated): handles $ in template properly")) + (assert= (hs-token-value (hs-stream-token (hs-tokens-of "\"" :template) 0)) "\"") + ) (deftest "handles all special escapes properly" - (error "SKIP (untranslated): handles all special escapes properly")) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "\"\\b\""))) (char-from-code 8)) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "\"\\f\""))) (char-from-code 12)) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "\"\\n\""))) "\n") + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "\"\\r\""))) "\r") + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "\"\\t\""))) "\t") + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "\"\\v\""))) (char-from-code 11)) + ) (deftest "handles basic token types" - (error "SKIP (untranslated): handles basic token types")) + (assert= (hs-token-type (hs-stream-consume (hs-tokens-of "foo"))) "IDENTIFIER") + (assert= (hs-token-type (hs-stream-consume (hs-tokens-of "1"))) "NUMBER") + (let ((s (hs-tokens-of "1.1"))) + (let ((tok (hs-stream-consume s))) + (assert= (hs-token-type tok) "NUMBER") + (assert= (hs-stream-has-more s) false))) + (let ((s (hs-tokens-of "1e6"))) + (let ((tok (hs-stream-consume s))) + (assert= (hs-token-type tok) "NUMBER") + (assert= (hs-stream-has-more s) false))) + (let ((s (hs-tokens-of "1e-6"))) + (let ((tok (hs-stream-consume s))) + (assert= (hs-token-type tok) "NUMBER") + (assert= (hs-stream-has-more s) false))) + (let ((s (hs-tokens-of "1.1e6"))) + (let ((tok (hs-stream-consume s))) + (assert= (hs-token-type tok) "NUMBER") + (assert= (hs-stream-has-more s) false))) + (let ((s (hs-tokens-of "1.1e-6"))) + (let ((tok (hs-stream-consume s))) + (assert= (hs-token-type tok) "NUMBER") + (assert= (hs-stream-has-more s) false))) + (assert= (hs-token-type (hs-stream-consume (hs-tokens-of ".a"))) "CLASS_REF") + (assert= (hs-token-type (hs-stream-consume (hs-tokens-of "#a"))) "ID_REF") + (assert= (hs-token-type (hs-stream-consume (hs-tokens-of "\"asdf\""))) "STRING") + ) (deftest "handles class identifiers properly" - (error "SKIP (untranslated): handles class identifiers properly")) + (assert= (hs-token-type (hs-stream-consume (hs-tokens-of ".a"))) "CLASS_REF") + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of ".a"))) ".a") + (assert= (hs-token-type (hs-stream-consume (hs-tokens-of " .a"))) "CLASS_REF") + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of " .a"))) ".a") + (assert= (hs-token-type (hs-stream-consume (hs-tokens-of "a.a"))) "IDENTIFIER") + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "a.a"))) "a") + (assert= (hs-token-type (nth (get (hs-tokens-of "(a).a") "list") 4)) "IDENTIFIER") + (assert= (hs-token-value (nth (get (hs-tokens-of "(a).a") "list") 4)) "a") + (assert= (hs-token-type (nth (get (hs-tokens-of "{a}.a") "list") 4)) "IDENTIFIER") + (assert= (hs-token-value (nth (get (hs-tokens-of "{a}.a") "list") 4)) "a") + (assert= (hs-token-type (nth (get (hs-tokens-of "[a].a") "list") 4)) "IDENTIFIER") + (assert= (hs-token-value (nth (get (hs-tokens-of "[a].a") "list") 4)) "a") + (assert= (hs-token-type (nth (get (hs-tokens-of "(a(.a") "list") 3)) "CLASS_REF") + (assert= (hs-token-value (nth (get (hs-tokens-of "(a(.a") "list") 3)) ".a") + (assert= (hs-token-type (nth (get (hs-tokens-of "{a{.a") "list") 3)) "CLASS_REF") + (assert= (hs-token-value (nth (get (hs-tokens-of "{a{.a") "list") 3)) ".a") + (assert= (hs-token-type (nth (get (hs-tokens-of "[a[.a") "list") 3)) "CLASS_REF") + (assert= (hs-token-value (nth (get (hs-tokens-of "[a[.a") "list") 3)) ".a") + ) (deftest "handles comments properly" - (error "SKIP (untranslated): handles comments properly")) + (assert= (len (get (hs-tokens-of "--") "list")) 0) + (assert= (len (get (hs-tokens-of "asdf--") "list")) 1) + (assert= (len (get (hs-tokens-of "-- asdf") "list")) 0) + (assert= (len (get (hs-tokens-of "--\nasdf") "list")) 1) + (assert= (len (get (hs-tokens-of "--\nasdf--") "list")) 1) + (assert= (len (get (hs-tokens-of "---asdf") "list")) 0) + (assert= (len (get (hs-tokens-of "----\n---asdf") "list")) 0) + (assert= (len (get (hs-tokens-of "----asdf----") "list")) 0) + (assert= (len (get (hs-tokens-of "---\nasdf---") "list")) 1) + (assert= (len (get (hs-tokens-of "// asdf") "list")) 0) + (assert= (len (get (hs-tokens-of "///asdf") "list")) 0) + (assert= (len (get (hs-tokens-of "asdf//") "list")) 1) + (assert= (len (get (hs-tokens-of "asdf\n//") "list")) 2) + ) (deftest "handles hex escapes properly" - (error "SKIP (untranslated): handles hex escapes properly")) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "\"\\x1f\""))) (char-from-code 31)) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "\"\\x41\""))) "A") + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "\"\\x41\\x61\""))) "Aa") + (let ((threw false)) + (guard (e (true (set! threw true))) (hs-stream-consume (hs-tokens-of "\"\\x\""))) + (assert threw)) + (let ((threw false)) + (guard (e (true (set! threw true))) (hs-stream-consume (hs-tokens-of "\"\\xGG\""))) + (assert threw)) + (let ((threw false)) + (guard (e (true (set! threw true))) (hs-stream-consume (hs-tokens-of "\"\\x4\""))) + (assert threw)) + ) (deftest "handles id references properly" - (error "SKIP (untranslated): handles id references properly")) + (assert= (hs-token-type (hs-stream-consume (hs-tokens-of "#a"))) "ID_REF") + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "#a"))) "#a") + (assert= (hs-token-type (hs-stream-consume (hs-tokens-of " #a"))) "ID_REF") + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of " #a"))) "#a") + (assert= (hs-token-type (hs-stream-consume (hs-tokens-of "a#a"))) "IDENTIFIER") + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "a#a"))) "a") + (assert= (hs-token-type (nth (get (hs-tokens-of "(a)#a") "list") 4)) "IDENTIFIER") + (assert= (hs-token-value (nth (get (hs-tokens-of "(a)#a") "list") 4)) "a") + (assert= (hs-token-type (nth (get (hs-tokens-of "{a}#a") "list") 4)) "IDENTIFIER") + (assert= (hs-token-value (nth (get (hs-tokens-of "{a}#a") "list") 4)) "a") + (assert= (hs-token-type (nth (get (hs-tokens-of "[a]#a") "list") 4)) "IDENTIFIER") + (assert= (hs-token-value (nth (get (hs-tokens-of "[a]#a") "list") 4)) "a") + (assert= (hs-token-type (nth (get (hs-tokens-of "(a(#a") "list") 3)) "ID_REF") + (assert= (hs-token-value (nth (get (hs-tokens-of "(a(#a") "list") 3)) "#a") + (assert= (hs-token-type (nth (get (hs-tokens-of "{a{#a") "list") 3)) "ID_REF") + (assert= (hs-token-value (nth (get (hs-tokens-of "{a{#a") "list") 3)) "#a") + (assert= (hs-token-type (nth (get (hs-tokens-of "[a[#a") "list") 3)) "ID_REF") + (assert= (hs-token-value (nth (get (hs-tokens-of "[a[#a") "list") 3)) "#a") + ) (deftest "handles identifiers properly" - (error "SKIP (untranslated): handles identifiers properly")) + (assert= (hs-token-type (hs-stream-consume (hs-tokens-of "foo"))) "IDENTIFIER") + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "foo"))) "foo") + (assert= (hs-token-type (hs-stream-consume (hs-tokens-of " foo "))) "IDENTIFIER") + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of " foo "))) "foo") + (let ((s (hs-tokens-of " foo bar"))) + (let ((tok1 (hs-stream-consume s))) + (assert= (hs-token-type tok1) "IDENTIFIER") + (assert= (hs-token-value tok1) "foo") + (let ((tok2 (hs-stream-consume s))) + (assert= (hs-token-type tok2) "IDENTIFIER") + (assert= (hs-token-value tok2) "bar")))) + (let ((s (hs-tokens-of " foo\n-- a comment\n bar"))) + (let ((tok1 (hs-stream-consume s))) + (assert= (hs-token-type tok1) "IDENTIFIER") + (assert= (hs-token-value tok1) "foo") + (let ((tok2 (hs-stream-consume s))) + (assert= (hs-token-type tok2) "IDENTIFIER") + (assert= (hs-token-value tok2) "bar")))) + ) (deftest "handles identifiers with numbers properly" - (error "SKIP (untranslated): handles identifiers with numbers properly")) + (assert= (hs-token-type (hs-stream-consume (hs-tokens-of "f1oo"))) "IDENTIFIER") + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "f1oo"))) "f1oo") + (assert= (hs-token-type (hs-stream-consume (hs-tokens-of "fo1o"))) "IDENTIFIER") + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "fo1o"))) "fo1o") + (assert= (hs-token-type (hs-stream-consume (hs-tokens-of "foo1"))) "IDENTIFIER") + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "foo1"))) "foo1") + ) (deftest "handles look ahead property" - (error "SKIP (untranslated): handles look ahead property")) + (assert= (hs-token-value (hs-stream-token (hs-tokens-of "a 1 + 1") 0)) "a") + (assert= (hs-token-value (hs-stream-token (hs-tokens-of "a 1 + 1") 1)) "1") + (assert= (hs-token-value (hs-stream-token (hs-tokens-of "a 1 + 1") 2)) "+") + (assert= (hs-token-value (hs-stream-token (hs-tokens-of "a 1 + 1") 3)) "1") + (assert= (hs-token-value (hs-stream-token (hs-tokens-of "a 1 + 1") 4)) "<<>>") + ) (deftest "handles numbers properly" - (error "SKIP (untranslated): handles numbers properly")) + (assert= (hs-token-type (hs-stream-consume (hs-tokens-of "1"))) "NUMBER") + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "1"))) "1") + (assert= (hs-token-type (hs-stream-consume (hs-tokens-of "1.1"))) "NUMBER") + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "1.1"))) "1.1") + (assert= (hs-token-type (hs-stream-consume (hs-tokens-of "1234567890.1234567890"))) "NUMBER") + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "1234567890.1234567890"))) "1234567890.1234567890") + (assert= (hs-token-type (hs-stream-consume (hs-tokens-of "1e6"))) "NUMBER") + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "1e6"))) "1e6") + (assert= (hs-token-type (hs-stream-consume (hs-tokens-of "1e-6"))) "NUMBER") + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "1e-6"))) "1e-6") + (assert= (hs-token-type (hs-stream-consume (hs-tokens-of "1.1e6"))) "NUMBER") + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "1.1e6"))) "1.1e6") + (assert= (hs-token-type (hs-stream-consume (hs-tokens-of "1.1e-6"))) "NUMBER") + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "1.1e-6"))) "1.1e-6") + (assert= (hs-token-type (nth (get (hs-tokens-of "1.1.1") "list") 0)) "NUMBER") + (assert= (hs-token-type (nth (get (hs-tokens-of "1.1.1") "list") 1)) "PERIOD") + (assert= (hs-token-type (nth (get (hs-tokens-of "1.1.1") "list") 2)) "NUMBER") + (assert= (len (get (hs-tokens-of "1.1.1") "list")) 3) + ) (deftest "handles operators properly" - (error "SKIP (untranslated): handles operators properly")) + (assert= (hs-token-op? (hs-stream-consume (hs-tokens-of "+"))) true) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "+"))) "+") + (assert= (hs-token-op? (hs-stream-consume (hs-tokens-of "-"))) true) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "-"))) "-") + (assert= (hs-token-op? (hs-stream-consume (hs-tokens-of "*"))) true) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "*"))) "*") + (assert= (hs-token-op? (hs-stream-consume (hs-tokens-of "."))) true) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "."))) ".") + (assert= (hs-token-op? (hs-stream-consume (hs-tokens-of "\\"))) true) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "\\"))) "\\") + (assert= (hs-token-op? (hs-stream-consume (hs-tokens-of ":"))) true) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of ":"))) ":") + (assert= (hs-token-op? (hs-stream-consume (hs-tokens-of "%"))) true) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "%"))) "%") + (assert= (hs-token-op? (hs-stream-consume (hs-tokens-of "|"))) true) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "|"))) "|") + (assert= (hs-token-op? (hs-stream-consume (hs-tokens-of "!"))) true) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "!"))) "!") + (assert= (hs-token-op? (hs-stream-consume (hs-tokens-of "?"))) true) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "?"))) "?") + (assert= (hs-token-op? (hs-stream-consume (hs-tokens-of "#"))) true) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "#"))) "#") + (assert= (hs-token-op? (hs-stream-consume (hs-tokens-of "&"))) true) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "&"))) "&") + (assert= (hs-token-op? (hs-stream-consume (hs-tokens-of ";"))) true) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of ";"))) ";") + (assert= (hs-token-op? (hs-stream-consume (hs-tokens-of ","))) true) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of ","))) ",") + (assert= (hs-token-op? (hs-stream-consume (hs-tokens-of "("))) true) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "("))) "(") + (assert= (hs-token-op? (hs-stream-consume (hs-tokens-of ")"))) true) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of ")"))) ")") + (assert= (hs-token-op? (hs-stream-consume (hs-tokens-of "<"))) true) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "<"))) "<") + (assert= (hs-token-op? (hs-stream-consume (hs-tokens-of ">"))) true) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of ">"))) ">") + (assert= (hs-token-op? (hs-stream-consume (hs-tokens-of "{"))) true) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "{"))) "{") + (assert= (hs-token-op? (hs-stream-consume (hs-tokens-of "}"))) true) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "}"))) "}") + (assert= (hs-token-op? (hs-stream-consume (hs-tokens-of "["))) true) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "["))) "[") + (assert= (hs-token-op? (hs-stream-consume (hs-tokens-of "]"))) true) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "]"))) "]") + (assert= (hs-token-op? (hs-stream-consume (hs-tokens-of "="))) true) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "="))) "=") + (assert= (hs-token-op? (hs-stream-consume (hs-tokens-of "<="))) true) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "<="))) "<=") + (assert= (hs-token-op? (hs-stream-consume (hs-tokens-of ">="))) true) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of ">="))) ">=") + (assert= (hs-token-op? (hs-stream-consume (hs-tokens-of "=="))) true) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "=="))) "==") + (assert= (hs-token-op? (hs-stream-consume (hs-tokens-of "==="))) true) + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "==="))) "===") + ) (deftest "handles strings properly" - (error "SKIP (untranslated): handles strings properly")) + (assert= (hs-token-type (hs-stream-consume (hs-tokens-of "\"foo\""))) "STRING") + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "\"foo\""))) "foo") + (assert= (hs-token-type (hs-stream-consume (hs-tokens-of "\"fo'o\""))) "STRING") + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "\"fo'o\""))) "fo'o") + (assert= (hs-token-type (hs-stream-consume (hs-tokens-of "\"fo\\\"o\""))) "STRING") + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "\"fo\\\"o\""))) "fo\"o") + (assert= (hs-token-type (hs-stream-consume (hs-tokens-of "'foo'"))) "STRING") + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "'foo'"))) "foo") + (assert= (hs-token-type (hs-stream-consume (hs-tokens-of "'fo\"o'"))) "STRING") + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "'fo\"o'"))) "fo\"o") + (assert= (hs-token-type (hs-stream-consume (hs-tokens-of "'fo\\'o'"))) "STRING") + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "'fo\\'o'"))) "fo'o") + (let ((threw false)) + (guard (e (true (set! threw true))) (hs-stream-consume (hs-tokens-of "'"))) + (assert threw)) + (let ((threw false)) + (guard (e (true (set! threw true))) (hs-stream-consume (hs-tokens-of "\""))) + (assert threw)) + ) (deftest "handles strings properly 2" - (error "SKIP (untranslated): handles strings properly 2")) + (assert= (hs-token-type (hs-stream-consume (hs-tokens-of "'foo'"))) "STRING") + (assert= (hs-token-value (hs-stream-consume (hs-tokens-of "'foo'"))) "foo") + ) (deftest "handles template bootstrap properly" - (error "SKIP (untranslated): handles template bootstrap properly")) + (assert= (hs-token-value (hs-stream-token (hs-tokens-of "\"" :template) 0)) "\"") + (assert= (hs-token-value (hs-stream-token (hs-tokens-of "\"$" :template) 0)) "\"") + (assert= (hs-token-value (hs-stream-token (hs-tokens-of "\"$" :template) 1)) "$") + (assert= (hs-token-value (hs-stream-token (hs-tokens-of "\"${" :template) 0)) "\"") + (assert= (hs-token-value (hs-stream-token (hs-tokens-of "\"${" :template) 1)) "$") + (assert= (hs-token-value (hs-stream-token (hs-tokens-of "\"${" :template) 2)) "{") + (assert= (hs-token-value (hs-stream-token (hs-tokens-of "\"${\"asdf\"" :template) 0)) "\"") + (assert= (hs-token-value (hs-stream-token (hs-tokens-of "\"${\"asdf\"" :template) 1)) "$") + (assert= (hs-token-value (hs-stream-token (hs-tokens-of "\"${\"asdf\"" :template) 2)) "{") + (assert= (hs-token-value (hs-stream-token (hs-tokens-of "\"${\"asdf\"" :template) 3)) "asdf") + (assert= (hs-token-value (hs-stream-token (hs-tokens-of "\"${\"asdf\"}\"" :template) 0)) "\"") + (assert= (hs-token-value (hs-stream-token (hs-tokens-of "\"${\"asdf\"}\"" :template) 1)) "$") + (assert= (hs-token-value (hs-stream-token (hs-tokens-of "\"${\"asdf\"}\"" :template) 2)) "{") + (assert= (hs-token-value (hs-stream-token (hs-tokens-of "\"${\"asdf\"}\"" :template) 3)) "asdf") + (assert= (hs-token-value (hs-stream-token (hs-tokens-of "\"${\"asdf\"}\"" :template) 4)) "}") + (assert= (hs-token-value (hs-stream-token (hs-tokens-of "\"${\"asdf\"}\"" :template) 5)) "\"") + ) (deftest "handles whitespace properly" - (error "SKIP (untranslated): handles whitespace properly")) + (assert= (len (get (hs-tokens-of " ") "list")) 0) + (assert= (len (get (hs-tokens-of " asdf") "list")) 1) + (assert= (len (get (hs-tokens-of " asdf ") "list")) 2) + (assert= (len (get (hs-tokens-of "asdf ") "list")) 2) + (assert= (len (get (hs-tokens-of "\n") "list")) 0) + (assert= (len (get (hs-tokens-of "\nasdf") "list")) 1) + (assert= (len (get (hs-tokens-of "\nasdf\n") "list")) 2) + (assert= (len (get (hs-tokens-of "asdf\n") "list")) 2) + (assert= (len (get (hs-tokens-of "\r") "list")) 0) + (assert= (len (get (hs-tokens-of "\rasdf") "list")) 1) + (assert= (len (get (hs-tokens-of "\rasdf\r") "list")) 2) + (assert= (len (get (hs-tokens-of "asdf\r") "list")) 2) + (assert= (len (get (hs-tokens-of "\t") "list")) 0) + (assert= (len (get (hs-tokens-of "\tasdf") "list")) 1) + (assert= (len (get (hs-tokens-of "\tasdf\t") "list")) 2) + (assert= (len (get (hs-tokens-of "asdf\t") "list")) 2) + ) (deftest "string interpolation isnt surprising" (hs-cleanup!) (let ((_el-div (dom-create-element "div"))) - (dom-set-attr _el-div "_" "on click set x to 42 then put `test${x} test ${x} test$x test $x test $x test ${x} test$x test_$x test_${x} test-$x test.$x` into my.innerHTML") + (dom-set-attr _el-div "_" "on click set x to 42 then put `test\\${x} test ${x} test\\$x test $x test \\$x test \\${x} test$x test_$x test_${x} test-$x test.$x` into my.innerHTML") (dom-append (dom-body) _el-div) (hs-activate! _el-div) (dom-dispatch _el-div "click" nil) diff --git a/tests/playwright/generate-sx-tests.py b/tests/playwright/generate-sx-tests.py index 3d30de7d..e42c2b41 100644 --- a/tests/playwright/generate-sx-tests.py +++ b/tests/playwright/generate-sx-tests.py @@ -1264,7 +1264,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. @@ -1855,6 +1857,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: @@ -2073,6 +2341,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 = []