coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Bytecode compiler: desugar let-match, fix SPA navigation

Browse Source 
The bytecode compiler now handles let-match (both variants):
- Variant 1: (let-match name expr {:k v} body...) — named binding + destructure
- Variant 2: (let-match {:k v} expr body...) — pattern-only destructure

Desugars to sequential let + get calls — no new opcodes needed.

This was the last blocker for SPA navigation. The bytecoded orchestration
and router modules used let-match which compiled to CALL_PRIM "let-match"
(undefined at runtime). Now desugared at compile time.

Also synced dist/sx/ sources with web/ and recompiled all 26 .sxbc modules.

2650/2650 tests pass.

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-04 21:31:17 +00:00
parent c0665ba58e
commit 9b060ef8c5
7 changed files with 1208 additions and 1130 deletions
Download Patch File Download Diff File Expand all files Collapse all files

44
lib/compiler.sx
View File

@@ -41,6 +41,7 @@
compile-or compile-or
compile-begin compile-begin
compile-let compile-let
desugar-let-match
compile-letrec compile-letrec
compile-lambda compile-lambda
compile-define compile-define
@@ -250,6 +251,8 @@
(compile-let em args scope tail?) (compile-let em args scope tail?)
(= name "let*") (= name "let*")
(compile-let em args scope tail?) (compile-let em args scope tail?)
(= name "let-match")
(compile-let em (desugar-let-match args) scope tail?)
(= name "begin") (= name "begin")
(compile-begin em args scope tail?) (compile-begin em args scope tail?)
(= name "do") (= name "do")
@@ -446,6 +449,47 @@
(compile-expr em (first exprs) scope false) (compile-expr em (first exprs) scope false)
(emit-op em 5) (emit-op em 5)
(compile-begin em (rest exprs) scope tail?)))))) (compile-begin em (rest exprs) scope tail?))))))
(define
desugar-let-match
(fn
(args)
(let
((first-arg (first args)))
(if (dict? first-arg)
;; Variant 2: (let-match {:k v} expr body...)
(let
((pattern first-arg)
(expr (nth args 1))
(body (slice args 2))
(src-sym (make-symbol "__lm_tmp"))
(bindings (list)))
(append! bindings (list src-sym expr))
(for-each
(fn (k)
(append! bindings
(list (get pattern k)
(list (make-symbol "get") src-sym (str k)))))
(keys pattern))
(cons bindings body))
;; Variant 1: (let-match name expr {:k v} body...)
(let
((name-sym first-arg)
(expr (nth args 1))
(pattern (nth args 2))
(body (slice args 3))
(src-sym (if (= (str name-sym) "_")
(make-symbol "__lm_tmp")
name-sym))
(bindings (list)))
(append! bindings (list src-sym expr))
(when (dict? pattern)
(for-each
(fn (k)
(append! bindings
(list (get pattern k)
(list (make-symbol "get") src-sym (str k)))))
(keys pattern)))
(cons bindings body))))))
(define (define
compile-let compile-let
(fn (fn

44
shared/static/wasm/sx/compiler.sx
View File

@@ -41,6 +41,7 @@
compile-or compile-or
compile-begin compile-begin
compile-let compile-let
desugar-let-match
compile-letrec compile-letrec
compile-lambda compile-lambda
compile-define compile-define
@@ -250,6 +251,8 @@
(compile-let em args scope tail?) (compile-let em args scope tail?)
(= name "let*") (= name "let*")
(compile-let em args scope tail?) (compile-let em args scope tail?)
(= name "let-match")
(compile-let em (desugar-let-match args) scope tail?)
(= name "begin") (= name "begin")
(compile-begin em args scope tail?) (compile-begin em args scope tail?)
(= name "do") (= name "do")
@@ -446,6 +449,47 @@
(compile-expr em (first exprs) scope false) (compile-expr em (first exprs) scope false)
(emit-op em 5) (emit-op em 5)
(compile-begin em (rest exprs) scope tail?)))))) (compile-begin em (rest exprs) scope tail?))))))
(define
desugar-let-match
(fn
(args)
(let
((first-arg (first args)))
(if (dict? first-arg)
;; Variant 2: (let-match {:k v} expr body...)
(let
((pattern first-arg)
(expr (nth args 1))
(body (slice args 2))
(src-sym (make-symbol "__lm_tmp"))
(bindings (list)))
(append! bindings (list src-sym expr))
(for-each
(fn (k)
(append! bindings
(list (get pattern k)
(list (make-symbol "get") src-sym (str k)))))
(keys pattern))
(cons bindings body))
;; Variant 1: (let-match name expr {:k v} body...)
(let
((name-sym first-arg)
(expr (nth args 1))
(pattern (nth args 2))
(body (slice args 3))
(src-sym (if (= (str name-sym) "_")
(make-symbol "__lm_tmp")
name-sym))
(bindings (list)))
(append! bindings (list src-sym expr))
(when (dict? pattern)
(for-each
(fn (k)
(append! bindings
(list (get pattern k)
(list (make-symbol "get") src-sym (str k)))))
(keys pattern)))
(cons bindings body))))))
(define (define
compile-let compile-let
(fn (fn

4
shared/static/wasm/sx/compiler.sxbc
View File

File diff suppressed because one or more lines are too long

179
shared/static/wasm/sx/deps.sx
View File

@@ -1,6 +1,7 @@
(define-library (web deps) (define-library
(web deps)
(export (export
scan-refs scan-refs
scan-refs-walk scan-refs-walk
@@ -22,33 +23,30 @@
page-render-plan page-render-plan
env-components) env-components)
(begin (begin
(define
(define
scan-refs scan-refs
:effects () :effects ()
(fn (node) (let ((refs (list))) (scan-refs-walk node refs) refs))) (fn (node) (let ((refs (list))) (scan-refs-walk node refs) refs)))
(define
(define
scan-refs-walk scan-refs-walk
:effects () :effects ()
(fn (fn
(node (refs :as list)) (node (refs :as list))
(cond (match
(= (type-of node) "symbol") (type-of node)
("symbol"
(let (let
((name (symbol-name node))) ((name (symbol-name node)))
(when (when
(starts-with? name "~") (starts-with? name "~")
(when (not (contains? refs name)) (append! refs name)))) (when (not (contains? refs name)) (append! refs name)))))
(= (type-of node) "list") ("list" (for-each (fn (item) (scan-refs-walk item refs)) node))
(for-each (fn (item) (scan-refs-walk item refs)) node) ("dict"
(= (type-of node) "dict")
(for-each (for-each
(fn (key) (scan-refs-walk (dict-get node key) refs)) (fn (key) (scan-refs-walk (dict-get node key) refs))
(keys node)) (keys node)))
:else nil))) (_ nil))))
(define
(define
transitive-deps-walk transitive-deps-walk
:effects () :effects ()
(fn (fn
@@ -58,18 +56,28 @@
(append! seen n) (append! seen n)
(let (let
((val (env-get env n))) ((val (env-get env n)))
(cond (match
(or (= (type-of val) "component") (= (type-of val) "island")) (type-of val)
("component"
(for-each (for-each
(fn ((ref :as string)) (transitive-deps-walk ref seen env)) (fn
(scan-refs (component-body val))) ((ref :as string))
(= (type-of val) "macro") (transitive-deps-walk ref seen env))
(scan-refs (component-body val))))
("island"
(for-each (for-each
(fn ((ref :as string)) (transitive-deps-walk ref seen env)) (fn
(scan-refs (macro-body val))) ((ref :as string))
:else nil))))) (transitive-deps-walk ref seen env))
(scan-refs (component-body val))))
(define ("macro"
(for-each
(fn
((ref :as string))
(transitive-deps-walk ref seen env))
(scan-refs (macro-body val))))
(_ nil))))))
(define
transitive-deps transitive-deps
:effects () :effects ()
(fn (fn
@@ -79,8 +87,7 @@
(key (if (starts-with? name "~") name (str "~" name)))) (key (if (starts-with? name "~") name (str "~" name))))
(transitive-deps-walk key seen env) (transitive-deps-walk key seen env)
(filter (fn ((x :as string)) (not (= x key))) seen)))) (filter (fn ((x :as string)) (not (= x key))) seen))))
(define
(define
compute-all-deps compute-all-deps
:effects (mutation) :effects (mutation)
(fn (fn
@@ -91,11 +98,12 @@
(let (let
((val (env-get env name))) ((val (env-get env name)))
(when (when
(or (= (type-of val) "component") (= (type-of val) "island")) (or
(= (type-of val) "component")
(= (type-of val) "island"))
(component-set-deps! val (transitive-deps name env))))) (component-set-deps! val (transitive-deps name env)))))
(env-components env)))) (env-components env))))
(define
(define
scan-components-from-source scan-components-from-source
:effects () :effects ()
(fn (fn
@@ -103,8 +111,7 @@
(let (let
((matches (regex-find-all "\\(~([a-zA-Z_][a-zA-Z0-9_\\-:/]*)" source))) ((matches (regex-find-all "\\(~([a-zA-Z_][a-zA-Z0-9_\\-:/]*)" source)))
(map (fn ((m :as string)) (str "~" m)) matches)))) (map (fn ((m :as string)) (str "~" m)) matches))))
(define
(define
components-needed components-needed
:effects () :effects ()
(fn (fn
@@ -115,7 +122,9 @@
(for-each (for-each
(fn (fn
((name :as string)) ((name :as string))
(when (not (contains? all-needed name)) (append! all-needed name)) (when
(not (contains? all-needed name))
(append! all-needed name))
(let (let
((val (env-get env name))) ((val (env-get env name)))
(let (let
@@ -129,15 +138,13 @@
deps)))) deps))))
direct) direct)
all-needed))) all-needed)))
(define
(define
page-component-bundle page-component-bundle
:effects () :effects ()
(fn (fn
((page-source :as string) (env :as dict)) ((page-source :as string) (env :as dict))
(components-needed page-source env))) (components-needed page-source env)))
(define
(define
page-css-classes page-css-classes
:effects () :effects ()
(fn (fn
@@ -154,7 +161,9 @@
(for-each (for-each
(fn (fn
((cls :as string)) ((cls :as string))
(when (not (contains? classes cls)) (append! classes cls))) (when
(not (contains? classes cls))
(append! classes cls)))
(component-css-classes val))))) (component-css-classes val)))))
needed) needed)
(for-each (for-each
@@ -163,35 +172,37 @@
(when (not (contains? classes cls)) (append! classes cls))) (when (not (contains? classes cls)) (append! classes cls)))
(scan-css-classes page-source)) (scan-css-classes page-source))
classes))) classes)))
(define
(define
scan-io-refs-walk scan-io-refs-walk
:effects () :effects ()
(fn (fn
(node (io-names :as list) (refs :as list)) (node (io-names :as list) (refs :as list))
(cond (match
(= (type-of node) "symbol") (type-of node)
("symbol"
(let (let
((name (symbol-name node))) ((name (symbol-name node)))
(when (when
(contains? io-names name) (contains? io-names name)
(when (not (contains? refs name)) (append! refs name)))) (when (not (contains? refs name)) (append! refs name)))))
(= (type-of node) "list") ("list"
(for-each (fn (item) (scan-io-refs-walk item io-names refs)) node)
(= (type-of node) "dict")
(for-each (for-each
(fn (key) (scan-io-refs-walk (dict-get node key) io-names refs)) (fn (item) (scan-io-refs-walk item io-names refs))
(keys node)) node))
:else nil))) ("dict"
(for-each
(define (fn
(key)
(scan-io-refs-walk (dict-get node key) io-names refs))
(keys node)))
(_ nil))))
(define
scan-io-refs scan-io-refs
:effects () :effects ()
(fn (fn
(node (io-names :as list)) (node (io-names :as list))
(let ((refs (list))) (scan-io-refs-walk node io-names refs) refs))) (let ((refs (list))) (scan-io-refs-walk node io-names refs) refs)))
(define
(define
transitive-io-refs-walk transitive-io-refs-walk
:effects () :effects ()
(fn (fn
@@ -205,34 +216,38 @@
(append! seen n) (append! seen n)
(let (let
((val (env-get env n))) ((val (env-get env n)))
(cond (match
(= (type-of val) "component") (type-of val)
("component"
(do (do
(for-each (for-each
(fn (fn
((ref :as string)) ((ref :as string))
(when (not (contains? all-refs ref)) (append! all-refs ref))) (when
(not (contains? all-refs ref))
(append! all-refs ref)))
(scan-io-refs (component-body val) io-names)) (scan-io-refs (component-body val) io-names))
(for-each (for-each
(fn (fn
((dep :as string)) ((dep :as string))
(transitive-io-refs-walk dep seen all-refs env io-names)) (transitive-io-refs-walk dep seen all-refs env io-names))
(scan-refs (component-body val)))) (scan-refs (component-body val)))))
(= (type-of val) "macro") ("macro"
(do (do
(for-each (for-each
(fn (fn
((ref :as string)) ((ref :as string))
(when (not (contains? all-refs ref)) (append! all-refs ref))) (when
(not (contains? all-refs ref))
(append! all-refs ref)))
(scan-io-refs (macro-body val) io-names)) (scan-io-refs (macro-body val) io-names))
(for-each (for-each
(fn (fn
((dep :as string)) ((dep :as string))
(transitive-io-refs-walk dep seen all-refs env io-names)) (transitive-io-refs-walk dep seen all-refs env io-names))
(scan-refs (macro-body val)))) (scan-refs (macro-body val)))))
:else nil))))) (_ nil))))))
(define
(define
transitive-io-refs transitive-io-refs
:effects () :effects ()
(fn (fn
@@ -243,8 +258,7 @@
(key (if (starts-with? name "~") name (str "~" name)))) (key (if (starts-with? name "~") name (str "~" name))))
(transitive-io-refs-walk key seen all-refs env io-names) (transitive-io-refs-walk key seen all-refs env io-names)
all-refs))) all-refs)))
(define
(define
compute-all-io-refs compute-all-io-refs
:effects (mutation) :effects (mutation)
(fn (fn
@@ -260,8 +274,7 @@
val val
(transitive-io-refs name env io-names))))) (transitive-io-refs name env io-names)))))
(env-components env)))) (env-components env))))
(define
(define
component-io-refs-cached component-io-refs-cached
:effects () :effects ()
(fn (fn
@@ -277,8 +290,7 @@
(not (empty? (component-io-refs val)))) (not (empty? (component-io-refs val))))
(component-io-refs val) (component-io-refs val)
(transitive-io-refs name env io-names)))))) (transitive-io-refs name env io-names))))))
(define
(define
component-pure? component-pure?
:effects () :effects ()
(fn (fn
@@ -294,8 +306,7 @@
(not (empty? (component-io-refs val)))) (not (empty? (component-io-refs val))))
false false
(empty? (transitive-io-refs name env io-names))))))) (empty? (transitive-io-refs name env io-names)))))))
(define
(define
render-target render-target
:effects () :effects ()
(fn (fn
@@ -307,18 +318,16 @@
(if (if
(not (= (type-of val) "component")) (not (= (type-of val) "component"))
"server" "server"
(let (match
((affinity (component-affinity val))) (component-affinity val)
(cond ("server" "server")
(= affinity "server") ("client" "client")
"server" (_
(= affinity "client") (if
"client"
(not (component-pure? name env io-names)) (not (component-pure? name env io-names))
"server" "server"
:else "client"))))))) "client"))))))))
(define
(define
page-render-plan page-render-plan
:effects () :effects ()
(fn (fn
@@ -349,8 +358,7 @@
(append! client-list name)))) (append! client-list name))))
needed) needed)
{:io-deps io-deps :server server-list :components comp-targets :client client-list}))) {:io-deps io-deps :server server-list :components comp-targets :client client-list})))
(define
(define
env-components env-components
:effects () :effects ()
(fn (fn
@@ -359,10 +367,7 @@
(fn (fn
((k :as string)) ((k :as string))
(let ((v (env-get env k))) (or (component? v) (macro? v)))) (let ((v (env-get env k))) (or (component? v) (macro? v))))
(keys env)))) (keys env)))))) ;; end define-library
)) ;; end define-library
;; Re-export to global namespace for backward compatibility ;; Re-export to global namespace for backward compatibility
(import (web deps)) (import (web deps))

4
shared/static/wasm/sx/deps.sxbc
View File

File diff suppressed because one or more lines are too long

205
shared/static/wasm/sx/engine.sx
View File

@@ -4,7 +4,8 @@
(import (sx dom)) (import (sx dom))
(import (sx browser)) (import (sx browser))
(define-library (web engine) (define-library
(web engine)
(export (export
ENGINE_VERBS ENGINE_VERBS
DEFAULT_SWAP DEFAULT_SWAP
@@ -40,12 +41,9 @@
should-boost-form? should-boost-form?
parse-sse-swap) parse-sse-swap)
(begin (begin
(define ENGINE_VERBS (list "get" "post" "put" "delete" "patch"))
(define ENGINE_VERBS (list "get" "post" "put" "delete" "patch")) (define DEFAULT_SWAP "outerHTML")
(define
(define DEFAULT_SWAP "outerHTML")
(define
parse-time parse-time
:effects () :effects ()
(fn (fn
@@ -60,8 +58,7 @@
(ends-with? s "s") (ends-with? s "s")
(* (parse-int (replace s "s" "") 0) 1000) (* (parse-int (replace s "s" "") 0) 1000)
(parse-int s 0)))))) (parse-int s 0))))))
(define
(define
parse-trigger-spec parse-trigger-spec
:effects () :effects ()
(fn (fn
@@ -82,7 +79,9 @@
(empty? tokens) (empty? tokens)
nil nil
(if (if
(and (= (first tokens) "every") (>= (len tokens) 2)) (and
(= (first tokens) "every")
(>= (len tokens) 2))
(dict (dict
"event" "event"
"every" "every"
@@ -127,23 +126,19 @@
mods)) mods))
(dict "event" raw-event "modifiers" mods))))))))) (dict "event" raw-event "modifiers" mods)))))))))
raw-parts)))))) raw-parts))))))
(define
(define
default-trigger default-trigger
:effects () :effects ()
(fn (fn
((tag-name :as string)) ((tag-name :as string))
(cond (match
(= tag-name "form") tag-name
(list (dict "event" "submit" "modifiers" (dict))) ("form" (list (dict "event" "submit" "modifiers" (dict))))
(or ("input" (list (dict "event" "change" "modifiers" (dict))))
(= tag-name "input") ("select" (list (dict "event" "change" "modifiers" (dict))))
(= tag-name "select") ("textarea" (list (dict "event" "change" "modifiers" (dict))))
(= tag-name "textarea")) (_ (list (dict "event" "click" "modifiers" (dict)))))))
(list (dict "event" "change" "modifiers" (dict))) (define
:else (list (dict "event" "click" "modifiers" (dict))))))
(define
get-verb-info get-verb-info
:effects (io) :effects (io)
(fn (fn
@@ -155,8 +150,7 @@
((url (dom-get-attr el (str "sx-" verb)))) ((url (dom-get-attr el (str "sx-" verb))))
(if url (dict "method" (upper verb) "url" url) nil))) (if url (dict "method" (upper verb) "url" url) nil)))
ENGINE_VERBS))) ENGINE_VERBS)))
(define
(define
build-request-headers build-request-headers
:effects (io) :effects (io)
(fn (fn
@@ -168,7 +162,9 @@
(when target-sel (dict-set! headers "SX-Target" target-sel))) (when target-sel (dict-set! headers "SX-Target" target-sel)))
(let (let
((comp-hash (dom-get-attr (dom-query "script[data-components][data-hash]") "data-hash"))) ((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
comp-hash
(dict-set! headers "SX-Components-Hash" comp-hash)))
(let (let
((extra-h (dom-get-attr el "sx-headers"))) ((extra-h (dom-get-attr el "sx-headers")))
(when (when
@@ -183,8 +179,7 @@
(dict-set! headers key (str (get parsed key)))) (dict-set! headers key (str (get parsed key))))
(keys parsed)))))) (keys parsed))))))
headers))) headers)))
(define
(define
process-response-headers process-response-headers
:effects () :effects ()
(fn (fn
@@ -214,8 +209,7 @@
(get-header "SX-Cache-Invalidate") (get-header "SX-Cache-Invalidate")
"cache-update" "cache-update"
(get-header "SX-Cache-Update")))) (get-header "SX-Cache-Update"))))
(define
(define
parse-swap-spec parse-swap-spec
:effects () :effects ()
(fn (fn
@@ -234,8 +228,7 @@
(set! use-transition false))) (set! use-transition false)))
(rest parts)) (rest parts))
(dict "style" style "transition" use-transition)))) (dict "style" style "transition" use-transition))))
(define
(define
parse-retry-spec parse-retry-spec
:effects () :effects ()
(fn (fn
@@ -252,15 +245,13 @@
(parse-int (nth parts 1) 1000) (parse-int (nth parts 1) 1000)
"cap-ms" "cap-ms"
(parse-int (nth parts 2) 30000)))))) (parse-int (nth parts 2) 30000))))))
(define
(define
next-retry-ms next-retry-ms
:effects () :effects ()
(fn (fn
((current-ms :as number) (cap-ms :as number)) ((current-ms :as number) (cap-ms :as number))
(min (* current-ms 2) cap-ms))) (min (* current-ms 2) cap-ms)))
(define
(define
filter-params filter-params
:effects () :effects ()
(fn (fn
@@ -279,29 +270,29 @@
(let (let
((excluded (map trim (split (slice params-spec 4) ",")))) ((excluded (map trim (split (slice params-spec 4) ","))))
(filter (filter
(fn ((p :as list)) (not (contains? excluded (first p)))) (fn
((p :as list))
(not (contains? excluded (first p))))
all-params)) all-params))
(let (let
((allowed (map trim (split params-spec ",")))) ((allowed (map trim (split params-spec ","))))
(filter (filter
(fn ((p :as list)) (contains? allowed (first p))) (fn ((p :as list)) (contains? allowed (first p)))
all-params)))))))) all-params))))))))
(define
(define
resolve-target resolve-target
:effects (io) :effects (io)
(fn (fn
(el) (el)
(let (let
((sel (dom-get-attr el "sx-target"))) ((sel (dom-get-attr el "sx-target")))
(cond (match
(or (nil? sel) (= sel "this")) sel
el (nil el)
(= sel "closest") ("this" el)
(dom-parent el) ("closest" (dom-parent el))
:else (dom-query sel))))) (_ (dom-query sel))))))
(define
(define
apply-optimistic apply-optimistic
:effects (mutation io) :effects (mutation io)
(fn (fn
@@ -322,7 +313,10 @@
(dom-set-style target "pointer-events" "none")) (dom-set-style target "pointer-events" "none"))
(= directive "disable") (= directive "disable")
(do (do
(dict-set! state "disabled" (dom-get-prop target "disabled")) (dict-set!
state
"disabled"
(dom-get-prop target "disabled"))
(dom-set-prop target "disabled" true)) (dom-set-prop target "disabled" true))
(starts-with? directive "add-class:") (starts-with? directive "add-class:")
(let (let
@@ -330,8 +324,7 @@
(dict-set! state "add-class" cls) (dict-set! state "add-class" cls)
(dom-add-class target cls))) (dom-add-class target cls)))
state))))) state)))))
(define
(define
revert-optimistic revert-optimistic
:effects (mutation io) :effects (mutation io)
(fn (fn
@@ -339,18 +332,24 @@
(when (when
state state
(let (let
((target (get state "target")) (directive (get state "directive"))) ((target (get state "target"))
(directive (get state "directive")))
(cond (cond
(= directive "remove") (= directive "remove")
(do (do
(dom-set-style target "opacity" (or (get state "opacity") "")) (dom-set-style
target
"opacity"
(or (get state "opacity") ""))
(dom-set-style target "pointer-events" "")) (dom-set-style target "pointer-events" ""))
(= directive "disable") (= directive "disable")
(dom-set-prop target "disabled" (or (get state "disabled") false)) (dom-set-prop
target
"disabled"
(or (get state "disabled") false))
(get state "add-class") (get state "add-class")
(dom-remove-class target (get state "add-class"))))))) (dom-remove-class target (get state "add-class")))))))
(define
(define
find-oob-swaps find-oob-swaps
:effects (mutation io) :effects (mutation io)
(fn (fn
@@ -383,8 +382,7 @@
oob-els))) oob-els)))
(list "sx-swap-oob" "hx-swap-oob")) (list "sx-swap-oob" "hx-swap-oob"))
results))) results)))
(define
(define
morph-node morph-node
:effects (mutation io) :effects (mutation io)
(fn (fn
@@ -416,9 +414,12 @@
(dom-parent old-node) (dom-parent old-node)
(dom-clone new-node true) (dom-clone new-node true)
old-node) old-node)
(or (= (dom-node-type old-node) 3) (= (dom-node-type old-node) 8)) (or
(= (dom-node-type old-node) 3)
(= (dom-node-type old-node) 8))
(when (when
(not (= (dom-text-content old-node) (dom-text-content new-node))) (not
(= (dom-text-content old-node) (dom-text-content new-node)))
(dom-set-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) (= (dom-node-type old-node) 1)
(do (do
@@ -439,8 +440,7 @@
(dom-is-active-element? old-node) (dom-is-active-element? old-node)
(dom-is-input-element? old-node))) (dom-is-input-element? old-node)))
(morph-children old-node new-node)))))) (morph-children old-node new-node))))))
(define
(define
sync-attrs sync-attrs
:effects (mutation io) :effects (mutation io)
(fn (fn
@@ -471,8 +471,7 @@
(not (= aname "data-sx-reactive-attrs"))) (not (= aname "data-sx-reactive-attrs")))
(dom-remove-attr old-el aname)))) (dom-remove-attr old-el aname))))
(dom-attr-list old-el))))) (dom-attr-list old-el)))))
(define
(define
morph-children morph-children
:effects (mutation io) :effects (mutation io)
(fn (fn
@@ -501,8 +500,10 @@
(new-child) (new-child)
(let (let
((raw-id (dom-id new-child)) ((raw-id (dom-id new-child))
(match-id (if (and raw-id (not (empty? raw-id))) raw-id nil)) (match-id
(match-by-id (if match-id (dict-get old-by-id match-id) nil))) (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 (cond
(and match-by-id (not (nil? match-by-id))) (and match-by-id (not (nil? match-by-id)))
(do (do
@@ -552,8 +553,7 @@
(not (dom-has-attr? leftover "sx-ignore"))) (not (dom-has-attr? leftover "sx-ignore")))
(dom-remove-child old-parent leftover))))) (dom-remove-child old-parent leftover)))))
(range 0 (len old-kids)))))) (range 0 (len old-kids))))))
(define
(define
morph-island-children morph-island-children
:effects (mutation io) :effects (mutation io)
(fn (fn
@@ -598,11 +598,12 @@
((id (dom-get-attr old-marsh "data-sx-marsh"))) ((id (dom-get-attr old-marsh "data-sx-marsh")))
(let (let
((new-marsh (dict-get new-marsh-map id))) ((new-marsh (dict-get new-marsh-map id)))
(when new-marsh (morph-marsh old-marsh new-marsh old-island))))) (when
new-marsh
(morph-marsh old-marsh new-marsh old-island)))))
old-marshes) old-marshes)
(process-signal-updates new-island))))) (process-signal-updates new-island)))))
(define
(define
morph-marsh morph-marsh
:effects (mutation io) :effects (mutation io)
(fn (fn
@@ -629,8 +630,7 @@
(do (do
(sync-attrs old-marsh new-marsh) (sync-attrs old-marsh new-marsh)
(morph-children old-marsh new-marsh)))))) (morph-children old-marsh new-marsh))))))
(define
(define
process-signal-updates process-signal-updates
:effects (mutation io) :effects (mutation io)
(fn (fn
@@ -656,8 +656,7 @@
(reset! (use-store store-name) parsed)) (reset! (use-store store-name) parsed))
(dom-remove-attr el "data-sx-signal"))))))) (dom-remove-attr el "data-sx-signal")))))))
signal-els)))) signal-els))))
(define
(define
swap-dom-nodes swap-dom-nodes
:effects (mutation io) :effects (mutation io)
(fn (fn
@@ -674,7 +673,8 @@
(morph-children target wrapper))) (morph-children target wrapper)))
"outerHTML" "outerHTML"
(let (let
((parent (dom-parent target)) (new-el (dom-clone new-nodes true))) ((parent (dom-parent target))
(new-el (dom-clone new-nodes true)))
(if (if
(dom-is-fragment? new-nodes) (dom-is-fragment? new-nodes)
(let (let
@@ -709,8 +709,7 @@
((wrapper (dom-create-element "div" nil))) ((wrapper (dom-create-element "div" nil)))
(dom-append wrapper new-nodes) (dom-append wrapper new-nodes)
(morph-children target wrapper)))))) (morph-children target wrapper))))))
(define
(define
insert-remaining-siblings insert-remaining-siblings
:effects (mutation io) :effects (mutation io)
(fn (fn
@@ -721,8 +720,7 @@
((next (dom-next-sibling sib))) ((next (dom-next-sibling sib)))
(dom-insert-after ref-node sib) (dom-insert-after ref-node sib)
(insert-remaining-siblings parent sib next))))) (insert-remaining-siblings parent sib next)))))
(define
(define
swap-html-string swap-html-string
:effects (mutation io) :effects (mutation io)
(fn (fn
@@ -750,8 +748,7 @@
"none" "none"
nil nil
:else (dom-set-inner-html target html)))) :else (dom-set-inner-html target html))))
(define
(define
handle-history handle-history
:effects (io) :effects (io)
(fn (fn
@@ -768,11 +765,10 @@
(save-scroll-position) (save-scroll-position)
(browser-push-state (if (= push-url "true") url push-url))) (browser-push-state (if (= push-url "true") url push-url)))
(and replace-url (not (= replace-url "false"))) (and replace-url (not (= replace-url "false")))
(browser-replace-state (if (= replace-url "true") url replace-url)))))) (browser-replace-state
(if (= replace-url "true") url replace-url))))))
(define PRELOAD_TTL 30000) (define PRELOAD_TTL 30000)
(define
(define
preload-cache-get preload-cache-get
:effects (mutation) :effects (mutation)
(fn (fn
@@ -786,8 +782,7 @@
(> (- (now-ms) (get entry "timestamp")) PRELOAD_TTL) (> (- (now-ms) (get entry "timestamp")) PRELOAD_TTL)
(do (dict-delete! cache url) nil) (do (dict-delete! cache url) nil)
(do (dict-delete! cache url) entry)))))) (do (dict-delete! cache url) entry))))))
(define
(define
preload-cache-set preload-cache-set
:effects (mutation) :effects (mutation)
(fn (fn
@@ -799,26 +794,21 @@
cache cache
url url
(dict "text" text "content-type" content-type "timestamp" (now-ms))))) (dict "text" text "content-type" content-type "timestamp" (now-ms)))))
(define
(define
classify-trigger classify-trigger
:effects () :effects ()
(fn (fn
((trigger :as dict)) ((trigger :as dict))
(let (let
((event (get trigger "event"))) ((event (get trigger "event")))
(cond (match
(= event "every") event
"poll" ("every" "poll")
(= event "intersect") ("intersect" "intersect")
"intersect" ("load" "load")
(= event "load") ("revealed" "revealed")
"load" (_ "event")))))
(= event "revealed") (define
"revealed"
:else "event"))))
(define
should-boost-link? should-boost-link?
:effects (io) :effects (io)
(fn (fn
@@ -834,8 +824,7 @@
(not (dom-has-attr? link "sx-get")) (not (dom-has-attr? link "sx-get"))
(not (dom-has-attr? link "sx-post")) (not (dom-has-attr? link "sx-post"))
(not (dom-has-attr? link "sx-disable")))))) (not (dom-has-attr? link "sx-disable"))))))
(define
(define
should-boost-form? should-boost-form?
:effects (io) :effects (io)
(fn (fn
@@ -844,14 +833,10 @@
(not (dom-has-attr? form "sx-get")) (not (dom-has-attr? form "sx-get"))
(not (dom-has-attr? form "sx-post")) (not (dom-has-attr? form "sx-post"))
(not (dom-has-attr? form "sx-disable"))))) (not (dom-has-attr? form "sx-disable")))))
(define
(define
parse-sse-swap parse-sse-swap
:effects (io) :effects (io)
(fn (el) (or (dom-get-attr el "sx-sse-swap") "message"))) (fn (el) (or (dom-get-attr el "sx-sse-swap") "message"))))) ;; end define-library
)) ;; end define-library
;; Re-export to global namespace for backward compatibility ;; Re-export to global namespace for backward compatibility
(import (web engine)) (import (web engine))

4
shared/static/wasm/sx/engine.sxbc
View File

File diff suppressed because one or more lines are too long