giles
b6e144a6fd
- boot.sx: popstate handler extracts scrollY from history state - engine.sx: pass scroll position to handle-popstate - boot-helpers.sx: scroll position tracking in navigation - orchestration.sx: scroll state management for back/forward nav - history.spec.js: new Playwright spec for history navigation Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
807 lines
23 KiB
Plaintext
807 lines
23 KiB
Plaintext
(define ENGINE_VERBS (list "get" "post" "put" "delete" "patch"))
|
|
|
|
(define DEFAULT_SWAP "outerHTML")
|
|
|
|
(define
|
|
parse-time
|
|
:effects ()
|
|
(fn
|
|
((s :as string))
|
|
(if
|
|
(nil? s)
|
|
0
|
|
(if
|
|
(ends-with? s "ms")
|
|
(parse-int s 0)
|
|
(if
|
|
(ends-with? s "s")
|
|
(* (parse-int (replace s "s" "") 0) 1000)
|
|
(parse-int s 0))))))
|
|
|
|
(define
|
|
parse-trigger-spec
|
|
:effects ()
|
|
(fn
|
|
((spec :as string))
|
|
(if
|
|
(nil? spec)
|
|
nil
|
|
(let
|
|
((raw-parts (split spec ",")))
|
|
(filter
|
|
(fn (x) (not (nil? x)))
|
|
(map
|
|
(fn
|
|
((part :as string))
|
|
(let
|
|
((tokens (split (trim part) " ")))
|
|
(if
|
|
(empty? tokens)
|
|
nil
|
|
(if
|
|
(and (= (first tokens) "every") (>= (len tokens) 2))
|
|
(dict
|
|
"event"
|
|
"every"
|
|
"modifiers"
|
|
(dict "interval" (parse-time (nth tokens 1))))
|
|
(let
|
|
((mods (dict)))
|
|
(for-each
|
|
(fn
|
|
((tok :as string))
|
|
(cond
|
|
(= tok "once")
|
|
(dict-set! mods "once" true)
|
|
(= tok "changed")
|
|
(dict-set! mods "changed" true)
|
|
(starts-with? tok "delay:")
|
|
(dict-set!
|
|
mods
|
|
"delay"
|
|
(parse-time (slice tok 6)))
|
|
(starts-with? tok "from:")
|
|
(dict-set! mods "from" (slice tok 5))))
|
|
(rest tokens))
|
|
(let
|
|
((raw-event (first tokens)))
|
|
(let
|
|
((bracket-idx (index-of raw-event "[")))
|
|
(if
|
|
(>= bracket-idx 0)
|
|
(do
|
|
(dict-set!
|
|
mods
|
|
"filter"
|
|
(slice
|
|
raw-event
|
|
(+ bracket-idx 1)
|
|
(- (len raw-event) 1)))
|
|
(dict
|
|
"event"
|
|
(slice raw-event 0 bracket-idx)
|
|
"modifiers"
|
|
mods))
|
|
(dict "event" raw-event "modifiers" mods)))))))))
|
|
raw-parts))))))
|
|
|
|
(define
|
|
default-trigger
|
|
:effects ()
|
|
(fn
|
|
((tag-name :as string))
|
|
(cond
|
|
(= tag-name "form")
|
|
(list (dict "event" "submit" "modifiers" (dict)))
|
|
(or
|
|
(= tag-name "input")
|
|
(= tag-name "select")
|
|
(= tag-name "textarea"))
|
|
(list (dict "event" "change" "modifiers" (dict)))
|
|
:else (list (dict "event" "click" "modifiers" (dict))))))
|
|
|
|
(define
|
|
get-verb-info
|
|
:effects (io)
|
|
(fn
|
|
(el)
|
|
(some
|
|
(fn
|
|
(verb)
|
|
(let
|
|
((url (dom-get-attr el (str "sx-" verb))))
|
|
(if url (dict "method" (upper verb) "url" url) nil)))
|
|
ENGINE_VERBS)))
|
|
|
|
(define
|
|
build-request-headers
|
|
:effects (io)
|
|
(fn
|
|
(el (loaded-components :as list) (css-hash :as string))
|
|
(let
|
|
((headers (dict "SX-Request" "true" "SX-Current-URL" (browser-location-href))))
|
|
(let
|
|
((target-sel (dom-get-attr el "sx-target")))
|
|
(when target-sel (dict-set! headers "SX-Target" target-sel)))
|
|
(let
|
|
((comp-hash (dom-get-attr (dom-query "script[data-components][data-hash]") "data-hash")))
|
|
(when comp-hash (dict-set! headers "SX-Components-Hash" comp-hash)))
|
|
(when css-hash (dict-set! headers "SX-Css" css-hash))
|
|
(let
|
|
((extra-h (dom-get-attr el "sx-headers")))
|
|
(when
|
|
extra-h
|
|
(let
|
|
((parsed (parse-header-value extra-h)))
|
|
(when
|
|
parsed
|
|
(for-each
|
|
(fn
|
|
((key :as string))
|
|
(dict-set! headers key (str (get parsed key))))
|
|
(keys parsed))))))
|
|
headers)))
|
|
|
|
(define
|
|
process-response-headers
|
|
:effects ()
|
|
(fn
|
|
((get-header :as lambda))
|
|
(dict
|
|
"redirect"
|
|
(get-header "SX-Redirect")
|
|
"refresh"
|
|
(get-header "SX-Refresh")
|
|
"trigger"
|
|
(get-header "SX-Trigger")
|
|
"retarget"
|
|
(get-header "SX-Retarget")
|
|
"reswap"
|
|
(get-header "SX-Reswap")
|
|
"location"
|
|
(get-header "SX-Location")
|
|
"replace-url"
|
|
(get-header "SX-Replace-Url")
|
|
"css-hash"
|
|
(get-header "SX-Css-Hash")
|
|
"trigger-swap"
|
|
(get-header "SX-Trigger-After-Swap")
|
|
"trigger-settle"
|
|
(get-header "SX-Trigger-After-Settle")
|
|
"content-type"
|
|
(get-header "Content-Type")
|
|
"cache-invalidate"
|
|
(get-header "SX-Cache-Invalidate")
|
|
"cache-update"
|
|
(get-header "SX-Cache-Update"))))
|
|
|
|
(define
|
|
parse-swap-spec
|
|
:effects ()
|
|
(fn
|
|
((raw-swap :as string) (global-transitions? :as boolean))
|
|
(let
|
|
((parts (split (or raw-swap DEFAULT_SWAP) " "))
|
|
(style (first parts))
|
|
(use-transition global-transitions?))
|
|
(for-each
|
|
(fn
|
|
((p :as string))
|
|
(cond
|
|
(= p "transition:true")
|
|
(set! use-transition true)
|
|
(= p "transition:false")
|
|
(set! use-transition false)))
|
|
(rest parts))
|
|
(dict "style" style "transition" use-transition))))
|
|
|
|
(define
|
|
parse-retry-spec
|
|
:effects ()
|
|
(fn
|
|
((retry-attr :as string))
|
|
(if
|
|
(nil? retry-attr)
|
|
nil
|
|
(let
|
|
((parts (split retry-attr ":")))
|
|
(dict
|
|
"strategy"
|
|
(first parts)
|
|
"start-ms"
|
|
(parse-int (nth parts 1) 1000)
|
|
"cap-ms"
|
|
(parse-int (nth parts 2) 30000))))))
|
|
|
|
(define
|
|
next-retry-ms
|
|
:effects ()
|
|
(fn
|
|
((current-ms :as number) (cap-ms :as number))
|
|
(min (* current-ms 2) cap-ms)))
|
|
|
|
(define
|
|
filter-params
|
|
:effects ()
|
|
(fn
|
|
((params-spec :as string) (all-params :as list))
|
|
(if
|
|
(nil? params-spec)
|
|
all-params
|
|
(if
|
|
(= params-spec "none")
|
|
(list)
|
|
(if
|
|
(= params-spec "*")
|
|
all-params
|
|
(if
|
|
(starts-with? params-spec "not ")
|
|
(let
|
|
((excluded (map trim (split (slice params-spec 4) ","))))
|
|
(filter
|
|
(fn ((p :as list)) (not (contains? excluded (first p))))
|
|
all-params))
|
|
(let
|
|
((allowed (map trim (split params-spec ","))))
|
|
(filter
|
|
(fn ((p :as list)) (contains? allowed (first p)))
|
|
all-params))))))))
|
|
|
|
(define
|
|
resolve-target
|
|
:effects (io)
|
|
(fn
|
|
(el)
|
|
(let
|
|
((sel (dom-get-attr el "sx-target")))
|
|
(cond
|
|
(or (nil? sel) (= sel "this"))
|
|
el
|
|
(= sel "closest")
|
|
(dom-parent el)
|
|
:else (dom-query sel)))))
|
|
|
|
(define
|
|
apply-optimistic
|
|
:effects (mutation io)
|
|
(fn
|
|
(el)
|
|
(let
|
|
((directive (dom-get-attr el "sx-optimistic")))
|
|
(if
|
|
(nil? directive)
|
|
nil
|
|
(let
|
|
((target (or (resolve-target el) el))
|
|
(state (dict "target" target "directive" directive)))
|
|
(cond
|
|
(= directive "remove")
|
|
(do
|
|
(dict-set! state "opacity" (dom-get-style target "opacity"))
|
|
(dom-set-style target "opacity" "0")
|
|
(dom-set-style target "pointer-events" "none"))
|
|
(= directive "disable")
|
|
(do
|
|
(dict-set! state "disabled" (dom-get-prop target "disabled"))
|
|
(dom-set-prop target "disabled" true))
|
|
(starts-with? directive "add-class:")
|
|
(let
|
|
((cls (slice directive 10)))
|
|
(dict-set! state "add-class" cls)
|
|
(dom-add-class target cls)))
|
|
state)))))
|
|
|
|
(define
|
|
revert-optimistic
|
|
:effects (mutation io)
|
|
(fn
|
|
((state :as dict))
|
|
(when
|
|
state
|
|
(let
|
|
((target (get state "target")) (directive (get state "directive")))
|
|
(cond
|
|
(= directive "remove")
|
|
(do
|
|
(dom-set-style target "opacity" (or (get state "opacity") ""))
|
|
(dom-set-style target "pointer-events" ""))
|
|
(= directive "disable")
|
|
(dom-set-prop target "disabled" (or (get state "disabled") false))
|
|
(get state "add-class")
|
|
(dom-remove-class target (get state "add-class")))))))
|
|
|
|
(define
|
|
find-oob-swaps
|
|
:effects (mutation io)
|
|
(fn
|
|
(container)
|
|
(let
|
|
((results (list)))
|
|
(for-each
|
|
(fn
|
|
((attr :as string))
|
|
(let
|
|
((oob-els (dom-query-all container (str "[" attr "]"))))
|
|
(for-each
|
|
(fn
|
|
(oob)
|
|
(let
|
|
((swap-type (or (dom-get-attr oob attr) "outerHTML"))
|
|
(target-id (dom-id oob)))
|
|
(dom-remove-attr oob attr)
|
|
(when
|
|
target-id
|
|
(append!
|
|
results
|
|
(dict
|
|
"element"
|
|
oob
|
|
"swap-type"
|
|
swap-type
|
|
"target-id"
|
|
target-id)))))
|
|
oob-els)))
|
|
(list "sx-swap-oob" "hx-swap-oob"))
|
|
results)))
|
|
|
|
(define
|
|
morph-node
|
|
:effects (mutation io)
|
|
(fn
|
|
(old-node new-node)
|
|
(cond
|
|
(or
|
|
(dom-has-attr? old-node "sx-preserve")
|
|
(dom-has-attr? old-node "sx-ignore"))
|
|
nil
|
|
(and
|
|
(dom-has-attr? old-node "data-sx-island")
|
|
(is-processed? old-node "island-hydrated")
|
|
(dom-has-attr? new-node "data-sx-island")
|
|
(=
|
|
(dom-get-attr old-node "data-sx-island")
|
|
(dom-get-attr new-node "data-sx-island")))
|
|
(do
|
|
(sync-attrs old-node new-node)
|
|
(morph-island-children old-node new-node))
|
|
(or
|
|
(not (= (dom-node-type old-node) (dom-node-type new-node)))
|
|
(not (= (dom-node-name old-node) (dom-node-name new-node))))
|
|
(dom-replace-child
|
|
(dom-parent old-node)
|
|
(dom-clone new-node true)
|
|
old-node)
|
|
(or (= (dom-node-type old-node) 3) (= (dom-node-type old-node) 8))
|
|
(when
|
|
(not (= (dom-text-content old-node) (dom-text-content new-node)))
|
|
(dom-set-text-content old-node (dom-text-content new-node)))
|
|
(= (dom-node-type old-node) 1)
|
|
(do
|
|
(when
|
|
(and
|
|
(dom-has-attr? old-node "data-sx-island")
|
|
(dom-has-attr? new-node "data-sx-island")
|
|
(not
|
|
(=
|
|
(dom-get-attr old-node "data-sx-island")
|
|
(dom-get-attr new-node "data-sx-island"))))
|
|
(dispose-island old-node)
|
|
(dispose-islands-in old-node))
|
|
(sync-attrs old-node new-node)
|
|
(when
|
|
(not
|
|
(and
|
|
(dom-is-active-element? old-node)
|
|
(dom-is-input-element? old-node)))
|
|
(morph-children old-node new-node))))))
|
|
|
|
(define
|
|
sync-attrs
|
|
:effects (mutation io)
|
|
(fn
|
|
(old-el new-el)
|
|
(let
|
|
((ra-str (or (dom-get-attr old-el "data-sx-reactive-attrs") ""))
|
|
(reactive-attrs (if (empty? ra-str) (list) (split ra-str ","))))
|
|
(for-each
|
|
(fn
|
|
((attr :as list))
|
|
(let
|
|
((name (first attr)) (val (nth attr 1)))
|
|
(when
|
|
(and
|
|
(not (= (dom-get-attr old-el name) val))
|
|
(not (contains? reactive-attrs name)))
|
|
(dom-set-attr old-el name val))))
|
|
(dom-attr-list new-el))
|
|
(for-each
|
|
(fn
|
|
((attr :as list))
|
|
(let
|
|
((aname (first attr)))
|
|
(when
|
|
(and
|
|
(not (dom-has-attr? new-el aname))
|
|
(not (contains? reactive-attrs aname))
|
|
(not (= aname "data-sx-reactive-attrs")))
|
|
(dom-remove-attr old-el aname))))
|
|
(dom-attr-list old-el)))))
|
|
|
|
(define
|
|
morph-children
|
|
:effects (mutation io)
|
|
(fn
|
|
(old-parent new-parent)
|
|
(let
|
|
((old-kids (dom-child-list old-parent))
|
|
(new-kids (dom-child-list new-parent))
|
|
(old-by-id (dict))
|
|
(old-idx-by-id (dict))
|
|
(consumed (dict))
|
|
(oi 0)
|
|
(idx 0))
|
|
(for-each
|
|
(fn
|
|
(kid)
|
|
(let
|
|
((id (dom-id kid)))
|
|
(when
|
|
(and id (not (empty? id)))
|
|
(dict-set! old-by-id id kid)
|
|
(dict-set! old-idx-by-id id idx)))
|
|
(set! idx (inc idx)))
|
|
old-kids)
|
|
(for-each
|
|
(fn
|
|
(new-child)
|
|
(let
|
|
((raw-id (dom-id new-child))
|
|
(match-id (if (and raw-id (not (empty? raw-id))) raw-id nil))
|
|
(match-by-id (if match-id (dict-get old-by-id match-id) nil)))
|
|
(cond
|
|
(and match-by-id (not (nil? match-by-id)))
|
|
(do
|
|
(let
|
|
((matched-idx (dict-get old-idx-by-id match-id)))
|
|
(when
|
|
matched-idx
|
|
(dict-set! consumed (str matched-idx) true)))
|
|
(when
|
|
(and
|
|
(< oi (len old-kids))
|
|
(not (= match-by-id (nth old-kids oi))))
|
|
(dom-insert-before
|
|
old-parent
|
|
match-by-id
|
|
(if (< oi (len old-kids)) (nth old-kids oi) nil)))
|
|
(morph-node match-by-id new-child)
|
|
(set! oi (inc oi)))
|
|
(< oi (len old-kids))
|
|
(let
|
|
((old-child (nth old-kids oi)))
|
|
(let
|
|
((old-id (dom-id old-child)))
|
|
(if
|
|
(and old-id (not (empty? old-id)) (not match-id))
|
|
(dom-insert-before
|
|
old-parent
|
|
(dom-clone new-child true)
|
|
old-child)
|
|
(do
|
|
(dict-set! consumed (str oi) true)
|
|
(morph-node old-child new-child)
|
|
(set! oi (inc oi))))))
|
|
:else (dom-append old-parent (dom-clone new-child true)))))
|
|
new-kids)
|
|
(for-each
|
|
(fn
|
|
(i)
|
|
(when
|
|
(not (dict-get consumed (str i)))
|
|
(let
|
|
((leftover (nth old-kids i)))
|
|
(when
|
|
(and
|
|
(dom-is-child-of? leftover old-parent)
|
|
(not (dom-has-attr? leftover "sx-preserve"))
|
|
(not (dom-has-attr? leftover "sx-ignore")))
|
|
(dom-remove-child old-parent leftover)))))
|
|
(range 0 (len old-kids))))))
|
|
|
|
(define
|
|
morph-island-children
|
|
:effects (mutation io)
|
|
(fn
|
|
(old-island new-island)
|
|
(let
|
|
((old-lakes (dom-query-all old-island "[data-sx-lake]"))
|
|
(new-lakes (dom-query-all new-island "[data-sx-lake]"))
|
|
(old-marshes (dom-query-all old-island "[data-sx-marsh]"))
|
|
(new-marshes (dom-query-all new-island "[data-sx-marsh]")))
|
|
(let
|
|
((new-lake-map (dict)) (new-marsh-map (dict)))
|
|
(for-each
|
|
(fn
|
|
(lake)
|
|
(let
|
|
((id (dom-get-attr lake "data-sx-lake")))
|
|
(when id (dict-set! new-lake-map id lake))))
|
|
new-lakes)
|
|
(for-each
|
|
(fn
|
|
(marsh)
|
|
(let
|
|
((id (dom-get-attr marsh "data-sx-marsh")))
|
|
(when id (dict-set! new-marsh-map id marsh))))
|
|
new-marshes)
|
|
(for-each
|
|
(fn
|
|
(old-lake)
|
|
(let
|
|
((id (dom-get-attr old-lake "data-sx-lake")))
|
|
(let
|
|
((new-lake (dict-get new-lake-map id)))
|
|
(when
|
|
new-lake
|
|
(sync-attrs old-lake new-lake)
|
|
(morph-children old-lake new-lake)))))
|
|
old-lakes)
|
|
(for-each
|
|
(fn
|
|
(old-marsh)
|
|
(let
|
|
((id (dom-get-attr old-marsh "data-sx-marsh")))
|
|
(let
|
|
((new-marsh (dict-get new-marsh-map id)))
|
|
(when new-marsh (morph-marsh old-marsh new-marsh old-island)))))
|
|
old-marshes)
|
|
(process-signal-updates new-island)))))
|
|
|
|
(define
|
|
morph-marsh
|
|
:effects (mutation io)
|
|
(fn
|
|
(old-marsh new-marsh island-el)
|
|
(let
|
|
((transform (dom-get-data old-marsh "sx-marsh-transform"))
|
|
(env (dom-get-data old-marsh "sx-marsh-env"))
|
|
(new-html (dom-inner-html new-marsh)))
|
|
(if
|
|
(and env new-html (not (empty? new-html)))
|
|
(let
|
|
((parsed (parse new-html)))
|
|
(let
|
|
((sx-content (if transform (cek-call transform (list parsed)) parsed)))
|
|
(dispose-marsh-scope old-marsh)
|
|
(with-marsh-scope
|
|
old-marsh
|
|
(fn
|
|
()
|
|
(let
|
|
((new-dom (render-to-dom sx-content env nil)))
|
|
(dom-remove-children-after old-marsh nil)
|
|
(dom-append old-marsh new-dom))))))
|
|
(do
|
|
(sync-attrs old-marsh new-marsh)
|
|
(morph-children old-marsh new-marsh))))))
|
|
|
|
(define
|
|
process-signal-updates
|
|
:effects (mutation io)
|
|
(fn
|
|
(root)
|
|
(let
|
|
((signal-els (dom-query-all root "[data-sx-signal]")))
|
|
(for-each
|
|
(fn
|
|
(el)
|
|
(let
|
|
((spec (dom-get-attr el "data-sx-signal")))
|
|
(when
|
|
spec
|
|
(let
|
|
((colon-idx (index-of spec ":")))
|
|
(when
|
|
(> colon-idx 0)
|
|
(let
|
|
((store-name (slice spec 0 colon-idx))
|
|
(raw-value (slice spec (+ colon-idx 1))))
|
|
(let
|
|
((parsed (json-parse raw-value)))
|
|
(reset! (use-store store-name) parsed))
|
|
(dom-remove-attr el "data-sx-signal")))))))
|
|
signal-els))))
|
|
|
|
(define
|
|
swap-dom-nodes
|
|
:effects (mutation io)
|
|
(fn
|
|
(target new-nodes (strategy :as string))
|
|
(case
|
|
strategy
|
|
"innerHTML"
|
|
(if
|
|
(dom-is-fragment? new-nodes)
|
|
(morph-children target new-nodes)
|
|
(let
|
|
((wrapper (dom-create-element "div" nil)))
|
|
(dom-append wrapper new-nodes)
|
|
(morph-children target wrapper)))
|
|
"outerHTML"
|
|
(let
|
|
((parent (dom-parent target)) (new-el (dom-clone new-nodes true)))
|
|
(if
|
|
(dom-is-fragment? new-nodes)
|
|
(let
|
|
((fc (dom-first-child new-nodes)))
|
|
(if
|
|
fc
|
|
(do
|
|
(set! new-el (dom-clone fc true))
|
|
(dom-replace-child parent new-el target)
|
|
(let
|
|
((sib (dom-next-sibling fc)))
|
|
(insert-remaining-siblings parent new-el sib)))
|
|
(dom-remove-child parent target)))
|
|
(dom-replace-child parent new-el target))
|
|
new-el)
|
|
"afterend"
|
|
(dom-insert-after target new-nodes)
|
|
"beforeend"
|
|
(dom-append target new-nodes)
|
|
"afterbegin"
|
|
(dom-prepend target new-nodes)
|
|
"beforebegin"
|
|
(dom-insert-before (dom-parent target) new-nodes target)
|
|
"delete"
|
|
(dom-remove-child (dom-parent target) target)
|
|
"none"
|
|
nil
|
|
:else (if
|
|
(dom-is-fragment? new-nodes)
|
|
(morph-children target new-nodes)
|
|
(let
|
|
((wrapper (dom-create-element "div" nil)))
|
|
(dom-append wrapper new-nodes)
|
|
(morph-children target wrapper))))))
|
|
|
|
(define
|
|
insert-remaining-siblings
|
|
:effects (mutation io)
|
|
(fn
|
|
(parent ref-node sib)
|
|
(when
|
|
sib
|
|
(let
|
|
((next (dom-next-sibling sib)))
|
|
(dom-insert-after ref-node sib)
|
|
(insert-remaining-siblings parent sib next)))))
|
|
|
|
(define
|
|
swap-html-string
|
|
:effects (mutation io)
|
|
(fn
|
|
(target (html :as string) (strategy :as string))
|
|
(case
|
|
strategy
|
|
"innerHTML"
|
|
(dom-set-inner-html target html)
|
|
"outerHTML"
|
|
(let
|
|
((parent (dom-parent target)))
|
|
(dom-insert-adjacent-html target "afterend" html)
|
|
(dom-remove-child parent target)
|
|
parent)
|
|
"afterend"
|
|
(dom-insert-adjacent-html target "afterend" html)
|
|
"beforeend"
|
|
(dom-insert-adjacent-html target "beforeend" html)
|
|
"afterbegin"
|
|
(dom-insert-adjacent-html target "afterbegin" html)
|
|
"beforebegin"
|
|
(dom-insert-adjacent-html target "beforebegin" html)
|
|
"delete"
|
|
(dom-remove-child (dom-parent target) target)
|
|
"none"
|
|
nil
|
|
:else (dom-set-inner-html target html))))
|
|
|
|
(define
|
|
handle-history
|
|
:effects (io)
|
|
(fn
|
|
(el (url :as string) (resp-headers :as dict))
|
|
(let
|
|
((push-url (dom-get-attr el "sx-push-url"))
|
|
(replace-url (dom-get-attr el "sx-replace-url"))
|
|
(hdr-replace (get resp-headers "replace-url")))
|
|
(cond
|
|
hdr-replace
|
|
(browser-replace-state hdr-replace)
|
|
(and push-url (not (= push-url "false")))
|
|
(do
|
|
(save-scroll-position)
|
|
(browser-push-state (if (= push-url "true") url push-url)))
|
|
(and replace-url (not (= replace-url "false")))
|
|
(browser-replace-state (if (= replace-url "true") url replace-url))))))
|
|
|
|
(define PRELOAD_TTL 30000)
|
|
|
|
(define
|
|
preload-cache-get
|
|
:effects (mutation)
|
|
(fn
|
|
((cache :as dict) (url :as string))
|
|
(let
|
|
((entry (dict-get cache url)))
|
|
(if
|
|
(nil? entry)
|
|
nil
|
|
(if
|
|
(> (- (now-ms) (get entry "timestamp")) PRELOAD_TTL)
|
|
(do (dict-delete! cache url) nil)
|
|
(do (dict-delete! cache url) entry))))))
|
|
|
|
(define
|
|
preload-cache-set
|
|
:effects (mutation)
|
|
(fn
|
|
((cache :as dict)
|
|
(url :as string)
|
|
(text :as string)
|
|
(content-type :as string))
|
|
(dict-set!
|
|
cache
|
|
url
|
|
(dict "text" text "content-type" content-type "timestamp" (now-ms)))))
|
|
|
|
(define
|
|
classify-trigger
|
|
:effects ()
|
|
(fn
|
|
((trigger :as dict))
|
|
(let
|
|
((event (get trigger "event")))
|
|
(cond
|
|
(= event "every")
|
|
"poll"
|
|
(= event "intersect")
|
|
"intersect"
|
|
(= event "load")
|
|
"load"
|
|
(= event "revealed")
|
|
"revealed"
|
|
:else "event"))))
|
|
|
|
(define
|
|
should-boost-link?
|
|
:effects (io)
|
|
(fn
|
|
(link)
|
|
(let
|
|
((href (dom-get-attr link "href")))
|
|
(and
|
|
href
|
|
(not (starts-with? href "#"))
|
|
(not (starts-with? href "javascript:"))
|
|
(not (starts-with? href "mailto:"))
|
|
(browser-same-origin? href)
|
|
(not (dom-has-attr? link "sx-get"))
|
|
(not (dom-has-attr? link "sx-post"))
|
|
(not (dom-has-attr? link "sx-disable"))))))
|
|
|
|
(define
|
|
should-boost-form?
|
|
:effects (io)
|
|
(fn
|
|
(form)
|
|
(and
|
|
(not (dom-has-attr? form "sx-get"))
|
|
(not (dom-has-attr? form "sx-post"))
|
|
(not (dom-has-attr? form "sx-disable")))))
|
|
|
|
(define
|
|
parse-sse-swap
|
|
:effects (io)
|
|
(fn (el) (or (dom-get-attr el "sx-sse-swap") "message")))
|