coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions 7 Packages Projects Releases Wiki Activity
Files
5b100cac176cac8d1a261fae8316a451e248f0a1
rose-ash/shared/static/wasm/sx/dom.sx
giles 5b100cac17 HS runtime + generator: make, Values, toggle styles, scoped storage, array ops, fetch coercion, scripts in PW bodies 
Runtime (lib/hyperscript/ + shared/static/wasm/sx/hs-*.sx):
- make: parser accepts `<tag.class#id/>` selectors and `from <expr>,…`; compiler
  emits via scoped-set so `called <name>` persists; `called $X` lands on
  window; runtime dispatches element vs host-new constructor by type.
- Values: `x as Values` walks form inputs/selects/textareas, producing
  {name: value | [value,…]}; duplicates promote to array; multi-select and
  checkbox/radio handled.
- toggle *display/*visibility/*opacity: paired with sensible inline defaults
  in the mock DOM so toggle flips block/visible/1 ↔ none/hidden/0.
- add/remove/put at array: emit-set paths route list mutations back through
  the scoped binding; add hs-put-at! / hs-splice-at! / hs-dict-without.
- remove OBJ.KEY / KEY of OBJ: rebuild dict via hs-dict-without and reassign,
  since SX dicts are copy-on-read across the bridge.
- dom-set-data: use (host-new "Object") rather than (dict) so element-local
  storage actually persists between reads.
- fetch: hs-fetch normalizes JSON/Object/Text/Response format aliases;
  compiler sets `the-result` when wrapping a fetch in the `let ((it …))`
  chain, and __get-cmd shares one evaluation via __hs-g.

Mock DOM (tests/hs-run-filtered.js):
- parseHTMLFragments accepts void elements (<input>, <br>, …);
- setAttribute tracks name/type/checked/selected/multiple;
- select.options populated on appendChild;
- insertAdjacentHTML parses fragments and inserts real El children into the
  parent so HS-activated handlers attach.

Generator (tests/playwright/generate-sx-tests.py):
- process_hs_val strips `//` / `--` line comments before newline→then
  collapse, and strips spurious `then` before else/end/catch/finally.
- parse_dev_body interleaves window-setup ops and DOM resets between
  actions/assertions; pre-html setups still emit up front.
- generate_test_pw compiles any `<script type=text/hyperscript>` (flattened
  across JS string-concat) under guard, exposing def blocks.
- Ordered ops for `run()`-style tests check window.obj.prop via new
  _js_window_expr_to_sx; add DOM-constructing evaluate + _hyperscript
  pattern for `as Values` tests (result.key[i].toBe(…)).
- js_val_to_sx handles backticks and escapes embedded quotes.

Net delta across suites:
- if 16→18, make 0→8, toggle 12→21, add 9→10, remove 11→16, put 29→31,
  fetch 11→15, repeat 14→26, expressions/asExpression 20→25, set 27→28,
  core/scoping 12→14, when 39→39 (no regression).

🤖 Generated with [Claude Code](https://claude.com/claude-code)

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
2026-04-23 16:08:07 +00:00

458 lines
12 KiB
Plaintext
Raw Blame History

(define-library
(sx dom)
(export
dom-document
dom-window
dom-body
dom-head
dom-create-element
create-text-node
create-fragment
create-comment
dom-append
dom-prepend
dom-insert-before
dom-insert-after
dom-remove
dom-is-active-element?
dom-is-input-element?
dom-is-child-of?
dom-attr-list
dom-remove-child
dom-replace-child
dom-clone
dom-query
dom-query-all
dom-query-by-id
dom-closest
dom-matches?
dom-get-attr
dom-set-attr
dom-remove-attr
dom-has-attr?
dom-add-class
dom-remove-class
dom-has-class?
dom-visible?
dom-text-content
dom-set-text-content
dom-inner-html
dom-set-inner-html
dom-outer-html
dom-insert-adjacent-html
dom-get-style
dom-set-style
dom-get-prop
dom-set-prop
dom-tag-name
dom-node-type
dom-node-name
dom-id
dom-parent
dom-first-child
dom-next-sibling
dom-child-list
dom-is-fragment?
dom-child-nodes
dom-remove-children-after
dom-focus
dom-parse-html
dom-listen
dom-add-listener
dom-dispatch
event-detail
prevent-default
stop-propagation
event-modifier-key?
element-value
error-message
dom-get-data
dom-set-data
dom-append-to-head
set-document-title)
(begin
(define dom-document (fn () (host-global "document")))
(define dom-window (fn () (host-global "window")))
(define dom-body (fn () (host-get (dom-document) "body")))
(define dom-head (fn () (host-get (dom-document) "head")))
(define
dom-create-element
(fn
(tag ns)
(if
ns
(host-call (dom-document) "createElementNS" ns tag)
(host-call (dom-document) "createElement" tag))))
(define
create-text-node
(fn (s) (host-call (dom-document) "createTextNode" s)))
(define
create-fragment
(fn () (host-call (dom-document) "createDocumentFragment")))
(define
create-comment
(fn (text) (host-call (dom-document) "createComment" (or text ""))))
(define
dom-append
(fn
(parent child)
(when (and parent child) (host-call parent "appendChild" child))))
(define
dom-prepend
(fn
(parent child)
(when (and parent child) (host-call parent "prepend" child))))
(define
dom-insert-before
(fn
(parent child ref)
(when (and parent child) (host-call parent "insertBefore" child ref))))
(define
dom-insert-after
(fn
(ref node)
"Insert node after ref in the same parent."
(let
((parent (host-get ref "parentNode"))
(next (host-get ref "nextSibling")))
(when
parent
(if
next
(host-call parent "insertBefore" node next)
(host-call parent "appendChild" node))))))
(define dom-remove (fn (el) (when el (host-call el "remove"))))
(define
dom-is-active-element?
(fn
(el)
(let
((active (host-get (dom-document) "activeElement")))
(if (and active el) (identical? el active) false))))
(define
dom-is-input-element?
(fn
(el)
(let
((tag (upper (or (dom-tag-name el) ""))))
(or (= tag "INPUT") (= tag "TEXTAREA") (= tag "SELECT")))))
(define
dom-is-child-of?
(fn
(child parent)
(and child parent (host-call parent "contains" child))))
(define
dom-attr-list
(fn
(el)
(let
((attrs (host-get el "attributes")) (result (list)))
(when
attrs
(let
((n (host-get attrs "length")))
(let
loop
((i 0))
(when
(< i n)
(let
((attr (host-call attrs "item" i)))
(append!
result
(list (host-get attr "name") (host-get attr "value"))))
(loop (+ i 1))))))
result)))
(define
dom-remove-child
(fn
(parent child)
(when (and parent child) (host-call parent "removeChild" child))))
(define
dom-replace-child
(fn
(parent new-child old-child)
(when
(and parent new-child old-child)
(host-call parent "replaceChild" new-child old-child))))
(define
dom-clone
(fn
(node deep)
(host-call node "cloneNode" (if (nil? deep) true deep))))
(define
dom-query
(fn
(root-or-sel sel)
(if
(nil? sel)
(host-call (dom-document) "querySelector" root-or-sel)
(host-call root-or-sel "querySelector" sel))))
(define
dom-query-all
(fn
(root sel)
"Query DOM and return an SX list (not a host NodeList)."
(let
((node-list (if (nil? sel) (host-call (dom-document) "querySelectorAll" root) (host-call root "querySelectorAll" sel))))
(if
(nil? node-list)
(list)
(let
((n (host-get node-list "length")) (result (list)))
(let
loop
((i 0))
(when
(< i n)
(append! result (host-call node-list "item" i))
(loop (+ i 1))))
result)))))
(define
dom-query-by-id
(fn (id) (host-call (dom-document) "getElementById" id)))
(define
dom-closest
(fn (el sel) (when el (host-call el "closest" sel))))
(define
dom-matches?
(fn
(el sel)
(if
(and el (host-get el "matches"))
(host-call el "matches" sel)
false)))
(define
dom-get-attr
(fn
(el name)
(if
(and el (host-get el "getAttribute"))
(let
((v (host-call el "getAttribute" name)))
(if (nil? v) nil v))
nil)))
(define
dom-set-attr
(fn
(el name val)
(when
(and el (host-get el "setAttribute"))
(host-call el "setAttribute" name val))))
(define
dom-remove-attr
(fn
(el name)
(when
(and el (host-get el "removeAttribute"))
(host-call el "removeAttribute" name))))
(define
dom-has-attr?
(fn
(el name)
(if
(and el (host-get el "hasAttribute"))
(host-call el "hasAttribute" name)
false)))
(define
dom-add-class
(fn
(el cls)
(when el (host-call (host-get el "classList") "add" cls))))
(define
dom-remove-class
(fn
(el cls)
(when el (host-call (host-get el "classList") "remove" cls))))
(define
dom-has-class?
(fn
(el cls)
(if el (host-call (host-get el "classList") "contains" cls) false)))
(define dom-text-content (fn (el) (host-get el "textContent")))
(define
dom-set-text-content
(fn (el val) (host-set! el "textContent" val)))
(define dom-inner-html (fn (el) (host-get el "innerHTML")))
(define dom-set-inner-html (fn (el val) (host-set! el "innerHTML" val)))
(define dom-outer-html (fn (el) (host-get el "outerHTML")))
(define
dom-insert-adjacent-html
(fn
(el position html)
(host-call el "insertAdjacentHTML" position html)))
(define
dom-get-style
(fn (el prop) (host-get (host-get el "style") prop)))
(define
dom-set-style
(fn
(el prop val)
(host-call (host-get el "style") "setProperty" prop val)))
(define dom-get-prop (fn (el name) (host-get el name)))
(define dom-set-prop (fn (el name val) (host-set! el name val)))
(define
dom-tag-name
(fn (el) (if el (lower (or (host-get el "tagName") "")) "")))
(define dom-node-type (fn (el) (host-get el "nodeType")))
(define dom-node-name (fn (el) (host-get el "nodeName")))
(define dom-id (fn (el) (host-get el "id")))
(define dom-parent (fn (el) (host-get el "parentNode")))
(define dom-first-child (fn (el) (host-get el "firstChild")))
(define dom-next-sibling (fn (el) (host-get el "nextSibling")))
(define
dom-child-list
(fn
(el)
"Return child nodes as an SX list."
(if
el
(let
((nl (host-get el "childNodes"))
(n (host-get nl "length"))
(result (list)))
(let
loop
((i 0))
(when
(< i n)
(append! result (host-call nl "item" i))
(loop (+ i 1))))
result)
(list))))
(define dom-is-fragment? (fn (el) (= (host-get el "nodeType") 11)))
(define
dom-child-nodes
(fn
(el)
"Return child nodes as an SX list."
(if
el
(let
((nl (host-get el "childNodes"))
(n (host-get nl "length"))
(result (list)))
(let
loop
((i 0))
(when
(< i n)
(append! result (host-call nl "item" i))
(loop (+ i 1))))
result)
(list))))
(define
dom-remove-children-after
(fn
(marker)
"Remove all siblings after marker node."
(let
((parent (dom-parent marker)))
(when
parent
(let
loop
()
(let
((next (dom-next-sibling marker)))
(when next (host-call parent "removeChild" next) (loop))))))))
(define dom-focus (fn (el) (when el (host-call el "focus"))))
(define
dom-parse-html
(fn
(html)
(let
((parser (host-new "DOMParser"))
(doc (host-call parser "parseFromString" html "text/html")))
(host-get (host-get doc "body") "childNodes"))))
(define
dom-listen
(fn
(el event-name handler)
(let
((cb (host-callback handler)))
(host-call el "addEventListener" event-name cb)
(fn () (host-call el "removeEventListener" event-name cb)))))
(define
dom-add-listener
(fn
(el event-name handler opts)
(let
((cb (host-callback handler)))
(if
opts
(host-call el "addEventListener" event-name cb opts)
(host-call el "addEventListener" event-name cb))
(fn () (host-call el "removeEventListener" event-name cb)))))
(define
dom-dispatch
(fn
(el event-name detail)
(let
((evt (host-new "CustomEvent" event-name (dict "detail" detail "bubbles" true))))
(host-call el "dispatchEvent" evt))))
(define event-detail (fn (evt) (host-get evt "detail")))
(define
prevent-default
(fn (e) (when e (host-call e "preventDefault"))))
(define
stop-propagation
(fn (e) (when e (host-call e "stopPropagation"))))
(define
event-modifier-key?
(fn
(e)
(and
e
(or
(host-get e "ctrlKey")
(host-get e "metaKey")
(host-get e "shiftKey")
(host-get e "altKey")))))
(define
element-value
(fn
(el)
(if
(and el (not (nil? (host-get el "value"))))
(host-get el "value")
nil)))
(define
error-message
(fn
(e)
(if (and e (host-get e "message")) (host-get e "message") (str e))))
(define
dom-get-data
(fn
(el key)
(let
((store (host-get el "__sx_data")))
(if store (host-get store key) nil))))
(define
dom-set-data
(fn
(el key val)
(when
(not (host-get el "__sx_data"))
(host-set! el "__sx_data" (host-new "Object")))
(host-set! (host-get el "__sx_data") key val)))
(define
dom-append-to-head
(fn (el) (when (dom-head) (host-call (dom-head) "appendChild" el))))
(define
set-document-title
(fn (title) (host-set! (dom-document) "title" title)))))
;; Re-export to global env
(define
dom-visible?
(fn
(el)
(if
el
(not (= (host-get (host-get el "style") "display") "none"))
false)))
(import (sx dom))
Reference in New Issue View Git Blame Copy Permalink