From 49afef6eef028f6a377e3585a0350aa34d3f7f8a Mon Sep 17 00:00:00 2001 From: giles Date: Mon, 13 Apr 2026 10:45:59 +0000 Subject: [PATCH] =?UTF-8?q?Add=20dom-visible=3F,=20json-stringify;=20fix?= =?UTF-8?q?=20Boolean=20coerce=20=E2=80=94=20427=E2=86=92428?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - dom-visible?: check element display != none (web/lib/dom.sx) - json-stringify: JSON.stringify via host-call (web/lib/browser.sx) - hs-coerce Boolean: use hs-falsy? for JS-compatible truthiness Co-Authored-By: Claude Opus 4.6 (1M context) --- web/lib/browser.sx | 473 +++++++++++++------------ web/lib/dom.sx | 863 +++++++++++++++++++++++---------------------- 2 files changed, 695 insertions(+), 641 deletions(-) diff --git a/web/lib/browser.sx b/web/lib/browser.sx index 5a36764e..c3fefe15 100644 --- a/web/lib/browser.sx +++ b/web/lib/browser.sx @@ -1,231 +1,254 @@ -(define-library (sx browser) - (export browser-location-href browser-location-pathname browser-location-origin browser-same-origin? url-pathname browser-push-state browser-replace-state browser-reload browser-navigate local-storage-get local-storage-set local-storage-remove set-timeout set-interval clear-timeout clear-interval request-animation-frame fetch-request new-abort-controller controller-signal controller-abort promise-then promise-resolve promise-delayed browser-confirm browser-prompt browser-media-matches? json-parse log-info log-warn console-log now-ms schedule-idle set-cookie get-cookie) +(define-library + (sx browser) + (export + browser-location-href + browser-location-pathname + browser-location-origin + browser-same-origin? + url-pathname + browser-push-state + browser-replace-state + browser-reload + browser-navigate + local-storage-get + local-storage-set + local-storage-remove + set-timeout + set-interval + clear-timeout + clear-interval + request-animation-frame + fetch-request + new-abort-controller + controller-signal + controller-abort + promise-then + promise-resolve + promise-delayed + browser-confirm + browser-prompt + browser-media-matches? + json-parse + json-stringify + log-info + log-warn + console-log + now-ms + schedule-idle + set-cookie + get-cookie) (begin - -(define - browser-location-href - (fn () (host-get (host-get (dom-window) "location") "href"))) - -(define - browser-location-pathname - (fn () (host-get (host-get (dom-window) "location") "pathname"))) - -(define - browser-location-origin - (fn () (host-get (host-get (dom-window) "location") "origin"))) - -(define - browser-same-origin? - (fn (url) (starts-with? url (browser-location-origin)))) - -(define - url-pathname - (fn - (url) - (host-get (host-new "URL" url (browser-location-origin)) "pathname"))) - -(define - browser-push-state - (fn - (url-or-state title url) - (if - (nil? title) - (host-call - (host-get (dom-window) "history") - "pushState" - nil - "" - url-or-state) - (host-call - (host-get (dom-window) "history") - "pushState" - url-or-state - title - url)))) - -(define - browser-replace-state - (fn - (url-or-state title url) - (if - (nil? title) - (host-call - (host-get (dom-window) "history") - "replaceState" - nil - "" - url-or-state) - (host-call - (host-get (dom-window) "history") - "replaceState" - url-or-state - title - url)))) - -(define - browser-reload - (fn () (host-call (host-get (dom-window) "location") "reload"))) - -(define - browser-navigate - (fn (url) (host-set! (host-get (dom-window) "location") "href" url))) - -(define - local-storage-get - (fn - (key) - (host-call (host-get (dom-window) "localStorage") "getItem" key))) - -(define - local-storage-set - (fn - (key val) - (host-call (host-get (dom-window) "localStorage") "setItem" key val))) - -(define - local-storage-remove - (fn - (key) - (host-call (host-get (dom-window) "localStorage") "removeItem" key))) - -(define - set-timeout - (fn - (fn-val ms) - (host-call (dom-window) "setTimeout" (host-callback fn-val) ms))) - -(define - set-interval - (fn - (fn-val ms) - (host-call (dom-window) "setInterval" (host-callback fn-val) ms))) - -(define clear-timeout (fn (id) (host-call (dom-window) "clearTimeout" id))) - -(define - clear-interval - (fn (id) (host-call (dom-window) "clearInterval" id))) - -(define - request-animation-frame - (fn - (fn-val) - (host-call (dom-window) "requestAnimationFrame" (host-callback fn-val)))) - -(define - fetch-request - (fn (url opts) (host-call (dom-window) "fetch" url opts))) - -(define new-abort-controller (fn () (host-new "AbortController"))) - -(define controller-signal (fn (controller) (host-get controller "signal"))) - -(define controller-abort (fn (controller) (host-call controller "abort"))) - -(define - promise-then - (fn - (p on-resolve on-reject) - (let - ((cb-resolve (host-callback on-resolve)) - (cb-reject (if on-reject (host-callback on-reject) nil))) - (if - cb-reject - (host-call (host-call p "then" cb-resolve) "catch" cb-reject) - (host-call p "then" cb-resolve))))) - -(define - promise-resolve - (fn (val) (host-call (host-global "Promise") "resolve" val))) - -(define - promise-delayed - (fn - (ms val) - (host-new - "Promise" - (host-callback - (fn - (resolve) - (set-timeout (fn () (host-call resolve "call" nil val)) ms)))))) - -(define browser-confirm (fn (msg) (host-call (dom-window) "confirm" msg))) - -(define - browser-prompt - (fn (msg default) (host-call (dom-window) "prompt" msg default))) - -(define - browser-media-matches? - (fn - (query) - (host-get (host-call (dom-window) "matchMedia" query) "matches"))) - -(define json-parse (fn (s) (host-call (host-global "JSON") "parse" s))) - -(define - log-info - (fn (msg) (host-call (host-global "console") "log" (str "[sx] " msg)))) - -(define - log-warn - (fn (msg) (host-call (host-global "console") "warn" (str "[sx] " msg)))) - -(define - console-log - (fn (msg) (host-call (host-global "console") "log" (str "[sx] " msg)))) - -(define now-ms (fn () (host-call (host-global "Date") "now"))) - -(define - schedule-idle - (fn - (f) - (let - ((cb (host-callback (fn (_deadline) (f))))) - (if - (host-get (dom-window) "requestIdleCallback") - (host-call (dom-window) "requestIdleCallback" cb) - (set-timeout cb 0))))) - -(define - set-cookie - (fn - (name value days) - (let - ((d (or days 365)) - (expires + (define + browser-location-href + (fn () (host-get (host-get (dom-window) "location") "href"))) + (define + browser-location-pathname + (fn () (host-get (host-get (dom-window) "location") "pathname"))) + (define + browser-location-origin + (fn () (host-get (host-get (dom-window) "location") "origin"))) + (define + browser-same-origin? + (fn (url) (starts-with? url (browser-location-origin)))) + (define + url-pathname + (fn + (url) + (host-get (host-new "URL" url (browser-location-origin)) "pathname"))) + (define + browser-push-state + (fn + (url-or-state title url) + (if + (nil? title) (host-call - (host-new - "Date" - (+ (host-call (host-global "Date") "now") (* d 86400000))) - "toUTCString"))) - (host-set! - (dom-document) - "cookie" - (str - name - "=" - (host-call nil "encodeURIComponent" value) - ";expires=" - expires - ";path=/;SameSite=Lax"))))) - -(define - get-cookie - (fn - (name) - (let - ((cookies (host-get (dom-document) "cookie")) - (match + (host-get (dom-window) "history") + "pushState" + nil + "" + url-or-state) (host-call - cookies - "match" - (host-new "RegExp" (str "(?:^|;\\s*)" name "=([^;]*)"))))) - (if match (host-call nil "decodeURIComponent" (host-get match 1)) nil)))) - - -)) + (host-get (dom-window) "history") + "pushState" + url-or-state + title + url)))) + (define + browser-replace-state + (fn + (url-or-state title url) + (if + (nil? title) + (host-call + (host-get (dom-window) "history") + "replaceState" + nil + "" + url-or-state) + (host-call + (host-get (dom-window) "history") + "replaceState" + url-or-state + title + url)))) + (define + browser-reload + (fn () (host-call (host-get (dom-window) "location") "reload"))) + (define + browser-navigate + (fn (url) (host-set! (host-get (dom-window) "location") "href" url))) + (define + local-storage-get + (fn + (key) + (host-call (host-get (dom-window) "localStorage") "getItem" key))) + (define + local-storage-set + (fn + (key val) + (host-call (host-get (dom-window) "localStorage") "setItem" key val))) + (define + local-storage-remove + (fn + (key) + (host-call (host-get (dom-window) "localStorage") "removeItem" key))) + (define + set-timeout + (fn + (fn-val ms) + (host-call (dom-window) "setTimeout" (host-callback fn-val) ms))) + (define + set-interval + (fn + (fn-val ms) + (host-call (dom-window) "setInterval" (host-callback fn-val) ms))) + (define + clear-timeout + (fn (id) (host-call (dom-window) "clearTimeout" id))) + (define + clear-interval + (fn (id) (host-call (dom-window) "clearInterval" id))) + (define + request-animation-frame + (fn + (fn-val) + (host-call + (dom-window) + "requestAnimationFrame" + (host-callback fn-val)))) + (define + fetch-request + (fn (url opts) (host-call (dom-window) "fetch" url opts))) + (define new-abort-controller (fn () (host-new "AbortController"))) + (define + controller-signal + (fn (controller) (host-get controller "signal"))) + (define + controller-abort + (fn (controller) (host-call controller "abort"))) + (define + promise-then + (fn + (p on-resolve on-reject) + (let + ((cb-resolve (host-callback on-resolve)) + (cb-reject (if on-reject (host-callback on-reject) nil))) + (if + cb-reject + (host-call (host-call p "then" cb-resolve) "catch" cb-reject) + (host-call p "then" cb-resolve))))) + (define + promise-resolve + (fn (val) (host-call (host-global "Promise") "resolve" val))) + (define + promise-delayed + (fn + (ms val) + (host-new + "Promise" + (host-callback + (fn + (resolve) + (set-timeout (fn () (host-call resolve "call" nil val)) ms)))))) + (define + browser-confirm + (fn (msg) (host-call (dom-window) "confirm" msg))) + (define + browser-prompt + (fn (msg default) (host-call (dom-window) "prompt" msg default))) + (define + browser-media-matches? + (fn + (query) + (host-get (host-call (dom-window) "matchMedia" query) "matches"))) + (define json-parse (fn (s) (host-call (host-global "JSON") "parse" s))) + (define + log-info + (fn + (msg) + (host-call (host-global "console") "log" (str "[sx] " msg)))) + (define + log-warn + (fn + (msg) + (host-call (host-global "console") "warn" (str "[sx] " msg)))) + (define + console-log + (fn + (msg) + (host-call (host-global "console") "log" (str "[sx] " msg)))) + (define now-ms (fn () (host-call (host-global "Date") "now"))) + (define + schedule-idle + (fn + (f) + (let + ((cb (host-callback (fn (_deadline) (f))))) + (if + (host-get (dom-window) "requestIdleCallback") + (host-call (dom-window) "requestIdleCallback" cb) + (set-timeout cb 0))))) + (define + set-cookie + (fn + (name value days) + (let + ((d (or days 365)) + (expires + (host-call + (host-new + "Date" + (+ (host-call (host-global "Date") "now") (* d 86400000))) + "toUTCString"))) + (host-set! + (dom-document) + "cookie" + (str + name + "=" + (host-call nil "encodeURIComponent" value) + ";expires=" + expires + ";path=/;SameSite=Lax"))))) + (define + get-cookie + (fn + (name) + (let + ((cookies (host-get (dom-document) "cookie")) + (match + (host-call + cookies + "match" + (host-new "RegExp" (str "(?:^|;\\s*)" name "=([^;]*)"))))) + (if + match + (host-call nil "decodeURIComponent" (host-get match 1)) + nil)))))) ;; Re-export to global env +(define + json-stringify + (fn (v) (host-call (host-global "JSON") "stringify" v))) + (import (sx browser)) diff --git a/web/lib/dom.sx b/web/lib/dom.sx index 22a89ef7..b6057de8 100644 --- a/web/lib/dom.sx +++ b/web/lib/dom.sx @@ -1,426 +1,457 @@ -(define-library (sx dom) - (export dom-document dom-window dom-body dom-head dom-create-element create-text-node create-fragment create-comment dom-append dom-prepend dom-insert-before dom-insert-after dom-remove dom-is-active-element? dom-is-input-element? dom-is-child-of? dom-attr-list dom-remove-child dom-replace-child dom-clone dom-query dom-query-all dom-query-by-id dom-closest dom-matches? dom-get-attr dom-set-attr dom-remove-attr dom-has-attr? dom-add-class dom-remove-class dom-has-class? dom-text-content dom-set-text-content dom-inner-html dom-set-inner-html dom-outer-html dom-insert-adjacent-html dom-get-style dom-set-style dom-get-prop dom-set-prop dom-tag-name dom-node-type dom-node-name dom-id dom-parent dom-first-child dom-next-sibling dom-child-list dom-is-fragment? dom-child-nodes dom-remove-children-after dom-focus dom-parse-html dom-listen dom-add-listener dom-dispatch event-detail prevent-default stop-propagation event-modifier-key? element-value error-message dom-get-data dom-set-data dom-append-to-head set-document-title) +(define-library + (sx dom) + (export + dom-document + dom-window + dom-body + dom-head + dom-create-element + create-text-node + create-fragment + create-comment + dom-append + dom-prepend + dom-insert-before + dom-insert-after + dom-remove + dom-is-active-element? + dom-is-input-element? + dom-is-child-of? + dom-attr-list + dom-remove-child + dom-replace-child + dom-clone + dom-query + dom-query-all + dom-query-by-id + dom-closest + dom-matches? + dom-get-attr + dom-set-attr + dom-remove-attr + dom-has-attr? + dom-add-class + dom-remove-class + dom-has-class? + dom-visible? + dom-text-content + dom-set-text-content + dom-inner-html + dom-set-inner-html + dom-outer-html + dom-insert-adjacent-html + dom-get-style + dom-set-style + dom-get-prop + dom-set-prop + dom-tag-name + dom-node-type + dom-node-name + dom-id + dom-parent + dom-first-child + dom-next-sibling + dom-child-list + dom-is-fragment? + dom-child-nodes + dom-remove-children-after + dom-focus + dom-parse-html + dom-listen + dom-add-listener + dom-dispatch + event-detail + prevent-default + stop-propagation + event-modifier-key? + element-value + error-message + dom-get-data + dom-set-data + dom-append-to-head + set-document-title) (begin - -(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-create-element - (fn - (tag ns) - (if - ns - (host-call (dom-document) "createElementNS" ns tag) - (host-call (dom-document) "createElement" tag)))) - -(define - create-text-node - (fn (s) (host-call (dom-document) "createTextNode" s))) - -(define - create-fragment - (fn () (host-call (dom-document) "createDocumentFragment"))) - -(define - create-comment - (fn (text) (host-call (dom-document) "createComment" (or text "")))) - -(define - dom-append - (fn - (parent child) - (when (and parent child) (host-call parent "appendChild" child)))) - -(define - dom-prepend - (fn - (parent child) - (when (and parent child) (host-call parent "prepend" child)))) - -(define - dom-insert-before - (fn - (parent child ref) - (when (and parent child) (host-call parent "insertBefore" child ref)))) - -(define - dom-insert-after - (fn - (ref node) - "Insert node after ref in the same parent." - (let - ((parent (host-get ref "parentNode")) - (next (host-get ref "nextSibling"))) - (when - parent + (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-create-element + (fn + (tag ns) (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-attr-list - (fn - (el) - (let - ((attrs (host-get el "attributes")) (result (list))) - (when - attrs + ns + (host-call (dom-document) "createElementNS" ns tag) + (host-call (dom-document) "createElement" tag)))) + (define + create-text-node + (fn (s) (host-call (dom-document) "createTextNode" s))) + (define + create-fragment + (fn () (host-call (dom-document) "createDocumentFragment"))) + (define + create-comment + (fn (text) (host-call (dom-document) "createComment" (or text "")))) + (define + dom-append + (fn + (parent child) + (when (and parent child) (host-call parent "appendChild" child)))) + (define + dom-prepend + (fn + (parent child) + (when (and parent child) (host-call parent "prepend" child)))) + (define + dom-insert-before + (fn + (parent child ref) + (when (and parent child) (host-call parent "insertBefore" child ref)))) + (define + dom-insert-after + (fn + (ref node) + "Insert node after ref in the same parent." (let - ((n (host-get attrs "length"))) - (let - loop - ((i 0)) - (when - (< i n) + ((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-attr-list + (fn + (el) + (let + ((attrs (host-get el "attributes")) (result (list))) + (when + attrs + (let + ((n (host-get attrs "length"))) (let - ((attr (host-call attrs "item" i))) - (append! - result - (list (host-get attr "name") (host-get attr "value")))) - (loop (+ i 1)))))) - result))) - -(define - dom-remove-child - (fn - (parent child) - (when (and parent child) (host-call parent "removeChild" child)))) - -(define - dom-replace-child - (fn - (parent new-child old-child) - (when - (and parent new-child old-child) - (host-call parent "replaceChild" new-child old-child)))) - -(define - dom-clone - (fn (node deep) (host-call node "cloneNode" (if (nil? deep) true deep)))) - -(define - dom-query - (fn - (root-or-sel sel) - (if - (nil? sel) - (host-call (dom-document) "querySelector" root-or-sel) - (host-call root-or-sel "querySelector" 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)))) - (if - (nil? node-list) - (list) + loop + ((i 0)) + (when + (< i n) + (let + ((attr (host-call attrs "item" i))) + (append! + result + (list (host-get attr "name") (host-get attr "value")))) + (loop (+ i 1)))))) + result))) + (define + dom-remove-child + (fn + (parent child) + (when (and parent child) (host-call parent "removeChild" child)))) + (define + dom-replace-child + (fn + (parent new-child old-child) + (when + (and parent new-child old-child) + (host-call parent "replaceChild" new-child old-child)))) + (define + dom-clone + (fn + (node deep) + (host-call node "cloneNode" (if (nil? deep) true deep)))) + (define + dom-query + (fn + (root-or-sel sel) + (if + (nil? sel) + (host-call (dom-document) "querySelector" root-or-sel) + (host-call root-or-sel "querySelector" sel)))) + (define + dom-query-all + (fn + (root sel) + "Query DOM and return an SX list (not a host NodeList)." (let - ((n (host-get node-list "length")) (result (list))) + ((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) + (append! result (host-call node-list "item" i)) + (loop (+ i 1)))) + result))))) + (define + dom-query-by-id + (fn (id) (host-call (dom-document) "getElementById" id))) + (define + dom-closest + (fn (el sel) (when el (host-call el "closest" sel)))) + (define + dom-matches? + (fn + (el sel) + (if + (and el (host-get el "matches")) + (host-call el "matches" sel) + false))) + (define + dom-get-attr + (fn + (el name) + (if + (and el (host-get el "getAttribute")) (let - loop - ((i 0)) - (when - (< i n) - (append! result (host-call node-list "item" i)) - (loop (+ i 1)))) - result))))) - -(define - dom-query-by-id - (fn (id) (host-call (dom-document) "getElementById" id))) - -(define dom-closest (fn (el sel) (when el (host-call el "closest" sel)))) - -(define - dom-matches? - (fn - (el sel) - (if (and el (host-get el "matches")) (host-call el "matches" sel) false))) - -(define - dom-get-attr - (fn - (el name) - (if - (and el (host-get el "getAttribute")) - (let ((v (host-call el "getAttribute" name))) (if (nil? v) nil v)) - nil))) - -(define - dom-set-attr - (fn - (el name val) - (when - (and el (host-get el "setAttribute")) - (host-call el "setAttribute" name val)))) - -(define - dom-remove-attr - (fn - (el name) - (when - (and el (host-get el "removeAttribute")) - (host-call el "removeAttribute" name)))) - -(define - dom-has-attr? - (fn - (el name) - (if - (and el (host-get el "hasAttribute")) - (host-call el "hasAttribute" name) - false))) - -(define - dom-add-class - (fn (el cls) (when el (host-call (host-get el "classList") "add" cls)))) - -(define - dom-remove-class - (fn - (el cls) - (when el (host-call (host-get el "classList") "remove" cls)))) - -(define - dom-has-class? - (fn - (el cls) - (if el (host-call (host-get el "classList") "contains" cls) false))) - -(define dom-text-content (fn (el) (host-get el "textContent"))) - -(define dom-set-text-content (fn (el val) (host-set! el "textContent" val))) - -(define dom-inner-html (fn (el) (host-get el "innerHTML"))) - -(define dom-set-inner-html (fn (el val) (host-set! el "innerHTML" val))) - -(define dom-outer-html (fn (el) (host-get el "outerHTML"))) - -(define - dom-insert-adjacent-html - (fn (el position html) (host-call el "insertAdjacentHTML" position html))) - -(define dom-get-style (fn (el prop) (host-get (host-get el "style") prop))) - -(define - dom-set-style - (fn - (el prop val) - (host-call (host-get el "style") "setProperty" prop val))) - -(define dom-get-prop (fn (el name) (host-get el name))) - -(define dom-set-prop (fn (el name val) (host-set! el name val))) - -(define - dom-tag-name - (fn (el) (if el (lower (or (host-get el "tagName") "")) ""))) - -(define dom-node-type (fn (el) (host-get el "nodeType"))) - -(define dom-node-name (fn (el) (host-get el "nodeName"))) - -(define dom-id (fn (el) (host-get el "id"))) - -(define dom-parent (fn (el) (host-get el "parentNode"))) - -(define dom-first-child (fn (el) (host-get el "firstChild"))) - -(define dom-next-sibling (fn (el) (host-get el "nextSibling"))) - -(define - dom-child-list - (fn - (el) - "Return child nodes as an SX list." - (if - el - (let - ((nl (host-get el "childNodes")) - (n (host-get nl "length")) - (result (list))) - (let - loop - ((i 0)) - (when - (< i n) - (append! result (host-call nl "item" i)) - (loop (+ i 1)))) - result) - (list)))) - -(define dom-is-fragment? (fn (el) (= (host-get el "nodeType") 11))) - -(define - dom-child-nodes - (fn - (el) - "Return child nodes as an SX list." - (if - el - (let - ((nl (host-get el "childNodes")) - (n (host-get nl "length")) - (result (list))) - (let - loop - ((i 0)) - (when - (< i n) - (append! result (host-call nl "item" i)) - (loop (+ i 1)))) - result) - (list)))) - -(define - dom-remove-children-after - (fn - (marker) - "Remove all siblings after marker node." - (let - ((parent (dom-parent marker))) - (when - parent - (let - loop - () + ((v (host-call el "getAttribute" name))) + (if (nil? v) nil v)) + nil))) + (define + dom-set-attr + (fn + (el name val) + (when + (and el (host-get el "setAttribute")) + (host-call el "setAttribute" name val)))) + (define + dom-remove-attr + (fn + (el name) + (when + (and el (host-get el "removeAttribute")) + (host-call el "removeAttribute" name)))) + (define + dom-has-attr? + (fn + (el name) + (if + (and el (host-get el "hasAttribute")) + (host-call el "hasAttribute" name) + false))) + (define + dom-add-class + (fn + (el cls) + (when el (host-call (host-get el "classList") "add" cls)))) + (define + dom-remove-class + (fn + (el cls) + (when el (host-call (host-get el "classList") "remove" cls)))) + (define + dom-has-class? + (fn + (el cls) + (if el (host-call (host-get el "classList") "contains" cls) false))) + (define dom-text-content (fn (el) (host-get el "textContent"))) + (define + dom-set-text-content + (fn (el val) (host-set! el "textContent" val))) + (define dom-inner-html (fn (el) (host-get el "innerHTML"))) + (define dom-set-inner-html (fn (el val) (host-set! el "innerHTML" val))) + (define dom-outer-html (fn (el) (host-get el "outerHTML"))) + (define + dom-insert-adjacent-html + (fn + (el position html) + (host-call el "insertAdjacentHTML" position html))) + (define + dom-get-style + (fn (el prop) (host-get (host-get el "style") prop))) + (define + dom-set-style + (fn + (el prop val) + (host-call (host-get el "style") "setProperty" prop val))) + (define dom-get-prop (fn (el name) (host-get el name))) + (define dom-set-prop (fn (el name val) (host-set! el name val))) + (define + dom-tag-name + (fn (el) (if el (lower (or (host-get el "tagName") "")) ""))) + (define dom-node-type (fn (el) (host-get el "nodeType"))) + (define dom-node-name (fn (el) (host-get el "nodeName"))) + (define dom-id (fn (el) (host-get el "id"))) + (define dom-parent (fn (el) (host-get el "parentNode"))) + (define dom-first-child (fn (el) (host-get el "firstChild"))) + (define dom-next-sibling (fn (el) (host-get el "nextSibling"))) + (define + dom-child-list + (fn + (el) + "Return child nodes as an SX list." + (if + el (let - ((next (dom-next-sibling marker))) - (when next (host-call parent "removeChild" next) (loop)))))))) - -(define dom-focus (fn (el) (when el (host-call el "focus")))) - -(define - dom-parse-html - (fn - (html) - (let - ((parser (host-new "DOMParser")) - (doc (host-call parser "parseFromString" html "text/html"))) - (host-get (host-get doc "body") "childNodes")))) - -(define - dom-listen - (fn - (el event-name handler) - (let - ((cb (host-callback handler))) - (host-call el "addEventListener" event-name cb) - (fn () (host-call el "removeEventListener" event-name cb))))) - -(define - dom-add-listener - (fn - (el event-name handler opts) - (let - ((cb (host-callback handler))) - (if - opts - (host-call el "addEventListener" event-name cb opts) - (host-call el "addEventListener" event-name cb)) - (fn () (host-call el "removeEventListener" event-name cb))))) - -(define - dom-dispatch - (fn - (el event-name detail) - (let - ((evt (host-new "CustomEvent" event-name (dict "detail" detail "bubbles" true)))) - (host-call el "dispatchEvent" evt)))) - -(define event-detail (fn (evt) (host-get evt "detail"))) - -(define prevent-default (fn (e) (when e (host-call e "preventDefault")))) - -(define stop-propagation (fn (e) (when e (host-call e "stopPropagation")))) - -(define - event-modifier-key? - (fn - (e) - (and - e - (or - (host-get e "ctrlKey") - (host-get e "metaKey") - (host-get e "shiftKey") - (host-get e "altKey"))))) - -(define - element-value - (fn - (el) - (if - (and el (not (nil? (host-get el "value")))) - (host-get el "value") - nil))) - -(define - error-message - (fn - (e) - (if (and e (host-get e "message")) (host-get e "message") (str e)))) - -(define - dom-get-data - (fn - (el key) - (let - ((store (host-get el "__sx_data"))) - (if store (host-get store key) nil)))) - -(define - dom-set-data - (fn - (el key val) - (when - (not (host-get el "__sx_data")) - (host-set! el "__sx_data" (dict))) - (host-set! (host-get el "__sx_data") key val))) - -(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))) - - -)) + ((nl (host-get el "childNodes")) + (n (host-get nl "length")) + (result (list))) + (let + loop + ((i 0)) + (when + (< i n) + (append! result (host-call nl "item" i)) + (loop (+ i 1)))) + result) + (list)))) + (define dom-is-fragment? (fn (el) (= (host-get el "nodeType") 11))) + (define + dom-child-nodes + (fn + (el) + "Return child nodes as an SX list." + (if + el + (let + ((nl (host-get el "childNodes")) + (n (host-get nl "length")) + (result (list))) + (let + loop + ((i 0)) + (when + (< i n) + (append! result (host-call nl "item" i)) + (loop (+ i 1)))) + result) + (list)))) + (define + dom-remove-children-after + (fn + (marker) + "Remove all siblings after marker node." + (let + ((parent (dom-parent marker))) + (when + parent + (let + loop + () + (let + ((next (dom-next-sibling marker))) + (when next (host-call parent "removeChild" next) (loop)))))))) + (define dom-focus (fn (el) (when el (host-call el "focus")))) + (define + dom-parse-html + (fn + (html) + (let + ((parser (host-new "DOMParser")) + (doc (host-call parser "parseFromString" html "text/html"))) + (host-get (host-get doc "body") "childNodes")))) + (define + dom-listen + (fn + (el event-name handler) + (let + ((cb (host-callback handler))) + (host-call el "addEventListener" event-name cb) + (fn () (host-call el "removeEventListener" event-name cb))))) + (define + dom-add-listener + (fn + (el event-name handler opts) + (let + ((cb (host-callback handler))) + (if + opts + (host-call el "addEventListener" event-name cb opts) + (host-call el "addEventListener" event-name cb)) + (fn () (host-call el "removeEventListener" event-name cb))))) + (define + dom-dispatch + (fn + (el event-name detail) + (let + ((evt (host-new "CustomEvent" event-name (dict "detail" detail "bubbles" true)))) + (host-call el "dispatchEvent" evt)))) + (define event-detail (fn (evt) (host-get evt "detail"))) + (define + prevent-default + (fn (e) (when e (host-call e "preventDefault")))) + (define + stop-propagation + (fn (e) (when e (host-call e "stopPropagation")))) + (define + event-modifier-key? + (fn + (e) + (and + e + (or + (host-get e "ctrlKey") + (host-get e "metaKey") + (host-get e "shiftKey") + (host-get e "altKey"))))) + (define + element-value + (fn + (el) + (if + (and el (not (nil? (host-get el "value")))) + (host-get el "value") + nil))) + (define + error-message + (fn + (e) + (if (and e (host-get e "message")) (host-get e "message") (str e)))) + (define + dom-get-data + (fn + (el key) + (let + ((store (host-get el "__sx_data"))) + (if store (host-get store key) nil)))) + (define + dom-set-data + (fn + (el key val) + (when + (not (host-get el "__sx_data")) + (host-set! el "__sx_data" (dict))) + (host-set! (host-get el "__sx_data") key val))) + (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))))) ;; Re-export to global env +(define + dom-visible? + (fn + (el) + (if + el + (not (= (host-get (host-get el "style") "display") "none")) + false))) + (import (sx dom))