coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
0c8c0b64261c19b639e8c1e89b5212beafa58dac
rose-ash/shared/static/wasm/sx/dom.sx
giles 07bbcaf1bb OCaml VM browser: safe equality, thunk trampolining, platform functions, nav pipeline 
Core runtime fixes:
- Safe equality (=, !=): physical equality for dicts/lambdas/signals,
  structural only for acyclic types. Prevents infinite loops on circular
  signal subscriber chains.
- contains?: same safe comparison (physical first, structural for simple types)
- Thunk trampolining in as_number and to_string: leaked thunks auto-resolve
  instead of showing <thunk> or erroring "Expected number, got thunk"
- Diagnostic first error: shows actual type received

Island hydration fixes:
- adapter-dom.sx: skip scope-emit for spreads inside islands (was tripling classes)
- schedule-idle: wrap callback to absorb requestIdleCallback deadline arg
- home-stepper: remove spread-specific highlighting (all tokens same style per step)

Platform functions (boot-helpers.sx):
- fetch-request: 3-arg interface (config, success-fn, error-fn) with promise chain
- build-request-body: form serialization for GET/POST
- strip-component-scripts / extract-response-css: SX text processing
- Navigation: bind-boost-link, bind-client-route-click via execute-request
- Loading state: show-indicator, disable-elements, clear-loading-state
- DOM extras: dom-remove, dom-attr-list (name/value pairs), dom-child-list (SX list),
  dom-is-active-element?, dom-is-input-element?, dom-is-child-of?, dom-on,
  dom-parse-html-document, dom-body-inner-html, create-script-clone
- All remaining stubs: csrf-token, loaded-component-names, observe-intersection,
  event-source-connect/listen, with-transition, cross-origin?, etc.

Navigation pipeline:
- browser-push-state/replace-state: accept 1-arg (URL only) or 3-arg
- boot.sx: wire popstate listener to handle-popstate
- URL updates working via handle-history + pushState fix

Morph debugging (WIP):
- dom-child-list returns proper SX list (was JS Array)
- dom-query accepts optional root element for scoped queries
- Navigation fetches and renders SX responses, URL updates, but morph
  doesn't replace content div (investigating dom-child-list on new elements)

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
2026-03-25 12:57:24 +00:00

430 lines
12 KiB
Plaintext
Raw Blame History

;; ==========================================================================
;; dom.sx — DOM library functions
;;
;; All DOM operations expressed using the host FFI primitives:
;; host-get — read property from host object
;; host-set! — write property on host object
;; host-call — call method on host object
;; host-new — construct host object
;; host-global — access global (window/document/etc.)
;; host-callback — wrap SX function as host callback
;; host-typeof — check host object type
;;
;; These are LIBRARY FUNCTIONS — portable, auditable, in-band SX.
;; ==========================================================================
;; --------------------------------------------------------------------------
;; Globals
;; --------------------------------------------------------------------------
(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")))
;; --------------------------------------------------------------------------
;; Node creation
;; --------------------------------------------------------------------------
(define dom-create-element
(fn (tag &rest ns-arg)
(let ((ns (if (and ns-arg (not (empty? ns-arg))) (first ns-arg) nil)))
(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 ""))))
;; --------------------------------------------------------------------------
;; Tree manipulation
;; --------------------------------------------------------------------------
(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-on
(fn (el event-name handler)
(host-call el "addEventListener" event-name (host-callback handler))))
(define dom-attr-list
(fn (el)
;; Return list of (name value) pairs for all attributes on the element.
(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))))
;; --------------------------------------------------------------------------
;; Queries
;; --------------------------------------------------------------------------
(define dom-query
(fn (root-or-sel &rest rest)
(if (empty? rest)
;; Single arg: selector on document
(host-call (dom-document) "querySelector" root-or-sel)
;; Two args: root element + selector
(host-call root-or-sel "querySelector" (first rest)))))
(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))))
;; Convert NodeList → SX list by indexing
(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)))
;; --------------------------------------------------------------------------
;; Attributes
;; --------------------------------------------------------------------------
(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)))
;; --------------------------------------------------------------------------
;; Classes
;; --------------------------------------------------------------------------
(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)))
;; --------------------------------------------------------------------------
;; Content
;; --------------------------------------------------------------------------
(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)))
;; --------------------------------------------------------------------------
;; Style & properties
;; --------------------------------------------------------------------------
(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)))
;; --------------------------------------------------------------------------
;; Node info
;; --------------------------------------------------------------------------
(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"))))
;; --------------------------------------------------------------------------
;; Events
;; --------------------------------------------------------------------------
(define dom-listen
(fn (el event-name handler)
(let ((cb (host-callback handler)))
(host-call el "addEventListener" event-name cb)
;; Return cleanup function
(fn () (host-call el "removeEventListener" event-name cb)))))
;; dom-add-listener — addEventListener with optional options
;; Used by orchestration.sx: (dom-add-listener el event handler opts)
(define dom-add-listener
(fn (el event-name handler &rest opts)
(let ((cb (host-callback handler)))
(if (and opts (not (empty? opts)))
(host-call el "addEventListener" event-name cb (first opts))
(host-call el "addEventListener" event-name cb))
;; Return cleanup function
(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))))
;; --------------------------------------------------------------------------
;; DOM data storage
;; --------------------------------------------------------------------------
(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" (dict)))
(host-set! (host-get el "__sx_data") key val)))
;; --------------------------------------------------------------------------
;; Head manipulation
;; --------------------------------------------------------------------------
(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)))
Reference in New Issue View Git Blame Copy Permalink