giles
2f42e8826c
Bootstrappers (bootstrap_py.py, js.sx) now skip :effects keyword in define forms, enabling effect annotations throughout the spec without changing generated output. Annotated 180+ functions across 14 spec files: - signals.sx: signal/deref [] pure, reset!/swap!/effect/batch [mutation] - engine.sx: parse-* [] pure, morph-*/swap-* [mutation io] - orchestration.sx: all [mutation io] (browser event binding) - adapter-html.sx: render-* [render] - adapter-dom.sx: render-* [render], reactive-* [render mutation] - adapter-sx.sx: aser-* [render] - adapter-async.sx: async-render-*/async-aser-* [render io] - parser.sx: all [] pure - render.sx: predicates [] pure, process-bindings [mutation] - boot.sx: all [mutation io] (browser init) - deps.sx: scan-*/transitive-* [] pure, compute-all-* [mutation] - router.sx: all [] pure (URL matching) Co-Authored-By: Claude Opus 4.6 <noreply@anthropic.com>
804 lines
32 KiB
Plaintext
804 lines
32 KiB
Plaintext
;; ==========================================================================
|
|
;; engine.sx — SxEngine pure logic
|
|
;;
|
|
;; Fetch/swap/history engine for browser-side SX. Like HTMX but native
|
|
;; to the SX rendering pipeline.
|
|
;;
|
|
;; This file specifies the pure LOGIC of the engine in s-expressions:
|
|
;; parsing trigger specs, morph algorithm, swap dispatch, header building,
|
|
;; retry logic, target resolution, etc.
|
|
;;
|
|
;; Orchestration (binding events, executing requests, processing elements)
|
|
;; lives in orchestration.sx, which depends on this file.
|
|
;;
|
|
;; Depends on:
|
|
;; adapter-dom.sx — render-to-dom (for SX response rendering)
|
|
;; render.sx — shared registries
|
|
;; ==========================================================================
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Constants
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define ENGINE_VERBS (list "get" "post" "put" "delete" "patch"))
|
|
(define DEFAULT_SWAP "outerHTML")
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Trigger parsing
|
|
;; --------------------------------------------------------------------------
|
|
;; Parses the sx-trigger attribute value into a list of trigger descriptors.
|
|
;; Each descriptor is a dict with "event" and "modifiers" keys.
|
|
|
|
(define parse-time :effects []
|
|
(fn ((s :as string))
|
|
;; Parse time string: "2s" → 2000, "500ms" → 500
|
|
;; Uses nested if (not cond) because cond misclassifies 2-element
|
|
;; function calls like (nil? s) as scheme-style ((test body)) clauses.
|
|
(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))
|
|
;; Parse "click delay:500ms once,change" → list of trigger descriptors
|
|
(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))
|
|
;; Polling trigger
|
|
(dict
|
|
"event" "every"
|
|
"modifiers" (dict "interval" (parse-time (nth tokens 1))))
|
|
;; Normal trigger with optional modifiers
|
|
(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))
|
|
(dict "event" (first tokens) "modifiers" mods))))))
|
|
raw-parts))))))
|
|
|
|
|
|
(define default-trigger :effects []
|
|
(fn ((tag-name :as string))
|
|
;; Default trigger for element type
|
|
(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))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Verb extraction
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define get-verb-info :effects [io]
|
|
(fn (el)
|
|
;; Check element for sx-get, sx-post, etc. Returns (dict "method" "url") or nil.
|
|
(some
|
|
(fn ((verb :as string))
|
|
(let ((url (dom-get-attr el (str "sx-" verb))))
|
|
(if url
|
|
(dict "method" (upper verb) "url" url)
|
|
nil)))
|
|
ENGINE_VERBS)))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Request header building
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define build-request-headers :effects [io]
|
|
(fn (el (loaded-components :as list) (css-hash :as string))
|
|
;; Build the SX request headers dict
|
|
(let ((headers (dict
|
|
"SX-Request" "true"
|
|
"SX-Current-URL" (browser-location-href))))
|
|
;; Target selector
|
|
(let ((target-sel (dom-get-attr el "sx-target")))
|
|
(when target-sel
|
|
(dict-set! headers "SX-Target" target-sel)))
|
|
|
|
;; Loaded component names
|
|
(when (not (empty? loaded-components))
|
|
(dict-set! headers "SX-Components"
|
|
(join "," loaded-components)))
|
|
|
|
;; CSS class hash
|
|
(when css-hash
|
|
(dict-set! headers "SX-Css" css-hash))
|
|
|
|
;; Extra headers from sx-headers attribute
|
|
(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)))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Response header processing
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define process-response-headers :effects []
|
|
(fn ((get-header :as lambda))
|
|
;; Extract all SX response header directives into a dict.
|
|
;; get-header is (fn (name) → string or nil).
|
|
(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"))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Swap specification parsing
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define parse-swap-spec :effects []
|
|
(fn ((raw-swap :as string) (global-transitions? :as boolean))
|
|
;; Parse "innerHTML transition:true" → dict with style + transition flag
|
|
(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))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Retry logic
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define parse-retry-spec :effects []
|
|
(fn ((retry-attr :as string))
|
|
;; Parse "exponential:1000:30000" → spec dict or nil
|
|
(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))
|
|
;; Exponential backoff: double current, cap at max
|
|
(min (* current-ms 2) cap-ms)))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Form parameter filtering
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define filter-params :effects []
|
|
(fn ((params-spec :as string) (all-params :as list))
|
|
;; Filter form parameters by sx-params spec.
|
|
;; all-params is a list of (key value) pairs.
|
|
;; Returns filtered list of (key value) pairs.
|
|
;; Uses nested if (not cond) — see parse-time comment.
|
|
(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))))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Target resolution
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define resolve-target :effects [io]
|
|
(fn (el)
|
|
;; Resolve the swap target for an element
|
|
(let ((sel (dom-get-attr el "sx-target")))
|
|
(cond
|
|
(or (nil? sel) (= sel "this")) el
|
|
(= sel "closest") (dom-parent el)
|
|
:else (dom-query sel)))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Optimistic updates
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define apply-optimistic :effects [mutation io]
|
|
(fn (el)
|
|
;; Apply optimistic update preview. Returns state for reverting, or nil.
|
|
(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))
|
|
;; Revert an optimistic update
|
|
(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")))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Out-of-band swap identification
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define find-oob-swaps :effects [mutation io]
|
|
(fn (container)
|
|
;; Find elements marked for out-of-band swapping.
|
|
;; Returns list of (dict "element" el "swap-type" type "target-id" id).
|
|
(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)))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; DOM morph algorithm
|
|
;; --------------------------------------------------------------------------
|
|
;; Lightweight reconciler: patches oldNode to match newNode in-place,
|
|
;; preserving event listeners, focus, scroll position, and form state
|
|
;; on keyed (id) elements.
|
|
|
|
(define morph-node :effects [mutation io]
|
|
(fn (old-node new-node)
|
|
;; Morph old-node to match new-node, preserving listeners/state.
|
|
(cond
|
|
;; sx-preserve / sx-ignore → skip
|
|
(or (dom-has-attr? old-node "sx-preserve")
|
|
(dom-has-attr? old-node "sx-ignore"))
|
|
nil
|
|
|
|
;; Hydrated island → preserve reactive state, morph lakes.
|
|
;; If old and new are the same island (by name), keep the old DOM
|
|
;; with its live signals, effects, and event listeners intact.
|
|
;; But recurse into data-sx-lake slots so the server can update
|
|
;; non-reactive content within the island.
|
|
(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")))
|
|
(morph-island-children old-node new-node)
|
|
|
|
;; Different node type or tag → replace wholesale
|
|
(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) old-node)
|
|
|
|
;; Text/comment nodes → update content
|
|
(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)))
|
|
|
|
;; Element nodes → sync attributes, then recurse children
|
|
(= (dom-node-type old-node) 1)
|
|
(do
|
|
(sync-attrs old-node new-node)
|
|
;; Skip morphing focused input to preserve user's in-progress edits
|
|
(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)
|
|
;; Sync attributes from new to old, but skip reactively managed attrs.
|
|
;; data-sx-reactive-attrs="style,class" means those attrs are owned by
|
|
;; signal effects and must not be overwritten by the morph.
|
|
(let ((ra-str (or (dom-get-attr old-el "data-sx-reactive-attrs") ""))
|
|
(reactive-attrs (if (empty? ra-str) (list) (split ra-str ","))))
|
|
;; Add/update attributes from new, skip reactive ones
|
|
(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))
|
|
;; Remove attributes not in new, skip reactive + marker attrs
|
|
(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)
|
|
;; Reconcile children of old-parent to match new-parent.
|
|
;; Keyed elements (with id) are matched and moved in-place.
|
|
(let ((old-kids (dom-child-list old-parent))
|
|
(new-kids (dom-child-list new-parent))
|
|
;; Build ID map of old children for keyed matching
|
|
(old-by-id (reduce
|
|
(fn ((acc :as dict) kid)
|
|
(let ((id (dom-id kid)))
|
|
(if id (do (dict-set! acc id kid) acc) acc)))
|
|
(dict) old-kids))
|
|
(oi 0))
|
|
|
|
;; Walk new children, morph/insert/append
|
|
(for-each
|
|
(fn (new-child)
|
|
(let ((match-id (dom-id new-child))
|
|
(match-by-id (if match-id (dict-get old-by-id match-id) nil)))
|
|
(cond
|
|
;; Keyed match — move into position if needed, then morph
|
|
(and match-by-id (not (nil? match-by-id)))
|
|
(do
|
|
(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)))
|
|
|
|
;; Positional match
|
|
(< oi (len old-kids))
|
|
(let ((old-child (nth old-kids oi)))
|
|
(if (and (dom-id old-child) (not match-id))
|
|
;; Old has ID, new doesn't — insert new before old
|
|
(dom-insert-before old-parent
|
|
(dom-clone new-child) old-child)
|
|
;; Normal positional morph
|
|
(do
|
|
(morph-node old-child new-child)
|
|
(set! oi (inc oi)))))
|
|
|
|
;; Extra new children — append
|
|
:else
|
|
(dom-append old-parent (dom-clone new-child)))))
|
|
new-kids)
|
|
|
|
;; Remove leftover old children
|
|
(for-each
|
|
(fn ((i :as number))
|
|
(when (>= i oi)
|
|
(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 oi (len old-kids))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; morph-island-children — deep morph into hydrated islands via lakes
|
|
;; --------------------------------------------------------------------------
|
|
;;
|
|
;; Level 2-3 island morphing: the server can update non-reactive content
|
|
;; within hydrated islands by morphing data-sx-lake slots.
|
|
;;
|
|
;; The island's reactive DOM (signals, effects, event listeners) is preserved.
|
|
;; Only lake slots — explicitly marked server territory — receive new content.
|
|
;;
|
|
;; This is the Hegelian synthesis made concrete:
|
|
;; - Islands = client subjectivity (reactive state, preserved)
|
|
;; - Lakes = server substance (content, morphed)
|
|
;; - The morph = Aufhebung (cancellation/preservation/elevation of both)
|
|
|
|
(define morph-island-children :effects [mutation io]
|
|
(fn (old-island new-island)
|
|
;; Find all lake and marsh slots in both old and new islands
|
|
(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]")))
|
|
;; Build ID→element maps for new lakes and marshes
|
|
(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)
|
|
;; Morph each old lake from its new counterpart
|
|
(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)
|
|
;; Morph each old marsh from its new counterpart
|
|
(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 data-sx-signal attributes — server writes to named stores
|
|
(process-signal-updates new-island)))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; morph-marsh — re-evaluate server content in island's reactive scope
|
|
;; --------------------------------------------------------------------------
|
|
;;
|
|
;; Marshes are zones inside islands where server content is re-evaluated by
|
|
;; the island's reactive evaluator. During morph, the new content is parsed
|
|
;; as SX and rendered in the island's signal context. If the marsh has a
|
|
;; :transform function, it reshapes the content before evaluation.
|
|
|
|
(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)))
|
|
;; Parse new content as SX and re-evaluate in island scope
|
|
(let ((parsed (parse new-html)))
|
|
(let ((sx-content (if transform (invoke transform parsed) parsed)))
|
|
;; Dispose old reactive bindings in this marsh
|
|
(dispose-marsh-scope old-marsh)
|
|
;; Evaluate the SX in a new marsh scope — creates new reactive bindings
|
|
(with-marsh-scope old-marsh
|
|
(fn ()
|
|
(let ((new-dom (render-to-dom sx-content env nil)))
|
|
;; Replace marsh children
|
|
(dom-remove-children-after old-marsh nil)
|
|
(dom-append old-marsh new-dom))))))
|
|
;; Fallback: morph like a lake
|
|
(do
|
|
(sync-attrs old-marsh new-marsh)
|
|
(morph-children old-marsh new-marsh))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; process-signal-updates — server responses write to named store signals
|
|
;; --------------------------------------------------------------------------
|
|
;;
|
|
;; Elements with data-sx-signal="name:value" trigger signal writes.
|
|
;; After processing, the attribute is removed (consumed).
|
|
;;
|
|
;; Values are JSON-parsed: "7" → 7, "\"hello\"" → "hello", "true" → true.
|
|
|
|
(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))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Swap dispatch
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define swap-dom-nodes :effects [mutation io]
|
|
(fn (target new-nodes (strategy :as string))
|
|
;; Execute a swap strategy on live DOM nodes.
|
|
;; new-nodes is typically a DocumentFragment or Element.
|
|
(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)))
|
|
(if (dom-is-fragment? new-nodes)
|
|
;; Fragment — morph first child, insert rest
|
|
(let ((fc (dom-first-child new-nodes)))
|
|
(if fc
|
|
(do
|
|
(morph-node target fc)
|
|
;; Insert remaining siblings after morphed element
|
|
(let ((sib (dom-next-sibling fc)))
|
|
(insert-remaining-siblings parent target sib)))
|
|
(dom-remove-child parent target)))
|
|
(morph-node target new-nodes))
|
|
parent)
|
|
|
|
"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
|
|
|
|
;; Default = innerHTML
|
|
: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)
|
|
;; Insert sibling chain after ref-node
|
|
(when sib
|
|
(let ((next (dom-next-sibling sib)))
|
|
(dom-insert-after ref-node sib)
|
|
(insert-remaining-siblings parent sib next)))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; String-based swap (fallback for HTML responses)
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define swap-html-string :effects [mutation io]
|
|
(fn (target (html :as string) (strategy :as string))
|
|
;; Execute a swap strategy using an HTML string (DOMParser pipeline).
|
|
(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))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; History management
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define handle-history :effects [io]
|
|
(fn (el (url :as string) (resp-headers :as dict))
|
|
;; Process history push/replace based on element attrs and response headers
|
|
(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
|
|
;; Server override
|
|
hdr-replace
|
|
(browser-replace-state hdr-replace)
|
|
;; Client push
|
|
(and push-url (not (= push-url "false")))
|
|
(browser-push-state
|
|
(if (= push-url "true") url push-url))
|
|
;; Client replace
|
|
(and replace-url (not (= replace-url "false")))
|
|
(browser-replace-state
|
|
(if (= replace-url "true") url replace-url))))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Preload cache
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define PRELOAD_TTL 30000) ;; 30 seconds
|
|
|
|
(define preload-cache-get :effects [mutation]
|
|
(fn ((cache :as dict) (url :as string))
|
|
;; Get and consume a cached preload response.
|
|
;; Returns (dict "text" ... "content-type" ...) or nil.
|
|
(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))
|
|
;; Store a preloaded response
|
|
(dict-set! cache url
|
|
(dict "text" text "content-type" content-type "timestamp" (now-ms)))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Trigger dispatch table
|
|
;; --------------------------------------------------------------------------
|
|
;; Maps trigger event names to binding strategies.
|
|
;; This is the logic; actual browser event binding is platform interface.
|
|
|
|
(define classify-trigger :effects []
|
|
(fn ((trigger :as dict))
|
|
;; Classify a parsed trigger descriptor for binding.
|
|
;; Returns one of: "poll", "intersect", "load", "revealed", "event"
|
|
(let ((event (get trigger "event")))
|
|
(cond
|
|
(= event "every") "poll"
|
|
(= event "intersect") "intersect"
|
|
(= event "load") "load"
|
|
(= event "revealed") "revealed"
|
|
:else "event"))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Boost logic
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define should-boost-link? :effects [io]
|
|
(fn (link)
|
|
;; Whether a link inside an sx-boost container should be boosted
|
|
(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)
|
|
;; Whether a form inside an sx-boost container should be boosted
|
|
(and (not (dom-has-attr? form "sx-get"))
|
|
(not (dom-has-attr? form "sx-post"))
|
|
(not (dom-has-attr? form "sx-disable")))))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; SSE event classification
|
|
;; --------------------------------------------------------------------------
|
|
|
|
(define parse-sse-swap :effects [io]
|
|
(fn (el)
|
|
;; Parse sx-sse-swap attribute
|
|
;; Returns event name to listen for (default "message")
|
|
(or (dom-get-attr el "sx-sse-swap") "message")))
|
|
|
|
|
|
;; --------------------------------------------------------------------------
|
|
;; Platform interface — Engine (pure logic)
|
|
;; --------------------------------------------------------------------------
|
|
;;
|
|
;; From adapter-dom.sx:
|
|
;; dom-get-attr, dom-set-attr, dom-remove-attr, dom-has-attr?, dom-attr-list
|
|
;; dom-query, dom-query-all, dom-id, dom-parent, dom-first-child,
|
|
;; dom-next-sibling, dom-child-list, dom-node-type, dom-node-name,
|
|
;; dom-text-content, dom-set-text-content, dom-is-fragment?,
|
|
;; dom-is-child-of?, dom-is-active-element?, dom-is-input-element?,
|
|
;; dom-create-element, dom-append, dom-prepend, dom-insert-before,
|
|
;; dom-insert-after, dom-remove-child, dom-replace-child, dom-clone,
|
|
;; dom-get-style, dom-set-style, dom-get-prop, dom-set-prop,
|
|
;; dom-add-class, dom-remove-class, dom-set-inner-html,
|
|
;; dom-insert-adjacent-html
|
|
;;
|
|
;; Browser/Network:
|
|
;; (browser-location-href) → current URL string
|
|
;; (browser-same-origin? url) → boolean
|
|
;; (browser-push-state url) → void (history.pushState)
|
|
;; (browser-replace-state url) → void (history.replaceState)
|
|
;;
|
|
;; Parsing:
|
|
;; (parse-header-value s) → parsed dict from header string
|
|
;; (now-ms) → current timestamp in milliseconds
|
|
;; --------------------------------------------------------------------------
|