coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions 7 Packages Projects Releases Wiki Activity

HS: fix empty/halt/morph/reset/dialog — 17 upstream tests pass

Browse Source 
- parser `empty` no-target → (ref "me") (was bogus (sym "me"))
- parser `halt` modes distinguish: "all"/"bubbling"/"default" halt execution
  (raise hs-return), "the-event"/"the event's" only stop propagation/default.
  "'s" now matched as op token, not keyword.
- parser `get` cmd: dispatch + cmd-kw list + parse-get-cmd (parses expr with
  optional `as TYPE`). Required for `get result as JSON` in fetch chains.
- compiler empty-target for (local X): emit (set! X (hs-empty-like X)) so
  arrays/sets/maps clear the variable, not call DOM empty on the value.
- runtime hs-empty-like: container-of-same-type empty value.
- runtime hs-empty-target!: drop dead FORM branch that was short-circuiting
  to innerHTML=""; the querySelectorAll-over-inputs branch now runs.
- runtime hs-halt!: take ev param (was free `event` lookup); raise hs-return
  to stop execution unless mode is "the-event".
- runtime hs-reset!: type-aware — FORM → reset, INPUT/TEXTAREA → value/checked
  from defaults, SELECT → defaultSelected option.
- runtime hs-open!/hs-close!: toggle `open` attribute on details elements
  (not just the prop) so dom-has-attr? assertions work.
- runtime hs-coerce JSON: json-stringify dict/list (was str).
- test-runner mock: host-get on List + "length"/"size" (was only Dict);
  dom-set-attr tracks defaultChecked / defaultSelected / defaultValue;
  mock_query_all supports comma-separated selector groups.
- generator: emit boolean attrs (checked/selected/etc) even with null value;
  drop overcautious "skip HS with bare quotes or embedded HTML" guard so
  morph tests (source contains embedded <div>) emit properly.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-22 15:36:01 +00:00
parent 5c66095b0f
commit 802ccd23e8
12 changed files with 1340 additions and 345 deletions
Download Patch File Download Diff File Expand all files Collapse all files

51
hosts/ocaml/bin/run_tests.ml
View File

@@ -1637,6 +1637,20 @@ let run_spec_tests env test_files =
in in
let rec mock_query_all el sel = 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 match split_selector sel with
| [single] -> mock_query_all_single el single | [single] -> mock_query_all_single el single
| first :: rest -> | first :: rest ->
@@ -1705,6 +1719,11 @@ let run_spec_tests env test_files =
| [Nil; _] -> Nil | [Nil; _] -> Nil
| [String s; String "length"] -> Number (float_of_int (String.length s)) | [String s; String "length"] -> Number (float_of_int (String.length s))
| [List l; String "length"] -> Number (float_of_int (List.length l)) | [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] -> | [Dict d; String key] ->
let mt = match Hashtbl.find_opt d "__mock_type" with Some (String t) -> t | _ -> "" in let mt = match Hashtbl.find_opt d "__mock_type" with Some (String t) -> t | _ -> "" in
(* classList.length *) (* classList.length *)
@@ -1789,6 +1808,18 @@ let run_spec_tests env test_files =
| Bool false -> String "false" | Bool false -> String "false"
| List l -> String (String.concat "," (List.map (fun v -> match dom_stringify v with String s -> s | _ -> "") l)) | List l -> String (String.concat "," (List.map (fun v -> match dom_stringify v with String s -> s | _ -> "") l))
| Nil -> String "" | 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) | v -> String (Sx_types.inspect v)
in in
@@ -1980,6 +2011,21 @@ let run_spec_tests env test_files =
Hashtbl.replace d "className" (String sv); Hashtbl.replace d "className" (String sv);
end; end;
if name = "disabled" then Hashtbl.replace d "disabled" (Bool true); 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 if name = "style" then begin
(* Parse CSS string into the style sub-dict *) (* Parse CSS string into the style sub-dict *)
let style_d = match Hashtbl.find_opt d "style" with Some (Dict s) -> s | _ -> 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-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-debug" (NativeFn ("console-debug", fun _ -> Nil)));
ignore (Sx_types.env_bind env "console-error" (NativeFn ("console-error", 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. (* eval-hs: compile hyperscript source to SX and evaluate it.
Used by eval-only behavioral tests (comparisonOperator, mathOperator, etc.). Used by eval-only behavioral tests (comparisonOperator, mathOperator, etc.).
Accepts optional ctx dict: {:me V :locals {:x V :y V ...}}. Catches Accepts optional ctx dict: {:me V :locals {:x V :y V ...}}. Catches

300
lib/hyperscript/compiler.sx
View File

@@ -23,14 +23,48 @@
((th (first target))) ((th (first target)))
(cond (cond
((= th dot-sym) ((= th dot-sym)
(list (let
(quote dom-set-prop) ((base-ast (nth target 1)) (prop (nth target 2)))
(hs-to-sx (nth target 1)) (cond
(nth target 2) ((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) "."))))
value)) (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)) ((= th (quote attr))
(list (list
(quote dom-set-attr) (quote hs-set-attr!)
(hs-to-sx (nth target 2)) (hs-to-sx (nth target 2))
(nth target 1) (nth target 1)
value)) value))
@@ -84,7 +118,7 @@
(list? prop-ast) (list? prop-ast)
(= (first prop-ast) (quote attr))) (= (first prop-ast) (quote attr)))
(list (list
(quote dom-set-attr) (quote hs-set-attr!)
(hs-to-sx obj-ast) (hs-to-sx obj-ast)
(nth prop-ast 1) (nth prop-ast 1)
value) value)
@@ -323,56 +357,120 @@
(cond (cond
((and (list? expr) (= (first expr) (quote attr))) ((and (list? expr) (= (first expr) (quote attr)))
(let (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 (list
(quote dom-set-attr) (quote let)
el
(nth expr 1)
(list (list
(quote +)
(list (list
(quote parse-number) (quote __hs-new)
(list (quote dom-get-attr) el (nth expr 1))) (list
amount)))) (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)) ((and (list? expr) (= (first expr) dot-sym))
(let (let
((obj (hs-to-sx (nth expr 1))) (prop (nth expr 2))) ((obj (hs-to-sx (nth expr 1))) (prop (nth expr 2)))
(list (list
(quote host-set!) (quote let)
obj
prop
(list (list
(quote +)
(list (list
(quote parse-number) (quote __hs-new)
(list (quote host-get) obj prop)) (list
amount)))) (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))) ((and (list? expr) (= (first expr) (quote style)))
(let (let
((el (if tgt-override (hs-to-sx tgt-override) (quote me))) ((el (if tgt-override (hs-to-sx tgt-override) (quote me)))
(prop (nth expr 1))) (prop (nth expr 1)))
(list (list
(quote dom-set-style) (quote let)
el
prop
(list (list
(quote +)
(list (list
(quote parse-number) (quote __hs-new)
(list (quote dom-get-style) el prop)) (list
amount)))) (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))) ((and (list? expr) (= (first expr) (quote dom-ref)))
(let (let
((el (hs-to-sx (nth expr 2))) (name (nth expr 1))) ((el (hs-to-sx (nth expr 2))) (name (nth expr 1)))
(list (list
(quote hs-dom-set!) (quote let)
el (list
name (list
(list (quote +) (list (quote hs-dom-get) el name) amount)))) (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 (true
(let (let
((t (hs-to-sx expr))) ((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 (define
emit-dec emit-dec
(fn (fn
@@ -380,56 +478,120 @@
(cond (cond
((and (list? expr) (= (first expr) (quote attr))) ((and (list? expr) (= (first expr) (quote attr)))
(let (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 (list
(quote dom-set-attr) (quote let)
el
(nth expr 1)
(list (list
(quote -)
(list (list
(quote parse-number) (quote __hs-new)
(list (quote dom-get-attr) el (nth expr 1))) (list
amount)))) (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)) ((and (list? expr) (= (first expr) dot-sym))
(let (let
((obj (hs-to-sx (nth expr 1))) (prop (nth expr 2))) ((obj (hs-to-sx (nth expr 1))) (prop (nth expr 2)))
(list (list
(quote host-set!) (quote let)
obj
prop
(list (list
(quote -)
(list (list
(quote parse-number) (quote __hs-new)
(list (quote host-get) obj prop)) (list
amount)))) (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))) ((and (list? expr) (= (first expr) (quote style)))
(let (let
((el (if tgt-override (hs-to-sx tgt-override) (quote me))) ((el (if tgt-override (hs-to-sx tgt-override) (quote me)))
(prop (nth expr 1))) (prop (nth expr 1)))
(list (list
(quote dom-set-style) (quote let)
el
prop
(list (list
(quote -)
(list (list
(quote parse-number) (quote __hs-new)
(list (quote dom-get-style) el prop)) (list
amount)))) (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))) ((and (list? expr) (= (first expr) (quote dom-ref)))
(let (let
((el (hs-to-sx (nth expr 2))) (name (nth expr 1))) ((el (hs-to-sx (nth expr 2))) (name (nth expr 1)))
(list (list
(quote hs-dom-set!) (quote let)
el (list
name (list
(list (quote -) (list (quote hs-dom-get) el name) amount)))) (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 (true
(let (let
((t (hs-to-sx expr))) ((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 (define
emit-behavior emit-behavior
(fn (fn
@@ -1009,7 +1171,15 @@
(hs-to-sx tgt) (hs-to-sx tgt)
(list (quote hs-remove-from!) val (hs-to-sx tgt))))) (list (quote hs-remove-from!) val (hs-to-sx tgt)))))
((= head (quote empty-target)) ((= 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)) ((= head (quote open-element))
(list (quote hs-open!) (hs-to-sx (nth ast 1)))) (list (quote hs-open!) (hs-to-sx (nth ast 1))))
((= head (quote close-element)) ((= head (quote close-element))
@@ -1160,6 +1330,9 @@
(or (or
(= (first c) (quote hs-fetch)) (= (first c) (quote hs-fetch))
(= (first c) (quote hs-wait)) (= (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))))) (= (first c) (quote perform)))))
compiled)) compiled))
(reduce (reduce
@@ -1486,7 +1659,8 @@
(hs-to-sx (nth ast 1)) (hs-to-sx (nth ast 1))
(list (quote fn) (list) (hs-to-sx (nth (nth ast 2) 2))) (list (quote fn) (list) (hs-to-sx (nth (nth ast 2) 2)))
(nth ast 3))) (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!)) ((= head (quote focus!))
(list (quote dom-focus) (hs-to-sx (nth ast 1)))) (list (quote dom-focus) (hs-to-sx (nth ast 1))))
(true ast)))))))) (true ast))))))))

48
lib/hyperscript/parser.sx
View File

@@ -1205,14 +1205,33 @@
(adv!) (adv!)
(let (let
((source (if (match-kw "from") (parse-expr) nil))) ((source (if (match-kw "from") (parse-expr) nil)))
(if (let
source ((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)))
(list (quote wait-for) event-name :from source) (cond
(list (quote wait-for) event-name))))) ((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") ((= (tp-type) "number")
(let (let
((tok (adv!))) ((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))))) (true (list (quote wait) 0)))))
(define (define
parse-detail-dict parse-detail-dict
@@ -1337,7 +1356,7 @@
(fn (fn
() ()
(let (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 (define
parse-one-transition parse-one-transition
(fn (fn
@@ -1473,18 +1492,7 @@
(if (= (tp-type) "comma") (adv!) nil) (if (= (tp-type) "comma") (adv!) nil)
(ca-collect (append acc (list arg))))))) (ca-collect (append acc (list arg)))))))
(ca-collect (list)))) (ca-collect (list))))
(define (define parse-call-cmd (fn () (parse-expr)))
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-get-cmd (fn () (parse-expr))) (define parse-get-cmd (fn () (parse-expr)))
(define (define
parse-take-cmd parse-take-cmd
@@ -1841,7 +1849,7 @@
(fn (fn
() ()
(let (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)))) (list (quote halt!) mode))))
(define (define
parse-param-list parse-param-list
@@ -1965,7 +1973,7 @@
(fn (fn
() ()
(let (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)))) (list (quote empty-target) target))))
(define (define
parse-swap-cmd parse-swap-cmd

245
lib/hyperscript/runtime.sx
View File

@@ -156,26 +156,77 @@
(dom-set-attr target name "")))))))) (dom-set-attr target name ""))))))))
;; First element matching selector within a scope. ;; First element matching selector within a scope.
(define (begin
hs-put! (define
(fn hs-element?
(value pos target) (fn
(cond (v)
((= pos "into") (and v (or (host-get v "nodeType") (host-get v "__mock_type")))))
(if (list? target) target (dom-set-inner-html target value))) (define
((= pos "before") hs-set-attr!
(dom-insert-adjacent-html target "beforebegin" value)) (fn
((= pos "after") (dom-insert-adjacent-html target "afterend" value)) (el name val)
((= pos "start") (if (nil? val) (dom-remove-attr el name) (dom-set-attr el name val))))
(if (define
(list? target) hs-put!
(append! target value 0) (fn
(dom-insert-adjacent-html target "afterbegin" value))) (value pos target)
((= pos "end") (cond
(if ((= pos "into")
(list? target) (cond
(append! target value) ((list? target) target)
(dom-insert-adjacent-html target "beforeend" value)))))) ((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. ;; Last element matching selector.
(define (define
@@ -228,16 +279,22 @@
(define (define
hs-halt! hs-halt!
(fn (fn
(mode) (ev mode)
(when (do
event (when
(cond ev
((= mode "default") (host-call event "preventDefault")) (cond
((= mode "bubbling") (host-call event "stopPropagation")) ((= mode "default") (host-call ev "preventDefault"))
(true ((= mode "bubbling") (host-call ev "stopPropagation"))
(do ((= mode "the-event")
(host-call event "preventDefault") (do
(host-call event "stopPropagation"))))))) (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 ─────────────────────────────────────────────── ;; ── Type coercion ───────────────────────────────────────────────
@@ -249,7 +306,51 @@
;; Make a new object of a given type. ;; Make a new object of a given type.
;; (hs-make type-name) — creates empty object/collection ;; (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 ─────────────────────────────────────── ;; ── Behavior installation ───────────────────────────────────────
@@ -306,6 +407,20 @@
hs-query-all hs-query-all
(fn (sel) (host-call (dom-body) "querySelectorAll" sel))) (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 (define
hs-query-first hs-query-first
(fn (sel) (host-call (host-global "document") "querySelector" sel))) (fn (sel) (host-call (host-global "document") "querySelector" sel)))
@@ -387,6 +502,10 @@
(if (cond-fn) nil (hs-repeat-until cond-fn thunk))) (if (cond-fn) nil (hs-repeat-until cond-fn thunk)))
(true (if (cond-fn) nil (hs-repeat-until cond-fn thunk))))))) (true (if (cond-fn) nil (hs-repeat-until cond-fn thunk)))))))
(define (define
hs-for-each hs-for-each
(fn (fn
@@ -419,17 +538,14 @@
(define (define
hs-append! hs-append!
(fn (value target) (dom-insert-adjacent-html target "beforeend" value)))) (fn (value target) (dom-insert-adjacent-html target "beforeend" value))))
;; ── Sandbox/test runtime additions ──────────────────────────────
;; Property access — dot notation and .length
(define (define
hs-fetch hs-fetch
(fn (fn
(url format) (url format)
(perform (list "io-fetch" url (if format format "text"))))) (perform (list "io-fetch" url (if format format "text")))))
;; DOM query stub — sandbox returns empty list
(define (define
hs-coerce hs-coerce
(fn (fn
@@ -520,8 +636,7 @@
(map (fn (k) (list k (get value k))) (keys value)) (map (fn (k) (list k (get value k))) (keys value))
value)) value))
(true value)))) (true value))))
;; ── Sandbox/test runtime additions ────────────────────────────── ;; Method dispatch — obj.method(args)
;; Property access — dot notation and .length
(define (define
hs-add hs-add
(fn (fn
@@ -531,7 +646,9 @@
((list? b) (cons a b)) ((list? b) (cons a b))
((or (string? a) (string? b)) (str a b)) ((or (string? a) (string? b)) (str a b))
(true (+ a b))))) (true (+ a b)))))
;; DOM query stub — sandbox returns empty list
;; ── 0.9.90 features ─────────────────────────────────────────────
;; beep! — debug logging, returns value unchanged
(define (define
hs-make hs-make
(fn (fn
@@ -542,15 +659,13 @@
((= type-name "Set") (list)) ((= type-name "Set") (list))
((= type-name "Map") (dict)) ((= type-name "Map") (dict))
(true (dict))))) (true (dict)))))
;; Method dispatch — obj.method(args) ;; Property-based is — check obj.key truthiness
(define hs-install (fn (behavior-fn) (behavior-fn me))) (define hs-install (fn (behavior-fn) (behavior-fn me)))
;; Array slicing (inclusive both ends)
;; ── 0.9.90 features ─────────────────────────────────────────────
;; beep! — debug logging, returns value unchanged
(define (define
hs-measure hs-measure
(fn (target) (perform (list (quote io-measure) target)))) (fn (target) (perform (list (quote io-measure) target))))
;; Property-based is — check obj.key truthiness ;; Collection: sorted by
(define (define
hs-transition hs-transition
(fn (fn
@@ -563,7 +678,7 @@
(str prop " " (/ duration 1000) "s"))) (str prop " " (/ duration 1000) "s")))
(dom-set-style target prop value) (dom-set-style target prop value)
(when duration (hs-settle target)))) (when duration (hs-settle target))))
;; Array slicing (inclusive both ends) ;; Collection: sorted by descending
(define (define
hs-transition-from hs-transition-from
(fn (fn
@@ -577,7 +692,7 @@
(str prop " " (/ duration 1000) "s"))) (str prop " " (/ duration 1000) "s")))
(dom-set-style target prop (str to-val)) (dom-set-style target prop (str to-val))
(when duration (hs-settle target)))) (when duration (hs-settle target))))
;; Collection: sorted by ;; Collection: split by
(define (define
hs-type-check hs-type-check
(fn (fn
@@ -597,17 +712,17 @@
(= (host-typeof value) "element") (= (host-typeof value) "element")
(= (host-typeof value) "text"))) (= (host-typeof value) "text")))
(true (= (host-typeof value) (downcase type-name))))))) (true (= (host-typeof value) (downcase type-name)))))))
;; Collection: sorted by descending ;; Collection: joined by
(define (define
hs-type-check-strict hs-type-check-strict
(fn (fn
(value type-name) (value type-name)
(if (nil? value) false (hs-type-check value type-name)))) (if (nil? value) false (hs-type-check value type-name))))
;; Collection: split by
(define (define
hs-strict-eq hs-strict-eq
(fn (a b) (and (= (type-of a) (type-of b)) (= a b)))) (fn (a b) (and (= (type-of a) (type-of b)) (= a b))))
;; Collection: joined by
(define (define
hs-eq-ignore-case hs-eq-ignore-case
(fn (a b) (= (downcase (str a)) (downcase (str b))))) (fn (a b) (= (downcase (str a)) (downcase (str b)))))
@@ -738,6 +853,17 @@
((dict? v) (= (len (keys v)) 0)) ((dict? v) (= (len (keys v)) 0))
(true false)))) (true false))))
(define
hs-empty-like
(fn
(v)
(cond
((list? v) (list))
((dict? v) (dict))
((string? v) "")
((nil? v) nil)
(true v))))
(define (define
hs-empty-target! hs-empty-target!
(fn (fn
@@ -756,7 +882,6 @@
(or (= input-type "checkbox") (= input-type "radio")) (or (= input-type "checkbox") (= input-type "radio"))
(dom-set-prop target "checked" false) (dom-set-prop target "checked" false)
(dom-set-prop target "value" "")))) (dom-set-prop target "value" ""))))
((= tag "FORM") (dom-set-inner-html target ""))
((= tag "FORM") ((= tag "FORM")
(let (let
((children (host-call target "querySelectorAll" "input, textarea, select"))) ((children (host-call target "querySelectorAll" "input, textarea, select")))
@@ -981,10 +1106,10 @@
(el) (el)
(let (let
((tag (dom-get-prop el "tagName"))) ((tag (dom-get-prop el "tagName")))
(if (cond
(= tag "DIALOG") ((= tag "DIALOG") (host-call el "showModal"))
(host-call el "showModal") (true
(dom-set-prop el "open" true))))) (do (dom-set-attr el "open" "") (dom-set-prop el "open" true)))))))
(define (define
hs-close! hs-close!
@@ -992,10 +1117,12 @@
(el) (el)
(let (let
((tag (dom-get-prop el "tagName"))) ((tag (dom-get-prop el "tagName")))
(if (cond
(= tag "DIALOG") ((= tag "DIALOG") (host-call el "close"))
(host-call el "close") (true
(dom-set-prop el "open" false))))) (do
(host-call el "removeAttribute" "open")
(dom-set-prop el "open" false)))))))
(define (define
hs-hide! hs-hide!

3
lib/hyperscript/tokenizer.sx
View File

@@ -183,7 +183,8 @@
"focus" "focus"
"blur" "blur"
"dom" "dom"
"morph")) "morph"
"using"))
(define hs-keyword? (fn (word) (some (fn (k) (= k word)) hs-keywords))) (define hs-keyword? (fn (word) (some (fn (k) (= k word)) hs-keywords)))

440
shared/static/wasm/sx/hs-compiler.sx
View File

@@ -23,14 +23,48 @@
((th (first target))) ((th (first target)))
(cond (cond
((= th dot-sym) ((= th dot-sym)
(list (let
(quote dom-set-prop) ((base-ast (nth target 1)) (prop (nth target 2)))
(hs-to-sx (nth target 1)) (cond
(nth target 2) ((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) "."))))
value)) (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)) ((= th (quote attr))
(list (list
(quote dom-set-attr) (quote hs-set-attr!)
(hs-to-sx (nth target 2)) (hs-to-sx (nth target 2))
(nth target 1) (nth target 1)
value)) value))
@@ -44,6 +78,12 @@
(list (quote set!) (make-symbol (nth target 1)) value)) (list (quote set!) (make-symbol (nth target 1)) value))
((= th (quote local)) ((= th (quote local))
(list (quote define) (make-symbol (nth target 1)) value)) (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)) ((= th (quote me))
(list (quote dom-set-inner-html) (quote me) value)) (list (quote dom-set-inner-html) (quote me) value))
((= th (quote it)) (list (quote set!) (quote it) 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 1))
(hs-to-sx (nth target 2)) (hs-to-sx (nth target 2))
value)) 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)) ((= th (quote of))
(let (let
((prop-ast (nth target 1)) (obj-ast (nth target 2))) ((prop-ast (nth target 1)) (obj-ast (nth target 2)))
@@ -76,7 +118,7 @@
(list? prop-ast) (list? prop-ast)
(= (first prop-ast) (quote attr))) (= (first prop-ast) (quote attr)))
(list (list
(quote dom-set-attr) (quote hs-set-attr!)
(hs-to-sx obj-ast) (hs-to-sx obj-ast)
(nth prop-ast 1) (nth prop-ast 1)
value) value)
@@ -247,7 +289,14 @@
(ast) (ast)
(let (let
((var-name (nth ast 1)) ((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)))) (body (hs-to-sx (nth ast 3))))
(if (if
(and (> (len ast) 4) (= (nth ast 4) :index)) (and (> (len ast) 4) (= (nth ast 4) :index))
@@ -308,48 +357,120 @@
(cond (cond
((and (list? expr) (= (first expr) (quote attr))) ((and (list? expr) (= (first expr) (quote attr)))
(let (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 (list
(quote dom-set-attr) (quote let)
el
(nth expr 1)
(list (list
(quote +)
(list (list
(quote parse-number) (quote __hs-new)
(list (quote dom-get-attr) el (nth expr 1))) (list
amount)))) (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)) ((and (list? expr) (= (first expr) dot-sym))
(let (let
((obj (hs-to-sx (nth expr 1))) (prop (nth expr 2))) ((obj (hs-to-sx (nth expr 1))) (prop (nth expr 2)))
(list (list
(quote host-set!) (quote let)
obj
prop
(list (list
(quote +)
(list (list
(quote parse-number) (quote __hs-new)
(list (quote host-get) obj prop)) (list
amount)))) (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))) ((and (list? expr) (= (first expr) (quote style)))
(let (let
((el (if tgt-override (hs-to-sx tgt-override) (quote me))) ((el (if tgt-override (hs-to-sx tgt-override) (quote me)))
(prop (nth expr 1))) (prop (nth expr 1)))
(list (list
(quote dom-set-style) (quote let)
el
prop
(list (list
(quote +)
(list (list
(quote parse-number) (quote __hs-new)
(list (quote dom-get-style) el prop)) (list
amount)))) (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 (true
(let (let
((t (hs-to-sx expr))) ((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 (define
emit-dec emit-dec
(fn (fn
@@ -357,48 +478,120 @@
(cond (cond
((and (list? expr) (= (first expr) (quote attr))) ((and (list? expr) (= (first expr) (quote attr)))
(let (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 (list
(quote dom-set-attr) (quote let)
el
(nth expr 1)
(list (list
(quote -)
(list (list
(quote parse-number) (quote __hs-new)
(list (quote dom-get-attr) el (nth expr 1))) (list
amount)))) (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)) ((and (list? expr) (= (first expr) dot-sym))
(let (let
((obj (hs-to-sx (nth expr 1))) (prop (nth expr 2))) ((obj (hs-to-sx (nth expr 1))) (prop (nth expr 2)))
(list (list
(quote host-set!) (quote let)
obj
prop
(list (list
(quote -)
(list (list
(quote parse-number) (quote __hs-new)
(list (quote host-get) obj prop)) (list
amount)))) (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))) ((and (list? expr) (= (first expr) (quote style)))
(let (let
((el (if tgt-override (hs-to-sx tgt-override) (quote me))) ((el (if tgt-override (hs-to-sx tgt-override) (quote me)))
(prop (nth expr 1))) (prop (nth expr 1)))
(list (list
(quote dom-set-style) (quote let)
el
prop
(list (list
(quote -)
(list (list
(quote parse-number) (quote __hs-new)
(list (quote dom-get-style) el prop)) (list
amount)))) (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 (true
(let (let
((t (hs-to-sx expr))) ((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 (define
emit-behavior emit-behavior
(fn (fn
@@ -427,7 +620,7 @@
((= head (quote null-literal)) nil) ((= head (quote null-literal)) nil)
((= head (quote not)) ((= head (quote not))
(list (quote not) (hs-to-sx (nth ast 1)))) (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)))) (cons head (map hs-to-sx (rest ast))))
((= head (quote object-literal)) ((= head (quote object-literal))
(let (let
@@ -559,6 +752,37 @@
(hs-to-sx (nth ast 1)) (hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2)) (hs-to-sx (nth ast 2))
(hs-to-sx (nth ast 3)))) (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)) ((= head (quote prop-is))
(list (list
(quote hs-prop-is) (quote hs-prop-is)
@@ -656,6 +880,11 @@
(quote dom-get-style) (quote dom-get-style)
(hs-to-sx (nth ast 2)) (hs-to-sx (nth ast 2))
(nth ast 1))) (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?)) ((= head (quote has-class?))
(list (list
(quote dom-has-class?) (quote dom-has-class?)
@@ -742,6 +971,26 @@
(quote hs-ends-with-ic?) (quote hs-ends-with-ic?)
(hs-to-sx (nth ast 1)) (hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2)))) (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?)) ((= head (quote contains?))
(list (list
(quote hs-contains?) (quote hs-contains?)
@@ -922,7 +1171,15 @@
(hs-to-sx tgt) (hs-to-sx tgt)
(list (quote hs-remove-from!) val (hs-to-sx tgt))))) (list (quote hs-remove-from!) val (hs-to-sx tgt)))))
((= head (quote empty-target)) ((= 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)) ((= head (quote open-element))
(list (quote hs-open!) (hs-to-sx (nth ast 1)))) (list (quote hs-open!) (hs-to-sx (nth ast 1))))
((= head (quote close-element)) ((= head (quote close-element))
@@ -937,6 +1194,11 @@
(quote do) (quote do)
(emit-set lhs (hs-to-sx rhs)) (emit-set lhs (hs-to-sx rhs))
(emit-set rhs (quote _swap_tmp)))))) (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)) ((= head (quote remove-attr))
(let (let
((tgt (if (nil? (nth ast 2)) (quote me) (hs-to-sx (nth ast 2))))) ((tgt (if (nil? (nth ast 2)) (quote me) (hs-to-sx (nth ast 2)))))
@@ -977,6 +1239,23 @@
(quote hs-set-on!) (quote hs-set-on!)
(hs-to-sx (nth ast 1)) (hs-to-sx (nth ast 1))
(hs-to-sx (nth ast 2)))) (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)) ((= head (quote toggle-between))
(list (list
(quote hs-toggle-between!) (quote hs-toggle-between!)
@@ -1051,6 +1330,9 @@
(or (or
(= (first c) (quote hs-fetch)) (= (first c) (quote hs-fetch))
(= (first c) (quote hs-wait)) (= (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))))) (= (first c) (quote perform)))))
compiled)) compiled))
(reduce (reduce
@@ -1061,7 +1343,7 @@
(list (list (quote it) cmd)) (list (list (quote it) cmd))
body)) body))
(nth compiled (- (len compiled) 1)) (nth compiled (- (len compiled) 1))
(reverse (rest (reverse compiled)))) (rest (reverse compiled)))
(cons (quote do) compiled)))) (cons (quote do) compiled))))
((= head (quote wait)) (list (quote hs-wait) (nth ast 1))) ((= head (quote wait)) (list (quote hs-wait) (nth ast 1)))
((= head (quote wait-for)) (emit-wait-for ast)) ((= head (quote wait-for)) (emit-wait-for ast))
@@ -1194,20 +1476,39 @@
((= head (quote measure)) ((= head (quote measure))
(list (quote hs-measure) (hs-to-sx (nth ast 1)))) (list (quote hs-measure) (hs-to-sx (nth ast 1))))
((= head (quote increment!)) ((= head (quote increment!))
(emit-inc (if
(nth ast 1) (= (len ast) 3)
(nth ast 2) (emit-inc (nth ast 1) 1 (nth ast 2))
(if (> (len ast) 3) (nth ast 3) nil))) (emit-inc
(nth ast 1)
(nth ast 2)
(if (> (len ast) 3) (nth ast 3) nil))))
((= head (quote decrement!)) ((= head (quote decrement!))
(emit-dec (if
(nth ast 1) (= (len ast) 3)
(nth ast 2) (emit-dec (nth ast 1) 1 (nth ast 2))
(if (> (len ast) 3) (nth ast 3) nil))) (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 break)) (list (quote raise) "hs-break"))
((= head (quote continue)) ((= head (quote continue))
(list (quote raise) "hs-continue")) (list (quote raise) "hs-continue"))
((= head (quote exit)) nil) ((= 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 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)) ((= head (quote init))
(list (list
(quote hs-init) (quote hs-init)
@@ -1352,7 +1653,14 @@
(quote when) (quote when)
(list (quote nil?) t) (list (quote nil?) t)
(list (quote set!) t v)))) (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!)) ((= head (quote focus!))
(list (quote dom-focus) (hs-to-sx (nth ast 1)))) (list (quote dom-focus) (hs-to-sx (nth ast 1))))
(true ast)))))))) (true ast))))))))

370
shared/static/wasm/sx/hs-parser.sx
View File

@@ -180,6 +180,16 @@
((= typ "style") ((= typ "style")
(do (adv!) (list (quote style) val (list (quote me))))) (do (adv!) (list (quote style) val (list (quote me)))))
((= typ "local") (do (adv!) (list (quote local) val))) ((= 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") ((= typ "class")
(do (adv!) (list (quote query) (str "." val)))) (do (adv!) (list (quote query) (str "." val))))
((= typ "ident") (do (adv!) (list (quote ref) val))) ((= typ "ident") (do (adv!) (list (quote ref) val)))
@@ -288,7 +298,7 @@
(adv!) (adv!)
(let (let
((name val) (args (parse-call-args))) ((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))))) (true nil)))))
(define (define
parse-poss parse-poss
@@ -301,7 +311,7 @@
((= (tp-type) "paren-open") ((= (tp-type) "paren-open")
(let (let
((args (parse-call-args))) ((args (parse-call-args)))
(list (quote call) obj args))) (cons (quote call) (cons obj args))))
((= (tp-type) "bracket-open") ((= (tp-type) "bracket-open")
(do (do
(adv!) (adv!)
@@ -479,20 +489,24 @@
(list (quote type-check-strict) left type-name) (list (quote type-check-strict) left type-name)
(list (quote type-check) left type-name)))))) (list (quote type-check) left type-name))))))
(true (true
(if (let
(and ((right (parse-expr)))
(= (tp-type) "ident") (if
(not (hs-keyword? (tp-val)))) (match-kw "ignoring")
(let (do
((prop-name (tp-val))) (match-kw "case")
(do (adv!) (list (quote prop-is) left prop-name))) (list (quote eq-ignore-case) left right))
(let
((right (parse-expr)))
(if (if
(match-kw "ignoring") (and
(do (list? right)
(match-kw "case") (= (len right) 2)
(list (quote eq-ignore-case) left right)) (= (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)))))))) (list (quote =) left right))))))))
((and (= typ "keyword") (= val "am")) ((and (= typ "keyword") (= val "am"))
(do (do
@@ -504,12 +518,34 @@
(list (quote not-in?) left (parse-expr))) (list (quote not-in?) left (parse-expr)))
((match-kw "empty") ((match-kw "empty")
(list (quote not) (list (quote empty?) left))) (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 (true
(let (let
((right (parse-expr))) ((right (parse-expr)))
(list (quote not) (list (quote =) left right)))))) (list (quote not) (list (quote =) left right))))))
((match-kw "in") (list (quote in?) left (parse-expr))) ((match-kw "in") (list (quote in?) left (parse-expr)))
((match-kw "empty") (list (quote empty?) left)) ((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 (true
(let (let
((right (parse-expr))) ((right (parse-expr)))
@@ -639,6 +675,14 @@
(list (list
(quote not) (quote not)
(list (quote ends-with?) left (parse-expr))))) (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)))) (true left))))
((and (= typ "keyword") (= val "equals")) ((and (= typ "keyword") (= val "equals"))
(do (adv!) (list (quote =) left (parse-expr)))) (do (adv!) (list (quote =) left (parse-expr))))
@@ -877,7 +921,7 @@
(collect-classes!)))) (collect-classes!))))
(collect-classes!) (collect-classes!)
(let (let
((tgt (if (match-kw "from") (parse-expr) nil))) ((tgt (if (match-kw "from") (parse-expr) (list (quote me)))))
(if (if
(empty? extra-classes) (empty? extra-classes)
(list (quote remove-class) cls tgt) (list (quote remove-class) cls tgt)
@@ -1097,7 +1141,12 @@
((match-kw "on") ((match-kw "on")
(let (let
((target (parse-expr))) ((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))))))) (true (error (str "Expected to/on at position " p)))))))
(define (define
parse-put-cmd parse-put-cmd
@@ -1105,28 +1154,31 @@
() ()
(let (let
((value (parse-expr))) ((value (parse-expr)))
(cond (let
((match-kw "into") (list (quote set!) (parse-expr) value)) ((value (if (and (list? value) (= (first value) (quote dom-ref)) (match-kw "on")) (list (quote dom-ref) (nth value 1) (parse-expr)) value)))
((match-kw "before") (cond
(list (quote put!) value "before" (parse-expr))) ((match-kw "into") (list (quote set!) (parse-expr) value))
((match-kw "after") ((match-kw "before")
(list (quote put!) value "after" (parse-expr))) (list (quote put!) value "before" (parse-expr)))
((match-kw "at") ((match-kw "after")
(do (list (quote put!) value "after" (parse-expr)))
(match-kw "the") ((match-kw "at")
(cond (do
((match-kw "start") (match-kw "the")
(do (cond
(expect-kw! "of") ((match-kw "start")
(list (quote put!) value "start" (parse-expr)))) (do
((match-kw "end") (expect-kw! "of")
(do (list (quote put!) value "start" (parse-expr))))
(expect-kw! "of") ((match-kw "end")
(list (quote put!) value "end" (parse-expr)))) (do
(true (expect-kw! "of")
(error (str "Expected start/end after at, position " p)))))) (list (quote put!) value "end" (parse-expr))))
(true (true
(error (str "Expected into/before/after/at at position " p))))))) (error
(str "Expected start/end after at, position " p))))))
(true
(error (str "Expected into/before/after/at at position " p))))))))
(define (define
parse-if-cmd parse-if-cmd
(fn (fn
@@ -1153,14 +1205,33 @@
(adv!) (adv!)
(let (let
((source (if (match-kw "from") (parse-expr) nil))) ((source (if (match-kw "from") (parse-expr) nil)))
(if (let
source ((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)))
(list (quote wait-for) event-name :from source) (cond
(list (quote wait-for) event-name))))) ((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") ((= (tp-type) "number")
(let (let
((tok (adv!))) ((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))))) (true (list (quote wait) 0)))))
(define (define
parse-detail-dict parse-detail-dict
@@ -1241,10 +1312,13 @@
(let (let
((expr (parse-expr))) ((expr (parse-expr)))
(let (let
((amount (if (match-kw "by") (parse-expr) 1))) ((by-amount (if (match-kw "by") (parse-expr) nil)))
(let (let
((tgt (parse-tgt-kw "on" (list (quote me))))) ((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 (define
parse-dec-cmd parse-dec-cmd
(fn (fn
@@ -1252,10 +1326,13 @@
(let (let
((expr (parse-expr))) ((expr (parse-expr)))
(let (let
((amount (if (match-kw "by") (parse-expr) 1))) ((by-amount (if (match-kw "by") (parse-expr) nil)))
(let (let
((tgt (parse-tgt-kw "on" (list (quote me))))) ((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 (define
parse-hide-cmd parse-hide-cmd
(fn (fn
@@ -1279,7 +1356,7 @@
(fn (fn
() ()
(let (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 (define
parse-one-transition parse-one-transition
(fn (fn
@@ -1370,11 +1447,13 @@
(fn (fn
() ()
(if (if
(and (= (tp-type) "keyword") (= (tp-val) "gql")) (and
(or (= (tp-type) "keyword") (= (tp-type) "ident"))
(= (tp-val) "gql"))
(do (do
(adv!) (adv!)
(let (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 (let
((url (if (and (= (tp-type) "keyword") (= (tp-val) "from")) (do (adv!) (parse-arith (parse-poss (parse-atom)))) nil))) ((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)))) (list (quote fetch-gql) gql-source url))))
@@ -1383,7 +1462,7 @@
(let (let
((url (if (nil? url-atom) url-atom (parse-arith (parse-poss url-atom))))) ((url (if (nil? url-atom) url-atom (parse-arith (parse-poss url-atom)))))
(let (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 (= (tp-type) "brace-open") (parse-expr))
(when (when
(match-kw "with") (match-kw "with")
@@ -1392,7 +1471,7 @@
(parse-expr) (parse-expr)
(parse-expr))) (parse-expr)))
(let (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 (let
((fmt (or fmt-before fmt-after "text"))) ((fmt (or fmt-before fmt-after "text")))
(list (quote fetch) url fmt))))))))) (list (quote fetch) url fmt)))))))))
@@ -1413,18 +1492,8 @@
(if (= (tp-type) "comma") (adv!) nil) (if (= (tp-type) "comma") (adv!) nil)
(ca-collect (append acc (list arg))))))) (ca-collect (append acc (list arg)))))))
(ca-collect (list)))) (ca-collect (list))))
(define (define parse-call-cmd (fn () (parse-expr)))
parse-call-cmd (define parse-get-cmd (fn () (parse-expr)))
(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 (define
parse-take-cmd parse-take-cmd
(fn (fn
@@ -1458,6 +1527,103 @@
attr-val attr-val
with-val))))))) with-val)))))))
(true nil)))) (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 (define
parse-go-cmd parse-go-cmd
(fn () (match-kw "to") (list (quote go) (parse-expr)))) (fn () (match-kw "to") (list (quote go) (parse-expr))))
@@ -1683,7 +1849,7 @@
(fn (fn
() ()
(let (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)))) (list (quote halt!) mode))))
(define (define
parse-param-list parse-param-list
@@ -1807,7 +1973,7 @@
(fn (fn
() ()
(let (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)))) (list (quote empty-target) target))))
(define (define
parse-swap-cmd parse-swap-cmd
@@ -1817,6 +1983,16 @@
((lhs (parse-expr))) ((lhs (parse-expr)))
(match-kw "with") (match-kw "with")
(let ((rhs (parse-expr))) (list (quote swap!) lhs rhs))))) (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 (define
parse-open-cmd parse-open-cmd
(fn (fn
@@ -1874,10 +2050,14 @@
(do (adv!) (parse-repeat-cmd))) (do (adv!) (parse-repeat-cmd)))
((and (= typ "keyword") (= val "fetch")) ((and (= typ "keyword") (= val "fetch"))
(do (adv!) (parse-fetch-cmd))) (do (adv!) (parse-fetch-cmd)))
((and (= typ "keyword") (= val "get"))
(do (adv!) (parse-get-cmd)))
((and (= typ "keyword") (= val "call")) ((and (= typ "keyword") (= val "call"))
(do (adv!) (parse-call-cmd))) (do (adv!) (parse-call-cmd)))
((and (= typ "keyword") (= val "take")) ((and (= typ "keyword") (= val "take"))
(do (adv!) (parse-take-cmd))) (do (adv!) (parse-take-cmd)))
((and (= typ "keyword") (= val "pick"))
(do (adv!) (parse-pick-cmd)))
((and (= typ "keyword") (= val "settle")) ((and (= typ "keyword") (= val "settle"))
(do (adv!) (list (quote settle)))) (do (adv!) (list (quote settle))))
((and (= typ "keyword") (= val "go")) ((and (= typ "keyword") (= val "go"))
@@ -1918,6 +2098,8 @@
(do (adv!) (parse-empty-cmd))) (do (adv!) (parse-empty-cmd)))
((and (= typ "keyword") (= val "swap")) ((and (= typ "keyword") (= val "swap"))
(do (adv!) (parse-swap-cmd))) (do (adv!) (parse-swap-cmd)))
((and (= typ "keyword") (= val "morph"))
(do (adv!) (parse-morph-cmd)))
((and (= typ "keyword") (= val "open")) ((and (= typ "keyword") (= val "open"))
(do (adv!) (parse-open-cmd))) (do (adv!) (parse-open-cmd)))
((and (= typ "keyword") (= val "close")) ((and (= typ "keyword") (= val "close"))
@@ -1955,6 +2137,7 @@
(= v "transition") (= v "transition")
(= v "repeat") (= v "repeat")
(= v "fetch") (= v "fetch")
(= v "get")
(= v "call") (= v "call")
(= v "take") (= v "take")
(= v "settle") (= v "settle")
@@ -1977,8 +2160,10 @@
(= v "empty") (= v "empty")
(= v "clear") (= v "clear")
(= v "swap") (= v "swap")
(= v "morph")
(= v "open") (= v "open")
(= v "close")))) (= v "close")
(= v "pick"))))
(define (define
cl-collect cl-collect
(fn (fn
@@ -2047,6 +2232,53 @@
((body (parse-cmd-list))) ((body (parse-cmd-list)))
(match-kw "end") (match-kw "end")
(list (quote init) body)))) (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 (define
parse-feat parse-feat
(fn (fn
@@ -2058,6 +2290,8 @@
((= val "init") (do (adv!) (parse-init-feat))) ((= val "init") (do (adv!) (parse-init-feat)))
((= val "def") (do (adv!) (parse-def-feat))) ((= val "def") (do (adv!) (parse-def-feat)))
((= val "behavior") (do (adv!) (parse-behavior-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)))))) (true (parse-cmd-list))))))
(define (define
coll-feats coll-feats

17
shared/static/wasm/sx/hs-tokenizer.sx
View File

@@ -117,6 +117,7 @@
"first" "first"
"last" "last"
"random" "random"
"pick"
"empty" "empty"
"clear" "clear"
"swap" "swap"
@@ -173,11 +174,17 @@
"default" "default"
"halt" "halt"
"precedes" "precedes"
"precede"
"follow"
"follows" "follows"
"ignoring" "ignoring"
"case" "case"
"changes"
"focus" "focus"
"blur")) "blur"
"dom"
"morph"
"using"))
(define hs-keyword? (fn (word) (some (fn (k) (= k word)) hs-keywords))) (define hs-keyword? (fn (word) (some (fn (k) (= k word)) hs-keywords)))
@@ -472,6 +479,14 @@
(hs-advance! 1) (hs-advance! 1)
(hs-emit! "attr" (read-ident pos) start) (hs-emit! "attr" (read-ident pos) start)
(scan!)) (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 (and
(= ch "~") (= ch "~")
(< (+ pos 1) src-len) (< (+ pos 1) src-len)

105
spec/tests/test-hyperscript-behavioral.sx
View File

@@ -23,7 +23,14 @@
(let ((sx (hs-to-sx (hs-compile src)))) (let ((sx (hs-to-sx (hs-compile src))))
(let ((handler (eval-expr-cek (let ((handler (eval-expr-cek
(list (quote fn) (list (quote me)) (list (quote let) (list (list (quote it) nil) (list (quote event) nil)) sx))))) (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.) ;; Evaluate with a specific me value (for "I am between" etc.)
(define eval-hs-with-me (define eval-hs-with-me
@@ -31,7 +38,14 @@
(let ((sx (hs-to-sx (hs-compile src)))) (let ((sx (hs-to-sx (hs-compile src))))
(let ((handler (eval-expr-cek (let ((handler (eval-expr-cek
(list (quote fn) (list (quote me)) (list (quote let) (list (list (quote it) nil) (list (quote event) nil)) sx))))) (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) ── ;; ── add (19 tests) ──
(defsuite "hs-upstream-add" (defsuite "hs-upstream-add"
@@ -235,6 +249,7 @@
(dom-set-attr _el-d1 "id" "d1") (dom-set-attr _el-d1 "id" "d1")
(dom-add-class _el-d1 "item") (dom-add-class _el-d1 "item")
(dom-set-attr _el-none "id" "none") (dom-set-attr _el-none "id" "none")
(dom-set-attr _el-none "hidden" "")
(dom-append (dom-body) _el-trigger) (dom-append (dom-body) _el-trigger)
(dom-append (dom-body) _el-d1) (dom-append (dom-body) _el-d1)
(dom-append (dom-body) _el-none) (dom-append (dom-body) _el-none)
@@ -365,7 +380,7 @@
(dom-append _el-d1 _el-p) (dom-append _el-d1 _el-p)
(dom-append _el-div _el-p3) (dom-append _el-div _el-p3)
(hs-activate! _el-d1) (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("foo").should.equal(true)
;; SKIP check: skip div.innerHTML.includes("bar").should.equal(true) ;; SKIP check: skip div.innerHTML.includes("bar").should.equal(true)
;; SKIP check: skip div.innerHTML.includes("doh").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 (dom-body) _el-div)
(dom-append _el-div _el-d1) (dom-append _el-div _el-d1)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-d1 "click" nil) (dom-dispatch _el-div "click" nil)
(assert= (dom-inner-html _el-d1) "foo") (assert= (dom-inner-html _el-div) "foo")
)) ))
(deftest "can set complex indirect properties rhs" (deftest "can set complex indirect properties rhs"
(hs-cleanup!) (hs-cleanup!)
@@ -808,8 +823,8 @@
(dom-append (dom-body) _el-div) (dom-append (dom-body) _el-div)
(dom-append _el-div _el-d1) (dom-append _el-div _el-d1)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-d1 "click" nil) (dom-dispatch _el-div "click" nil)
(assert= (dom-inner-html _el-d1) "foo") (assert= (dom-inner-html _el-div) "foo")
)) ))
(deftest "can set chained indirect properties" (deftest "can set chained indirect properties"
(hs-cleanup!) (hs-cleanup!)
@@ -819,8 +834,8 @@
(dom-append (dom-body) _el-div) (dom-append (dom-body) _el-div)
(dom-append _el-div _el-d1) (dom-append _el-div _el-d1)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-d1 "click" nil) (dom-dispatch _el-div "click" nil)
(assert= (dom-inner-html _el-d1) "foo") (assert= (dom-inner-html _el-div) "foo")
)) ))
(deftest "can set styles" (deftest "can set styles"
(hs-cleanup!) (hs-cleanup!)
@@ -1358,8 +1373,8 @@
(dom-append (dom-body) _el-div) (dom-append (dom-body) _el-div)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-div "click" nil) (dom-dispatch _el-div "click" nil)
(dom-dispatch _el-div "click" nil) (dom-dispatch (dom-query "button") "click" nil)
(assert= (dom-inner-html _el-div) "42") (assert= (dom-inner-html (dom-query "button")) "42")
)) ))
(deftest "properly processes hyperscript in new content in a element target" (deftest "properly processes hyperscript in new content in a element target"
(hs-cleanup!) (hs-cleanup!)
@@ -1369,8 +1384,8 @@
(dom-append (dom-body) _el-d1) (dom-append (dom-body) _el-d1)
(hs-activate! _el-d1) (hs-activate! _el-d1)
(dom-dispatch _el-d1 "click" nil) (dom-dispatch _el-d1 "click" nil)
(dom-dispatch _el-d1 "click" nil) (dom-dispatch (dom-query "button") "click" nil)
(assert= (dom-inner-html _el-d1) "42") (assert= (dom-inner-html (dom-query "button")) "42")
)) ))
(deftest "properly processes hyperscript in before" (deftest "properly processes hyperscript in before"
(hs-cleanup!) (hs-cleanup!)
@@ -1380,8 +1395,8 @@
(dom-append (dom-body) _el-d1) (dom-append (dom-body) _el-d1)
(hs-activate! _el-d1) (hs-activate! _el-d1)
(dom-dispatch _el-d1 "click" nil) (dom-dispatch _el-d1 "click" nil)
(dom-dispatch _el-d1 "click" nil) (dom-dispatch (dom-query "button") "click" nil)
(assert= (dom-inner-html _el-d1) "42") (assert= (dom-inner-html (dom-query "button")) "42")
)) ))
(deftest "properly processes hyperscript at start of" (deftest "properly processes hyperscript at start of"
(hs-cleanup!) (hs-cleanup!)
@@ -1391,8 +1406,8 @@
(dom-append (dom-body) _el-d1) (dom-append (dom-body) _el-d1)
(hs-activate! _el-d1) (hs-activate! _el-d1)
(dom-dispatch _el-d1 "click" nil) (dom-dispatch _el-d1 "click" nil)
(dom-dispatch _el-d1 "click" nil) (dom-dispatch (dom-query "button") "click" nil)
(assert= (dom-inner-html _el-d1) "42") (assert= (dom-inner-html (dom-query "button")) "42")
)) ))
(deftest "properly processes hyperscript at end of" (deftest "properly processes hyperscript at end of"
(hs-cleanup!) (hs-cleanup!)
@@ -1402,8 +1417,8 @@
(dom-append (dom-body) _el-d1) (dom-append (dom-body) _el-d1)
(hs-activate! _el-d1) (hs-activate! _el-d1)
(dom-dispatch _el-d1 "click" nil) (dom-dispatch _el-d1 "click" nil)
(dom-dispatch _el-d1 "click" nil) (dom-dispatch (dom-query "button") "click" nil)
(assert= (dom-inner-html _el-d1) "42") (assert= (dom-inner-html (dom-query "button")) "42")
)) ))
(deftest "properly processes hyperscript after" (deftest "properly processes hyperscript after"
(hs-cleanup!) (hs-cleanup!)
@@ -1413,8 +1428,8 @@
(dom-append (dom-body) _el-d1) (dom-append (dom-body) _el-d1)
(hs-activate! _el-d1) (hs-activate! _el-d1)
(dom-dispatch _el-d1 "click" nil) (dom-dispatch _el-d1 "click" nil)
(dom-dispatch _el-d1 "click" nil) (dom-dispatch (dom-query "button") "click" nil)
(assert= (dom-inner-html _el-d1) "42") (assert= (dom-inner-html (dom-query "button")) "42")
)) ))
(deftest "is null tolerant" (deftest "is null tolerant"
(hs-cleanup!) (hs-cleanup!)
@@ -2324,7 +2339,7 @@
(dom-append _el-div _el-d3) (dom-append _el-div _el-d3)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-d2 "click" nil) (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 (dom-has-class? _el-d2 "foo"))
(assert (not (dom-has-class? _el-d3 "foo"))) (assert (not (dom-has-class? _el-d3 "foo")))
)) ))
@@ -2441,7 +2456,7 @@
(dom-append _el-div _el-d3) (dom-append _el-div _el-d3)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-d2 "click" nil) (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") "") (assert= (dom-get-attr _el-d2 "data-foo") "")
;; SKIP check: skip assert.isNull(d2.getAttribute("data-foo") ;; SKIP check: skip assert.isNull(d2.getAttribute("data-foo")
;; SKIP check: skip assert.isNull(d3.getAttribute("data-foo") ;; SKIP check: skip assert.isNull(d3.getAttribute("data-foo")
@@ -3300,7 +3315,7 @@
(dom-append (dom-body) _el-div) (dom-append (dom-body) _el-div)
(hs-activate! _el-div) (hs-activate! _el-div)
(dom-dispatch _el-div "click" nil) (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" (deftest "can append a value to a set"
(hs-cleanup!) (hs-cleanup!)
@@ -4227,6 +4242,7 @@
(hs-cleanup!) (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"))) (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 "id" "d")
(dom-set-attr _el-d "open" "")
(dom-set-inner-html _el-summary "More") (dom-set-inner-html _el-summary "More")
(dom-set-inner-html _el-p "Content") (dom-set-inner-html _el-p "Content")
(dom-set-attr _el-button "_" "on click close #d") (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"))) (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 "id" "cb1")
(dom-set-attr _el-cb1 "type" "checkbox") (dom-set-attr _el-cb1 "type" "checkbox")
(dom-set-attr _el-cb1 "checked" "")
(dom-set-attr _el-button "_" "on click empty #cb1") (dom-set-attr _el-button "_" "on click empty #cb1")
(dom-set-inner-html _el-button "Empty") (dom-set-inner-html _el-button "Empty")
(dom-append (dom-body) _el-cb1) (dom-append (dom-body) _el-cb1)
@@ -4401,6 +4418,7 @@
(dom-set-attr _el-option "value" "a") (dom-set-attr _el-option "value" "a")
(dom-set-inner-html _el-option "A") (dom-set-inner-html _el-option "A")
(dom-set-attr _el-option2 "value" "b") (dom-set-attr _el-option2 "value" "b")
(dom-set-attr _el-option2 "selected" "")
(dom-set-inner-html _el-option2 "B") (dom-set-inner-html _el-option2 "B")
(dom-set-attr _el-button "_" "on click empty #sel1") (dom-set-attr _el-button "_" "on click empty #sel1")
(dom-set-inner-html _el-button "Empty") (dom-set-inner-html _el-button "Empty")
@@ -4422,6 +4440,7 @@
(dom-set-inner-html _el-ta2 "text") (dom-set-inner-html _el-ta2 "text")
(dom-set-attr _el-cb2 "id" "cb2") (dom-set-attr _el-cb2 "id" "cb2")
(dom-set-attr _el-cb2 "type" "checkbox") (dom-set-attr _el-cb2 "type" "checkbox")
(dom-set-attr _el-cb2 "checked" "")
(dom-set-attr _el-button "_" "on click empty #f1") (dom-set-attr _el-button "_" "on click empty #f1")
(dom-set-inner-html _el-button "Empty") (dom-set-inner-html _el-button "Empty")
(dom-append (dom-body) _el-f1) (dom-append (dom-body) _el-f1)
@@ -4649,10 +4668,11 @@
(let ((_el-target (dom-create-element "div")) (_el-button (dom-create-element "button"))) (let ((_el-target (dom-create-element "div")) (_el-button (dom-create-element "button")))
(dom-set-attr _el-target "id" "target") (dom-set-attr _el-target "id" "target")
(dom-set-inner-html _el-target "old") (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 \"<div id=target>new</div>\"")
(dom-set-inner-html _el-button "go") (dom-set-inner-html _el-button "go")
(dom-append (dom-body) _el-target) (dom-append (dom-body) _el-target)
(dom-append (dom-body) _el-button) (dom-append (dom-body) _el-button)
(hs-activate! _el-button)
(dom-dispatch _el-button "click" nil) (dom-dispatch _el-button "click" nil)
(assert= (dom-text-content (dom-query-by-id "target")) "new") (assert= (dom-text-content (dom-query-by-id "target")) "new")
)) ))
@@ -4662,10 +4682,11 @@
(dom-set-attr _el-target "id" "target") (dom-set-attr _el-target "id" "target")
(dom-set-inner-html _el-target "old") (dom-set-inner-html _el-target "old")
(dom-set-attr _el-go "id" "go") (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 \"<div id=target>new</div>\"")
(dom-set-inner-html _el-go "go") (dom-set-inner-html _el-go "go")
(dom-append (dom-body) _el-target) (dom-append (dom-body) _el-target)
(dom-append (dom-body) _el-go) (dom-append (dom-body) _el-go)
(hs-activate! _el-go)
(dom-dispatch (dom-query-by-id "go") "click" nil) (dom-dispatch (dom-query-by-id "go") "click" nil)
(assert= (dom-text-content (dom-query-by-id "target")) "new") (assert= (dom-text-content (dom-query-by-id "target")) "new")
)) ))
@@ -4675,10 +4696,11 @@
(dom-set-attr _el-target "id" "target") (dom-set-attr _el-target "id" "target")
(dom-add-class _el-target "old") (dom-add-class _el-target "old")
(dom-set-inner-html _el-target "content") (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 \"<div id=target class=new>content</div>\"")
(dom-set-inner-html _el-button "go") (dom-set-inner-html _el-button "go")
(dom-append (dom-body) _el-target) (dom-append (dom-body) _el-target)
(dom-append (dom-body) _el-button) (dom-append (dom-body) _el-button)
(hs-activate! _el-button)
(dom-dispatch _el-button "click" nil) (dom-dispatch _el-button "click" nil)
(assert (dom-has-class? (dom-query-by-id "target") "new")) (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 "id" "child")
(dom-set-attr _el-child "_" "on click put \"alive\" into me") (dom-set-attr _el-child "_" "on click put \"alive\" into me")
(dom-set-inner-html _el-child "child") (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 \"<div id=target><p>replaced</p></div>\"")
(dom-set-inner-html _el-button "go") (dom-set-inner-html _el-button "go")
(dom-append (dom-body) _el-target) (dom-append (dom-body) _el-target)
(dom-append _el-target _el-child) (dom-append _el-target _el-child)
(dom-append (dom-body) _el-button) (dom-append (dom-body) _el-button)
(hs-activate! _el-child) (hs-activate! _el-child)
(hs-activate! _el-button)
(dom-dispatch _el-button "click" nil) (dom-dispatch _el-button "click" nil)
)) ))
(deftest "morph reorders children by id" (deftest "morph reorders children by id"
@@ -4752,12 +4775,13 @@
(dom-set-inner-html _el-a "A") (dom-set-inner-html _el-a "A")
(dom-set-attr _el-b "id" "b") (dom-set-attr _el-b "id" "b")
(dom-set-inner-html _el-b "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 \"<div id=target><div id=b>B2</div><div id=a>A2</div></div>\"")
(dom-set-inner-html _el-button "go") (dom-set-inner-html _el-button "go")
(dom-append (dom-body) _el-target) (dom-append (dom-body) _el-target)
(dom-append _el-target _el-a) (dom-append _el-target _el-a)
(dom-append _el-target _el-b) (dom-append _el-target _el-b)
(dom-append (dom-body) _el-button) (dom-append (dom-body) _el-button)
(hs-activate! _el-button)
(dom-dispatch _el-button "click" nil) (dom-dispatch _el-button "click" nil)
)) ))
(deftest "morph preserves matched child identity" (deftest "morph preserves matched child identity"
@@ -4767,11 +4791,12 @@
(dom-set-attr _el-child "id" "child") (dom-set-attr _el-child "id" "child")
(dom-set-inner-html _el-child "old") (dom-set-inner-html _el-child "old")
(dom-set-attr _el-go "id" "go") (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 \"<div id=target><div id=child>new</div></div>\"")
(dom-set-inner-html _el-go "go") (dom-set-inner-html _el-go "go")
(dom-append (dom-body) _el-target) (dom-append (dom-body) _el-target)
(dom-append _el-target _el-child) (dom-append _el-target _el-child)
(dom-append (dom-body) _el-go) (dom-append (dom-body) _el-go)
(hs-activate! _el-go)
(dom-dispatch (dom-query-by-id "go") "click" nil) (dom-dispatch (dom-query-by-id "go") "click" nil)
)) ))
(deftest "morph with variable content" (deftest "morph with variable content"
@@ -4856,6 +4881,7 @@
(let ((_el-cb1 (dom-create-element "input")) (_el-button (dom-create-element "button"))) (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 "id" "cb1")
(dom-set-attr _el-cb1 "type" "checkbox") (dom-set-attr _el-cb1 "type" "checkbox")
(dom-set-attr _el-cb1 "checked" "")
(dom-set-attr _el-button "_" "on click reset #cb1") (dom-set-attr _el-button "_" "on click reset #cb1")
(dom-set-inner-html _el-button "Reset") (dom-set-inner-html _el-button "Reset")
(dom-append (dom-body) _el-cb1) (dom-append (dom-body) _el-cb1)
@@ -4906,6 +4932,7 @@
(dom-set-attr _el-option "value" "a") (dom-set-attr _el-option "value" "a")
(dom-set-inner-html _el-option "A") (dom-set-inner-html _el-option "A")
(dom-set-attr _el-option2 "value" "b") (dom-set-attr _el-option2 "value" "b")
(dom-set-attr _el-option2 "selected" "")
(dom-set-inner-html _el-option2 "B") (dom-set-inner-html _el-option2 "B")
(dom-set-attr _el-option3 "value" "c") (dom-set-attr _el-option3 "value" "c")
(dom-set-inner-html _el-option3 "C") (dom-set-inner-html _el-option3 "C")
@@ -5633,6 +5660,7 @@
(dom-set-attr _el-input "type" "radio") (dom-set-attr _el-input "type" "radio")
(dom-set-attr _el-input "name" "color") (dom-set-attr _el-input "name" "color")
(dom-set-attr _el-input "value" "red") (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 "_" "bind $color to me")
(dom-set-attr _el-input1 "type" "radio") (dom-set-attr _el-input1 "type" "radio")
(dom-set-attr _el-input1 "name" "color") (dom-set-attr _el-input1 "name" "color")
@@ -6891,10 +6919,11 @@
(let ((_el-target (dom-create-element "div")) (_el-button (dom-create-element "button"))) (let ((_el-target (dom-create-element "div")) (_el-button (dom-create-element "button")))
(dom-set-attr _el-target "id" "target") (dom-set-attr _el-target "id" "target")
(dom-set-inner-html _el-target "old") (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 \"<span id=target>new</span>\"")
(dom-set-inner-html _el-button "go") (dom-set-inner-html _el-button "go")
(dom-append (dom-body) _el-target) (dom-append (dom-body) _el-target)
(dom-append (dom-body) _el-button) (dom-append (dom-body) _el-button)
(hs-activate! _el-button)
(dom-dispatch _el-button "click" nil) (dom-dispatch _el-button "click" nil)
(assert= (dom-text-content (dom-query-by-id "target")) "new") (assert= (dom-text-content (dom-query-by-id "target")) "new")
)) ))
@@ -6920,13 +6949,14 @@
(dom-set-inner-html _el-li2 "b") (dom-set-inner-html _el-li2 "b")
(dom-add-class _el-li3 "item") (dom-add-class _el-li3 "item")
(dom-set-inner-html _el-li3 "c") (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 \"<li class=item>replaced</li>\"")
(dom-set-inner-html _el-button "go") (dom-set-inner-html _el-button "go")
(dom-append (dom-body) _el-list) (dom-append (dom-body) _el-list)
(dom-append _el-list _el-li) (dom-append _el-list _el-li)
(dom-append _el-list _el-li2) (dom-append _el-list _el-li2)
(dom-append _el-list _el-li3) (dom-append _el-list _el-li3)
(dom-append (dom-body) _el-button) (dom-append (dom-body) _el-button)
(hs-activate! _el-button)
(dom-dispatch _el-button "click" nil) (dom-dispatch _el-button "click" nil)
)) ))
(deftest "set <query/> replaces all matching elements" (deftest "set <query/> replaces all matching elements"
@@ -6935,22 +6965,24 @@
(dom-set-attr _el-box "id" "box") (dom-set-attr _el-box "id" "box")
(dom-set-inner-html _el-p "one") (dom-set-inner-html _el-p "one")
(dom-set-inner-html _el-p2 "two") (dom-set-inner-html _el-p2 "two")
;; HS source has bare quotes or embedded HTML (dom-set-attr _el-button "_" "on click set <p/> in #box to \"<p>done</p>\"")
(dom-set-inner-html _el-button "go") (dom-set-inner-html _el-button "go")
(dom-append (dom-body) _el-box) (dom-append (dom-body) _el-box)
(dom-append _el-box _el-p) (dom-append _el-box _el-p)
(dom-append _el-box _el-p2) (dom-append _el-box _el-p2)
(dom-append (dom-body) _el-button) (dom-append (dom-body) _el-button)
(hs-activate! _el-button)
(dom-dispatch _el-button "click" nil) (dom-dispatch _el-button "click" nil)
)) ))
(deftest "set closest replaces ancestor" (deftest "set closest replaces ancestor"
(hs-cleanup!) (hs-cleanup!)
(let ((_el-div (dom-create-element "div")) (_el-button (dom-create-element "button"))) (let ((_el-div (dom-create-element "div")) (_el-button (dom-create-element "button")))
(dom-add-class _el-div "wrapper") (dom-add-class _el-div "wrapper")
;; HS source has bare quotes or embedded HTML (dom-set-attr _el-button "_" "on click set (closest <div/>) to \"<div class=wrapper>replaced</div>\"")
(dom-set-inner-html _el-button "go") (dom-set-inner-html _el-button "go")
(dom-append (dom-body) _el-div) (dom-append (dom-body) _el-div)
(dom-append _el-div _el-button) (dom-append _el-div _el-button)
(hs-activate! _el-button)
(dom-dispatch _el-button "click" nil) (dom-dispatch _el-button "click" nil)
(assert= (dom-text-content (dom-query ".wrapper")) "replaced") (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"))) (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-add-class _el-input "cb")
(dom-set-attr _el-input "type" "checkbox") (dom-set-attr _el-input "type" "checkbox")
(dom-set-attr _el-input "checked" "")
(dom-add-class _el-input6 "cb") (dom-add-class _el-input6 "cb")
(dom-set-attr _el-input6 "type" "checkbox") (dom-set-attr _el-input6 "type" "checkbox")
(dom-add-class _el-input9 "cb") (dom-add-class _el-input9 "cb")
(dom-set-attr _el-input9 "type" "checkbox") (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 "id" "master")
(dom-set-attr _el-master "_" "set :checkboxes to <input[type=checkbox]/> in the closest <table/> where it is not me then on change set checked of the :checkboxes to my checked") (dom-set-attr _el-master "_" "set :checkboxes to <input[type=checkbox]/> in the closest <table/> where it is not me then on change set checked of the :checkboxes to my checked")
(dom-set-attr _el-master "type" "checkbox") (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"))) (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-add-class _el-input "cb")
(dom-set-attr _el-input "type" "checkbox") (dom-set-attr _el-input "type" "checkbox")
(dom-set-attr _el-input "checked" "")
(dom-add-class _el-input6 "cb") (dom-add-class _el-input6 "cb")
(dom-set-attr _el-input6 "type" "checkbox") (dom-set-attr _el-input6 "type" "checkbox")
(dom-add-class _el-input9 "cb") (dom-add-class _el-input9 "cb")
(dom-set-attr _el-input9 "type" "checkbox") (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 "id" "master")
(dom-set-attr _el-master "_" "set :checkboxes to <input[type=checkbox]/> in the closest <table/> where it is not me then on change set checked of the :checkboxes to my checked then on change from the closest <table/> 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 "_" "set :checkboxes to <input[type=checkbox]/> in the closest <table/> where it is not me then on change set checked of the :checkboxes to my checked then on change from the closest <table/> 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") (dom-set-attr _el-master "type" "checkbox")
@@ -8292,6 +8328,7 @@
(hs-cleanup!) (hs-cleanup!)
(let ((_el-b1 (dom-create-element "button")) (_el-b2 (dom-create-element "button"))) (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 "id" "b1")
(dom-set-attr _el-b1 "disabled" "")
(dom-set-inner-html _el-b1 "Disabled") (dom-set-inner-html _el-b1 "Disabled")
(dom-set-attr _el-b2 "id" "b2") (dom-set-attr _el-b2 "id" "b2")
(dom-set-inner-html _el-b2 "Enabled") (dom-set-inner-html _el-b2 "Enabled")

56
spec/tests/test-hyperscript-compiler.sx
View File

@@ -16,9 +16,9 @@
"remove class from target" "remove class from target"
(let (let
((sx (hs-to-sx-from-source "remove .old from #box"))) ((sx (hs-to-sx-from-source "remove .old from #box")))
(assert= (quote dom-remove-class) (first sx)) (assert= (quote for-each) (first sx))
(assert= (quote dom-query) (first (nth sx 1))) (assert= (quote hs-query-all) (first (nth sx 2)))
(assert= "old" (nth sx 2)))) (assert= "#box" (nth (nth sx 2) 1))))
(deftest (deftest
"toggle class" "toggle class"
(let (let
@@ -84,7 +84,7 @@
"for becomes for-each" "for becomes for-each"
(let (let
((sx (hs-to-sx-from-source "for item in items log item end"))) ((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))))) (assert= (quote fn) (first (nth sx 1)))))
(deftest (deftest
"tell rebinds me" "tell rebinds me"
@@ -100,17 +100,16 @@
"hide sets display none" "hide sets display none"
(let (let
((sx (hs-to-sx-from-source "hide"))) ((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= (quote me) (nth sx 1))
(assert= "display" (nth sx 2)) (assert= "display" (nth sx 2))))
(assert= "none" (nth sx 3))))
(deftest (deftest
"show clears display" "show clears display"
(let (let
((sx (hs-to-sx-from-source "show"))) ((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= (quote me) (nth sx 1))
(assert= "" (nth sx 3)))) (assert= "display" (nth sx 2))))
(deftest (deftest
"log passes through" "log passes through"
(let (let
@@ -121,7 +120,9 @@
"append becomes dom-append" "append becomes dom-append"
(let (let
((sx (hs-to-sx-from-source "append 'text' to me"))) ((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 ─────────────────────────────────────────────── ;; ── Expressions ───────────────────────────────────────────────
(defsuite (defsuite
@@ -138,7 +139,7 @@
"query emits dom-query" "query emits dom-query"
(let (let
((sx (hs-to-sx (list (quote query) ".foo")))) ((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)))) (assert= ".foo" (nth sx 1))))
(deftest (deftest
"attr emits dom-get-attr" "attr emits dom-get-attr"
@@ -176,7 +177,7 @@
(let (let
((sx (hs-to-sx-from-source "on click from #btn add .clicked end"))) ((sx (hs-to-sx-from-source "on click from #btn add .clicked end")))
(assert= (quote hs-on) (first sx)) (assert= (quote hs-on) (first sx))
(assert= (quote dom-query) (first (nth sx 1))))) (assert= (quote hs-query-first) (first (nth sx 1)))))
(deftest (deftest
"on every click" "on every click"
(let (let
@@ -254,7 +255,10 @@
"hs-emit-return-throw" "hs-emit-return-throw"
(deftest (deftest
"return unwraps to value" "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 (deftest
"throw becomes raise" "throw becomes raise"
(let (let
@@ -306,11 +310,11 @@
(assert= (quote hs-on) (first sx)) (assert= (quote hs-on) (first sx))
(assert= "click" (nth sx 2)) (assert= "click" (nth sx 2))
(let (let
((body (nth (nth sx 3) 2))) ((body (nth (nth sx 3) 2)) (inner (nth (nth (nth sx 3) 2) 2)))
(assert= (quote do) (first body)) (assert= (quote let) (first body))
(assert= 3 (len (rest body))) (assert= (quote let) (first inner))
(assert= (quote hs-wait) (first (nth body 2))) (assert= (quote hs-wait) (first (nth (first (nth inner 1)) 1)))
(assert= 1000 (nth (nth body 2) 1))))) (assert= 1000 (nth (nth (first (nth inner 1)) 1) 1)))))
(deftest (deftest
"count clicks: then chains increment and set in same handler" "count clicks: then chains increment and set in same handler"
(let (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"))) ((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)) (assert= (quote hs-on) (first sx))
(let (let
((body (nth (nth sx 3) 2))) ((inner (nth (nth (nth sx 3) 2) 2)))
(assert= (quote do) (first body)) (assert= (quote let) (first inner))
(assert= 3 (len (rest body))) (assert= (quote hs-wait) (first (nth (first (nth inner 1)) 1)))
(assert= (quote hs-wait) (first (nth body 2))) (assert= 1000 (nth (nth (first (nth inner 1)) 1) 1)))))
(assert= 1000 (nth (nth body 2) 1)))))
(deftest (deftest
"wait preserves ms value in handler" "wait preserves ms value in handler"
(let (let
((sx (hs-to-sx-from-source "on click add .a then wait 2s then add .b"))) ((sx (hs-to-sx-from-source "on click add .a then wait 2s then add .b")))
(let (let
((body (nth (nth sx 3) 2))) ((inner (nth (nth (nth sx 3) 2) 2)))
(assert= (quote hs-wait) (first (nth body 2))) (assert= (quote let) (first inner))
(assert= 2000 (nth (nth body 2) 1)))))) (assert= (quote hs-wait) (first (nth (first (nth inner 1)) 1)))
(assert= 2000 (nth (nth (first (nth inner 1)) 1) 1))))))

2
spec/tests/test-hyperscript-runtime.sx
View File

@@ -118,7 +118,7 @@
(let (let
((sx (hs-to-sx-from-source "fetch '/api'"))) ((sx (hs-to-sx-from-source "fetch '/api'")))
(assert= (quote hs-fetch) (first sx)) (assert= (quote hs-fetch) (first sx))
(assert= "json" (nth sx 2)))) (assert= "text" (nth sx 2))))
(deftest (deftest
"source → SX shape: def function" "source → SX shape: def function"
(let (let

48
tests/playwright/generate-sx-tests.py
View File

@@ -227,12 +227,15 @@ def parse_html(html):
'attrs': {}, 'inner': '', 'depth': len(stack), 'attrs': {}, 'inner': '', 'depth': len(stack),
'children': [], 'parent_idx': None 'children': [], 'parent_idx': None
} }
BOOL_ATTRS = {'checked', 'selected', 'disabled', 'multiple',
'required', 'readonly', 'autofocus', 'hidden', 'open'}
for name, val in attrs: for name, val in attrs:
if name == 'id': el['id'] = val if name == 'id': el['id'] = val
elif name == 'class': el['classes'] = (val or '').split() elif name == 'class': el['classes'] = (val or '').split()
elif name == '_': el['hs'] = val elif name == '_': el['hs'] = val
elif name == 'style': el['attrs']['style'] = val or '' elif name == 'style': el['attrs']['style'] = val or ''
elif val is not None: el['attrs'][name] = val elif val is not None: el['attrs'][name] = val
elif name in BOOL_ATTRS: el['attrs'][name] = ''
# Track parent-child relationship # Track parent-child relationship
if stack: if stack:
parent = stack[-1] 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). # 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) 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): 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 # Exact ID match first
if name in id_to_var: if name in id_to_var:
return id_to_var[name] return id_to_var[name]
@@ -499,8 +518,13 @@ def make_ref_fn(elements, var_names, action_str=''):
return tag_to_id[name] return tag_to_id[name]
if name in tag_to_unnamed: if name in tag_to_unnamed:
return tag_to_unnamed[name] return tag_to_unnamed[name]
# Fallback: first element of that tag (even if named) if name in tag_to_all and tag_to_all[name]:
return tag_to_all.get(name, [first_var])[0] # 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. # Tag + number: div1→1st div, div2→2nd div, form1→1st form, etc.
m = re.match(r'^([a-z]+)(\d+)$', name) 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']) hs_val = process_hs_val(el['hs'])
if not hs_val: if not hs_val:
pass # no HS to set 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: else:
hs_escaped = hs_val.replace('\\', '\\\\').replace('"', '\\"') hs_escaped = hs_val.replace('\\', '\\\\').replace('"', '\\"')
lines.append(f'{indent}(dom-set-attr {var} "_" "{hs_escaped}")') 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 ((sx (hs-to-sx (hs-compile src))))')
output.append(' (let ((handler (eval-expr-cek') 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(' (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('')
output.append(';; Evaluate with a specific me value (for "I am between" etc.)') output.append(';; Evaluate with a specific me value (for "I am between" etc.)')
output.append('(define eval-hs-with-me') 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 ((sx (hs-to-sx (hs-compile src))))')
output.append(' (let ((handler (eval-expr-cek') 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(' (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('') output.append('')
# Group by category # Group by category