diff --git a/hosts/ocaml/bin/run_tests.ml b/hosts/ocaml/bin/run_tests.ml index c6ee1c3a..c9372942 100644 --- a/hosts/ocaml/bin/run_tests.ml +++ b/hosts/ocaml/bin/run_tests.ml @@ -1637,6 +1637,20 @@ let run_spec_tests env test_files = in let rec mock_query_all el sel = + (* Handle comma-separated selector groups: "a, b, c" *) + if String.contains sel ',' then + let parts = String.split_on_char ',' sel + |> List.map String.trim + |> List.filter (fun s -> String.length s > 0) in + let seen = ref [] in + List.concat_map (fun part -> + let results = mock_query_all el part in + List.filter (fun r -> + if List.memq r !seen then false + else (seen := r :: !seen; true) + ) results + ) parts + else match split_selector sel with | [single] -> mock_query_all_single el single | first :: rest -> @@ -1705,6 +1719,11 @@ let run_spec_tests env test_files = | [Nil; _] -> Nil | [String s; String "length"] -> Number (float_of_int (String.length s)) | [List l; String "length"] -> Number (float_of_int (List.length l)) + | [ListRef { contents = l }; String "length"] -> Number (float_of_int (List.length l)) + | [List l; String "size"] -> Number (float_of_int (List.length l)) + | [ListRef { contents = l }; String "size"] -> Number (float_of_int (List.length l)) + | [Dict d; String "size"] when not (Hashtbl.mem d "__mock_type") -> + Number (float_of_int (Hashtbl.length d)) | [Dict d; String key] -> let mt = match Hashtbl.find_opt d "__mock_type" with Some (String t) -> t | _ -> "" in (* classList.length *) @@ -1789,6 +1808,18 @@ let run_spec_tests env test_files = | Bool false -> String "false" | List l -> String (String.concat "," (List.map (fun v -> match dom_stringify v with String s -> s | _ -> "") l)) | Nil -> String "" + | Dict d -> + (* Avoid `inspect` on circular mock-DOM dicts. Prefer outerHTML, fall + back to a tag placeholder, then "[object Object]". *) + (match Hashtbl.find_opt d "outerHTML" with + | Some (String s) when String.length s > 0 -> String s + | _ -> + (match Hashtbl.find_opt d "__mock_type" with + | Some (String "element") -> + let tag = match Hashtbl.find_opt d "tagName" with + | Some (String t) -> String.lowercase_ascii t | _ -> "div" in + String ("<" ^ tag ^ ">") + | _ -> String "[object Object]")) | v -> String (Sx_types.inspect v) in @@ -1980,6 +2011,21 @@ let run_spec_tests env test_files = Hashtbl.replace d "className" (String sv); end; if name = "disabled" then Hashtbl.replace d "disabled" (Bool true); + if name = "checked" then begin + Hashtbl.replace d "defaultChecked" (Bool true); + Hashtbl.replace d "checked" (Bool true); + end; + if name = "selected" then begin + Hashtbl.replace d "defaultSelected" (Bool true); + Hashtbl.replace d "selected" (Bool true); + end; + if name = "value" then begin + (match Hashtbl.find_opt d "defaultValue" with + | Some _ -> () + | None -> Hashtbl.replace d "defaultValue" (String sv)); + Hashtbl.replace d "value" (String sv); + end; + if name = "type" then Hashtbl.replace d "type" (String sv); if name = "style" then begin (* Parse CSS string into the style sub-dict *) let style_d = match Hashtbl.find_opt d "style" with Some (Dict s) -> s | _ -> @@ -2543,6 +2589,11 @@ let run_spec_tests env test_files = ignore (Sx_types.env_bind env "console-log" (NativeFn ("console-log", fun _ -> Nil))); ignore (Sx_types.env_bind env "console-debug" (NativeFn ("console-debug", fun _ -> Nil))); ignore (Sx_types.env_bind env "console-error" (NativeFn ("console-error", fun _ -> Nil))); + (* promiseAString / promiseAnInt: upstream hyperscript tests use these to + exercise promise awaiting. In the synchronous mock environment they + resolve immediately to the expected value. *) + ignore (Sx_types.env_bind env "promiseAString" (NativeFn ("promiseAString", fun _ -> String "foo"))); + ignore (Sx_types.env_bind env "promiseAnInt" (NativeFn ("promiseAnInt", fun _ -> Number 42.0))); (* eval-hs: compile hyperscript source to SX and evaluate it. Used by eval-only behavioral tests (comparisonOperator, mathOperator, etc.). Accepts optional ctx dict: {:me V :locals {:x V :y V ...}}. Catches diff --git a/lib/hyperscript/compiler.sx b/lib/hyperscript/compiler.sx index 8ea23d50..21dbe0ed 100644 --- a/lib/hyperscript/compiler.sx +++ b/lib/hyperscript/compiler.sx @@ -23,14 +23,48 @@ ((th (first target))) (cond ((= th dot-sym) - (list - (quote dom-set-prop) - (hs-to-sx (nth target 1)) - (nth target 2) - value)) + (let + ((base-ast (nth target 1)) (prop (nth target 2))) + (cond + ((and (list? base-ast) (= (first base-ast) (quote query)) (let ((s (nth base-ast 1))) (and (string? s) (> (len s) 0) (= (substring s 0 1) ".")))) + (list + (quote for-each) + (list + (quote fn) + (list (quote __hs-el)) + (list + (quote dom-set-prop) + (quote __hs-el) + prop + value)) + (list (quote hs-query-all) (nth base-ast 1)))) + ((and (list? base-ast) (= (first base-ast) dot-sym) (let ((inner (nth base-ast 1))) (and (list? inner) (= (first inner) (quote query)) (let ((s (nth inner 1))) (and (string? s) (> (len s) 0) (= (substring s 0 1) ".")))))) + (let + ((inner (nth base-ast 1)) + (mid-prop (nth base-ast 2))) + (list + (quote for-each) + (list + (quote fn) + (list (quote __hs-el)) + (list + (quote dom-set-prop) + (list + (quote host-get) + (quote __hs-el) + mid-prop) + prop + value)) + (list (quote hs-query-all) (nth inner 1))))) + (true + (list + (quote dom-set-prop) + (hs-to-sx base-ast) + prop + value))))) ((= th (quote attr)) (list - (quote dom-set-attr) + (quote hs-set-attr!) (hs-to-sx (nth target 2)) (nth target 1) value)) @@ -84,7 +118,7 @@ (list? prop-ast) (= (first prop-ast) (quote attr))) (list - (quote dom-set-attr) + (quote hs-set-attr!) (hs-to-sx obj-ast) (nth prop-ast 1) value) @@ -323,56 +357,120 @@ (cond ((and (list? expr) (= (first expr) (quote attr))) (let - ((el (if tgt-override (hs-to-sx tgt-override) (quote me)))) + ((el (if tgt-override (hs-to-sx tgt-override) (quote me))) + (attr-name (nth expr 1))) (list - (quote dom-set-attr) - el - (nth expr 1) + (quote let) (list - (quote +) (list - (quote parse-number) - (list (quote dom-get-attr) el (nth expr 1))) - amount)))) + (quote __hs-new) + (list + (quote +) + (list + (quote hs-to-number) + (list (quote dom-get-attr) el attr-name)) + amount))) + (list + (quote do) + (list (quote dom-set-attr) el attr-name (quote __hs-new)) + (list (quote set!) (quote it) (quote __hs-new)))))) ((and (list? expr) (= (first expr) dot-sym)) (let ((obj (hs-to-sx (nth expr 1))) (prop (nth expr 2))) (list - (quote host-set!) - obj - prop + (quote let) (list - (quote +) (list - (quote parse-number) - (list (quote host-get) obj prop)) - amount)))) + (quote __hs-new) + (list + (quote +) + (list + (quote hs-to-number) + (list (quote host-get) obj prop)) + amount))) + (list + (quote do) + (list (quote host-set!) obj prop (quote __hs-new)) + (list (quote set!) (quote it) (quote __hs-new)))))) ((and (list? expr) (= (first expr) (quote style))) (let ((el (if tgt-override (hs-to-sx tgt-override) (quote me))) (prop (nth expr 1))) (list - (quote dom-set-style) - el - prop + (quote let) (list - (quote +) (list - (quote parse-number) - (list (quote dom-get-style) el prop)) - amount)))) + (quote __hs-new) + (list + (quote +) + (list + (quote hs-to-number) + (list (quote dom-get-style) el prop)) + amount))) + (list + (quote do) + (list (quote dom-set-style) el prop (quote __hs-new)) + (list (quote set!) (quote it) (quote __hs-new)))))) ((and (list? expr) (= (first expr) (quote dom-ref))) (let ((el (hs-to-sx (nth expr 2))) (name (nth expr 1))) (list - (quote hs-dom-set!) - el - name - (list (quote +) (list (quote hs-dom-get) el name) amount)))) + (quote let) + (list + (list + (quote __hs-new) + (list + (quote +) + (list + (quote hs-to-number) + (list (quote hs-dom-get) el name)) + amount))) + (list + (quote do) + (list (quote hs-dom-set!) el name (quote __hs-new)) + (list (quote set!) (quote it) (quote __hs-new)))))) + ((and (list? expr) (= (first expr) (quote array-index)) (list? (nth expr 1)) (= (first (nth expr 1)) (quote ref))) + (let + ((var-sym (make-symbol (nth (nth expr 1) 1))) + (idx (hs-to-sx (nth expr 2)))) + (list + (quote let) + (list (list (quote __hs-idx) idx)) + (list + (quote let) + (list + (list + (quote __hs-new) + (list + (quote +) + (list + (quote hs-to-number) + (list (quote nth) var-sym (quote __hs-idx))) + amount))) + (list + (quote do) + (list + (quote set!) + var-sym + (list + (quote hs-list-set) + var-sym + (quote __hs-idx) + (quote __hs-new))) + (list (quote set!) (quote it) (quote __hs-new))))))) (true (let ((t (hs-to-sx expr))) - (list (quote set!) t (list (quote +) t amount))))))) + (list + (quote let) + (list + (list + (quote __hs-new) + (list (quote +) (list (quote hs-to-number) t) amount))) + (list + (quote do) + (list (quote set!) t (quote __hs-new)) + (list (quote set!) (quote it) (quote __hs-new))))))))) (define emit-dec (fn @@ -380,56 +478,120 @@ (cond ((and (list? expr) (= (first expr) (quote attr))) (let - ((el (if tgt-override (hs-to-sx tgt-override) (quote me)))) + ((el (if tgt-override (hs-to-sx tgt-override) (quote me))) + (attr-name (nth expr 1))) (list - (quote dom-set-attr) - el - (nth expr 1) + (quote let) (list - (quote -) (list - (quote parse-number) - (list (quote dom-get-attr) el (nth expr 1))) - amount)))) + (quote __hs-new) + (list + (quote -) + (list + (quote hs-to-number) + (list (quote dom-get-attr) el attr-name)) + amount))) + (list + (quote do) + (list (quote dom-set-attr) el attr-name (quote __hs-new)) + (list (quote set!) (quote it) (quote __hs-new)))))) ((and (list? expr) (= (first expr) dot-sym)) (let ((obj (hs-to-sx (nth expr 1))) (prop (nth expr 2))) (list - (quote host-set!) - obj - prop + (quote let) (list - (quote -) (list - (quote parse-number) - (list (quote host-get) obj prop)) - amount)))) + (quote __hs-new) + (list + (quote -) + (list + (quote hs-to-number) + (list (quote host-get) obj prop)) + amount))) + (list + (quote do) + (list (quote host-set!) obj prop (quote __hs-new)) + (list (quote set!) (quote it) (quote __hs-new)))))) ((and (list? expr) (= (first expr) (quote style))) (let ((el (if tgt-override (hs-to-sx tgt-override) (quote me))) (prop (nth expr 1))) (list - (quote dom-set-style) - el - prop + (quote let) (list - (quote -) (list - (quote parse-number) - (list (quote dom-get-style) el prop)) - amount)))) + (quote __hs-new) + (list + (quote -) + (list + (quote hs-to-number) + (list (quote dom-get-style) el prop)) + amount))) + (list + (quote do) + (list (quote dom-set-style) el prop (quote __hs-new)) + (list (quote set!) (quote it) (quote __hs-new)))))) ((and (list? expr) (= (first expr) (quote dom-ref))) (let ((el (hs-to-sx (nth expr 2))) (name (nth expr 1))) (list - (quote hs-dom-set!) - el - name - (list (quote -) (list (quote hs-dom-get) el name) amount)))) + (quote let) + (list + (list + (quote __hs-new) + (list + (quote -) + (list + (quote hs-to-number) + (list (quote hs-dom-get) el name)) + amount))) + (list + (quote do) + (list (quote hs-dom-set!) el name (quote __hs-new)) + (list (quote set!) (quote it) (quote __hs-new)))))) + ((and (list? expr) (= (first expr) (quote array-index)) (list? (nth expr 1)) (= (first (nth expr 1)) (quote ref))) + (let + ((var-sym (make-symbol (nth (nth expr 1) 1))) + (idx (hs-to-sx (nth expr 2)))) + (list + (quote let) + (list (list (quote __hs-idx) idx)) + (list + (quote let) + (list + (list + (quote __hs-new) + (list + (quote -) + (list + (quote hs-to-number) + (list (quote nth) var-sym (quote __hs-idx))) + amount))) + (list + (quote do) + (list + (quote set!) + var-sym + (list + (quote hs-list-set) + var-sym + (quote __hs-idx) + (quote __hs-new))) + (list (quote set!) (quote it) (quote __hs-new))))))) (true (let ((t (hs-to-sx expr))) - (list (quote set!) t (list (quote -) t amount))))))) + (list + (quote let) + (list + (list + (quote __hs-new) + (list (quote -) (list (quote hs-to-number) t) amount))) + (list + (quote do) + (list (quote set!) t (quote __hs-new)) + (list (quote set!) (quote it) (quote __hs-new))))))))) (define emit-behavior (fn @@ -1009,7 +1171,15 @@ (hs-to-sx tgt) (list (quote hs-remove-from!) val (hs-to-sx tgt))))) ((= head (quote empty-target)) - (list (quote hs-empty-target!) (hs-to-sx (nth ast 1)))) + (let + ((tgt (nth ast 1))) + (if + (and (list? tgt) (= (first tgt) (quote local))) + (list + (quote set!) + (make-symbol (nth tgt 1)) + (list (quote hs-empty-like) (make-symbol (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)) @@ -1160,6 +1330,9 @@ (or (= (first c) (quote hs-fetch)) (= (first c) (quote hs-wait)) + (= (first c) (quote hs-wait-for)) + (= (first c) (quote hs-query-first)) + (= (first c) (quote hs-query-all)) (= (first c) (quote perform))))) compiled)) (reduce @@ -1486,7 +1659,8 @@ (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!) (nth ast 1))) + ((= 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)))))))) diff --git a/lib/hyperscript/parser.sx b/lib/hyperscript/parser.sx index 226b56f6..0bdb84bb 100644 --- a/lib/hyperscript/parser.sx +++ b/lib/hyperscript/parser.sx @@ -1205,14 +1205,33 @@ (adv!) (let ((source (if (match-kw "from") (parse-expr) nil))) - (if - source - (list (quote wait-for) event-name :from source) - (list (quote wait-for) event-name))))) + (let + ((timeout-dur (if (match-kw "or") (if (= (tp-type) "number") (let ((tok (adv!))) (let ((raw (get tok "value")) (suffix (if (and (= (tp-type) "ident") (or (= (tp-val) "ms") (= (tp-val) "s"))) (get (adv!) "value") ""))) (parse-dur (str raw suffix)))) nil) nil))) + (cond + ((and source timeout-dur) + (list + (quote wait-for) + event-name + :from source + :or timeout-dur)) + (source + (list (quote wait-for) event-name :from source)) + (timeout-dur + (list (quote wait-for) event-name :or timeout-dur)) + (true (list (quote wait-for) event-name))))))) ((= (tp-type) "number") (let ((tok (adv!))) - (list (quote wait) (parse-dur (get tok "value"))))) + (let + ((raw (get tok "value")) + (suffix + (if + (and + (= (tp-type) "ident") + (or (= (tp-val) "ms") (= (tp-val) "s"))) + (get (adv!) "value") + ""))) + (list (quote wait) (parse-dur (str raw suffix)))))) (true (list (quote wait) 0))))) (define parse-detail-dict @@ -1337,7 +1356,7 @@ (fn () (let - ((tgt (cond ((and (= (tp-type) "ident") (= (tp-val) "element")) (do (adv!) (parse-atom))) ((= (tp-type) "id") (parse-atom)) ((= (tp-type) "class") (parse-atom)) ((= (tp-type) "selector") (parse-atom)) (true nil)))) + ((tgt (cond ((and (= (tp-type) "ident") (= (tp-val) "element")) (do (adv!) (parse-atom))) ((and (= (tp-type) "keyword") (= (tp-val) "its")) (do (adv!) (list (quote ref) "it"))) ((= (tp-type) "id") (parse-atom)) ((= (tp-type) "class") (parse-atom)) ((= (tp-type) "selector") (parse-atom)) (true nil)))) (define parse-one-transition (fn @@ -1473,18 +1492,7 @@ (if (= (tp-type) "comma") (adv!) nil) (ca-collect (append acc (list arg))))))) (ca-collect (list)))) - (define - parse-call-cmd - (fn - () - (let - ((name (get (adv!) "value"))) - (if - (= (tp-type) "paren-open") - (let - ((args (parse-call-args))) - (cons (quote call) (cons name args))) - (list (quote call) name))))) + (define parse-call-cmd (fn () (parse-expr))) (define parse-get-cmd (fn () (parse-expr))) (define parse-take-cmd @@ -1841,7 +1849,7 @@ (fn () (let - ((mode (cond ((match-kw "the") (do (match-kw "event") (match-kw "'s") "event")) ((or (match-kw "default") (and (= (tp-val) "default") (do (adv!) true))) "default") ((or (match-kw "bubbling") (and (= (tp-val) "bubbling") (do (adv!) true))) "bubbling") (true "event")))) + ((mode (cond ((match-kw "the") (do (match-kw "event") (when (and (= (tp-type) "op") (= (tp-val) "'s")) (adv!)) "the-event")) ((or (match-kw "default") (and (= (tp-val) "default") (do (adv!) true))) "default") ((or (match-kw "bubbling") (and (= (tp-val) "bubbling") (do (adv!) true))) "bubbling") (true "all")))) (list (quote halt!) mode)))) (define parse-param-list @@ -1965,7 +1973,7 @@ (fn () (let - ((target (cond ((at-end?) (list (quote sym) "me")) ((and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end"))) (list (quote sym) "me")) (true (parse-expr))))) + ((target (cond ((at-end?) (list (quote ref) "me")) ((and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end"))) (list (quote ref) "me")) (true (parse-expr))))) (list (quote empty-target) target)))) (define parse-swap-cmd diff --git a/lib/hyperscript/runtime.sx b/lib/hyperscript/runtime.sx index 85324ca7..35586471 100644 --- a/lib/hyperscript/runtime.sx +++ b/lib/hyperscript/runtime.sx @@ -156,26 +156,77 @@ (dom-set-attr target name "")))))))) ;; First element matching selector within a scope. -(define - hs-put! - (fn - (value pos target) - (cond - ((= pos "into") - (if (list? target) target (dom-set-inner-html target value))) - ((= pos "before") - (dom-insert-adjacent-html target "beforebegin" value)) - ((= pos "after") (dom-insert-adjacent-html target "afterend" value)) - ((= pos "start") - (if - (list? target) - (append! target value 0) - (dom-insert-adjacent-html target "afterbegin" value))) - ((= pos "end") - (if - (list? target) - (append! target value) - (dom-insert-adjacent-html target "beforeend" value)))))) +(begin + (define + hs-element? + (fn + (v) + (and v (or (host-get v "nodeType") (host-get v "__mock_type"))))) + (define + hs-set-attr! + (fn + (el name val) + (if (nil? val) (dom-remove-attr el name) (dom-set-attr el name val)))) + (define + hs-put! + (fn + (value pos target) + (cond + ((= pos "into") + (cond + ((list? target) target) + ((hs-element? value) + (do + (dom-set-inner-html target "") + (host-call target "appendChild" value))) + (true + (do + (dom-set-inner-html target value) + (hs-boot-subtree! target))))) + ((= pos "before") + (if + (hs-element? value) + (let + ((parent (dom-parent target))) + (when parent (host-call parent "insertBefore" value target))) + (let + ((parent (dom-parent target))) + (do + (dom-insert-adjacent-html target "beforebegin" value) + (when parent (hs-boot-subtree! parent)))))) + ((= pos "after") + (if + (hs-element? value) + (let + ((parent (dom-parent target)) + (next (host-get target "nextSibling"))) + (when + parent + (if + next + (host-call parent "insertBefore" value next) + (host-call parent "appendChild" value)))) + (let + ((parent (dom-parent target))) + (do + (dom-insert-adjacent-html target "afterend" value) + (when parent (hs-boot-subtree! parent)))))) + ((= pos "start") + (cond + ((list? target) (append! target value 0)) + ((hs-element? value) (dom-prepend target value)) + (true + (do + (dom-insert-adjacent-html target "afterbegin" value) + (hs-boot-subtree! target))))) + ((= pos "end") + (cond + ((list? target) (append! target value)) + ((hs-element? value) (dom-append target value)) + (true + (do + (dom-insert-adjacent-html target "beforeend" value) + (hs-boot-subtree! target))))))))) ;; Last element matching selector. (define @@ -228,16 +279,22 @@ (define hs-halt! (fn - (mode) - (when - event - (cond - ((= mode "default") (host-call event "preventDefault")) - ((= mode "bubbling") (host-call event "stopPropagation")) - (true - (do - (host-call event "preventDefault") - (host-call event "stopPropagation"))))))) + (ev mode) + (do + (when + ev + (cond + ((= mode "default") (host-call ev "preventDefault")) + ((= mode "bubbling") (host-call ev "stopPropagation")) + ((= mode "the-event") + (do + (host-call ev "preventDefault") + (host-call ev "stopPropagation"))) + (true + (do + (host-call ev "preventDefault") + (host-call ev "stopPropagation"))))) + (when (not (= mode "the-event")) (raise (list "hs-return" nil)))))) ;; ── Type coercion ─────────────────────────────────────────────── @@ -249,7 +306,51 @@ ;; Make a new object of a given type. ;; (hs-make type-name) — creates empty object/collection -(define hs-reset! (fn (target) (host-call target "reset" (list)))) +(define + hs-reset! + (fn + (target) + (cond + ((list? target) (for-each (fn (el) (hs-reset! el)) target)) + ((nil? target) nil) + (true + (let + ((tag (dom-get-prop target "tagName"))) + (cond + ((= tag "FORM") (host-call target "reset" (list))) + ((or (= tag "INPUT") (= tag "TEXTAREA")) + (let + ((input-type (dom-get-prop target "type"))) + (cond + ((or (= input-type "checkbox") (= input-type "radio")) + (dom-set-prop + target + "checked" + (dom-get-prop target "defaultChecked"))) + (true + (dom-set-prop + target + "value" + (dom-get-prop target "defaultValue")))))) + ((= tag "SELECT") + (let + ((options (host-call target "querySelectorAll" "option")) + (default-val nil)) + (do + (for-each + (fn + (opt) + (when + (and + (nil? default-val) + (dom-get-prop opt "defaultSelected")) + (set! default-val (dom-get-prop opt "value")))) + options) + (when + (and (nil? default-val) (> (len options) 0)) + (set! default-val (dom-get-prop (first options) "value"))) + (when default-val (dom-set-prop target "value" default-val))))) + (true nil))))))) ;; ── Behavior installation ─────────────────────────────────────── @@ -306,6 +407,20 @@ hs-query-all (fn (sel) (host-call (dom-body) "querySelectorAll" sel))) +(define + hs-list-set + (fn (lst idx val) (map-indexed (fn (i x) (if (= i idx) val x)) lst))) + +(define + hs-to-number + (fn + (v) + (cond + ((number? v) v) + ((string? v) (or (parse-number v) 0)) + ((nil? v) 0) + (true (or (parse-number (str v)) 0))))) + (define hs-query-first (fn (sel) (host-call (host-global "document") "querySelector" sel))) @@ -387,6 +502,10 @@ (if (cond-fn) nil (hs-repeat-until cond-fn thunk))) (true (if (cond-fn) nil (hs-repeat-until cond-fn thunk))))))) + + + + (define hs-for-each (fn @@ -419,17 +538,14 @@ (define hs-append! (fn (value target) (dom-insert-adjacent-html target "beforeend" value)))) - - - - - +;; ── Sandbox/test runtime additions ────────────────────────────── +;; Property access — dot notation and .length (define hs-fetch (fn (url format) (perform (list "io-fetch" url (if format format "text"))))) - +;; DOM query stub — sandbox returns empty list (define hs-coerce (fn @@ -520,8 +636,7 @@ (map (fn (k) (list k (get value k))) (keys value)) value)) (true value)))) -;; ── Sandbox/test runtime additions ────────────────────────────── -;; Property access — dot notation and .length +;; Method dispatch — obj.method(args) (define hs-add (fn @@ -531,7 +646,9 @@ ((list? b) (cons a b)) ((or (string? a) (string? b)) (str a b)) (true (+ a b))))) -;; DOM query stub — sandbox returns empty list + +;; ── 0.9.90 features ───────────────────────────────────────────── +;; beep! — debug logging, returns value unchanged (define hs-make (fn @@ -542,15 +659,13 @@ ((= type-name "Set") (list)) ((= type-name "Map") (dict)) (true (dict))))) -;; Method dispatch — obj.method(args) +;; Property-based is — check obj.key truthiness (define hs-install (fn (behavior-fn) (behavior-fn me))) - -;; ── 0.9.90 features ───────────────────────────────────────────── -;; beep! — debug logging, returns value unchanged +;; Array slicing (inclusive both ends) (define hs-measure (fn (target) (perform (list (quote io-measure) target)))) -;; Property-based is — check obj.key truthiness +;; Collection: sorted by (define hs-transition (fn @@ -563,7 +678,7 @@ (str prop " " (/ duration 1000) "s"))) (dom-set-style target prop value) (when duration (hs-settle target)))) -;; Array slicing (inclusive both ends) +;; Collection: sorted by descending (define hs-transition-from (fn @@ -577,7 +692,7 @@ (str prop " " (/ duration 1000) "s"))) (dom-set-style target prop (str to-val)) (when duration (hs-settle target)))) -;; Collection: sorted by +;; Collection: split by (define hs-type-check (fn @@ -597,17 +712,17 @@ (= (host-typeof value) "element") (= (host-typeof value) "text"))) (true (= (host-typeof value) (downcase type-name))))))) -;; Collection: sorted by descending +;; Collection: joined by (define hs-type-check-strict (fn (value type-name) (if (nil? value) false (hs-type-check value type-name)))) -;; Collection: split by + (define hs-strict-eq (fn (a b) (and (= (type-of a) (type-of b)) (= a b)))) -;; Collection: joined by + (define hs-eq-ignore-case (fn (a b) (= (downcase (str a)) (downcase (str b))))) @@ -738,6 +853,17 @@ ((dict? v) (= (len (keys v)) 0)) (true false)))) +(define + hs-empty-like + (fn + (v) + (cond + ((list? v) (list)) + ((dict? v) (dict)) + ((string? v) "") + ((nil? v) nil) + (true v)))) + (define hs-empty-target! (fn @@ -756,7 +882,6 @@ (or (= input-type "checkbox") (= input-type "radio")) (dom-set-prop target "checked" false) (dom-set-prop target "value" "")))) - ((= tag "FORM") (dom-set-inner-html target "")) ((= tag "FORM") (let ((children (host-call target "querySelectorAll" "input, textarea, select"))) @@ -981,10 +1106,10 @@ (el) (let ((tag (dom-get-prop el "tagName"))) - (if - (= tag "DIALOG") - (host-call el "showModal") - (dom-set-prop el "open" true))))) + (cond + ((= tag "DIALOG") (host-call el "showModal")) + (true + (do (dom-set-attr el "open" "") (dom-set-prop el "open" true))))))) (define hs-close! @@ -992,10 +1117,12 @@ (el) (let ((tag (dom-get-prop el "tagName"))) - (if - (= tag "DIALOG") - (host-call el "close") - (dom-set-prop el "open" false))))) + (cond + ((= tag "DIALOG") (host-call el "close")) + (true + (do + (host-call el "removeAttribute" "open") + (dom-set-prop el "open" false))))))) (define hs-hide! diff --git a/lib/hyperscript/tokenizer.sx b/lib/hyperscript/tokenizer.sx index a0f3b506..f846e34d 100644 --- a/lib/hyperscript/tokenizer.sx +++ b/lib/hyperscript/tokenizer.sx @@ -183,7 +183,8 @@ "focus" "blur" "dom" - "morph")) + "morph" + "using")) (define hs-keyword? (fn (word) (some (fn (k) (= k word)) hs-keywords))) diff --git a/shared/static/wasm/sx/hs-compiler.sx b/shared/static/wasm/sx/hs-compiler.sx index 4d19ce05..21dbe0ed 100644 --- a/shared/static/wasm/sx/hs-compiler.sx +++ b/shared/static/wasm/sx/hs-compiler.sx @@ -23,14 +23,48 @@ ((th (first target))) (cond ((= th dot-sym) - (list - (quote dom-set-prop) - (hs-to-sx (nth target 1)) - (nth target 2) - value)) + (let + ((base-ast (nth target 1)) (prop (nth target 2))) + (cond + ((and (list? base-ast) (= (first base-ast) (quote query)) (let ((s (nth base-ast 1))) (and (string? s) (> (len s) 0) (= (substring s 0 1) ".")))) + (list + (quote for-each) + (list + (quote fn) + (list (quote __hs-el)) + (list + (quote dom-set-prop) + (quote __hs-el) + prop + value)) + (list (quote hs-query-all) (nth base-ast 1)))) + ((and (list? base-ast) (= (first base-ast) dot-sym) (let ((inner (nth base-ast 1))) (and (list? inner) (= (first inner) (quote query)) (let ((s (nth inner 1))) (and (string? s) (> (len s) 0) (= (substring s 0 1) ".")))))) + (let + ((inner (nth base-ast 1)) + (mid-prop (nth base-ast 2))) + (list + (quote for-each) + (list + (quote fn) + (list (quote __hs-el)) + (list + (quote dom-set-prop) + (list + (quote host-get) + (quote __hs-el) + mid-prop) + prop + value)) + (list (quote hs-query-all) (nth inner 1))))) + (true + (list + (quote dom-set-prop) + (hs-to-sx base-ast) + prop + value))))) ((= th (quote attr)) (list - (quote dom-set-attr) + (quote hs-set-attr!) (hs-to-sx (nth target 2)) (nth target 1) value)) @@ -44,6 +78,12 @@ (list (quote set!) (make-symbol (nth target 1)) value)) ((= th (quote local)) (list (quote define) (make-symbol (nth target 1)) value)) + ((= th (quote dom-ref)) + (list + (quote hs-dom-set!) + (hs-to-sx (nth target 2)) + (nth target 1) + value)) ((= th (quote me)) (list (quote dom-set-inner-html) (quote me) value)) ((= th (quote it)) (list (quote set!) (quote it) value)) @@ -55,6 +95,8 @@ (hs-to-sx (nth target 1)) (hs-to-sx (nth target 2)) value)) + ((or (= th (quote next)) (= th (quote previous)) (= th (quote closest))) + (list (quote dom-set-inner-html) (hs-to-sx target) value)) ((= th (quote of)) (let ((prop-ast (nth target 1)) (obj-ast (nth target 2))) @@ -76,7 +118,7 @@ (list? prop-ast) (= (first prop-ast) (quote attr))) (list - (quote dom-set-attr) + (quote hs-set-attr!) (hs-to-sx obj-ast) (nth prop-ast 1) value) @@ -247,7 +289,14 @@ (ast) (let ((var-name (nth ast 1)) - (collection (hs-to-sx (nth ast 2))) + (raw-coll (hs-to-sx (nth ast 2))) + (collection + (if + (symbol? raw-coll) + (list + (quote hs-safe-call) + (list (quote fn) (list) raw-coll)) + raw-coll)) (body (hs-to-sx (nth ast 3)))) (if (and (> (len ast) 4) (= (nth ast 4) :index)) @@ -308,48 +357,120 @@ (cond ((and (list? expr) (= (first expr) (quote attr))) (let - ((el (if tgt-override (hs-to-sx tgt-override) (quote me)))) + ((el (if tgt-override (hs-to-sx tgt-override) (quote me))) + (attr-name (nth expr 1))) (list - (quote dom-set-attr) - el - (nth expr 1) + (quote let) (list - (quote +) (list - (quote parse-number) - (list (quote dom-get-attr) el (nth expr 1))) - amount)))) + (quote __hs-new) + (list + (quote +) + (list + (quote hs-to-number) + (list (quote dom-get-attr) el attr-name)) + amount))) + (list + (quote do) + (list (quote dom-set-attr) el attr-name (quote __hs-new)) + (list (quote set!) (quote it) (quote __hs-new)))))) ((and (list? expr) (= (first expr) dot-sym)) (let ((obj (hs-to-sx (nth expr 1))) (prop (nth expr 2))) (list - (quote host-set!) - obj - prop + (quote let) (list - (quote +) (list - (quote parse-number) - (list (quote host-get) obj prop)) - amount)))) + (quote __hs-new) + (list + (quote +) + (list + (quote hs-to-number) + (list (quote host-get) obj prop)) + amount))) + (list + (quote do) + (list (quote host-set!) obj prop (quote __hs-new)) + (list (quote set!) (quote it) (quote __hs-new)))))) ((and (list? expr) (= (first expr) (quote style))) (let ((el (if tgt-override (hs-to-sx tgt-override) (quote me))) (prop (nth expr 1))) (list - (quote dom-set-style) - el - prop + (quote let) (list - (quote +) (list - (quote parse-number) - (list (quote dom-get-style) el prop)) - amount)))) + (quote __hs-new) + (list + (quote +) + (list + (quote hs-to-number) + (list (quote dom-get-style) el prop)) + amount))) + (list + (quote do) + (list (quote dom-set-style) el prop (quote __hs-new)) + (list (quote set!) (quote it) (quote __hs-new)))))) + ((and (list? expr) (= (first expr) (quote dom-ref))) + (let + ((el (hs-to-sx (nth expr 2))) (name (nth expr 1))) + (list + (quote let) + (list + (list + (quote __hs-new) + (list + (quote +) + (list + (quote hs-to-number) + (list (quote hs-dom-get) el name)) + amount))) + (list + (quote do) + (list (quote hs-dom-set!) el name (quote __hs-new)) + (list (quote set!) (quote it) (quote __hs-new)))))) + ((and (list? expr) (= (first expr) (quote array-index)) (list? (nth expr 1)) (= (first (nth expr 1)) (quote ref))) + (let + ((var-sym (make-symbol (nth (nth expr 1) 1))) + (idx (hs-to-sx (nth expr 2)))) + (list + (quote let) + (list (list (quote __hs-idx) idx)) + (list + (quote let) + (list + (list + (quote __hs-new) + (list + (quote +) + (list + (quote hs-to-number) + (list (quote nth) var-sym (quote __hs-idx))) + amount))) + (list + (quote do) + (list + (quote set!) + var-sym + (list + (quote hs-list-set) + var-sym + (quote __hs-idx) + (quote __hs-new))) + (list (quote set!) (quote it) (quote __hs-new))))))) (true (let ((t (hs-to-sx expr))) - (list (quote set!) t (list (quote +) t amount))))))) + (list + (quote let) + (list + (list + (quote __hs-new) + (list (quote +) (list (quote hs-to-number) t) amount))) + (list + (quote do) + (list (quote set!) t (quote __hs-new)) + (list (quote set!) (quote it) (quote __hs-new))))))))) (define emit-dec (fn @@ -357,48 +478,120 @@ (cond ((and (list? expr) (= (first expr) (quote attr))) (let - ((el (if tgt-override (hs-to-sx tgt-override) (quote me)))) + ((el (if tgt-override (hs-to-sx tgt-override) (quote me))) + (attr-name (nth expr 1))) (list - (quote dom-set-attr) - el - (nth expr 1) + (quote let) (list - (quote -) (list - (quote parse-number) - (list (quote dom-get-attr) el (nth expr 1))) - amount)))) + (quote __hs-new) + (list + (quote -) + (list + (quote hs-to-number) + (list (quote dom-get-attr) el attr-name)) + amount))) + (list + (quote do) + (list (quote dom-set-attr) el attr-name (quote __hs-new)) + (list (quote set!) (quote it) (quote __hs-new)))))) ((and (list? expr) (= (first expr) dot-sym)) (let ((obj (hs-to-sx (nth expr 1))) (prop (nth expr 2))) (list - (quote host-set!) - obj - prop + (quote let) (list - (quote -) (list - (quote parse-number) - (list (quote host-get) obj prop)) - amount)))) + (quote __hs-new) + (list + (quote -) + (list + (quote hs-to-number) + (list (quote host-get) obj prop)) + amount))) + (list + (quote do) + (list (quote host-set!) obj prop (quote __hs-new)) + (list (quote set!) (quote it) (quote __hs-new)))))) ((and (list? expr) (= (first expr) (quote style))) (let ((el (if tgt-override (hs-to-sx tgt-override) (quote me))) (prop (nth expr 1))) (list - (quote dom-set-style) - el - prop + (quote let) (list - (quote -) (list - (quote parse-number) - (list (quote dom-get-style) el prop)) - amount)))) + (quote __hs-new) + (list + (quote -) + (list + (quote hs-to-number) + (list (quote dom-get-style) el prop)) + amount))) + (list + (quote do) + (list (quote dom-set-style) el prop (quote __hs-new)) + (list (quote set!) (quote it) (quote __hs-new)))))) + ((and (list? expr) (= (first expr) (quote dom-ref))) + (let + ((el (hs-to-sx (nth expr 2))) (name (nth expr 1))) + (list + (quote let) + (list + (list + (quote __hs-new) + (list + (quote -) + (list + (quote hs-to-number) + (list (quote hs-dom-get) el name)) + amount))) + (list + (quote do) + (list (quote hs-dom-set!) el name (quote __hs-new)) + (list (quote set!) (quote it) (quote __hs-new)))))) + ((and (list? expr) (= (first expr) (quote array-index)) (list? (nth expr 1)) (= (first (nth expr 1)) (quote ref))) + (let + ((var-sym (make-symbol (nth (nth expr 1) 1))) + (idx (hs-to-sx (nth expr 2)))) + (list + (quote let) + (list (list (quote __hs-idx) idx)) + (list + (quote let) + (list + (list + (quote __hs-new) + (list + (quote -) + (list + (quote hs-to-number) + (list (quote nth) var-sym (quote __hs-idx))) + amount))) + (list + (quote do) + (list + (quote set!) + var-sym + (list + (quote hs-list-set) + var-sym + (quote __hs-idx) + (quote __hs-new))) + (list (quote set!) (quote it) (quote __hs-new))))))) (true (let ((t (hs-to-sx expr))) - (list (quote set!) t (list (quote -) t amount))))))) + (list + (quote let) + (list + (list + (quote __hs-new) + (list (quote -) (list (quote hs-to-number) t) amount))) + (list + (quote do) + (list (quote set!) t (quote __hs-new)) + (list (quote set!) (quote it) (quote __hs-new))))))))) (define emit-behavior (fn @@ -427,7 +620,7 @@ ((= head (quote null-literal)) nil) ((= head (quote not)) (list (quote not) (hs-to-sx (nth ast 1)))) - ((or (= head (quote starts-with?)) (= head (quote ends-with?)) (= head (quote contains?)) (= head (quote precedes?)) (= head (quote follows?)) (= head (quote exists?))) + ((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 @@ -559,6 +752,37 @@ (hs-to-sx (nth ast 1)) (hs-to-sx (nth ast 2)) (hs-to-sx (nth ast 3)))) + ((= head (quote pick-first)) + (list + (quote hs-pick-first) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote pick-last)) + (list + (quote hs-pick-last) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote pick-random)) + (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 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 regex-match) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) + ((= head (quote pick-matches)) + (list + (quote regex-find-all) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) ((= head (quote prop-is)) (list (quote hs-prop-is) @@ -656,6 +880,11 @@ (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?) @@ -742,6 +971,26 @@ (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?) @@ -922,7 +1171,15 @@ (hs-to-sx tgt) (list (quote hs-remove-from!) val (hs-to-sx tgt))))) ((= head (quote empty-target)) - (list (quote hs-empty-target!) (hs-to-sx (nth ast 1)))) + (let + ((tgt (nth ast 1))) + (if + (and (list? tgt) (= (first tgt) (quote local))) + (list + (quote set!) + (make-symbol (nth tgt 1)) + (list (quote hs-empty-like) (make-symbol (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)) @@ -937,6 +1194,11 @@ (quote do) (emit-set lhs (hs-to-sx rhs)) (emit-set rhs (quote _swap_tmp)))))) + ((= head (quote morph!)) + (list + (quote hs-morph!) + (hs-to-sx (nth ast 1)) + (hs-to-sx (nth ast 2)))) ((= head (quote remove-attr)) (let ((tgt (if (nil? (nth ast 2)) (quote me) (hs-to-sx (nth ast 2))))) @@ -977,6 +1239,23 @@ (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!) @@ -1051,6 +1330,9 @@ (or (= (first c) (quote hs-fetch)) (= (first c) (quote hs-wait)) + (= (first c) (quote hs-wait-for)) + (= (first c) (quote hs-query-first)) + (= (first c) (quote hs-query-all)) (= (first c) (quote perform))))) compiled)) (reduce @@ -1061,7 +1343,7 @@ (list (list (quote it) cmd)) body)) (nth compiled (- (len compiled) 1)) - (reverse (rest (reverse compiled)))) + (rest (reverse compiled))) (cons (quote do) compiled)))) ((= head (quote wait)) (list (quote hs-wait) (nth ast 1))) ((= head (quote wait-for)) (emit-wait-for ast)) @@ -1194,20 +1476,39 @@ ((= head (quote measure)) (list (quote hs-measure) (hs-to-sx (nth ast 1)))) ((= head (quote increment!)) - (emit-inc - (nth ast 1) - (nth ast 2) - (if (> (len ast) 3) (nth ast 3) nil))) + (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!)) - (emit-dec - (nth ast 1) - (nth ast 2) - (if (> (len ast) 3) (nth ast 3) nil))) + (if + (= (len ast) 3) + (emit-dec (nth ast 1) 1 (nth ast 2)) + (emit-dec + (nth ast 1) + (nth ast 2) + (if (> (len ast) 3) (nth ast 3) nil)))) ((= head (quote break)) (list (quote raise) "hs-break")) ((= head (quote continue)) (list (quote raise) "hs-continue")) ((= head (quote exit)) nil) + ((= head (quote live-no-op)) nil) + ((= head (quote when-feat-no-op)) nil) ((= head (quote on)) (emit-on ast)) + ((= head (quote when-changes)) + (let + ((expr (nth ast 1)) (body (nth ast 2))) + (if + (and (list? expr) (= (first expr) (quote dom-ref))) + (list + (quote hs-dom-watch!) + (hs-to-sx (nth expr 2)) + (nth expr 1) + (list (quote fn) (list (quote it)) (hs-to-sx body))) + nil))) ((= head (quote init)) (list (quote hs-init) @@ -1352,7 +1653,14 @@ (quote when) (list (quote nil?) t) (list (quote set!) t v)))) - ((= head (quote halt!)) (list (quote hs-halt!) (nth ast 1))) + ((= 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)))))))) diff --git a/shared/static/wasm/sx/hs-parser.sx b/shared/static/wasm/sx/hs-parser.sx index 4f8fa5af..0bdb84bb 100644 --- a/shared/static/wasm/sx/hs-parser.sx +++ b/shared/static/wasm/sx/hs-parser.sx @@ -180,6 +180,16 @@ ((= typ "style") (do (adv!) (list (quote style) val (list (quote me))))) ((= typ "local") (do (adv!) (list (quote local) val))) + ((= typ "hat") + (do (adv!) (list (quote dom-ref) val (list (quote me))))) + ((and (= typ "keyword") (= val "dom")) + (do + (adv!) + (let + ((name (tp-val))) + (do + (adv!) + (list (quote dom-ref) name (list (quote me))))))) ((= typ "class") (do (adv!) (list (quote query) (str "." val)))) ((= typ "ident") (do (adv!) (list (quote ref) val))) @@ -288,7 +298,7 @@ (adv!) (let ((name val) (args (parse-call-args))) - (list (quote call) (list (quote ref) name) args)))) + (cons (quote call) (cons (list (quote ref) name) args))))) (true nil))))) (define parse-poss @@ -301,7 +311,7 @@ ((= (tp-type) "paren-open") (let ((args (parse-call-args))) - (list (quote call) obj args))) + (cons (quote call) (cons obj args)))) ((= (tp-type) "bracket-open") (do (adv!) @@ -479,20 +489,24 @@ (list (quote type-check-strict) left type-name) (list (quote type-check) left type-name)))))) (true - (if - (and - (= (tp-type) "ident") - (not (hs-keyword? (tp-val)))) - (let - ((prop-name (tp-val))) - (do (adv!) (list (quote prop-is) left prop-name))) - (let - ((right (parse-expr))) + (let + ((right (parse-expr))) + (if + (match-kw "ignoring") + (do + (match-kw "case") + (list (quote eq-ignore-case) left right)) (if - (match-kw "ignoring") - (do - (match-kw "case") - (list (quote eq-ignore-case) left right)) + (and + (list? right) + (= (len right) 2) + (= (first right) (quote ref)) + (string? (nth right 1))) + (list + (quote hs-is) + left + (list (quote fn) (list) right) + (nth right 1)) (list (quote =) left right)))))))) ((and (= typ "keyword") (= val "am")) (do @@ -504,12 +518,34 @@ (list (quote not-in?) left (parse-expr))) ((match-kw "empty") (list (quote not) (list (quote empty?) left))) + ((match-kw "between") + (let + ((lo (parse-atom))) + (match-kw "and") + (let + ((hi (parse-atom))) + (list + (quote not) + (list + (quote and) + (list (quote >=) left lo) + (list (quote <=) left hi)))))) (true (let ((right (parse-expr))) (list (quote not) (list (quote =) left right)))))) ((match-kw "in") (list (quote in?) left (parse-expr))) ((match-kw "empty") (list (quote empty?) left)) + ((match-kw "between") + (let + ((lo (parse-atom))) + (match-kw "and") + (let + ((hi (parse-atom))) + (list + (quote and) + (list (quote >=) left lo) + (list (quote <=) left hi))))) (true (let ((right (parse-expr))) @@ -639,6 +675,14 @@ (list (quote not) (list (quote ends-with?) left (parse-expr))))) + ((or (match-kw "precede") (match-kw "precedes")) + (list + (quote not) + (list (quote precedes?) left (parse-atom)))) + ((or (match-kw "follow") (match-kw "follows")) + (list + (quote not) + (list (quote follows?) left (parse-atom)))) (true left)))) ((and (= typ "keyword") (= val "equals")) (do (adv!) (list (quote =) left (parse-expr)))) @@ -877,7 +921,7 @@ (collect-classes!)))) (collect-classes!) (let - ((tgt (if (match-kw "from") (parse-expr) nil))) + ((tgt (if (match-kw "from") (parse-expr) (list (quote me))))) (if (empty? extra-classes) (list (quote remove-class) cls tgt) @@ -1097,7 +1141,12 @@ ((match-kw "on") (let ((target (parse-expr))) - (list (quote set-on) tgt target))) + (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 @@ -1105,28 +1154,31 @@ () (let ((value (parse-expr))) - (cond - ((match-kw "into") (list (quote set!) (parse-expr) value)) - ((match-kw "before") - (list (quote put!) value "before" (parse-expr))) - ((match-kw "after") - (list (quote put!) value "after" (parse-expr))) - ((match-kw "at") - (do - (match-kw "the") - (cond - ((match-kw "start") - (do - (expect-kw! "of") - (list (quote put!) value "start" (parse-expr)))) - ((match-kw "end") - (do - (expect-kw! "of") - (list (quote put!) value "end" (parse-expr)))) - (true - (error (str "Expected start/end after at, position " p)))))) - (true - (error (str "Expected into/before/after/at at position " p))))))) + (let + ((value (if (and (list? value) (= (first value) (quote dom-ref)) (match-kw "on")) (list (quote dom-ref) (nth value 1) (parse-expr)) value))) + (cond + ((match-kw "into") (list (quote set!) (parse-expr) value)) + ((match-kw "before") + (list (quote put!) value "before" (parse-expr))) + ((match-kw "after") + (list (quote put!) value "after" (parse-expr))) + ((match-kw "at") + (do + (match-kw "the") + (cond + ((match-kw "start") + (do + (expect-kw! "of") + (list (quote put!) value "start" (parse-expr)))) + ((match-kw "end") + (do + (expect-kw! "of") + (list (quote put!) value "end" (parse-expr)))) + (true + (error + (str "Expected start/end after at, position " p)))))) + (true + (error (str "Expected into/before/after/at at position " p)))))))) (define parse-if-cmd (fn @@ -1153,14 +1205,33 @@ (adv!) (let ((source (if (match-kw "from") (parse-expr) nil))) - (if - source - (list (quote wait-for) event-name :from source) - (list (quote wait-for) event-name))))) + (let + ((timeout-dur (if (match-kw "or") (if (= (tp-type) "number") (let ((tok (adv!))) (let ((raw (get tok "value")) (suffix (if (and (= (tp-type) "ident") (or (= (tp-val) "ms") (= (tp-val) "s"))) (get (adv!) "value") ""))) (parse-dur (str raw suffix)))) nil) nil))) + (cond + ((and source timeout-dur) + (list + (quote wait-for) + event-name + :from source + :or timeout-dur)) + (source + (list (quote wait-for) event-name :from source)) + (timeout-dur + (list (quote wait-for) event-name :or timeout-dur)) + (true (list (quote wait-for) event-name))))))) ((= (tp-type) "number") (let ((tok (adv!))) - (list (quote wait) (parse-dur (get tok "value"))))) + (let + ((raw (get tok "value")) + (suffix + (if + (and + (= (tp-type) "ident") + (or (= (tp-val) "ms") (= (tp-val) "s"))) + (get (adv!) "value") + ""))) + (list (quote wait) (parse-dur (str raw suffix)))))) (true (list (quote wait) 0))))) (define parse-detail-dict @@ -1241,10 +1312,13 @@ (let ((expr (parse-expr))) (let - ((amount (if (match-kw "by") (parse-expr) 1))) + ((by-amount (if (match-kw "by") (parse-expr) nil))) (let ((tgt (parse-tgt-kw "on" (list (quote me))))) - (list (quote increment!) expr amount tgt)))))) + (if + by-amount + (list (quote increment!) expr by-amount tgt) + (list (quote increment!) expr tgt))))))) (define parse-dec-cmd (fn @@ -1252,10 +1326,13 @@ (let ((expr (parse-expr))) (let - ((amount (if (match-kw "by") (parse-expr) 1))) + ((by-amount (if (match-kw "by") (parse-expr) nil))) (let ((tgt (parse-tgt-kw "on" (list (quote me))))) - (list (quote decrement!) expr amount tgt)))))) + (if + by-amount + (list (quote decrement!) expr by-amount tgt) + (list (quote decrement!) expr tgt))))))) (define parse-hide-cmd (fn @@ -1279,7 +1356,7 @@ (fn () (let - ((tgt (cond ((and (= (tp-type) "ident") (= (tp-val) "element")) (do (adv!) (parse-atom))) ((= (tp-type) "id") (parse-atom)) ((= (tp-type) "class") (parse-atom)) ((= (tp-type) "selector") (parse-atom)) (true nil)))) + ((tgt (cond ((and (= (tp-type) "ident") (= (tp-val) "element")) (do (adv!) (parse-atom))) ((and (= (tp-type) "keyword") (= (tp-val) "its")) (do (adv!) (list (quote ref) "it"))) ((= (tp-type) "id") (parse-atom)) ((= (tp-type) "class") (parse-atom)) ((= (tp-type) "selector") (parse-atom)) (true nil)))) (define parse-one-transition (fn @@ -1370,11 +1447,13 @@ (fn () (if - (and (= (tp-type) "keyword") (= (tp-val) "gql")) + (and + (or (= (tp-type) "keyword") (= (tp-type) "ident")) + (= (tp-val) "gql")) (do (adv!) (let - ((gql-source (if (= (tp-type) "brace-open") (do (adv!) (define collect-gql (fn (acc depth) (cond ((at-end?) (join " " acc)) ((= (tp-type) "brace-open") (do (adv!) (collect-gql (append acc (list "{")) (+ depth 1)))) ((= (tp-type) "brace-close") (if (= depth 0) (do (adv!) (join " " acc)) (do (adv!) (collect-gql (append acc (list "}")) (- depth 1))))) (true (let ((v (tp-val))) (adv!) (collect-gql (append acc (list (if v v ""))) depth)))))) (str "{ " (collect-gql (list) 0) " }")) (if (or (and (= (tp-type) "keyword") (= (tp-val) "query")) (and (= (tp-type) "keyword") (= (tp-val) "mutation")) (and (= (tp-type) "keyword") (= (tp-val) "subscription"))) (let ((op-word (tp-val))) (adv!) (if (= (tp-type) "brace-open") (do (adv!) (define collect-gql2 (fn (acc depth) (cond ((at-end?) (join " " acc)) ((= (tp-type) "brace-open") (do (adv!) (collect-gql2 (append acc (list "{")) (+ depth 1)))) ((= (tp-type) "brace-close") (if (= depth 0) (do (adv!) (join " " acc)) (do (adv!) (collect-gql2 (append acc (list "}")) (- depth 1))))) (true (let ((v (tp-val))) (adv!) (collect-gql2 (append acc (list (if v v ""))) depth)))))) (str op-word " { " (collect-gql2 (list) 0) " }")) (str op-word ""))) "")))) + ((gql-source (if (= (tp-type) "brace-open") (do (adv!) (define collect-gql (fn (acc depth) (cond ((at-end?) (join " " acc)) ((= (tp-type) "brace-open") (do (adv!) (collect-gql (append acc (list "{")) (+ depth 1)))) ((= (tp-type) "brace-close") (if (= depth 0) (do (adv!) (join " " acc)) (do (adv!) (collect-gql (append acc (list "}")) (- depth 1))))) (true (let ((v (tp-val))) (adv!) (collect-gql (append acc (list (if v v ""))) depth)))))) (str "{ " (collect-gql (list) 0) " }")) (if (or (and (or (= (tp-type) "keyword") (= (tp-type) "ident")) (= (tp-val) "query")) (and (or (= (tp-type) "keyword") (= (tp-type) "ident")) (= (tp-val) "mutation")) (and (or (= (tp-type) "keyword") (= (tp-type) "ident")) (= (tp-val) "subscription"))) (let ((op-word (tp-val))) (adv!) (if (= (tp-type) "brace-open") (do (adv!) (define collect-gql2 (fn (acc depth) (cond ((at-end?) (join " " acc)) ((= (tp-type) "brace-open") (do (adv!) (collect-gql2 (append acc (list "{")) (+ depth 1)))) ((= (tp-type) "brace-close") (if (= depth 0) (do (adv!) (join " " acc)) (do (adv!) (collect-gql2 (append acc (list "}")) (- depth 1))))) (true (let ((v (tp-val))) (adv!) (collect-gql2 (append acc (list (if v v ""))) depth)))))) (str op-word " { " (collect-gql2 (list) 0) " }")) (str op-word ""))) "")))) (let ((url (if (and (= (tp-type) "keyword") (= (tp-val) "from")) (do (adv!) (parse-arith (parse-poss (parse-atom)))) nil))) (list (quote fetch-gql) gql-source url)))) @@ -1383,7 +1462,7 @@ (let ((url (if (nil? url-atom) url-atom (parse-arith (parse-poss url-atom))))) (let - ((fmt-before (if (match-kw "as") (let ((f (tp-val))) (adv!) f) nil))) + ((fmt-before (if (match-kw "as") (do (when (and (or (= (tp-type) "ident") (= (tp-type) "keyword")) (or (= (tp-val) "an") (= (tp-val) "a"))) (adv!)) (let ((f (tp-val))) (adv!) f)) nil))) (when (= (tp-type) "brace-open") (parse-expr)) (when (match-kw "with") @@ -1392,7 +1471,7 @@ (parse-expr) (parse-expr))) (let - ((fmt-after (if (and (not fmt-before) (match-kw "as")) (let ((f (tp-val))) (adv!) f) nil))) + ((fmt-after (if (and (not fmt-before) (match-kw "as")) (do (when (and (or (= (tp-type) "ident") (= (tp-type) "keyword")) (or (= (tp-val) "an") (= (tp-val) "a"))) (adv!)) (let ((f (tp-val))) (adv!) f)) nil))) (let ((fmt (or fmt-before fmt-after "text"))) (list (quote fetch) url fmt))))))))) @@ -1413,18 +1492,8 @@ (if (= (tp-type) "comma") (adv!) nil) (ca-collect (append acc (list arg))))))) (ca-collect (list)))) - (define - parse-call-cmd - (fn - () - (let - ((name (get (adv!) "value"))) - (if - (= (tp-type) "paren-open") - (let - ((args (parse-call-args))) - (cons (quote call) (cons name args))) - (list (quote call) name))))) + (define parse-call-cmd (fn () (parse-expr))) + (define parse-get-cmd (fn () (parse-expr))) (define parse-take-cmd (fn @@ -1458,6 +1527,103 @@ attr-val with-val))))))) (true nil)))) + (define + parse-pick-cmd + (fn + () + (let + ((typ (tp-type)) (val (tp-val))) + (cond + ((and (= typ "keyword") (= val "first")) + (do + (adv!) + (let + ((n (parse-atom))) + (do + (expect-kw! "of") + (let + ((coll (parse-expr))) + (list (quote pick-first) coll n)))))) + ((and (= typ "keyword") (= val "last")) + (do + (adv!) + (let + ((n (parse-atom))) + (do + (expect-kw! "of") + (let + ((coll (parse-expr))) + (list (quote pick-last) coll n)))))) + ((and (= typ "keyword") (= val "random")) + (do + (adv!) + (if + (match-kw "of") + (let + ((coll (parse-expr))) + (list (quote pick-random) coll nil)) + (let + ((n (parse-atom))) + (do + (expect-kw! "of") + (let + ((coll (parse-expr))) + (list (quote pick-random) coll n))))))) + ((and (= typ "ident") (= val "items")) + (do + (adv!) + (let + ((start-expr (parse-atom))) + (do + (expect-kw! "to") + (let + ((end-expr (parse-atom))) + (do + (expect-kw! "of") + (let + ((coll (parse-expr))) + (list (quote pick-items) coll start-expr end-expr)))))))) + ((and (= typ "keyword") (= val "match")) + (do + (adv!) + (expect-kw! "of") + (let + ((regex (parse-expr))) + (do + (cond + ((match-kw "of") nil) + ((match-kw "from") nil) + (true + (error + (str + "Expected of/from after pick match regex at " + p)))) + (let + ((haystack (parse-expr))) + (list (quote pick-match) regex haystack)))))) + ((and (= typ "keyword") (= val "matches")) + (do + (adv!) + (expect-kw! "of") + (let + ((regex (parse-expr))) + (do + (cond + ((match-kw "of") nil) + ((match-kw "from") nil) + (true + (error + (str + "Expected of/from after pick matches regex at " + p)))) + (let + ((haystack (parse-expr))) + (list (quote pick-matches) regex haystack)))))) + (true + (error + (str + "Expected first/last/random/items/match/matches after 'pick' at " + p))))))) (define parse-go-cmd (fn () (match-kw "to") (list (quote go) (parse-expr)))) @@ -1683,7 +1849,7 @@ (fn () (let - ((mode (cond ((match-kw "the") (do (match-kw "event") (match-kw "'s") "event")) ((or (match-kw "default") (and (= (tp-val) "default") (do (adv!) true))) "default") ((or (match-kw "bubbling") (and (= (tp-val) "bubbling") (do (adv!) true))) "bubbling") (true "event")))) + ((mode (cond ((match-kw "the") (do (match-kw "event") (when (and (= (tp-type) "op") (= (tp-val) "'s")) (adv!)) "the-event")) ((or (match-kw "default") (and (= (tp-val) "default") (do (adv!) true))) "default") ((or (match-kw "bubbling") (and (= (tp-val) "bubbling") (do (adv!) true))) "bubbling") (true "all")))) (list (quote halt!) mode)))) (define parse-param-list @@ -1807,7 +1973,7 @@ (fn () (let - ((target (cond ((at-end?) (list (quote sym) "me")) ((and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end"))) (list (quote sym) "me")) (true (parse-expr))))) + ((target (cond ((at-end?) (list (quote ref) "me")) ((and (= (tp-type) "keyword") (or (= (tp-val) "then") (= (tp-val) "end"))) (list (quote ref) "me")) (true (parse-expr))))) (list (quote empty-target) target)))) (define parse-swap-cmd @@ -1817,6 +1983,16 @@ ((lhs (parse-expr))) (match-kw "with") (let ((rhs (parse-expr))) (list (quote swap!) lhs rhs))))) + (define + parse-morph-cmd + (fn + () + (let + ((target (parse-expr))) + (expect-kw! "to") + (let + ((content (parse-expr))) + (list (quote morph!) target content))))) (define parse-open-cmd (fn @@ -1874,10 +2050,14 @@ (do (adv!) (parse-repeat-cmd))) ((and (= typ "keyword") (= val "fetch")) (do (adv!) (parse-fetch-cmd))) + ((and (= typ "keyword") (= val "get")) + (do (adv!) (parse-get-cmd))) ((and (= typ "keyword") (= val "call")) (do (adv!) (parse-call-cmd))) ((and (= typ "keyword") (= val "take")) (do (adv!) (parse-take-cmd))) + ((and (= typ "keyword") (= val "pick")) + (do (adv!) (parse-pick-cmd))) ((and (= typ "keyword") (= val "settle")) (do (adv!) (list (quote settle)))) ((and (= typ "keyword") (= val "go")) @@ -1918,6 +2098,8 @@ (do (adv!) (parse-empty-cmd))) ((and (= typ "keyword") (= val "swap")) (do (adv!) (parse-swap-cmd))) + ((and (= typ "keyword") (= val "morph")) + (do (adv!) (parse-morph-cmd))) ((and (= typ "keyword") (= val "open")) (do (adv!) (parse-open-cmd))) ((and (= typ "keyword") (= val "close")) @@ -1955,6 +2137,7 @@ (= v "transition") (= v "repeat") (= v "fetch") + (= v "get") (= v "call") (= v "take") (= v "settle") @@ -1977,8 +2160,10 @@ (= v "empty") (= v "clear") (= v "swap") + (= v "morph") (= v "open") - (= v "close")))) + (= v "close") + (= v "pick")))) (define cl-collect (fn @@ -2047,6 +2232,53 @@ ((body (parse-cmd-list))) (match-kw "end") (list (quote init) body)))) + (define + parse-live-feat + (fn + () + (define + plf-skip + (fn + () + (cond + ((at-end?) nil) + ((and (= (tp-type) "keyword") (or (= (tp-val) "end") (= (tp-val) "on") (= (tp-val) "init") (= (tp-val) "def") (= (tp-val) "behavior") (= (tp-val) "live") (= (tp-val) "when"))) + nil) + (true (do (adv!) (plf-skip)))))) + (plf-skip) + (match-kw "end") + (list (quote live-no-op)))) + (define + parse-when-feat + (fn + () + (define + pwf-skip + (fn + () + (cond + ((at-end?) nil) + ((and (= (tp-type) "keyword") (or (= (tp-val) "end") (= (tp-val) "on") (= (tp-val) "init") (= (tp-val) "def") (= (tp-val) "behavior") (= (tp-val) "live") (= (tp-val) "when"))) + nil) + (true (do (adv!) (pwf-skip)))))) + (if + (or + (= (tp-type) "hat") + (and (= (tp-type) "keyword") (= (tp-val) "dom"))) + (let + ((expr (parse-expr))) + (if + (match-kw "changes") + (let + ((body (parse-cmd-list))) + (do + (match-kw "end") + (list (quote when-changes) expr body))) + (do + (pwf-skip) + (match-kw "end") + (list (quote when-feat-no-op))))) + (do (pwf-skip) (match-kw "end") (list (quote when-feat-no-op)))))) (define parse-feat (fn @@ -2058,6 +2290,8 @@ ((= val "init") (do (adv!) (parse-init-feat))) ((= val "def") (do (adv!) (parse-def-feat))) ((= val "behavior") (do (adv!) (parse-behavior-feat))) + ((= val "live") (do (adv!) (parse-live-feat))) + ((= val "when") (do (adv!) (parse-when-feat))) (true (parse-cmd-list)))))) (define coll-feats diff --git a/shared/static/wasm/sx/hs-tokenizer.sx b/shared/static/wasm/sx/hs-tokenizer.sx index 2f7707d7..f846e34d 100644 --- a/shared/static/wasm/sx/hs-tokenizer.sx +++ b/shared/static/wasm/sx/hs-tokenizer.sx @@ -117,6 +117,7 @@ "first" "last" "random" + "pick" "empty" "clear" "swap" @@ -173,11 +174,17 @@ "default" "halt" "precedes" + "precede" + "follow" "follows" "ignoring" "case" + "changes" "focus" - "blur")) + "blur" + "dom" + "morph" + "using")) (define hs-keyword? (fn (word) (some (fn (k) (= k word)) hs-keywords))) @@ -472,6 +479,14 @@ (hs-advance! 1) (hs-emit! "attr" (read-ident pos) start) (scan!)) + (and + (= ch "^") + (< (+ pos 1) src-len) + (hs-ident-char? (hs-peek 1))) + (do + (hs-advance! 1) + (hs-emit! "hat" (read-ident pos) start) + (scan!)) (and (= ch "~") (< (+ pos 1) src-len) diff --git a/spec/tests/test-hyperscript-behavioral.sx b/spec/tests/test-hyperscript-behavioral.sx index 284fe941..05dbe9ec 100644 --- a/spec/tests/test-hyperscript-behavioral.sx +++ b/spec/tests/test-hyperscript-behavioral.sx @@ -23,7 +23,14 @@ (let ((sx (hs-to-sx (hs-compile src)))) (let ((handler (eval-expr-cek (list (quote fn) (list (quote me)) (list (quote let) (list (list (quote it) nil) (list (quote event) nil)) sx))))) - (handler nil))))) + (guard + (_e + (true + (if + (and (list? _e) (= (first _e) "hs-return")) + (nth _e 1) + (raise _e)))) + (handler nil)))))) ;; Evaluate with a specific me value (for "I am between" etc.) (define eval-hs-with-me @@ -31,7 +38,14 @@ (let ((sx (hs-to-sx (hs-compile src)))) (let ((handler (eval-expr-cek (list (quote fn) (list (quote me)) (list (quote let) (list (list (quote it) nil) (list (quote event) nil)) sx))))) - (handler me-val))))) + (guard + (_e + (true + (if + (and (list? _e) (= (first _e) "hs-return")) + (nth _e 1) + (raise _e)))) + (handler me-val)))))) ;; ── add (19 tests) ── (defsuite "hs-upstream-add" @@ -235,6 +249,7 @@ (dom-set-attr _el-d1 "id" "d1") (dom-add-class _el-d1 "item") (dom-set-attr _el-none "id" "none") + (dom-set-attr _el-none "hidden" "") (dom-append (dom-body) _el-trigger) (dom-append (dom-body) _el-d1) (dom-append (dom-body) _el-none) @@ -365,7 +380,7 @@ (dom-append _el-d1 _el-p) (dom-append _el-div _el-p3) (hs-activate! _el-d1) - (dom-dispatch _el-d1 "click" nil) + (dom-dispatch _el-div "click" nil) ;; SKIP check: skip div.innerHTML.includes("foo").should.equal(true) ;; SKIP check: skip div.innerHTML.includes("bar").should.equal(true) ;; SKIP check: skip div.innerHTML.includes("doh").should.equal(true) @@ -797,8 +812,8 @@ (dom-append (dom-body) _el-div) (dom-append _el-div _el-d1) (hs-activate! _el-div) - (dom-dispatch _el-d1 "click" nil) - (assert= (dom-inner-html _el-d1) "foo") + (dom-dispatch _el-div "click" nil) + (assert= (dom-inner-html _el-div) "foo") )) (deftest "can set complex indirect properties rhs" (hs-cleanup!) @@ -808,8 +823,8 @@ (dom-append (dom-body) _el-div) (dom-append _el-div _el-d1) (hs-activate! _el-div) - (dom-dispatch _el-d1 "click" nil) - (assert= (dom-inner-html _el-d1) "foo") + (dom-dispatch _el-div "click" nil) + (assert= (dom-inner-html _el-div) "foo") )) (deftest "can set chained indirect properties" (hs-cleanup!) @@ -819,8 +834,8 @@ (dom-append (dom-body) _el-div) (dom-append _el-div _el-d1) (hs-activate! _el-div) - (dom-dispatch _el-d1 "click" nil) - (assert= (dom-inner-html _el-d1) "foo") + (dom-dispatch _el-div "click" nil) + (assert= (dom-inner-html _el-div) "foo") )) (deftest "can set styles" (hs-cleanup!) @@ -1358,8 +1373,8 @@ (dom-append (dom-body) _el-div) (hs-activate! _el-div) (dom-dispatch _el-div "click" nil) - (dom-dispatch _el-div "click" nil) - (assert= (dom-inner-html _el-div) "42") + (dom-dispatch (dom-query "button") "click" nil) + (assert= (dom-inner-html (dom-query "button")) "42") )) (deftest "properly processes hyperscript in new content in a element target" (hs-cleanup!) @@ -1369,8 +1384,8 @@ (dom-append (dom-body) _el-d1) (hs-activate! _el-d1) (dom-dispatch _el-d1 "click" nil) - (dom-dispatch _el-d1 "click" nil) - (assert= (dom-inner-html _el-d1) "42") + (dom-dispatch (dom-query "button") "click" nil) + (assert= (dom-inner-html (dom-query "button")) "42") )) (deftest "properly processes hyperscript in before" (hs-cleanup!) @@ -1380,8 +1395,8 @@ (dom-append (dom-body) _el-d1) (hs-activate! _el-d1) (dom-dispatch _el-d1 "click" nil) - (dom-dispatch _el-d1 "click" nil) - (assert= (dom-inner-html _el-d1) "42") + (dom-dispatch (dom-query "button") "click" nil) + (assert= (dom-inner-html (dom-query "button")) "42") )) (deftest "properly processes hyperscript at start of" (hs-cleanup!) @@ -1391,8 +1406,8 @@ (dom-append (dom-body) _el-d1) (hs-activate! _el-d1) (dom-dispatch _el-d1 "click" nil) - (dom-dispatch _el-d1 "click" nil) - (assert= (dom-inner-html _el-d1) "42") + (dom-dispatch (dom-query "button") "click" nil) + (assert= (dom-inner-html (dom-query "button")) "42") )) (deftest "properly processes hyperscript at end of" (hs-cleanup!) @@ -1402,8 +1417,8 @@ (dom-append (dom-body) _el-d1) (hs-activate! _el-d1) (dom-dispatch _el-d1 "click" nil) - (dom-dispatch _el-d1 "click" nil) - (assert= (dom-inner-html _el-d1) "42") + (dom-dispatch (dom-query "button") "click" nil) + (assert= (dom-inner-html (dom-query "button")) "42") )) (deftest "properly processes hyperscript after" (hs-cleanup!) @@ -1413,8 +1428,8 @@ (dom-append (dom-body) _el-d1) (hs-activate! _el-d1) (dom-dispatch _el-d1 "click" nil) - (dom-dispatch _el-d1 "click" nil) - (assert= (dom-inner-html _el-d1) "42") + (dom-dispatch (dom-query "button") "click" nil) + (assert= (dom-inner-html (dom-query "button")) "42") )) (deftest "is null tolerant" (hs-cleanup!) @@ -2324,7 +2339,7 @@ (dom-append _el-div _el-d3) (hs-activate! _el-div) (dom-dispatch _el-d2 "click" nil) - (assert (not (dom-has-class? _el-d1 "foo"))) + (assert (not (dom-has-class? _el-div "foo"))) (assert (dom-has-class? _el-d2 "foo")) (assert (not (dom-has-class? _el-d3 "foo"))) )) @@ -2441,7 +2456,7 @@ (dom-append _el-div _el-d3) (hs-activate! _el-div) (dom-dispatch _el-d2 "click" nil) - (assert= (dom-get-attr _el-d1 "data-foo") "bar") + (assert= (dom-get-attr _el-div "data-foo") "bar") (assert= (dom-get-attr _el-d2 "data-foo") "") ;; SKIP check: skip assert.isNull(d2.getAttribute("data-foo") ;; SKIP check: skip assert.isNull(d3.getAttribute("data-foo") @@ -3300,7 +3315,7 @@ (dom-append (dom-body) _el-div) (hs-activate! _el-div) (dom-dispatch _el-div "click" nil) - (assert (dom-has-class? _el-div "topping")) + (assert (dom-has-class? (dom-query "span") "topping")) )) (deftest "can append a value to a set" (hs-cleanup!) @@ -4227,6 +4242,7 @@ (hs-cleanup!) (let ((_el-d (dom-create-element "details")) (_el-summary (dom-create-element "summary")) (_el-p (dom-create-element "p")) (_el-button (dom-create-element "button"))) (dom-set-attr _el-d "id" "d") + (dom-set-attr _el-d "open" "") (dom-set-inner-html _el-summary "More") (dom-set-inner-html _el-p "Content") (dom-set-attr _el-button "_" "on click close #d") @@ -4386,6 +4402,7 @@ (let ((_el-cb1 (dom-create-element "input")) (_el-button (dom-create-element "button"))) (dom-set-attr _el-cb1 "id" "cb1") (dom-set-attr _el-cb1 "type" "checkbox") + (dom-set-attr _el-cb1 "checked" "") (dom-set-attr _el-button "_" "on click empty #cb1") (dom-set-inner-html _el-button "Empty") (dom-append (dom-body) _el-cb1) @@ -4401,6 +4418,7 @@ (dom-set-attr _el-option "value" "a") (dom-set-inner-html _el-option "A") (dom-set-attr _el-option2 "value" "b") + (dom-set-attr _el-option2 "selected" "") (dom-set-inner-html _el-option2 "B") (dom-set-attr _el-button "_" "on click empty #sel1") (dom-set-inner-html _el-button "Empty") @@ -4422,6 +4440,7 @@ (dom-set-inner-html _el-ta2 "text") (dom-set-attr _el-cb2 "id" "cb2") (dom-set-attr _el-cb2 "type" "checkbox") + (dom-set-attr _el-cb2 "checked" "") (dom-set-attr _el-button "_" "on click empty #f1") (dom-set-inner-html _el-button "Empty") (dom-append (dom-body) _el-f1) @@ -4649,10 +4668,11 @@ (let ((_el-target (dom-create-element "div")) (_el-button (dom-create-element "button"))) (dom-set-attr _el-target "id" "target") (dom-set-inner-html _el-target "old") - ;; HS source has bare quotes or embedded HTML + (dom-set-attr _el-button "_" "on click morph #target to \"
new
\"") (dom-set-inner-html _el-button "go") (dom-append (dom-body) _el-target) (dom-append (dom-body) _el-button) + (hs-activate! _el-button) (dom-dispatch _el-button "click" nil) (assert= (dom-text-content (dom-query-by-id "target")) "new") )) @@ -4662,10 +4682,11 @@ (dom-set-attr _el-target "id" "target") (dom-set-inner-html _el-target "old") (dom-set-attr _el-go "id" "go") - ;; HS source has bare quotes or embedded HTML + (dom-set-attr _el-go "_" "on click morph #target to \"
new
\"") (dom-set-inner-html _el-go "go") (dom-append (dom-body) _el-target) (dom-append (dom-body) _el-go) + (hs-activate! _el-go) (dom-dispatch (dom-query-by-id "go") "click" nil) (assert= (dom-text-content (dom-query-by-id "target")) "new") )) @@ -4675,10 +4696,11 @@ (dom-set-attr _el-target "id" "target") (dom-add-class _el-target "old") (dom-set-inner-html _el-target "content") - ;; HS source has bare quotes or embedded HTML + (dom-set-attr _el-button "_" "on click morph #target to \"
content
\"") (dom-set-inner-html _el-button "go") (dom-append (dom-body) _el-target) (dom-append (dom-body) _el-button) + (hs-activate! _el-button) (dom-dispatch _el-button "click" nil) (assert (dom-has-class? (dom-query-by-id "target") "new")) )) @@ -4736,12 +4758,13 @@ (dom-set-attr _el-child "id" "child") (dom-set-attr _el-child "_" "on click put \"alive\" into me") (dom-set-inner-html _el-child "child") - ;; HS source has bare quotes or embedded HTML + (dom-set-attr _el-button "_" "on click morph #target to \"

replaced

\"") (dom-set-inner-html _el-button "go") (dom-append (dom-body) _el-target) (dom-append _el-target _el-child) (dom-append (dom-body) _el-button) (hs-activate! _el-child) + (hs-activate! _el-button) (dom-dispatch _el-button "click" nil) )) (deftest "morph reorders children by id" @@ -4752,12 +4775,13 @@ (dom-set-inner-html _el-a "A") (dom-set-attr _el-b "id" "b") (dom-set-inner-html _el-b "B") - ;; HS source has bare quotes or embedded HTML + (dom-set-attr _el-button "_" "on click morph #target to \"
B2
A2
\"") (dom-set-inner-html _el-button "go") (dom-append (dom-body) _el-target) (dom-append _el-target _el-a) (dom-append _el-target _el-b) (dom-append (dom-body) _el-button) + (hs-activate! _el-button) (dom-dispatch _el-button "click" nil) )) (deftest "morph preserves matched child identity" @@ -4767,11 +4791,12 @@ (dom-set-attr _el-child "id" "child") (dom-set-inner-html _el-child "old") (dom-set-attr _el-go "id" "go") - ;; HS source has bare quotes or embedded HTML + (dom-set-attr _el-go "_" "on click morph #target to \"
new
\"") (dom-set-inner-html _el-go "go") (dom-append (dom-body) _el-target) (dom-append _el-target _el-child) (dom-append (dom-body) _el-go) + (hs-activate! _el-go) (dom-dispatch (dom-query-by-id "go") "click" nil) )) (deftest "morph with variable content" @@ -4856,6 +4881,7 @@ (let ((_el-cb1 (dom-create-element "input")) (_el-button (dom-create-element "button"))) (dom-set-attr _el-cb1 "id" "cb1") (dom-set-attr _el-cb1 "type" "checkbox") + (dom-set-attr _el-cb1 "checked" "") (dom-set-attr _el-button "_" "on click reset #cb1") (dom-set-inner-html _el-button "Reset") (dom-append (dom-body) _el-cb1) @@ -4906,6 +4932,7 @@ (dom-set-attr _el-option "value" "a") (dom-set-inner-html _el-option "A") (dom-set-attr _el-option2 "value" "b") + (dom-set-attr _el-option2 "selected" "") (dom-set-inner-html _el-option2 "B") (dom-set-attr _el-option3 "value" "c") (dom-set-inner-html _el-option3 "C") @@ -5633,6 +5660,7 @@ (dom-set-attr _el-input "type" "radio") (dom-set-attr _el-input "name" "color") (dom-set-attr _el-input "value" "red") + (dom-set-attr _el-input "checked" "") (dom-set-attr _el-input1 "_" "bind $color to me") (dom-set-attr _el-input1 "type" "radio") (dom-set-attr _el-input1 "name" "color") @@ -6891,10 +6919,11 @@ (let ((_el-target (dom-create-element "div")) (_el-button (dom-create-element "button"))) (dom-set-attr _el-target "id" "target") (dom-set-inner-html _el-target "old") - ;; HS source has bare quotes or embedded HTML + (dom-set-attr _el-button "_" "on click set #target to \"new\"") (dom-set-inner-html _el-button "go") (dom-append (dom-body) _el-target) (dom-append (dom-body) _el-button) + (hs-activate! _el-button) (dom-dispatch _el-button "click" nil) (assert= (dom-text-content (dom-query-by-id "target")) "new") )) @@ -6920,13 +6949,14 @@ (dom-set-inner-html _el-li2 "b") (dom-add-class _el-li3 "item") (dom-set-inner-html _el-li3 "c") - ;; HS source has bare quotes or embedded HTML + (dom-set-attr _el-button "_" "on click set .item to \"
  • replaced
    • \"") (dom-set-inner-html _el-button "go") (dom-append (dom-body) _el-list) (dom-append _el-list _el-li) (dom-append _el-list _el-li2) (dom-append _el-list _el-li3) (dom-append (dom-body) _el-button) + (hs-activate! _el-button) (dom-dispatch _el-button "click" nil) )) (deftest "set replaces all matching elements" @@ -6935,22 +6965,24 @@ (dom-set-attr _el-box "id" "box") (dom-set-inner-html _el-p "one") (dom-set-inner-html _el-p2 "two") - ;; HS source has bare quotes or embedded HTML + (dom-set-attr _el-button "_" "on click set

    in #box to \"

    done

    \"") (dom-set-inner-html _el-button "go") (dom-append (dom-body) _el-box) (dom-append _el-box _el-p) (dom-append _el-box _el-p2) (dom-append (dom-body) _el-button) + (hs-activate! _el-button) (dom-dispatch _el-button "click" nil) )) (deftest "set closest replaces ancestor" (hs-cleanup!) (let ((_el-div (dom-create-element "div")) (_el-button (dom-create-element "button"))) (dom-add-class _el-div "wrapper") - ;; HS source has bare quotes or embedded HTML + (dom-set-attr _el-button "_" "on click set (closest
    ) to \"
    replaced
    \"") (dom-set-inner-html _el-button "go") (dom-append (dom-body) _el-div) (dom-append _el-div _el-button) + (hs-activate! _el-button) (dom-dispatch _el-button "click" nil) (assert= (dom-text-content (dom-query ".wrapper")) "replaced") )) @@ -7195,10 +7227,12 @@ (let ((_el-table (dom-create-element "table")) (_el-tr (dom-create-element "tr")) (_el-td (dom-create-element "td")) (_el-input (dom-create-element "input")) (_el-tr4 (dom-create-element "tr")) (_el-td5 (dom-create-element "td")) (_el-input6 (dom-create-element "input")) (_el-tr7 (dom-create-element "tr")) (_el-td8 (dom-create-element "td")) (_el-input9 (dom-create-element "input")) (_el-tr10 (dom-create-element "tr")) (_el-td11 (dom-create-element "td")) (_el-master (dom-create-element "input"))) (dom-add-class _el-input "cb") (dom-set-attr _el-input "type" "checkbox") + (dom-set-attr _el-input "checked" "") (dom-add-class _el-input6 "cb") (dom-set-attr _el-input6 "type" "checkbox") (dom-add-class _el-input9 "cb") (dom-set-attr _el-input9 "type" "checkbox") + (dom-set-attr _el-input9 "checked" "") (dom-set-attr _el-master "id" "master") (dom-set-attr _el-master "_" "set :checkboxes to in the closest where it is not me then on change set checked of the :checkboxes to my checked") (dom-set-attr _el-master "type" "checkbox") @@ -7223,10 +7257,12 @@ (let ((_el-table (dom-create-element "table")) (_el-tr (dom-create-element "tr")) (_el-td (dom-create-element "td")) (_el-input (dom-create-element "input")) (_el-tr4 (dom-create-element "tr")) (_el-td5 (dom-create-element "td")) (_el-input6 (dom-create-element "input")) (_el-tr7 (dom-create-element "tr")) (_el-td8 (dom-create-element "td")) (_el-input9 (dom-create-element "input")) (_el-tr10 (dom-create-element "tr")) (_el-td11 (dom-create-element "td")) (_el-master (dom-create-element "input"))) (dom-add-class _el-input "cb") (dom-set-attr _el-input "type" "checkbox") + (dom-set-attr _el-input "checked" "") (dom-add-class _el-input6 "cb") (dom-set-attr _el-input6 "type" "checkbox") (dom-add-class _el-input9 "cb") (dom-set-attr _el-input9 "type" "checkbox") + (dom-set-attr _el-input9 "checked" "") (dom-set-attr _el-master "id" "master") (dom-set-attr _el-master "_" "set :checkboxes to in the closest
    where it is not me then on change set checked of the :checkboxes to my checked then on change from the closest
    then if no :checkboxes where it is checked then set my indeterminate to false then set my checked to false then else if no :checkboxes where it is not checked then set my indeterminate to false then set my checked to true then else then set my indeterminate to true then end") (dom-set-attr _el-master "type" "checkbox") @@ -8292,6 +8328,7 @@ (hs-cleanup!) (let ((_el-b1 (dom-create-element "button")) (_el-b2 (dom-create-element "button"))) (dom-set-attr _el-b1 "id" "b1") + (dom-set-attr _el-b1 "disabled" "") (dom-set-inner-html _el-b1 "Disabled") (dom-set-attr _el-b2 "id" "b2") (dom-set-inner-html _el-b2 "Enabled") diff --git a/spec/tests/test-hyperscript-compiler.sx b/spec/tests/test-hyperscript-compiler.sx index 6a00989b..05c300f7 100644 --- a/spec/tests/test-hyperscript-compiler.sx +++ b/spec/tests/test-hyperscript-compiler.sx @@ -16,9 +16,9 @@ "remove class from target" (let ((sx (hs-to-sx-from-source "remove .old from #box"))) - (assert= (quote dom-remove-class) (first sx)) - (assert= (quote dom-query) (first (nth sx 1))) - (assert= "old" (nth sx 2)))) + (assert= (quote for-each) (first sx)) + (assert= (quote hs-query-all) (first (nth sx 2))) + (assert= "#box" (nth (nth sx 2) 1)))) (deftest "toggle class" (let @@ -84,7 +84,7 @@ "for becomes for-each" (let ((sx (hs-to-sx-from-source "for item in items log item end"))) - (assert= (quote for-each) (first sx)) + (assert= (quote hs-for-each) (first sx)) (assert= (quote fn) (first (nth sx 1))))) (deftest "tell rebinds me" @@ -100,17 +100,16 @@ "hide sets display none" (let ((sx (hs-to-sx-from-source "hide"))) - (assert= (quote dom-set-style) (first sx)) + (assert= (quote hs-hide!) (first sx)) (assert= (quote me) (nth sx 1)) - (assert= "display" (nth sx 2)) - (assert= "none" (nth sx 3)))) + (assert= "display" (nth sx 2)))) (deftest "show clears display" (let ((sx (hs-to-sx-from-source "show"))) - (assert= (quote dom-set-style) (first sx)) + (assert= (quote hs-show!) (first sx)) (assert= (quote me) (nth sx 1)) - (assert= "" (nth sx 3)))) + (assert= "display" (nth sx 2)))) (deftest "log passes through" (let @@ -121,7 +120,9 @@ "append becomes dom-append" (let ((sx (hs-to-sx-from-source "append 'text' to me"))) - (assert= (quote dom-append) (first sx))))) + (assert= (quote set!) (first sx)) + (assert= (quote hs-append) (first (nth sx 2))) + (assert= "text" (nth (nth sx 2) 2))))) ;; ── Expressions ─────────────────────────────────────────────── (defsuite @@ -138,7 +139,7 @@ "query emits dom-query" (let ((sx (hs-to-sx (list (quote query) ".foo")))) - (assert= (quote dom-query) (first sx)) + (assert= (quote hs-query-first) (first sx)) (assert= ".foo" (nth sx 1)))) (deftest "attr emits dom-get-attr" @@ -176,7 +177,7 @@ (let ((sx (hs-to-sx-from-source "on click from #btn add .clicked end"))) (assert= (quote hs-on) (first sx)) - (assert= (quote dom-query) (first (nth sx 1))))) + (assert= (quote hs-query-first) (first (nth sx 1))))) (deftest "on every click" (let @@ -254,7 +255,10 @@ "hs-emit-return-throw" (deftest "return unwraps to value" - (let ((sx (hs-to-sx-from-source "return 42"))) (assert= 42 sx))) + (let + ((sx (hs-to-sx-from-source "return 42"))) + (assert= (quote raise) (first sx)) + (assert= 42 (nth (nth sx 1) 2)))) (deftest "throw becomes raise" (let @@ -306,11 +310,11 @@ (assert= (quote hs-on) (first sx)) (assert= "click" (nth sx 2)) (let - ((body (nth (nth sx 3) 2))) - (assert= (quote do) (first body)) - (assert= 3 (len (rest body))) - (assert= (quote hs-wait) (first (nth body 2))) - (assert= 1000 (nth (nth body 2) 1))))) + ((body (nth (nth sx 3) 2)) (inner (nth (nth (nth sx 3) 2) 2))) + (assert= (quote let) (first body)) + (assert= (quote let) (first inner)) + (assert= (quote hs-wait) (first (nth (first (nth inner 1)) 1))) + (assert= 1000 (nth (nth (first (nth inner 1)) 1) 1))))) (deftest "count clicks: then chains increment and set in same handler" (let @@ -330,16 +334,16 @@ ((sx (hs-to-sx-from-source "on click add .bounce to me then wait 1s then remove .bounce from me"))) (assert= (quote hs-on) (first sx)) (let - ((body (nth (nth sx 3) 2))) - (assert= (quote do) (first body)) - (assert= 3 (len (rest body))) - (assert= (quote hs-wait) (first (nth body 2))) - (assert= 1000 (nth (nth body 2) 1))))) + ((inner (nth (nth (nth sx 3) 2) 2))) + (assert= (quote let) (first inner)) + (assert= (quote hs-wait) (first (nth (first (nth inner 1)) 1))) + (assert= 1000 (nth (nth (first (nth inner 1)) 1) 1))))) (deftest "wait preserves ms value in handler" (let ((sx (hs-to-sx-from-source "on click add .a then wait 2s then add .b"))) (let - ((body (nth (nth sx 3) 2))) - (assert= (quote hs-wait) (first (nth body 2))) - (assert= 2000 (nth (nth body 2) 1)))))) \ No newline at end of file + ((inner (nth (nth (nth sx 3) 2) 2))) + (assert= (quote let) (first inner)) + (assert= (quote hs-wait) (first (nth (first (nth inner 1)) 1))) + (assert= 2000 (nth (nth (first (nth inner 1)) 1) 1)))))) \ No newline at end of file diff --git a/spec/tests/test-hyperscript-runtime.sx b/spec/tests/test-hyperscript-runtime.sx index d1f0d4aa..cd739e10 100644 --- a/spec/tests/test-hyperscript-runtime.sx +++ b/spec/tests/test-hyperscript-runtime.sx @@ -118,7 +118,7 @@ (let ((sx (hs-to-sx-from-source "fetch '/api'"))) (assert= (quote hs-fetch) (first sx)) - (assert= "json" (nth sx 2)))) + (assert= "text" (nth sx 2)))) (deftest "source → SX shape: def function" (let diff --git a/tests/playwright/generate-sx-tests.py b/tests/playwright/generate-sx-tests.py index 81f1b601..15d7daf9 100644 --- a/tests/playwright/generate-sx-tests.py +++ b/tests/playwright/generate-sx-tests.py @@ -227,12 +227,15 @@ def parse_html(html): 'attrs': {}, 'inner': '', 'depth': len(stack), 'children': [], 'parent_idx': None } + BOOL_ATTRS = {'checked', 'selected', 'disabled', 'multiple', + 'required', 'readonly', 'autofocus', 'hidden', 'open'} for name, val in attrs: if name == 'id': el['id'] = val elif name == 'class': el['classes'] = (val or '').split() elif name == '_': el['hs'] = val elif name == 'style': el['attrs']['style'] = val or '' elif val is not None: el['attrs'][name] = val + elif name in BOOL_ATTRS: el['attrs'][name] = '' # Track parent-child relationship if stack: parent = stack[-1] @@ -483,7 +486,23 @@ def make_ref_fn(elements, var_names, action_str=''): # most likely refers to an *other* element (often the ID'd one). action_uses_alias = any(n not in tags for n in action_vars) + # Build var→element lookup for depth checks + var_to_el = {var_names[i]: elements[i] for i in range(len(var_names))} + def ref(name): + # Special case for `d1`, `d2`, ... (upstream convention `var d1 = make(HTML)` + # binds to the outermost wrapper). If the HTML also has an element with + # id='d1' *nested inside* the wrapper, the JS variable shadows it — so + # `d1.click()` / `d1.innerHTML` in the check refer to the wrapper, not + # the nested element. Prefer the top-level positional element here. + pos_match = re.match(r'^d(\d+)$', name) + if pos_match and name in id_to_var: + id_el = var_to_el.get(id_to_var[name]) + if id_el is not None and id_el.get('depth', 0) > 0: + idx = int(pos_match.group(1)) - 1 + if 0 <= idx < len(top_level_vars): + return top_level_vars[idx] + # Exact ID match first if name in id_to_var: return id_to_var[name] @@ -499,8 +518,13 @@ def make_ref_fn(elements, var_names, action_str=''): return tag_to_id[name] if name in tag_to_unnamed: return tag_to_unnamed[name] - # Fallback: first element of that tag (even if named) - return tag_to_all.get(name, [first_var])[0] + if name in tag_to_all and tag_to_all[name]: + # Static element of that tag exists — use it + return tag_to_all[name][0] + # No static element of this tag: it must be dynamically inserted + # by the hyperscript (e.g. `button` after the handler creates one). + # Query the DOM at action/check time with a tag selector. + return f'(dom-query "{name}")' # Tag + number: div1→1st div, div2→2nd div, form1→1st form, etc. m = re.match(r'^([a-z]+)(\d+)$', name) @@ -791,8 +815,6 @@ def emit_element_setup(lines, elements, var_names, root='(dom-body)', indent=' hs_val = process_hs_val(el['hs']) if not hs_val: pass # no HS to set - elif hs_val.startswith('"') or (hs_val.endswith('"') and '<' in hs_val): - lines.append(f'{indent};; HS source has bare quotes or embedded HTML') else: hs_escaped = hs_val.replace('\\', '\\\\').replace('"', '\\"') lines.append(f'{indent}(dom-set-attr {var} "_" "{hs_escaped}")') @@ -1416,7 +1438,14 @@ output.append(' (fn (src)') output.append(' (let ((sx (hs-to-sx (hs-compile src))))') output.append(' (let ((handler (eval-expr-cek') output.append(' (list (quote fn) (list (quote me)) (list (quote let) (list (list (quote it) nil) (list (quote event) nil)) sx)))))') -output.append(' (handler nil)))))') +output.append(' (guard') +output.append(' (_e') +output.append(' (true') +output.append(' (if') +output.append(' (and (list? _e) (= (first _e) "hs-return"))') +output.append(' (nth _e 1)') +output.append(' (raise _e))))') +output.append(' (handler nil))))))') output.append('') output.append(';; Evaluate with a specific me value (for "I am between" etc.)') output.append('(define eval-hs-with-me') @@ -1424,7 +1453,14 @@ output.append(' (fn (src me-val)') output.append(' (let ((sx (hs-to-sx (hs-compile src))))') output.append(' (let ((handler (eval-expr-cek') output.append(' (list (quote fn) (list (quote me)) (list (quote let) (list (list (quote it) nil) (list (quote event) nil)) sx)))))') -output.append(' (handler me-val)))))') +output.append(' (guard') +output.append(' (_e') +output.append(' (true') +output.append(' (if') +output.append(' (and (list? _e) (= (first _e) "hs-return"))') +output.append(' (nth _e 1)') +output.append(' (raise _e))))') +output.append(' (handler me-val))))))') output.append('') # Group by category