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

OCaml VM browser: safe equality, thunk trampolining, platform functions, nav pipeline

Browse Source 
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:
giles
2026-03-25 12:57:24 +00:00
parent 5aea9d2678
commit 07bbcaf1bb
14 changed files with 41905 additions and 50 deletions
Download Patch File Download Diff File Expand all files Collapse all files

58
web/adapter-dom.sx
View File

@@ -13,6 +13,12 @@
(define SVG_NS "http://www.w3.org/2000/svg")
(define MATH_NS "http://www.w3.org/1998/Math/MathML")
;; Check if we're inside an island scope.
;; Uses scope-peek (mutable scope stack) rather than context (CEK continuation)
;; because with-island-scope uses scope-push!, not provide.
(define island-scope?
(fn () (not (nil? (scope-peek "sx-island-scope")))))
;; --------------------------------------------------------------------------
;; dom-on — dom-listen with post-render hooks
@@ -27,7 +33,7 @@
(dom-listen el name
(if (lambda? handler)
(if (= 0 (len (lambda-params handler)))
(fn () (trampoline (call-lambda handler (list))) (run-post-render-hooks))
(fn (_e) (trampoline (call-lambda handler (list))) (run-post-render-hooks))
(fn (e) (trampoline (call-lambda handler (list e))) (run-post-render-hooks)))
handler))))
@@ -63,7 +69,11 @@
"dom-node" expr
;; Spread → emit attrs to nearest element provider, pass through for reactive-spread
"spread" (do (emit! "element-attrs" (spread-attrs expr)) expr)
;; Inside islands, reactive-spread handles attr application directly —
;; skip scope emission to avoid double/triple application.
"spread" (do (when (not (island-scope?))
(scope-emit! "element-attrs" (spread-attrs expr)))
expr)
;; Dict → empty
"dict" (create-fragment)
@@ -77,7 +87,7 @@
;; Signal → reactive text in island scope, deref outside
:else
(if (signal? expr)
(if (context "sx-island-scope" nil)
(if (island-scope?)
(reactive-text expr)
(create-text-node (str (deref expr))))
(create-text-node (str expr))))))
@@ -161,7 +171,7 @@
(render-dom-element name args env ns)
;; deref in island scope → reactive text node
(and (= name "deref") (context "sx-island-scope" nil))
(and (= name "deref") (island-scope?))
(let ((sig-or-val (trampoline (eval-expr (first args) env))))
(if (signal? sig-or-val)
(reactive-text sig-or-val)
@@ -233,7 +243,7 @@
;; Inside island scope: reactive attribute binding.
;; The effect tracks signal deps automatically — if none
;; are deref'd, it fires once and never again (safe).
(context "sx-island-scope" nil)
(island-scope?)
(reactive-attr el attr-name
(fn () (trampoline (eval-expr attr-expr env))))
;; Static attribute (outside islands)
@@ -255,7 +265,7 @@
(let ((child (render-to-dom arg env new-ns)))
(cond
;; Reactive spread: track signal deps, update attrs on change
(and (spread? child) (context "sx-island-scope" nil))
(and (spread? child) (island-scope?))
(reactive-spread el (fn () (render-to-dom arg env new-ns)))
;; Static spread: already emitted via provide, skip
(spread? child) nil
@@ -286,7 +296,7 @@
val)))
(dom-set-attr el key (str val))))))
(keys spread-dict)))
(emitted "element-attrs"))
(scope-emitted "element-attrs"))
(scope-pop! "element-attrs")
el)))
@@ -396,7 +406,7 @@
;; produce DOM nodes rather than evaluated values.
(define RENDER_DOM_FORMS
(list "if" "when" "cond" "case" "let" "let*" "begin" "do"
(list "if" "when" "cond" "case" "let" "let*" "letrec" "begin" "do"
"define" "defcomp" "defisland" "defmacro" "defstyle"
"map" "map-indexed" "filter" "for-each" "portal"
"error-boundary" "scope" "provide"))
@@ -410,7 +420,7 @@
(cond
;; if — reactive inside islands (re-renders when signal deps change)
(= name "if")
(if (context "sx-island-scope" nil)
(if (island-scope?)
(let ((marker (create-comment "r-if"))
(current-nodes (list))
(initial-result nil))
@@ -458,7 +468,7 @@
;; when — reactive inside islands
(= name "when")
(if (context "sx-island-scope" nil)
(if (island-scope?)
(let ((marker (create-comment "r-when"))
(current-nodes (list))
(initial-result nil))
@@ -504,7 +514,7 @@
;; cond — reactive inside islands
(= name "cond")
(if (context "sx-island-scope" nil)
(if (island-scope?)
(let ((marker (create-comment "r-cond"))
(current-nodes (list))
(initial-result nil))
@@ -561,6 +571,30 @@
(range 2 (len expr)))
frag)))
;; letrec — pre-bind all names (nil), evaluate values, render body.
(= name "letrec")
(let ((bindings (nth expr 1))
(body (slice expr 2))
(local (env-extend env)))
;; Phase 1: pre-bind all names to nil
(for-each (fn (pair)
(let ((pname (if (= (type-of (first pair)) "symbol")
(symbol-name (first pair))
(str (first pair)))))
(env-bind! local pname nil)))
bindings)
;; Phase 2: evaluate values (all names in scope for mutual recursion)
(for-each (fn (pair)
(let ((pname (if (= (type-of (first pair)) "symbol")
(symbol-name (first pair))
(str (first pair)))))
(env-set! local pname (trampoline (eval-expr (nth pair 1) local)))))
bindings)
;; Phase 3: eval non-last body exprs for side effects, render last
(when (> (len body) 1)
(for-each (fn (e) (trampoline (eval-expr e local))) (init body)))
(render-to-dom (last body) local ns))
;; begin / do — single body: pass through. Multi: fragment.
(or (= name "begin") (= name "do"))
(if (= (len expr) 2)
@@ -581,7 +615,7 @@
;; map — reactive-list when mapping over a signal inside an island
(= name "map")
(let ((coll-expr (nth expr 2)))
(if (and (context "sx-island-scope" nil)
(if (and (island-scope?)
(= (type-of coll-expr) "list")
(> (len coll-expr) 1)
(= (type-of (first coll-expr)) "symbol")

9
web/boot.sx
View File

@@ -460,9 +460,9 @@
(define run-post-render-hooks :effects [mutation io]
(fn ()
(log-info "run-post-render-hooks:" (len *post-render-hooks*) "hooks")
(log-info (str "run-post-render-hooks: " (len *post-render-hooks*) " hooks"))
(for-each (fn (hook)
(log-info " hook type:" (type-of hook) "callable:" (callable? hook) "lambda:" (lambda? hook))
(log-info (str " hook type: " (type-of hook) " callable: " (callable? hook) " lambda: " (lambda? hook)))
(cek-call hook nil))
*post-render-hooks*)))
@@ -489,7 +489,10 @@
(sx-hydrate-elements nil)
(sx-hydrate-islands nil)
(run-post-render-hooks)
(process-elements nil))))
(process-elements nil)
;; Wire up popstate for back/forward navigation
(dom-listen (dom-window) "popstate"
(fn (e) (handle-popstate 0))))))
;; --------------------------------------------------------------------------

696
web/lib/boot-helpers.sx Normal file
View 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))

21
web/lib/browser.sx
View File

@@ -26,13 +26,24 @@
(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 (state title url)
(host-call (host-get (dom-window) "history") "pushState" state title url)))
(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 (state title url)
(host-call (host-get (dom-window) "history") "replaceState" state title url)))
(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 ()
@@ -182,7 +193,7 @@
(define schedule-idle
(fn (f)
(let ((cb (host-callback f)))
(let ((cb (host-callback (fn (_deadline) (f)))))
(if (host-get (dom-window) "requestIdleCallback")
(host-call (dom-window) "requestIdleCallback" cb)
(set-timeout cb 0)))))

132
web/lib/dom.sx
View File

@@ -29,8 +29,11 @@
;; --------------------------------------------------------------------------
(define dom-create-element
(fn (tag)
(host-call (dom-document) "createElement" tag)))
(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)
@@ -40,6 +43,10 @@
(fn ()
(host-call (dom-document) "createDocumentFragment")))
(define create-comment
(fn (text)
(host-call (dom-document) "createComment" (or text ""))))
;; --------------------------------------------------------------------------
;; Tree manipulation
@@ -60,6 +67,54 @@
(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)
@@ -80,16 +135,29 @@
;; --------------------------------------------------------------------------
(define dom-query
(fn (sel)
(host-call (dom-document) "querySelector" sel)))
(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)
(if (nil? sel)
;; Single arg: query document
(host-call (dom-document) "querySelectorAll" root)
;; Two args: query within root
(host-call root "querySelectorAll" 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)
@@ -226,13 +294,46 @@
(define dom-child-list
(fn (el)
"Return child nodes as an SX list."
(if el
(host-call (host-global "Array") "from" (host-get el "childNodes"))
(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"))))
@@ -254,6 +355,17 @@
;; 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