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>
This commit is contained in:
1366
shared/static/wasm/sx/adapter-dom.sx
Normal file
1366
shared/static/wasm/sx/adapter-dom.sx
Normal file
File diff suppressed because it is too large
Load Diff
696
shared/static/wasm/sx/boot-helpers.sx
Normal file
696
shared/static/wasm/sx/boot-helpers.sx
Normal file
@@ -0,0 +1,696 @@
|
||||
;; boot-helpers.sx — Platform helpers for boot/orchestration/engine
|
||||
;;
|
||||
;; These were JS-native functions in the transpiled bundle. Now pure SX
|
||||
;; built on the 8 FFI host primitives + dom.sx/browser.sx.
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Processing markers — track which DOM elements have been bound/hydrated
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define _sx-bound-prefix "_sxBound")
|
||||
|
||||
(define mark-processed!
|
||||
(fn (el key)
|
||||
(host-set! el (str _sx-bound-prefix key) true)))
|
||||
|
||||
(define is-processed?
|
||||
(fn (el key)
|
||||
(let ((v (host-get el (str _sx-bound-prefix key))))
|
||||
(if v true false))))
|
||||
|
||||
(define clear-processed!
|
||||
(fn (el key)
|
||||
(host-set! el (str _sx-bound-prefix key) nil)))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Callable check
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define callable?
|
||||
(fn (v)
|
||||
(let ((t (type-of v)))
|
||||
(or (= t "lambda") (= t "native-fn") (= t "continuation")))))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; String helpers
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define to-kebab
|
||||
(fn (s)
|
||||
"Convert camelCase to kebab-case."
|
||||
(let ((result (list))
|
||||
(i 0))
|
||||
(let loop ((i 0))
|
||||
(when (< i (len s))
|
||||
(let ((ch (nth s i)))
|
||||
(if (and (>= ch "A") (<= ch "Z"))
|
||||
(do
|
||||
(when (> i 0) (append! result "-"))
|
||||
(append! result (lower ch)))
|
||||
(append! result ch))
|
||||
(loop (+ i 1)))))
|
||||
(join "" result))))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Component / rendering helpers
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define sx-load-components
|
||||
(fn (text)
|
||||
"Parse and evaluate component definitions from text."
|
||||
(when (and text (> (len text) 0))
|
||||
(let ((exprs (sx-parse text)))
|
||||
(for-each (fn (expr) (cek-eval expr)) exprs)))))
|
||||
|
||||
(define call-expr
|
||||
(fn (expr-text &rest env-bindings)
|
||||
"Parse and evaluate an SX expression string."
|
||||
(let ((exprs (sx-parse expr-text)))
|
||||
(when (not (empty? exprs))
|
||||
(cek-eval (first exprs))))))
|
||||
|
||||
(define base-env
|
||||
(fn ()
|
||||
"Return the current global environment."
|
||||
(global-env)))
|
||||
|
||||
(define get-render-env
|
||||
(fn (&rest extra)
|
||||
"Get the rendering environment (global env, optionally merged with extra)."
|
||||
(let ((env (global-env)))
|
||||
(if (and extra (not (nil? (first extra))) (not (empty? extra)))
|
||||
(env-merge env (first extra))
|
||||
env))))
|
||||
|
||||
(define merge-envs
|
||||
(fn (a b)
|
||||
"Merge two environments."
|
||||
(if (and a b)
|
||||
(env-merge a b)
|
||||
(or a b (global-env)))))
|
||||
|
||||
(define sx-render-with-env
|
||||
(fn (source extra-env)
|
||||
"Parse SX source and render to DOM fragment."
|
||||
(let ((doc (host-global "document"))
|
||||
(frag (host-call doc "createDocumentFragment"))
|
||||
(exprs (sx-parse source)))
|
||||
(for-each (fn (expr)
|
||||
(let ((html (render-to-html expr)))
|
||||
(when (and html (> (len html) 0))
|
||||
(let ((temp (host-call doc "createElement" "template")))
|
||||
(host-set! temp "innerHTML" html)
|
||||
(host-call frag "appendChild" (host-get temp "content"))))))
|
||||
exprs)
|
||||
frag)))
|
||||
|
||||
(define parse-env-attr
|
||||
(fn (el)
|
||||
"Parse data-sx-env attribute (JSON key-value pairs)."
|
||||
nil))
|
||||
|
||||
(define store-env-attr
|
||||
(fn (el base new-env)
|
||||
nil))
|
||||
|
||||
(define resolve-mount-target
|
||||
(fn (target)
|
||||
"Resolve a CSS selector string to a DOM element."
|
||||
(if (string? target)
|
||||
(dom-query target)
|
||||
target)))
|
||||
|
||||
(define remove-head-element
|
||||
(fn (sel)
|
||||
"Remove a <head> element matching selector."
|
||||
(let ((el (dom-query sel)))
|
||||
(when el
|
||||
(dom-remove el)))))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Cookie helpers for component caching
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define set-sx-comp-cookie
|
||||
(fn (hash)
|
||||
(set-cookie "sx-components" hash)))
|
||||
|
||||
(define clear-sx-comp-cookie
|
||||
(fn ()
|
||||
(set-cookie "sx-components" "")))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Logging
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define log-parse-error
|
||||
(fn (label text err)
|
||||
(log-error (str "Parse error in " label ": " err))))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Validation stub (orchestration.sx needs this)
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Loaded component tracking
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Returns names of components/islands loaded client-side.
|
||||
;; build-request-headers uses a DOM hash instead of this list,
|
||||
;; and deps-satisfied? falls back to server fetch when empty.
|
||||
|
||||
(define loaded-component-names
|
||||
(fn ()
|
||||
;; Scan data-components script tags for loaded component names
|
||||
(let ((scripts (dom-query-all (dom-body) "script[data-components]"))
|
||||
(names (list)))
|
||||
(for-each (fn (script)
|
||||
(let ((text (or (dom-get-attr script "data-components") "")))
|
||||
(when (> (len text) 0)
|
||||
(for-each (fn (name)
|
||||
(when (> (len (trim name)) 0)
|
||||
(append! names (trim name))))
|
||||
(split text ",")))))
|
||||
scripts)
|
||||
names)))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; CSRF token
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define csrf-token
|
||||
(fn ()
|
||||
(let ((meta (dom-query "meta[name=\"csrf-token\"]")))
|
||||
(if meta (dom-get-attr meta "content") nil))))
|
||||
|
||||
(define validate-for-request
|
||||
(fn (el) true))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Request body builder
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; For GET/HEAD: no body. If element is a form, serialize inputs as query params.
|
||||
;; For POST/PUT/etc: if element is a form, build FormData body.
|
||||
;; Returns dict with "url", "body", "content-type".
|
||||
|
||||
(define build-request-body
|
||||
(fn (el method url)
|
||||
(let ((m (upper method)))
|
||||
(if (or (= m "GET") (= m "HEAD"))
|
||||
;; GET/HEAD — serialize form inputs into URL query params
|
||||
(if (and el (= (upper (or (dom-tag-name el) "")) "FORM"))
|
||||
(let ((fd (host-new "FormData" el))
|
||||
(params (host-new "URLSearchParams" fd))
|
||||
(qs (host-call params "toString")))
|
||||
(dict "url" (if (and qs (> (len qs) 0))
|
||||
(str url (if (contains? url "?") "&" "?") qs)
|
||||
url)
|
||||
"body" nil
|
||||
"content-type" nil))
|
||||
(dict "url" url "body" nil "content-type" nil))
|
||||
;; POST/PUT/etc — build form body if element is a form
|
||||
(if (and el (= (upper (or (dom-tag-name el) "")) "FORM"))
|
||||
(let ((enctype (or (dom-get-attr el "enctype") "application/x-www-form-urlencoded")))
|
||||
(if (= enctype "multipart/form-data")
|
||||
;; Multipart: let browser set Content-Type with boundary
|
||||
(let ((fd (host-new "FormData" el)))
|
||||
(dict "url" url "body" fd "content-type" nil))
|
||||
;; URL-encoded
|
||||
(let ((fd (host-new "FormData" el))
|
||||
(params (host-new "URLSearchParams" fd)))
|
||||
(dict "url" url
|
||||
"body" (host-call params "toString")
|
||||
"content-type" "application/x-www-form-urlencoded"))))
|
||||
;; Not a form — no body
|
||||
(dict "url" url "body" nil "content-type" nil))))))
|
||||
|
||||
(define abort-previous-target (fn (el) nil))
|
||||
(define abort-previous (fn (el) nil))
|
||||
(define track-controller (fn (el ctrl) nil))
|
||||
(define track-controller-target (fn (el ctrl) nil))
|
||||
(define new-abort-controller (fn () (host-new "AbortController")))
|
||||
(define abort-signal (fn (ctrl) (host-get ctrl "signal")))
|
||||
(define apply-optimistic (fn (el) nil))
|
||||
(define revert-optimistic (fn (el) nil))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; DOM query helpers (used by boot.sx)
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define dom-has-attr?
|
||||
(fn (el name)
|
||||
(host-call el "hasAttribute" name)))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Loading state (indicators, disabling)
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define show-indicator
|
||||
(fn (el)
|
||||
;; Show loading indicator. Returns indicator state for cleanup.
|
||||
(let ((indicator-sel (dom-get-attr el "sx-indicator")))
|
||||
(when indicator-sel
|
||||
(let ((indicator (dom-query indicator-sel)))
|
||||
(when indicator
|
||||
(dom-remove-class indicator "hidden")
|
||||
(dom-add-class indicator "sx-indicator-visible"))))
|
||||
indicator-sel)))
|
||||
|
||||
(define disable-elements
|
||||
(fn (el)
|
||||
;; Disable elements during request. Returns list of disabled elements.
|
||||
(let ((disable-sel (dom-get-attr el "sx-disabled-elt")))
|
||||
(if disable-sel
|
||||
(let ((elts (dom-query-all (dom-body) disable-sel)))
|
||||
(for-each (fn (e) (dom-set-attr e "disabled" "")) elts)
|
||||
elts)
|
||||
(list)))))
|
||||
|
||||
(define clear-loading-state
|
||||
(fn (el indicator disabled-elts)
|
||||
;; Reverse loading state: hide indicator, re-enable elements
|
||||
(dom-remove-class el "sx-request")
|
||||
(dom-remove-attr el "aria-busy")
|
||||
(when indicator
|
||||
(let ((ind (dom-query indicator)))
|
||||
(when ind
|
||||
(dom-add-class ind "hidden")
|
||||
(dom-remove-class ind "sx-indicator-visible"))))
|
||||
(when disabled-elts
|
||||
(for-each (fn (e) (dom-remove-attr e "disabled")) disabled-elts))))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Abort / error helpers
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define abort-error?
|
||||
(fn (err)
|
||||
(= (host-get err "name") "AbortError")))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Promise helpers
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define promise-catch
|
||||
(fn (p f)
|
||||
(let ((cb (host-callback f)))
|
||||
(host-call p "catch" cb))))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Fetch helpers
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
;; Override browser.sx's raw fetch-request with the higher-level interface
|
||||
;; that orchestration expects: (fetch-request config success-fn error-fn)
|
||||
;; config: dict with url, method, headers, body, signal, cross-origin, preloaded
|
||||
;; success-fn: (fn (resp-ok status get-header text) ...)
|
||||
;; error-fn: (fn (err) ...)
|
||||
(define fetch-request
|
||||
(fn (config success-fn error-fn)
|
||||
(let ((url (get config "url"))
|
||||
(method (or (get config "method") "GET"))
|
||||
(headers (or (get config "headers") (dict)))
|
||||
(body (get config "body"))
|
||||
(signal (get config "signal"))
|
||||
(preloaded (get config "preloaded")))
|
||||
;; If preloaded content is available, use it directly
|
||||
(if preloaded
|
||||
(success-fn true 200 (fn (name) nil) preloaded)
|
||||
;; Build fetch options as plain JS object
|
||||
(let ((h (host-new "Headers"))
|
||||
(js-opts (host-new "Object")))
|
||||
(for-each (fn (k)
|
||||
(host-call h "set" k (get headers k)))
|
||||
(keys headers))
|
||||
(host-set! js-opts "method" method)
|
||||
(host-set! js-opts "headers" h)
|
||||
(when body (host-set! js-opts "body" body))
|
||||
(when signal (host-set! js-opts "signal" signal))
|
||||
;; Execute fetch
|
||||
(promise-then
|
||||
(host-call (dom-window) "fetch" url js-opts)
|
||||
(fn (response)
|
||||
(let ((ok (host-get response "ok"))
|
||||
(status (host-get response "status"))
|
||||
(get-header (fn (name) (host-call (host-get response "headers") "get" name))))
|
||||
(promise-then
|
||||
(host-call response "text")
|
||||
(fn (text) (success-fn ok status get-header text))
|
||||
error-fn)))
|
||||
error-fn))))))
|
||||
|
||||
(define fetch-location
|
||||
(fn (url)
|
||||
;; Navigate to URL via fetch + swap into boost target
|
||||
(let ((target (or (dom-query "[sx-boost]") (dom-query "#main-panel"))))
|
||||
(when target
|
||||
(browser-navigate url)))))
|
||||
|
||||
(define fetch-and-restore
|
||||
(fn (main url headers scroll-y)
|
||||
;; Popstate: fetch URL, swap into main, restore scroll
|
||||
(fetch-request
|
||||
(dict "url" url "method" "GET" "headers" headers "body" nil "signal" nil)
|
||||
(fn (resp-ok status get-header text)
|
||||
(when resp-ok
|
||||
(dom-set-inner-html main text)
|
||||
(post-swap main)
|
||||
(host-call (dom-window) "scrollTo" 0 scroll-y)))
|
||||
(fn (err) (log-warn (str "fetch-and-restore error: " err))))))
|
||||
|
||||
(define fetch-preload
|
||||
(fn (url headers cache)
|
||||
;; Preload URL into cache dict
|
||||
(fetch-request
|
||||
(dict "url" url "method" "GET" "headers" headers "body" nil "signal" nil)
|
||||
(fn (resp-ok status get-header text)
|
||||
(when resp-ok
|
||||
(preload-cache-set cache url text)))
|
||||
(fn (err) nil))))
|
||||
|
||||
(define fetch-streaming
|
||||
(fn (target pathname headers swap-fn)
|
||||
;; Streaming fetch — fallback to non-streaming
|
||||
(fetch-and-restore target pathname headers 0)))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; DOM extras
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define dom-parse-html-document
|
||||
(fn (text)
|
||||
(let ((parser (host-new "DOMParser")))
|
||||
(host-call parser "parseFromString" text "text/html"))))
|
||||
|
||||
(define dom-body-inner-html
|
||||
(fn (doc)
|
||||
(host-get (host-get doc "body") "innerHTML")))
|
||||
|
||||
(define create-script-clone
|
||||
(fn (dead)
|
||||
(let ((doc (host-global "document"))
|
||||
(live (host-call doc "createElement" "script")))
|
||||
;; Copy attributes
|
||||
(let ((attrs (host-get dead "attributes")))
|
||||
(let loop ((i 0))
|
||||
(when (< i (host-get attrs "length"))
|
||||
(let ((attr (host-call attrs "item" i)))
|
||||
(host-call live "setAttribute"
|
||||
(host-get attr "name") (host-get attr "value"))
|
||||
(loop (+ i 1))))))
|
||||
;; Copy content
|
||||
(host-set! live "textContent" (host-get dead "textContent"))
|
||||
live)))
|
||||
|
||||
(define cross-origin?
|
||||
(fn (url)
|
||||
(if (or (starts-with? url "http://") (starts-with? url "https://"))
|
||||
(not (starts-with? url (browser-location-origin)))
|
||||
false)))
|
||||
|
||||
(define browser-scroll-to
|
||||
(fn (x y)
|
||||
(host-call (dom-window) "scrollTo" x y)))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; View transitions
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define with-transition
|
||||
(fn (enabled thunk)
|
||||
(if (and enabled (host-get (host-global "document") "startViewTransition"))
|
||||
(host-call (host-global "document") "startViewTransition"
|
||||
(host-callback thunk))
|
||||
(thunk))))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; IntersectionObserver
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define observe-intersection
|
||||
(fn (el callback once? delay)
|
||||
(let ((cb (host-callback
|
||||
(fn (entries)
|
||||
(for-each (fn (entry)
|
||||
(when (host-get entry "isIntersecting")
|
||||
(if delay
|
||||
(set-timeout (fn () (callback entry)) delay)
|
||||
(callback entry))
|
||||
(when once?
|
||||
(host-call observer "unobserve" el))))
|
||||
(host-call entries "forEach" (host-callback (fn (e) e))))))))
|
||||
;; Direct approach: create observer that calls back for each entry
|
||||
(let ((observer (host-new "IntersectionObserver"
|
||||
(host-callback (fn (entries)
|
||||
(let ((arr-len (host-get entries "length")))
|
||||
(let loop ((i 0))
|
||||
(when (< i arr-len)
|
||||
(let ((entry (host-call entries "item" i)))
|
||||
(when (and entry (host-get entry "isIntersecting"))
|
||||
(if delay
|
||||
(set-timeout (fn () (callback entry)) delay)
|
||||
(callback entry))
|
||||
(when once?
|
||||
(host-call observer "unobserve" el))))
|
||||
(loop (+ i 1))))))))))
|
||||
(host-call observer "observe" el)
|
||||
observer))))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; EventSource (SSE)
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define event-source-connect
|
||||
(fn (url el)
|
||||
(let ((source (host-new "EventSource" url)))
|
||||
(host-set! source "_sxElement" el)
|
||||
source)))
|
||||
|
||||
(define event-source-listen
|
||||
(fn (source event-name handler)
|
||||
(host-call source "addEventListener" event-name
|
||||
(host-callback (fn (e) (handler e))))))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Boost bindings
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define bind-boost-link
|
||||
(fn (el href)
|
||||
(dom-listen el "click"
|
||||
(fn (e)
|
||||
(when (not (event-modifier-key? e))
|
||||
(prevent-default e)
|
||||
;; Set verb attrs so execute-request can process this as a GET
|
||||
(when (not (dom-has-attr? el "sx-get"))
|
||||
(dom-set-attr el "sx-get" href))
|
||||
(when (not (dom-has-attr? el "sx-push-url"))
|
||||
(dom-set-attr el "sx-push-url" "true"))
|
||||
(execute-request el nil nil))))))
|
||||
|
||||
(define bind-boost-form
|
||||
(fn (form method action)
|
||||
(dom-listen form "submit"
|
||||
(fn (e)
|
||||
(prevent-default e)
|
||||
(execute-request form nil nil)))))
|
||||
|
||||
(define bind-client-route-click
|
||||
(fn (link href fallback-fn)
|
||||
(dom-listen link "click"
|
||||
(fn (e)
|
||||
(when (not (event-modifier-key? e))
|
||||
(prevent-default e)
|
||||
;; Try client routing first, fall back to server fetch
|
||||
(let ((boost-el (dom-query "[sx-boost]"))
|
||||
(target-sel (if boost-el
|
||||
(let ((attr (dom-get-attr boost-el "sx-boost")))
|
||||
(if (and attr (not (= attr "true"))) attr "#main-panel"))
|
||||
"#main-panel")))
|
||||
(if (try-client-route (url-pathname href) target-sel)
|
||||
(do
|
||||
(browser-push-state nil "" href)
|
||||
(browser-scroll-to 0 0))
|
||||
;; Fallback: server fetch via execute-request
|
||||
(do
|
||||
(when (not (dom-has-attr? link "sx-get"))
|
||||
(dom-set-attr link "sx-get" href))
|
||||
(when (not (dom-has-attr? link "sx-push-url"))
|
||||
(dom-set-attr link "sx-push-url" "true"))
|
||||
(execute-request link nil nil)))))))))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Service worker
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define sw-post-message (fn (msg) nil))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Response processing (fetch/swap pipeline)
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define try-parse-json
|
||||
(fn (text)
|
||||
(json-parse text)))
|
||||
|
||||
(define strip-component-scripts
|
||||
(fn (text)
|
||||
;; Remove <script data-components>...</script> from response text.
|
||||
;; The text may be SX (not valid HTML), so use string matching.
|
||||
;; First, load the component definitions into the environment.
|
||||
(let ((result text)
|
||||
(start-tag "<script type=\"text/sx\" data-components>")
|
||||
(end-tag "</script>"))
|
||||
;; Find and extract component scripts
|
||||
(let loop ((s result))
|
||||
(let ((start-idx (index-of s start-tag)))
|
||||
(if (= start-idx -1)
|
||||
(set! result s)
|
||||
(let ((after-start (+ start-idx (len start-tag)))
|
||||
(rest-str (slice s (+ start-idx (len start-tag)))))
|
||||
(let ((end-offset (index-of rest-str end-tag)))
|
||||
(if (= end-offset -1)
|
||||
(set! result s)
|
||||
(let ((comp-text (slice rest-str 0 end-offset))
|
||||
(before (slice s 0 start-idx))
|
||||
(after (slice rest-str (+ end-offset (len end-tag)))))
|
||||
;; Load component definitions
|
||||
(sx-load-components comp-text)
|
||||
(loop (str before after)))))))))
|
||||
result)))
|
||||
|
||||
(define extract-response-css
|
||||
(fn (text)
|
||||
;; Extract <style data-sx-css>...</style> tags from response text.
|
||||
;; Apply them to the document head, return remaining text.
|
||||
(let ((result text)
|
||||
(start-tag "<style data-sx-css>")
|
||||
(end-tag "</style>"))
|
||||
(let loop ((s result))
|
||||
(let ((start-idx (index-of s start-tag)))
|
||||
(if (= start-idx -1)
|
||||
(set! result s)
|
||||
(let ((rest-str (slice s (+ start-idx (len start-tag)))))
|
||||
(let ((end-offset (index-of rest-str end-tag)))
|
||||
(if (= end-offset -1)
|
||||
(set! result s)
|
||||
(let ((css-text (slice rest-str 0 end-offset))
|
||||
(before (slice s 0 start-idx))
|
||||
(after (slice rest-str (+ end-offset (len end-tag)))))
|
||||
;; Apply CSS to head
|
||||
(let ((doc (host-global "document"))
|
||||
(style-el (host-call doc "createElement" "style")))
|
||||
(host-set! style-el "textContent" css-text)
|
||||
(dom-append-to-head style-el))
|
||||
(loop (str before after)))))))))
|
||||
result)))
|
||||
|
||||
(define sx-render
|
||||
(fn (text)
|
||||
;; Parse SX text and render to a DOM fragment.
|
||||
(let ((doc (host-global "document"))
|
||||
(frag (host-call doc "createDocumentFragment"))
|
||||
(exprs (sx-parse text)))
|
||||
(for-each (fn (expr)
|
||||
(let ((result (render-to-dom expr (get-render-env nil) nil)))
|
||||
(when result (dom-append frag result))))
|
||||
exprs)
|
||||
frag)))
|
||||
|
||||
(define sx-hydrate
|
||||
(fn (root)
|
||||
;; Hydrate data-sx elements in root (or document).
|
||||
(sx-hydrate-elements (or root (dom-body)))))
|
||||
|
||||
(define sx-process-scripts
|
||||
(fn (root)
|
||||
;; Find and evaluate <script type="text/sx"> in root.
|
||||
(let ((scripts (dom-query-all (or root (dom-body)) "script[type=\"text/sx\"]")))
|
||||
(for-each (fn (s)
|
||||
(when (not (is-processed? s "sx-script"))
|
||||
(mark-processed! s "sx-script")
|
||||
(let ((text (host-get s "textContent")))
|
||||
(when (and text (> (len text) 0))
|
||||
(let ((exprs (sx-parse text)))
|
||||
(for-each (fn (expr) (cek-eval expr)) exprs))))))
|
||||
scripts))))
|
||||
|
||||
(define select-from-container
|
||||
(fn (container selector)
|
||||
;; Select matching element from container, return it (not just children).
|
||||
(if selector
|
||||
(let ((selected (dom-query container selector)))
|
||||
(if selected
|
||||
selected
|
||||
(children-to-fragment container)))
|
||||
(children-to-fragment container))))
|
||||
|
||||
(define children-to-fragment
|
||||
(fn (el)
|
||||
;; Move all children of el into a DocumentFragment.
|
||||
(let ((doc (host-global "document"))
|
||||
(frag (host-call doc "createDocumentFragment")))
|
||||
(let loop ()
|
||||
(let ((child (dom-first-child el)))
|
||||
(when child
|
||||
(dom-append frag child)
|
||||
(loop))))
|
||||
frag)))
|
||||
|
||||
(define select-html-from-doc
|
||||
(fn (doc selector)
|
||||
;; Extract HTML from a parsed document, optionally selecting.
|
||||
(if selector
|
||||
(let ((el (dom-query doc selector)))
|
||||
(if el (dom-inner-html el) (dom-body-inner-html doc)))
|
||||
(dom-body-inner-html doc))))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Client routing stubs
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define find-matching-route
|
||||
(fn (pathname routes)
|
||||
;; Match pathname against registered page routes.
|
||||
;; Returns match dict or nil.
|
||||
nil))
|
||||
|
||||
(define parse-route-pattern (fn (pattern) nil))
|
||||
|
||||
(define register-io-deps (fn (deps) nil))
|
||||
|
||||
(define resolve-page-data
|
||||
(fn (page-name params &rest rest)
|
||||
nil))
|
||||
|
||||
(define parse-sx-data
|
||||
(fn (text)
|
||||
(if (and text (> (len text) 0))
|
||||
(let ((exprs (sx-parse text)))
|
||||
(if (not (empty? exprs)) (first exprs) nil))
|
||||
nil)))
|
||||
|
||||
(define try-eval-content
|
||||
(fn (content-src env)
|
||||
;; Evaluate SX content source to DOM.
|
||||
(let ((exprs (sx-parse content-src)))
|
||||
(if (empty? exprs)
|
||||
nil
|
||||
(let ((frag (create-fragment)))
|
||||
(for-each (fn (expr)
|
||||
(let ((result (render-to-dom expr env nil)))
|
||||
(when result (dom-append frag result))))
|
||||
exprs)
|
||||
frag)))))
|
||||
|
||||
(define try-async-eval-content
|
||||
(fn (content-src env &rest rest)
|
||||
;; Async variant — for now, delegate to sync.
|
||||
(try-eval-content content-src env)))
|
||||
|
||||
(define try-rerender-page (fn (&rest args) nil))
|
||||
(define execute-action (fn (&rest args) nil))
|
||||
(define bind-preload (fn (&rest args) nil))
|
||||
(define persist-offline-data (fn (&rest args) nil))
|
||||
(define retrieve-offline-data (fn (&rest args) nil))
|
||||
574
shared/static/wasm/sx/boot.sx
Normal file
574
shared/static/wasm/sx/boot.sx
Normal file
@@ -0,0 +1,574 @@
|
||||
;; ==========================================================================
|
||||
;; boot.sx — Browser boot, mount, hydrate, script processing
|
||||
;;
|
||||
;; Handles the browser startup lifecycle:
|
||||
;; 1. CSS tracking init
|
||||
;; 2. Component script processing (from <script type="text/sx">)
|
||||
;; 3. Hydration of [data-sx] elements
|
||||
;; 4. Engine element processing
|
||||
;;
|
||||
;; Also provides the public mounting/hydration API:
|
||||
;; mount, hydrate, update, render-component
|
||||
;;
|
||||
;; Depends on:
|
||||
;; orchestration.sx — process-elements, engine-init
|
||||
;; adapter-dom.sx — render-to-dom
|
||||
;; render.sx — shared registries
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Head element hoisting (full version)
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Moves <meta>, <title>, <link rel=canonical>, <script type=application/ld+json>
|
||||
;; from rendered content to <head>, deduplicating as needed.
|
||||
|
||||
(define HEAD_HOIST_SELECTOR
|
||||
"meta, title, link[rel='canonical'], script[type='application/ld+json']")
|
||||
|
||||
(define hoist-head-elements-full :effects [mutation io]
|
||||
(fn (root)
|
||||
(let ((els (dom-query-all root HEAD_HOIST_SELECTOR)))
|
||||
(for-each
|
||||
(fn (el)
|
||||
(let ((tag (lower (dom-tag-name el))))
|
||||
(cond
|
||||
;; <title> — replace document title
|
||||
(= tag "title")
|
||||
(do
|
||||
(set-document-title (dom-text-content el))
|
||||
(dom-remove-child (dom-parent el) el))
|
||||
|
||||
;; <meta> — deduplicate by name or property
|
||||
(= tag "meta")
|
||||
(do
|
||||
(let ((name (dom-get-attr el "name"))
|
||||
(prop (dom-get-attr el "property")))
|
||||
(when name
|
||||
(remove-head-element (str "meta[name=\"" name "\"]")))
|
||||
(when prop
|
||||
(remove-head-element (str "meta[property=\"" prop "\"]"))))
|
||||
(dom-remove-child (dom-parent el) el)
|
||||
(dom-append-to-head el))
|
||||
|
||||
;; <link rel=canonical> — deduplicate
|
||||
(and (= tag "link")
|
||||
(= (dom-get-attr el "rel") "canonical"))
|
||||
(do
|
||||
(remove-head-element "link[rel=\"canonical\"]")
|
||||
(dom-remove-child (dom-parent el) el)
|
||||
(dom-append-to-head el))
|
||||
|
||||
;; Everything else (ld+json, etc.) — just move
|
||||
:else
|
||||
(do
|
||||
(dom-remove-child (dom-parent el) el)
|
||||
(dom-append-to-head el)))))
|
||||
els))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Mount — render SX source into a DOM element
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define sx-mount :effects [mutation io]
|
||||
(fn (target (source :as string) (extra-env :as dict))
|
||||
;; Render SX source string into target element.
|
||||
;; target: Element or CSS selector string
|
||||
;; source: SX source string
|
||||
;; extra-env: optional extra bindings dict
|
||||
(let ((el (resolve-mount-target target)))
|
||||
(when el
|
||||
;; If the server already rendered content (isomorphic SSR),
|
||||
;; skip re-render — just hydrate the existing DOM.
|
||||
(when (empty? (dom-child-list el))
|
||||
(let ((node (sx-render-with-env source extra-env)))
|
||||
(dom-set-text-content el "")
|
||||
(dom-append el node)
|
||||
;; Hoist head elements from rendered content
|
||||
(hoist-head-elements-full el)))
|
||||
;; Process sx- attributes, hydrate data-sx and islands
|
||||
(process-elements el)
|
||||
(sx-hydrate-elements el)
|
||||
(sx-hydrate-islands el)
|
||||
(run-post-render-hooks)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Resolve Suspense — replace streaming placeholder with resolved content
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; Called by inline <script> tags that arrive during chunked transfer:
|
||||
;; __sxResolve("content", "(~article :title \"Hello\")")
|
||||
;;
|
||||
;; Finds the suspense wrapper by data-suspense attribute, renders the
|
||||
;; new SX content, and replaces the wrapper's children.
|
||||
|
||||
(define resolve-suspense :effects [mutation io]
|
||||
(fn ((id :as string) (sx :as string))
|
||||
;; Process any new <script type="text/sx"> tags that arrived via
|
||||
;; streaming (e.g. extra component defs) before resolving.
|
||||
(process-sx-scripts nil)
|
||||
(let ((el (dom-query (str "[data-suspense=\"" id "\"]"))))
|
||||
(if el
|
||||
(do
|
||||
;; parse returns a list of expressions — render each individually
|
||||
;; (mirroring the public render() API).
|
||||
(let ((exprs (parse sx))
|
||||
(env (get-render-env nil)))
|
||||
(dom-set-text-content el "")
|
||||
(for-each (fn (expr)
|
||||
(dom-append el (render-to-dom expr env nil)))
|
||||
exprs)
|
||||
(process-elements el)
|
||||
(sx-hydrate-elements el)
|
||||
(sx-hydrate-islands el)
|
||||
(run-post-render-hooks)
|
||||
(dom-dispatch el "sx:resolved" {:id id})))
|
||||
(log-warn (str "resolveSuspense: no element for id=" id))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Hydrate — render all [data-sx] elements
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define sx-hydrate-elements :effects [mutation io]
|
||||
(fn (root)
|
||||
;; Find all [data-sx] elements within root and render them.
|
||||
(let ((els (dom-query-all (or root (dom-body)) "[data-sx]")))
|
||||
(for-each
|
||||
(fn (el)
|
||||
(when (not (is-processed? el "hydrated"))
|
||||
(mark-processed! el "hydrated")
|
||||
(sx-update-element el nil)))
|
||||
els))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Update — re-render a [data-sx] element with new env data
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define sx-update-element :effects [mutation io]
|
||||
(fn (el new-env)
|
||||
;; Re-render a [data-sx] element.
|
||||
;; Reads source from data-sx attr, base env from data-sx-env attr.
|
||||
(let ((target (resolve-mount-target el)))
|
||||
(when target
|
||||
(let ((source (dom-get-attr target "data-sx")))
|
||||
(when source
|
||||
(let ((base-env (parse-env-attr target))
|
||||
(env (merge-envs base-env new-env)))
|
||||
(let ((node (sx-render-with-env source env)))
|
||||
(dom-set-text-content target "")
|
||||
(dom-append target node)
|
||||
;; Update stored env if new-env provided
|
||||
(when new-env
|
||||
(store-env-attr target base-env new-env))))))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Render component — build synthetic call from kwargs dict
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define sx-render-component :effects [mutation io]
|
||||
(fn ((name :as string) (kwargs :as dict) (extra-env :as dict))
|
||||
;; Render a named component with keyword args.
|
||||
;; name: component name (with or without ~ prefix)
|
||||
;; kwargs: dict of param-name → value
|
||||
;; extra-env: optional extra env bindings
|
||||
(let ((full-name (if (starts-with? name "~") name (str "~" name))))
|
||||
(let ((env (get-render-env extra-env))
|
||||
(comp (env-get env full-name)))
|
||||
(if (not (component? comp))
|
||||
(error (str "Unknown component: " full-name))
|
||||
;; Build synthetic call expression
|
||||
(let ((call-expr (list (make-symbol full-name))))
|
||||
(for-each
|
||||
(fn ((k :as string))
|
||||
(append! call-expr (make-keyword (to-kebab k)))
|
||||
(append! call-expr (dict-get kwargs k)))
|
||||
(keys kwargs))
|
||||
(render-to-dom call-expr env nil)))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Script processing — <script type="text/sx">
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define process-sx-scripts :effects [mutation io]
|
||||
(fn (root)
|
||||
;; Process all <script type="text/sx"> tags.
|
||||
;; - data-components + data-hash → localStorage cache
|
||||
;; - data-mount="<selector>" → render into target
|
||||
;; - Default: load as components
|
||||
(let ((scripts (query-sx-scripts root)))
|
||||
(for-each
|
||||
(fn (s)
|
||||
(when (not (is-processed? s "script"))
|
||||
(mark-processed! s "script")
|
||||
(let ((text (dom-text-content s)))
|
||||
(cond
|
||||
;; Component definitions
|
||||
(dom-has-attr? s "data-components")
|
||||
(process-component-script s text)
|
||||
|
||||
;; Empty script — skip
|
||||
(or (nil? text) (empty? (trim text)))
|
||||
nil
|
||||
|
||||
;; Init scripts — evaluate SX for side effects (event listeners etc.)
|
||||
(dom-has-attr? s "data-init")
|
||||
(let ((exprs (sx-parse text)))
|
||||
(for-each
|
||||
(fn (expr) (eval-expr expr (env-extend (dict))))
|
||||
exprs))
|
||||
|
||||
;; Mount directive
|
||||
(dom-has-attr? s "data-mount")
|
||||
(let ((mount-sel (dom-get-attr s "data-mount"))
|
||||
(target (dom-query mount-sel)))
|
||||
(when target
|
||||
(sx-mount target text nil)))
|
||||
|
||||
;; Default: load as components
|
||||
:else
|
||||
(sx-load-components text)))))
|
||||
scripts))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Component script with caching
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define process-component-script :effects [mutation io]
|
||||
(fn (script (text :as string))
|
||||
;; Handle <script type="text/sx" data-components data-hash="...">
|
||||
(let ((hash (dom-get-attr script "data-hash")))
|
||||
(if (nil? hash)
|
||||
;; Legacy: no hash — just load inline
|
||||
(when (and text (not (empty? (trim text))))
|
||||
(sx-load-components text))
|
||||
;; Hash-based caching
|
||||
(let ((has-inline (and text (not (empty? (trim text))))))
|
||||
(let ((cached-hash (local-storage-get "sx-components-hash")))
|
||||
(if (= cached-hash hash)
|
||||
;; Cache hit
|
||||
(if has-inline
|
||||
;; Server sent full source (cookie stale) — update cache
|
||||
(do
|
||||
(local-storage-set "sx-components-hash" hash)
|
||||
(local-storage-set "sx-components-src" text)
|
||||
(sx-load-components text)
|
||||
(log-info "components: downloaded (cookie stale)"))
|
||||
;; Server omitted source — load from cache
|
||||
(let ((cached (local-storage-get "sx-components-src")))
|
||||
(if cached
|
||||
(do
|
||||
(sx-load-components cached)
|
||||
(log-info (str "components: cached (" hash ")")))
|
||||
;; Cache entry missing — clear cookie and reload
|
||||
(do
|
||||
(clear-sx-comp-cookie)
|
||||
(browser-reload)))))
|
||||
;; Cache miss — hash mismatch
|
||||
(if has-inline
|
||||
;; Server sent full source — cache it
|
||||
(do
|
||||
(local-storage-set "sx-components-hash" hash)
|
||||
(local-storage-set "sx-components-src" text)
|
||||
(sx-load-components text)
|
||||
(log-info (str "components: downloaded (" hash ")")))
|
||||
;; Server omitted but cache stale — clear and reload
|
||||
(do
|
||||
(local-storage-remove "sx-components-hash")
|
||||
(local-storage-remove "sx-components-src")
|
||||
(clear-sx-comp-cookie)
|
||||
(browser-reload)))))
|
||||
(set-sx-comp-cookie hash))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Page registry for client-side routing
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define _page-routes (list))
|
||||
|
||||
(define process-page-scripts :effects [mutation io]
|
||||
(fn ()
|
||||
;; Process <script type="text/sx-pages"> tags.
|
||||
;; Parses SX page registry and builds route entries with parsed patterns.
|
||||
(let ((scripts (query-page-scripts)))
|
||||
(log-info (str "pages: found " (len scripts) " script tags"))
|
||||
(for-each
|
||||
(fn (s)
|
||||
(when (not (is-processed? s "pages"))
|
||||
(mark-processed! s "pages")
|
||||
(let ((text (dom-text-content s)))
|
||||
(log-info (str "pages: script text length=" (if text (len text) 0)))
|
||||
(if (and text (not (empty? (trim text))))
|
||||
(let ((pages (parse text)))
|
||||
(log-info (str "pages: parsed " (len pages) " entries"))
|
||||
(for-each
|
||||
(fn ((page :as dict))
|
||||
(append! _page-routes
|
||||
(merge page
|
||||
{"parsed" (parse-route-pattern (get page "path"))})))
|
||||
pages))
|
||||
(log-warn "pages: script tag is empty")))))
|
||||
scripts)
|
||||
(log-info (str "pages: " (len _page-routes) " routes loaded")))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Island hydration — activate reactive islands from SSR output
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; The server renders islands as:
|
||||
;; <div data-sx-island="counter" data-sx-state='{"initial": 0}'>
|
||||
;; ...static HTML...
|
||||
;; </div>
|
||||
;;
|
||||
;; Hydration:
|
||||
;; 1. Find all [data-sx-island] elements
|
||||
;; 2. Look up the island component by name
|
||||
;; 3. Parse data-sx-state into kwargs
|
||||
;; 4. Re-render the island body in a reactive context
|
||||
;; 5. Morph existing DOM to preserve structure, focus, scroll
|
||||
;; 6. Store disposers on the element for cleanup
|
||||
|
||||
(define sx-hydrate-islands :effects [mutation io]
|
||||
(fn (root)
|
||||
(let ((els (dom-query-all (or root (dom-body)) "[data-sx-island]")))
|
||||
(log-info (str "sx-hydrate-islands: " (len els) " island(s) in " (if root "subtree" "document")))
|
||||
(for-each
|
||||
(fn (el)
|
||||
(if (is-processed? el "island-hydrated")
|
||||
(log-info (str " skip (already hydrated): " (dom-get-attr el "data-sx-island")))
|
||||
(do
|
||||
(log-info (str " hydrating: " (dom-get-attr el "data-sx-island")))
|
||||
(mark-processed! el "island-hydrated")
|
||||
(hydrate-island el))))
|
||||
els))))
|
||||
|
||||
(define hydrate-island :effects [mutation io]
|
||||
(fn (el)
|
||||
(let ((name (dom-get-attr el "data-sx-island"))
|
||||
(state-sx (or (dom-get-attr el "data-sx-state") "{}")))
|
||||
(let ((comp-name (str "~" name))
|
||||
(env (get-render-env nil)))
|
||||
(let ((comp (env-get env comp-name)))
|
||||
(if (not (or (component? comp) (island? comp)))
|
||||
(log-warn (str "hydrate-island: unknown island " comp-name))
|
||||
|
||||
;; Parse state and build keyword args — SX format, not JSON
|
||||
(let ((kwargs (or (first (sx-parse state-sx)) {}))
|
||||
(disposers (list))
|
||||
(local (env-merge (component-closure comp) env)))
|
||||
|
||||
;; Bind params from kwargs
|
||||
(for-each
|
||||
(fn ((p :as string))
|
||||
(env-bind! local p (if (dict-has? kwargs p) (dict-get kwargs p) nil)))
|
||||
(component-params comp))
|
||||
|
||||
;; Render the island body in a reactive scope
|
||||
(let ((body-dom
|
||||
(with-island-scope
|
||||
(fn (disposable) (append! disposers disposable))
|
||||
(fn () (render-to-dom (component-body comp) local nil)))))
|
||||
|
||||
;; Clear existing content and append reactive DOM directly.
|
||||
;; Unlike morph-children, this preserves addEventListener-based
|
||||
;; event handlers on the freshly rendered nodes.
|
||||
(dom-set-text-content el "")
|
||||
(dom-append el body-dom)
|
||||
|
||||
;; Store disposers for cleanup
|
||||
(dom-set-data el "sx-disposers" disposers)
|
||||
|
||||
;; Process any sx- attributes on new content
|
||||
(process-elements el)
|
||||
|
||||
(log-info (str "hydrated island: " comp-name
|
||||
" (" (len disposers) " disposers)"))))))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Island disposal — clean up when island removed from DOM
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define dispose-island :effects [mutation io]
|
||||
(fn (el)
|
||||
(let ((disposers (dom-get-data el "sx-disposers")))
|
||||
(when disposers
|
||||
(for-each
|
||||
(fn ((d :as lambda))
|
||||
(when (callable? d) (d)))
|
||||
disposers)
|
||||
(dom-set-data el "sx-disposers" nil)))
|
||||
;; Clear hydration marker so the island can be re-hydrated
|
||||
(clear-processed! el "island-hydrated")))
|
||||
|
||||
(define dispose-islands-in :effects [mutation io]
|
||||
(fn (root)
|
||||
;; Dispose islands within root, but SKIP hydrated islands —
|
||||
;; they may be preserved across morphs. Only dispose islands
|
||||
;; that are not currently hydrated (e.g. freshly parsed content
|
||||
;; being discarded) or that have been explicitly detached.
|
||||
(when root
|
||||
(let ((islands (dom-query-all root "[data-sx-island]")))
|
||||
(when (and islands (not (empty? islands)))
|
||||
(let ((to-dispose (filter
|
||||
(fn (el) (not (is-processed? el "island-hydrated")))
|
||||
islands)))
|
||||
(when (not (empty? to-dispose))
|
||||
(log-info (str "disposing " (len to-dispose) " island(s)"))
|
||||
(for-each dispose-island to-dispose))))))))
|
||||
|
||||
(define force-dispose-islands-in :effects [mutation io]
|
||||
(fn (root)
|
||||
;; Dispose ALL islands in root, including hydrated ones.
|
||||
;; Used when the target is being completely replaced (outerHTML swap).
|
||||
(when root
|
||||
(let ((islands (dom-query-all root "[data-sx-island]")))
|
||||
(when (and islands (not (empty? islands)))
|
||||
(log-info (str "force-disposing " (len islands) " island(s)"))
|
||||
(for-each dispose-island islands))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Render hooks — generic pre/post callbacks for hydration, swap, mount.
|
||||
;; The spec calls these at render boundaries; the app decides what to do.
|
||||
;; Pre-render: setup before DOM changes (e.g. prepare state).
|
||||
;; Post-render: cleanup after DOM changes (e.g. flush collected CSS).
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define *pre-render-hooks* (list))
|
||||
(define *post-render-hooks* (list))
|
||||
|
||||
(define register-pre-render-hook :effects [mutation]
|
||||
(fn ((hook-fn :as lambda))
|
||||
(append! *pre-render-hooks* hook-fn)))
|
||||
|
||||
(define register-post-render-hook :effects [mutation]
|
||||
(fn ((hook-fn :as lambda))
|
||||
(append! *post-render-hooks* hook-fn)))
|
||||
|
||||
(define run-pre-render-hooks :effects [mutation io]
|
||||
(fn ()
|
||||
(for-each (fn (hook) (cek-call hook nil)) *pre-render-hooks*)))
|
||||
|
||||
(define run-post-render-hooks :effects [mutation io]
|
||||
(fn ()
|
||||
(log-info (str "run-post-render-hooks: " (len *post-render-hooks*) " hooks"))
|
||||
(for-each (fn (hook)
|
||||
(log-info (str " hook type: " (type-of hook) " callable: " (callable? hook) " lambda: " (lambda? hook)))
|
||||
(cek-call hook nil))
|
||||
*post-render-hooks*)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Full boot sequence
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define boot-init :effects [mutation io]
|
||||
(fn ()
|
||||
;; Full browser initialization:
|
||||
;; 1. CSS tracking
|
||||
;; 2. Style dictionary
|
||||
;; 3. Process scripts (components + mounts)
|
||||
;; 4. Process page registry (client-side routing)
|
||||
;; 5. Hydrate [data-sx] elements
|
||||
;; 6. Hydrate [data-sx-island] elements (reactive islands)
|
||||
;; 7. Process engine elements
|
||||
(do
|
||||
(log-info (str "sx-browser " SX_VERSION))
|
||||
(init-css-tracking)
|
||||
(process-page-scripts)
|
||||
(process-sx-scripts nil)
|
||||
(sx-hydrate-elements nil)
|
||||
(sx-hydrate-islands nil)
|
||||
(run-post-render-hooks)
|
||||
(process-elements nil)
|
||||
;; Wire up popstate for back/forward navigation
|
||||
(dom-listen (dom-window) "popstate"
|
||||
(fn (e) (handle-popstate 0))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Platform interface — Boot
|
||||
;; --------------------------------------------------------------------------
|
||||
;;
|
||||
;; From orchestration.sx:
|
||||
;; process-elements, init-css-tracking
|
||||
;;
|
||||
;; === DOM / Render ===
|
||||
;; (resolve-mount-target target) → Element (string → querySelector, else identity)
|
||||
;; (sx-render-with-env source extra-env) → DOM node (parse + render with componentEnv + extra)
|
||||
;; (get-render-env extra-env) → merged component env + extra
|
||||
;; (merge-envs base new) → merged env dict
|
||||
;; (render-to-dom expr env ns) → DOM node
|
||||
;; (sx-load-components text) → void (parse + eval into componentEnv)
|
||||
;;
|
||||
;; === DOM queries ===
|
||||
;; (dom-query sel) → Element or nil
|
||||
;; (dom-query-all root sel) → list of Elements
|
||||
;; (dom-body) → document.body
|
||||
;; (dom-get-attr el name) → string or nil
|
||||
;; (dom-has-attr? el name) → boolean
|
||||
;; (dom-text-content el) → string
|
||||
;; (dom-set-text-content el s) → void
|
||||
;; (dom-append el child) → void
|
||||
;; (dom-remove-child parent el) → void
|
||||
;; (dom-parent el) → Element
|
||||
;; (dom-append-to-head el) → void
|
||||
;; (dom-tag-name el) → string
|
||||
;;
|
||||
;; === Head hoisting ===
|
||||
;; (set-document-title s) → void (document.title = s)
|
||||
;; (remove-head-element sel) → void (remove matching element from <head>)
|
||||
;;
|
||||
;; === Script queries ===
|
||||
;; (query-sx-scripts root) → list of <script type="text/sx"> elements
|
||||
;; (query-page-scripts) → list of <script type="text/sx-pages"> elements
|
||||
;;
|
||||
;; === localStorage ===
|
||||
;; (local-storage-get key) → string or nil
|
||||
;; (local-storage-set key val) → void
|
||||
;; (local-storage-remove key) → void
|
||||
;;
|
||||
;; === Cookies ===
|
||||
;; (set-sx-comp-cookie hash) → void
|
||||
;; (clear-sx-comp-cookie) → void
|
||||
;;
|
||||
;; === Env ===
|
||||
;; (parse-env-attr el) → dict (parse data-sx-env JSON attr)
|
||||
;; (store-env-attr el base new) → void (merge and store back as JSON)
|
||||
;; (to-kebab s) → string (underscore → kebab-case)
|
||||
;;
|
||||
;; === Logging ===
|
||||
;; (log-info msg) → void (console.log with prefix)
|
||||
;; (log-parse-error label text err) → void (diagnostic parse error)
|
||||
;;
|
||||
;; === Parsing (island state) ===
|
||||
;; (sx-parse str) → list of AST expressions (from parser.sx)
|
||||
;;
|
||||
;; === Processing markers ===
|
||||
;; (mark-processed! el key) → void
|
||||
;; (is-processed? el key) → boolean
|
||||
;;
|
||||
;; === Morph ===
|
||||
;; (morph-children target source) → void (morph target's children to match source)
|
||||
;;
|
||||
;; === Island support (from adapter-dom.sx / signals.sx) ===
|
||||
;; (island? x) → boolean
|
||||
;; (component-closure comp) → env
|
||||
;; (component-params comp) → list of param names
|
||||
;; (component-body comp) → AST
|
||||
;; (component-name comp) → string
|
||||
;; (component-has-children? comp) → boolean
|
||||
;; (with-island-scope scope-fn body-fn) → result (track disposables)
|
||||
;; (render-to-dom expr env ns) → DOM node
|
||||
;; (dom-get-data el key) → any (from el._sxData)
|
||||
;; (dom-set-data el key val) → void
|
||||
;; --------------------------------------------------------------------------
|
||||
227
shared/static/wasm/sx/browser.sx
Normal file
227
shared/static/wasm/sx/browser.sx
Normal file
@@ -0,0 +1,227 @@
|
||||
;; ==========================================================================
|
||||
;; browser.sx — Browser API library functions
|
||||
;;
|
||||
;; Location, history, storage, cookies, timers, fetch — all expressed
|
||||
;; using the host FFI primitives. Library functions, not primitives.
|
||||
;; ==========================================================================
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Location & navigation
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define browser-location-href
|
||||
(fn ()
|
||||
(host-get (host-get (dom-window) "location") "href")))
|
||||
|
||||
(define browser-location-pathname
|
||||
(fn ()
|
||||
(host-get (host-get (dom-window) "location") "pathname")))
|
||||
|
||||
(define browser-location-origin
|
||||
(fn ()
|
||||
(host-get (host-get (dom-window) "location") "origin")))
|
||||
|
||||
(define browser-same-origin?
|
||||
(fn (url)
|
||||
(starts-with? url (browser-location-origin))))
|
||||
|
||||
;; Extract pathname from a URL string using the URL API
|
||||
(define url-pathname
|
||||
(fn (url)
|
||||
(host-get (host-new "URL" url (browser-location-origin)) "pathname")))
|
||||
|
||||
(define browser-push-state
|
||||
(fn (url-or-state &rest rest)
|
||||
(if (empty? rest)
|
||||
;; Single arg: just URL
|
||||
(host-call (host-get (dom-window) "history") "pushState" nil "" url-or-state)
|
||||
;; Three args: state, title, url
|
||||
(host-call (host-get (dom-window) "history") "pushState" url-or-state (first rest) (nth rest 1)))))
|
||||
|
||||
(define browser-replace-state
|
||||
(fn (url-or-state &rest rest)
|
||||
(if (empty? rest)
|
||||
(host-call (host-get (dom-window) "history") "replaceState" nil "" url-or-state)
|
||||
(host-call (host-get (dom-window) "history") "replaceState" url-or-state (first rest) (nth rest 1)))))
|
||||
|
||||
(define browser-reload
|
||||
(fn ()
|
||||
(host-call (host-get (dom-window) "location") "reload")))
|
||||
|
||||
(define browser-navigate
|
||||
(fn (url)
|
||||
(host-set! (host-get (dom-window) "location") "href" url)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Storage
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define local-storage-get
|
||||
(fn (key)
|
||||
(host-call (host-get (dom-window) "localStorage") "getItem" key)))
|
||||
|
||||
(define local-storage-set
|
||||
(fn (key val)
|
||||
(host-call (host-get (dom-window) "localStorage") "setItem" key val)))
|
||||
|
||||
(define local-storage-remove
|
||||
(fn (key)
|
||||
(host-call (host-get (dom-window) "localStorage") "removeItem" key)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Timers
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define set-timeout
|
||||
(fn (fn-val ms)
|
||||
(host-call (dom-window) "setTimeout" (host-callback fn-val) ms)))
|
||||
|
||||
(define set-interval
|
||||
(fn (fn-val ms)
|
||||
(host-call (dom-window) "setInterval" (host-callback fn-val) ms)))
|
||||
|
||||
(define clear-timeout
|
||||
(fn (id)
|
||||
(host-call (dom-window) "clearTimeout" id)))
|
||||
|
||||
(define clear-interval
|
||||
(fn (id)
|
||||
(host-call (dom-window) "clearInterval" id)))
|
||||
|
||||
(define request-animation-frame
|
||||
(fn (fn-val)
|
||||
(host-call (dom-window) "requestAnimationFrame" (host-callback fn-val))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Fetch
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define fetch-request
|
||||
(fn (url opts)
|
||||
(host-call (dom-window) "fetch" url opts)))
|
||||
|
||||
(define new-abort-controller
|
||||
(fn ()
|
||||
(host-new "AbortController")))
|
||||
|
||||
(define controller-signal
|
||||
(fn (controller)
|
||||
(host-get controller "signal")))
|
||||
|
||||
(define controller-abort
|
||||
(fn (controller)
|
||||
(host-call controller "abort")))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Promises
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define promise-then
|
||||
(fn (p on-resolve on-reject)
|
||||
(let ((cb-resolve (host-callback on-resolve))
|
||||
(cb-reject (if on-reject (host-callback on-reject) nil)))
|
||||
(if cb-reject
|
||||
(host-call (host-call p "then" cb-resolve) "catch" cb-reject)
|
||||
(host-call p "then" cb-resolve)))))
|
||||
|
||||
(define promise-resolve
|
||||
(fn (val)
|
||||
(host-call (host-global "Promise") "resolve" val)))
|
||||
|
||||
(define promise-delayed
|
||||
(fn (ms val)
|
||||
(host-new "Promise" (host-callback
|
||||
(fn (resolve)
|
||||
(set-timeout (fn () (host-call resolve "call" nil val)) ms))))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Dialogs & media
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define browser-confirm
|
||||
(fn (msg) (host-call (dom-window) "confirm" msg)))
|
||||
|
||||
(define browser-prompt
|
||||
(fn (msg default)
|
||||
(host-call (dom-window) "prompt" msg default)))
|
||||
|
||||
(define browser-media-matches?
|
||||
(fn (query)
|
||||
(host-get (host-call (dom-window) "matchMedia" query) "matches")))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; JSON
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define json-parse
|
||||
(fn (s)
|
||||
(host-call (host-global "JSON") "parse" s)))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Console
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define log-info
|
||||
(fn (msg)
|
||||
(host-call (host-global "console") "log" (str "[sx] " msg))))
|
||||
|
||||
(define log-warn
|
||||
(fn (msg)
|
||||
(host-call (host-global "console") "warn" (str "[sx] " msg))))
|
||||
|
||||
(define console-log
|
||||
(fn (&rest args)
|
||||
(host-call (host-global "console") "log"
|
||||
(join " " (cons "[sx]" (map str args))))))
|
||||
|
||||
(define now-ms
|
||||
(fn ()
|
||||
(host-call (host-global "Date") "now")))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Scheduling
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define schedule-idle
|
||||
(fn (f)
|
||||
(let ((cb (host-callback (fn (_deadline) (f)))))
|
||||
(if (host-get (dom-window) "requestIdleCallback")
|
||||
(host-call (dom-window) "requestIdleCallback" cb)
|
||||
(set-timeout cb 0)))))
|
||||
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Cookies
|
||||
;; --------------------------------------------------------------------------
|
||||
|
||||
(define set-cookie
|
||||
(fn (name value days)
|
||||
(let ((d (or days 365))
|
||||
(expires (host-call
|
||||
(host-new "Date"
|
||||
(+ (host-call (host-global "Date") "now")
|
||||
(* d 864e5)))
|
||||
"toUTCString")))
|
||||
(host-set! (dom-document) "cookie"
|
||||
(str name "="
|
||||
(host-call nil "encodeURIComponent" value)
|
||||
";expires=" expires ";path=/;SameSite=Lax")))))
|
||||
|
||||
(define get-cookie
|
||||
(fn (name)
|
||||
(let ((cookies (host-get (dom-document) "cookie"))
|
||||
(match (host-call cookies "match"
|
||||
(host-new "RegExp"
|
||||
(str "(?:^|;\\s*)" name "=([^;]*)")))))
|
||||
(if match
|
||||
(host-call nil "decodeURIComponent" (host-get match 1))
|
||||
nil))))
|
||||
429
shared/static/wasm/sx/dom.sx
Normal file
429
shared/static/wasm/sx/dom.sx
Normal file
@@ -0,0 +1,429 @@
|
||||
;; ==========================================================================
|
||||
;; 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)))
|
||||
37634
shared/static/wasm/sx_browser.bc.js
Normal file
37634
shared/static/wasm/sx_browser.bc.js
Normal file
File diff suppressed because one or more lines are too long
Reference in New Issue
Block a user