giles
fc2b5e502f
Lazy module loading (Step 5 piece 6 completion): - Add define-library wrappers + import declarations to 13 source .sx files - compile-modules.js generates module-manifest.json with dependency graph - compile-modules.js strips define-library/import before bytecode compilation (VM doesn't handle these as special forms) - sx-platform.js replaces hardcoded 24-file loadWebStack() with manifest-driven recursive loader — only downloads modules the page needs - Result: 12 modules loaded (was 24), zero errors, zero warnings - Fallback to full load if manifest missing VM transpilation prep (Step 6b): - Refactor lib/vm.sx: 20 accessor functions replace raw dict access - Factor out collect-n-from-stack, collect-n-pairs, pad-n-nils helpers - bootstrap_vm.py: transpiles 9 VM logic functions to OCaml - sx_vm_ref.ml: proof that vm.sx transpiles (preamble has stubs) Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
1352 lines
44 KiB
Plaintext
1352 lines
44 KiB
Plaintext
(import (sx dom))
|
|
(import (sx render))
|
|
|
|
(define-library (web adapter-dom)
|
|
(export SVG_NS MATH_NS island-scope? contains-deref? dom-on render-to-dom render-dom-list render-dom-element render-dom-component render-dom-fragment render-dom-raw render-dom-unknown-component RENDER_DOM_FORMS render-dom-form? dispatch-render-form render-lambda-dom render-dom-island render-dom-lake render-dom-marsh reactive-text reactive-attr reactive-spread reactive-fragment render-list-item extract-key reactive-list bind-input *use-cek-reactive* enable-cek-reactive! cek-reactive-text cek-reactive-attr render-dom-portal render-dom-error-boundary)
|
|
(begin
|
|
|
|
(define SVG_NS "http://www.w3.org/2000/svg")
|
|
|
|
(define MATH_NS "http://www.w3.org/1998/Math/MathML")
|
|
|
|
(define island-scope? (fn () (not (nil? (scope-peek "sx-island-scope")))))
|
|
|
|
(begin
|
|
(define *memo-cache* (dict))
|
|
(define *cyst-counter* 0)
|
|
(define
|
|
next-cyst-id
|
|
(fn
|
|
()
|
|
(set! *cyst-counter* (+ *cyst-counter* 1))
|
|
(str "sx-cyst-" *cyst-counter*))))
|
|
|
|
(define
|
|
contains-deref?
|
|
(fn
|
|
(expr)
|
|
(if
|
|
(not (list? expr))
|
|
false
|
|
(if
|
|
(empty? expr)
|
|
false
|
|
(if
|
|
(and
|
|
(= (type-of (first expr)) "symbol")
|
|
(= (symbol-name (first expr)) "deref"))
|
|
true
|
|
(some contains-deref? expr))))))
|
|
|
|
(define
|
|
dom-on
|
|
:effects (io)
|
|
(fn
|
|
(el name handler)
|
|
(dom-listen
|
|
el
|
|
name
|
|
(if
|
|
(lambda? handler)
|
|
(if
|
|
(= 0 (len (lambda-params handler)))
|
|
(fn
|
|
(_e)
|
|
(trampoline (call-lambda handler (list)))
|
|
(run-post-render-hooks))
|
|
(fn
|
|
(e)
|
|
(trampoline (call-lambda handler (list e)))
|
|
(run-post-render-hooks)))
|
|
handler))))
|
|
|
|
(define
|
|
render-to-dom
|
|
:effects (render)
|
|
(fn
|
|
(expr (env :as dict) (ns :as string))
|
|
(set-render-active! true)
|
|
(case
|
|
(type-of expr)
|
|
"nil"
|
|
(create-fragment)
|
|
"boolean"
|
|
(create-fragment)
|
|
"raw-html"
|
|
(dom-parse-html (raw-html-content expr))
|
|
"string"
|
|
(create-text-node expr)
|
|
"number"
|
|
(create-text-node (str expr))
|
|
"symbol"
|
|
(render-to-dom (trampoline (eval-expr expr env)) env ns)
|
|
"keyword"
|
|
(create-text-node (keyword-name expr))
|
|
"dom-node"
|
|
expr
|
|
"spread"
|
|
(do
|
|
(when
|
|
(not (island-scope?))
|
|
(scope-emit! "element-attrs" (spread-attrs expr)))
|
|
expr)
|
|
"dict"
|
|
(if (has-key? expr "__host_handle") expr (create-fragment))
|
|
"list"
|
|
(if (empty? expr) (create-fragment) (render-dom-list expr env ns))
|
|
:else (if
|
|
(signal? expr)
|
|
(if
|
|
(island-scope?)
|
|
(reactive-text expr)
|
|
(create-text-node (str (deref expr))))
|
|
(create-text-node (str expr))))))
|
|
|
|
(define
|
|
render-dom-list
|
|
:effects (render)
|
|
(fn
|
|
(expr (env :as dict) (ns :as string))
|
|
(let
|
|
((head (first expr)))
|
|
(cond
|
|
(= (type-of head) "symbol")
|
|
(let
|
|
((name (symbol-name head)) (args (rest expr)))
|
|
(cond
|
|
(= name "raw!")
|
|
(render-dom-raw args env)
|
|
(= name "<>")
|
|
(render-dom-fragment args env ns)
|
|
(= name "lake")
|
|
(render-dom-lake args env ns)
|
|
(= name "marsh")
|
|
(render-dom-marsh args env ns)
|
|
(starts-with? name "html:")
|
|
(render-dom-element (slice name 5) args env ns)
|
|
(render-dom-form? name)
|
|
(if
|
|
(and
|
|
(contains? HTML_TAGS name)
|
|
(or
|
|
(and
|
|
(> (len args) 0)
|
|
(= (type-of (first args)) "keyword"))
|
|
ns))
|
|
(render-dom-element name args env ns)
|
|
(dispatch-render-form name expr env ns))
|
|
(and (env-has? env name) (macro? (env-get env name)))
|
|
(render-to-dom (expand-macro (env-get env name) args env) env ns)
|
|
(contains? HTML_TAGS name)
|
|
(render-dom-element name args env ns)
|
|
(and
|
|
(starts-with? name "~")
|
|
(env-has? env name)
|
|
(island? (env-get env name)))
|
|
(if
|
|
(scope-peek "sx-render-markers")
|
|
(let
|
|
((island (env-get env name))
|
|
(marker (dom-create-element "span" nil))
|
|
(kw-state (dict)))
|
|
(reduce
|
|
(fn
|
|
(state arg)
|
|
(let
|
|
((skip (get state "skip")))
|
|
(if
|
|
skip
|
|
(assoc state "skip" false "i" (inc (get state "i")))
|
|
(if
|
|
(and
|
|
(= (type-of arg) "keyword")
|
|
(< (inc (get state "i")) (len args)))
|
|
(let
|
|
((kname (keyword-name arg))
|
|
(kval
|
|
(trampoline
|
|
(eval-expr
|
|
(nth args (inc (get state "i")))
|
|
env))))
|
|
(dict-set! kw-state kname kval)
|
|
(assoc
|
|
state
|
|
"skip"
|
|
true
|
|
"i"
|
|
(inc (get state "i"))))
|
|
(assoc state "i" (inc (get state "i")))))))
|
|
(dict "i" 0 "skip" false)
|
|
args)
|
|
(dom-set-attr marker "data-sx-island" (component-name island))
|
|
(when
|
|
(not (empty-dict? kw-state))
|
|
(dom-set-attr
|
|
marker
|
|
"data-sx-state"
|
|
(sx-serialize kw-state)))
|
|
marker)
|
|
(render-dom-island (env-get env name) args env ns))
|
|
(starts-with? name "~")
|
|
(let
|
|
((comp (env-get env name)))
|
|
(if
|
|
(component? comp)
|
|
(render-dom-component comp args env ns)
|
|
(render-dom-unknown-component name)))
|
|
(and
|
|
(> (index-of name "-") 0)
|
|
(> (len args) 0)
|
|
(= (type-of (first args)) "keyword"))
|
|
(render-dom-element name args env ns)
|
|
ns
|
|
(render-dom-element name args env ns)
|
|
(and (= name "deref") (island-scope?))
|
|
(let
|
|
((sig-or-val (trampoline (eval-expr (first args) env))))
|
|
(if
|
|
(signal? sig-or-val)
|
|
(reactive-text sig-or-val)
|
|
(create-text-node (str (deref sig-or-val)))))
|
|
(and (island-scope?) (contains-deref? expr))
|
|
(reactive-text
|
|
(computed (fn () (trampoline (eval-expr expr env)))))
|
|
:else (render-to-dom (trampoline (eval-expr expr env)) env ns)))
|
|
(or (lambda? head) (= (type-of head) "list"))
|
|
(render-to-dom (trampoline (eval-expr expr env)) env ns)
|
|
:else (let
|
|
((frag (create-fragment)))
|
|
(for-each
|
|
(fn
|
|
(x)
|
|
(let
|
|
((result (render-to-dom x env ns)))
|
|
(when (not (spread? result)) (dom-append frag result))))
|
|
expr)
|
|
frag)))))
|
|
|
|
(define
|
|
render-dom-element
|
|
:effects (render)
|
|
(fn
|
|
((tag :as string) (args :as list) (env :as dict) (ns :as string))
|
|
(let
|
|
((new-ns (cond (= tag "svg") SVG_NS (= tag "math") MATH_NS :else ns))
|
|
(el (dom-create-element tag new-ns)))
|
|
(scope-push! "element-attrs" nil)
|
|
(reduce
|
|
(fn
|
|
(state arg)
|
|
(let
|
|
((skip (get state "skip")))
|
|
(if
|
|
skip
|
|
(assoc state "skip" false "i" (inc (get state "i")))
|
|
(if
|
|
(and
|
|
(= (type-of arg) "keyword")
|
|
(< (inc (get state "i")) (len args)))
|
|
(let
|
|
((attr-name (keyword-name arg))
|
|
(attr-expr (nth args (inc (get state "i")))))
|
|
(cond
|
|
(starts-with? attr-name "on-")
|
|
(let
|
|
((attr-val (trampoline (eval-expr attr-expr env))))
|
|
(when
|
|
(callable? attr-val)
|
|
(dom-on el (slice attr-name 3) attr-val)))
|
|
(= attr-name "bind")
|
|
(let
|
|
((attr-val (trampoline (eval-expr attr-expr env))))
|
|
(when (signal? attr-val) (bind-input el attr-val)))
|
|
(= attr-name "ref")
|
|
(let
|
|
((attr-val (trampoline (eval-expr attr-expr env))))
|
|
(dict-set! attr-val "current" el))
|
|
(= attr-name "key")
|
|
(let
|
|
((attr-val (trampoline (eval-expr attr-expr env))))
|
|
(dom-set-attr el "key" (str attr-val)))
|
|
(island-scope?)
|
|
(reactive-attr
|
|
el
|
|
attr-name
|
|
(fn () (trampoline (eval-expr attr-expr env))))
|
|
:else (let
|
|
((attr-val (trampoline (eval-expr attr-expr env))))
|
|
(cond
|
|
(or (nil? attr-val) (= attr-val false))
|
|
nil
|
|
(contains? BOOLEAN_ATTRS attr-name)
|
|
(when attr-val (dom-set-attr el attr-name ""))
|
|
(= attr-val true)
|
|
(dom-set-attr el attr-name "")
|
|
:else (dom-set-attr el attr-name (str attr-val)))))
|
|
(assoc state "skip" true "i" (inc (get state "i"))))
|
|
(do
|
|
(when
|
|
(not (contains? VOID_ELEMENTS tag))
|
|
(let
|
|
((child (render-to-dom arg env new-ns)))
|
|
(cond
|
|
(and (spread? child) (island-scope?))
|
|
(reactive-spread
|
|
el
|
|
(fn () (render-to-dom arg env new-ns)))
|
|
(spread? child)
|
|
nil
|
|
:else (dom-append el child))))
|
|
(assoc state "i" (inc (get state "i"))))))))
|
|
(dict "i" 0 "skip" false)
|
|
args)
|
|
(for-each
|
|
(fn
|
|
(spread-dict)
|
|
(for-each
|
|
(fn
|
|
((key :as string))
|
|
(let
|
|
((val (dict-get spread-dict key)))
|
|
(if
|
|
(= key "class")
|
|
(let
|
|
((existing (dom-get-attr el "class")))
|
|
(dom-set-attr
|
|
el
|
|
"class"
|
|
(if
|
|
(and existing (not (= existing "")))
|
|
(str existing " " val)
|
|
val)))
|
|
(if
|
|
(= key "style")
|
|
(let
|
|
((existing (dom-get-attr el "style")))
|
|
(dom-set-attr
|
|
el
|
|
"style"
|
|
(if
|
|
(and existing (not (= existing "")))
|
|
(str existing ";" val)
|
|
val)))
|
|
(dom-set-attr el key (str val))))))
|
|
(keys spread-dict)))
|
|
(scope-emitted "element-attrs"))
|
|
(scope-pop! "element-attrs")
|
|
el)))
|
|
|
|
(define
|
|
render-dom-component
|
|
:effects (render)
|
|
(fn
|
|
((comp :as component) (args :as list) (env :as dict) (ns :as string))
|
|
(let
|
|
((kwargs (dict)) (children (list)))
|
|
(reduce
|
|
(fn
|
|
(state arg)
|
|
(let
|
|
((skip (get state "skip")))
|
|
(if
|
|
skip
|
|
(assoc state "skip" false "i" (inc (get state "i")))
|
|
(if
|
|
(and
|
|
(= (type-of arg) "keyword")
|
|
(< (inc (get state "i")) (len args)))
|
|
(let
|
|
((val (trampoline (eval-expr (nth args (inc (get state "i"))) env))))
|
|
(dict-set! kwargs (keyword-name arg) val)
|
|
(assoc state "skip" true "i" (inc (get state "i"))))
|
|
(do
|
|
(append! children arg)
|
|
(assoc state "i" (inc (get state "i"))))))))
|
|
(dict "i" 0 "skip" false)
|
|
args)
|
|
(let
|
|
((local (env-merge (component-closure comp) env)))
|
|
(for-each
|
|
(fn
|
|
(p)
|
|
(env-bind!
|
|
local
|
|
p
|
|
(if (dict-has? kwargs p) (dict-get kwargs p) nil)))
|
|
(component-params comp))
|
|
(when
|
|
(component-has-children? comp)
|
|
(let
|
|
((child-frag (create-fragment)))
|
|
(for-each
|
|
(fn
|
|
(c)
|
|
(let
|
|
((result (render-to-dom c env ns)))
|
|
(when
|
|
(not (spread? result))
|
|
(dom-append child-frag result))))
|
|
children)
|
|
(env-bind! local "children" child-frag)))
|
|
(render-to-dom (component-body comp) local ns)))))
|
|
|
|
(define
|
|
render-dom-fragment
|
|
:effects (render)
|
|
(fn
|
|
((args :as list) (env :as dict) (ns :as string))
|
|
(let
|
|
((frag (create-fragment)))
|
|
(for-each
|
|
(fn
|
|
(x)
|
|
(let
|
|
((result (render-to-dom x env ns)))
|
|
(when (not (spread? result)) (dom-append frag result))))
|
|
args)
|
|
frag)))
|
|
|
|
(define
|
|
render-dom-raw
|
|
:effects (render)
|
|
(fn
|
|
((args :as list) (env :as dict))
|
|
(let
|
|
((frag (create-fragment)))
|
|
(for-each
|
|
(fn
|
|
(arg)
|
|
(let
|
|
((val (trampoline (eval-expr arg env))))
|
|
(cond
|
|
(= (type-of val) "string")
|
|
(dom-append frag (dom-parse-html val))
|
|
(= (type-of val) "dom-node")
|
|
(dom-append frag (dom-clone val))
|
|
(not (nil? val))
|
|
(dom-append frag (create-text-node (str val))))))
|
|
args)
|
|
frag)))
|
|
|
|
(define
|
|
render-dom-unknown-component
|
|
:effects (render)
|
|
(fn ((name :as string)) (error (str "Unknown component: " name))))
|
|
|
|
(define
|
|
RENDER_DOM_FORMS
|
|
(list
|
|
"if"
|
|
"when"
|
|
"cond"
|
|
"case"
|
|
"let"
|
|
"let*"
|
|
"letrec"
|
|
"begin"
|
|
"do"
|
|
"define"
|
|
"defcomp"
|
|
"defisland"
|
|
"defmacro"
|
|
"defstyle"
|
|
"map"
|
|
"map-indexed"
|
|
"filter"
|
|
"for-each"
|
|
"portal"
|
|
"error-boundary"
|
|
"scope"
|
|
"provide"
|
|
"cyst"))
|
|
|
|
(define
|
|
render-dom-form?
|
|
:effects ()
|
|
(fn ((name :as string)) (contains? RENDER_DOM_FORMS name)))
|
|
|
|
(define
|
|
dispatch-render-form
|
|
:effects (render)
|
|
(fn
|
|
((name :as string) expr (env :as dict) (ns :as string))
|
|
(cond
|
|
(= name "if")
|
|
(if
|
|
(island-scope?)
|
|
(let
|
|
((marker (create-comment "r-if"))
|
|
(current-nodes (list))
|
|
(initial-result nil))
|
|
(effect
|
|
(fn
|
|
()
|
|
(let
|
|
((result (let ((cond-val (trampoline (eval-expr (nth expr 1) env)))) (if cond-val (render-to-dom (nth expr 2) env ns) (if (> (len expr) 3) (render-to-dom (nth expr 3) env ns) (create-fragment))))))
|
|
(if
|
|
(dom-parent marker)
|
|
(do
|
|
(for-each (fn (n) (dom-remove n)) current-nodes)
|
|
(set!
|
|
current-nodes
|
|
(if
|
|
(dom-is-fragment? result)
|
|
(dom-child-nodes result)
|
|
(list result)))
|
|
(dom-insert-after marker result))
|
|
(set! initial-result result)))))
|
|
(if
|
|
(spread? initial-result)
|
|
initial-result
|
|
(let
|
|
((frag (create-fragment)))
|
|
(dom-append frag marker)
|
|
(when
|
|
initial-result
|
|
(set!
|
|
current-nodes
|
|
(if
|
|
(dom-is-fragment? initial-result)
|
|
(dom-child-nodes initial-result)
|
|
(list initial-result)))
|
|
(dom-append frag initial-result))
|
|
frag)))
|
|
(let
|
|
((cond-val (trampoline (eval-expr (nth expr 1) env))))
|
|
(if
|
|
cond-val
|
|
(render-to-dom (nth expr 2) env ns)
|
|
(if
|
|
(> (len expr) 3)
|
|
(render-to-dom (nth expr 3) env ns)
|
|
(create-fragment)))))
|
|
(= name "when")
|
|
(if
|
|
(island-scope?)
|
|
(let
|
|
((marker (create-comment "r-when"))
|
|
(current-nodes (list))
|
|
(initial-result nil))
|
|
(effect
|
|
(fn
|
|
()
|
|
(if
|
|
(dom-parent marker)
|
|
(do
|
|
(for-each (fn (n) (dom-remove n)) current-nodes)
|
|
(set! current-nodes (list))
|
|
(when
|
|
(trampoline (eval-expr (nth expr 1) env))
|
|
(let
|
|
((frag (create-fragment)))
|
|
(for-each
|
|
(fn
|
|
(i)
|
|
(dom-append
|
|
frag
|
|
(render-to-dom (nth expr i) env ns)))
|
|
(range 2 (len expr)))
|
|
(set! current-nodes (dom-child-nodes frag))
|
|
(dom-insert-after marker frag))))
|
|
(when
|
|
(trampoline (eval-expr (nth expr 1) env))
|
|
(let
|
|
((frag (create-fragment)))
|
|
(for-each
|
|
(fn
|
|
(i)
|
|
(dom-append frag (render-to-dom (nth expr i) env ns)))
|
|
(range 2 (len expr)))
|
|
(set! current-nodes (dom-child-nodes frag))
|
|
(set! initial-result frag))))))
|
|
(if
|
|
(spread? initial-result)
|
|
initial-result
|
|
(let
|
|
((frag (create-fragment)))
|
|
(dom-append frag marker)
|
|
(when initial-result (dom-append frag initial-result))
|
|
frag)))
|
|
(if
|
|
(not (trampoline (eval-expr (nth expr 1) env)))
|
|
(create-fragment)
|
|
(let
|
|
((frag (create-fragment)))
|
|
(for-each
|
|
(fn
|
|
(i)
|
|
(dom-append frag (render-to-dom (nth expr i) env ns)))
|
|
(range 2 (len expr)))
|
|
frag)))
|
|
(= name "cond")
|
|
(if
|
|
(island-scope?)
|
|
(let
|
|
((marker (create-comment "r-cond"))
|
|
(current-nodes (list))
|
|
(initial-result nil))
|
|
(effect
|
|
(fn
|
|
()
|
|
(let
|
|
((branch (eval-cond (rest expr) env)))
|
|
(if
|
|
(dom-parent marker)
|
|
(do
|
|
(for-each (fn (n) (dom-remove n)) current-nodes)
|
|
(set! current-nodes (list))
|
|
(when
|
|
branch
|
|
(let
|
|
((result (render-to-dom branch env ns)))
|
|
(set!
|
|
current-nodes
|
|
(if
|
|
(dom-is-fragment? result)
|
|
(dom-child-nodes result)
|
|
(list result)))
|
|
(dom-insert-after marker result))))
|
|
(when
|
|
branch
|
|
(let
|
|
((result (render-to-dom branch env ns)))
|
|
(set!
|
|
current-nodes
|
|
(if
|
|
(dom-is-fragment? result)
|
|
(dom-child-nodes result)
|
|
(list result)))
|
|
(set! initial-result result)))))))
|
|
(if
|
|
(spread? initial-result)
|
|
initial-result
|
|
(let
|
|
((frag (create-fragment)))
|
|
(dom-append frag marker)
|
|
(when initial-result (dom-append frag initial-result))
|
|
frag)))
|
|
(let
|
|
((branch (eval-cond (rest expr) env)))
|
|
(if branch (render-to-dom branch env ns) (create-fragment))))
|
|
(= name "case")
|
|
(render-to-dom (trampoline (eval-expr expr env)) env ns)
|
|
(or (= name "let") (= name "let*"))
|
|
(let
|
|
((local (process-bindings (nth expr 1) env)))
|
|
(if
|
|
(= (len expr) 3)
|
|
(render-to-dom (nth expr 2) local ns)
|
|
(let
|
|
((frag (create-fragment)))
|
|
(for-each
|
|
(fn
|
|
(i)
|
|
(let
|
|
((result (render-to-dom (nth expr i) local ns)))
|
|
(when (not (spread? result)) (dom-append frag result))))
|
|
(range 2 (len expr)))
|
|
frag)))
|
|
(= name "letrec")
|
|
(let
|
|
((bindings (nth expr 1))
|
|
(body (slice expr 2))
|
|
(local (env-extend env)))
|
|
(for-each
|
|
(fn
|
|
(pair)
|
|
(let
|
|
((pname (if (= (type-of (first pair)) "symbol") (symbol-name (first pair)) (str (first pair)))))
|
|
(env-bind! local pname nil)))
|
|
bindings)
|
|
(for-each
|
|
(fn
|
|
(pair)
|
|
(let
|
|
((pname (if (= (type-of (first pair)) "symbol") (symbol-name (first pair)) (str (first pair)))))
|
|
(env-set!
|
|
local
|
|
pname
|
|
(trampoline (eval-expr (nth pair 1) local)))))
|
|
bindings)
|
|
(when
|
|
(> (len body) 1)
|
|
(for-each (fn (e) (trampoline (eval-expr e local))) (init body)))
|
|
(render-to-dom (last body) local ns))
|
|
(or (= name "begin") (= name "do"))
|
|
(if
|
|
(= (len expr) 2)
|
|
(render-to-dom (nth expr 1) env ns)
|
|
(let
|
|
((frag (create-fragment)))
|
|
(for-each
|
|
(fn
|
|
(i)
|
|
(let
|
|
((result (render-to-dom (nth expr i) env ns)))
|
|
(when (not (spread? result)) (dom-append frag result))))
|
|
(range 1 (len expr)))
|
|
frag))
|
|
(definition-form? name)
|
|
(do (trampoline (eval-expr expr env)) (create-fragment))
|
|
(= name "map")
|
|
(let
|
|
((coll-expr (nth expr 2)))
|
|
(if
|
|
(and
|
|
(island-scope?)
|
|
(= (type-of coll-expr) "list")
|
|
(> (len coll-expr) 1)
|
|
(= (type-of (first coll-expr)) "symbol")
|
|
(= (symbol-name (first coll-expr)) "deref"))
|
|
(let
|
|
((f (trampoline (eval-expr (nth expr 1) env)))
|
|
(sig (trampoline (eval-expr (nth coll-expr 1) env))))
|
|
(if
|
|
(signal? sig)
|
|
(reactive-list f sig env ns)
|
|
(let
|
|
((coll (deref sig)) (frag (create-fragment)))
|
|
(for-each
|
|
(fn
|
|
(item)
|
|
(let
|
|
((val (if (lambda? f) (render-lambda-dom f (list item) env ns) (render-to-dom (apply f (list item)) env ns))))
|
|
(dom-append frag val)))
|
|
coll)
|
|
frag)))
|
|
(let
|
|
((f (trampoline (eval-expr (nth expr 1) env)))
|
|
(coll (trampoline (eval-expr (nth expr 2) env)))
|
|
(frag (create-fragment)))
|
|
(for-each
|
|
(fn
|
|
(item)
|
|
(let
|
|
((val (if (lambda? f) (render-lambda-dom f (list item) env ns) (render-to-dom (apply f (list item)) env ns))))
|
|
(dom-append frag val)))
|
|
coll)
|
|
frag)))
|
|
(= name "map-indexed")
|
|
(let
|
|
((f (trampoline (eval-expr (nth expr 1) env)))
|
|
(coll (trampoline (eval-expr (nth expr 2) env)))
|
|
(frag (create-fragment)))
|
|
(for-each-indexed
|
|
(fn
|
|
(i item)
|
|
(let
|
|
((val (if (lambda? f) (render-lambda-dom f (list i item) env ns) (render-to-dom (apply f (list i item)) env ns))))
|
|
(dom-append frag val)))
|
|
coll)
|
|
frag)
|
|
(= name "filter")
|
|
(render-to-dom (trampoline (eval-expr expr env)) env ns)
|
|
(= name "portal")
|
|
(render-dom-portal (rest expr) env ns)
|
|
(= name "error-boundary")
|
|
(render-dom-error-boundary (rest expr) env ns)
|
|
(= name "for-each")
|
|
(let
|
|
((f (trampoline (eval-expr (nth expr 1) env)))
|
|
(coll (trampoline (eval-expr (nth expr 2) env)))
|
|
(frag (create-fragment)))
|
|
(for-each
|
|
(fn
|
|
(item)
|
|
(let
|
|
((val (if (lambda? f) (render-lambda-dom f (list item) env ns) (render-to-dom (apply f (list item)) env ns))))
|
|
(dom-append frag val)))
|
|
coll)
|
|
frag)
|
|
(= name "scope")
|
|
(let
|
|
((scope-name (trampoline (eval-expr (nth expr 1) env)))
|
|
(rest-args (slice expr 2))
|
|
(scope-val nil)
|
|
(body-exprs nil)
|
|
(frag (create-fragment)))
|
|
(if
|
|
(and
|
|
(>= (len rest-args) 2)
|
|
(= (type-of (first rest-args)) "keyword")
|
|
(= (keyword-name (first rest-args)) "value"))
|
|
(do
|
|
(set! scope-val (trampoline (eval-expr (nth rest-args 1) env)))
|
|
(set! body-exprs (slice rest-args 2)))
|
|
(set! body-exprs rest-args))
|
|
(scope-push! scope-name scope-val)
|
|
(for-each
|
|
(fn (e) (dom-append frag (render-to-dom e env ns)))
|
|
body-exprs)
|
|
(scope-pop! scope-name)
|
|
frag)
|
|
(= name "provide")
|
|
(let
|
|
((prov-name (trampoline (eval-expr (nth expr 1) env)))
|
|
(prov-val (trampoline (eval-expr (nth expr 2) env)))
|
|
(frag (create-fragment)))
|
|
(scope-push! prov-name prov-val)
|
|
(for-each
|
|
(fn (i) (dom-append frag (render-to-dom (nth expr i) env ns)))
|
|
(range 3 (len expr)))
|
|
(scope-pop! prov-name)
|
|
frag)
|
|
(= name "cyst")
|
|
(let
|
|
((cyst-key (if (and (> (len expr) 2) (= (type-of (nth expr 1)) "keyword") (= (keyword-name (nth expr 1)) "key")) (str (trampoline (eval-expr (nth expr 2) env))) (next-cyst-id)))
|
|
(cached (get *memo-cache* cyst-key)))
|
|
(if
|
|
(and cached (host-get cached "isConnected"))
|
|
cached
|
|
(let
|
|
((container (dom-create-element "div" nil))
|
|
(disposers (list))
|
|
(body-exprs
|
|
(if
|
|
(and
|
|
(> (len expr) 2)
|
|
(= (type-of (nth expr 1)) "keyword")
|
|
(= (keyword-name (nth expr 1)) "key"))
|
|
(slice expr 3)
|
|
(slice expr 1))))
|
|
(dom-set-attr container "data-sx-cyst" cyst-key)
|
|
(let
|
|
((body-dom (with-island-scope (fn (d) (append! disposers d)) (fn () (let ((frag (create-fragment))) (for-each (fn (child) (dom-append frag (render-to-dom child env ns))) body-exprs) frag)))))
|
|
(dom-append container body-dom)
|
|
(dom-set-data container "sx-disposers" disposers)
|
|
(dict-set! *memo-cache* cyst-key container)
|
|
container))))
|
|
:else (render-to-dom (trampoline (eval-expr expr env)) env ns))))
|
|
|
|
(define
|
|
render-lambda-dom
|
|
:effects (render)
|
|
(fn
|
|
((f :as lambda) (args :as list) (env :as dict) (ns :as string))
|
|
(let
|
|
((local (env-merge (lambda-closure f) env)))
|
|
(for-each-indexed
|
|
(fn (i p) (env-bind! local p (nth args i)))
|
|
(lambda-params f))
|
|
(render-to-dom (lambda-body f) local ns))))
|
|
|
|
(define
|
|
render-dom-island
|
|
:effects (render mutation)
|
|
(fn
|
|
((island :as island) (args :as list) (env :as dict) (ns :as string))
|
|
(let
|
|
((kwargs (dict)) (children (list)))
|
|
(reduce
|
|
(fn
|
|
(state arg)
|
|
(let
|
|
((skip (get state "skip")))
|
|
(if
|
|
skip
|
|
(assoc state "skip" false "i" (inc (get state "i")))
|
|
(if
|
|
(and
|
|
(= (type-of arg) "keyword")
|
|
(< (inc (get state "i")) (len args)))
|
|
(let
|
|
((val (trampoline (eval-expr (nth args (inc (get state "i"))) env))))
|
|
(dict-set! kwargs (keyword-name arg) val)
|
|
(assoc state "skip" true "i" (inc (get state "i"))))
|
|
(do
|
|
(append! children arg)
|
|
(assoc state "i" (inc (get state "i"))))))))
|
|
(dict "i" 0 "skip" false)
|
|
args)
|
|
(let
|
|
((local (env-merge (component-closure island) env))
|
|
(island-name (component-name island)))
|
|
(for-each
|
|
(fn
|
|
(p)
|
|
(env-bind!
|
|
local
|
|
p
|
|
(if (dict-has? kwargs p) (dict-get kwargs p) nil)))
|
|
(component-params island))
|
|
(when
|
|
(component-has-children? island)
|
|
(let
|
|
((child-frag (create-fragment)))
|
|
(for-each
|
|
(fn (c) (dom-append child-frag (render-to-dom c env ns)))
|
|
children)
|
|
(env-bind! local "children" child-frag)))
|
|
(let
|
|
((container (dom-create-element "span" nil)) (disposers (list)))
|
|
(begin
|
|
(dom-set-attr container "data-sx-island" island-name)
|
|
(when
|
|
(not (empty-dict? kwargs))
|
|
(dom-set-attr container "data-sx-state" (sx-serialize kwargs))))
|
|
(mark-processed! container "island-hydrated")
|
|
(let
|
|
((body-dom (with-island-scope (fn (disposable) (append! disposers disposable)) (fn () (render-to-dom (component-body island) local ns)))))
|
|
(dom-append container body-dom)
|
|
(dom-set-data container "sx-disposers" disposers)
|
|
container))))))
|
|
|
|
(define
|
|
render-dom-lake
|
|
:effects (render)
|
|
(fn
|
|
((args :as list) (env :as dict) (ns :as string))
|
|
(let
|
|
((lake-id nil) (lake-tag "div") (children (list)))
|
|
(reduce
|
|
(fn
|
|
(state arg)
|
|
(let
|
|
((skip (get state "skip")))
|
|
(if
|
|
skip
|
|
(assoc state "skip" false "i" (inc (get state "i")))
|
|
(if
|
|
(and
|
|
(= (type-of arg) "keyword")
|
|
(< (inc (get state "i")) (len args)))
|
|
(let
|
|
((kname (keyword-name arg))
|
|
(kval
|
|
(trampoline
|
|
(eval-expr (nth args (inc (get state "i"))) env))))
|
|
(cond
|
|
(= kname "id")
|
|
(set! lake-id kval)
|
|
(= kname "tag")
|
|
(set! lake-tag kval))
|
|
(assoc state "skip" true "i" (inc (get state "i"))))
|
|
(do
|
|
(append! children arg)
|
|
(assoc state "i" (inc (get state "i"))))))))
|
|
(dict "i" 0 "skip" false)
|
|
args)
|
|
(let
|
|
((el (dom-create-element lake-tag nil)))
|
|
(dom-set-attr el "data-sx-lake" (or lake-id ""))
|
|
(for-each
|
|
(fn (c) (dom-append el (render-to-dom c env ns)))
|
|
children)
|
|
el))))
|
|
|
|
(define
|
|
render-dom-marsh
|
|
:effects (render)
|
|
(fn
|
|
((args :as list) (env :as dict) (ns :as string))
|
|
(let
|
|
((marsh-id nil)
|
|
(marsh-tag "div")
|
|
(marsh-transform nil)
|
|
(children (list)))
|
|
(reduce
|
|
(fn
|
|
(state arg)
|
|
(let
|
|
((skip (get state "skip")))
|
|
(if
|
|
skip
|
|
(assoc state "skip" false "i" (inc (get state "i")))
|
|
(if
|
|
(and
|
|
(= (type-of arg) "keyword")
|
|
(< (inc (get state "i")) (len args)))
|
|
(let
|
|
((kname (keyword-name arg))
|
|
(kval
|
|
(trampoline
|
|
(eval-expr (nth args (inc (get state "i"))) env))))
|
|
(cond
|
|
(= kname "id")
|
|
(set! marsh-id kval)
|
|
(= kname "tag")
|
|
(set! marsh-tag kval)
|
|
(= kname "transform")
|
|
(set! marsh-transform kval))
|
|
(assoc state "skip" true "i" (inc (get state "i"))))
|
|
(do
|
|
(append! children arg)
|
|
(assoc state "i" (inc (get state "i"))))))))
|
|
(dict "i" 0 "skip" false)
|
|
args)
|
|
(let
|
|
((el (dom-create-element marsh-tag nil)))
|
|
(dom-set-attr el "data-sx-marsh" (or marsh-id ""))
|
|
(when
|
|
marsh-transform
|
|
(dom-set-data el "sx-marsh-transform" marsh-transform))
|
|
(dom-set-data el "sx-marsh-env" env)
|
|
(for-each
|
|
(fn (c) (dom-append el (render-to-dom c env ns)))
|
|
children)
|
|
el))))
|
|
|
|
(define
|
|
reactive-text
|
|
:effects (render mutation)
|
|
(fn
|
|
(sig)
|
|
(let
|
|
((node (create-text-node (str (deref sig)))))
|
|
(effect (fn () (dom-set-text-content node (str (deref sig)))))
|
|
node)))
|
|
|
|
(define
|
|
reactive-attr
|
|
:effects (render mutation)
|
|
(fn
|
|
(el (attr-name :as string) (compute-fn :as lambda))
|
|
(let
|
|
((existing (or (dom-get-attr el "data-sx-reactive-attrs") ""))
|
|
(updated
|
|
(if (empty? existing) attr-name (str existing "," attr-name))))
|
|
(dom-set-attr el "data-sx-reactive-attrs" updated))
|
|
(effect
|
|
(fn
|
|
()
|
|
(let
|
|
((raw (compute-fn)))
|
|
(let
|
|
((val (if (signal? raw) (deref raw) raw)))
|
|
(cond
|
|
(or (nil? val) (= val false))
|
|
(dom-remove-attr el attr-name)
|
|
(= val true)
|
|
(dom-set-attr el attr-name "")
|
|
:else (dom-set-attr el attr-name (str val)))))))))
|
|
|
|
(define
|
|
reactive-spread
|
|
:effects (render mutation)
|
|
(fn
|
|
(el (render-fn :as lambda))
|
|
(let
|
|
((prev-classes (list)) (prev-extra-keys (list)))
|
|
(let
|
|
((existing (or (dom-get-attr el "data-sx-reactive-attrs") "")))
|
|
(dom-set-attr
|
|
el
|
|
"data-sx-reactive-attrs"
|
|
(if (empty? existing) "_spread" (str existing ",_spread"))))
|
|
(effect
|
|
(fn
|
|
()
|
|
(when
|
|
(not (empty? prev-classes))
|
|
(let
|
|
((current (or (dom-get-attr el "class") ""))
|
|
(tokens
|
|
(filter (fn (c) (not (= c ""))) (split current " ")))
|
|
(kept
|
|
(filter
|
|
(fn (c) (not (some (fn (pc) (= pc c)) prev-classes)))
|
|
tokens)))
|
|
(if
|
|
(empty? kept)
|
|
(dom-remove-attr el "class")
|
|
(dom-set-attr el "class" (join " " kept)))))
|
|
(for-each (fn (k) (dom-remove-attr el k)) prev-extra-keys)
|
|
(let
|
|
((result (render-fn)))
|
|
(if
|
|
(spread? result)
|
|
(let
|
|
((attrs (spread-attrs result))
|
|
(cls-str (or (dict-get attrs "class") ""))
|
|
(new-classes
|
|
(filter (fn (c) (not (= c ""))) (split cls-str " ")))
|
|
(extra-keys
|
|
(filter (fn (k) (not (= k "class"))) (keys attrs))))
|
|
(set! prev-classes new-classes)
|
|
(set! prev-extra-keys extra-keys)
|
|
(when
|
|
(not (empty? new-classes))
|
|
(let
|
|
((current (or (dom-get-attr el "class") "")))
|
|
(dom-set-attr
|
|
el
|
|
"class"
|
|
(if
|
|
(and current (not (= current "")))
|
|
(str current " " cls-str)
|
|
cls-str))))
|
|
(for-each
|
|
(fn (k) (dom-set-attr el k (str (dict-get attrs k))))
|
|
extra-keys)
|
|
(run-post-render-hooks))
|
|
(do (set! prev-classes (list)) (set! prev-extra-keys (list))))))))))
|
|
|
|
(define
|
|
reactive-fragment
|
|
:effects (render mutation)
|
|
(fn
|
|
((test-fn :as lambda)
|
|
(render-fn :as lambda)
|
|
(env :as dict)
|
|
(ns :as string))
|
|
(let
|
|
((marker (create-comment "island-fragment")) (current-nodes (list)))
|
|
(effect
|
|
(fn
|
|
()
|
|
(for-each (fn (n) (dom-remove n)) current-nodes)
|
|
(set! current-nodes (list))
|
|
(when
|
|
(test-fn)
|
|
(let
|
|
((frag (render-fn)))
|
|
(set! current-nodes (dom-child-nodes frag))
|
|
(dom-insert-after marker frag)))))
|
|
marker)))
|
|
|
|
(define
|
|
render-list-item
|
|
:effects (render)
|
|
(fn
|
|
((map-fn :as lambda) item (env :as dict) (ns :as string))
|
|
(if
|
|
(lambda? map-fn)
|
|
(render-lambda-dom map-fn (list item) env ns)
|
|
(render-to-dom (apply map-fn (list item)) env ns))))
|
|
|
|
(define
|
|
extract-key
|
|
:effects (render)
|
|
(fn
|
|
(node (index :as number))
|
|
(let
|
|
((k (dom-get-attr node "key")))
|
|
(if
|
|
k
|
|
(do (dom-remove-attr node "key") k)
|
|
(let
|
|
((dk (dom-get-data node "key")))
|
|
(if dk (str dk) (str "__idx_" index)))))))
|
|
|
|
(define
|
|
reactive-list
|
|
:effects (render mutation)
|
|
(fn
|
|
((map-fn :as lambda)
|
|
(items-sig :as signal)
|
|
(env :as dict)
|
|
(ns :as string))
|
|
(let
|
|
((container (create-fragment))
|
|
(marker (create-comment "island-list"))
|
|
(key-map (dict))
|
|
(key-order (list)))
|
|
(dom-append container marker)
|
|
(effect
|
|
(fn
|
|
()
|
|
(let
|
|
((items (deref items-sig)))
|
|
(if
|
|
(dom-parent marker)
|
|
(let
|
|
((new-map (dict)) (new-keys (list)) (has-keys false))
|
|
(for-each-indexed
|
|
(fn
|
|
(idx item)
|
|
(let
|
|
((rendered (render-list-item map-fn item env ns))
|
|
(key (extract-key rendered idx)))
|
|
(when
|
|
(and
|
|
(not has-keys)
|
|
(not (starts-with? key "__idx_")))
|
|
(set! has-keys true))
|
|
(if
|
|
(dict-has? key-map key)
|
|
(dict-set! new-map key (dict-get key-map key))
|
|
(dict-set! new-map key rendered))
|
|
(append! new-keys key)))
|
|
items)
|
|
(if
|
|
(not has-keys)
|
|
(do
|
|
(dom-remove-children-after marker)
|
|
(let
|
|
((frag (create-fragment)))
|
|
(for-each
|
|
(fn (k) (dom-append frag (dict-get new-map k)))
|
|
new-keys)
|
|
(dom-insert-after marker frag)))
|
|
(do
|
|
(for-each
|
|
(fn
|
|
(old-key)
|
|
(when
|
|
(not (dict-has? new-map old-key))
|
|
(dom-remove (dict-get key-map old-key))))
|
|
key-order)
|
|
(let
|
|
((cursor marker))
|
|
(for-each
|
|
(fn
|
|
(k)
|
|
(let
|
|
((node (dict-get new-map k))
|
|
(next (dom-next-sibling cursor)))
|
|
(when
|
|
(not (identical? node next))
|
|
(dom-insert-after cursor node))
|
|
(set! cursor node)))
|
|
new-keys))))
|
|
(set! key-map new-map)
|
|
(set! key-order new-keys))
|
|
(for-each-indexed
|
|
(fn
|
|
(idx item)
|
|
(let
|
|
((rendered (render-list-item map-fn item env ns))
|
|
(key (extract-key rendered idx)))
|
|
(dict-set! key-map key rendered)
|
|
(append! key-order key)
|
|
(dom-append container rendered)))
|
|
items)))))
|
|
container)))
|
|
|
|
(define
|
|
bind-input
|
|
:effects (render mutation)
|
|
(fn
|
|
(el (sig :as signal))
|
|
(let
|
|
((input-type (lower (or (dom-get-attr el "type") "")))
|
|
(is-checkbox (or (= input-type "checkbox") (= input-type "radio"))))
|
|
(if
|
|
is-checkbox
|
|
(dom-set-prop el "checked" (deref sig))
|
|
(dom-set-prop el "value" (str (deref sig))))
|
|
(effect
|
|
(fn
|
|
()
|
|
(if
|
|
is-checkbox
|
|
(dom-set-prop el "checked" (deref sig))
|
|
(let
|
|
((v (str (deref sig))))
|
|
(when
|
|
(!= (dom-get-prop el "value") v)
|
|
(dom-set-prop el "value" v))))))
|
|
(dom-on
|
|
el
|
|
(if is-checkbox "change" "input")
|
|
(fn
|
|
(e)
|
|
(if
|
|
is-checkbox
|
|
(reset! sig (dom-get-prop el "checked"))
|
|
(reset! sig (dom-get-prop el "value"))))))))
|
|
|
|
(define *use-cek-reactive* true)
|
|
|
|
(define enable-cek-reactive! (fn () (set! *use-cek-reactive* true)))
|
|
|
|
(define
|
|
cek-reactive-text
|
|
:effects (render mutation)
|
|
(fn
|
|
(expr env)
|
|
(let
|
|
((node (create-text-node ""))
|
|
(update-fn (fn (val) (dom-set-text-content node (str val)))))
|
|
(let
|
|
((initial (cek-run (make-cek-state expr env (list (make-reactive-reset-frame env update-fn true))))))
|
|
(dom-set-text-content node (str initial))
|
|
node))))
|
|
|
|
(define
|
|
cek-reactive-attr
|
|
:effects (render mutation)
|
|
(fn
|
|
(el attr-name expr env)
|
|
(let
|
|
((update-fn (fn (val) (cond (or (nil? val) (= val false)) (dom-remove-attr el attr-name) (= val true) (dom-set-attr el attr-name "") :else (dom-set-attr el attr-name (str val))))))
|
|
(let
|
|
((existing (or (dom-get-attr el "data-sx-reactive-attrs") ""))
|
|
(updated
|
|
(if (empty? existing) attr-name (str existing "," attr-name))))
|
|
(dom-set-attr el "data-sx-reactive-attrs" updated))
|
|
(let
|
|
((initial (cek-run (make-cek-state expr env (list (make-reactive-reset-frame env update-fn true))))))
|
|
(cek-call update-fn (list initial))))))
|
|
|
|
(define
|
|
render-dom-portal
|
|
:effects (render)
|
|
(fn
|
|
((args :as list) (env :as dict) (ns :as string))
|
|
(let
|
|
((selector (trampoline (eval-expr (first args) env)))
|
|
(target (or (dom-query selector) (dom-ensure-element selector))))
|
|
(if
|
|
(not target)
|
|
(create-comment (str "portal: " selector " (not found)"))
|
|
(let
|
|
((marker (create-comment (str "portal: " selector)))
|
|
(frag (create-fragment)))
|
|
(for-each
|
|
(fn (child) (dom-append frag (render-to-dom child env ns)))
|
|
(rest args))
|
|
(let
|
|
((portal-nodes (dom-child-nodes frag)))
|
|
(dom-append target frag)
|
|
(register-in-scope
|
|
(fn () (for-each (fn (n) (dom-remove n)) portal-nodes))))
|
|
marker)))))
|
|
|
|
(define
|
|
render-dom-error-boundary
|
|
:effects (render)
|
|
(fn
|
|
((args :as list) (env :as dict) (ns :as string))
|
|
(let
|
|
((fallback-expr (if (> (len args) 1) (first args) nil))
|
|
(body-exprs (if (> (len args) 1) (rest args) args))
|
|
(container (dom-create-element "div" nil))
|
|
(retry-version (signal 0)))
|
|
(dom-set-attr container "data-sx-boundary" "true")
|
|
(effect
|
|
(fn
|
|
()
|
|
(deref retry-version)
|
|
(dom-set-prop container "innerHTML" "")
|
|
(scope-push! "sx-island-scope" nil)
|
|
(try-catch
|
|
(fn
|
|
()
|
|
(let
|
|
((frag (create-fragment)))
|
|
(for-each
|
|
(fn
|
|
(child)
|
|
(dom-append frag (render-to-dom child env ns)))
|
|
body-exprs)
|
|
(dom-append container frag))
|
|
(scope-pop! "sx-island-scope"))
|
|
(fn
|
|
(err)
|
|
(scope-pop! "sx-island-scope")
|
|
(let
|
|
((fallback-fn (trampoline (eval-expr fallback-expr env)))
|
|
(retry-fn
|
|
(fn () (swap! retry-version (fn (n) (+ n 1))))))
|
|
(let
|
|
((fallback-dom (if (nil? fallback-fn) (let ((el (dom-create-element "div" nil))) (dom-set-attr el "class" "sx-render-error") (dom-set-attr el "style" "color:red;font-size:0.875rem;padding:0.5rem;border:1px solid red;border-radius:0.25rem;margin:0.5rem 0;") (dom-set-text-content el (str "Render error: " err)) el) (if (lambda? fallback-fn) (render-lambda-dom fallback-fn (list err retry-fn) env ns) (render-to-dom (apply fallback-fn (list err retry-fn)) env ns)))))
|
|
(dom-append container fallback-dom)))))))
|
|
container)))
|
|
|
|
|
|
))
|
|
|
|
;; Re-export to global env
|
|
(import (web adapter-dom))
|