From af3d81d1083027ea33108ae03e84ecc665a09df0 Mon Sep 17 00:00:00 2001 From: giles Date: Wed, 1 Jul 2026 05:16:56 +0000 Subject: [PATCH] =?UTF-8?q?host:=20polish=20=E2=80=94=20a=20third=20fold?= =?UTF-8?q?=20domain=20(deps)=20+=20a=20live=20execute-fold=20demo=20(/wor?= =?UTF-8?q?kflow-demo)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Two concrete demonstrations of the composition architecture: THIRD DOMAIN (proves step 8's "a new domain is just a dict + leaf, no new control flow"). host/comp-deps folds a composition to the object ids it TRANSCLUDES — the static contains DAG of a body. It reuses host/comp-fold's seq/alt/each dispatch verbatim; only the leaf (collect `(ref ID)`) + accumulator (concat) are new. Useful in its own right (what a (seq (ref c0) (each … (ref …))) body pulls in; context-specific — alt picks the taken branch). compose suite 20/20. LIVE EXECUTE-FOLD DEMO (makes step 7 tangible, parallel to /compose-demo for render). /workflow-demo runs ONE composition object's :body through host/exec-run — the SAME structure the render-fold would turn into HTML, folded by execute into a plan of effects (validate → branch on status → notify each recipient). host/blog-seed-workflow-demo! + host/blog-workflow- demo + route + serve.sh seed. Shows the behaviour model IS an execute-fold over a composition object — the same object the block editor authors. blog suite 165/165. Co-Authored-By: Claude Opus 4.8 --- lib/host/blog.sx | 34 ++++++++++++++++++++++++++++++++++ lib/host/compose.sx | 15 +++++++++++++++ lib/host/serve.sh | 5 +++++ lib/host/tests/blog.sx | 10 ++++++++++ lib/host/tests/compose.sx | 13 +++++++++++++ 5 files changed, 77 insertions(+) diff --git a/lib/host/blog.sx b/lib/host/blog.sx index e098da12..401db6ad 100644 --- a/lib/host/blog.sx +++ b/lib/host/blog.sx @@ -733,6 +733,39 @@ (each (query is-a compose-item) (seq (text "
  • ") (field :title) (text "
    • "))) (text ""))))))) +;; A live demo of the EXECUTE-fold (the second fold): ONE composition object whose :body is +;; a WORKFLOW — the SAME structure the render-fold renders, folded by execute -> an effect +;; log. Parallels /compose-demo (render). GET /workflow-demo runs it and shows the effects. +(define host/blog-seed-workflow-demo! + (fn () + (begin + (host/blog-seed! "workflow-demo" "Workflow Demo" "(article (h1 \"Workflow\"))" "published") + (host/blog--set-body! "workflow-demo" + (quote (seq + (effect validate (field :slug)) + (alt (when (eq "status" "ready") (effect publish (field :slug))) + (else (effect hold (field :slug)))) + (each (items {:to "alice@x"} {:to "bob@x"}) (effect notify (field :to))))))))) +;; GET /workflow-demo — run the workflow object through the execute-fold and render its +;; effect log. The same object's :body, folded by RENDER, would produce HTML; folded by +;; EXECUTE it produces this plan of effects. The behaviour model IS an execute-fold. +(define host/blog-workflow-demo + (fn (req) + (let ((effects (host/exec-run (host/blog-body-of "workflow-demo") {"slug" "post-1" "status" "ready"}))) + (let ((rows (map (fn (e) (quasiquote + (li (b (unquote (get e :verb))) " " + (unquote (str (get e :args)))))) effects))) + (host/blog--resp req 200 + (host/blog--page req "Workflow Demo" + (quasiquote + (div (h1 "Workflow Demo") + (p "This is ONE composition object (its :body). The render-fold would turn it into HTML; the " + (b "execute-fold") " turns the SAME structure into a plan of effects — leaves are effects, " + (code "seq") " = steps, " (code "alt") " = branch, " (code "each") " = for-each:") + (unquote (cons (quote ol) rows)) + (p :style "margin-top:1em;color:#555" + "(validate → branch on status=ready → notify each recipient. The behaviour model is an execute-fold over a composition object — the same object the block editor authors.)") + (p (a :href "/compose-demo/" "→ the render-fold demo (same algebra, folded to HTML)")))))))))) ;; replace every (field "name") node in a parsed template tree with values[name] ("" if ;; absent). Pure: a tree-walk over the already-parsed template + pre-fetched values. (define host/blog--instantiate @@ -1871,6 +1904,7 @@ (dream-get "/new" host/blog-new-form) (dream-get "/tags" host/blog-tags-index) (dream-get "/meta" host/blog-meta-index) + (dream-get "/workflow-demo" host/blog-workflow-demo) (dream-get "/:slug/source" host/blog-source) (dream-get "/:slug/relate-options" host/blog-relate-options) (dream-get "/:slug" host/blog-post))) diff --git a/lib/host/compose.sx b/lib/host/compose.sx index b0554e26..bda30d9b 100644 --- a/lib/host/compose.sx +++ b/lib/host/compose.sx @@ -128,3 +128,18 @@ ;; 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))) + +;; ── a THIRD domain (deps → the object ids a composition transcludes) ── +;; Proof of step 8's claim "a new domain is just a dict + leaf": no new control flow — seq/ +;; alt/each come from the core unchanged; only the leaf + accumulator are new. The deps-leaf +;; collects `(ref ID)` ids; everything else contributes nothing. Useful in its own right: the +;; static transclusion set of a body (which card objects it pulls in — the contains DAG for a +;; (seq (ref c0) (each … (ref …))) body). Context-specific (alt picks the taken branch). +(define host/comp--deps-leaf + (fn (node ctx dom) + (if (and (= (type-of node) "list") (= (str (first node)) "ref")) + (list (str (first (rest node)))) + (list)))) +(define host/comp--deps-dom + {:empty (list) :combine concat :overflow (list) :leaf host/comp--deps-leaf}) +(define host/comp-deps (fn (node ctx) (host/comp-fold node ctx host/comp--deps-dom))) diff --git a/lib/host/serve.sh b/lib/host/serve.sh index b676b5cb..b3d8af1d 100755 --- a/lib/host/serve.sh +++ b/lib/host/serve.sh @@ -159,6 +159,11 @@ EPOCH=1 echo "(epoch $EPOCH)" echo "(eval \"(host/blog-seed-compose-demo!)\")" EPOCH=$((EPOCH+1)) + # Seed the EXECUTE-fold demo (composition step 7): /workflow-demo runs ONE composition + # object through host/exec-run — the same algebra as render, folded to an effect log. + echo "(epoch $EPOCH)" + echo "(eval \"(host/blog-seed-workflow-demo!)\")" + EPOCH=$((EPOCH+1)) # Load relation metadata (symmetry/labels) from the relation-posts into the # in-memory cache, so render paths read it without a (VmSuspending) durable read. echo "(epoch $EPOCH)" diff --git a/lib/host/tests/blog.sx b/lib/host/tests/blog.sx index ddbba892..9e38d0f3 100644 --- a/lib/host/tests/blog.sx +++ b/lib/host/tests/blog.sx @@ -856,6 +856,16 @@ "application/x-www-form-urlencoded" "ctype=card-text&text=added+block")) (len (host/blog-body-refs "bdoc"))) 2) +;; -- /workflow-demo: ONE composition object run through the EXECUTE-fold (step 7 live). The +;; same :body structure the render-fold renders, folded to an effect log (status=ready -> +;; validate, publish, notify each — not hold). -- +(host-bl-test "GET /workflow-demo runs the composition through the execute-fold" + (begin + (host/blog-seed-workflow-demo!) + (let ((html (dream-resp-body (host-bl-app (host-bl-req "/workflow-demo"))))) + (list (contains? html "validate") (contains? html "publish") + (contains? html "notify") (contains? html "hold")))) + (list true true true false)) (host-bl-test "a post with no schema'd type is vacuously valid" (host/blog-type-valid? "ppost" "(p \"anything\")") true) (host-bl-test "edit-submit rejects content violating the type schema (not saved)" diff --git a/lib/host/tests/compose.sx b/lib/host/tests/compose.sx index 8b8343a1..96a51738 100644 --- a/lib/host/tests/compose.sx +++ b/lib/host/tests/compose.sx @@ -74,6 +74,19 @@ (list (host/comp-render obj {}) (host/comp-render obj {"auth" "y"}))) (list "guest" "member")) +;; -- a THIRD domain over the SAME core: deps (collect transcluded refs). Proves step 8 — +;; a new domain is just a dict + leaf, reusing seq/alt/each with no new control flow. -- +(host-cp-test "deps collects the refs a seq body transcludes (the contains DAG)" + (host/comp-deps (quote (seq (ref "c0") (text "x") (ref "c1"))) {}) + (list "c0" "c1")) +(host-cp-test "deps walks each — refs inside an iterated template are collected per item" + (host/comp-deps (quote (each (items {} {}) (ref "card"))) {}) + (list "card" "card")) +(host-cp-test "deps follows alt's taken branch (context-specific transclusions)" + (list (host/comp-deps (quote (alt (when (has "auth") (ref "member")) (else (ref "guest")))) {"auth" "y"}) + (host/comp-deps (quote (alt (when (has "auth") (ref "member")) (else (ref "guest")))) {})) + (list (list "member") (list "guest"))) + (define host-cp-tests-run! (fn () {:total (+ host-cp-pass host-cp-fail)