giles
584445a843
Refactor page components (docs, examples, specs, reference, layouts) and adapters (adapter-sx, boot-helpers, orchestration) across sx/ and web/ directories. Add Playwright SPA navigation tests. Rebuild WASM kernel with updated bytecode. Add OCaml primitives for request handling. Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
731 lines
19 KiB
Plaintext
731 lines
19 KiB
Plaintext
(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)))
|
|
|
|
(define
|
|
callable?
|
|
(fn
|
|
(v)
|
|
(let
|
|
((t (type-of v)))
|
|
(or (= t "lambda") (= t "native-fn") (= t "continuation")))))
|
|
|
|
(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))))
|
|
|
|
(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 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
|
|
(extra)
|
|
"Get the rendering environment (global env, optionally merged with extra)."
|
|
(let
|
|
((env (base-env)))
|
|
(if (and extra (not (nil? extra))) (env-merge env 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)))))
|
|
|
|
(define set-sx-comp-cookie (fn (hash) (set-cookie "sx-components" hash)))
|
|
|
|
(define clear-sx-comp-cookie (fn () (set-cookie "sx-components" "")))
|
|
|
|
(define
|
|
log-parse-error
|
|
(fn (label text err) (log-error (str "Parse error in " label ": " err))))
|
|
|
|
(define
|
|
loaded-component-names
|
|
(fn
|
|
()
|
|
(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)))
|
|
|
|
(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))
|
|
|
|
(define
|
|
build-request-body
|
|
(fn
|
|
(el method url)
|
|
(let
|
|
((m (upper method)))
|
|
(if
|
|
(or (= m "GET") (= m "HEAD"))
|
|
(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))
|
|
(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")
|
|
(let
|
|
((fd (host-new "FormData" el)))
|
|
(dict "url" url "body" fd "content-type" nil))
|
|
(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"))))
|
|
(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))
|
|
|
|
(define dom-has-attr? (fn (el name) (host-call el "hasAttribute" name)))
|
|
|
|
(define
|
|
show-indicator
|
|
(fn
|
|
(el)
|
|
(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)
|
|
(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)
|
|
(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))))
|
|
|
|
(define abort-error? (fn (err) (= (host-get err "name") "AbortError")))
|
|
|
|
(define
|
|
promise-catch
|
|
(fn (p f) (let ((cb (host-callback f))) (host-call p "catch" cb))))
|
|
|
|
(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
|
|
(success-fn true 200 (fn (name) nil) preloaded)
|
|
(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))
|
|
(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)
|
|
(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)
|
|
(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)
|
|
(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)
|
|
(fetch-and-restore target pathname headers 0)))
|
|
|
|
(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")))
|
|
(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))))))
|
|
(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)))
|
|
|
|
(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))))
|
|
|
|
(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))))))))
|
|
(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))))
|
|
|
|
(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))))))
|
|
|
|
(define
|
|
bind-boost-link
|
|
(fn
|
|
(el href)
|
|
(dom-listen
|
|
el
|
|
"click"
|
|
(fn
|
|
(e)
|
|
(when
|
|
(not (event-modifier-key? e))
|
|
(prevent-default e)
|
|
(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)
|
|
(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 "#sx-content"))
|
|
"#sx-content")))
|
|
(if
|
|
(try-client-route (url-pathname href) target-sel)
|
|
(do (browser-push-state nil "" href) (browser-scroll-to 0 0))
|
|
(do
|
|
(log-info (str "sx:route server fetch " href))
|
|
(dom-set-attr link "sx-get" href)
|
|
(dom-set-attr link "sx-target" target-sel)
|
|
(dom-set-attr link "sx-select" target-sel)
|
|
(dom-set-attr link "sx-push-url" "true")
|
|
(execute-request link nil nil)))))))))
|
|
|
|
(define sw-post-message (fn (msg) nil))
|
|
|
|
(define try-parse-json (fn (text) (json-parse text)))
|
|
|
|
(define
|
|
strip-component-scripts
|
|
(fn
|
|
(text)
|
|
(let
|
|
((result text)
|
|
(start-tag "<script type=\"text/sx\" data-components>")
|
|
(end-tag "</script>"))
|
|
(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)))))
|
|
(sx-load-components comp-text)
|
|
(loop (str before after)))))))))
|
|
result)))
|
|
|
|
(define
|
|
extract-response-css
|
|
(fn
|
|
(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)))))
|
|
(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)
|
|
(let
|
|
((doc (host-global "document"))
|
|
(frag (host-call doc "createDocumentFragment"))
|
|
(exprs (sx-parse text)))
|
|
(scope-push! "sx-render-markers" true)
|
|
(for-each
|
|
(fn
|
|
(expr)
|
|
(let
|
|
((result (try-catch (fn () (render-to-dom expr (get-render-env nil) nil)) (fn (err) (log-error (str "sx-render: " err)) (let ((el (dom-create-element "div" nil))) (dom-set-attr el "class" "sx-render-error") (dom-set-attr el "style" "color:red;font-size:0.875rem;padding:0.5rem;border:1px solid red;border-radius:4px;margin:0.25rem 0;") (dom-set-text-content el (str "Render error: " err)) el)))))
|
|
(when result (dom-append frag result))))
|
|
exprs)
|
|
(scope-pop! "sx-render-markers")
|
|
frag)))
|
|
|
|
(define sx-hydrate (fn (root) (sx-hydrate-elements (or root (dom-body)))))
|
|
|
|
(define
|
|
sx-process-scripts
|
|
(fn
|
|
(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)
|
|
(try-catch
|
|
(fn () (cek-eval expr))
|
|
(fn
|
|
(err)
|
|
(log-error (str "sx-process-scripts: " err)))))
|
|
exprs))))))
|
|
scripts))))
|
|
|
|
(define
|
|
select-from-container
|
|
(fn
|
|
(container selector)
|
|
(if
|
|
selector
|
|
(let
|
|
((selected (dom-query container selector)))
|
|
(if
|
|
selected
|
|
(children-to-fragment selected)
|
|
(children-to-fragment container)))
|
|
(children-to-fragment container))))
|
|
|
|
(define
|
|
children-to-fragment
|
|
(fn
|
|
(el)
|
|
(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)
|
|
(if
|
|
selector
|
|
(let
|
|
((el (dom-query doc selector)))
|
|
(if el (dom-inner-html el) (dom-body-inner-html doc)))
|
|
(dom-body-inner-html doc))))
|
|
|
|
(define register-io-deps (fn (deps) nil))
|
|
|
|
(define resolve-page-data (fn (page-name params callback) 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)
|
|
(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 callback) (try-eval-content content-src env)))
|
|
|
|
(define try-rerender-page (fn () nil))
|
|
|
|
(define execute-action (fn () nil))
|
|
|
|
(define bind-preload (fn () nil))
|
|
|
|
(define persist-offline-data (fn () nil))
|
|
|
|
(define retrieve-offline-data (fn () nil))
|