Phase 5-7: Clean up duplicates, verify end-to-end
All checks were successful
Build and Deploy / build-and-deploy (push) Successful in 1m50s
All checks were successful
Build and Deploy / build-and-deploy (push) Successful in 1m50s
Remove all duplicate .sx files from shared/sx/ref/ — originals now in spec/, web/, hosts/. Only generated runtime (sx_ref.py), async shim, and theorem prover tools remain in shared/sx/ref/. Final structure: spec/ 10 .sx files (core language) spec/tests/ 8 .sx files (core tests) web/ 10 .sx files (web framework) web/tests/ 7 .sx files (web tests) hosts/python/ bootstrapper + platform + 5 test runners hosts/javascript/ bootstrapper + CLI + platform shared/sx/ref/ generated runtime only All 89 tests pass. Both bootstrappers build fully. Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
@@ -14,7 +14,7 @@
|
|||||||
// =========================================================================
|
// =========================================================================
|
||||||
|
|
||||||
var NIL = Object.freeze({ _nil: true, toString: function() { return "nil"; } });
|
var NIL = Object.freeze({ _nil: true, toString: function() { return "nil"; } });
|
||||||
var SX_VERSION = "2026-03-15T02:24:46Z";
|
var SX_VERSION = "2026-03-15T02:29:18Z";
|
||||||
|
|
||||||
function isNil(x) { return x === NIL || x === null || x === undefined; }
|
function isNil(x) { return x === NIL || x === null || x === undefined; }
|
||||||
function isSxTruthy(x) { return x !== false && !isNil(x); }
|
function isSxTruthy(x) { return x !== false && !isNil(x); }
|
||||||
|
|||||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@@ -1,545 +0,0 @@
|
|||||||
;; ==========================================================================
|
|
||||||
;; adapter-html.sx — HTML string rendering adapter
|
|
||||||
;;
|
|
||||||
;; Renders evaluated SX expressions to HTML strings. Used server-side.
|
|
||||||
;;
|
|
||||||
;; Depends on:
|
|
||||||
;; render.sx — HTML_TAGS, VOID_ELEMENTS, BOOLEAN_ATTRS,
|
|
||||||
;; parse-element-args, render-attrs, definition-form?
|
|
||||||
;; eval.sx — eval-expr, trampoline, expand-macro, process-bindings,
|
|
||||||
;; eval-cond, env-has?, env-get, env-set!, env-merge,
|
|
||||||
;; lambda?, component?, island?, macro?,
|
|
||||||
;; lambda-closure, lambda-params, lambda-body
|
|
||||||
;; ==========================================================================
|
|
||||||
|
|
||||||
|
|
||||||
(define render-to-html :effects [render]
|
|
||||||
(fn (expr (env :as dict))
|
|
||||||
(set-render-active! true)
|
|
||||||
(case (type-of expr)
|
|
||||||
;; Literals — render directly
|
|
||||||
"nil" ""
|
|
||||||
"string" (escape-html expr)
|
|
||||||
"number" (str expr)
|
|
||||||
"boolean" (if expr "true" "false")
|
|
||||||
;; List — dispatch to render-list which handles HTML tags, special forms, etc.
|
|
||||||
"list" (if (empty? expr) "" (render-list-to-html expr env))
|
|
||||||
;; Symbol — evaluate then render
|
|
||||||
"symbol" (render-value-to-html (trampoline (eval-expr expr env)) env)
|
|
||||||
;; Keyword — render as text
|
|
||||||
"keyword" (escape-html (keyword-name expr))
|
|
||||||
;; Raw HTML passthrough
|
|
||||||
"raw-html" (raw-html-content expr)
|
|
||||||
;; Spread — emit attrs to nearest element provider
|
|
||||||
"spread" (do (emit! "element-attrs" (spread-attrs expr)) "")
|
|
||||||
;; Everything else — evaluate first
|
|
||||||
:else (render-value-to-html (trampoline (eval-expr expr env)) env))))
|
|
||||||
|
|
||||||
(define render-value-to-html :effects [render]
|
|
||||||
(fn (val (env :as dict))
|
|
||||||
(case (type-of val)
|
|
||||||
"nil" ""
|
|
||||||
"string" (escape-html val)
|
|
||||||
"number" (str val)
|
|
||||||
"boolean" (if val "true" "false")
|
|
||||||
"list" (render-list-to-html val env)
|
|
||||||
"raw-html" (raw-html-content val)
|
|
||||||
"spread" (do (emit! "element-attrs" (spread-attrs val)) "")
|
|
||||||
:else (escape-html (str val)))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Render-aware form classification
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define RENDER_HTML_FORMS
|
|
||||||
(list "if" "when" "cond" "case" "let" "let*" "begin" "do"
|
|
||||||
"define" "defcomp" "defisland" "defmacro" "defstyle" "defhandler"
|
|
||||||
"deftype" "defeffect"
|
|
||||||
"map" "map-indexed" "filter" "for-each" "scope" "provide"))
|
|
||||||
|
|
||||||
(define render-html-form? :effects []
|
|
||||||
(fn ((name :as string))
|
|
||||||
(contains? RENDER_HTML_FORMS name)))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; render-list-to-html — dispatch on list head
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define render-list-to-html :effects [render]
|
|
||||||
(fn ((expr :as list) (env :as dict))
|
|
||||||
(if (empty? expr)
|
|
||||||
""
|
|
||||||
(let ((head (first expr)))
|
|
||||||
(if (not (= (type-of head) "symbol"))
|
|
||||||
;; Data list — render each item
|
|
||||||
(join "" (map (fn (x) (render-value-to-html x env)) expr))
|
|
||||||
(let ((name (symbol-name head))
|
|
||||||
(args (rest expr)))
|
|
||||||
(cond
|
|
||||||
;; Fragment
|
|
||||||
(= name "<>")
|
|
||||||
(join "" (map (fn (x) (render-to-html x env)) args))
|
|
||||||
|
|
||||||
;; Raw HTML passthrough
|
|
||||||
(= name "raw!")
|
|
||||||
(join "" (map (fn (x) (str (trampoline (eval-expr x env)))) args))
|
|
||||||
|
|
||||||
;; Lake — server-morphable slot within an island
|
|
||||||
(= name "lake")
|
|
||||||
(render-html-lake args env)
|
|
||||||
|
|
||||||
;; Marsh — reactive server-morphable slot within an island
|
|
||||||
(= name "marsh")
|
|
||||||
(render-html-marsh args env)
|
|
||||||
|
|
||||||
;; HTML tag
|
|
||||||
(contains? HTML_TAGS name)
|
|
||||||
(render-html-element name args env)
|
|
||||||
|
|
||||||
;; Island (~name) — reactive component, SSR with hydration markers
|
|
||||||
(and (starts-with? name "~")
|
|
||||||
(env-has? env name)
|
|
||||||
(island? (env-get env name)))
|
|
||||||
(render-html-island (env-get env name) args env)
|
|
||||||
|
|
||||||
;; Component or macro call (~name)
|
|
||||||
(starts-with? name "~")
|
|
||||||
(let ((val (env-get env name)))
|
|
||||||
(cond
|
|
||||||
(component? val)
|
|
||||||
(render-html-component val args env)
|
|
||||||
(macro? val)
|
|
||||||
(render-to-html
|
|
||||||
(expand-macro val args env)
|
|
||||||
env)
|
|
||||||
:else
|
|
||||||
(error (str "Unknown component: " name))))
|
|
||||||
|
|
||||||
;; Render-aware special forms
|
|
||||||
(render-html-form? name)
|
|
||||||
(dispatch-html-form name expr env)
|
|
||||||
|
|
||||||
;; Macro expansion
|
|
||||||
(and (env-has? env name) (macro? (env-get env name)))
|
|
||||||
(render-to-html
|
|
||||||
(expand-macro (env-get env name) args env)
|
|
||||||
env)
|
|
||||||
|
|
||||||
;; Fallback — evaluate then render result
|
|
||||||
:else
|
|
||||||
(render-value-to-html
|
|
||||||
(trampoline (eval-expr expr env))
|
|
||||||
env))))))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; dispatch-html-form — render-aware special form handling for HTML output
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define dispatch-html-form :effects [render]
|
|
||||||
(fn ((name :as string) (expr :as list) (env :as dict))
|
|
||||||
(cond
|
|
||||||
;; if
|
|
||||||
(= name "if")
|
|
||||||
(let ((cond-val (trampoline (eval-expr (nth expr 1) env))))
|
|
||||||
(if cond-val
|
|
||||||
(render-to-html (nth expr 2) env)
|
|
||||||
(if (> (len expr) 3)
|
|
||||||
(render-to-html (nth expr 3) env)
|
|
||||||
"")))
|
|
||||||
|
|
||||||
;; when — single body: pass through. Multi: join strings.
|
|
||||||
(= name "when")
|
|
||||||
(if (not (trampoline (eval-expr (nth expr 1) env)))
|
|
||||||
""
|
|
||||||
(if (= (len expr) 3)
|
|
||||||
(render-to-html (nth expr 2) env)
|
|
||||||
(join "" (map (fn (i) (render-to-html (nth expr i) env))
|
|
||||||
(range 2 (len expr))))))
|
|
||||||
|
|
||||||
;; cond
|
|
||||||
(= name "cond")
|
|
||||||
(let ((branch (eval-cond (rest expr) env)))
|
|
||||||
(if branch
|
|
||||||
(render-to-html branch env)
|
|
||||||
""))
|
|
||||||
|
|
||||||
;; case
|
|
||||||
(= name "case")
|
|
||||||
(render-to-html (trampoline (eval-expr expr env)) env)
|
|
||||||
|
|
||||||
;; let / let* — single body: pass through. Multi: join strings.
|
|
||||||
(or (= name "let") (= name "let*"))
|
|
||||||
(let ((local (process-bindings (nth expr 1) env)))
|
|
||||||
(if (= (len expr) 3)
|
|
||||||
(render-to-html (nth expr 2) local)
|
|
||||||
(join "" (map (fn (i) (render-to-html (nth expr i) local))
|
|
||||||
(range 2 (len expr))))))
|
|
||||||
|
|
||||||
;; begin / do — single body: pass through. Multi: join strings.
|
|
||||||
(or (= name "begin") (= name "do"))
|
|
||||||
(if (= (len expr) 2)
|
|
||||||
(render-to-html (nth expr 1) env)
|
|
||||||
(join "" (map (fn (i) (render-to-html (nth expr i) env))
|
|
||||||
(range 1 (len expr)))))
|
|
||||||
|
|
||||||
;; Definition forms — eval for side effects
|
|
||||||
(definition-form? name)
|
|
||||||
(do (trampoline (eval-expr expr env)) "")
|
|
||||||
|
|
||||||
;; map
|
|
||||||
(= name "map")
|
|
||||||
(let ((f (trampoline (eval-expr (nth expr 1) env)))
|
|
||||||
(coll (trampoline (eval-expr (nth expr 2) env))))
|
|
||||||
(join ""
|
|
||||||
(map
|
|
||||||
(fn (item)
|
|
||||||
(if (lambda? f)
|
|
||||||
(render-lambda-html f (list item) env)
|
|
||||||
(render-to-html (apply f (list item)) env)))
|
|
||||||
coll)))
|
|
||||||
|
|
||||||
;; map-indexed
|
|
||||||
(= name "map-indexed")
|
|
||||||
(let ((f (trampoline (eval-expr (nth expr 1) env)))
|
|
||||||
(coll (trampoline (eval-expr (nth expr 2) env))))
|
|
||||||
(join ""
|
|
||||||
(map-indexed
|
|
||||||
(fn (i item)
|
|
||||||
(if (lambda? f)
|
|
||||||
(render-lambda-html f (list i item) env)
|
|
||||||
(render-to-html (apply f (list i item)) env)))
|
|
||||||
coll)))
|
|
||||||
|
|
||||||
;; filter — evaluate fully then render
|
|
||||||
(= name "filter")
|
|
||||||
(render-to-html (trampoline (eval-expr expr env)) env)
|
|
||||||
|
|
||||||
;; for-each (render variant)
|
|
||||||
(= name "for-each")
|
|
||||||
(let ((f (trampoline (eval-expr (nth expr 1) env)))
|
|
||||||
(coll (trampoline (eval-expr (nth expr 2) env))))
|
|
||||||
(join ""
|
|
||||||
(map
|
|
||||||
(fn (item)
|
|
||||||
(if (lambda? f)
|
|
||||||
(render-lambda-html f (list item) env)
|
|
||||||
(render-to-html (apply f (list item)) env)))
|
|
||||||
coll)))
|
|
||||||
|
|
||||||
;; scope — unified render-time dynamic scope
|
|
||||||
(= name "scope")
|
|
||||||
(let ((scope-name (trampoline (eval-expr (nth expr 1) env)))
|
|
||||||
(rest-args (slice expr 2))
|
|
||||||
(scope-val nil)
|
|
||||||
(body-exprs nil))
|
|
||||||
;; Check for :value keyword
|
|
||||||
(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)
|
|
||||||
(let ((result (if (= (len body-exprs) 1)
|
|
||||||
(render-to-html (first body-exprs) env)
|
|
||||||
(join "" (map (fn (e) (render-to-html e env)) body-exprs)))))
|
|
||||||
(scope-pop! scope-name)
|
|
||||||
result))
|
|
||||||
|
|
||||||
;; provide — sugar for scope with value
|
|
||||||
(= name "provide")
|
|
||||||
(let ((prov-name (trampoline (eval-expr (nth expr 1) env)))
|
|
||||||
(prov-val (trampoline (eval-expr (nth expr 2) env)))
|
|
||||||
(body-start 3)
|
|
||||||
(body-count (- (len expr) 3)))
|
|
||||||
(scope-push! prov-name prov-val)
|
|
||||||
(let ((result (if (= body-count 1)
|
|
||||||
(render-to-html (nth expr body-start) env)
|
|
||||||
(join "" (map (fn (i) (render-to-html (nth expr i) env))
|
|
||||||
(range body-start (+ body-start body-count)))))))
|
|
||||||
(scope-pop! prov-name)
|
|
||||||
result))
|
|
||||||
|
|
||||||
;; Fallback
|
|
||||||
:else
|
|
||||||
(render-value-to-html (trampoline (eval-expr expr env)) env))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; render-lambda-html — render a lambda body in HTML context
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define render-lambda-html :effects [render]
|
|
||||||
(fn ((f :as lambda) (args :as list) (env :as dict))
|
|
||||||
(let ((local (env-merge (lambda-closure f) env)))
|
|
||||||
(for-each-indexed
|
|
||||||
(fn (i p)
|
|
||||||
(env-set! local p (nth args i)))
|
|
||||||
(lambda-params f))
|
|
||||||
(render-to-html (lambda-body f) local))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; render-html-component — expand and render a component
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define render-html-component :effects [render]
|
|
||||||
(fn ((comp :as component) (args :as list) (env :as dict))
|
|
||||||
;; Expand component and render body through HTML adapter.
|
|
||||||
;; Component body contains rendering forms (HTML tags) that only the
|
|
||||||
;; adapter understands, so expansion must happen here, not in eval-expr.
|
|
||||||
(let ((kwargs (dict))
|
|
||||||
(children (list)))
|
|
||||||
;; Separate keyword args from positional children
|
|
||||||
(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)
|
|
||||||
;; Build component env: closure + caller env + params
|
|
||||||
(let ((local (env-merge (component-closure comp) env)))
|
|
||||||
;; Bind params from kwargs
|
|
||||||
(for-each
|
|
||||||
(fn (p)
|
|
||||||
(env-set! local p (if (dict-has? kwargs p) (dict-get kwargs p) nil)))
|
|
||||||
(component-params comp))
|
|
||||||
;; If component accepts children, pre-render them to raw HTML
|
|
||||||
(when (component-has-children? comp)
|
|
||||||
(env-set! local "children"
|
|
||||||
(make-raw-html (join "" (map (fn (c) (render-to-html c env)) children)))))
|
|
||||||
(render-to-html (component-body comp) local)))))
|
|
||||||
|
|
||||||
|
|
||||||
(define render-html-element :effects [render]
|
|
||||||
(fn ((tag :as string) (args :as list) (env :as dict))
|
|
||||||
(let ((parsed (parse-element-args args env))
|
|
||||||
(attrs (first parsed))
|
|
||||||
(children (nth parsed 1))
|
|
||||||
(is-void (contains? VOID_ELEMENTS tag)))
|
|
||||||
(if is-void
|
|
||||||
(str "<" tag (render-attrs attrs) " />")
|
|
||||||
;; Provide scope for spread emit!
|
|
||||||
(do
|
|
||||||
(scope-push! "element-attrs" nil)
|
|
||||||
(let ((content (join "" (map (fn (c) (render-to-html c env)) children))))
|
|
||||||
(for-each
|
|
||||||
(fn (spread-dict) (merge-spread-attrs attrs spread-dict))
|
|
||||||
(emitted "element-attrs"))
|
|
||||||
(scope-pop! "element-attrs")
|
|
||||||
(str "<" tag (render-attrs attrs) ">"
|
|
||||||
content
|
|
||||||
"</" tag ">")))))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; render-html-lake — SSR rendering of a server-morphable slot
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;;
|
|
||||||
;; (lake :id "name" children...) → <div data-sx-lake="name">children</div>
|
|
||||||
;;
|
|
||||||
;; Lakes are server territory inside islands. The morph can update lake
|
|
||||||
;; content while preserving surrounding reactive DOM.
|
|
||||||
|
|
||||||
(define render-html-lake :effects [render]
|
|
||||||
(fn ((args :as list) (env :as dict))
|
|
||||||
(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)
|
|
||||||
;; Provide scope for spread emit!
|
|
||||||
(let ((lake-attrs (dict "data-sx-lake" (or lake-id ""))))
|
|
||||||
(scope-push! "element-attrs" nil)
|
|
||||||
(let ((content (join "" (map (fn (c) (render-to-html c env)) children))))
|
|
||||||
(for-each
|
|
||||||
(fn (spread-dict) (merge-spread-attrs lake-attrs spread-dict))
|
|
||||||
(emitted "element-attrs"))
|
|
||||||
(scope-pop! "element-attrs")
|
|
||||||
(str "<" lake-tag (render-attrs lake-attrs) ">"
|
|
||||||
content
|
|
||||||
"</" lake-tag ">"))))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; render-html-marsh — SSR rendering of a reactive server-morphable slot
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;;
|
|
||||||
;; (marsh :id "name" :tag "div" :transform fn children...)
|
|
||||||
;; → <div data-sx-marsh="name">children</div>
|
|
||||||
;;
|
|
||||||
;; Like a lake but reactive: during morph, new content is parsed as SX and
|
|
||||||
;; re-evaluated in the island's signal scope. Server renders children normally;
|
|
||||||
;; the :transform is a client-only concern.
|
|
||||||
|
|
||||||
(define render-html-marsh :effects [render]
|
|
||||||
(fn ((args :as list) (env :as dict))
|
|
||||||
(let ((marsh-id nil)
|
|
||||||
(marsh-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! marsh-id kval)
|
|
||||||
(= kname "tag") (set! marsh-tag kval)
|
|
||||||
(= kname "transform") nil)
|
|
||||||
(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)
|
|
||||||
;; Provide scope for spread emit!
|
|
||||||
(let ((marsh-attrs (dict "data-sx-marsh" (or marsh-id ""))))
|
|
||||||
(scope-push! "element-attrs" nil)
|
|
||||||
(let ((content (join "" (map (fn (c) (render-to-html c env)) children))))
|
|
||||||
(for-each
|
|
||||||
(fn (spread-dict) (merge-spread-attrs marsh-attrs spread-dict))
|
|
||||||
(emitted "element-attrs"))
|
|
||||||
(scope-pop! "element-attrs")
|
|
||||||
(str "<" marsh-tag (render-attrs marsh-attrs) ">"
|
|
||||||
content
|
|
||||||
"</" marsh-tag ">"))))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; render-html-island — SSR rendering of a reactive island
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;;
|
|
||||||
;; Renders the island body as static HTML wrapped in a container element
|
|
||||||
;; with data-sx-island and data-sx-state attributes. The client hydrates
|
|
||||||
;; this by finding these elements and re-rendering with reactive context.
|
|
||||||
;;
|
|
||||||
;; On the server, signal/deref/reset!/swap! are simple passthrough:
|
|
||||||
;; (signal val) → returns val (no container needed server-side)
|
|
||||||
;; (deref s) → returns s (signal values are plain values server-side)
|
|
||||||
;; (reset! s v) → no-op
|
|
||||||
;; (swap! s f) → no-op
|
|
||||||
|
|
||||||
(define render-html-island :effects [render]
|
|
||||||
(fn ((island :as island) (args :as list) (env :as dict))
|
|
||||||
;; Parse kwargs and children (same pattern as render-html-component)
|
|
||||||
(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)
|
|
||||||
|
|
||||||
;; Build island env: closure + caller env + params
|
|
||||||
(let ((local (env-merge (component-closure island) env))
|
|
||||||
(island-name (component-name island)))
|
|
||||||
|
|
||||||
;; Bind params from kwargs
|
|
||||||
(for-each
|
|
||||||
(fn (p)
|
|
||||||
(env-set! local p (if (dict-has? kwargs p) (dict-get kwargs p) nil)))
|
|
||||||
(component-params island))
|
|
||||||
|
|
||||||
;; If island accepts children, pre-render them to raw HTML
|
|
||||||
(when (component-has-children? island)
|
|
||||||
(env-set! local "children"
|
|
||||||
(make-raw-html (join "" (map (fn (c) (render-to-html c env)) children)))))
|
|
||||||
|
|
||||||
;; Render the island body as HTML
|
|
||||||
(let ((body-html (render-to-html (component-body island) local))
|
|
||||||
(state-sx (serialize-island-state kwargs)))
|
|
||||||
;; Wrap in container with hydration attributes
|
|
||||||
(str "<span data-sx-island=\"" (escape-attr island-name) "\""
|
|
||||||
(if state-sx
|
|
||||||
(str " data-sx-state=\"" (escape-attr state-sx) "\"")
|
|
||||||
"")
|
|
||||||
">"
|
|
||||||
body-html
|
|
||||||
"</span>"))))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; serialize-island-state — serialize kwargs to SX for hydration
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;;
|
|
||||||
;; Uses the SX serializer (not JSON) so the client can parse with sx-parse.
|
|
||||||
;; Handles all SX types natively: numbers, strings, booleans, nil, lists, dicts.
|
|
||||||
|
|
||||||
(define serialize-island-state :effects []
|
|
||||||
(fn ((kwargs :as dict))
|
|
||||||
(if (empty-dict? kwargs)
|
|
||||||
nil
|
|
||||||
(sx-serialize kwargs))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Platform interface — HTML adapter
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;;
|
|
||||||
;; Inherited from render.sx:
|
|
||||||
;; escape-html, escape-attr, raw-html-content
|
|
||||||
;;
|
|
||||||
;; From eval.sx:
|
|
||||||
;; eval-expr, trampoline, expand-macro, process-bindings, eval-cond
|
|
||||||
;; env-has?, env-get, env-set!, env-merge
|
|
||||||
;; lambda?, component?, island?, macro?
|
|
||||||
;; lambda-closure, lambda-params, lambda-body
|
|
||||||
;; component-params, component-body, component-closure,
|
|
||||||
;; component-has-children?, component-name
|
|
||||||
;;
|
|
||||||
;; Raw HTML construction:
|
|
||||||
;; (make-raw-html s) → wrap string as raw HTML (not double-escaped)
|
|
||||||
;;
|
|
||||||
;; Island state serialization:
|
|
||||||
;; (sx-serialize val) → SX source string (from parser.sx)
|
|
||||||
;; (empty-dict? d) → boolean
|
|
||||||
;; (escape-attr s) → HTML attribute escape
|
|
||||||
;;
|
|
||||||
;; Iteration:
|
|
||||||
;; (for-each-indexed fn coll) → call fn(index, item) for each element
|
|
||||||
;; (map-indexed fn coll) → map fn(index, item) over each element
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
@@ -1,407 +0,0 @@
|
|||||||
;; ==========================================================================
|
|
||||||
;; adapter-sx.sx — SX wire format rendering adapter
|
|
||||||
;;
|
|
||||||
;; Serializes SX expressions for client-side rendering.
|
|
||||||
;; Component calls are NOT expanded — they're sent to the client as-is.
|
|
||||||
;; HTML tags are serialized as SX source text. Special forms are evaluated.
|
|
||||||
;;
|
|
||||||
;; Depends on:
|
|
||||||
;; render.sx — HTML_TAGS
|
|
||||||
;; eval.sx — eval-expr, trampoline, call-lambda, expand-macro
|
|
||||||
;; ==========================================================================
|
|
||||||
|
|
||||||
|
|
||||||
(define render-to-sx :effects [render]
|
|
||||||
(fn (expr (env :as dict))
|
|
||||||
(let ((result (aser expr env)))
|
|
||||||
;; aser-call already returns serialized SX strings;
|
|
||||||
;; only serialize non-string values
|
|
||||||
(if (= (type-of result) "string")
|
|
||||||
result
|
|
||||||
(serialize result)))))
|
|
||||||
|
|
||||||
(define aser :effects [render]
|
|
||||||
(fn ((expr :as any) (env :as dict))
|
|
||||||
;; Evaluate for SX wire format — serialize rendering forms,
|
|
||||||
;; evaluate control flow and function calls.
|
|
||||||
(set-render-active! true)
|
|
||||||
(let ((result
|
|
||||||
(case (type-of expr)
|
|
||||||
"number" expr
|
|
||||||
"string" expr
|
|
||||||
"boolean" expr
|
|
||||||
"nil" nil
|
|
||||||
|
|
||||||
"symbol"
|
|
||||||
(let ((name (symbol-name expr)))
|
|
||||||
(cond
|
|
||||||
(env-has? env name) (env-get env name)
|
|
||||||
(primitive? name) (get-primitive name)
|
|
||||||
(= name "true") true
|
|
||||||
(= name "false") false
|
|
||||||
(= name "nil") nil
|
|
||||||
:else (error (str "Undefined symbol: " name))))
|
|
||||||
|
|
||||||
"keyword" (keyword-name expr)
|
|
||||||
|
|
||||||
"list"
|
|
||||||
(if (empty? expr)
|
|
||||||
(list)
|
|
||||||
(aser-list expr env))
|
|
||||||
|
|
||||||
;; Spread — emit attrs to nearest element provider
|
|
||||||
"spread" (do (emit! "element-attrs" (spread-attrs expr)) nil)
|
|
||||||
|
|
||||||
:else expr)))
|
|
||||||
;; Catch spread values from function calls and symbol lookups
|
|
||||||
(if (spread? result)
|
|
||||||
(do (emit! "element-attrs" (spread-attrs result)) nil)
|
|
||||||
result))))
|
|
||||||
|
|
||||||
|
|
||||||
(define aser-list :effects [render]
|
|
||||||
(fn ((expr :as list) (env :as dict))
|
|
||||||
(let ((head (first expr))
|
|
||||||
(args (rest expr)))
|
|
||||||
(if (not (= (type-of head) "symbol"))
|
|
||||||
(map (fn (x) (aser x env)) expr)
|
|
||||||
(let ((name (symbol-name head)))
|
|
||||||
(cond
|
|
||||||
;; Fragment — serialize children
|
|
||||||
(= name "<>")
|
|
||||||
(aser-fragment args env)
|
|
||||||
|
|
||||||
;; Component call — serialize WITHOUT expanding
|
|
||||||
(starts-with? name "~")
|
|
||||||
(aser-call name args env)
|
|
||||||
|
|
||||||
;; Lake — serialize (server-morphable slot)
|
|
||||||
(= name "lake")
|
|
||||||
(aser-call name args env)
|
|
||||||
|
|
||||||
;; Marsh — serialize (reactive server-morphable slot)
|
|
||||||
(= name "marsh")
|
|
||||||
(aser-call name args env)
|
|
||||||
|
|
||||||
;; HTML tag — serialize
|
|
||||||
(contains? HTML_TAGS name)
|
|
||||||
(aser-call name args env)
|
|
||||||
|
|
||||||
;; Special/HO forms — evaluate (produces data)
|
|
||||||
(or (special-form? name) (ho-form? name))
|
|
||||||
(aser-special name expr env)
|
|
||||||
|
|
||||||
;; Macro — expand then aser
|
|
||||||
(and (env-has? env name) (macro? (env-get env name)))
|
|
||||||
(aser (expand-macro (env-get env name) args env) env)
|
|
||||||
|
|
||||||
;; Function call — evaluate fully
|
|
||||||
:else
|
|
||||||
(let ((f (trampoline (eval-expr head env)))
|
|
||||||
(evaled-args (map (fn (a) (trampoline (eval-expr a env))) args)))
|
|
||||||
(cond
|
|
||||||
(and (callable? f) (not (lambda? f)) (not (component? f)) (not (island? f)))
|
|
||||||
(apply f evaled-args)
|
|
||||||
(lambda? f)
|
|
||||||
(trampoline (call-lambda f evaled-args env))
|
|
||||||
(component? f)
|
|
||||||
(aser-call (str "~" (component-name f)) args env)
|
|
||||||
(island? f)
|
|
||||||
(aser-call (str "~" (component-name f)) args env)
|
|
||||||
:else (error (str "Not callable: " (inspect f)))))))))))
|
|
||||||
|
|
||||||
|
|
||||||
(define aser-fragment :effects [render]
|
|
||||||
(fn ((children :as list) (env :as dict))
|
|
||||||
;; Serialize (<> child1 child2 ...) to sx source string
|
|
||||||
;; Must flatten list results (e.g. from map/filter) to avoid nested parens
|
|
||||||
(let ((parts (list)))
|
|
||||||
(for-each
|
|
||||||
(fn (c)
|
|
||||||
(let ((result (aser c env)))
|
|
||||||
(if (= (type-of result) "list")
|
|
||||||
(for-each
|
|
||||||
(fn (item)
|
|
||||||
(when (not (nil? item))
|
|
||||||
(append! parts (serialize item))))
|
|
||||||
result)
|
|
||||||
(when (not (nil? result))
|
|
||||||
(append! parts (serialize result))))))
|
|
||||||
children)
|
|
||||||
(if (empty? parts)
|
|
||||||
""
|
|
||||||
(str "(<> " (join " " parts) ")")))))
|
|
||||||
|
|
||||||
|
|
||||||
(define aser-call :effects [render]
|
|
||||||
(fn ((name :as string) (args :as list) (env :as dict))
|
|
||||||
;; Serialize (name :key val child ...) — evaluate args but keep as sx
|
|
||||||
;; Uses for-each + mutable state (not reduce) so bootstrapper emits for-loops
|
|
||||||
;; that can contain nested for-each for list flattening.
|
|
||||||
;; Separate attrs and children so emitted spread attrs go before children.
|
|
||||||
(let ((attr-parts (list))
|
|
||||||
(child-parts (list))
|
|
||||||
(skip false)
|
|
||||||
(i 0))
|
|
||||||
;; Provide scope for spread emit!
|
|
||||||
(scope-push! "element-attrs" nil)
|
|
||||||
(for-each
|
|
||||||
(fn (arg)
|
|
||||||
(if skip
|
|
||||||
(do (set! skip false)
|
|
||||||
(set! i (inc i)))
|
|
||||||
(if (and (= (type-of arg) "keyword")
|
|
||||||
(< (inc i) (len args)))
|
|
||||||
(let ((val (aser (nth args (inc i)) env)))
|
|
||||||
(when (not (nil? val))
|
|
||||||
(append! attr-parts (str ":" (keyword-name arg)))
|
|
||||||
(append! attr-parts (serialize val)))
|
|
||||||
(set! skip true)
|
|
||||||
(set! i (inc i)))
|
|
||||||
(let ((val (aser arg env)))
|
|
||||||
(when (not (nil? val))
|
|
||||||
(if (= (type-of val) "list")
|
|
||||||
(for-each
|
|
||||||
(fn (item)
|
|
||||||
(when (not (nil? item))
|
|
||||||
(append! child-parts (serialize item))))
|
|
||||||
val)
|
|
||||||
(append! child-parts (serialize val))))
|
|
||||||
(set! i (inc i))))))
|
|
||||||
args)
|
|
||||||
;; Collect emitted spread attrs — goes after explicit attrs, before children
|
|
||||||
(for-each
|
|
||||||
(fn (spread-dict)
|
|
||||||
(for-each
|
|
||||||
(fn (k)
|
|
||||||
(let ((v (dict-get spread-dict k)))
|
|
||||||
(append! attr-parts (str ":" k))
|
|
||||||
(append! attr-parts (serialize v))))
|
|
||||||
(keys spread-dict)))
|
|
||||||
(emitted "element-attrs"))
|
|
||||||
(scope-pop! "element-attrs")
|
|
||||||
(let ((parts (concat (list name) attr-parts child-parts)))
|
|
||||||
(str "(" (join " " parts) ")")))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Form classification
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define SPECIAL_FORM_NAMES
|
|
||||||
(list "if" "when" "cond" "case" "and" "or"
|
|
||||||
"let" "let*" "lambda" "fn"
|
|
||||||
"define" "defcomp" "defmacro" "defstyle"
|
|
||||||
"defhandler" "defpage" "defquery" "defaction" "defrelation"
|
|
||||||
"begin" "do" "quote" "quasiquote"
|
|
||||||
"->" "set!" "letrec" "dynamic-wind" "defisland"
|
|
||||||
"deftype" "defeffect" "scope" "provide"))
|
|
||||||
|
|
||||||
(define HO_FORM_NAMES
|
|
||||||
(list "map" "map-indexed" "filter" "reduce"
|
|
||||||
"some" "every?" "for-each"))
|
|
||||||
|
|
||||||
(define special-form? :effects []
|
|
||||||
(fn ((name :as string))
|
|
||||||
(contains? SPECIAL_FORM_NAMES name)))
|
|
||||||
|
|
||||||
(define ho-form? :effects []
|
|
||||||
(fn ((name :as string))
|
|
||||||
(contains? HO_FORM_NAMES name)))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; aser-special — evaluate special/HO forms in aser mode
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;;
|
|
||||||
;; Control flow forms evaluate conditions normally but render branches
|
|
||||||
;; through aser (serializing tags/components instead of rendering HTML).
|
|
||||||
;; Definition forms evaluate for side effects and return nil.
|
|
||||||
|
|
||||||
(define aser-special :effects [render]
|
|
||||||
(fn ((name :as string) (expr :as list) (env :as dict))
|
|
||||||
(let ((args (rest expr)))
|
|
||||||
(cond
|
|
||||||
;; if — evaluate condition, aser chosen branch
|
|
||||||
(= name "if")
|
|
||||||
(if (trampoline (eval-expr (first args) env))
|
|
||||||
(aser (nth args 1) env)
|
|
||||||
(if (> (len args) 2)
|
|
||||||
(aser (nth args 2) env)
|
|
||||||
nil))
|
|
||||||
|
|
||||||
;; when — evaluate condition, aser body if true
|
|
||||||
(= name "when")
|
|
||||||
(if (not (trampoline (eval-expr (first args) env)))
|
|
||||||
nil
|
|
||||||
(let ((result nil))
|
|
||||||
(for-each (fn (body) (set! result (aser body env)))
|
|
||||||
(rest args))
|
|
||||||
result))
|
|
||||||
|
|
||||||
;; cond — evaluate conditions, aser matching branch
|
|
||||||
(= name "cond")
|
|
||||||
(let ((branch (eval-cond args env)))
|
|
||||||
(if branch (aser branch env) nil))
|
|
||||||
|
|
||||||
;; case — evaluate match value, check each pair
|
|
||||||
(= name "case")
|
|
||||||
(let ((match-val (trampoline (eval-expr (first args) env)))
|
|
||||||
(clauses (rest args)))
|
|
||||||
(eval-case-aser match-val clauses env))
|
|
||||||
|
|
||||||
;; let / let*
|
|
||||||
(or (= name "let") (= name "let*"))
|
|
||||||
(let ((local (process-bindings (first args) env))
|
|
||||||
(result nil))
|
|
||||||
(for-each (fn (body) (set! result (aser body local)))
|
|
||||||
(rest args))
|
|
||||||
result)
|
|
||||||
|
|
||||||
;; begin / do
|
|
||||||
(or (= name "begin") (= name "do"))
|
|
||||||
(let ((result nil))
|
|
||||||
(for-each (fn (body) (set! result (aser body env))) args)
|
|
||||||
result)
|
|
||||||
|
|
||||||
;; and — short-circuit
|
|
||||||
(= name "and")
|
|
||||||
(let ((result true))
|
|
||||||
(some (fn (arg)
|
|
||||||
(set! result (trampoline (eval-expr arg env)))
|
|
||||||
(not result))
|
|
||||||
args)
|
|
||||||
result)
|
|
||||||
|
|
||||||
;; or — short-circuit
|
|
||||||
(= name "or")
|
|
||||||
(let ((result false))
|
|
||||||
(some (fn (arg)
|
|
||||||
(set! result (trampoline (eval-expr arg env)))
|
|
||||||
result)
|
|
||||||
args)
|
|
||||||
result)
|
|
||||||
|
|
||||||
;; map — evaluate function and collection, map through aser
|
|
||||||
(= name "map")
|
|
||||||
(let ((f (trampoline (eval-expr (first args) env)))
|
|
||||||
(coll (trampoline (eval-expr (nth args 1) env))))
|
|
||||||
(map (fn (item)
|
|
||||||
(if (lambda? f)
|
|
||||||
(let ((local (env-merge (lambda-closure f) env)))
|
|
||||||
(env-set! local (first (lambda-params f)) item)
|
|
||||||
(aser (lambda-body f) local))
|
|
||||||
(cek-call f (list item))))
|
|
||||||
coll))
|
|
||||||
|
|
||||||
;; map-indexed
|
|
||||||
(= name "map-indexed")
|
|
||||||
(let ((f (trampoline (eval-expr (first args) env)))
|
|
||||||
(coll (trampoline (eval-expr (nth args 1) env))))
|
|
||||||
(map-indexed (fn (i item)
|
|
||||||
(if (lambda? f)
|
|
||||||
(let ((local (env-merge (lambda-closure f) env)))
|
|
||||||
(env-set! local (first (lambda-params f)) i)
|
|
||||||
(env-set! local (nth (lambda-params f) 1) item)
|
|
||||||
(aser (lambda-body f) local))
|
|
||||||
(cek-call f (list i item))))
|
|
||||||
coll))
|
|
||||||
|
|
||||||
;; for-each — evaluate for side effects, aser each body
|
|
||||||
(= name "for-each")
|
|
||||||
(let ((f (trampoline (eval-expr (first args) env)))
|
|
||||||
(coll (trampoline (eval-expr (nth args 1) env)))
|
|
||||||
(results (list)))
|
|
||||||
(for-each (fn (item)
|
|
||||||
(if (lambda? f)
|
|
||||||
(let ((local (env-merge (lambda-closure f) env)))
|
|
||||||
(env-set! local (first (lambda-params f)) item)
|
|
||||||
(append! results (aser (lambda-body f) local)))
|
|
||||||
(cek-call f (list item))))
|
|
||||||
coll)
|
|
||||||
(if (empty? results) nil results))
|
|
||||||
|
|
||||||
;; defisland — evaluate AND serialize (client needs the definition)
|
|
||||||
(= name "defisland")
|
|
||||||
(do (trampoline (eval-expr expr env))
|
|
||||||
(serialize expr))
|
|
||||||
|
|
||||||
;; Definition forms — evaluate for side effects
|
|
||||||
(or (= name "define") (= name "defcomp") (= name "defmacro")
|
|
||||||
(= name "defstyle") (= name "defhandler") (= name "defpage")
|
|
||||||
(= name "defquery") (= name "defaction") (= name "defrelation")
|
|
||||||
(= name "deftype") (= name "defeffect"))
|
|
||||||
(do (trampoline (eval-expr expr env)) nil)
|
|
||||||
|
|
||||||
;; scope — unified render-time dynamic scope
|
|
||||||
(= name "scope")
|
|
||||||
(let ((scope-name (trampoline (eval-expr (first args) env)))
|
|
||||||
(rest-args (rest args))
|
|
||||||
(scope-val nil)
|
|
||||||
(body-args nil))
|
|
||||||
;; Check for :value keyword
|
|
||||||
(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-args (slice rest-args 2)))
|
|
||||||
(set! body-args rest-args))
|
|
||||||
(scope-push! scope-name scope-val)
|
|
||||||
(let ((result nil))
|
|
||||||
(for-each (fn (body) (set! result (aser body env)))
|
|
||||||
body-args)
|
|
||||||
(scope-pop! scope-name)
|
|
||||||
result))
|
|
||||||
|
|
||||||
;; provide — sugar for scope with value
|
|
||||||
(= name "provide")
|
|
||||||
(let ((prov-name (trampoline (eval-expr (first args) env)))
|
|
||||||
(prov-val (trampoline (eval-expr (nth args 1) env)))
|
|
||||||
(result nil))
|
|
||||||
(scope-push! prov-name prov-val)
|
|
||||||
(for-each (fn (body) (set! result (aser body env)))
|
|
||||||
(slice args 2))
|
|
||||||
(scope-pop! prov-name)
|
|
||||||
result)
|
|
||||||
|
|
||||||
;; Everything else — evaluate normally
|
|
||||||
:else
|
|
||||||
(trampoline (eval-expr expr env))))))
|
|
||||||
|
|
||||||
|
|
||||||
;; Helper: case dispatch for aser mode
|
|
||||||
(define eval-case-aser :effects [render]
|
|
||||||
(fn (match-val (clauses :as list) (env :as dict))
|
|
||||||
(if (< (len clauses) 2)
|
|
||||||
nil
|
|
||||||
(let ((test (first clauses))
|
|
||||||
(body (nth clauses 1)))
|
|
||||||
(if (or (and (= (type-of test) "keyword") (= (keyword-name test) "else"))
|
|
||||||
(and (= (type-of test) "symbol")
|
|
||||||
(or (= (symbol-name test) ":else")
|
|
||||||
(= (symbol-name test) "else"))))
|
|
||||||
(aser body env)
|
|
||||||
(if (= match-val (trampoline (eval-expr test env)))
|
|
||||||
(aser body env)
|
|
||||||
(eval-case-aser match-val (slice clauses 2) env)))))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Platform interface — SX wire adapter
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;;
|
|
||||||
;; From eval.sx:
|
|
||||||
;; eval-expr, trampoline, call-lambda, expand-macro
|
|
||||||
;; env-has?, env-get, env-set!, env-merge, callable?, lambda?, component?,
|
|
||||||
;; macro?, island?, primitive?, get-primitive, component-name
|
|
||||||
;; lambda-closure, lambda-params, lambda-body
|
|
||||||
;;
|
|
||||||
;; From render.sx:
|
|
||||||
;; HTML_TAGS, eval-cond, process-bindings
|
|
||||||
;;
|
|
||||||
;; From parser.sx:
|
|
||||||
;; serialize (= sx-serialize)
|
|
||||||
;;
|
|
||||||
;; From signals.sx (optional):
|
|
||||||
;; invoke
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
@@ -1,552 +0,0 @@
|
|||||||
;; ==========================================================================
|
|
||||||
;; boot.sx — Browser boot, mount, hydrate, script processing
|
|
||||||
;;
|
|
||||||
;; Handles the browser startup lifecycle:
|
|
||||||
;; 1. CSS tracking init
|
|
||||||
;; 2. Component script processing (from <script type="text/sx">)
|
|
||||||
;; 3. Hydration of [data-sx] elements
|
|
||||||
;; 4. Engine element processing
|
|
||||||
;;
|
|
||||||
;; Also provides the public mounting/hydration API:
|
|
||||||
;; mount, hydrate, update, render-component
|
|
||||||
;;
|
|
||||||
;; Depends on:
|
|
||||||
;; orchestration.sx — process-elements, engine-init
|
|
||||||
;; adapter-dom.sx — render-to-dom
|
|
||||||
;; render.sx — shared registries
|
|
||||||
;; ==========================================================================
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Head element hoisting (full version)
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Moves <meta>, <title>, <link rel=canonical>, <script type=application/ld+json>
|
|
||||||
;; from rendered content to <head>, deduplicating as needed.
|
|
||||||
|
|
||||||
(define HEAD_HOIST_SELECTOR
|
|
||||||
"meta, title, link[rel='canonical'], script[type='application/ld+json']")
|
|
||||||
|
|
||||||
(define hoist-head-elements-full :effects [mutation io]
|
|
||||||
(fn (root)
|
|
||||||
(let ((els (dom-query-all root HEAD_HOIST_SELECTOR)))
|
|
||||||
(for-each
|
|
||||||
(fn (el)
|
|
||||||
(let ((tag (lower (dom-tag-name el))))
|
|
||||||
(cond
|
|
||||||
;; <title> — replace document title
|
|
||||||
(= tag "title")
|
|
||||||
(do
|
|
||||||
(set-document-title (dom-text-content el))
|
|
||||||
(dom-remove-child (dom-parent el) el))
|
|
||||||
|
|
||||||
;; <meta> — deduplicate by name or property
|
|
||||||
(= tag "meta")
|
|
||||||
(do
|
|
||||||
(let ((name (dom-get-attr el "name"))
|
|
||||||
(prop (dom-get-attr el "property")))
|
|
||||||
(when name
|
|
||||||
(remove-head-element (str "meta[name=\"" name "\"]")))
|
|
||||||
(when prop
|
|
||||||
(remove-head-element (str "meta[property=\"" prop "\"]"))))
|
|
||||||
(dom-remove-child (dom-parent el) el)
|
|
||||||
(dom-append-to-head el))
|
|
||||||
|
|
||||||
;; <link rel=canonical> — deduplicate
|
|
||||||
(and (= tag "link")
|
|
||||||
(= (dom-get-attr el "rel") "canonical"))
|
|
||||||
(do
|
|
||||||
(remove-head-element "link[rel=\"canonical\"]")
|
|
||||||
(dom-remove-child (dom-parent el) el)
|
|
||||||
(dom-append-to-head el))
|
|
||||||
|
|
||||||
;; Everything else (ld+json, etc.) — just move
|
|
||||||
:else
|
|
||||||
(do
|
|
||||||
(dom-remove-child (dom-parent el) el)
|
|
||||||
(dom-append-to-head el)))))
|
|
||||||
els))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Mount — render SX source into a DOM element
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define sx-mount :effects [mutation io]
|
|
||||||
(fn (target (source :as string) (extra-env :as dict))
|
|
||||||
;; Render SX source string into target element.
|
|
||||||
;; target: Element or CSS selector string
|
|
||||||
;; source: SX source string
|
|
||||||
;; extra-env: optional extra bindings dict
|
|
||||||
(let ((el (resolve-mount-target target)))
|
|
||||||
(when el
|
|
||||||
(let ((node (sx-render-with-env source extra-env)))
|
|
||||||
(dom-set-text-content el "")
|
|
||||||
(dom-append el node)
|
|
||||||
;; Hoist head elements from rendered content
|
|
||||||
(hoist-head-elements-full el)
|
|
||||||
;; Process sx- attributes, hydrate data-sx and islands
|
|
||||||
(process-elements el)
|
|
||||||
(sx-hydrate-elements el)
|
|
||||||
(sx-hydrate-islands el)
|
|
||||||
(run-post-render-hooks))))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Resolve Suspense — replace streaming placeholder with resolved content
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;;
|
|
||||||
;; Called by inline <script> tags that arrive during chunked transfer:
|
|
||||||
;; __sxResolve("content", "(~article :title \"Hello\")")
|
|
||||||
;;
|
|
||||||
;; Finds the suspense wrapper by data-suspense attribute, renders the
|
|
||||||
;; new SX content, and replaces the wrapper's children.
|
|
||||||
|
|
||||||
(define resolve-suspense :effects [mutation io]
|
|
||||||
(fn ((id :as string) (sx :as string))
|
|
||||||
;; Process any new <script type="text/sx"> tags that arrived via
|
|
||||||
;; streaming (e.g. extra component defs) before resolving.
|
|
||||||
(process-sx-scripts nil)
|
|
||||||
(let ((el (dom-query (str "[data-suspense=\"" id "\"]"))))
|
|
||||||
(if el
|
|
||||||
(do
|
|
||||||
;; parse returns a list of expressions — render each individually
|
|
||||||
;; (mirroring the public render() API).
|
|
||||||
(let ((exprs (parse sx))
|
|
||||||
(env (get-render-env nil)))
|
|
||||||
(dom-set-text-content el "")
|
|
||||||
(for-each (fn (expr)
|
|
||||||
(dom-append el (render-to-dom expr env nil)))
|
|
||||||
exprs)
|
|
||||||
(process-elements el)
|
|
||||||
(sx-hydrate-elements el)
|
|
||||||
(sx-hydrate-islands el)
|
|
||||||
(run-post-render-hooks)
|
|
||||||
(dom-dispatch el "sx:resolved" {:id id})))
|
|
||||||
(log-warn (str "resolveSuspense: no element for id=" id))))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Hydrate — render all [data-sx] elements
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define sx-hydrate-elements :effects [mutation io]
|
|
||||||
(fn (root)
|
|
||||||
;; Find all [data-sx] elements within root and render them.
|
|
||||||
(let ((els (dom-query-all (or root (dom-body)) "[data-sx]")))
|
|
||||||
(for-each
|
|
||||||
(fn (el)
|
|
||||||
(when (not (is-processed? el "hydrated"))
|
|
||||||
(mark-processed! el "hydrated")
|
|
||||||
(sx-update-element el nil)))
|
|
||||||
els))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Update — re-render a [data-sx] element with new env data
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define sx-update-element :effects [mutation io]
|
|
||||||
(fn (el new-env)
|
|
||||||
;; Re-render a [data-sx] element.
|
|
||||||
;; Reads source from data-sx attr, base env from data-sx-env attr.
|
|
||||||
(let ((target (resolve-mount-target el)))
|
|
||||||
(when target
|
|
||||||
(let ((source (dom-get-attr target "data-sx")))
|
|
||||||
(when source
|
|
||||||
(let ((base-env (parse-env-attr target))
|
|
||||||
(env (merge-envs base-env new-env)))
|
|
||||||
(let ((node (sx-render-with-env source env)))
|
|
||||||
(dom-set-text-content target "")
|
|
||||||
(dom-append target node)
|
|
||||||
;; Update stored env if new-env provided
|
|
||||||
(when new-env
|
|
||||||
(store-env-attr target base-env new-env))))))))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Render component — build synthetic call from kwargs dict
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define sx-render-component :effects [mutation io]
|
|
||||||
(fn ((name :as string) (kwargs :as dict) (extra-env :as dict))
|
|
||||||
;; Render a named component with keyword args.
|
|
||||||
;; name: component name (with or without ~ prefix)
|
|
||||||
;; kwargs: dict of param-name → value
|
|
||||||
;; extra-env: optional extra env bindings
|
|
||||||
(let ((full-name (if (starts-with? name "~") name (str "~" name))))
|
|
||||||
(let ((env (get-render-env extra-env))
|
|
||||||
(comp (env-get env full-name)))
|
|
||||||
(if (not (component? comp))
|
|
||||||
(error (str "Unknown component: " full-name))
|
|
||||||
;; Build synthetic call expression
|
|
||||||
(let ((call-expr (list (make-symbol full-name))))
|
|
||||||
(for-each
|
|
||||||
(fn ((k :as string))
|
|
||||||
(append! call-expr (make-keyword (to-kebab k)))
|
|
||||||
(append! call-expr (dict-get kwargs k)))
|
|
||||||
(keys kwargs))
|
|
||||||
(render-to-dom call-expr env nil)))))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Script processing — <script type="text/sx">
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define process-sx-scripts :effects [mutation io]
|
|
||||||
(fn (root)
|
|
||||||
;; Process all <script type="text/sx"> tags.
|
|
||||||
;; - data-components + data-hash → localStorage cache
|
|
||||||
;; - data-mount="<selector>" → render into target
|
|
||||||
;; - Default: load as components
|
|
||||||
(let ((scripts (query-sx-scripts root)))
|
|
||||||
(for-each
|
|
||||||
(fn (s)
|
|
||||||
(when (not (is-processed? s "script"))
|
|
||||||
(mark-processed! s "script")
|
|
||||||
(let ((text (dom-text-content s)))
|
|
||||||
(cond
|
|
||||||
;; Component definitions
|
|
||||||
(dom-has-attr? s "data-components")
|
|
||||||
(process-component-script s text)
|
|
||||||
|
|
||||||
;; Empty script — skip
|
|
||||||
(or (nil? text) (empty? (trim text)))
|
|
||||||
nil
|
|
||||||
|
|
||||||
;; Init scripts — evaluate SX for side effects (event listeners etc.)
|
|
||||||
(dom-has-attr? s "data-init")
|
|
||||||
(let ((exprs (sx-parse text)))
|
|
||||||
(for-each
|
|
||||||
(fn (expr) (eval-expr expr (env-extend (dict))))
|
|
||||||
exprs))
|
|
||||||
|
|
||||||
;; Mount directive
|
|
||||||
(dom-has-attr? s "data-mount")
|
|
||||||
(let ((mount-sel (dom-get-attr s "data-mount"))
|
|
||||||
(target (dom-query mount-sel)))
|
|
||||||
(when target
|
|
||||||
(sx-mount target text nil)))
|
|
||||||
|
|
||||||
;; Default: load as components
|
|
||||||
:else
|
|
||||||
(sx-load-components text)))))
|
|
||||||
scripts))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Component script with caching
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define process-component-script :effects [mutation io]
|
|
||||||
(fn (script (text :as string))
|
|
||||||
;; Handle <script type="text/sx" data-components data-hash="...">
|
|
||||||
(let ((hash (dom-get-attr script "data-hash")))
|
|
||||||
(if (nil? hash)
|
|
||||||
;; Legacy: no hash — just load inline
|
|
||||||
(when (and text (not (empty? (trim text))))
|
|
||||||
(sx-load-components text))
|
|
||||||
;; Hash-based caching
|
|
||||||
(let ((has-inline (and text (not (empty? (trim text))))))
|
|
||||||
(let ((cached-hash (local-storage-get "sx-components-hash")))
|
|
||||||
(if (= cached-hash hash)
|
|
||||||
;; Cache hit
|
|
||||||
(if has-inline
|
|
||||||
;; Server sent full source (cookie stale) — update cache
|
|
||||||
(do
|
|
||||||
(local-storage-set "sx-components-hash" hash)
|
|
||||||
(local-storage-set "sx-components-src" text)
|
|
||||||
(sx-load-components text)
|
|
||||||
(log-info "components: downloaded (cookie stale)"))
|
|
||||||
;; Server omitted source — load from cache
|
|
||||||
(let ((cached (local-storage-get "sx-components-src")))
|
|
||||||
(if cached
|
|
||||||
(do
|
|
||||||
(sx-load-components cached)
|
|
||||||
(log-info (str "components: cached (" hash ")")))
|
|
||||||
;; Cache entry missing — clear cookie and reload
|
|
||||||
(do
|
|
||||||
(clear-sx-comp-cookie)
|
|
||||||
(browser-reload)))))
|
|
||||||
;; Cache miss — hash mismatch
|
|
||||||
(if has-inline
|
|
||||||
;; Server sent full source — cache it
|
|
||||||
(do
|
|
||||||
(local-storage-set "sx-components-hash" hash)
|
|
||||||
(local-storage-set "sx-components-src" text)
|
|
||||||
(sx-load-components text)
|
|
||||||
(log-info (str "components: downloaded (" hash ")")))
|
|
||||||
;; Server omitted but cache stale — clear and reload
|
|
||||||
(do
|
|
||||||
(local-storage-remove "sx-components-hash")
|
|
||||||
(local-storage-remove "sx-components-src")
|
|
||||||
(clear-sx-comp-cookie)
|
|
||||||
(browser-reload)))))
|
|
||||||
(set-sx-comp-cookie hash))))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Page registry for client-side routing
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define _page-routes (list))
|
|
||||||
|
|
||||||
(define process-page-scripts :effects [mutation io]
|
|
||||||
(fn ()
|
|
||||||
;; Process <script type="text/sx-pages"> tags.
|
|
||||||
;; Parses SX page registry and builds route entries with parsed patterns.
|
|
||||||
(let ((scripts (query-page-scripts)))
|
|
||||||
(log-info (str "pages: found " (len scripts) " script tags"))
|
|
||||||
(for-each
|
|
||||||
(fn (s)
|
|
||||||
(when (not (is-processed? s "pages"))
|
|
||||||
(mark-processed! s "pages")
|
|
||||||
(let ((text (dom-text-content s)))
|
|
||||||
(log-info (str "pages: script text length=" (if text (len text) 0)))
|
|
||||||
(if (and text (not (empty? (trim text))))
|
|
||||||
(let ((pages (parse text)))
|
|
||||||
(log-info (str "pages: parsed " (len pages) " entries"))
|
|
||||||
(for-each
|
|
||||||
(fn ((page :as dict))
|
|
||||||
(append! _page-routes
|
|
||||||
(merge page
|
|
||||||
{"parsed" (parse-route-pattern (get page "path"))})))
|
|
||||||
pages))
|
|
||||||
(log-warn "pages: script tag is empty")))))
|
|
||||||
scripts)
|
|
||||||
(log-info (str "pages: " (len _page-routes) " routes loaded")))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Island hydration — activate reactive islands from SSR output
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;;
|
|
||||||
;; The server renders islands as:
|
|
||||||
;; <div data-sx-island="counter" data-sx-state='{"initial": 0}'>
|
|
||||||
;; ...static HTML...
|
|
||||||
;; </div>
|
|
||||||
;;
|
|
||||||
;; Hydration:
|
|
||||||
;; 1. Find all [data-sx-island] elements
|
|
||||||
;; 2. Look up the island component by name
|
|
||||||
;; 3. Parse data-sx-state into kwargs
|
|
||||||
;; 4. Re-render the island body in a reactive context
|
|
||||||
;; 5. Morph existing DOM to preserve structure, focus, scroll
|
|
||||||
;; 6. Store disposers on the element for cleanup
|
|
||||||
|
|
||||||
(define sx-hydrate-islands :effects [mutation io]
|
|
||||||
(fn (root)
|
|
||||||
(let ((els (dom-query-all (or root (dom-body)) "[data-sx-island]")))
|
|
||||||
(for-each
|
|
||||||
(fn (el)
|
|
||||||
(when (not (is-processed? el "island-hydrated"))
|
|
||||||
(mark-processed! el "island-hydrated")
|
|
||||||
(hydrate-island el)))
|
|
||||||
els))))
|
|
||||||
|
|
||||||
(define hydrate-island :effects [mutation io]
|
|
||||||
(fn (el)
|
|
||||||
(let ((name (dom-get-attr el "data-sx-island"))
|
|
||||||
(state-sx (or (dom-get-attr el "data-sx-state") "{}")))
|
|
||||||
(let ((comp-name (str "~" name))
|
|
||||||
(env (get-render-env nil)))
|
|
||||||
(let ((comp (env-get env comp-name)))
|
|
||||||
(if (not (or (component? comp) (island? comp)))
|
|
||||||
(log-warn (str "hydrate-island: unknown island " comp-name))
|
|
||||||
|
|
||||||
;; Parse state and build keyword args — SX format, not JSON
|
|
||||||
(let ((kwargs (or (first (sx-parse state-sx)) {}))
|
|
||||||
(disposers (list))
|
|
||||||
(local (env-merge (component-closure comp) env)))
|
|
||||||
|
|
||||||
;; Bind params from kwargs
|
|
||||||
(for-each
|
|
||||||
(fn ((p :as string))
|
|
||||||
(env-set! local p (if (dict-has? kwargs p) (dict-get kwargs p) nil)))
|
|
||||||
(component-params comp))
|
|
||||||
|
|
||||||
;; Render the island body in a reactive scope
|
|
||||||
(let ((body-dom
|
|
||||||
(with-island-scope
|
|
||||||
(fn (disposable) (append! disposers disposable))
|
|
||||||
(fn () (render-to-dom (component-body comp) local nil)))))
|
|
||||||
|
|
||||||
;; Clear existing content and append reactive DOM directly.
|
|
||||||
;; Unlike morph-children, this preserves addEventListener-based
|
|
||||||
;; event handlers on the freshly rendered nodes.
|
|
||||||
(dom-set-text-content el "")
|
|
||||||
(dom-append el body-dom)
|
|
||||||
|
|
||||||
;; Store disposers for cleanup
|
|
||||||
(dom-set-data el "sx-disposers" disposers)
|
|
||||||
|
|
||||||
;; Process any sx- attributes on new content
|
|
||||||
(process-elements el)
|
|
||||||
|
|
||||||
(log-info (str "hydrated island: " comp-name
|
|
||||||
" (" (len disposers) " disposers)"))))))))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Island disposal — clean up when island removed from DOM
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define dispose-island :effects [mutation io]
|
|
||||||
(fn (el)
|
|
||||||
(let ((disposers (dom-get-data el "sx-disposers")))
|
|
||||||
(when disposers
|
|
||||||
(for-each
|
|
||||||
(fn ((d :as lambda))
|
|
||||||
(when (callable? d) (d)))
|
|
||||||
disposers)
|
|
||||||
(dom-set-data el "sx-disposers" nil)))))
|
|
||||||
|
|
||||||
(define dispose-islands-in :effects [mutation io]
|
|
||||||
(fn (root)
|
|
||||||
;; Dispose islands within root, but SKIP hydrated islands —
|
|
||||||
;; they may be preserved across morphs. Only dispose islands
|
|
||||||
;; that are not currently hydrated (e.g. freshly parsed content
|
|
||||||
;; being discarded) or that have been explicitly detached.
|
|
||||||
(when root
|
|
||||||
(let ((islands (dom-query-all root "[data-sx-island]")))
|
|
||||||
(when (and islands (not (empty? islands)))
|
|
||||||
(let ((to-dispose (filter
|
|
||||||
(fn (el) (not (is-processed? el "island-hydrated")))
|
|
||||||
islands)))
|
|
||||||
(when (not (empty? to-dispose))
|
|
||||||
(log-info (str "disposing " (len to-dispose) " island(s)"))
|
|
||||||
(for-each dispose-island to-dispose))))))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Render hooks — generic pre/post callbacks for hydration, swap, mount.
|
|
||||||
;; The spec calls these at render boundaries; the app decides what to do.
|
|
||||||
;; Pre-render: setup before DOM changes (e.g. prepare state).
|
|
||||||
;; Post-render: cleanup after DOM changes (e.g. flush collected CSS).
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define *pre-render-hooks* (list))
|
|
||||||
(define *post-render-hooks* (list))
|
|
||||||
|
|
||||||
(define register-pre-render-hook :effects [mutation]
|
|
||||||
(fn ((hook-fn :as lambda))
|
|
||||||
(append! *pre-render-hooks* hook-fn)))
|
|
||||||
|
|
||||||
(define register-post-render-hook :effects [mutation]
|
|
||||||
(fn ((hook-fn :as lambda))
|
|
||||||
(append! *post-render-hooks* hook-fn)))
|
|
||||||
|
|
||||||
(define run-pre-render-hooks :effects [mutation io]
|
|
||||||
(fn ()
|
|
||||||
(for-each (fn (hook) (cek-call hook nil)) *pre-render-hooks*)))
|
|
||||||
|
|
||||||
(define run-post-render-hooks :effects [mutation io]
|
|
||||||
(fn ()
|
|
||||||
(log-info "run-post-render-hooks:" (len *post-render-hooks*) "hooks")
|
|
||||||
(for-each (fn (hook)
|
|
||||||
(log-info " hook type:" (type-of hook) "callable:" (callable? hook) "lambda:" (lambda? hook))
|
|
||||||
(cek-call hook nil))
|
|
||||||
*post-render-hooks*)))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Full boot sequence
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define boot-init :effects [mutation io]
|
|
||||||
(fn ()
|
|
||||||
;; Full browser initialization:
|
|
||||||
;; 1. CSS tracking
|
|
||||||
;; 2. Style dictionary
|
|
||||||
;; 3. Process scripts (components + mounts)
|
|
||||||
;; 4. Process page registry (client-side routing)
|
|
||||||
;; 5. Hydrate [data-sx] elements
|
|
||||||
;; 6. Hydrate [data-sx-island] elements (reactive islands)
|
|
||||||
;; 7. Process engine elements
|
|
||||||
(do
|
|
||||||
(log-info (str "sx-browser " SX_VERSION))
|
|
||||||
(init-css-tracking)
|
|
||||||
(process-page-scripts)
|
|
||||||
(process-sx-scripts nil)
|
|
||||||
(sx-hydrate-elements nil)
|
|
||||||
(sx-hydrate-islands nil)
|
|
||||||
(run-post-render-hooks)
|
|
||||||
(process-elements nil))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Platform interface — Boot
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;;
|
|
||||||
;; From orchestration.sx:
|
|
||||||
;; process-elements, init-css-tracking
|
|
||||||
;;
|
|
||||||
;; === DOM / Render ===
|
|
||||||
;; (resolve-mount-target target) → Element (string → querySelector, else identity)
|
|
||||||
;; (sx-render-with-env source extra-env) → DOM node (parse + render with componentEnv + extra)
|
|
||||||
;; (get-render-env extra-env) → merged component env + extra
|
|
||||||
;; (merge-envs base new) → merged env dict
|
|
||||||
;; (render-to-dom expr env ns) → DOM node
|
|
||||||
;; (sx-load-components text) → void (parse + eval into componentEnv)
|
|
||||||
;;
|
|
||||||
;; === DOM queries ===
|
|
||||||
;; (dom-query sel) → Element or nil
|
|
||||||
;; (dom-query-all root sel) → list of Elements
|
|
||||||
;; (dom-body) → document.body
|
|
||||||
;; (dom-get-attr el name) → string or nil
|
|
||||||
;; (dom-has-attr? el name) → boolean
|
|
||||||
;; (dom-text-content el) → string
|
|
||||||
;; (dom-set-text-content el s) → void
|
|
||||||
;; (dom-append el child) → void
|
|
||||||
;; (dom-remove-child parent el) → void
|
|
||||||
;; (dom-parent el) → Element
|
|
||||||
;; (dom-append-to-head el) → void
|
|
||||||
;; (dom-tag-name el) → string
|
|
||||||
;;
|
|
||||||
;; === Head hoisting ===
|
|
||||||
;; (set-document-title s) → void (document.title = s)
|
|
||||||
;; (remove-head-element sel) → void (remove matching element from <head>)
|
|
||||||
;;
|
|
||||||
;; === Script queries ===
|
|
||||||
;; (query-sx-scripts root) → list of <script type="text/sx"> elements
|
|
||||||
;; (query-page-scripts) → list of <script type="text/sx-pages"> elements
|
|
||||||
;;
|
|
||||||
;; === localStorage ===
|
|
||||||
;; (local-storage-get key) → string or nil
|
|
||||||
;; (local-storage-set key val) → void
|
|
||||||
;; (local-storage-remove key) → void
|
|
||||||
;;
|
|
||||||
;; === Cookies ===
|
|
||||||
;; (set-sx-comp-cookie hash) → void
|
|
||||||
;; (clear-sx-comp-cookie) → void
|
|
||||||
;;
|
|
||||||
;; === Env ===
|
|
||||||
;; (parse-env-attr el) → dict (parse data-sx-env JSON attr)
|
|
||||||
;; (store-env-attr el base new) → void (merge and store back as JSON)
|
|
||||||
;; (to-kebab s) → string (underscore → kebab-case)
|
|
||||||
;;
|
|
||||||
;; === Logging ===
|
|
||||||
;; (log-info msg) → void (console.log with prefix)
|
|
||||||
;; (log-parse-error label text err) → void (diagnostic parse error)
|
|
||||||
;;
|
|
||||||
;; === Parsing (island state) ===
|
|
||||||
;; (sx-parse str) → list of AST expressions (from parser.sx)
|
|
||||||
;;
|
|
||||||
;; === Processing markers ===
|
|
||||||
;; (mark-processed! el key) → void
|
|
||||||
;; (is-processed? el key) → boolean
|
|
||||||
;;
|
|
||||||
;; === Morph ===
|
|
||||||
;; (morph-children target source) → void (morph target's children to match source)
|
|
||||||
;;
|
|
||||||
;; === Island support (from adapter-dom.sx / signals.sx) ===
|
|
||||||
;; (island? x) → boolean
|
|
||||||
;; (component-closure comp) → env
|
|
||||||
;; (component-params comp) → list of param names
|
|
||||||
;; (component-body comp) → AST
|
|
||||||
;; (component-name comp) → string
|
|
||||||
;; (component-has-children? comp) → boolean
|
|
||||||
;; (with-island-scope scope-fn body-fn) → result (track disposables)
|
|
||||||
;; (render-to-dom expr env ns) → DOM node
|
|
||||||
;; (dom-get-data el key) → any (from el._sxData)
|
|
||||||
;; (dom-set-data el key val) → void
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
@@ -1,206 +0,0 @@
|
|||||||
;; ==========================================================================
|
|
||||||
;; boundary-app.sx — Deployment-specific boundary declarations
|
|
||||||
;;
|
|
||||||
;; I/O primitives specific to THIS deployment's architecture:
|
|
||||||
;; inter-service communication, framework bindings, domain concepts,
|
|
||||||
;; and layout context providers.
|
|
||||||
;;
|
|
||||||
;; These are NOT part of the SX language contract — a different deployment
|
|
||||||
;; would declare different primitives here.
|
|
||||||
;;
|
|
||||||
;; The core SX I/O contract lives in boundary.sx.
|
|
||||||
;; Per-service page helpers live in {service}/sx/boundary.sx.
|
|
||||||
;; ==========================================================================
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Inter-service communication — microservice architecture
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define-io-primitive "frag"
|
|
||||||
:params (service frag-type &key)
|
|
||||||
:returns "string"
|
|
||||||
:async true
|
|
||||||
:doc "Fetch cross-service HTML fragment."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "query"
|
|
||||||
:params (service query-name &key)
|
|
||||||
:returns "any"
|
|
||||||
:async true
|
|
||||||
:doc "Fetch data from another service via internal HTTP."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "action"
|
|
||||||
:params (service action-name &key)
|
|
||||||
:returns "any"
|
|
||||||
:async true
|
|
||||||
:doc "Call an action on another service via internal HTTP."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "service"
|
|
||||||
:params (service-or-method &rest args &key)
|
|
||||||
:returns "any"
|
|
||||||
:async true
|
|
||||||
:doc "Call a domain service method. Two-arg: (service svc method). One-arg: (service method) uses bound handler service."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Framework bindings — Quart/Jinja2/HTMX specifics
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define-io-primitive "htmx-request?"
|
|
||||||
:params ()
|
|
||||||
:returns "boolean"
|
|
||||||
:async true
|
|
||||||
:doc "True if current request has HX-Request header."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "g"
|
|
||||||
:params (key)
|
|
||||||
:returns "any"
|
|
||||||
:async true
|
|
||||||
:doc "Read a value from the Quart request-local g object."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "jinja-global"
|
|
||||||
:params (key &rest default)
|
|
||||||
:returns "any"
|
|
||||||
:async false
|
|
||||||
:doc "Read a Jinja environment global."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Domain concepts — navigation, relations
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define-io-primitive "nav-tree"
|
|
||||||
:params ()
|
|
||||||
:returns "list"
|
|
||||||
:async true
|
|
||||||
:doc "Navigation tree as list of node dicts."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "get-children"
|
|
||||||
:params (&key parent-type parent-id)
|
|
||||||
:returns "list"
|
|
||||||
:async true
|
|
||||||
:doc "Fetch child entities for a parent."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "relations-from"
|
|
||||||
:params (entity-type)
|
|
||||||
:returns "list"
|
|
||||||
:async false
|
|
||||||
:doc "List of RelationDef dicts for an entity type."
|
|
||||||
:context :config)
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Layout context providers — per-service header/page context
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
;; Shared across all services (root layout)
|
|
||||||
|
|
||||||
(define-io-primitive "root-header-ctx"
|
|
||||||
:params ()
|
|
||||||
:returns "dict"
|
|
||||||
:async true
|
|
||||||
:doc "Dict with root header values (cart-mini, auth-menu, nav-tree, etc.)."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "select-colours"
|
|
||||||
:params ()
|
|
||||||
:returns "string"
|
|
||||||
:async true
|
|
||||||
:doc "Shared select/hover CSS class string."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "account-nav-ctx"
|
|
||||||
:params ()
|
|
||||||
:returns "any"
|
|
||||||
:async true
|
|
||||||
:doc "Account nav fragments, or nil."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "app-rights"
|
|
||||||
:params ()
|
|
||||||
:returns "dict"
|
|
||||||
:async true
|
|
||||||
:doc "User rights dict from g.rights."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
;; Blog service layout
|
|
||||||
|
|
||||||
(define-io-primitive "post-header-ctx"
|
|
||||||
:params ()
|
|
||||||
:returns "dict"
|
|
||||||
:async true
|
|
||||||
:doc "Dict with post-level header values."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
;; Cart service layout
|
|
||||||
|
|
||||||
(define-io-primitive "cart-page-ctx"
|
|
||||||
:params ()
|
|
||||||
:returns "dict"
|
|
||||||
:async true
|
|
||||||
:doc "Dict with cart page header values."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
;; Events service layouts
|
|
||||||
|
|
||||||
(define-io-primitive "events-calendar-ctx"
|
|
||||||
:params ()
|
|
||||||
:returns "dict"
|
|
||||||
:async true
|
|
||||||
:doc "Dict with events calendar header values."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "events-day-ctx"
|
|
||||||
:params ()
|
|
||||||
:returns "dict"
|
|
||||||
:async true
|
|
||||||
:doc "Dict with events day header values."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "events-entry-ctx"
|
|
||||||
:params ()
|
|
||||||
:returns "dict"
|
|
||||||
:async true
|
|
||||||
:doc "Dict with events entry header values."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "events-slot-ctx"
|
|
||||||
:params ()
|
|
||||||
:returns "dict"
|
|
||||||
:async true
|
|
||||||
:doc "Dict with events slot header values."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "events-ticket-type-ctx"
|
|
||||||
:params ()
|
|
||||||
:returns "dict"
|
|
||||||
:async true
|
|
||||||
:doc "Dict with ticket type header values."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
;; Market service layout
|
|
||||||
|
|
||||||
(define-io-primitive "market-header-ctx"
|
|
||||||
:params ()
|
|
||||||
:returns "dict"
|
|
||||||
:async true
|
|
||||||
:doc "Dict with market header data."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
;; Federation service layout
|
|
||||||
|
|
||||||
(define-io-primitive "federation-actor-ctx"
|
|
||||||
:params ()
|
|
||||||
:returns "dict?"
|
|
||||||
:async true
|
|
||||||
:doc "Serialized ActivityPub actor dict or nil."
|
|
||||||
:context :request)
|
|
||||||
@@ -1,435 +0,0 @@
|
|||||||
;; ==========================================================================
|
|
||||||
;; boundary.sx — SX language boundary contract
|
|
||||||
;;
|
|
||||||
;; Declares the core I/O primitives that any SX host must provide.
|
|
||||||
;; This is the LANGUAGE contract — not deployment-specific.
|
|
||||||
;;
|
|
||||||
;; Pure primitives (Tier 1) are declared in primitives.sx.
|
|
||||||
;; Deployment-specific I/O lives in boundary-app.sx.
|
|
||||||
;; Per-service page helpers live in {service}/sx/boundary.sx.
|
|
||||||
;;
|
|
||||||
;; Format:
|
|
||||||
;; (define-io-primitive "name"
|
|
||||||
;; :params (param1 param2 &key ...)
|
|
||||||
;; :returns "type"
|
|
||||||
;; :effects [io]
|
|
||||||
;; :async true
|
|
||||||
;; :doc "description"
|
|
||||||
;; :context :request)
|
|
||||||
;;
|
|
||||||
;; ==========================================================================
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Tier 1: Pure primitives — declared in primitives.sx
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(declare-tier :pure :source "primitives.sx")
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Tier 2: Core I/O primitives — async, side-effectful, need host context
|
|
||||||
;;
|
|
||||||
;; These are generic web-platform I/O that any SX web host would provide,
|
|
||||||
;; regardless of deployment architecture.
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
;; Request context
|
|
||||||
|
|
||||||
(define-io-primitive "current-user"
|
|
||||||
:params ()
|
|
||||||
:returns "dict?"
|
|
||||||
:effects [io]
|
|
||||||
:async true
|
|
||||||
:doc "Current authenticated user dict, or nil."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "request-arg"
|
|
||||||
:params (name &rest default)
|
|
||||||
:returns "any"
|
|
||||||
:effects [io]
|
|
||||||
:async true
|
|
||||||
:doc "Read a query string argument from the current request."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "request-path"
|
|
||||||
:params ()
|
|
||||||
:returns "string"
|
|
||||||
:effects [io]
|
|
||||||
:async true
|
|
||||||
:doc "Current request path."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "request-view-args"
|
|
||||||
:params (key)
|
|
||||||
:returns "any"
|
|
||||||
:effects [io]
|
|
||||||
:async true
|
|
||||||
:doc "Read a URL view argument from the current request."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "csrf-token"
|
|
||||||
:params ()
|
|
||||||
:returns "string"
|
|
||||||
:effects [io]
|
|
||||||
:async true
|
|
||||||
:doc "Current CSRF token string."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "abort"
|
|
||||||
:params (status &rest message)
|
|
||||||
:returns "nil"
|
|
||||||
:effects [io]
|
|
||||||
:async true
|
|
||||||
:doc "Raise HTTP error from SX."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
;; Routing
|
|
||||||
|
|
||||||
(define-io-primitive "url-for"
|
|
||||||
:params (endpoint &key)
|
|
||||||
:returns "string"
|
|
||||||
:effects [io]
|
|
||||||
:async true
|
|
||||||
:doc "Generate URL for a named endpoint."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "route-prefix"
|
|
||||||
:params ()
|
|
||||||
:returns "string"
|
|
||||||
:effects [io]
|
|
||||||
:async true
|
|
||||||
:doc "Service URL prefix for dev/prod routing."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
;; Config and host context (sync — no await needed)
|
|
||||||
|
|
||||||
(define-io-primitive "app-url"
|
|
||||||
:params (service &rest path)
|
|
||||||
:returns "string"
|
|
||||||
:effects [io]
|
|
||||||
:async false
|
|
||||||
:doc "Full URL for a service: (app-url \"blog\" \"/my-post/\")."
|
|
||||||
:context :config)
|
|
||||||
|
|
||||||
(define-io-primitive "asset-url"
|
|
||||||
:params (&rest path)
|
|
||||||
:returns "string"
|
|
||||||
:effects [io]
|
|
||||||
:async false
|
|
||||||
:doc "Versioned static asset URL."
|
|
||||||
:context :config)
|
|
||||||
|
|
||||||
(define-io-primitive "config"
|
|
||||||
:params (key)
|
|
||||||
:returns "any"
|
|
||||||
:effects [io]
|
|
||||||
:async false
|
|
||||||
:doc "Read a value from host configuration."
|
|
||||||
:context :config)
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Boundary types — what's allowed to cross the host-SX boundary
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define-boundary-types
|
|
||||||
(list "number" "string" "boolean" "nil" "keyword"
|
|
||||||
"list" "dict" "sx-source"))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Web interop — reading non-SX request formats
|
|
||||||
;;
|
|
||||||
;; SX's native wire format is SX (text/sx). These primitives bridge to
|
|
||||||
;; legacy web formats: HTML form encoding, JSON bodies, HTTP headers.
|
|
||||||
;; They're useful for interop but not fundamental to SX-to-SX communication.
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define-io-primitive "now"
|
|
||||||
:params (&rest format)
|
|
||||||
:returns "string"
|
|
||||||
:async true
|
|
||||||
:doc "Current timestamp. Optional format string (strftime). Default ISO 8601."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "sleep"
|
|
||||||
:params (ms)
|
|
||||||
:returns "nil"
|
|
||||||
:async true
|
|
||||||
:doc "Pause execution for ms milliseconds. For demos and testing."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "request-form"
|
|
||||||
:params (name &rest default)
|
|
||||||
:returns "any"
|
|
||||||
:async true
|
|
||||||
:doc "Read a form field from a POST/PUT/PATCH request body."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "request-json"
|
|
||||||
:params ()
|
|
||||||
:returns "dict?"
|
|
||||||
:async true
|
|
||||||
:doc "Read JSON body from the current request, or nil if not JSON."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "request-header"
|
|
||||||
:params (name &rest default)
|
|
||||||
:returns "string?"
|
|
||||||
:async true
|
|
||||||
:doc "Read a request header value by name."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "request-content-type"
|
|
||||||
:params ()
|
|
||||||
:returns "string?"
|
|
||||||
:async true
|
|
||||||
:doc "Content-Type of the current request."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "request-args-all"
|
|
||||||
:params ()
|
|
||||||
:returns "dict"
|
|
||||||
:async true
|
|
||||||
:doc "All query string parameters as a dict."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "request-form-all"
|
|
||||||
:params ()
|
|
||||||
:returns "dict"
|
|
||||||
:async true
|
|
||||||
:doc "All form fields as a dict."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "request-form-list"
|
|
||||||
:params (field-name)
|
|
||||||
:returns "list"
|
|
||||||
:async true
|
|
||||||
:doc "All values for a multi-value form field as a list."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "request-headers-all"
|
|
||||||
:params ()
|
|
||||||
:returns "dict"
|
|
||||||
:async true
|
|
||||||
:doc "All request headers as a dict (lowercase keys)."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "request-file-name"
|
|
||||||
:params (field-name)
|
|
||||||
:returns "string?"
|
|
||||||
:async true
|
|
||||||
:doc "Filename of an uploaded file by field name, or nil."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
;; Response manipulation
|
|
||||||
|
|
||||||
(define-io-primitive "set-response-header"
|
|
||||||
:params (name value)
|
|
||||||
:returns "nil"
|
|
||||||
:async true
|
|
||||||
:doc "Set a response header. Applied after handler returns."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "set-response-status"
|
|
||||||
:params (status)
|
|
||||||
:returns "nil"
|
|
||||||
:async true
|
|
||||||
:doc "Set the HTTP response status code. Applied after handler returns."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
;; Ephemeral state — per-process, resets on restart
|
|
||||||
|
|
||||||
(define-io-primitive "state-get"
|
|
||||||
:params (key &rest default)
|
|
||||||
:returns "any"
|
|
||||||
:async true
|
|
||||||
:doc "Read from ephemeral per-process state dict."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
(define-io-primitive "state-set!"
|
|
||||||
:params (key value)
|
|
||||||
:returns "nil"
|
|
||||||
:async true
|
|
||||||
:doc "Write to ephemeral per-process state dict."
|
|
||||||
:context :request)
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Tier 3: Signal primitives — reactive state for islands
|
|
||||||
;;
|
|
||||||
;; These are pure primitives (no IO) but are separated from primitives.sx
|
|
||||||
;; because they introduce a new type (signal) and depend on signals.sx.
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(declare-tier :signals :source "signals.sx")
|
|
||||||
|
|
||||||
(declare-signal-primitive "signal"
|
|
||||||
:params (initial-value)
|
|
||||||
:returns "signal"
|
|
||||||
:effects []
|
|
||||||
:doc "Create a reactive signal container with an initial value.")
|
|
||||||
|
|
||||||
(declare-signal-primitive "deref"
|
|
||||||
:params (signal)
|
|
||||||
:returns "any"
|
|
||||||
:effects []
|
|
||||||
:doc "Read a signal's current value. In a reactive context (inside an island),
|
|
||||||
subscribes the current DOM binding to the signal. Outside reactive
|
|
||||||
context, just returns the value.")
|
|
||||||
|
|
||||||
(declare-signal-primitive "reset!"
|
|
||||||
:params (signal value)
|
|
||||||
:returns "nil"
|
|
||||||
:effects [mutation]
|
|
||||||
:doc "Set a signal to a new value. Notifies all subscribers.")
|
|
||||||
|
|
||||||
(declare-signal-primitive "swap!"
|
|
||||||
:params (signal f &rest args)
|
|
||||||
:returns "nil"
|
|
||||||
:effects [mutation]
|
|
||||||
:doc "Update a signal by applying f to its current value. (swap! s inc)
|
|
||||||
is equivalent to (reset! s (inc (deref s))) but atomic.")
|
|
||||||
|
|
||||||
(declare-signal-primitive "computed"
|
|
||||||
:params (compute-fn)
|
|
||||||
:returns "signal"
|
|
||||||
:effects []
|
|
||||||
:doc "Create a derived signal that recomputes when its dependencies change.
|
|
||||||
Dependencies are discovered automatically by tracking deref calls.")
|
|
||||||
|
|
||||||
(declare-signal-primitive "effect"
|
|
||||||
:params (effect-fn)
|
|
||||||
:returns "lambda"
|
|
||||||
:effects [mutation]
|
|
||||||
:doc "Run a side effect that re-runs when its signal dependencies change.
|
|
||||||
Returns a dispose function. If the effect function returns a function,
|
|
||||||
it is called as cleanup before the next run.")
|
|
||||||
|
|
||||||
(declare-signal-primitive "batch"
|
|
||||||
:params (thunk)
|
|
||||||
:returns "any"
|
|
||||||
:effects [mutation]
|
|
||||||
:doc "Group multiple signal writes. Subscribers are notified once at the end,
|
|
||||||
after all values have been updated.")
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Tier 4: Spread + Collect — render-time attribute injection and accumulation
|
|
||||||
;;
|
|
||||||
;; `spread` is a new type: a dict of attributes that, when returned as a child
|
|
||||||
;; of an HTML element, merges its attrs onto the parent element rather than
|
|
||||||
;; rendering as content. This enables components like `~cssx/tw` to inject
|
|
||||||
;; classes and styles onto their parent from inside the child list.
|
|
||||||
;;
|
|
||||||
;; `collect!` / `collected` are render-time accumulators. Values are collected
|
|
||||||
;; into named buckets (with deduplication) during rendering and retrieved at
|
|
||||||
;; flush points (e.g. a single <style> tag for all collected CSS rules).
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(declare-tier :spread :source "render.sx")
|
|
||||||
|
|
||||||
(declare-spread-primitive "make-spread"
|
|
||||||
:params (attrs)
|
|
||||||
:returns "spread"
|
|
||||||
:effects []
|
|
||||||
:doc "Create a spread value from an attrs dict. When this value appears as
|
|
||||||
a child of an HTML element, its attrs are merged onto the parent
|
|
||||||
element (class values joined, others overwritten).")
|
|
||||||
|
|
||||||
(declare-spread-primitive "spread?"
|
|
||||||
:params (x)
|
|
||||||
:returns "boolean"
|
|
||||||
:effects []
|
|
||||||
:doc "Test whether a value is a spread.")
|
|
||||||
|
|
||||||
(declare-spread-primitive "spread-attrs"
|
|
||||||
:params (s)
|
|
||||||
:returns "dict"
|
|
||||||
:effects []
|
|
||||||
:doc "Extract the attrs dict from a spread value.")
|
|
||||||
|
|
||||||
(declare-spread-primitive "collect!"
|
|
||||||
:params (bucket value)
|
|
||||||
:returns "nil"
|
|
||||||
:effects [mutation]
|
|
||||||
:doc "Add value to a named render-time accumulator bucket. Values are
|
|
||||||
deduplicated (no duplicates added). Buckets persist for the duration
|
|
||||||
of the current render pass.")
|
|
||||||
|
|
||||||
(declare-spread-primitive "collected"
|
|
||||||
:params (bucket)
|
|
||||||
:returns "list"
|
|
||||||
:effects []
|
|
||||||
:doc "Return all values collected in the named bucket during the current
|
|
||||||
render pass. Returns an empty list if the bucket doesn't exist.")
|
|
||||||
|
|
||||||
(declare-spread-primitive "clear-collected!"
|
|
||||||
:params (bucket)
|
|
||||||
:returns "nil"
|
|
||||||
:effects [mutation]
|
|
||||||
:doc "Clear a named render-time accumulator bucket. Used at flush points
|
|
||||||
after emitting collected values (e.g. after writing a <style> tag).")
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Tier 5: Scoped effects — unified render-time dynamic scope
|
|
||||||
;;
|
|
||||||
;; `scope` is the general primitive. `provide` is sugar for scope-with-value.
|
|
||||||
;; Both `provide` and `scope` are special forms in the evaluator.
|
|
||||||
;;
|
|
||||||
;; The platform must implement per-name stacks. Each entry has a value,
|
|
||||||
;; an emitted list, and a dedup flag. `scope-push!`/`scope-pop!` manage
|
|
||||||
;; the stack. `provide-push!`/`provide-pop!` are aliases.
|
|
||||||
;;
|
|
||||||
;; `collect!`/`collected`/`clear-collected!` (Tier 4) are backed by scopes:
|
|
||||||
;; collect! lazily creates a root scope with dedup=true, then emits into it.
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(declare-tier :scoped-effects :source "eval.sx")
|
|
||||||
|
|
||||||
(declare-spread-primitive "scope-push!"
|
|
||||||
:params (name value)
|
|
||||||
:returns "nil"
|
|
||||||
:effects [mutation]
|
|
||||||
:doc "Push a scope with name and value. General form — provide-push! is an alias.")
|
|
||||||
|
|
||||||
(declare-spread-primitive "scope-pop!"
|
|
||||||
:params (name)
|
|
||||||
:returns "nil"
|
|
||||||
:effects [mutation]
|
|
||||||
:doc "Pop the most recent scope for name. General form — provide-pop! is an alias.")
|
|
||||||
|
|
||||||
(declare-spread-primitive "provide-push!"
|
|
||||||
:params (name value)
|
|
||||||
:returns "nil"
|
|
||||||
:effects [mutation]
|
|
||||||
:doc "Alias for scope-push!. Push a scope with name and value.")
|
|
||||||
|
|
||||||
(declare-spread-primitive "provide-pop!"
|
|
||||||
:params (name)
|
|
||||||
:returns "nil"
|
|
||||||
:effects [mutation]
|
|
||||||
:doc "Alias for scope-pop!. Pop the most recent scope for name.")
|
|
||||||
|
|
||||||
(declare-spread-primitive "context"
|
|
||||||
:params (name &rest default)
|
|
||||||
:returns "any"
|
|
||||||
:effects []
|
|
||||||
:doc "Read value from nearest enclosing provide with matching name.
|
|
||||||
Errors if no provider and no default given.")
|
|
||||||
|
|
||||||
(declare-spread-primitive "emit!"
|
|
||||||
:params (name value)
|
|
||||||
:returns "nil"
|
|
||||||
:effects [mutation]
|
|
||||||
:doc "Append value to nearest enclosing provide's accumulator.
|
|
||||||
Errors if no matching provider. No deduplication.")
|
|
||||||
|
|
||||||
(declare-spread-primitive "emitted"
|
|
||||||
:params (name)
|
|
||||||
:returns "list"
|
|
||||||
:effects []
|
|
||||||
:doc "Return list of values emitted into nearest matching provider.
|
|
||||||
Empty list if no provider.")
|
|
||||||
@@ -1,459 +0,0 @@
|
|||||||
;; ==========================================================================
|
|
||||||
;; deps.sx — Component dependency analysis specification
|
|
||||||
;;
|
|
||||||
;; Pure functions for analyzing component dependency graphs.
|
|
||||||
;; Used by the bundling system to compute per-page component bundles
|
|
||||||
;; instead of sending every definition to every page.
|
|
||||||
;;
|
|
||||||
;; All functions are pure — no IO, no platform-specific operations.
|
|
||||||
;; Each host bootstraps this to native code alongside eval.sx/render.sx.
|
|
||||||
;;
|
|
||||||
;; From eval.sx platform (already provided by every host):
|
|
||||||
;; (type-of x) → type string
|
|
||||||
;; (symbol-name s) → string name of symbol
|
|
||||||
;; (component-body c) → unevaluated AST of component body
|
|
||||||
;; (component-name c) → string name (without ~)
|
|
||||||
;; (macro-body m) → macro body AST
|
|
||||||
;; (env-get env k) → value or nil
|
|
||||||
;;
|
|
||||||
;; New platform functions for deps (each host implements):
|
|
||||||
;; (component-deps c) → cached deps list (may be empty)
|
|
||||||
;; (component-set-deps! c d)→ cache deps on component
|
|
||||||
;; (component-css-classes c)→ pre-scanned CSS class list
|
|
||||||
;; (regex-find-all pat src) → list of capture group 1 matches
|
|
||||||
;; (scan-css-classes src) → list of CSS class strings from source
|
|
||||||
;; ==========================================================================
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 1. AST scanning — collect ~component references from an AST node
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Walks all branches of control flow (if/when/cond/case) to find
|
|
||||||
;; every component that *could* be rendered.
|
|
||||||
|
|
||||||
(define scan-refs :effects []
|
|
||||||
(fn (node)
|
|
||||||
(let ((refs (list)))
|
|
||||||
(scan-refs-walk node refs)
|
|
||||||
refs)))
|
|
||||||
|
|
||||||
|
|
||||||
(define scan-refs-walk :effects []
|
|
||||||
(fn (node (refs :as list))
|
|
||||||
(cond
|
|
||||||
;; Symbol starting with ~ → component reference
|
|
||||||
(= (type-of node) "symbol")
|
|
||||||
(let ((name (symbol-name node)))
|
|
||||||
(when (starts-with? name "~")
|
|
||||||
(when (not (contains? refs name))
|
|
||||||
(append! refs name))))
|
|
||||||
|
|
||||||
;; List → recurse into all elements (covers all control flow branches)
|
|
||||||
(= (type-of node) "list")
|
|
||||||
(for-each (fn (item) (scan-refs-walk item refs)) node)
|
|
||||||
|
|
||||||
;; Dict → recurse into values
|
|
||||||
(= (type-of node) "dict")
|
|
||||||
(for-each (fn (key) (scan-refs-walk (dict-get node key) refs))
|
|
||||||
(keys node))
|
|
||||||
|
|
||||||
;; Literals (number, string, boolean, nil, keyword) → no refs
|
|
||||||
:else nil)))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 2. Transitive dependency closure
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Given a component name and an environment, compute all components
|
|
||||||
;; that it can transitively render. Handles cycles via seen-set.
|
|
||||||
|
|
||||||
(define transitive-deps-walk :effects []
|
|
||||||
(fn ((n :as string) (seen :as list) (env :as dict))
|
|
||||||
(when (not (contains? seen n))
|
|
||||||
(append! seen n)
|
|
||||||
(let ((val (env-get env n)))
|
|
||||||
(cond
|
|
||||||
(or (= (type-of val) "component") (= (type-of val) "island"))
|
|
||||||
(for-each (fn ((ref :as string)) (transitive-deps-walk ref seen env))
|
|
||||||
(scan-refs (component-body val)))
|
|
||||||
(= (type-of val) "macro")
|
|
||||||
(for-each (fn ((ref :as string)) (transitive-deps-walk ref seen env))
|
|
||||||
(scan-refs (macro-body val)))
|
|
||||||
:else nil)))))
|
|
||||||
|
|
||||||
|
|
||||||
(define transitive-deps :effects []
|
|
||||||
(fn ((name :as string) (env :as dict))
|
|
||||||
(let ((seen (list))
|
|
||||||
(key (if (starts-with? name "~") name (str "~" name))))
|
|
||||||
(transitive-deps-walk key seen env)
|
|
||||||
(filter (fn ((x :as string)) (not (= x key))) seen))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 3. Compute deps for all components in an environment
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Iterates env, calls transitive-deps for each component, and
|
|
||||||
;; stores the result via the platform's component-set-deps! function.
|
|
||||||
;;
|
|
||||||
;; Platform interface:
|
|
||||||
;; (env-components env) → list of component names in env
|
|
||||||
;; (component-set-deps! comp deps) → store deps on component
|
|
||||||
|
|
||||||
(define compute-all-deps :effects [mutation]
|
|
||||||
(fn ((env :as dict))
|
|
||||||
(for-each
|
|
||||||
(fn ((name :as string))
|
|
||||||
(let ((val (env-get env name)))
|
|
||||||
(when (or (= (type-of val) "component") (= (type-of val) "island"))
|
|
||||||
(component-set-deps! val (transitive-deps name env)))))
|
|
||||||
(env-components env))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 4. Scan serialized SX source for component references
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Regex-based extraction of (~name patterns from SX wire format.
|
|
||||||
;; Returns list of names WITH ~ prefix.
|
|
||||||
;;
|
|
||||||
;; Platform interface:
|
|
||||||
;; (regex-find-all pattern source) → list of matched group strings
|
|
||||||
|
|
||||||
(define scan-components-from-source :effects []
|
|
||||||
(fn ((source :as string))
|
|
||||||
(let ((matches (regex-find-all "\\(~([a-zA-Z_][a-zA-Z0-9_\\-:/]*)" source)))
|
|
||||||
(map (fn ((m :as string)) (str "~" m)) matches))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 5. Components needed for a page
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Scans page source for direct component references, then computes
|
|
||||||
;; the transitive closure. Returns list of ~names.
|
|
||||||
|
|
||||||
(define components-needed :effects []
|
|
||||||
(fn ((page-source :as string) (env :as dict))
|
|
||||||
(let ((direct (scan-components-from-source page-source))
|
|
||||||
(all-needed (list)))
|
|
||||||
|
|
||||||
;; Add each direct ref + its transitive deps
|
|
||||||
(for-each
|
|
||||||
(fn ((name :as string))
|
|
||||||
(when (not (contains? all-needed name))
|
|
||||||
(append! all-needed name))
|
|
||||||
(let ((val (env-get env name)))
|
|
||||||
(let ((deps (if (and (= (type-of val) "component")
|
|
||||||
(not (empty? (component-deps val))))
|
|
||||||
(component-deps val)
|
|
||||||
(transitive-deps name env))))
|
|
||||||
(for-each
|
|
||||||
(fn ((dep :as string))
|
|
||||||
(when (not (contains? all-needed dep))
|
|
||||||
(append! all-needed dep)))
|
|
||||||
deps))))
|
|
||||||
direct)
|
|
||||||
|
|
||||||
all-needed)))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 6. Build per-page component bundle
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Given page source and env, returns list of component names needed.
|
|
||||||
;; The host uses this list to serialize only the needed definitions
|
|
||||||
;; and compute a page-specific hash.
|
|
||||||
;;
|
|
||||||
;; This replaces the "send everything" approach with per-page bundles.
|
|
||||||
|
|
||||||
(define page-component-bundle :effects []
|
|
||||||
(fn ((page-source :as string) (env :as dict))
|
|
||||||
(components-needed page-source env)))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 7. CSS classes for a page
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Returns the union of CSS classes from components this page uses,
|
|
||||||
;; plus classes from the page source itself.
|
|
||||||
;;
|
|
||||||
;; Platform interface:
|
|
||||||
;; (component-css-classes c) → set/list of class strings
|
|
||||||
;; (scan-css-classes source) → set/list of class strings from source
|
|
||||||
|
|
||||||
(define page-css-classes :effects []
|
|
||||||
(fn ((page-source :as string) (env :as dict))
|
|
||||||
(let ((needed (components-needed page-source env))
|
|
||||||
(classes (list)))
|
|
||||||
|
|
||||||
;; Collect classes from needed components
|
|
||||||
(for-each
|
|
||||||
(fn ((name :as string))
|
|
||||||
(let ((val (env-get env name)))
|
|
||||||
(when (= (type-of val) "component")
|
|
||||||
(for-each
|
|
||||||
(fn ((cls :as string))
|
|
||||||
(when (not (contains? classes cls))
|
|
||||||
(append! classes cls)))
|
|
||||||
(component-css-classes val)))))
|
|
||||||
needed)
|
|
||||||
|
|
||||||
;; Add classes from page source
|
|
||||||
(for-each
|
|
||||||
(fn ((cls :as string))
|
|
||||||
(when (not (contains? classes cls))
|
|
||||||
(append! classes cls)))
|
|
||||||
(scan-css-classes page-source))
|
|
||||||
|
|
||||||
classes)))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 8. IO detection — scan component ASTs for IO primitive references
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Extends the dependency walker to detect references to IO primitives.
|
|
||||||
;; IO names are provided by the host (from boundary.sx declarations).
|
|
||||||
;; A component is "pure" if it (transitively) references no IO primitives.
|
|
||||||
;;
|
|
||||||
;; Platform interface additions:
|
|
||||||
;; (component-io-refs c) → cached IO ref list (may be empty)
|
|
||||||
;; (component-set-io-refs! c r) → cache IO refs on component
|
|
||||||
|
|
||||||
(define scan-io-refs-walk :effects []
|
|
||||||
(fn (node (io-names :as list) (refs :as list))
|
|
||||||
(cond
|
|
||||||
;; Symbol → check if name is in the IO set
|
|
||||||
(= (type-of node) "symbol")
|
|
||||||
(let ((name (symbol-name node)))
|
|
||||||
(when (contains? io-names name)
|
|
||||||
(when (not (contains? refs name))
|
|
||||||
(append! refs name))))
|
|
||||||
|
|
||||||
;; List → recurse into all elements
|
|
||||||
(= (type-of node) "list")
|
|
||||||
(for-each (fn (item) (scan-io-refs-walk item io-names refs)) node)
|
|
||||||
|
|
||||||
;; Dict → recurse into values
|
|
||||||
(= (type-of node) "dict")
|
|
||||||
(for-each (fn (key) (scan-io-refs-walk (dict-get node key) io-names refs))
|
|
||||||
(keys node))
|
|
||||||
|
|
||||||
;; Literals → no IO refs
|
|
||||||
:else nil)))
|
|
||||||
|
|
||||||
|
|
||||||
(define scan-io-refs :effects []
|
|
||||||
(fn (node (io-names :as list))
|
|
||||||
(let ((refs (list)))
|
|
||||||
(scan-io-refs-walk node io-names refs)
|
|
||||||
refs)))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 9. Transitive IO refs — follow component deps and union IO refs
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define transitive-io-refs-walk :effects []
|
|
||||||
(fn ((n :as string) (seen :as list) (all-refs :as list) (env :as dict) (io-names :as list))
|
|
||||||
(when (not (contains? seen n))
|
|
||||||
(append! seen n)
|
|
||||||
(let ((val (env-get env n)))
|
|
||||||
(cond
|
|
||||||
(= (type-of val) "component")
|
|
||||||
(do
|
|
||||||
;; Scan this component's body for IO refs
|
|
||||||
(for-each
|
|
||||||
(fn ((ref :as string))
|
|
||||||
(when (not (contains? all-refs ref))
|
|
||||||
(append! all-refs ref)))
|
|
||||||
(scan-io-refs (component-body val) io-names))
|
|
||||||
;; Recurse into component deps
|
|
||||||
(for-each
|
|
||||||
(fn ((dep :as string)) (transitive-io-refs-walk dep seen all-refs env io-names))
|
|
||||||
(scan-refs (component-body val))))
|
|
||||||
|
|
||||||
(= (type-of val) "macro")
|
|
||||||
(do
|
|
||||||
(for-each
|
|
||||||
(fn ((ref :as string))
|
|
||||||
(when (not (contains? all-refs ref))
|
|
||||||
(append! all-refs ref)))
|
|
||||||
(scan-io-refs (macro-body val) io-names))
|
|
||||||
(for-each
|
|
||||||
(fn ((dep :as string)) (transitive-io-refs-walk dep seen all-refs env io-names))
|
|
||||||
(scan-refs (macro-body val))))
|
|
||||||
|
|
||||||
:else nil)))))
|
|
||||||
|
|
||||||
|
|
||||||
(define transitive-io-refs :effects []
|
|
||||||
(fn ((name :as string) (env :as dict) (io-names :as list))
|
|
||||||
(let ((all-refs (list))
|
|
||||||
(seen (list))
|
|
||||||
(key (if (starts-with? name "~") name (str "~" name))))
|
|
||||||
(transitive-io-refs-walk key seen all-refs env io-names)
|
|
||||||
all-refs)))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 10. Compute IO refs for all components in an environment
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define compute-all-io-refs :effects [mutation]
|
|
||||||
(fn ((env :as dict) (io-names :as list))
|
|
||||||
(for-each
|
|
||||||
(fn ((name :as string))
|
|
||||||
(let ((val (env-get env name)))
|
|
||||||
(when (= (type-of val) "component")
|
|
||||||
(component-set-io-refs! val (transitive-io-refs name env io-names)))))
|
|
||||||
(env-components env))))
|
|
||||||
|
|
||||||
|
|
||||||
(define component-io-refs-cached :effects []
|
|
||||||
(fn ((name :as string) (env :as dict) (io-names :as list))
|
|
||||||
(let ((key (if (starts-with? name "~") name (str "~" name))))
|
|
||||||
(let ((val (env-get env key)))
|
|
||||||
(if (and (= (type-of val) "component")
|
|
||||||
(not (nil? (component-io-refs val)))
|
|
||||||
(not (empty? (component-io-refs val))))
|
|
||||||
(component-io-refs val)
|
|
||||||
;; Fallback: not yet cached (shouldn't happen after compute-all-io-refs)
|
|
||||||
(transitive-io-refs name env io-names))))))
|
|
||||||
|
|
||||||
(define component-pure? :effects []
|
|
||||||
(fn ((name :as string) (env :as dict) (io-names :as list))
|
|
||||||
(let ((key (if (starts-with? name "~") name (str "~" name))))
|
|
||||||
(let ((val (env-get env key)))
|
|
||||||
(if (and (= (type-of val) "component")
|
|
||||||
(not (nil? (component-io-refs val))))
|
|
||||||
;; Use cached io-refs (empty list = pure)
|
|
||||||
(empty? (component-io-refs val))
|
|
||||||
;; Fallback
|
|
||||||
(empty? (transitive-io-refs name env io-names)))))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 5. Render target — boundary decision per component
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Combines IO analysis with affinity annotations to decide where a
|
|
||||||
;; component should render:
|
|
||||||
;;
|
|
||||||
;; :affinity :server → always "server" (auth-sensitive, secrets)
|
|
||||||
;; :affinity :client → "client" even if IO-dependent (IO proxy)
|
|
||||||
;; :affinity :auto → "server" if IO-dependent, "client" if pure
|
|
||||||
;;
|
|
||||||
;; Returns: "server" | "client"
|
|
||||||
|
|
||||||
(define render-target :effects []
|
|
||||||
(fn ((name :as string) (env :as dict) (io-names :as list))
|
|
||||||
(let ((key (if (starts-with? name "~") name (str "~" name))))
|
|
||||||
(let ((val (env-get env key)))
|
|
||||||
(if (not (= (type-of val) "component"))
|
|
||||||
"server"
|
|
||||||
(let ((affinity (component-affinity val)))
|
|
||||||
(cond
|
|
||||||
(= affinity "server") "server"
|
|
||||||
(= affinity "client") "client"
|
|
||||||
;; auto: decide from IO analysis
|
|
||||||
(not (component-pure? name env io-names)) "server"
|
|
||||||
:else "client")))))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 6. Page render plan — pre-computed boundary decisions for a page
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Given page source + env + IO names, returns a render plan dict:
|
|
||||||
;;
|
|
||||||
;; {:components {~name "server"|"client" ...}
|
|
||||||
;; :server (list of ~names that render server-side)
|
|
||||||
;; :client (list of ~names that render client-side)
|
|
||||||
;; :io-deps (list of IO primitives needed by server components)}
|
|
||||||
;;
|
|
||||||
;; This is computed once at page registration and cached on the page def.
|
|
||||||
;; The async evaluator and client router both use it to make decisions
|
|
||||||
;; without recomputing at every request.
|
|
||||||
|
|
||||||
(define page-render-plan :effects []
|
|
||||||
(fn ((page-source :as string) (env :as dict) (io-names :as list))
|
|
||||||
(let ((needed (components-needed page-source env))
|
|
||||||
(comp-targets (dict))
|
|
||||||
(server-list (list))
|
|
||||||
(client-list (list))
|
|
||||||
(io-deps (list)))
|
|
||||||
|
|
||||||
(for-each
|
|
||||||
(fn ((name :as string))
|
|
||||||
(let ((target (render-target name env io-names)))
|
|
||||||
(dict-set! comp-targets name target)
|
|
||||||
(if (= target "server")
|
|
||||||
(do
|
|
||||||
(append! server-list name)
|
|
||||||
;; Collect IO deps from server components (use cache)
|
|
||||||
(for-each
|
|
||||||
(fn ((io-ref :as string))
|
|
||||||
(when (not (contains? io-deps io-ref))
|
|
||||||
(append! io-deps io-ref)))
|
|
||||||
(component-io-refs-cached name env io-names)))
|
|
||||||
(append! client-list name))))
|
|
||||||
needed)
|
|
||||||
|
|
||||||
{:components comp-targets
|
|
||||||
:server server-list
|
|
||||||
:client client-list
|
|
||||||
:io-deps io-deps})))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Host obligation: selective expansion in async partial evaluation
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; The spec classifies components as pure or IO-dependent and provides
|
|
||||||
;; per-component render-target decisions. Each host's async partial
|
|
||||||
;; evaluator (the server-side rendering path that bridges sync evaluation
|
|
||||||
;; with async IO) must use this classification:
|
|
||||||
;;
|
|
||||||
;; render-target "server" → expand server-side (IO must resolve)
|
|
||||||
;; render-target "client" → serialize for client (can render anywhere)
|
|
||||||
;; Layout slot context → expand all (server needs full HTML)
|
|
||||||
;;
|
|
||||||
;; The spec provides: component-io-refs, component-pure?, render-target,
|
|
||||||
;; component-affinity. The host provides the async runtime that acts on it.
|
|
||||||
;; This is not SX semantics — it is host infrastructure. Every host
|
|
||||||
;; with a server-side async evaluator implements the same rule.
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Platform interface summary
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;;
|
|
||||||
;; From eval.sx (already provided):
|
|
||||||
;; (type-of x) → type string
|
|
||||||
;; (symbol-name s) → string name of symbol
|
|
||||||
;; (env-get env k) → value or nil
|
|
||||||
;;
|
|
||||||
;; New for deps.sx (each host implements):
|
|
||||||
;; (component-body c) → AST body of component
|
|
||||||
;; (component-name c) → name string
|
|
||||||
;; (component-deps c) → cached deps list (may be empty)
|
|
||||||
;; (component-set-deps! c d)→ cache deps on component
|
|
||||||
;; (component-css-classes c)→ pre-scanned CSS class list
|
|
||||||
;; (component-io-refs c) → cached IO ref list (may be empty)
|
|
||||||
;; (component-set-io-refs! c r)→ cache IO refs on component
|
|
||||||
;; (component-affinity c) → "auto" | "client" | "server"
|
|
||||||
;; (macro-body m) → AST body of macro
|
|
||||||
;; (regex-find-all pat src) → list of capture group matches
|
|
||||||
;; (scan-css-classes src) → list of CSS class strings from source
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; env-components — list component/macro names in an environment
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Moved from platform to spec: pure logic using type predicates.
|
|
||||||
|
|
||||||
(define env-components :effects []
|
|
||||||
(fn ((env :as dict))
|
|
||||||
(filter
|
|
||||||
(fn ((k :as string))
|
|
||||||
(let ((v (env-get env k)))
|
|
||||||
(or (component? v) (macro? v))))
|
|
||||||
(keys env))))
|
|
||||||
@@ -1,803 +0,0 @@
|
|||||||
;; ==========================================================================
|
|
||||||
;; 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 (cek-call transform (list 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
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
@@ -1,278 +0,0 @@
|
|||||||
;; ==========================================================================
|
|
||||||
;; forms.sx — Server-side definition forms
|
|
||||||
;;
|
|
||||||
;; Platform-specific special forms for declaring handlers, pages, queries,
|
|
||||||
;; and actions. These parse &key parameter lists and create typed definition
|
|
||||||
;; objects that the server runtime uses for routing and execution.
|
|
||||||
;;
|
|
||||||
;; When SX moves to isomorphic execution, these forms will have different
|
|
||||||
;; platform bindings on client vs server. The spec stays the same — only
|
|
||||||
;; the constructors (make-handler-def, make-query-def, etc.) change.
|
|
||||||
;;
|
|
||||||
;; Platform functions required:
|
|
||||||
;; make-handler-def(name, params, body, env) → HandlerDef
|
|
||||||
;; make-query-def(name, params, doc, body, env) → QueryDef
|
|
||||||
;; make-action-def(name, params, doc, body, env) → ActionDef
|
|
||||||
;; make-page-def(name, slots, env) → PageDef
|
|
||||||
;; ==========================================================================
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Shared: parse (&key param1 param2 ...) → list of param name strings
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define parse-key-params
|
|
||||||
(fn ((params-expr :as list))
|
|
||||||
(let ((params (list))
|
|
||||||
(in-key false))
|
|
||||||
(for-each
|
|
||||||
(fn (p)
|
|
||||||
(when (= (type-of p) "symbol")
|
|
||||||
(let ((name (symbol-name p)))
|
|
||||||
(cond
|
|
||||||
(= name "&key") (set! in-key true)
|
|
||||||
in-key (append! params name)
|
|
||||||
:else (append! params name)))))
|
|
||||||
params-expr)
|
|
||||||
params)))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; defhandler — (defhandler name [:path "..." :method :get :csrf false :returns "element"] (&key param...) body)
|
|
||||||
;;
|
|
||||||
;; Keyword options between name and params list:
|
|
||||||
;; :path — public route path (string). Without :path, handler is internal-only.
|
|
||||||
;; :method — HTTP method (keyword: :get :post :put :patch :delete). Default :get.
|
|
||||||
;; :csrf — CSRF protection (boolean). Default true; set false for POST/PUT etc.
|
|
||||||
;; :returns — return type annotation (types.sx vocabulary). Default "element".
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define parse-handler-args
|
|
||||||
(fn ((args :as list))
|
|
||||||
"Parse defhandler args after the name symbol.
|
|
||||||
Scans for :keyword value option pairs, then a list (params), then body.
|
|
||||||
Returns dict with keys: opts, params, body."
|
|
||||||
(let ((opts {})
|
|
||||||
(params (list))
|
|
||||||
(body nil)
|
|
||||||
(i 0)
|
|
||||||
(n (len args))
|
|
||||||
(done false))
|
|
||||||
(for-each
|
|
||||||
(fn (idx)
|
|
||||||
(when (and (not done) (= idx i))
|
|
||||||
(let ((arg (nth args idx)))
|
|
||||||
(cond
|
|
||||||
;; keyword-value pair → consume two items
|
|
||||||
(= (type-of arg) "keyword")
|
|
||||||
(do
|
|
||||||
(when (< (+ idx 1) n)
|
|
||||||
(let ((val (nth args (+ idx 1))))
|
|
||||||
;; For :method, extract keyword name; for :csrf, keep as-is
|
|
||||||
(dict-set! opts (keyword-name arg)
|
|
||||||
(if (= (type-of val) "keyword")
|
|
||||||
(keyword-name val)
|
|
||||||
val))))
|
|
||||||
(set! i (+ idx 2)))
|
|
||||||
;; list → params, next element is body
|
|
||||||
(= (type-of arg) "list")
|
|
||||||
(do
|
|
||||||
(set! params (parse-key-params arg))
|
|
||||||
(when (< (+ idx 1) n)
|
|
||||||
(set! body (nth args (+ idx 1))))
|
|
||||||
(set! done true))
|
|
||||||
;; anything else → no explicit params, this is body
|
|
||||||
:else
|
|
||||||
(do
|
|
||||||
(set! body arg)
|
|
||||||
(set! done true))))))
|
|
||||||
(range 0 n))
|
|
||||||
(dict :opts opts :params params :body body))))
|
|
||||||
|
|
||||||
(define sf-defhandler
|
|
||||||
(fn ((args :as list) (env :as dict))
|
|
||||||
(let ((name-sym (first args))
|
|
||||||
(name (symbol-name name-sym))
|
|
||||||
(parsed (parse-handler-args (rest args)))
|
|
||||||
(opts (get parsed "opts"))
|
|
||||||
(params (get parsed "params"))
|
|
||||||
(body (get parsed "body")))
|
|
||||||
(let ((hdef (make-handler-def name params body env opts)))
|
|
||||||
(env-set! env (str "handler:" name) hdef)
|
|
||||||
hdef))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; defquery — (defquery name (&key param...) "docstring" body)
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define sf-defquery
|
|
||||||
(fn ((args :as list) (env :as dict))
|
|
||||||
(let ((name-sym (first args))
|
|
||||||
(params-raw (nth args 1))
|
|
||||||
(name (symbol-name name-sym))
|
|
||||||
(params (parse-key-params params-raw))
|
|
||||||
;; Optional docstring before body
|
|
||||||
(has-doc (and (>= (len args) 4) (= (type-of (nth args 2)) "string")))
|
|
||||||
(doc (if has-doc (nth args 2) ""))
|
|
||||||
(body (if has-doc (nth args 3) (nth args 2))))
|
|
||||||
(let ((qdef (make-query-def name params doc body env)))
|
|
||||||
(env-set! env (str "query:" name) qdef)
|
|
||||||
qdef))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; defaction — (defaction name (&key param...) "docstring" body)
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define sf-defaction
|
|
||||||
(fn ((args :as list) (env :as dict))
|
|
||||||
(let ((name-sym (first args))
|
|
||||||
(params-raw (nth args 1))
|
|
||||||
(name (symbol-name name-sym))
|
|
||||||
(params (parse-key-params params-raw))
|
|
||||||
(has-doc (and (>= (len args) 4) (= (type-of (nth args 2)) "string")))
|
|
||||||
(doc (if has-doc (nth args 2) ""))
|
|
||||||
(body (if has-doc (nth args 3) (nth args 2))))
|
|
||||||
(let ((adef (make-action-def name params doc body env)))
|
|
||||||
(env-set! env (str "action:" name) adef)
|
|
||||||
adef))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; defpage — (defpage name :path "/..." :auth :public :content expr ...)
|
|
||||||
;;
|
|
||||||
;; Keyword-slot form: all values after the name are :key value pairs.
|
|
||||||
;; Values are stored as unevaluated AST — resolved at request time.
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define sf-defpage
|
|
||||||
(fn ((args :as list) (env :as dict))
|
|
||||||
(let ((name-sym (first args))
|
|
||||||
(name (symbol-name name-sym))
|
|
||||||
(slots {}))
|
|
||||||
;; Parse keyword slots from remaining args
|
|
||||||
(let ((i 1)
|
|
||||||
(max-i (len args)))
|
|
||||||
(for-each
|
|
||||||
(fn ((idx :as number))
|
|
||||||
(when (and (< idx max-i)
|
|
||||||
(= (type-of (nth args idx)) "keyword"))
|
|
||||||
(when (< (+ idx 1) max-i)
|
|
||||||
(dict-set! slots (keyword-name (nth args idx))
|
|
||||||
(nth args (+ idx 1))))))
|
|
||||||
(range 1 max-i 2)))
|
|
||||||
(let ((pdef (make-page-def name slots env)))
|
|
||||||
(env-set! env (str "page:" name) pdef)
|
|
||||||
pdef))))
|
|
||||||
|
|
||||||
|
|
||||||
;; ==========================================================================
|
|
||||||
;; Page Execution Semantics
|
|
||||||
;; ==========================================================================
|
|
||||||
;;
|
|
||||||
;; A PageDef describes what to render for a route. The host evaluates slots
|
|
||||||
;; at request time. This section specifies the data → content protocol that
|
|
||||||
;; every host must implement identically.
|
|
||||||
;;
|
|
||||||
;; Slots (all unevaluated AST):
|
|
||||||
;; :path — route pattern (string)
|
|
||||||
;; :auth — "public" | "login" | "admin"
|
|
||||||
;; :layout — layout reference + kwargs
|
|
||||||
;; :stream — boolean, opt into chunked transfer
|
|
||||||
;; :shell — immediate content (contains ~suspense placeholders)
|
|
||||||
;; :fallback — loading skeleton for single-stream mode
|
|
||||||
;; :data — IO expression producing bindings
|
|
||||||
;; :content — template expression evaluated with data bindings
|
|
||||||
;; :filter, :aside, :menu — additional content slots
|
|
||||||
;;
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Data Protocol
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;;
|
|
||||||
;; The :data expression is evaluated at request time. It returns one of:
|
|
||||||
;;
|
|
||||||
;; 1. A dict — single-stream mode (default).
|
|
||||||
;; Each key becomes an env binding (underscores → hyphens).
|
|
||||||
;; Then :content is evaluated once with those bindings.
|
|
||||||
;; Result resolves the "stream-content" suspense slot.
|
|
||||||
;;
|
|
||||||
;; 2. A sequence of dicts — multi-stream mode.
|
|
||||||
;; The host delivers items over time (async generator, channel, etc.).
|
|
||||||
;; Each dict:
|
|
||||||
;; - MUST contain "stream-id" → string matching a ~suspense :id
|
|
||||||
;; - Remaining keys become env bindings (underscores → hyphens)
|
|
||||||
;; - :content is re-evaluated with those bindings
|
|
||||||
;; - Result resolves the ~suspense slot matching "stream-id"
|
|
||||||
;; If "stream-id" is absent, defaults to "stream-content".
|
|
||||||
;;
|
|
||||||
;; The host is free to choose the timing mechanism:
|
|
||||||
;; Python — async generator (yield dicts at intervals)
|
|
||||||
;; Go — channel of dicts
|
|
||||||
;; Haskell — conduit / streaming
|
|
||||||
;; JS — async iterator
|
|
||||||
;;
|
|
||||||
;; The spec requires:
|
|
||||||
;; (a) Each item's bindings are isolated (fresh env per item)
|
|
||||||
;; (b) :content is evaluated independently for each item
|
|
||||||
;; (c) Resolution is incremental — each item resolves as it arrives
|
|
||||||
;; (d) "stream-id" routes to the correct ~suspense slot
|
|
||||||
;;
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Streaming Execution Order
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;;
|
|
||||||
;; When :stream is true:
|
|
||||||
;;
|
|
||||||
;; 1. Evaluate :shell (if present) → HTML for immediate content slot
|
|
||||||
;; :shell typically contains ~suspense placeholders with :fallback
|
|
||||||
;; 2. Render HTML shell with suspense placeholders → send to client
|
|
||||||
;; 3. Start :data evaluation concurrently with header resolution
|
|
||||||
;; 4. As each data item arrives:
|
|
||||||
;; a. Bind item keys into fresh env
|
|
||||||
;; b. Evaluate :content with those bindings → SX wire format
|
|
||||||
;; c. Send resolve script: __sxResolve(stream-id, sx)
|
|
||||||
;; 5. Close response when all items + headers have resolved
|
|
||||||
;;
|
|
||||||
;; Non-streaming pages evaluate :data then :content sequentially and
|
|
||||||
;; return the complete page in a single response.
|
|
||||||
;;
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Spec helpers for multi-stream data protocol
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
;; Extract stream-id from a data chunk dict, defaulting to "stream-content"
|
|
||||||
(define stream-chunk-id
|
|
||||||
(fn ((chunk :as dict))
|
|
||||||
(if (has-key? chunk "stream-id")
|
|
||||||
(get chunk "stream-id")
|
|
||||||
"stream-content")))
|
|
||||||
|
|
||||||
;; Remove stream-id from chunk, returning only the bindings
|
|
||||||
(define stream-chunk-bindings
|
|
||||||
(fn ((chunk :as dict))
|
|
||||||
(dissoc chunk "stream-id")))
|
|
||||||
|
|
||||||
;; Normalize binding keys: underscore → hyphen
|
|
||||||
(define normalize-binding-key
|
|
||||||
(fn ((key :as string))
|
|
||||||
(replace key "_" "-")))
|
|
||||||
|
|
||||||
;; Bind a data chunk's keys into a fresh env (isolated per chunk)
|
|
||||||
(define bind-stream-chunk
|
|
||||||
(fn ((chunk :as dict) (base-env :as dict))
|
|
||||||
(let ((env (merge {} base-env))
|
|
||||||
(bindings (stream-chunk-bindings chunk)))
|
|
||||||
(for-each
|
|
||||||
(fn ((key :as string))
|
|
||||||
(env-set! env (normalize-binding-key key)
|
|
||||||
(get bindings key)))
|
|
||||||
(keys bindings))
|
|
||||||
env)))
|
|
||||||
|
|
||||||
;; Validate a multi-stream data result: must be a list of dicts
|
|
||||||
(define validate-stream-data
|
|
||||||
(fn (data)
|
|
||||||
(and (= (type-of data) "list")
|
|
||||||
(every? (fn (item) (= (type-of item) "dict")) data))))
|
|
||||||
File diff suppressed because it is too large
Load Diff
@@ -1,368 +0,0 @@
|
|||||||
;; ==========================================================================
|
|
||||||
;; page-helpers.sx — Pure data-transformation page helpers
|
|
||||||
;;
|
|
||||||
;; These functions take raw data (from Python I/O edge) and return
|
|
||||||
;; structured dicts for page rendering. No I/O — pure transformations
|
|
||||||
;; only. Bootstrapped to every host.
|
|
||||||
;; ==========================================================================
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; categorize-special-forms
|
|
||||||
;;
|
|
||||||
;; Parses define-special-form declarations from special-forms.sx AST,
|
|
||||||
;; categorizes each form by name lookup, returns dict of category → forms.
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define special-form-category-map
|
|
||||||
{"if" "Control Flow" "when" "Control Flow" "cond" "Control Flow"
|
|
||||||
"case" "Control Flow" "and" "Control Flow" "or" "Control Flow"
|
|
||||||
"let" "Binding" "let*" "Binding" "letrec" "Binding"
|
|
||||||
"define" "Binding" "set!" "Binding"
|
|
||||||
"lambda" "Functions & Components" "fn" "Functions & Components"
|
|
||||||
"defcomp" "Functions & Components" "defmacro" "Functions & Components"
|
|
||||||
"begin" "Sequencing & Threading" "do" "Sequencing & Threading"
|
|
||||||
"->" "Sequencing & Threading"
|
|
||||||
"quote" "Quoting" "quasiquote" "Quoting"
|
|
||||||
"reset" "Continuations" "shift" "Continuations"
|
|
||||||
"dynamic-wind" "Guards"
|
|
||||||
"map" "Higher-Order Forms" "map-indexed" "Higher-Order Forms"
|
|
||||||
"filter" "Higher-Order Forms" "reduce" "Higher-Order Forms"
|
|
||||||
"some" "Higher-Order Forms" "every?" "Higher-Order Forms"
|
|
||||||
"for-each" "Higher-Order Forms"
|
|
||||||
"defstyle" "Domain Definitions"
|
|
||||||
"defhandler" "Domain Definitions" "defpage" "Domain Definitions"
|
|
||||||
"defquery" "Domain Definitions" "defaction" "Domain Definitions"})
|
|
||||||
|
|
||||||
|
|
||||||
(define extract-define-kwargs
|
|
||||||
(fn ((expr :as list))
|
|
||||||
;; Extract keyword args from a define-special-form expression.
|
|
||||||
;; Returns dict of keyword-name → string value.
|
|
||||||
;; Walks items pairwise: when item[i] is a keyword, item[i+1] is its value.
|
|
||||||
(let ((result {})
|
|
||||||
(items (slice expr 2))
|
|
||||||
(n (len items)))
|
|
||||||
(for-each
|
|
||||||
(fn ((idx :as number))
|
|
||||||
(when (and (< (+ idx 1) n)
|
|
||||||
(= (type-of (nth items idx)) "keyword"))
|
|
||||||
(let ((key (keyword-name (nth items idx)))
|
|
||||||
(val (nth items (+ idx 1))))
|
|
||||||
(dict-set! result key
|
|
||||||
(if (= (type-of val) "list")
|
|
||||||
(str "(" (join " " (map serialize val)) ")")
|
|
||||||
(str val))))))
|
|
||||||
(range 0 n))
|
|
||||||
result)))
|
|
||||||
|
|
||||||
|
|
||||||
(define categorize-special-forms
|
|
||||||
(fn ((parsed-exprs :as list))
|
|
||||||
;; parsed-exprs: result of parse-all on special-forms.sx
|
|
||||||
;; Returns dict of category-name → list of form dicts.
|
|
||||||
(let ((categories {}))
|
|
||||||
(for-each
|
|
||||||
(fn (expr)
|
|
||||||
(when (and (= (type-of expr) "list")
|
|
||||||
(>= (len expr) 2)
|
|
||||||
(= (type-of (first expr)) "symbol")
|
|
||||||
(= (symbol-name (first expr)) "define-special-form"))
|
|
||||||
(let ((name (nth expr 1))
|
|
||||||
(kwargs (extract-define-kwargs expr))
|
|
||||||
(category (or (get special-form-category-map name) "Other")))
|
|
||||||
(when (not (has-key? categories category))
|
|
||||||
(dict-set! categories category (list)))
|
|
||||||
(append! (get categories category)
|
|
||||||
{"name" name
|
|
||||||
"syntax" (or (get kwargs "syntax") "")
|
|
||||||
"doc" (or (get kwargs "doc") "")
|
|
||||||
"tail-position" (or (get kwargs "tail-position") "")
|
|
||||||
"example" (or (get kwargs "example") "")}))))
|
|
||||||
parsed-exprs)
|
|
||||||
categories)))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; build-reference-data
|
|
||||||
;;
|
|
||||||
;; Takes a slug and raw reference data, returns structured dict for rendering.
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define build-ref-items-with-href
|
|
||||||
(fn ((items :as list) (base-path :as string) (detail-keys :as list) (n-fields :as number))
|
|
||||||
;; items: list of lists (tuples), each with n-fields elements
|
|
||||||
;; base-path: e.g. "/geography/hypermedia/reference/attributes/"
|
|
||||||
;; detail-keys: list of strings (keys that have detail pages)
|
|
||||||
;; n-fields: 2 or 3 (number of fields per tuple)
|
|
||||||
(map
|
|
||||||
(fn ((item :as list))
|
|
||||||
(if (= n-fields 3)
|
|
||||||
;; [name, desc/value, exists/desc]
|
|
||||||
(let ((name (nth item 0))
|
|
||||||
(field2 (nth item 1))
|
|
||||||
(field3 (nth item 2)))
|
|
||||||
{"name" name
|
|
||||||
"desc" field2
|
|
||||||
"exists" field3
|
|
||||||
"href" (if (and field3 (some (fn ((k :as string)) (= k name)) detail-keys))
|
|
||||||
(str base-path name)
|
|
||||||
nil)})
|
|
||||||
;; [name, desc]
|
|
||||||
(let ((name (nth item 0))
|
|
||||||
(desc (nth item 1)))
|
|
||||||
{"name" name
|
|
||||||
"desc" desc
|
|
||||||
"href" (if (some (fn ((k :as string)) (= k name)) detail-keys)
|
|
||||||
(str base-path name)
|
|
||||||
nil)})))
|
|
||||||
items)))
|
|
||||||
|
|
||||||
|
|
||||||
(define build-reference-data
|
|
||||||
(fn ((slug :as string) (raw-data :as dict) (detail-keys :as list))
|
|
||||||
;; slug: "attributes", "headers", "events", "js-api"
|
|
||||||
;; raw-data: dict with the raw data lists for this slug
|
|
||||||
;; detail-keys: list of names that have detail pages
|
|
||||||
(case slug
|
|
||||||
"attributes"
|
|
||||||
{"req-attrs" (build-ref-items-with-href
|
|
||||||
(get raw-data "req-attrs")
|
|
||||||
"/geography/hypermedia/reference/attributes/" detail-keys 3)
|
|
||||||
"beh-attrs" (build-ref-items-with-href
|
|
||||||
(get raw-data "beh-attrs")
|
|
||||||
"/geography/hypermedia/reference/attributes/" detail-keys 3)
|
|
||||||
"uniq-attrs" (build-ref-items-with-href
|
|
||||||
(get raw-data "uniq-attrs")
|
|
||||||
"/geography/hypermedia/reference/attributes/" detail-keys 3)}
|
|
||||||
|
|
||||||
"headers"
|
|
||||||
{"req-headers" (build-ref-items-with-href
|
|
||||||
(get raw-data "req-headers")
|
|
||||||
"/geography/hypermedia/reference/headers/" detail-keys 3)
|
|
||||||
"resp-headers" (build-ref-items-with-href
|
|
||||||
(get raw-data "resp-headers")
|
|
||||||
"/geography/hypermedia/reference/headers/" detail-keys 3)}
|
|
||||||
|
|
||||||
"events"
|
|
||||||
{"events-list" (build-ref-items-with-href
|
|
||||||
(get raw-data "events-list")
|
|
||||||
"/geography/hypermedia/reference/events/" detail-keys 2)}
|
|
||||||
|
|
||||||
"js-api"
|
|
||||||
{"js-api-list" (map (fn ((item :as list)) {"name" (nth item 0) "desc" (nth item 1)})
|
|
||||||
(get raw-data "js-api-list"))}
|
|
||||||
|
|
||||||
;; default: attributes
|
|
||||||
:else
|
|
||||||
{"req-attrs" (build-ref-items-with-href
|
|
||||||
(get raw-data "req-attrs")
|
|
||||||
"/geography/hypermedia/reference/attributes/" detail-keys 3)
|
|
||||||
"beh-attrs" (build-ref-items-with-href
|
|
||||||
(get raw-data "beh-attrs")
|
|
||||||
"/geography/hypermedia/reference/attributes/" detail-keys 3)
|
|
||||||
"uniq-attrs" (build-ref-items-with-href
|
|
||||||
(get raw-data "uniq-attrs")
|
|
||||||
"/geography/hypermedia/reference/attributes/" detail-keys 3)})))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; build-attr-detail / build-header-detail / build-event-detail
|
|
||||||
;;
|
|
||||||
;; Lookup a slug in a detail dict, reshape for page rendering.
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define build-attr-detail
|
|
||||||
(fn ((slug :as string) detail)
|
|
||||||
;; detail: dict with "description", "example", "handler", "demo" keys or nil
|
|
||||||
(if (nil? detail)
|
|
||||||
{"attr-not-found" true}
|
|
||||||
{"attr-not-found" nil
|
|
||||||
"attr-title" slug
|
|
||||||
"attr-description" (get detail "description")
|
|
||||||
"attr-example" (get detail "example")
|
|
||||||
"attr-handler" (get detail "handler")
|
|
||||||
"attr-demo" (get detail "demo")
|
|
||||||
"attr-wire-id" (if (has-key? detail "handler")
|
|
||||||
(str "ref-wire-"
|
|
||||||
(replace (replace slug ":" "-") "*" "star"))
|
|
||||||
nil)})))
|
|
||||||
|
|
||||||
|
|
||||||
(define build-header-detail
|
|
||||||
(fn ((slug :as string) detail)
|
|
||||||
(if (nil? detail)
|
|
||||||
{"header-not-found" true}
|
|
||||||
{"header-not-found" nil
|
|
||||||
"header-title" slug
|
|
||||||
"header-direction" (get detail "direction")
|
|
||||||
"header-description" (get detail "description")
|
|
||||||
"header-example" (get detail "example")
|
|
||||||
"header-demo" (get detail "demo")})))
|
|
||||||
|
|
||||||
|
|
||||||
(define build-event-detail
|
|
||||||
(fn ((slug :as string) detail)
|
|
||||||
(if (nil? detail)
|
|
||||||
{"event-not-found" true}
|
|
||||||
{"event-not-found" nil
|
|
||||||
"event-title" slug
|
|
||||||
"event-description" (get detail "description")
|
|
||||||
"event-example" (get detail "example")
|
|
||||||
"event-demo" (get detail "demo")})))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; build-component-source
|
|
||||||
;;
|
|
||||||
;; Reconstruct defcomp/defisland source from component metadata.
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define build-component-source
|
|
||||||
(fn ((comp-data :as dict))
|
|
||||||
;; comp-data: dict with "type", "name", "params", "has-children", "body-sx", "affinity"
|
|
||||||
(let ((comp-type (get comp-data "type"))
|
|
||||||
(name (get comp-data "name"))
|
|
||||||
(params (get comp-data "params"))
|
|
||||||
(has-children (get comp-data "has-children"))
|
|
||||||
(body-sx (get comp-data "body-sx"))
|
|
||||||
(affinity (get comp-data "affinity")))
|
|
||||||
(if (= comp-type "not-found")
|
|
||||||
(str ";; component " name " not found")
|
|
||||||
(let ((param-strs (if (empty? params)
|
|
||||||
(if has-children
|
|
||||||
(list "&rest" "children")
|
|
||||||
(list))
|
|
||||||
(if has-children
|
|
||||||
(append (cons "&key" params) (list "&rest" "children"))
|
|
||||||
(cons "&key" params))))
|
|
||||||
(params-sx (str "(" (join " " param-strs) ")"))
|
|
||||||
(form-name (if (= comp-type "island") "defisland" "defcomp"))
|
|
||||||
(affinity-str (if (and (= comp-type "component")
|
|
||||||
(not (nil? affinity))
|
|
||||||
(not (= affinity "auto")))
|
|
||||||
(str " :affinity " affinity)
|
|
||||||
"")))
|
|
||||||
(str "(" form-name " " name " " params-sx affinity-str "\n " body-sx ")"))))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; build-bundle-analysis
|
|
||||||
;;
|
|
||||||
;; Compute per-page bundle stats from pre-extracted component data.
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define build-bundle-analysis
|
|
||||||
(fn ((pages-raw :as list) (components-raw :as dict) (total-components :as number) (total-macros :as number) (pure-count :as number) (io-count :as number))
|
|
||||||
;; pages-raw: list of {:name :path :direct :needed-names}
|
|
||||||
;; components-raw: dict of name → {:is-pure :affinity :render-target :io-refs :deps :source}
|
|
||||||
(let ((pages-data (list)))
|
|
||||||
(for-each
|
|
||||||
(fn ((page :as dict))
|
|
||||||
(let ((needed-names (get page "needed-names"))
|
|
||||||
(n (len needed-names))
|
|
||||||
(pct (if (> total-components 0)
|
|
||||||
(round (* (/ n total-components) 100))
|
|
||||||
0))
|
|
||||||
(savings (- 100 pct))
|
|
||||||
(pure-in-page 0)
|
|
||||||
(io-in-page 0)
|
|
||||||
(page-io-refs (list))
|
|
||||||
(comp-details (list)))
|
|
||||||
;; Walk needed components
|
|
||||||
(for-each
|
|
||||||
(fn ((comp-name :as string))
|
|
||||||
(let ((info (get components-raw comp-name)))
|
|
||||||
(when (not (nil? info))
|
|
||||||
(if (get info "is-pure")
|
|
||||||
(set! pure-in-page (+ pure-in-page 1))
|
|
||||||
(do
|
|
||||||
(set! io-in-page (+ io-in-page 1))
|
|
||||||
(for-each
|
|
||||||
(fn ((ref :as string)) (when (not (some (fn ((r :as string)) (= r ref)) page-io-refs))
|
|
||||||
(append! page-io-refs ref)))
|
|
||||||
(or (get info "io-refs") (list)))))
|
|
||||||
(append! comp-details
|
|
||||||
{"name" comp-name
|
|
||||||
"is-pure" (get info "is-pure")
|
|
||||||
"affinity" (get info "affinity")
|
|
||||||
"render-target" (get info "render-target")
|
|
||||||
"io-refs" (or (get info "io-refs") (list))
|
|
||||||
"deps" (or (get info "deps") (list))
|
|
||||||
"source" (get info "source")}))))
|
|
||||||
needed-names)
|
|
||||||
(append! pages-data
|
|
||||||
{"name" (get page "name")
|
|
||||||
"path" (get page "path")
|
|
||||||
"direct" (get page "direct")
|
|
||||||
"needed" n
|
|
||||||
"pct" pct
|
|
||||||
"savings" savings
|
|
||||||
"io-refs" (len page-io-refs)
|
|
||||||
"pure-in-page" pure-in-page
|
|
||||||
"io-in-page" io-in-page
|
|
||||||
"components" comp-details})))
|
|
||||||
pages-raw)
|
|
||||||
{"pages" pages-data
|
|
||||||
"total-components" total-components
|
|
||||||
"total-macros" total-macros
|
|
||||||
"pure-count" pure-count
|
|
||||||
"io-count" io-count})))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; build-routing-analysis
|
|
||||||
;;
|
|
||||||
;; Classify pages by routing mode (client vs server).
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define build-routing-analysis
|
|
||||||
(fn ((pages-raw :as list))
|
|
||||||
;; pages-raw: list of {:name :path :has-data :content-src}
|
|
||||||
(let ((pages-data (list))
|
|
||||||
(client-count 0)
|
|
||||||
(server-count 0))
|
|
||||||
(for-each
|
|
||||||
(fn ((page :as dict))
|
|
||||||
(let ((has-data (get page "has-data"))
|
|
||||||
(content-src (or (get page "content-src") ""))
|
|
||||||
(mode nil)
|
|
||||||
(reason ""))
|
|
||||||
(cond
|
|
||||||
has-data
|
|
||||||
(do (set! mode "server")
|
|
||||||
(set! reason "Has :data expression — needs server IO")
|
|
||||||
(set! server-count (+ server-count 1)))
|
|
||||||
(empty? content-src)
|
|
||||||
(do (set! mode "server")
|
|
||||||
(set! reason "No content expression")
|
|
||||||
(set! server-count (+ server-count 1)))
|
|
||||||
:else
|
|
||||||
(do (set! mode "client")
|
|
||||||
(set! client-count (+ client-count 1))))
|
|
||||||
(append! pages-data
|
|
||||||
{"name" (get page "name")
|
|
||||||
"path" (get page "path")
|
|
||||||
"mode" mode
|
|
||||||
"has-data" has-data
|
|
||||||
"content-expr" (if (> (len content-src) 80)
|
|
||||||
(str (slice content-src 0 80) "...")
|
|
||||||
content-src)
|
|
||||||
"reason" reason})))
|
|
||||||
pages-raw)
|
|
||||||
{"pages" pages-data
|
|
||||||
"total-pages" (+ client-count server-count)
|
|
||||||
"client-count" client-count
|
|
||||||
"server-count" server-count})))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; build-affinity-analysis
|
|
||||||
;;
|
|
||||||
;; Package component affinity info + page render plans for display.
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define build-affinity-analysis
|
|
||||||
(fn ((demo-components :as list) (page-plans :as list))
|
|
||||||
{"components" demo-components
|
|
||||||
"page-plans" page-plans}))
|
|
||||||
@@ -1,680 +0,0 @@
|
|||||||
;; ==========================================================================
|
|
||||||
;; router.sx — Client-side route matching specification
|
|
||||||
;;
|
|
||||||
;; Pure functions for matching URL paths against Flask-style route patterns.
|
|
||||||
;; Used by client-side routing to determine if a page can be rendered
|
|
||||||
;; locally without a server roundtrip.
|
|
||||||
;;
|
|
||||||
;; All functions are pure — no IO, no platform-specific operations.
|
|
||||||
;; Uses only primitives from primitives.sx (string ops, list ops).
|
|
||||||
;; ==========================================================================
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 1. Split path into segments
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; "/docs/hello" → ("docs" "hello")
|
|
||||||
;; "/" → ()
|
|
||||||
;; "/docs/" → ("docs")
|
|
||||||
|
|
||||||
(define split-path-segments :effects []
|
|
||||||
(fn ((path :as string))
|
|
||||||
(let ((trimmed (if (starts-with? path "/") (slice path 1) path)))
|
|
||||||
(let ((trimmed2 (if (and (not (empty? trimmed))
|
|
||||||
(ends-with? trimmed "/"))
|
|
||||||
(slice trimmed 0 (- (len trimmed) 1))
|
|
||||||
trimmed)))
|
|
||||||
(if (empty? trimmed2)
|
|
||||||
(list)
|
|
||||||
(split trimmed2 "/"))))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 2. Parse Flask-style route pattern into segment descriptors
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; "/docs/<slug>" → ({"type" "literal" "value" "docs"}
|
|
||||||
;; {"type" "param" "value" "slug"})
|
|
||||||
|
|
||||||
(define make-route-segment :effects []
|
|
||||||
(fn ((seg :as string))
|
|
||||||
(if (and (starts-with? seg "<") (ends-with? seg ">"))
|
|
||||||
(let ((param-name (slice seg 1 (- (len seg) 1))))
|
|
||||||
(let ((d {}))
|
|
||||||
(dict-set! d "type" "param")
|
|
||||||
(dict-set! d "value" param-name)
|
|
||||||
d))
|
|
||||||
(let ((d {}))
|
|
||||||
(dict-set! d "type" "literal")
|
|
||||||
(dict-set! d "value" seg)
|
|
||||||
d))))
|
|
||||||
|
|
||||||
(define parse-route-pattern :effects []
|
|
||||||
(fn ((pattern :as string))
|
|
||||||
(let ((segments (split-path-segments pattern)))
|
|
||||||
(map make-route-segment segments))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 3. Match path segments against parsed pattern
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Returns params dict if match, nil if no match.
|
|
||||||
|
|
||||||
(define match-route-segments :effects []
|
|
||||||
(fn ((path-segs :as list) (parsed-segs :as list))
|
|
||||||
(if (not (= (len path-segs) (len parsed-segs)))
|
|
||||||
nil
|
|
||||||
(let ((params {})
|
|
||||||
(matched true))
|
|
||||||
(for-each-indexed
|
|
||||||
(fn ((i :as number) (parsed-seg :as dict))
|
|
||||||
(when matched
|
|
||||||
(let ((path-seg (nth path-segs i))
|
|
||||||
(seg-type (get parsed-seg "type")))
|
|
||||||
(cond
|
|
||||||
(= seg-type "literal")
|
|
||||||
(when (not (= path-seg (get parsed-seg "value")))
|
|
||||||
(set! matched false))
|
|
||||||
(= seg-type "param")
|
|
||||||
(dict-set! params (get parsed-seg "value") path-seg)
|
|
||||||
:else
|
|
||||||
(set! matched false)))))
|
|
||||||
parsed-segs)
|
|
||||||
(if matched params nil)))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 4. Public API: match a URL path against a pattern string
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Returns params dict (may be empty for exact matches) or nil.
|
|
||||||
|
|
||||||
(define match-route :effects []
|
|
||||||
(fn ((path :as string) (pattern :as string))
|
|
||||||
(let ((path-segs (split-path-segments path))
|
|
||||||
(parsed-segs (parse-route-pattern pattern)))
|
|
||||||
(match-route-segments path-segs parsed-segs))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 5. Search a list of route entries for first match
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Each entry: {"pattern" "/docs/<slug>" "parsed" [...] "name" "docs-page" ...}
|
|
||||||
;; Returns matching entry with "params" added, or nil.
|
|
||||||
|
|
||||||
(define find-matching-route :effects []
|
|
||||||
(fn ((path :as string) (routes :as list))
|
|
||||||
;; If path is an SX expression URL, convert to old-style for matching.
|
|
||||||
(let ((match-path (if (starts-with? path "/(")
|
|
||||||
(or (sx-url-to-path path) path)
|
|
||||||
path)))
|
|
||||||
(let ((path-segs (split-path-segments match-path))
|
|
||||||
(result nil))
|
|
||||||
(for-each
|
|
||||||
(fn ((route :as dict))
|
|
||||||
(when (nil? result)
|
|
||||||
(let ((params (match-route-segments path-segs (get route "parsed"))))
|
|
||||||
(when (not (nil? params))
|
|
||||||
(let ((matched (merge route {})))
|
|
||||||
(dict-set! matched "params" params)
|
|
||||||
(set! result matched))))))
|
|
||||||
routes)
|
|
||||||
result))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 6. SX expression URL → old-style path conversion
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Converts /(language.(doc.introduction)) → /language/docs/introduction
|
|
||||||
;; so client-side routing can match SX URLs against Flask-style patterns.
|
|
||||||
|
|
||||||
(define _fn-to-segment :effects []
|
|
||||||
(fn ((name :as string))
|
|
||||||
(case name
|
|
||||||
"doc" "docs"
|
|
||||||
"spec" "specs"
|
|
||||||
"bootstrapper" "bootstrappers"
|
|
||||||
"test" "testing"
|
|
||||||
"example" "examples"
|
|
||||||
"protocol" "protocols"
|
|
||||||
"essay" "essays"
|
|
||||||
"plan" "plans"
|
|
||||||
"reference-detail" "reference"
|
|
||||||
:else name)))
|
|
||||||
|
|
||||||
(define sx-url-to-path :effects []
|
|
||||||
(fn ((url :as string))
|
|
||||||
;; Convert an SX expression URL to an old-style slash path.
|
|
||||||
;; "/(language.(doc.introduction))" → "/language/docs/introduction"
|
|
||||||
;; Returns nil for non-SX URLs (those not starting with "/(" ).
|
|
||||||
(if (not (and (starts-with? url "/(") (ends-with? url ")")))
|
|
||||||
nil
|
|
||||||
(let ((inner (slice url 2 (- (len url) 1))))
|
|
||||||
;; "language.(doc.introduction)" → dots to slashes, strip parens
|
|
||||||
(let ((s (replace (replace (replace inner "." "/") "(" "") ")" "")))
|
|
||||||
;; "language/doc/introduction" → split, map names, rejoin
|
|
||||||
(let ((segs (filter (fn (s) (not (empty? s))) (split s "/"))))
|
|
||||||
(str "/" (join "/" (map _fn-to-segment segs)))))))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 7. Relative SX URL resolution
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Resolves relative SX URLs against the current absolute URL.
|
|
||||||
;; This is a macro in the deepest sense: SX transforming SX into SX.
|
|
||||||
;; The URL is code. Relative resolution is code transformation.
|
|
||||||
;;
|
|
||||||
;; Relative URLs start with ( or . :
|
|
||||||
;; (.slug) → append slug as argument to innermost call
|
|
||||||
;; (..section) → up 1: replace innermost with new nested call
|
|
||||||
;; (...section) → up 2: replace 2 innermost levels
|
|
||||||
;;
|
|
||||||
;; Bare-dot shorthand (parens optional):
|
|
||||||
;; .slug → same as (.slug)
|
|
||||||
;; .. → same as (..) — go up one level
|
|
||||||
;; ... → same as (...) — go up two levels
|
|
||||||
;; .:page.4 → same as (.:page.4) — set keyword
|
|
||||||
;;
|
|
||||||
;; Dot count semantics (parallels filesystem . and ..):
|
|
||||||
;; 1 dot = current level (append argument / modify keyword)
|
|
||||||
;; 2 dots = up 1 level (sibling call)
|
|
||||||
;; 3 dots = up 2 levels
|
|
||||||
;; N dots = up N-1 levels
|
|
||||||
;;
|
|
||||||
;; Keyword operations (set, delta):
|
|
||||||
;; (.:page.4) → set :page to 4 at current level
|
|
||||||
;; (.:page.+1) → increment :page by 1 (delta)
|
|
||||||
;; (.:page.-1) → decrement :page by 1 (delta)
|
|
||||||
;; (.slug.:page.1) → append slug AND set :page=1
|
|
||||||
;;
|
|
||||||
;; Examples (current = "/(geography.(hypermedia.(example)))"):
|
|
||||||
;; (.progress-bar) → /(geography.(hypermedia.(example.progress-bar)))
|
|
||||||
;; (..reactive.demo) → /(geography.(hypermedia.(reactive.demo)))
|
|
||||||
;; (...marshes) → /(geography.(marshes))
|
|
||||||
;; (..) → /(geography.(hypermedia))
|
|
||||||
;; (...) → /(geography)
|
|
||||||
;;
|
|
||||||
;; Keyword examples (current = "/(language.(spec.(explore.signals.:page.3)))"):
|
|
||||||
;; (.:page.4) → /(language.(spec.(explore.signals.:page.4)))
|
|
||||||
;; (.:page.+1) → /(language.(spec.(explore.signals.:page.4)))
|
|
||||||
;; (.:page.-1) → /(language.(spec.(explore.signals.:page.2)))
|
|
||||||
;; (..eval) → /(language.(spec.(eval)))
|
|
||||||
;; (..eval.:page.1) → /(language.(spec.(eval.:page.1)))
|
|
||||||
|
|
||||||
(define _count-leading-dots :effects []
|
|
||||||
(fn ((s :as string))
|
|
||||||
(if (empty? s)
|
|
||||||
0
|
|
||||||
(if (starts-with? s ".")
|
|
||||||
(+ 1 (_count-leading-dots (slice s 1)))
|
|
||||||
0))))
|
|
||||||
|
|
||||||
(define _strip-trailing-close :effects []
|
|
||||||
(fn ((s :as string))
|
|
||||||
;; Strip trailing ) characters: "/(a.(b.(c" from "/(a.(b.(c)))"
|
|
||||||
(if (ends-with? s ")")
|
|
||||||
(_strip-trailing-close (slice s 0 (- (len s) 1)))
|
|
||||||
s)))
|
|
||||||
|
|
||||||
(define _index-of-safe :effects []
|
|
||||||
(fn ((s :as string) (needle :as string))
|
|
||||||
;; Wrapper around index-of that normalizes -1 to nil.
|
|
||||||
;; (index-of returns -1 on some platforms, nil on others.)
|
|
||||||
(let ((idx (index-of s needle)))
|
|
||||||
(if (or (nil? idx) (< idx 0)) nil idx))))
|
|
||||||
|
|
||||||
(define _last-index-of :effects []
|
|
||||||
(fn ((s :as string) (needle :as string))
|
|
||||||
;; Find the last occurrence of needle in s. Returns nil if not found.
|
|
||||||
(let ((idx (_index-of-safe s needle)))
|
|
||||||
(if (nil? idx)
|
|
||||||
nil
|
|
||||||
(let ((rest-idx (_last-index-of (slice s (+ idx 1)) needle)))
|
|
||||||
(if (nil? rest-idx)
|
|
||||||
idx
|
|
||||||
(+ (+ idx 1) rest-idx)))))))
|
|
||||||
|
|
||||||
(define _pop-sx-url-level :effects []
|
|
||||||
(fn ((url :as string))
|
|
||||||
;; Remove the innermost nesting level from an absolute SX URL.
|
|
||||||
;; "/(a.(b.(c)))" → "/(a.(b))"
|
|
||||||
;; "/(a.(b))" → "/(a)"
|
|
||||||
;; "/(a)" → "/"
|
|
||||||
(let ((stripped (_strip-trailing-close url))
|
|
||||||
(close-count (- (len url) (len (_strip-trailing-close url)))))
|
|
||||||
(if (<= close-count 1)
|
|
||||||
"/" ;; at root, popping goes to bare root
|
|
||||||
(let ((last-dp (_last-index-of stripped ".(")))
|
|
||||||
(if (nil? last-dp)
|
|
||||||
"/" ;; single-level URL, pop to root
|
|
||||||
;; Remove from .( to end of stripped, drop one closing paren
|
|
||||||
(str (slice stripped 0 last-dp)
|
|
||||||
(slice url (- (len url) (- close-count 1))))))))))
|
|
||||||
|
|
||||||
(define _pop-sx-url-levels :effects []
|
|
||||||
(fn ((url :as string) (n :as number))
|
|
||||||
(if (<= n 0)
|
|
||||||
url
|
|
||||||
(_pop-sx-url-levels (_pop-sx-url-level url) (- n 1)))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 8. Relative URL body parsing — positional vs keyword tokens
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Body "slug.:page.4" → positional "slug", keywords ((:page 4))
|
|
||||||
;; Body ":page.+1" → positional "", keywords ((:page +1))
|
|
||||||
|
|
||||||
(define _split-pos-kw :effects []
|
|
||||||
(fn ((tokens :as list) (i :as number) (pos :as list) (kw :as list))
|
|
||||||
;; Walk tokens: non-: tokens are positional, : tokens consume next as value
|
|
||||||
(if (>= i (len tokens))
|
|
||||||
{"positional" (join "." pos) "keywords" kw}
|
|
||||||
(let ((tok (nth tokens i)))
|
|
||||||
(if (starts-with? tok ":")
|
|
||||||
;; Keyword: take this + next token as a pair
|
|
||||||
(let ((val (if (< (+ i 1) (len tokens))
|
|
||||||
(nth tokens (+ i 1))
|
|
||||||
"")))
|
|
||||||
(_split-pos-kw tokens (+ i 2) pos
|
|
||||||
(append kw (list (list tok val)))))
|
|
||||||
;; Positional token
|
|
||||||
(_split-pos-kw tokens (+ i 1)
|
|
||||||
(append pos (list tok))
|
|
||||||
kw))))))
|
|
||||||
|
|
||||||
(define _parse-relative-body :effects []
|
|
||||||
(fn ((body :as string))
|
|
||||||
;; Returns {"positional" <string> "keywords" <list of (kw val) pairs>}
|
|
||||||
(if (empty? body)
|
|
||||||
{"positional" "" "keywords" (list)}
|
|
||||||
(_split-pos-kw (split body ".") 0 (list) (list)))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 9. Keyword operations on URL expressions
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Extract, find, and modify keyword arguments in the innermost expression.
|
|
||||||
|
|
||||||
(define _extract-innermost :effects []
|
|
||||||
(fn ((url :as string))
|
|
||||||
;; Returns {"before" ... "content" ... "suffix" ...}
|
|
||||||
;; where before + content + suffix = url
|
|
||||||
;; content = the innermost expression's dot-separated tokens
|
|
||||||
(let ((stripped (_strip-trailing-close url))
|
|
||||||
(suffix (slice url (len (_strip-trailing-close url)))))
|
|
||||||
(let ((last-dp (_last-index-of stripped ".(")))
|
|
||||||
(if (nil? last-dp)
|
|
||||||
;; Single-level: /(content)
|
|
||||||
{"before" "/("
|
|
||||||
"content" (slice stripped 2)
|
|
||||||
"suffix" suffix}
|
|
||||||
;; Multi-level: .../.(content)...)
|
|
||||||
{"before" (slice stripped 0 (+ last-dp 2))
|
|
||||||
"content" (slice stripped (+ last-dp 2))
|
|
||||||
"suffix" suffix})))))
|
|
||||||
|
|
||||||
(define _find-kw-in-tokens :effects []
|
|
||||||
(fn ((tokens :as list) (i :as number) (kw :as string))
|
|
||||||
;; Find value of keyword kw in token list. Returns nil if not found.
|
|
||||||
(if (>= i (len tokens))
|
|
||||||
nil
|
|
||||||
(if (and (= (nth tokens i) kw)
|
|
||||||
(< (+ i 1) (len tokens)))
|
|
||||||
(nth tokens (+ i 1))
|
|
||||||
(_find-kw-in-tokens tokens (+ i 1) kw)))))
|
|
||||||
|
|
||||||
(define _find-keyword-value :effects []
|
|
||||||
(fn ((content :as string) (kw :as string))
|
|
||||||
;; Find keyword's value in dot-separated content string.
|
|
||||||
;; "explore.signals.:page.3" ":page" → "3"
|
|
||||||
(_find-kw-in-tokens (split content ".") 0 kw)))
|
|
||||||
|
|
||||||
(define _replace-kw-in-tokens :effects []
|
|
||||||
(fn ((tokens :as list) (i :as number) (kw :as string) (value :as string))
|
|
||||||
;; Replace keyword's value in token list. Returns new token list.
|
|
||||||
(if (>= i (len tokens))
|
|
||||||
(list)
|
|
||||||
(if (and (= (nth tokens i) kw)
|
|
||||||
(< (+ i 1) (len tokens)))
|
|
||||||
;; Found — keep keyword, replace value, concat rest
|
|
||||||
(append (list kw value)
|
|
||||||
(_replace-kw-in-tokens tokens (+ i 2) kw value))
|
|
||||||
;; Not this keyword — keep token, continue
|
|
||||||
(cons (nth tokens i)
|
|
||||||
(_replace-kw-in-tokens tokens (+ i 1) kw value))))))
|
|
||||||
|
|
||||||
(define _set-keyword-in-content :effects []
|
|
||||||
(fn ((content :as string) (kw :as string) (value :as string))
|
|
||||||
;; Set or replace keyword value in dot-separated content.
|
|
||||||
;; "a.b.:page.3" ":page" "4" → "a.b.:page.4"
|
|
||||||
;; "a.b" ":page" "1" → "a.b.:page.1"
|
|
||||||
(let ((current (_find-keyword-value content kw)))
|
|
||||||
(if (nil? current)
|
|
||||||
;; Not found — append
|
|
||||||
(str content "." kw "." value)
|
|
||||||
;; Found — replace
|
|
||||||
(join "." (_replace-kw-in-tokens (split content ".") 0 kw value))))))
|
|
||||||
|
|
||||||
(define _is-delta-value? :effects []
|
|
||||||
(fn ((s :as string))
|
|
||||||
;; "+1", "-2", "+10" are deltas. "-" alone is not.
|
|
||||||
(and (not (empty? s))
|
|
||||||
(> (len s) 1)
|
|
||||||
(or (starts-with? s "+") (starts-with? s "-")))))
|
|
||||||
|
|
||||||
(define _apply-delta :effects []
|
|
||||||
(fn ((current-str :as string) (delta-str :as string))
|
|
||||||
;; Apply numeric delta to current value string.
|
|
||||||
;; "3" "+1" → "4", "3" "-1" → "2"
|
|
||||||
(let ((cur (parse-int current-str nil))
|
|
||||||
(delta (parse-int delta-str nil)))
|
|
||||||
(if (or (nil? cur) (nil? delta))
|
|
||||||
delta-str ;; fallback: use delta as literal value
|
|
||||||
(str (+ cur delta))))))
|
|
||||||
|
|
||||||
(define _apply-kw-pairs :effects []
|
|
||||||
(fn ((content :as string) (kw-pairs :as list))
|
|
||||||
;; Apply keyword modifications to content, one at a time.
|
|
||||||
(if (empty? kw-pairs)
|
|
||||||
content
|
|
||||||
(let ((pair (first kw-pairs))
|
|
||||||
(kw (first pair))
|
|
||||||
(raw-val (nth pair 1)))
|
|
||||||
(let ((actual-val
|
|
||||||
(if (_is-delta-value? raw-val)
|
|
||||||
(let ((current (_find-keyword-value content kw)))
|
|
||||||
(if (nil? current)
|
|
||||||
raw-val ;; no current value, treat delta as literal
|
|
||||||
(_apply-delta current raw-val)))
|
|
||||||
raw-val)))
|
|
||||||
(_apply-kw-pairs
|
|
||||||
(_set-keyword-in-content content kw actual-val)
|
|
||||||
(rest kw-pairs)))))))
|
|
||||||
|
|
||||||
(define _apply-keywords-to-url :effects []
|
|
||||||
(fn ((url :as string) (kw-pairs :as list))
|
|
||||||
;; Apply keyword modifications to the innermost expression of a URL.
|
|
||||||
(if (empty? kw-pairs)
|
|
||||||
url
|
|
||||||
(let ((parts (_extract-innermost url)))
|
|
||||||
(let ((new-content (_apply-kw-pairs (get parts "content") kw-pairs)))
|
|
||||||
(str (get parts "before") new-content (get parts "suffix")))))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 10. Public API: resolve-relative-url (structural + keywords)
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define _normalize-relative :effects []
|
|
||||||
(fn ((url :as string))
|
|
||||||
;; Normalize bare-dot shorthand to paren form.
|
|
||||||
;; ".." → "(..)"
|
|
||||||
;; ".slug" → "(.slug)"
|
|
||||||
;; ".:page.4" → "(.:page.4)"
|
|
||||||
;; "(.slug)" → "(.slug)" (already canonical)
|
|
||||||
(if (starts-with? url "(")
|
|
||||||
url
|
|
||||||
(str "(" url ")"))))
|
|
||||||
|
|
||||||
(define resolve-relative-url :effects []
|
|
||||||
(fn ((current :as string) (relative :as string))
|
|
||||||
;; current: absolute SX URL "/(geography.(hypermedia.(example)))"
|
|
||||||
;; relative: relative SX URL "(.progress-bar)" or ".." or ".:page.+1"
|
|
||||||
;; Returns: absolute SX URL
|
|
||||||
(let ((canonical (_normalize-relative relative)))
|
|
||||||
(let ((rel-inner (slice canonical 1 (- (len canonical) 1))))
|
|
||||||
(let ((dots (_count-leading-dots rel-inner))
|
|
||||||
(body (slice rel-inner (_count-leading-dots rel-inner))))
|
|
||||||
(if (= dots 0)
|
|
||||||
current ;; no dots — not a relative URL
|
|
||||||
;; Parse body into positional part + keyword pairs
|
|
||||||
(let ((parsed (_parse-relative-body body))
|
|
||||||
(pos-body (get parsed "positional"))
|
|
||||||
(kw-pairs (get parsed "keywords")))
|
|
||||||
;; Step 1: structural navigation
|
|
||||||
(let ((after-nav
|
|
||||||
(if (= dots 1)
|
|
||||||
;; One dot = current level
|
|
||||||
(if (empty? pos-body)
|
|
||||||
current ;; no positional → stay here (keyword-only)
|
|
||||||
;; Append positional part at current level
|
|
||||||
(let ((stripped (_strip-trailing-close current))
|
|
||||||
(suffix (slice current (len (_strip-trailing-close current)))))
|
|
||||||
(str stripped "." pos-body suffix)))
|
|
||||||
;; Two+ dots = pop (dots-1) levels
|
|
||||||
(let ((base (_pop-sx-url-levels current (- dots 1))))
|
|
||||||
(if (empty? pos-body)
|
|
||||||
base ;; no positional → just pop (cd ..)
|
|
||||||
(if (= base "/")
|
|
||||||
(str "/(" pos-body ")")
|
|
||||||
(let ((stripped (_strip-trailing-close base))
|
|
||||||
(suffix (slice base (len (_strip-trailing-close base)))))
|
|
||||||
(str stripped ".(" pos-body ")" suffix))))))))
|
|
||||||
;; Step 2: apply keyword modifications
|
|
||||||
(_apply-keywords-to-url after-nav kw-pairs)))))))))
|
|
||||||
|
|
||||||
;; Check if a URL is relative (starts with ( but not /( , or starts with .)
|
|
||||||
(define relative-sx-url? :effects []
|
|
||||||
(fn ((url :as string))
|
|
||||||
(or (and (starts-with? url "(")
|
|
||||||
(not (starts-with? url "/(")))
|
|
||||||
(starts-with? url "."))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 11. URL special forms (! prefix)
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Special forms are meta-operations on URL expressions.
|
|
||||||
;; Distinguished by `!` prefix to avoid name collisions with sections/pages.
|
|
||||||
;;
|
|
||||||
;; Known forms:
|
|
||||||
;; !source — show defcomp source code
|
|
||||||
;; !inspect — deps, CSS footprint, render plan, IO
|
|
||||||
;; !diff — side-by-side comparison of two expressions
|
|
||||||
;; !search — grep within a page/spec
|
|
||||||
;; !raw — skip ~sx-doc wrapping, return raw content
|
|
||||||
;; !json — return content as JSON data
|
|
||||||
;;
|
|
||||||
;; URL examples:
|
|
||||||
;; /(!source.(~essay-sx-sucks))
|
|
||||||
;; /(!inspect.(language.(doc.primitives)))
|
|
||||||
;; /(!diff.(language.(spec.signals)).(language.(spec.eval)))
|
|
||||||
;; /(!search."define".:in.(language.(spec.signals)))
|
|
||||||
;; /(!raw.(~some-component))
|
|
||||||
;; /(!json.(language.(doc.primitives)))
|
|
||||||
|
|
||||||
(define _url-special-forms :effects []
|
|
||||||
(fn ()
|
|
||||||
;; Returns the set of known URL special form names.
|
|
||||||
(list "!source" "!inspect" "!diff" "!search" "!raw" "!json")))
|
|
||||||
|
|
||||||
(define url-special-form? :effects []
|
|
||||||
(fn ((name :as string))
|
|
||||||
;; Check if a name is a URL special form (starts with ! and is known).
|
|
||||||
(and (starts-with? name "!")
|
|
||||||
(contains? (_url-special-forms) name))))
|
|
||||||
|
|
||||||
(define parse-sx-url :effects []
|
|
||||||
(fn ((url :as string))
|
|
||||||
;; Parse an SX URL into a structured descriptor.
|
|
||||||
;; Returns a dict with:
|
|
||||||
;; "type" — "home" | "absolute" | "relative" | "special-form" | "direct-component"
|
|
||||||
;; "form" — special form name (for special-form type), e.g. "!source"
|
|
||||||
;; "inner" — inner URL expression string (without the special form wrapper)
|
|
||||||
;; "raw" — original URL string
|
|
||||||
;;
|
|
||||||
;; Examples:
|
|
||||||
;; "/" → {"type" "home" "raw" "/"}
|
|
||||||
;; "/(language.(doc.intro))" → {"type" "absolute" "raw" ...}
|
|
||||||
;; "(.slug)" → {"type" "relative" "raw" ...}
|
|
||||||
;; "..slug" → {"type" "relative" "raw" ...}
|
|
||||||
;; "/(!source.(~essay))" → {"type" "special-form" "form" "!source" "inner" "(~essay)" "raw" ...}
|
|
||||||
;; "/(~essay-sx-sucks)" → {"type" "direct-component" "name" "~essay-sx-sucks" "raw" ...}
|
|
||||||
(cond
|
|
||||||
(= url "/")
|
|
||||||
{"type" "home" "raw" url}
|
|
||||||
(relative-sx-url? url)
|
|
||||||
{"type" "relative" "raw" url}
|
|
||||||
(and (starts-with? url "/(!")
|
|
||||||
(ends-with? url ")"))
|
|
||||||
;; Special form: /(!source.(~essay)) or /(!diff.a.b)
|
|
||||||
;; Extract the form name (first dot-separated token after /()
|
|
||||||
(let ((inner (slice url 2 (- (len url) 1))))
|
|
||||||
;; inner = "!source.(~essay)" or "!diff.(a).(b)"
|
|
||||||
(let ((dot-pos (_index-of-safe inner "."))
|
|
||||||
(paren-pos (_index-of-safe inner "(")))
|
|
||||||
;; Form name ends at first . or ( (whichever comes first)
|
|
||||||
(let ((end-pos (cond
|
|
||||||
(and (nil? dot-pos) (nil? paren-pos)) (len inner)
|
|
||||||
(nil? dot-pos) paren-pos
|
|
||||||
(nil? paren-pos) dot-pos
|
|
||||||
:else (min dot-pos paren-pos))))
|
|
||||||
(let ((form-name (slice inner 0 end-pos))
|
|
||||||
(rest-part (slice inner end-pos)))
|
|
||||||
;; rest-part starts with "." → strip leading dot
|
|
||||||
(let ((inner-expr (if (starts-with? rest-part ".")
|
|
||||||
(slice rest-part 1)
|
|
||||||
rest-part)))
|
|
||||||
{"type" "special-form"
|
|
||||||
"form" form-name
|
|
||||||
"inner" inner-expr
|
|
||||||
"raw" url})))))
|
|
||||||
(and (starts-with? url "/(~")
|
|
||||||
(ends-with? url ")"))
|
|
||||||
;; Direct component: /(~essay-sx-sucks)
|
|
||||||
(let ((name (slice url 2 (- (len url) 1))))
|
|
||||||
{"type" "direct-component" "name" name "raw" url})
|
|
||||||
(and (starts-with? url "/(")
|
|
||||||
(ends-with? url ")"))
|
|
||||||
{"type" "absolute" "raw" url}
|
|
||||||
:else
|
|
||||||
{"type" "path" "raw" url})))
|
|
||||||
|
|
||||||
(define url-special-form-name :effects []
|
|
||||||
(fn ((url :as string))
|
|
||||||
;; Extract the special form name from a URL, or nil if not a special form.
|
|
||||||
;; "/(!source.(~essay))" → "!source"
|
|
||||||
;; "/(language.(doc))" → nil
|
|
||||||
(let ((parsed (parse-sx-url url)))
|
|
||||||
(if (= (get parsed "type") "special-form")
|
|
||||||
(get parsed "form")
|
|
||||||
nil))))
|
|
||||||
|
|
||||||
(define url-special-form-inner :effects []
|
|
||||||
(fn ((url :as string))
|
|
||||||
;; Extract the inner expression from a special form URL, or nil.
|
|
||||||
;; "/(!source.(~essay))" → "(~essay)"
|
|
||||||
;; "/(!diff.(a).(b))" → "(a).(b)"
|
|
||||||
(let ((parsed (parse-sx-url url)))
|
|
||||||
(if (= (get parsed "type") "special-form")
|
|
||||||
(get parsed "inner")
|
|
||||||
nil))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 12. URL expression evaluation
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; A URL is an expression. The system is the environment.
|
|
||||||
;; eval(url, env) — that's it.
|
|
||||||
;;
|
|
||||||
;; The only URL-specific pre-processing:
|
|
||||||
;; 1. Surface syntax → AST (dots to spaces, parse as SX)
|
|
||||||
;; 2. Auto-quote unknowns (symbols not in env become strings)
|
|
||||||
;;
|
|
||||||
;; After that, it's standard eval. The host wires these into its route
|
|
||||||
;; handlers (Python catch-all, JS client-side navigation). The same
|
|
||||||
;; functions serve both.
|
|
||||||
|
|
||||||
(define url-to-expr :effects []
|
|
||||||
(fn ((url-path :as string))
|
|
||||||
;; Convert a URL path to an SX expression (AST).
|
|
||||||
;;
|
|
||||||
;; "/sx/(language.(doc.introduction))" → (language (doc introduction))
|
|
||||||
;; "/(language.(doc.introduction))" → (language (doc introduction))
|
|
||||||
;; "/" → (list) ; empty — home
|
|
||||||
;;
|
|
||||||
;; Steps:
|
|
||||||
;; 1. Strip URL prefix ("/sx/" or "/") — host passes the path after prefix
|
|
||||||
;; 2. Dots → spaces (URL-safe whitespace encoding)
|
|
||||||
;; 3. Parse as SX expression
|
|
||||||
;;
|
|
||||||
;; The caller is responsible for stripping any app-level prefix.
|
|
||||||
;; This function receives the raw expression portion: "(language.(doc.intro))"
|
|
||||||
;; or "/" for home.
|
|
||||||
(if (or (= url-path "/") (empty? url-path))
|
|
||||||
(list)
|
|
||||||
(let ((trimmed (if (starts-with? url-path "/")
|
|
||||||
(slice url-path 1)
|
|
||||||
url-path)))
|
|
||||||
;; Dots → spaces
|
|
||||||
(let ((sx-source (replace trimmed "." " ")))
|
|
||||||
;; Parse — returns list of expressions, take the first
|
|
||||||
(let ((exprs (sx-parse sx-source)))
|
|
||||||
(if (empty? exprs)
|
|
||||||
(list)
|
|
||||||
(first exprs))))))))
|
|
||||||
|
|
||||||
|
|
||||||
(define auto-quote-unknowns :effects []
|
|
||||||
(fn ((expr :as list) (env :as dict))
|
|
||||||
;; Walk an AST and replace symbols not in env with their name as a string.
|
|
||||||
;; This makes URL slugs work without quoting:
|
|
||||||
;; (language (doc introduction)) ; introduction is not a function
|
|
||||||
;; → (language (doc "introduction"))
|
|
||||||
;;
|
|
||||||
;; Rules:
|
|
||||||
;; - List head (call position) stays as-is — it's a function name
|
|
||||||
;; - Tail symbols: if in env, keep as symbol; otherwise, string
|
|
||||||
;; - Keywords, strings, numbers, nested lists: pass through
|
|
||||||
;; - Non-list expressions: pass through unchanged
|
|
||||||
(if (not (list? expr))
|
|
||||||
expr
|
|
||||||
(if (empty? expr)
|
|
||||||
expr
|
|
||||||
;; Head stays as symbol (function position), quote the rest
|
|
||||||
(cons (first expr)
|
|
||||||
(map (fn (child)
|
|
||||||
(cond
|
|
||||||
;; Nested list — recurse
|
|
||||||
(list? child)
|
|
||||||
(auto-quote-unknowns child env)
|
|
||||||
;; Symbol — check env
|
|
||||||
(= (type-of child) "symbol")
|
|
||||||
(let ((name (symbol-name child)))
|
|
||||||
(if (or (env-has? env name)
|
|
||||||
;; Keep keywords, component refs, special forms
|
|
||||||
(starts-with? name ":")
|
|
||||||
(starts-with? name "~")
|
|
||||||
(starts-with? name "!"))
|
|
||||||
child
|
|
||||||
name)) ;; unknown → string
|
|
||||||
;; Everything else passes through
|
|
||||||
:else child))
|
|
||||||
(rest expr)))))))
|
|
||||||
|
|
||||||
|
|
||||||
(define prepare-url-expr :effects []
|
|
||||||
(fn ((url-path :as string) (env :as dict))
|
|
||||||
;; Full pipeline: URL path → ready-to-eval AST.
|
|
||||||
;;
|
|
||||||
;; "(language.(doc.introduction))" + env
|
|
||||||
;; → (language (doc "introduction"))
|
|
||||||
;;
|
|
||||||
;; The result can be fed directly to eval:
|
|
||||||
;; (eval (prepare-url-expr path env) env)
|
|
||||||
(let ((expr (url-to-expr url-path)))
|
|
||||||
(if (empty? expr)
|
|
||||||
expr
|
|
||||||
(auto-quote-unknowns expr env)))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Platform interface
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Pure primitives used:
|
|
||||||
;; split, slice, starts-with?, ends-with?, len, empty?, replace,
|
|
||||||
;; map, filter, for-each, for-each-indexed, nth, get, dict-set!, merge,
|
|
||||||
;; list, nil?, not, =, case, join, str, index-of, and, or, cons,
|
|
||||||
;; first, rest, append, parse-int, contains?, min, cond,
|
|
||||||
;; symbol?, symbol-name, list?, env-has?, type-of
|
|
||||||
;;
|
|
||||||
;; From parser.sx: sx-parse, sx-serialize
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
@@ -1,479 +0,0 @@
|
|||||||
;; ==========================================================================
|
|
||||||
;; signals.sx — Reactive signal runtime specification
|
|
||||||
;;
|
|
||||||
;; Defines the signal primitive: a container for a value that notifies
|
|
||||||
;; subscribers when it changes. Signals are the reactive state primitive
|
|
||||||
;; for SX islands.
|
|
||||||
;;
|
|
||||||
;; Signals are pure computation — no DOM, no IO. The reactive rendering
|
|
||||||
;; layer (adapter-dom.sx) subscribes DOM nodes to signals. The server
|
|
||||||
;; adapter (adapter-html.sx) reads signal values without subscribing.
|
|
||||||
;;
|
|
||||||
;; Signals are plain dicts with a "__signal" marker key. No platform
|
|
||||||
;; primitives needed — all signal operations are pure SX.
|
|
||||||
;;
|
|
||||||
;; Reactive tracking and island lifecycle use the general scoped effects
|
|
||||||
;; system (scope-push!/scope-pop!/context) instead of separate globals.
|
|
||||||
;; Two scope names:
|
|
||||||
;; "sx-reactive" — tracking context for computed/effect dep discovery
|
|
||||||
;; "sx-island-scope" — island disposable collector
|
|
||||||
;;
|
|
||||||
;; Scope-based tracking:
|
|
||||||
;; (scope-push! "sx-reactive" {:deps (list) :notify fn}) → void
|
|
||||||
;; (scope-pop! "sx-reactive") → void
|
|
||||||
;; (context "sx-reactive" nil) → dict or nil
|
|
||||||
;;
|
|
||||||
;; CEK callable dispatch:
|
|
||||||
;; (cek-call f args) → any — call f with args list via CEK.
|
|
||||||
;; Dispatches through cek-run for SX
|
|
||||||
;; lambdas, apply for native callables.
|
|
||||||
;; Defined in cek.sx.
|
|
||||||
;;
|
|
||||||
;; ==========================================================================
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Signal container — plain dict with marker key
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;;
|
|
||||||
;; A signal is a dict: {"__signal" true, "value" v, "subscribers" [], "deps" []}
|
|
||||||
;; type-of returns "dict". Use signal? to distinguish from regular dicts.
|
|
||||||
|
|
||||||
(define make-signal (fn (value)
|
|
||||||
(dict "__signal" true "value" value "subscribers" (list) "deps" (list))))
|
|
||||||
|
|
||||||
(define signal? (fn (x)
|
|
||||||
(and (dict? x) (has-key? x "__signal"))))
|
|
||||||
|
|
||||||
(define signal-value (fn (s) (get s "value")))
|
|
||||||
(define signal-set-value! (fn (s v) (dict-set! s "value" v)))
|
|
||||||
(define signal-subscribers (fn (s) (get s "subscribers")))
|
|
||||||
|
|
||||||
(define signal-add-sub! (fn (s f)
|
|
||||||
(when (not (contains? (get s "subscribers") f))
|
|
||||||
(append! (get s "subscribers") f))))
|
|
||||||
|
|
||||||
(define signal-remove-sub! (fn (s f)
|
|
||||||
(dict-set! s "subscribers"
|
|
||||||
(filter (fn (sub) (not (identical? sub f)))
|
|
||||||
(get s "subscribers")))))
|
|
||||||
|
|
||||||
(define signal-deps (fn (s) (get s "deps")))
|
|
||||||
(define signal-set-deps! (fn (s deps) (dict-set! s "deps" deps)))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 1. signal — create a reactive container
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define signal :effects []
|
|
||||||
(fn ((initial-value :as any))
|
|
||||||
(make-signal initial-value)))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 2. deref — read signal value, subscribe current reactive context
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;;
|
|
||||||
;; In a reactive context (inside effect or computed), deref registers the
|
|
||||||
;; signal as a dependency. Outside reactive context, deref just returns
|
|
||||||
;; the current value — no subscription, no overhead.
|
|
||||||
|
|
||||||
(define deref :effects []
|
|
||||||
(fn ((s :as any))
|
|
||||||
(if (not (signal? s))
|
|
||||||
s ;; non-signal values pass through
|
|
||||||
(let ((ctx (context "sx-reactive" nil)))
|
|
||||||
(when ctx
|
|
||||||
;; Register this signal as a dependency of the current context
|
|
||||||
(let ((dep-list (get ctx "deps"))
|
|
||||||
(notify-fn (get ctx "notify")))
|
|
||||||
(when (not (contains? dep-list s))
|
|
||||||
(append! dep-list s)
|
|
||||||
(signal-add-sub! s notify-fn))))
|
|
||||||
(signal-value s)))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 3. reset! — write a new value, notify subscribers
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define reset! :effects [mutation]
|
|
||||||
(fn ((s :as signal) value)
|
|
||||||
(when (signal? s)
|
|
||||||
(let ((old (signal-value s)))
|
|
||||||
(when (not (identical? old value))
|
|
||||||
(signal-set-value! s value)
|
|
||||||
(notify-subscribers s))))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 4. swap! — update signal via function
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(define swap! :effects [mutation]
|
|
||||||
(fn ((s :as signal) (f :as lambda) &rest args)
|
|
||||||
(when (signal? s)
|
|
||||||
(let ((old (signal-value s))
|
|
||||||
(new-val (apply f (cons old args))))
|
|
||||||
(when (not (identical? old new-val))
|
|
||||||
(signal-set-value! s new-val)
|
|
||||||
(notify-subscribers s))))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 5. computed — derived signal with automatic dependency tracking
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;;
|
|
||||||
;; A computed signal wraps a zero-arg function. It re-evaluates when any
|
|
||||||
;; of its dependencies change. The dependency set is discovered automatically
|
|
||||||
;; by tracking deref calls during evaluation.
|
|
||||||
|
|
||||||
(define computed :effects [mutation]
|
|
||||||
(fn ((compute-fn :as lambda))
|
|
||||||
(let ((s (make-signal nil))
|
|
||||||
(deps (list))
|
|
||||||
(compute-ctx nil))
|
|
||||||
|
|
||||||
;; The notify function — called when a dependency changes
|
|
||||||
(let ((recompute
|
|
||||||
(fn ()
|
|
||||||
;; Unsubscribe from old deps
|
|
||||||
(for-each
|
|
||||||
(fn ((dep :as signal)) (signal-remove-sub! dep recompute))
|
|
||||||
(signal-deps s))
|
|
||||||
(signal-set-deps! s (list))
|
|
||||||
|
|
||||||
;; Push scope-based tracking context for this computed
|
|
||||||
(let ((ctx (dict "deps" (list) "notify" recompute)))
|
|
||||||
(scope-push! "sx-reactive" ctx)
|
|
||||||
(let ((new-val (cek-call compute-fn nil)))
|
|
||||||
(scope-pop! "sx-reactive")
|
|
||||||
;; Save discovered deps
|
|
||||||
(signal-set-deps! s (get ctx "deps"))
|
|
||||||
;; Update value + notify downstream
|
|
||||||
(let ((old (signal-value s)))
|
|
||||||
(signal-set-value! s new-val)
|
|
||||||
(when (not (identical? old new-val))
|
|
||||||
(notify-subscribers s))))))))
|
|
||||||
|
|
||||||
;; Initial computation
|
|
||||||
(recompute)
|
|
||||||
;; Auto-register disposal with island scope
|
|
||||||
(register-in-scope (fn () (dispose-computed s)))
|
|
||||||
s))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 6. effect — side effect that runs when dependencies change
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;;
|
|
||||||
;; Like computed, but doesn't produce a signal value. Returns a dispose
|
|
||||||
;; function that tears down the effect.
|
|
||||||
|
|
||||||
(define effect :effects [mutation]
|
|
||||||
(fn ((effect-fn :as lambda))
|
|
||||||
(let ((deps (list))
|
|
||||||
(disposed false)
|
|
||||||
(cleanup-fn nil))
|
|
||||||
|
|
||||||
(let ((run-effect
|
|
||||||
(fn ()
|
|
||||||
(when (not disposed)
|
|
||||||
;; Run previous cleanup if any
|
|
||||||
(when cleanup-fn (cek-call cleanup-fn nil))
|
|
||||||
|
|
||||||
;; Unsubscribe from old deps
|
|
||||||
(for-each
|
|
||||||
(fn ((dep :as signal)) (signal-remove-sub! dep run-effect))
|
|
||||||
deps)
|
|
||||||
(set! deps (list))
|
|
||||||
|
|
||||||
;; Push scope-based tracking context
|
|
||||||
(let ((ctx (dict "deps" (list) "notify" run-effect)))
|
|
||||||
(scope-push! "sx-reactive" ctx)
|
|
||||||
(let ((result (cek-call effect-fn nil)))
|
|
||||||
(scope-pop! "sx-reactive")
|
|
||||||
(set! deps (get ctx "deps"))
|
|
||||||
;; If effect returns a function, it's the cleanup
|
|
||||||
(when (callable? result)
|
|
||||||
(set! cleanup-fn result))))))))
|
|
||||||
|
|
||||||
;; Initial run
|
|
||||||
(run-effect)
|
|
||||||
|
|
||||||
;; Return dispose function
|
|
||||||
(let ((dispose-fn
|
|
||||||
(fn ()
|
|
||||||
(set! disposed true)
|
|
||||||
(when cleanup-fn (cek-call cleanup-fn nil))
|
|
||||||
(for-each
|
|
||||||
(fn ((dep :as signal)) (signal-remove-sub! dep run-effect))
|
|
||||||
deps)
|
|
||||||
(set! deps (list)))))
|
|
||||||
;; Auto-register with island scope so disposal happens on swap
|
|
||||||
(register-in-scope dispose-fn)
|
|
||||||
dispose-fn)))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 7. batch — group multiple signal writes into one notification pass
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;;
|
|
||||||
;; During a batch, signal writes are deferred. Subscribers are notified
|
|
||||||
;; once at the end, after all values have been updated.
|
|
||||||
|
|
||||||
(define *batch-depth* 0)
|
|
||||||
(define *batch-queue* (list))
|
|
||||||
|
|
||||||
(define batch :effects [mutation]
|
|
||||||
(fn ((thunk :as lambda))
|
|
||||||
(set! *batch-depth* (+ *batch-depth* 1))
|
|
||||||
(cek-call thunk nil)
|
|
||||||
(set! *batch-depth* (- *batch-depth* 1))
|
|
||||||
(when (= *batch-depth* 0)
|
|
||||||
(let ((queue *batch-queue*))
|
|
||||||
(set! *batch-queue* (list))
|
|
||||||
;; Collect unique subscribers across all queued signals,
|
|
||||||
;; then notify each exactly once.
|
|
||||||
(let ((seen (list))
|
|
||||||
(pending (list)))
|
|
||||||
(for-each
|
|
||||||
(fn ((s :as signal))
|
|
||||||
(for-each
|
|
||||||
(fn ((sub :as lambda))
|
|
||||||
(when (not (contains? seen sub))
|
|
||||||
(append! seen sub)
|
|
||||||
(append! pending sub)))
|
|
||||||
(signal-subscribers s)))
|
|
||||||
queue)
|
|
||||||
(for-each (fn ((sub :as lambda)) (sub)) pending))))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 8. notify-subscribers — internal notification dispatch
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;;
|
|
||||||
;; If inside a batch, queues the signal. Otherwise, notifies immediately.
|
|
||||||
|
|
||||||
(define notify-subscribers :effects [mutation]
|
|
||||||
(fn ((s :as signal))
|
|
||||||
(if (> *batch-depth* 0)
|
|
||||||
(when (not (contains? *batch-queue* s))
|
|
||||||
(append! *batch-queue* s))
|
|
||||||
(flush-subscribers s))))
|
|
||||||
|
|
||||||
(define flush-subscribers :effects [mutation]
|
|
||||||
(fn ((s :as signal))
|
|
||||||
(for-each
|
|
||||||
(fn ((sub :as lambda)) (sub))
|
|
||||||
(signal-subscribers s))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 9. Reactive tracking context
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;;
|
|
||||||
;; Tracking is now scope-based. computed/effect push a dict
|
|
||||||
;; {:deps (list) :notify fn} onto the "sx-reactive" scope stack via
|
|
||||||
;; scope-push!/scope-pop!. deref reads it via (context "sx-reactive" nil).
|
|
||||||
;; No platform primitives needed — uses the existing scope infrastructure.
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 10. dispose — tear down a computed signal
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;;
|
|
||||||
;; For computed signals, unsubscribe from all dependencies.
|
|
||||||
;; For effects, the dispose function is returned by effect itself.
|
|
||||||
|
|
||||||
(define dispose-computed :effects [mutation]
|
|
||||||
(fn ((s :as signal))
|
|
||||||
(when (signal? s)
|
|
||||||
(for-each
|
|
||||||
(fn ((dep :as signal)) (signal-remove-sub! dep nil))
|
|
||||||
(signal-deps s))
|
|
||||||
(signal-set-deps! s (list)))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 11. Island scope — automatic cleanup of signals within an island
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;;
|
|
||||||
;; When an island is created, all signals, effects, and computeds created
|
|
||||||
;; within it are tracked. When the island is removed from the DOM, they
|
|
||||||
;; are all disposed.
|
|
||||||
;;
|
|
||||||
;; Uses "sx-island-scope" scope name. The scope value is a collector
|
|
||||||
;; function (fn (disposable) ...) that appends to the island's disposer list.
|
|
||||||
|
|
||||||
(define with-island-scope :effects [mutation]
|
|
||||||
(fn ((scope-fn :as lambda) (body-fn :as lambda))
|
|
||||||
(scope-push! "sx-island-scope" scope-fn)
|
|
||||||
(let ((result (body-fn)))
|
|
||||||
(scope-pop! "sx-island-scope")
|
|
||||||
result)))
|
|
||||||
|
|
||||||
;; Hook into signal/effect/computed creation for scope tracking.
|
|
||||||
|
|
||||||
(define register-in-scope :effects [mutation]
|
|
||||||
(fn ((disposable :as lambda))
|
|
||||||
(let ((collector (context "sx-island-scope" nil)))
|
|
||||||
(when collector
|
|
||||||
(cek-call collector (list disposable))))))
|
|
||||||
|
|
||||||
|
|
||||||
;; ==========================================================================
|
|
||||||
;; 12. Marsh scopes — child scopes within islands
|
|
||||||
;; ==========================================================================
|
|
||||||
;;
|
|
||||||
;; Marshes are zones inside islands where server content is re-evaluated
|
|
||||||
;; in the island's reactive context. When a marsh is re-morphed with new
|
|
||||||
;; content, its old effects and computeds must be disposed WITHOUT disturbing
|
|
||||||
;; the island's own reactive graph.
|
|
||||||
;;
|
|
||||||
;; Scope hierarchy: island → marsh → effects/computeds
|
|
||||||
;; Disposing a marsh disposes its subscope. Disposing an island disposes
|
|
||||||
;; all its marshes. The signal graph is a tree, not a flat list.
|
|
||||||
;;
|
|
||||||
;; Platform interface required:
|
|
||||||
;; (dom-set-data el key val) → void — store JS value on element
|
|
||||||
;; (dom-get-data el key) → any — retrieve stored value
|
|
||||||
|
|
||||||
(define with-marsh-scope :effects [mutation io]
|
|
||||||
(fn (marsh-el (body-fn :as lambda))
|
|
||||||
;; Execute body-fn collecting all disposables into a marsh-local list.
|
|
||||||
;; Nested under the current island scope — if the island is disposed,
|
|
||||||
;; the marsh is disposed too (because island scope collected the marsh's
|
|
||||||
;; own dispose function).
|
|
||||||
(let ((disposers (list)))
|
|
||||||
(with-island-scope
|
|
||||||
(fn (d) (append! disposers d))
|
|
||||||
body-fn)
|
|
||||||
;; Store disposers on the marsh element for later cleanup
|
|
||||||
(dom-set-data marsh-el "sx-marsh-disposers" disposers))))
|
|
||||||
|
|
||||||
(define dispose-marsh-scope :effects [mutation io]
|
|
||||||
(fn (marsh-el)
|
|
||||||
;; Dispose all effects/computeds registered in this marsh's scope.
|
|
||||||
;; Parent island scope and sibling marshes are unaffected.
|
|
||||||
(let ((disposers (dom-get-data marsh-el "sx-marsh-disposers")))
|
|
||||||
(when disposers
|
|
||||||
(for-each (fn ((d :as lambda)) (cek-call d nil)) disposers)
|
|
||||||
(dom-set-data marsh-el "sx-marsh-disposers" nil)))))
|
|
||||||
|
|
||||||
|
|
||||||
;; ==========================================================================
|
|
||||||
;; 13. Named stores — page-level signal containers (L3)
|
|
||||||
;; ==========================================================================
|
|
||||||
;;
|
|
||||||
;; Stores persist across island creation/destruction. They live at page
|
|
||||||
;; scope, not island scope. When an island is swapped out and re-created,
|
|
||||||
;; it reconnects to the same store instance.
|
|
||||||
;;
|
|
||||||
;; The store registry is global page-level state. It survives island
|
|
||||||
;; disposal but is cleared on full page navigation.
|
|
||||||
|
|
||||||
(define *store-registry* (dict))
|
|
||||||
|
|
||||||
(define def-store :effects [mutation]
|
|
||||||
(fn ((name :as string) (init-fn :as lambda))
|
|
||||||
(let ((registry *store-registry*))
|
|
||||||
;; Only create the store once — subsequent calls return existing
|
|
||||||
(when (not (has-key? registry name))
|
|
||||||
(set! *store-registry* (assoc registry name (cek-call init-fn nil))))
|
|
||||||
(get *store-registry* name))))
|
|
||||||
|
|
||||||
(define use-store :effects []
|
|
||||||
(fn ((name :as string))
|
|
||||||
(if (has-key? *store-registry* name)
|
|
||||||
(get *store-registry* name)
|
|
||||||
(error (str "Store not found: " name
|
|
||||||
". Call (def-store ...) before (use-store ...).")))))
|
|
||||||
|
|
||||||
(define clear-stores :effects [mutation]
|
|
||||||
(fn ()
|
|
||||||
(set! *store-registry* (dict))))
|
|
||||||
|
|
||||||
|
|
||||||
;; ==========================================================================
|
|
||||||
;; 13. Event bridge — DOM event communication for lake→island
|
|
||||||
;; ==========================================================================
|
|
||||||
;;
|
|
||||||
;; Server-rendered content ("htmx lakes") inside reactive islands can
|
|
||||||
;; communicate with island signals via DOM custom events. The bridge
|
|
||||||
;; pattern:
|
|
||||||
;;
|
|
||||||
;; 1. Server renders a button/link with data-sx-emit="event-name"
|
|
||||||
;; 2. When clicked, the client dispatches a CustomEvent on the element
|
|
||||||
;; 3. The event bubbles up to the island container
|
|
||||||
;; 4. An island effect listens for the event and updates signals
|
|
||||||
;;
|
|
||||||
;; This keeps server content pure HTML — no signal references needed.
|
|
||||||
;; The island effect is the only reactive code.
|
|
||||||
;;
|
|
||||||
;; Platform interface required:
|
|
||||||
;; (dom-listen el event-name handler) → remove-fn
|
|
||||||
;; (dom-dispatch el event-name detail) → void
|
|
||||||
;; (event-detail e) → any
|
|
||||||
;;
|
|
||||||
;; These are platform primitives because they require browser DOM APIs.
|
|
||||||
|
|
||||||
(define emit-event :effects [io]
|
|
||||||
(fn (el (event-name :as string) detail)
|
|
||||||
(dom-dispatch el event-name detail)))
|
|
||||||
|
|
||||||
(define on-event :effects [io]
|
|
||||||
(fn (el (event-name :as string) (handler :as lambda))
|
|
||||||
(dom-listen el event-name handler)))
|
|
||||||
|
|
||||||
;; Convenience: create an effect that listens for a DOM event on an
|
|
||||||
;; element and writes the event detail (or a transformed value) into
|
|
||||||
;; a target signal. Returns the effect's dispose function.
|
|
||||||
;; When the effect is disposed (island teardown), the listener is
|
|
||||||
;; removed automatically via the cleanup return.
|
|
||||||
|
|
||||||
(define bridge-event :effects [mutation io]
|
|
||||||
(fn (el (event-name :as string) (target-signal :as signal) transform-fn)
|
|
||||||
(effect (fn ()
|
|
||||||
(let ((remove (dom-listen el event-name
|
|
||||||
(fn (e)
|
|
||||||
(let ((detail (event-detail e))
|
|
||||||
(new-val (if transform-fn
|
|
||||||
(cek-call transform-fn (list detail))
|
|
||||||
detail)))
|
|
||||||
(reset! target-signal new-val))))))
|
|
||||||
;; Return cleanup — removes listener on dispose/re-run
|
|
||||||
remove)))))
|
|
||||||
|
|
||||||
|
|
||||||
;; ==========================================================================
|
|
||||||
;; 14. Resource — async signal with loading/resolved/error states
|
|
||||||
;; ==========================================================================
|
|
||||||
;;
|
|
||||||
;; A resource wraps an async operation (fetch, computation) and exposes
|
|
||||||
;; its state as a signal. The signal transitions through:
|
|
||||||
;; {:loading true :data nil :error nil} — initial/loading
|
|
||||||
;; {:loading false :data result :error nil} — success
|
|
||||||
;; {:loading false :data nil :error err} — failure
|
|
||||||
;;
|
|
||||||
;; Usage:
|
|
||||||
;; (let ((user (resource (fn () (fetch-json "/api/user")))))
|
|
||||||
;; (cond
|
|
||||||
;; (get (deref user) "loading") (div "Loading...")
|
|
||||||
;; (get (deref user) "error") (div "Error: " (get (deref user) "error"))
|
|
||||||
;; :else (div (get (deref user) "data"))))
|
|
||||||
;;
|
|
||||||
;; Platform interface required:
|
|
||||||
;; (promise-then promise on-resolve on-reject) → void
|
|
||||||
|
|
||||||
(define resource :effects [mutation io]
|
|
||||||
(fn ((fetch-fn :as lambda))
|
|
||||||
(let ((state (signal (dict "loading" true "data" nil "error" nil))))
|
|
||||||
;; Kick off the async operation
|
|
||||||
(promise-then (cek-call fetch-fn nil)
|
|
||||||
(fn (data) (reset! state (dict "loading" false "data" data "error" nil)))
|
|
||||||
(fn (err) (reset! state (dict "loading" false "data" nil "error" err))))
|
|
||||||
state)))
|
|
||||||
|
|
||||||
|
|
||||||
@@ -1,346 +0,0 @@
|
|||||||
;; ==========================================================================
|
|
||||||
;; test-aser.sx — Tests for the SX wire format (aser) adapter
|
|
||||||
;;
|
|
||||||
;; Requires: test-framework.sx loaded first.
|
|
||||||
;; Modules tested: adapter-sx.sx (aser, aser-call, aser-fragment, aser-special)
|
|
||||||
;;
|
|
||||||
;; Platform functions required (beyond test framework):
|
|
||||||
;; render-sx (sx-source) -> SX wire format string
|
|
||||||
;; Parses the sx-source string, evaluates via aser in a
|
|
||||||
;; fresh env, and returns the resulting SX wire format string.
|
|
||||||
;; ==========================================================================
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Basic serialization
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "aser-basics"
|
|
||||||
(deftest "number literal passes through"
|
|
||||||
(assert-equal "42"
|
|
||||||
(render-sx "42")))
|
|
||||||
|
|
||||||
(deftest "string literal passes through"
|
|
||||||
;; aser returns the raw string value; render-sx concatenates it directly
|
|
||||||
(assert-equal "hello"
|
|
||||||
(render-sx "\"hello\"")))
|
|
||||||
|
|
||||||
(deftest "boolean true passes through"
|
|
||||||
(assert-equal "true"
|
|
||||||
(render-sx "true")))
|
|
||||||
|
|
||||||
(deftest "boolean false passes through"
|
|
||||||
(assert-equal "false"
|
|
||||||
(render-sx "false")))
|
|
||||||
|
|
||||||
(deftest "nil produces empty"
|
|
||||||
(assert-equal ""
|
|
||||||
(render-sx "nil"))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; HTML tag serialization
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "aser-tags"
|
|
||||||
(deftest "simple div"
|
|
||||||
(assert-equal "(div \"hello\")"
|
|
||||||
(render-sx "(div \"hello\")")))
|
|
||||||
|
|
||||||
(deftest "nested tags"
|
|
||||||
(assert-equal "(div (span \"hi\"))"
|
|
||||||
(render-sx "(div (span \"hi\"))")))
|
|
||||||
|
|
||||||
(deftest "multiple children"
|
|
||||||
(assert-equal "(div (p \"a\") (p \"b\"))"
|
|
||||||
(render-sx "(div (p \"a\") (p \"b\"))")))
|
|
||||||
|
|
||||||
(deftest "attributes serialize"
|
|
||||||
(assert-equal "(div :class \"foo\" \"bar\")"
|
|
||||||
(render-sx "(div :class \"foo\" \"bar\")")))
|
|
||||||
|
|
||||||
(deftest "multiple attributes"
|
|
||||||
(assert-equal "(a :href \"/home\" :class \"link\" \"Home\")"
|
|
||||||
(render-sx "(a :href \"/home\" :class \"link\" \"Home\")")))
|
|
||||||
|
|
||||||
(deftest "void elements"
|
|
||||||
(assert-equal "(br)"
|
|
||||||
(render-sx "(br)")))
|
|
||||||
|
|
||||||
(deftest "void element with attrs"
|
|
||||||
(assert-equal "(img :src \"pic.jpg\")"
|
|
||||||
(render-sx "(img :src \"pic.jpg\")"))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Fragment serialization
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "aser-fragments"
|
|
||||||
(deftest "simple fragment"
|
|
||||||
(assert-equal "(<> (p \"a\") (p \"b\"))"
|
|
||||||
(render-sx "(<> (p \"a\") (p \"b\"))")))
|
|
||||||
|
|
||||||
(deftest "empty fragment"
|
|
||||||
(assert-equal ""
|
|
||||||
(render-sx "(<>)")))
|
|
||||||
|
|
||||||
(deftest "single-child fragment"
|
|
||||||
(assert-equal "(<> (div \"x\"))"
|
|
||||||
(render-sx "(<> (div \"x\"))"))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Control flow in aser mode
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "aser-control-flow"
|
|
||||||
(deftest "if true branch"
|
|
||||||
(assert-equal "(p \"yes\")"
|
|
||||||
(render-sx "(if true (p \"yes\") (p \"no\"))")))
|
|
||||||
|
|
||||||
(deftest "if false branch"
|
|
||||||
(assert-equal "(p \"no\")"
|
|
||||||
(render-sx "(if false (p \"yes\") (p \"no\"))")))
|
|
||||||
|
|
||||||
(deftest "when true"
|
|
||||||
(assert-equal "(p \"ok\")"
|
|
||||||
(render-sx "(when true (p \"ok\"))")))
|
|
||||||
|
|
||||||
(deftest "when false"
|
|
||||||
(assert-equal ""
|
|
||||||
(render-sx "(when false (p \"ok\"))")))
|
|
||||||
|
|
||||||
(deftest "cond serializes matching branch"
|
|
||||||
(assert-equal "(p \"two\")"
|
|
||||||
(render-sx "(cond false (p \"one\") true (p \"two\") :else (p \"three\"))")))
|
|
||||||
|
|
||||||
(deftest "cond with 2-element predicate test"
|
|
||||||
;; Regression: cond misclassifies (nil? x) as scheme-style clause.
|
|
||||||
(assert-equal "(p \"yes\")"
|
|
||||||
(render-sx "(cond (nil? nil) (p \"yes\") :else (p \"no\"))"))
|
|
||||||
(assert-equal "(p \"no\")"
|
|
||||||
(render-sx "(cond (nil? \"x\") (p \"yes\") :else (p \"no\"))")))
|
|
||||||
|
|
||||||
(deftest "let binds then serializes"
|
|
||||||
(assert-equal "(p \"hello\")"
|
|
||||||
(render-sx "(let ((x \"hello\")) (p x))")))
|
|
||||||
|
|
||||||
(deftest "let preserves outer scope bindings"
|
|
||||||
;; Regression: process-bindings must preserve parent env scope chain.
|
|
||||||
;; Using merge() instead of env-extend loses parent scope items.
|
|
||||||
(assert-equal "(p \"outer\")"
|
|
||||||
(render-sx "(do (define theme \"outer\") (let ((x 1)) (p theme)))")))
|
|
||||||
|
|
||||||
(deftest "nested let preserves outer scope"
|
|
||||||
(assert-equal "(div (span \"hello\") (span \"world\"))"
|
|
||||||
(render-sx "(do (define a \"hello\")
|
|
||||||
(define b \"world\")
|
|
||||||
(div (let ((x 1)) (span a))
|
|
||||||
(let ((y 2)) (span b))))")))
|
|
||||||
|
|
||||||
(deftest "begin serializes last"
|
|
||||||
(assert-equal "(p \"last\")"
|
|
||||||
(render-sx "(begin (p \"first\") (p \"last\"))"))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; THE BUG — map/filter list flattening in children (critical regression)
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "aser-list-flattening"
|
|
||||||
(deftest "map inside tag flattens children"
|
|
||||||
(assert-equal "(div (span \"a\") (span \"b\") (span \"c\"))"
|
|
||||||
(render-sx "(do (define items (list \"a\" \"b\" \"c\"))
|
|
||||||
(div (map (fn (x) (span x)) items)))")))
|
|
||||||
|
|
||||||
(deftest "map inside tag with other children"
|
|
||||||
(assert-equal "(ul (li \"first\") (li \"a\") (li \"b\"))"
|
|
||||||
(render-sx "(do (define items (list \"a\" \"b\"))
|
|
||||||
(ul (li \"first\") (map (fn (x) (li x)) items)))")))
|
|
||||||
|
|
||||||
(deftest "filter result via let binding as children"
|
|
||||||
;; Note: (filter ...) is treated as an SVG tag in aser dispatch (SVG has <filter>),
|
|
||||||
;; so we evaluate filter via let binding + map to serialize children
|
|
||||||
(assert-equal "(ul (li \"a\") (li \"b\"))"
|
|
||||||
(render-sx "(do (define items (list \"a\" nil \"b\"))
|
|
||||||
(define kept (filter (fn (x) (not (nil? x))) items))
|
|
||||||
(ul (map (fn (x) (li x)) kept)))")))
|
|
||||||
|
|
||||||
(deftest "map inside fragment flattens"
|
|
||||||
(assert-equal "(<> (p \"a\") (p \"b\"))"
|
|
||||||
(render-sx "(do (define items (list \"a\" \"b\"))
|
|
||||||
(<> (map (fn (x) (p x)) items)))")))
|
|
||||||
|
|
||||||
(deftest "nested map does not double-wrap"
|
|
||||||
(assert-equal "(div (span \"1\") (span \"2\"))"
|
|
||||||
(render-sx "(do (define nums (list 1 2))
|
|
||||||
(div (map (fn (n) (span (str n))) nums)))")))
|
|
||||||
|
|
||||||
(deftest "map with component-like output flattens"
|
|
||||||
(assert-equal "(div (li \"x\") (li \"y\"))"
|
|
||||||
(render-sx "(do (define items (list \"x\" \"y\"))
|
|
||||||
(div (map (fn (x) (li x)) items)))"))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Component serialization (NOT expanded in basic aser mode)
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "aser-components"
|
|
||||||
(deftest "unknown component serializes as-is"
|
|
||||||
(assert-equal "(~foo :title \"bar\")"
|
|
||||||
(render-sx "(~foo :title \"bar\")")))
|
|
||||||
|
|
||||||
(deftest "defcomp then unexpanded component call"
|
|
||||||
(assert-equal "(~card :title \"Hi\")"
|
|
||||||
(render-sx "(do (defcomp ~card (&key title) (h1 title)) (~card :title \"Hi\"))")))
|
|
||||||
|
|
||||||
(deftest "component with children serializes unexpanded"
|
|
||||||
(assert-equal "(~box (p \"inside\"))"
|
|
||||||
(render-sx "(do (defcomp ~box (&key &rest children) (div children))
|
|
||||||
(~box (p \"inside\")))"))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Definition forms in aser mode
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "aser-definitions"
|
|
||||||
(deftest "define evaluates for side effects, returns nil"
|
|
||||||
(assert-equal "(p 42)"
|
|
||||||
(render-sx "(do (define x 42) (p x))")))
|
|
||||||
|
|
||||||
(deftest "defcomp evaluates and returns nil"
|
|
||||||
(assert-equal "(~tag :x 1)"
|
|
||||||
(render-sx "(do (defcomp ~tag (&key x) (span x)) (~tag :x 1))")))
|
|
||||||
|
|
||||||
(deftest "defisland evaluates AND serializes"
|
|
||||||
(let ((result (render-sx "(defisland ~counter (&key count) (span count))")))
|
|
||||||
(assert-true (string-contains? result "defisland")))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Function calls in aser mode
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "aser-function-calls"
|
|
||||||
(deftest "named function call evaluates fully"
|
|
||||||
(assert-equal "3"
|
|
||||||
(render-sx "(do (define inc1 (fn (x) (+ x 1))) (inc1 2))")))
|
|
||||||
|
|
||||||
(deftest "define + call"
|
|
||||||
(assert-equal "10"
|
|
||||||
(render-sx "(do (define double (fn (x) (* x 2))) (double 5))")))
|
|
||||||
|
|
||||||
(deftest "native callable with multiple args"
|
|
||||||
;; Regression: async-aser-eval-call passed evaled-args list to
|
|
||||||
;; async-invoke (&rest), wrapping it in another list. apply(f, [list])
|
|
||||||
;; calls f(list) instead of f(*list).
|
|
||||||
(assert-equal "3"
|
|
||||||
(render-sx "(do (define my-add +) (my-add 1 2))")))
|
|
||||||
|
|
||||||
(deftest "native callable with two args via alias"
|
|
||||||
(assert-equal "hello world"
|
|
||||||
(render-sx "(do (define my-join str) (my-join \"hello\" \" world\"))")))
|
|
||||||
|
|
||||||
(deftest "higher-order: map returns list"
|
|
||||||
(let ((result (render-sx "(map (fn (x) (+ x 1)) (list 1 2 3))")))
|
|
||||||
;; map at top level returns a list, not serialized tags
|
|
||||||
(assert-true (not (nil? result))))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; and/or short-circuit in aser mode
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "aser-logic"
|
|
||||||
(deftest "and short-circuits on false"
|
|
||||||
(assert-equal "false"
|
|
||||||
(render-sx "(and true false true)")))
|
|
||||||
|
|
||||||
(deftest "and returns last truthy"
|
|
||||||
(assert-equal "3"
|
|
||||||
(render-sx "(and 1 2 3)")))
|
|
||||||
|
|
||||||
(deftest "or short-circuits on true"
|
|
||||||
(assert-equal "1"
|
|
||||||
(render-sx "(or 1 2 3)")))
|
|
||||||
|
|
||||||
(deftest "or returns last falsy"
|
|
||||||
(assert-equal "false"
|
|
||||||
(render-sx "(or false false)"))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Spread serialization
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "aser-spreads"
|
|
||||||
(deftest "spread in element merges attrs"
|
|
||||||
(assert-equal "(div :class \"card\" \"hello\")"
|
|
||||||
(render-sx "(div (make-spread {:class \"card\"}) \"hello\")")))
|
|
||||||
|
|
||||||
(deftest "multiple spreads merge into element"
|
|
||||||
(assert-equal "(div :class \"card\" :style \"color:red\" \"hello\")"
|
|
||||||
(render-sx "(div (make-spread {:class \"card\"}) (make-spread {:style \"color:red\"}) \"hello\")")))
|
|
||||||
|
|
||||||
(deftest "spread in fragment is silently dropped"
|
|
||||||
(assert-equal "(<> \"hello\")"
|
|
||||||
(render-sx "(<> (make-spread {:class \"card\"}) \"hello\")")))
|
|
||||||
|
|
||||||
(deftest "stored spread in let binding"
|
|
||||||
(assert-equal "(div :class \"card\" \"hello\")"
|
|
||||||
(render-sx "(let ((card (make-spread {:class \"card\"})))
|
|
||||||
(div card \"hello\"))")))
|
|
||||||
|
|
||||||
(deftest "spread in nested element"
|
|
||||||
(assert-equal "(div (span :class \"inner\" \"hi\"))"
|
|
||||||
(render-sx "(div (span (make-spread {:class \"inner\"}) \"hi\"))")))
|
|
||||||
|
|
||||||
(deftest "spread in non-element context silently drops"
|
|
||||||
(assert-equal "hello"
|
|
||||||
(render-sx "(do (make-spread {:class \"card\"}) \"hello\")"))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Scope tests — unified scope primitive
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "scope"
|
|
||||||
|
|
||||||
(deftest "scope with value and context"
|
|
||||||
(assert-equal "dark"
|
|
||||||
(render-sx "(scope \"sc-theme\" :value \"dark\" (context \"sc-theme\"))")))
|
|
||||||
|
|
||||||
(deftest "scope without value defaults to nil"
|
|
||||||
(assert-equal ""
|
|
||||||
(render-sx "(scope \"sc-nil\" (str (context \"sc-nil\")))")))
|
|
||||||
|
|
||||||
(deftest "scope with emit!/emitted"
|
|
||||||
(assert-equal "a,b"
|
|
||||||
(render-sx "(scope \"sc-emit\" (emit! \"sc-emit\" \"a\") (emit! \"sc-emit\" \"b\") (join \",\" (emitted \"sc-emit\")))")))
|
|
||||||
|
|
||||||
(deftest "provide is equivalent to scope with value"
|
|
||||||
(assert-equal "42"
|
|
||||||
(render-sx "(provide \"sc-prov\" 42 (str (context \"sc-prov\")))")))
|
|
||||||
|
|
||||||
(deftest "collect! works via scope (lazy root scope)"
|
|
||||||
(assert-equal "x,y"
|
|
||||||
(render-sx "(do (collect! \"sc-coll\" \"x\") (collect! \"sc-coll\" \"y\") (join \",\" (collected \"sc-coll\")))")))
|
|
||||||
|
|
||||||
(deftest "collect! deduplicates"
|
|
||||||
(assert-equal "a"
|
|
||||||
(render-sx "(do (collect! \"sc-dedup\" \"a\") (collect! \"sc-dedup\" \"a\") (join \",\" (collected \"sc-dedup\")))")))
|
|
||||||
|
|
||||||
(deftest "clear-collected! clears scope accumulator"
|
|
||||||
(assert-equal ""
|
|
||||||
(render-sx "(do (collect! \"sc-clear\" \"x\") (clear-collected! \"sc-clear\") (join \",\" (collected \"sc-clear\")))")))
|
|
||||||
|
|
||||||
(deftest "nested scope shadows outer"
|
|
||||||
(assert-equal "inner"
|
|
||||||
(render-sx "(scope \"sc-nest\" :value \"outer\" (scope \"sc-nest\" :value \"inner\" (context \"sc-nest\")))")))
|
|
||||||
|
|
||||||
(deftest "scope pops correctly after body"
|
|
||||||
(assert-equal "outer"
|
|
||||||
(render-sx "(scope \"sc-pop\" :value \"outer\" (scope \"sc-pop\" :value \"inner\" \"ignore\") (context \"sc-pop\"))"))))
|
|
||||||
@@ -1,279 +0,0 @@
|
|||||||
;; ==========================================================================
|
|
||||||
;; test-cek-reactive.sx — Tests for deref-as-shift reactive rendering
|
|
||||||
;;
|
|
||||||
;; Tests that (deref signal) inside a reactive-reset boundary performs
|
|
||||||
;; continuation capture: the rest of the expression becomes the subscriber.
|
|
||||||
;;
|
|
||||||
;; Requires: test-framework.sx, frames.sx, cek.sx, signals.sx loaded first.
|
|
||||||
;; ==========================================================================
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Basic deref behavior through CEK
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "deref pass-through"
|
|
||||||
(deftest "deref non-signal passes through"
|
|
||||||
(let ((result (eval-expr-cek
|
|
||||||
(sx-parse-one "(deref 42)")
|
|
||||||
(test-env))))
|
|
||||||
(assert-equal 42 result)))
|
|
||||||
|
|
||||||
(deftest "deref nil passes through"
|
|
||||||
(let ((result (eval-expr-cek
|
|
||||||
(sx-parse-one "(deref nil)")
|
|
||||||
(test-env))))
|
|
||||||
(assert-nil result)))
|
|
||||||
|
|
||||||
(deftest "deref string passes through"
|
|
||||||
(let ((result (eval-expr-cek
|
|
||||||
(sx-parse-one "(deref \"hello\")")
|
|
||||||
(test-env))))
|
|
||||||
(assert-equal "hello" result))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Deref signal without reactive-reset (no shift)
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "deref signal without reactive-reset"
|
|
||||||
(deftest "deref signal returns current value"
|
|
||||||
(let ((s (signal 99)))
|
|
||||||
(env-set! (test-env) "test-sig" s)
|
|
||||||
(let ((result (eval-expr-cek
|
|
||||||
(sx-parse-one "(deref test-sig)")
|
|
||||||
(test-env))))
|
|
||||||
(assert-equal 99 result))))
|
|
||||||
|
|
||||||
(deftest "deref signal in expression returns computed value"
|
|
||||||
(let ((s (signal 10)))
|
|
||||||
(env-set! (test-env) "test-sig" s)
|
|
||||||
(let ((result (eval-expr-cek
|
|
||||||
(sx-parse-one "(+ 5 (deref test-sig))")
|
|
||||||
(test-env))))
|
|
||||||
(assert-equal 15 result)))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Reactive reset + deref: continuation capture
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "reactive-reset shift"
|
|
||||||
(deftest "deref signal with reactive-reset captures continuation"
|
|
||||||
(let ((s (signal 42))
|
|
||||||
(captured-val nil))
|
|
||||||
;; Run CEK with a ReactiveResetFrame
|
|
||||||
(let ((result (cek-run
|
|
||||||
(make-cek-state
|
|
||||||
(sx-parse-one "(deref test-sig)")
|
|
||||||
(let ((e (env-extend (test-env))))
|
|
||||||
(env-set! e "test-sig" s)
|
|
||||||
e)
|
|
||||||
(list (make-reactive-reset-frame
|
|
||||||
(test-env)
|
|
||||||
(fn (v) (set! captured-val v))
|
|
||||||
true))))))
|
|
||||||
;; Initial render: returns current value, update-fn NOT called (first-render)
|
|
||||||
(assert-equal 42 result)
|
|
||||||
(assert-nil captured-val))))
|
|
||||||
|
|
||||||
(deftest "signal change invokes subscriber with update-fn"
|
|
||||||
(let ((s (signal 10))
|
|
||||||
(update-calls (list)))
|
|
||||||
;; Set up reactive-reset with tracking update-fn
|
|
||||||
(scope-push! "sx-island-scope" nil)
|
|
||||||
(let ((e (env-extend (test-env))))
|
|
||||||
(env-set! e "test-sig" s)
|
|
||||||
(cek-run
|
|
||||||
(make-cek-state
|
|
||||||
(sx-parse-one "(deref test-sig)")
|
|
||||||
e
|
|
||||||
(list (make-reactive-reset-frame
|
|
||||||
e
|
|
||||||
(fn (v) (append! update-calls v))
|
|
||||||
true)))))
|
|
||||||
;; Change signal — subscriber should fire
|
|
||||||
(reset! s 20)
|
|
||||||
(assert-equal 1 (len update-calls))
|
|
||||||
(assert-equal 20 (first update-calls))
|
|
||||||
;; Change again
|
|
||||||
(reset! s 30)
|
|
||||||
(assert-equal 2 (len update-calls))
|
|
||||||
(assert-equal 30 (nth update-calls 1))
|
|
||||||
(scope-pop! "sx-island-scope")))
|
|
||||||
|
|
||||||
(deftest "expression with deref captures rest as continuation"
|
|
||||||
(let ((s (signal 5))
|
|
||||||
(update-calls (list)))
|
|
||||||
(scope-push! "sx-island-scope" nil)
|
|
||||||
(let ((e (env-extend (test-env))))
|
|
||||||
(env-set! e "test-sig" s)
|
|
||||||
;; (str "val=" (deref test-sig)) — continuation captures (str "val=" [HOLE])
|
|
||||||
(let ((result (cek-run
|
|
||||||
(make-cek-state
|
|
||||||
(sx-parse-one "(str \"val=\" (deref test-sig))")
|
|
||||||
e
|
|
||||||
(list (make-reactive-reset-frame
|
|
||||||
e
|
|
||||||
(fn (v) (append! update-calls v))
|
|
||||||
true))))))
|
|
||||||
(assert-equal "val=5" result)))
|
|
||||||
;; Change signal — should get updated string
|
|
||||||
(reset! s 42)
|
|
||||||
(assert-equal 1 (len update-calls))
|
|
||||||
(assert-equal "val=42" (first update-calls))
|
|
||||||
(scope-pop! "sx-island-scope"))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Disposal and cleanup
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "disposal"
|
|
||||||
(deftest "scope cleanup unsubscribes continuation"
|
|
||||||
(let ((s (signal 1))
|
|
||||||
(update-calls (list))
|
|
||||||
(disposers (list)))
|
|
||||||
;; Create island scope with collector that accumulates disposers
|
|
||||||
(scope-push! "sx-island-scope" (fn (d) (append! disposers d)))
|
|
||||||
(let ((e (env-extend (test-env))))
|
|
||||||
(env-set! e "test-sig" s)
|
|
||||||
(cek-run
|
|
||||||
(make-cek-state
|
|
||||||
(sx-parse-one "(deref test-sig)")
|
|
||||||
e
|
|
||||||
(list (make-reactive-reset-frame
|
|
||||||
e
|
|
||||||
(fn (v) (append! update-calls v))
|
|
||||||
true)))))
|
|
||||||
;; Pop scope — call all disposers
|
|
||||||
(scope-pop! "sx-island-scope")
|
|
||||||
(for-each (fn (d) (cek-call d nil)) disposers)
|
|
||||||
;; Change signal — no update should fire
|
|
||||||
(reset! s 999)
|
|
||||||
(assert-equal 0 (len update-calls)))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; cek-call integration — computed/effect use cek-call dispatch
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "cek-call dispatch"
|
|
||||||
(deftest "cek-call invokes native function"
|
|
||||||
(let ((log (list)))
|
|
||||||
(cek-call (fn (x) (append! log x)) (list 42))
|
|
||||||
(assert-equal (list 42) log)))
|
|
||||||
|
|
||||||
(deftest "cek-call invokes zero-arg lambda"
|
|
||||||
(let ((result (cek-call (fn () (+ 1 2)) nil)))
|
|
||||||
(assert-equal 3 result)))
|
|
||||||
|
|
||||||
(deftest "cek-call with nil function returns nil"
|
|
||||||
(assert-nil (cek-call nil nil)))
|
|
||||||
|
|
||||||
(deftest "computed tracks deps via cek-call"
|
|
||||||
(let ((s (signal 10)))
|
|
||||||
(let ((c (computed (fn () (* 2 (deref s))))))
|
|
||||||
(assert-equal 20 (deref c))
|
|
||||||
(reset! s 5)
|
|
||||||
(assert-equal 10 (deref c)))))
|
|
||||||
|
|
||||||
(deftest "effect runs and re-runs via cek-call"
|
|
||||||
(let ((s (signal "a"))
|
|
||||||
(log (list)))
|
|
||||||
(effect (fn () (append! log (deref s))))
|
|
||||||
(assert-equal (list "a") log)
|
|
||||||
(reset! s "b")
|
|
||||||
(assert-equal (list "a" "b") log)))
|
|
||||||
|
|
||||||
(deftest "effect cleanup runs on re-trigger"
|
|
||||||
(let ((s (signal 0))
|
|
||||||
(log (list)))
|
|
||||||
(effect (fn ()
|
|
||||||
(let ((val (deref s)))
|
|
||||||
(append! log (str "run:" val))
|
|
||||||
;; Return cleanup function
|
|
||||||
(fn () (append! log (str "clean:" val))))))
|
|
||||||
(assert-equal (list "run:0") log)
|
|
||||||
(reset! s 1)
|
|
||||||
(assert-equal (list "run:0" "clean:0" "run:1") log)))
|
|
||||||
|
|
||||||
(deftest "batch coalesces via cek-call"
|
|
||||||
(let ((s (signal 0))
|
|
||||||
(count (signal 0)))
|
|
||||||
(effect (fn () (do (deref s) (swap! count inc))))
|
|
||||||
(assert-equal 1 (deref count))
|
|
||||||
(batch (fn ()
|
|
||||||
(reset! s 1)
|
|
||||||
(reset! s 2)
|
|
||||||
(reset! s 3)))
|
|
||||||
;; batch should coalesce — effect runs once, not three times
|
|
||||||
(assert-equal 2 (deref count)))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; CEK-native higher-order forms
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "CEK higher-order forms"
|
|
||||||
(deftest "map through CEK"
|
|
||||||
(let ((result (eval-expr-cek
|
|
||||||
(sx-parse-one "(map (fn (x) (* x 2)) (list 1 2 3))")
|
|
||||||
(test-env))))
|
|
||||||
(assert-equal (list 2 4 6) result)))
|
|
||||||
|
|
||||||
(deftest "map-indexed through CEK"
|
|
||||||
(let ((result (eval-expr-cek
|
|
||||||
(sx-parse-one "(map-indexed (fn (i x) (+ i x)) (list 10 20 30))")
|
|
||||||
(test-env))))
|
|
||||||
(assert-equal (list 10 21 32) result)))
|
|
||||||
|
|
||||||
(deftest "filter through CEK"
|
|
||||||
(let ((result (eval-expr-cek
|
|
||||||
(sx-parse-one "(filter (fn (x) (> x 2)) (list 1 2 3 4 5))")
|
|
||||||
(test-env))))
|
|
||||||
(assert-equal (list 3 4 5) result)))
|
|
||||||
|
|
||||||
(deftest "reduce through CEK"
|
|
||||||
(let ((result (eval-expr-cek
|
|
||||||
(sx-parse-one "(reduce (fn (acc x) (+ acc x)) 0 (list 1 2 3))")
|
|
||||||
(test-env))))
|
|
||||||
(assert-equal 6 result)))
|
|
||||||
|
|
||||||
(deftest "some through CEK"
|
|
||||||
(let ((result (eval-expr-cek
|
|
||||||
(sx-parse-one "(some (fn (x) (> x 3)) (list 1 2 3 4 5))")
|
|
||||||
(test-env))))
|
|
||||||
(assert-true result)))
|
|
||||||
|
|
||||||
(deftest "some returns false when none match"
|
|
||||||
(let ((result (eval-expr-cek
|
|
||||||
(sx-parse-one "(some (fn (x) (> x 10)) (list 1 2 3))")
|
|
||||||
(test-env))))
|
|
||||||
(assert-false result)))
|
|
||||||
|
|
||||||
(deftest "every? through CEK"
|
|
||||||
(let ((result (eval-expr-cek
|
|
||||||
(sx-parse-one "(every? (fn (x) (> x 0)) (list 1 2 3))")
|
|
||||||
(test-env))))
|
|
||||||
(assert-true result)))
|
|
||||||
|
|
||||||
(deftest "every? returns false on first falsy"
|
|
||||||
(let ((result (eval-expr-cek
|
|
||||||
(sx-parse-one "(every? (fn (x) (> x 2)) (list 1 2 3))")
|
|
||||||
(test-env))))
|
|
||||||
(assert-false result)))
|
|
||||||
|
|
||||||
(deftest "for-each through CEK"
|
|
||||||
(let ((log (list)))
|
|
||||||
(env-set! (test-env) "test-log" log)
|
|
||||||
(eval-expr-cek
|
|
||||||
(sx-parse-one "(for-each (fn (x) (append! test-log x)) (list 1 2 3))")
|
|
||||||
(test-env))
|
|
||||||
(assert-equal (list 1 2 3) log)))
|
|
||||||
|
|
||||||
(deftest "map on empty list"
|
|
||||||
(let ((result (eval-expr-cek
|
|
||||||
(sx-parse-one "(map (fn (x) x) (list))")
|
|
||||||
(test-env))))
|
|
||||||
(assert-equal (list) result))))
|
|
||||||
@@ -1,327 +0,0 @@
|
|||||||
;; ==========================================================================
|
|
||||||
;; test-deps.sx — Tests for component dependency analysis (deps.sx)
|
|
||||||
;;
|
|
||||||
;; Requires: test-framework.sx loaded first.
|
|
||||||
;; Platform functions: scan-refs, transitive-deps, components-needed,
|
|
||||||
;; component-pure?, scan-io-refs, transitive-io-refs,
|
|
||||||
;; scan-components-from-source, test-env
|
|
||||||
;; (loaded from bootstrapped output by test runners)
|
|
||||||
;; ==========================================================================
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Test component definitions — these exist in the test env for dep analysis
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defcomp ~dep-leaf ()
|
|
||||||
(span "leaf"))
|
|
||||||
|
|
||||||
(defcomp ~dep-branch ()
|
|
||||||
(div (~dep-leaf)))
|
|
||||||
|
|
||||||
(defcomp ~dep-trunk ()
|
|
||||||
(div (~dep-branch) (~dep-leaf)))
|
|
||||||
|
|
||||||
(defcomp ~dep-conditional (&key show?)
|
|
||||||
(if show?
|
|
||||||
(~dep-leaf)
|
|
||||||
(~dep-branch)))
|
|
||||||
|
|
||||||
(defcomp ~dep-nested-cond (&key mode)
|
|
||||||
(cond
|
|
||||||
(= mode "a") (~dep-leaf)
|
|
||||||
(= mode "b") (~dep-branch)
|
|
||||||
:else (~dep-trunk)))
|
|
||||||
|
|
||||||
(defcomp ~dep-island ()
|
|
||||||
(div "no deps"))
|
|
||||||
|
|
||||||
;; Islands with dependencies — defisland bodies must be scanned
|
|
||||||
(defisland ~dep-island-with-child ()
|
|
||||||
(div (~dep-leaf) "island content"))
|
|
||||||
|
|
||||||
(defisland ~dep-island-with-chain ()
|
|
||||||
(div (~dep-branch) "deep island"))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 1. scan-refs — finds component references in AST nodes
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "scan-refs"
|
|
||||||
|
|
||||||
(deftest "empty for string literal"
|
|
||||||
(assert-equal (list) (scan-refs "hello")))
|
|
||||||
|
|
||||||
(deftest "empty for number"
|
|
||||||
(assert-equal (list) (scan-refs 42)))
|
|
||||||
|
|
||||||
(deftest "finds component symbol"
|
|
||||||
(let ((refs (scan-refs (quote (~dep-leaf)))))
|
|
||||||
(assert-contains "~dep-leaf" refs)))
|
|
||||||
|
|
||||||
(deftest "finds in nested list"
|
|
||||||
(let ((refs (scan-refs (quote (div (span (~dep-leaf)))))))
|
|
||||||
(assert-contains "~dep-leaf" refs)))
|
|
||||||
|
|
||||||
(deftest "finds multiple refs"
|
|
||||||
(let ((refs (scan-refs (quote (div (~dep-leaf) (~dep-branch))))))
|
|
||||||
(assert-contains "~dep-leaf" refs)
|
|
||||||
(assert-contains "~dep-branch" refs)))
|
|
||||||
|
|
||||||
(deftest "deduplicates"
|
|
||||||
(let ((refs (scan-refs (quote (div (~dep-leaf) (~dep-leaf))))))
|
|
||||||
(assert-equal 1 (len refs))))
|
|
||||||
|
|
||||||
(deftest "walks if branches"
|
|
||||||
(let ((refs (scan-refs (quote (if true (~dep-leaf) (~dep-branch))))))
|
|
||||||
(assert-contains "~dep-leaf" refs)
|
|
||||||
(assert-contains "~dep-branch" refs)))
|
|
||||||
|
|
||||||
(deftest "walks cond branches"
|
|
||||||
(let ((refs (scan-refs (quote (cond (= x 1) (~dep-leaf) :else (~dep-trunk))))))
|
|
||||||
(assert-contains "~dep-leaf" refs)
|
|
||||||
(assert-contains "~dep-trunk" refs)))
|
|
||||||
|
|
||||||
(deftest "ignores non-component symbols"
|
|
||||||
(let ((refs (scan-refs (quote (div class "foo")))))
|
|
||||||
(assert-equal 0 (len refs)))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 2. scan-components-from-source — regex-based source string scanning
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "scan-components-from-source"
|
|
||||||
|
|
||||||
(deftest "finds single component"
|
|
||||||
(let ((refs (scan-components-from-source "(~dep-leaf)")))
|
|
||||||
(assert-contains "~dep-leaf" refs)))
|
|
||||||
|
|
||||||
(deftest "finds multiple components"
|
|
||||||
(let ((refs (scan-components-from-source "(div (~dep-leaf) (~dep-branch))")))
|
|
||||||
(assert-contains "~dep-leaf" refs)
|
|
||||||
(assert-contains "~dep-branch" refs)))
|
|
||||||
|
|
||||||
(deftest "no false positives on plain text"
|
|
||||||
(let ((refs (scan-components-from-source "(div \"hello world\")")))
|
|
||||||
(assert-equal 0 (len refs))))
|
|
||||||
|
|
||||||
(deftest "handles hyphenated names"
|
|
||||||
(let ((refs (scan-components-from-source "(~my-component :key val)")))
|
|
||||||
(assert-contains "~my-component" refs))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 3. transitive-deps — transitive dependency closure
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "transitive-deps"
|
|
||||||
|
|
||||||
(deftest "leaf has no deps"
|
|
||||||
(let ((deps (transitive-deps "~dep-leaf" (test-env))))
|
|
||||||
(assert-equal 0 (len deps))))
|
|
||||||
|
|
||||||
(deftest "direct dependency"
|
|
||||||
(let ((deps (transitive-deps "~dep-branch" (test-env))))
|
|
||||||
(assert-contains "~dep-leaf" deps)))
|
|
||||||
|
|
||||||
(deftest "transitive closure"
|
|
||||||
(let ((deps (transitive-deps "~dep-trunk" (test-env))))
|
|
||||||
(assert-contains "~dep-branch" deps)
|
|
||||||
(assert-contains "~dep-leaf" deps)))
|
|
||||||
|
|
||||||
(deftest "excludes self"
|
|
||||||
(let ((deps (transitive-deps "~dep-trunk" (test-env))))
|
|
||||||
(assert-false (contains? deps "~dep-trunk"))))
|
|
||||||
|
|
||||||
(deftest "walks conditional branches"
|
|
||||||
(let ((deps (transitive-deps "~dep-conditional" (test-env))))
|
|
||||||
(assert-contains "~dep-leaf" deps)
|
|
||||||
(assert-contains "~dep-branch" deps)))
|
|
||||||
|
|
||||||
(deftest "walks all cond branches"
|
|
||||||
(let ((deps (transitive-deps "~dep-nested-cond" (test-env))))
|
|
||||||
(assert-contains "~dep-leaf" deps)
|
|
||||||
(assert-contains "~dep-branch" deps)
|
|
||||||
(assert-contains "~dep-trunk" deps)))
|
|
||||||
|
|
||||||
(deftest "island has no deps"
|
|
||||||
(let ((deps (transitive-deps "~dep-island" (test-env))))
|
|
||||||
(assert-equal 0 (len deps))))
|
|
||||||
|
|
||||||
(deftest "accepts name without tilde"
|
|
||||||
(let ((deps (transitive-deps "dep-branch" (test-env))))
|
|
||||||
(assert-contains "~dep-leaf" deps)))
|
|
||||||
|
|
||||||
(deftest "island direct dep scanned"
|
|
||||||
(let ((deps (transitive-deps "~dep-island-with-child" (test-env))))
|
|
||||||
(assert-contains "~dep-leaf" deps)))
|
|
||||||
|
|
||||||
(deftest "island transitive deps scanned"
|
|
||||||
(let ((deps (transitive-deps "~dep-island-with-chain" (test-env))))
|
|
||||||
(assert-contains "~dep-branch" deps)
|
|
||||||
(assert-contains "~dep-leaf" deps))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 4. components-needed — page bundle computation
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "components-needed"
|
|
||||||
|
|
||||||
(deftest "finds direct and transitive"
|
|
||||||
(let ((needed (components-needed "(~dep-trunk)" (test-env))))
|
|
||||||
(assert-contains "~dep-trunk" needed)
|
|
||||||
(assert-contains "~dep-branch" needed)
|
|
||||||
(assert-contains "~dep-leaf" needed)))
|
|
||||||
|
|
||||||
(deftest "deduplicates"
|
|
||||||
(let ((needed (components-needed "(div (~dep-leaf) (~dep-leaf))" (test-env))))
|
|
||||||
;; ~dep-leaf should appear only once
|
|
||||||
(assert-true (contains? needed "~dep-leaf"))))
|
|
||||||
|
|
||||||
(deftest "handles leaf page"
|
|
||||||
(let ((needed (components-needed "(~dep-island)" (test-env))))
|
|
||||||
(assert-contains "~dep-island" needed)
|
|
||||||
(assert-equal 1 (len needed))))
|
|
||||||
|
|
||||||
(deftest "handles multiple top-level components"
|
|
||||||
(let ((needed (components-needed "(div (~dep-leaf) (~dep-island))" (test-env))))
|
|
||||||
(assert-contains "~dep-leaf" needed)
|
|
||||||
(assert-contains "~dep-island" needed)))
|
|
||||||
|
|
||||||
(deftest "island deps included in page bundle"
|
|
||||||
(let ((needed (components-needed "(~dep-island-with-chain)" (test-env))))
|
|
||||||
(assert-contains "~dep-island-with-chain" needed)
|
|
||||||
(assert-contains "~dep-branch" needed)
|
|
||||||
(assert-contains "~dep-leaf" needed))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 5. IO detection — scan-io-refs, component-pure?
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
;; Define components that reference "io" functions for testing
|
|
||||||
(defcomp ~dep-pure ()
|
|
||||||
(div (~dep-leaf) "static"))
|
|
||||||
|
|
||||||
(defcomp ~dep-io ()
|
|
||||||
(div (fetch-data "/api")))
|
|
||||||
|
|
||||||
(defcomp ~dep-io-indirect ()
|
|
||||||
(div (~dep-io)))
|
|
||||||
|
|
||||||
(defsuite "scan-io-refs"
|
|
||||||
|
|
||||||
(deftest "no IO in pure AST"
|
|
||||||
(let ((refs (scan-io-refs (quote (div "hello" (span "world"))) (list "fetch-data"))))
|
|
||||||
(assert-equal 0 (len refs))))
|
|
||||||
|
|
||||||
(deftest "finds IO reference"
|
|
||||||
(let ((refs (scan-io-refs (quote (div (fetch-data "/api"))) (list "fetch-data"))))
|
|
||||||
(assert-contains "fetch-data" refs)))
|
|
||||||
|
|
||||||
(deftest "multiple IO refs"
|
|
||||||
(let ((refs (scan-io-refs (quote (div (fetch-data "/a") (query-db "x"))) (list "fetch-data" "query-db"))))
|
|
||||||
(assert-contains "fetch-data" refs)
|
|
||||||
(assert-contains "query-db" refs)))
|
|
||||||
|
|
||||||
(deftest "ignores non-IO symbols"
|
|
||||||
(let ((refs (scan-io-refs (quote (div (map str items))) (list "fetch-data"))))
|
|
||||||
(assert-equal 0 (len refs)))))
|
|
||||||
|
|
||||||
|
|
||||||
(defsuite "component-pure?"
|
|
||||||
|
|
||||||
(deftest "pure component is pure"
|
|
||||||
(assert-true (component-pure? "~dep-pure" (test-env) (list "fetch-data"))))
|
|
||||||
|
|
||||||
(deftest "IO component is not pure"
|
|
||||||
(assert-false (component-pure? "~dep-io" (test-env) (list "fetch-data"))))
|
|
||||||
|
|
||||||
(deftest "indirect IO is not pure"
|
|
||||||
(assert-false (component-pure? "~dep-io-indirect" (test-env) (list "fetch-data"))))
|
|
||||||
|
|
||||||
(deftest "leaf component is pure"
|
|
||||||
(assert-true (component-pure? "~dep-leaf" (test-env) (list "fetch-data")))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 6. render-target — boundary decision with affinity
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
;; Components with explicit affinity annotations
|
|
||||||
(defcomp ~dep-force-client (&key x)
|
|
||||||
:affinity :client
|
|
||||||
(div (fetch-data "/api") x))
|
|
||||||
|
|
||||||
(defcomp ~dep-force-server (&key x)
|
|
||||||
:affinity :server
|
|
||||||
(div x))
|
|
||||||
|
|
||||||
(defcomp ~dep-auto-pure (&key x)
|
|
||||||
(div x))
|
|
||||||
|
|
||||||
(defcomp ~dep-auto-io (&key x)
|
|
||||||
(div (fetch-data "/api")))
|
|
||||||
|
|
||||||
(defsuite "render-target"
|
|
||||||
|
|
||||||
(deftest "pure auto component targets client"
|
|
||||||
(assert-equal "client" (render-target "~dep-auto-pure" (test-env) (list "fetch-data"))))
|
|
||||||
|
|
||||||
(deftest "IO auto component targets server"
|
|
||||||
(assert-equal "server" (render-target "~dep-auto-io" (test-env) (list "fetch-data"))))
|
|
||||||
|
|
||||||
(deftest "affinity client overrides IO to client"
|
|
||||||
(assert-equal "client" (render-target "~dep-force-client" (test-env) (list "fetch-data"))))
|
|
||||||
|
|
||||||
(deftest "affinity server overrides pure to server"
|
|
||||||
(assert-equal "server" (render-target "~dep-force-server" (test-env) (list "fetch-data"))))
|
|
||||||
|
|
||||||
(deftest "leaf component targets client"
|
|
||||||
(assert-equal "client" (render-target "~dep-leaf" (test-env) (list "fetch-data"))))
|
|
||||||
|
|
||||||
(deftest "unknown name targets server"
|
|
||||||
(assert-equal "server" (render-target "~nonexistent" (test-env) (list "fetch-data")))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 7. page-render-plan — per-page boundary plan
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
;; A page component that uses both pure and IO components
|
|
||||||
(defcomp ~plan-page (&key data)
|
|
||||||
(div
|
|
||||||
(~dep-auto-pure :x "hello")
|
|
||||||
(~dep-auto-io :x data)
|
|
||||||
(~dep-force-client :x "interactive")))
|
|
||||||
|
|
||||||
(defsuite "page-render-plan"
|
|
||||||
|
|
||||||
(deftest "plan classifies components correctly"
|
|
||||||
(let ((plan (page-render-plan "(~plan-page :data d)" (test-env) (list "fetch-data"))))
|
|
||||||
;; ~plan-page has transitive IO deps (via ~dep-auto-io) so targets server
|
|
||||||
(assert-equal "server" (dict-get (get plan :components) "~plan-page"))
|
|
||||||
(assert-equal "client" (dict-get (get plan :components) "~dep-auto-pure"))
|
|
||||||
(assert-equal "server" (dict-get (get plan :components) "~dep-auto-io"))
|
|
||||||
(assert-equal "client" (dict-get (get plan :components) "~dep-force-client"))))
|
|
||||||
|
|
||||||
(deftest "plan server list contains IO components"
|
|
||||||
(let ((plan (page-render-plan "(~plan-page :data d)" (test-env) (list "fetch-data"))))
|
|
||||||
(assert-true (contains? (get plan :server) "~dep-auto-io"))))
|
|
||||||
|
|
||||||
(deftest "plan client list contains pure components"
|
|
||||||
(let ((plan (page-render-plan "(~plan-page :data d)" (test-env) (list "fetch-data"))))
|
|
||||||
(assert-true (contains? (get plan :client) "~dep-auto-pure"))
|
|
||||||
(assert-true (contains? (get plan :client) "~dep-force-client"))))
|
|
||||||
|
|
||||||
(deftest "plan collects IO deps from server components"
|
|
||||||
(let ((plan (page-render-plan "(~plan-page :data d)" (test-env) (list "fetch-data"))))
|
|
||||||
(assert-true (contains? (get plan :io-deps) "fetch-data"))))
|
|
||||||
|
|
||||||
(deftest "pure-only page has empty server list"
|
|
||||||
(let ((plan (page-render-plan "(~dep-auto-pure :x 1)" (test-env) (list "fetch-data"))))
|
|
||||||
(assert-equal 0 (len (get plan :server)))
|
|
||||||
(assert-true (> (len (get plan :client)) 0)))))
|
|
||||||
@@ -1,212 +0,0 @@
|
|||||||
;; ==========================================================================
|
|
||||||
;; test-engine.sx — Tests for SxEngine pure logic (engine.sx)
|
|
||||||
;;
|
|
||||||
;; Requires: test-framework.sx loaded first.
|
|
||||||
;; Platform functions: parse-time, parse-trigger-spec, default-trigger,
|
|
||||||
;; parse-swap-spec, parse-retry-spec, next-retry-ms, filter-params
|
|
||||||
;; (loaded from bootstrapped output by test runners)
|
|
||||||
;; ==========================================================================
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 1. parse-time — time string parsing
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "parse-time"
|
|
||||||
|
|
||||||
(deftest "seconds to ms"
|
|
||||||
(assert-equal 2000 (parse-time "2s")))
|
|
||||||
|
|
||||||
(deftest "milliseconds"
|
|
||||||
(assert-equal 500 (parse-time "500ms")))
|
|
||||||
|
|
||||||
(deftest "nil returns 0"
|
|
||||||
(assert-equal 0 (parse-time nil)))
|
|
||||||
|
|
||||||
(deftest "plain number string"
|
|
||||||
(assert-equal 100 (parse-time "100")))
|
|
||||||
|
|
||||||
(deftest "one second"
|
|
||||||
(assert-equal 1000 (parse-time "1s")))
|
|
||||||
|
|
||||||
(deftest "large seconds"
|
|
||||||
(assert-equal 30000 (parse-time "30s"))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 2. parse-trigger-spec — trigger attribute parsing
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "parse-trigger-spec"
|
|
||||||
|
|
||||||
(deftest "nil returns nil"
|
|
||||||
(assert-nil (parse-trigger-spec nil)))
|
|
||||||
|
|
||||||
(deftest "single event"
|
|
||||||
(let ((triggers (parse-trigger-spec "click")))
|
|
||||||
(assert-equal 1 (len triggers))
|
|
||||||
(assert-equal "click" (get (first triggers) "event"))))
|
|
||||||
|
|
||||||
(deftest "event with once modifier"
|
|
||||||
(let ((triggers (parse-trigger-spec "click once")))
|
|
||||||
(assert-equal 1 (len triggers))
|
|
||||||
(assert-equal "click" (get (first triggers) "event"))
|
|
||||||
(assert-true (get (get (first triggers) "modifiers") "once"))))
|
|
||||||
|
|
||||||
(deftest "event with delay modifier"
|
|
||||||
(let ((triggers (parse-trigger-spec "click delay:500ms")))
|
|
||||||
(assert-equal 1 (len triggers))
|
|
||||||
(assert-equal 500 (get (get (first triggers) "modifiers") "delay"))))
|
|
||||||
|
|
||||||
(deftest "multiple triggers comma-separated"
|
|
||||||
(let ((triggers (parse-trigger-spec "click,change")))
|
|
||||||
(assert-equal 2 (len triggers))
|
|
||||||
(assert-equal "click" (get (first triggers) "event"))
|
|
||||||
(assert-equal "change" (get (nth triggers 1) "event"))))
|
|
||||||
|
|
||||||
(deftest "polling trigger"
|
|
||||||
(let ((triggers (parse-trigger-spec "every 3s")))
|
|
||||||
(assert-equal 1 (len triggers))
|
|
||||||
(assert-equal "every" (get (first triggers) "event"))
|
|
||||||
(assert-equal 3000 (get (get (first triggers) "modifiers") "interval"))))
|
|
||||||
|
|
||||||
(deftest "event with from modifier"
|
|
||||||
(let ((triggers (parse-trigger-spec "click from:body")))
|
|
||||||
(assert-equal "body" (get (get (first triggers) "modifiers") "from"))))
|
|
||||||
|
|
||||||
(deftest "event with changed modifier"
|
|
||||||
(let ((triggers (parse-trigger-spec "keyup changed")))
|
|
||||||
(assert-equal "keyup" (get (first triggers) "event"))
|
|
||||||
(assert-true (get (get (first triggers) "modifiers") "changed")))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 3. default-trigger — default trigger by element tag
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "default-trigger"
|
|
||||||
|
|
||||||
(deftest "form submits"
|
|
||||||
(let ((triggers (default-trigger "FORM")))
|
|
||||||
(assert-equal "submit" (get (first triggers) "event"))))
|
|
||||||
|
|
||||||
(deftest "input changes"
|
|
||||||
(let ((triggers (default-trigger "INPUT")))
|
|
||||||
(assert-equal "change" (get (first triggers) "event"))))
|
|
||||||
|
|
||||||
(deftest "select changes"
|
|
||||||
(let ((triggers (default-trigger "SELECT")))
|
|
||||||
(assert-equal "change" (get (first triggers) "event"))))
|
|
||||||
|
|
||||||
(deftest "textarea changes"
|
|
||||||
(let ((triggers (default-trigger "TEXTAREA")))
|
|
||||||
(assert-equal "change" (get (first triggers) "event"))))
|
|
||||||
|
|
||||||
(deftest "div clicks"
|
|
||||||
(let ((triggers (default-trigger "DIV")))
|
|
||||||
(assert-equal "click" (get (first triggers) "event"))))
|
|
||||||
|
|
||||||
(deftest "button clicks"
|
|
||||||
(let ((triggers (default-trigger "BUTTON")))
|
|
||||||
(assert-equal "click" (get (first triggers) "event")))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 4. parse-swap-spec — swap specification parsing
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "parse-swap-spec"
|
|
||||||
|
|
||||||
(deftest "default swap"
|
|
||||||
(let ((spec (parse-swap-spec nil false)))
|
|
||||||
(assert-equal "outerHTML" (get spec "style"))
|
|
||||||
(assert-false (get spec "transition"))))
|
|
||||||
|
|
||||||
(deftest "innerHTML"
|
|
||||||
(let ((spec (parse-swap-spec "innerHTML" false)))
|
|
||||||
(assert-equal "innerHTML" (get spec "style"))))
|
|
||||||
|
|
||||||
(deftest "with transition true"
|
|
||||||
(let ((spec (parse-swap-spec "innerHTML transition:true" false)))
|
|
||||||
(assert-equal "innerHTML" (get spec "style"))
|
|
||||||
(assert-true (get spec "transition"))))
|
|
||||||
|
|
||||||
(deftest "transition false overrides global"
|
|
||||||
(let ((spec (parse-swap-spec "outerHTML transition:false" true)))
|
|
||||||
(assert-equal "outerHTML" (get spec "style"))
|
|
||||||
(assert-false (get spec "transition"))))
|
|
||||||
|
|
||||||
(deftest "global transition when not overridden"
|
|
||||||
(let ((spec (parse-swap-spec "innerHTML" true)))
|
|
||||||
(assert-equal "innerHTML" (get spec "style"))
|
|
||||||
(assert-true (get spec "transition")))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 5. parse-retry-spec — retry specification parsing
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "parse-retry-spec"
|
|
||||||
|
|
||||||
(deftest "nil returns nil"
|
|
||||||
(assert-nil (parse-retry-spec nil)))
|
|
||||||
|
|
||||||
(deftest "exponential backoff"
|
|
||||||
(let ((spec (parse-retry-spec "exponential:1000:30000")))
|
|
||||||
(assert-equal "exponential" (get spec "strategy"))
|
|
||||||
(assert-equal 1000 (get spec "start-ms"))
|
|
||||||
(assert-equal 30000 (get spec "cap-ms"))))
|
|
||||||
|
|
||||||
(deftest "linear strategy"
|
|
||||||
(let ((spec (parse-retry-spec "linear:2000:60000")))
|
|
||||||
(assert-equal "linear" (get spec "strategy"))
|
|
||||||
(assert-equal 2000 (get spec "start-ms"))
|
|
||||||
(assert-equal 60000 (get spec "cap-ms")))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 6. next-retry-ms — exponential backoff calculation
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "next-retry-ms"
|
|
||||||
|
|
||||||
(deftest "doubles current"
|
|
||||||
(assert-equal 2000 (next-retry-ms 1000 30000)))
|
|
||||||
|
|
||||||
(deftest "caps at maximum"
|
|
||||||
(assert-equal 30000 (next-retry-ms 20000 30000)))
|
|
||||||
|
|
||||||
(deftest "exact cap"
|
|
||||||
(assert-equal 30000 (next-retry-ms 15000 30000)))
|
|
||||||
|
|
||||||
(deftest "small initial"
|
|
||||||
(assert-equal 200 (next-retry-ms 100 30000))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 7. filter-params — form parameter filtering
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "filter-params"
|
|
||||||
|
|
||||||
(deftest "nil passes all through"
|
|
||||||
(let ((params (list (list "a" "1") (list "b" "2"))))
|
|
||||||
(assert-equal 2 (len (filter-params nil params)))))
|
|
||||||
|
|
||||||
(deftest "none returns empty"
|
|
||||||
(let ((params (list (list "a" "1") (list "b" "2"))))
|
|
||||||
(assert-equal 0 (len (filter-params "none" params)))))
|
|
||||||
|
|
||||||
(deftest "star passes all"
|
|
||||||
(let ((params (list (list "a" "1") (list "b" "2"))))
|
|
||||||
(assert-equal 2 (len (filter-params "*" params)))))
|
|
||||||
|
|
||||||
(deftest "whitelist"
|
|
||||||
(let ((params (list (list "name" "Jo") (list "age" "30") (list "secret" "x"))))
|
|
||||||
(let ((filtered (filter-params "name,age" params)))
|
|
||||||
(assert-equal 2 (len filtered)))))
|
|
||||||
|
|
||||||
(deftest "blacklist with not"
|
|
||||||
(let ((params (list (list "name" "Jo") (list "csrf" "tok") (list "age" "30"))))
|
|
||||||
(let ((filtered (filter-params "not csrf" params)))
|
|
||||||
(assert-equal 2 (len filtered))))))
|
|
||||||
@@ -1,170 +0,0 @@
|
|||||||
;; ==========================================================================
|
|
||||||
;; test-orchestration.sx — Tests for orchestration.sx Phase 7c + 7d
|
|
||||||
;;
|
|
||||||
;; Requires: test-framework.sx loaded first.
|
|
||||||
;; Platform functions mocked by test runner:
|
|
||||||
;; now-ms, log-info, log-warn, execute-action, try-rerender-page
|
|
||||||
;; ==========================================================================
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 1. page-data-cache — basic cache operations
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "page-data-cache"
|
|
||||||
|
|
||||||
(deftest "cache-key bare page name"
|
|
||||||
(assert-equal "my-page" (page-data-cache-key "my-page" nil)))
|
|
||||||
|
|
||||||
(deftest "cache-key with params"
|
|
||||||
(let ((key (page-data-cache-key "my-page" {"id" "42"})))
|
|
||||||
(assert-equal "my-page:id=42" key)))
|
|
||||||
|
|
||||||
(deftest "cache-set then get"
|
|
||||||
(let ((key "test-cache-1"))
|
|
||||||
(page-data-cache-set key {"items" (list 1 2 3)})
|
|
||||||
(let ((result (page-data-cache-get key)))
|
|
||||||
(assert-equal (list 1 2 3) (get result "items")))))
|
|
||||||
|
|
||||||
(deftest "cache miss returns nil"
|
|
||||||
(assert-nil (page-data-cache-get "nonexistent-key"))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 2. optimistic-cache-update — predicted mutation with snapshot
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "optimistic-cache-update"
|
|
||||||
|
|
||||||
(deftest "applies mutator to cached data"
|
|
||||||
(let ((key "opt-test-1"))
|
|
||||||
;; Seed the cache
|
|
||||||
(page-data-cache-set key {"count" 10})
|
|
||||||
;; Apply optimistic mutation
|
|
||||||
(let ((predicted (optimistic-cache-update key
|
|
||||||
(fn (data) (merge data {"count" 11})))))
|
|
||||||
(assert-equal 11 (get predicted "count")))))
|
|
||||||
|
|
||||||
(deftest "updates cache with prediction"
|
|
||||||
(let ((key "opt-test-2"))
|
|
||||||
(page-data-cache-set key {"count" 5})
|
|
||||||
(optimistic-cache-update key (fn (data) (merge data {"count" 6})))
|
|
||||||
;; Cache now has predicted value
|
|
||||||
(let ((cached (page-data-cache-get key)))
|
|
||||||
(assert-equal 6 (get cached "count")))))
|
|
||||||
|
|
||||||
(deftest "returns nil when no cached data"
|
|
||||||
(let ((result (optimistic-cache-update "no-such-key"
|
|
||||||
(fn (data) (merge data {"x" 1})))))
|
|
||||||
(assert-nil result))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 3. optimistic-cache-revert — restore from snapshot
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "optimistic-cache-revert"
|
|
||||||
|
|
||||||
(deftest "reverts to original data"
|
|
||||||
(let ((key "revert-test-1"))
|
|
||||||
(page-data-cache-set key {"count" 10})
|
|
||||||
(optimistic-cache-update key (fn (data) (merge data {"count" 99})))
|
|
||||||
;; Cache now has 99
|
|
||||||
(assert-equal 99 (get (page-data-cache-get key) "count"))
|
|
||||||
;; Revert
|
|
||||||
(let ((restored (optimistic-cache-revert key)))
|
|
||||||
(assert-equal 10 (get restored "count"))
|
|
||||||
;; Cache is back to original
|
|
||||||
(assert-equal 10 (get (page-data-cache-get key) "count")))))
|
|
||||||
|
|
||||||
(deftest "returns nil when no snapshot"
|
|
||||||
(assert-nil (optimistic-cache-revert "never-mutated"))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 4. optimistic-cache-confirm — discard snapshot
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "optimistic-cache-confirm"
|
|
||||||
|
|
||||||
(deftest "confirm clears snapshot"
|
|
||||||
(let ((key "confirm-test-1"))
|
|
||||||
(page-data-cache-set key {"val" "a"})
|
|
||||||
(optimistic-cache-update key (fn (data) (merge data {"val" "b"})))
|
|
||||||
;; Confirm — accepts the optimistic value
|
|
||||||
(optimistic-cache-confirm key)
|
|
||||||
;; Revert should now return nil (no snapshot)
|
|
||||||
(assert-nil (optimistic-cache-revert key))
|
|
||||||
;; Cache still has optimistic value
|
|
||||||
(assert-equal "b" (get (page-data-cache-get key) "val")))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 5. offline-is-online? / offline-set-online! — connectivity tracking
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "offline-connectivity"
|
|
||||||
|
|
||||||
(deftest "initially online"
|
|
||||||
(assert-true (offline-is-online?)))
|
|
||||||
|
|
||||||
(deftest "set offline"
|
|
||||||
(offline-set-online! false)
|
|
||||||
(assert-false (offline-is-online?)))
|
|
||||||
|
|
||||||
(deftest "set back online"
|
|
||||||
(offline-set-online! true)
|
|
||||||
(assert-true (offline-is-online?))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 6. offline-queue-mutation — queue entries when offline
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "offline-queue-mutation"
|
|
||||||
|
|
||||||
(deftest "queues an entry"
|
|
||||||
;; Seed cache so optimistic update works
|
|
||||||
(let ((key (page-data-cache-key "notes" nil)))
|
|
||||||
(page-data-cache-set key {"items" (list "a" "b")})
|
|
||||||
(let ((entry (offline-queue-mutation "add-note"
|
|
||||||
{"text" "c"}
|
|
||||||
"notes" nil
|
|
||||||
(fn (data) (merge data {"items" (list "a" "b" "c")})))))
|
|
||||||
(assert-equal "add-note" (get entry "action"))
|
|
||||||
(assert-equal "pending" (get entry "status")))))
|
|
||||||
|
|
||||||
(deftest "pending count increases"
|
|
||||||
;; Previous test queued 1 entry; count should be >= 1
|
|
||||||
(assert-true (> (offline-pending-count) 0))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; 7. offline-aware-mutation — routes by connectivity
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "offline-aware-mutation"
|
|
||||||
|
|
||||||
(deftest "when online calls submit-mutation path"
|
|
||||||
(offline-set-online! true)
|
|
||||||
(let ((key (page-data-cache-key "test-page" nil)))
|
|
||||||
(page-data-cache-set key {"v" 1})
|
|
||||||
;; This will trigger execute-action (mocked) which calls success cb
|
|
||||||
(let ((status nil))
|
|
||||||
(offline-aware-mutation "test-page" nil "do-thing" {"x" 1}
|
|
||||||
(fn (data) (merge data {"v" 2}))
|
|
||||||
(fn (s) (set! status s)))
|
|
||||||
;; Mock execute-action calls success immediately
|
|
||||||
(assert-equal "confirmed" status))))
|
|
||||||
|
|
||||||
(deftest "when offline queues mutation"
|
|
||||||
(offline-set-online! false)
|
|
||||||
(let ((key (page-data-cache-key "test-page-2" nil)))
|
|
||||||
(page-data-cache-set key {"v" 1})
|
|
||||||
(let ((status nil))
|
|
||||||
(offline-aware-mutation "test-page-2" nil "do-thing" {"x" 1}
|
|
||||||
(fn (data) (merge data {"v" 2}))
|
|
||||||
(fn (s) (set! status s)))
|
|
||||||
(assert-equal "queued" status)))
|
|
||||||
;; Clean up: go back online
|
|
||||||
(offline-set-online! true)))
|
|
||||||
@@ -1,708 +0,0 @@
|
|||||||
;; ==========================================================================
|
|
||||||
;; test-router.sx — Tests for client-side route matching & SX URL algebra
|
|
||||||
;;
|
|
||||||
;; Requires: test-framework.sx loaded first.
|
|
||||||
;; Modules tested: router.sx
|
|
||||||
;;
|
|
||||||
;; No additional platform functions needed — router.sx is pure.
|
|
||||||
;; ==========================================================================
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; split-path-segments
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "split-path-segments"
|
|
||||||
(deftest "root path"
|
|
||||||
(assert-equal (list) (split-path-segments "/")))
|
|
||||||
|
|
||||||
(deftest "single segment"
|
|
||||||
(assert-equal (list "docs") (split-path-segments "/docs")))
|
|
||||||
|
|
||||||
(deftest "multiple segments"
|
|
||||||
(assert-equal (list "docs" "hello") (split-path-segments "/docs/hello")))
|
|
||||||
|
|
||||||
(deftest "trailing slash stripped"
|
|
||||||
(assert-equal (list "docs") (split-path-segments "/docs/")))
|
|
||||||
|
|
||||||
(deftest "deep path"
|
|
||||||
(assert-equal (list "a" "b" "c" "d") (split-path-segments "/a/b/c/d"))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; parse-route-pattern
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "parse-route-pattern"
|
|
||||||
(deftest "static pattern"
|
|
||||||
(let ((segs (parse-route-pattern "/docs/intro")))
|
|
||||||
(assert-length 2 segs)
|
|
||||||
(assert-equal "literal" (get (first segs) "type"))
|
|
||||||
(assert-equal "docs" (get (first segs) "value"))
|
|
||||||
(assert-equal "literal" (get (nth segs 1) "type"))
|
|
||||||
(assert-equal "intro" (get (nth segs 1) "value"))))
|
|
||||||
|
|
||||||
(deftest "pattern with param"
|
|
||||||
(let ((segs (parse-route-pattern "/docs/<slug>")))
|
|
||||||
(assert-length 2 segs)
|
|
||||||
(assert-equal "literal" (get (first segs) "type"))
|
|
||||||
(assert-equal "docs" (get (first segs) "value"))
|
|
||||||
(assert-equal "param" (get (nth segs 1) "type"))
|
|
||||||
(assert-equal "slug" (get (nth segs 1) "value"))))
|
|
||||||
|
|
||||||
(deftest "multiple params"
|
|
||||||
(let ((segs (parse-route-pattern "/users/<uid>/posts/<pid>")))
|
|
||||||
(assert-length 4 segs)
|
|
||||||
(assert-equal "param" (get (nth segs 1) "type"))
|
|
||||||
(assert-equal "uid" (get (nth segs 1) "value"))
|
|
||||||
(assert-equal "param" (get (nth segs 3) "type"))
|
|
||||||
(assert-equal "pid" (get (nth segs 3) "value"))))
|
|
||||||
|
|
||||||
(deftest "root pattern"
|
|
||||||
(assert-equal (list) (parse-route-pattern "/"))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; match-route
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "match-route"
|
|
||||||
(deftest "exact match returns empty params"
|
|
||||||
(let ((result (match-route "/docs/intro" "/docs/intro")))
|
|
||||||
(assert-true (not (nil? result)))
|
|
||||||
(assert-length 0 (keys result))))
|
|
||||||
|
|
||||||
(deftest "param match extracts value"
|
|
||||||
(let ((result (match-route "/docs/hello" "/docs/<slug>")))
|
|
||||||
(assert-true (not (nil? result)))
|
|
||||||
(assert-equal "hello" (get result "slug"))))
|
|
||||||
|
|
||||||
(deftest "no match returns nil"
|
|
||||||
(assert-nil (match-route "/docs/hello" "/essays/<slug>"))
|
|
||||||
(assert-nil (match-route "/docs" "/docs/<slug>")))
|
|
||||||
|
|
||||||
(deftest "segment count mismatch returns nil"
|
|
||||||
(assert-nil (match-route "/a/b/c" "/a/<b>"))
|
|
||||||
(assert-nil (match-route "/a" "/a/b")))
|
|
||||||
|
|
||||||
(deftest "root matches root"
|
|
||||||
(let ((result (match-route "/" "/")))
|
|
||||||
(assert-true (not (nil? result)))))
|
|
||||||
|
|
||||||
(deftest "multiple params extracted"
|
|
||||||
(let ((result (match-route "/users/42/posts/99" "/users/<uid>/posts/<pid>")))
|
|
||||||
(assert-true (not (nil? result)))
|
|
||||||
(assert-equal "42" (get result "uid"))
|
|
||||||
(assert-equal "99" (get result "pid")))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; find-matching-route
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "find-matching-route"
|
|
||||||
(deftest "finds first matching route"
|
|
||||||
(let ((routes (list
|
|
||||||
{:pattern "/docs/" :parsed (parse-route-pattern "/docs/") :name "docs-index"}
|
|
||||||
{:pattern "/docs/<slug>" :parsed (parse-route-pattern "/docs/<slug>") :name "docs-page"})))
|
|
||||||
(let ((result (find-matching-route "/docs/hello" routes)))
|
|
||||||
(assert-true (not (nil? result)))
|
|
||||||
(assert-equal "docs-page" (get result "name"))
|
|
||||||
(assert-equal "hello" (get (get result "params") "slug")))))
|
|
||||||
|
|
||||||
(deftest "returns nil for no match"
|
|
||||||
(let ((routes (list
|
|
||||||
{:pattern "/docs/<slug>" :parsed (parse-route-pattern "/docs/<slug>") :name "docs-page"})))
|
|
||||||
(assert-nil (find-matching-route "/essays/hello" routes))))
|
|
||||||
|
|
||||||
(deftest "matches exact routes before param routes"
|
|
||||||
(let ((routes (list
|
|
||||||
{:pattern "/docs/" :parsed (parse-route-pattern "/docs/") :name "docs-index"}
|
|
||||||
{:pattern "/docs/<slug>" :parsed (parse-route-pattern "/docs/<slug>") :name "docs-page"})))
|
|
||||||
(let ((result (find-matching-route "/docs/" routes)))
|
|
||||||
(assert-true (not (nil? result)))
|
|
||||||
(assert-equal "docs-index" (get result "name")))))
|
|
||||||
|
|
||||||
(deftest "propagates stream flag from route"
|
|
||||||
(let ((routes (list
|
|
||||||
{:pattern "/demo/streaming"
|
|
||||||
:parsed (parse-route-pattern "/demo/streaming")
|
|
||||||
:name "streaming-demo"
|
|
||||||
:stream true
|
|
||||||
:has-data true})))
|
|
||||||
(let ((result (find-matching-route "/demo/streaming" routes)))
|
|
||||||
(assert-true (not (nil? result)))
|
|
||||||
(assert-equal true (get result "stream"))
|
|
||||||
(assert-equal true (get result "has-data")))))
|
|
||||||
|
|
||||||
(deftest "non-streaming route has no stream flag"
|
|
||||||
(let ((routes (list
|
|
||||||
{:pattern "/about"
|
|
||||||
:parsed (parse-route-pattern "/about")
|
|
||||||
:name "about"
|
|
||||||
:has-data false})))
|
|
||||||
(let ((result (find-matching-route "/about" routes)))
|
|
||||||
(assert-true (not (nil? result)))
|
|
||||||
(assert-nil (get result "stream"))))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; sx-url-to-path — SX expression URL → old-style path
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "sx-url-to-path"
|
|
||||||
(deftest "simple two-level"
|
|
||||||
(assert-equal "/language/docs/introduction"
|
|
||||||
(sx-url-to-path "/(language.(doc.introduction))")))
|
|
||||||
|
|
||||||
(deftest "deep nesting"
|
|
||||||
(assert-equal "/geography/hypermedia/reference/attributes"
|
|
||||||
(sx-url-to-path "/(geography.(hypermedia.(reference.attributes)))")))
|
|
||||||
|
|
||||||
(deftest "section index"
|
|
||||||
(assert-equal "/language"
|
|
||||||
(sx-url-to-path "/(language)")))
|
|
||||||
|
|
||||||
(deftest "function name mapping — doc to docs"
|
|
||||||
(assert-equal "/language/docs/getting-started"
|
|
||||||
(sx-url-to-path "/(language.(doc.getting-started))")))
|
|
||||||
|
|
||||||
(deftest "function name mapping — spec to specs"
|
|
||||||
(assert-equal "/language/specs/core"
|
|
||||||
(sx-url-to-path "/(language.(spec.core))")))
|
|
||||||
|
|
||||||
(deftest "function name mapping — example to examples"
|
|
||||||
(assert-equal "/geography/hypermedia/examples/click-to-load"
|
|
||||||
(sx-url-to-path "/(geography.(hypermedia.(example.click-to-load)))")))
|
|
||||||
|
|
||||||
(deftest "function name mapping — essay to essays"
|
|
||||||
(assert-equal "/etc/essays/sx-sucks"
|
|
||||||
(sx-url-to-path "/(etc.(essay.sx-sucks))")))
|
|
||||||
|
|
||||||
(deftest "function name mapping — plan to plans"
|
|
||||||
(assert-equal "/etc/plans/spec-explorer"
|
|
||||||
(sx-url-to-path "/(etc.(plan.spec-explorer))")))
|
|
||||||
|
|
||||||
(deftest "function name mapping — test to testing"
|
|
||||||
(assert-equal "/language/testing/eval"
|
|
||||||
(sx-url-to-path "/(language.(test.eval))")))
|
|
||||||
|
|
||||||
(deftest "function name mapping — bootstrapper to bootstrappers"
|
|
||||||
(assert-equal "/language/bootstrappers/python"
|
|
||||||
(sx-url-to-path "/(language.(bootstrapper.python))")))
|
|
||||||
|
|
||||||
(deftest "function name mapping — protocol to protocols"
|
|
||||||
(assert-equal "/applications/protocols/wire-format"
|
|
||||||
(sx-url-to-path "/(applications.(protocol.wire-format))")))
|
|
||||||
|
|
||||||
(deftest "function name mapping — reference-detail to reference"
|
|
||||||
(assert-equal "/geography/hypermedia/reference/attributes"
|
|
||||||
(sx-url-to-path "/(geography.(hypermedia.(reference-detail.attributes)))")))
|
|
||||||
|
|
||||||
(deftest "non-SX URL returns nil"
|
|
||||||
(assert-nil (sx-url-to-path "/language/docs/introduction"))
|
|
||||||
(assert-nil (sx-url-to-path "https://example.com"))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; find-matching-route with SX URLs
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "find-matching-route-sx-urls"
|
|
||||||
(deftest "SX URL auto-converts for matching"
|
|
||||||
(let ((routes (list
|
|
||||||
{:pattern "/language/docs/<slug>"
|
|
||||||
:parsed (parse-route-pattern "/language/docs/<slug>")
|
|
||||||
:name "docs-page"})))
|
|
||||||
(let ((result (find-matching-route "/(language.(doc.introduction))" routes)))
|
|
||||||
(assert-true (not (nil? result)))
|
|
||||||
(assert-equal "docs-page" (get result "name"))
|
|
||||||
(assert-equal "introduction" (get (get result "params") "slug"))))))
|
|
||||||
|
|
||||||
|
|
||||||
;; ==========================================================================
|
|
||||||
;; SX URL Resolution — Structural Navigation
|
|
||||||
;; ==========================================================================
|
|
||||||
|
|
||||||
(defsuite "relative-sx-url?"
|
|
||||||
(deftest "paren-form relative"
|
|
||||||
(assert-true (relative-sx-url? "(.slug)"))
|
|
||||||
(assert-true (relative-sx-url? "(..)"))
|
|
||||||
(assert-true (relative-sx-url? "(..reactive.demo)")))
|
|
||||||
|
|
||||||
(deftest "bare-dot relative"
|
|
||||||
(assert-true (relative-sx-url? ".slug"))
|
|
||||||
(assert-true (relative-sx-url? ".."))
|
|
||||||
(assert-true (relative-sx-url? "..."))
|
|
||||||
(assert-true (relative-sx-url? ".:page.4")))
|
|
||||||
|
|
||||||
(deftest "absolute URLs are not relative"
|
|
||||||
(assert-false (relative-sx-url? "/(language.(doc.intro))"))
|
|
||||||
(assert-false (relative-sx-url? "/"))
|
|
||||||
(assert-false (relative-sx-url? "/language/docs/intro")))
|
|
||||||
|
|
||||||
(deftest "special form URLs are not relative"
|
|
||||||
(assert-false (relative-sx-url? "/(!source.(~essay))"))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Structural: append at current level (1 dot)
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "resolve-relative-url: append (.slug)"
|
|
||||||
(deftest "append to deep URL"
|
|
||||||
(assert-equal "/(geography.(hypermedia.(example.progress-bar)))"
|
|
||||||
(resolve-relative-url
|
|
||||||
"/(geography.(hypermedia.(example)))"
|
|
||||||
"(.progress-bar)")))
|
|
||||||
|
|
||||||
(deftest "append to single-level URL"
|
|
||||||
(assert-equal "/(language.intro)"
|
|
||||||
(resolve-relative-url "/(language)" "(.intro)")))
|
|
||||||
|
|
||||||
(deftest "append with multi-token body"
|
|
||||||
(assert-equal "/(geography.(hypermedia.(example.progress-bar.v2)))"
|
|
||||||
(resolve-relative-url
|
|
||||||
"/(geography.(hypermedia.(example)))"
|
|
||||||
"(.progress-bar.v2)")))
|
|
||||||
|
|
||||||
(deftest "bare-dot shorthand"
|
|
||||||
(assert-equal "/(geography.(hypermedia.(example.progress-bar)))"
|
|
||||||
(resolve-relative-url
|
|
||||||
"/(geography.(hypermedia.(example)))"
|
|
||||||
".progress-bar"))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Structural: go up one level (2 dots)
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "resolve-relative-url: up one (..slug)"
|
|
||||||
(deftest "sibling call"
|
|
||||||
(assert-equal "/(geography.(hypermedia.(reactive.demo)))"
|
|
||||||
(resolve-relative-url
|
|
||||||
"/(geography.(hypermedia.(example)))"
|
|
||||||
"(..reactive.demo)")))
|
|
||||||
|
|
||||||
(deftest "just go up — no new content"
|
|
||||||
(assert-equal "/(geography.(hypermedia))"
|
|
||||||
(resolve-relative-url
|
|
||||||
"/(geography.(hypermedia.(example)))"
|
|
||||||
"(..)")))
|
|
||||||
|
|
||||||
(deftest "bare-dot shorthand for up"
|
|
||||||
(assert-equal "/(geography.(hypermedia))"
|
|
||||||
(resolve-relative-url
|
|
||||||
"/(geography.(hypermedia.(example)))"
|
|
||||||
"..")))
|
|
||||||
|
|
||||||
(deftest "up from two-level URL"
|
|
||||||
(assert-equal "/(language)"
|
|
||||||
(resolve-relative-url "/(language.(doc))" "(..)")))
|
|
||||||
|
|
||||||
(deftest "up from single-level pops to root"
|
|
||||||
(assert-equal "/"
|
|
||||||
(resolve-relative-url "/(language)" "(..)"))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Structural: go up two levels (3 dots)
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "resolve-relative-url: up two (...slug)"
|
|
||||||
(deftest "up two and push"
|
|
||||||
(assert-equal "/(geography.(marshes))"
|
|
||||||
(resolve-relative-url
|
|
||||||
"/(geography.(hypermedia.(example)))"
|
|
||||||
"(...marshes)")))
|
|
||||||
|
|
||||||
(deftest "just up two — no content"
|
|
||||||
(assert-equal "/(geography)"
|
|
||||||
(resolve-relative-url
|
|
||||||
"/(geography.(hypermedia.(example)))"
|
|
||||||
"(...)")))
|
|
||||||
|
|
||||||
(deftest "bare-dot shorthand for up two"
|
|
||||||
(assert-equal "/(geography)"
|
|
||||||
(resolve-relative-url
|
|
||||||
"/(geography.(hypermedia.(example)))"
|
|
||||||
"...")))
|
|
||||||
|
|
||||||
(deftest "up two from two-level pops to root"
|
|
||||||
(assert-equal "/"
|
|
||||||
(resolve-relative-url "/(language.(doc))" "(...)")))
|
|
||||||
|
|
||||||
(deftest "up two and push from deep URL"
|
|
||||||
;; 4-level URL, ... = 3 dots = pop 2 levels → at hypermedia level
|
|
||||||
(assert-equal "/(geography.(hypermedia.(reactive.demo)))"
|
|
||||||
(resolve-relative-url
|
|
||||||
"/(geography.(hypermedia.(reference.(attributes))))"
|
|
||||||
"(...reactive.demo)"))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Structural: up N levels (N+1 dots)
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "resolve-relative-url: up N"
|
|
||||||
(deftest "up three levels (4 dots) from 4-level URL"
|
|
||||||
;; 4-level URL, .... = 4 dots = pop 3 levels → at geography level
|
|
||||||
(assert-equal "/(geography)"
|
|
||||||
(resolve-relative-url
|
|
||||||
"/(geography.(hypermedia.(reference.(attributes))))"
|
|
||||||
"(....)")))
|
|
||||||
|
|
||||||
(deftest "up three and push from 4-level URL"
|
|
||||||
;; 4 dots = pop 3 → at geography, then push new-section
|
|
||||||
(assert-equal "/(geography.(new-section))"
|
|
||||||
(resolve-relative-url
|
|
||||||
"/(geography.(hypermedia.(reference.(attributes))))"
|
|
||||||
"(....new-section)")))
|
|
||||||
|
|
||||||
(deftest "up four levels (5 dots) pops to root"
|
|
||||||
(assert-equal "/"
|
|
||||||
(resolve-relative-url
|
|
||||||
"/(geography.(hypermedia.(reference.(attributes))))"
|
|
||||||
"(.....)"))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Structural: current (1 dot, no body) = no-op
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "resolve-relative-url: current level no-op"
|
|
||||||
(deftest "dot with no body is identity"
|
|
||||||
;; (.): dots=1, body="" → no positional, no keywords → current unchanged
|
|
||||||
(assert-equal "/(language.(doc.intro))"
|
|
||||||
(resolve-relative-url "/(language.(doc.intro))" "(.)")))
|
|
||||||
|
|
||||||
(deftest "bare dot shorthand"
|
|
||||||
(assert-equal "/(language.(doc.intro))"
|
|
||||||
(resolve-relative-url "/(language.(doc.intro))" "."))))
|
|
||||||
|
|
||||||
|
|
||||||
;; ==========================================================================
|
|
||||||
;; SX URL Resolution — Keyword Operations
|
|
||||||
;; ==========================================================================
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Keyword set: absolute value
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "resolve-relative-url: keyword set"
|
|
||||||
(deftest "set keyword on URL without keywords"
|
|
||||||
(assert-equal "/(language.(spec.(explore.signals.:page.4)))"
|
|
||||||
(resolve-relative-url
|
|
||||||
"/(language.(spec.(explore.signals)))"
|
|
||||||
"(.:page.4)")))
|
|
||||||
|
|
||||||
(deftest "replace existing keyword"
|
|
||||||
(assert-equal "/(language.(spec.(explore.signals.:page.4)))"
|
|
||||||
(resolve-relative-url
|
|
||||||
"/(language.(spec.(explore.signals.:page.3)))"
|
|
||||||
"(.:page.4)")))
|
|
||||||
|
|
||||||
(deftest "set keyword with bare-dot shorthand"
|
|
||||||
(assert-equal "/(language.(spec.(explore.signals.:page.4)))"
|
|
||||||
(resolve-relative-url
|
|
||||||
"/(language.(spec.(explore.signals.:page.3)))"
|
|
||||||
".:page.4")))
|
|
||||||
|
|
||||||
(deftest "set keyword on single-level URL"
|
|
||||||
(assert-equal "/(language.:page.1)"
|
|
||||||
(resolve-relative-url "/(language)" "(.:page.1)")))
|
|
||||||
|
|
||||||
(deftest "set multiple keywords"
|
|
||||||
(assert-equal "/(language.(spec.(explore.signals.:page.4.:section.batch)))"
|
|
||||||
(resolve-relative-url
|
|
||||||
"/(language.(spec.(explore.signals.:page.3)))"
|
|
||||||
"(.:page.4.:section.batch)")))
|
|
||||||
|
|
||||||
(deftest "add new keyword preserving existing"
|
|
||||||
(assert-equal "/(language.(spec.(explore.signals.:page.3.:section.batch)))"
|
|
||||||
(resolve-relative-url
|
|
||||||
"/(language.(spec.(explore.signals.:page.3)))"
|
|
||||||
"(.:section.batch)"))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Keyword delta: +N / -N
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "resolve-relative-url: keyword delta"
|
|
||||||
(deftest "increment by 1"
|
|
||||||
(assert-equal "/(language.(spec.(explore.signals.:page.4)))"
|
|
||||||
(resolve-relative-url
|
|
||||||
"/(language.(spec.(explore.signals.:page.3)))"
|
|
||||||
"(.:page.+1)")))
|
|
||||||
|
|
||||||
(deftest "decrement by 1"
|
|
||||||
(assert-equal "/(language.(spec.(explore.signals.:page.2)))"
|
|
||||||
(resolve-relative-url
|
|
||||||
"/(language.(spec.(explore.signals.:page.3)))"
|
|
||||||
"(.:page.-1)")))
|
|
||||||
|
|
||||||
(deftest "increment by larger amount"
|
|
||||||
(assert-equal "/(language.(spec.(explore.signals.:page.13)))"
|
|
||||||
(resolve-relative-url
|
|
||||||
"/(language.(spec.(explore.signals.:page.3)))"
|
|
||||||
"(.:page.+10)")))
|
|
||||||
|
|
||||||
(deftest "delta with bare-dot shorthand"
|
|
||||||
(assert-equal "/(language.(spec.(explore.signals.:page.4)))"
|
|
||||||
(resolve-relative-url
|
|
||||||
"/(language.(spec.(explore.signals.:page.3)))"
|
|
||||||
".:page.+1")))
|
|
||||||
|
|
||||||
(deftest "delta on missing keyword uses literal"
|
|
||||||
;; If :page doesn't exist, +1 is used as-is (not numeric delta)
|
|
||||||
(assert-equal "/(language.(spec.(explore.signals.:page.+1)))"
|
|
||||||
(resolve-relative-url
|
|
||||||
"/(language.(spec.(explore.signals)))"
|
|
||||||
"(.:page.+1)"))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Composed: structural + keyword
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "resolve-relative-url: composed structural + keyword"
|
|
||||||
(deftest "append slug + set keyword"
|
|
||||||
(assert-equal "/(language.(spec.(explore.signals.batch.:page.1)))"
|
|
||||||
(resolve-relative-url
|
|
||||||
"/(language.(spec.(explore.signals)))"
|
|
||||||
"(.batch.:page.1)")))
|
|
||||||
|
|
||||||
(deftest "sibling + set keyword"
|
|
||||||
(assert-equal "/(language.(spec.(eval.:page.1)))"
|
|
||||||
(resolve-relative-url
|
|
||||||
"/(language.(spec.(explore.signals.:page.3)))"
|
|
||||||
"(..eval.:page.1)")))
|
|
||||||
|
|
||||||
(deftest "up two + set keyword"
|
|
||||||
(assert-equal "/(geography.(reactive.demo.:page.1))"
|
|
||||||
(resolve-relative-url
|
|
||||||
"/(geography.(hypermedia.(example.progress-bar)))"
|
|
||||||
"(...reactive.demo.:page.1)")))
|
|
||||||
|
|
||||||
(deftest "bare-dot composed"
|
|
||||||
(assert-equal "/(language.(spec.(eval.:page.1)))"
|
|
||||||
(resolve-relative-url
|
|
||||||
"/(language.(spec.(explore.signals.:page.3)))"
|
|
||||||
"..eval.:page.1"))))
|
|
||||||
|
|
||||||
|
|
||||||
;; ==========================================================================
|
|
||||||
;; SX URL Parsing — parse-sx-url
|
|
||||||
;; ==========================================================================
|
|
||||||
|
|
||||||
(defsuite "parse-sx-url"
|
|
||||||
(deftest "home URL"
|
|
||||||
(let ((parsed (parse-sx-url "/")))
|
|
||||||
(assert-equal "home" (get parsed "type"))
|
|
||||||
(assert-equal "/" (get parsed "raw"))))
|
|
||||||
|
|
||||||
(deftest "absolute SX URL"
|
|
||||||
(let ((parsed (parse-sx-url "/(language.(doc.intro))")))
|
|
||||||
(assert-equal "absolute" (get parsed "type"))))
|
|
||||||
|
|
||||||
(deftest "relative paren-form"
|
|
||||||
(let ((parsed (parse-sx-url "(.slug)")))
|
|
||||||
(assert-equal "relative" (get parsed "type"))))
|
|
||||||
|
|
||||||
(deftest "relative bare-dot"
|
|
||||||
(let ((parsed (parse-sx-url ".slug")))
|
|
||||||
(assert-equal "relative" (get parsed "type"))))
|
|
||||||
|
|
||||||
(deftest "relative double-dot"
|
|
||||||
(let ((parsed (parse-sx-url "..")))
|
|
||||||
(assert-equal "relative" (get parsed "type"))))
|
|
||||||
|
|
||||||
(deftest "direct component"
|
|
||||||
(let ((parsed (parse-sx-url "/(~essay-sx-sucks)")))
|
|
||||||
(assert-equal "direct-component" (get parsed "type"))
|
|
||||||
(assert-equal "~essay-sx-sucks" (get parsed "name"))))
|
|
||||||
|
|
||||||
(deftest "old-style path"
|
|
||||||
(let ((parsed (parse-sx-url "/language/docs/intro")))
|
|
||||||
(assert-equal "path" (get parsed "type")))))
|
|
||||||
|
|
||||||
|
|
||||||
;; ==========================================================================
|
|
||||||
;; URL Special Forms (! prefix)
|
|
||||||
;; ==========================================================================
|
|
||||||
|
|
||||||
(defsuite "url-special-form?"
|
|
||||||
(deftest "known special forms"
|
|
||||||
(assert-true (url-special-form? "!source"))
|
|
||||||
(assert-true (url-special-form? "!inspect"))
|
|
||||||
(assert-true (url-special-form? "!diff"))
|
|
||||||
(assert-true (url-special-form? "!search"))
|
|
||||||
(assert-true (url-special-form? "!raw"))
|
|
||||||
(assert-true (url-special-form? "!json")))
|
|
||||||
|
|
||||||
(deftest "unknown bang-prefix is not a special form"
|
|
||||||
(assert-false (url-special-form? "!unknown"))
|
|
||||||
(assert-false (url-special-form? "!foo")))
|
|
||||||
|
|
||||||
(deftest "non-bang names are not special forms"
|
|
||||||
(assert-false (url-special-form? "source"))
|
|
||||||
(assert-false (url-special-form? "language"))
|
|
||||||
(assert-false (url-special-form? "~essay"))))
|
|
||||||
|
|
||||||
|
|
||||||
(defsuite "parse-sx-url: special forms"
|
|
||||||
(deftest "source special form"
|
|
||||||
(let ((parsed (parse-sx-url "/(!source.(~essay-sx-sucks))")))
|
|
||||||
(assert-equal "special-form" (get parsed "type"))
|
|
||||||
(assert-equal "!source" (get parsed "form"))
|
|
||||||
(assert-equal "(~essay-sx-sucks)" (get parsed "inner"))))
|
|
||||||
|
|
||||||
(deftest "inspect special form"
|
|
||||||
(let ((parsed (parse-sx-url "/(!inspect.(language.(doc.primitives)))")))
|
|
||||||
(assert-equal "special-form" (get parsed "type"))
|
|
||||||
(assert-equal "!inspect" (get parsed "form"))
|
|
||||||
(assert-equal "(language.(doc.primitives))" (get parsed "inner"))))
|
|
||||||
|
|
||||||
(deftest "diff special form with two args"
|
|
||||||
(let ((parsed (parse-sx-url "/(!diff.(language.(spec.signals)).(language.(spec.eval)))")))
|
|
||||||
(assert-equal "special-form" (get parsed "type"))
|
|
||||||
(assert-equal "!diff" (get parsed "form"))
|
|
||||||
(assert-equal "(language.(spec.signals)).(language.(spec.eval))" (get parsed "inner"))))
|
|
||||||
|
|
||||||
(deftest "raw special form"
|
|
||||||
(let ((parsed (parse-sx-url "/(!raw.(~some-component))")))
|
|
||||||
(assert-equal "special-form" (get parsed "type"))
|
|
||||||
(assert-equal "!raw" (get parsed "form"))
|
|
||||||
(assert-equal "(~some-component)" (get parsed "inner"))))
|
|
||||||
|
|
||||||
(deftest "json special form"
|
|
||||||
(let ((parsed (parse-sx-url "/(!json.(language.(doc.primitives)))")))
|
|
||||||
(assert-equal "special-form" (get parsed "type"))
|
|
||||||
(assert-equal "!json" (get parsed "form"))
|
|
||||||
(assert-equal "(language.(doc.primitives))" (get parsed "inner")))))
|
|
||||||
|
|
||||||
|
|
||||||
(defsuite "url-special-form-name"
|
|
||||||
(deftest "extracts form name"
|
|
||||||
(assert-equal "!source"
|
|
||||||
(url-special-form-name "/(!source.(~essay))")))
|
|
||||||
|
|
||||||
(deftest "returns nil for non-special-form"
|
|
||||||
(assert-nil (url-special-form-name "/(language.(doc.intro))"))
|
|
||||||
(assert-nil (url-special-form-name "/"))
|
|
||||||
(assert-nil (url-special-form-name "(.slug)"))))
|
|
||||||
|
|
||||||
|
|
||||||
(defsuite "url-special-form-inner"
|
|
||||||
(deftest "extracts inner expression"
|
|
||||||
(assert-equal "(~essay)"
|
|
||||||
(url-special-form-inner "/(!source.(~essay))")))
|
|
||||||
|
|
||||||
(deftest "extracts multi-arg inner"
|
|
||||||
(assert-equal "(a).(b)"
|
|
||||||
(url-special-form-inner "/(!diff.(a).(b))")))
|
|
||||||
|
|
||||||
(deftest "returns nil for non-special-form"
|
|
||||||
(assert-nil (url-special-form-inner "/(language.(doc.intro))"))))
|
|
||||||
|
|
||||||
|
|
||||||
;; ==========================================================================
|
|
||||||
;; Internal helpers — additional edge cases
|
|
||||||
;; ==========================================================================
|
|
||||||
|
|
||||||
(defsuite "internal: _pop-sx-url-level"
|
|
||||||
(deftest "pop three-level"
|
|
||||||
(assert-equal "/(a.(b))"
|
|
||||||
(_pop-sx-url-level "/(a.(b.(c)))")))
|
|
||||||
|
|
||||||
(deftest "pop two-level"
|
|
||||||
(assert-equal "/(a)"
|
|
||||||
(_pop-sx-url-level "/(a.(b))")))
|
|
||||||
|
|
||||||
(deftest "pop single-level to root"
|
|
||||||
(assert-equal "/"
|
|
||||||
(_pop-sx-url-level "/(a)")))
|
|
||||||
|
|
||||||
(deftest "pop root stays root"
|
|
||||||
(assert-equal "/"
|
|
||||||
(_pop-sx-url-level "/"))))
|
|
||||||
|
|
||||||
(defsuite "internal: _extract-innermost"
|
|
||||||
(deftest "single-level URL"
|
|
||||||
(let ((parts (_extract-innermost "/(language)")))
|
|
||||||
(assert-equal "/(" (get parts "before"))
|
|
||||||
(assert-equal "language" (get parts "content"))
|
|
||||||
(assert-equal ")" (get parts "suffix"))))
|
|
||||||
|
|
||||||
(deftest "two-level URL"
|
|
||||||
(let ((parts (_extract-innermost "/(language.(doc.intro))")))
|
|
||||||
(assert-equal "/(language.(" (get parts "before"))
|
|
||||||
(assert-equal "doc.intro" (get parts "content"))
|
|
||||||
(assert-equal "))" (get parts "suffix"))))
|
|
||||||
|
|
||||||
(deftest "three-level URL with keywords"
|
|
||||||
(let ((parts (_extract-innermost "/(a.(b.(c.d.:page.3)))")))
|
|
||||||
(assert-equal "/(a.(b.(" (get parts "before"))
|
|
||||||
(assert-equal "c.d.:page.3" (get parts "content"))
|
|
||||||
(assert-equal ")))" (get parts "suffix")))))
|
|
||||||
|
|
||||||
(defsuite "internal: _find-keyword-value"
|
|
||||||
(deftest "finds keyword"
|
|
||||||
(assert-equal "3"
|
|
||||||
(_find-keyword-value "explore.signals.:page.3" ":page")))
|
|
||||||
|
|
||||||
(deftest "returns nil when not found"
|
|
||||||
(assert-nil (_find-keyword-value "explore.signals" ":page")))
|
|
||||||
|
|
||||||
(deftest "finds among multiple keywords"
|
|
||||||
(assert-equal "batch"
|
|
||||||
(_find-keyword-value "explore.signals.:page.3.:section.batch" ":section"))))
|
|
||||||
|
|
||||||
(defsuite "internal: _set-keyword-in-content"
|
|
||||||
(deftest "replace existing"
|
|
||||||
(assert-equal "a.b.:page.4"
|
|
||||||
(_set-keyword-in-content "a.b.:page.3" ":page" "4")))
|
|
||||||
|
|
||||||
(deftest "append when missing"
|
|
||||||
(assert-equal "a.b.:page.1"
|
|
||||||
(_set-keyword-in-content "a.b" ":page" "1")))
|
|
||||||
|
|
||||||
(deftest "replace with multiple keywords present"
|
|
||||||
(assert-equal "a.:page.4.:section.batch"
|
|
||||||
(_set-keyword-in-content "a.:page.3.:section.batch" ":page" "4"))))
|
|
||||||
|
|
||||||
(defsuite "internal: _is-delta-value?"
|
|
||||||
(deftest "positive delta"
|
|
||||||
(assert-true (_is-delta-value? "+1"))
|
|
||||||
(assert-true (_is-delta-value? "+10")))
|
|
||||||
|
|
||||||
(deftest "negative delta"
|
|
||||||
(assert-true (_is-delta-value? "-1"))
|
|
||||||
(assert-true (_is-delta-value? "-10")))
|
|
||||||
|
|
||||||
(deftest "bare minus is not delta"
|
|
||||||
(assert-false (_is-delta-value? "-")))
|
|
||||||
|
|
||||||
(deftest "bare plus is not delta"
|
|
||||||
(assert-false (_is-delta-value? "+")))
|
|
||||||
|
|
||||||
(deftest "plain number is not delta"
|
|
||||||
(assert-false (_is-delta-value? "3"))
|
|
||||||
(assert-false (_is-delta-value? "0")))
|
|
||||||
|
|
||||||
(deftest "empty string is not delta"
|
|
||||||
(assert-false (_is-delta-value? ""))))
|
|
||||||
|
|
||||||
(defsuite "internal: _apply-delta"
|
|
||||||
(deftest "increment"
|
|
||||||
(assert-equal "4" (_apply-delta "3" "+1")))
|
|
||||||
|
|
||||||
(deftest "decrement"
|
|
||||||
(assert-equal "2" (_apply-delta "3" "-1")))
|
|
||||||
|
|
||||||
(deftest "large increment"
|
|
||||||
(assert-equal "13" (_apply-delta "3" "+10")))
|
|
||||||
|
|
||||||
(deftest "non-numeric current falls back"
|
|
||||||
(assert-equal "+1" (_apply-delta "abc" "+1"))))
|
|
||||||
@@ -1,216 +0,0 @@
|
|||||||
;; ==========================================================================
|
|
||||||
;; test-signals.sx — Tests for signals and reactive islands
|
|
||||||
;;
|
|
||||||
;; Requires: test-framework.sx loaded first.
|
|
||||||
;; Modules tested: signals.sx, eval.sx (defisland)
|
|
||||||
;;
|
|
||||||
;; Note: Multi-expression lambda bodies are wrapped in (do ...) for
|
|
||||||
;; compatibility with the hand-written evaluator which only supports
|
|
||||||
;; single-expression lambda bodies.
|
|
||||||
;; ==========================================================================
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Signal creation and basic read/write
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "signal basics"
|
|
||||||
(deftest "signal creates a reactive container"
|
|
||||||
(let ((s (signal 42)))
|
|
||||||
(assert-true (signal? s))
|
|
||||||
(assert-equal 42 (deref s))))
|
|
||||||
|
|
||||||
(deftest "deref on non-signal passes through"
|
|
||||||
(assert-equal 5 (deref 5))
|
|
||||||
(assert-equal "hello" (deref "hello"))
|
|
||||||
(assert-nil (deref nil)))
|
|
||||||
|
|
||||||
(deftest "reset! changes value"
|
|
||||||
(let ((s (signal 0)))
|
|
||||||
(reset! s 10)
|
|
||||||
(assert-equal 10 (deref s))))
|
|
||||||
|
|
||||||
(deftest "reset! does not notify when value unchanged"
|
|
||||||
(let ((s (signal 5))
|
|
||||||
(count (signal 0)))
|
|
||||||
(effect (fn () (do (deref s) (swap! count inc))))
|
|
||||||
;; Effect runs once on creation → count=1
|
|
||||||
(let ((c1 (deref count)))
|
|
||||||
(reset! s 5) ;; same value — no notification
|
|
||||||
(assert-equal c1 (deref count)))))
|
|
||||||
|
|
||||||
(deftest "swap! applies function to current value"
|
|
||||||
(let ((s (signal 10)))
|
|
||||||
(swap! s inc)
|
|
||||||
(assert-equal 11 (deref s))))
|
|
||||||
|
|
||||||
(deftest "swap! passes extra args"
|
|
||||||
(let ((s (signal 10)))
|
|
||||||
(swap! s + 5)
|
|
||||||
(assert-equal 15 (deref s)))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Computed signals
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "computed"
|
|
||||||
(deftest "computed derives initial value"
|
|
||||||
(let ((a (signal 3))
|
|
||||||
(b (signal 4))
|
|
||||||
(sum (computed (fn () (+ (deref a) (deref b))))))
|
|
||||||
(assert-equal 7 (deref sum))))
|
|
||||||
|
|
||||||
(deftest "computed updates when dependency changes"
|
|
||||||
(let ((a (signal 2))
|
|
||||||
(doubled (computed (fn () (* 2 (deref a))))))
|
|
||||||
(assert-equal 4 (deref doubled))
|
|
||||||
(reset! a 5)
|
|
||||||
(assert-equal 10 (deref doubled))))
|
|
||||||
|
|
||||||
(deftest "computed chains"
|
|
||||||
(let ((base (signal 1))
|
|
||||||
(doubled (computed (fn () (* 2 (deref base)))))
|
|
||||||
(quadrupled (computed (fn () (* 2 (deref doubled))))))
|
|
||||||
(assert-equal 4 (deref quadrupled))
|
|
||||||
(reset! base 3)
|
|
||||||
(assert-equal 12 (deref quadrupled)))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Effects
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "effects"
|
|
||||||
(deftest "effect runs immediately"
|
|
||||||
(let ((ran (signal false)))
|
|
||||||
(effect (fn () (reset! ran true)))
|
|
||||||
(assert-true (deref ran))))
|
|
||||||
|
|
||||||
(deftest "effect re-runs when dependency changes"
|
|
||||||
(let ((source (signal "a"))
|
|
||||||
(log (signal (list))))
|
|
||||||
(effect (fn ()
|
|
||||||
(swap! log (fn (l) (append l (deref source))))))
|
|
||||||
;; Initial run logs "a"
|
|
||||||
(assert-equal (list "a") (deref log))
|
|
||||||
;; Change triggers re-run
|
|
||||||
(reset! source "b")
|
|
||||||
(assert-equal (list "a" "b") (deref log))))
|
|
||||||
|
|
||||||
(deftest "effect dispose stops tracking"
|
|
||||||
(let ((source (signal 0))
|
|
||||||
(count (signal 0)))
|
|
||||||
(let ((dispose (effect (fn () (do
|
|
||||||
(deref source)
|
|
||||||
(swap! count inc))))))
|
|
||||||
;; Effect ran once
|
|
||||||
(assert-equal 1 (deref count))
|
|
||||||
;; Trigger
|
|
||||||
(reset! source 1)
|
|
||||||
(assert-equal 2 (deref count))
|
|
||||||
;; Dispose
|
|
||||||
(dispose)
|
|
||||||
;; Should NOT trigger
|
|
||||||
(reset! source 2)
|
|
||||||
(assert-equal 2 (deref count)))))
|
|
||||||
|
|
||||||
(deftest "effect cleanup runs before re-run"
|
|
||||||
(let ((source (signal 0))
|
|
||||||
(cleanups (signal 0)))
|
|
||||||
(effect (fn () (do
|
|
||||||
(deref source)
|
|
||||||
(fn () (swap! cleanups inc))))) ;; return cleanup fn
|
|
||||||
;; No cleanup yet (first run)
|
|
||||||
(assert-equal 0 (deref cleanups))
|
|
||||||
;; Change triggers cleanup of previous run
|
|
||||||
(reset! source 1)
|
|
||||||
(assert-equal 1 (deref cleanups)))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Batch
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "batch"
|
|
||||||
(deftest "batch defers notifications"
|
|
||||||
(let ((a (signal 0))
|
|
||||||
(b (signal 0))
|
|
||||||
(run-count (signal 0)))
|
|
||||||
(effect (fn () (do
|
|
||||||
(deref a) (deref b)
|
|
||||||
(swap! run-count inc))))
|
|
||||||
;; Initial run
|
|
||||||
(assert-equal 1 (deref run-count))
|
|
||||||
;; Without batch: 2 writes → 2 effect runs
|
|
||||||
;; With batch: 2 writes → 1 effect run
|
|
||||||
(batch (fn () (do
|
|
||||||
(reset! a 1)
|
|
||||||
(reset! b 2))))
|
|
||||||
;; Should be 2 (initial + 1 batched), not 3
|
|
||||||
(assert-equal 2 (deref run-count)))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; defisland
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "defisland"
|
|
||||||
(deftest "defisland creates an island"
|
|
||||||
(defisland ~test-island (&key value)
|
|
||||||
(list "island" value))
|
|
||||||
(assert-true (island? ~test-island)))
|
|
||||||
|
|
||||||
(deftest "island is callable like component"
|
|
||||||
(defisland ~greeting (&key name)
|
|
||||||
(str "Hello, " name "!"))
|
|
||||||
(assert-equal "Hello, World!" (~greeting :name "World")))
|
|
||||||
|
|
||||||
(deftest "island accepts children"
|
|
||||||
(defisland ~wrapper (&rest children)
|
|
||||||
(list "wrap" children))
|
|
||||||
(assert-equal (list "wrap" (list "a" "b"))
|
|
||||||
(~wrapper "a" "b"))))
|
|
||||||
|
|
||||||
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
;; Scope integration — reactive tracking uses scope-push!/scope-pop!
|
|
||||||
;; --------------------------------------------------------------------------
|
|
||||||
|
|
||||||
(defsuite "scope integration"
|
|
||||||
(deftest "deref outside reactive scope does not subscribe"
|
|
||||||
(let ((s (signal 42)))
|
|
||||||
;; Reading outside any reactive context should not add subscribers
|
|
||||||
(assert-equal 42 (deref s))
|
|
||||||
(assert-equal 0 (len (signal-subscribers s)))))
|
|
||||||
|
|
||||||
(deftest "computed uses scope for tracking"
|
|
||||||
(let ((a (signal 1))
|
|
||||||
(b (signal 2))
|
|
||||||
(sum (computed (fn () (+ (deref a) (deref b))))))
|
|
||||||
;; Each signal should have exactly 1 subscriber (the computed's recompute)
|
|
||||||
(assert-equal 1 (len (signal-subscribers a)))
|
|
||||||
(assert-equal 1 (len (signal-subscribers b)))
|
|
||||||
;; Verify computed value
|
|
||||||
(assert-equal 3 (deref sum))))
|
|
||||||
|
|
||||||
(deftest "nested effects with overlapping deps use scope correctly"
|
|
||||||
(let ((shared (signal 0))
|
|
||||||
(inner-only (signal 0))
|
|
||||||
(outer-count (signal 0))
|
|
||||||
(inner-count (signal 0)))
|
|
||||||
;; Outer effect tracks shared
|
|
||||||
(effect (fn () (do (deref shared) (swap! outer-count inc))))
|
|
||||||
;; Inner effect tracks shared AND inner-only
|
|
||||||
(effect (fn () (do (deref shared) (deref inner-only) (swap! inner-count inc))))
|
|
||||||
;; Both ran once
|
|
||||||
(assert-equal 1 (deref outer-count))
|
|
||||||
(assert-equal 1 (deref inner-count))
|
|
||||||
;; Changing shared triggers both
|
|
||||||
(reset! shared 1)
|
|
||||||
(assert-equal 2 (deref outer-count))
|
|
||||||
(assert-equal 2 (deref inner-count))
|
|
||||||
;; Changing inner-only triggers only inner
|
|
||||||
(reset! inner-only 1)
|
|
||||||
(assert-equal 2 (deref outer-count))
|
|
||||||
(assert-equal 3 (deref inner-count)))))
|
|
||||||
Reference in New Issue
Block a user