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

host: factor the shared composition CORE — one fold, N domains (composition step 8)

Browse Source 
The roadmap's capstone: now that two folds exist (render, execute), extract the machinery
they share. host/comp-fold (compose.sx) is the reusable core — the seq/alt/each combinator
dispatch + the `when` predicate set (host/comp--pred?) + the context-environment + the `each`
source (host/comp--source) + recursion + the depth guard, ALL in one place. A domain plugs in
via a small dict {:empty :combine :leaf :overflow}; only its leaves and how results combine
differ:
  render  = {:empty ""     :combine str    …}  leaf -> markup (+ row/grid layout combinators)
  execute = {:empty (list) :combine concat …}  leaf -> effect

host/comp-render and host/exec-run are now one-liners over host/comp-fold with their domain.
execute.sx shed its own seq/alt/each dispatch — it's just a dict + a leaf. A THIRD domain
(eval/reduce/extent over the same algebra) is now only a new dict + leaf, no new control flow.

Both folds went through the core with ZERO behaviour change: new tests/compose.sx exercises
the core + render domain directly (17/17 — leaves, seq, row, alt+when (has/eq/not), each
(items/query/empty), tmpl recursion over a (children) tree + depth guard, ref transclude, one
object two contexts); execute 13/13; blog 162/164 (2 pre-existing relate-picker fails). Full
host conformance 388/390. Wired tests/compose.sx into conformance.

plans/composition-objects.md roadmap steps 1-8 COMPLETE.

Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
This commit is contained in:
giles
2026-06-30 23:53:56 +00:00
parent ed68b9883d
commit e12e314bc3
5 changed files with 190 additions and 119 deletions
Download Patch File Download Diff File Expand all files Collapse all files

125
lib/host/compose.sx
View File

@@ -1,15 +1,19 @@
;; lib/host/compose.sx — the composition / object render-fold (plans/composition-objects.md).
;; lib/host/compose.sx — the composition algebra + its render-fold (plans/composition-objects.md).
;;
;; An object's :body is a composition node — a tiny UI language over object refs. The
;; render-fold below is its interpreter. Four combinators (seq/row/alt/each) + leaves
;; (field/val/text/card) + ref + recursion (tmpl). `field` wraps its value in a span for
;; display; `val` is the raw value (no markup) for use inside attributes (href/src).
;; The context is an EXTENSIBLE ENVIRONMENT:
;; `when` reads it, `each` extends it (:item, :depth). Same predicate set as the type
;; guards. The object's CID is its DEFINITION; render is the EXECUTION (per context+data).
;; An object's :body is a composition node — a tiny language over object refs:
;; (seq …) sequence (row/grid …) layout (alt (when P n)… (else n)) conditional
;; (each src tmpl) iteration + domain leaves + (tmpl NAME) recursion
;;
;; The combinator dispatch (seq/alt/each), the `when` predicate set, the context-environment,
;; the `each` source, and recursion are SHARED by every domain — they live in the CORE below
;; (host/comp-fold). A domain plugs in via a small dict {:empty :combine :leaf :overflow};
;; only the leaves and how results combine differ. The render-fold (render → HTML) is the
;; first such domain; the execute-fold (execute → effects, lib/host/execute.sx) is the second.
;; The object's CID is its DEFINITION; a fold is the EXECUTION (per context + data + domain).
;; Self-contained (no blog deps) so the model can be proven in isolation.
;; ── predicates for `when` (over the context environment) ────────────
;; ── shared machinery (domain-agnostic) ──────────────────────────────
;; predicates for `when`, over the context environment.
(define host/comp--pred?
(fn (pred ctx)
(let ((op (str (first pred))))
@@ -19,7 +23,7 @@
((= op "not") (not (host/comp--pred? (first (rest pred)) ctx)))
(else false)))))
;; the value of a leaf (field): the current :item's key, else the context's key.
;; the value of a field: the current :item's key, else the context's key.
(define host/comp--field
(fn (k ctx)
(let ((item (get ctx "item")) (key (str k)))
@@ -27,12 +31,10 @@
(str (get item key))
(str (or (get ctx key) ""))))))
;; the source collection for `each`: literal items, the :item's :children (trees), a
;; named list field on the :item, or a GRAPH QUERY. The query source `(query REL TYPE)`
;; is data-driven: it delegates to a resolver function bound in the context under "query"
;; (the host injects one with graph access), so compose.sx stays self-contained — it asks
;; the context for the data, it doesn't reach into the graph itself. `src` minus its head
;; (`(REL TYPE …)`) + the live ctx are passed through; the resolver returns a list of items.
;; the source collection for `each`: literal items, the :item's :children (trees), a named
;; list field on the :item, or a GRAPH QUERY. `(query REL TYPE)` is data-driven: it delegates
;; to a resolver bound in the context under "query" (the host injects one with graph access),
;; so compose.sx stays self-contained — it asks the context for the data.
(define host/comp--source
(fn (src ctx)
(let ((op (str (first src))) (item (get ctx "item")))
@@ -44,40 +46,54 @@
(if qfn (qfn (rest src) ctx) (list))))
(else (list))))))
;; ── template registry (recursion: a template may reference itself by name) ──
;; template registry (recursion: a template may reference itself by name).
(define host/comp--tmpls (dict))
(define host/comp--def-tmpl! (fn (name node) (dict-set! host/comp--tmpls name node)))
;; ── the render-fold (the interpreter) ───────────────────────────────
(define host/comp--render-all
(fn (nodes ctx) (reduce (fn (acc n) (str acc (host/comp--render n ctx))) "" nodes)))
;; alt: render the FIRST branch whose `when` holds (or `else`) — recursive first-match so
;; a branch that legitimately renders empty isn't skipped.
(define host/comp--alt-pick
(fn (branches ctx)
;; ── the CORE fold framework (build once, reuse per domain) ──────────
;; host/comp-fold walks seq/alt/each generically, parameterised by a DOMAIN dict:
;; :empty — the zero result ("" for render, (list) for execute)
;; :combine — merge two results (str for render, concat for execute)
;; :overflow — the depth-guard result (a string / an effect)
;; :leaf — (node ctx dom) -> result for any non-core head: the domain's leaves AND its
;; own extra combinators (e.g. render's row/grid), which may recurse via the core.
;; seq, alt+when, each+source, the context-environment, recursion, and the depth guard are
;; handled HERE, once. A new domain (render, execute, eval, …) is just a new dict.
(define host/comp--fold-all
(fn (nodes ctx dom)
(reduce (fn (acc n) ((get dom :combine) acc (host/comp-fold n ctx dom))) (get dom :empty) nodes)))
(define host/comp--fold-alt
(fn (branches ctx dom)
(if (empty? branches)
""
(get dom :empty)
(let ((br (first branches)) (bh (str (first (first branches)))))
(cond
((= bh "else") (host/comp--render (first (rest br)) ctx))
((= bh "else") (host/comp-fold (first (rest br)) ctx dom))
((= bh "when") (if (host/comp--pred? (first (rest br)) ctx)
(host/comp--render (first (rest (rest br))) ctx)
(host/comp--alt-pick (rest branches) ctx)))
(else (host/comp--alt-pick (rest branches) ctx)))))))
;; each: eval source -> items; render template per item with :item bound + :depth+1
;; (depth guard backstops runaway recursion; trees terminate naturally on empty source).
(define host/comp--each
(fn (src tmpl ctx)
(host/comp-fold (first (rest (rest br))) ctx dom)
(host/comp--fold-alt (rest branches) ctx dom)))
(else (host/comp--fold-alt (rest branches) ctx dom)))))))
(define host/comp--fold-each
(fn (src body ctx dom)
(let ((depth (or (get ctx "depth") 0)))
(if (> depth 40)
"<em>(max depth)</em>"
(get dom :overflow)
(reduce
(fn (acc item)
(str acc (host/comp--render tmpl (merge ctx {"item" item "depth" (+ depth 1)}))))
"" (host/comp--source src ctx))))))
((get dom :combine) acc (host/comp-fold body (merge ctx {"item" item "depth" (+ depth 1)}) dom)))
(get dom :empty) (host/comp--source src ctx))))))
(define host/comp-fold
(fn (node ctx dom)
(if (not (= (type-of node) "list"))
((get dom :leaf) node ctx dom)
(let ((h (str (first node))))
(cond
((= h "seq") (host/comp--fold-all (rest node) ctx dom))
((= h "alt") (host/comp--fold-alt (rest node) ctx dom))
((= h "each") (host/comp--fold-each (first (rest node)) (first (rest (rest node))) ctx dom))
(else ((get dom :leaf) node ctx dom)))))))
;; ── the RENDER domain (render → HTML): leaves + layout combinators ──
;; card leaf (proof: a labelled box; in the host this renders via the card-type's :template).
(define host/comp--card
(fn (ctype fields)
@@ -85,29 +101,30 @@
(reduce (fn (acc k) (str acc "<b>" k ":</b> " (str (get fields k)) " ")) "" (keys fields))
"</div>")))
(define host/comp--render
(fn (node ctx)
;; render-leaf handles everything that isn't a core combinator: the layout combinators
;; row/grid (which recurse via the core), the leaves field/val/text/card, transclusion (ref),
;; and named-template recursion (tmpl). `field` wraps its value in a <span>; `val` is the raw
;; value (no markup) for attributes (href/src).
(define host/comp--render-leaf
(fn (node ctx dom)
(if (not (= (type-of node) "list"))
(str node)
(let ((h (str (first node))) (args (rest node)))
(cond
((= h "seq") (host/comp--render-all args ctx))
((= h "row") (str "<div class=\"row\" style=\"display:flex;gap:1em\">" (host/comp--render-all args ctx) "</div>"))
((= h "grid") (str "<div class=\"grid\" style=\"display:grid;gap:1em\">" (host/comp--render-all args ctx) "</div>"))
((= h "alt") (host/comp--alt-pick args ctx))
((= h "each") (host/comp--each (first args) (first (rest args)) ctx))
((= h "row") (str "<div class=\"row\" style=\"display:flex;gap:1em\">" (host/comp--fold-all args ctx dom) "</div>"))
((= h "grid") (str "<div class=\"grid\" style=\"display:grid;gap:1em\">" (host/comp--fold-all args ctx dom) "</div>"))
((= h "field") (str "<span>" (host/comp--field (first args) ctx) "</span>"))
((= h "val") (host/comp--field (first args) ctx)) ;; raw value, no markup — for attributes
((= h "text") (str (first args)))
((= h "card") (host/comp--card (str (first args)) (first (rest args))))
;; ref: TRANSCLUDE another object by id/CID — fetch it and render its body. Like
;; `query`, this delegates to a resolver bound in the context (the host supplies
;; graph access) so compose.sx stays self-contained. A join in the Merkle DAG is
;; free: two bodies can (ref) the same child id (content-addressed).
((= h "ref") (let ((rfn (get ctx "ref")))
(if rfn (rfn (str (first args)) ctx) "")))
((= h "tmpl") (host/comp--render (get host/comp--tmpls (str (first args))) ctx))
;; ref: TRANSCLUDE another object by id/CID via a context resolver (the host supplies
;; graph access) so compose.sx stays self-contained; a join in the Merkle DAG is free.
((= h "ref") (let ((rfn (get ctx "ref"))) (if rfn (rfn (str (first args)) ctx) "")))
((= h "tmpl") (host/comp-fold (get host/comp--tmpls (str (first args))) ctx dom))
(else ""))))))
;; public entry: render a composition node against a context environment.
(define host/comp-render (fn (node ctx) (host/comp--render node ctx)))
(define host/comp--render-dom
{:empty "" :combine str :overflow "<em>(max depth)</em>" :leaf host/comp--render-leaf})
;; public entry: render a composition node against a context environment -> HTML string.
(define host/comp-render (fn (node ctx) (host/comp-fold node ctx host/comp--render-dom)))

1
lib/host/conformance.sh
View File

@@ -109,6 +109,7 @@ SUITES=(
"feed host-fd-tests-run! lib/host/tests/feed.sx"
"relations host-rl-tests-run! lib/host/tests/relations.sx"
"blog host-bl-tests-run! lib/host/tests/blog.sx"
"compose host-cp-tests-run! lib/host/tests/compose.sx"
"execute host-ex-tests-run! lib/host/tests/execute.sx"
"session host-se-tests-run! lib/host/tests/session.sx"
"page host-pg-tests-run! lib/host/tests/page.sx"

84
lib/host/execute.sx
View File

@@ -1,18 +1,16 @@
;; lib/host/execute.sx — the EXECUTE-fold: a SECOND interpreter over the SAME composition
;; algebra (seq/alt/each) as the render-fold (lib/host/compose.sx), proving the algebra is
;; domain-agnostic (plans/composition-objects.md step 7 — "prove universality with a second
;; fold"). What changes between folds is only what the combinators + leaves MEAN:
;; lib/host/execute.sx — the EXECUTE-fold: a SECOND domain over the SAME composition core
;; as the render-fold (lib/host/compose.sx), proving the algebra is domain-agnostic
;; (plans/composition-objects.md steps 7-8). Now that the core (host/comp-fold: the seq/alt/
;; each dispatch + when-predicates + each-source + context-environment + recursion) is shared,
;; a whole new domain is just a DOMAIN DICT + a leaf function:
;;
;; domain fold seq alt+when each leaf
;; content render -> block order choose map items markup -> HTML string
;; behaviour execute -> steps in order branch for-each effect -> effect log
;; render {:empty "" :combine str …} leaf -> markup; fold -> HTML string
;; execute {:empty (list) :combine concat …} leaf -> effect; fold -> effect log
;;
;; Crucially this REUSES compose.sx's shared machinery — the `when` predicate set
;; (host/comp--pred?), the field/value resolver (host/comp--field), and the `each` source
;; (host/comp--source). So the predicate set, the context-environment, and the iteration
;; source are domain-agnostic; ONLY the leaf semantics (effect vs markup) and the fold's
;; accumulator (a list of effects vs a string) are new. The behaviour model (Slice 9) is
;; therefore "an execute-fold over a composition object", not a separate system.
;; seq = steps in order, alt+when = branch, each = for-each — all from the core, unchanged.
;; Only the leaf semantics (effect vs markup) and the accumulator (list vs string) are new.
;; So the behaviour model (Slice 9) is "an execute-fold over a composition object", not a
;; separate system — the same structure an author edits as a document.
;; resolve an effect argument against the context: (field K) reads the :item/ctx value via
;; the SAME resolver the render-fold uses; anything else is a literal.
@@ -22,55 +20,21 @@
(host/comp--field (first (rest a)) ctx)
a)))
;; a leaf effect: (effect VERB ARG…) -> one effect record {:verb :args}. The execute-fold's
;; analogue of a render leaf — it performs (records) an effect rather than emitting markup.
(define host/exec--effect
(fn (verb args ctx)
(list {:verb (str verb) :args (map (fn (a) (host/exec--arg a ctx)) args)})))
;; seq: run every step IN ORDER, concatenating their effects (the sequential strategy).
(define host/exec--run-all
(fn (nodes ctx) (reduce (fn (acc n) (concat acc (host/exec--run n ctx))) (list) nodes)))
;; alt: BRANCH — run the FIRST branch whose `when` holds (reusing the render-fold's
;; predicate host/comp--pred?), else `else`. This is if/cond for the behaviour domain.
(define host/exec--alt
(fn (branches ctx)
(if (empty? branches)
(list)
(let ((br (first branches)) (bh (str (first (first branches)))))
(cond
((= bh "else") (host/exec--run (first (rest br)) ctx))
((= bh "when") (if (host/comp--pred? (first (rest br)) ctx)
(host/exec--run (first (rest (rest br))) ctx)
(host/exec--alt (rest branches) ctx)))
(else (host/exec--alt (rest branches) ctx)))))))
;; each: FOR-EACH — run the body per item from the (reused) source, :item bound, in order;
;; depth guard backstops runaway recursion, same as the render-fold.
(define host/exec--each
(fn (src body ctx)
(let ((depth (or (get ctx "depth") 0)))
(if (> depth 40)
(list {:verb "max-depth" :args (list)})
(reduce
(fn (acc item)
(concat acc (host/exec--run body (merge ctx {"item" item "depth" (+ depth 1)}))))
(list) (host/comp--source src ctx))))))
;; the execute-fold (the interpreter): same combinator dispatch shape as host/comp--render,
;; but leaves are effects and the accumulator is an effect log.
(define host/exec--run
(fn (node ctx)
;; the execute-fold's LEAF: an (effect VERB ARG…) node records one effect {:verb :args};
;; anything else contributes no effects. (The core handles seq/alt/each.)
(define host/exec--leaf
(fn (node ctx dom)
(if (not (= (type-of node) "list"))
(list)
(let ((h (str (first node))) (args (rest node)))
(cond
((= h "seq") (host/exec--run-all args ctx))
((= h "alt") (host/exec--alt args ctx))
((= h "each") (host/exec--each (first args) (first (rest args)) ctx))
((= h "effect") (host/exec--effect (first args) (rest args) ctx))
(else (list)))))))
(if (= h "effect")
(list {:verb (str (first args)) :args (map (fn (a) (host/exec--arg a ctx)) (rest args))})
(list))))))
;; the execute DOMAIN: effects concatenate into a log; the depth guard yields a max-depth
;; effect. host/comp-fold (compose.sx) supplies the seq/alt/each walk + when + each source.
(define host/exec--dom
{:empty (list) :combine concat :overflow (list {:verb "max-depth" :args (list)}) :leaf host/exec--leaf})
;; public entry: execute a composition node against a context -> the effect log (the run).
(define host/exec-run (fn (node ctx) (host/exec--run node ctx)))
(define host/exec-run (fn (node ctx) (host/comp-fold node ctx host/exec--dom)))

80
lib/host/tests/compose.sx Normal file
View File

@@ -0,0 +1,80 @@
;; lib/host/tests/compose.sx — the composition CORE + render-fold (lib/host/compose.sx).
;; Tests host/comp-fold's shared dispatch (seq/alt/each + when + each-source + recursion +
;; depth guard) through the RENDER domain (render → HTML). The execute domain is tested in
;; tests/execute.sx; together they show one core, two folds (plans/composition-objects.md).
(define host-cp-pass 0)
(define host-cp-fail 0)
(define host-cp-fails (list))
(define host-cp-test
(fn (name actual expected)
(if (= actual expected)
(set! host-cp-pass (+ host-cp-pass 1))
(begin
(set! host-cp-fail (+ host-cp-fail 1))
(append! host-cp-fails {:name name :actual actual :expected expected})))))
;; -- leaves --
(host-cp-test "text leaf passes markup through"
(host/comp-render (quote (text "<p>hi</p>")) {}) "<p>hi</p>")
(host-cp-test "field wraps the value in a span; reads the context"
(host/comp-render (quote (field :title)) {"title" "Hello"}) "<span>Hello</span>")
(host-cp-test "val is the raw value (no markup) — for attributes"
(host/comp-render (quote (val :slug)) {"slug" "p1"}) "p1")
(host-cp-test "a missing field renders empty, not an error"
(host/comp-render (quote (field :nope)) {}) "<span></span>")
;; -- seq: render all in order --
(host-cp-test "seq renders children in order"
(host/comp-render (quote (seq (text "a") (text "b") (text "c"))) {}) "abc")
;; -- row/grid: layout combinators wrap + recurse via the core --
(host-cp-test "row wraps its children in a flex div"
(host/comp-render (quote (row (text "A") (text "B"))) {})
"<div class=\"row\" style=\"display:flex;gap:1em\">AB</div>")
;; -- alt + when: render the first branch whose predicate holds --
(host-cp-test "alt renders the when-branch when the predicate holds"
(host/comp-render (quote (alt (when (has "auth") (text "in")) (else (text "out")))) {"auth" "y"}) "in")
(host-cp-test "alt falls through to else"
(host/comp-render (quote (alt (when (has "auth") (text "in")) (else (text "out")))) {}) "out")
(host-cp-test "alt eq predicate matches a context value"
(host/comp-render (quote (alt (when (eq "t" "dark") (text "D")) (else (text "L")))) {"t" "dark"}) "D")
(host-cp-test "alt not predicate negates"
(host/comp-render (quote (alt (when (not (has "auth")) (text "anon")) (else (text "user")))) {}) "anon")
;; -- each: iterate a source, binding :item, with field resolution --
(host-cp-test "each renders the template per item (items source)"
(host/comp-render (quote (each (items {:n "x"} {:n "y"}) (seq (text "<li>") (field :n) (text "</li>")))) {})
"<li><span>x</span></li><li><span>y</span></li>")
(host-cp-test "each over an empty source renders empty"
(host/comp-render (quote (each (items) (field :n))) {}) "")
(host-cp-test "each query source delegates to the context resolver"
(host/comp-render (quote (each (query is-a t) (field :title)))
{"query" (fn (qargs ctx) (list {:title "One"} {:title "Two"}))})
"<span>One</span><span>Two</span>")
;; -- recursion via named templates + a depth guard --
(host/comp--def-tmpl! "node"
(quote (seq (field :name) (each (children) (tmpl "node")))))
(host-cp-test "tmpl recurses over a (children) tree until the source runs dry"
(host/comp-render (quote (tmpl "node"))
{"item" {:name "root" :children (list {:name "a" :children (list)} {:name "b" :children (list)})}})
"<span>root</span><span>a</span><span>b</span>")
;; -- ref: transclude via the context resolver --
(host-cp-test "ref transcludes via the context resolver"
(host/comp-render (quote (ref "c1")) {"ref" (fn (id ctx) (str "<card:" id ">"))}) "<card:c1>")
(host-cp-test "ref with no resolver renders empty"
(host/comp-render (quote (ref "c1")) {}) "")
;; -- the unifying property: ONE object renders differently per context --
(host-cp-test "the SAME object renders two ways by context (anon vs authed)"
(let ((obj (quote (alt (when (has "auth") (text "member")) (else (text "guest"))))))
(list (host/comp-render obj {}) (host/comp-render obj {"auth" "y"})))
(list "guest" "member"))
(define host-cp-tests-run!
(fn ()
{:total (+ host-cp-pass host-cp-fail)
:passed host-cp-pass :failed host-cp-fail :fails host-cp-fails}))