diff --git a/lib/hyperscript/compiler.sx b/lib/hyperscript/compiler.sx index 6f346d29..d67e1439 100644 --- a/lib/hyperscript/compiler.sx +++ b/lib/hyperscript/compiler.sx @@ -18,7 +18,17 @@ (target value) (if (not (list? target)) - (list (quote set!) target value) + (if + (= target (quote the-result)) + (list + (quote let) + (list (list (quote __hs-r) value)) + (list + (quote begin) + (list (quote set!) (quote the-result) (quote __hs-r)) + (list (quote set!) (quote it) (quote __hs-r)) + (quote __hs-r))) + (list (quote set!) target value)) (let ((th (first target))) (cond @@ -1169,15 +1179,71 @@ (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 for-each) + (quote let) (list - (quote fn) - (list (quote it)) (list - (quote when) - (hs-to-sx when-cond) - (list (quote dom-add-class) (quote it) cls))) - tgt-expr)))) + (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))) @@ -1598,11 +1664,17 @@ ((= head (quote append!)) (let ((tgt (hs-to-sx (nth ast 2))) - (val (hs-to-sx (nth ast 1)))) - (if - (symbol? tgt) - (list (quote set!) tgt (list (quote hs-append) tgt val)) - (list (quote hs-append!) val tgt)))) + (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)))) diff --git a/lib/hyperscript/parser.sx b/lib/hyperscript/parser.sx index 3fe8e8ad..4cde77ee 100644 --- a/lib/hyperscript/parser.sx +++ b/lib/hyperscript/parser.sx @@ -954,7 +954,35 @@ (when (= (tp-type) "bracket-close") (adv!)) (let ((tgt (parse-tgt-kw "to" (list (quote me))))) - (list (quote add-attr) attr-name attr-val tgt)))))) + (let + ((when-clause (if (match-kw "when") (parse-expr) nil))) + (if + when-clause + (list + (quote add-attr-when) + attr-name + attr-val + tgt + when-clause) + (list (quote add-attr) attr-name attr-val tgt)))))))) + ((= (tp-type) "attr") + (let + ((attr-name (get (adv!) "value"))) + (let + ((attr-val (if (and (= (tp-type) "op") (= (tp-val) "=")) (do (adv!) (parse-expr)) ""))) + (let + ((tgt (if (match-kw "to") (parse-expr) (list (quote me))))) + (let + ((when-clause (if (match-kw "when") (parse-expr) nil))) + (if + when-clause + (list + (quote add-attr-when) + attr-name + attr-val + tgt + when-clause) + (list (quote add-attr) attr-name attr-val tgt))))))) (true (let ((value (parse-expr))) @@ -991,6 +1019,12 @@ (cons (quote multi-remove-class) (cons tgt (cons cls extra-classes))))))) + ((= (tp-type) "attr") + (let + ((attr-name (get (adv!) "value"))) + (let + ((tgt (if (match-kw "from") (parse-expr) (list (quote me))))) + (list (quote remove-attr) attr-name tgt)))) ((and (= (tp-type) "bracket-open") (= (tp-val) "[")) (do (adv!) @@ -1276,20 +1310,24 @@ (fn () (let - ((tgt (cond ((and (= (tp-type) "ident") (or (= (tp-val) "element") (= (tp-val) "global") (= (tp-val) "local"))) (do (adv!) (parse-expr))) (true (parse-expr))))) - (cond - ((match-kw "to") - (let ((value (parse-expr))) (list (quote set!) tgt value))) - ((match-kw "on") - (let - ((target (parse-expr))) - (if - (match-kw "to") - (let - ((value (parse-expr))) - (list (quote set-on!) tgt target value)) - (list (quote set-on) tgt target)))) - (true (error (str "Expected to/on at position " p))))))) + ((tgt-raw (cond ((and (= (tp-type) "ident") (or (= (tp-val) "element") (= (tp-val) "global") (= (tp-val) "local"))) (do (adv!) (parse-expr))) (true (parse-expr))))) + (let + ((tgt (if (= (tp-type) "attr") (let ((attr-name (get (adv!) "value"))) (list (quote attr) attr-name tgt-raw)) tgt-raw))) + (cond + ((match-kw "to") + (let + ((value (parse-expr))) + (list (quote set!) tgt value))) + ((match-kw "on") + (let + ((target (parse-expr))) + (if + (match-kw "to") + (let + ((value (parse-expr))) + (list (quote set-on!) tgt target value)) + (list (quote set-on) tgt target)))) + (true (error (str "Expected to/on at position " p)))))))) (define parse-put-cmd (fn diff --git a/lib/hyperscript/runtime.sx b/lib/hyperscript/runtime.sx index ee577e1b..d5f02c38 100644 --- a/lib/hyperscript/runtime.sx +++ b/lib/hyperscript/runtime.sx @@ -294,10 +294,13 @@ hs-add-to! (fn (value target) - (if - (list? target) - (append target (list value)) - (host-call target "push" value)))) + (cond + ((list? target) + (if + (some (fn (x) (= x value)) target) + target + (append target (list value)))) + (true (do (host-call target "push" value) target))))) ;; First/last within a specific scope. (define @@ -664,7 +667,11 @@ (cond ((nil? target) value) ((string? target) (str target value)) - ((list? target) (append target (list value))) + ((list? target) + (if + (some (fn (x) (= x value)) target) + target + (append target (list value)))) ((hs-element? target) (do (dom-insert-adjacent-html target "beforeend" (str value)) @@ -688,6 +695,61 @@ ((fmt (cond ((nil? format) "text") ((or (= format "JSON") (= format "json") (= format "Object") (= format "object")) "json") ((or (= format "HTML") (= format "html")) "html") ((or (= format "Response") (= format "response")) "response") ((or (= format "Text") (= format "text")) "text") (true format)))) (perform (list "io-fetch" url fmt))))) ;; Array slicing (inclusive both ends) +(define + hs-json-escape + (fn + (s) + (str + "\"" + (let + ((out "") (i 0) (n (string-length s))) + (define + walk + (fn + () + (when + (< i n) + (let + ((c (substring s i (+ i 1)))) + (set! + out + (cond + ((= c "\\") (str out "\\\\")) + ((= c "\"") (str out "\\\"")) + ((= c "\n") (str out "\\n")) + ((= c "\r") (str out "\\r")) + ((= c "\t") (str out "\\t")) + (true (str out c)))) + (set! i (+ i 1)) + (walk))))) + (walk) + out) + "\""))) +;; Collection: sorted by +(define + hs-json-stringify + (fn + (v) + (cond + ((nil? v) "null") + ((= v true) "true") + ((= v false) "false") + ((number? v) (str v)) + ((string? v) (hs-json-escape v)) + ((list? v) (str "[" (join "," (map hs-json-stringify v)) "]")) + ((dict? v) + (str + "{" + (join + "," + (map + (fn + (k) + (str (hs-json-escape k) ":" (hs-json-stringify (get v k)))) + (keys v))) + "}")) + (true (hs-json-escape (str v)))))) +;; Collection: sorted by descending (define hs-coerce (fn @@ -705,19 +767,39 @@ ((= type-name "Bool") (not (hs-falsy? value))) ((= type-name "Boolean") (not (hs-falsy? value))) ((= type-name "Array") (if (list? value) value (list value))) - ((= type-name "HTML") (str value)) + ((= type-name "HTML") + (cond + ((list? value) (join "" (map (fn (x) (str x)) value))) + ((hs-element? value) (host-get value "outerHTML")) + (true (str value)))) ((= type-name "JSON") (cond ((string? value) (guard (_e (true value)) (json-parse value))) - ((dict? value) (json-stringify value)) - ((list? value) (json-stringify value)) + ((dict? value) (hs-json-stringify value)) + ((list? value) (hs-json-stringify value)) (true value))) ((= type-name "Object") (if (string? value) (guard (_e (true value)) (json-parse value)) value)) - ((= type-name "JSONString") (json-stringify value)) + ((= type-name "JSONString") (hs-json-stringify value)) + ((= type-name "FormEncoded") + (if + (dict? value) + (join + "&" + (map + (fn + (k) + (let + ((v (get value k))) + (if + (list? v) + (join "&" (map (fn (item) (str k "=" item)) v)) + (str k "=" v)))) + (keys value))) + (str value))) ((or (= type-name "Fixed") (= type-name "Fixed:") (starts-with? type-name "Fixed:")) (let ((digits (if (> (string-length type-name) 6) (+ (substring type-name 6 (string-length type-name)) 0) 0)) @@ -774,7 +856,7 @@ (map (fn (k) (list k (get value k))) (keys value)) value)) (true value)))) -;; Collection: sorted by +;; Collection: split by (define hs-gather-form-nodes (fn @@ -808,11 +890,11 @@ (each 0))))))))) (walk root) acc))) -;; Collection: sorted by descending +;; Collection: joined by (define hs-values-from-nodes (fn (nodes) (reduce hs-values-absorb (dict) nodes))) -;; Collection: split by + (define hs-value-of-node (fn @@ -828,7 +910,7 @@ ((or (= typ "checkbox") (= typ "radio")) (if (host-get node "checked") (host-get node "value") nil)) (true (host-get node "value")))))) -;; Collection: joined by + (define hs-select-multi-values (fn diff --git a/shared/static/wasm/sx/hs-compiler.sx b/shared/static/wasm/sx/hs-compiler.sx index 6f346d29..d67e1439 100644 --- a/shared/static/wasm/sx/hs-compiler.sx +++ b/shared/static/wasm/sx/hs-compiler.sx @@ -18,7 +18,17 @@ (target value) (if (not (list? target)) - (list (quote set!) target value) + (if + (= target (quote the-result)) + (list + (quote let) + (list (list (quote __hs-r) value)) + (list + (quote begin) + (list (quote set!) (quote the-result) (quote __hs-r)) + (list (quote set!) (quote it) (quote __hs-r)) + (quote __hs-r))) + (list (quote set!) target value)) (let ((th (first target))) (cond @@ -1169,15 +1179,71 @@ (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 for-each) + (quote let) (list - (quote fn) - (list (quote it)) (list - (quote when) - (hs-to-sx when-cond) - (list (quote dom-add-class) (quote it) cls))) - tgt-expr)))) + (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))) @@ -1598,11 +1664,17 @@ ((= head (quote append!)) (let ((tgt (hs-to-sx (nth ast 2))) - (val (hs-to-sx (nth ast 1)))) - (if - (symbol? tgt) - (list (quote set!) tgt (list (quote hs-append) tgt val)) - (list (quote hs-append!) val tgt)))) + (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)))) diff --git a/shared/static/wasm/sx/hs-parser.sx b/shared/static/wasm/sx/hs-parser.sx index 3fe8e8ad..4cde77ee 100644 --- a/shared/static/wasm/sx/hs-parser.sx +++ b/shared/static/wasm/sx/hs-parser.sx @@ -954,7 +954,35 @@ (when (= (tp-type) "bracket-close") (adv!)) (let ((tgt (parse-tgt-kw "to" (list (quote me))))) - (list (quote add-attr) attr-name attr-val tgt)))))) + (let + ((when-clause (if (match-kw "when") (parse-expr) nil))) + (if + when-clause + (list + (quote add-attr-when) + attr-name + attr-val + tgt + when-clause) + (list (quote add-attr) attr-name attr-val tgt)))))))) + ((= (tp-type) "attr") + (let + ((attr-name (get (adv!) "value"))) + (let + ((attr-val (if (and (= (tp-type) "op") (= (tp-val) "=")) (do (adv!) (parse-expr)) ""))) + (let + ((tgt (if (match-kw "to") (parse-expr) (list (quote me))))) + (let + ((when-clause (if (match-kw "when") (parse-expr) nil))) + (if + when-clause + (list + (quote add-attr-when) + attr-name + attr-val + tgt + when-clause) + (list (quote add-attr) attr-name attr-val tgt))))))) (true (let ((value (parse-expr))) @@ -991,6 +1019,12 @@ (cons (quote multi-remove-class) (cons tgt (cons cls extra-classes))))))) + ((= (tp-type) "attr") + (let + ((attr-name (get (adv!) "value"))) + (let + ((tgt (if (match-kw "from") (parse-expr) (list (quote me))))) + (list (quote remove-attr) attr-name tgt)))) ((and (= (tp-type) "bracket-open") (= (tp-val) "[")) (do (adv!) @@ -1276,20 +1310,24 @@ (fn () (let - ((tgt (cond ((and (= (tp-type) "ident") (or (= (tp-val) "element") (= (tp-val) "global") (= (tp-val) "local"))) (do (adv!) (parse-expr))) (true (parse-expr))))) - (cond - ((match-kw "to") - (let ((value (parse-expr))) (list (quote set!) tgt value))) - ((match-kw "on") - (let - ((target (parse-expr))) - (if - (match-kw "to") - (let - ((value (parse-expr))) - (list (quote set-on!) tgt target value)) - (list (quote set-on) tgt target)))) - (true (error (str "Expected to/on at position " p))))))) + ((tgt-raw (cond ((and (= (tp-type) "ident") (or (= (tp-val) "element") (= (tp-val) "global") (= (tp-val) "local"))) (do (adv!) (parse-expr))) (true (parse-expr))))) + (let + ((tgt (if (= (tp-type) "attr") (let ((attr-name (get (adv!) "value"))) (list (quote attr) attr-name tgt-raw)) tgt-raw))) + (cond + ((match-kw "to") + (let + ((value (parse-expr))) + (list (quote set!) tgt value))) + ((match-kw "on") + (let + ((target (parse-expr))) + (if + (match-kw "to") + (let + ((value (parse-expr))) + (list (quote set-on!) tgt target value)) + (list (quote set-on) tgt target)))) + (true (error (str "Expected to/on at position " p)))))))) (define parse-put-cmd (fn diff --git a/shared/static/wasm/sx/hs-runtime.sx b/shared/static/wasm/sx/hs-runtime.sx index ee577e1b..d5f02c38 100644 --- a/shared/static/wasm/sx/hs-runtime.sx +++ b/shared/static/wasm/sx/hs-runtime.sx @@ -294,10 +294,13 @@ hs-add-to! (fn (value target) - (if - (list? target) - (append target (list value)) - (host-call target "push" value)))) + (cond + ((list? target) + (if + (some (fn (x) (= x value)) target) + target + (append target (list value)))) + (true (do (host-call target "push" value) target))))) ;; First/last within a specific scope. (define @@ -664,7 +667,11 @@ (cond ((nil? target) value) ((string? target) (str target value)) - ((list? target) (append target (list value))) + ((list? target) + (if + (some (fn (x) (= x value)) target) + target + (append target (list value)))) ((hs-element? target) (do (dom-insert-adjacent-html target "beforeend" (str value)) @@ -688,6 +695,61 @@ ((fmt (cond ((nil? format) "text") ((or (= format "JSON") (= format "json") (= format "Object") (= format "object")) "json") ((or (= format "HTML") (= format "html")) "html") ((or (= format "Response") (= format "response")) "response") ((or (= format "Text") (= format "text")) "text") (true format)))) (perform (list "io-fetch" url fmt))))) ;; Array slicing (inclusive both ends) +(define + hs-json-escape + (fn + (s) + (str + "\"" + (let + ((out "") (i 0) (n (string-length s))) + (define + walk + (fn + () + (when + (< i n) + (let + ((c (substring s i (+ i 1)))) + (set! + out + (cond + ((= c "\\") (str out "\\\\")) + ((= c "\"") (str out "\\\"")) + ((= c "\n") (str out "\\n")) + ((= c "\r") (str out "\\r")) + ((= c "\t") (str out "\\t")) + (true (str out c)))) + (set! i (+ i 1)) + (walk))))) + (walk) + out) + "\""))) +;; Collection: sorted by +(define + hs-json-stringify + (fn + (v) + (cond + ((nil? v) "null") + ((= v true) "true") + ((= v false) "false") + ((number? v) (str v)) + ((string? v) (hs-json-escape v)) + ((list? v) (str "[" (join "," (map hs-json-stringify v)) "]")) + ((dict? v) + (str + "{" + (join + "," + (map + (fn + (k) + (str (hs-json-escape k) ":" (hs-json-stringify (get v k)))) + (keys v))) + "}")) + (true (hs-json-escape (str v)))))) +;; Collection: sorted by descending (define hs-coerce (fn @@ -705,19 +767,39 @@ ((= type-name "Bool") (not (hs-falsy? value))) ((= type-name "Boolean") (not (hs-falsy? value))) ((= type-name "Array") (if (list? value) value (list value))) - ((= type-name "HTML") (str value)) + ((= type-name "HTML") + (cond + ((list? value) (join "" (map (fn (x) (str x)) value))) + ((hs-element? value) (host-get value "outerHTML")) + (true (str value)))) ((= type-name "JSON") (cond ((string? value) (guard (_e (true value)) (json-parse value))) - ((dict? value) (json-stringify value)) - ((list? value) (json-stringify value)) + ((dict? value) (hs-json-stringify value)) + ((list? value) (hs-json-stringify value)) (true value))) ((= type-name "Object") (if (string? value) (guard (_e (true value)) (json-parse value)) value)) - ((= type-name "JSONString") (json-stringify value)) + ((= type-name "JSONString") (hs-json-stringify value)) + ((= type-name "FormEncoded") + (if + (dict? value) + (join + "&" + (map + (fn + (k) + (let + ((v (get value k))) + (if + (list? v) + (join "&" (map (fn (item) (str k "=" item)) v)) + (str k "=" v)))) + (keys value))) + (str value))) ((or (= type-name "Fixed") (= type-name "Fixed:") (starts-with? type-name "Fixed:")) (let ((digits (if (> (string-length type-name) 6) (+ (substring type-name 6 (string-length type-name)) 0) 0)) @@ -774,7 +856,7 @@ (map (fn (k) (list k (get value k))) (keys value)) value)) (true value)))) -;; Collection: sorted by +;; Collection: split by (define hs-gather-form-nodes (fn @@ -808,11 +890,11 @@ (each 0))))))))) (walk root) acc))) -;; Collection: sorted by descending +;; Collection: joined by (define hs-values-from-nodes (fn (nodes) (reduce hs-values-absorb (dict) nodes))) -;; Collection: split by + (define hs-value-of-node (fn @@ -828,7 +910,7 @@ ((or (= typ "checkbox") (= typ "radio")) (if (host-get node "checked") (host-get node "value") nil)) (true (host-get node "value")))))) -;; Collection: joined by + (define hs-select-multi-values (fn