Fix WASM browser click handlers: 8 bugs, 50 new VM tests
The sx-get links were doing full page refreshes because click handlers never attached. Root causes: VM frame management bug, missing primitives, CEK/VM type dispatch mismatch, and silent error swallowing. Fixes: - VM frame exhaustion: frames <- [] now properly pops to rest_frames - length primitive: add alias for len in OCaml primitives - call_sx_fn: use sx_call directly instead of eval_expr (CEK checks for type "lambda" but VmClosure reports "function") - Boot error surfacing: Sx.init() now has try/catch + failure summary - Callback error surfacing: catch-all handler for non-Eval_error exceptions - Silent JIT failures: log before CEK fallback instead of swallowing - vm→env sync: loadModule now calls sync_vm_to_env() - sx_build_bytecode MCP tool added for bytecode compilation Tests: 50 new tests across test-vm.sx and test-vm-primitives.sx covering nested VM calls, frame integrity, CEK bridge, primitive availability, cross-module symbol resolution, and callback dispatch. Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
429
web/boot.sx
429
web/boot.sx
@@ -1,45 +1,434 @@
|
||||
(define HEAD_HOIST_SELECTOR "meta, title, link[rel='canonical'], script[type='application/ld+json']")
|
||||
(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 (= tag "title") (do (set-document-title (dom-text-content el)) (dom-remove-child (dom-parent el) el)) (= 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)) (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)) :else (do (dom-remove-child (dom-parent el) el) (dom-append-to-head el))))) els))))
|
||||
(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
|
||||
(= tag "title")
|
||||
(do
|
||||
(set-document-title (dom-text-content el))
|
||||
(dom-remove-child (dom-parent el) el))
|
||||
(= 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))
|
||||
(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))
|
||||
:else (do
|
||||
(dom-remove-child (dom-parent el) el)
|
||||
(dom-append-to-head el)))))
|
||||
els))))
|
||||
|
||||
(define sx-mount :effects (mutation io) (fn (target (source :as string) (extra-env :as dict)) (let ((el (resolve-mount-target target))) (when el (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-full el))) (process-elements el) (sx-hydrate-elements el) (sx-hydrate-islands el) (run-post-render-hooks)))))
|
||||
(define
|
||||
sx-mount
|
||||
:effects (mutation io)
|
||||
(fn
|
||||
(target (source :as string) (extra-env :as dict))
|
||||
(let
|
||||
((el (resolve-mount-target target)))
|
||||
(when
|
||||
el
|
||||
(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-full el)))
|
||||
(process-elements el)
|
||||
(sx-hydrate-elements el)
|
||||
(sx-hydrate-islands el)
|
||||
(run-post-render-hooks)))))
|
||||
|
||||
(define resolve-suspense :effects (mutation io) (fn ((id :as string) (sx :as string)) (process-sx-scripts nil) (let ((el (dom-query (str "[data-suspense=\"" id "\"]")))) (if el (do (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))))))
|
||||
(define
|
||||
resolve-suspense
|
||||
:effects (mutation io)
|
||||
(fn
|
||||
((id :as string) (sx :as string))
|
||||
(process-sx-scripts nil)
|
||||
(let
|
||||
((el (dom-query (str "[data-suspense=\"" id "\"]"))))
|
||||
(if
|
||||
el
|
||||
(do
|
||||
(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))))))
|
||||
|
||||
(define sx-hydrate-elements :effects (mutation io) (fn (root) (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))))
|
||||
(define
|
||||
sx-hydrate-elements
|
||||
:effects (mutation io)
|
||||
(fn
|
||||
(root)
|
||||
(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))))
|
||||
|
||||
(define sx-update-element :effects (mutation io) (fn (el new-env) (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) (when new-env (store-env-attr target base-env new-env))))))))))
|
||||
(define
|
||||
sx-update-element
|
||||
:effects (mutation io)
|
||||
(fn
|
||||
(el new-env)
|
||||
(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)
|
||||
(when new-env (store-env-attr target base-env new-env))))))))))
|
||||
|
||||
(define sx-render-component :effects (mutation io) (fn ((name :as string) (kwargs :as dict) (extra-env :as dict)) (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)) (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)))))))
|
||||
(define
|
||||
sx-render-component
|
||||
:effects (mutation io)
|
||||
(fn
|
||||
((name :as string) (kwargs :as dict) (extra-env :as dict))
|
||||
(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))
|
||||
(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)))))))
|
||||
|
||||
(define process-sx-scripts :effects (mutation io) (fn (root) (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 (dom-has-attr? s "data-components") (process-component-script s text) (or (nil? text) (empty? (trim text))) nil (dom-has-attr? s "data-init") (let ((exprs (sx-parse text))) (for-each (fn (expr) (eval-expr expr (env-extend (dict)))) exprs)) (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))) :else (sx-load-components text))))) scripts))))
|
||||
(define
|
||||
process-sx-scripts
|
||||
:effects (mutation io)
|
||||
(fn
|
||||
(root)
|
||||
(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
|
||||
(dom-has-attr? s "data-components")
|
||||
(process-component-script s text)
|
||||
(or (nil? text) (empty? (trim text)))
|
||||
nil
|
||||
(dom-has-attr? s "data-init")
|
||||
(let
|
||||
((exprs (sx-parse text)))
|
||||
(for-each (fn (expr) (cek-eval expr)) exprs))
|
||||
(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)))
|
||||
:else (sx-load-components text)))))
|
||||
scripts))))
|
||||
|
||||
(define process-component-script :effects (mutation io) (fn (script (text :as string)) (let ((hash (dom-get-attr script "data-hash"))) (if (nil? hash) (when (and text (not (empty? (trim text)))) (sx-load-components text)) (let ((has-inline (and text (not (empty? (trim text)))))) (let ((cached-hash (local-storage-get "sx-components-hash"))) (if (= cached-hash hash) (if has-inline (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)")) (let ((cached (local-storage-get "sx-components-src"))) (if cached (do (sx-load-components cached) (log-info (str "components: cached (" hash ")"))) (do (clear-sx-comp-cookie) (browser-reload))))) (if has-inline (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 ")"))) (do (local-storage-remove "sx-components-hash") (local-storage-remove "sx-components-src") (clear-sx-comp-cookie) (browser-reload))))) (set-sx-comp-cookie hash))))))
|
||||
(define
|
||||
process-component-script
|
||||
:effects (mutation io)
|
||||
(fn
|
||||
(script (text :as string))
|
||||
(let
|
||||
((hash (dom-get-attr script "data-hash")))
|
||||
(if
|
||||
(nil? hash)
|
||||
(when
|
||||
(and text (not (empty? (trim text))))
|
||||
(sx-load-components text))
|
||||
(let
|
||||
((has-inline (and text (not (empty? (trim text))))))
|
||||
(let
|
||||
((cached-hash (local-storage-get "sx-components-hash")))
|
||||
(if
|
||||
(= cached-hash hash)
|
||||
(if
|
||||
has-inline
|
||||
(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)"))
|
||||
(let
|
||||
((cached (local-storage-get "sx-components-src")))
|
||||
(if
|
||||
cached
|
||||
(do
|
||||
(sx-load-components cached)
|
||||
(log-info (str "components: cached (" hash ")")))
|
||||
(do (clear-sx-comp-cookie) (browser-reload)))))
|
||||
(if
|
||||
has-inline
|
||||
(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 ")")))
|
||||
(do
|
||||
(local-storage-remove "sx-components-hash")
|
||||
(local-storage-remove "sx-components-src")
|
||||
(clear-sx-comp-cookie)
|
||||
(browser-reload)))))
|
||||
(set-sx-comp-cookie hash))))))
|
||||
|
||||
(define _page-routes (list))
|
||||
|
||||
(define process-page-scripts :effects (mutation io) (fn () (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")))))
|
||||
(define
|
||||
process-page-scripts
|
||||
:effects (mutation io)
|
||||
(fn
|
||||
()
|
||||
(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")))))
|
||||
|
||||
(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
|
||||
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)) (let ((kwargs (or (first (sx-parse state-sx)) {})) (disposers (list)) (local (env-merge (component-closure comp) env))) (for-each (fn ((p :as string)) (env-bind! local p (if (dict-has? kwargs p) (dict-get kwargs p) nil))) (component-params comp)) (let ((body-dom (cek-try (fn () (with-island-scope (fn (disposable) (append! disposers disposable)) (fn () (render-to-dom (component-body comp) local nil)))) (fn (err) (log-warn (str "hydrate-island FAILED: " comp-name " — " err)) (let ((error-el (dom-create-element "div" nil))) (dom-set-attr error-el "class" "sx-island-error") (dom-set-attr error-el "style" "padding:8px;margin:4px 0;border:1px solid #ef4444;border-radius:4px;background:#fef2f2;color:#b91c1c;font-family:monospace;font-size:12px;white-space:pre-wrap") (dom-set-text-content error-el (str "Island error: " comp-name "\n" err)) error-el))))) (dom-set-text-content el "") (dom-append el body-dom) (dom-set-data el "sx-disposers" disposers) (process-elements el) (log-info (str "hydrated island: " comp-name " (" (len disposers) " disposers)"))))))))))
|
||||
(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))
|
||||
(let
|
||||
((kwargs (or (first (sx-parse state-sx)) {}))
|
||||
(disposers (list))
|
||||
(local (env-merge (component-closure comp) env)))
|
||||
(for-each
|
||||
(fn
|
||||
((p :as string))
|
||||
(env-bind!
|
||||
local
|
||||
p
|
||||
(if (dict-has? kwargs p) (dict-get kwargs p) nil)))
|
||||
(component-params comp))
|
||||
(let
|
||||
((body-dom (cek-try (fn () (with-island-scope (fn (disposable) (append! disposers disposable)) (fn () (render-to-dom (component-body comp) local nil)))) (fn (err) (log-warn (str "hydrate-island FAILED: " comp-name " — " err)) (let ((error-el (dom-create-element "div" nil))) (dom-set-attr error-el "class" "sx-island-error") (dom-set-attr error-el "style" "padding:8px;margin:4px 0;border:1px solid #ef4444;border-radius:4px;background:#fef2f2;color:#b91c1c;font-family:monospace;font-size:12px;white-space:pre-wrap") (dom-set-text-content error-el (str "Island error: " comp-name "\n" err)) error-el)))))
|
||||
(dom-set-text-content el "")
|
||||
(dom-append el body-dom)
|
||||
(dom-set-data el "sx-disposers" disposers)
|
||||
(process-elements el)
|
||||
(log-info
|
||||
(str
|
||||
"hydrated island: "
|
||||
comp-name
|
||||
" ("
|
||||
(len disposers)
|
||||
" disposers)"))))))))))
|
||||
|
||||
(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-processed! el "island-hydrated")))
|
||||
(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-processed! el "island-hydrated")))
|
||||
|
||||
(define dispose-islands-in :effects (mutation io) (fn (root) (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
|
||||
dispose-islands-in
|
||||
:effects (mutation io)
|
||||
(fn
|
||||
(root)
|
||||
(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) (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))))))
|
||||
(define
|
||||
force-dispose-islands-in
|
||||
:effects (mutation io)
|
||||
(fn
|
||||
(root)
|
||||
(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))))))
|
||||
|
||||
(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-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
|
||||
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-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*)))
|
||||
(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*)))
|
||||
|
||||
(define boot-init :effects (mutation io) (fn () (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) (dom-listen (dom-window) "popstate" (fn (e) (handle-popstate 0))))))
|
||||
(define
|
||||
boot-init
|
||||
:effects (mutation io)
|
||||
(fn
|
||||
()
|
||||
(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)
|
||||
(dom-listen (dom-window) "popstate" (fn (e) (handle-popstate 0))))))
|
||||
|
||||
619
web/lib/dom.sx
619
web/lib/dom.sx
@@ -1,425 +1,418 @@
|
||||
;; ==========================================================================
|
||||
;; 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")))
|
||||
|
||||
(define dom-window (fn () (host-global "window")))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Node creation
|
||||
;; --------------------------------------------------------------------------
|
||||
(define dom-body (fn () (host-get (dom-document) "body")))
|
||||
|
||||
(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
|
||||
(define dom-head (fn () (host-get (dom-document) "head")))
|
||||
|
||||
(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-text-node
|
||||
(fn (s) (host-call (dom-document) "createTextNode" s)))
|
||||
|
||||
(define create-fragment
|
||||
(fn ()
|
||||
(host-call (dom-document) "createDocumentFragment")))
|
||||
(define
|
||||
create-fragment
|
||||
(fn () (host-call (dom-document) "createDocumentFragment")))
|
||||
|
||||
(define create-comment
|
||||
(fn (text)
|
||||
(host-call (dom-document) "createComment" (or text ""))))
|
||||
(define
|
||||
create-comment
|
||||
(fn (text) (host-call (dom-document) "createComment" (or text ""))))
|
||||
|
||||
(define
|
||||
dom-append
|
||||
(fn
|
||||
(parent child)
|
||||
(when (and parent child) (host-call parent "appendChild" child))))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Tree manipulation
|
||||
;; --------------------------------------------------------------------------
|
||||
(define
|
||||
dom-prepend
|
||||
(fn
|
||||
(parent child)
|
||||
(when (and parent child) (host-call parent "prepend" child))))
|
||||
|
||||
(define dom-append
|
||||
(fn (parent child)
|
||||
(when (and parent child)
|
||||
(host-call parent "appendChild" child))))
|
||||
(define
|
||||
dom-insert-before
|
||||
(fn
|
||||
(parent child ref)
|
||||
(when (and parent child) (host-call parent "insertBefore" child ref))))
|
||||
|
||||
(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)
|
||||
(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
|
||||
(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-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-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) ""))))
|
||||
(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-is-child-of?
|
||||
(fn (child parent) (and child parent (host-call parent "contains" child))))
|
||||
|
||||
(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"))))
|
||||
(define
|
||||
dom-attr-list
|
||||
(fn
|
||||
(el)
|
||||
(let
|
||||
((attrs (host-get el "attributes")) (result (list)))
|
||||
(when
|
||||
attrs
|
||||
(let
|
||||
((n (host-get attrs "length")))
|
||||
(let
|
||||
loop
|
||||
((i 0))
|
||||
(when
|
||||
(< i n)
|
||||
(let
|
||||
((attr (host-call attrs "item" i)))
|
||||
(append!
|
||||
result
|
||||
(list (host-get attr "name") (host-get attr "value"))))
|
||||
(loop (+ i 1))))))
|
||||
result)))
|
||||
|
||||
(define dom-remove-child
|
||||
(fn (parent child)
|
||||
(when (and parent child)
|
||||
(host-call parent "removeChild" child))))
|
||||
(define
|
||||
dom-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)
|
||||
(define
|
||||
dom-replace-child
|
||||
(fn
|
||||
(parent new-child old-child)
|
||||
(when
|
||||
(and parent new-child old-child)
|
||||
(host-call parent "replaceChild" new-child old-child))))
|
||||
|
||||
(define dom-clone
|
||||
(fn (node deep)
|
||||
(host-call node "cloneNode" (if (nil? deep) true deep))))
|
||||
(define
|
||||
dom-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
|
||||
(define
|
||||
dom-query
|
||||
(fn
|
||||
(root-or-sel &rest rest)
|
||||
(if
|
||||
(empty? rest)
|
||||
(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)
|
||||
(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)
|
||||
(let
|
||||
((node-list (if (nil? sel) (host-call (dom-document) "querySelectorAll" root) (host-call root "querySelectorAll" sel))))
|
||||
(if
|
||||
(nil? node-list)
|
||||
(list)
|
||||
(let ((n (host-get node-list "length"))
|
||||
(result (list)))
|
||||
(let loop ((i 0))
|
||||
(when (< i n)
|
||||
(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-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-closest (fn (el sel) (when el (host-call el "closest" sel))))
|
||||
|
||||
(define dom-matches?
|
||||
(fn (el sel)
|
||||
(if (and el (host-get el "matches"))
|
||||
(host-call el "matches" sel)
|
||||
false)))
|
||||
(define
|
||||
dom-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))
|
||||
(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"))
|
||||
(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"))
|
||||
(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"))
|
||||
(define
|
||||
dom-has-attr?
|
||||
(fn
|
||||
(el name)
|
||||
(if
|
||||
(and el (host-get el "hasAttribute"))
|
||||
(host-call el "hasAttribute" name)
|
||||
false)))
|
||||
|
||||
(define
|
||||
dom-add-class
|
||||
(fn (el cls) (when el (host-call (host-get el "classList") "add" cls))))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Classes
|
||||
;; --------------------------------------------------------------------------
|
||||
(define
|
||||
dom-remove-class
|
||||
(fn
|
||||
(el cls)
|
||||
(when el (host-call (host-get el "classList") "remove" cls))))
|
||||
|
||||
(define dom-add-class
|
||||
(fn (el cls)
|
||||
(when el
|
||||
(host-call (host-get el "classList") "add" cls))))
|
||||
(define
|
||||
dom-has-class?
|
||||
(fn
|
||||
(el cls)
|
||||
(if el (host-call (host-get el "classList") "contains" cls) false)))
|
||||
|
||||
(define dom-remove-class
|
||||
(fn (el cls)
|
||||
(when el
|
||||
(host-call (host-get el "classList") "remove" cls))))
|
||||
(define dom-text-content (fn (el) (host-get el "textContent")))
|
||||
|
||||
(define dom-has-class?
|
||||
(fn (el cls)
|
||||
(if el
|
||||
(host-call (host-get el "classList") "contains" cls)
|
||||
false)))
|
||||
(define dom-set-text-content (fn (el val) (host-set! el "textContent" val)))
|
||||
|
||||
(define dom-inner-html (fn (el) (host-get el "innerHTML")))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Content
|
||||
;; --------------------------------------------------------------------------
|
||||
(define dom-set-inner-html (fn (el val) (host-set! el "innerHTML" val)))
|
||||
|
||||
(define dom-text-content
|
||||
(fn (el) (host-get el "textContent")))
|
||||
(define dom-outer-html (fn (el) (host-get el "outerHTML")))
|
||||
|
||||
(define dom-set-text-content
|
||||
(fn (el val) (host-set! el "textContent" val)))
|
||||
(define
|
||||
dom-insert-adjacent-html
|
||||
(fn (el position html) (host-call el "insertAdjacentHTML" position html)))
|
||||
|
||||
(define dom-inner-html
|
||||
(fn (el) (host-get el "innerHTML")))
|
||||
(define dom-get-style (fn (el prop) (host-get (host-get el "style") prop)))
|
||||
|
||||
(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)
|
||||
(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-get-prop (fn (el name) (host-get el name)))
|
||||
|
||||
(define dom-set-prop
|
||||
(fn (el name val) (host-set! el name val)))
|
||||
(define dom-set-prop (fn (el name val) (host-set! el name val)))
|
||||
|
||||
(define
|
||||
dom-tag-name
|
||||
(fn (el) (if el (lower (or (host-get el "tagName") "")) "")))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; Node info
|
||||
;; --------------------------------------------------------------------------
|
||||
(define dom-node-type (fn (el) (host-get el "nodeType")))
|
||||
|
||||
(define dom-tag-name
|
||||
(fn (el)
|
||||
(if el (lower (or (host-get el "tagName") "")) "")))
|
||||
(define dom-node-name (fn (el) (host-get el "nodeName")))
|
||||
|
||||
(define dom-node-type
|
||||
(fn (el) (host-get el "nodeType")))
|
||||
(define dom-id (fn (el) (host-get el "id")))
|
||||
|
||||
(define dom-node-name
|
||||
(fn (el) (host-get el "nodeName")))
|
||||
(define dom-parent (fn (el) (host-get el "parentNode")))
|
||||
|
||||
(define dom-id
|
||||
(fn (el) (host-get el "id")))
|
||||
(define dom-first-child (fn (el) (host-get el "firstChild")))
|
||||
|
||||
(define dom-parent
|
||||
(fn (el) (host-get el "parentNode")))
|
||||
(define dom-next-sibling (fn (el) (host-get el "nextSibling")))
|
||||
|
||||
(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)
|
||||
(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)
|
||||
(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-is-fragment? (fn (el) (= (host-get el "nodeType") 11)))
|
||||
|
||||
(define dom-child-nodes
|
||||
(fn (el)
|
||||
(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)
|
||||
(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)
|
||||
(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))))))))
|
||||
(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-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")))
|
||||
(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)))
|
||||
(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)))
|
||||
(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))))
|
||||
(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 event-detail (fn (evt) (host-get evt "detail")))
|
||||
|
||||
(define prevent-default
|
||||
(fn (e) (when e (host-call e "preventDefault"))))
|
||||
(define prevent-default (fn (e) (when e (host-call e "preventDefault"))))
|
||||
|
||||
(define stop-propagation
|
||||
(fn (e) (when e (host-call e "stopPropagation"))))
|
||||
(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
|
||||
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"))))
|
||||
(define
|
||||
element-value
|
||||
(fn
|
||||
(el)
|
||||
(if
|
||||
(and el (not (nil? (host-get el "value"))))
|
||||
(host-get el "value")
|
||||
nil)))
|
||||
|
||||
(define error-message
|
||||
(fn (e)
|
||||
(if (and e (host-get e "message"))
|
||||
(host-get e "message")
|
||||
(str e))))
|
||||
(define
|
||||
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")))
|
||||
(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"))
|
||||
(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)))
|
||||
|
||||
(define
|
||||
dom-append-to-head
|
||||
(fn (el) (when (dom-head) (host-call (dom-head) "appendChild" el))))
|
||||
|
||||
;; --------------------------------------------------------------------------
|
||||
;; 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)))
|
||||
(define
|
||||
set-document-title
|
||||
(fn (title) (host-set! (dom-document) "title" title)))
|
||||
|
||||
2363
web/orchestration.sx
2363
web/orchestration.sx
File diff suppressed because it is too large
Load Diff
Reference in New Issue
Block a user