giles
4aa49e42e8
- htmx-boot-subtree! wired into process-elements for auto-activation
- Fixed cond compilation bug in hx-verb-info (Clojure-style flat cond)
- Platform io-fetch upgraded: method/body/headers support, full response dict
- Replaced perform IO ops with browser primitives (set-timeout, browser-confirm, etc)
- SX→HTML rendering in hx-do-swap with OOB section filtering
- hx-collect-params: collects input name/value for all methods
- Handler naming: ex-{slug} convention, removed perform IO dependencies
- Test runner page at (test.(applications.(htmx))) with iframe-based runner
- Header "test" link on every page linking to test URL
- Page file restructure: 285 files moved to URL-matching paths (a/b/c/index.sx)
- page-functions.sx: ~100 component name references updated
- _test added to skip_dirs, test- file prefix convention for test files
Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
1211 lines
41 KiB
Plaintext
1211 lines
41 KiB
Plaintext
;; htmx.sx — hx-* attributes as hyperscript sugar (htmx 4.0 compat)
|
|
;;
|
|
;; Every hx- attribute is syntactic sugar for a hyperscript event handler.
|
|
;; htmx-activate! scans hx-* attributes, builds the equivalent handler
|
|
;; from the same runtime primitives the hyperscript compiler emits,
|
|
;; and registers it via hs-on — same bytecode path, zero duplication.
|
|
;;
|
|
;; The translation:
|
|
;; <button hx-get="/api" hx-target="#list" hx-swap="innerHTML">
|
|
;; is exactly:
|
|
;; <button _="on click fetch /api then put it into #list">
|
|
;; Both use hs-on + perform io-fetch + dom-set-inner-html. Same runtime.
|
|
;;
|
|
;; htmx 4.0 features:
|
|
;; - hx-action/hx-method as verb alternative
|
|
;; - :inherited modifier for explicit attribute inheritance
|
|
;; - Swap aliases: before/after/prepend/append + innerMorph/outerMorph
|
|
;; - htmx:phase:action event naming
|
|
;; - All responses swap (except 204/304)
|
|
;; - hx-ignore (processing) vs hx-disable (form elements)
|
|
;; - hx-config per-element JSON config
|
|
;;
|
|
;; Entry points:
|
|
;; (htmx-activate! el) — activate hx-* attributes on one element
|
|
;; (htmx-boot-subtree! root) — activate all hx-* elements in subtree
|
|
|
|
;; ── Config defaults (htmx 4.0) ─────────────────────────────────
|
|
|
|
(define HX-CONFIG-DEFAULTS {:defaultTimeout 60000 :transitions false :defaultSwap "innerHTML" :requestClass "htmx-request" :defaultSettleDelay 1 :implicitInheritance false :noSwap (list 204 304)})
|
|
|
|
(define HX-REQUEST-CLASS "htmx-request")
|
|
|
|
;; ── Per-element config ──────────────────────────────────────────
|
|
|
|
(define
|
|
url-encode-params
|
|
(fn
|
|
(params)
|
|
"Encode dict as URL query string: {:a 1 :b 2} → 'a=1&b=2'."
|
|
(let
|
|
((pairs (map (fn (key) (str (str key) "=" (get params key))) (keys params))))
|
|
(join "&" pairs))))
|
|
|
|
;; ── Attribute inheritance (v4: explicit with :inherited) ────────
|
|
|
|
(define
|
|
sx-url-with-params
|
|
(fn
|
|
(url params)
|
|
"Embed params as :key \"value\" keywords inside an SX URL's innermost paren.\n /sx/(a.(b)) + {:q \"hi\"} → /sx/(a.(b :q \"hi\"))"
|
|
(if
|
|
(not (contains? url "("))
|
|
(str url "?" (url-encode-params params))
|
|
(let
|
|
((i (- (len url) 1)) (count 0))
|
|
(when
|
|
(and (>= i 0) (= (nth url i) ")"))
|
|
(set! count (+ count 1))
|
|
(set! i (- i 1)))
|
|
(when
|
|
(and (>= i 0) (= (nth url i) ")"))
|
|
(set! count (+ count 1))
|
|
(set! i (- i 1)))
|
|
(when
|
|
(and (>= i 0) (= (nth url i) ")"))
|
|
(set! count (+ count 1))
|
|
(set! i (- i 1)))
|
|
(when
|
|
(and (>= i 0) (= (nth url i) ")"))
|
|
(set! count (+ count 1))
|
|
(set! i (- i 1)))
|
|
(when
|
|
(and (>= i 0) (= (nth url i) ")"))
|
|
(set! count (+ count 1))
|
|
(set! i (- i 1)))
|
|
(when
|
|
(and (>= i 0) (= (nth url i) ")"))
|
|
(set! count (+ count 1))
|
|
(set! i (- i 1)))
|
|
(let
|
|
((base (slice url 0 (+ i 1)))
|
|
(suffix (slice url (+ i 1)))
|
|
(kw-str
|
|
(join
|
|
" "
|
|
(map
|
|
(fn (k) (str ":" k " \"" (get params k) "\""))
|
|
(keys params)))))
|
|
(str base " " kw-str suffix))))))
|
|
|
|
(define
|
|
hx-element-config
|
|
(fn
|
|
(el key)
|
|
"Read config value: hx-config JSON on element → global defaults."
|
|
(let
|
|
((cfg-raw (dom-get-attr el "hx-config")))
|
|
(if
|
|
cfg-raw
|
|
(let
|
|
((cfg (json-parse cfg-raw)))
|
|
(or (get cfg key) (get HX-CONFIG-DEFAULTS key)))
|
|
(get HX-CONFIG-DEFAULTS key)))))
|
|
|
|
;; ── Verb scanning (v4: hx-get/post/put/delete/patch + hx-action/hx-method) ──
|
|
|
|
(define
|
|
hx-walk-inherited
|
|
(fn
|
|
(el attr)
|
|
"Walk ancestors looking for attr:inherited."
|
|
(let
|
|
((inherited-attr (str attr ":inherited")) (parent (dom-parent el)))
|
|
(if
|
|
(not parent)
|
|
nil
|
|
(let
|
|
((val (dom-get-attr parent inherited-attr)))
|
|
(if val val (hx-walk-inherited parent attr)))))))
|
|
|
|
;; ── Default trigger ─────────────────────────────────────────────
|
|
|
|
(define
|
|
hx-resolve-attr
|
|
(fn
|
|
(el attr)
|
|
"Resolve attribute, checking :inherited on ancestors.\n v4 default: no implicit inheritance."
|
|
(or (dom-get-attr el attr) (hx-walk-inherited el attr))))
|
|
|
|
;; ── Time parsing ────────────────────────────────────────────────
|
|
|
|
(define
|
|
hx-verb-info
|
|
(fn
|
|
(el)
|
|
"Scan verb attributes. Returns (method url) or nil.\n v4 supports both hx-get='/url' and hx-action='/url' hx-method='get'."
|
|
(let
|
|
((get-url (dom-get-attr el "hx-get"))
|
|
(post-url (dom-get-attr el "hx-post"))
|
|
(put-url (dom-get-attr el "hx-put"))
|
|
(del-url (dom-get-attr el "hx-delete"))
|
|
(patch-url (dom-get-attr el "hx-patch"))
|
|
(action (dom-get-attr el "hx-action"))
|
|
(method (dom-get-attr el "hx-method")))
|
|
(cond
|
|
get-url
|
|
(list "GET" get-url)
|
|
post-url
|
|
(list "POST" post-url)
|
|
put-url
|
|
(list "PUT" put-url)
|
|
del-url
|
|
(list "DELETE" del-url)
|
|
patch-url
|
|
(list "PATCH" patch-url)
|
|
(and action method)
|
|
(list (upcase method) action)
|
|
action
|
|
(list "GET" action)
|
|
true
|
|
nil))))
|
|
|
|
;; ── Trigger parsing ─────────────────────────────────────────────
|
|
|
|
(define
|
|
hx-default-trigger
|
|
(fn
|
|
(el)
|
|
"Default trigger: form→submit, input/select/textarea→change, else→click."
|
|
(let
|
|
((tag (downcase (dom-tag-name el))))
|
|
(cond
|
|
((= tag "form") "submit")
|
|
((or (= tag "input") (= tag "textarea") (= tag "select")) "change")
|
|
(true "click")))))
|
|
|
|
;; ── Target resolution ───────────────────────────────────────────
|
|
|
|
(define
|
|
hx-parse-time
|
|
(fn
|
|
(raw)
|
|
"Parse time spec: '500ms'→500, '1s'→1000, '2m'→120000."
|
|
(cond
|
|
((not raw) nil)
|
|
((ends-with? raw "ms") (parse-number (slice raw 0 (- (len raw) 2))))
|
|
((ends-with? raw "s")
|
|
(* 1000 (parse-number (slice raw 0 (- (len raw) 1)))))
|
|
((ends-with? raw "m")
|
|
(* 60000 (parse-number (slice raw 0 (- (len raw) 1)))))
|
|
(true (parse-number raw)))))
|
|
|
|
;; ── Swap mode resolution (v4 aliases + morph) ───────────────────
|
|
|
|
(define
|
|
hx-parse-trigger
|
|
(fn
|
|
(raw el)
|
|
"Parse hx-trigger spec. Returns {:event :delay :throttle :once :changed :from :filter}."
|
|
(if
|
|
(not raw)
|
|
{:filter nil :delay nil :throttle nil :from nil :event (hx-default-trigger el) :changed false :once false}
|
|
(let
|
|
((parts (split (trim raw) " "))
|
|
(event (first parts))
|
|
(delay-ms nil)
|
|
(throttle-ms nil)
|
|
(once false)
|
|
(changed false)
|
|
(from-sel nil)
|
|
(filter nil))
|
|
(for-each
|
|
(fn
|
|
(part)
|
|
(cond
|
|
((starts-with? part "delay:")
|
|
(set! delay-ms (hx-parse-time (slice part 6))))
|
|
((starts-with? part "throttle:")
|
|
(set! throttle-ms (hx-parse-time (slice part 9))))
|
|
((= part "once") (set! once true))
|
|
((= part "changed") (set! changed true))
|
|
((starts-with? part "from:") (set! from-sel (slice part 5)))
|
|
((starts-with? part "[") (set! filter part))
|
|
(true nil)))
|
|
(rest parts))
|
|
{:filter filter :delay delay-ms :throttle throttle-ms :from from-sel :event event :changed changed :once once}))))
|
|
|
|
(define
|
|
hx-resolve-target
|
|
(fn
|
|
(el spec)
|
|
"Resolve hx-target: nil→el, 'this'→el, 'closest sel'→walk up, '#id'→query."
|
|
(let
|
|
((target-spec (or spec (hx-resolve-attr el "hx-target"))))
|
|
(cond
|
|
((not target-spec) el)
|
|
((= target-spec "this") el)
|
|
((= target-spec "body") (dom-body))
|
|
((starts-with? target-spec "closest ")
|
|
(dom-closest el (slice target-spec 8)))
|
|
((starts-with? target-spec "find ")
|
|
(dom-query el (slice target-spec 5)))
|
|
((starts-with? target-spec "next ")
|
|
(hs-next el (slice target-spec 5)))
|
|
((starts-with? target-spec "previous ")
|
|
(hs-previous el (slice target-spec 9)))
|
|
(true (dom-query (dom-body) target-spec))))))
|
|
|
|
;; ── Swap execution (all v4 modes) ───────────────────────────────
|
|
|
|
(define
|
|
hx-normalize-swap-mode
|
|
(fn
|
|
(mode)
|
|
"Normalize v4 swap aliases to canonical names."
|
|
(cond
|
|
((= mode "before") "beforebegin")
|
|
((= mode "after") "afterend")
|
|
((= mode "prepend") "afterbegin")
|
|
((= mode "append") "beforeend")
|
|
(true mode))))
|
|
|
|
;; ── Select fragment ─────────────────────────────────────────────
|
|
|
|
(define
|
|
hx-parse-swap-spec
|
|
(fn
|
|
(raw)
|
|
"Parse swap spec with all v4 modifiers.\n Returns {:mode :swap-delay :settle-delay :scroll :show-target :transition :strip :target :ignore-title}."
|
|
(if
|
|
(not raw)
|
|
{:ignore-title false :transition false :target nil :strip false :scroll nil :mode "innerHTML" :settle-delay nil :show-target nil :swap-delay nil}
|
|
(let
|
|
((parts (split raw " "))
|
|
(mode (hx-normalize-swap-mode (first parts)))
|
|
(swap-delay nil)
|
|
(settle-delay nil)
|
|
(scroll nil)
|
|
(show-target nil)
|
|
(transition false)
|
|
(strip false)
|
|
(target nil)
|
|
(ignore-title false))
|
|
(for-each
|
|
(fn
|
|
(part)
|
|
(cond
|
|
((starts-with? part "swap:")
|
|
(set! swap-delay (hx-parse-time (slice part 5))))
|
|
((starts-with? part "settle:")
|
|
(set! settle-delay (hx-parse-time (slice part 7))))
|
|
((starts-with? part "scroll:") (set! scroll (slice part 7)))
|
|
((starts-with? part "show:") (set! scroll (slice part 5)))
|
|
((starts-with? part "showTarget:")
|
|
(set! show-target (slice part 11)))
|
|
((starts-with? part "scrollTarget:")
|
|
(set! show-target (slice part 13)))
|
|
((= part "transition:true") (set! transition true))
|
|
((= part "strip:true") (set! strip true))
|
|
((starts-with? part "target:") (set! target (slice part 7)))
|
|
((= part "ignoreTitle:true") (set! ignore-title true))
|
|
(true nil)))
|
|
(rest parts))
|
|
{:ignore-title ignore-title :transition transition :target target :strip strip :scroll scroll :mode mode :settle-delay settle-delay :show-target show-target :swap-delay swap-delay}))))
|
|
|
|
;; ── Request building (v4 headers) ───────────────────────────────
|
|
|
|
(define
|
|
hx-swap!
|
|
(fn
|
|
(target content mode)
|
|
"Swap content into target. Supports all v4 modes."
|
|
(cond
|
|
((= mode "innerHTML") (dom-set-inner-html target content))
|
|
((= mode "outerHTML")
|
|
(do
|
|
(dom-insert-adjacent-html target "afterend" content)
|
|
(dom-remove target)))
|
|
((= mode "afterend")
|
|
(dom-insert-adjacent-html target "afterend" content))
|
|
((= mode "beforeend")
|
|
(dom-insert-adjacent-html target "beforeend" content))
|
|
((= mode "afterbegin")
|
|
(dom-insert-adjacent-html target "afterbegin" content))
|
|
((= mode "beforebegin")
|
|
(dom-insert-adjacent-html target "beforebegin" content))
|
|
((= mode "delete") (dom-remove target))
|
|
((= mode "none") nil)
|
|
((= mode "textContent") (dom-set-text-content target content))
|
|
((= mode "innerMorph") (dom-set-inner-html target content))
|
|
((= mode "outerMorph")
|
|
(do
|
|
(dom-insert-adjacent-html target "afterend" content)
|
|
(dom-remove target)))
|
|
(true (dom-set-inner-html target content)))))
|
|
|
|
(define
|
|
hx-select-fragment
|
|
(fn
|
|
(html selector)
|
|
"Extract fragment matching selector from HTML response (hx-select)."
|
|
(if
|
|
(not selector)
|
|
html
|
|
(let
|
|
((doc (dom-parse-html html)))
|
|
(let
|
|
((found (dom-query doc selector)))
|
|
(if found (dom-outer-html found) html))))))
|
|
|
|
(define
|
|
hx-element-source-id
|
|
(fn
|
|
(el)
|
|
"Format element as tagName#id for v4 HX-Source header."
|
|
(let
|
|
((tag (downcase (dom-tag-name el))) (id (dom-get-attr el "id")))
|
|
(if id (str tag "#" id) tag))))
|
|
|
|
(define
|
|
hx-form-values
|
|
(fn
|
|
(form-el)
|
|
"Extract name=value pairs from form inputs."
|
|
(let
|
|
((inputs (dom-query-all form-el "input, select, textarea"))
|
|
(result {}))
|
|
(for-each
|
|
(fn
|
|
(input)
|
|
(let
|
|
((name (dom-get-attr input "name"))
|
|
(val (element-value input)))
|
|
(when name (set! result (assoc result name val)))))
|
|
inputs)
|
|
result)))
|
|
|
|
(define
|
|
hx-collect-params
|
|
(fn
|
|
(el method)
|
|
"Collect request params: form values + hx-include + hx-vals + element name/value."
|
|
(let
|
|
((params {}))
|
|
(when
|
|
(= (downcase (dom-tag-name el)) "form")
|
|
(set! params (hx-form-values el)))
|
|
(let
|
|
((tag (downcase (dom-tag-name el))))
|
|
(when
|
|
(or (= tag "input") (= tag "select") (= tag "textarea"))
|
|
(let
|
|
((name (dom-get-attr el "name")))
|
|
(when name (set! params (assoc params name (element-value el)))))))
|
|
(let
|
|
((include-sel (dom-get-attr el "hx-include")))
|
|
(when
|
|
include-sel
|
|
(let
|
|
((other (dom-query include-sel)))
|
|
(when other (set! params (merge params (hx-form-values other)))))))
|
|
(let
|
|
((vals-raw (dom-get-attr el "hx-vals")))
|
|
(when
|
|
vals-raw
|
|
(let
|
|
((extra (json-parse vals-raw)))
|
|
(when extra (set! params (merge params extra))))))
|
|
params)))
|
|
|
|
;; ── OOB processing (v4: main swap first, then OOB) ─────────────
|
|
|
|
(define
|
|
hx-build-headers
|
|
(fn
|
|
(el target-el)
|
|
"Build v4 request headers."
|
|
(let
|
|
((headers {:HX-Source (hx-element-source-id el) :HX-Request "true" :Accept "text/html" :HX-Request-Type "partial"}))
|
|
(when
|
|
target-el
|
|
(set!
|
|
headers
|
|
(assoc headers :HX-Target (hx-element-source-id target-el))))
|
|
(set! headers (assoc headers :HX-Current-URL (browser-location-href)))
|
|
(let
|
|
((extra-raw (hx-resolve-attr el "hx-headers")))
|
|
(when
|
|
extra-raw
|
|
(let
|
|
((extra (json-parse extra-raw)))
|
|
(when extra (set! headers (merge headers extra))))))
|
|
headers)))
|
|
|
|
;; ── History ─────────────────────────────────────────────────────
|
|
|
|
(define
|
|
hx-request
|
|
(fn
|
|
(el url method target-el)
|
|
"Issue HTTP request with v4 conventions.\n Returns {:status :body :headers} for status-based dispatch."
|
|
(let
|
|
((params (hx-collect-params el method))
|
|
(headers (hx-build-headers el target-el))
|
|
(encoding (dom-get-attr el "hx-encoding"))
|
|
(etag (dom-get-data el "hx-etag")))
|
|
(let
|
|
((fetch-url (if (or (= method "GET") (= method "DELETE")) (if (empty? params) url (str url "?" (url-encode-params params))) url))
|
|
(body
|
|
(if
|
|
(or (= method "GET") (= method "DELETE"))
|
|
nil
|
|
(if
|
|
(= encoding "multipart/form-data")
|
|
params
|
|
(json-stringify params)))))
|
|
(when
|
|
(and body (not (= encoding "multipart/form-data")))
|
|
(set! headers (assoc headers :Content-Type "application/json")))
|
|
(when etag (set! headers (assoc headers :If-None-Match etag)))
|
|
(let
|
|
((raw (perform (list (quote io-fetch) fetch-url method body headers))))
|
|
(let
|
|
((status (host-get raw "status"))
|
|
(resp-body (host-get raw "body"))
|
|
(resp-headers (host-get raw "headers")))
|
|
(when
|
|
(host-get resp-headers "etag")
|
|
(dom-set-data el "hx-etag" (host-get resp-headers "etag")))
|
|
{:status status :headers resp-headers :body resp-body}))))))
|
|
|
|
;; ── Indicator ───────────────────────────────────────────────────
|
|
|
|
(define
|
|
hx-process-oob!
|
|
(fn
|
|
(response-html)
|
|
"Process out-of-band swaps: elements with hx-swap-oob."
|
|
(let
|
|
((doc (dom-parse-html response-html)))
|
|
(let
|
|
((oob-els (dom-query-all doc "[hx-swap-oob]")))
|
|
(for-each
|
|
(fn
|
|
(oob-el)
|
|
(let
|
|
((spec (dom-get-attr oob-el "hx-swap-oob"))
|
|
(id (dom-get-attr oob-el "id")))
|
|
(when
|
|
id
|
|
(let
|
|
((target (dom-query (dom-body) (str "#" id)))
|
|
(mode
|
|
(hx-normalize-swap-mode
|
|
(if (= spec "true") "innerHTML" spec))))
|
|
(when
|
|
target
|
|
(dom-remove-attr oob-el "hx-swap-oob")
|
|
(hx-swap! target (dom-outer-html oob-el) mode))))))
|
|
oob-els)))))
|
|
|
|
(define
|
|
hx-process-partials!
|
|
(fn
|
|
(response-html)
|
|
"Process <hx-partial> elements: each specifies its own target + swap.\n v4: swaps in document order after main content."
|
|
(let
|
|
((doc (dom-parse-html response-html)))
|
|
(let
|
|
((partials (dom-query-all doc "hx-partial")))
|
|
(for-each
|
|
(fn
|
|
(partial)
|
|
(let
|
|
((target-sel (dom-get-attr partial "hx-target"))
|
|
(swap-mode (or (dom-get-attr partial "hx-swap") "innerHTML")))
|
|
(when
|
|
target-sel
|
|
(let
|
|
((target (dom-query (dom-body) target-sel))
|
|
(mode (hx-normalize-swap-mode swap-mode)))
|
|
(when
|
|
target
|
|
(hx-swap! target (dom-inner-html partial) mode))))))
|
|
partials)))))
|
|
|
|
;; ── Disable form elements (v4: hx-disable) ─────────────────────
|
|
|
|
(define
|
|
hx-parse-status-modifiers
|
|
(fn
|
|
(value)
|
|
"Parse hx-status modifier string: 'swap:innerHTML target:#errors push:false'."
|
|
(let
|
|
((parts (split value " ")) (result {:target nil :transition nil :swap nil :select nil :push nil :replace nil}))
|
|
(for-each
|
|
(fn
|
|
(part)
|
|
(cond
|
|
((starts-with? part "swap:")
|
|
(set! result (assoc result :swap (slice part 5))))
|
|
((starts-with? part "target:")
|
|
(set! result (assoc result :target (slice part 7))))
|
|
((starts-with? part "select:")
|
|
(set! result (assoc result :select (slice part 7))))
|
|
((starts-with? part "push:")
|
|
(set! result (assoc result :push (slice part 5))))
|
|
((starts-with? part "replace:")
|
|
(set! result (assoc result :replace (slice part 8))))
|
|
((starts-with? part "transition:")
|
|
(set! result (assoc result :transition (slice part 11))))
|
|
(true nil)))
|
|
parts)
|
|
result)))
|
|
|
|
(define
|
|
hx-status-matches?
|
|
(fn
|
|
(status-str pattern)
|
|
"Check if status matches pattern: '404'='404', '50x'=500-509, '5xx'=500-599."
|
|
(cond
|
|
((= status-str pattern) true)
|
|
((and (= (len pattern) 3) (ends-with? pattern "xx") (= (slice status-str 0 1) (slice pattern 0 1)))
|
|
true)
|
|
((and (= (len pattern) 3) (ends-with? pattern "x") (not (ends-with? pattern "xx")) (= (slice status-str 0 2) (slice pattern 0 2)))
|
|
true)
|
|
(true false))))
|
|
|
|
;; ── Confirm ─────────────────────────────────────────────────────
|
|
|
|
(define
|
|
hx-parse-status-rules
|
|
(fn
|
|
(el)
|
|
"Scan element for hx-status:CODE attributes. Returns list of rule dicts."
|
|
(let
|
|
((attrs (dom-attr-list el)) (rules (list)))
|
|
(for-each
|
|
(fn
|
|
(attr)
|
|
(let
|
|
((name (get attr :name)) (value (get attr :value)))
|
|
(when
|
|
(starts-with? name "hx-status:")
|
|
(let
|
|
((code-str (slice name 10))
|
|
(specificity
|
|
(cond
|
|
((not (ends-with? code-str "x")) 3)
|
|
((and (ends-with? code-str "x") (not (ends-with? code-str "xx")))
|
|
2)
|
|
(true 1))))
|
|
(set!
|
|
rules
|
|
(append
|
|
rules
|
|
(list
|
|
(merge {:specificity specificity :code code-str} (hx-parse-status-modifiers value)))))))))
|
|
attrs)
|
|
rules)))
|
|
|
|
;; ── v4 event dispatch ───────────────────────────────────────────
|
|
|
|
(define
|
|
hx-match-status
|
|
(fn
|
|
(status rules)
|
|
"Match HTTP status against rules. Returns best match (highest specificity) or nil."
|
|
(let
|
|
((status-str (str status)) (best nil) (best-spec 0))
|
|
(for-each
|
|
(fn
|
|
(rule)
|
|
(let
|
|
((pattern (get rule :code)) (spec (get rule :specificity)))
|
|
(when
|
|
(and
|
|
(hx-status-matches? status-str pattern)
|
|
(> spec best-spec))
|
|
(set! best rule)
|
|
(set! best-spec spec))))
|
|
rules)
|
|
best)))
|
|
|
|
;; ── Handler builder ─────────────────────────────────────────────
|
|
;;
|
|
;; Builds a handler fn that calls the same runtime primitives as
|
|
;; compiled hyperscript. The handler for:
|
|
;; <button hx-get="/api" hx-target="#list" hx-swap="innerHTML"
|
|
;; hx-indicator="#spinner" hx-confirm="Sure?">
|
|
;; produces identical runtime calls to:
|
|
;; on click confirm 'Sure?' add .htmx-request to #spinner
|
|
;; fetch /api put the result into #list
|
|
;; remove .htmx-request from #spinner
|
|
|
|
(define
|
|
hx-handle-history!
|
|
(fn
|
|
(el url)
|
|
"Push or replace URL based on hx-push-url / hx-replace-url."
|
|
(let
|
|
((push (hx-resolve-attr el "hx-push-url"))
|
|
(replace (hx-resolve-attr el "hx-replace-url")))
|
|
(cond
|
|
((= push "true") (browser-push-state {:scrollY 0} "" url))
|
|
((and push (not (= push "false")))
|
|
(browser-push-state {:scrollY 0} "" push))
|
|
((= replace "true") (browser-replace-state {:scrollY 0} "" url))
|
|
((and replace (not (= replace "false")))
|
|
(browser-replace-state {:scrollY 0} "" replace))
|
|
(true nil)))))
|
|
|
|
;; ── Trigger wrappers ────────────────────────────────────────────
|
|
|
|
(define
|
|
hx-indicator-on!
|
|
(fn
|
|
(el)
|
|
"Add request class to element + indicator targets."
|
|
(dom-add-class el HX-REQUEST-CLASS)
|
|
(let
|
|
((sel (hx-resolve-attr el "hx-indicator")))
|
|
(when
|
|
sel
|
|
(for-each
|
|
(fn (ind) (dom-add-class ind HX-REQUEST-CLASS))
|
|
(dom-query-all (dom-body) sel))))))
|
|
|
|
(define
|
|
hx-indicator-off!
|
|
(fn
|
|
(el)
|
|
"Remove request class from element + indicator targets."
|
|
(dom-remove-class el HX-REQUEST-CLASS)
|
|
(let
|
|
((sel (hx-resolve-attr el "hx-indicator")))
|
|
(when
|
|
sel
|
|
(for-each
|
|
(fn (ind) (dom-remove-class ind HX-REQUEST-CLASS))
|
|
(dom-query-all (dom-body) sel))))))
|
|
|
|
(define
|
|
hx-disable-inputs!
|
|
(fn
|
|
(el)
|
|
"Disable form elements during request (v4 hx-disable)."
|
|
(let
|
|
((sel (dom-get-attr el "hx-disable")))
|
|
(when
|
|
sel
|
|
(for-each
|
|
(fn (input) (dom-set-attr input "disabled" "true"))
|
|
(dom-query-all (dom-body) sel))))))
|
|
|
|
;; ── Trigger registration ────────────────────────────────────────
|
|
|
|
(define
|
|
hx-enable-inputs!
|
|
(fn
|
|
(el)
|
|
"Re-enable form elements after request."
|
|
(let
|
|
((sel (dom-get-attr el "hx-disable")))
|
|
(when
|
|
sel
|
|
(for-each
|
|
(fn (input) (dom-remove-attr input "disabled"))
|
|
(dom-query-all (dom-body) sel))))))
|
|
|
|
;; ── Activation ──────────────────────────────────────────────────
|
|
|
|
(define
|
|
hx-confirm?
|
|
(fn
|
|
(el)
|
|
"Show confirm dialog if hx-confirm set. Returns true to proceed."
|
|
(let
|
|
((msg (hx-resolve-attr el "hx-confirm")))
|
|
(if msg (browser-confirm msg) true))))
|
|
|
|
;; ── Boot ────────────────────────────────────────────────────────
|
|
|
|
(define
|
|
hx-validate-form?
|
|
(fn
|
|
(el)
|
|
"Check form validity if hx-validate is set. Returns true to proceed."
|
|
(let
|
|
((validate (dom-get-attr el "hx-validate")))
|
|
(if
|
|
validate
|
|
(let
|
|
((form (if (= (downcase (dom-tag-name el)) "form") el (dom-closest el "form"))))
|
|
(if form (host-call form "checkValidity") true))
|
|
true))))
|
|
|
|
(define
|
|
hx-parse-sync-spec
|
|
(fn
|
|
(raw)
|
|
"Parse hx-sync='selector:strategy'. Returns {:selector :strategy :queue-mode} or nil."
|
|
(if
|
|
(not raw)
|
|
nil
|
|
(let
|
|
((colon-pos (index-of raw ":")))
|
|
(if
|
|
(not colon-pos)
|
|
{:strategy "drop" :selector raw :queue-mode nil}
|
|
(let
|
|
((selector (trim (slice raw 0 colon-pos)))
|
|
(rest-str (trim (slice raw (+ colon-pos 1)))))
|
|
(let
|
|
((strategy (if (starts-with? rest-str "queue") "queue" rest-str))
|
|
(qm
|
|
(if
|
|
(starts-with? rest-str "queue")
|
|
(let
|
|
((parts (split rest-str " ")))
|
|
(if (> (len parts) 1) (nth parts 1) "last"))
|
|
nil)))
|
|
{:strategy strategy :selector selector :queue-mode qm})))))))
|
|
|
|
(define
|
|
hx-sync-resolve-target
|
|
(fn
|
|
(el target-sel)
|
|
"Resolve sync target element."
|
|
(cond
|
|
((= target-sel "this") el)
|
|
((= target-sel "closest form") (dom-closest el "form"))
|
|
(true (dom-query (dom-body) target-sel)))))
|
|
|
|
;; ── Boost — progressive enhancement ────────────────────────────
|
|
|
|
(define
|
|
hx-sync-check!
|
|
(fn
|
|
(el)
|
|
"Check sync strategy. Returns true if request should proceed."
|
|
(let
|
|
((sync-spec (hx-parse-sync-spec (dom-get-attr el "hx-sync"))))
|
|
(if
|
|
(not sync-spec)
|
|
true
|
|
(let
|
|
((sync-el (hx-sync-resolve-target el (get sync-spec :selector)))
|
|
(strategy (get sync-spec :strategy)))
|
|
(if
|
|
(not sync-el)
|
|
true
|
|
(let
|
|
((in-flight (dom-get-data sync-el "hx-sync-in-flight")))
|
|
(cond
|
|
((= strategy "drop")
|
|
(if
|
|
in-flight
|
|
false
|
|
(do (dom-set-data sync-el "hx-sync-in-flight" true) true)))
|
|
((or (= strategy "abort") (= strategy "replace"))
|
|
(do
|
|
(when in-flight (dom-dispatch sync-el "htmx:abort" nil))
|
|
(dom-set-data sync-el "hx-sync-in-flight" true)
|
|
true))
|
|
((= strategy "queue")
|
|
(if
|
|
in-flight
|
|
(do (dom-set-data sync-el "hx-sync-queued" el) false)
|
|
(do (dom-set-data sync-el "hx-sync-in-flight" true) true)))
|
|
(true true)))))))))
|
|
|
|
(define
|
|
hx-sync-complete!
|
|
(fn
|
|
(el)
|
|
"Mark request complete. Fire queued request if any."
|
|
(let
|
|
((sync-spec (hx-parse-sync-spec (dom-get-attr el "hx-sync"))))
|
|
(when
|
|
sync-spec
|
|
(let
|
|
((sync-el (hx-sync-resolve-target el (get sync-spec :selector))))
|
|
(when
|
|
sync-el
|
|
(dom-set-data sync-el "hx-sync-in-flight" false)
|
|
(let
|
|
((queued (dom-get-data sync-el "hx-sync-queued")))
|
|
(when
|
|
queued
|
|
(dom-set-data sync-el "hx-sync-queued" nil)
|
|
(dom-dispatch queued "click" nil)))))))))
|
|
|
|
(define
|
|
hx-dispatch!
|
|
(fn
|
|
(el event-name detail)
|
|
"Dispatch htmx event with v4 naming (htmx:phase:action)."
|
|
(dom-dispatch el event-name detail)))
|
|
|
|
(define
|
|
hx-strip-outer
|
|
(fn
|
|
(html)
|
|
"Remove outer element, return inner content."
|
|
(let
|
|
((doc (dom-parse-html html)))
|
|
(let
|
|
((first-child (dom-first-child doc)))
|
|
(if first-child (dom-inner-html first-child) html)))))
|
|
|
|
(define
|
|
hx-do-swap
|
|
(fn
|
|
(el body status status-rules swap-spec select-sel target url)
|
|
"Execute swap phase: status overrides → select → strip → transition → swap → partials → OOB → history → settle."
|
|
(let
|
|
((override (hx-match-status status status-rules)))
|
|
(let
|
|
((eff-swap (if (and override (get override :swap)) (hx-normalize-swap-mode (get override :swap)) (get swap-spec :mode)))
|
|
(eff-target
|
|
(if
|
|
(and override (get override :target))
|
|
(dom-query (dom-body) (get override :target))
|
|
(or target el)))
|
|
(eff-select
|
|
(if
|
|
(and override (get override :select))
|
|
(get override :select)
|
|
select-sel))
|
|
(use-trans
|
|
(or
|
|
(get swap-spec :transition)
|
|
(and override (= (get override :transition) "true")))))
|
|
(hx-dispatch! el "htmx:before:swap" {:target eff-target :swap eff-swap :status status})
|
|
(let
|
|
((rendered-body (if (and body (starts-with? (trim body) "(")) (let ((parsed (first (parse body)))) (if (and (list? parsed) (= (first parsed) (quote <>))) (let ((children (filter (fn (child) (not (and (list? child) (some (fn (a) (and (= (type-of a) "keyword") (= (keyword-name a) "sx-swap-oob"))) child)))) (rest parsed)))) (render-to-html (cons (quote <>) children))) (render-to-html parsed))) body)))
|
|
(let
|
|
((content (if eff-select (hx-select-fragment rendered-body eff-select) rendered-body)))
|
|
(let
|
|
((final (if (get swap-spec :strip) (hx-strip-outer content) content)))
|
|
(if
|
|
use-trans
|
|
(perform
|
|
(list
|
|
(quote io-view-transition)
|
|
(fn () (hx-swap! eff-target final eff-swap))))
|
|
(hx-swap! eff-target final eff-swap))
|
|
(hx-dispatch! el "htmx:after:swap" nil)
|
|
(when
|
|
(not (and override (= (get override :push) "false")))
|
|
(hx-handle-history! el url))
|
|
(hs-wait (or (get swap-spec :settle-delay) 1))
|
|
(hx-dispatch! el "htmx:after:settle" nil))))))))
|
|
|
|
(define
|
|
hx-make-handler
|
|
(fn
|
|
(el method url)
|
|
"Build handler fn — Phase 2: status dispatch, sync, validate, partials, transitions, etag."
|
|
(let
|
|
((target-sel (hx-resolve-attr el "hx-target"))
|
|
(swap-spec
|
|
(hx-parse-swap-spec
|
|
(or (hx-resolve-attr el "hx-swap") "innerHTML")))
|
|
(select-sel (dom-get-attr el "hx-select"))
|
|
(status-rules (hx-parse-status-rules el)))
|
|
(fn
|
|
(event)
|
|
(when event (prevent-default event))
|
|
(when
|
|
(and (hx-sync-check! el) (hx-validate-form? el) (hx-confirm? el))
|
|
(hx-dispatch! el "htmx:before:request" {:method method :url url})
|
|
(hx-indicator-on! el)
|
|
(hx-disable-inputs! el)
|
|
(when
|
|
(get swap-spec :swap-delay)
|
|
(hs-wait (get swap-spec :swap-delay)))
|
|
(let
|
|
((target (hx-resolve-target el target-sel)))
|
|
(let
|
|
((response (hx-request el url method target)))
|
|
(let
|
|
((status (get response :status))
|
|
(body (get response :body)))
|
|
(hx-dispatch! el "htmx:after:request" {:method method :url url :status status})
|
|
(when
|
|
(not (or (= status 204) (= status 304)))
|
|
(hx-do-swap
|
|
el
|
|
body
|
|
status
|
|
status-rules
|
|
swap-spec
|
|
select-sel
|
|
target
|
|
url))
|
|
(hx-enable-inputs! el)
|
|
(hx-indicator-off! el)
|
|
(hx-sync-complete! el)
|
|
(when
|
|
(not (or (= status 204) (= status 304)))
|
|
(htmx-boot-subtree! (or target el))
|
|
(hs-boot-subtree! (or target el)))))))))))
|
|
|
|
(define
|
|
hx-wrap-debounce
|
|
(fn
|
|
(handler delay-ms)
|
|
"Wrap handler with debounce (delay: ms before firing)"
|
|
(let
|
|
((timer nil))
|
|
(fn
|
|
(event)
|
|
(when timer (clear-timeout timer))
|
|
(set!
|
|
timer
|
|
(set-timeout (fn () (set! timer nil) (handler event)) delay-ms))))))
|
|
|
|
(define
|
|
hx-wrap-throttle
|
|
(fn
|
|
(handler throttle-ms)
|
|
"Wrap handler with throttle."
|
|
(let
|
|
((last-time 0))
|
|
(fn
|
|
(event)
|
|
(let
|
|
((now (now-ms)))
|
|
(when
|
|
(> (- now last-time) throttle-ms)
|
|
(set! last-time now)
|
|
(handler event)))))))
|
|
|
|
(define
|
|
hx-wrap-changed
|
|
(fn
|
|
(handler el)
|
|
"Wrap handler: only fire if element value changed since last fire."
|
|
(let
|
|
((last-value nil))
|
|
(fn
|
|
(event)
|
|
(let
|
|
((current (element-value el)))
|
|
(when
|
|
(not (= current last-value))
|
|
(set! last-value current)
|
|
(handler event)))))))
|
|
|
|
(define
|
|
hx-register-trigger!
|
|
(fn
|
|
(el trigger-spec handler)
|
|
"Register event handler with trigger modifiers applied."
|
|
(let
|
|
((event (get trigger-spec :event))
|
|
(delay-ms (get trigger-spec :delay))
|
|
(throttle-ms (get trigger-spec :throttle))
|
|
(once (get trigger-spec :once))
|
|
(changed (get trigger-spec :changed))
|
|
(from-sel (get trigger-spec :from)))
|
|
(let
|
|
((wrapped handler))
|
|
(when changed (set! wrapped (hx-wrap-changed wrapped el)))
|
|
(when delay-ms (set! wrapped (hx-wrap-debounce wrapped delay-ms)))
|
|
(when
|
|
throttle-ms
|
|
(set! wrapped (hx-wrap-throttle wrapped throttle-ms)))
|
|
(let
|
|
((listen-target (if from-sel (dom-query (dom-body) from-sel) el)))
|
|
(cond
|
|
((= event "load") (wrapped nil))
|
|
((or (= event "revealed") (= event "intersect"))
|
|
(perform
|
|
(list
|
|
(quote io-observe-intersection)
|
|
el
|
|
(fn () (wrapped nil)))))
|
|
((= event "every")
|
|
(when
|
|
delay-ms
|
|
(perform
|
|
(list
|
|
(quote io-set-interval)
|
|
(fn () (wrapped nil))
|
|
delay-ms))))
|
|
(true (hs-on listen-target event wrapped))))))))
|
|
|
|
(define
|
|
htmx-activate!
|
|
(fn
|
|
(el)
|
|
"Scan hx-* attributes on element, build and register handler.\n Also handles: hx-preload, hx-sse-connect, hx-ignore."
|
|
(when
|
|
(not (dom-get-attr el "hx-ignore"))
|
|
(let
|
|
((verb-info (hx-verb-info el)))
|
|
(when
|
|
(and verb-info (not (dom-get-data el "hx-active")))
|
|
(dom-set-data el "hx-active" true)
|
|
(let
|
|
((method (first verb-info)) (url (nth verb-info 1)))
|
|
(let
|
|
((trigger-spec (hx-parse-trigger (dom-get-attr el "hx-trigger") el)))
|
|
(let
|
|
((handler (hx-make-handler el method url)))
|
|
(hx-register-trigger! el trigger-spec handler))))))
|
|
(when (dom-get-attr el "hx-preload") (hx-preload-register! el))
|
|
(when (dom-get-attr el "hx-sse-connect") (hx-sse-connect! el)))))
|
|
|
|
(define
|
|
HX-VERB-SELECTORS
|
|
"[hx-get],[hx-post],[hx-put],[hx-delete],[hx-patch],[hx-action],[hx-sse-connect],[hx-preload]")
|
|
|
|
(define
|
|
htmx-boot!
|
|
(fn
|
|
()
|
|
"Scan entire document for hx-* elements and activate."
|
|
(for-each htmx-activate! (dom-query-all (dom-body) HX-VERB-SELECTORS))
|
|
(hx-boost-subtree! nil)))
|
|
|
|
(define hx-preload-cache (list))
|
|
|
|
(define
|
|
hx-preload-register!
|
|
(fn
|
|
(el)
|
|
"Register preload: prefetch GET on mouseenter, cache result."
|
|
(let
|
|
((verb-info (hx-verb-info el)))
|
|
(when
|
|
(and verb-info (= (first verb-info) "GET"))
|
|
(let
|
|
((url (nth verb-info 1)))
|
|
(hs-on
|
|
el
|
|
"mouseenter"
|
|
(fn
|
|
(event)
|
|
(when
|
|
(not (get hx-preload-cache url))
|
|
(let
|
|
((raw (perform (list (quote io-fetch) url "GET" nil {:Accept "text/html"}))))
|
|
(let
|
|
((body (perform (list (quote io-parse-text) raw))))
|
|
(set! hx-preload-cache (assoc hx-preload-cache url body))))))))))))
|
|
|
|
(define
|
|
hx-parse-sse-swap
|
|
(fn
|
|
(raw)
|
|
"Parse hx-sse-swap='event:#target,event2:#target2:outerHTML'."
|
|
(if
|
|
(not raw)
|
|
(list)
|
|
(map
|
|
(fn
|
|
(spec-raw)
|
|
(let
|
|
((parts (split (trim spec-raw) ":")))
|
|
(cond
|
|
((= (len parts) 2) {:target (nth parts 1) :swap "innerHTML" :event (nth parts 0)})
|
|
((>= (len parts) 3) {:target (nth parts 1) :swap (nth parts 2) :event (nth parts 0)})
|
|
(true {:target nil :swap "innerHTML" :event (trim spec-raw)}))))
|
|
(split raw ",")))))
|
|
|
|
(define
|
|
hx-sse-connect!
|
|
(fn
|
|
(el)
|
|
"Connect to SSE endpoint. Dispatch events to swap targets."
|
|
(let
|
|
((url (dom-get-attr el "hx-sse-connect")))
|
|
(when
|
|
url
|
|
(let
|
|
((swap-specs (hx-parse-sse-swap (dom-get-attr el "hx-sse-swap"))))
|
|
(perform
|
|
(list
|
|
(quote io-event-source)
|
|
url
|
|
(fn
|
|
(event-name data)
|
|
(for-each
|
|
(fn
|
|
(spec)
|
|
(when
|
|
(= event-name (get spec :event))
|
|
(let
|
|
((target (dom-query (dom-body) (get spec :target))))
|
|
(when
|
|
target
|
|
(hx-swap!
|
|
target
|
|
data
|
|
(hx-normalize-swap-mode (get spec :swap)))
|
|
(htmx-boot-subtree! target)
|
|
(hs-boot-subtree! target)))))
|
|
swap-specs)))))))))
|
|
|
|
(define
|
|
htmx-boot-subtree!
|
|
(fn
|
|
(root)
|
|
"Activate hx-* elements in subtree. Called after swaps."
|
|
(when
|
|
root
|
|
(for-each htmx-activate! (dom-query-all root HX-VERB-SELECTORS))
|
|
(htmx-activate! root))))
|
|
|
|
(define
|
|
hx-boost-link!
|
|
(fn
|
|
(link)
|
|
"Boost an anchor: click → AJAX fetch → swap body → push URL."
|
|
(let
|
|
((href (dom-get-attr link "href")))
|
|
(when
|
|
(and
|
|
href
|
|
(not (hx-verb-info link))
|
|
(not (starts-with? href "http"))
|
|
(not (starts-with? href "mailto"))
|
|
(not (starts-with? href "#")))
|
|
(dom-set-attr link "hx-get" href)
|
|
(when
|
|
(not (dom-get-attr link "hx-target"))
|
|
(dom-set-attr link "hx-target" "body"))
|
|
(when
|
|
(not (dom-get-attr link "hx-swap"))
|
|
(dom-set-attr link "hx-swap" "innerHTML"))
|
|
(when
|
|
(not (dom-get-attr link "hx-push-url"))
|
|
(dom-set-attr link "hx-push-url" "true"))
|
|
(htmx-activate! link)))))
|
|
|
|
(define
|
|
hx-boost-form!
|
|
(fn
|
|
(form)
|
|
"Boost a form: submit → AJAX."
|
|
(let
|
|
((action (or (dom-get-attr form "action") ""))
|
|
(method (downcase (or (dom-get-attr form "method") "post"))))
|
|
(when
|
|
(not (hx-verb-info form))
|
|
(dom-set-attr form (str "hx-" method) action)
|
|
(when
|
|
(not (dom-get-attr form "hx-target"))
|
|
(dom-set-attr form "hx-target" "body"))
|
|
(when
|
|
(not (dom-get-attr form "hx-swap"))
|
|
(dom-set-attr form "hx-swap" "innerHTML"))
|
|
(htmx-activate! form)))))
|
|
|
|
(define
|
|
hx-boost-subtree!
|
|
(fn
|
|
(root)
|
|
"Apply hx-boost to links and forms within scope."
|
|
(let
|
|
((scope (or root (dom-body))))
|
|
(for-each
|
|
hx-boost-link!
|
|
(dom-query-all scope "[hx-boost] a, a[hx-boost]"))
|
|
(for-each
|
|
hx-boost-form!
|
|
(dom-query-all scope "[hx-boost] form, form[hx-boost]"))))) |