host: polish — a third fold domain (deps) + a live execute-fold demo (/workflow-demo)
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 <noreply@anthropic.com>
This commit is contained in:
@@ -733,6 +733,39 @@
|
|||||||
(each (query is-a compose-item)
|
(each (query is-a compose-item)
|
||||||
(seq (text "<li><a href=\"/") (val :slug) (text "\">") (field :title) (text "</a></li>")))
|
(seq (text "<li><a href=\"/") (val :slug) (text "\">") (field :title) (text "</a></li>")))
|
||||||
(text "</ul>")))))))
|
(text "</ul>")))))))
|
||||||
|
;; 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
|
;; 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.
|
;; absent). Pure: a tree-walk over the already-parsed template + pre-fetched values.
|
||||||
(define host/blog--instantiate
|
(define host/blog--instantiate
|
||||||
@@ -1871,6 +1904,7 @@
|
|||||||
(dream-get "/new" host/blog-new-form)
|
(dream-get "/new" host/blog-new-form)
|
||||||
(dream-get "/tags" host/blog-tags-index)
|
(dream-get "/tags" host/blog-tags-index)
|
||||||
(dream-get "/meta" host/blog-meta-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/source" host/blog-source)
|
||||||
(dream-get "/:slug/relate-options" host/blog-relate-options)
|
(dream-get "/:slug/relate-options" host/blog-relate-options)
|
||||||
(dream-get "/:slug" host/blog-post)))
|
(dream-get "/:slug" host/blog-post)))
|
||||||
|
|||||||
@@ -128,3 +128,18 @@
|
|||||||
|
|
||||||
;; public entry: render a composition node against a context environment -> HTML string.
|
;; 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)))
|
(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)))
|
||||||
|
|||||||
@@ -159,6 +159,11 @@ EPOCH=1
|
|||||||
echo "(epoch $EPOCH)"
|
echo "(epoch $EPOCH)"
|
||||||
echo "(eval \"(host/blog-seed-compose-demo!)\")"
|
echo "(eval \"(host/blog-seed-compose-demo!)\")"
|
||||||
EPOCH=$((EPOCH+1))
|
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
|
# Load relation metadata (symmetry/labels) from the relation-posts into the
|
||||||
# in-memory cache, so render paths read it without a (VmSuspending) durable read.
|
# in-memory cache, so render paths read it without a (VmSuspending) durable read.
|
||||||
echo "(epoch $EPOCH)"
|
echo "(epoch $EPOCH)"
|
||||||
|
|||||||
@@ -856,6 +856,16 @@
|
|||||||
"application/x-www-form-urlencoded" "ctype=card-text&text=added+block"))
|
"application/x-www-form-urlencoded" "ctype=card-text&text=added+block"))
|
||||||
(len (host/blog-body-refs "bdoc")))
|
(len (host/blog-body-refs "bdoc")))
|
||||||
2)
|
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-bl-test "a post with no schema'd type is vacuously valid"
|
||||||
(host/blog-type-valid? "ppost" "(p \"anything\")") true)
|
(host/blog-type-valid? "ppost" "(p \"anything\")") true)
|
||||||
(host-bl-test "edit-submit rejects content violating the type schema (not saved)"
|
(host-bl-test "edit-submit rejects content violating the type schema (not saved)"
|
||||||
|
|||||||
@@ -74,6 +74,19 @@
|
|||||||
(list (host/comp-render obj {}) (host/comp-render obj {"auth" "y"})))
|
(list (host/comp-render obj {}) (host/comp-render obj {"auth" "y"})))
|
||||||
(list "guest" "member"))
|
(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!
|
(define host-cp-tests-run!
|
||||||
(fn ()
|
(fn ()
|
||||||
{:total (+ host-cp-pass host-cp-fail)
|
{:total (+ host-cp-pass host-cp-fail)
|
||||||
|
|||||||
Reference in New Issue
Block a user