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

Separate core spec from web framework
All checks were successful
Build and Deploy / build-and-deploy (push) Successful in 4m49s
Details

Browse Source 
Three-layer architecture:
  spec/  — Core language (19 files): evaluator, parser, primitives,
           CEK machine, types, continuations. Host-independent.
  web/   — Web framework (20 files): signals, adapters, engine,
           orchestration, boot, router, CSSX. Built on core spec.
  sx/    — Application (sx-docs website). Built on web framework.

Split boundary.sx into boundary-core.sx (type-of, make-env, identical?)
and boundary-web.sx (IO primitives, signals, spreads, page helpers).

Bootstrappers search spec/ → web/ → shared/sx/ref/ for .sx files.
Original files remain in shared/sx/ref/ as fallback during transition.
All 63 tests pass.

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-03-15 01:42:19 +00:00
parent ab015fa2fd
commit 1a3d7b3d77
41 changed files with 20182 additions and 9 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1375
web/adapter-async.sx Normal file
View File

File diff suppressed because it is too large Load Diff

1314
web/adapter-dom.sx Normal file
View File

File diff suppressed because it is too large Load Diff

545
web/adapter-html.sx Normal file
View File

@@ -0,0 +1,545 @@
;; ==========================================================================
;; 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
;; --------------------------------------------------------------------------

407
web/adapter-sx.sx Normal file
View File

@@ -0,0 +1,407 @@
;; ==========================================================================
;; 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
;; --------------------------------------------------------------------------

552
web/boot.sx Normal file
View File

@@ -0,0 +1,552 @@
;; ==========================================================================
;; 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
;; --------------------------------------------------------------------------

414
web/boundary-web.sx Normal file
View File

@@ -0,0 +1,414 @@
;; ==========================================================================
;; boundary-web.sx — Web platform boundary contract
;;
;; I/O primitives, signals, spreads, scopes, and page helpers
;; required by the SX web framework. Built on the core spec.
;; ==========================================================================
;; --------------------------------------------------------------------------
;; 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.")

459
web/deps.sx Normal file
View File

@@ -0,0 +1,459 @@
;; ==========================================================================
;; 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))))

803
web/engine.sx Normal file
View File

@@ -0,0 +1,803 @@
;; ==========================================================================
;; 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
;; --------------------------------------------------------------------------

278
web/forms.sx Normal file
View File

@@ -0,0 +1,278 @@
;; ==========================================================================
;; 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))))

1414
web/orchestration.sx Normal file
View File

File diff suppressed because it is too large Load Diff

368
web/page-helpers.sx Normal file
View File

@@ -0,0 +1,368 @@
;; ==========================================================================
;; 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}))

680
web/router.sx Normal file
View File

@@ -0,0 +1,680 @@
;; ==========================================================================
;; 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
;; --------------------------------------------------------------------------

479
web/signals.sx Normal file
View File

@@ -0,0 +1,479 @@
;; ==========================================================================
;; 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)))

346
web/test-aser.sx Normal file
View File

@@ -0,0 +1,346 @@
;; ==========================================================================
;; 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\"))"))))

279
web/test-cek-reactive.sx Normal file
View File

@@ -0,0 +1,279 @@
;; ==========================================================================
;; 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))))

327
web/test-deps.sx Normal file
View File

@@ -0,0 +1,327 @@
;; ==========================================================================
;; 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)))))

212
web/test-engine.sx Normal file
View File

@@ -0,0 +1,212 @@
;; ==========================================================================
;; 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))))))

170
web/test-orchestration.sx Normal file
View File

@@ -0,0 +1,170 @@
;; ==========================================================================
;; 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)))

708
web/test-router.sx Normal file
View File

@@ -0,0 +1,708 @@
;; ==========================================================================
;; 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"))))

216
web/test-signals.sx Normal file
View File

@@ -0,0 +1,216 @@
;; ==========================================================================
;; 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)))))